home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / src / iconc / inline.c < prev    next >
C/C++ Source or Header  |  2000-07-29  |  58KB  |  2,008 lines
  1. /*
  2.  * inline.c - routines to put run-time routines in-line.
  3.  */
  4. #include "../h/gsupport.h"
  5. #include "ctrans.h"
  6. #include "ccode.h"
  7. #include "csym.h"
  8. #include "ctree.h"
  9. #include "cproto.h"
  10. #include "cglobals.h"
  11.  
  12. /*
  13.  * Prototypes for static functions.
  14.  */
  15. static void          arth_arg  ( struct il_code *var,
  16.                                     struct val_loc *v_orig, int chk,
  17.                                     struct code *cnv);
  18. static int              body_fnc  (struct il_code *il);
  19. static void          chkforblk (void);
  20. static void          cnv_dest  (int loc, int is_cstr,
  21.                                     struct il_code *src, int sym_indx,
  22.                                     struct il_c *dest, struct code *cd, int i);
  23. static void          dwrd_asgn (struct val_loc *vloc, char *typ);
  24. static struct il_c     *line_ilc  (struct il_c *ilc);
  25. static int              gen_if    (struct code *cond_cd,
  26.                                     struct il_code *il_then,
  27.                                     struct il_code *il_else,
  28.                                     struct val_loc **locs);
  29. static int              gen_il    (struct il_code *il);
  30. static void          gen_ilc   (struct il_c *il);
  31. static void          gen_ilret (struct il_c *ilc);
  32. static int              gen_tcase (struct il_code *il, int has_dflt);
  33. static void          il_var    (struct il_code *il, struct code *cd,
  34.                                     int indx);
  35. static void          mrg_locs  (struct val_loc **locs);
  36. static struct code     *oper_lbl  (char *s);
  37. static void          part_asgn (struct val_loc *vloc, char *asgn,
  38.                                     struct il_c *value);
  39. static void          rstr_locs (struct val_loc **locs);
  40. static struct val_loc **sav_locs  (void);
  41. static void         sub_ilc    (struct il_c *ilc, struct code *cd, int indx);
  42.  
  43. /*
  44.  * There are many parameters that are shared by multiple routines. There
  45.  *  are copied into statics.
  46.  */
  47. static struct val_loc *rslt;     /* result location */
  48. static struct code **scont_strt; /* label following operation code */
  49. static struct code **scont_fail; /* resumption label for in-line suspend */
  50. static struct c_fnc *cont;       /* success continuation */
  51. static struct implement *impl;   /* data base entry for operation */
  52. static int nsyms;                /* number symbols in operation symbol table */
  53. static int n_vararg;             /* size of variable part of arg list */
  54. static nodeptr intrnl_lftm;      /* lifetime of internal variables */
  55. static struct val_loc **tended;  /* array of tended locals */
  56.  
  57. /*
  58.  * gen_inlin - generate in-line code for an operation.
  59.  */
  60. void gen_inlin(il, r, strt, fail, c, ip, ns, st, n, dcl_var, n_va)
  61. struct il_code *il;
  62. struct val_loc *r;
  63. struct code **strt;
  64. struct code **fail;
  65. struct c_fnc *c;
  66. struct implement *ip;
  67. int ns;
  68. struct op_symentry *st;
  69. nodeptr n;
  70. int dcl_var;
  71. int n_va;
  72.    {
  73.    struct code *cd;
  74.    struct val_loc *tnd;
  75.    int i;
  76.  
  77.    /*
  78.     * Copy arguments in to globals.
  79.     */
  80.    rslt = r;
  81.    scont_strt = strt;
  82.    scont_fail = fail;
  83.    cont = c;
  84.    impl = ip;
  85.    nsyms = ns;
  86.    cur_symtab = st;
  87.    intrnl_lftm = n->intrnl_lftm;
  88.    cur_symtyps = n->symtyps;
  89.    n_vararg = n_va;
  90.  
  91.    /*
  92.     * Generate code to initialize local tended descriptors and determine
  93.     *  how to access the descriptors.
  94.     */
  95.    for (i = 0; i < impl->ntnds; ++i) {
  96.       if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) {
  97.          tnd = chk_alc(NULL, n->intrnl_lftm);
  98.           switch (impl->tnds[i].var_type) {
  99.              case TndDesc:
  100.                 cur_symtab[dcl_var].loc = tnd; 
  101.                 break;
  102.              case TndStr:
  103.                 cd = alc_ary(2);
  104.                 cd->ElemTyp(0) = A_ValLoc;
  105.                 cd->ValLoc(0) =                tnd;
  106.                 cd->ElemTyp(1) = A_Str;
  107.                 cd->Str(1) =                   " = emptystr;";
  108.                 cd_add(cd);
  109.                 cur_symtab[dcl_var].loc = loc_cpy(tnd, M_CharPtr);
  110.                 break;
  111.              case TndBlk:
  112.                 cd = alc_ary(2);
  113.                 cd->ElemTyp(0) = A_ValLoc;
  114.                 cd->ValLoc(0) =                tnd;
  115.                 cd->ElemTyp(1) = A_Str;
  116.                 cd->Str(1) =                   " = nullptr;"; 
  117.                 cd_add(cd);
  118.                 cur_symtab[dcl_var].loc = loc_cpy(tnd, M_BlkPtr);
  119.                 cur_symtab[dcl_var].loc->blk_name = impl->tnds[i].blk_name;
  120.                 break;
  121.              }
  122.          if (impl->tnds[i].init != NULL) {
  123.              cd = alc_ary(4);
  124.              cd->ElemTyp(0) = A_ValLoc;
  125.              cd->ValLoc(0) =                cur_symtab[dcl_var].loc;
  126.              cd->ElemTyp(1) = A_Str;
  127.              cd->Str(1) =                   " = "; 
  128.              sub_ilc(impl->tnds[i].init, cd, 2);
  129.              cd->ElemTyp(3) = A_Str;
  130.              cd->Str(3) =                   ";"; 
  131.              cd_add(cd);
  132.              }
  133.          }
  134.       ++dcl_var;
  135.       }
  136.  
  137.    /*
  138.     * If there are local non-tended variables, generate code for the
  139.     *  declarations, placing everything in braces.
  140.      */
  141.    if (impl->nvars > 0) {
  142.       cd = NewCode(0);
  143.       cd->cd_id = C_LBrack;    /* { */
  144.       cd_add(cd);
  145.       for (i = 0;  i < impl->nvars; ++i) {
  146.          if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) {
  147.             gen_ilc(impl->vars[i].dcl);
  148.             cur_symtab[dcl_var].loc = cvar_loc(impl->vars[i].name);
  149.             }
  150.          ++dcl_var;
  151.          }
  152.       }
  153.  
  154.    gen_il(il);  /* generate executable code */
  155.  
  156.    if (impl->nvars > 0) {
  157.       cd = NewCode(0);
  158.       cd->cd_id = C_RBrack;    /* } */
  159.       cd_add(cd);
  160.       }
  161.    }
  162.  
  163. /*
  164.  * gen_il - generate code from a sub-tree of in-line code from the data
  165.  *  base. Determine if execution can continue past this code.
  166.  *
  167.  */
  168. static int gen_il(il)
  169. struct il_code *il;
  170.    {
  171.    struct code *cd;
  172.    struct code *cd1;
  173.    struct il_code *il_cond;
  174.    struct il_code *il_then;
  175.    struct il_code *il_else;
  176.    struct il_code *il_t;
  177.    struct val_loc **locs;
  178.    struct val_loc **locs1;
  179.    struct val_loc *tnd;
  180.    int fall_thru;
  181.    int cond;
  182.    int ncases;
  183.    int indx;
  184.    int ntended;
  185.    int i;
  186.  
  187.    if (il == NULL)
  188.       return 1;
  189.  
  190.    switch (il->il_type) {
  191.       case IL_Const: /* should have been replaced by literal node */
  192.          return 1;
  193.  
  194.       case IL_If1:
  195.       case IL_If2:
  196.          /*
  197.           * if-then or if-then-else statement.
  198.           */
  199.          il_then = il->u[1].fld;
  200.          if (il->il_type == IL_If2)
  201.             il_else = il->u[2].fld;
  202.          else
  203.             il_else = NULL;
  204.          il_cond = il->u[0].fld;
  205.          if (il->u[0].fld->il_type == IL_Bang) {
  206.             il_cond = il_cond->u[0].fld;
  207.             il_t = il_then;
  208.             il_then = il_else;
  209.             il_else = il_t;
  210.             }
  211.          locs = sav_locs();
  212.          cond = cond_anlz(il_cond, &cd1);
  213.          if (cond == (MaybeTrue | MaybeFalse))
  214.             fall_thru = gen_if(cd1, il_then, il_else, locs);
  215.          else {
  216.             if (cd1 != NULL) {
  217.                cd_add(cd1);  /* condition contains needed conversions */
  218.                cd = alc_ary(1);
  219.                cd->ElemTyp(0) = A_Str;
  220.                cd->Str(0) =              ";";
  221.                cd_add(cd);
  222.                }
  223.             if (cond == MaybeTrue)
  224.                fall_thru = gen_il(il_then);
  225.             else if (cond == MaybeFalse) {
  226.                locs1 = sav_locs();
  227.                rstr_locs(locs);
  228.                locs = locs1;
  229.                fall_thru = gen_il(il_else);
  230.                }
  231.             mrg_locs(locs);
  232.             }
  233.          return fall_thru;
  234.  
  235.       case IL_Tcase1:
  236.          /*
  237.           * type_case statement with no default clause.
  238.           */
  239.          return gen_tcase(il, 0);
  240.  
  241.       case IL_Tcase2:
  242.          /*
  243.           * type_case statement with a default clause.
  244.           */
  245.          return gen_tcase(il, 1);
  246.  
  247.       case IL_Lcase:
  248.          /*
  249.           * len_case statement. Determine which case matches the number
  250.           *  of arguments.
  251.           */
  252.          ncases = il->u[0].n;
  253.          indx = 1;
  254.          for (i = 0; i < ncases; ++i) {
  255.             if (il->u[indx++].n == n_vararg)    /* selection number */
  256.                return gen_il(il->u[indx].fld);  /* action */
  257.             ++indx;
  258.             }
  259.          return gen_il(il->u[indx].fld);        /* default */
  260.  
  261.       case IL_Acase: {
  262.          /*
  263.           * arith_case statement.
  264.           */
  265.          struct il_code *var1;
  266.          struct il_code *var2;
  267.          struct val_loc *v_orig1;
  268.          struct val_loc *v_orig2;
  269.          struct code *cnv1;
  270.          struct code *cnv2;
  271.          int maybe_int;
  272.          int maybe_dbl;
  273.          int chk1;
  274.          int chk2;
  275.  
  276.          var1 = il->u[0].fld;
  277.          var2 = il->u[1].fld;
  278.          v_orig1 = cur_symtab[var1->u[0].n].loc;  /* remember for error msgs */
  279.          v_orig2 = cur_symtab[var2->u[0].n].loc;  /* remember for error msgs */
  280.          arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, &cnv1,
  281.            &chk2, &cnv2);
  282.  
  283.          /*
  284.           * This statement is in-lined if there is only C integer
  285.           *  arithmetic, only C double arithmetic, or only a run-time
  286.           *  error.
  287.           */
  288.          arth_arg(var1, v_orig1, chk1, cnv1);
  289.          arth_arg(var2, v_orig2, chk2, cnv2);
  290.          if (maybe_int)
  291.             return gen_il(il->u[2].fld);     /* C_integer action */
  292.          else if (maybe_dbl)
  293.             return gen_il(il->u[4].fld);     /* C_double action */
  294.          else
  295.             return 0;
  296.          }
  297.  
  298.       case IL_Err1:
  299.          /*
  300.           * runerr() with no offending value.
  301.           */
  302.          cd = alc_ary(3);
  303.          cd->ElemTyp(0) = A_Str;
  304.          cd->Str(0) =              "err_msg(";
  305.          cd->ElemTyp(1) = A_Intgr;
  306.          cd->Intgr(1) =            il->u[0].n;
  307.          cd->ElemTyp(2) = A_Str;
  308.          cd->Str(2) =              ", NULL);";
  309.          cd_add(cd);
  310.          if (err_conv)
  311.             cd_add(sig_cd(on_failure, cur_fnc));
  312.          for (i = 0; i < nsyms; ++i)
  313.             cur_symtab[i].loc = NULL;
  314.          return 0;
  315.  
  316.       case IL_Err2:
  317.          /*
  318.           * runerr() with an offending value. Note the reference to
  319.           *  the offending value descriptor.
  320.           */
  321.          cd = alc_ary(5);
  322.          cd->ElemTyp(0) = A_Str;
  323.          cd->Str(0) =              "err_msg(";
  324.          cd->ElemTyp(1) = A_Intgr;
  325.          cd->Intgr(1) =            il->u[0].n;
  326.          cd->ElemTyp(2) = A_Str;
  327.          cd->Str(2) =              ", &(";
  328.          il_var(il->u[1].fld, cd, 3);
  329.          cd->ElemTyp(4) = A_Str;
  330.          cd->Str(4) =              "));";
  331.          cd_add(cd);
  332.          if (err_conv)
  333.             cd_add(sig_cd(on_failure, cur_fnc));
  334.          for (i = 0; i < nsyms; ++i)
  335.             cur_symtab[i].loc = NULL;
  336.          return 0;
  337.  
  338.       case IL_Lst:
  339.          /*
  340.           * Two consecutive pieces of RTL code.
  341.           */
  342.          fall_thru = gen_il(il->u[0].fld);
  343.          if (fall_thru)
  344.             fall_thru = gen_il(il->u[1].fld);
  345.          return fall_thru;
  346.  
  347.       case IL_Block:
  348.          /*
  349.           * inline {...} statement.
  350.           *
  351.           *  Allocate and initialize any tended locals.
  352.           */
  353.          ntended = il->u[1].n;
  354.          if (ntended > 0)
  355.             tended = (struct val_loc **)alloc((unsigned int)
  356.                sizeof(struct val_loc *) * ntended);
  357.          for (i = 2; i - 2 < ntended; ++i) {
  358.              tnd = chk_alc(NULL, intrnl_lftm);
  359.              tended[i - 2] = tnd;
  360.              switch (il->u[i].n) {
  361.                 case TndDesc:
  362.                    break;
  363.                 case TndStr:
  364.                    cd = alc_ary(2);
  365.                    cd->ElemTyp(0) = A_ValLoc;
  366.                    cd->ValLoc(0) =                tnd;
  367.                    cd->ElemTyp(1) = A_Str;
  368.                    cd->Str(1) =                   " = emptystr;";
  369.                    cd_add(cd);
  370.                    break;
  371.                 case TndBlk:
  372.                    cd = alc_ary(2);
  373.                    cd->ElemTyp(0) = A_ValLoc;
  374.                    cd->ValLoc(0) =                tnd;
  375.                    cd->ElemTyp(1) = A_Str;
  376.                    cd->Str(1) =                   " = nullptr;"; 
  377.                    cd_add(cd);
  378.                    break;
  379.                 }
  380.             }
  381.          gen_ilc(il->u[i].c_cd);    /* body of block */
  382.          /*
  383.           * See if execution can fall through this code.
  384.           */
  385.          if (il->u[0].n)
  386.             return 1;
  387.          else {
  388.             for (i = 0; i < nsyms; ++i)
  389.                cur_symtab[i].loc = NULL;
  390.             return 0;
  391.             }
  392.  
  393.       case IL_Call:
  394.          /*
  395.           * call to body function.
  396.           */
  397.          return body_fnc(il);
  398.  
  399.       case IL_Abstr:
  400.          /*
  401.           * abstract type computation. Only used by type inference.
  402.           */
  403.          return 1;
  404.  
  405.       default:
  406.          fprintf(stderr, "compiler error: unknown info in data base\n");
  407.          exit(1);
  408.          /* NOTREACHED */
  409.       }
  410.    }
  411.  
  412. /*
  413.  * arth_arg - in-line code to check a conversion for an arith_case statement.
  414.  */
  415. static void arth_arg(var, v_orig, chk, cnv)
  416. struct il_code *var;
  417. struct val_loc *v_orig;
  418. int chk;
  419. struct code *cnv;
  420.    {
  421.    struct code *lbl;
  422.    struct code *cd;
  423.  
  424.    if (chk) {
  425.       /*
  426.        * Must check the conversion.
  427.        */
  428.       lbl = oper_lbl("converted");
  429.       cd_add(lbl);
  430.       cur_fnc->cursor = lbl->prev;        /* code goes before label */
  431.       if (cnv != NULL) {
  432.          cd = NewCode(2);
  433.          cd->cd_id = C_If;
  434.          cd->Cond = cnv;
  435.          cd->ThenStmt = mk_goto(lbl);
  436.          cd_add(cd);
  437.          }
  438.       cd = alc_ary(3);
  439.       cd->ElemTyp(0) = A_Str;
  440.       cd->Str(0) =              "err_msg(102, &(";
  441.       cd->ElemTyp(1) = A_ValLoc;
  442.       cd->ValLoc(1) =           v_orig;    /* var location before conversion */
  443.       cd->ElemTyp(2) = A_Str;
  444.       cd->Str(2) =              "));";
  445.       cd_add(cd);
  446.       if (err_conv)
  447.          cd_add(sig_cd(on_failure, cur_fnc));
  448.       cur_fnc->cursor = lbl;
  449.       }
  450.    else if (cnv != NULL) {
  451.       cd_add(cnv);          /* conversion cannot fail  */
  452.       cd = alc_ary(1);
  453.       cd->ElemTyp(0) = A_Str;
  454.       cd->Str(0) =              ";";
  455.       cd_add(cd);
  456.       }
  457.    }
  458.  
  459. /*
  460.  * body_fnc - generate code to call a body function.
  461.  */
  462. static int body_fnc(il)
  463. struct il_code *il;
  464.    {
  465.    struct code *arg_lst;
  466.    struct code *cd;
  467.    struct c_fnc *cont1;
  468.    char *oper_nm;
  469.    int ret_val;
  470.    int ret_flag;
  471.    int need_rslt;
  472.    int num_sbuf;
  473.    int num_cbuf;
  474.    int expl_args;
  475.    int arglst_sz;  /* size of arg list in number of code pieces */
  476.    int il_indx;
  477.    int cd_indx;
  478.    int proto_prt;
  479.    int i;
  480.  
  481.    /*
  482.     * Determine if a function prototype has been printed yet for this
  483.     *  body function.
  484.     */
  485.    proto_prt = il->u[0].n;
  486.    il->u[0].n = 1;
  487.  
  488.    /*
  489.     * Construct the name of the body function.
  490.     */
  491.    oper_nm = (char *)alloc((unsigned int)(strlen(impl->name) + 6));
  492.    sprintf(oper_nm, "%c%c%c%c_%s", impl->oper_typ, impl->prefix[0],
  493.       impl->prefix[1], (char)il->u[1].n, impl->name);
  494.  
  495.    /*
  496.     * Extract from the call the flags and other information describing
  497.     *  the function, then use this information to deduce the arguments
  498.     *  needed by the function.
  499.     */
  500.    ret_val = il->u[2].n;
  501.    ret_flag = il->u[3].n;
  502.    need_rslt = il->u[4].n;
  503.    num_sbuf = il->u[5].n;
  504.    num_cbuf = il->u[6].n;
  505.    expl_args = il->u[7].n;
  506.  
  507.    /*
  508.     * determine how large the argument list is.
  509.     */
  510.    arglst_sz = 2 * expl_args - 1;
  511.    if (num_sbuf > 0)
  512.       arglst_sz += 3;
  513.    if (num_cbuf > 0)
  514.       arglst_sz += 2;
  515.    if (need_rslt)
  516.       arglst_sz += 3;
  517.    if (arglst_sz > 0)
  518.       arg_lst = alc_ary(arglst_sz);
  519.    else
  520.       arg_lst = alc_ary(0);
  521.  
  522.    if (!proto_prt) {
  523.       /*
  524.        * Determine whether the body function returns a C integer, double,
  525.        *  no value, or a signal.
  526.        */
  527.       switch (ret_val) {
  528.          case RetInt:
  529.             fprintf(inclfile, "C_integer %s (", oper_nm);
  530.             break;
  531.          case RetDbl:
  532.             fprintf(inclfile, "double %s (", oper_nm);
  533.             break;
  534.          case RetNoVal:
  535.             fprintf(inclfile, "void %s (", oper_nm);
  536.             break;
  537.          case RetSig:
  538.             fprintf(inclfile, "int %s (", oper_nm);
  539.             break;
  540.          }
  541.      }
  542.  
  543.    /*
  544.     * Produce prototype and code for the explicit arguments in the
  545.     *  function call. Note that the call entry contains C code for both.
  546.     */
  547.    il_indx = 8;
  548.    cd_indx = 0;
  549.    while (expl_args--) {
  550.       if (cd_indx > 0) {
  551.          /*
  552.           * Not first entry, precede by ','.
  553.           */
  554.          arg_lst->ElemTyp(cd_indx) = A_Str;                /* , */
  555.          arg_lst->Str(cd_indx) = ", ";
  556.          if (!proto_prt)
  557.             fprintf(inclfile, ", ");
  558.          ++cd_indx;
  559.          }
  560.       if (!proto_prt)
  561.         fprintf(inclfile, "%s", il->u[il_indx].c_cd->s);   /* parameter dcl */
  562.       ++il_indx;
  563.       sub_ilc(il->u[il_indx++].c_cd, arg_lst, cd_indx++);
  564.       }
  565.  
  566.    /*
  567.     * If string buffers are needed, allocate them and pass pointer to
  568.     *   function.
  569.     */
  570.    if (num_sbuf > 0) {
  571.       if (cd_indx > 0) {
  572.          /*
  573.           * Not first entry, precede by ','.
  574.           */
  575.          arg_lst->ElemTyp(cd_indx) = A_Str;        /* , */
  576.          arg_lst->Str(cd_indx) = ", ";
  577.          if (!proto_prt)
  578.             fprintf(inclfile, ", ");
  579.          ++cd_indx;
  580.          }
  581.       arg_lst->ElemTyp(cd_indx) = A_Str;
  582.       arg_lst->Str(cd_indx) = "(char (*)[MaxCvtLen])";
  583.       ++cd_indx;
  584.       arg_lst->ElemTyp(cd_indx) = A_SBuf;
  585.       arg_lst->Intgr(cd_indx) = alc_sbufs(num_sbuf, intrnl_lftm);
  586.       if (!proto_prt)
  587.          fprintf(inclfile, "char (*r_sbuf)[MaxCvtLen]");
  588.       ++cd_indx;
  589.       }
  590.  
  591.    /*
  592.     * If cset buffers are needed, allocate them and pass pointer to
  593.     *   function.
  594.     */
  595.    if (num_cbuf > 0) {
  596.       if (cd_indx > 0) {
  597.          /*
  598.           * Not first entry, precede by ','.
  599.           */
  600.          arg_lst->ElemTyp(cd_indx) = A_Str;        /* , */
  601.          arg_lst->Str(cd_indx) = ", ";
  602.          if (!proto_prt)
  603.             fprintf(inclfile, ", ");
  604.          ++cd_indx;
  605.          }
  606.       arg_lst->ElemTyp(cd_indx) = A_CBuf;
  607.       arg_lst->Intgr(cd_indx) = alc_cbufs(num_cbuf, intrnl_lftm);
  608.       if (!proto_prt)
  609.          fprintf(inclfile, "struct b_cset *r_cbuf");
  610.       ++cd_indx;
  611.       }
  612.  
  613.    /*
  614.     * See if the function needs a pointer to the result location
  615.     *  of the operation.
  616.     */
  617.    if (need_rslt) {
  618.       if (cd_indx > 0) {
  619.          /*
  620.           * Not first entry, precede by ','.
  621.           */
  622.          arg_lst->ElemTyp(cd_indx) = A_Str;        /* , */
  623.          arg_lst->Str(cd_indx) = ", ";
  624.          if (!proto_prt)
  625.             fprintf(inclfile, ", ");
  626.          ++cd_indx;
  627.          }
  628.       arg_lst->ElemTyp(cd_indx) = A_Str;        /* location of result */
  629.       arg_lst->Str(cd_indx) = "&";
  630.       ++cd_indx;
  631.       arg_lst->ElemTyp(cd_indx) = A_ValLoc;
  632.       arg_lst->ValLoc(cd_indx) = rslt;
  633.       if (!proto_prt)
  634.          fprintf(inclfile, "dptr rslt");
  635.       ++cd_indx;
  636.       }
  637.  
  638.    if (!proto_prt) {
  639.       /*
  640.        * The last possible argument is the success continuation.
  641.        *  If there are no arguments, indicate this in the prototype.
  642.        */
  643.       if (ret_flag & DoesSusp) {
  644.          if (cd_indx > 0)
  645.             fprintf(inclfile, ", ");
  646.          fprintf(inclfile, "continuation succ_cont");
  647.          }
  648.       else if (cd_indx == 0)
  649.          fprintf(inclfile, "void");
  650.       fprintf(inclfile, ");\n");
  651.       }
  652.  
  653.    /*
  654.     * Does this call need the success continuation for the operation.
  655.     */
  656.    if (ret_flag & DoesSusp)
  657.        cont1 = cont;
  658.    else
  659.        cont1 = NULL;
  660.  
  661.    switch (ret_val) {
  662.       case RetInt:
  663.          /*
  664.           * The body function returns a C integer.
  665.           */
  666.          cd = alc_ary(6);
  667.          cd->ElemTyp(0) = A_ValLoc;
  668.          cd->ValLoc(0) =               rslt;
  669.          cd->ElemTyp(1) = A_Str;
  670.          cd->Str(1) =                  ".vword.integr = ";
  671.          cd->ElemTyp(2) = A_Str;
  672.          cd->Str(2) =                  oper_nm;
  673.          cd->ElemTyp(3) = A_Str;
  674.          cd->Str(3) =                  "(";
  675.          cd->ElemTyp(4) = A_Ary;
  676.          cd->Array(4) =                  arg_lst;
  677.          cd->ElemTyp(5) = A_Str;
  678.          cd->Str(5) =                  ");";
  679.          cd_add(cd);
  680.          dwrd_asgn(rslt, "Integer");
  681.          cd_add(mk_goto(*scont_strt));
  682.          break;
  683.       case RetDbl:
  684.          /*
  685.           * The body function returns a C double.
  686.           */
  687.          cd = alc_ary(6);
  688.          cd->ElemTyp(0) = A_ValLoc;
  689.          cd->ValLoc(0) =               rslt;
  690.          cd->ElemTyp(1) = A_Str;
  691.          cd->Str(1) =                  ".vword.bptr = (union block *)alcreal(";
  692.          cd->ElemTyp(2) = A_Str;
  693.          cd->Str(2) =                  oper_nm;
  694.          cd->ElemTyp(3) = A_Str;
  695.          cd->Str(3) =                  "(";
  696.          cd->ElemTyp(4) = A_Ary;
  697.          cd->Array(4) =                  arg_lst;
  698.          cd->ElemTyp(5) = A_Str;
  699.          cd->Str(5) =                  "));";
  700.          cd_add(cd);
  701.          dwrd_asgn(rslt, "Real");
  702.          chkforblk();    /* make sure the block allocation succeeded */
  703.          cd_add(mk_goto(*scont_strt));
  704.          break;
  705.       case RetNoVal:
  706.          /*
  707.           * The body function does not directly return a value.
  708.           */
  709.          cd = alc_ary(4);
  710.          cd->ElemTyp(0) = A_Str;
  711.          cd->Str(0) =                  oper_nm;
  712.          cd->ElemTyp(1) = A_Str;
  713.          cd->Str(1) =                  "(";
  714.          cd->ElemTyp(2) = A_Ary;
  715.          cd->Array(2) =                  arg_lst;
  716.          cd->ElemTyp(3) = A_Str;
  717.          cd->Str(3) =                  ");";
  718.          cd_add(cd);
  719.          if (ret_flag & DoesFail | (err_conv && (ret_flag & DoesEFail)))
  720.             cd_add(sig_cd(on_failure, cur_fnc));
  721.          else if (ret_flag & DoesRet)
  722.             cd_add(mk_goto(*scont_strt));
  723.          break;
  724.       case RetSig:
  725.          /*
  726.           * The body function returns a signal.
  727.           */
  728.          callo_add(oper_nm, ret_flag, cont1, 0, arg_lst, mk_goto(*scont_strt));
  729.          break;
  730.       }
  731.    /*
  732.     * See if execution can fall through this call.
  733.     */
  734.    if (ret_flag & DoesFThru)
  735.       return 1;
  736.    else {
  737.       for (i = 0; i < nsyms; ++i)
  738.          cur_symtab[i].loc = NULL;
  739.       return 0;
  740.       }
  741.    }
  742.  
  743.  
  744. /*
  745.  * il_var - generate code for a possibly subscripted variable into
  746.  *   an element of a code array.
  747.  */
  748. static void il_var(il, cd, indx)
  749. struct il_code *il;
  750. struct code *cd;
  751. int indx;
  752.    {
  753.    struct code *cd1;
  754.  
  755.    if (il->il_type == IL_Subscr) {
  756.       /*
  757.        * Subscripted variable.
  758.        */
  759.       cd1 = cd;
  760.       cd = alc_ary(4);
  761.       cd1->ElemTyp(indx) = A_Ary;
  762.       cd1->Array(indx) = cd;
  763.       indx = 0;
  764.       cd->ElemTyp(1) = A_Str;
  765.       cd->Str(1) =                  "[";
  766.       cd->ElemTyp(2) = A_Intgr;
  767.       cd->Intgr(2) =                il->u[1].n;
  768.       cd->ElemTyp(3) = A_Str;
  769.       cd->Str(3) =                  "]";
  770.       }
  771.  
  772.    /*
  773.     * See if this is the result location of the operation or an ordinary
  774.     *  variable.
  775.     */
  776.    cd->ElemTyp(indx) = A_ValLoc;
  777.    if (il->u[0].n == RsltIndx)
  778.       cd->ValLoc(indx) = rslt;
  779.    else
  780.       cd->ValLoc(indx) = cur_symtab[il->u[0].n].loc;
  781.    }
  782.  
  783. /*
  784.  * part_asgn - generate code for an assignment to (part of) a descriptor.
  785.  */
  786. static void part_asgn(vloc, asgn, value)
  787. struct val_loc *vloc;
  788. char *asgn;
  789. struct il_c *value;
  790.    {
  791.    struct code *cd;
  792.  
  793.    cd = alc_ary(4);
  794.    cd->ElemTyp(0) = A_ValLoc;
  795.    cd->ValLoc(0) =                          vloc;
  796.    cd->ElemTyp(1) = A_Str;
  797.    cd->Str(1) =                             asgn;
  798.    sub_ilc(value, cd, 2);                /* value */
  799.    cd->ElemTyp(3) = A_Str;
  800.    cd->Str(3) =                             ";";
  801.    cd_add(cd);
  802.    }
  803.  
  804. /*
  805.  * dwrd_asgn - generate code to assign a type code to the dword of a descriptor.
  806.  */
  807. static void dwrd_asgn(vloc, typ)
  808. struct val_loc *vloc;
  809. char *typ;
  810.    {
  811.    struct code *cd;
  812.  
  813.    cd = alc_ary(4);
  814.    cd->ElemTyp(0) = A_ValLoc;
  815.    cd->ValLoc(0) =               vloc;
  816.    cd->ElemTyp(1) = A_Str;
  817.    cd->Str(1) =                  ".dword = D_";
  818.    cd->ElemTyp(2) = A_Str;
  819.    cd->Str(2) =                  typ;
  820.    cd->ElemTyp(3) = A_Str;
  821.    cd->Str(3) =                  ";";
  822.    cd_add(cd);
  823.    }
  824.  
  825. /*
  826.  * sub_ilc - generate code from a sequence of C code and place it
  827.  *  in a slot in a code array.
  828.  */
  829. static void sub_ilc(ilc, cd, indx)
  830. struct il_c *ilc;
  831. struct code *cd;
  832. int indx;
  833.    {
  834.    struct il_c *ilc1;
  835.    struct code *cd1;
  836.    int n;
  837.  
  838.    /*
  839.     * Count the number of pieces of C code to process.
  840.     */
  841.    n = 0;
  842.    for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next)
  843.       ++n;
  844.  
  845.    /*
  846.     * If there is only one piece of code, place it directly in the 
  847.     *  slot of the array. Otherwise allocate a sub-array and place it
  848.     *  in the slot.
  849.     */
  850.    if (n > 1) {
  851.       cd1 = cd;
  852.       cd = alc_ary(n);
  853.       cd1->ElemTyp(indx) = A_Ary;
  854.       cd1->Array(indx) = cd;
  855.       indx = 0;
  856.       }
  857.  
  858.    while (ilc != NULL) {
  859.       switch (ilc->il_c_type) {
  860.          case ILC_Ref:
  861.          case ILC_Mod:
  862.             /*
  863.              * Reference to variable in symbol table.
  864.              */
  865.             cd->ElemTyp(indx) = A_ValLoc;
  866.             if (ilc->n == RsltIndx)
  867.                cd->ValLoc(indx) = rslt;
  868.             else {
  869.                if (ilc->s == NULL)
  870.                   cd->ValLoc(indx) = cur_symtab[ilc->n].loc;
  871.                else {
  872.                   /*
  873.                    * Access the entire descriptor.
  874.                    */
  875.                   cd->ValLoc(indx) = loc_cpy(cur_symtab[ilc->n].loc, M_None);
  876.                   }
  877.                }
  878.             break;
  879.  
  880.          case ILC_Tend:
  881.             /*
  882.              * Reference to a tended variable.
  883.              */
  884.             cd->ElemTyp(indx) = A_ValLoc;
  885.             cd->ValLoc(indx) = tended[ilc->n];
  886.             break;
  887.  
  888.          case ILC_Str:
  889.             /*
  890.              * String representing C code.
  891.              */
  892.             cd->ElemTyp(indx) = A_Str;
  893.             cd->Str(indx) = ilc->s;
  894.             break;
  895.  
  896.          case ILC_SBuf:
  897.             /*
  898.              * String buffer for a conversion.
  899.              */
  900.             cd->ElemTyp(indx) = A_SBuf;
  901.             cd->Intgr(indx) = alc_sbufs(1, intrnl_lftm);
  902.             break;
  903.  
  904.          case ILC_CBuf:
  905.             /*
  906.              * Cset buffer for a conversion.
  907.              */
  908.             cd->ElemTyp(indx) = A_CBuf;
  909.             cd->Intgr(indx) = alc_cbufs(1, intrnl_lftm);
  910.             break;
  911.  
  912.  
  913.          default:
  914.             fprintf(stderr, "compiler error: unknown info in data base\n");
  915.             exit(1);
  916.          }
  917.       ilc = ilc->next;
  918.       ++indx;
  919.       }
  920.  
  921.    }
  922.  
  923. /*
  924.  * gen_ilret - generate code to set the result value from a suspend or
  925.  *   return.
  926.  */
  927. static void gen_ilret(ilc)
  928. struct il_c *ilc;
  929.    {
  930.    struct il_c *ilc0;
  931.    struct code *cd;
  932.    char *cap_id;
  933.    int typcd;
  934.  
  935.    if (rslt == &ignore)
  936.       return;    /* Don't bother computing the result; it's never used */
  937.  
  938.    ilc0 = ilc->code[0];
  939.    typcd = ilc->n;
  940.  
  941.    if (typcd < 0) {
  942.       /*
  943.        * RTL returns that do not look like function calls to standard Icon
  944.        *  type name.
  945.        */
  946.       switch (typcd) {
  947.          case TypCInt:
  948.             /*
  949.              * return/suspend C_integer <expr>;
  950.              */
  951.             part_asgn(rslt, ".vword.integr = ", ilc0);
  952.             dwrd_asgn(rslt, "Integer");
  953.             break;
  954.          case TypCDbl:
  955.             /*
  956.              * return/suspend C_double <expr>;
  957.              */
  958.             cd = alc_ary(4);
  959.             cd->ElemTyp(0) = A_ValLoc;
  960.             cd->ValLoc(0) =             rslt;
  961.             cd->ElemTyp(1) = A_Str;
  962.             cd->Str(1) =                ".vword.bptr = (union block *)alcreal(";
  963.             sub_ilc(ilc0, cd, 2);       /* value */
  964.             cd->ElemTyp(3) = A_Str;
  965.             cd->Str(3) =                ");";
  966.             cd_add(cd);
  967.             dwrd_asgn(rslt, "Real");
  968.             chkforblk();    /* make sure the block allocation succeeded */
  969.             break;
  970.          case TypCStr:
  971.             /*
  972.              * return/suspend C_string <expr>;
  973.              */
  974.             cd = alc_ary(5);
  975.             cd->ElemTyp(0) = A_Str;
  976.             cd->Str(0) =                  "AsgnCStr(";
  977.             cd->ElemTyp(1) = A_ValLoc;
  978.             cd->ValLoc(1) =               rslt;
  979.             cd->ElemTyp(2) = A_Str;
  980.             cd->Str(2) =                  ", ";
  981.             sub_ilc(ilc0, cd, 3);         /* <expr> */
  982.             cd->ElemTyp(4) = A_Str;
  983.             cd->Str(4) =                  ");";
  984.             cd_add(cd);
  985.             break;
  986.          case RetDesc:
  987.             /*
  988.              * return/suspend <expr>;
  989.              */
  990.             part_asgn(rslt, " = ", ilc0);
  991.             break;
  992.          case RetNVar:
  993.             /*
  994.              * return/suspend named_var(<desc-pntr>);
  995.              */
  996.             part_asgn(rslt, ".vword.descptr = ", ilc0);
  997.             dwrd_asgn(rslt, "Var");
  998.             break;
  999.          case RetSVar:
  1000.             /*
  1001.              * return/suspend struct_var(<desc-pntr>, <block_pntr>);
  1002.              */
  1003.             part_asgn(rslt, ".vword.descptr = (dptr)", ilc->code[1]);
  1004.             cd = alc_ary(6);
  1005.             cd->ElemTyp(0) = A_ValLoc;
  1006.             cd->ValLoc(0) =               rslt;
  1007.             cd->ElemTyp(1) = A_Str;
  1008.             cd->Str(1) =                  ".dword = D_Var + ((word *)";
  1009.             sub_ilc(ilc0, cd, 2);       /* value */
  1010.             cd->ElemTyp(3) = A_Str;
  1011.             cd->Str(3) =                  " - (word *)";
  1012.             cd->ElemTyp(4) = A_ValLoc;
  1013.             cd->ValLoc(4) =               rslt;
  1014.             cd->ElemTyp(5) = A_Str;
  1015.             cd->Str(5) =                  ".vword.descptr);";
  1016.             cd_add(cd);
  1017.             break;
  1018.          case RetNone:
  1019.             /*
  1020.              * return/suspend result;
  1021.              *
  1022.              *  Result already set, do nothing.
  1023.              */
  1024.             break;
  1025.          default:
  1026.             fprintf(stderr,
  1027.                "compiler error: unknown RLT return in data base\n");
  1028.             exit(1);
  1029.             /* NOTREACHED */
  1030.          }
  1031.       }
  1032.    else {
  1033.       /*
  1034.        * RTL returns that look like function calls to standard Icon type
  1035.        *  names.
  1036.        */
  1037.       cap_id = icontypes[typcd].cap_id;
  1038.       switch (icontypes[typcd].rtl_ret) {
  1039.          case TRetBlkP:
  1040.             /*
  1041.              * return/suspend <type>(<block-pntr>);
  1042.              */
  1043.             part_asgn(rslt, ".vword.bptr = (union block *)", ilc0);
  1044.             dwrd_asgn(rslt, cap_id);
  1045.             break;
  1046.          case TRetDescP:
  1047.             /*
  1048.              * return/suspend <type>(<descriptor-pntr>);
  1049.              */
  1050.             part_asgn(rslt, ".vword.descptr = (dptr)", ilc0);
  1051.             dwrd_asgn(rslt, cap_id);
  1052.             break;
  1053.          case TRetCharP:
  1054.             /*
  1055.              * return/suspend <type>(<char-pntr>);
  1056.              */
  1057.             part_asgn(rslt, ".vword.sptr = (char *)", ilc0);
  1058.             dwrd_asgn(rslt, cap_id);
  1059.             break;
  1060.          case TRetCInt:
  1061.             /*
  1062.              * return/suspend <type>(<integer>);
  1063.              */
  1064.             part_asgn(rslt, ".vword.integr = (word)", ilc0);
  1065.             dwrd_asgn(rslt, cap_id);
  1066.             break;
  1067.          case TRetSpcl:
  1068.             /*
  1069.              * RTL returns that look like function calls to standard type
  1070.              *  names but take more than one argument.
  1071.              */
  1072.             if (typcd == str_typ) {
  1073.                 /*
  1074.                 * return/suspend string(<len>, <char-pntr>);
  1075.                 */
  1076.                part_asgn(rslt, ".vword.sptr = ", ilc->code[1]);
  1077.                part_asgn(rslt, ".dword = ", ilc0);
  1078.                }
  1079.             else if (typcd == stv_typ) {
  1080.                /*
  1081.                 * return/suspend substr(<desc-pntr>, <start>, <len>);
  1082.                 */
  1083.                cd = alc_ary(9);
  1084.                cd->ElemTyp(0) = A_Str;
  1085.                cd->Str(0) =                  "SubStr(&";
  1086.                cd->ElemTyp(1) = A_ValLoc;
  1087.                cd->ValLoc(1) =               rslt;
  1088.                cd->ElemTyp(2) = A_Str;
  1089.                cd->Str(2) =                  ", ";
  1090.                sub_ilc(ilc0, cd, 3);
  1091.                cd->ElemTyp(4) = A_Str;
  1092.                cd->Str(4) =                  ", ";
  1093.                sub_ilc(ilc->code[2], cd, 5);
  1094.                cd->ElemTyp(6) = A_Str;
  1095.                cd->Str(6) =                  ", ";
  1096.                sub_ilc(ilc->code[1], cd, 7);
  1097.                cd->ElemTyp(8) = A_Str;
  1098.                cd->Str(8) =                  ");";
  1099.                cd_add(cd);
  1100.                chkforblk();    /* make sure the block allocation succeeded */
  1101.                }
  1102.             else {
  1103.                fprintf(stderr,
  1104.                   "compiler error: unknown RLT return in data base\n");
  1105.                exit(1);
  1106.                /* NOTREACHED */
  1107.                }
  1108.             break;
  1109.          default:
  1110.             fprintf(stderr,
  1111.                "compiler error: unknown RLT return in data base\n");
  1112.             exit(1);
  1113.             /* NOTREACHED */
  1114.          }
  1115.       }
  1116.    }
  1117.  
  1118. /*
  1119.  * chkforblk - generate code to make sure the allocation of a block
  1120.  *   for the result descriptor was successful.
  1121.  */
  1122. static void chkforblk()
  1123.    {
  1124.    struct code *cd;
  1125.    struct code *cd1;
  1126.    struct code *lbl;
  1127.  
  1128.    lbl = alc_lbl("got allocation", 0);
  1129.    cd_add(lbl);
  1130.    cur_fnc->cursor = lbl->prev;        /* code goes before label */
  1131.    cd = NewCode(2);
  1132.    cd->cd_id = C_If;
  1133.    cd1 = alc_ary(3);
  1134.    cd1->ElemTyp(0) = A_Str;
  1135.    cd1->Str(0) =                  "(";
  1136.    cd1->ElemTyp(1) = A_ValLoc;
  1137.    cd1->ValLoc(1) =               rslt;
  1138.    cd1->ElemTyp(2) = A_Str;
  1139.    cd1->Str(2) =                  ").vword.bptr != NULL";
  1140.    cd->Cond = cd1;
  1141.    cd->ThenStmt = mk_goto(lbl);
  1142.    cd_add(cd);
  1143.    cd = alc_ary(1);
  1144.    cd->ElemTyp(0) = A_Str;
  1145.    cd->Str(0) =                   "err_msg(307, NULL);";
  1146.    cd_add(cd);
  1147.    if (err_conv)
  1148.       cd_add(sig_cd(on_failure, cur_fnc));
  1149.    cur_fnc->cursor = lbl;
  1150.    }
  1151.  
  1152. /*
  1153.  * gen_ilc - generate code for an sequence of in-line C code.
  1154.  */
  1155. static void gen_ilc(ilc)
  1156. struct il_c *ilc;
  1157.    {
  1158.    struct il_c *ilc1;
  1159.    struct code *cd;
  1160.    struct code *cd1;
  1161.    struct code *lbl1;
  1162.    struct code *fail_sav;
  1163.    struct code **lbls;
  1164.    int max_lbl;
  1165.    int i;
  1166.  
  1167.    /*
  1168.     * Determine how many labels there are in the code and allocate an
  1169.     *  array to map from label numbers to labels in the code.
  1170.     */
  1171.    max_lbl = -1;
  1172.    for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) {
  1173.       switch(ilc1->il_c_type) {
  1174.          case ILC_CGto:
  1175.          case ILC_Goto:
  1176.          case ILC_Lbl:
  1177.             if (ilc1->n > max_lbl)
  1178.                max_lbl = ilc1->n;
  1179.          }
  1180.       }
  1181.    ++max_lbl;    /* adjust for 0 indexing */
  1182.    if (max_lbl > 0) {
  1183.       lbls = (struct code **)alloc((unsigned int) sizeof(struct code *) *
  1184.          max_lbl);
  1185.       for (i = 0; i < max_lbl; ++i)
  1186.          lbls[i] = NULL;
  1187.       }
  1188.  
  1189.    while (ilc != NULL) {
  1190.       switch(ilc->il_c_type) {
  1191.          case ILC_Ref:
  1192.          case ILC_Mod:
  1193.          case ILC_Tend:
  1194.          case ILC_SBuf:
  1195.          case ILC_CBuf:
  1196.          case ILC_Str:
  1197.             /*
  1198.              * The beginning of a sequence of code fragments that can be
  1199.              *  place on one line.
  1200.              */
  1201.             ilc = line_ilc(ilc);
  1202.             break;
  1203.  
  1204.          case ILC_Fail:
  1205.             /*
  1206.              * fail - perform failure action.
  1207.              */
  1208.             cd_add(sig_cd(on_failure, cur_fnc));
  1209.             break;
  1210.  
  1211.          case ILC_EFail:
  1212.             /*
  1213.              * errorfail - same as fail if error conversion is supported.
  1214.              */
  1215.             if (err_conv)
  1216.                cd_add(sig_cd(on_failure, cur_fnc));
  1217.             break;
  1218.  
  1219.          case ILC_Ret:
  1220.             /*
  1221.              * return - set result location and jump out of operation.
  1222.              */
  1223.             gen_ilret(ilc);
  1224.             cd_add(mk_goto(*scont_strt));
  1225.             break;
  1226.  
  1227.          case ILC_Susp:
  1228.             /*
  1229.              * suspend - set result location. If there is a success
  1230.              *  continuation, call it. Otherwise the "continuation"
  1231.              *  will be generated in-line, so set up a resumption label.
  1232.              */
  1233.             gen_ilret(ilc);
  1234.             if (cont == NULL)
  1235.                *scont_strt = cur_fnc->cursor;
  1236.             lbl1 = oper_lbl("end suspend");
  1237.             cd_add(lbl1);
  1238.             if (cont == NULL)
  1239.                *scont_fail = lbl1;
  1240.             else {
  1241.                cur_fnc->cursor = lbl1->prev; 
  1242.                fail_sav = on_failure;
  1243.                on_failure = lbl1;
  1244.                callc_add(cont);
  1245.                on_failure = fail_sav;
  1246.                cur_fnc->cursor = lbl1;
  1247.                }
  1248.             break;
  1249.  
  1250.          case ILC_LBrc:
  1251.             /*
  1252.              * non-deletable '{'
  1253.              */
  1254.             cd = NewCode(0);
  1255.             cd->cd_id = C_LBrack;
  1256.             cd_add(cd);
  1257.             break;
  1258.  
  1259.          case ILC_RBrc:
  1260.             /*
  1261.              * non-deletable '}'
  1262.              */
  1263.             cd = NewCode(0);
  1264.             cd->cd_id = C_RBrack;
  1265.             cd_add(cd);
  1266.             break;
  1267.  
  1268.          case ILC_CGto:
  1269.             /*
  1270.              * Conditional goto.
  1271.              */
  1272.             i = ilc->n;
  1273.             if (lbls[i] == NULL)
  1274.                lbls[i] = oper_lbl("within");
  1275.             cd = NewCode(2);
  1276.             cd->cd_id = C_If;
  1277.             cd1 = alc_ary(1);
  1278.             sub_ilc(ilc->code[0], cd1, 0);
  1279.             cd->Cond = cd1;
  1280.             cd->ThenStmt = mk_goto(lbls[i]);
  1281.             cd_add(cd);
  1282.             break;
  1283.  
  1284.          case ILC_Goto:
  1285.             /*
  1286.              * Goto.
  1287.              */
  1288.             i = ilc->n;
  1289.             if (lbls[i] == NULL)
  1290.                lbls[i] = oper_lbl("within");
  1291.             cd_add(mk_goto(lbls[i]));
  1292.             break;
  1293.  
  1294.          case ILC_Lbl:
  1295.             /*
  1296.              * Label.
  1297.              */
  1298.             i = ilc->n;
  1299.             if (lbls[i] == NULL)
  1300.                lbls[i] = oper_lbl("within");
  1301.             cd_add(lbls[i]);
  1302.             break;
  1303.  
  1304.          default:
  1305.             fprintf(stderr, "compiler error: unknown info in data base\n");
  1306.             exit(1);
  1307.          }
  1308.       ilc = ilc->next;
  1309.       }
  1310.  
  1311.    if (max_lbl > 0)
  1312.       free((char *)lbls);
  1313.    }
  1314.  
  1315. /*
  1316.  * line_ilc - gather a line of in-line code.
  1317.  */
  1318. static struct il_c *line_ilc(ilc)
  1319. struct il_c *ilc;
  1320.    {
  1321.    struct il_c *ilc1;
  1322.    struct il_c *last;
  1323.    struct code *cd;
  1324.    int n;
  1325.    int i;
  1326.  
  1327.    /*
  1328.     * Count the number of pieces in the line. Determine the last
  1329.     *  piece in the sequence; this is returned to the caller.
  1330.     */
  1331.    n = 0;
  1332.    ilc1 = ilc;
  1333.    while (ilc1 != NULL) {
  1334.       switch(ilc1->il_c_type) {
  1335.          case ILC_Ref:
  1336.          case ILC_Mod:
  1337.          case ILC_Tend:
  1338.          case ILC_SBuf:
  1339.          case ILC_CBuf:
  1340.          case ILC_Str:
  1341.             ++n;
  1342.             last = ilc1;
  1343.             ilc1 = ilc1->next;
  1344.             break;
  1345.          default: 
  1346.             ilc1 = NULL;
  1347.          }
  1348.       }
  1349.  
  1350.    /*
  1351.     * Construct the line.
  1352.     */
  1353.    cd = alc_ary(n);
  1354.    for (i = 0; i < n; ++i) {
  1355.       switch(ilc->il_c_type) {
  1356.          case ILC_Ref:
  1357.          case ILC_Mod:
  1358.             /*
  1359.              * Reference to variable in symbol table.
  1360.              */
  1361.             cd->ElemTyp(i) = A_ValLoc;
  1362.             if (ilc->n == RsltIndx)
  1363.                cd->ValLoc(i) = rslt;
  1364.             else
  1365.                cd->ValLoc(i) = cur_symtab[ilc->n].loc;
  1366.             break;
  1367.  
  1368.          case ILC_Tend:
  1369.             /*
  1370.              * Reference to a tended variable.
  1371.              */
  1372.             cd->ElemTyp(i) = A_ValLoc;
  1373.             cd->ValLoc(i) = tended[ilc->n];
  1374.             break;
  1375.  
  1376.          case ILC_SBuf:
  1377.             /*
  1378.              * String buffer for a conversion.
  1379.              */
  1380.             cd->ElemTyp(i) = A_SBuf;
  1381.             cd->Intgr(i) = alc_sbufs(1, intrnl_lftm);
  1382.             break;
  1383.  
  1384.          case ILC_CBuf:
  1385.             /*
  1386.              * Cset buffer for a conversion.
  1387.              */
  1388.             cd->ElemTyp(i) = A_CBuf;
  1389.             cd->Intgr(i) = alc_cbufs(1, intrnl_lftm);
  1390.             break;
  1391.  
  1392.          case ILC_Str:
  1393.             /*
  1394.              * String representing C code.
  1395.              */
  1396.             cd->ElemTyp(i) = A_Str;
  1397.             cd->Str(i) = ilc->s;
  1398.             break;
  1399.  
  1400.          default:
  1401.             ilc = NULL;  
  1402.          }
  1403.       ilc = ilc->next;
  1404.       }
  1405.  
  1406.    cd_add(cd);
  1407.    return last;
  1408.    }
  1409.  
  1410. /*
  1411.  * generate code to perform simple type checking.
  1412.  */
  1413. struct code *typ_chk(var, typcd)
  1414. struct il_code *var;
  1415. int typcd;
  1416.    {
  1417.    struct code *cd;
  1418.  
  1419.    if (typcd == int_typ && largeints) {
  1420.       /*
  1421.        * Handle large integer support specially.
  1422.        */
  1423.       cd = alc_ary(5);
  1424.       cd->ElemTyp(0) = A_Str;
  1425.       cd->Str(0) =                           "((";
  1426.       il_var(var, cd, 1);                    /* value */
  1427.       cd->ElemTyp(2) = A_Str;
  1428.       cd->Str(2) =                           ").dword == D_Integer || (";
  1429.       il_var(var, cd, 3);                    /* value */
  1430.       cd->ElemTyp(4) = A_Str;
  1431.       cd->Str(4) =                           ").dword == D_Lrgint)";
  1432.       return cd;
  1433.       }
  1434.    else if (typcd < 0) {
  1435.       /*
  1436.        * Not a standard Icon type name.
  1437.        */
  1438.       cd = alc_ary(3);
  1439.       cd->ElemTyp(0) = A_Str;
  1440.       switch (typcd) {
  1441.          case TypVar:
  1442.             cd->Str(0) =                     "(((";
  1443.             il_var(var, cd, 1);              /* value */
  1444.             cd->ElemTyp(2) = A_Str;
  1445.             cd->Str(2) =                     ").dword & D_Var) == D_Var)";
  1446.             break;
  1447.          case TypCInt:
  1448.             cd->Str(0) =                     "((";
  1449.             il_var(var, cd, 1);              /* value */
  1450.             cd->ElemTyp(2) = A_Str;
  1451.             cd->Str(2) =                     ").dword == D_Integer)";
  1452.             break;
  1453.          }
  1454.       }
  1455.    else if (typcd == str_typ) {
  1456.       cd = alc_ary(3);
  1457.       cd->ElemTyp(0) = A_Str;
  1458.       cd->Str(0) =                           "(!((";
  1459.       il_var(var, cd, 1);                    /* value */
  1460.       cd->ElemTyp(2) = A_Str;
  1461.       cd->Str(2) =                           ").dword & F_Nqual))";
  1462.       }
  1463.    else {
  1464.       cd = alc_ary(5);
  1465.       cd->ElemTyp(0) = A_Str;
  1466.       cd->Str(0) =                           "((";
  1467.       il_var(var, cd, 1);                    /* value */
  1468.       cd->ElemTyp(2) = A_Str;
  1469.       cd->Str(2) =                           ").dword == D_";
  1470.       cd->ElemTyp(3) = A_Str;
  1471.       cd->Str(3) = icontypes[typcd].cap_id;  /* type name */
  1472.       cd->ElemTyp(4) = A_Str;
  1473.       cd->Str(4) =                           ")";
  1474.       }
  1475.  
  1476.    return cd;
  1477.    }
  1478.  
  1479. /*
  1480.  * oper_lbl - generate a label with an associated comment that includes
  1481.  *   the operation name.
  1482.  */
  1483. static struct code *oper_lbl(s)
  1484. char *s;
  1485.    {
  1486.    char *sbuf;
  1487.  
  1488.    sbuf = (char *)alloc((unsigned int)(strlen(s) + strlen(impl->name) + 3));
  1489.    sprintf(sbuf, "%s: %s", s, impl->name);
  1490.    return alc_lbl(sbuf, 0);
  1491.    }
  1492.  
  1493. /*
  1494.  * sav_locs - save the current interpretation of symbols that may
  1495.  *  be affected by conversions.
  1496.  */
  1497. static struct val_loc **sav_locs()
  1498.    {
  1499.    struct val_loc **locs;
  1500.    int i;
  1501.  
  1502.    if (nsyms == 0)
  1503.       return NULL;
  1504.  
  1505.    locs = (struct val_loc **)alloc((unsigned int)(nsyms *
  1506.       sizeof(struct val_loc *)));
  1507.    for (i = 0; i < nsyms; ++i)
  1508.       locs[i] = cur_symtab[i].loc;
  1509.    return locs;
  1510.    }
  1511.  
  1512. /*
  1513.  * rstr_locs - restore the interpretation of symbols that may
  1514.  *  have been affected by conversions.
  1515.  */
  1516. static void rstr_locs(locs)
  1517. struct val_loc **locs;
  1518.    {
  1519.    int i;
  1520.  
  1521.    for (i = 0; i < nsyms; ++i)
  1522.       cur_symtab[i].loc = locs[i];
  1523.    free((char *)locs);
  1524.    }
  1525.  
  1526. /*
  1527.  * mrg_locs - merge the interpretations of symbols along two execution
  1528.  *  paths. Any ambiguity is caught by rtt, so differences only occur
  1529.  *  if one path involves program termination so that the symbols
  1530.  *  no longer have an interpretation along that path.
  1531.  */
  1532. static void mrg_locs(locs)
  1533. struct val_loc **locs;
  1534.    {
  1535.    int i;
  1536.  
  1537.    for (i = 0; i < nsyms; ++i)
  1538.       if (cur_symtab[i].loc == NULL)
  1539.          cur_symtab[i].loc = locs[i];
  1540.    free((char *)locs);
  1541.    }
  1542.  
  1543. /*
  1544.  * il_cnv - generate code for an in-line conversion.
  1545.  */
  1546. struct code *il_cnv(typcd, src, dflt, dest)
  1547. int typcd;
  1548. struct il_code *src;
  1549. struct il_c *dflt;
  1550. struct il_c *dest;
  1551.    {
  1552.    struct code *cd;
  1553.    struct code *cd1;
  1554.    int dflt_to_ptr;
  1555.    int loc;
  1556.    int is_cstr;
  1557.    int sym_indx;
  1558.    int n;
  1559.    int i;
  1560.  
  1561.    sym_indx = src->u[0].n;
  1562.  
  1563.    /*
  1564.     * Determine whether the address must be taken of a default value and
  1565.     *  whether the interpretation of the symbol in an in-place conversion
  1566.     *  changes.
  1567.     */
  1568.    dflt_to_ptr = 0;
  1569.    loc = PrmTend;
  1570.    is_cstr = 0;
  1571.    switch (typcd) {
  1572.       case TypCInt:
  1573.       case TypECInt:
  1574.          loc = PrmInt;
  1575.          break;
  1576.       case TypCDbl:
  1577.          loc = PrmDbl;
  1578.          break;
  1579.       case TypCStr:
  1580.          is_cstr = 1;
  1581.          break;
  1582.       case TypEInt:
  1583.          break;
  1584.       case TypTStr:
  1585.       case TypTCset:
  1586.          dflt_to_ptr = 1;
  1587.          break;
  1588.       default:
  1589.          /*
  1590.           * Cset, real, integer, or string
  1591.           */
  1592.          if (typcd == cset_typ || typcd == str_typ)
  1593.             dflt_to_ptr = 1;
  1594.          break;
  1595.       }
  1596.  
  1597.   if (typcd == TypCDbl && !(eval_is(real_typ, sym_indx) & MaybeFalse)) {
  1598.      /*
  1599.       * Conversion from Icon real to C double. Just copy the C value
  1600.       *  from the block.
  1601.       */
  1602.      cd = alc_ary(5);
  1603.      cd->ElemTyp(0) = A_Str;
  1604.      cd->Str(0) =                "(GetReal(&(";
  1605.      il_var(src, cd, 1);
  1606.      cd->ElemTyp(2) = A_Str;
  1607.      cd->Str(2) =                "), ";
  1608.      cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 3);
  1609.      cd->ElemTyp(4) = A_Str;
  1610.      cd->Str(4) =                "), 1)";
  1611.      }
  1612.   else if (typcd == TypCDbl && !largeints &&
  1613.      !(eval_is(int_typ, sym_indx) & MaybeFalse)) {
  1614.      /*
  1615.       * Conversion from Icon integer (not large integer) to C double.
  1616.       *  Do as a C conversion by an assigment.
  1617.       */
  1618.      cd = alc_ary(5);
  1619.      cd->ElemTyp(0) = A_Str;
  1620.      cd->Str(0) =                "(";
  1621.      cd->ElemTyp(2) = A_Str;
  1622.      cd->Str(2) =                " = IntVal( ";
  1623.      cd->ElemTyp(4) = A_Str;
  1624.      cd->Str(4) =                "), 1)";
  1625.      /*
  1626.       * Note that cnv_dest() must be called after the source is output
  1627.       *  in case it changes the location of the parameter.
  1628.       */
  1629.      il_var(src, cd, 3);
  1630.      cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 1);
  1631.      }
  1632.    else {
  1633.       /*
  1634.        * Compute the number of code fragments required to construct the
  1635.        *  call to the conversion routine.
  1636.        */
  1637.       n = 7;
  1638.       if (dflt != NULL)
  1639.         n += 2;
  1640.    
  1641.       cd = alc_ary(n);
  1642.    
  1643.       /*
  1644.        * The names of simple conversions are distinguished from defaulting
  1645.        *  conversions by a prefix of "cnv_" or "def_".
  1646.        */
  1647.       cd->ElemTyp(0) = A_Str;
  1648.       if (dflt == NULL)
  1649.          cd->Str(0) = "cnv_";
  1650.       else
  1651.          cd->Str(0) = "def_";
  1652.    
  1653.       /*
  1654.        * Determine the name of the conversion routine.
  1655.        */
  1656.       cd->ElemTyp(1) = A_Str;    /* may be overridden */
  1657.       switch (typcd) {
  1658.          case TypCInt:
  1659.             cd->Str(1) = "c_int(&(";
  1660.             break;
  1661.          case TypCDbl:
  1662.             cd->Str(1) = "c_dbl(&(";
  1663.             break;
  1664.          case TypCStr:
  1665.             cd->Str(1) = "c_str(&(";
  1666.             break;
  1667.          case TypEInt:
  1668.             cd->Str(1) = "eint(&(";
  1669.             break;
  1670.          case TypECInt:
  1671.             cd->Str(1) = "ec_int(&(";
  1672.             break;
  1673.          case TypTStr:
  1674.             /*
  1675.              * Allocate a string buffer.
  1676.              */
  1677.             cd1 = alc_ary(3);
  1678.             cd1->ElemTyp(0) = A_Str;
  1679.             cd1->Str(0) = "tstr(";
  1680.             cd1->ElemTyp(1) = A_SBuf;
  1681.             cd1->Intgr(1) = alc_sbufs(1, intrnl_lftm);
  1682.             cd1->ElemTyp(2) = A_Str;
  1683.             cd1->Str(2) = ", (&";
  1684.             cd->ElemTyp(1) = A_Ary;
  1685.             cd->Array(1) = cd1;
  1686.             break;
  1687.          case TypTCset:
  1688.             /*
  1689.              * Allocate a cset buffer.
  1690.              */
  1691.             cd1 = alc_ary(3);
  1692.             cd1->ElemTyp(0) = A_Str;
  1693.             cd1->Str(0) = "tcset(";
  1694.             cd1->ElemTyp(1) = A_CBuf;
  1695.             cd1->Intgr(1) = alc_cbufs(1, intrnl_lftm);
  1696.             cd1->ElemTyp(2) = A_Str;
  1697.             cd1->Str(2) = ", &(";
  1698.             cd->ElemTyp(1) = A_Ary;
  1699.             cd->Array(1) = cd1;
  1700.             break;
  1701.          default:
  1702.             /*
  1703.              * Cset, real, integer, or string
  1704.              */
  1705.             if (typcd == cset_typ)
  1706.                cd->Str(1) = "cset(&(";
  1707.             else if (typcd == real_typ) 
  1708.                cd->Str(1) = "real(&(";
  1709.             else if (typcd == int_typ) 
  1710.                cd->Str(1) = "int(&(";
  1711.             else if (typcd == str_typ)
  1712.                cd->Str(1) = "str(&(";
  1713.             break;
  1714.          }
  1715.    
  1716.       il_var(src, cd, 2);
  1717.    
  1718.       cd->ElemTyp(3) = A_Str;
  1719.       if (dflt != NULL && dflt_to_ptr)
  1720.          cd->Str(3) = "), &(";
  1721.       else
  1722.          cd->Str(3) = "), ";
  1723.    
  1724.    
  1725.       /*
  1726.        * Determine if this conversion has a default value.
  1727.        */
  1728.       i = 4;
  1729.       if (dflt != NULL) {
  1730.          sub_ilc(dflt, cd, i);
  1731.          ++i;
  1732.          cd->ElemTyp(i) = A_Str;
  1733.          if (dflt_to_ptr)
  1734.             cd->Str(i) = "), ";
  1735.          else
  1736.             cd->Str(i) = ", ";
  1737.          ++i;
  1738.          }
  1739.    
  1740.       cd->ElemTyp(i) = A_Str;
  1741.       cd->Str(i) = "&(";
  1742.       ++i;
  1743.       cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i);
  1744.       ++i;
  1745.       cd->ElemTyp(i) = A_Str;
  1746.       cd->Str(i) = "))";
  1747.       }
  1748.    return cd;
  1749.    }
  1750.  
  1751. /*
  1752.  * il_dflt - generate code for a defaulting conversion that always defaults.
  1753.  */
  1754. struct code *il_dflt(typcd, src, dflt, dest)
  1755. int typcd;
  1756. struct il_code *src;
  1757. struct il_c *dflt;
  1758. struct il_c *dest;
  1759.    {
  1760.    struct code *cd;
  1761.    int sym_indx;
  1762.  
  1763.    sym_indx = src->u[0].n;
  1764.  
  1765.    if (typcd == TypCDbl) {
  1766.       cd = alc_ary(5);
  1767.       cd->ElemTyp(0) = A_Str;
  1768.       cd->Str(0) =                                      "(";
  1769.       cnv_dest(PrmDbl, 0, src, sym_indx, dest, cd, 1);  /* variable */
  1770.       cd->ElemTyp(2) = A_Str;
  1771.       cd->Str(2) =                                      " = ";
  1772.       sub_ilc(dflt, cd, 3);                             /* default */
  1773.       cd->ElemTyp(4) = A_Str;
  1774.       cd->Str(4) =                                      ", 1)";
  1775.       }
  1776.    else if (typcd == TypCInt || typcd == TypECInt) {
  1777.       cd = alc_ary(5);
  1778.       cd->ElemTyp(0) = A_Str;
  1779.       cd->Str(0) =                                      "(";
  1780.       cnv_dest(PrmInt, 0, src, sym_indx, dest, cd, 1);  /* variable */
  1781.       cd->ElemTyp(2) = A_Str;
  1782.       cd->Str(2) =                                      " = ";
  1783.       sub_ilc(dflt, cd, 3);                             /* default */
  1784.       cd->ElemTyp(4) = A_Str;
  1785.       cd->Str(4) =                                      ", 1)";
  1786.       }
  1787.    else if (typcd == TypTStr || typcd == str_typ) {
  1788.       cd = alc_ary(5);
  1789.       cd->ElemTyp(0) = A_Str;
  1790.       cd->Str(0) =                                      "(";
  1791.       cnv_dest(0, 0, src, sym_indx, dest, cd, 1);       /* variable */
  1792.       cd->ElemTyp(2) = A_Str;
  1793.       cd->Str(2) =                                      " = ";
  1794.       sub_ilc(dflt, cd, 3);                             /* default */
  1795.       cd->ElemTyp(4) = A_Str;
  1796.       cd->Str(4) =                                      ", 1)";
  1797.       }
  1798.    else if (typcd == TypCStr) {
  1799.       cd = alc_ary(5);
  1800.       cd->ElemTyp(0) = A_Str;
  1801.       cd->Str(0) =                                      "(AsgnCStr(";
  1802.       cnv_dest(0, 1, src, sym_indx, dest, cd, 1);       /* variable */
  1803.       cd->ElemTyp(2) = A_Str;
  1804.       cd->Str(2) =                                      ", ";
  1805.       sub_ilc(dflt, cd, 3);                             /* default */
  1806.       cd->ElemTyp(4) = A_Str;
  1807.       cd->Str(4) =                                      "), 1)";
  1808.       }
  1809.    else if (typcd == TypTCset || typcd == cset_typ) {
  1810.       cd = alc_ary(7);
  1811.       cd->ElemTyp(0) = A_Str;
  1812.       cd->Str(0) =                                      "(BlkLoc(";
  1813.       cnv_dest(0, 0, src, sym_indx, dest, cd, 1);       /* variable */
  1814.       cd->ElemTyp(2) = A_Str;
  1815.       cd->Str(2) =                                      ") = (union block *)&";
  1816.       sub_ilc(dflt, cd, 3);                             /* default */
  1817.       cd->ElemTyp(4) = A_Str;
  1818.       cd->Str(4) =                                      ", ";
  1819.       cnv_dest(0, 0, src, sym_indx, dest, cd, 5);       /* variable */
  1820.       cd->ElemTyp(6) = A_Str;
  1821.       cd->Str(6) =                                      ".dword = D_Cset, 1)";
  1822.       }
  1823.    else if (typcd == TypEInt || typcd == int_typ) {
  1824.       cd = alc_ary(7);
  1825.       cd->ElemTyp(0) = A_Str;
  1826.       cd->Str(0) =                                      "(IntVal(";
  1827.       cnv_dest(0, 0, src, sym_indx, dest, cd, 1);       /* variable */
  1828.       cd->ElemTyp(2) = A_Str;
  1829.       cd->Str(2) =                                      ") = ";
  1830.       sub_ilc(dflt, cd, 3);                             /* default */
  1831.       cd->ElemTyp(4) = A_Str;
  1832.       cd->Str(4) =                                      ", ";
  1833.       cnv_dest(0, 0, src, sym_indx, dest, cd, 5);       /* variable */
  1834.       cd->ElemTyp(6) = A_Str;
  1835.       cd->Str(6) =                                     ".dword = D_Integer, 1)";
  1836.       }
  1837.    else if (typcd == real_typ) {
  1838.       cd = alc_ary(7);
  1839.       cd->ElemTyp(0) = A_Str;
  1840.       cd->Str(0) =                                      "((BlkLoc(";
  1841.       cnv_dest(0, 0, src, sym_indx, dest, cd, 1);       /* variable */
  1842.       cd->ElemTyp(2) = A_Str;
  1843.       cd->Str(2) =                                ") = (union block *)alcreal(";
  1844.       sub_ilc(dflt, cd, 3);                             /* default */
  1845.       cd->ElemTyp(4) = A_Str;
  1846.       cd->Str(4) =                     ")) == NULL ? (fatalerr(0,NULL), 0) : (";
  1847.       cnv_dest(0, 0, src, sym_indx, dest, cd, 5);       /* variable */
  1848.       cd->ElemTyp(6) = A_Str;
  1849.       cd->Str(6) =                                     ".dword = D_Real, 1))";
  1850.       }
  1851.  
  1852.    return cd;
  1853.    }
  1854.  
  1855. /*
  1856.  * cnv_dest - output the destination of a conversion.
  1857.  */
  1858. static void cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i)
  1859. int loc;
  1860. int is_cstr;
  1861. struct il_code *src;
  1862. int sym_indx;
  1863. struct il_c *dest;
  1864. struct code *cd;
  1865. int i;
  1866.    {
  1867.    if (dest == NULL) {
  1868.       /*
  1869.        * Convert "in place", changing the location of a parameter if needed.
  1870.        */
  1871.       switch (loc) {
  1872.          case PrmInt:
  1873.             if (cur_symtab[sym_indx].itmp_indx < 0)
  1874.                cur_symtab[sym_indx].itmp_indx = alc_itmp(intrnl_lftm);
  1875.             cur_symtab[sym_indx].loc = itmp_loc(cur_symtab[sym_indx].itmp_indx);
  1876.             break;
  1877.          case PrmDbl:
  1878.             if (cur_symtab[sym_indx].dtmp_indx < 0)
  1879.                cur_symtab[sym_indx].dtmp_indx = alc_dtmp(intrnl_lftm);
  1880.             cur_symtab[sym_indx].loc = dtmp_loc(cur_symtab[sym_indx].dtmp_indx);
  1881.             break;
  1882.          }
  1883.       il_var(src, cd, i);
  1884.       if (is_cstr)
  1885.          cur_symtab[sym_indx].loc = loc_cpy(cur_symtab[sym_indx].loc,M_CharPtr);
  1886.       }
  1887.    else {
  1888.       if (is_cstr && dest->il_c_type == ILC_Mod && dest->next == NULL &&
  1889.          dest->n != RsltIndx && cur_symtab[dest->n].loc->mod_access != M_None) {
  1890.             /*
  1891.              * We are converting to a C string. The destination variable
  1892.              *  is not defined as a simple descriptor, but must be accessed
  1893.              *  as such for this conversion.
  1894.              */
  1895.             cd->ElemTyp(i) = A_ValLoc;
  1896.             cd->ValLoc(i) = loc_cpy(cur_symtab[dest->n].loc, M_None);
  1897.             }
  1898.       else 
  1899.          sub_ilc(dest, cd, i);
  1900.       }
  1901.  
  1902.    }
  1903.  
  1904. /*
  1905.  * il_copy - produce code for an optimized "conversion" that always succeeds
  1906.  *   and just copies a value from one place to another.
  1907.  */
  1908. struct code *il_copy(dest, src)
  1909. struct il_c *dest;
  1910. struct val_loc *src;
  1911.    {
  1912.    struct code *cd;
  1913.  
  1914.    cd = alc_ary(5);
  1915.    cd->ElemTyp(0) = A_Str;
  1916.    cd->Str(0) = "(";
  1917.    sub_ilc(dest, cd, 1);
  1918.    cd->ElemTyp(2) = A_Str;
  1919.    cd->Str(2) = " = ";
  1920.    cd->ElemTyp(3) = A_ValLoc;
  1921.    cd->ValLoc(3) = src;
  1922.    cd->ElemTyp(4) = A_Str;
  1923.    cd->Str(4) = ", 1)";
  1924.    return cd;
  1925.    }
  1926.  
  1927. /*
  1928.  * loc_cpy - make a copy of a reference to a value location, but change
  1929.  *  the way the location is accessed.
  1930.  */
  1931. struct val_loc *loc_cpy(loc, mod_access)
  1932. struct val_loc *loc;
  1933. int mod_access;
  1934.    {
  1935.    struct val_loc *new_loc;
  1936.  
  1937.    if (loc == NULL)
  1938.       return NULL;
  1939.    new_loc = NewStruct(val_loc);
  1940.    *new_loc = *loc;
  1941.    new_loc->mod_access = mod_access;
  1942.    return new_loc;
  1943.    }
  1944.  
  1945. /*
  1946.  * gen_tcase - generate in-line code for a type_case statement.
  1947.  */
  1948. static int gen_tcase(il, has_dflt)
  1949. struct il_code *il;
  1950. int has_dflt;
  1951.    {
  1952.    struct case_anlz case_anlz;
  1953.  
  1954.    /*
  1955.     * We can only get here if the type_case statement can be implemented
  1956.     *  with a no more than one type check. Determine how simple the
  1957.     *  code can be.
  1958.     */
  1959.    findcases(il, has_dflt, &case_anlz);
  1960.    if (case_anlz.il_then == NULL) {
  1961.       if (case_anlz.il_else == NULL)
  1962.          return 1;
  1963.       else
  1964.          return gen_il(case_anlz.il_else);
  1965.       }
  1966.    else
  1967.       return gen_if(typ_chk(il->u[0].fld, case_anlz.typcd), case_anlz.il_then,
  1968.          case_anlz.il_else, sav_locs());
  1969.    }
  1970.  
  1971. /*
  1972.  * gen_if - generate code to test a condition that might be true
  1973.  *  of false. Determine if execution can continue past this if statement.
  1974.  */
  1975. static int gen_if(cond_cd, il_then, il_else, locs)
  1976. struct code *cond_cd;
  1977. struct il_code *il_then;
  1978. struct il_code *il_else;
  1979. struct val_loc **locs;
  1980.    {
  1981.    struct val_loc **locs1;
  1982.    struct code *lbl_then;
  1983.    struct code *lbl_end;
  1984.    struct code *else_loc;
  1985.    struct code *cd;
  1986.    int fall_thru;
  1987.  
  1988.    lbl_then = oper_lbl("then");
  1989.    lbl_end = oper_lbl("end if");
  1990.    cd = NewCode(2);
  1991.    cd->cd_id = C_If;
  1992.    cd->Cond = cond_cd;
  1993.    cd->ThenStmt = mk_goto(lbl_then);
  1994.    cd_add(cd);
  1995.    else_loc = cur_fnc->cursor;
  1996.    cd_add(lbl_then);
  1997.    fall_thru = gen_il(il_then);
  1998.    cd_add(lbl_end);
  1999.    locs1 = sav_locs();
  2000.    rstr_locs(locs);
  2001.    cur_fnc->cursor = else_loc;  /* go back for the else clause */
  2002.    fall_thru |= gen_il(il_else);
  2003.    cd_add(mk_goto(lbl_end));
  2004.    cur_fnc->cursor = lbl_end;
  2005.    mrg_locs(locs1);
  2006.    return fall_thru;
  2007.    }
  2008.