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, 0 insertions, 2007 deletions
diff --git a/src/iconc/inline.c b/src/iconc/inline.c
deleted file mode 100644
index 234229c..0000000
--- a/src/iconc/inline.c
+++ /dev/null
@@ -1,2007 +0,0 @@
-/*
- * 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 2025-07-17 13:38:47 +0000