BSD 2 development

[unix-history] / 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);
}