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 / common / rtdb.c < prev    next >
C/C++ Source or Header  |  2002-01-18  |  48KB  |  1,693 lines
  1. /*
  2.  * Routines to read a data base of run-time information.
  3.  */
  4. #include "../h/gsupport.h"
  5. #include "../h/version.h"
  6. #include "icontype.h"
  7.  
  8. /*
  9.  * GetInt - the next thing in the data base is an integer. Get it.
  10.  */
  11. #define GetInt(n, c)\
  12.    n = 0;\
  13.    while (isdigit(c)) {\
  14.       n = n * 10 + (c - '0');\
  15.       c = getc(db);\
  16.       }
  17.  
  18. /*
  19.  * SkipWhSp - skip white space characters in the data base.
  20.  */
  21. #define SkipWhSp(c)\
  22.    while (isspace(c)) {\
  23.       if (c == '\n')\
  24.          ++dbline;\
  25.       c = getc(db);\
  26.       }
  27.  
  28. /*
  29.  * prototypes for static functions.
  30.  */
  31. static int            cmp_1_pre  (int p1, int p2);
  32. static struct il_code *db_abstr  (void);
  33. static void         db_case   (struct il_code *il, int num_cases);
  34. static void         db_err3   (int fatal,char *s1,char *s2,char *s3);
  35. static int             db_icntyp (void);
  36. static struct il_c    *db_ilc    (void);
  37. static struct il_c    *db_ilcret (int il_c_type);
  38. static struct il_code *db_inlin  (void);
  39. static struct il_code *db_ilvar  (void);
  40. static int             db_rtflg  (void);
  41. static int             db_tndtyp (void);
  42. static struct il_c    *new_ilc   (int il_c_type);
  43. static void          quoted   (int delim);
  44.  
  45. extern char *progname;   /* name of program using this module */
  46.  
  47. static char *dbname;           /* data base name */
  48. static FILE *db;               /* data base  file */
  49. static int dbline;             /* line number current position in data base */
  50. static struct str_buf db_sbuf; /* string buffer */
  51. static int *type_map;          /* map data base type codes to internal ones */
  52. static int *compnt_map;        /* map data base component codes to internal */
  53.  
  54. /*
  55.  * opendb - open data base and do other house keeping.
  56.  */
  57. int db_open(s, lrgintflg)
  58. char *s;
  59. char **lrgintflg;
  60.    {
  61.    char *msg_buf;
  62.    char *id;
  63.    int i, n;
  64.    register int c;
  65.    static int first_time = 1;
  66.  
  67.    if (first_time) {
  68.       first_time = 0;
  69.       init_sbuf(&db_sbuf);
  70.       }
  71.    dbname = s;
  72.    dbline = 0;
  73.    *lrgintflg = NULL;
  74.    db = fopen(dbname, "rb");
  75.    if (db == NULL)
  76.       return 0;
  77.    ++dbline;
  78.  
  79.    /*
  80.     * Make sure the version number in the data base is what is expected.
  81.     */
  82.    s = db_string();
  83.    if (strcmp(s, DVersion) != 0) {
  84.       msg_buf = alloc(35 + strlen(s) + strlen(progname) + strlen(DVersion));
  85.       sprintf(msg_buf, "found version %s, %s requires version %s",
  86.            s, progname, DVersion);
  87.       db_err1(1, msg_buf);
  88.       }
  89.  
  90.    *lrgintflg = db_string();  /* large integer flag */
  91.  
  92.    /*
  93.     * Create tables for mapping type codes and type component codes in
  94.     *  the data base to those compiled into this program. The codes may
  95.     *  be different if types have been added to the program since the
  96.     *  data base was created.
  97.     */
  98.    type_map = alloc(num_typs * sizeof(int));
  99.    db_chstr("", "types");   /* verify section header */
  100.    c = getc(db);
  101.    SkipWhSp(c)
  102.    while (c == 'T') {
  103.       c = getc(db);
  104.       if (!isdigit(c))
  105.          db_err1(1, "expected type code");
  106.       GetInt(n, c)
  107.       if (n >= num_typs)
  108.          db_err1(1, "data base inconsistant with program, rebuild data base");
  109.       SkipWhSp(c)
  110.       if (c != ':')
  111.          db_err1(1, "expected ':'");
  112.       id = db_string();
  113.       for (i = 0; strcmp(id, icontypes[i].id) != 0; ++i)
  114.          if (i >= num_typs)
  115.             db_err2(1, "unknown type:", id);
  116.       type_map[n] = i;
  117.       c = getc(db);
  118.       SkipWhSp(c)
  119.       }
  120.    db_chstr("", "endsect");
  121.  
  122.    compnt_map = alloc(num_cmpnts * sizeof(int));
  123.    db_chstr("", "components");   /* verify section header */
  124.    c = getc(db);
  125.    SkipWhSp(c)
  126.    while (c == 'C') {
  127.       c = getc(db);
  128.       if (!isdigit(c))
  129.          db_err1(1, "expected type component code");
  130.       GetInt(n, c)
  131.       if (n >= num_cmpnts)
  132.          db_err1(1, "data base inconsistant with program, rebuild data base");
  133.       SkipWhSp(c)
  134.       if (c != ':')
  135.          db_err1(1, "expected ':'");
  136.       id = db_string();
  137.       for (i = 0; strcmp(id, typecompnt[i].id) != 0; ++i)
  138.          if (i >= num_cmpnts)
  139.             db_err2(1, "unknown type component:", id);
  140.       compnt_map[n] = i;
  141.       c = getc(db);
  142.       SkipWhSp(c)
  143.       }
  144.    db_chstr("", "endsect");
  145.  
  146.    return 1;
  147.    }
  148.  
  149. /*
  150.  * db_close - close data base.
  151.  */
  152. void db_close()
  153.    {
  154.    if (fclose(db) != 0)
  155.       db_err2(0, "cannot close", dbname);
  156.    }
  157.  
  158. /*
  159.  * db_string - get a white-space delimited string from the data base.
  160.  */
  161. char *db_string()
  162.    {
  163.    register int c;
  164.  
  165.    /*
  166.     * Look for the start of the string; '$' starts a special indicator.
  167.     *  Copy characters into string buffer until white space is found.
  168.     */
  169.    c = getc(db);
  170.    SkipWhSp(c);
  171.    if (c == EOF)
  172.       db_err1(1, "unexpected EOF");
  173.    if (c == '$')
  174.       return NULL;
  175.    while (!isspace(c) && c != EOF) {
  176.       AppChar(db_sbuf, c);
  177.       c = getc(db);
  178.       }
  179.    if (c == '\n')
  180.       ++dbline;
  181.    return str_install(&db_sbuf); /* put string in string table */
  182.    }
  183.  
  184. /*
  185.  * db_impl - read basic header information for an operation into a structure
  186.  *   and return it.
  187.  */
  188. struct implement *db_impl(oper_typ)
  189. int oper_typ;
  190.    {
  191.    register struct implement *ip;
  192.    register int c;
  193.    int i;
  194.    char *name;
  195.    long n;
  196.  
  197.    /*
  198.     * Get operation name.
  199.     */
  200.    if ((name = db_string()) == NULL)
  201.       return NULL;
  202.  
  203.    /*
  204.     * Create an internal structure to hold the data base entry.
  205.     */
  206.    ip = NewStruct(implement);
  207.    ip->blink = NULL;
  208.    ip->iconc_flgs = 0;         /* reserved for internal use by compiler */
  209.    ip->oper_typ = oper_typ;
  210.    ip->name = name;
  211.    ip->op = NULL;
  212.  
  213.    /*
  214.     * Get the function name prefix assigned to this operation.
  215.     */
  216.    c = getc(db);
  217.    SkipWhSp(c)
  218.    if (isalpha(c) || isdigit(c))
  219.       ip->prefix[0] = c;
  220.    else
  221.      db_err2(1, "invalid prefix for", ip->name);
  222.    c = getc(db);
  223.    if (isalpha(c) || isdigit(c))
  224.       ip->prefix[1] = c;
  225.    else
  226.      db_err2(1, "invalid prefix for", ip->name);
  227.  
  228.    /*
  229.     * Get the number of parameters.
  230.     */
  231.    c = getc(db);
  232.    SkipWhSp(c)
  233.    if (!isdigit(c))
  234.      db_err2(1, "number of parameters missing for", ip->name);
  235.    GetInt(n, c)
  236.    ip->nargs = n;
  237.  
  238.    /*
  239.     * Get the flags that indicate whether each parameter requires a dereferenced
  240.     *  and/or undereferenced value, and whether the last parameter represents
  241.     *  the end of a varargs list. Store the flags in an array.
  242.     */
  243.    if (n == 0)
  244.       ip->arg_flgs = NULL;
  245.    else
  246.       ip->arg_flgs = alloc(n * sizeof(int));
  247.    if (c != '(')
  248.       db_err2(1, "parameter flags missing for", ip->name);
  249.    c = getc(db);
  250.    for (i = 0; i < n; ++i) {
  251.       if (c == ',' || c == ')')
  252.          db_err2(1, "parameter flag missing for", ip->name);
  253.       ip->arg_flgs[i] = 0;
  254.       while (c != ',' && c != ')') {
  255.           switch (c) {
  256.              case 'u':
  257.                 ip->arg_flgs[i] |= RtParm;
  258.                 break;
  259.              case 'd':
  260.                 ip->arg_flgs[i] |= DrfPrm;
  261.                 break;
  262.              case 'v':
  263.                 ip->arg_flgs[i] |= VarPrm;
  264.                 break;
  265.              default:
  266.                 db_err2(1, "invalid parameter flag for", ip->name);
  267.              }
  268.          c = getc(db);
  269.          }
  270.       if (c == ',')
  271.          c = getc(db);
  272.       }
  273.    if (c != ')')
  274.      db_err2(1, "invalid parameter flag list for", ip->name);
  275.  
  276.    /*
  277.     * Get the result sequence indicator for the operation.
  278.     */
  279.    c = getc(db);
  280.    SkipWhSp(c)
  281.    if (c != '{')
  282.      db_err2(1, "result sequence missing for", ip->name);
  283.    c = getc(db);
  284.    ip->resume = 0;
  285.    if (c == '}') {
  286.       ip->min_result = NoRsltSeq;
  287.       ip->max_result = NoRsltSeq;
  288.       }
  289.    else {
  290.       if (!isdigit(c))
  291.         db_err2(1, "invalid result sequence for", ip->name);
  292.       GetInt(n, c)
  293.       ip->min_result = n;
  294.       if (c != ',')
  295.         db_err2(1, "invalid result sequence for", ip->name);
  296.       c = getc(db);
  297.       if (c == '*') {
  298.          ip->max_result = UnbndSeq;
  299.          c = getc(db);
  300.          }
  301.       else if (isdigit(c)) {
  302.          GetInt(n, c)
  303.          ip->max_result = n;
  304.          }
  305.       else
  306.         db_err2(1, "invalid result sequence for", ip->name);
  307.       if (c == '+') {
  308.          ip->resume = 1;
  309.          c = getc(db);
  310.          }
  311.       if (c != '}')
  312.         db_err2(1, "invalid result sequence for", ip->name);
  313.       }
  314.  
  315.    /*
  316.     * Get the flag indicating whether the operation contains returns, fails,
  317.     *  or suspends.
  318.     */
  319.    ip->ret_flag = db_rtflg();
  320.  
  321.    /*
  322.     * Get the t/f flag that indicates whether the operation explicitly
  323.     *  uses the 'result' location.
  324.     */
  325.    c = getc(db);
  326.    SkipWhSp(c)
  327.    switch (c) {
  328.       case 't':
  329.          ip->use_rslt = 1;
  330.          break;
  331.       case 'f':
  332.          ip->use_rslt = 0;
  333.          break;
  334.       default:
  335.          db_err2(1, "invalid 'result' use indicator for", ip->name);
  336.          }
  337.    return ip;
  338.    }
  339.  
  340. /*
  341.  * db_code - read the RTL code for the body of an operation.
  342.  */
  343. void db_code(ip)
  344. struct implement *ip;
  345.    {
  346.    register int c;
  347.    char *s;
  348.    word n;
  349.    int var_type;
  350.    int i;
  351.  
  352.    /*
  353.     * read the descriptive string.
  354.     */
  355.    c = getc(db);
  356.    SkipWhSp(c)
  357.    if (c != '"')
  358.       db_err1(1, "operation description expected");
  359.    for (c = getc(db); c != '"' && c != '\n' && c != EOF; c = getc(db)) {
  360.       if (c == '\\') {
  361.          AppChar(db_sbuf, c);
  362.          c = getc(db);
  363.          }
  364.       AppChar(db_sbuf, c);
  365.       }
  366.    if (c != '"')
  367.       db_err1(1, "expected '\"'");
  368.    ip->comment = str_install(&db_sbuf);
  369.  
  370.    /*
  371.     * Get the number of tended variables in the declare clause.
  372.     */
  373.    c = getc(db);
  374.    SkipWhSp(c)
  375.    GetInt(n, c)
  376.    ip->ntnds = n;
  377.  
  378.    /*
  379.     * Read information about the tended variables into an array.
  380.     */
  381.    if (n == 0)
  382.       ip->tnds = NULL;
  383.    else
  384.       ip->tnds = alloc(n * sizeof(struct tend_var));
  385.    for (i = 0; i < n; ++i) {
  386.       var_type = db_tndtyp();  /* type of tended declaration */
  387.       ip->tnds[i].var_type = var_type;
  388.       ip->tnds[i].blk_name = NULL;
  389.       if (var_type == TndBlk) {
  390.          /*
  391.           * Tended block pointer declarations include a block type or '*' to
  392.           *  indicate 'union block *'.
  393.           */
  394.          s = db_string();
  395.          if (s == NULL)
  396.             db_err1(1, "block name expected");
  397.          if (*s != '*')
  398.             ip->tnds[i].blk_name = s;
  399.          }
  400.       ip->tnds[i].init = db_ilc();  /* C code for declaration initializer */
  401.       }
  402.  
  403.    /*
  404.     * Get the number of non-tended variables in the declare clause.
  405.     */
  406.    c = getc(db);
  407.    SkipWhSp(c)
  408.    GetInt(n, c)
  409.    ip->nvars = n;
  410.  
  411.    /*
  412.     * Get each non-tended declaration and store it in an array.
  413.     */
  414.    if (n == 0)
  415.       ip->vars = NULL;
  416.    else
  417.       ip->vars = alloc(n * sizeof(struct ord_var));
  418.    for (i = 0; i < n; ++i) {
  419.       s = db_string();             /* variable name */
  420.       if (s == NULL)
  421.          db_err1(1, "variable name expected");
  422.       ip->vars[i].name = s;
  423.       ip->vars[i].dcl = db_ilc();  /* full declaration including name */
  424.       }
  425.  
  426.    /*
  427.     * Get the executable RTL code.
  428.     */
  429.    ip->in_line = db_inlin();
  430.  
  431.    /*
  432.     * We should be at the end of the operation.
  433.     */
  434.    c = getc(db);
  435.    SkipWhSp(c)
  436.    if (c != '$')
  437.       db_err1(1, "expected $end");
  438.    }
  439.  
  440. /*
  441.  * db_inlin - read in the in-line code (executable RTL code) for an operation.
  442.  */
  443. static struct il_code *db_inlin()
  444.    {
  445.    struct il_code *il = NULL;
  446.    register int c;
  447.    int i;
  448.    int indx;
  449.    int fall_thru;
  450.    int n, n1;
  451.  
  452.    /*
  453.     * The following nested switch statements act as a trie for recognizing
  454.     *  the prefix form of RTL code in the data base.
  455.     */
  456.    c = getc(db);
  457.    SkipWhSp(c)
  458.    switch (c) {
  459.       case 'a':
  460.          switch (getc(db)) {
  461.             case 'b': {
  462.                db_chstr("ab", "str");
  463.                il = new_il(IL_Abstr, 2);        /* abstract type computation */
  464.                il->u[0].fld = db_abstr();       /* side effects */
  465.                il->u[1].fld = db_abstr();       /* return type */
  466.                break;
  467.                }
  468.             case 'c': {
  469.                db_chstr("ac", "ase");
  470.                il = new_il(IL_Acase, 5);        /* arith_case */
  471.                il->u[0].fld = db_ilvar();       /* first variable */
  472.                il->u[1].fld = db_ilvar();       /* second variable */
  473.                il->u[2].fld = db_inlin();       /* C_integer action */
  474.                il->u[3].fld = db_inlin();       /* integer action */
  475.                il->u[4].fld = db_inlin();       /* C_double action */
  476.                break;
  477.                }
  478.             default:
  479.                db_err1(1, "expected abstr or acase");
  480.             }
  481.          break;
  482.  
  483.       case 'b':
  484.          db_chstr("b", "lock");
  485.          c = getc(db);
  486.          SkipWhSp(c)
  487.          if (c == 't')
  488.             fall_thru = 1;
  489.          else
  490.             fall_thru = 0;
  491.          c = getc(db);
  492.          SkipWhSp(c)
  493.          GetInt(n, c)
  494.          il = new_il(IL_Block, 3 + n);    /* block of in-line C code */
  495.          il->u[0].n = fall_thru;
  496.          il->u[1].n = n;                  /* number of local tended */
  497.          for (i = 2; i - 2 < n; ++i)
  498.              il->u[i].n = db_tndtyp();    /* tended declaration */
  499.          il->u[i].c_cd = db_ilc();        /* C code */
  500.          break;
  501.  
  502.       case 'c':
  503.          switch (getc(db)) {
  504.             case 'a': {
  505.                char prfx3;
  506.                int ret_val = 0;
  507.                int ret_flag;
  508.                int rslt = 0;
  509.                int num_sbuf;
  510.                int num_cbuf;
  511.  
  512.                db_chstr("ca", "ll");
  513.                /*
  514.                 * Call to body function. Get the letter used as the 3rd
  515.                 *  character of the function prefix.
  516.                 */
  517.                c = getc(db);
  518.                SkipWhSp(c)
  519.                prfx3 = c;
  520.  
  521.                /*
  522.                 * Determine what the body function returns directly.
  523.                 */
  524.                c = getc(db);
  525.                SkipWhSp(c)
  526.                switch (c) {
  527.                   case 'i':
  528.                      ret_val = RetInt;    /* returns C integer */
  529.                      break;
  530.                   case 'd':
  531.                      ret_val = RetDbl;    /* returns C double */
  532.                      break;
  533.                   case 'n':
  534.                      ret_val = RetNoVal;  /* returns nothing directly */
  535.                      break;
  536.                   case 's':
  537.                      ret_val = RetSig;    /* returns a signal */
  538.                      break;
  539.                   default:
  540.                      db_err1(1, "invalid indicator for type of return value");
  541.                   }
  542.  
  543.               /*
  544.                * Get the return/suspend/fail/fall-through flag.
  545.                */
  546.                c = getc(db);
  547.                ret_flag = db_rtflg();
  548.  
  549.                /*
  550.                 * Get the flag indicating whether the body function expects
  551.                 *  to have an explicit result location passed to it.
  552.                 */
  553.                c = getc(db);
  554.                SkipWhSp(c)
  555.                switch (c) {
  556.                   case 't':
  557.                      rslt = 1;
  558.                      break;
  559.                   case 'f':
  560.                      rslt = 0;
  561.                      break;
  562.                   default:
  563.                      db_err1(1, "t or f expected");
  564.                   }
  565.  
  566.                c = getc(db);
  567.                SkipWhSp(c)
  568.                GetInt(num_sbuf, c)  /* number of cset buffers */
  569.                c = getc(db);
  570.                SkipWhSp(c)
  571.                GetInt(num_cbuf, c)  /* number of string buffers */
  572.                c = getc(db);
  573.                SkipWhSp(c)
  574.                GetInt(n, c)         /* num args */
  575.  
  576.                il = new_il(IL_Call, 8 + n * 2);
  577.                il->u[0].n = 0;      /* reserved for internal use by compiler */
  578.                il->u[1].n = prfx3;
  579.                il->u[2].n = ret_val;
  580.                il->u[3].n = ret_flag;
  581.                il->u[4].n = rslt;
  582.                il->u[5].n = num_sbuf;
  583.                il->u[6].n = num_cbuf;
  584.                il->u[7].n = n;
  585.                indx = 8;
  586.  
  587.                /*
  588.                 * get the prototype parameter declarations and actual arguments.
  589.                 */
  590.                n *= 2;
  591.                while (n--)
  592.                   il->u[indx++].c_cd = db_ilc();
  593.                }
  594.                break;
  595.  
  596.             case 'n':
  597.                if (getc(db) != 'v')
  598.                   db_err1(1, "expected cnv1 or cnv2");
  599.                switch (getc(db)) {
  600.                   case '1':
  601.                      il = new_il(IL_Cnv1, 2);
  602.                      il->u[0].n = db_icntyp();      /* type code */
  603.                      il->u[1].fld = db_ilvar();     /* source */
  604.                      break;
  605.                   case '2':
  606.                      il = new_il(IL_Cnv2, 3);
  607.                      il->u[0].n = db_icntyp();      /* type code */
  608.                      il->u[1].fld = db_ilvar();     /* source */
  609.                      il->u[2].c_cd = db_ilc();      /* destination */
  610.                      break;
  611.                   default:
  612.                      db_err1(1, "expected cnv1 or cnv2");
  613.                   }
  614.                break;
  615.  
  616.             case 'o':
  617.                db_chstr("co", "nst");
  618.                il = new_il(IL_Const, 2);     /* constant keyword */
  619.                il->u[0].n = db_icntyp();     /* type code */
  620.                c = getc(db);
  621.                SkipWhSp(c)
  622.                if (c == '"' || c == '\'') {
  623.                   quoted(c);
  624.                   c = getc(db);              /* quoted literal without quotes */
  625.                   }
  626.                else
  627.                   while (c != EOF && !isspace(c)) {
  628.                      AppChar(db_sbuf, c);
  629.                      c = getc(db);
  630.                      }
  631.                il->u[1].s = str_install(&db_sbuf); /* non-quoted values */
  632.                break;
  633.  
  634.             default:
  635.                db_err1(1, "expected call, const, cnv1, or cnv2");
  636.             }
  637.          break;
  638.  
  639.       case 'd':
  640.          if (getc(db) != 'e' || getc(db) != 'f')
  641.             db_err1(1, "expected def1 or def2");
  642.          switch (getc(db)) {
  643.             case '1':
  644.                il = new_il(IL_Def1, 3);       /* defaulting, no dest. field */
  645.                il->u[0].n = db_icntyp();      /* type code */
  646.                il->u[1].fld = db_ilvar();     /* source */
  647.                il->u[2].c_cd = db_ilc();      /* default value */
  648.                break;
  649.             case '2':
  650.                il = new_il(IL_Def2, 4);       /* defaulting, with dest. field */
  651.                il->u[0].n = db_icntyp();      /* type code */
  652.                il->u[1].fld = db_ilvar();     /* source */
  653.                il->u[2].c_cd = db_ilc();      /* default value */
  654.                il->u[3].c_cd = db_ilc();      /* destination */
  655.                break;
  656.             default:
  657.                db_err1(1, "expected dflt1 or dflt2");
  658.             }
  659.          break;
  660.  
  661.       case 'r':
  662.          if (getc(db) != 'u' || getc(db) != 'n' || getc(db) != 'e' ||
  663.             getc(db) != 'r' || getc(db) != 'r')
  664.             db_err1(1, "expected runerr1 or runerr2");
  665.          switch (getc(db)) {
  666.             case '1':
  667.                il = new_il(IL_Err1, 1);       /* runerr, no offending value */
  668.                c = getc(db);
  669.                SkipWhSp(c)
  670.                GetInt(n, c)
  671.                il->u[0].n = n;                /* error number */
  672.                break;
  673.             case '2':
  674.                il = new_il(IL_Err2, 2);       /* runerr, with offending value */
  675.                c = getc(db);
  676.                SkipWhSp(c)
  677.                GetInt(n, c)
  678.                il->u[0].n = n;                /* error number */
  679.                il->u[1].fld = db_ilvar();     /* variable */
  680.                break;
  681.             default:
  682.                db_err1(1, "expected runerr1 or runerr2");
  683.             }
  684.          break;
  685.  
  686.       case 'i':
  687.          switch (getc(db)) {
  688.             case 'f':
  689.                switch (getc(db)) {
  690.                   case '1':
  691.                      il = new_il(IL_If1, 2);    /* if-then */
  692.                      il->u[0].fld = db_inlin(); /* condition */
  693.                      il->u[1].fld = db_inlin(); /* then clause */
  694.                      break;
  695.                   case '2':
  696.                      il = new_il(IL_If2, 3);     /* if-then-else */
  697.                      il->u[0].fld = db_inlin(); /* condition */
  698.                      il->u[1].fld = db_inlin(); /* then clause */
  699.                      il->u[2].fld = db_inlin(); /* else clause */
  700.                      break;
  701.                   default:
  702.                      db_err1(1, "expected if1 or if2");
  703.                   }
  704.                break;
  705.             case 's':
  706.                il = new_il(IL_Is, 2);         /* type check */
  707.                il->u[0].n = db_icntyp();      /* type code */
  708.                il->u[1].fld = db_ilvar();     /* variable */
  709.                break;
  710.             default:
  711.                db_err1(1, "expected if1, if2, or is");
  712.             }
  713.          break;
  714.  
  715.       case 'l':
  716.          switch (getc(db)) {
  717.             case 'c':
  718.                db_chstr("lc", "ase");
  719.                c = getc(db);
  720.                SkipWhSp(c)
  721.                GetInt(n, c)
  722.                il = new_il(IL_Lcase, 2 + 2 * n); /* length case */
  723.                il->u[0].n = n;                   /* number of cases */
  724.                indx = 1;
  725.                while (n--) {
  726.                   c = getc(db);
  727.                   SkipWhSp(c)
  728.                   GetInt(n1, c)
  729.                   il->u[indx++].n = n1;           /* selection number */
  730.                   il->u[indx++].fld = db_inlin(); /* action */
  731.                   }
  732.                il->u[indx].fld = db_inlin();      /* default */
  733.                break;
  734.  
  735.             case 's':
  736.                if (getc(db) != 't')
  737.                   db_err1(1, "expected lst");
  738.                il = new_il(IL_Lst, 2);            /* sequence of code parts */
  739.                il->u[0].fld = db_inlin();         /* 1st part */
  740.                il->u[1].fld = db_inlin();         /* 2nd part */
  741.                break;
  742.  
  743.             default:
  744.                db_err1(1, "expected lcase or lst");
  745.             }
  746.          break;
  747.  
  748.       case 'n':
  749.          db_chstr("n", "il");
  750.          il = NULL;
  751.          break;
  752.  
  753.       case 't': {
  754.          struct il_code *var;
  755.  
  756.          if (getc(db) != 'c' || getc(db) != 'a' || getc(db) != 's' ||
  757.             getc(db) != 'e')
  758.                db_err1(1, "expected tcase1 or tcase2");
  759.          switch (getc(db)) {
  760.             case '1':
  761.                var = db_ilvar();
  762.                c = getc(db);
  763.                SkipWhSp(c)
  764.                GetInt(n, c)
  765.                il = new_il(IL_Tcase1, 3 * n + 2); /* type case, no default */
  766.                il->u[0].fld = var;                /* variable */
  767.                db_case(il, n);                    /* get cases */
  768.                break;
  769.  
  770.             case '2':
  771.                var = db_ilvar();
  772.                c = getc(db);
  773.                SkipWhSp(c)
  774.                GetInt(n, c)
  775.                il = new_il(IL_Tcase2, 3 * n + 3);  /* type case, with default */
  776.                il->u[0].fld = var;                 /* variable */
  777.                db_case(il, n);                     /* get cases */
  778.                il->u[3 * n + 2].fld = db_inlin();  /* default */
  779.                break;
  780.  
  781.             default:
  782.                db_err1(1, "expected tcase1 or tcase2");
  783.             }
  784.          }
  785.          break;
  786.  
  787.       case '!':
  788.          il = new_il(IL_Bang, 1);                   /* negated condition */
  789.          il->u[0].fld = db_inlin();                 /* condition */
  790.          break;
  791.  
  792.       case '&':
  793.          if (getc(db) != '&')
  794.             db_err1(1, "expected &&");
  795.          il = new_il(IL_And, 2);                    /* && (conjunction) */
  796.          il->u[0].fld = db_inlin();                 /* 1st operand */
  797.          il->u[1].fld = db_inlin();                 /* 2nd operand */
  798.          break;
  799.  
  800.       default:
  801.          db_err1(1, "syntax error");
  802.       }
  803.    return il;
  804.    }
  805.  
  806. /*
  807.  * db_rtflg - get the sequence of 4 [or 5] flags that indicate whether code
  808.  *  for a operation [or body function] returns, fails, suspends, has error
  809.  *  failure, [or execution falls through the code].
  810.  */
  811. static int db_rtflg()
  812.    {
  813.    register int c;
  814.    int ret_flag;
  815.  
  816.    /*
  817.     * The presence of each flag is indicated by a unique character. Its absence
  818.     *  indicated by '_'.
  819.     */
  820.    ret_flag = 0;
  821.    c = getc(db);
  822.    SkipWhSp(c)
  823.    if (c == 'f')
  824.       ret_flag |= DoesFail;
  825.    else if (c != '_')
  826.      db_err1(1, "invalid return indicator");
  827.    c = getc(db);
  828.    if (c == 'r')
  829.       ret_flag |= DoesRet;
  830.    else if (c != '_')
  831.      db_err1(1, "invalid return indicator");
  832.    c = getc(db);
  833.    if (c == 's')
  834.       ret_flag |= DoesSusp;
  835.    else if (c != '_')
  836.      db_err1(1, "invalid return indicator");
  837.    c = getc(db);
  838.    if (c == 'e')
  839.       ret_flag |= DoesEFail;
  840.    else if (c != '_')
  841.      db_err1(1, "invalid return indicator");
  842.    c = getc(db);
  843.    if (c == 't')
  844.       ret_flag |= DoesFThru;
  845.    else if (c != '_' && c != ' ')
  846.      db_err1(1, "invalid return indicator");
  847.    return ret_flag;
  848.    }
  849.  
  850. /*
  851.  * db_case - get the cases for a type_case statement from the data base.
  852.  */
  853. static void db_case(il, num_cases)
  854. struct il_code *il;
  855. int num_cases;
  856.    {
  857.    register int c;
  858.    int *typ_vect;
  859.    int i, j;
  860.    int num_types;
  861.    int indx;
  862.  
  863.    il->u[1].n = num_cases;    /* number of cases */
  864.    indx = 2;
  865.    for (i = 0; i < num_cases; ++i) {
  866.       /*
  867.        * Determine the number of types in this case then store the
  868.        *  type codes in an array.
  869.        */
  870.       c = getc(db);
  871.       SkipWhSp(c)
  872.       GetInt(num_types, c)
  873.       il->u[indx++].n = num_types;
  874.       typ_vect = alloc(num_types * sizeof(int));
  875.       il->u[indx++].vect = typ_vect;
  876.       for (j = 0; j < num_types; ++j)
  877.          typ_vect[j] = db_icntyp();           /* type code */
  878.  
  879.       il->u[indx++].fld = db_inlin();         /* action */
  880.       }
  881.    }
  882.  
  883. /*
  884.  * db_ilvar - get a symbol table index for a simple variable or a
  885.  *  subscripted variable from the data base.
  886.  */
  887. static struct il_code *db_ilvar()
  888.    {
  889.    struct il_code *il;
  890.    register int c;
  891.    int n;
  892.  
  893.    c = getc(db);
  894.    SkipWhSp(c)
  895.  
  896.    if (isdigit(c)) {
  897.       /*
  898.        * Simple variable: just a symbol table index.
  899.        */
  900.       il = new_il(IL_Var, 1);
  901.       GetInt(n, c)
  902.       il->u[0].n = n;    /* symbol table index */
  903.       }
  904.    else {
  905.       if (c != '[')
  906.          db_err1(1, "expected symbol table index or '['");
  907.       /*
  908.        * Subscripted variable: symbol table index and subscript.
  909.        */
  910.       il = new_il(IL_Subscr, 2);
  911.       c = getc(db);
  912.       SkipWhSp(c);
  913.       GetInt(n, c)
  914.       il->u[0].n = n;    /* symbol table index */
  915.       c = getc(db);
  916.       SkipWhSp(c)
  917.       GetInt(n, c)
  918.       il->u[1].n = n;    /* subscripting index */
  919.       }
  920.    return il;
  921.    }
  922.  
  923. /*
  924.  * db_abstr - get abstract type computations from the data base.
  925.  */
  926. static struct il_code *db_abstr()
  927.    {
  928.    struct il_code *il = NULL;
  929.    register int c;
  930.    word typcd;
  931.    word indx;
  932.    int n;
  933.    int nargs;
  934.  
  935.    c = getc(db);
  936.    SkipWhSp(c)
  937.    switch (c) {
  938.       case 'l':
  939.          db_chstr("l", "st");
  940.          il = new_il(IL_Lst, 2);        /* sequence of code parts */
  941.          il->u[0].fld = db_abstr();     /* 1st part */
  942.          il->u[1].fld = db_abstr();     /* 2nd part */
  943.          break;
  944.  
  945.       case 'n':
  946.          switch (getc(db)) {
  947.             case 'e':
  948.                if (getc(db) != 'w')
  949.                   db_err1(1, "expected new");
  950.                typcd = db_icntyp();
  951.                c = getc(db);
  952.                SkipWhSp(c)
  953.                GetInt(nargs, c)
  954.                il = new_il(IL_New, 2 + nargs);  /* new structure create here */
  955.                il->u[0].n = typcd;              /* type code */
  956.                il->u[1].n = nargs;              /* number of args */
  957.                indx = 2;
  958.                while (nargs--)
  959.                   il->u[indx++].fld = db_abstr(); /* argument for component */
  960.                break;
  961.             case 'i':
  962.                if (getc(db) != 'l')
  963.                   db_err1(1, "expected nil");
  964.                il = NULL;
  965.                break;
  966.             default:
  967.                db_err1(1, "expected new or nil");
  968.             }
  969.        break;
  970.  
  971.       case 's':
  972.          db_chstr("s", "tore");
  973.          il = new_il(IL_Store, 1);  /* abstract store */
  974.          il->u[0].fld = db_abstr(); /* type to "dereference" */
  975.          break;
  976.  
  977.       case 't':
  978.          db_chstr("t", "yp");
  979.          il = new_il(IL_IcnTyp, 1);  /* explicit type */
  980.          il->u[0].n = db_icntyp();   /* type code */
  981.          break;
  982.  
  983.       case 'v':
  984.          db_chstr("v", "artyp");
  985.          il = new_il(IL_VarTyp, 1);        /* variable */
  986.          il->u[0].fld = db_ilvar();        /* symbol table index, etc */
  987.          break;
  988.  
  989.       case '.':
  990.          il = new_il(IL_Compnt, 2);        /* component access */
  991.          il->u[0].fld = db_abstr();        /* type being accessed */
  992.          c = getc(db);
  993.          SkipWhSp(c)
  994.          switch (c) {
  995.             case 'f':
  996.                il->u[1].n = CM_Fields;
  997.                break;
  998.             case 'C':
  999.                c = getc(db);
  1000.                GetInt(n, c)
  1001.                il->u[1].n = compnt_map[n];
  1002.                break;
  1003.             default:
  1004.                db_err1(1, "expected component code");
  1005.             }
  1006.          break;
  1007.  
  1008.       case '=':
  1009.          il = new_il(IL_TpAsgn, 2);        /* assignment (side effect) */
  1010.          il->u[0].fld = db_abstr();        /* left-hand-side */
  1011.          il->u[1].fld = db_abstr();        /* right-hand-side */
  1012.          break;
  1013.  
  1014.       case '+':
  1015.          if (getc(db) != '+')
  1016.             db_err1(1, "expected ++");
  1017.          il = new_il(IL_Union, 2);         /* ++ (union) */
  1018.          il->u[0].fld = db_abstr();        /* 1st operand */
  1019.          il->u[1].fld = db_abstr();        /* 2nd operand */
  1020.          break;
  1021.  
  1022.       case '*':
  1023.          if (getc(db) != '*')
  1024.             db_err1(1, "expected **");
  1025.          il = new_il(IL_Inter, 2);         /* ** (intersection) */
  1026.          il->u[0].fld = db_abstr();        /* 1st operand */
  1027.          il->u[1].fld = db_abstr();        /* 2nd operand */
  1028.          break;
  1029.       }
  1030.    return il;
  1031.    }
  1032.  
  1033. /*
  1034.  * db_ilc - read a piece of in-line C code.
  1035.  */
  1036. static struct il_c *db_ilc()
  1037.    {
  1038.    register int c;
  1039.    int old_c;
  1040.    word n;
  1041.    struct il_c *base = NULL;
  1042.    struct il_c **nxtp = &base;
  1043.  
  1044.    c = getc(db);
  1045.    SkipWhSp(c)
  1046.    switch (c) {
  1047.       case '$':
  1048.          /*
  1049.           * This had better be the starting $c.
  1050.           */
  1051.          c = getc(db);
  1052.          if (c == 'c') {
  1053.             c = getc(db);
  1054.             for (;;) {
  1055.                SkipWhSp(c)
  1056.                if (c == '$') {
  1057.                   c = getc(db);
  1058.                   switch (c) {
  1059.                      case 'c':             /* $cb or $cgoto <cond> <lbl num> */
  1060.                         c = getc(db);
  1061.                         switch (c) {
  1062.                            case 'b':
  1063.                               *nxtp = new_ilc(ILC_CBuf);
  1064.                               c = getc(db);
  1065.                               break;
  1066.                            case 'g':
  1067.                               db_chstr("$cg", "oto");
  1068.                               *nxtp = new_ilc(ILC_CGto);
  1069. #ifdef MultiThread
  1070.    #undef code
  1071. #endif                    /* MultiThead */
  1072.                               (*nxtp)->code[0] = db_ilc();
  1073.                               c = getc(db);
  1074.                               SkipWhSp(c);
  1075.                               if (!isdigit(c))
  1076.                                  db_err1(1, "$cgoto: expected label number");
  1077.                               GetInt(n, c);
  1078.                               (*nxtp)->n = n;
  1079.                               break;
  1080.                            default:
  1081.                              db_err1(1, "expected $cb or $cgoto");
  1082.                            }
  1083.                         break;
  1084.                      case 'e':
  1085.                         c = getc(db);
  1086.                         if (c == 'f') {             /* $efail */
  1087.                             db_chstr("$ef", "ail");
  1088.                             *nxtp = new_ilc(ILC_EFail);
  1089.                             c = getc(db);
  1090.                             break;
  1091.                             }
  1092.                         else
  1093.                            return base;            /* $e */
  1094.                      case 'f':                     /* $fail */
  1095.                         db_chstr("$f", "ail");
  1096.                         *nxtp = new_ilc(ILC_Fail);
  1097.                         c = getc(db);
  1098.                         break;
  1099.                      case 'g':                     /* $goto <lbl num> */
  1100.                         db_chstr("$g", "oto");
  1101.                         *nxtp = new_ilc(ILC_Goto);
  1102.                         c = getc(db);
  1103.                         SkipWhSp(c);
  1104.                         if (!isdigit(c))
  1105.                            db_err1(1, "$goto: expected label number");
  1106.                         GetInt(n, c);
  1107.                         (*nxtp)->n = n;
  1108.                         break;
  1109.                      case 'l':                     /* $lbl <lbl num> */
  1110.                         db_chstr("$l", "bl");
  1111.                         *nxtp = new_ilc(ILC_Lbl);
  1112.                         c = getc(db);
  1113.                         SkipWhSp(c);
  1114.                         if (!isdigit(c))
  1115.                            db_err1(1, "$lbl: expected label number");
  1116.                         GetInt(n, c);
  1117.                         (*nxtp)->n = n;
  1118.                         break;
  1119.                      case 'm':                     /* $m[d]<indx> */
  1120.                         *nxtp = new_ilc(ILC_Mod);
  1121.                         c = getc(db);
  1122.                         if (c == 'd') {
  1123.                            (*nxtp)->s = "d";
  1124.                            c = getc(db);
  1125.                            }
  1126.                         if (isdigit(c)) {
  1127.                            GetInt(n, c);
  1128.                            (*nxtp)->n = n;
  1129.                            }
  1130.                         else if (c == 'r') {
  1131.                            (*nxtp)->n = RsltIndx;
  1132.                            c = getc(db);
  1133.                            }
  1134.                         else
  1135.                            db_err1(1, "$m: expected symbol table index");
  1136.                         break;
  1137.                      case 'r':                     /* $r[d]<indx> or $ret ... */
  1138.                         c = getc(db);
  1139.                         if (isdigit(c) || c == 'd') {
  1140.                            *nxtp = new_ilc(ILC_Ref);
  1141.                            if (c == 'd') {
  1142.                               (*nxtp)->s = "d";
  1143.                               c = getc(db);
  1144.                               }
  1145.                            GetInt(n, c);
  1146.                            (*nxtp)->n = n;
  1147.                            }
  1148.                         else if (c == 'r') {
  1149.                            *nxtp = new_ilc(ILC_Ref);
  1150.                            (*nxtp)->n = RsltIndx;
  1151.                            c = getc(db);
  1152.                            }
  1153.                         else {
  1154.                            if (c != 'e' || getc(db) != 't')
  1155.                               db_err1(1, "expected $ret");
  1156.                            *nxtp = db_ilcret(ILC_Ret);
  1157.                            c = getc(db);
  1158.                            }
  1159.                         break;
  1160.                      case 's':                     /* $sb or $susp ... */
  1161.                         c = getc(db);
  1162.                         switch (c) {
  1163.                            case 'b':
  1164.                               *nxtp = new_ilc(ILC_SBuf);
  1165.                               c = getc(db);
  1166.                               break;
  1167.                            case 'u':
  1168.                               db_chstr("$su", "sp");
  1169.                               *nxtp = db_ilcret(ILC_Susp);
  1170.                               c = getc(db);
  1171.                               break;
  1172.                            default:
  1173.                              db_err1(1, "expected $sb or $susp");
  1174.                            }
  1175.                         break;
  1176.                      case 't':                     /* $t[d]<indx> */
  1177.                         *nxtp = new_ilc(ILC_Tend);
  1178.                         c = getc(db);
  1179.                         if (!isdigit(c))
  1180.                            db_err1(1, "$t: expected index");
  1181.                         GetInt(n, c);
  1182.                         (*nxtp)->n = n;
  1183.                         break;
  1184.                      case '{':
  1185.                         *nxtp = new_ilc(ILC_LBrc);
  1186.                         c = getc(db);
  1187.                         break;
  1188.                      case '}':
  1189.                         *nxtp = new_ilc(ILC_RBrc);
  1190.                         c = getc(db);
  1191.                         break;
  1192.                      default:
  1193.                         db_err1(1, "invalid $ escape in C code");
  1194.                      }
  1195.                   }
  1196.                else {
  1197.                   /*
  1198.                    * Arbitrary code - gather into a string.
  1199.                    */
  1200.                   while (c != '$') {
  1201.                      if (c == '"' || c == '\'') {
  1202.                         quoted(c);
  1203.                         c = getc(db);
  1204.                         }
  1205.                      if (c == '\n')
  1206.                         ++dbline;
  1207.                      if (c == EOF)
  1208.                         db_err1(1, "unexpected EOF in C code");
  1209.                      old_c = c;
  1210.                      AppChar(db_sbuf, c);
  1211.                      c = getc(db);
  1212.                      if (old_c == ' ')
  1213.                         while (c == ' ')
  1214.                            c = getc(db);
  1215.                      }
  1216.                   *nxtp = new_ilc(ILC_Str);
  1217.                   (*nxtp)->s = str_install(&db_sbuf);
  1218.                   }
  1219.                nxtp = &(*nxtp)->next;
  1220.                }
  1221.             }
  1222.          break;
  1223.       case 'n':
  1224.          db_chstr("n", "il");
  1225.          return NULL;
  1226.       }
  1227.    db_err1(1, "expected C code of the form $c ... $e or nil");
  1228.    /*NOTREACHED*/
  1229.    return 0;    /* avoid gcc warning */
  1230.    }
  1231.  
  1232. /*
  1233.  * quoted - get the string for a quoted literal. The first quote mark
  1234.  *  has been read.
  1235.  */
  1236. static void quoted(delim)
  1237. int delim;
  1238.    {
  1239.    register int c;
  1240.  
  1241.    AppChar(db_sbuf, delim);
  1242.    c = getc(db);
  1243.    while (c != delim && c != EOF) {
  1244.       if (c == '\\') {
  1245.          AppChar(db_sbuf, c);
  1246.          c = getc(db);
  1247.          if (c == EOF)
  1248.             db_err1(1, "unexpected EOF in quoted literal");
  1249.          }
  1250.       AppChar(db_sbuf, c);
  1251.       c = getc(db);
  1252.       }
  1253.    if (c == EOF)
  1254.       db_err1(1, "unexpected EOF in quoted literal");
  1255.    AppChar(db_sbuf, c);
  1256.    }
  1257.  
  1258. /*
  1259.  * db_ilcret - get the in-line C code on a return or suspend statement.
  1260.  */
  1261. static struct il_c *db_ilcret(il_c_type)
  1262. int il_c_type;
  1263.    {
  1264.    struct il_c *ilc;
  1265.    int c;
  1266.    int n;
  1267.    int i;
  1268.  
  1269.    ilc = new_ilc(il_c_type);
  1270.    ilc->n = db_icntyp();       /* kind of return expression */
  1271.    c = getc(db);
  1272.    SkipWhSp(c)
  1273.    GetInt(n, c)                /* number of arguments in this expression */
  1274.    for (i = 0; i < n; ++i)
  1275.       ilc->code[i] = db_ilc(); /* an argument to the return expression */
  1276.    return ilc;
  1277.    }
  1278.  
  1279. /*
  1280.  * db_tndtyp - get the indication for the type of a tended declaration.
  1281.  */
  1282. static int db_tndtyp()
  1283.    {
  1284.    int c;
  1285.  
  1286.    c = getc(db);
  1287.    SkipWhSp(c)
  1288.    switch (c) {
  1289.       case 'b':
  1290.          db_chstr("b", "lkptr");
  1291.          return TndBlk;          /* tended block pointer */
  1292.       case 'd':
  1293.          db_chstr("d", "esc");
  1294.          return TndDesc;         /* tended descriptor */
  1295.       case 's':
  1296.          db_chstr("s", "tr");
  1297.          return TndStr;          /* tended string */
  1298.       default:
  1299.          db_err1(1, "expected blkptr, desc, or str");
  1300.          /* NOTREACHED */
  1301.       }
  1302.    /* NOTREACHED */
  1303.    return 0;    /* avoid gcc warning */
  1304.    }
  1305.  
  1306. /*
  1307.  * db_icntyp - get a type code from the data base.
  1308.  */
  1309. static int db_icntyp()
  1310.    {
  1311.    int c;
  1312.    int n;
  1313.  
  1314.    c = getc(db);
  1315.    SkipWhSp(c)
  1316.    switch (c) {
  1317.       case 'T':
  1318.          c = getc(db);
  1319.          GetInt(n, c)
  1320.          if (n < num_typs)
  1321.             return type_map[n];       /* type code from specification system */
  1322.          break;
  1323.       case 'a':
  1324.          return TypAny;               /* a - any type */
  1325.       case 'c':
  1326.          switch (getc(db)) {
  1327.             case 'i':
  1328.                return TypCInt;        /* ci - C integer */
  1329.             case 'd':
  1330.                return TypCDbl;        /* cd - C double */
  1331.             case 's':
  1332.                return TypCStr;        /* cs - C string */
  1333.             }
  1334.          break;
  1335.       case 'd':
  1336.          return RetDesc;              /* d - descriptor on return statement */
  1337.       case 'e':
  1338.          switch (getc(db)) {
  1339.             case 'c':
  1340.                if (getc(db) == 'i')
  1341.                   return TypECInt;    /* eci - exact C integer */
  1342.                break;
  1343.             case 'i':
  1344.                return TypEInt;        /* ei - exact integer */
  1345.             case ' ':
  1346.             case '\n':
  1347.             case '\t':
  1348.                 return TypEmpty;      /* e - empty  type */
  1349.             }
  1350.          break;
  1351.       case 'n':
  1352.          if (getc(db) == 'v')
  1353.             return RetNVar;           /* nv - named variable on return */
  1354.          break;
  1355.       case 'r':
  1356.          if (getc(db) == 'n')
  1357.             return RetNone;           /* rn - nothing explicitly returned */
  1358.          break;
  1359.       case 's':
  1360.          if (getc(db) == 'v')
  1361.             return RetSVar;           /* sv - structure variable on return */
  1362.          break;
  1363.       case 't':
  1364.          switch (getc(db)) {
  1365.             case 'c':
  1366.                return TypTCset;       /* tc - temporary cset */
  1367.             case 's':
  1368.                return TypTStr;        /* ts - temporary string */
  1369.             }
  1370.          break;
  1371.       case 'v':
  1372.          return TypVar;               /* v - variable */
  1373.       }
  1374.    db_err1(1, "invalid type code");
  1375.    /* NOTREACHED */
  1376.    return 0;    /* avoid gcc warning */
  1377.    }
  1378.  
  1379. /*
  1380.  * new_ilc - allocate a new structure to hold a piece of in-line C code.
  1381.  */
  1382. static struct il_c *new_ilc(il_c_type)
  1383. int il_c_type;
  1384.    {
  1385.    struct il_c *ilc;
  1386.    int i;
  1387.  
  1388.    ilc = NewStruct(il_c);
  1389.    ilc->next = NULL;
  1390.    ilc->il_c_type = il_c_type;
  1391.    for (i = 0; i < 3; ++i)
  1392.       ilc->code[i] = NULL;
  1393.    ilc->n = 0;
  1394.    ilc->s = NULL;
  1395.    return ilc;
  1396.    }
  1397.  
  1398. /*
  1399.  * new_il - allocate a new structure with "size" fields to hold a piece of
  1400.  *   RTL code.
  1401.  */
  1402. struct il_code *new_il(il_type, size)
  1403. int il_type;
  1404. int size;
  1405.    {
  1406.    struct il_code *il;
  1407.  
  1408.    il = alloc(sizeof(struct il_code) + (size-1) * sizeof(union il_fld));
  1409.    il->il_type = il_type;
  1410.    return il;
  1411.    }
  1412.  
  1413. /*
  1414.  * db_dscrd - discard an implementation up to $end, skipping the in-line
  1415.  *   RTL code.
  1416.  */
  1417. void db_dscrd(ip)
  1418. struct implement *ip;
  1419.    {
  1420.    char state;  /* how far along we are at recognizing $end */
  1421.  
  1422.    free(ip);
  1423.    state = '\0';
  1424.    for (;;) {
  1425.       switch (getc(db)) {
  1426.          case '$':
  1427.             state = '$';
  1428.             continue;
  1429.          case 'e':
  1430.             if (state == '$') {
  1431.                state = 'e';
  1432.                continue;
  1433.                }
  1434.             break;
  1435.          case 'n':
  1436.             if (state == 'e') {
  1437.                state = 'n';
  1438.                continue;
  1439.                }
  1440.             break;
  1441.          case 'd':
  1442.             if (state == 'n')
  1443.                return;
  1444.             break;
  1445.          case '\n':
  1446.             ++dbline;
  1447.             break;
  1448.          case EOF:
  1449.             db_err1(1, "unexpected EOF");
  1450.          }
  1451.       state = '\0';
  1452.       }
  1453.    }
  1454.  
  1455. /*
  1456.  * db_chstr - we are expecting a specific string. We may already have
  1457.  *   read a prefix of it.
  1458.  */
  1459. void db_chstr(prefix, suffix)
  1460. char *prefix;
  1461. char *suffix;
  1462.    {
  1463.    int c;
  1464.  
  1465.    c = getc(db);
  1466.    SkipWhSp(c)
  1467.  
  1468.    for (;;) {
  1469.       if (*suffix == '\0' && (isspace(c) || c == EOF)) {
  1470.          if (c == '\n')
  1471.             ++dbline;
  1472.          return;
  1473.          }
  1474.       else if (*suffix != c)
  1475.          break;
  1476.       c = getc(db);
  1477.       ++suffix;
  1478.       }
  1479.    db_err3(1, "expected:", prefix, suffix);
  1480.    }
  1481.  
  1482. /*
  1483.  * db_tbl - fill in a hash table of implementation information for the
  1484.  *  given section.
  1485.  */
  1486. int db_tbl(section, tbl)
  1487. char *section;
  1488. struct implement **tbl;
  1489.    {
  1490.    struct implement *ip;
  1491.    int num_added = 0;
  1492.    unsigned hashval;
  1493.  
  1494.    /*
  1495.     * Get past the section header.
  1496.     */
  1497.    db_chstr("", section);
  1498.  
  1499.    /*
  1500.     * Create an entry in the hash table for each entry in the data base.
  1501.     *  If multiple data bases are loaded into one hash table, use the
  1502.     *  first entry encountered for each operation.
  1503.     */
  1504.    while ((ip = db_impl(toupper(section[0]))) != NULL) {
  1505.       if (db_ilkup(ip->name, tbl) == NULL) {
  1506.          db_code(ip);
  1507.          hashval = IHasher(ip->name);
  1508.          ip->blink = tbl[hashval];
  1509.          tbl[hashval] = ip;
  1510.          ++num_added;
  1511.          db_chstr("", "end");
  1512.          }
  1513.       else
  1514.          db_dscrd(ip);
  1515.       }
  1516.    db_chstr("", "endsect");
  1517.    return num_added;
  1518.    }
  1519.  
  1520. /*
  1521.  * db_ilkup - look up id in a table of implementation information and return
  1522.  *  pointer it or NULL if it is not there.
  1523.  */
  1524. struct implement *db_ilkup(id, tbl)
  1525. char *id;
  1526. struct implement **tbl;
  1527.    {
  1528.    register struct implement *ptr;
  1529.  
  1530.    ptr = tbl[IHasher(id)];
  1531.    while (ptr != NULL && ptr->name != id)
  1532.       ptr = ptr->blink;
  1533.    return ptr;
  1534.    }
  1535.  
  1536. /*
  1537.  * nxt_pre - assign next prefix. A prefix consists of n characters each from
  1538.  *   the range 0-9 and a-z, at least one of which is a digit.
  1539.  *
  1540.  */
  1541. void nxt_pre(pre, nxt, n)
  1542. char *pre;
  1543. char *nxt;
  1544. int n;
  1545.    {
  1546.    int i, num_dig;
  1547.  
  1548.    if (nxt[0] == '\0') {
  1549.       fprintf(stderr, "out of unique prefixes\n");
  1550.       exit(EXIT_FAILURE);
  1551.       }
  1552.  
  1553.    /*
  1554.     * copy the next prefix into the output string.
  1555.     */
  1556.    for (i = 0; i < n; ++i)
  1557.       pre[i] = nxt[i];
  1558.  
  1559.    /*
  1560.     * Increment next prefix. First, determine how many digits there are in
  1561.     *  the current prefix.
  1562.     */
  1563.    num_dig = 0;
  1564.    for (i = 0; i < n; ++i)
  1565.       if (isdigit(nxt[i]))
  1566.          ++num_dig;
  1567.  
  1568.    for (i = n - 1; i >= 0; --i) {
  1569.       switch (nxt[i]) {
  1570.          case '9':
  1571.             /*
  1572.              * If there is at least one other digit, increment to a letter.
  1573.              *  Otherwise, start over at zero and continue to the previous
  1574.              *  character in the prefix.
  1575.              */
  1576.             if (num_dig > 1) {
  1577.                nxt[i] = 'a';
  1578.                return;
  1579.                }
  1580.             else
  1581.                nxt[i] = '0';
  1582.             break;
  1583.  
  1584.          case 'z':
  1585.             /*
  1586.              * Start over at zero and continue to previous character in the
  1587.              *  prefix.
  1588.              */
  1589.             nxt[i] = '0';
  1590.             ++num_dig;
  1591.             break;
  1592.          default:
  1593.             ++nxt[i];
  1594.             return;
  1595.          }
  1596.       }
  1597.  
  1598.    /*
  1599.     * Indicate that there are no more prefixes.
  1600.     */
  1601.    nxt[0] = '\0';
  1602.    }
  1603.  
  1604. /*
  1605.  * cmp_pre - lexically compare 2-character prefixes.
  1606.  */
  1607. int cmp_pre(pre1, pre2)
  1608. char *pre1;
  1609. char *pre2;
  1610.    {
  1611.    int cmp;
  1612.  
  1613.    cmp = cmp_1_pre(pre1[0], pre2[0]);
  1614.    if (cmp == 0)
  1615.       return cmp_1_pre(pre1[1], pre2[1]);
  1616.    else
  1617.       return cmp;
  1618.    }
  1619.  
  1620. /*
  1621.  * cmp_1_pre - lexically compare 1 character of a prefix.
  1622.  */
  1623. static int cmp_1_pre(p1, p2)
  1624. int p1;
  1625. int p2;
  1626.    {
  1627.    if (isdigit(p1)) {
  1628.       if (isdigit(p2))
  1629.          return p1 - p2;
  1630.       else
  1631.          return -1;
  1632.       }
  1633.     else {
  1634.        if (isdigit(p2))
  1635.           return 1;
  1636.        else
  1637.          return p1 - p2;
  1638.       }
  1639.    }
  1640.  
  1641. /*
  1642.  * db_err1 - print a data base error message in the form of 1 string.
  1643.  */
  1644. void db_err1(fatal, s)
  1645. int fatal;
  1646. char *s;
  1647.    {
  1648.    if (fatal)
  1649.       fprintf(stderr, "error, ");
  1650.    else
  1651.       fprintf(stderr, "warning, ");
  1652.    fprintf(stderr, "data base \"%s\", line %d - %s\n", dbname, dbline, s);
  1653.    if (fatal)
  1654.       exit(EXIT_FAILURE);
  1655.    }
  1656.  
  1657. /*
  1658.  * db_err2 - print a data base error message in the form of 2 strings.
  1659.  */
  1660. void db_err2(fatal, s1, s2)
  1661. int fatal;
  1662. char *s1;
  1663. char *s2;
  1664.    {
  1665.    if (fatal)
  1666.       fprintf(stderr, "error, ");
  1667.    else
  1668.       fprintf(stderr, "warning, ");
  1669.    fprintf(stderr, "data base \"%s\", line %d - %s %s\n", dbname, dbline, s1,
  1670.       s2);
  1671.    if (fatal)
  1672.       exit(EXIT_FAILURE);
  1673.    }
  1674.  
  1675. /*
  1676.  * db_err3 - print a data base error message in the form of 3 strings.
  1677.  */
  1678. static void db_err3(fatal, s1, s2, s3)
  1679. int fatal;
  1680. char *s1;
  1681. char *s2;
  1682. char *s3;
  1683.    {
  1684.    if (fatal)
  1685.       fprintf(stderr, "error, ");
  1686.    else
  1687.       fprintf(stderr, "warning, ");
  1688.    fprintf(stderr, "data base \"%s\", line %d - %s %s%s\n", dbname, dbline, s1,
  1689.       s2, s3);
  1690.    if (fatal)
  1691.       exit(EXIT_FAILURE);
  1692.    }
  1693.