home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v92.tgz / v92.tar / v92 / src / rtt / rttdb.c < prev    next >
C/C++ Source or Header  |  1996-03-22  |  42KB  |  1,458 lines
  1. /*
  2.  * rttdb.c - routines to read, manipulate, and write the data base of
  3.  *  information about run-time routines.
  4.  */
  5.  
  6. #include "rtt.h"
  7. #include "::h:version.h"
  8.  
  9. #define DHSize 47
  10. #define MaxLine 80
  11.  
  12. /*
  13.  * prototypes for static functions.
  14.  */
  15. hidden novalue max_pre   Params((struct implement **tbl, char *pre));
  16. hidden int     name_cmp  Params((char *p1, char *p2));
  17. hidden int     op_cmp    Params((char *p1, char *p2));
  18. hidden novalue prt_dpnd  Params((FILE *db));
  19. hidden novalue prt_impls Params((FILE *db, char *sect, struct implement **tbl,
  20.                            int num, struct implement **sort_ary, int (*com)()));
  21. hidden int     prt_c_fl  Params((FILE *db, struct cfile *clst, int line_left));
  22. hidden int     put_case  Params((FILE *db, struct il_code *il));
  23. hidden novalue put_ilc   Params((FILE *db, struct il_c *ilc));
  24. hidden novalue put_inlin Params((FILE *db, struct il_code *il));
  25. hidden novalue put_ret   Params((FILE *db, struct il_c *ilc));
  26. hidden novalue put_typcd Params((FILE *db, int typcd));
  27. hidden novalue put_var   Params((FILE *db, int code, struct il_c *ilc));
  28. hidden novalue ret_flag  Params((FILE *db, int flag, int may_fthru));
  29. hidden int     set_impl  Params((struct token *name, struct implement **tbl,
  30.                            int num_impl, char *pre));
  31. hidden novalue set_prms  Params((struct implement *ptr));
  32. hidden int     src_cmp   Params((char *p1, char *p2));
  33.  
  34. static struct implement *bhash[IHSize];    /* hash area for built-in func table */
  35. static struct implement *ohash[IHSize]; /* hash area for operator table */
  36. static struct implement *khash[IHSize];    /* hash area for keyword table */
  37.  
  38. static struct srcfile *dhash[DHSize];    /* hash area for file dependencies */
  39.  
  40. static int num_fnc;        /* number of function in data base */
  41. static int num_op = 0;        /* number of operators in data base */
  42. static int num_key;        /* number of keywords in data base */
  43. static int num_src = 0;        /* number of source files in dependencies */
  44.  
  45. static char fnc_pre[2];        /* next prefix available for functions */
  46. static char op_pre[2];        /* next prefix available for operators */
  47. static char key_pre[2];        /* next prefix available for keywords */
  48.  
  49. static long min_rs;        /* min result sequence of current operation */
  50. static long max_rs;        /* max result sequence of current operation */
  51. static int rsm_rs;        /* '+' at end of result sequencce of cur. oper. */
  52.  
  53. static int newdb = 0;        /* flag: this is a new data base */
  54. struct token *comment;        /* comment associated with current operation */
  55. struct implement *cur_impl;    /* data base entry for current operation */
  56.  
  57. /*
  58.  * loaddb - load data base.
  59.  */
  60. novalue loaddb(dbname)
  61. char *dbname;
  62.    {
  63.    char *op;
  64.    struct implement *ip;
  65.    unsigned hashval;
  66.    int i;
  67.    char *srcname;
  68.    char *c_name;
  69.    struct srcfile *sfile;
  70.  
  71.  
  72.    /*
  73.     * Initialize internal data base.
  74.     */
  75.    for (i = 0; i < IHSize; i++) {
  76.        bhash[i] = NULL;   /* built-in function table */
  77.        ohash[i] = NULL;   /* operator table */
  78.        khash[i] = NULL;   /* keyword table */
  79.        }
  80.    for (i = 0; i < DHSize; i++)
  81.        dhash[i] = NULL;   /* dependency table */
  82.  
  83.    /*
  84.     * Determine if this is a new data base or an existing one.
  85.     */
  86.    if (iconx_flg || !db_open(dbname, &largeints))
  87.       newdb = 1;
  88.    else {
  89.  
  90.       /*
  91.        * Read information about built-in functions.
  92.        */
  93.       num_fnc = db_tbl("functions", bhash);
  94.  
  95.       /*
  96.        * Read information about operators.
  97.        */
  98.       db_chstr("", "operators");    /* verify and skip "operators" */
  99.  
  100.       while ((op = db_string()) != NULL) {
  101.          /*
  102.           * Read header information for the operator.
  103.            */
  104.          if ((ip = db_impl('O')) == NULL)
  105.             db_err2(1, "no implementation information for operator", op);
  106.          ip->op = op;
  107.  
  108.          /*
  109.           * Read the descriptive comment and in-line code for the operator,
  110.           *  then put the entry in the hash table.
  111.           */
  112.          db_code(ip);
  113.          hashval = (int)IHasher(op);
  114.          ip->blink = ohash[hashval];
  115.          ohash[hashval] = ip;
  116.          db_chstr("", "end");         /* verify and skip "end" */
  117.          ++num_op;
  118.          }
  119.       db_chstr("", "endsect");       /* verify and skip "endsect" */
  120.  
  121.       /*
  122.        * Read information about keywords.
  123.        */
  124.       num_key = db_tbl("keywords", khash);
  125.  
  126.       /*
  127.        * Read C file/source dependency information.
  128.        */
  129.       db_chstr("", "dependencies");  /* verify and skip "dependencies" */
  130.  
  131.       while ((srcname = db_string()) != NULL) {
  132.          sfile = src_lkup(srcname);
  133.          while ((c_name = db_string()) != NULL)
  134.             add_dpnd(sfile, c_name);
  135.          db_chstr("", "end");         /* verify and skip "end" */
  136.          }
  137.       db_chstr("", "endsect");        /* verify and skip "endsect" */
  138.  
  139.       db_close();
  140.       }
  141.  
  142.    /*
  143.     * Determine the next available operation prefixes by finding the
  144.     *  maximum prefixes currently in use.
  145.     */
  146.    max_pre(bhash, fnc_pre);
  147.    max_pre(ohash, op_pre);
  148.    max_pre(khash, key_pre);
  149.    }
  150.  
  151. /*
  152.  * max_pre - find the maximum prefix in an implemetation table and set the
  153.  *  prefix array to the next value.
  154.  */
  155. static novalue max_pre(tbl, pre)
  156. struct implement **tbl;
  157. char *pre;
  158.    {
  159.    register struct implement *ptr;
  160.    unsigned hashval;
  161.    int empty = 1;
  162.    char dmy_pre[2];
  163.  
  164.    pre[0] = '0';
  165.    pre[1] = '0';
  166.    for (hashval = 0; hashval < IHSize; ++hashval) 
  167.       for (ptr = tbl[hashval]; ptr != NULL; ptr = ptr->blink) {
  168.          empty = 0;
  169.          /*
  170.           * Determine if this prefix is larger than any found so far.
  171.           */
  172.          if (cmp_pre(ptr->prefix, pre) > 0) {
  173.             pre[0] = ptr->prefix[0];
  174.             pre[1] = ptr->prefix[1];
  175.             }
  176.          }
  177.    if (!empty)
  178.       nxt_pre(dmy_pre, pre, 2);
  179.    }
  180.  
  181.  
  182. /*
  183.  * src_lkup - return pointer to dependency information for the given
  184.  *   source file.
  185.  */
  186. struct srcfile *src_lkup(srcname)
  187. char *srcname;
  188.    {
  189.    unsigned hashval;
  190.    struct srcfile *sfile;
  191.  
  192.    /*
  193.     * See if the source file is already in the dependancy section of
  194.     *  the data base.
  195.     */
  196.    hashval = (unsigned)srcname % DHSize;
  197.    for (sfile = dhash[hashval]; sfile != NULL && sfile->name != srcname;
  198.         sfile = sfile->next)
  199.       ;
  200.  
  201.    /*
  202.     * If an entry for the source file was not found, create one.
  203.     */
  204.    if (sfile == NULL) {
  205.       sfile = NewStruct(srcfile);
  206.       sfile->name = srcname;
  207.       sfile->dependents = NULL;
  208.       sfile->next = dhash[hashval];
  209.       dhash[hashval] = sfile;
  210.       ++num_src;
  211.       }
  212.    return sfile;
  213.    }
  214.  
  215. /*
  216.  * add_dpnd - add the given source/dependency relation to the dependency
  217.  *   table.
  218.  */
  219. novalue add_dpnd(sfile, c_name)
  220. struct srcfile *sfile;
  221. char *c_name;
  222.    {
  223.    struct cfile *cf;
  224.  
  225.    cf = NewStruct(cfile);
  226.    cf->name = c_name;
  227.    cf->next = sfile->dependents;
  228.    sfile->dependents = cf;
  229.    }
  230.  
  231. /*
  232.  * clr_dpnd - delete all dependencies for the given source file.
  233.  */
  234. novalue clr_dpnd(srcname)
  235. char *srcname;
  236.    {
  237.    src_lkup(srcname)->dependents = NULL;
  238.    }
  239.  
  240. /*
  241.  * dumpdb - write the updated data base.
  242.  */
  243. novalue dumpdb(dbname)
  244. char *dbname;
  245.    {
  246. #ifdef Rttx
  247.    fprintf(stdout, "rtt was compiled to only support the intepreter, use -x\n");
  248.    exit(ErrorExit);
  249. #else                    /* Rttx */
  250.    FILE *db;
  251.    struct implement **sort_ary;
  252.    int ary_sz;
  253.    int i;
  254.  
  255.  
  256. #if MVS
  257.    /*
  258.     * Avoid problems with MVS line length restrictions.
  259.     */
  260.    db = fopen(dbname, "wb");
  261. #else                                   /* MVS */
  262.    db = fopen(dbname, "w");
  263. #endif                                  /* MVS */
  264.  
  265.    if (db == NULL)
  266.       err2("cannot open data base for output:", dbname);
  267.    if(newdb)
  268.       fprintf(stdout, "creating new data base: %s\n", dbname);
  269.  
  270.    /*
  271.     * The data base starts with a version number associated with this
  272.     *   version of rtt and an indication of whether LargeInts was
  273.     *   defined during the build.
  274.     */
  275.    fprintf(db, "%s %s\n\n", DVersion, largeints);
  276.  
  277.    fprintf(db, "\ntypes\n\n");          /* start of type code section */
  278.    for (i = 0; i < num_typs; ++i)
  279.       fprintf(db, "   T%d: %s\n", i, icontypes[i].id);
  280.    fprintf(db, "\n$endsect\n\n");       /* end of section for type codes */
  281.  
  282.    fprintf(db, "\ncomponents\n\n");     /* start of component code section */
  283.    for (i = 0; i < num_cmpnts; ++i)
  284.       fprintf(db, "   C%d: %s\n", i, typecompnt[i].id);
  285.    fprintf(db, "\n$endsect\n\n");       /* end of section for component codes */
  286.  
  287.    /*
  288.     * Allocate an array for sorting operation entries. It must be
  289.     *   large enough to hold functions, operators, or keywords.
  290.     */
  291.    ary_sz = Max(num_fnc, num_op);
  292.    ary_sz = Max(ary_sz, num_key);
  293.    if (ary_sz > 0)
  294.       sort_ary = (struct implement**)alloc((unsigned int)(ary_sz *
  295.            sizeof(struct implement*)));
  296.    else
  297.       sort_ary = NULL;
  298.  
  299.    /*
  300.     * Sort and print to the data base the enties for each of the
  301.     *   three operation sections.
  302.     */
  303.    prt_impls(db, "functions", bhash, num_fnc, sort_ary, name_cmp);
  304.    prt_impls(db, "\noperators", ohash, num_op, sort_ary, op_cmp);
  305.    prt_impls(db, "\nkeywords", khash, num_key, sort_ary, name_cmp);
  306.    if (ary_sz > 0)
  307.       free((char *)sort_ary);
  308.  
  309.    /*
  310.     * Print the dependancy information to the data base.
  311.     */
  312.    prt_dpnd(db);
  313.    if (fclose(db) != 0)
  314.      err2("cannot close ", dbname);
  315. #endif                    /* Rttx */
  316.    }
  317.  
  318. #ifndef Rttx
  319. /*
  320.  * prt_impl - sort and print to the data base the enties from one
  321.  *   of the operation tables.
  322.  */
  323. static novalue prt_impls(db, sect, tbl, num, sort_ary, cmp)
  324. FILE *db;
  325. char *sect;
  326. struct implement **tbl;
  327. int num;
  328. struct implement **sort_ary;
  329. int (*cmp)();
  330.    {
  331.    int i;
  332.    int j;
  333.    unsigned hashval;
  334.    struct implement *ip;
  335.  
  336.    /*
  337.     * Each operation section begins with the section name.
  338.     */
  339.    fprintf(db, "%s\n\n", sect);
  340.  
  341.    /*
  342.     * Sort the table entries before printing.
  343.     */
  344.    if (num > 0) {
  345.       i = 0;
  346.       for (hashval = 0; hashval < IHSize; ++hashval)
  347.          for (ip = tbl[hashval]; ip != NULL; ip = ip->blink)
  348.             sort_ary[i++] = ip;
  349.       qsort((char *)sort_ary, num, sizeof(struct implement *), cmp);
  350.       }
  351.  
  352.    /*
  353.     * Output each entry to the data base.
  354.     */
  355.    for (i = 0; i < num; ++i) {
  356.       ip = sort_ary[i];
  357.  
  358.       /*
  359.        * Operators have operator symbols.
  360.        */
  361.       if (ip->op != NULL)
  362.          fprintf(db, "%s\t", ip->op);
  363.  
  364.       /*
  365.        * Print the operation name, the unique prefix used to generate
  366.        *   C function names, and the number of parameters to the operation.
  367.        */
  368.       fprintf(db, "%s\t%c%c %d(", ip->name, ip->prefix[0], ip->prefix[1],
  369.          ip->nargs);
  370.  
  371.       /*
  372.        * For each parameter, write and indication of whether a dereferenced
  373.        *   value, 'd', and/or and undereferenced value, 'u', is needed.
  374.        */
  375.       for (j = 0; j < ip->nargs; ++j) {
  376.          if (j > 0)
  377.             fprintf(db, ",");
  378.          if (ip->arg_flgs[j] & RtParm)
  379.             fprintf(db, "u");
  380.          if (ip->arg_flgs[j] & DrfPrm)
  381.             fprintf(db, "d");
  382.          }
  383.  
  384.       /*
  385.        * Indicate if the last parameter represents the tail of a
  386.        *   variable length argument list.
  387.        */
  388.       if (ip->nargs > 0 && ip->arg_flgs[ip->nargs - 1] & VarPrm)
  389.          fprintf(db, "v");
  390.       fprintf(db, ")\t{");
  391.  
  392.       /*
  393.        * Print the min and max result sequence length.
  394.        */
  395.       if (ip->min_result != NoRsltSeq) {
  396.          fprintf(db, "%ld,", ip->min_result);
  397.          if (ip->max_result == UnbndSeq)
  398.             fprintf(db, "*");
  399.          else
  400.             fprintf(db, "%ld", ip->max_result);
  401.          if (ip->resume)
  402.             fprintf(db, "+");
  403.          }
  404.       fprintf(db, "} ");
  405.  
  406.       /*
  407.        * Print the return/suspend/fail/fall-through flag and an indication
  408.        *   of whether the operation explicitly uses the result location
  409.        *   (as opposed to an implicit use via return or suspend).
  410.        */
  411.       ret_flag(db, ip->ret_flag, 0);
  412.       if (ip->use_rslt)
  413.          fprintf(db, "t ");
  414.       else
  415.          fprintf(db, "f ");
  416.  
  417.       /*
  418.        * Print the descriptive comment associated with the operation.
  419.        */
  420.       fprintf(db, "\n\"%s\"\n", ip->comment);
  421.  
  422.       /*
  423.        * Print information about tended declarations from the declare
  424.        *  statement. The number of tended variables is printed followed
  425.        *  by an entry for each variable. Each entry consists of the
  426.        *  type of the declaration
  427.        * 
  428.        *     struct descrip  -> desc
  429.        *     char *          -> str
  430.        *     struct b_xxx *  -> blkptr b_xxx
  431.        *     union block *   -> blkptr *
  432.        *
  433.        *  followed by the C code for the initializer (nil indicates none).
  434.        */
  435.       fprintf(db, "%d ", ip->ntnds);
  436.       for (j = 0; j < ip->ntnds; ++j) {
  437.          switch (ip->tnds[j].var_type) {
  438.             case TndDesc:
  439.                fprintf(db, "desc ");
  440.                break;
  441.             case TndStr:
  442.                fprintf(db, "str ");
  443.                break;
  444.             case TndBlk:
  445.                fprintf(db, "blkptr ");
  446.                if (ip->tnds[j].blk_name == NULL)
  447.                   fprintf(db, "* ");
  448.                else
  449.                   fprintf(db, "%s ", ip->tnds[j].blk_name);
  450.                break;
  451.             }
  452.          put_ilc(db, ip->tnds[j].init);
  453.          }
  454.  
  455.       /*
  456.        * Print information about non-tended declarations from the declare
  457.        *  statement. The number of variables is printed followed by an
  458.        *  entry for each variable. Each entry consists of the variable
  459.        *  name followed by the complete C code for the declaration.
  460.        */
  461.       fprintf(db, "\n%d ", ip->nvars);
  462.       for (j = 0; j < ip->nvars; ++j) {
  463.          fprintf(db, "%s ", ip->vars[j].name);
  464.          put_ilc(db, ip->vars[j].dcl);
  465.          }
  466.       fprintf(db, "\n");
  467.  
  468.       /*
  469.        * Output the "executable" code (includes abstract code) for the
  470.        *   operation.
  471.        */
  472.       put_inlin(db, ip->in_line);
  473.       fprintf(db, "\n$end\n\n");    /* end of operation entry */
  474.       }
  475.    fprintf(db, "$endsect\n\n");     /* end of section for operation type */
  476.    }
  477.  
  478. /*
  479.  * put_inlin - put in-line code into the data base file. This is the
  480.  *   code used by iconc to perform type infernence for the operation
  481.  *   and to generate a tailored version of the operation.
  482.  */
  483. static novalue put_inlin(db, il)
  484. FILE *db;
  485. struct il_code *il;
  486.    {
  487.    int i;
  488.    int num_cases;
  489.    int indx;
  490.  
  491.    /*
  492.     * RTL statements are handled by this function. Other functions
  493.     *  are called for C code.
  494.     */
  495.    if (il == NULL) {
  496.       fprintf(db, "nil ");
  497.       return;
  498.       }
  499.  
  500.    switch (il->il_type) {
  501.       case IL_Const:
  502.          /*
  503.           * Constant keyword.
  504.           */
  505.          fprintf(db, "const ");
  506.          put_typcd(db, il->u[0].n);              /* type  code */
  507.          fputs(il->u[1].s, db); fputc(' ', db);  /* literal */
  508.          break;
  509.       case IL_If1:
  510.          /*
  511.           * if-then statment.
  512.           */
  513.          fprintf(db, "if1 ");
  514.          put_inlin(db, il->u[0].fld);            /* condition */
  515.          fprintf(db, "\n");
  516.          put_inlin(db, il->u[1].fld);            /* then clause */
  517.          break;
  518.       case IL_If2:
  519.          /*
  520.           * if-then-else statment.
  521.           */
  522.          fprintf(db, "if2 ");
  523.          put_inlin(db, il->u[0].fld);            /* condition */
  524.          fprintf(db, "\n");
  525.          put_inlin(db, il->u[1].fld);            /* then clause */
  526.          fprintf(db, "\n");
  527.          put_inlin(db, il->u[2].fld);            /* else clause */
  528.          break;
  529.       case IL_Tcase1:
  530.          /*
  531.           * type_case statement with no default clause.
  532.           */
  533.          fprintf(db, "tcase1 ");
  534.          put_case(db, il);
  535.          break;
  536.       case IL_Tcase2:
  537.          /*
  538.           * type_case statement with a default clause.
  539.           */
  540.          fprintf(db, "tcase2 ");
  541.          indx = put_case(db, il);
  542.          fprintf(db, "\n");
  543.          put_inlin(db, il->u[indx].fld);         /* default */
  544.          break;
  545.       case IL_Lcase:
  546.          /*
  547.           * len_case statement.
  548.           */
  549.          fprintf(db, "lcase ");
  550.          num_cases = il->u[0].n;
  551.          fprintf(db, "%d ", num_cases);
  552.          indx = 1;
  553.          for (i = 0; i < num_cases; ++i) {
  554.             fprintf(db, "\n%d ", il->u[indx++].n);    /* selection number */
  555.             put_inlin(db, il->u[indx++].fld);        /* action */
  556.             }
  557.          fprintf(db, "\n");
  558.          put_inlin(db, il->u[indx].fld);             /* default */
  559.          break;
  560.       case IL_Acase:
  561.          /*
  562.           * arith_case statement.
  563.           */
  564.          fprintf(db, "acase ");
  565.          put_inlin(db, il->u[0].fld);               /* first variable */
  566.          put_inlin(db, il->u[1].fld);               /* second variable */
  567.          fprintf(db, "\n");
  568.          put_inlin(db, il->u[2].fld);               /* C_integer action */
  569.          fprintf(db, "\n");
  570.          put_inlin(db, il->u[3].fld);               /* integer action */
  571.          fprintf(db, "\n");
  572.          put_inlin(db, il->u[4].fld);               /* C_double action */
  573.          break;
  574.       case IL_Err1:
  575.          /*
  576.           * runerr with no value argument.
  577.           */
  578.          fprintf(db, "runerr1 ");
  579.          fprintf(db, "%d ", il->u[0].n);      /* error number */
  580.          break;
  581.       case IL_Err2:
  582.          /*
  583.           * runerr with a value argument.
  584.           */
  585.          fprintf(db, "runerr2 ");
  586.          fprintf(db, "%d ", il->u[0].n);      /* error number */
  587.          put_inlin(db, il->u[1].fld);          /* variable */
  588.          break;
  589.       case IL_Lst:
  590.          /*
  591.           * "glue" to string statements together.
  592.           */
  593.          fprintf(db, "lst ");
  594.          put_inlin(db, il->u[0].fld);
  595.          fprintf(db, "\n");
  596.          put_inlin(db, il->u[1].fld);
  597.          break;
  598.       case IL_Bang:
  599.          /*
  600.           * ! operator from type checking.
  601.           */
  602.          fprintf(db, "! ");
  603.          put_inlin(db, il->u[0].fld);
  604.          break;
  605.       case IL_And:
  606.          /*
  607.           * && operator from type checking.
  608.           */
  609.          fprintf(db, "&& ");
  610.          put_inlin(db, il->u[0].fld);
  611.          put_inlin(db, il->u[1].fld);
  612.          break;
  613.       case IL_Cnv1:
  614.          /*
  615.           * cnv:<dest-type>(<source>)
  616.           */
  617.          fprintf(db, "cnv1 ");
  618.          put_typcd(db, il->u[0].n);      /* type code */
  619.          put_inlin(db, il->u[1].fld);    /* source */
  620.          break;
  621.       case IL_Cnv2:
  622.          /*
  623.           * cnv:<dest-type>(<source>,<destination>)
  624.           */
  625.          fprintf(db, "cnv2 ");
  626.          put_typcd(db, il->u[0].n);      /* type code */
  627.          put_inlin(db, il->u[1].fld);    /* source */
  628.          put_ilc(db, il->u[2].c_cd);     /* destination */
  629.          break;
  630.       case IL_Def1:
  631.          /*
  632.           * def:<dest-type>(<source>,<default-value>)
  633.           */
  634.          fprintf(db, "def1 ");
  635.          put_typcd(db, il->u[0].n);      /* type code */
  636.          put_inlin(db, il->u[1].fld);    /* source */
  637.          put_ilc(db, il->u[2].c_cd);     /* default value */
  638.          break;
  639.       case IL_Def2:
  640.          /*
  641.           * def:<dest-type>(<source>,<default-value>,<destination>)
  642.           */
  643.          fprintf(db, "def2 ");
  644.          put_typcd(db, il->u[0].n);      /* type code */
  645.          put_inlin(db, il->u[1].fld);    /* source */
  646.          put_ilc(db, il->u[2].c_cd);     /* default value */
  647.          put_ilc(db, il->u[3].c_cd);     /* destination */
  648.          break;
  649.       case IL_Is:
  650.          /*
  651.           * is:<type-name>(<variable>)
  652.           */
  653.          fprintf(db, "is ");
  654.          put_typcd(db, il->u[0].n);      /* type code */
  655.          put_inlin(db, il->u[1].fld);    /* variable */
  656.          break;
  657.       case IL_Var:
  658.          /*
  659.           * A variable.
  660.           */
  661.          fprintf(db, "%d ", il->u[0].n);    /* symbol table index */
  662.          break;
  663.       case IL_Subscr:
  664.          /*
  665.           * A subscripted variable.
  666.           */
  667.          fprintf(db, "[ ");
  668.          fprintf(db, "%d ", il->u[0].n);    /* symbol table index */
  669.          fprintf(db, "%d ", il->u[1].n);    /* subscripting index */
  670.          break;
  671.       case IL_Block:
  672.          /*
  673.           * A block of in-line code. 
  674.           */
  675.          fprintf(db, "block ");
  676.          if (il->u[0].n)
  677.             fprintf(db, "t ");              /* execution can fall through */
  678.          else
  679.             fprintf(db, "_ ");              /* execution cannot fall through */
  680.           /*
  681.            * Output a symbol table of tended variables.
  682.            */
  683.          fprintf(db, "%d ", il->u[1].n);    /* number of local tended */
  684.          for (i = 2; i - 2 < il->u[1].n; ++i)
  685.              switch (il->u[i].n) {
  686.                 case TndDesc:
  687.                    fprintf(db, "desc ");
  688.                    break;
  689.                 case TndStr:
  690.                    fprintf(db, "str ");
  691.                    break;
  692.                 case TndBlk:
  693.                    fprintf(db, "blkptr ");
  694.                    break;
  695.                 }
  696.          put_ilc(db, il->u[i].c_cd);         /* body of block */
  697.          break;
  698.       case IL_Call:
  699.          /*
  700.           * A call to a body function.
  701.           */
  702.          fprintf(db, "call ");
  703.  
  704.          /*
  705.           * Each body function has a 3rd prefix character to distingish
  706.           *  it from other functions for the operation.
  707.           */
  708.          fprintf(db, "%c ", (char)il->u[1].n);
  709.  
  710.          /*
  711.           * A body function that would only return one possible signal
  712.           *   need return none. In which case, it can directly return a
  713.           *   C integer or double directly rather than using a result
  714.           *   descriptor location. Indicate what it does.
  715.           */
  716.          switch (il->u[2].n) {
  717.             case RetInt:
  718.                fprintf(db, "i ");  /* directly return integer */
  719.                break;
  720.             case RetDbl:
  721.                fprintf(db, "d ");  /* directly return double */
  722.                break;
  723.             case RetNoVal:
  724.                fprintf(db, "n ");  /* return nothing directly */
  725.                break;
  726.             case RetSig:
  727.                fprintf(db, "s ");  /* return a signal */
  728.                break;
  729.             }
  730.  
  731.          /*
  732.           * Output the return/suspend/fail/fall-through flag.
  733.           */
  734.          ret_flag(db, il->u[3].n, 1);
  735.  
  736.          /*
  737.           * Indicate whether the body function expects to have
  738.           *   an explicit result location passed to it.
  739.           */
  740.          if (il->u[4].n)
  741.             fprintf(db, "t ");
  742.          else
  743.             fprintf(db, "f ");
  744.  
  745.          fprintf(db, "%d ", il->u[5].n);    /* num string bufs */
  746.          fprintf(db, "%d ", il->u[6].n);    /* num cset bufs */
  747.          i = il->u[7].n;
  748.          fprintf(db, "%d ", i);             /* num args */
  749.          indx = 8;
  750.          /*
  751.           * output prototype paramater declarations and actual arguments.
  752.           */
  753.          i *= 2;
  754.          while (i--)
  755.             put_ilc(db, il->u[indx++].c_cd);
  756.          break;
  757.       case IL_Abstr:
  758.          /*
  759.           * Abstract type computation.
  760.           */
  761.          fprintf(db, "abstr ");
  762.          put_inlin(db, il->u[0].fld);    /* side effects */
  763.          put_inlin(db, il->u[1].fld);    /* return type */
  764.          break;
  765.       case IL_VarTyp:
  766.          /*
  767.           * type(<parameter>)
  768.           */
  769.          fprintf(db, "vartyp ");
  770.          put_inlin(db, il->u[0].fld);    /* variable */
  771.          break;
  772.       case IL_Store:
  773.          /*
  774.           * store[<type>]
  775.           */
  776.          fprintf(db, "store ");
  777.          put_inlin(db, il->u[0].fld);    /* type to be "dereferenced "*/
  778.          break;
  779.       case IL_Compnt:
  780.          /*
  781.           * <type>.<component>
  782.           */
  783.          fprintf(db, ". ");
  784.          put_inlin(db, il->u[0].fld);    /* type */
  785.          if (il->u[1].n == CM_Fields)
  786.              fprintf(db, "f ");          /* special case record fields */
  787.          else
  788.              fprintf(db, "C%d ", (int)il->u[1].n); /* component table index */
  789.          break;
  790.       case IL_TpAsgn:
  791.          /*
  792.           * store[<variable-type>] = <value-type>
  793.           */
  794.          fprintf(db, "= ");
  795.          put_inlin(db, il->u[0].fld);    /* variable type */
  796.          put_inlin(db, il->u[1].fld);    /* value type */
  797.          break;
  798.       case IL_Union:
  799.          /*
  800.           * <type 1> ++ <type 2>
  801.           */
  802.          fprintf(db, "++ ");
  803.          put_inlin(db, il->u[0].fld);
  804.          put_inlin(db, il->u[1].fld);
  805.          break;
  806.       case IL_Inter:
  807.          /*
  808.           * <type 1> ** <type 2>
  809.           */
  810.          fprintf(db, "** ");
  811.          put_inlin(db, il->u[0].fld);
  812.          put_inlin(db, il->u[1].fld);
  813.          break;
  814.       case IL_New:
  815.          /*
  816.           * new <type-name>(<type 1> , ...)
  817.           */
  818.          fprintf(db, "new ");
  819.          put_typcd(db, il->u[0].n);      /* type code */
  820.          i = il->u[1].n;
  821.          fprintf(db, "%d ", i);          /* num args */
  822.          indx = 2;
  823.          while (i--)
  824.             put_inlin(db, il->u[indx++].fld);
  825.          break;
  826.       case IL_IcnTyp:
  827.          /*
  828.           * <type-name>
  829.           */
  830.          fprintf(db, "typ ");
  831.          put_typcd(db, il->u[0].n);      /* type code */
  832.          break;
  833.       }
  834.    }
  835.  
  836. /*
  837.  * put_case - put the cases of a type_case statement into the data base file.
  838.  */
  839. static int put_case(db, il)
  840. FILE *db;
  841. struct il_code *il;
  842.    {
  843.    int *typ_vect;
  844.    int i, j;
  845.    int num_cases;
  846.    int num_types;
  847.    int indx;
  848.  
  849.    put_inlin(db, il->u[0].fld);               /* expression being checked */
  850.    num_cases = il->u[1].n;                    /* number of cases */
  851.    fprintf(db, "%d ", num_cases);
  852.    indx = 2;
  853.    for (i = 0; i < num_cases; ++i) {
  854.       num_types = il->u[indx++].n;             /* number of types in case */
  855.       fprintf(db, "\n%d ", num_types);
  856.       typ_vect = il->u[indx++].vect;          /* vector of type codes */
  857.       for (j = 0; j < num_types; ++j)
  858.          put_typcd(db, typ_vect[j]);          /* type code */
  859.       put_inlin(db, il->u[indx++].fld);       /* action */
  860.       }
  861.    return indx;
  862.    }
  863.  
  864. /*
  865.  * put_typcd - convert a numeric type code into an alpha type code and
  866.  *  put it in the data base file.
  867.  */
  868. static novalue put_typcd(db, typcd)
  869. FILE *db;
  870. int typcd;
  871.    {
  872.    if (typcd >= 0)
  873.       fprintf(db, "T%d ", typcd);
  874.    else {
  875.       switch (typcd) {
  876.          case TypAny:
  877.             fprintf(db, "a ");       /* any_value */
  878.             break;
  879.          case TypEmpty:
  880.             fprintf(db, "e ");       /* empty_type */
  881.             break;
  882.          case TypVar:
  883.             fprintf(db, "v ");       /* variable */
  884.             break;
  885.          case TypCInt:
  886.             fprintf(db, "ci ");    /* C_integer */
  887.             break;
  888.          case TypCDbl:
  889.             fprintf(db, "cd ");    /* C_double */
  890.             break;
  891.          case TypCStr:
  892.             fprintf(db, "cs ");    /* C_string */
  893.             break;
  894.          case TypEInt:
  895.             fprintf(db, "ei ");    /* (exact)integer) */
  896.             break;
  897.          case TypECInt:
  898.             fprintf(db, "eci ");   /* (exact)C_integer */
  899.             break;
  900.          case TypTStr:
  901.             fprintf(db, "ts ");    /* tmp_string */
  902.             break;
  903.          case TypTCset:
  904.             fprintf(db, "tc ");    /* tmp_cset */
  905.             break;
  906.          case RetDesc:
  907.             fprintf(db, "d ");     /* plain descriptor on return/suspend */
  908.             break;
  909.          case RetNVar:
  910.             fprintf(db, "nv ");    /* named_var */
  911.             break;
  912.          case RetSVar:
  913.             fprintf(db, "sv ");    /* struct_var */
  914.             break;
  915.          case RetNone:
  916.             fprintf(db, "rn ");   /* preset result location on return/suspend */
  917.             break;
  918.          }
  919.       }
  920.    }
  921.  
  922. /*
  923.  * put_ilc - put in-line C code in the data base file.
  924.  */
  925. static novalue put_ilc(db, ilc)
  926. FILE *db;
  927. struct il_c *ilc;
  928.    {
  929.    /*
  930.     * In-line C code is either "nil" or code bracketed by $c $e.
  931.     *   The bracketed code consists of text for C code plus special
  932.     *   constructs starting with $. Control structures have been
  933.     *   translated into gotos in the form of special constructs
  934.     *   (note that case statements are not supported in in-line code).
  935.     */
  936.    if (ilc == NULL) {
  937.       fprintf(db, "nil ");
  938.       return;
  939.       }
  940.    fprintf(db, "$c ");
  941.    while (ilc != NULL) {
  942.       switch(ilc->il_c_type) {
  943.          case ILC_Ref:
  944.             put_var(db, 'r', ilc);   /* non-modifying reference to variable */
  945.             break;
  946.          case ILC_Mod:
  947.             put_var(db, 'm', ilc);   /* modifying reference to variable */
  948.             break;
  949.          case ILC_Tend:
  950.             put_var(db, 't', ilc);   /* variable declared tended */
  951.             break;
  952.          case ILC_SBuf:
  953.             fprintf(db, "$sb ");     /* string buffer for tmp_string */
  954.             break;
  955.          case ILC_CBuf:
  956.             fprintf(db, "$cb ");     /* cset buffer for tmp_cset */
  957.             break;
  958.          case ILC_Ret:
  959.             fprintf(db, "$ret ");    /* return statement */
  960.             put_ret(db, ilc);
  961.             break;
  962.          case ILC_Susp:
  963.             fprintf(db, "$susp ");   /* suspend statement */
  964.             put_ret(db, ilc);
  965.             break;
  966.          case ILC_Fail:
  967.             fprintf(db, "$fail ");   /* fail statement */
  968.             break;
  969.          case ILC_EFail:
  970.             fprintf(db, "$efail ");  /* errorfail statement */
  971.             break;
  972.          case ILC_Goto:
  973.             fprintf(db, "$goto %d ", ilc->n);  /* goto label */
  974.             break;
  975.          case ILC_CGto:
  976.             fprintf(db, "$cgoto ");            /* conditional goto */
  977.             put_ilc(db, ilc->code[0]);         /* condition (with $c $e) */
  978.             fprintf(db, "%d ", ilc->n);        /* label */
  979.             break;
  980.          case ILC_Lbl:
  981.             fprintf(db, "$lbl %d ", ilc->n);   /* label */
  982.             break;
  983.          case ILC_LBrc:
  984.             fprintf(db, "${ ");                /* start of C block with dcls */
  985.             break;
  986.          case ILC_RBrc:
  987.             fprintf(db, "$} ");                /* end of C block with dcls */
  988.             break;
  989.          case ILC_Str:
  990.             fprintf(db, "%s", ilc->s);         /* C code as plain text */
  991.             break;
  992.          }
  993.       ilc = ilc->next;
  994.       }
  995.    fprintf(db, " $e ");
  996.    }
  997.  
  998. /*
  999.  * put_var - output in-line C code for a variable.
  1000.  */
  1001. static novalue put_var(db, code, ilc)
  1002. FILE *db;
  1003. int code;
  1004. struct il_c *ilc;
  1005.    {
  1006.    fprintf(db, "$%c", code);  /* 'r': non-mod ref, 'm': mod ref, 't': tended */
  1007.    if (ilc->s != NULL)
  1008.       fprintf(db, "%s", ilc->s);  /* access into descriptor */
  1009.    if (ilc->n == RsltIndx)
  1010.       fprintf(db, "r ");          /* this is "result" */
  1011.    else
  1012.       fprintf(db, "%d ", ilc->n); /* offset into a symbol table */
  1013.    }
  1014.  
  1015. /*
  1016.  * ret_flag - put a return/suspend/fail/fall-through flag in the data base
  1017.  *  file.
  1018.  */
  1019. static novalue ret_flag(db, flag, may_fthru)
  1020. FILE *db;
  1021. int flag;
  1022. int may_fthru;
  1023.    {
  1024.    if (flag & DoesFail)
  1025.       fprintf(db, "f");      /* can fail */
  1026.    else
  1027.       fprintf(db, "_");      /* cannot fail */
  1028.    if (flag & DoesRet)
  1029.       fprintf(db, "r");      /* can return */
  1030.    else
  1031.       fprintf(db, "_");      /* cannot return */
  1032.    if (flag & DoesSusp)
  1033.       fprintf(db, "s");      /* can suspend */
  1034.    else
  1035.       fprintf(db, "_");      /* cannot suspend */
  1036.    if (flag & DoesEFail)
  1037.       fprintf(db, "e");      /* can do error conversion */
  1038.    else
  1039.       fprintf(db, "_");      /* cannot do error conversion */
  1040.    if (may_fthru)            /* body functions only: */
  1041.       if (flag & DoesFThru)
  1042.          fprintf(db, "t");      /* can fall through */
  1043.       else
  1044.          fprintf(db, "_");      /* cannot fall through */
  1045.   fprintf(db, " ");
  1046.   }
  1047.  
  1048. /*
  1049.  * put_ret - put the body of a return/suspend statement in the data base.
  1050.  */
  1051. static novalue put_ret(db, ilc)
  1052. FILE *db;
  1053. struct il_c *ilc;
  1054.    {
  1055.    int i;
  1056.  
  1057.    /*
  1058.     * Output the type of descriptor constructor on the return/suspend,
  1059.     *  then output the the number of arguments to the constructor, and
  1060.     *  the arguments themselves.
  1061.     */
  1062.    put_typcd(db, ilc->n);
  1063.    for (i = 0; i < 3 && ilc->code[i] != NULL; ++i)
  1064.        ;
  1065.    fprintf(db, "%d ", i);
  1066.    for (i = 0; i < 3 && ilc->code[i] != NULL; ++i)
  1067.        put_ilc(db, ilc->code[i]);
  1068.    }
  1069.  
  1070. /*
  1071.  * name_cmp - compare implementation structs by name; function used as
  1072.  *  an argument to qsort().
  1073.  */
  1074. static int name_cmp(p1, p2)
  1075. char *p1;
  1076. char *p2;
  1077.    {
  1078.    register struct implement *ip1;
  1079.    register struct implement *ip2;
  1080.  
  1081.    ip1 = *(struct implement **)p1;
  1082.    ip2 = *(struct implement **)p2;
  1083.    return strcmp(ip1->name, ip2->name);
  1084.    }
  1085.  
  1086. /*
  1087.  * op_cmp - compare implementation structs by operator and number of args;
  1088.  *   function used as an argument to qsort().
  1089.  */
  1090. static int op_cmp(p1, p2)
  1091. char *p1;
  1092. char *p2;
  1093.    {
  1094.    register int cmp;
  1095.    register struct implement *ip1;
  1096.    register struct implement *ip2;
  1097.  
  1098.    ip1 = *(struct implement **)p1;
  1099.    ip2 = *(struct implement **)p2;
  1100.  
  1101.    cmp = strcmp(ip1->op, ip2->op);
  1102.    if (cmp == 0)
  1103.       return ip1->nargs - ip2->nargs;
  1104.    else
  1105.       return cmp;
  1106.    }
  1107.  
  1108. /*
  1109.  * prt_dpnd - print dependency information to the data base.
  1110.  */
  1111. static novalue prt_dpnd(db)
  1112. FILE *db;
  1113.    {
  1114.    struct srcfile **sort_ary;
  1115.    struct srcfile *sfile;
  1116.    unsigned hashval;
  1117.    int line_left;
  1118.    int num;
  1119.    int i;
  1120.  
  1121.    fprintf(db, "\ndependencies\n\n");  /* start of dependency section */
  1122.  
  1123.    /*
  1124.     * sort the dependency information by source file name.
  1125.     */
  1126.    num = 0;
  1127.    if (num_src > 0) {
  1128.       sort_ary = (struct srcfile **)alloc((unsigned int)(num_src *
  1129.          sizeof(struct srcfile *)));
  1130.       for (hashval = 0; hashval < DHSize; ++hashval)
  1131.          for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next)
  1132.             sort_ary[num++] = sfile;
  1133.       qsort((char *)sort_ary, num, sizeof(struct srcfile *),
  1134.          (int (*)())src_cmp);
  1135.       }
  1136.  
  1137.    /*
  1138.     * For each source file with dependents, output the source file
  1139.     *  name followed by the list of dependent files. The list is
  1140.     *  terminated with "end".
  1141.     */
  1142.    for (i = 0; i < num; ++i) {
  1143.       sfile = sort_ary[i];
  1144.       if (sfile->dependents != NULL) {
  1145.          fprintf(db, "%-12s  ", sfile->name);
  1146.          line_left = prt_c_fl(db, sfile->dependents, MaxLine - 14);
  1147.          if (line_left - 4 < 0)
  1148.             fprintf(db, "\n            ");
  1149.          fprintf(db, "$end\n");
  1150.          }
  1151.       }
  1152.    fprintf(db, "\n$endsect\n");  /* end of dependency section */
  1153.    if (num_src > 0)
  1154.       free((char *)sort_ary);
  1155.    }
  1156.  
  1157. /*
  1158.  * src_cmp - compare srcfile structs; function used as an argument to qsort().
  1159.  */
  1160. static int src_cmp(p1, p2)
  1161. char *p1;
  1162. char *p2;
  1163.    {
  1164.    register struct srcfile *sp1;
  1165.    register struct srcfile *sp2;
  1166.  
  1167.    sp1 = *(struct srcfile **)p1;
  1168.    sp2 = *(struct srcfile **)p2;
  1169.    return strcmp(sp1->name, sp2->name);
  1170.    }
  1171.  
  1172. /*
  1173.  * prt_c_fl - print list of C files in reverse order.
  1174.  */
  1175. static int prt_c_fl(db, clst, line_left)
  1176. FILE *db;
  1177. struct cfile *clst;
  1178. int line_left;
  1179.    {
  1180.    int len;
  1181.  
  1182.    if (clst == NULL)
  1183.       return line_left;
  1184.    line_left = prt_c_fl(db, clst->next, line_left);
  1185.  
  1186.    /*
  1187.     * If this will exceed the line length, print a new-line and some
  1188.     *  leading white space.
  1189.     */
  1190.    len = strlen(clst->name) + 1;
  1191.    if (line_left - len < 0) {
  1192.       fprintf(db, "\n              ");
  1193.       line_left = MaxLine - 14;
  1194.       }
  1195.    fprintf(db, "%s ", clst->name);
  1196.    return line_left - len;
  1197.    }
  1198. #endif                    /* Rttx */
  1199.  
  1200. /*
  1201.  * full_lst - print a full list of all files produced by translations
  1202.  *  as represented in the dependencies section of the data base.
  1203.  */
  1204. novalue full_lst(fname)
  1205. char *fname;
  1206.    {
  1207.    unsigned hashval;
  1208.    struct srcfile *sfile;
  1209.    struct cfile *clst;
  1210.    struct fileparts *fp;
  1211.    FILE *f;
  1212.  
  1213.    f = fopen(fname, "w");
  1214.    if (f == NULL)
  1215.       err2("cannot open ", fname);
  1216.    for (hashval = 0; hashval < DHSize; ++hashval)
  1217.       for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next)
  1218.          for (clst = sfile->dependents; clst != NULL; clst = clst->next) {
  1219.             /*
  1220.              * Remove the suffix from the name before printing.
  1221.              */
  1222.             fp = fparse(clst->name);
  1223.  
  1224. #if MVS
  1225.             if (*fp->member)
  1226.                fprintf(f, "%s(%s\n", fp->name, fp->member);
  1227.             else
  1228. #endif                                  /* MVS */
  1229.  
  1230.             fprintf(f, "%s\n", fp->name);
  1231.             }
  1232.    if (fclose(f) != 0)
  1233.       err2("cannot close ", fname);
  1234.    }
  1235.  
  1236. /*
  1237.  * impl_fnc - find or create implementation struct for function currently
  1238.  *  being parsed.
  1239.  */
  1240. novalue impl_fnc(name)
  1241. struct token *name;
  1242.    {
  1243.    /*
  1244.     * Set the global operation type for later use. If this is a
  1245.     *  new function update the number of them.
  1246.     */
  1247.    op_type = Function;
  1248.    num_fnc = set_impl(name, bhash, num_fnc, fnc_pre);
  1249.    }
  1250.  
  1251. /*
  1252.  * impl_key - find or create implementation struct for keyword currently
  1253.  *  being parsed.
  1254.  */
  1255. novalue impl_key(name)
  1256. struct token *name;
  1257.    {
  1258.    /*
  1259.     * Set the global operation type for later use. If this is a
  1260.     *  new keyword update the number of them.
  1261.     */
  1262.    op_type = Keyword;
  1263.    num_key = set_impl(name, khash, num_key, key_pre);
  1264.    }
  1265.  
  1266. /*
  1267.  * set_impl - lookup a function or keyword in a hash table and update the
  1268.  *  entry, creating the entry if needed.
  1269.  */
  1270. static int set_impl(name, tbl, num_impl, pre)
  1271. struct token *name;
  1272. struct implement **tbl;
  1273. int num_impl;
  1274. char *pre;
  1275.    {
  1276.    register struct implement *ptr;
  1277.    char *name_s;
  1278.    unsigned hashval;
  1279.  
  1280.    /*
  1281.     * we only need the operation name and not the entire token.
  1282.     */
  1283.    name_s = name->image;
  1284.    free_t(name);
  1285.  
  1286.    /*
  1287.     * If the operation is not in the hash table, put it there.
  1288.     */
  1289.    if ((ptr = db_ilkup(name_s, tbl)) == NULL) {
  1290.       ptr = NewStruct(implement);
  1291.       hashval = IHasher(name_s);
  1292.       ptr->blink = tbl[hashval];
  1293.       ptr->oper_typ = ((op_type == Function) ? 'F' : 'K');
  1294.       nxt_pre(ptr->prefix, pre, 2);    /* allocate a unique prefix */
  1295.       ptr->name = name_s;
  1296.       ptr->op = NULL;
  1297.       tbl[hashval] = ptr;
  1298.       ++num_impl;
  1299.       }
  1300.  
  1301.    cur_impl = ptr;   /* put entry in global variable for later access */
  1302.  
  1303.    /*
  1304.     * initialize the entry based on global information set during parsing.
  1305.     */
  1306.    set_prms(ptr);
  1307.    ptr->min_result = min_rs;
  1308.    ptr->max_result = max_rs;
  1309.    ptr->resume = rsm_rs;
  1310.    ptr->ret_flag = 0;
  1311.    if (comment == NULL)
  1312.       ptr->comment = "";
  1313.    else {
  1314.       ptr->comment = comment->image;
  1315.       free_t(comment);
  1316.       comment = NULL;
  1317.       }
  1318.    ptr->ntnds = 0;
  1319.    ptr->tnds = NULL;
  1320.    ptr->nvars = 0;
  1321.    ptr->vars = NULL;
  1322.    ptr->in_line = NULL;
  1323.    ptr->iconc_flgs = 0;
  1324.    return num_impl;
  1325.    }
  1326.  
  1327. /*
  1328.  * set_prms - set the parameter information of an implementation based on
  1329.  *   the params list constructed during parsing.
  1330.  */
  1331. static novalue set_prms(ptr)
  1332. struct implement *ptr;
  1333.    {
  1334.    struct sym_entry *sym;
  1335.    int nargs;
  1336.    int i;
  1337.  
  1338.    /*
  1339.     * Create an array of parameter flags for the operation. The flag
  1340.     * indicates the deref/underef and varargs status for each parameter.
  1341.     */
  1342.    if (params == NULL) {
  1343.       ptr->nargs = 0;
  1344.       ptr->arg_flgs = NULL;
  1345.       }
  1346.    else {
  1347.       /*
  1348.        * The parameters are in reverse order, so the number of the parameters
  1349.        *  can be determined by the number assigned to the first one on the
  1350.        *  list.
  1351.        */
  1352.       nargs = params->u.param_info.param_num + 1;
  1353.       ptr->nargs = nargs;
  1354.       ptr->arg_flgs = (int *)alloc((unsigned int)(sizeof(int) * nargs));
  1355.       for (i = 0; i < nargs; ++i)
  1356.          ptr->arg_flgs[i] = 0;
  1357.       for (sym = params; sym != NULL; sym = sym->u.param_info.next)
  1358.          ptr->arg_flgs[sym->u.param_info.param_num] |= sym->id_type;
  1359.       }
  1360.    }
  1361.  
  1362. /*
  1363.  * impl_op - find or create implementation struct for operator currently
  1364.  *  being parsed.
  1365.  */
  1366. novalue impl_op(op_sym, name)
  1367. struct token *op_sym;
  1368. struct token *name;
  1369.    {
  1370.    register struct implement *ptr;
  1371.    char *op;
  1372.    int nargs;
  1373.    unsigned hashval;
  1374.  
  1375.    /*
  1376.     * The operator symbol is needed but not the entire token.
  1377.     */
  1378.    op = op_sym->image;
  1379.    free_t(op_sym);
  1380.  
  1381.    /*
  1382.     * The parameters are in reverse order, so the number of the parameters
  1383.     *  can be determined by the number assigned to the first one on the
  1384.     *  list.
  1385.     */
  1386.    if (params == NULL)
  1387.       nargs = 0;
  1388.    else
  1389.       nargs = params->u.param_info.param_num + 1;
  1390.  
  1391.    /*
  1392.     * Locate the operator in the hash table; it must match both the
  1393.     *  operator symbol and the number of arguments. If the operator is
  1394.     *  not there, create an entry.
  1395.     */
  1396.    hashval = IHasher(op);
  1397.    ptr = ohash[hashval];
  1398.    while (ptr != NULL && (ptr->op != op || ptr->nargs != nargs))
  1399.       ptr = ptr->blink;
  1400.    if (ptr == NULL) {
  1401.       ptr = NewStruct(implement);
  1402.       ptr->blink = ohash[hashval];
  1403.       ptr->oper_typ = 'O';
  1404.       nxt_pre(ptr->prefix, op_pre, 2);   /* allocate a unique prefix */
  1405.       ptr->op = op;
  1406.       ohash[hashval] = ptr;
  1407.       ++num_op;
  1408.       }
  1409.  
  1410.    /* 
  1411.     * Put the entry and operation type in global variables for
  1412.     *  later access.
  1413.     */
  1414.    cur_impl = ptr;
  1415.    op_type = Operator;
  1416.  
  1417.    /*
  1418.     * initialize the entry based on global information set during parsing.
  1419.     */
  1420.    ptr->name = name->image;
  1421.    free_t(name);
  1422.    set_prms(ptr);
  1423.    ptr->min_result = min_rs;
  1424.    ptr->max_result = max_rs;
  1425.    ptr->resume = rsm_rs;
  1426.    ptr->ret_flag = 0;
  1427.    if (comment == NULL)
  1428.       ptr->comment = "";
  1429.    else {
  1430.       ptr->comment = comment->image;
  1431.       free_t(comment);
  1432.       comment = NULL;
  1433.       }
  1434.    ptr->ntnds = 0;
  1435.    ptr->tnds = NULL;
  1436.    ptr->nvars = 0;
  1437.    ptr->vars = NULL;
  1438.    ptr->in_line = NULL;
  1439.    ptr->iconc_flgs = 0;
  1440.    }
  1441.  
  1442. /*
  1443.  * set_r_seq - save result sequence information for updating the
  1444.  *  operation entry.
  1445.  */
  1446. novalue set_r_seq(min, max, resume)
  1447. long min;
  1448. long max;
  1449. int resume;
  1450.    {
  1451.    if (min == UnbndSeq)
  1452.       min = 0;
  1453.    min_rs = min;
  1454.    max_rs = max;
  1455.    rsm_rs = resume;
  1456.    }
  1457.  
  1458.