diff options
Diffstat (limited to 'src/iconc/ccode.c')
| -rw-r--r-- | src/iconc/ccode.c | 4954 |
1 files changed, 0 insertions, 4954 deletions
diff --git a/src/iconc/ccode.c b/src/iconc/ccode.c deleted file mode 100644 index 108cd15..0000000 --- a/src/iconc/ccode.c +++ /dev/null @@ -1,4954 +0,0 @@ -/* - * ccode.c - routines to produce internal representation of C code. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "ctoken.h" -#include "cproto.h" - -#ifdef OptimizeLit - -#define NO_LIMIT 0 -#define LIMITED 1 -#define LIMITED_TO_INT 2 -#define NO_TOUCH 3 - -struct lit_tbl { - int modified; - int index; - int safe; - struct code *initial; - struct code *end; - struct val_loc *vloc; - struct centry *csym; - struct lit_tbl *prev; - struct lit_tbl *next; -}; -#endif /* OptimizeLit */ - -/* - * Prototypes for static functions. - */ -static struct c_fnc *alc_fnc (void); -static struct tmplftm *alc_lftm (int num, union field *args); -static int alc_tmp (int n, struct tmplftm *lifetm_ary); - -#ifdef OptimizePoll - static int analyze_poll (void); - static void remove_poll (void); -#endif /* OptimizePoll */ - -#ifdef OptimizeLit - static int instr (const char *str, int chr); - static void invalidate (struct val_loc *val,struct code *end,int code); - static void analyze_literals (struct code *start, struct code *top, int lvl); - static int eval_code (struct code *cd, struct lit_tbl *cur); - static void propagate_literals (void); - static void free_tbl (void); - static struct lit_tbl *alc_tbl (void); - static void tbl_add (truct lit_tbl *add); -#endif /* OptimizeLit */ - -static struct code *asgn_null (struct val_loc *loc1); -static struct val_loc *bound (struct node *n, struct val_loc *rslt, - int catch_fail); -static struct code *check_var (struct val_loc *d, struct code *lbl); -static void deref_cd (struct val_loc *src, struct val_loc *dest); -static void deref_ret (struct val_loc *src, struct val_loc *dest, - int subtypes); -static void endlife (int kind, int indx, int old, nodeptr n); -static struct val_loc *field_ref(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_act (nodeptr n, struct val_loc *rslt); -static struct val_loc *gen_apply(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_args (struct node *n, int frst_arg, int nargs); -static struct val_loc *gen_case (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_creat(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_lim (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_scan (struct node *n, struct val_loc *rslt); -static struct val_loc *gencode (struct node *n, struct val_loc *rslt); -static struct val_loc *genretval(struct node *n, struct node *expr, - struct val_loc *dest); -static struct val_loc *inv_prc (nodeptr n, struct val_loc *rslt); -static struct val_loc *inv_op (nodeptr n, struct val_loc *rslt); -static nodeptr max_lftm (nodeptr n1, nodeptr n2); -static void mk_callop (char *oper_nm, int ret_flag, - struct val_loc *arg1rslt, int nargs, - struct val_loc *rslt, int optim); -static struct code *mk_cpyval (struct val_loc *loc1, struct val_loc *loc2); -static struct code *new_call (void); -static char *oper_name (struct implement *impl); -static void restr_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void save_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void setloc (nodeptr n); -static struct val_loc *tmp_loc (int n); -static struct val_loc *var_ref (struct lentry *sym); -static struct val_loc *vararg_sz(int n); - -#define FrstArg 2 - -/* - * Information that must be passed between a loop and its next and break - * expressions. - */ -struct loop_info { - struct code *next_lbl; /* where to branch for a next expression */ - struct code *end_loop; /* label at end of loop */ - struct code *on_failure; /* where to go if the loop fails */ - struct scan_info *scan_info; /* scanning environment upon entering loop */ - struct val_loc *rslt; /* place to put result of loop */ - struct c_fnc *succ_cont; /* the success continuation for the loop */ - struct loop_info *prev; /* link to info for outer loop */ - }; - -/* - * The allocation status of a temporary variable can either be "in use", - * "not allocated", or reserved for use at a code position (indicated - * by a specific negative number). - */ -#define InUse 1 -#define NotAlc 0 - -/* - * tmplftm is used to precompute lifetime information for use in allocating - * temporary variables. - */ -struct tmplftm { - int cur_status; - nodeptr lifetime; - }; - -/* - * Places where &subject and &pos are saved during string scanning. "outer" - * values are saved when the scanning expression is executed. "inner" - * values are saved when the scanning expression suspends. - */ -struct scan_info { - struct val_loc *outer_sub; - struct val_loc *outer_pos; - struct val_loc *inner_sub; - struct val_loc *inner_pos; - struct scan_info *next; - }; - -struct scan_info scan_base = {NULL, 0, NULL, 0, NULL}; -struct scan_info *nxt_scan = &scan_base; - -struct val_loc ignore; /* no values, just something to point at */ -static struct val_loc proc_rslt; /* result location for procedure */ - -int *tmp_status = NULL; /* allocation status of temp descriptor vars */ -int *itmp_status = NULL; /* allocation status of temp C int vars*/ -int *dtmp_status = NULL; /* allocation status of temp C double vars */ -int *sbuf_status = NULL; /* allocation of string buffers */ -int *cbuf_status = NULL; /* allocation of cset buffers */ -int num_tmp; /* number of temp descriptors actually used */ -int num_itmp; /* number of temp C ints actually used */ -int num_dtmp; /* number of temp C doubles actually used */ -int num_sbuf; /* number of string buffers actually used */ -int num_cbuf; /* number of cset buffers actually used */ -int status_sz = 20; /* current size of tmp_status array */ -int istatus_sz = 20; /* current size of itmp_status array */ -int dstatus_sz = 20; /* current size of dtmp_status array */ -int sstatus_sz = 20; /* current size of sbuf_status array */ -int cstatus_sz = 20; /* current size of cbuf_status array */ -struct freetmp *freetmp_pool = NULL; - -static char frm_prfx[PrfxSz + 1];/* prefix for procedure frame */ -static char *lastfiln; /* last file name set in code */ -static int lastline; /* last line number set in code */ - -#ifdef OptimizePoll -static struct code *lastpoll; -#endif /* OptimizePoll */ - -#ifdef OptimizeLit -static struct lit_tbl *tbl = NULL; -static struct lit_tbl *free_lit_tbl = NULL; -#endif /* OptimizeLit */ - -static struct c_fnc *fnc_lst; /* list of C functions implementing proc */ -static struct c_fnc **flst_end; /* pointer to null pointer at end of fnc_lst */ -struct c_fnc *cur_fnc; /* C function currently being built */ -static int create_lvl = 0; /* co-expression create level */ - -struct pentry *cur_proc; /* procedure currently being translated */ - -struct code *on_failure; /* place to go on failure */ - -static struct code *p_ret_lbl; /* label for procedure return */ -static struct code *p_fail_lbl; /* label for procedure fail */ -struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -struct code resume; -struct code contin; -struct code fallthru; -struct code next_fail; - -int lbl_seq_num = 0; /* next label sequence number */ - -#ifdef OptimizeLit -static void print_tbl(struct lit_tbl *start) { - struct lit_tbl *ptr; - - for (ptr=start; ptr != NULL ;ptr=ptr->next) { - printf("mod (%2d) strchr (%2d) ",ptr->modified,ptr->index); - if (ptr->csym != NULL) { - printf("image (%13s) ",ptr->csym->image); - } - if (ptr->vloc != NULL) { - printf("val (%6d) type (%d)",ptr->vloc->u.tmp,ptr->vloc->loc_type); - } - if (ptr->end == NULL) - printf(" END IS NULL"); - printf("\n"); - } -} - - -static void free_tbl() { -/* - struct lit_tbl *ptr, *next; -*/ - free_lit_tbl = tbl; - tbl = NULL; -/* - ptr = tbl; - while (ptr != NULL) { - next = ptr->next; - free(ptr); - ptr = next; - } - tbl = NULL; -*/ -} - - -static struct lit_tbl *alc_tbl() { - struct lit_tbl *new; - static int cnt=0; - - - if (free_lit_tbl != NULL) { - new = free_lit_tbl; - free_lit_tbl = new->next; - } - else - new = (struct lit_tbl *)alloc(sizeof(struct lit_tbl)); - new->modified = NO_LIMIT; - new->index = -1; - new->safe = 1; - new->initial = NULL; - new->end = NULL; - new->vloc = NULL; - new->csym = NULL; - new->prev = NULL; - new->next = NULL; - return new; -} -#endif /* OptimizeLit */ - -/* - * proccode - generate code for a procedure. - */ -void proccode(proc) -struct pentry *proc; - { - struct c_fnc *fnc; - struct code *cd; - struct code *cd1; - struct code *lbl; - nodeptr n; - nodeptr failer; - int gen; - int i; -#ifdef OptimizeLit - struct code *procstart; -#endif /* OptimizeLit */ - - /* - * Initialize arrays used for allocating temporary variables. - */ - if (tmp_status == NULL) - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - if (itmp_status == NULL) - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - if (dtmp_status == NULL) - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - if (sbuf_status == NULL) - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - if (cbuf_status == NULL) - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Initialize standard signals. - */ - resume.cd_id = C_Resume; - contin.cd_id = C_Continue; - fallthru.cd_id = C_FallThru; - - /* - * Initialize procedure result and the transcan locations. - */ - proc_rslt.loc_type = V_PRslt; - proc_rslt.mod_access = M_None; - ignore.loc_type = V_Ignore; - ignore.mod_access = M_None; - - cur_proc = proc; /* current procedure */ - lastfiln = NULL; /* file name */ - lastline = 0; /* line number */ - -#ifdef OptimizePoll - lastpoll = NULL; -#endif /* OptimizePoll */ - - /* - * Procedure frame prefix is the procedure prefix. - */ - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = cur_proc->prefix[i]; - frm_prfx[PrfxSz] = '\0'; - - /* - * Initialize the continuation list and allocate the outer function for - * this procedure. - */ - fnc_lst = NULL; - flst_end = &fnc_lst; - cur_fnc = alc_fnc(); - -#ifdef OptimizeLit - procstart = cur_fnc->cursor; -#endif /* OptimizeLit */ - - /* - * If the procedure is not used anywhere don't generate code for it. - * This can happen when using libraries containing several procedures, - * but not all are needed. However, if there is a block for the - * procedure, we need at least a dummy function. - */ - if (!cur_proc->reachable) { - if (!(glookup(cur_proc->name)->flag & F_SmplInv)) - outerfnc(fnc_lst); - return; - } - - /* - * Allocate labels for the code for procedure failure, procedure return, - * and allocate the bounding signal for this procedure (at this point - * signals and labels are not distinguished). - */ - p_fail_lbl = alc_lbl("proc fail", 0); - p_ret_lbl = alc_lbl("proc return", 0); - bound_sig = alc_lbl("bound", 0); - - n = proc->tree; - setloc(n); - if (Type(Tree1(n)) != N_Empty) { - /* - * initial clause. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - lbl = alc_lbl("end initial", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!first_time"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "first_time = 0;"; - cd_add(cd); - bound(Tree1(n), &ignore, 1); - cur_fnc->cursor = lbl; - } - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - bound(Tree2(n), &ignore, 1); - - /* - * Place code to perform procedure failure and return and the - * end of the outer function. - */ - setloc(Tree3(n)); - cd_add(p_fail_lbl); - cd = NewCode(0); - cd->cd_id = C_PFail; - cd_add(cd); - cd_add(p_ret_lbl); - cd = NewCode(0); - cd->cd_id = C_PRet; - cd_add(cd); - - /* - * Fix up signal handling code and perform peephole optimizations. - */ - fix_fncs(fnc_lst); - -#ifdef OptimizeLit - analyze_literals(procstart, NULL, 0); - propagate_literals(); -#endif /* OptimizeLit */ - - /* - * The outer function is the first one on the list. It has the - * procedure interface; the others are just continuations. - */ - outerfnc(fnc_lst); - for (fnc = fnc_lst->next; fnc != NULL; fnc = fnc->next) - if (fnc->ref_cnt > 0) - prt_fnc(fnc); -#ifdef OptimizeLit - free_tbl(); -#endif /* OptimizeLit */ -} - -/* - * gencode - generate code for a syntax tree. - */ -static struct val_loc *gencode(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *lbl1; - struct code *lbl2; - struct code *cursor_sav; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct implement *impl; - struct implement *impl1; - struct val_loc *r1[3]; - struct val_loc *r2[2]; - struct val_loc *frst_arg; - struct lentry *single; - struct freetmp *freetmp; - struct freetmp *ft; - struct tmplftm *lifetm_ary; - char *sbuf; - int i; - int tmp_indx; - int nargs; - static struct loop_info *loop_info = NULL; - struct loop_info *li_sav; - - switch (n->n_type) { - case N_Activat: - rslt = gen_act(n, rslt); - break; - - case N_Alt: - rslt = chk_alc(rslt, n->lifetime); /* insure a result location */ - - fail_sav = on_failure; - fnc_sav = cur_fnc; - - /* - * If the first alternative fails, execution must go to the - * "alt" label. - */ - lbl1 = alc_lbl("alt", 0); - on_failure = lbl1; - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* 1st alternative goes before label */ - gencode(Tree0(n), rslt); - - /* - * Each alternative must call the same success continuation. - */ - fnc = alc_fnc(); - callc_add(fnc); - - cur_fnc = fnc_sav; /* return to the context of the label */ - cur_fnc->cursor = lbl1; /* 2nd alternative goes after label */ - on_failure = fail_sav; /* on failure, alternation fails */ - gencode(Tree1(n), rslt); - callc_add(fnc); /* call continuation */ - - /* - * Code following the alternation goes in the continuation. If - * the code fails, the continuation returns the resume signal. - */ - cur_fnc = fnc; - on_failure = &resume; - break; - - case N_Apply: - rslt = gen_apply(n, rslt); - break; - - case N_Augop: - impl = Impl0(n); /* assignment */ - impl1 = Impl1(n); /* the operation */ - if (impl == NULL || impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - /* - * allocate an argument list for the operation. - */ - lifetm_ary = alc_lftm(2, &n->n_field[2]); - tmp_indx = alc_tmp(2, lifetm_ary); - r1[0] = tmp_loc(tmp_indx); - r1[1] = tmp_loc(tmp_indx + 1); - - gencode(Tree2(n), r1[0]); /* first argument */ - - /* - * allocate an argument list for the assignment and copy the - * value of the first argument into it. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[1].cur_status = n->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(2, lifetm_ary); - r2[0] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[0])); - r2[1] = tmp_loc(tmp_indx); - - gencode(Tree3(n), r1[1]); /* second argument */ - - /* - * Produce code for the operation. - */ - setloc(n); - implproto(impl1); - mk_callop(oper_name(impl1), impl1->ret_flag, r1[0], 2, r2[1], 0); - - /* - * Produce code for the assignment. - */ - implproto(impl); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, rslt, 0); - - free((char *)lifetm_ary); - break; - - case N_Bar: { - struct val_loc *fail_flg; - - /* - * Allocate an integer variable to keep track of whether the - * repeated alternation should fail when execution reaches - * the top of its loop, and generate code to initialize the - * variable to 0. - */ - fail_flg = itmp_loc(alc_itmp(n->intrnl_lftm)); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - - /* - * Code at the top of the repeated alternation loop checks - * the failure flag. - */ - lbl1 = alc_lbl("rep alt", 0); - cd_add(lbl1); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = fail_flg; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * If the expression fails without producing a value, the - * repeated alternation must fail. - */ - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 1;"; - cd_add(cd); - - /* - * Generate code for the repeated expression. If it produces - * a value before before backtracking occurs, the loop is - * repeated as indicated by the value of the failure flag. - */ - on_failure = lbl1; - rslt = gencode(Tree0(n), rslt); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - } - break; - - case N_Break: - if (loop_info == NULL) { - nfatal(n, "invalid context for a break expression", NULL); - rslt = &ignore; - break; - } - - /* - * If the break is in a different string scanning context from the - * loop itself, generate code to restore the scanning environment. - */ - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - - - if (Tree0(n)->n_type == N_Empty && loop_info->rslt == &ignore) { - /* - * The break has no associated expression and the loop needs - * no value, so just branch out of the loop. - */ - cd_add(sig_cd(loop_info->end_loop, cur_fnc)); - } - else { - /* - * The code for the expression associated with the break is - * actually placed at the end of the loop. Go there and - * add a label to branch to. - */ - cursor_sav = cur_fnc->cursor; - fnc_sav = cur_fnc; - fail_sav = on_failure; - cur_fnc = loop_info->end_loop->Container; - cur_fnc->cursor = loop_info->end_loop->prev; - on_failure = loop_info->on_failure; - lbl1 = alc_lbl("break", 0); - cd_add(lbl1); - - /* - * Make sure a result location has been allocated for the - * loop, restore the loop information for the next outer - * loop, generate code for the break expression, then - * restore the loop information for this loop. - */ - loop_info->rslt = chk_alc(loop_info->rslt, Tree0(n)->lifetime); - li_sav = loop_info; - loop_info = loop_info->prev; - gencode(Tree0(n), li_sav->rslt); - loop_info = li_sav; - - /* - * If this or another break expression suspends so we cannot - * just branch to the end of the loop, all breaks must - * call a common continuation. - */ - if (cur_fnc->cursor->next != loop_info->end_loop && - loop_info->succ_cont == NULL) - loop_info->succ_cont = alc_fnc(); - if (loop_info->succ_cont == NULL) - cd_add(mk_goto(loop_info->end_loop)); /* go to end of loop */ - else - callc_add(loop_info->succ_cont); /* call continuation */ - - /* - * Return to the location of the break and generate a branch to - * the code for its associated expression. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cursor_sav; - on_failure = fail_sav; - cd_add(sig_cd(lbl1, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Case: - rslt = gen_case(n, rslt); - break; - - case N_Create: - rslt = gen_creat(n, rslt); - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - cd = NewCode(2); - cd->cd_id = C_Lit; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->Literal = CSym0(n); - cd_add(cd); - break; - - case N_Empty: - /* - * Assume null value is needed. - */ - if (rslt == &ignore) - break; - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - break; - - case N_Field: - rslt = field_ref(n, rslt); - break; - - case N_Id: - /* - * If the variable reference is not going to be used, don't bother - * building it. - */ - if (rslt == &ignore) - break; - cd = NewCode(2); - cd->cd_id = C_NamedVar; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->NamedVar = LSym0(n); - cd_add(cd); - break; - - case N_If: - if (Type(Tree2(n)) == N_Empty) { - /* - * if-then. Control clause is bounded, but otherwise trivial. - */ - bound(Tree0(n), &ignore, 0); /* control clause */ - rslt = gencode(Tree1(n), rslt); /* then clause */ - } - else { - /* - * if-then-else. Establish an "else" label as the failure - * label of the bounded control clause. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - lbl1 = alc_lbl("else", 0); - on_failure = lbl1; - - bound(Tree0(n), &ignore, 0); /* control clause */ - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* then clause goes before else lbl */ - on_failure = fail_sav; - rslt = chk_alc(rslt, n->lifetime); - gencode(Tree1(n), rslt); /* then clause */ - - /* - * If the then clause is not a generator, execution can - * just go to the end of the if-then-else expression. If it - * is a generator, the continuation for the expression must be - * in a separate function. - */ - if (cur_fnc->cursor->next == lbl1) { - fnc = NULL; - lbl2 = alc_lbl("end if", 0); - cd_add(mk_goto(lbl2)); - cur_fnc->cursor = lbl1; - cd_add(lbl2); - } - else { - lbl2 = NULL; - fnc = alc_fnc(); - callc_add(fnc); - cur_fnc = fnc_sav; - } - - cur_fnc->cursor = lbl1; /* else clause goes after label */ - on_failure = fail_sav; - gencode(Tree2(n), rslt); /* else clause */ - - /* - * If the else clause is not a generator, execution is at - * the end of the if-then-else expression, but the if clause - * may have forced the continuation to be in a separate function. - * If the else clause is a generator, it forces the continuation - * to be in a separate function. - */ - if (fnc == NULL) { - if (cur_fnc->cursor->next == lbl2) - cur_fnc->cursor = lbl2; - else { - fnc = alc_fnc(); - callc_add(fnc); - /* - * The then clause is not a generator, so it has branched - * to lbl2. We must add a call to the continuation there. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl2; - on_failure = fail_sav; - callc_add(fnc); - } - } - else - callc_add(fnc); - - if (fnc != NULL) { - /* - * We produced a continuation for the if-then-else, so code - * generation must proceed in it. - */ - cur_fnc = fnc; - on_failure = &resume; - } - } - break; - - case N_Invok: - /* - * General invocation. - */ - nargs = Val0(n); - if (Tree1(n)->n_type == N_Empty) { - /* - * Mutual evaluation. - */ - for (i = 2; i <= nargs; ++i) - gencode(n->n_field[i].n_ptr, &ignore); /* arg i - 1 */ - rslt = chk_alc(rslt, n->lifetime); - gencode(n->n_field[nargs + 1].n_ptr, rslt); /* last argument */ - } - else { - ++nargs; /* consider the procedure an argument to invoke() */ - frst_arg = gen_args(n, 1, nargs); - setloc(n); - /* - * Assume this operation uses its result location as a work - * area. Give it a location that is tended, where the value - * is retained as long as the operation can be resumed. - */ - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - rslt = chk_alc(rslt, max_lftm(n->lifetime, n->intrnl_lftm)); - mk_callop( "invoke", DoesRet | DoesFail | DoesSusp, frst_arg, nargs, - rslt, 0); - } - break; - - case N_InvOp: - rslt = inv_op(n, rslt); - break; - - case N_InvProc: - rslt = inv_prc(n, rslt); - break; - - case N_InvRec: { - /* - * Directly invoke a record constructor. - */ - struct rentry *rec; - - nargs = Val0(n); /* number of arguments */ - frst_arg = gen_args(n, 2, nargs); - setloc(n); - rec = Rec1(n); - - rslt = chk_alc(rslt, n->lifetime); - - /* - * If error conversion can occur then the record constructor may - * fail and we must check the signal. - */ - if (err_conv) { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + - strlen("signal = R_") + PrfxSz + 1)); - sprintf(sbuf, "signal = R%s_%s(", rec->prefix, rec->name); - } - else { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + PrfxSz +4)); - sprintf(sbuf, "R%s_%s(", rec->prefix, rec->name); - } - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; /* constructor name */ - cd->Str(0) = sbuf; - cd->ElemTyp(1) = A_Intgr; /* number of arguments */ - cd->Intgr(1) = nargs; - cd->ElemTyp(2) = A_Str; /* , */ - cd->Str(2) = ", "; - if (frst_arg == NULL) { /* location of first argument */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "NULL"; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ""; - } - else { - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "&"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = frst_arg; - } - cd->ElemTyp(5) = A_Str; /* , */ - cd->Str(5) = ", "; - cd->ElemTyp(6) = A_Str; /* location of result */ - cd->Str(6) = "&"; - cd->ElemTyp(7) = A_ValLoc; - cd->ValLoc(7) = rslt; - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - if (err_conv) { - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "signal == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - } - break; - - case N_Limit: - rslt = gen_lim(n, rslt); - break; - - case N_Loop: { - struct loop_info li; - - /* - * Set up loop information for use by break and next expressions. - */ - li.end_loop = alc_lbl("end loop", 0); - cd_add(li.end_loop); - cur_fnc->cursor = li.end_loop->prev; /* loop goes before label */ - li.rslt = rslt; - li.on_failure = on_failure; - li.scan_info = nxt_scan; - li.succ_cont = NULL; - li.prev = loop_info; - loop_info = &li; - - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * "next" in the control clause just fails. - */ - li.next_lbl = &next_fail; - gencode(Tree1(n), &ignore); /* control clause */ - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); /* resume control clause */ - break; - - case REPEAT: - li.next_lbl = alc_lbl("repeat", 0); - cd_add(li.next_lbl); - bound(Tree1(n), &ignore, 1); - cd_add(mk_goto(li.next_lbl)); - break; - - case SUSPEND: /* suspension expression */ - if (create_lvl > 0) { - nfatal(n, "invalid context for suspend", NULL); - return &ignore; - } - /* - * "next" in the control clause just fails. The result - * of the control clause goes in the procedure return - * location. - */ - li.next_lbl = &next_fail; - genretval(n, Tree1(n), &proc_rslt); - - /* - * If necessary, swap scanning environments before suspending. - * if there is no success continuation, just return. - */ - if (nxt_scan != &scan_base) { - save_env(scan_base.inner_sub, scan_base.inner_pos); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - } - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ProcCont; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == NULL"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(p_ret_lbl, cur_fnc); - cd_add(cd); - cd = NewCode(0); - cd->cd_id = C_PSusp; - cd_add(cd); - cur_fnc->flag |= CF_ForeignSig; - - /* - * Force updating file name and line number, and if needed, - * switch scanning environments before resuming. - */ - lastfiln = NULL; - lastline = 0; - if (nxt_scan != &scan_base) { - save_env(scan_base.outer_sub, scan_base.outer_pos); - restr_env(scan_base.inner_sub, scan_base.inner_pos); - } - - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case WHILE: - li.next_lbl = alc_lbl("while", 0); - cd_add(li.next_lbl); - /* - * The control clause and do clause are both bounded expressions, - * but only the do clause establishes a new failure label. - */ - bound(Tree1(n), &ignore, 0); /* control clause */ - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - break; - - case UNTIL: - fail_sav = on_failure; - li.next_lbl = alc_lbl("until", 0); - cd_add(li.next_lbl); - - /* - * If the control clause fails, execution continues in - * the loop. - */ - if (Type(Tree2(n)) == N_Empty) - on_failure = li.next_lbl; - else { - lbl2 = alc_lbl("do", 0); - on_failure = lbl2; - cd_add(lbl2); - cur_fnc->cursor = lbl2->prev; /* control before label */ - } - bound(Tree1(n), &ignore, 0); /* control clause */ - - /* - * If the control clause succeeds, the loop fails. - */ - cd_add(sig_cd(fail_sav, cur_fnc)); - - if (Type(Tree2(n)) != N_Empty) { - /* - * Do clause goes after the label and the loop repeats. - */ - cur_fnc->cursor = lbl2; - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - } - break; - } - - /* - * Go to the end of the loop and see if the loop's success continuation - * is in a separate function. - */ - cur_fnc = li.end_loop->Container; - cur_fnc->cursor = li.end_loop; - if (li.succ_cont != NULL) { - callc_add(li.succ_cont); - cur_fnc = li.succ_cont; - on_failure = &resume; - } - if (li.rslt == NULL) - rslt = &ignore; /* shouldn't be used but must be something valid */ - else - rslt = li.rslt; - loop_info = li.prev; - break; - } - - case N_Next: - /* - * In some contexts "next" just fails. In other contexts it - * transfers control to a label, in which case it may have - * to restore a scanning environment. - */ - if (loop_info == NULL) - nfatal(n, "invalid context for a next expression", NULL); - else if (loop_info->next_lbl == &next_fail) - cd_add(sig_cd(on_failure, cur_fnc)); - else { - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - cd_add(sig_cd(loop_info->next_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Not: - lbl1 = alc_lbl("not", 0); - fail_sav = on_failure; - on_failure = lbl1; - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - bound(Tree0(n), &ignore, 0); - on_failure = fail_sav; - cd_add(sig_cd(on_failure, cur_fnc)); /* convert success to failure */ - cur_fnc->cursor = lbl1; /* convert failure to null */ - if (rslt != &ignore) { - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - } - break; - - case N_Ret: - if (create_lvl > 0) { - nfatal(n, "invalid context for return or fail", NULL); - return &ignore; - } - if (Val0(Tree0(n)) == RETURN) { - /* - * Set up the failure action of the return expression to do a - * procedure fail. - */ - if (nxt_scan != &scan_base) { - /* - * we must switch scanning environments if the expression fails. - */ - lbl1 = alc_lbl("return fail", 0); - cd_add(lbl1); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - on_failure = lbl1; - } - else - on_failure = p_fail_lbl; - - /* - * Produce code to place return value in procedure result location. - */ - genretval(n, Tree1(n), &proc_rslt); - - /* - * See if a scanning environment must be restored and - * transfer control to the procedure return code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_ret_lbl, cur_fnc)); - } - else { - /* - * fail. See if a scanning environment must be restored and - * transfer control to the procedure failure code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Scan: - rslt = gen_scan(n, rslt); - break; - - case N_Sect: - /* - * x[i+:j] or x[i-:j] (x[i:j] handled as ordinary operator) - */ - impl1 = Impl0(n); /* sectioning */ - if (impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - implproto(impl1); - - impl = Impl1(n); /* plus or minus */ - /* - * Allocate work area of temporary variables for sectioning. - */ - lifetm_ary = alc_lftm(3, NULL); - lifetm_ary[0].cur_status = Tree2(n)->postn; - lifetm_ary[0].lifetime = n->intrnl_lftm; - lifetm_ary[1].cur_status = Tree3(n)->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - lifetm_ary[2].cur_status = n->postn; - lifetm_ary[2].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(3, lifetm_ary); - for (i = 0; i < 3; ++i) - r1[i] = tmp_loc(tmp_indx++); - gencode(Tree2(n), r1[0]); /* generate code to compute x */ - gencode(Tree3(n), r1[1]); /* generate code compute i */ - - /* - * Allocate work area of temporary variables for arithmetic. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[0].lifetime = Tree3(n)->lifetime; - lifetm_ary[1].cur_status = Tree4(n)->postn; - lifetm_ary[1].lifetime = Tree4(n)->lifetime; - tmp_indx = alc_tmp(2, lifetm_ary); - for (i = 0; i < 2; ++i) - r2[i] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[1])); /* generate code to copy i */ - gencode(Tree4(n), r2[1]); /* generate code to compute j */ - - /* - * generate code for i op j. - */ - setloc(n); - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, r1[2], 0); - - /* - * generate code for x[i : (i op j)] - */ - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl1),impl1->ret_flag,r1[0],3,rslt,0); - free((char *)lifetm_ary); - break; - - case N_Slist: - bound(Tree0(n), &ignore, 1); - rslt = gencode(Tree1(n), rslt); - break; - - case N_SmplAsgn: { - struct val_loc *var, *val; - - /* - * Optimized assignment to a named variable. Use information - * from type inferencing to determine if the right-hand-side - * is a variable. - */ - var = var_ref(LSym0(Tree2(n))); - if (HasVar(varsubtyp(Tree3(n)->type, &single))) - Val0(n) = AsgnDeref; - if (single != NULL) { - /* - * Right-hand-side results in a named variable. Compute - * the expression but don't bother saving the result, we - * know what it is. Assignment just copies value from - * one variable to the other. - */ - gencode(Tree3(n), &ignore); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - gencode(Tree3(n), var); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = gencode(Tree3(n), NULL); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = gencode(Tree3(n), NULL); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - case N_SmplAug: { - /* - * Optimized augmented assignment to a named variable. - */ - struct val_loc *var, *val; - - impl = Impl1(n); /* the operation */ - if (impl == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - implproto(impl); /* insure prototype for operation */ - - /* - * Generate code to compute the arguments for the operation. - */ - frst_arg = gen_args(n, 2, 2); - setloc(n); - - /* - * Use information from type inferencing to determine if the - * operation produces a variable. - */ - if (HasVar(varsubtyp(Typ4(n), &single))) - Val0(n) = AsgnDeref; - var = var_ref(LSym0(Tree2(n))); - if (single != NULL) { - /* - * The operation results in a named variable. Call the operation - * but don't bother saving the result, we know what it is. - * Assignment just copies value from one variable to the other. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - &ignore, 0); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - var, 0); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - - /* - * Free any temporaries whose lifetime ends at this node. - */ - freetmp = n->freetmp; - while (freetmp != NULL) { - switch (freetmp->kind) { - case DescTmp: - tmp_status[freetmp->indx] = freetmp->old; - break; - case CIntTmp: - itmp_status[freetmp->indx] = freetmp->old; - break; - case CDblTmp: - dtmp_status[freetmp->indx] = freetmp->old; - break; - case SBuf: - sbuf_status[freetmp->indx] = freetmp->old; - break; - case CBuf: - cbuf_status[freetmp->indx] = freetmp->old; - break; - } - ft = freetmp->next; - freetmp->next = freetmp_pool; - freetmp_pool = freetmp; - freetmp = ft; - } - return rslt; - } - -/* - * chk_alc - make sure a result location has been allocated. If it is - * a temporary variable, indicate that it is now in use. - */ -struct val_loc *chk_alc(rslt, lifetime) -struct val_loc *rslt; -nodeptr lifetime; - { - struct tmplftm tmplftm; - - if (rslt == NULL) { - if (lifetime == NULL) - rslt = &ignore; - else { - tmplftm.cur_status = InUse; - tmplftm.lifetime = lifetime; - rslt = tmp_loc(alc_tmp(1, &tmplftm)); - } - } - else if (rslt->loc_type == V_Temp) - tmp_status[rslt->u.tmp] = InUse; - return rslt; - } - -/* - * mk_goto - make a code structure for goto label - */ -struct code *mk_goto(label) -struct code *label; - { - register struct code *cd; - - cd = NewCode(1); /* # fields == # fields of C_RetSig & C_Break */ - cd->cd_id = C_Goto; - cd->next = NULL; - cd->prev = NULL; - cd->Lbl = label; - ++label->RefCnt; - return cd; - } - -/* - * mk_cpyval - make code to copy a value from one location to another. - */ -static struct code *mk_cpyval(loc1, loc2) -struct val_loc *loc1; -struct val_loc *loc2; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = loc2; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - return cd; - } - -/* - * asgn_null - make code to assign the null value to a location. - */ -static struct code *asgn_null(loc1) -struct val_loc *loc1; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nulldesc;"; - return cd; - } - -/* - * oper_name - create the name for the most general implementation of an Icon - * operation. - */ -static char *oper_name(impl) -struct implement *impl; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "%c%c%c_%s", impl->oper_typ, impl->prefix[0], impl->prefix[1], - impl->name); - return sbuf; - } - -/* - * gen_args - generate code to evaluate an argument list. - */ -static struct val_loc *gen_args(n, frst_arg, nargs) -struct node *n; -int frst_arg; -int nargs; - { - struct tmplftm *lifetm_ary; - int i; - int tmp_indx; - - if (nargs == 0) - return NULL; - - lifetm_ary = alc_lftm(nargs, &n->n_field[frst_arg]); - tmp_indx = alc_tmp(nargs, lifetm_ary); - for (i = 0; i < nargs; ++i) - gencode(n->n_field[frst_arg + i].n_ptr, tmp_loc(tmp_indx + i)); - free((char *)lifetm_ary); - return tmp_loc(tmp_indx); - } - -/* - * gen_case - generate code for a case expression. - */ -static struct val_loc *gen_case(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *control; - struct node *cases; - struct node *deflt; - struct node *clause; - struct val_loc *r1; - struct val_loc *r2; - struct val_loc *r3; - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *skp_lbl; - struct code *cd_lbl; - struct code *end_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont = NULL; - - control = Tree0(n); - cases = Tree1(n); - deflt = Tree2(n); - - /* - * The control clause is bounded. - */ - r1 = chk_alc(NULL, n); - bound(control, r1, 0); - - /* - * Remember the context in which the case expression occurs and - * establish a label at the end of the expression. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - end_lbl = alc_lbl("end case", 0); - cd_add(end_lbl); - cur_fnc->cursor = end_lbl->prev; /* generate code before the end label */ - - /* - * All cases share the result location of the case expression. - */ - rslt = chk_alc(rslt, n->lifetime); - r2 = chk_alc(NULL, n); /* for result of selection clause */ - r3 = chk_alc(NULL, n); /* for dereferenced result of control clause */ - - while (cases != NULL) { - /* - * See if we are at the end of the case clause list. - */ - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * If the evaluation of the selection code or the comparison of - * its value to the control clause fail, execution will proceed - * to the "skip clause" label and on to the next case. - */ - skp_lbl = alc_lbl("skip clause", 0); - on_failure = skp_lbl; - cd_add(skp_lbl); - cur_fnc->cursor = skp_lbl->prev; /* generate code before end label */ - - /* - * Bound the selection code for this clause. - */ - cd_lbl = alc_lbl("selected code", Bounding); - cd_add(cd_lbl); - cur_fnc->cursor = cd_lbl->prev; - gencode(Tree0(clause), r2); - - /* - * Dereference the results of the control clause and the selection - * clause and compare them. - */ - setloc(clause); - deref_cd(r1, r3); - deref_cd(r2, r2); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!equiv(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = r3; - cd->Cond = cd1; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = r2; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - cd_add(sig_cd(cd_lbl, cur_fnc)); /* transfer control to bounding label */ - - /* - * Generate code for the body of this clause after the bounding label. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cd_lbl; - on_failure = fail_sav; - gencode(Tree1(clause), rslt); - - /* - * If this clause is a generator, call the success continuation - * for the case expression, otherwise branch to the end of the - * expression. - */ - if (cur_fnc->cursor->next != skp_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); /* allocate a continuation function */ - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - else - cd_add(mk_goto(end_lbl)); - - /* - * The code for the next clause goes after the "skip" label of - * this clause. - */ - cur_fnc->cursor = skp_lbl; - } - - if (deflt == NULL) - cd_add(sig_cd(fail_sav, cur_fnc)); /* default action is failure */ - else { - /* - * There is an explicit default action. - */ - on_failure = fail_sav; - gencode(deflt, rslt); - if (cur_fnc->cursor->next != end_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - } - cur_fnc->cursor = end_lbl; - - /* - * If some clauses are generators but others have transferred control - * to here, we must call the success continuation of the case - * expression and generate subsequent code there. - */ - if (succ_cont != NULL) { - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - } - return rslt; - } - -/* - * gen_creat - generate code to create a co-expression. - */ -static struct val_loc *gen_creat(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *fail_sav; - struct code *fail_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct val_loc *co_rslt; - struct freetmp *ft; - char sav_prfx[PrfxSz]; - int *tmp_sv; - int *itmp_sv; - int *dtmp_sv; - int *sbuf_sv; - int *cbuf_sv; - int ntmp_sv; - int nitmp_sv; - int ndtmp_sv; - int nsbuf_sv; - int ncbuf_sv; - int stat_sz_sv; - int istat_sz_sv; - int dstat_sz_sv; - int sstat_sz_sv; - int cstat_sz_sv; - int i; - - - rslt = chk_alc(rslt, n->lifetime); - - fail_sav = on_failure; - fnc_sav = cur_fnc; - for (i = 0; i < PrfxSz; ++i) - sav_prfx[i] = frm_prfx[i]; - - /* - * Temporary variables are allocated independently for the co-expression. - */ - tmp_sv = tmp_status; - itmp_sv = itmp_status; - dtmp_sv = dtmp_status; - sbuf_sv = sbuf_status; - cbuf_sv = cbuf_status; - stat_sz_sv = status_sz; - istat_sz_sv = istatus_sz; - dstat_sz_sv = dstatus_sz; - sstat_sz_sv = sstatus_sz; - cstat_sz_sv = cstatus_sz; - ntmp_sv = num_tmp; - nitmp_sv = num_itmp; - ndtmp_sv = num_dtmp; - nsbuf_sv = num_sbuf; - ncbuf_sv = num_cbuf; - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Put code for co-expression in separate function. We will need a new - * type of procedure frame which contains copies of local variables, - * copies of arguments, and temporaries for use by the co-expression. - */ - fnc = alc_fnc(); - fnc->ref_cnt = 1; - fnc->flag |= CF_Coexpr; - ChkPrefix(fnc->prefix); - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = fnc->frm_prfx[i] = fnc->prefix[i]; - cur_fnc = fnc; - - /* - * Set up a co-expression failure label followed by a context switch - * and a branch back to the failure label. - */ - fail_lbl = alc_lbl("co_fail", 0); - cd_add(fail_lbl); - lastline = 0; /* force setting line number so tracing matches interp */ - setloc(n); - cd = alc_ary(2); - cd->ElemTyp(0) = A_Str; - cd->ElemTyp(1) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)),"; - cd->Str(1) = "NULL, NULL, A_Cofail, 1);"; - cd_add(cd); - cd_add(mk_goto(fail_lbl)); - cur_fnc->cursor = fail_lbl->prev; /* code goes before failure label */ - on_failure = fail_lbl; - - /* - * Generate code for the co-expression body, using the same - * dereferencing rules as for procedure return. - */ - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - ++create_lvl; - co_rslt = genretval(n, Tree0(n), NULL); - --create_lvl; - - /* - * If the co-expression might produce a result, generate a co-expression - * context switch. - */ - if (co_rslt != NULL) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "++BlkLoc(k_current)->coexpr.size;"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)), &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = co_rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL, A_Coret, 1);"; - cd_add(cd); - cd_add(sig_cd(on_failure, cur_fnc)); /* if reactivated, resume expr */ - } - - /* - * Output the new frame definition. - */ - prt_frame(frm_prfx, cur_proc->tnd_loc + num_tmp + Abs(cur_proc->nargs), - num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Now return to original function and produce code to create the - * co-expression. - */ - cur_fnc = fnc_sav; - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = sav_prfx[i]; - on_failure = fail_sav; - - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - cd = NewCode(5); - cd->cd_id = C_Create; - cd->Rslt = rslt; - cd->Cont = fnc; - cd->NTemps = num_tmp; - cd->WrkSize = num_itmp; - cd->NextCreat = cur_fnc->creatlst; - cur_fnc->creatlst = cd; - cd_add(cd); - - /* - * Restore arrays for temporary variable allocation. - */ - free((char *)tmp_status); - free((char *)itmp_status); - free((char *)dtmp_status); - free((char *)sbuf_status); - free((char *)cbuf_status); - tmp_status = tmp_sv; - itmp_status = itmp_sv; - dtmp_status = dtmp_sv; - sbuf_status = sbuf_sv; - cbuf_status = cbuf_sv; - status_sz = stat_sz_sv; - istatus_sz = istat_sz_sv; - dstatus_sz = dstat_sz_sv; - sstatus_sz = sstat_sz_sv; - cstatus_sz = cstat_sz_sv; - num_tmp = ntmp_sv; - num_itmp = nitmp_sv; - num_dtmp = ndtmp_sv; - num_sbuf = nsbuf_sv; - num_cbuf = ncbuf_sv; - - /* - * Temporary variables that exist to the end of the co-expression - * have no meaning in the surrounding code and must not be - * deallocated there. - */ - while (n->freetmp != NULL) { - ft = n->freetmp->next; - n->freetmp->next = freetmp_pool; - freetmp_pool = n->freetmp; - n->freetmp = ft; - } - - return rslt; - } - -/* - * gen_lim - generate code for limitation. - */ -static struct val_loc *gen_lim(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *expr; - struct node *limit; - struct val_loc *lim_desc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct code *fail_sav; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont; - struct val_loc *lim_int; - struct lentry *single; - int deref; - - expr = Tree0(n); - limit = Tree1(n); - - /* - * Generate code to compute the limitation value and dereference it. - */ - deref = HasVar(varsubtyp(limit->type, &single)); - if (single != NULL) { - /* - * Limitation is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(limit, &ignore); - lim_desc = var_ref(single); - } - else { - lim_desc = gencode(limit, NULL); - if (deref) - deref_cd(lim_desc, lim_desc); - } - - setloc(n); - fail_sav = on_failure; - - /* - * Try to convert the limitation value into an integer. - */ - lim_int = itmp_loc(alc_itmp(n->intrnl_lftm)); - cur_symtyps = n->symtyps; - if (largeints || (eval_is(int_typ, 0) & MaybeFalse)) { - /* - * Must call the conversion routine. - */ - lbl = alc_lbl("limit is int", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* conversion goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_c_int(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_desc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = lim_int; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(101, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - /* - * The C integer is in the vword. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = lim_int; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = IntVal("; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = lim_desc; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - } - - /* - * Make sure the limitation value is positive. - */ - lbl = alc_lbl("limit positive", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " >= 0"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(205, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - - /* - * If the limitation value is 0, fail immediately. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * Establish where to go when limit has been reached. - */ - fnc_sav = cur_fnc; - lbl = alc_lbl("limit", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* limited expression goes before label */ - - /* - * Generate code for limited expression and to check the limit value. - */ - rslt = gencode(expr, rslt); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "--"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_int; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(lbl, cur_fnc); - cd_add(cd); - - /* - * Call the success continuation both here and after the limitation - * label. - */ - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl; - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - - return rslt; - } - -/* - * gen_apply - generate code for the apply operator, !. - */ -static struct val_loc *gen_apply(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct val_loc *callee; - struct val_loc *lst; - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - - /* - * Generate code to compute the two operands. - */ - callee = gencode(Tree0(n), NULL); - lst = gencode(Tree1(n), NULL); - rslt = chk_alc(rslt, n->lifetime); - setloc(n); - - /* - * Construct argument list for apply(). - */ - arg_lst = alc_ary(6); - arg_lst->ElemTyp(0) = A_Str; - arg_lst->Str(0) = "&"; - arg_lst->ElemTyp(1) = A_ValLoc; - arg_lst->ValLoc(1) = callee; - arg_lst->ElemTyp(2) = A_Str; - arg_lst->Str(2) = ", &"; - arg_lst->ElemTyp(3) = A_ValLoc; - arg_lst->ValLoc(3) = lst; - arg_lst->ElemTyp(4) = A_Str; - arg_lst->Str(4) = ", &"; - arg_lst->ElemTyp(5) = A_ValLoc; - arg_lst->ValLoc(5) = rslt; - - /* - * Generate code to call apply(). Assume the operation can suspend and - * allocate a continuation. If it returns a "continue" signal, - * just break out of the signal handling code and fall into a call - * to the continuation. - */ - on_ret = NewCode(1); /* #fields for C_Break == #fields for C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - fnc = alc_fnc(); /* success continuation */ - callo_add("apply", DoesFail | DoesRet | DoesSusp, fnc, 1, arg_lst, on_ret); - callc_add(fnc); - cur_fnc = fnc; /* subsequent code goes in the continuation */ - on_failure = &resume; - - return rslt; - } - - -/* - * gen_scan - generate code for string scanning. - */ -static struct val_loc *gen_scan(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *subj; - struct node *body; - struct scan_info *scanp; - struct val_loc *asgn_var; - struct val_loc *new_subj; - struct val_loc *scan_rslt; - struct tmplftm *lifetm_ary; - struct lentry *subj_single; - struct lentry *body_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int subj_deref; - int body_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node '?' or '?:=' */ - subj = Tree1(n); /* subject expression */ - body = Tree2(n); /* scanning expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * The location of the save areas for scanning environments is stored - * in list so they can be accessed by expressions that transfer - * control out of string scanning. Get the next list element and - * allocate the save areas in the procedure frame. - */ - scanp = nxt_scan; - if (nxt_scan->next == NULL) - nxt_scan->next = NewStruct(scan_info); - nxt_scan = nxt_scan->next; - scanp->outer_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->outer_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - scanp->inner_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->inner_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - - subj_deref = HasVar(varsubtyp(subj->type, &subj_single)); - if (subj_single != NULL) { - /* - * The subject value is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(subj, &ignore); - new_subj = var_ref(subj_single); - - if (op_tok == AUGQMARK) { - body_deref = HasVar(varsubtyp(body->type, &body_single)); - if (body_single != NULL) - scan_rslt = &ignore; /* we know where the value will be */ - else - scan_rslt = chk_alc(NULL, n->intrnl_lftm); - } - else - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - else if (op_tok == AUGQMARK) { - /* - * Augmented string scanning using general assignment. The operands - * must be in consecutive locations. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn_var = tmp_loc(tmp_indx++); - scan_rslt = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - gencode(subj, asgn_var); - new_subj = chk_alc(NULL, n->intrnl_lftm); - deref_cd(asgn_var, new_subj); - } - else { - new_subj = gencode(subj, NULL); - if (subj_deref) - deref_cd(new_subj, new_subj); - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - - /* - * Produce code to save the old scanning environment. - */ - setloc(op); - save_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle failure of the body of string scanning. - */ - lbl = alc_lbl("scan fail", 0); - cd_add(lbl); - restr_env(scanp->outer_sub, scanp->outer_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* body goes before label */ - on_failure = lbl; - - /* - * If necessary, try to convert the subject to a string. Note that if - * error conversion occurs, backtracking will restore old subject. - */ - cur_symtyps = n->symtyps; - if (eval_is(str_typ, 0) & MaybeFalse) { - lbl = alc_lbl("&subject is string", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_str(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = new_subj; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &k_subject)"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(103, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = 1;"; - cd_add(cd); - - scan_rslt = gencode(body, scan_rslt); - - setloc(op); - if (op_tok == AUGQMARK) { - /* - * '?:=' - perform assignment. - */ - if (subj_single != NULL) { - /* - * Assignment to a named variable. - */ - if (body_single != NULL) - cd_add(mk_cpyval(new_subj, var_ref(body_single))); - else if (body_deref) - deref_cd(scan_rslt, new_subj); - else - cd_add(mk_cpyval(new_subj, scan_rslt)); - } - else { - /* - * Use general assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, asgn_var, 2, rslt,0); - } - } - } - else { - /* - * '?' - */ - rslt = scan_rslt; - } - - /* - * Produce code restore subject and pos when the body of the - * scanning expression succeeds. The new subject and pos must - * be saved in case of resumption. - */ - save_env(scanp->inner_sub, scanp->inner_pos); - restr_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle resumption of string scanning. - */ - lbl = alc_lbl("scan resume", 0); - cd_add(lbl); - save_env(scanp->outer_sub, scanp->outer_pos); - restr_env(scanp->inner_sub, scanp->inner_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* success continuation goes before label */ - on_failure = lbl; - - nxt_scan = scanp; - return rslt; - } - -/* - * gen_act - generate code for co-expression activation. - */ -static struct val_loc *gen_act(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *transmit; - struct node *coexpr; - struct tmplftm *lifetm_ary; - struct val_loc *trans_loc; - struct val_loc *coexpr_loc; - struct val_loc *asgn1; - struct val_loc *asgn2; - struct val_loc *act_rslt; - struct lentry *c_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int c_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node for '@' or '@:=' */ - transmit = Tree1(n); /* expression for value to transmit */ - coexpr = Tree2(n); /* expression for co-expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * Produce code for the value to be transmitted. - */ - if (op_tok == AUGAT) { - /* - * Augmented activation. This is seldom used so don't try too - * hard to optimize it. Allocate contiguous temporaries for - * the operands to the assignment. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn1 = tmp_loc(tmp_indx++); - asgn2 = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - /* - * Generate code to produce the left-hand-side of the assignment. - * This is also the transmitted value. Activation may need a - * dereferenced value, so this must be in a different location. - */ - gencode(transmit, asgn1); - trans_loc = chk_alc(NULL, n->intrnl_lftm); - setloc(op); - deref_ret(asgn1, trans_loc, varsubtyp(transmit->type, NULL)); - } - else - trans_loc = genretval(op, transmit, NULL); /* ordinary activation */ - - /* - * Determine if the value to be activated needs dereferencing, and - * see if it can only come from a single named variable. - */ - c_deref = HasVar(varsubtyp(coexpr->type, &c_single)); - if (c_single == NULL) { - /* - * The value is something other than a single named variable. - */ - coexpr_loc = gencode(coexpr, NULL); - if (c_deref) - deref_cd(coexpr_loc, coexpr_loc); - } - else { - /* - * The value is in a named variable. Use it directly from the - * variable rather than saving the result of the expression. - */ - gencode(coexpr, &ignore); - coexpr_loc = var_ref(c_single); - } - - /* - * Make sure the value to be activated is a co-expression. Perform - * run-time checking if necessary. - */ - cur_symtyps = n->symtyps; - if (eval_is(coexp_typ, 1) & MaybeFalse) { - lbl = alc_lbl("is co-expression", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = coexpr_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Coexpr"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(118, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = coexpr_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - /* - * Make sure a result location has been allocated. For ordinary - * activation, this is where activate() puts its result. For - * augmented activation, this is where assignment puts its result. - */ - rslt = chk_alc(rslt, n->lifetime); - if (op_tok == AUGAT) - act_rslt = asgn2; - else - act_rslt = rslt; - - /* - * Generate code to call activate(). - */ - setloc(n); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(7); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "activate(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = trans_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (struct b_coexpr *)BlkLoc("; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = coexpr_loc; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = "), &"; - cd1->ElemTyp(5) = A_ValLoc; - cd1->ValLoc(5) = act_rslt; - cd1->ElemTyp(6) = A_Str; - cd1->Str(6) = ") == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * For augmented activation, generate code to call assignment. - */ - if (op_tok == AUGAT) { - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, asgn1, 2, rslt, 0); - } - } - - return rslt; - } - -/* - * save_env - generate code to save scanning environment. - */ -static void save_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = sub_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_subject;"; - cd_add(cd); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = pos_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_pos;"; - cd_add(cd); - } - -/* - * restr_env - generate code to restore scanning environment. - */ -static void restr_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = sub_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = pos_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - -/* - * mk_callop - produce the code to directly call an operation. - */ -static void mk_callop(oper_nm, ret_flag, arg1rslt, nargs, rslt, optim) -char *oper_nm; -int ret_flag; -struct val_loc *arg1rslt; -int nargs; -struct val_loc *rslt; -int optim; - { - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - int n; - int need_cont; - - /* - * If this operation can return an "continue" signal, we will need - * a break statement in the signal switch to handle it. - */ - if (ret_flag & DoesRet) { - on_ret = NewCode(1); /* #fields == #fields C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - } - else - on_ret = NULL; - - /* - * Construct argument list for the C function implementing the - * operation. First compute the size of the code array for the - * argument list; this varies if we are using an optimized calling - * interface. - */ - if (optim) { - n = 0; - if (arg1rslt != NULL) - n += 2; - if (ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) - ++n; - n += 2; - } - } - else - n = 7; - if (n == 0) - arg_lst = NULL; - else { - arg_lst = alc_ary(n); - n = 0; - if (!optim) { - arg_lst->ElemTyp(n) = A_Intgr; /* number of arguments */ - arg_lst->Intgr(n) = nargs; - ++n; - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - if (arg1rslt == NULL) { /* location of first argument */ - if (!optim) { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "NULL"; - ++n; - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = ""; /* nothing, but must fill slot */ - ++n; - } - } - else { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = arg1rslt; - ++n; - } - if (!optim || ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) { - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - arg_lst->ElemTyp(n) = A_Str; /* location of result */ - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = rslt; - } - } - - /* - * Generate code to call the operation and handle returned signals. - */ - if (ret_flag & DoesSusp) { - /* - * The operation suspends, so call it with a continuation, then - * proceed to generate code in the continuation. - */ - fnc = alc_fnc(); - callo_add(oper_nm, ret_flag, fnc, 1, arg_lst, on_ret); - if (ret_flag & DoesRet) - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - } - else { - /* - * No continuation is needed, but if standard calling conventions - * are used, a NULL continuation argument is required. - */ - if (optim) - need_cont = 0; - else - need_cont = 1; - callo_add(oper_nm, ret_flag, NULL, need_cont, arg_lst, on_ret); - } -} - -/* - * genretval - generate code for the expression in a return/suspend or - * for the expression for the value to be transmitted in a co-expression - * context switch. - */ -static struct val_loc *genretval(n, expr, dest) -struct node *n; -struct node *expr; -struct val_loc *dest; - { - int subtypes; - struct lentry *single; - struct val_loc *val; - - subtypes = varsubtyp(expr->type, &single); - - /* - * If we have a single local or argument, we don't need to construct - * a variable reference; we need the value and we know where it is. - */ - if (single != NULL && (subtypes & (HasLcl | HasPrm))) { - gencode(expr, &ignore); - val = var_ref(single); - if (dest == NULL) - dest = val; - else - cd_add(mk_cpyval(dest, val)); - } - else { - dest = gencode(expr, dest); - setloc(n); - deref_ret(dest, dest, subtypes); - } - - return dest; - } - -/* - * deref_ret - produced dereferencing code for values returned from - * procedures or transmitted to co-expressions. - */ -static void deref_ret(src, dest, subtypes) -struct val_loc *src; -struct val_loc *dest; -int subtypes; - { - struct code *cd; - struct code *lbl; - - if (src == NULL) - return; /* no value to dereference */ - - /* - * If there may be values that do not need dereferencing, insure that the - * values are in the destination and make it the source of dereferencing. - */ - if ((subtypes & (HasVal | HasGlb)) && (src != dest)) { - cd_add(mk_cpyval(dest, src)); - src = dest; - } - - if (subtypes & (HasLcl | HasPrm)) { - /* - * Some values may need to be dereferenced. - */ - lbl = NULL; - if (subtypes & HasVal) { - /* - * We may have a non-variable and must check at run time. - */ - lbl = check_var(dest, NULL); - } - - if (subtypes & HasGlb) { - /* - * Make sure we don't dereference any globals, use retderef(). - */ - if (subtypes & HasLcl) { - /* - * We must dereference any locals. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = - ", (word *)pfp->tend.d, (word *)(pfp->tend.d + pfp->tend.num));"; - cd_add(cd); - /* - * We may now have a value. We must check at run-time and skip - * any attempt to dereference an argument. - */ - lbl = check_var(dest, lbl); - } - - if (subtypes & HasPrm) { - /* - * We must dereference any arguments. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", (word *)glbl_argp, (word *)(glbl_argp + "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = Abs(cur_proc->nargs); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - } - } - else /* No globals */ - deref_cd(src, dest); - - if (lbl != NULL) - cur_fnc->cursor = lbl; /* continue after label */ - } - } - -/* - * check_var - generate code to make sure a descriptor contains a variable - * reference. If no label is given to jump to for a non-variable, allocate - * one and generate code before it. - */ -static struct code *check_var(d, lbl) -struct val_loc *d; -struct code *lbl; - { - struct code *cd, *cd1; - - if (lbl == NULL) { - lbl = alc_lbl("not variable", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - } - - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!Var("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = d; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - - return lbl; - } - -/* - * field_ref - generate code for a field reference. - */ -static struct val_loc *field_ref(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *rec; - struct node *fld; - struct fentry *fp; - struct par_rec *rp; - struct val_loc *rec_loc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct lentry *single; - int deref; - int num_offsets; - int offset; - int bad_recs; - - rec = Tree0(n); - fld = Tree1(n); - - /* - * Generate code to compute the record value and dereference it. - */ - deref = HasVar(varsubtyp(rec->type, &single)); - if (single != NULL) { - /* - * The record is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(rec, &ignore); - rec_loc = var_ref(single); - } - else { - rec_loc = gencode(rec, NULL); - if (deref) - deref_cd(rec_loc, rec_loc); - } - - setloc(fld); - - /* - * Make sure the operand is a record. - */ - cur_symtyps = n->symtyps; - if (eval_is(rec_typ, 0) & MaybeFalse) { - lbl = alc_lbl("is record", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rec_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Record"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(107, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - rslt = chk_alc(rslt, n->lifetime); - - /* - * Find the list of records containing this field. - */ - if ((fp = flookup(Str0(fld))) == NULL) { - nfatal(n, "invalid field", Str0(fld)); - return rslt; - } - - /* - * Generate code for declarations and to get the record block pointer. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "{"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "struct b_record *r_rp = (struct b_record *) BlkLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "int r_must_fail = 0;"; - cd_add(cd); - } - - /* - * Determine which records are in the record type. - */ - mark_recs(fp, cur_symtyps->types[0], &num_offsets, &offset, &bad_recs); - - /* - * Generate code to insure that the field belongs to the record - * and to index into the record block. - */ - if (num_offsets == 1 && !bad_recs) { - /* - * We already know the offset of the field. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)&r_rp->fields["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = offset; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "] - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - for (rp = fp->rlist; rp != NULL; rp = rp->next) - rp->mark = 0; - } - else { - /* - * The field appears in several records. generate code to determine - * which one it is. - */ - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "dptr r_dp;"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "switch (r_rp->recdesc->proc.recnum) {"; - cd_add(cd); - - rp = fp->rlist; - while (rp != NULL) { - offset = rp->offset; - while (rp != NULL && rp->offset == offset) { - if (rp->mark) { - rp->mark = 0; - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " case "; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = rp->rec->rec_num; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ":"; - cd_add(cd); - } - rp = rp->next; - } - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_dp = &r_rp->fields["; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = offset; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "];"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " break;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " default:"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " err_msg(207, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - /* - * The peephole analyzer doesn't know how to handle a goto or return - * in a switch statement, so just set a flag here. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_must_fail = 1;"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " }"; - cd_add(cd); - if (err_conv) { - /* - * Now that we are out of the switch statement, see if the flag - * was set to indicate error conversion. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "r_must_fail"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)r_dp - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "}"; - cd_add(cd); - return rslt; - } - -/* - * bound - bound the code for the given sub-tree. If catch_fail is true, - * direct failure to the bounding label. - */ -static struct val_loc *bound(n, rslt, catch_fail) -struct node *n; -struct val_loc *rslt; -int catch_fail; - { - struct code *lbl1; - struct code *fail_sav; - struct c_fnc *fnc_sav; - - fnc_sav = cur_fnc; - fail_sav = on_failure; - - lbl1 = alc_lbl("bound", Bounding); - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - if (catch_fail) - on_failure = lbl1; - - rslt = gencode(n, rslt); - - cd_add(sig_cd(lbl1, cur_fnc)); /* transfer control to bounding label */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl1; - - on_failure = fail_sav; - return rslt; - } - -/* - * cd_add - add a code struct at the cursor in the current function. - */ -void cd_add(cd) -struct code *cd; - { - register struct code *cursor; - - cursor = cur_fnc->cursor; - - cd->next = cursor->next; - cd->prev = cursor; - if (cursor->next != NULL) - cursor->next->prev = cd; - cursor->next = cd; - cur_fnc->cursor = cd; - } - -/* - * sig_cd - convert a signal/label into a goto or return signal in - * the context of the given function. - */ -struct code *sig_cd(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct code *cd; - - if (sig->cd_id == C_Label && sig->Container == fnc) - return mk_goto(sig); - else { - cd = NewCode(1); /* # fields <= # fields of C_Goto */ - cd->cd_id = C_RetSig; - cd->next = NULL; - cd->prev = NULL; - cd->SigRef = add_sig(sig, fnc); - return cd; - } - } - -/* - * add_sig - add signal to list of signals returned by function. - */ -struct sig_lst *add_sig(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct sig_lst *sl; - - for (sl = fnc->sig_lst; sl != NULL && sl->sig != sig; sl = sl->next) - ; - if (sl == NULL) { - sl = NewStruct(sig_lst); - sl->sig = sig; - sl->ref_cnt = 1; - sl->next = fnc->sig_lst; - fnc->sig_lst = sl; - } - else - ++sl->ref_cnt; - return sl; - } - -/* - * callc_add - add code to call a continuation. Note the action to be - * taken if the continuation returns resumption. The actual list - * signals returned and actions to take will be figured out after - * the continuation has been optimized. - */ -void callc_add(cont) -struct c_fnc *cont; - { - struct code *cd; - - cd = new_call(); - cd->OperName = NULL; - cd->Cont = cont; - cd->ArgLst = NULL; - cd->ContFail = on_failure; - cd->SigActs = NULL; - ++cont->ref_cnt; - } - -/* - * callo_add - add code to call an operation. - */ -void callo_add(oper_nm, ret_flag, cont, need_cont, arglist, on_ret) -char *oper_nm; -int ret_flag; -struct c_fnc *cont; -int need_cont; -struct code *arglist; -struct code *on_ret; - { - struct code *cd; - struct code *cd1; - - cd = new_call(); - cd->OperName = oper_nm; - cd->Cont = cont; - if (need_cont) - cd->Flags = NeedCont; - cd->ArgLst = arglist; - cd->ContFail = NULL; /* operation handles failure from the continuation */ - /* - * Decide how to handle the signals produced by the operation. (Those - * produced by the continuation will be examined after the continuation - * is optimized.) - */ - cd->SigActs = NULL; - if (MightFail(ret_flag)) - cd->SigActs = new_sgact(&resume, sig_cd(on_failure,cur_fnc), cd->SigActs); - if (ret_flag & DoesRet) - cd->SigActs = new_sgact(&contin, on_ret, cd->SigActs); - if (ret_flag & DoesFThru) { - cd1 = NewCode(1); /* #fields == #fields C_Goto */ - cd1->cd_id = C_Break; - cd1->next = NULL; - cd1->prev = NULL; - cd->SigActs = new_sgact(&fallthru, cd1, cd->SigActs); - } - if (cont != NULL) - ++cont->ref_cnt; /* increment reference count */ -} - -/* - * Create a call, add it to the code for the current function, and - * add it to the list of calls from the current function. - */ -static struct code *new_call() - { - struct code *cd; - - cd = NewCode(7); - cd->cd_id = C_CallSig; - cd_add(cd); - cd->Flags = 0; - cd->NextCall = cur_fnc->call_lst; - cur_fnc->call_lst = cd; - return cd; - } - -/* - * sig_act - create a new binding of an action to a signal. - */ -struct sig_act *new_sgact(sig, cd, next) -struct code *sig; -struct code *cd; -struct sig_act *next; - { - struct sig_act *sa; - - sa = NewStruct(sig_act); - sa->sig = sig; - sa->cd = cd; - sa->shar_act = NULL; - sa->next = next; - return sa; - } - - -#ifdef OptimizeLit -static int instr(const char *str, int chr) { - int i, found, go; - - found = 0; go = 1; - for(i=0; ((str[i] != '\0') && go) ;i++) { - if (str[i] == chr) { - go = 0; - found = 1; - if ((str[i+1] != '\0') && (chr == '=')) - if (str[i+1] == '=') - found = 0; - if ((chr == '=') && (i > 0)) { - if (str[i-1] == '>') - found = 0; - else if (str[i-1] == '<') - found = 0; - else if (str[i-1] == '!') - found = 0; - } - } - } - return found; -} - -static void tbl_add(struct lit_tbl *add) { - struct lit_tbl *ins; - static struct lit_tbl *ptr = NULL; - int go = 1; - - if (tbl == NULL) { - tbl = add; - ptr = add; - } - else { - ins = ptr; - while ((ins != NULL) && go) { - if (add->index != ins->index) - ins = ins->prev; - else - go = 0; - } - if (ins != NULL) { - if (ins->end == NULL) - ins->end = add->initial; - } - ptr->next = add; - add->prev = ptr; - ptr = add; - } -} - - -static void invalidate(struct val_loc *val, struct code *end, int code) { - struct lit_tbl *ptr, *back; - int index, go = 1; - - if (val == NULL) - return; - if (val->loc_type == V_NamedVar) { - index = val->u.nvar->val.index; - return; - } - else if (val->loc_type == V_Temp) - index = val->u.tmp + cur_proc->tnd_loc; - else - return; - if (tbl == NULL) - return; - back = tbl; - while (back->next != NULL) - back = back->next; - go = 1; - for(ptr=back; ((ptr != NULL) && go) ; ptr=ptr->prev) { - if ((ptr->index == index) && (ptr->modified != NO_TOUCH)) { - ptr->modified = code; - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if ((ptr->index == index) && (ptr->modified == NO_TOUCH)) { - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if (ptr->index == index) - go = 0; - } -} - - -static int eval_code(struct code *cd, struct lit_tbl *cur) { - struct code *tmp; - struct lit_tbl *tmp_tbl; - int i, j; - char *str; - - for (i=0; cd->ElemTyp(i) != A_End ;i++) { - switch(cd->ElemTyp(i)) { - case A_ValLoc: - if (cd->ValLoc(i)->mod_access != M_CInt) - break; - if ((cd->ValLoc(i)->u.tmp + cur_proc->tnd_loc) == cur->index) { - switch (cd->ValLoc(i)->loc_type) { - case V_Temp: - if (cur->csym->flag == F_StrLit) { -#if 0 - cd->ElemTyp(i) = A_Str; - str = (char *)alloc(strlen(cur->csym->image)+8); - sprintf(str, "\"%s\"/*Z*/", cur->csym->image); - cd->Str(i) = str; -#endif - } - else if (cur->csym->flag == F_IntLit) { - cd->ElemTyp(i) = A_Str; - cd->Str(i) = cur->csym->image; - } - break; - default: - break; - } - } - break; - case A_Ary: - for(tmp=cd->Array(i); tmp != NULL ;tmp=tmp->next) - eval_code(tmp, cur); - break; - default: - break; - } - } -} - -static void propagate_literals() { - struct lit_tbl *ptr; - struct code *cd, *arg; - int ret; - - for(ptr=tbl; ptr != NULL ;ptr=ptr->next) { - if (ptr->modified != NO_TOUCH) { - for(cd=ptr->initial; cd != ptr->end ;cd=cd->next) { - switch (cd->cd_id) { - case C_If: - for(arg=cd->Cond; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - /* - * Again, don't take the 'then' portion. - * It might lead to infinite loops. - * for(arg=cd->ThenStmt; arg != NULL ;arg=arg->next) - * ret = eval_code(arg, ptr); - */ - break; - case C_CdAry: - ret = eval_code(cd, ptr); - break; - case C_CallSig: - for(arg=cd->ArgLst; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - break; - default: - break; - } - } - } - } -} - -/* - * analyze_literals - analyzes the generated code to replace - * complex record dereferences with C - * literals. - */ -static void analyze_literals(struct code *start, struct code *top, int lvl) { - struct code *ptr, *tmp, *not_null; - struct lit_tbl *new_tbl; - struct lbl_tbl *new_lbl; - struct val_loc *prev = NULL; - int i, inc=0, addr=0, assgn=0, equal = 0; - - for (ptr = start; ptr != NULL ; ptr = ptr->next) { - if (!lvl) - not_null = ptr; - else - not_null = top; - switch (ptr->cd_id) { - case C_NamedVar: - break; - case C_CallSig: - analyze_literals(ptr->ArgLst, not_null, lvl+1); - break; - case C_Goto: - break; - case C_Label: - break; - case C_Lit: - new_tbl = alc_tbl(); - new_tbl->initial = ptr; - new_tbl->vloc = ptr->Rslt; - new_tbl->csym = ptr->Literal; - switch (ptr->Rslt->loc_type) { - case V_NamedVar: - new_tbl->index = ptr->Rslt->u.nvar->val.index; - tbl_add(new_tbl); - break; - case V_Temp: - new_tbl->index = ptr->Rslt->u.tmp + cur_proc->tnd_loc; - tbl_add(new_tbl); - break; - default: - new_tbl->index = -1; - free(new_tbl); - break; - } - break; - case C_If: - analyze_literals(ptr->Cond, not_null, lvl+1); - /* - * Don't analyze the 'then' portion such as in: - * analyze_literals(ptr->ThenStmt, not_null, lvl+1); - * Apparently, all the intermediate code does is maintain - * a pointer to where the flow of execution jumps to in - * case the 'then' is taken. These are all goto statments - * and can result in infinite loops of analyzation. - */ - break; - case C_CdAry: - for(i=0; ptr->ElemTyp(i) != A_End ;i++) { - switch(ptr->ElemTyp(i)) { - case A_Str: - if (ptr->Str(i) != NULL) { - if ( (strstr(ptr->Str(i), "-=")) || - (strstr(ptr->Str(i), "+=")) || - (strstr(ptr->Str(i), "*=")) || - (strstr(ptr->Str(i), "/=")) ) - invalidate(prev, not_null, NO_TOUCH); - else if (instr(ptr->Str(i), '=')) { - invalidate(prev, not_null, LIMITED); - assgn = 1; - } - else if ( (strstr(ptr->Str(i), "++")) || - (strstr(ptr->Str(i), "--")) ) - inc = 1; - else if (instr(ptr->Str(i), '&')) - addr = 1; - else if (strstr(ptr->Str(i), "==")) - equal = 1; - } - break; - case A_ValLoc: - if (inc) { - invalidate(ptr->ValLoc(i), not_null, NO_TOUCH); - inc = 0; - } - if (addr) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - addr = 0; - } - if ((assgn) && (ptr->ValLoc(i)->mod_access == M_None)) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - assgn = 0; - } - else if (assgn) - assgn = 0; - if (equal) { - invalidate(ptr->ValLoc(i), not_null, LIMITED_TO_INT); - equal = 0; - } - prev = ptr->ValLoc(i); - break; - case A_Intgr: - break; - case A_SBuf: - break; - case A_Ary: - for(tmp=ptr->Array(i); tmp != NULL ;tmp=tmp->next) - analyze_literals(tmp, not_null, lvl+1); - break; - default: - break; - } - } - break; - default: - break; - } - } -} -#endif /* OptimizeLit */ - -/* - * analyze_poll - analyzes the internal C code representation from - * the position of the last Poll() function call to - * the current position in the code. - * Returns a 0 if the last Poll() function should not - * be removed. - */ -#ifdef OptimizePoll -static int analyze_poll(void) { - struct code *cursor, *ptr; - int cont = 1; - - ptr = lastpoll; - if (ptr == NULL) - return 0; - cursor = cur_fnc->cursor; - while ((cursor != ptr) && (ptr != NULL) && (cont)) { - switch (ptr->cd_id) { - case C_Null : - case C_NamedVar : - case C_Label : - case C_Lit : - case C_Resume : - case C_Continue : - case C_FallThru : - case C_PFail : - case C_Goto : - case C_Create : - case C_If : - case C_SrcLoc : - case C_CdAry : - break; - case C_CallSig : - case C_RetSig : - case C_LBrack : - case C_RBrack : - case C_PRet : - case C_PSusp : - case C_Break : - cont = 0; - break; - } - ptr = ptr->next; - } - return cont; -} - -/* - * remove_poll - removes the ccode structure that represents the last - * call to the "Poll()" function by simply changing the code ID to - * C_Null code. - */ -static void remove_poll(void) { - - if (lastpoll == NULL) - return; - lastpoll->cd_id = C_Null; -} -#endif /* OptimizePoll */ - -/* - * setloc produces code to set the file name and line number to the - * source location of node n. Code is only produced if the corresponding - * value has changed since the last time setloc was called. - */ -static void setloc(n) -nodeptr n; - { - struct code *cd; - static int count=0; - - if (n == NULL || File(n) == NULL || Line(n) == 0) - return; - - if (File(n) != lastfiln || Line(n) != lastline) { -#ifdef OptimizePoll - if (analyze_poll()) - remove_poll(); - cd = alc_ary(1); - lastpoll = cd; -#else /* OptimizePoll */ - cd = alc_ary(1); -#endif /* OptimizePoll */ - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "Poll();"; - cd_add(cd); - - if (line_info) { - cd = NewCode(2); - cd->cd_id = C_SrcLoc; - - if (File(n) == lastfiln) - cd->FileName = NULL; - else { - lastfiln = File(n); - cd->FileName = lastfiln; - } - - if (Line(n) == lastline) - cd->LineNum = 0; - else { - lastline = Line(n); - cd->LineNum = lastline; - } - - cd_add(cd); - } - } - } - -/* - * alc_ary - create an array for a sequence of code fragments. - */ -struct code *alc_ary(n) -int n; - { - struct code *cd; - static cnt=1; - - cd = NewCode(2 * n + 1); - cd->cd_id = C_CdAry; - cd->next = NULL; - cd->prev = NULL; - cd->ElemTyp(n) = A_End; - return cd; - } - - -/* - * alc_lbl - create a label. - */ -struct code *alc_lbl(desc, flag) -char *desc; -int flag; - { - register struct code *cd; - - cd = NewCode(5); - cd->cd_id = C_Label; - cd->next = NULL; - cd->prev = NULL; - cd->Container = cur_fnc; /* function containing label */ - cd->SeqNum = 0; /* sequence number is allocated later */ - cd->Desc = desc; /* identifying comment */ - cd->RefCnt = 0; /* reference count */ - cd->LabFlg = flag; - return cd; - } - -/* - * alc_fnc - allocate a function structure; - */ -static struct c_fnc *alc_fnc() - { - register struct c_fnc *cf; - int i; - - cf = NewStruct(c_fnc); - cf->prefix[0] = '\0'; /* prefix is allocated later */ - cf->prefix[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->flag = 0; - for (i = 0; i < PrfxSz; ++i) - cf->frm_prfx[i] = frm_prfx[i]; /* note procedure frame prefix */ - cf->frm_prfx[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->cd.cd_id = C_Null; /* base of code sequence in function */ - cf->cd.next = NULL; - cf->cursor = &cf->cd; /* current place to insert code */ - cf->call_lst = NULL; /* functions called by this function */ - cf->creatlst = NULL; /* creates within this function */ - cf->sig_lst = NULL; /* signals returned by this function */ - cf->ref_cnt = 0; - cf->next = NULL; - *flst_end = cf; /* link entry onto global list */ - flst_end = &(cf->next); - return cf; - } - -/* - * tmp_loc - allocate a value location structure for nth temporary descriptor - * variable in procedure frame. - */ -static struct val_loc *tmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Temp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * itmp_loc - allocate a value location structure for nth temporary integer - * variable in procedure frame. - */ -struct val_loc *itmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_ITemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * dtmp_loc - allocate a value location structure for nth temporary double - * variable in procedure frame. - */ -struct val_loc *dtmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_DTemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * vararg_sz - allocate a value location structure that refers to the size - * of the variable part of an argument list. - */ -static struct val_loc *vararg_sz(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Const; - r->mod_access = M_None; - r->u.int_const = n; - return r; - } - -/* - * cvar_loc - allocate a value location structure for a C variable. - */ -struct val_loc *cvar_loc(name) -char *name; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_CVar; - r->mod_access = M_None; - r->u.name = name; - return r; - } - -/* - * var_ref - allocate a value location structure for an Icon named variable. - */ -static struct val_loc *var_ref(sym) -struct lentry *sym; - { - struct val_loc *loc; - - loc = NewStruct(val_loc); - loc->loc_type = V_NamedVar; - loc->mod_access = M_None; - loc->u.nvar = sym; - return loc; - } - -/* - * deref_cd - generate code to dereference a descriptor. - */ -static void deref_cd(src, dest) -struct val_loc *src; -struct val_loc *dest; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "deref(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = src; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &"; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = dest; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - } - -/* - * inv_op - directly invoke a run-time operation, in-lining it if possible. - */ -static struct val_loc *inv_op(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct implement *impl; - struct code *scont_strt; - struct code *scont_fail; - struct c_fnc *fnc; - struct val_loc *frst_arg; - struct val_loc *arg_rslt; - struct val_loc *r; - struct val_loc **varg_rslt; - struct op_symentry *symtab; - struct lentry **single; - struct tmplftm *lifetm_ary; - nodeptr rslt_lftm; - char *sbuf; - int *maybe_var; - int may_mod; - int nsyms; - int nargs; - int nparms; - int cont_loc; - int flag; - int refs; - int var_args; - int n_varargs; - int arg_loc; - int dcl_var; - int i; - int j; - int v; - - nargs = Val0(n); - impl = Impl1(n); - if (impl == NULL) { - /* - * We have already printed an error, just make sure we can - * continue. - */ - return &ignore; - } - - /* - * If this operation uses its result location as a work area, it must - * be given a tended result location and the value must be retained - * as long as the operation can be resumed. - */ - rslt_lftm = n->lifetime; - if (impl->use_rslt) { - rslt_lftm = max_lftm(rslt_lftm, n->intrnl_lftm); - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - } - - /* - * Determine if this operation takes a variable number of arguments - * and determine the size of the variable part of the arg list. - */ - nparms = impl->nargs; - if (nparms > 0 && impl->arg_flgs[nparms - 1] & VarPrm) { - var_args = 1; - n_varargs = nargs - nparms + 1; - if (n_varargs < 0) - n_varargs = 0; - } - else { - var_args = 0; - n_varargs = 0; - } - - /* - * Construct a symbol table (implemented as an array) for the operation. - * The symbol table includes parameters, and both the tended and - * ordinary variables from the RTL declare statement. - */ - nsyms = (n->symtyps == NULL ? 0 : n->symtyps->nsyms); - if (var_args) - ++nsyms; - nsyms += impl->ntnds + impl->nvars; - if (nsyms > 0) - symtab = (struct op_symentry *)alloc((unsigned int)(nsyms * - sizeof(struct op_symentry))); - else - symtab = NULL; - for (i = 0; i < nsyms; ++i) { - symtab[i].n_refs = 0; /* number of non-modifying references */ - symtab[i].n_mods = 0; /* number of modifying references */ - symtab[i].n_rets = 0; /* number of times returned directly */ - symtab[i].var_safe = 0; /* Icon variable arg can be passed directly */ - symtab[i].adjust = 0; /* adjustments needed to "dereference" */ - symtab[i].itmp_indx = -1; /* loc after "in-place" convert to C integer */ - symtab[i].dtmp_indx = -1; /* loc after "in-place" convert to C double */ - symtab[i].loc = NULL; /* location as a descriptor */ - } - - /* - * If in-lining has not been disabled or the operation is a keyword, - * check to see if it can reasonably be in-lined and gather information - * needed to in-line it. - */ - if ((allow_inline || impl->oper_typ == 'K') && - do_inlin(impl, n, &cont_loc, symtab, n_varargs)) { - /* - * In-line the operation. - */ - - if (impl->ret_flag & DoesRet || impl->ret_flag & DoesSusp) - rslt = chk_alc(rslt, rslt_lftm); /* operation produces a result */ - - /* - * Allocate arrays to hold information from type inferencing about - * whether arguments are variables. This is used to optimize - * dereferencing. - */ - if (nargs > 0) { - maybe_var = (int *)alloc((unsigned int)(nargs * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nargs * - sizeof(struct lentry *))); - } - - if (var_args) - --nparms; /* don't deal with varargs parameter yet. */ - - /* - * Match arguments with parameters and generate code for the - * arguments. The type of code generated depends on the kinds - * of dereferencing optimizations that are possible, though - * in general, dereferencing must wait until all arguments are - * computed. Because there may be both dereferenced and undereferenced - * parameters for an argument, the symbol table index does not always - * match the argument index. - */ - i = 0; /* symbol table index */ - for (j = 0; j < nparms && j < nargs; ++j) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j] = HasVar(varsubtyp(n->n_field[FrstArg + j].n_ptr->type, - &(single[j]))); - - /* - * Determine how many times the argument is referenced. If we - * optimize away return statements because we don't need the - * result, those references don't count. Take into account - * that there may be both dereferenced and undereferenced - * parameters for this argument. - */ - if (rslt == &ignore) - symtab[i].n_refs -= symtab[i].n_rets; - refs = symtab[i].n_refs + symtab[i].n_mods; - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - if (flag == (RtParm | DrfPrm)) - refs += symtab[i + 1].n_refs + symtab[i + 1].n_mods; - if (refs == 0) { - /* - * Indicate that we don't need the argument value (we must - * still perform the computation in case it has side effects). - */ - arg_rslt = &ignore; - symtab[i].adjust = AdjNone; - } - else { - /* - * Decide whether the result location for the argument can be - * used directly as the parameter. - */ - if (flag == (RtParm | DrfPrm) && symtab[i].n_refs + - symtab[i].n_mods == 0) { - /* - * We have both dereferenced and undereferenced parameters, - * but don't use the undereferenced one so ignore it. - */ - symtab[i].adjust = AdjNone; - ++i; - flag = DrfPrm; - } - if (flag == DrfPrm && single[j] != NULL) { - /* - * We need only a dereferenced value, but know what variable - * it is in. We don't need the computed argument value, we will - * get it directly from the variable. If it is safe to do - * so, we will pass a pointer to the variable as the argument - * to the operation. - */ - arg_rslt = &ignore; - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * Determine if the argument descriptor is modified by the - * operation; dereferencing a variable is a modification. - */ - may_mod = (symtab[i].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j]; - if (n->n_field[FrstArg + j].n_ptr->reuse && may_mod) { - /* - * The parameter may be reused without recomputing - * the argument and the value may be modified. The - * argument result location and the parameter location - * must be separate so the parameter is reloaded upon - * each invocation. - */ - arg_rslt = chk_alc(NULL, - n->n_field[FrstArg + j].n_ptr->lifetime); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjNDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjCpy; /* value only: just copy */ - } - else { - /* - * Argument result location will act as parameter location. - * Its lifetime must be as long as both that of the - * the argument and the parameter (operation internal - * lifetime). - */ - arg_rslt = chk_alc(NULL, max_lftm(n->intrnl_lftm, - n->n_field[FrstArg + j].n_ptr->lifetime)); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjNone; - } - symtab[i].loc = arg_rslt; - } - } - - /* - * Generate the code for the argument. - */ - gencode(n->n_field[FrstArg + j].n_ptr, arg_rslt); - - if (flag == (RtParm | DrfPrm)) { - /* - * We have computed the value for the undereferenced parameter, - * decide how to get the dereferenced value. - */ - ++i; - if (symtab[i].n_refs + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; /* not needed, ignore */ - else { - if (single[j] != NULL) { - /* - * The value is in a specific Icon variable, get it from - * there. If is is safe to pass the variable directly - * to the operation, do so. - */ - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * If there might be a variable reference, note that it - * must be dereferenced. Otherwise decide whether the - * argument location can be used for both the dereferenced - * and undereferenced parameter. - */ - symtab[i].loc = arg_rslt; - if (maybe_var[j]) - symtab[i].adjust = AdjNDrf; - else if (symtab[i - 1].n_mods + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - } - } - ++i; - } - - /* - * Fill out parameter list with null values. - */ - while (j < nparms) { - int k, kn; - kn = 0; - if (impl->arg_flgs[j] & RtParm) - ++kn; - if (impl->arg_flgs[j] & DrfPrm) - ++kn; - for (k = 0; k < kn; ++k) { - if (symtab[i].n_refs + symtab[i].n_mods > 0) { - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(asgn_null(arg_rslt)); - symtab[i].loc = arg_rslt; - } - symtab[i].adjust = AdjNone; - ++i; - } - ++j; - } - - if (var_args) { - /* - * Compute variable part of argument list. - */ - ++nparms; /* add varargs parameter back into parameter list */ - - /* - * The variable part of the parameter list must be in contiguous - * descriptors. Create location and lifetime arrays for use in - * allocating the descriptors. - */ - if (n_varargs > 0) { - varg_rslt = (struct val_loc **)alloc((unsigned int)(n_varargs * - sizeof(struct val_loc *))); - lifetm_ary = alc_lftm(n_varargs, NULL); - } - - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - - /* - * Compute the lifetime of the elements of the varargs parameter array. - */ - for (v = 0; v < n_varargs; ++v) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j + v] = HasVar(varsubtyp( - n->n_field[FrstArg+j+v].n_ptr->type, &(single[j + v]))); - - /* - * Determine if the elements of the vararg parameter array - * might be modified. If it is a variable, dereferencing - * modifies it. - */ - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - - if ((flag == DrfPrm && single[j + v] != NULL) || - (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod)) { - /* - * The argument value is only placed in the vararg parameter - * array during "dereferencing". So the lifetime of the array - * element is the lifetime of the parameter and the element - * is not used until dereferencing. - */ - lifetm_ary[v].lifetime = n->intrnl_lftm; - lifetm_ary[v].cur_status = n->postn; - } - else { - /* - * The argument is computed into the vararg parameter array. - * The lifetime of the array element encompasses both - * the lifetime of the argument and the parameter. The - * element is used as soon as the argument is computed. - */ - lifetm_ary[v].lifetime = max_lftm(n->intrnl_lftm, - n->n_field[FrstArg+j+v].n_ptr->lifetime); - lifetm_ary[v].cur_status = n->n_field[FrstArg+j+v].n_ptr->postn; - } - } - - /* - * Allocate (reserve) the array of temporary variables for the - * vararg list. - */ - if (n_varargs > 0) { - arg_loc = alc_tmp(n_varargs, lifetm_ary); - free((char *)lifetm_ary); - } - - /* - * Generate code to compute arguments. - */ - for (v = 0; v < n_varargs; ++v) { - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * We need a dereferenced value and it is in a known place: a - * named variable; don't bother saving the result of the - * argument computation. - */ - r = &ignore; - } - else if (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod) { - /* - * The argument can be reused without being recomputed and - * the parameter may be modified, so we cannot safely - * compute the argument into the vararg parameter array; we - * must compute it elsewhere and copy (dereference) it at the - * beginning of the operation. Let gencode allocate an argument - * result location. - */ - r = NULL; - } - else { - /* - * We can compute the argument directly into the vararg - * parameter array. - */ - r = tmp_loc(arg_loc + v); - } - varg_rslt[v] = gencode(n->n_field[FrstArg + j + v].n_ptr, r); - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in vararg - * parameter list. Preceding arguments are dereferenced later, but - * it is okay if dereferencing is out-of-order. - */ - for (v = 0; v < n_varargs; ++v) { - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * Copy the value from the known named variable into the - * parameter list. - */ - varg_rslt[v] = var_ref(single[j + v]); - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - else if (flag == DrfPrm && maybe_var[j + v]) { - /* - * Dereference the argument into the parameter list. - */ - deref_cd(varg_rslt[v], tmp_loc(arg_loc + v)); - } - else if (arg_loc + v != varg_rslt[v]->u.tmp) { - /* - * The argument is a dereferenced value, but is not yet - * in the parameter list; copy it there. - */ - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - tmp_status[arg_loc + v] = InUse; /* parameter location in use */ - } - - /* - * The vararg parameter gets the address of the first element - * in the variable part of the argument list and the size - * parameter gets the number of elements in the list. - */ - if (n_varargs > 0) { - free((char *)varg_rslt); - symtab[i].loc = tmp_loc(arg_loc); - } - else - symtab[i].loc = chk_alc(NULL, n); /* dummy arg location */ - symtab[i].loc->mod_access = M_Addr; - ++i; - symtab[i].loc = vararg_sz(n_varargs); - ++i; - } - else { - /* - * Compute extra arguments, but discard the results. - */ - while (j < nargs) { - gencode(n->n_field[FrstArg + j].n_ptr, &ignore); - ++j; - } - } - - if (nargs > 0) { - free((char *)maybe_var); - free((char *)single); - } - - /* - * If execution does not continue through the parameter evaluation, - * don't try to generate in-line code. A lack of parameter types - * will cause problems with some in-line type conversions. - */ - if (!past_prms(n)) - return rslt; - - setloc(n); - - dcl_var = i; - - /* - * Perform any needed copying or dereferencing. - */ - for (i = 0; i < nsyms; ++i) { - switch (symtab[i].adjust) { - case AdjNDrf: - /* - * Dereference into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - deref_cd(symtab[i].loc, arg_rslt); - symtab[i].loc = arg_rslt; - break; - case AdjDrf: - /* - * Dereference in place. - */ - deref_cd(symtab[i].loc, symtab[i].loc); - break; - case AdjCpy: - /* - * Copy into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(mk_cpyval(arg_rslt, symtab[i].loc)); - symtab[i].loc = arg_rslt; - break; - case AdjNone: - break; /* nothing need be done */ - } - } - - switch (cont_loc) { - case SepFnc: - /* - * success continuation must be in a separate function. - */ - fnc = alc_fnc(); - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put oper before label */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, fnc, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - break; - case SContIL: - /* - * one suspend an no return: success continuation is put in-line. - */ - gen_inlin(impl->in_line, rslt, &scont_strt, &scont_fail, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - on_failure = scont_fail; - break; - case EndOper: - /* - * no suspends: success continuation goes at end of operation. - */ - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put operation before lbl */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - break; - } - } - else { - /* - * Do not in-line operation. - */ - implproto(impl); - frst_arg = gen_args(n, 2, nargs); - setloc(n); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, rslt_lftm); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, nargs, rslt, - 0); - } - if (symtab != NULL) - free((char *)symtab); - return rslt; - } - -/* - * max_lftm - given two lifetimes (in the form of nodes) return the - * maximum one. - */ -static nodeptr max_lftm(n1, n2) -nodeptr n1; -nodeptr n2; - { - if (n1 == NULL) - return n2; - else if (n2 == NULL) - return n1; - else if (n1->postn > n2->postn) - return n1; - else - return n2; - } - -/* - * inv_prc - directly invoke a procedure. - */ -static struct val_loc *inv_prc(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct pentry *proc; - struct val_loc *r; - struct val_loc *arg1rslt; - struct val_loc *var_part; - int *must_deref; - struct lentry **single; - struct val_loc **arg_rslt; - struct code *cd; - struct tmplftm *lifetm_ary; - char *sbuf; - int nargs; - int nparms; - int i, j; - int arg_loc; - int var_sz; - int var_loc; - - /* - * This procedure is implemented without argument list adjustment or - * dereferencing, so they must be done before the call. - */ - nargs = Val0(n); /* number of arguments */ - proc = Proc1(n); - nparms = Abs(proc->nargs); - - if (nparms > 0) { - must_deref = (int *)alloc((unsigned int)(nparms * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nparms * - sizeof(struct lentry *))); - arg_rslt = (struct val_loc **)alloc((unsigned int)(nparms * - sizeof(struct val_loc *))); - } - - /* - * Allocate a work area of temporaries to use as argument list. If - * an argument can be reused without being recomputed, it must not - * be computed directly into the work area. It will be copied or - * dereferenced into the work area when execution reaches the - * operation. If an argument is a single named variable, it can - * be dereferenced directly into the argument location. These - * conditions affect when the temporary will receive a value. - */ - if (nparms > 0) - lifetm_ary = alc_lftm(nparms, NULL); - for (i = 0; i < nparms; ++i) - lifetm_ary[i].lifetime = n->intrnl_lftm; - for (i = 0; i < nparms && i < nargs; ++i) { - must_deref[i] = HasVar(varsubtyp(n->n_field[FrstArg + i].n_ptr->type, - &(single[i]))); - if (single[i] != NULL || n->n_field[FrstArg + i].n_ptr->reuse) - lifetm_ary[i].cur_status = n->postn; - else - lifetm_ary[i].cur_status = n->n_field[FrstArg + i].n_ptr->postn; - } - while (i < nparms) { - lifetm_ary[i].cur_status = n->postn; /* arg list extension */ - ++i; - } - if (proc->nargs < 0) - lifetm_ary[nparms - 1].cur_status = n->postn; /* variable part */ - - if (nparms > 0) { - arg_loc = alc_tmp(nparms, lifetm_ary); - free((char *)lifetm_ary); - } - if (proc->nargs < 0) - --nparms; /* treat variable part specially */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (single[i] != NULL) - r = &ignore; /* we know where the dereferenced value is */ - else if (n->n_field[FrstArg + i].n_ptr->reuse) - r = NULL; /* let gencode allocate a new temporary */ - else - r = tmp_loc(arg_loc + i); - arg_rslt[i] = gencode(n->n_field[FrstArg + i].n_ptr, r); - } - - /* - * If necessary, fill out argument list with nulls. - */ - while (i < nparms) { - cd_add(asgn_null(tmp_loc(arg_loc + i))); - tmp_status[arg_loc + i] = InUse; - ++i; - } - - if (proc->nargs < 0) { - /* - * handle variable part of list. - */ - var_sz = nargs - nparms; - - if (var_sz > 0) { - lifetm_ary = alc_lftm(var_sz, &n->n_field[FrstArg + nparms]); - var_loc = alc_tmp(var_sz, lifetm_ary); - free((char *)lifetm_ary); - for (j = 0; j < var_sz; ++j) { - gencode(n->n_field[FrstArg + nparms + j].n_ptr, - tmp_loc(var_loc + j)); - } - } - } - else { - /* - * If there are extra arguments, compute them, but discard the - * results. - */ - while (i < nargs) { - gencode(n->n_field[FrstArg + i].n_ptr, &ignore); - ++i; - } - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in argument - * list as dereferenced values. - */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (must_deref[i]) { - if (single[i] == NULL) { - deref_cd(arg_rslt[i], tmp_loc(arg_loc + i)); - } - else { - arg_rslt[i] = var_ref(single[i]); - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - } - } - else if (n->n_field[FrstArg + i].n_ptr->reuse) - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - tmp_status[arg_loc + i] = InUse; - } - - if (proc->nargs < 0) { - var_part = tmp_loc(arg_loc + nparms); - tmp_status[arg_loc + nparms] = InUse; - if (var_sz <= 0) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(NULL, 0, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = var_part; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - } - else { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = tmp_loc(var_loc); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = var_sz; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", &"; - cd->ElemTyp(5) = A_ValLoc; - cd->ValLoc(5) = var_part; - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ");"; - } - cd_add(cd); - ++nparms; /* include variable part in call */ - } - - if (nparms > 0) { - free((char *)must_deref); - free((char *)single); - free((char *)arg_rslt); - } - - sbuf = (char *)alloc((unsigned int)(strlen(proc->name) + PrfxSz + 3)); - sprintf(sbuf, "P%s_%s", proc->prefix, proc->name); - if (nparms > 0) - arg1rslt = tmp_loc(arg_loc); - else - arg1rslt = NULL; - if (proc->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(sbuf, proc->ret_flag, arg1rslt, nargs, rslt, 1); - return rslt; - } - -/* - * endlife - link a temporary variable onto the list to be freed when - * execution reaches a node. - */ -static void endlife(kind, indx, old, n) -int kind; -int indx; -int old; -nodeptr n; - { - struct freetmp *freetmp; - - if ((freetmp = freetmp_pool) == NULL) - freetmp = NewStruct(freetmp); - else - freetmp_pool = freetmp_pool->next; - freetmp->kind = kind; - freetmp->indx = indx; - freetmp->old = old; - freetmp->next = n->freetmp; - n->freetmp = freetmp; - } - -/* - * alc_tmp - allocate a block of temporary variables with the given lifetimes. - */ -static int alc_tmp(num, lifetm_ary) -int num; -struct tmplftm *lifetm_ary; - { - int i, j, k; - register int status; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > status_sz) { - /* - * The status array is too small, expand it. - */ - new_size = status_sz + Max(num, status_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < status_sz) { - new_status[k] = tmp_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)tmp_status); - tmp_status = new_status; - status_sz = new_size; - } - for (j = 0; j < num; ++j) { - status = tmp_status[i + j]; - if (status != NotAlloc && - (status == InUse || status <= lifetm_ary[j].lifetime->postn)) - break; - } - /* - * Did we find a block of temporaries that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(DescTmp, i + j, tmp_status[i + j], lifetm_ary[j].lifetime); - tmp_status[i + j] = lifetm_ary[j].cur_status; - } - if (i + num > num_tmp) - num_tmp = i + num; - return i; - } - ++i; - } - } - -/* - * alc_lftm - allocate an array of lifetime information for an argument - * list. - */ -static struct tmplftm *alc_lftm(num, args) -int num; -union field *args; - { - struct tmplftm *lifetm_ary; - int i; - - lifetm_ary = (struct tmplftm *)alloc((unsigned int)(num * - sizeof(struct tmplftm))); - if (args != NULL) - for (i = 0; i < num; ++i) { - lifetm_ary[i].cur_status = args[i].n_ptr->postn; /* reserved for arg */ - lifetm_ary[i].lifetime = args[i].n_ptr->lifetime; - } - return lifetm_ary; - } - -/* - * alc_itmp - allocate a temporary C integer variable. - */ -int alc_itmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < istatus_sz && itmp_status[i] == InUse) - ++i; - if (i >= istatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)itmp_status); - new_size = istatus_sz * 2; - itmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < istatus_sz) - itmp_status[j++] = InUse; - while (j < new_size) - itmp_status[j++] = NotAlloc; - istatus_sz = new_size; - } - endlife(CIntTmp, i, NotAlloc, lifetime); - itmp_status[i] = InUse; - if (num_itmp < i + 1) - num_itmp = i + 1; - return i; - } - -/* - * alc_dtmp - allocate a temporary C integer variable. - */ -int alc_dtmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < dstatus_sz && dtmp_status[i] == InUse) - ++i; - if (i >= dstatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)dtmp_status); - new_size = dstatus_sz * 2; - dtmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < dstatus_sz) - dtmp_status[j++] = InUse; - while (j < new_size) - dtmp_status[j++] = NotAlloc; - dstatus_sz = new_size; - } - endlife(CDblTmp, i, NotAlloc, lifetime); - dtmp_status[i] = InUse; - if (num_dtmp < i + 1) - num_dtmp = i + 1; - return i; - } - -/* - * alc_sbufs - allocate a block of string buffers with the given lifetime. - */ -int alc_sbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > sstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = sstatus_sz + Max(num, sstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < sstatus_sz) { - new_status[k] = sbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)sbuf_status); - sbuf_status = new_status; - sstatus_sz = new_size; - } - for (j = 0; j < num && sbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(SBuf, i + j, sbuf_status[i + j], lifetime); - sbuf_status[i + j] = InUse; - } - if (i + num > num_sbuf) - num_sbuf = i + num; - return i; - } - ++i; - } - } - -/* - * alc_cbufs - allocate a block of cset buffers with the given lifetime. - */ -int alc_cbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > cstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = cstatus_sz + Max(num, cstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < cstatus_sz) { - new_status[k] = cbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)cbuf_status); - cbuf_status = new_status; - cstatus_sz = new_size; - } - for (j = 0; j < num && cbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(CBuf, i + j, cbuf_status[i + j], lifetime); - cbuf_status[i + j] = InUse; - } - if (i + num > num_cbuf) - num_cbuf = i + num; - return i; - } - ++i; - } - } |