summaryrefslogtreecommitdiff
path: root/src/iconc/inline.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/iconc/inline.c')
-rw-r--r--src/iconc/inline.c2007
1 files changed, 2007 insertions, 0 deletions
diff --git a/src/iconc/inline.c b/src/iconc/inline.c
new file mode 100644
index 0000000..234229c
--- /dev/null
+++ b/src/iconc/inline.c
@@ -0,0 +1,2007 @@
+/*
+ * inline.c - routines to put run-time routines in-line.
+ */
+#include "../h/gsupport.h"
+#include "ctrans.h"
+#include "ccode.h"
+#include "csym.h"
+#include "ctree.h"
+#include "cproto.h"
+#include "cglobals.h"
+
+/*
+ * Prototypes for static functions.
+ */
+static void arth_arg ( struct il_code *var,
+ struct val_loc *v_orig, int chk,
+ struct code *cnv);
+static int body_fnc (struct il_code *il);
+static void chkforblk (void);
+static void cnv_dest (int loc, int is_cstr,
+ struct il_code *src, int sym_indx,
+ struct il_c *dest, struct code *cd, int i);
+static void dwrd_asgn (struct val_loc *vloc, char *typ);
+static struct il_c *line_ilc (struct il_c *ilc);
+static int gen_if (struct code *cond_cd,
+ struct il_code *il_then,
+ struct il_code *il_else,
+ struct val_loc **locs);
+static int gen_il (struct il_code *il);
+static void gen_ilc (struct il_c *il);
+static void gen_ilret (struct il_c *ilc);
+static int gen_tcase (struct il_code *il, int has_dflt);
+static void il_var (struct il_code *il, struct code *cd,
+ int indx);
+static void mrg_locs (struct val_loc **locs);
+static struct code *oper_lbl (char *s);
+static void part_asgn (struct val_loc *vloc, char *asgn,
+ struct il_c *value);
+static void rstr_locs (struct val_loc **locs);
+static struct val_loc **sav_locs (void);
+static void sub_ilc (struct il_c *ilc, struct code *cd, int indx);
+
+/*
+ * There are many parameters that are shared by multiple routines. There
+ * are copied into statics.
+ */
+static struct val_loc *rslt; /* result location */
+static struct code **scont_strt; /* label following operation code */
+static struct code **scont_fail; /* resumption label for in-line suspend */
+static struct c_fnc *cont; /* success continuation */
+static struct implement *impl; /* data base entry for operation */
+static int nsyms; /* number symbols in operation symbol table */
+static int n_vararg; /* size of variable part of arg list */
+static nodeptr intrnl_lftm; /* lifetime of internal variables */
+static struct val_loc **tended; /* array of tended locals */
+
+/*
+ * gen_inlin - generate in-line code for an operation.
+ */
+void gen_inlin(il, r, strt, fail, c, ip, ns, st, n, dcl_var, n_va)
+struct il_code *il;
+struct val_loc *r;
+struct code **strt;
+struct code **fail;
+struct c_fnc *c;
+struct implement *ip;
+int ns;
+struct op_symentry *st;
+nodeptr n;
+int dcl_var;
+int n_va;
+ {
+ struct code *cd;
+ struct val_loc *tnd;
+ int i;
+
+ /*
+ * Copy arguments in to globals.
+ */
+ rslt = r;
+ scont_strt = strt;
+ scont_fail = fail;
+ cont = c;
+ impl = ip;
+ nsyms = ns;
+ cur_symtab = st;
+ intrnl_lftm = n->intrnl_lftm;
+ cur_symtyps = n->symtyps;
+ n_vararg = n_va;
+
+ /*
+ * Generate code to initialize local tended descriptors and determine
+ * how to access the descriptors.
+ */
+ for (i = 0; i < impl->ntnds; ++i) {
+ if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) {
+ tnd = chk_alc(NULL, n->intrnl_lftm);
+ switch (impl->tnds[i].var_type) {
+ case TndDesc:
+ cur_symtab[dcl_var].loc = tnd;
+ break;
+ case TndStr:
+ cd = alc_ary(2);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = tnd;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = " = emptystr;";
+ cd_add(cd);
+ cur_symtab[dcl_var].loc = loc_cpy(tnd, M_CharPtr);
+ break;
+ case TndBlk:
+ cd = alc_ary(2);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = tnd;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = " = nullptr;";
+ cd_add(cd);
+ cur_symtab[dcl_var].loc = loc_cpy(tnd, M_BlkPtr);
+ cur_symtab[dcl_var].loc->blk_name = impl->tnds[i].blk_name;
+ break;
+ }
+ if (impl->tnds[i].init != NULL) {
+ cd = alc_ary(4);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = cur_symtab[dcl_var].loc;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = " = ";
+ sub_ilc(impl->tnds[i].init, cd, 2);
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = ";";
+ cd_add(cd);
+ }
+ }
+ ++dcl_var;
+ }
+
+ /*
+ * If there are local non-tended variables, generate code for the
+ * declarations, placing everything in braces.
+ */
+ if (impl->nvars > 0) {
+ cd = NewCode(0);
+ cd->cd_id = C_LBrack; /* { */
+ cd_add(cd);
+ for (i = 0; i < impl->nvars; ++i) {
+ if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) {
+ gen_ilc(impl->vars[i].dcl);
+ cur_symtab[dcl_var].loc = cvar_loc(impl->vars[i].name);
+ }
+ ++dcl_var;
+ }
+ }
+
+ gen_il(il); /* generate executable code */
+
+ if (impl->nvars > 0) {
+ cd = NewCode(0);
+ cd->cd_id = C_RBrack; /* } */
+ cd_add(cd);
+ }
+ }
+
+/*
+ * gen_il - generate code from a sub-tree of in-line code from the data
+ * base. Determine if execution can continue past this code.
+ *
+ */
+static int gen_il(il)
+struct il_code *il;
+ {
+ struct code *cd;
+ struct code *cd1;
+ struct il_code *il_cond;
+ struct il_code *il_then;
+ struct il_code *il_else;
+ struct il_code *il_t;
+ struct val_loc **locs;
+ struct val_loc **locs1;
+ struct val_loc *tnd;
+ int fall_thru;
+ int cond;
+ int ncases;
+ int indx;
+ int ntended;
+ int i;
+
+ if (il == NULL)
+ return 1;
+
+ switch (il->il_type) {
+ case IL_Const: /* should have been replaced by literal node */
+ return 1;
+
+ case IL_If1:
+ case IL_If2:
+ /*
+ * if-then or if-then-else statement.
+ */
+ il_then = il->u[1].fld;
+ if (il->il_type == IL_If2)
+ il_else = il->u[2].fld;
+ else
+ il_else = NULL;
+ il_cond = il->u[0].fld;
+ if (il->u[0].fld->il_type == IL_Bang) {
+ il_cond = il_cond->u[0].fld;
+ il_t = il_then;
+ il_then = il_else;
+ il_else = il_t;
+ }
+ locs = sav_locs();
+ cond = cond_anlz(il_cond, &cd1);
+ if (cond == (MaybeTrue | MaybeFalse))
+ fall_thru = gen_if(cd1, il_then, il_else, locs);
+ else {
+ if (cd1 != NULL) {
+ cd_add(cd1); /* condition contains needed conversions */
+ cd = alc_ary(1);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = ";";
+ cd_add(cd);
+ }
+ if (cond == MaybeTrue)
+ fall_thru = gen_il(il_then);
+ else if (cond == MaybeFalse) {
+ locs1 = sav_locs();
+ rstr_locs(locs);
+ locs = locs1;
+ fall_thru = gen_il(il_else);
+ }
+ mrg_locs(locs);
+ }
+ return fall_thru;
+
+ case IL_Tcase1:
+ /*
+ * type_case statement with no default clause.
+ */
+ return gen_tcase(il, 0);
+
+ case IL_Tcase2:
+ /*
+ * type_case statement with a default clause.
+ */
+ return gen_tcase(il, 1);
+
+ case IL_Lcase:
+ /*
+ * len_case statement. Determine which case matches the number
+ * of arguments.
+ */
+ ncases = il->u[0].n;
+ indx = 1;
+ for (i = 0; i < ncases; ++i) {
+ if (il->u[indx++].n == n_vararg) /* selection number */
+ return gen_il(il->u[indx].fld); /* action */
+ ++indx;
+ }
+ return gen_il(il->u[indx].fld); /* default */
+
+ case IL_Acase: {
+ /*
+ * arith_case statement.
+ */
+ struct il_code *var1;
+ struct il_code *var2;
+ struct val_loc *v_orig1;
+ struct val_loc *v_orig2;
+ struct code *cnv1;
+ struct code *cnv2;
+ int maybe_int;
+ int maybe_dbl;
+ int chk1;
+ int chk2;
+
+ var1 = il->u[0].fld;
+ var2 = il->u[1].fld;
+ v_orig1 = cur_symtab[var1->u[0].n].loc; /* remember for error msgs */
+ v_orig2 = cur_symtab[var2->u[0].n].loc; /* remember for error msgs */
+ arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, &cnv1,
+ &chk2, &cnv2);
+
+ /*
+ * This statement is in-lined if there is only C integer
+ * arithmetic, only C double arithmetic, or only a run-time
+ * error.
+ */
+ arth_arg(var1, v_orig1, chk1, cnv1);
+ arth_arg(var2, v_orig2, chk2, cnv2);
+ if (maybe_int)
+ return gen_il(il->u[2].fld); /* C_integer action */
+ else if (maybe_dbl)
+ return gen_il(il->u[4].fld); /* C_double action */
+ else
+ return 0;
+ }
+
+ case IL_Err1:
+ /*
+ * runerr() with no offending value.
+ */
+ cd = alc_ary(3);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "err_msg(";
+ cd->ElemTyp(1) = A_Intgr;
+ cd->Intgr(1) = il->u[0].n;
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ", NULL);";
+ cd_add(cd);
+ if (err_conv)
+ cd_add(sig_cd(on_failure, cur_fnc));
+ for (i = 0; i < nsyms; ++i)
+ cur_symtab[i].loc = NULL;
+ return 0;
+
+ case IL_Err2:
+ /*
+ * runerr() with an offending value. Note the reference to
+ * the offending value descriptor.
+ */
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "err_msg(";
+ cd->ElemTyp(1) = A_Intgr;
+ cd->Intgr(1) = il->u[0].n;
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ", &(";
+ il_var(il->u[1].fld, cd, 3);
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = "));";
+ cd_add(cd);
+ if (err_conv)
+ cd_add(sig_cd(on_failure, cur_fnc));
+ for (i = 0; i < nsyms; ++i)
+ cur_symtab[i].loc = NULL;
+ return 0;
+
+ case IL_Lst:
+ /*
+ * Two consecutive pieces of RTL code.
+ */
+ fall_thru = gen_il(il->u[0].fld);
+ if (fall_thru)
+ fall_thru = gen_il(il->u[1].fld);
+ return fall_thru;
+
+ case IL_Block:
+ /*
+ * inline {...} statement.
+ *
+ * Allocate and initialize any tended locals.
+ */
+ ntended = il->u[1].n;
+ if (ntended > 0)
+ tended = (struct val_loc **)alloc((unsigned int)
+ sizeof(struct val_loc *) * ntended);
+ for (i = 2; i - 2 < ntended; ++i) {
+ tnd = chk_alc(NULL, intrnl_lftm);
+ tended[i - 2] = tnd;
+ switch (il->u[i].n) {
+ case TndDesc:
+ break;
+ case TndStr:
+ cd = alc_ary(2);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = tnd;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = " = emptystr;";
+ cd_add(cd);
+ break;
+ case TndBlk:
+ cd = alc_ary(2);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = tnd;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = " = nullptr;";
+ cd_add(cd);
+ break;
+ }
+ }
+ gen_ilc(il->u[i].c_cd); /* body of block */
+ /*
+ * See if execution can fall through this code.
+ */
+ if (il->u[0].n)
+ return 1;
+ else {
+ for (i = 0; i < nsyms; ++i)
+ cur_symtab[i].loc = NULL;
+ return 0;
+ }
+
+ case IL_Call:
+ /*
+ * call to body function.
+ */
+ return body_fnc(il);
+
+ case IL_Abstr:
+ /*
+ * abstract type computation. Only used by type inference.
+ */
+ return 1;
+
+ default:
+ fprintf(stderr, "compiler error: unknown info in data base\n");
+ exit(1);
+ /* NOTREACHED */
+ }
+ }
+
+/*
+ * arth_arg - in-line code to check a conversion for an arith_case statement.
+ */
+static void arth_arg(var, v_orig, chk, cnv)
+struct il_code *var;
+struct val_loc *v_orig;
+int chk;
+struct code *cnv;
+ {
+ struct code *lbl;
+ struct code *cd;
+
+ if (chk) {
+ /*
+ * Must check the conversion.
+ */
+ lbl = oper_lbl("converted");
+ cd_add(lbl);
+ cur_fnc->cursor = lbl->prev; /* code goes before label */
+ if (cnv != NULL) {
+ cd = NewCode(2);
+ cd->cd_id = C_If;
+ cd->Cond = cnv;
+ cd->ThenStmt = mk_goto(lbl);
+ cd_add(cd);
+ }
+ cd = alc_ary(3);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "err_msg(102, &(";
+ cd->ElemTyp(1) = A_ValLoc;
+ cd->ValLoc(1) = v_orig; /* var location before conversion */
+ 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 if (cnv != NULL) {
+ cd_add(cnv); /* conversion cannot fail */
+ cd = alc_ary(1);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = ";";
+ cd_add(cd);
+ }
+ }
+
+/*
+ * body_fnc - generate code to call a body function.
+ */
+static int body_fnc(il)
+struct il_code *il;
+ {
+ struct code *arg_lst;
+ struct code *cd;
+ struct c_fnc *cont1;
+ char *oper_nm;
+ int ret_val;
+ int ret_flag;
+ int need_rslt;
+ int num_sbuf;
+ int num_cbuf;
+ int expl_args;
+ int arglst_sz; /* size of arg list in number of code pieces */
+ int il_indx;
+ int cd_indx;
+ int proto_prt;
+ int i;
+
+ /*
+ * Determine if a function prototype has been printed yet for this
+ * body function.
+ */
+ proto_prt = il->u[0].n;
+ il->u[0].n = 1;
+
+ /*
+ * Construct the name of the body function.
+ */
+ oper_nm = (char *)alloc((unsigned int)(strlen(impl->name) + 6));
+ sprintf(oper_nm, "%c%c%c%c_%s", impl->oper_typ, impl->prefix[0],
+ impl->prefix[1], (char)il->u[1].n, impl->name);
+
+ /*
+ * Extract from the call the flags and other information describing
+ * the function, then use this information to deduce the arguments
+ * needed by the function.
+ */
+ ret_val = il->u[2].n;
+ ret_flag = il->u[3].n;
+ need_rslt = il->u[4].n;
+ num_sbuf = il->u[5].n;
+ num_cbuf = il->u[6].n;
+ expl_args = il->u[7].n;
+
+ /*
+ * determine how large the argument list is.
+ */
+ arglst_sz = 2 * expl_args - 1;
+ if (num_sbuf > 0)
+ arglst_sz += 3;
+ if (num_cbuf > 0)
+ arglst_sz += 2;
+ if (need_rslt)
+ arglst_sz += 3;
+ if (arglst_sz > 0)
+ arg_lst = alc_ary(arglst_sz);
+ else
+ arg_lst = alc_ary(0);
+
+ if (!proto_prt) {
+ /*
+ * Determine whether the body function returns a C integer, double,
+ * no value, or a signal.
+ */
+ switch (ret_val) {
+ case RetInt:
+ fprintf(inclfile, "C_integer %s (", oper_nm);
+ break;
+ case RetDbl:
+ fprintf(inclfile, "double %s (", oper_nm);
+ break;
+ case RetNoVal:
+ fprintf(inclfile, "void %s (", oper_nm);
+ break;
+ case RetSig:
+ fprintf(inclfile, "int %s (", oper_nm);
+ break;
+ }
+ }
+
+ /*
+ * Produce prototype and code for the explicit arguments in the
+ * function call. Note that the call entry contains C code for both.
+ */
+ il_indx = 8;
+ cd_indx = 0;
+ while (expl_args--) {
+ if (cd_indx > 0) {
+ /*
+ * Not first entry, precede by ','.
+ */
+ arg_lst->ElemTyp(cd_indx) = A_Str; /* , */
+ arg_lst->Str(cd_indx) = ", ";
+ if (!proto_prt)
+ fprintf(inclfile, ", ");
+ ++cd_indx;
+ }
+ if (!proto_prt)
+ fprintf(inclfile, "%s", il->u[il_indx].c_cd->s); /* parameter dcl */
+ ++il_indx;
+ sub_ilc(il->u[il_indx++].c_cd, arg_lst, cd_indx++);
+ }
+
+ /*
+ * If string buffers are needed, allocate them and pass pointer to
+ * function.
+ */
+ if (num_sbuf > 0) {
+ if (cd_indx > 0) {
+ /*
+ * Not first entry, precede by ','.
+ */
+ arg_lst->ElemTyp(cd_indx) = A_Str; /* , */
+ arg_lst->Str(cd_indx) = ", ";
+ if (!proto_prt)
+ fprintf(inclfile, ", ");
+ ++cd_indx;
+ }
+ arg_lst->ElemTyp(cd_indx) = A_Str;
+ arg_lst->Str(cd_indx) = "(char (*)[MaxCvtLen])";
+ ++cd_indx;
+ arg_lst->ElemTyp(cd_indx) = A_SBuf;
+ arg_lst->Intgr(cd_indx) = alc_sbufs(num_sbuf, intrnl_lftm);
+ if (!proto_prt)
+ fprintf(inclfile, "char (*r_sbuf)[MaxCvtLen]");
+ ++cd_indx;
+ }
+
+ /*
+ * If cset buffers are needed, allocate them and pass pointer to
+ * function.
+ */
+ if (num_cbuf > 0) {
+ if (cd_indx > 0) {
+ /*
+ * Not first entry, precede by ','.
+ */
+ arg_lst->ElemTyp(cd_indx) = A_Str; /* , */
+ arg_lst->Str(cd_indx) = ", ";
+ if (!proto_prt)
+ fprintf(inclfile, ", ");
+ ++cd_indx;
+ }
+ arg_lst->ElemTyp(cd_indx) = A_CBuf;
+ arg_lst->Intgr(cd_indx) = alc_cbufs(num_cbuf, intrnl_lftm);
+ if (!proto_prt)
+ fprintf(inclfile, "struct b_cset *r_cbuf");
+ ++cd_indx;
+ }
+
+ /*
+ * See if the function needs a pointer to the result location
+ * of the operation.
+ */
+ if (need_rslt) {
+ if (cd_indx > 0) {
+ /*
+ * Not first entry, precede by ','.
+ */
+ arg_lst->ElemTyp(cd_indx) = A_Str; /* , */
+ arg_lst->Str(cd_indx) = ", ";
+ if (!proto_prt)
+ fprintf(inclfile, ", ");
+ ++cd_indx;
+ }
+ arg_lst->ElemTyp(cd_indx) = A_Str; /* location of result */
+ arg_lst->Str(cd_indx) = "&";
+ ++cd_indx;
+ arg_lst->ElemTyp(cd_indx) = A_ValLoc;
+ arg_lst->ValLoc(cd_indx) = rslt;
+ if (!proto_prt)
+ fprintf(inclfile, "dptr rslt");
+ ++cd_indx;
+ }
+
+ if (!proto_prt) {
+ /*
+ * The last possible argument is the success continuation.
+ * If there are no arguments, indicate this in the prototype.
+ */
+ if (ret_flag & DoesSusp) {
+ if (cd_indx > 0)
+ fprintf(inclfile, ", ");
+ fprintf(inclfile, "continuation succ_cont");
+ }
+ else if (cd_indx == 0)
+ fprintf(inclfile, "void");
+ fprintf(inclfile, ");\n");
+ }
+
+ /*
+ * Does this call need the success continuation for the operation.
+ */
+ if (ret_flag & DoesSusp)
+ cont1 = cont;
+ else
+ cont1 = NULL;
+
+ switch (ret_val) {
+ case RetInt:
+ /*
+ * The body function returns a C integer.
+ */
+ cd = alc_ary(6);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = rslt;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = ".vword.integr = ";
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = oper_nm;
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = "(";
+ cd->ElemTyp(4) = A_Ary;
+ cd->Array(4) = arg_lst;
+ cd->ElemTyp(5) = A_Str;
+ cd->Str(5) = ");";
+ cd_add(cd);
+ dwrd_asgn(rslt, "Integer");
+ cd_add(mk_goto(*scont_strt));
+ break;
+ case RetDbl:
+ /*
+ * The body function returns a C double.
+ */
+ cd = alc_ary(6);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = rslt;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = ".vword.bptr = (union block *)alcreal(";
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = oper_nm;
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = "(";
+ cd->ElemTyp(4) = A_Ary;
+ cd->Array(4) = arg_lst;
+ cd->ElemTyp(5) = A_Str;
+ cd->Str(5) = "));";
+ cd_add(cd);
+ dwrd_asgn(rslt, "Real");
+ chkforblk(); /* make sure the block allocation succeeded */
+ cd_add(mk_goto(*scont_strt));
+ break;
+ case RetNoVal:
+ /*
+ * The body function does not directly return a value.
+ */
+ cd = alc_ary(4);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = oper_nm;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = "(";
+ cd->ElemTyp(2) = A_Ary;
+ cd->Array(2) = arg_lst;
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = ");";
+ cd_add(cd);
+ if (ret_flag & DoesFail | (err_conv && (ret_flag & DoesEFail)))
+ cd_add(sig_cd(on_failure, cur_fnc));
+ else if (ret_flag & DoesRet)
+ cd_add(mk_goto(*scont_strt));
+ break;
+ case RetSig:
+ /*
+ * The body function returns a signal.
+ */
+ callo_add(oper_nm, ret_flag, cont1, 0, arg_lst, mk_goto(*scont_strt));
+ break;
+ }
+ /*
+ * See if execution can fall through this call.
+ */
+ if (ret_flag & DoesFThru)
+ return 1;
+ else {
+ for (i = 0; i < nsyms; ++i)
+ cur_symtab[i].loc = NULL;
+ return 0;
+ }
+ }
+
+
+/*
+ * il_var - generate code for a possibly subscripted variable into
+ * an element of a code array.
+ */
+static void il_var(il, cd, indx)
+struct il_code *il;
+struct code *cd;
+int indx;
+ {
+ struct code *cd1;
+
+ if (il->il_type == IL_Subscr) {
+ /*
+ * Subscripted variable.
+ */
+ cd1 = cd;
+ cd = alc_ary(4);
+ cd1->ElemTyp(indx) = A_Ary;
+ cd1->Array(indx) = cd;
+ indx = 0;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = "[";
+ cd->ElemTyp(2) = A_Intgr;
+ cd->Intgr(2) = il->u[1].n;
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = "]";
+ }
+
+ /*
+ * See if this is the result location of the operation or an ordinary
+ * variable.
+ */
+ cd->ElemTyp(indx) = A_ValLoc;
+ if (il->u[0].n == RsltIndx)
+ cd->ValLoc(indx) = rslt;
+ else
+ cd->ValLoc(indx) = cur_symtab[il->u[0].n].loc;
+ }
+
+/*
+ * part_asgn - generate code for an assignment to (part of) a descriptor.
+ */
+static void part_asgn(vloc, asgn, value)
+struct val_loc *vloc;
+char *asgn;
+struct il_c *value;
+ {
+ struct code *cd;
+
+ cd = alc_ary(4);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = vloc;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = asgn;
+ sub_ilc(value, cd, 2); /* value */
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = ";";
+ cd_add(cd);
+ }
+
+/*
+ * dwrd_asgn - generate code to assign a type code to the dword of a descriptor.
+ */
+static void dwrd_asgn(vloc, typ)
+struct val_loc *vloc;
+char *typ;
+ {
+ struct code *cd;
+
+ cd = alc_ary(4);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = vloc;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = ".dword = D_";
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = typ;
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = ";";
+ cd_add(cd);
+ }
+
+/*
+ * sub_ilc - generate code from a sequence of C code and place it
+ * in a slot in a code array.
+ */
+static void sub_ilc(ilc, cd, indx)
+struct il_c *ilc;
+struct code *cd;
+int indx;
+ {
+ struct il_c *ilc1;
+ struct code *cd1;
+ int n;
+
+ /*
+ * Count the number of pieces of C code to process.
+ */
+ n = 0;
+ for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next)
+ ++n;
+
+ /*
+ * If there is only one piece of code, place it directly in the
+ * slot of the array. Otherwise allocate a sub-array and place it
+ * in the slot.
+ */
+ if (n > 1) {
+ cd1 = cd;
+ cd = alc_ary(n);
+ cd1->ElemTyp(indx) = A_Ary;
+ cd1->Array(indx) = cd;
+ indx = 0;
+ }
+
+ while (ilc != NULL) {
+ switch (ilc->il_c_type) {
+ case ILC_Ref:
+ case ILC_Mod:
+ /*
+ * Reference to variable in symbol table.
+ */
+ cd->ElemTyp(indx) = A_ValLoc;
+ if (ilc->n == RsltIndx)
+ cd->ValLoc(indx) = rslt;
+ else {
+ if (ilc->s == NULL)
+ cd->ValLoc(indx) = cur_symtab[ilc->n].loc;
+ else {
+ /*
+ * Access the entire descriptor.
+ */
+ cd->ValLoc(indx) = loc_cpy(cur_symtab[ilc->n].loc, M_None);
+ }
+ }
+ break;
+
+ case ILC_Tend:
+ /*
+ * Reference to a tended variable.
+ */
+ cd->ElemTyp(indx) = A_ValLoc;
+ cd->ValLoc(indx) = tended[ilc->n];
+ break;
+
+ case ILC_Str:
+ /*
+ * String representing C code.
+ */
+ cd->ElemTyp(indx) = A_Str;
+ cd->Str(indx) = ilc->s;
+ break;
+
+ case ILC_SBuf:
+ /*
+ * String buffer for a conversion.
+ */
+ cd->ElemTyp(indx) = A_SBuf;
+ cd->Intgr(indx) = alc_sbufs(1, intrnl_lftm);
+ break;
+
+ case ILC_CBuf:
+ /*
+ * Cset buffer for a conversion.
+ */
+ cd->ElemTyp(indx) = A_CBuf;
+ cd->Intgr(indx) = alc_cbufs(1, intrnl_lftm);
+ break;
+
+
+ default:
+ fprintf(stderr, "compiler error: unknown info in data base\n");
+ exit(1);
+ }
+ ilc = ilc->next;
+ ++indx;
+ }
+
+ }
+
+/*
+ * gen_ilret - generate code to set the result value from a suspend or
+ * return.
+ */
+static void gen_ilret(ilc)
+struct il_c *ilc;
+ {
+ struct il_c *ilc0;
+ struct code *cd;
+ char *cap_id;
+ int typcd;
+
+ if (rslt == &ignore)
+ return; /* Don't bother computing the result; it's never used */
+
+ ilc0 = ilc->code[0];
+ typcd = ilc->n;
+
+ if (typcd < 0) {
+ /*
+ * RTL returns that do not look like function calls to standard Icon
+ * type name.
+ */
+ switch (typcd) {
+ case TypCInt:
+ /*
+ * return/suspend C_integer <expr>;
+ */
+ part_asgn(rslt, ".vword.integr = ", ilc0);
+ dwrd_asgn(rslt, "Integer");
+ break;
+ case TypCDbl:
+ /*
+ * return/suspend C_double <expr>;
+ */
+ cd = alc_ary(4);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = rslt;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = ".vword.bptr = (union block *)alcreal(";
+ sub_ilc(ilc0, cd, 2); /* value */
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = ");";
+ cd_add(cd);
+ dwrd_asgn(rslt, "Real");
+ chkforblk(); /* make sure the block allocation succeeded */
+ break;
+ case TypCStr:
+ /*
+ * return/suspend C_string <expr>;
+ */
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "AsgnCStr(";
+ cd->ElemTyp(1) = A_ValLoc;
+ cd->ValLoc(1) = rslt;
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ", ";
+ sub_ilc(ilc0, cd, 3); /* <expr> */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ");";
+ cd_add(cd);
+ break;
+ case RetDesc:
+ /*
+ * return/suspend <expr>;
+ */
+ part_asgn(rslt, " = ", ilc0);
+ break;
+ case RetNVar:
+ /*
+ * return/suspend named_var(<desc-pntr>);
+ */
+ part_asgn(rslt, ".vword.descptr = ", ilc0);
+ dwrd_asgn(rslt, "Var");
+ break;
+ case RetSVar:
+ /*
+ * return/suspend struct_var(<desc-pntr>, <block_pntr>);
+ */
+ part_asgn(rslt, ".vword.descptr = (dptr)", ilc->code[1]);
+ cd = alc_ary(6);
+ cd->ElemTyp(0) = A_ValLoc;
+ cd->ValLoc(0) = rslt;
+ cd->ElemTyp(1) = A_Str;
+ cd->Str(1) = ".dword = D_Var + ((word *)";
+ sub_ilc(ilc0, cd, 2); /* value */
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = " - (word *)";
+ cd->ElemTyp(4) = A_ValLoc;
+ cd->ValLoc(4) = rslt;
+ cd->ElemTyp(5) = A_Str;
+ cd->Str(5) = ".vword.descptr);";
+ cd_add(cd);
+ break;
+ case RetNone:
+ /*
+ * return/suspend result;
+ *
+ * Result already set, do nothing.
+ */
+ break;
+ default:
+ fprintf(stderr,
+ "compiler error: unknown RLT return in data base\n");
+ exit(1);
+ /* NOTREACHED */
+ }
+ }
+ else {
+ /*
+ * RTL returns that look like function calls to standard Icon type
+ * names.
+ */
+ cap_id = icontypes[typcd].cap_id;
+ switch (icontypes[typcd].rtl_ret) {
+ case TRetBlkP:
+ /*
+ * return/suspend <type>(<block-pntr>);
+ */
+ part_asgn(rslt, ".vword.bptr = (union block *)", ilc0);
+ dwrd_asgn(rslt, cap_id);
+ break;
+ case TRetDescP:
+ /*
+ * return/suspend <type>(<descriptor-pntr>);
+ */
+ part_asgn(rslt, ".vword.descptr = (dptr)", ilc0);
+ dwrd_asgn(rslt, cap_id);
+ break;
+ case TRetCharP:
+ /*
+ * return/suspend <type>(<char-pntr>);
+ */
+ part_asgn(rslt, ".vword.sptr = (char *)", ilc0);
+ dwrd_asgn(rslt, cap_id);
+ break;
+ case TRetCInt:
+ /*
+ * return/suspend <type>(<integer>);
+ */
+ part_asgn(rslt, ".vword.integr = (word)", ilc0);
+ dwrd_asgn(rslt, cap_id);
+ break;
+ case TRetSpcl:
+ /*
+ * RTL returns that look like function calls to standard type
+ * names but take more than one argument.
+ */
+ if (typcd == str_typ) {
+ /*
+ * return/suspend string(<len>, <char-pntr>);
+ */
+ part_asgn(rslt, ".vword.sptr = ", ilc->code[1]);
+ part_asgn(rslt, ".dword = ", ilc0);
+ }
+ else if (typcd == stv_typ) {
+ /*
+ * return/suspend substr(<desc-pntr>, <start>, <len>);
+ */
+ cd = alc_ary(9);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "SubStr(&";
+ cd->ElemTyp(1) = A_ValLoc;
+ cd->ValLoc(1) = rslt;
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ", ";
+ sub_ilc(ilc0, cd, 3);
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", ";
+ sub_ilc(ilc->code[2], cd, 5);
+ cd->ElemTyp(6) = A_Str;
+ cd->Str(6) = ", ";
+ sub_ilc(ilc->code[1], cd, 7);
+ cd->ElemTyp(8) = A_Str;
+ cd->Str(8) = ");";
+ cd_add(cd);
+ chkforblk(); /* make sure the block allocation succeeded */
+ }
+ else {
+ fprintf(stderr,
+ "compiler error: unknown RLT return in data base\n");
+ exit(1);
+ /* NOTREACHED */
+ }
+ break;
+ default:
+ fprintf(stderr,
+ "compiler error: unknown RLT return in data base\n");
+ exit(1);
+ /* NOTREACHED */
+ }
+ }
+ }
+
+/*
+ * chkforblk - generate code to make sure the allocation of a block
+ * for the result descriptor was successful.
+ */
+static void chkforblk()
+ {
+ struct code *cd;
+ struct code *cd1;
+ struct code *lbl;
+
+ lbl = alc_lbl("got allocation", 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) = rslt;
+ cd1->ElemTyp(2) = A_Str;
+ cd1->Str(2) = ").vword.bptr != NULL";
+ cd->Cond = cd1;
+ cd->ThenStmt = mk_goto(lbl);
+ cd_add(cd);
+ cd = alc_ary(1);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "err_msg(307, NULL);";
+ cd_add(cd);
+ if (err_conv)
+ cd_add(sig_cd(on_failure, cur_fnc));
+ cur_fnc->cursor = lbl;
+ }
+
+/*
+ * gen_ilc - generate code for an sequence of in-line C code.
+ */
+static void gen_ilc(ilc)
+struct il_c *ilc;
+ {
+ struct il_c *ilc1;
+ struct code *cd;
+ struct code *cd1;
+ struct code *lbl1;
+ struct code *fail_sav;
+ struct code **lbls;
+ int max_lbl;
+ int i;
+
+ /*
+ * Determine how many labels there are in the code and allocate an
+ * array to map from label numbers to labels in the code.
+ */
+ max_lbl = -1;
+ for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) {
+ switch(ilc1->il_c_type) {
+ case ILC_CGto:
+ case ILC_Goto:
+ case ILC_Lbl:
+ if (ilc1->n > max_lbl)
+ max_lbl = ilc1->n;
+ }
+ }
+ ++max_lbl; /* adjust for 0 indexing */
+ if (max_lbl > 0) {
+ lbls = (struct code **)alloc((unsigned int) sizeof(struct code *) *
+ max_lbl);
+ for (i = 0; i < max_lbl; ++i)
+ lbls[i] = NULL;
+ }
+
+ while (ilc != NULL) {
+ switch(ilc->il_c_type) {
+ case ILC_Ref:
+ case ILC_Mod:
+ case ILC_Tend:
+ case ILC_SBuf:
+ case ILC_CBuf:
+ case ILC_Str:
+ /*
+ * The beginning of a sequence of code fragments that can be
+ * place on one line.
+ */
+ ilc = line_ilc(ilc);
+ break;
+
+ case ILC_Fail:
+ /*
+ * fail - perform failure action.
+ */
+ cd_add(sig_cd(on_failure, cur_fnc));
+ break;
+
+ case ILC_EFail:
+ /*
+ * errorfail - same as fail if error conversion is supported.
+ */
+ if (err_conv)
+ cd_add(sig_cd(on_failure, cur_fnc));
+ break;
+
+ case ILC_Ret:
+ /*
+ * return - set result location and jump out of operation.
+ */
+ gen_ilret(ilc);
+ cd_add(mk_goto(*scont_strt));
+ break;
+
+ case ILC_Susp:
+ /*
+ * suspend - set result location. If there is a success
+ * continuation, call it. Otherwise the "continuation"
+ * will be generated in-line, so set up a resumption label.
+ */
+ gen_ilret(ilc);
+ if (cont == NULL)
+ *scont_strt = cur_fnc->cursor;
+ lbl1 = oper_lbl("end suspend");
+ cd_add(lbl1);
+ if (cont == NULL)
+ *scont_fail = lbl1;
+ else {
+ cur_fnc->cursor = lbl1->prev;
+ fail_sav = on_failure;
+ on_failure = lbl1;
+ callc_add(cont);
+ on_failure = fail_sav;
+ cur_fnc->cursor = lbl1;
+ }
+ break;
+
+ case ILC_LBrc:
+ /*
+ * non-deletable '{'
+ */
+ cd = NewCode(0);
+ cd->cd_id = C_LBrack;
+ cd_add(cd);
+ break;
+
+ case ILC_RBrc:
+ /*
+ * non-deletable '}'
+ */
+ cd = NewCode(0);
+ cd->cd_id = C_RBrack;
+ cd_add(cd);
+ break;
+
+ case ILC_CGto:
+ /*
+ * Conditional goto.
+ */
+ i = ilc->n;
+ if (lbls[i] == NULL)
+ lbls[i] = oper_lbl("within");
+ cd = NewCode(2);
+ cd->cd_id = C_If;
+ cd1 = alc_ary(1);
+ sub_ilc(ilc->code[0], cd1, 0);
+ cd->Cond = cd1;
+ cd->ThenStmt = mk_goto(lbls[i]);
+ cd_add(cd);
+ break;
+
+ case ILC_Goto:
+ /*
+ * Goto.
+ */
+ i = ilc->n;
+ if (lbls[i] == NULL)
+ lbls[i] = oper_lbl("within");
+ cd_add(mk_goto(lbls[i]));
+ break;
+
+ case ILC_Lbl:
+ /*
+ * Label.
+ */
+ i = ilc->n;
+ if (lbls[i] == NULL)
+ lbls[i] = oper_lbl("within");
+ cd_add(lbls[i]);
+ break;
+
+ default:
+ fprintf(stderr, "compiler error: unknown info in data base\n");
+ exit(1);
+ }
+ ilc = ilc->next;
+ }
+
+ if (max_lbl > 0)
+ free((char *)lbls);
+ }
+
+/*
+ * line_ilc - gather a line of in-line code.
+ */
+static struct il_c *line_ilc(ilc)
+struct il_c *ilc;
+ {
+ struct il_c *ilc1;
+ struct il_c *last;
+ struct code *cd;
+ int n;
+ int i;
+
+ /*
+ * Count the number of pieces in the line. Determine the last
+ * piece in the sequence; this is returned to the caller.
+ */
+ n = 0;
+ ilc1 = ilc;
+ while (ilc1 != NULL) {
+ switch(ilc1->il_c_type) {
+ case ILC_Ref:
+ case ILC_Mod:
+ case ILC_Tend:
+ case ILC_SBuf:
+ case ILC_CBuf:
+ case ILC_Str:
+ ++n;
+ last = ilc1;
+ ilc1 = ilc1->next;
+ break;
+ default:
+ ilc1 = NULL;
+ }
+ }
+
+ /*
+ * Construct the line.
+ */
+ cd = alc_ary(n);
+ for (i = 0; i < n; ++i) {
+ switch(ilc->il_c_type) {
+ case ILC_Ref:
+ case ILC_Mod:
+ /*
+ * Reference to variable in symbol table.
+ */
+ cd->ElemTyp(i) = A_ValLoc;
+ if (ilc->n == RsltIndx)
+ cd->ValLoc(i) = rslt;
+ else
+ cd->ValLoc(i) = cur_symtab[ilc->n].loc;
+ break;
+
+ case ILC_Tend:
+ /*
+ * Reference to a tended variable.
+ */
+ cd->ElemTyp(i) = A_ValLoc;
+ cd->ValLoc(i) = tended[ilc->n];
+ break;
+
+ case ILC_SBuf:
+ /*
+ * String buffer for a conversion.
+ */
+ cd->ElemTyp(i) = A_SBuf;
+ cd->Intgr(i) = alc_sbufs(1, intrnl_lftm);
+ break;
+
+ case ILC_CBuf:
+ /*
+ * Cset buffer for a conversion.
+ */
+ cd->ElemTyp(i) = A_CBuf;
+ cd->Intgr(i) = alc_cbufs(1, intrnl_lftm);
+ break;
+
+ case ILC_Str:
+ /*
+ * String representing C code.
+ */
+ cd->ElemTyp(i) = A_Str;
+ cd->Str(i) = ilc->s;
+ break;
+
+ default:
+ ilc = NULL;
+ }
+ ilc = ilc->next;
+ }
+
+ cd_add(cd);
+ return last;
+ }
+
+/*
+ * generate code to perform simple type checking.
+ */
+struct code *typ_chk(var, typcd)
+struct il_code *var;
+int typcd;
+ {
+ struct code *cd;
+
+ if (typcd == int_typ && largeints) {
+ /*
+ * Handle large integer support specially.
+ */
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "((";
+ il_var(var, cd, 1); /* value */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ").dword == D_Integer || (";
+ il_var(var, cd, 3); /* value */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ").dword == D_Lrgint)";
+ return cd;
+ }
+ else if (typcd < 0) {
+ /*
+ * Not a standard Icon type name.
+ */
+ cd = alc_ary(3);
+ cd->ElemTyp(0) = A_Str;
+ switch (typcd) {
+ case TypVar:
+ cd->Str(0) = "(((";
+ il_var(var, cd, 1); /* value */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ").dword & D_Var) == D_Var)";
+ break;
+ case TypCInt:
+ cd->Str(0) = "((";
+ il_var(var, cd, 1); /* value */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ").dword == D_Integer)";
+ break;
+ }
+ }
+ else if (typcd == str_typ) {
+ cd = alc_ary(3);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(!((";
+ il_var(var, cd, 1); /* value */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ").dword & F_Nqual))";
+ }
+ else {
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "((";
+ il_var(var, cd, 1); /* value */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ").dword == D_";
+ cd->ElemTyp(3) = A_Str;
+ cd->Str(3) = icontypes[typcd].cap_id; /* type name */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ")";
+ }
+
+ return cd;
+ }
+
+/*
+ * oper_lbl - generate a label with an associated comment that includes
+ * the operation name.
+ */
+static struct code *oper_lbl(s)
+char *s;
+ {
+ char *sbuf;
+
+ sbuf = (char *)alloc((unsigned int)(strlen(s) + strlen(impl->name) + 3));
+ sprintf(sbuf, "%s: %s", s, impl->name);
+ return alc_lbl(sbuf, 0);
+ }
+
+/*
+ * sav_locs - save the current interpretation of symbols that may
+ * be affected by conversions.
+ */
+static struct val_loc **sav_locs()
+ {
+ struct val_loc **locs;
+ int i;
+
+ if (nsyms == 0)
+ return NULL;
+
+ locs = (struct val_loc **)alloc((unsigned int)(nsyms *
+ sizeof(struct val_loc *)));
+ for (i = 0; i < nsyms; ++i)
+ locs[i] = cur_symtab[i].loc;
+ return locs;
+ }
+
+/*
+ * rstr_locs - restore the interpretation of symbols that may
+ * have been affected by conversions.
+ */
+static void rstr_locs(locs)
+struct val_loc **locs;
+ {
+ int i;
+
+ for (i = 0; i < nsyms; ++i)
+ cur_symtab[i].loc = locs[i];
+ free((char *)locs);
+ }
+
+/*
+ * mrg_locs - merge the interpretations of symbols along two execution
+ * paths. Any ambiguity is caught by rtt, so differences only occur
+ * if one path involves program termination so that the symbols
+ * no longer have an interpretation along that path.
+ */
+static void mrg_locs(locs)
+struct val_loc **locs;
+ {
+ int i;
+
+ for (i = 0; i < nsyms; ++i)
+ if (cur_symtab[i].loc == NULL)
+ cur_symtab[i].loc = locs[i];
+ free((char *)locs);
+ }
+
+/*
+ * il_cnv - generate code for an in-line conversion.
+ */
+struct code *il_cnv(typcd, src, dflt, dest)
+int typcd;
+struct il_code *src;
+struct il_c *dflt;
+struct il_c *dest;
+ {
+ struct code *cd;
+ struct code *cd1;
+ int dflt_to_ptr;
+ int loc;
+ int is_cstr;
+ int sym_indx;
+ int n;
+ int i;
+
+ sym_indx = src->u[0].n;
+
+ /*
+ * Determine whether the address must be taken of a default value and
+ * whether the interpretation of the symbol in an in-place conversion
+ * changes.
+ */
+ dflt_to_ptr = 0;
+ loc = PrmTend;
+ is_cstr = 0;
+ switch (typcd) {
+ case TypCInt:
+ case TypECInt:
+ loc = PrmInt;
+ break;
+ case TypCDbl:
+ loc = PrmDbl;
+ break;
+ case TypCStr:
+ is_cstr = 1;
+ break;
+ case TypEInt:
+ break;
+ case TypTStr:
+ case TypTCset:
+ dflt_to_ptr = 1;
+ break;
+ default:
+ /*
+ * Cset, real, integer, or string
+ */
+ if (typcd == cset_typ || typcd == str_typ)
+ dflt_to_ptr = 1;
+ break;
+ }
+
+ if (typcd == TypCDbl && !(eval_is(real_typ, sym_indx) & MaybeFalse)) {
+ /*
+ * Conversion from Icon real to C double. Just copy the C value
+ * from the block.
+ */
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(GetReal(&(";
+ il_var(src, cd, 1);
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = "), ";
+ cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 3);
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = "), 1)";
+ }
+ else if (typcd == TypCDbl && !largeints &&
+ !(eval_is(int_typ, sym_indx) & MaybeFalse)) {
+ /*
+ * Conversion from Icon integer (not large integer) to C double.
+ * Do as a C conversion by an assigment.
+ */
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(";
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = " = IntVal( ";
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = "), 1)";
+ /*
+ * Note that cnv_dest() must be called after the source is output
+ * in case it changes the location of the parameter.
+ */
+ il_var(src, cd, 3);
+ cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 1);
+ }
+ else {
+ /*
+ * Compute the number of code fragments required to construct the
+ * call to the conversion routine.
+ */
+ n = 7;
+ if (dflt != NULL)
+ n += 2;
+
+ cd = alc_ary(n);
+
+ /*
+ * The names of simple conversions are distinguished from defaulting
+ * conversions by a prefix of "cnv_" or "def_".
+ */
+ cd->ElemTyp(0) = A_Str;
+ if (dflt == NULL)
+ cd->Str(0) = "cnv_";
+ else
+ cd->Str(0) = "def_";
+
+ /*
+ * Determine the name of the conversion routine.
+ */
+ cd->ElemTyp(1) = A_Str; /* may be overridden */
+ switch (typcd) {
+ case TypCInt:
+ cd->Str(1) = "c_int(&(";
+ break;
+ case TypCDbl:
+ cd->Str(1) = "c_dbl(&(";
+ break;
+ case TypCStr:
+ cd->Str(1) = "c_str(&(";
+ break;
+ case TypEInt:
+ cd->Str(1) = "eint(&(";
+ break;
+ case TypECInt:
+ cd->Str(1) = "ec_int(&(";
+ break;
+ case TypTStr:
+ /*
+ * Allocate a string buffer.
+ */
+ cd1 = alc_ary(3);
+ cd1->ElemTyp(0) = A_Str;
+ cd1->Str(0) = "tstr(";
+ cd1->ElemTyp(1) = A_SBuf;
+ cd1->Intgr(1) = alc_sbufs(1, intrnl_lftm);
+ cd1->ElemTyp(2) = A_Str;
+ cd1->Str(2) = ", (&";
+ cd->ElemTyp(1) = A_Ary;
+ cd->Array(1) = cd1;
+ break;
+ case TypTCset:
+ /*
+ * Allocate a cset buffer.
+ */
+ cd1 = alc_ary(3);
+ cd1->ElemTyp(0) = A_Str;
+ cd1->Str(0) = "tcset(";
+ cd1->ElemTyp(1) = A_CBuf;
+ cd1->Intgr(1) = alc_cbufs(1, intrnl_lftm);
+ cd1->ElemTyp(2) = A_Str;
+ cd1->Str(2) = ", &(";
+ cd->ElemTyp(1) = A_Ary;
+ cd->Array(1) = cd1;
+ break;
+ default:
+ /*
+ * Cset, real, integer, or string
+ */
+ if (typcd == cset_typ)
+ cd->Str(1) = "cset(&(";
+ else if (typcd == real_typ)
+ cd->Str(1) = "real(&(";
+ else if (typcd == int_typ)
+ cd->Str(1) = "int(&(";
+ else if (typcd == str_typ)
+ cd->Str(1) = "str(&(";
+ break;
+ }
+
+ il_var(src, cd, 2);
+
+ cd->ElemTyp(3) = A_Str;
+ if (dflt != NULL && dflt_to_ptr)
+ cd->Str(3) = "), &(";
+ else
+ cd->Str(3) = "), ";
+
+
+ /*
+ * Determine if this conversion has a default value.
+ */
+ i = 4;
+ if (dflt != NULL) {
+ sub_ilc(dflt, cd, i);
+ ++i;
+ cd->ElemTyp(i) = A_Str;
+ if (dflt_to_ptr)
+ cd->Str(i) = "), ";
+ else
+ cd->Str(i) = ", ";
+ ++i;
+ }
+
+ cd->ElemTyp(i) = A_Str;
+ cd->Str(i) = "&(";
+ ++i;
+ cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i);
+ ++i;
+ cd->ElemTyp(i) = A_Str;
+ cd->Str(i) = "))";
+ }
+ return cd;
+ }
+
+/*
+ * il_dflt - generate code for a defaulting conversion that always defaults.
+ */
+struct code *il_dflt(typcd, src, dflt, dest)
+int typcd;
+struct il_code *src;
+struct il_c *dflt;
+struct il_c *dest;
+ {
+ struct code *cd;
+ int sym_indx;
+
+ sym_indx = src->u[0].n;
+
+ if (typcd == TypCDbl) {
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(";
+ cnv_dest(PrmDbl, 0, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = " = ";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", 1)";
+ }
+ else if (typcd == TypCInt || typcd == TypECInt) {
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(";
+ cnv_dest(PrmInt, 0, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = " = ";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", 1)";
+ }
+ else if (typcd == TypTStr || typcd == str_typ) {
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = " = ";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", 1)";
+ }
+ else if (typcd == TypCStr) {
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(AsgnCStr(";
+ cnv_dest(0, 1, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ", ";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = "), 1)";
+ }
+ else if (typcd == TypTCset || typcd == cset_typ) {
+ cd = alc_ary(7);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(BlkLoc(";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ") = (union block *)&";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", ";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */
+ cd->ElemTyp(6) = A_Str;
+ cd->Str(6) = ".dword = D_Cset, 1)";
+ }
+ else if (typcd == TypEInt || typcd == int_typ) {
+ cd = alc_ary(7);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(IntVal(";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ") = ";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", ";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */
+ cd->ElemTyp(6) = A_Str;
+ cd->Str(6) = ".dword = D_Integer, 1)";
+ }
+ else if (typcd == real_typ) {
+ cd = alc_ary(7);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "((BlkLoc(";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = ") = (union block *)alcreal(";
+ sub_ilc(dflt, cd, 3); /* default */
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ")) == NULL ? (fatalerr(0,NULL), 0) : (";
+ cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */
+ cd->ElemTyp(6) = A_Str;
+ cd->Str(6) = ".dword = D_Real, 1))";
+ }
+
+ return cd;
+ }
+
+/*
+ * cnv_dest - output the destination of a conversion.
+ */
+static void cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i)
+int loc;
+int is_cstr;
+struct il_code *src;
+int sym_indx;
+struct il_c *dest;
+struct code *cd;
+int i;
+ {
+ if (dest == NULL) {
+ /*
+ * Convert "in place", changing the location of a parameter if needed.
+ */
+ switch (loc) {
+ case PrmInt:
+ if (cur_symtab[sym_indx].itmp_indx < 0)
+ cur_symtab[sym_indx].itmp_indx = alc_itmp(intrnl_lftm);
+ cur_symtab[sym_indx].loc = itmp_loc(cur_symtab[sym_indx].itmp_indx);
+ break;
+ case PrmDbl:
+ if (cur_symtab[sym_indx].dtmp_indx < 0)
+ cur_symtab[sym_indx].dtmp_indx = alc_dtmp(intrnl_lftm);
+ cur_symtab[sym_indx].loc = dtmp_loc(cur_symtab[sym_indx].dtmp_indx);
+ break;
+ }
+ il_var(src, cd, i);
+ if (is_cstr)
+ cur_symtab[sym_indx].loc = loc_cpy(cur_symtab[sym_indx].loc,M_CharPtr);
+ }
+ else {
+ if (is_cstr && dest->il_c_type == ILC_Mod && dest->next == NULL &&
+ dest->n != RsltIndx && cur_symtab[dest->n].loc->mod_access != M_None) {
+ /*
+ * We are converting to a C string. The destination variable
+ * is not defined as a simple descriptor, but must be accessed
+ * as such for this conversion.
+ */
+ cd->ElemTyp(i) = A_ValLoc;
+ cd->ValLoc(i) = loc_cpy(cur_symtab[dest->n].loc, M_None);
+ }
+ else
+ sub_ilc(dest, cd, i);
+ }
+
+ }
+
+/*
+ * il_copy - produce code for an optimized "conversion" that always succeeds
+ * and just copies a value from one place to another.
+ */
+struct code *il_copy(dest, src)
+struct il_c *dest;
+struct val_loc *src;
+ {
+ struct code *cd;
+
+ cd = alc_ary(5);
+ cd->ElemTyp(0) = A_Str;
+ cd->Str(0) = "(";
+ sub_ilc(dest, cd, 1);
+ cd->ElemTyp(2) = A_Str;
+ cd->Str(2) = " = ";
+ cd->ElemTyp(3) = A_ValLoc;
+ cd->ValLoc(3) = src;
+ cd->ElemTyp(4) = A_Str;
+ cd->Str(4) = ", 1)";
+ return cd;
+ }
+
+/*
+ * loc_cpy - make a copy of a reference to a value location, but change
+ * the way the location is accessed.
+ */
+struct val_loc *loc_cpy(loc, mod_access)
+struct val_loc *loc;
+int mod_access;
+ {
+ struct val_loc *new_loc;
+
+ if (loc == NULL)
+ return NULL;
+ new_loc = NewStruct(val_loc);
+ *new_loc = *loc;
+ new_loc->mod_access = mod_access;
+ return new_loc;
+ }
+
+/*
+ * gen_tcase - generate in-line code for a type_case statement.
+ */
+static int gen_tcase(il, has_dflt)
+struct il_code *il;
+int has_dflt;
+ {
+ struct case_anlz case_anlz;
+
+ /*
+ * We can only get here if the type_case statement can be implemented
+ * with a no more than one type check. Determine how simple the
+ * code can be.
+ */
+ findcases(il, has_dflt, &case_anlz);
+ if (case_anlz.il_then == NULL) {
+ if (case_anlz.il_else == NULL)
+ return 1;
+ else
+ return gen_il(case_anlz.il_else);
+ }
+ else
+ return gen_if(typ_chk(il->u[0].fld, case_anlz.typcd), case_anlz.il_then,
+ case_anlz.il_else, sav_locs());
+ }
+
+/*
+ * gen_if - generate code to test a condition that might be true
+ * of false. Determine if execution can continue past this if statement.
+ */
+static int gen_if(cond_cd, il_then, il_else, locs)
+struct code *cond_cd;
+struct il_code *il_then;
+struct il_code *il_else;
+struct val_loc **locs;
+ {
+ struct val_loc **locs1;
+ struct code *lbl_then;
+ struct code *lbl_end;
+ struct code *else_loc;
+ struct code *cd;
+ int fall_thru;
+
+ lbl_then = oper_lbl("then");
+ lbl_end = oper_lbl("end if");
+ cd = NewCode(2);
+ cd->cd_id = C_If;
+ cd->Cond = cond_cd;
+ cd->ThenStmt = mk_goto(lbl_then);
+ cd_add(cd);
+ else_loc = cur_fnc->cursor;
+ cd_add(lbl_then);
+ fall_thru = gen_il(il_then);
+ cd_add(lbl_end);
+ locs1 = sav_locs();
+ rstr_locs(locs);
+ cur_fnc->cursor = else_loc; /* go back for the else clause */
+ fall_thru |= gen_il(il_else);
+ cd_add(mk_goto(lbl_end));
+ cur_fnc->cursor = lbl_end;
+ mrg_locs(locs1);
+ return fall_thru;
+ }
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-03 04:20:07 +0000