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