diff options
Diffstat (limited to 'src/iconc/ccode.c')
| -rw-r--r-- | src/iconc/ccode.c | 4954 |
1 files changed, 4954 insertions, 0 deletions
diff --git a/src/iconc/ccode.c b/src/iconc/ccode.c new file mode 100644 index 0000000..108cd15 --- /dev/null +++ b/src/iconc/ccode.c @@ -0,0 +1,4954 @@ +/* + * 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; + } + } |