2BSD/src/pi0/fdec.c
/* Copyright (c) 1979 Regents of the University of California */
#
/*
* pi - Pascal interpreter code translator
*
* Charles Haley, Bill Joy UCB
* Version 1.2 January 1979
*/
#include "0.h"
#include "tree.h"
/*
* Funchdr inserts
* declaration of a the
* prog/proc/func into the
* namelist. It also handles
* the arguments and puts out
* a transfer which defines
* the entry point of a procedure.
*/
funchdr(r)
int *r;
{
register struct nl *p;
register *il, **rl;
int *rll, o;
struct nl *cp, *dp, *sp;
int *pp;
send(REVFHDR, r);
if (inpflist(r[2])) {
opush('l');
yyretrieve(); /* kludge */
}
line = r[1];
if (r[3] == NIL && (p=lookup1(r[2])) != NIL && bn == cbn) {
/*
* Symbol already defined
* in this block. it is either
* a redeclared symbol (error)
* or a forward declaration.
*/
if ((p->class == FUNC || p->class == PROC) && (p->nl_flags & NFORWD) != 0) {
/*
* Grammar doesnt forbid
* types on a resolution
* of a forward function
* declaration.
*/
if (p->class == FUNC && r[4])
error("Function type should be given only in forward declaration");
return (p);
}
}
/*
* Declare the prog/proc/func
*/
switch (r[0]) {
case T_PROG:
program = p = defnl(r[2], PROG, 0, 0);
break;
case T_PDEC:
if (r[4] != NIL)
error("Procedures do not have types, only functions do");
p = enter(defnl(r[2], PROC, 0, 0));
break;
case T_FDEC:
il = r[4];
if (il == NIL)
error("Function type must be specified");
else if (il[0] != T_TYID) {
il = NIL;
error("Function type can be specified only by using a type identifier");
} else
il = gtype(il);
p = enter(defnl(r[2], FUNC, il, NIL));
/*
* An arbitrary restriction
*/
switch (o = classify(p->type)) {
case TFILE:
case TARY:
case TREC:
case TSET:
case TSTR:
warning();
if (opt('s'))
standard();
error("Functions should not return %ss", clnames[o]);
}
break;
default:
panic("funchdr");
}
if (r[0] != T_PROG) {
/*
* Mark this proc/func as
* begin forward declared
*/
p->nl_flags =| NFORWD;
/*
* Enter the parameters
* in the next block for
* the time being
*/
if (++cbn >= DSPLYSZ) {
error("Procedure/function nesting too deep");
pexit(ERRS);
}
/*
* For functions, the function variable
*/
if (p->class == FUNC) {
cp = defnl(r[2], FVAR, p->type, 0);
cp->chain = p;
p->value[NL_FVAR] = cp;
}
/*
* Enter the parameters
*/
cp = sp = p;
for (rl = r[3]; rl != NIL; rl = rl[2]) {
p = NIL;
if (rl[1] == NIL)
continue;
/*
* Parametric procedures
* don't have types
*/
if (rl[1][0] != T_PPROC) {
rll = rl[1][2];
if (rll[0] != T_TYID) {
error("Types for arguments can be specified only by using type identifiers");
p = NIL;
} else
p = gtype(rll);
}
for (il = rl[1][1]; il != NIL; il = il[2]) {
switch (rl[1][0]) {
default:
panic("funchdr2");
case T_PVAL:
if (p != NIL) {
if (p->class == FILE)
error("Files cannot be passed by value");
else if (p->nl_flags & NFILES)
error("Files cannot be a component of %ss passed by value",
nameof(p));
}
dp = defnl(il[1], VAR, p, 0);
break;
case T_PVAR:
dp = defnl(il[1], REF, p, 0);
break;
case T_PFUNC:
case T_PPROC:
error("Procedure/function parameters not implemented");
continue;
}
if (dp != NIL) {
cp->chain = dp;
cp = dp;
}
}
}
cbn--;
p = sp;
} else {
cp = p;
for (rl = r[3]; rl; rl = rl[2]) {
if (rl[1] == NIL)
continue;
dp = defnl(rl[1], VAR, 0, 0);
cp->chain = dp;
cp = dp;
}
}
return (p);
}
/*
* Funcbody is called
* when the actual (resolved)
* declaration of a procedure is
* encountered. It puts the names
* of the (function) and parameters
* into the symbol table.
*/
funcbody(fp)
struct nl *fp;
{
register struct nl *q, *p;
cbn++;
if (cbn >= DSPLYSZ) {
error("Too many levels of function/procedure nesting");
pexit(ERRS);
}
send(REVFBDY);
errcnt[cbn] = syneflg;
parts = NIL;
if (fp == NIL)
return (NIL);
/*
* Save the virtual name
* list stack pointer so
* the space can be freed
* later (funcend).
*/
fp->value[2] = nlp;
if (fp->class != PROG)
for (q = fp->chain; q != NIL; q = q->chain)
enter(q);
if (fp->class == FUNC) {
/*
* For functions, enter the fvar
*/
enter(fp->value[NL_FVAR]);
}
return (fp);
}
int pnumcnt;
struct nl *Fp;
/*
* Funcend is called to
* finish a block by generating
* the code for the statements.
* It then looks for unresolved declarations
* of labels, procedures and functions,
* and cleans up the name list.
* For the program, it checks the
* semantics of the program
* statement (yuchh).
*/
funcend(fp, bundle, endline)
struct nl *fp;
int *bundle;
int endline;
{
register struct nl *p;
register int i, b;
int *blk;
char *cp;
blk = bundle[2];
if (fp == NIL) {
cbn--;
return;
}
send(REVFEND, bundle, endline, syneflg == errcnt[cbn]);
if (Fp != NIL)
Fp = fp;
/*
* Clean up the symbol table displays and check for unresolves
*/
line = endline;
b = cbn;
for (i = 0; i <= 077; i++) {
for (p = disptab[i]; p != NIL && (p->nl_block & 037) == b; p = p->nl_next)
if (p->class == BADUSE) {
cp = "s";
if (p->chain->ud_next == NIL)
cp++;
eholdnl();
if (p->value[NL_KINDS] & ISUNDEF)
nerror("%s undefined on line%s", p->symbol, cp);
else
nerror("%s improperly used on line%s", p->symbol, cp);
pnumcnt = 10;
pnums(p->chain);
putchar('\n');
}
/*
* Pop this symbol
* table slot
*/
disptab[i] = p;
}
#ifdef DEBUG
dumpnl(fp->value[2], fp->symbol);
#endif
/*
* Restore the
* (virtual) name list
* position
*/
nlfree(fp->value[2]);
/*
* Proc/func has been
* resolved
*/
fp->nl_flags =& ~NFORWD;
elineon();
cbn--;
if (inpflist(fp->symbol)) {
opop('l');
}
}
pnums(p)
struct udinfo *p;
{
if (p->ud_next != NIL)
pnums(p->ud_next);
if (pnumcnt == 0) {
printf("\n\t");
pnumcnt = 20;
}
pnumcnt--;
printf(" %d", p->ud_line);
}
nerror(a1, a2, a3)
{
if (Fp != NIL) {
yySsync();
printf("In %s %s:\n", classes[Fp->class], Fp->symbol);
Fp = NIL;
}
elineoff();
error(a1, a2, a3);
}