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);
}