home *** CD-ROM | disk | FTP | other *** search
/* * tcode.c - routines to produce internal representation of C code. */ #include "::h:gsupport.h" #include "trans.h" #include "globals.h" #include "tsym.h" #include "tcode.h" #include "tree.h" #include "token.h" #include "tlex.h" #include "tproto.h" /* * Prototypes for static functions. */ hidden struct c_fnc *alc_fnc Params((noargs)); hidden struct tmplftm *alc_lftm Params((int num, union field *args)); hidden int alc_tmp Params((int n, struct tmplftm *lifetm_ary)); hidden struct code *asgn_null Params((struct val_loc *loc1)); hidden struct val_loc *bound Params((struct node *n, struct val_loc *rslt, int catch_fail)); hidden struct code *check_var Params((struct val_loc *d, struct code *lbl)); hidden novalue deref_cd Params((struct val_loc *src, struct val_loc *dest)); hidden novalue deref_ret Params((struct val_loc *src, struct val_loc *dest, int subtypes)); hidden novalue endlife Params((int kind, int indx, int old, nodeptr n)); hidden struct val_loc *field_ref Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *gen_act Params((nodeptr n, struct val_loc *rslt)); hidden struct val_loc *gen_apply Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *gen_args Params((struct node *n, int frst_arg, int nargs)); hidden struct val_loc *gen_case Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *gen_creat Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *gen_lim Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *gen_scan Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *gencode Params((struct node *n, struct val_loc *rslt)); hidden struct val_loc *genretval Params((struct node *n, struct node *expr, struct val_loc *dest)); hidden struct val_loc *inv_prc Params((nodeptr n, struct val_loc *rslt)); hidden struct val_loc *inv_op Params((nodeptr n, struct val_loc *rslt)); hidden nodeptr max_lftm Params((nodeptr n1, nodeptr n2)); hidden novalue mk_callop Params((char *oper_nm, int ret_flag, struct val_loc *arg1rslt, int nargs, struct val_loc *rslt, int optim)); hidden struct code *mk_cpyval Params((struct val_loc *loc1, struct val_loc *loc2)); hidden struct code *new_call Params((noargs)); hidden char *oper_name Params((struct implement *impl)); hidden novalue restr_env Params((struct val_loc *sub_sav, struct val_loc *pos_sav)); hidden novalue save_env Params((struct val_loc *sub_sav, struct val_loc *pos_sav)); hidden novalue setloc Params((nodeptr n)); hidden struct val_loc *tmp_loc Params((int n)); hidden struct val_loc *var_ref Params((struct lentry *sym)); hidden struct val_loc *vararg_sz Params((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 */ 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 */ /* * staticly declared "signals". */ struct code resume; struct code contin; struct code fallthru; struct code next_fail; int lbl_seq_num = 0; /* next label sequence number */ /* * proccode - generate code for a procedure. */ novalue 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; /* * 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 */ /* * 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(); /* * 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); /* * 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); } /* * 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(ErrorExit); } /* * 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 *singl= mize it. Allocate contiguous temporaries for e ope s to the lifetm_ary = alc_lftm(2, >n_field[1]) mp_indx = alc_tmp(2, l = tmp_loc(tmp_indx++); asgn2 = tmp_loc(tmp_indx ree((char *) * e code to produce the left-hand-side of the a * This is also the tted Activation may need a * dereferenced value, so thi st be in a different location. gencode( t gn t loc = chk_alc(NULL, ftm p); d ret(asgn1, trans_loc yp( t e, NULL) se t loc retval( it, NULL); /* ord y activation */ /* * Determine if the value activated needs dereferencing, and * see if it can onl ome from a s . */ c r( yp( xpr e, &c_single) (c == NULL) The something other than a si iable co loc = de( xpr, if (c cd( xpr_loc, co loc * The v a n ariable. se it di from the * variable r r th g the result gencode( xpr ; c _loc _ref(c_si e sur activated is a co-expression. Perform * run-time checking if ssary. */ c mt = n->symt l_ xp 1) ay { lbl("is c ression ); c bl- v; /* c befo cd cd-> f; cd1 emTyp(0 tr(0) e co xpr ).d == D_Coexpr = m o(l ; cd cd-> cd-> " sg(118, & cd-> ; cd-> xpr ")); ; (e ) sor = } /* * e sure a result location has been allocated. For ord nary * activation, thi is where activate() puts it esult. Fo * au vation, this is where ment puts it result alc(rs ->lifetim G rslt = asgn2; else r lt; e code to call activate */ n); d_id = = alc_ary(7) "activate trans_loc; , (struct b_coexpr *)BlkLoc( ; >ValLoc( xpr loc; tr( >ElemTyp( A_Va alLoc( act >ElemTyp(6 >Str(6) ) == A_Resume ond enS ur_fnc) cd); Fo a nted activation, generate code to call ment. G T) { impl = op oc y (impl = nfatal(op not implemented", NULL); rslt e; /* ure neration can continue */ } i to(impl); er_name(i impl->ret_flag, , 2, rslt, 0); } } re slt; } /* * env - g de to nviro novalue s _sav, pos_sav) struct val_loc *sub_sav; struct val_loc *pos_sav; ct code *cd; (2); ; cd-> sub_sav; cd->Ele cd-> " = ect cd_add(cd); = alc_ary( d->Va pos_sav; cd->Ele = os cd_add(cd); } /* * restr_env code to nviro tic novalue _env(sub_sav, pos_sav) l_loc *sub_sav al_loc *pos_sav; c cd; ( cd->Ele Typ( tr(0) t = ; cd-> sub_sav; cd->Ele c ); cd _pos = oc; cd-> pos_sav; cd /* * mk_callop roduce the code to ectl all an operation. */ static novalue er_nm, ret_flag, arg1rslt, nargs, rslt, o m) char *oper_nm; int ret_flag a rg1rslt; int nargs; l ; int o m; { struct code *ar code *on_ struct c_fnc *fnc; int int need_cont f this can return an ignal, we need * a break statement in the signal switch to */ if (ret_flag & et) { = NewCode( /* ields == ields C_Goto */ on_ et = C_ on_ e next = NULL; on_ e else on_ e = NULL; /* * Construct for the C function nting the * . First te the size of the code array for the * argument list; thi varies if we are g an optimized calling * interface (optim) { n = 0; if (arg1rslt ! n += 2 (ret_flag & ( et | DoesSusp)) { if (n > 0) ++n; n += 2 } } e n = 7 n == 0) = NULL; se { = alc_ary(n); n = 0; if (!optim) { ElemTyp(n) = A_Intgr; /* number of arguments */ Intgr(n) = nargs; ++n; ElemTyp(n) = /* , */ n) = ", "; ++n; arg1rslt == NULL) { location of first argument */ if (!o m) { ElemTyp(n) = tr(n) = "NULL"; ++n; Ele n) = tr(n) = ""; /* nothing, but must fill slot */ ++n; } } se { Ele Typ(n) = a >Str(n) = " ++n; >ElemTyp(n ; >ValLoc(n) = arg1rslt; ++n; } !o tim ret_flag & ( et oesSusp if (n > 0) { ElemTyp(n = A_Str; /* , */ Str(n) = ", "; ++n; } >ElemTyp(n) = A_Str; /* locatio result */ tr(n) = "&"; ++n; >ElemTyp(n ; Loc(n) = rslt; } } de to call the operation and returned signals (ret_flag & DoesSusp * The s, so call it with a ation, then * proceed to generate code in the fnc = alc_fn ; c add(oper_nm, ret_flag c, 1 , on_ e ); if (ret_flag & et) (fn nc = fnc; o resume; } e { * N tinuation is needed, but i tandard calling c ntions * are used, a NULL ation quire if tim) need_cont = 0; else ed_cont ; c llo_add(oper_nm, ret_flag, NULL, need_cont _lst, on_ret } enretval - g nerate e ex in a return/ or * for the or the be tted in a * context switch ic 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 novalue 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 *)argp, (word *)(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 code *lbl1; 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. */ novalue 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. */ novalue 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. */ novalue 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->Sig * cat arg ts me and generate code for the nts he de genera depe on the ki of optimizations t are sible, though in general, de ci wait il all nts are computed. Because there may be h d un me for nt, the s ol le inde does not alwa ch rgu inde . */ i o inde */ for (j j s && j j /* * Us pe inferenci g if the * arg migh it a single * known le. */ [j HasVar(varsubtyp(n->n_f [FrstArg + j ptr->type, single[j] /* * ne how ny t the nt ced. If we * optimize awa state because we 't d the * , those ces 't co into nt * that there ma bo and un ence * parame rs arg * == nore s - ; = s ef ; l j & (RtP | D ; if ( = (RtP rm | D f ef + + + + n_ ; i fs == 0) { /* * Indi that we on't need the rgu value (we must * still per the computation in case it side effects). */ &i re; st = Adj * Decide whe the resu arg nt be * ect he meter. * if ( == (RtP | D f && ef + s n s == 0 * We have h dereference d nd enced me * t don't se the un ced one so i re it. * s djust = Adj ; D rm; } if ( == D f rm && single[j] L) { We need on dereference lue, t know what variable * s in. We 't d the compu nt value, we will * get it di f the v le. If it is o do * so, we will pointe le as t e argu nt * . lt re; ef(single[j ); if (s ar_ st = Adj else st = AdjCpy; } * rm e argum ied the * ; g le i icat n_ ods != 0); if ( = D rm) y |= var[j]; ->n_field[FrstArg + j n_ptr->reuse && od / * The arameter y be re out recompu ing rgum nt the v may be modified he * nt cat on the a * be se te so the me s reloaded upon * each cat o lt = chk_a NULL >n_f eld[FrstArg + j n ptr->lifetime); if ( == D f rm && ay var[j ) s . st = Adj D f ar */ else djust = AdjCpy; /* value on y copy */ } lse { / * Argu nt resu cat o will act as me r l . * Its lifetime be as s bot e * the rgum nt and the arame (o rnal * lifet ). * lt alc(NULL m(n-> > [FrstArg + j n ptr fet me)); if ( == D rm && var[j] d = AdjD f /* var must d ence else d ust = Adj } oc = a } } * Generate th rg t. gencode(n-> eld[FrstArg + j ptr, ar ; if ( = (RtP | D f rm) /* * We have compu ed t alue un nced meter * decide w to get the value. */ ; if (s . efs + n s == 0 s d = Adj not d, i nore */ if (single[j] != NULL) { * The value is i specific on variable, get it f * e. s is to le e y * op do so. oc = ef(single[j] ; if ( afe) d ust = Adj else djust = AdjCp } else { * here m le ce, not it * be dereference . O wise ide her the argu nt cation be for h the * and n me r. */ oc = a if ( var[j] d = AdjND f else if (s n + n_ o == 0 . st = Adj else d ust = AdjCp } } ; } * l out me r wi null values. */ while (j int k, kn; kn if ( s[j & RtP rm) +kn; -> l j D f +kn; for (k = 0; k kn k if (s . + . { lt = chk c(NULL n-> ; cd_add(asgn_null( lt oc = a lt; } . djust = Adj ; ; } ++ } * mpu e rgu nt */ + s; /* add me back into me r list */ * The v le he a r list mus in contiguous * ors. te nd life ays for use in * ati the escr ors. 0 lt (s oc( f(s loc * m_ = alc_ m(n , NULL) g_ s[j] & (RtP rm | D rm); /* * Compu e me e el var me r ay. or (v v ++v) { * Us infor ion renci to de e * rgu nt mig m le he her s ngle * known med . may ar[j + v HasVar(varsubtyp( n-> eld[FrstArg+j+v n pt type, &(single[j + v * rmine if the el of t a me er ay * m gh be ied. If s , de nci g * ie . ay = ( j n s != 0); if ( == D f rm) od |= ay [j + v]; if ((fl == D fPrm && ingle[j + v L) (n-> _f eld[FrstArg + j + v n pt ->reuse && od * The argu nt value i me r * ay during cing". So the life of t e ar * el is t e lifetim me r nd the element * is not il g. */ life m_ ry[v .life me = n ntr m; life m_ary[v cur_status ost } * The argum nt compute me er a . The life m the r el encompasses both * fet m rg th er. The * el is as soon s t e nt is compu . l m_ary[v .life m = m n-> ntr m, n-> _f eld[FrstArg+j+v pt life m ); m_ary[v ur_status = n >n_field[FrstArg+j+v .n_ptr ost } } * (reserve) r of t he * * (n { oc = alc_ (n gs, l m_ary); free((cha )life m_ary); } /* * Gen code to compu e arg ts. * for (v v v) { od j n != 0); if ( == D f rm) ay |= y var[j + v ; if ( = D f rm && ingle[j + v] != NULL We need enced value s in a know a * ; on't bo her saving the resu he * nt compu ation. * r = & r } else if (n->n_f [FrstArg + j + v] pt ->reuse && ay * The arg t can ithout be ecompu e d * he a me r y be ied, so annot ly * compu e the rg t into rg me r ; we * compu e it else re copy (de ce) it at the * beginni o . et gencode a gum nt * . } else { * We compu e rg tly into the v * me r . r = c( oc + v); } rslt[v = gencode(n-> _field[FrstArg + j + v] pt , r); } s c( * De ce or copy arg nt values t at are not a in * me r list. Preced rgu nt e de ced later, ut * s okay if g out-of-order. */ for (v v v if ( == D fPrm && single[j + v L) { / * Copy the v ue he known into the * me r list. rslt[v = var_ ingle[j + v ); cd_add(mk_cpyval( c( oc + v var lt[v } else if ( == D f rm && ay var[j + v] { * ence the rg int me r lis * eref_cd( rslt[v , t loc( oc + v)); } lse if ( oc + v != rslt[v /* * The arg is a value, ut is not t in the a er list; copy here. cd_add(mk_cpyval( c( oc + v), v lt[v ); } status[ oc + v InUs * me r l in use * The v me r gets t e dd the first el ent * of t e arg nt th si * me r gets t e f el nts in t ist. */ i 0 { free((c ) rslt); oc = t loc( oc); } lse chk_a c(NULL, n /* dummy arg oc _Addr; ++ oc = gs); ; } el * Compute extra arg nts, t di ard the resu s. while (j args gencode(n-> _f [FrstArg + j n ptr, &i re); ++ } { ree((c ) var); free((c ar *)single); } * If execution does not nu rough the me r evaluation 't to genera code. A lack of me r types ill cause proble some sions. */ ! t_prms(n) return rslt; s c(n); ; /* * Per or any ded copying or g. { switch ( d ust case AdjND f: * ce into w t ry which is sed as t e * arame er. * arg lt = chk_a c(NULL n ntr ; oc, ar lt); oc = lt; br k; case AdjD f: * De nc o oc); br ak; case AdjCp : * Copy int a new which sed as t e * me r. * lt = chk_a c(NULL n > ntr ); cd_add(mk_cpyval( lt .loc .loc = lt; br ak; case AdjNone: br ak * nothi need be e * } } switch (c loc { case SepFnc: uc uation be in a se arate * fnc = alc_ ); (c a ) gn strlen l-> ) + 5)); f(s , " %s", ; strt = l(s , 0 ; cd_add(s s ); cur_fnc->cursor = s s ->prev; /* put op r before label gen in l n_line, rslt, &s s t, NULL fnc, i d ar ); c ursor = s strt; callc_add(fnc); cur_fnc = fnc; o ailure br ak case SContIL: * one suspe no return su s continuation is put ne. gen in in_line, rslt, & t_strt, &s fail, NULL, ab l_var g c ursor s t; on_failure = s fail; b case dOper: / * no suspends suc uation goes at of . */ = (cha *) int)(strlen l me) + 5)); f(s , " nd %s", ); s = alc_lbl(s , 0); cd_add( t ); c r_fnc->cursor s - rev * put before lbl */ gen in l in_ , rslt, &s s t, NULL, NULL, i ar, g c ursor strt; b k /* * Do not n * i proto( ); t_ = gen args(n, 2, nargs ; s c( if l-> ( et | D r chk c , rslt ); mk_c p(oper_ l ag, frst_arg, s, rslt 0); if (s L) ree((cha *) eturn - given two lifetimes n th rm odes) the * im one c m(n n2) ode 1; n2 1 == NULL) urn n2; else if (n2 ) return n ; else if (n1->postn n2->postn) return n ; e urn n2 /* * prc - di ect y inv a re c prc odep n; loc *rslt; struct pe *proc r; loc *arg1 loc *var_ t; _deref ngle lt; *cd; struct *l m_ar c s n s; i, t a c; * ro re is i mented out nt list st or * g, s y be e before the call al n er rgu nt */ proc = Proc ); = Abs(pro ->nargs ; s { _deref = ( ) gn (n s f( ); = ( ) gn int)(n f uct *) lt = uct v o gned (n loc * } * or rea ie use rgu nt ist. If g t be re ithout be ecompu ed, it not * be compu ed e tly into the ar . It will be copied or * ence the when execution reaches t e * op ration. If rgu nt le can * be de nc d d t nt rg . These * condi affect when the y will receive */ life m_ary = alc_ (n ms, NULL); ) life m_ary life m = n > ; for ( s && s ) { _deref = HasVar(varsubtyp(n-> _f eld[FrstArg + ptr->type, single[ if (single[ ] != NULL n-> _f eld[FrstArg n pt ->reuse life m_ary cur_statu ->post ; else l m_ar cur_status = > _f eld[FrstArg + ptr t while ) { life m_ary cur_statu - ost /* list extension */ ; } if (proc- ) l m_ar - cur_statu - tn; t */ 0 { oc = alc_ ( , l fetm_ ry); ree((c )life m_ary); } if (pro - ) * tr t speciall 0; s && ) { if (single[ L) r = & re; /* we know r e de ferenced value is else if (n-> _field[FrstArg + n pt ->re se r et gencod w y */ else t oc( oc ); lt[ = gencode(n->n_f eld[FrstArg pt , r); } /* * If ne ary, fill out nt list nulls while ( ) { cd_add(asgn_null( loc( oc + i statu [ oc + = InUs } if (pr s < 0 { handl t of */ - if ( { life m_ary = alc_l ( , &n->n_f eld[FrstArg n ] ; c = alc_ ( , lifetm_ ry); free((c ar *)life m_ary); or (j j j gencode(n->n_f eld[FrstArg + + j n_ptr, c( c + j } e { here ar extra arg nts, compute them, but di card the * results. */ while args { gencode(n->n_f [FrstArg + pt , n ; ; s c( ); /* * D ence or copy nt values that a e not alr y in arg nt * list s ence values. */ 0; && ++ ) { if ( _deref if (single[ == NULL) deref_cd( lt[ ], t oc + else { lt[ ] = var_ ef(single[ ]); cd_add(mk_cpyval( c( oc + lt[ ] } } el (n-> _f [FrstArg + pt re se) add(mk_cpyval( c( g_loc i , ar rslt[ ); statu [ oc = InUse proc- s 0) { var_ t = c( g_loc + ; statu [ g_loc + InUse <= 0 { cd = alc_ary(3 >ElemTyp(0 cd->S " (NULL, 0 cd->ElemTyp(1 c; cd->ValLoc(1) = var_ ; cd->ElemTyp(2) = A_Str; cd->Str(2) = ");"; } else { cd = alc_ary( ; cd-> cd->Str(0) = " ( cd->ElemTyp(1) = A_ValLoc; cd->ValLoc(1) = c( ar_loc ; cd-> lemTyp(2 cd->S ", "; cd-> lemTyp( _Intgr; cd->Intgr(3) = var_s cd->ElemTyp( A_Str; cd->Str(4) = " cd->ElemTyp(5) = A_ValLoc; cd->ValLoc(5) = var_ ; cd-> lemTyp(6 cd->Str(6 = " } /* ude in call } { free((c ar *) _deref); ree((c a *)single); free((c a ) lt); } s = (cha *) gn )(strlen proc- + + 3) f(s , "P%s_%s", proc- , pro - ); 0 arg1 t loc( oc se arg1 if (pr c-> a ( et | D sp r chk alc(rslt >life m ); mk_c p(s , , ar 1 slt, gs, rslt, 1); return r /* * endlife - ry the list to be freed when * execution reache node c ue endlife(ki d, indx, old, n kind; i ndx; i t old; odep n truct free *free f ((free f ee pool) == NULL) free p = free mp se free m pool = free m _pool-> ree p->ki d = ki d; free p-> n ndx; ree mp-> = old; ree p-> n->free m ->free p = free p alc_ block of t ry ith the en life m / st int alc_ mp(num, l fetm_ ry) num; struct fetm , , k; re int status w_status ize; i (;;) { if + status * The statu ar is too sm expand i * ize = statu + Max(num, status s ); tatu nt o int)( ize f( k = 0; while (k status sz tatu [k status[k ; +k wh (k ize) { tatu [k = Not c; ++k; } free((c a *) statu statu w_statu ; status sz w_size or (j j um j { status = statu + j ; i (s atu != Not && (statu == InUse status <= life m_ary j life m ->post b } /* * Did we find a block of t es that we c use? if (j == num) { while ( j >= 0 { endlife( cTmp, i + j, t tatu [ + j , l fe ary[j l me); statu + j life m_ary j cur_statu if + num num_ num_ + num return } ; /* * alc_l ar ay of me info tion for g ment * truct alc_l tm(num, ar um union * { struct fetm t i; l m_ar ruct *) gn (num f(s ruct if ( != NULL 0; n m; ++ ) { life m_ary cur_statu = a s[ pt ->postn; /* erved for arg life m_ary .l me = a s ptr->l me; } return life m_ary alc_ inte . int alc_ (life m ) odeptr life m , ize; i while ( istatu && statu = InUse) ; if ( >= istatu s ) * The statu ay is too small, exp */ free((cha *) status); ize status sz * 2 i statu = ( nt ) oc( gn int)( ize * f nt) j while (j istatu i statu j++ InUs wh le (j ize statu [j++ tA ; istatus sz w_size; } endlife(CIntTmp, i, Not lifet ); i statu = InUs um_ + 1) num_ urn alc_ e a inte er variable. */ int alc_ p(life m ) life m , j w_size while ( tatu s && p atu [ == InUs ) >= dstatus sz) { * tatu too sm exp nd i . */ free((c a *) p status) ize = dstatu s * 2 d statu = nt ) gned (n ize ); j wh (j tatu s ) p statu [j++ InUse wh le (j ize statu j++ = NotA tatu s w_ endlife(CDblTmp, i, NotA oc, lifet me); p statu [ InUs f (num_ p + 1) num_ p 1 alc_s s e a block of string fer i he en l me. */ int lc_s s(num, lifet me) um; odep life m , j, k; w atu w_siz i for (;;) { if + m sstatus sz) { * tatu ay is too small, exp . w_siz = sstatus sz + Max(num, tatu s ); tatu = nt *) o gn )(n w_siz f( t) ); k = 0; while (k sstatus sz) { new_statu [k s atus[k ; +k while (k ize) { n tatu [k = Not c; +k; } ree((c )s status) s statu = tatus; sstatus sz new_siz for (j j um && s atus[ + j ot oc; ++j ; * Did we find a block of f that we can se? j = num) { while ( j = 0 { endlife(SB , + j, s status + j , lifet me); atus + j = InUs } if + num num_s num_s + num; return ; } alc_c s a e a block set f rs the gi life m . */ int alc_c s(num, life m ) um; l me; t i, , k tatu nt n ize; (;;) { if ( + num cstatu s ) { * tatu ay is too sm exp . */ ize = cstatus sz + Max(num, cstatus sz); tatu nt *) ( ize f nt k = 0; while (k cstatu sz { tatu [k c status k ; ++k wh le (k ize { tatu [k ot oc; +k } free((cha *)c f_status) c statu = tatus; cstatus sz ize or (j j && c f atus + j == Not oc j ; * Did we find a block of fer that we use? if j = n m while ( j >= 0) { endlife(CB f, i + j, c statu [ + j , l fe ); c statu [ + j InUs + n n m_c num_c f + m; eturn } 
