1BSD/pi/nl.c
#
/*
* pi - Pascal interpreter code translator
*
* Charles Haley, Bill Joy UCB
* Version 1.0 August 1977
*/
#include "whoami"
#include "0.h"
#include "opcode.h"
#ifdef PI
/*
* Array of information about pre-defined, block 0 symbols.
*/
int *biltins[] {
/*
* Types
*/
"boolean",
"char",
"integer",
"real",
"_nil", /* dummy name */
0,
/*
* Ranges
*/
TINT, 0177777, 0177600, 0, 0177,
TINT, 0177777, 0100000, 0, 077777,
TINT, 0100000, 0, 077777, 0177777,
TCHAR, 0, 0, 0, 127,
TBOOL, 0, 0, 0, 1,
TDOUBLE, 0, 0, 0, 0, /* fake for reals */
0,
/*
* Built-in composite types
*/
"Boolean",
"intset",
"alfa",
"text",
"input",
"output",
/*
* Built-in constants
*/
"true", TBOOL, 1, 0,
"false", TBOOL, 0, 0,
"minint", T4INT, 0100000, 0,
"maxint", T4INT, 077777, 0177777,
"minchar", T1CHAR, 0, 0,
"maxchar", T1CHAR, 0177, 0,
"bell", T1CHAR, 07, 0,
"tab", T1CHAR, 011, 0,
0,
/*
* Built-in functions
*/
"abs", O_ABS2,
"arctan", O_ATAN,
"card", O_CARD|NSTAND,
"chr", O_CHR2,
"clock", O_CLCK|NSTAND,
"cos", O_COS,
"eof", O_EOF,
"eoln", O_EOLN,
"eos", 0,
"exp", O_EXP,
"expo", O_EXPO|NSTAND,
"ln", O_LN,
"odd", O_ODD2,
"ord", O_ORD2,
"pred", O_PRED2,
"round", O_ROUND,
"sin", O_SIN,
"sqr", O_SQR2,
"sqrt", O_SQRT,
"succ", O_SUCC2,
"trunc", O_TRUNC,
"undefined", O_UNDEF|NSTAND,
/*
* UNIX extensions
*/
"argc", O_ARGC|NSTAND,
"random", O_RANDOM|NSTAND,
"seed", O_SEED|NSTAND,
"wallclock", O_WCLCK|NSTAND,
"sysclock", O_SCLCK|NSTAND,
0,
/*
* Built-in procedures
*/
"date", O_DATE|NSTAND,
"flush", O_FLUSH|NSTAND,
"get", O_GET,
"getseg", 0,
"halt", O_HALT|NSTAND,
"linelimit", O_LLIMIT|NSTAND,
"message", O_MESSAGE|NSTAND,
"new", O_NEW,
"pack", O_PACK,
"page", O_PAGE,
"put", O_PUT,
"putseg", 0,
"read", O_READ4,
"readln", O_READLN,
"remove", O_REMOVE|NSTAND,
"reset", O_RESET,
"rewrite", O_REWRITE,
"time", O_TIME|NSTAND,
"unpack", O_UNPACK,
"write", O_WRIT2,
"writeln", O_WRITLN,
/*
* UNIX extensions
*/
"argv", O_ARGV|NSTAND,
"null", O_NULL|NSTAND,
"stlimit", O_STLIM|NSTAND,
0,
};
/*
* NAMELIST SEGMENT DEFINITIONS
*/
struct nls {
struct nl *nls_low;
struct nl *nls_high;
} ntab[MAXNL], *nlact;
struct nl nl[INL];
struct nl *nlp nl;
struct nls *nlact ntab;
/*
* Initnl initializes the first namelist segment and then
* uses the array biltins to initialize the name list for
* block 0.
*/
initnl()
{
register int *q;
register struct nl *p;
register int i;
ntab[0].nls_low = nl;
ntab[0].nls_high = &nl[INL];
defnl(0, 0, 0, 0);
/*
* Fundamental types
*/
for (q = biltins; *q != 0; q++)
hdefnl(*q, TYPE, nlp, 0);
q++;
/*
* Ranges
*/
while (*q) {
p = defnl(0, RANGE, nl+*q, 0);
nl[*q++].type = p;
for (i = 0; i < 4; i++)
p->value[i] = *q++;
}
q++;
/*
* Pre-defined composite types
*/
hdefnl(*q++, TYPE, nl+T1BOOL, 0);
enter(defnl((intset = *q++), TYPE, nlp+1, 0));
defnl(0, SET, nlp+1, 0);
defnl(0, RANGE, nl+TINT, 0)->value[3] = 127;
p= defnl(0, RANGE, nl+TINT, 0);
p->value[1] = 1;
p->value[3] = 10;
defnl(0, ARRAY, nl+T1CHAR, 1)->chain = p;
hdefnl(*q++, TYPE, nlp-1, 0); /* "alfa" */
hdefnl(*q++, TYPE, nlp+1, 0); /* "text" */
p= defnl(0, FILE, nl+T1CHAR, 0);
p->nl_flags =| NFILES;
input = hdefnl(*q++, VAR, p, -2); /* "input" */
output = hdefnl(*q++, VAR, p, -4); /* "output" */
/*
* Pre-defined constants
*/
for (; *q; q =+ 4)
hdefnl(q[0], CONST, nl+q[1], q[2])->value[1] = q[3];
/*
* Built-in procedures and functions
*/
for (q++; *q; q =+ 2)
hdefnl(q[0], FUNC, 0, q[1]);
for (q++; *q; q =+ 2)
hdefnl(q[0], PROC, 0, q[1]);
}
hdefnl(sym, cls, typ, val)
{
register struct nl *p;
if (sym)
hash(sym, 0);
p = defnl(sym, cls, typ, val);
if (sym)
enter(p);
return (p);
}
/*
* Free up the name list segments
* at the end of a statement/proc/func
* All segments are freed down to the one in which
* p points.
*/
nlfree(p)
struct nl *p;
{
nlp = p;
while (nlact->nls_low > nlp || nlact->nls_high < nlp) {
free(nlact->nls_low);
nlact->nls_low = NIL;
nlact->nls_high = NIL;
--nlact;
if (nlact < &ntab[0])
panic("nlfree");
}
}
#endif
char VARIABLE[] "variable";
char *classes[] {
"undefined",
"constant",
"type",
VARIABLE,
"array",
"pointer or file",
"record",
"field",
"procedure",
"function",
VARIABLE,
VARIABLE,
"pointer",
"file",
"set",
"subrange",
"label",
"withptr",
"scalar",
"string",
"program",
"improper",
#ifdef DEBUG
"variant",
#endif
};
char snark[] "SNARK";
#ifdef PI
#ifdef DEBUG
char *ctext[]
{
"BADUSE",
"CONST",
"TYPE",
"VAR",
"ARRAY",
"PTRFILE",
"RECORD",
"FIELD",
"PROC",
"FUNC",
"FVAR",
"REF",
"PTR",
"FILE",
"SET",
"RANGE",
"LABEL",
"WITHPTR",
"SCAL",
"STR",
"PROG",
"IMPROPER",
"VARNT"
};
char *stars "\t***";
/*
* Dump the namelist from the
* current nlp down to 'to'.
* All the namelist is dumped if
* to is NIL.
*/
dumpnl(to, rout)
struct nl *to;
{
register struct nl *p;
register int j;
struct nls *nlsp;
int i, v, head;
if (opt('y') == 0)
return;
if (to != NIL)
printf("\n\"%s\" Block=%d\n", rout, cbn);
nlsp = nlact;
head = NIL;
for (p = nlp; p != to;) {
if (p == nlsp->nls_low) {
if (nlsp == &ntab[0])
break;
nlsp--;
p = nlsp->nls_high;
}
p--;
if (head == NIL) {
printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n");
head++;
}
printf("%3d:", nloff(p));
if (p->symbol)
printf("\t%.7s", p->symbol);
else
printf(stars);
if (p->class)
printf("\t%s", ctext[p->class]);
else
printf(stars);
if (p->nl_flags) {
putchar('\t');
if (p->nl_flags & 037)
printf("%d ", p->nl_flags & 037);
if (p->nl_flags & NMOD)
putchar('M');
if (p->nl_flags & NUSED)
putchar('U');
if (p->nl_flags & NFILES)
putchar('F');
} else
printf(stars);
if (p->type)
printf("\t[%d]", nloff(p->type));
else
printf(stars);
v = p->value[0];
switch (p->class) {
case TYPE:
break;
case VARNT:
goto con;
case CONST:
switch (nloff(p->type)) {
default:
printf("\t%d", v);
break;
case TDOUBLE:
printf("\t%f", p->real);
break;
case TINT:
con:
printf("\t%ld", p->range[0]);
break;
case TSTR:
printf("\t'%s'", v);
break;
}
break;
case VAR:
case REF:
case WITHPTR:
printf("\t%d,%d", cbn, v);
break;
case SCAL:
case RANGE:
printf("\t%ld..%ld", p->range[0], p->range[1]);
break;
case RECORD:
printf("\t%d(%d)", v, p->value[NL_FLDSZ]);
break;
case FIELD:
printf("\t%d", v);
break;
case STR:
printf("\t\"%s\"", p->value[1]);
goto casedef;
case FVAR:
case FUNC:
case PROC:
case PROG:
if (cbn == 0) {
printf("\t<%o>", p->value[0] & 0377);
if (p->value[0] & NSTAND)
printf("\tNSTAND");
break;
}
v = p->value[1];
default:
casedef:
if (v)
printf("\t<%d>", v);
else
printf(stars);
}
if (p->chain)
printf("\t[%d]", nloff(p->chain));
switch (p->class) {
case RECORD:
if (p->value[NL_VARNT])
printf("\tVARNT=[%d]", nloff(p->value[NL_VARNT]));
if (p->value[NL_TAG])
printf(" TAG=[%d]", nloff(p->value[NL_TAG]));
break;
case VARNT:
printf("\tVTOREC=[%d]", nloff(p->value[NL_VTOREC]));
break;
}
putchar('\n');
}
if (head == 0)
printf("\tNo entries\n");
}
#endif
/*
* Define a new name list entry
* with initial symbol, class, type
* and value[0] as given. A new name
* list segment is allocated to hold
* the next name list slot if necessary.
*/
defnl(sym, cls, typ, val)
char *sym;
int cls;
struct nl *typ;
int val;
{
register struct nl *p;
register int *q, i;
char *cp;
p = nlp;
/*
* Zero out this entry
*/
q = p;
i = (sizeof *p)/2;
do
*q++ = 0;
while (--i);
/*
* Insert the values
*/
p->symbol = sym;
p->class = cls;
p->type = typ;
p->nl_block = cbn;
p->value[0] = val;
/*
* Insure that the next namelist
* entry actually exists. This is
* really not needed here, it would
* suffice to do it at entry if we
* need the slot. It is done this
* way because, historically, nlp
* always pointed at the next namelist
* slot.
*/
nlp++;
if (nlp >= nlact->nls_high) {
i = NLINC;
cp = alloc(NLINC * sizeof *nlp);
if (cp == -1) {
i = NLINC / 2;
cp = alloc((NLINC / 2) * sizeof *nlp);
}
if (cp == -1) {
error("Ran out of memory (defnl)");
pexit(DIED);
}
nlact++;
if (nlact >= &ntab[MAXNL]) {
error("Ran out of name list tables");
pexit(DIED);
}
nlp = cp;
nlact->nls_low = nlp;
nlact->nls_high = nlact->nls_low + i;
}
return (p);
}
/*
* Make a duplicate of the argument
* namelist entry for, e.g., type
* declarations of the form 'type a = b'
* and array indicies.
*/
nlcopy(p)
struct nl *p;
{
register int *p1, *p2, i;
p1 = p;
p = p2 = defnl(0, 0, 0, 0);
i = (sizeof *p)/2;
do
*p2++ = *p1++;
while (--i);
return (p);
}
/*
* Compute a namelist offset
*/
nloff(p)
struct nl *p;
{
return (p - nl);
}
/*
* Enter a symbol into the block
* symbol table. Symbols are hashed
* 64 ways based on low 6 bits of the
* character pointer into the string
* table.
*/
enter(np)
struct nl *np;
{
register struct nl *rp, *hp;
register struct nl *p;
int i;
rp = np;
if (rp == NIL)
return (NIL);
if (cbn > 0)
if (rp->symbol == input->symbol || rp->symbol == output->symbol)
error("Pre-defined files input and output must not be redefined");
i = rp->symbol;
i =& 077;
hp = disptab[i];
if (rp->class != BADUSE && rp->class != FIELD)
for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)
if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) {
error("%s is already defined in this block", rp->symbol);
break;
}
rp->nl_next = hp;
disptab[i] = rp;
return (rp);
}
#endif