summaryrefslogtreecommitdiff
path: root/src/common/rtdb.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/common/rtdb.c')
-rw-r--r--src/common/rtdb.c1692
1 files changed, 1692 insertions, 0 deletions
diff --git a/src/common/rtdb.c b/src/common/rtdb.c
new file mode 100644
index 0000000..5467244
--- /dev/null
+++ b/src/common/rtdb.c
@@ -0,0 +1,1692 @@
+/*
+ * Routines to read a data base of run-time information.
+ */
+#include "../h/gsupport.h"
+#include "../h/version.h"
+#include "icontype.h"
+
+/*
+ * GetInt - the next thing in the data base is an integer. Get it.
+ */
+#define GetInt(n, c)\
+ n = 0;\
+ while (isdigit(c)) {\
+ n = n * 10 + (c - '0');\
+ c = getc(db);\
+ }
+
+/*
+ * SkipWhSp - skip white space characters in the data base.
+ */
+#define SkipWhSp(c)\
+ while (isspace(c)) {\
+ if (c == '\n')\
+ ++dbline;\
+ c = getc(db);\
+ }
+
+/*
+ * prototypes for static functions.
+ */
+static int cmp_1_pre (int p1, int p2);
+static struct il_code *db_abstr (void);
+static void db_case (struct il_code *il, int num_cases);
+static void db_err3 (int fatal,char *s1,char *s2,char *s3);
+static int db_icntyp (void);
+static struct il_c *db_ilc (void);
+static struct il_c *db_ilcret (int il_c_type);
+static struct il_code *db_inlin (void);
+static struct il_code *db_ilvar (void);
+static int db_rtflg (void);
+static int db_tndtyp (void);
+static struct il_c *new_ilc (int il_c_type);
+static void quoted (int delim);
+
+extern char *progname; /* name of program using this module */
+
+static char *dbname; /* data base name */
+static FILE *db; /* data base file */
+static int dbline; /* line number current position in data base */
+static struct str_buf db_sbuf; /* string buffer */
+static int *type_map; /* map data base type codes to internal ones */
+static int *compnt_map; /* map data base component codes to internal */
+
+/*
+ * opendb - open data base and do other house keeping.
+ */
+int db_open(s, lrgintflg)
+char *s;
+char **lrgintflg;
+ {
+ char *msg_buf;
+ char *id;
+ int i, n;
+ register int c;
+ static int first_time = 1;
+
+ if (first_time) {
+ first_time = 0;
+ init_sbuf(&db_sbuf);
+ }
+ dbname = s;
+ dbline = 0;
+ *lrgintflg = NULL;
+ db = fopen(dbname, "rb");
+ if (db == NULL)
+ return 0;
+ ++dbline;
+
+ /*
+ * Make sure the version number in the data base is what is expected.
+ */
+ s = db_string();
+ if (strcmp(s, DVersion) != 0) {
+ msg_buf = alloc(35 + strlen(s) + strlen(progname) + strlen(DVersion));
+ sprintf(msg_buf, "found version %s, %s requires version %s",
+ s, progname, DVersion);
+ db_err1(1, msg_buf);
+ }
+
+ *lrgintflg = db_string(); /* large integer flag */
+
+ /*
+ * Create tables for mapping type codes and type component codes in
+ * the data base to those compiled into this program. The codes may
+ * be different if types have been added to the program since the
+ * data base was created.
+ */
+ type_map = alloc(num_typs * sizeof(int));
+ db_chstr("", "types"); /* verify section header */
+ c = getc(db);
+ SkipWhSp(c)
+ while (c == 'T') {
+ c = getc(db);
+ if (!isdigit(c))
+ db_err1(1, "expected type code");
+ GetInt(n, c)
+ if (n >= num_typs)
+ db_err1(1, "data base inconsistant with program, rebuild data base");
+ SkipWhSp(c)
+ if (c != ':')
+ db_err1(1, "expected ':'");
+ id = db_string();
+ for (i = 0; strcmp(id, icontypes[i].id) != 0; ++i)
+ if (i >= num_typs)
+ db_err2(1, "unknown type:", id);
+ type_map[n] = i;
+ c = getc(db);
+ SkipWhSp(c)
+ }
+ db_chstr("", "endsect");
+
+ compnt_map = alloc(num_cmpnts * sizeof(int));
+ db_chstr("", "components"); /* verify section header */
+ c = getc(db);
+ SkipWhSp(c)
+ while (c == 'C') {
+ c = getc(db);
+ if (!isdigit(c))
+ db_err1(1, "expected type component code");
+ GetInt(n, c)
+ if (n >= num_cmpnts)
+ db_err1(1, "data base inconsistant with program, rebuild data base");
+ SkipWhSp(c)
+ if (c != ':')
+ db_err1(1, "expected ':'");
+ id = db_string();
+ for (i = 0; strcmp(id, typecompnt[i].id) != 0; ++i)
+ if (i >= num_cmpnts)
+ db_err2(1, "unknown type component:", id);
+ compnt_map[n] = i;
+ c = getc(db);
+ SkipWhSp(c)
+ }
+ db_chstr("", "endsect");
+
+ return 1;
+ }
+
+/*
+ * db_close - close data base.
+ */
+void db_close()
+ {
+ if (fclose(db) != 0)
+ db_err2(0, "cannot close", dbname);
+ }
+
+/*
+ * db_string - get a white-space delimited string from the data base.
+ */
+char *db_string()
+ {
+ register int c;
+
+ /*
+ * Look for the start of the string; '$' starts a special indicator.
+ * Copy characters into string buffer until white space is found.
+ */
+ c = getc(db);
+ SkipWhSp(c);
+ if (c == EOF)
+ db_err1(1, "unexpected EOF");
+ if (c == '$')
+ return NULL;
+ while (!isspace(c) && c != EOF) {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ if (c == '\n')
+ ++dbline;
+ return str_install(&db_sbuf); /* put string in string table */
+ }
+
+/*
+ * db_impl - read basic header information for an operation into a structure
+ * and return it.
+ */
+struct implement *db_impl(oper_typ)
+int oper_typ;
+ {
+ register struct implement *ip;
+ register int c;
+ int i;
+ char *name;
+ long n;
+
+ /*
+ * Get operation name.
+ */
+ if ((name = db_string()) == NULL)
+ return NULL;
+
+ /*
+ * Create an internal structure to hold the data base entry.
+ */
+ ip = NewStruct(implement);
+ ip->blink = NULL;
+ ip->iconc_flgs = 0; /* reserved for internal use by compiler */
+ ip->oper_typ = oper_typ;
+ ip->name = name;
+ ip->op = NULL;
+
+ /*
+ * Get the function name prefix assigned to this operation.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (isalpha(c) || isdigit(c))
+ ip->prefix[0] = c;
+ else
+ db_err2(1, "invalid prefix for", ip->name);
+ c = getc(db);
+ if (isalpha(c) || isdigit(c))
+ ip->prefix[1] = c;
+ else
+ db_err2(1, "invalid prefix for", ip->name);
+
+ /*
+ * Get the number of parameters.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (!isdigit(c))
+ db_err2(1, "number of parameters missing for", ip->name);
+ GetInt(n, c)
+ ip->nargs = n;
+
+ /*
+ * Get the flags that indicate whether each parameter requires a dereferenced
+ * and/or undereferenced value, and whether the last parameter represents
+ * the end of a varargs list. Store the flags in an array.
+ */
+ if (n == 0)
+ ip->arg_flgs = NULL;
+ else
+ ip->arg_flgs = alloc(n * sizeof(int));
+ if (c != '(')
+ db_err2(1, "parameter flags missing for", ip->name);
+ c = getc(db);
+ for (i = 0; i < n; ++i) {
+ if (c == ',' || c == ')')
+ db_err2(1, "parameter flag missing for", ip->name);
+ ip->arg_flgs[i] = 0;
+ while (c != ',' && c != ')') {
+ switch (c) {
+ case 'u':
+ ip->arg_flgs[i] |= RtParm;
+ break;
+ case 'd':
+ ip->arg_flgs[i] |= DrfPrm;
+ break;
+ case 'v':
+ ip->arg_flgs[i] |= VarPrm;
+ break;
+ default:
+ db_err2(1, "invalid parameter flag for", ip->name);
+ }
+ c = getc(db);
+ }
+ if (c == ',')
+ c = getc(db);
+ }
+ if (c != ')')
+ db_err2(1, "invalid parameter flag list for", ip->name);
+
+ /*
+ * Get the result sequence indicator for the operation.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c != '{')
+ db_err2(1, "result sequence missing for", ip->name);
+ c = getc(db);
+ ip->resume = 0;
+ if (c == '}') {
+ ip->min_result = NoRsltSeq;
+ ip->max_result = NoRsltSeq;
+ }
+ else {
+ if (!isdigit(c))
+ db_err2(1, "invalid result sequence for", ip->name);
+ GetInt(n, c)
+ ip->min_result = n;
+ if (c != ',')
+ db_err2(1, "invalid result sequence for", ip->name);
+ c = getc(db);
+ if (c == '*') {
+ ip->max_result = UnbndSeq;
+ c = getc(db);
+ }
+ else if (isdigit(c)) {
+ GetInt(n, c)
+ ip->max_result = n;
+ }
+ else
+ db_err2(1, "invalid result sequence for", ip->name);
+ if (c == '+') {
+ ip->resume = 1;
+ c = getc(db);
+ }
+ if (c != '}')
+ db_err2(1, "invalid result sequence for", ip->name);
+ }
+
+ /*
+ * Get the flag indicating whether the operation contains returns, fails,
+ * or suspends.
+ */
+ ip->ret_flag = db_rtflg();
+
+ /*
+ * Get the t/f flag that indicates whether the operation explicitly
+ * uses the 'result' location.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 't':
+ ip->use_rslt = 1;
+ break;
+ case 'f':
+ ip->use_rslt = 0;
+ break;
+ default:
+ db_err2(1, "invalid 'result' use indicator for", ip->name);
+ }
+ return ip;
+ }
+
+/*
+ * db_code - read the RTL code for the body of an operation.
+ */
+void db_code(ip)
+struct implement *ip;
+ {
+ register int c;
+ char *s;
+ word n;
+ int var_type;
+ int i;
+
+ /*
+ * read the descriptive string.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c != '"')
+ db_err1(1, "operation description expected");
+ for (c = getc(db); c != '"' && c != '\n' && c != EOF; c = getc(db)) {
+ if (c == '\\') {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ AppChar(db_sbuf, c);
+ }
+ if (c != '"')
+ db_err1(1, "expected '\"'");
+ ip->comment = str_install(&db_sbuf);
+
+ /*
+ * Get the number of tended variables in the declare clause.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ ip->ntnds = n;
+
+ /*
+ * Read information about the tended variables into an array.
+ */
+ if (n == 0)
+ ip->tnds = NULL;
+ else
+ ip->tnds = alloc(n * sizeof(struct tend_var));
+ for (i = 0; i < n; ++i) {
+ var_type = db_tndtyp(); /* type of tended declaration */
+ ip->tnds[i].var_type = var_type;
+ ip->tnds[i].blk_name = NULL;
+ if (var_type == TndBlk) {
+ /*
+ * Tended block pointer declarations include a block type or '*' to
+ * indicate 'union block *'.
+ */
+ s = db_string();
+ if (s == NULL)
+ db_err1(1, "block name expected");
+ if (*s != '*')
+ ip->tnds[i].blk_name = s;
+ }
+ ip->tnds[i].init = db_ilc(); /* C code for declaration initializer */
+ }
+
+ /*
+ * Get the number of non-tended variables in the declare clause.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ ip->nvars = n;
+
+ /*
+ * Get each non-tended declaration and store it in an array.
+ */
+ if (n == 0)
+ ip->vars = NULL;
+ else
+ ip->vars = alloc(n * sizeof(struct ord_var));
+ for (i = 0; i < n; ++i) {
+ s = db_string(); /* variable name */
+ if (s == NULL)
+ db_err1(1, "variable name expected");
+ ip->vars[i].name = s;
+ ip->vars[i].dcl = db_ilc(); /* full declaration including name */
+ }
+
+ /*
+ * Get the executable RTL code.
+ */
+ ip->in_line = db_inlin();
+
+ /*
+ * We should be at the end of the operation.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c != '$')
+ db_err1(1, "expected $end");
+ }
+
+/*
+ * db_inlin - read in the in-line code (executable RTL code) for an operation.
+ */
+static struct il_code *db_inlin()
+ {
+ struct il_code *il = NULL;
+ register int c;
+ int i;
+ int indx;
+ int fall_thru;
+ int n, n1;
+
+ /*
+ * The following nested switch statements act as a trie for recognizing
+ * the prefix form of RTL code in the data base.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'a':
+ switch (getc(db)) {
+ case 'b': {
+ db_chstr("ab", "str");
+ il = new_il(IL_Abstr, 2); /* abstract type computation */
+ il->u[0].fld = db_abstr(); /* side effects */
+ il->u[1].fld = db_abstr(); /* return type */
+ break;
+ }
+ case 'c': {
+ db_chstr("ac", "ase");
+ il = new_il(IL_Acase, 5); /* arith_case */
+ il->u[0].fld = db_ilvar(); /* first variable */
+ il->u[1].fld = db_ilvar(); /* second variable */
+ il->u[2].fld = db_inlin(); /* C_integer action */
+ il->u[3].fld = db_inlin(); /* integer action */
+ il->u[4].fld = db_inlin(); /* C_double action */
+ break;
+ }
+ default:
+ db_err1(1, "expected abstr or acase");
+ }
+ break;
+
+ case 'b':
+ db_chstr("b", "lock");
+ c = getc(db);
+ SkipWhSp(c)
+ if (c == 't')
+ fall_thru = 1;
+ else
+ fall_thru = 0;
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Block, 3 + n); /* block of in-line C code */
+ il->u[0].n = fall_thru;
+ il->u[1].n = n; /* number of local tended */
+ for (i = 2; i - 2 < n; ++i)
+ il->u[i].n = db_tndtyp(); /* tended declaration */
+ il->u[i].c_cd = db_ilc(); /* C code */
+ break;
+
+ case 'c':
+ switch (getc(db)) {
+ case 'a': {
+ char prfx3;
+ int ret_val = 0;
+ int ret_flag;
+ int rslt = 0;
+ int num_sbuf;
+ int num_cbuf;
+
+ db_chstr("ca", "ll");
+ /*
+ * Call to body function. Get the letter used as the 3rd
+ * character of the function prefix.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ prfx3 = c;
+
+ /*
+ * Determine what the body function returns directly.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'i':
+ ret_val = RetInt; /* returns C integer */
+ break;
+ case 'd':
+ ret_val = RetDbl; /* returns C double */
+ break;
+ case 'n':
+ ret_val = RetNoVal; /* returns nothing directly */
+ break;
+ case 's':
+ ret_val = RetSig; /* returns a signal */
+ break;
+ default:
+ db_err1(1, "invalid indicator for type of return value");
+ }
+
+ /*
+ * Get the return/suspend/fail/fall-through flag.
+ */
+ c = getc(db);
+ ret_flag = db_rtflg();
+
+ /*
+ * Get the flag indicating whether the body function expects
+ * to have an explicit result location passed to it.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 't':
+ rslt = 1;
+ break;
+ case 'f':
+ rslt = 0;
+ break;
+ default:
+ db_err1(1, "t or f expected");
+ }
+
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(num_sbuf, c) /* number of cset buffers */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(num_cbuf, c) /* number of string buffers */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c) /* num args */
+
+ il = new_il(IL_Call, 8 + n * 2);
+ il->u[0].n = 0; /* reserved for internal use by compiler */
+ il->u[1].n = prfx3;
+ il->u[2].n = ret_val;
+ il->u[3].n = ret_flag;
+ il->u[4].n = rslt;
+ il->u[5].n = num_sbuf;
+ il->u[6].n = num_cbuf;
+ il->u[7].n = n;
+ indx = 8;
+
+ /*
+ * get the prototype parameter declarations and actual arguments.
+ */
+ n *= 2;
+ while (n--)
+ il->u[indx++].c_cd = db_ilc();
+ }
+ break;
+
+ case 'n':
+ if (getc(db) != 'v')
+ db_err1(1, "expected cnv1 or cnv2");
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_Cnv1, 2);
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ break;
+ case '2':
+ il = new_il(IL_Cnv2, 3);
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ il->u[2].c_cd = db_ilc(); /* destination */
+ break;
+ default:
+ db_err1(1, "expected cnv1 or cnv2");
+ }
+ break;
+
+ case 'o':
+ db_chstr("co", "nst");
+ il = new_il(IL_Const, 2); /* constant keyword */
+ il->u[0].n = db_icntyp(); /* type code */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c == '"' || c == '\'') {
+ quoted(c);
+ c = getc(db); /* quoted literal without quotes */
+ }
+ else
+ while (c != EOF && !isspace(c)) {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ il->u[1].s = str_install(&db_sbuf); /* non-quoted values */
+ break;
+
+ default:
+ db_err1(1, "expected call, const, cnv1, or cnv2");
+ }
+ break;
+
+ case 'd':
+ if (getc(db) != 'e' || getc(db) != 'f')
+ db_err1(1, "expected def1 or def2");
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_Def1, 3); /* defaulting, no dest. field */
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ il->u[2].c_cd = db_ilc(); /* default value */
+ break;
+ case '2':
+ il = new_il(IL_Def2, 4); /* defaulting, with dest. field */
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ il->u[2].c_cd = db_ilc(); /* default value */
+ il->u[3].c_cd = db_ilc(); /* destination */
+ break;
+ default:
+ db_err1(1, "expected dflt1 or dflt2");
+ }
+ break;
+
+ case 'r':
+ if (getc(db) != 'u' || getc(db) != 'n' || getc(db) != 'e' ||
+ getc(db) != 'r' || getc(db) != 'r')
+ db_err1(1, "expected runerr1 or runerr2");
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_Err1, 1); /* runerr, no offending value */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il->u[0].n = n; /* error number */
+ break;
+ case '2':
+ il = new_il(IL_Err2, 2); /* runerr, with offending value */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il->u[0].n = n; /* error number */
+ il->u[1].fld = db_ilvar(); /* variable */
+ break;
+ default:
+ db_err1(1, "expected runerr1 or runerr2");
+ }
+ break;
+
+ case 'i':
+ switch (getc(db)) {
+ case 'f':
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_If1, 2); /* if-then */
+ il->u[0].fld = db_inlin(); /* condition */
+ il->u[1].fld = db_inlin(); /* then clause */
+ break;
+ case '2':
+ il = new_il(IL_If2, 3); /* if-then-else */
+ il->u[0].fld = db_inlin(); /* condition */
+ il->u[1].fld = db_inlin(); /* then clause */
+ il->u[2].fld = db_inlin(); /* else clause */
+ break;
+ default:
+ db_err1(1, "expected if1 or if2");
+ }
+ break;
+ case 's':
+ il = new_il(IL_Is, 2); /* type check */
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* variable */
+ break;
+ default:
+ db_err1(1, "expected if1, if2, or is");
+ }
+ break;
+
+ case 'l':
+ switch (getc(db)) {
+ case 'c':
+ db_chstr("lc", "ase");
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Lcase, 2 + 2 * n); /* length case */
+ il->u[0].n = n; /* number of cases */
+ indx = 1;
+ while (n--) {
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n1, c)
+ il->u[indx++].n = n1; /* selection number */
+ il->u[indx++].fld = db_inlin(); /* action */
+ }
+ il->u[indx].fld = db_inlin(); /* default */
+ break;
+
+ case 's':
+ if (getc(db) != 't')
+ db_err1(1, "expected lst");
+ il = new_il(IL_Lst, 2); /* sequence of code parts */
+ il->u[0].fld = db_inlin(); /* 1st part */
+ il->u[1].fld = db_inlin(); /* 2nd part */
+ break;
+
+ default:
+ db_err1(1, "expected lcase or lst");
+ }
+ break;
+
+ case 'n':
+ db_chstr("n", "il");
+ il = NULL;
+ break;
+
+ case 't': {
+ struct il_code *var;
+
+ if (getc(db) != 'c' || getc(db) != 'a' || getc(db) != 's' ||
+ getc(db) != 'e')
+ db_err1(1, "expected tcase1 or tcase2");
+ switch (getc(db)) {
+ case '1':
+ var = db_ilvar();
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Tcase1, 3 * n + 2); /* type case, no default */
+ il->u[0].fld = var; /* variable */
+ db_case(il, n); /* get cases */
+ break;
+
+ case '2':
+ var = db_ilvar();
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Tcase2, 3 * n + 3); /* type case, with default */
+ il->u[0].fld = var; /* variable */
+ db_case(il, n); /* get cases */
+ il->u[3 * n + 2].fld = db_inlin(); /* default */
+ break;
+
+ default:
+ db_err1(1, "expected tcase1 or tcase2");
+ }
+ }
+ break;
+
+ case '!':
+ il = new_il(IL_Bang, 1); /* negated condition */
+ il->u[0].fld = db_inlin(); /* condition */
+ break;
+
+ case '&':
+ if (getc(db) != '&')
+ db_err1(1, "expected &&");
+ il = new_il(IL_And, 2); /* && (conjunction) */
+ il->u[0].fld = db_inlin(); /* 1st operand */
+ il->u[1].fld = db_inlin(); /* 2nd operand */
+ break;
+
+ default:
+ db_err1(1, "syntax error");
+ }
+ return il;
+ }
+
+/*
+ * db_rtflg - get the sequence of 4 [or 5] flags that indicate whether code
+ * for a operation [or body function] returns, fails, suspends, has error
+ * failure, [or execution falls through the code].
+ */
+static int db_rtflg()
+ {
+ register int c;
+ int ret_flag;
+
+ /*
+ * The presence of each flag is indicated by a unique character. Its absence
+ * indicated by '_'.
+ */
+ ret_flag = 0;
+ c = getc(db);
+ SkipWhSp(c)
+ if (c == 'f')
+ ret_flag |= DoesFail;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 'r')
+ ret_flag |= DoesRet;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 's')
+ ret_flag |= DoesSusp;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 'e')
+ ret_flag |= DoesEFail;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 't')
+ ret_flag |= DoesFThru;
+ else if (c != '_' && c != ' ')
+ db_err1(1, "invalid return indicator");
+ return ret_flag;
+ }
+
+/*
+ * db_case - get the cases for a type_case statement from the data base.
+ */
+static void db_case(il, num_cases)
+struct il_code *il;
+int num_cases;
+ {
+ register int c;
+ int *typ_vect;
+ int i, j;
+ int num_types;
+ int indx;
+
+ il->u[1].n = num_cases; /* number of cases */
+ indx = 2;
+ for (i = 0; i < num_cases; ++i) {
+ /*
+ * Determine the number of types in this case then store the
+ * type codes in an array.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(num_types, c)
+ il->u[indx++].n = num_types;
+ typ_vect = alloc(num_types * sizeof(int));
+ il->u[indx++].vect = typ_vect;
+ for (j = 0; j < num_types; ++j)
+ typ_vect[j] = db_icntyp(); /* type code */
+
+ il->u[indx++].fld = db_inlin(); /* action */
+ }
+ }
+
+/*
+ * db_ilvar - get a symbol table index for a simple variable or a
+ * subscripted variable from the data base.
+ */
+static struct il_code *db_ilvar()
+ {
+ struct il_code *il;
+ register int c;
+ int n;
+
+ c = getc(db);
+ SkipWhSp(c)
+
+ if (isdigit(c)) {
+ /*
+ * Simple variable: just a symbol table index.
+ */
+ il = new_il(IL_Var, 1);
+ GetInt(n, c)
+ il->u[0].n = n; /* symbol table index */
+ }
+ else {
+ if (c != '[')
+ db_err1(1, "expected symbol table index or '['");
+ /*
+ * Subscripted variable: symbol table index and subscript.
+ */
+ il = new_il(IL_Subscr, 2);
+ c = getc(db);
+ SkipWhSp(c);
+ GetInt(n, c)
+ il->u[0].n = n; /* symbol table index */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il->u[1].n = n; /* subscripting index */
+ }
+ return il;
+ }
+
+/*
+ * db_abstr - get abstract type computations from the data base.
+ */
+static struct il_code *db_abstr()
+ {
+ struct il_code *il = NULL;
+ register int c;
+ word typcd;
+ word indx;
+ int n;
+ int nargs;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'l':
+ db_chstr("l", "st");
+ il = new_il(IL_Lst, 2); /* sequence of code parts */
+ il->u[0].fld = db_abstr(); /* 1st part */
+ il->u[1].fld = db_abstr(); /* 2nd part */
+ break;
+
+ case 'n':
+ switch (getc(db)) {
+ case 'e':
+ if (getc(db) != 'w')
+ db_err1(1, "expected new");
+ typcd = db_icntyp();
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(nargs, c)
+ il = new_il(IL_New, 2 + nargs); /* new structure create here */
+ il->u[0].n = typcd; /* type code */
+ il->u[1].n = nargs; /* number of args */
+ indx = 2;
+ while (nargs--)
+ il->u[indx++].fld = db_abstr(); /* argument for component */
+ break;
+ case 'i':
+ if (getc(db) != 'l')
+ db_err1(1, "expected nil");
+ il = NULL;
+ break;
+ default:
+ db_err1(1, "expected new or nil");
+ }
+ break;
+
+ case 's':
+ db_chstr("s", "tore");
+ il = new_il(IL_Store, 1); /* abstract store */
+ il->u[0].fld = db_abstr(); /* type to "dereference" */
+ break;
+
+ case 't':
+ db_chstr("t", "yp");
+ il = new_il(IL_IcnTyp, 1); /* explicit type */
+ il->u[0].n = db_icntyp(); /* type code */
+ break;
+
+ case 'v':
+ db_chstr("v", "artyp");
+ il = new_il(IL_VarTyp, 1); /* variable */
+ il->u[0].fld = db_ilvar(); /* symbol table index, etc */
+ break;
+
+ case '.':
+ il = new_il(IL_Compnt, 2); /* component access */
+ il->u[0].fld = db_abstr(); /* type being accessed */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'f':
+ il->u[1].n = CM_Fields;
+ break;
+ case 'C':
+ c = getc(db);
+ GetInt(n, c)
+ il->u[1].n = compnt_map[n];
+ break;
+ default:
+ db_err1(1, "expected component code");
+ }
+ break;
+
+ case '=':
+ il = new_il(IL_TpAsgn, 2); /* assignment (side effect) */
+ il->u[0].fld = db_abstr(); /* left-hand-side */
+ il->u[1].fld = db_abstr(); /* right-hand-side */
+ break;
+
+ case '+':
+ if (getc(db) != '+')
+ db_err1(1, "expected ++");
+ il = new_il(IL_Union, 2); /* ++ (union) */
+ il->u[0].fld = db_abstr(); /* 1st operand */
+ il->u[1].fld = db_abstr(); /* 2nd operand */
+ break;
+
+ case '*':
+ if (getc(db) != '*')
+ db_err1(1, "expected **");
+ il = new_il(IL_Inter, 2); /* ** (intersection) */
+ il->u[0].fld = db_abstr(); /* 1st operand */
+ il->u[1].fld = db_abstr(); /* 2nd operand */
+ break;
+ }
+ return il;
+ }
+
+/*
+ * db_ilc - read a piece of in-line C code.
+ */
+static struct il_c *db_ilc()
+ {
+ register int c;
+ int old_c;
+ word n;
+ struct il_c *base = NULL;
+ struct il_c **nxtp = &base;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case '$':
+ /*
+ * This had better be the starting $c.
+ */
+ c = getc(db);
+ if (c == 'c') {
+ c = getc(db);
+ for (;;) {
+ SkipWhSp(c)
+ if (c == '$') {
+ c = getc(db);
+ switch (c) {
+ case 'c': /* $cb or $cgoto <cond> <lbl num> */
+ c = getc(db);
+ switch (c) {
+ case 'b':
+ *nxtp = new_ilc(ILC_CBuf);
+ c = getc(db);
+ break;
+ case 'g':
+ db_chstr("$cg", "oto");
+ *nxtp = new_ilc(ILC_CGto);
+#ifdef MultiThread
+ #undef code
+#endif /* MultiThead */
+ (*nxtp)->code[0] = db_ilc();
+ c = getc(db);
+ SkipWhSp(c);
+ if (!isdigit(c))
+ db_err1(1, "$cgoto: expected label number");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ default:
+ db_err1(1, "expected $cb or $cgoto");
+ }
+ break;
+ case 'e':
+ c = getc(db);
+ if (c == 'f') { /* $efail */
+ db_chstr("$ef", "ail");
+ *nxtp = new_ilc(ILC_EFail);
+ c = getc(db);
+ break;
+ }
+ else
+ return base; /* $e */
+ case 'f': /* $fail */
+ db_chstr("$f", "ail");
+ *nxtp = new_ilc(ILC_Fail);
+ c = getc(db);
+ break;
+ case 'g': /* $goto <lbl num> */
+ db_chstr("$g", "oto");
+ *nxtp = new_ilc(ILC_Goto);
+ c = getc(db);
+ SkipWhSp(c);
+ if (!isdigit(c))
+ db_err1(1, "$goto: expected label number");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ case 'l': /* $lbl <lbl num> */
+ db_chstr("$l", "bl");
+ *nxtp = new_ilc(ILC_Lbl);
+ c = getc(db);
+ SkipWhSp(c);
+ if (!isdigit(c))
+ db_err1(1, "$lbl: expected label number");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ case 'm': /* $m[d]<indx> */
+ *nxtp = new_ilc(ILC_Mod);
+ c = getc(db);
+ if (c == 'd') {
+ (*nxtp)->s = "d";
+ c = getc(db);
+ }
+ if (isdigit(c)) {
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ }
+ else if (c == 'r') {
+ (*nxtp)->n = RsltIndx;
+ c = getc(db);
+ }
+ else
+ db_err1(1, "$m: expected symbol table index");
+ break;
+ case 'r': /* $r[d]<indx> or $ret ... */
+ c = getc(db);
+ if (isdigit(c) || c == 'd') {
+ *nxtp = new_ilc(ILC_Ref);
+ if (c == 'd') {
+ (*nxtp)->s = "d";
+ c = getc(db);
+ }
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ }
+ else if (c == 'r') {
+ *nxtp = new_ilc(ILC_Ref);
+ (*nxtp)->n = RsltIndx;
+ c = getc(db);
+ }
+ else {
+ if (c != 'e' || getc(db) != 't')
+ db_err1(1, "expected $ret");
+ *nxtp = db_ilcret(ILC_Ret);
+ c = getc(db);
+ }
+ break;
+ case 's': /* $sb or $susp ... */
+ c = getc(db);
+ switch (c) {
+ case 'b':
+ *nxtp = new_ilc(ILC_SBuf);
+ c = getc(db);
+ break;
+ case 'u':
+ db_chstr("$su", "sp");
+ *nxtp = db_ilcret(ILC_Susp);
+ c = getc(db);
+ break;
+ default:
+ db_err1(1, "expected $sb or $susp");
+ }
+ break;
+ case 't': /* $t[d]<indx> */
+ *nxtp = new_ilc(ILC_Tend);
+ c = getc(db);
+ if (!isdigit(c))
+ db_err1(1, "$t: expected index");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ case '{':
+ *nxtp = new_ilc(ILC_LBrc);
+ c = getc(db);
+ break;
+ case '}':
+ *nxtp = new_ilc(ILC_RBrc);
+ c = getc(db);
+ break;
+ default:
+ db_err1(1, "invalid $ escape in C code");
+ }
+ }
+ else {
+ /*
+ * Arbitrary code - gather into a string.
+ */
+ while (c != '$') {
+ if (c == '"' || c == '\'') {
+ quoted(c);
+ c = getc(db);
+ }
+ if (c == '\n')
+ ++dbline;
+ if (c == EOF)
+ db_err1(1, "unexpected EOF in C code");
+ old_c = c;
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ if (old_c == ' ')
+ while (c == ' ')
+ c = getc(db);
+ }
+ *nxtp = new_ilc(ILC_Str);
+ (*nxtp)->s = str_install(&db_sbuf);
+ }
+ nxtp = &(*nxtp)->next;
+ }
+ }
+ break;
+ case 'n':
+ db_chstr("n", "il");
+ return NULL;
+ }
+ db_err1(1, "expected C code of the form $c ... $e or nil");
+ /*NOTREACHED*/
+ return 0; /* avoid gcc warning */
+ }
+
+/*
+ * quoted - get the string for a quoted literal. The first quote mark
+ * has been read.
+ */
+static void quoted(delim)
+int delim;
+ {
+ register int c;
+
+ AppChar(db_sbuf, delim);
+ c = getc(db);
+ while (c != delim && c != EOF) {
+ if (c == '\\') {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ if (c == EOF)
+ db_err1(1, "unexpected EOF in quoted literal");
+ }
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ if (c == EOF)
+ db_err1(1, "unexpected EOF in quoted literal");
+ AppChar(db_sbuf, c);
+ }
+
+/*
+ * db_ilcret - get the in-line C code on a return or suspend statement.
+ */
+static struct il_c *db_ilcret(il_c_type)
+int il_c_type;
+ {
+ struct il_c *ilc;
+ int c;
+ int n;
+ int i;
+
+ ilc = new_ilc(il_c_type);
+ ilc->n = db_icntyp(); /* kind of return expression */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c) /* number of arguments in this expression */
+ for (i = 0; i < n; ++i)
+ ilc->code[i] = db_ilc(); /* an argument to the return expression */
+ return ilc;
+ }
+
+/*
+ * db_tndtyp - get the indication for the type of a tended declaration.
+ */
+static int db_tndtyp()
+ {
+ int c;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'b':
+ db_chstr("b", "lkptr");
+ return TndBlk; /* tended block pointer */
+ case 'd':
+ db_chstr("d", "esc");
+ return TndDesc; /* tended descriptor */
+ case 's':
+ db_chstr("s", "tr");
+ return TndStr; /* tended string */
+ default:
+ db_err1(1, "expected blkptr, desc, or str");
+ /* NOTREACHED */
+ }
+ /* NOTREACHED */
+ return 0; /* avoid gcc warning */
+ }
+
+/*
+ * db_icntyp - get a type code from the data base.
+ */
+static int db_icntyp()
+ {
+ int c;
+ int n;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'T':
+ c = getc(db);
+ GetInt(n, c)
+ if (n < num_typs)
+ return type_map[n]; /* type code from specification system */
+ break;
+ case 'a':
+ return TypAny; /* a - any type */
+ case 'c':
+ switch (getc(db)) {
+ case 'i':
+ return TypCInt; /* ci - C integer */
+ case 'd':
+ return TypCDbl; /* cd - C double */
+ case 's':
+ return TypCStr; /* cs - C string */
+ }
+ break;
+ case 'd':
+ return RetDesc; /* d - descriptor on return statement */
+ case 'e':
+ switch (getc(db)) {
+ case 'c':
+ if (getc(db) == 'i')
+ return TypECInt; /* eci - exact C integer */
+ break;
+ case 'i':
+ return TypEInt; /* ei - exact integer */
+ case ' ':
+ case '\n':
+ case '\t':
+ return TypEmpty; /* e - empty type */
+ }
+ break;
+ case 'n':
+ if (getc(db) == 'v')
+ return RetNVar; /* nv - named variable on return */
+ break;
+ case 'r':
+ if (getc(db) == 'n')
+ return RetNone; /* rn - nothing explicitly returned */
+ break;
+ case 's':
+ if (getc(db) == 'v')
+ return RetSVar; /* sv - structure variable on return */
+ break;
+ case 't':
+ switch (getc(db)) {
+ case 'c':
+ return TypTCset; /* tc - temporary cset */
+ case 's':
+ return TypTStr; /* ts - temporary string */
+ }
+ break;
+ case 'v':
+ return TypVar; /* v - variable */
+ }
+ db_err1(1, "invalid type code");
+ /* NOTREACHED */
+ return 0; /* avoid gcc warning */
+ }
+
+/*
+ * new_ilc - allocate a new structure to hold a piece of in-line C code.
+ */
+static struct il_c *new_ilc(il_c_type)
+int il_c_type;
+ {
+ struct il_c *ilc;
+ int i;
+
+ ilc = NewStruct(il_c);
+ ilc->next = NULL;
+ ilc->il_c_type = il_c_type;
+ for (i = 0; i < 3; ++i)
+ ilc->code[i] = NULL;
+ ilc->n = 0;
+ ilc->s = NULL;
+ return ilc;
+ }
+
+/*
+ * new_il - allocate a new structure with "size" fields to hold a piece of
+ * RTL code.
+ */
+struct il_code *new_il(il_type, size)
+int il_type;
+int size;
+ {
+ struct il_code *il;
+
+ il = alloc(sizeof(struct il_code) + (size-1) * sizeof(union il_fld));
+ il->il_type = il_type;
+ return il;
+ }
+
+/*
+ * db_dscrd - discard an implementation up to $end, skipping the in-line
+ * RTL code.
+ */
+void db_dscrd(ip)
+struct implement *ip;
+ {
+ char state; /* how far along we are at recognizing $end */
+
+ free(ip);
+ state = '\0';
+ for (;;) {
+ switch (getc(db)) {
+ case '$':
+ state = '$';
+ continue;
+ case 'e':
+ if (state == '$') {
+ state = 'e';
+ continue;
+ }
+ break;
+ case 'n':
+ if (state == 'e') {
+ state = 'n';
+ continue;
+ }
+ break;
+ case 'd':
+ if (state == 'n')
+ return;
+ break;
+ case '\n':
+ ++dbline;
+ break;
+ case EOF:
+ db_err1(1, "unexpected EOF");
+ }
+ state = '\0';
+ }
+ }
+
+/*
+ * db_chstr - we are expecting a specific string. We may already have
+ * read a prefix of it.
+ */
+void db_chstr(prefix, suffix)
+char *prefix;
+char *suffix;
+ {
+ int c;
+
+ c = getc(db);
+ SkipWhSp(c)
+
+ for (;;) {
+ if (*suffix == '\0' && (isspace(c) || c == EOF)) {
+ if (c == '\n')
+ ++dbline;
+ return;
+ }
+ else if (*suffix != c)
+ break;
+ c = getc(db);
+ ++suffix;
+ }
+ db_err3(1, "expected:", prefix, suffix);
+ }
+
+/*
+ * db_tbl - fill in a hash table of implementation information for the
+ * given section.
+ */
+int db_tbl(section, tbl)
+char *section;
+struct implement **tbl;
+ {
+ struct implement *ip;
+ int num_added = 0;
+ unsigned hashval;
+
+ /*
+ * Get past the section header.
+ */
+ db_chstr("", section);
+
+ /*
+ * Create an entry in the hash table for each entry in the data base.
+ * If multiple data bases are loaded into one hash table, use the
+ * first entry encountered for each operation.
+ */
+ while ((ip = db_impl(toupper(section[0]))) != NULL) {
+ if (db_ilkup(ip->name, tbl) == NULL) {
+ db_code(ip);
+ hashval = IHasher(ip->name);
+ ip->blink = tbl[hashval];
+ tbl[hashval] = ip;
+ ++num_added;
+ db_chstr("", "end");
+ }
+ else
+ db_dscrd(ip);
+ }
+ db_chstr("", "endsect");
+ return num_added;
+ }
+
+/*
+ * db_ilkup - look up id in a table of implementation information and return
+ * pointer it or NULL if it is not there.
+ */
+struct implement *db_ilkup(id, tbl)
+char *id;
+struct implement **tbl;
+ {
+ register struct implement *ptr;
+
+ ptr = tbl[IHasher(id)];
+ while (ptr != NULL && ptr->name != id)
+ ptr = ptr->blink;
+ return ptr;
+ }
+
+/*
+ * nxt_pre - assign next prefix. A prefix consists of n characters each from
+ * the range 0-9 and a-z, at least one of which is a digit.
+ *
+ */
+void nxt_pre(pre, nxt, n)
+char *pre;
+char *nxt;
+int n;
+ {
+ int i, num_dig;
+
+ if (nxt[0] == '\0') {
+ fprintf(stderr, "out of unique prefixes\n");
+ exit(EXIT_FAILURE);
+ }
+
+ /*
+ * copy the next prefix into the output string.
+ */
+ for (i = 0; i < n; ++i)
+ pre[i] = nxt[i];
+
+ /*
+ * Increment next prefix. First, determine how many digits there are in
+ * the current prefix.
+ */
+ num_dig = 0;
+ for (i = 0; i < n; ++i)
+ if (isdigit(nxt[i]))
+ ++num_dig;
+
+ for (i = n - 1; i >= 0; --i) {
+ switch (nxt[i]) {
+ case '9':
+ /*
+ * If there is at least one other digit, increment to a letter.
+ * Otherwise, start over at zero and continue to the previous
+ * character in the prefix.
+ */
+ if (num_dig > 1) {
+ nxt[i] = 'a';
+ return;
+ }
+ else
+ nxt[i] = '0';
+ break;
+
+ case 'z':
+ /*
+ * Start over at zero and continue to previous character in the
+ * prefix.
+ */
+ nxt[i] = '0';
+ ++num_dig;
+ break;
+ default:
+ ++nxt[i];
+ return;
+ }
+ }
+
+ /*
+ * Indicate that there are no more prefixes.
+ */
+ nxt[0] = '\0';
+ }
+
+/*
+ * cmp_pre - lexically compare 2-character prefixes.
+ */
+int cmp_pre(pre1, pre2)
+char *pre1;
+char *pre2;
+ {
+ int cmp;
+
+ cmp = cmp_1_pre(pre1[0], pre2[0]);
+ if (cmp == 0)
+ return cmp_1_pre(pre1[1], pre2[1]);
+ else
+ return cmp;
+ }
+
+/*
+ * cmp_1_pre - lexically compare 1 character of a prefix.
+ */
+static int cmp_1_pre(p1, p2)
+int p1;
+int p2;
+ {
+ if (isdigit(p1)) {
+ if (isdigit(p2))
+ return p1 - p2;
+ else
+ return -1;
+ }
+ else {
+ if (isdigit(p2))
+ return 1;
+ else
+ return p1 - p2;
+ }
+ }
+
+/*
+ * db_err1 - print a data base error message in the form of 1 string.
+ */
+void db_err1(fatal, s)
+int fatal;
+char *s;
+ {
+ if (fatal)
+ fprintf(stderr, "error, ");
+ else
+ fprintf(stderr, "warning, ");
+ fprintf(stderr, "data base \"%s\", line %d - %s\n", dbname, dbline, s);
+ if (fatal)
+ exit(EXIT_FAILURE);
+ }
+
+/*
+ * db_err2 - print a data base error message in the form of 2 strings.
+ */
+void db_err2(fatal, s1, s2)
+int fatal;
+char *s1;
+char *s2;
+ {
+ if (fatal)
+ fprintf(stderr, "error, ");
+ else
+ fprintf(stderr, "warning, ");
+ fprintf(stderr, "data base \"%s\", line %d - %s %s\n", dbname, dbline, s1,
+ s2);
+ if (fatal)
+ exit(EXIT_FAILURE);
+ }
+
+/*
+ * db_err3 - print a data base error message in the form of 3 strings.
+ */
+static void db_err3(fatal, s1, s2, s3)
+int fatal;
+char *s1;
+char *s2;
+char *s3;
+ {
+ if (fatal)
+ fprintf(stderr, "error, ");
+ else
+ fprintf(stderr, "warning, ");
+ fprintf(stderr, "data base \"%s\", line %d - %s %s%s\n", dbname, dbline, s1,
+ s2, s3);
+ if (fatal)
+ exit(EXIT_FAILURE);
+ }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 11:52:11 +0000