proc.c File Reference

#include "defs.h"
#include "names.h"
#include "output.h"
#include "p1defs.h"

Include dependency graph for proc.c:

Go to the source code of this file.

Defines
#define	roundup(a, b)   ( b * ( (a+b-1)/b) )
#define	EXNULL   (union Expression *)0
Functions
static void dobss	Argdcl ((void))
static void doentry	Argdcl ((struct Entrypoint *))
static int nextarg	Argdcl ((int))
void	changedtype (Namep q)
void	unamstring (register Addrp q, register char *s)
static void	fix_entry_returns (Void)
static void	putentries (FILE *outfile)
static void	entry_goto (FILE *outfile)
void	newproc (Void)
static void	zap_changes (Void)
void	endproc (Void)
void	enddcl (Void)
void	startproc (Extsym *progname, int Class)
Extsym *	newentry (register Namep v, int substmsg)
void	entrypt (int Class, int type, ftnint length, Extsym *entry, chainp args)
LOCAL void	epicode (Void)
LOCAL void	retval (register int t)
void	procode (FILE *outfile)
static void	bad_dimtype (Namep q)
static void	dim_finish (Namep v)
static void	duparg (Namep q)
LOCAL void	doentry (struct Entrypoint *ep)
LOCAL int	nextarg (int type)
LOCAL void	dim_check (Namep q)
LOCAL void	dobss (Void)
void	donmlist (Void)
ftnint	iarrlen (register Namep q)
void	namelist (Namep np)
LOCAL void	docommon (Void)
void	copy_data (chainp list)
LOCAL void	docomleng (Void)
void	frtemp (Addrp p)
void	freetemps (Void)
Addrp	autovar (register int nelt0, register int t, expptr lengp, char *name)
Addrp	mktmpn (int nelt, register int type, expptr lengp)
Addrp	mktmp (int type, expptr lengp)
Addrp	mktmp0 (int type, expptr lengp)
Extsym *	comblock (register char *s)
void	incomm (Extsym *c, Namep v)
void	settype (register Namep v, register int type, register ftnint length)
int	lengtype (register int type, ftnint len)
void	setintr (register Namep v)
void	setext (register Namep v)
void	setbound (Namep v, int nd, struct Dims *dims)
void	wr_abbrevs (FILE *outfile, int function_head, chainp vars)
Variables
static char	Blank [] = BLANKCOMMON
static char *	postfix []
chainp	new_procs
int	prev_proc
int	proc_argchanges
int	proc_protochanges

---

Define Documentation

#define EXNULL   (union Expression *)0

Definition at line 36 of file proc.c.

Referenced by doentry().

#define roundup	(	a,
		b		)	( b * ( (a+b-1)/b) )

Definition at line 34 of file proc.c.

Referenced by docommon().

---

Function Documentation

static int nextarg Argdcl

(

(int)

)

[static]

static void doentry Argdcl

(

(struct Entrypoint *)

)

[static]

static void dobss Argdcl

(

(void)

)

[static]

Addrp autovar	(	register int	nelt0,
		register int	t,
		expptr	lengp,
		char *	name
	)

Definition at line 1230 of file proc.c.

References ALLOC, autonum, av_pfix, declare_new_addr(), Fatal(), ICON, Addrblock::ident, Addrblock::isarray, ISICON, Addrblock::memoffset, Dimblock::nelt, Addrblock::ntempelt, STGAUTO, TADDR, Addrblock::tag, temp_name(), TYCHAR, typesize, UNAM_IDENT, Addrblock::uname_tag, unamstring(), Addrblock::user, Addrblock::varleng, Addrblock::vleng, Addrblock::vstg, and Addrblock::vtype.

Referenced by doentry(), endioctl(), settype(), and startrw().

{
        ftnint leng;
        register Addrp q;
        register int nelt = nelt0 > 0 ? nelt0 : 1;
        extern char *av_pfix[];

        if(t == TYCHAR)
                if( ISICON(lengp) )
                        leng = lengp->constblock.Const.ci;
                else    {
                        Fatal("automatic variable of nonconstant length");
                }
        else
                leng = typesize[t];

        q = ALLOC(Addrblock);
        q->tag = TADDR;
        q->vtype = t;
        if(t == TYCHAR)
        {
                q->vleng = ICON(leng);
                q->varleng = leng;
        }
        q->vstg = STGAUTO;
        q->ntempelt = nelt;
        q->isarray = (nelt > 1);
        q->memoffset = ICON(0);

        /* kludge for nls so we can have ret_val rather than ret_val_4 */
        if (*name == ' ')
                unamstring(q, name);
        else {
                q->uname_tag = UNAM_IDENT;
                temp_name(av_pfix[t], ++autonum[t], q->user.ident);
                }
        if (nelt0 > 0)
                declare_new_addr (q);
        return(q);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void bad_dimtype

(

Namep

q

)

[static]

Definition at line 666 of file proc.c.

References errstr(), and Nameblock::fvarname.

Referenced by dim_check(), and dim_finish().

{
        errstr("bad dimension type for %.70s", q->fvarname);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

void changedtype

(

Namep

q

)

Definition at line 62 of file proc.c.

References Extsym::arginfo, buf, Argtypes::changes, Argtypes::defined, extsymtab, Extsym::extype, Extsym::exused, ftn_types, Nameblock::fvarname, TYSUBR, TYUNKNOWN, Nameblock::vardesc, Nameblock::varno, Nameblock::vtype, Nameblock::vtypewarned, and warn().

Referenced by doentry(), fixexttype(), and settype().

{
        char buf[200];
        int qtype, type1;
        register Extsym *e;
        Argtypes *at;

        if (q->vtypewarned)
                return;
        q->vtypewarned = 1;
        qtype = q->vtype;
        e = &extsymtab[q->vardesc.varno];
        if (!(at = e->arginfo)) {
                if (!e->exused)
                        return;
                }
        else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
                proc_protochanges++;
        type1 = e->extype;
        if (type1 == TYUNKNOWN)
                return;
        if (qtype == TYUNKNOWN)
                /* e.g.,
                        subroutine foo
                        end
                        external foo
                        call goo(foo)
                        end
                */
                return;
        sprintf(buf, "%.90s: inconsistent declarations:\n\
        here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
                qtype == TYSUBR ? "" : " function",
                ftn_types[type1], type1 == TYSUBR ? "" : " function");
        warn(buf);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

Extsym* comblock

(

register char *

s

)

Definition at line 1380 of file proc.c.

References errstr(), i, mkext1(), p, STGCOMMON, and STGUNKNOWN.

Referenced by yyparse().

{
        Extsym *p;
        register char *t;
        register int c, i;
        char cbuf[256], *s0;

/* Give the unnamed common block a unique name */

        if(*s == 0)
                p = mkext1(s0 = Blank, Blank);
        else {
                s0 = s;
                t = cbuf;
                for(i = 0; c = *t = *s++; t++)
                        if (c == '_')
                                i = 1;
                if (i)
                        *t++ = '_';
                t[0] = '_';
                t[1] = 0;
                p = mkext1(s0,cbuf);
                }
        if(p->extstg == STGUNKNOWN)
                p->extstg = STGCOMMON;
        else if(p->extstg != STGCOMMON)
        {
                errstr("%.52s cannot be a common block: it is a subprogram.",
                        s0);
                return(0);
        }

        return( p );
}

Here is the call graph for this function:

Here is the caller graph for this function:

void copy_data

(

chainp

list

)

Definition at line 1131 of file proc.c.

References ALLOC, ckalloc(), cpexpr(), cpn(), Chain::datap, dims, Dimblock::dimsize, gmem(), i, int, nd, ndim, and size.

Referenced by endproc().

{
    for (; list; list = list -> nextp) {
        Namep namep = ALLOC (Nameblock);
        int size, nd, i;
        struct Dimblock *dp;

        cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
        namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
                namep->fvarname);
        namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
                ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
                : namep->fvarname;
        if (namep -> vleng)
            namep -> vleng = (expptr) cpexpr (namep -> vleng);
        if (namep -> vdim) {
            nd = namep -> vdim -> ndim;
            size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
            dp = (struct Dimblock *) ckalloc (size);
            cpn(size, (char *)namep->vdim, (char *)dp);
            namep -> vdim = dp;
            dp->nelt = (expptr)cpexpr(dp->nelt);
            for (i = 0; i < nd; i++) {
                dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
            } /* for */
        } /* if */
        list -> datap = (char *) namep;
    } /* for */
} /* copy_data */

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void dim_check

(

Namep

q

)

Definition at line 909 of file proc.c.

References bad_dimtype(), Constant::cd, Constant::ci, Constblock::Const, Expression::constblock, dclerr(), Expression::headblock, ISCONST, ISINT, MSKINT, MSKREAL, Dimblock::nelt, ONEOF, Nameblock::vdim, and Headblock::vtype.

{
        register struct Dimblock *vdim = q->vdim;
        register expptr nelt;

        if(!(nelt = vdim->nelt) || !ISCONST(nelt))
                dclerr("adjustable dimension on non-argument", q);
        else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
                bad_dimtype(q);
        else if (ISINT(nelt->headblock.vtype)
                        ? nelt->constblock.Const.ci <= 0
                        : nelt->constblock.Const.cd[0] <= 0.)
                dclerr("nonpositive dimension", q);
        }

Here is the call graph for this function:

static void dim_finish

(

Namep

v

)

[static]

Definition at line 685 of file proc.c.

References bad_dimtype(), doin_setbound, fixtype(), Expression::headblock, i, make_int_expr(), MSKINT, MSKREAL, nd, ONEOF, p, putx(), v, and Headblock::vtype.

Referenced by doentry().

{
        register struct Dimblock *p;
        register expptr q;
        register int i, nd;

        p = v->vdim;
        v->vdimfinish = 0;
        nd = p->ndim;
        doin_setbound = 1;
        for(i = 0; i < nd; i++)
                if (q = p->dims[i].dimexpr) {
                        q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
                        if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
                                bad_dimtype(v);
                        }
        if (q = p->basexpr)
                p->basexpr = make_int_expr(putx(fixtype(q)));
        doin_setbound = 0;
        }

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void dobss

(

Void

)

Definition at line 926 of file proc.c.

References CLUNKNOWN, CLVAR, Nameblock::fvarname, lasthash, p, STGARG, STGUNKNOWN, Nameblock::vclass, Nameblock::vimpldovar, Nameblock::vis_assigned, Nameblock::vstg, Nameblock::vtype, and warn1().

Referenced by endproc().

{
        register struct Hashentry *p;
        register Namep q;
        int qstg, qclass, qtype;
        Extsym *e;

        for(p = hashtab ; p<lasthash ; ++p)
                if(q = p->varp)
                {
                        qstg = q->vstg;
                        qtype = q->vtype;
                        qclass = q->vclass;

                        if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
                            (qclass==CLVAR && qstg==STGUNKNOWN) ) {
                                if (!(q->vis_assigned | q->vimpldovar))
                                        warn1("local variable %s never used",
                                                q->fvarname);
                                }
                        else if(qclass==CLVAR && qstg==STGBSS)
                        { ; }

/* Give external procedures the proper storage class */

                        else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
                                        && qstg!=STGARG) {
                                e = mkext(q->fvarname,addunder(q->cvarname));
                                e->extstg = STGEXT;
                                q->vardesc.varno = e - extsymtab;
                                if (e->extype != qtype)
                                        changedtype(q);
                                }
                        if(qclass==CLVAR) {
                            if (qstg != STGARG && q->vdim)
                                dim_check(q);
                        } /* if qclass == CLVAR */
                }

}

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void docomleng

(

Void

)

Definition at line 1165 of file proc.c.

References extsymtab, nextext, p, STGCOMMON, and warn1().

Referenced by enddcl().

{
        register Extsym *p;

        for(p = extsymtab ; p < nextext ; ++p)
                if(p->extstg == STGCOMMON)
                {
                        if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
                            && strcmp(Blank, p->cextname) )
                                warn1("incompatible lengths for common block %.60s",
                                    p->fextname);
                        if(p->maxleng < p->extleng)
                                p->maxleng = p->extleng;
                        p->extleng = 0;
                }
}

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void docommon

(

Void

)

Definition at line 1041 of file proc.c.

References Constant::ci, Constblock::Const, Expression::constblock, Chain::datap, dclerr(), Extsym::extleng, Extsym::extp, Extsym::extstg, extsymtab, i, ISCONST, nerr, nextext, Chain::nextp, NO, revchain(), roundup, size, STGCOMMON, t, TYCHAR, type_pref, typealign, typesize, vardcl(), Nameblock::vardesc, Nameblock::varno, Nameblock::vdcldone, Nameblock::vdim, Nameblock::vleng, and Nameblock::voffset.

Referenced by enddcl().

{
    register Extsym *extptr;
    register chainp q, q1;
    struct Dimblock *t;
    expptr neltp;
    register Namep comvar;
    ftnint size;
    int i, k, pref, type;
    extern int type_pref[];

    for(extptr = extsymtab ; extptr<nextext ; ++extptr)
        if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {

/* If a common declaration also had a list of variables ... */

            q = extptr->extp = revchain(q);
            pref = 1;
            for(k = TYCHAR; q ; q = q->nextp)
            {
                comvar = (Namep) (q->datap);

                if(comvar->vdcldone == NO)
                    vardcl(comvar);
                type = comvar->vtype;
                if (pref < type_pref[type])
                        pref = type_pref[k = type];
                if(extptr->extleng % typealign[type] != 0) {
                    dclerr("common alignment", comvar);
                    --nerr; /* don't give bad return code for this */
#if 0
                    extptr->extleng = roundup(extptr->extleng, typealign[type]);
#endif
                } /* if extptr -> extleng % */

/* Set the offset into the common block */

                comvar->voffset = extptr->extleng;
                comvar->vardesc.varno = extptr - extsymtab;
                if(type == TYCHAR)
                        if (comvar->vleng)
                                size = comvar->vleng->constblock.Const.ci;
                        else  {
                                dclerr("character*(*) in common", comvar);
                                size = 1;
                                }
                else
                        size = typesize[type];
                if(t = comvar->vdim)
                    if( (neltp = t->nelt) && ISCONST(neltp) )
                        size *= neltp->constblock.Const.ci;
                    else
                        dclerr("adjustable array in common", comvar);

/* Adjust the length of the common block so far */

                extptr->extleng += size;
            } /* for */

            extptr->extype = k;

/* Determine curno and, if new, save this identifier chain */

            q1 = extptr->extp;
            for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
                if (struct_eq((chainp)q->datap, q1))
                        break;
            if (q)
                extptr->curno = extptr->maxno - i;
            else {
                extptr->curno = ++extptr->maxno;
                extptr->allextp = mkchain((char *)extptr->extp,
                                                extptr->allextp);
                }
        } /* if extptr -> extstg == STGCOMMON */

/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
   varno.  And the common block itself has its full size in extleng. */

} /* docommon */

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void doentry

(

struct Entrypoint *

ep

)

Definition at line 726 of file proc.c.

References Expression::addrblock, allargs, Extsym::arginfo, Entrypoint::arglist, autovar(), changedtype(), chlgslot, chslot, Constant::ci, CLBLOCK, CLMAIN, CLPROC, Constblock::Const, Expression::constblock, cxslot, Chain::datap, dclerr(), dflttype, dim_finish(), duparg(), Entrypoint::entryname, err, EXNULL, Extsym::exproto, Extsym::extseen, extsymtab, Extsym::extype, Extsym::fextname, Nameblock::fvarname, ICON, Addrblock::ident, impldcl(), infertypes, int, ISCOMPLEX, ISCONST, it, letter, mkarg(), mkchain(), mkname(), multitype, nallargs, nallchargs, nentry, new_arg_length(), new_func_length(), newlabel(), nextarg(), Chain::nextp, NULL, p, p1_label(), procclass, procleng, proctype, retslot, rtvlabel, save_argtypes(), STGARG, STGAUTO, STGEXT, TYADDR, TYCHAR, TYLENG, Entrypoint::typelabel, TYSUBR, TYUNKNOWN, UNAM_IDENT, Addrblock::uname_tag, unamstring(), Addrblock::user, Nameblock::vardesc, Nameblock::varno, Nameblock::vclass, Nameblock::vdcldone, Nameblock::vknownarg, Nameblock::vleng, Nameblock::vstg, Nameblock::vtype, xretslot, and YES.

Referenced by enddcl(), and entrypt().

{
        register int type;
        register Namep np;
        chainp p, p1;
        register Namep q;
        Addrp rs;
        int it, k;
        extern char dflttype[26];
        Extsym *entryname = ep->entryname;

        if (++nentry > 1)
                p1_label((long)(extsymtab - entryname - 1));

/* The main program isn't allowed to have parameters, so any given
   parameters are ignored */

        if(procclass == CLMAIN && !ep->arglist || procclass == CLBLOCK)
                return;

        /* Entry points in MAIN are an error, but we process them here */
        /* to prevent faults elsewhere. */

/* So now we're working with something other than CLMAIN or CLBLOCK.
   Determine the type of its return value. */

        impldcl( np = mkname(entryname->fextname) );
        type = np->vtype;
        proc_argchanges = prev_proc && type != entryname->extype;
        entryname->extseen = 1;
        if(proctype == TYUNKNOWN)
                if( (proctype = type) == TYCHAR)
                        procleng = np->vleng ? np->vleng->constblock.Const.ci
                                             : (ftnint) (-1);

        if(proctype == TYCHAR)
        {
                if(type != TYCHAR)
                        err("noncharacter entry of character function");

/* Functions returning type   char   can only have multiple entries if all
   entries return the same length */

                else if( (np->vleng ? np->vleng->constblock.Const.ci :
                    (ftnint) (-1)) != procleng)
                        err("mismatched character entry lengths");
        }
        else if(type == TYCHAR)
                err("character entry of noncharacter function");
        else if(type != proctype)
                multitype = YES;
        if(rtvlabel[type] == 0)
                rtvlabel[type] = (int)newlabel();
        ep->typelabel = rtvlabel[type];

        if(type == TYCHAR)
        {
                if(chslot < 0)
                {
                        chslot = nextarg(TYADDR);
                        chlgslot = nextarg(TYLENG);
                }
                np->vstg = STGARG;

/* Put a new argument in the function, one which will hold the result of
   a character function.  This will have to be named sometime, probably in
   mkarg(). */

                if(procleng < 0) {
                        np->vleng = (expptr) mkarg(TYLENG, chlgslot);
                        np->vleng->addrblock.uname_tag = UNAM_IDENT;
                        strcpy (np -> vleng -> addrblock.user.ident,
                                new_func_length());
                        }
                if (!xretslot[TYCHAR]) {
                        xretslot[TYCHAR] = rs =
                                autovar(0, type, ISCONST(np->vleng)
                                        ? np->vleng : ICON(0), "");
                        strcpy(rs->user.ident, "ret_val");
                        }
        }

/* Handle a   complex   return type -- declare a new parameter (pointer to
   a complex value) */

        else if( ISCOMPLEX(type) ) {
                if (!xretslot[type])
                        xretslot[type] =
                                autovar(0, type, EXNULL, " ret_val");
                                /* the blank is for use in out_addr */
                np->vstg = STGARG;
                if(cxslot < 0)
                        cxslot = nextarg(TYADDR);
                }
        else if (type != TYSUBR) {
                if (type == TYUNKNOWN) {
                        dclerr("untyped function", np);
                        proctype = type = np->vtype =
                                dflttype[letter(np->fvarname[0])];
                        }
                if (!xretslot[type])
                        xretslot[type] = retslot =
                                autovar(1, type, EXNULL, " ret_val");
                                /* the blank is for use in out_addr */
                np->vstg = STGAUTO;
                }

        for(p = ep->arglist ; p ; p = p->nextp)
                if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
                        q->vknownarg = 1;
                        q->vardesc.varno = nextarg(TYADDR);
                        allargs = mkchain((char *)q, allargs);
                        q->argno = nallargs++;
                        }
                else if (nentry == 1)
                        duparg(q);
                else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
                        if ((Namep)p1->datap == q)
                                duparg(q);

        k = 0;
        for(p = ep->arglist ; p ; p = p->nextp) {
                if(! (( q = (Namep) (p->datap) )->vdcldone) )
                        {
                        impldcl(q);
                        q->vdcldone = YES;
                        if(q->vtype == TYCHAR)
                                {

/* If we don't know the length of a char*(*) (i.e. a string), we must add
   in this additional length argument. */

                                ++nallchargs;
                                if (q->vclass == CLPROC)
                                        nallchargs--;
                                else if (q->vleng == NULL) {
                                        /* character*(*) */
                                        q->vleng = (expptr)
                                            mkarg(TYLENG, nextarg(TYLENG) );
                                        unamstring((Addrp)q->vleng,
                                                new_arg_length(q));
                                        }
                                }
                        }
                if (q->vdimfinish)
                        dim_finish(q);
                if (q->vtype == TYCHAR && q->vclass != CLPROC)
                        k++;
                }

        if (entryname->extype != type)
                changedtype(np);

        /* save information for checking consistency of arg lists */

        it = infertypes;
        if (entryname->exproto)
                infertypes = 1;
        save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
                        0, np->fvarname, STGEXT, k, np->vtype, 2);
        infertypes = it;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void donmlist

(

Void

)

Definition at line 969 of file proc.c.

References CLNAMELIST, lasthash, namelist(), p, and Nameblock::vclass.

Referenced by endproc().

{
        register struct Hashentry *p;
        register Namep q;

        for(p=hashtab; p<lasthash; ++p)
                if( (q = p->varp) && q->vclass==CLNAMELIST)
                        namelist(q);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void duparg

(

Namep

q

)

[static]

Definition at line 712 of file proc.c.

References errstr(), and Nameblock::fvarname.

Referenced by doentry().

{ errstr("duplicate argument %.80s", q->fvarname); }

Here is the call graph for this function:

Here is the caller graph for this function:

void enddcl

(

Void

)

Definition at line 380 of file proc.c.

References Chain::datap, docomleng(), docommon(), doentry(), doequiv(), earlylabs, entries, err_proc, frchain(), freetemps(), INEXEC, lineno, Chain::nextp, p1_label(), p1_line_number(), P1_PROCODE, p1put(), parstate, and revchain().

Referenced by endproc(), exequals(), and yyparse().

{
        register struct Entrypoint *ep;
        struct Entrypoint *ep0;
        chainp cp;
        extern char *err_proc;
        static char comblks[] = "common blocks";

        err_proc = comblks;
        docommon();

/* Now the hash table entries for fields of common blocks have STGCOMMON,
   vdcldone, voffset, and varno.  And the common blocks themselves have
   their full sizes in extleng. */

        err_proc = "equivalences";
        doequiv();

        err_proc = comblks;
        docomleng();

/* This implies that entry points in the declarations are buffered in
   entries   but not written out */

        err_proc = "entries";
        if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
                /* entries could be 0 in case of an error */
                do doentry(ep);
                        while(ep = ep->entnextp);
                entries = (struct Entrypoint *)revchain((chainp)ep0);
                }

        err_proc = 0;
        parstate = INEXEC;
        p1put(P1_PROCODE);
        freetemps();
        if (earlylabs) {
                for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
                        p1_label((long)cp->datap);
                frchain(&earlylabs);
                }
        p1_line_number(lineno); /* for files that start with a MAIN program */
                                /* that starts with an executable statement */
}

Here is the call graph for this function:

Here is the caller graph for this function:

void endproc

(

Void

)

Definition at line 330 of file proc.c.

References c_file, CHNULL, convic(), copy_data(), ctls, ctlstack, dobss(), donmlist(), enddcl(), epicode(), err, errstr(), extsymtab, fix_entry_returns(), INDATA, labeltab, labtabend, lp, nentry, nextext, NO, parstate, procinit(), putentries(), start_formatting(), STGCOMMON, usedefsforcommon, wr_abbrevs(), and zap_changes().

Referenced by main(), newproc(), startproc(), and yyparse().

{
        struct Labelblock *lp;
        Extsym *ext;

        if(parstate < INDATA)
                enddcl();
        if(ctlstack >= ctls)
                err("DO loop or BLOCK IF not closed");
        for(lp = labeltab ; lp < labtabend ; ++lp)
                if(lp->stateno!=0 && lp->labdefined==NO)
                        errstr("missing statement label %s",
                                convic(lp->stateno) );

/* Save copies of the common variables in extptr -> allextp */

        for (ext = extsymtab; ext < nextext; ext++)
                if (ext -> extstg == STGCOMMON && ext -> extp) {
                        extern int usedefsforcommon;

/* Write out the abbreviations for common block reference */

                        copy_data (ext -> extp);
                        if (usedefsforcommon) {
                                wr_abbrevs (c_file, 1, ext -> extp);
                                ext -> used_here = 1;
                                }
                        else
                                ext -> extp = CHNULL;

                        }

        if (nentry > 1)
                fix_entry_returns();
        epicode();
        donmlist();
        dobss();
        start_formatting ();
        if (nentry > 1)
                putentries(c_file);

        zap_changes();
        procinit();     /* clean up for next procedure */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void entry_goto

(

FILE *

outfile

)

[static]

Definition at line 279 of file proc.c.

References Entrypoint::entnextp, entries, Entrypoint::entryname, extsymtab, next_tab, nice_printf(), prev_tab, and user_label().

Referenced by procode().

{
        struct Entrypoint *e = entries;
        int k = 0;

        nice_printf(outfile, "switch(n__) {\n");
        next_tab(outfile);
        while(e = e->entnextp)
                nice_printf(outfile, "case %d: goto %s;\n", ++k,
                        user_label((long)(extsymtab - e->entryname - 1)));
        nice_printf(outfile, "}\n\n");
        prev_tab(outfile);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

void entrypt	(	int	Class,
		int	type,
		ftnint	length,
		Extsym *	entry,
		chainp	args
	)

Definition at line 523 of file proc.c.

References ALLOC, args, Extsym::cextname, CLENTRY, CLPROC, diagfile, doentry(), entries, Extsym::fextname, INDATA, lengtype(), mkname(), p, parstate, procclass, procleng, procname, proctype, PTHISPROC, puthead(), revchain(), settype(), STGEXT, TYCHAR, TYSUBR, Nameblock::vclass, Nameblock::vprocclass, and Nameblock::vstg.

Referenced by startproc(), and yyparse().

{
        register Namep q;
        register struct Entrypoint *p;

        if(Class != CLENTRY)
                puthead( procname = entry->cextname, Class);
        else
                fprintf(diagfile, "       entry ");
        fprintf(diagfile, "   %s:\n", entry->fextname);
        fflush(diagfile);
        q = mkname(entry->fextname);
        if (type == TYSUBR)
                q->vstg = STGEXT;

        type = lengtype(type, length);
        if(Class == CLPROC)
        {
                procclass = CLPROC;
                proctype = type;
                procleng = type == TYCHAR ? length : 0;
        }

        p = ALLOC(Entrypoint);

        p->entnextp = entries;
        entries = p;

        p->entryname = entry;
        p->arglist = revchain(args);
        p->enamep = q;

        if(Class == CLENTRY)
        {
                Class = CLPROC;
                if(proctype == TYSUBR)
                        type = TYSUBR;
        }

        q->vclass = Class;
        q->vprocclass = 0;
        settype(q, type, length);
        q->vprocclass = PTHISPROC;
        /* hold all initial entry points till end of declarations */
        if(parstate >= INDATA)
                doentry(p);
}

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void epicode

(

Void

)

Definition at line 579 of file proc.c.

References Ansi, CLMAIN, CLPROC, ICON, lastwasbranch, multitype, NO, p1_subr_ret(), procclass, proctype, retval(), substars, TYSUBR, and YES.

Referenced by endproc().

{
        extern int lastwasbranch;

        if(procclass==CLPROC)
        {
                if(proctype==TYSUBR)
                {

/* Return a zero only when the alternate return mechanism has been
   specified in the function header */

                        if ((substars || Ansi) && lastwasbranch != YES)
                            p1_subr_ret (ICON(0));
                }
                else if (!multitype && lastwasbranch != YES)
                        retval(proctype);
        }
        else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
                p1_subr_ret (ICON(0));
        lastwasbranch = NO;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void fix_entry_returns

(

Void

)

[static]

Definition at line 125 of file proc.c.

References a, allargs, Entrypoint::enamep, entries, i, multitype, revchain(), STGARG, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLOGICAL, TYLOGICAL1, TYLOGICAL2, TYLONG, TYQUAD, TYREAL, TYSHORT, Nameblock::vstg, Nameblock::vtype, and xretslot.

Referenced by endproc().

{
        Addrp a;
        int i;
        struct Entrypoint *e;
        Namep np;

        e = entries = (struct Entrypoint *)revchain((chainp)entries);
        allargs = revchain(allargs);
        if (!multitype)
                return;

        /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */

        for(i = TYINT1; i <= TYLOGICAL; i++)
                if (a = xretslot[i])
                        sprintf(a->user.ident, "(*ret_val).%s",
                                postfix[i-TYINT1]);

        do {
                np = e->enamep;
                switch(np->vtype) {
                        case TYINT1:
                        case TYSHORT:
                        case TYLONG:
#ifdef TYQUAD
                        case TYQUAD:
#endif
                        case TYREAL:
                        case TYDREAL:
                        case TYCOMPLEX:
                        case TYDCOMPLEX:
                        case TYLOGICAL1:
                        case TYLOGICAL2:
                        case TYLOGICAL:
                                np->vstg = STGARG;
                        }
                }
                while(e = e->entnextp);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

void freetemps

(

Void

)

Definition at line 1198 of file proc.c.

References frexpr(), holdtemps, ICON, p, templist, TYCHAR, Addrblock::varleng, Addrblock::vleng, and Addrblock::vtype.

Referenced by enddcl(), and yyparse().

{
        register chainp p, p1;
        register Addrp q;
        register int t;

        p1 = holdtemps;
        while(p = p1) {
                q = (Addrp)p->datap;
                t = q->vtype;
                if (t == TYCHAR && q->varleng != 0) {
                        /* restore clobbered character string lengths */
                        frexpr(q->vleng);
                        q->vleng = ICON(q->varleng);
                        }
                p1 = p->nextp;
                p->nextp = templist[t];
                templist[t] = p;
                }
        holdtemps = 0;
        }

Here is the call graph for this function:

Here is the caller graph for this function:

void frtemp

(

Addrp

p

)

Definition at line 1190 of file proc.c.

References holdtemps, mkchain(), and p.

Referenced by enddo(), mktmp(), and putcat().

{
        /* put block on chain of temps to be reclaimed */
        holdtemps = mkchain((char *)p, holdtemps);
}

Here is the call graph for this function:

Here is the caller graph for this function:

ftnint iarrlen

(

register Namep

q

)

Definition at line 987 of file proc.c.

References ISICON, and typesize.

{
        ftnint leng;

        leng = typesize[q->vtype];
        if(leng <= 0)
                return(-1);
        if(q->vdim)
                if( ISICON(q->vdim->nelt) )
                        leng *= q->vdim->nelt->constblock.Const.ci;
                else    return(-1);
        if(q->vleng)
                if( ISICON(q->vleng) )
                        leng *= q->vleng->constblock.Const.ci;
                else return(-1);
        return(leng);
}

void incomm	(	Extsym *	c,
		Namep	v
	)

Definition at line 1425 of file proc.c.

References dclerr(), Extsym::extp, mkchain(), STGARG, STGCOMMON, STGUNKNOWN, and v.

Referenced by yyparse().

{
        if (!c)
                return;
        if(v->vstg != STGUNKNOWN && !v->vimplstg)
                dclerr(v->vstg == STGARG
                        ? "dummy arguments cannot be in common"
                        : "incompatible common declaration", v);
        else
        {
                v->vstg = STGCOMMON;
                c->extp = mkchain((char *)v, c->extp);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

int lengtype	(	register int	type,
		ftnint	len
	)

Definition at line 1537 of file proc.c.

References badtype(), err, int, TYCHAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYERROR, tyint, TYINT1, tylog, TYLOGICAL, TYLOGICAL1, TYLOGICAL2, TYLONG, typesize, TYQUAD, TYREAL, TYSHORT, TYSUBR, TYUNKNOWN, and use_tyquad.

Referenced by entrypt(), setimpl(), and settype().

{
        register int length = (int)len;
        switch(type)
        {
        case TYREAL:
                if(length == typesize[TYDREAL])
                        return(TYDREAL);
                if(length == typesize[TYREAL])
                        goto ret;
                break;

        case TYCOMPLEX:
                if(length == typesize[TYDCOMPLEX])
                        return(TYDCOMPLEX);
                if(length == typesize[TYCOMPLEX])
                        goto ret;
                break;

        case TYINT1:
        case TYSHORT:
        case TYDREAL:
        case TYDCOMPLEX:
        case TYCHAR:
        case TYLOGICAL1:
        case TYLOGICAL2:
        case TYUNKNOWN:
        case TYSUBR:
        case TYERROR:
#ifdef TYQUAD
        case TYQUAD:
#endif
                goto ret;

        case TYLOGICAL:
                switch(length) {
                        case 0: return tylog;
                        case 1: return TYLOGICAL1;
                        case 2: return TYLOGICAL2;
                        case 4: goto ret;
                        }
                break;

        case TYLONG:
                if(length == 0)
                        return(tyint);
                if (length == 1)
                        return TYINT1;
                if(length == typesize[TYSHORT])
                        return(TYSHORT);
#ifdef TYQUAD
                if(length == typesize[TYQUAD] && use_tyquad)
                        return(TYQUAD);
#endif
                if(length == typesize[TYLONG])
                        goto ret;
                break;
        default:
                badtype("lengtype", type);
        }

        if(len != 0)
                err("incompatible type-length combination");

ret:
        return(type);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Addrp mktmp	(	int	type,
		expptr	lengp
	)

Definition at line 1341 of file proc.c.

References cpexpr(), frtemp(), and mktmpn().

Referenced by cast_args(), doiolist(), endioctl(), exarif(), exdo(), Inline(), intdouble(), krput(), putch1(), putcx1(), putmnmx(), putop(), putpower(), stfcall(), subcheck(), and suboffset().

{
        Addrp rv;
        /* arrange for temporaries to be recycled */
        /* at the end of this statement... */
        rv = mktmpn(1,type,lengp);
        frtemp((Addrp)cpexpr((expptr)rv));
        return rv;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Addrp mktmp0	(	int	type,
		expptr	lengp
	)

Definition at line 1359 of file proc.c.

References Addrblock::istemp, mktmpn(), and YES.

Referenced by exdo().

{
        Addrp rv;
        /* arrange for temporaries to be recycled */
        /* when this Addrp is freed */
        rv = mktmpn(1,type,lengp);
        rv->istemp = YES;
        return rv;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Addrp mktmpn	(	int	nelt,
		register int	type,
		expptr	lengp
	)

Definition at line 1283 of file proc.c.

References badtype(), CHNULL, Constant::ci, Constblock::Const, Expression::constblock, err, erri(), errnode, free(), ISICON, krparens, M, Chain::nextp, Addrblock::ntempelt, ONEOF, p, templist, TYADDR, TYCHAR, TYCOMPLEX, TYERROR, TYREAL, TYUNKNOWN, and Addrblock::vleng.

Referenced by mktmp(), mktmp0(), and putcat().

{
        ftnint leng;
        chainp p, oldp;
        register Addrp q;
        extern int krparens;

        if(type==TYUNKNOWN || type==TYERROR)
                badtype("mktmpn", type);

        if(type==TYCHAR)
                if(lengp && ISICON(lengp) )
                        leng = lengp->constblock.Const.ci;
                else    {
                        err("adjustable length");
                        return( (Addrp) errnode() );
                }
        else if (type > TYCHAR || type < TYADDR) {
                erri("mktmpn: unexpected type %d", type);
                exit(1);
                }
/*
 * if a temporary of appropriate shape is on the templist,
 * remove it from the list and return it
 */
        if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
                type++;
        for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
        {
                q = (Addrp) (p->datap);
                if(q->ntempelt==nelt &&
                    (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
                {
                        if(oldp)
                                oldp->nextp = p->nextp;
                        else
                                templist[type] = p->nextp;
                        free( (charptr) p);
                        return(q);
                }
        }
        q = autovar(nelt, type, lengp, "");
        return(q);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void namelist

(

Namep

np

)

Definition at line 1011 of file proc.c.

References Chain::datap, dclerr(), MSKSTATIC, Nameblock::namelist, Chain::nextp, ONEOF, v, vardcl(), Nameblock::varxptr, Nameblock::visused, and y.

Referenced by donmlist().

{
        register chainp q;
        register Namep v;
        int y;

        if (!np->visused)
                return;
        y = 0;

        for(q = np->varxptr.namelist ; q ; q = q->nextp)
        {
                vardcl( v = (Namep) (q->datap) );
                if( !ONEOF(v->vstg, MSKSTATIC) )
                        dclerr("may not appear in namelist", v);
                else {
                        v->vnamelist = 1;
                        v->visused = 1;
                        v->vsave = 1;
                        y = 1;
                        }
        np->visused = y;
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Extsym* newentry	(	register Namep	v,
		int	substmsg
	)

Definition at line 480 of file proc.c.

References addunder(), buf, CLPROC, dclerr(), extsymtab, M, mkext(), ONEOF, p, PTHISPROC, STGAUTO, STGEXT, STGUNKNOWN, and YES.

Referenced by startproc(), and yyparse().

{
        register Extsym *p;
        char buf[128], badname[64];
        static int nbad = 0;
        static char already[] = "external name already used";

        p = mkext(v->fvarname, addunder(v->cvarname));

        if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
        {
                sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
                if (substmsg) {
                        sprintf(buf,"%s\n\tsubstituting \"%s\"",
                                already, badname);
                        dclerr(buf, v);
                        }
                else
                        dclerr(already, v);
                p = mkext(v->fvarname, badname);
        }
        v->vstg = STGAUTO;
        v->vprocclass = PTHISPROC;
        v->vclass = CLPROC;
        if (p->extstg == STGEXT)
                prev_proc = 1;
        else
                p->extstg = STGEXT;
        p->extinit = YES;
        v->vardesc.varno = p - extsymtab;
        return(p);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void newproc

(

Void

)

Definition at line 297 of file proc.c.

References CLMAIN, CNULL, endproc(), execerr(), INSIDE, OUTSIDE, parstate, and procclass.

Referenced by startproc(), and yyparse().

{
        if(parstate != OUTSIDE)
        {
                execerr("missing end statement", CNULL);
                endproc();
        }

        parstate = INSIDE;
        procclass = CLMAIN;     /* default */
}

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL int nextarg

(

int

type

)

Definition at line 897 of file proc.c.

References lastargslot.

Referenced by doentry().

{
        type = type;    /* shut up warning */
        return(lastargslot++);
        }

Here is the caller graph for this function:

void procode

(

FILE *

outfile

)

Definition at line 653 of file proc.c.

References allargs, entry_goto(), nentry, and prolog().

Referenced by do_format().

{
        prolog(outfile, allargs);

        if (nentry > 1)
                entry_goto(outfile);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

static void putentries

(

FILE *

outfile

)

[static]

Definition at line 171 of file proc.c.

References a, A, allargs, Ansi, Entrypoint::arglist, Nameblock::argno, args, base, c_type_decl(), Castargs, ckalloc(), CLPROC, Nameblock::cvarname, dfltarg, dfltproc, Entrypoint::enamep, Entrypoint::entnextp, entries, forcedouble, frchain(), free(), i, Addrblock::ident, ISCOMPLEX, length_comp(), list_arg_types(), listargs(), MAXNAMELEN, memset(), mt, multitype, nallargs, nallchargs, new_arg_length(), next_tab, Chain::nextp, nice_printf(), prev_tab, proctype, protofile, protowrite(), t, TYCHAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, TYLOGICAL, type, TYREAL, TYSUBR, TYUNKNOWN, Nameblock::vclass, Nameblock::vtype, and xretslot.

Referenced by endproc().

{
        char base[MAXNAMELEN+4];
        struct Entrypoint *e;
        Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
        chainp args, lengths;
        int i, k, mt, nL, t, type;
        extern char *dfltarg[], **dfltproc;

        e = entries;
        if (!e->enamep) /* only possible with erroneous input */
                return;
        nL = (nallargs + nallchargs) * sizeof(Namep *);
        if (!nL)
                nL = 8;
        A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
        Ae = A + nallargs;
        Alp = (Namep **)(Ae1 = Ae + nallchargs);
        i = k = 0;
        for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
                np = (Namep)args->datap;
                if (np->vtype == TYCHAR && np->vclass != CLPROC)
                        *a1 = &Ae[i++];
                }

        mt = multitype;
        multitype = 0;
        sprintf(base, "%s0_", e->enamep->cvarname);
        do {
                np = e->enamep;
                lengths = length_comp(e, 0);
                proctype = type = np->vtype;
                if (protofile)
                        protowrite(protofile, type, np->cvarname, e, lengths);
                nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
                nice_printf(outfile, "%s", np->cvarname);
                if (!Ansi) {
                        listargs(outfile, e, 0, lengths);
                        nice_printf(outfile, "\n");
                        }
                list_arg_types(outfile, e, lengths, 0, "\n");
                nice_printf(outfile, "{\n");
                frchain(&lengths);
                next_tab(outfile);
                if (mt)
                        nice_printf(outfile,
                                "Multitype ret_val;\n%s(%d, &ret_val",
                                base, k); /*)*/
                else if (ISCOMPLEX(type))
                        nice_printf(outfile, "%s(%d,%s", base, k,
                                xretslot[type]->user.ident); /*)*/
                else if (type == TYCHAR)
                        nice_printf(outfile,
                                "%s(%d, ret_val, ret_val_len", base, k); /*)*/
                else
                        nice_printf(outfile, "return %s(%d", base, k); /*)*/
                k++;
                memset((char *)A, 0, nL);
                for(args = e->arglist; args; args = args->nextp) {
                        np = (Namep)args->datap;
                        A[np->argno] = np;
                        if (np->vtype == TYCHAR && np->vclass != CLPROC)
                                *Alp[np->argno] = np;
                        }
                args = allargs;
                for(a = A; a < Ae; a++, args = args->nextp) {
                        t = ((Namep)args->datap)->vtype;
                        nice_printf(outfile, ", %s", (np = *a)
                                ? np->cvarname
                                : ((Namep)args->datap)->vclass == CLPROC
                                ? dfltproc[((Namep)args->datap)->vimpltype
                                        ? (Castargs ? TYUNKNOWN : TYSUBR)
                                        : t == TYREAL && forcedouble && !Castargs
                                        ? TYDREAL : t]
                                : dfltarg[((Namep)args->datap)->vtype]);
                        }
                for(; a < Ae1; a++)
                        if (np = *a)
                                nice_printf(outfile, ", %s",
                                        new_arg_length(np));
                        else
                                nice_printf(outfile, ", (ftnint)0");
                nice_printf(outfile, /*(*/ ");\n");
                if (mt) {
                        if (type == TYCOMPLEX)
                                nice_printf(outfile,
                    "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
                        else if (type == TYDCOMPLEX)
                                nice_printf(outfile,
                    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
                        else if (type <= TYLOGICAL)
                                nice_printf(outfile, "return ret_val.%s;\n",
                                        postfix[type-TYINT1]);
                        }
                nice_printf(outfile, "}\n");
                prev_tab(outfile);
                }
                while(e = e->entnextp);
        free((char *)A);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

LOCAL void retval

(

register int

t

)

Definition at line 610 of file proc.c.

References badtype(), cpexpr(), fixtype(), mkconv(), p, p1_subr_ret(), retslot, TYADDR, TYCHAR, TYCOMPLEX, TYDCOMPLEX, TYDREAL, TYINT1, tylogical, TYLOGICAL, TYLOGICAL1, TYLOGICAL2, TYLONG, TYQUAD, TYREAL, and TYSHORT.

Referenced by __PARAMS(), C2F(), call_printf(), do_format(), do_p1_subr_ret(), do_xxprintf(), epicode(), fakecresmat2(), getversionmodule(), int_objfscanf(), is_negatable(), isnegative_const(), Load_primitives_from_file(), MlistGetFieldNumber(), op_assign(), sciprint2(), stcreate(), XmuSnprintf(), and yylex().

{
        register Addrp p;

        switch(t)
        {
        case TYCHAR:
        case TYCOMPLEX:
        case TYDCOMPLEX:
                break;

        case TYLOGICAL:
                t = tylogical;
        case TYINT1:
        case TYADDR:
        case TYSHORT:
        case TYLONG:
#ifdef TYQUAD
        case TYQUAD:
#endif
        case TYREAL:
        case TYDREAL:
        case TYLOGICAL1:
        case TYLOGICAL2:
                p = (Addrp) cpexpr((expptr)retslot);
                p->vtype = t;
                p1_subr_ret (mkconv (t, fixtype((expptr)p)));
                break;

        default:
                badtype("retval", t);
        }
}

Here is the call graph for this function:

Here is the caller graph for this function:

void setbound	(	Namep	v,
		int	nd,
		struct Dims *	dims
	)

Definition at line 1683 of file proc.c.

References buf, ckalloc(), CLUNKNOWN, CLVAR, dclerr(), dims, doin_setbound, errext(), Expression::headblock, i, ICON, ISINT, new_vars, noextflag, p, Dims::ub, v, and Headblock::vtype.

Referenced by yyparse().

{
        expptr q, q0, t;
        struct Dimblock *p;
        int i;
        extern chainp new_vars;
        char buf[256];

        if(v->vclass == CLUNKNOWN)
                v->vclass = CLVAR;
        else if(v->vclass != CLVAR)
        {
                dclerr("only variables may be arrays", v);
                return;
        }

        v->vdim = p = (struct Dimblock *)
            ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
        p->ndim = nd--;
        p->nelt = ICON(1);
        doin_setbound = 1;

        if (noextflag)
                for(i = 0; i <= nd; i++)
                        if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
                         || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
                                sprintf(buf, "dimension %d of %s is not an integer.",
                                        i+1, v->fvarname);
                                errext(buf);
                                break;
                                }

        for(i = 0; i <= nd; i++) {
                if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
                        dims[i].lb = mkconv(TYINT, q);
                if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
                        dims[i].ub = mkconv(TYINT, q);
                }

        for(i = 0; i <= nd; ++i)
        {
                if( (q = dims[i].ub) == NULL)
                {
                        if(i == nd)
                        {
                                frexpr(p->nelt);
                                p->nelt = NULL;
                        }
                        else
                                err("only last bound may be asterisk");
                        p->dims[i].dimsize = ICON(1);
                        p->dims[i].dimexpr = NULL;
                }
                else
                {

                        if(dims[i].lb)
                        {
                                q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
                                q = mkexpr(OPPLUS, q, ICON(1) );
                        }
                        if( ISCONST(q) )
                        {
                                p->dims[i].dimsize = q;
                                p->dims[i].dimexpr = (expptr) PNULL;
                        }
                        else {
                                sprintf(buf, " %s_dim%d", v->fvarname, i+1);
                                p->dims[i].dimsize = (expptr)
                                        autovar(1, tyint, EXNULL, buf);
                                p->dims[i].dimexpr = q;
                                if (i == nd)
                                        v->vlastdim = new_vars;
                                v->vdimfinish = 1;
                        }
                        if(p->nelt)
                                p->nelt = mkexpr(OPSTAR, p->nelt,
                                    cpexpr(p->dims[i].dimsize) );
                }
        }

        q = dims[nd].lb;
        q0 = 0;
        if(q == NULL)
                q = q0 = ICON(1);

        for(i = nd-1 ; i>=0 ; --i)
        {
                t = dims[i].lb;
                if(t == NULL)
                        t = ICON(1);
                if(p->dims[i].dimsize) {
                        if (q == q0) {
                                q0 = 0;
                                frexpr(q);
                                q = cpexpr(p->dims[i].dimsize);
                                }
                        else
                                q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q);
                        q = mkexpr(OPPLUS, t, q);
                        }
        }

        if( ISCONST(q) )
        {
                p->baseoffset = q;
                p->basexpr = NULL;
        }
        else
        {
                sprintf(buf, " %s_offset", v->fvarname);
                p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
                p->basexpr = q;
                v->vdimfinish = 1;
        }
        doin_setbound = 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void setext

(

register Namep

v

)

Definition at line 1657 of file proc.c.

References CLPROC, CLUNKNOWN, dclerr(), PEXTERNAL, and PUNKNOWN.

Referenced by yyparse().

{
        if(v->vclass == CLUNKNOWN)
                v->vclass = CLPROC;
        else if(v->vclass != CLPROC)
                dclerr("invalid external declaration", v);

        if(v->vprocclass == PUNKNOWN)
                v->vprocclass = PEXTERNAL;
        else if(v->vprocclass != PEXTERNAL)
                dclerr("invalid external declaration", v);
} /* setext */

Here is the call graph for this function:

Here is the caller graph for this function:

void setintr

(

register Namep

v

)

Definition at line 1617 of file proc.c.

References CLPROC, CLUNKNOWN, dclerr(), dcomplex_seen, intrfunct(), noextflag, PINTRINSIC, PUNKNOWN, STGINTR, STGUNKNOWN, and unknown.

Referenced by yyparse().

{
        int k;

        if(k = intrfunct(v->fvarname)) {
                if ((*(struct Intrpacked *)&k).f4)
                        if (noextflag)
                                goto unknown;
                        else
                                dcomplex_seen++;
                v->vardesc.varno = k;
                }
        else {
 unknown:
                dclerr("unknown intrinsic function", v);
                return;
                }
        if(v->vstg == STGUNKNOWN)
                v->vstg = STGINTR;
        else if(v->vstg!=STGINTR)
                dclerr("incompatible use of intrinsic function", v);
        if(v->vclass==CLUNKNOWN)
                v->vclass = CLPROC;
        if(v->vprocclass == PUNKNOWN)
                v->vprocclass = PINTRINSIC;
        else if(v->vprocclass != PINTRINSIC)
                dclerr("invalid intrinsic declaration", v);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void settype	(	register Namep	v,
		register int	type,
		register ftnint	length
	)

Definition at line 1456 of file proc.c.

References autovar(), changedtype(), CLMAIN, CLPROC, dclerr(), errstr(), extsymtab, Extsym::extype, frexpr(), ICON, INDATA, lengtype(), MSKCHAR, MSKCOMPLEX, ONEOF, parstate, procclass, PTHISPROC, STGARG, STGEXT, STGUNKNOWN, TYCHAR, TYSUBR, TYUNKNOWN, and xretslot.

Referenced by entrypt(), excall(), impldcl(), and yyparse().

{
        int type1;

        if(type == TYUNKNOWN)
                return;

        if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
        {
                v->vtype = TYSUBR;
                frexpr(v->vleng);
                v->vleng = 0;
                v->vimpltype = 0;
        }
        else if(type < 0)       /* storage class set */
        {
                if(v->vstg == STGUNKNOWN)
                        v->vstg = - type;
                else if(v->vstg != -type)
                        dclerr("incompatible storage declarations", v);
        }
        else if(v->vtype == TYUNKNOWN
                || v->vtype != type
                        && (v->vimpltype || v->vinftype || v->vinfproc))
        {
                if( (v->vtype = lengtype(type, length))==TYCHAR )
                        if (length>=0)
                                v->vleng = ICON(length);
                        else if (parstate >= INDATA)
                                v->vleng = ICON(1);     /* avoid a memory fault */
                v->vimpltype = 0;
                v->vinftype = 0; /* 19960709 */
                v->vinfproc = 0; /* 19960709 */

                if (v->vclass == CLPROC) {
                        if (v->vstg == STGEXT
                         && (type1 = extsymtab[v->vardesc.varno].extype)
                         &&  type1 != v->vtype)
                                changedtype(v);
                        else if (v->vprocclass == PTHISPROC
                                        && (parstate >= INDATA
                                                || procclass == CLMAIN)
                                        && !xretslot[type]) {
                                xretslot[type] = autovar(ONEOF(type,
                                        MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
                                        v->vleng, " ret_val");
                                if (procclass == CLMAIN)
                                        errstr(
                                "illegal use of %.60s (main program name)",
                                        v->fvarname);
                                /* not completely right, but enough to */
                                /* avoid memory faults; we won't */
                                /* emit any C as we have illegal Fortran */
                                }
                        }
        }
        else if(v->vtype != type && v->vtype != lengtype(type, length)) {
 incompat:
                dclerr("incompatible type declarations", v);
                }
        else if (type==TYCHAR)
                if (v->vleng && v->vleng->constblock.Const.ci != length)
                        goto incompat;
                else if (parstate >= INDATA)
                        v->vleng = ICON(1);     /* avoid a memory fault */
}

Here is the call graph for this function:

Here is the caller graph for this function:

void startproc	(	Extsym *	progname,
		int	Class
	)

Definition at line 435 of file proc.c.

References ALLOC, CLBLOCK, CLMAIN, CLPROC, CNULL, diagfile, endproc(), entries, entrypt(), Extsym::extinit, main_alias, mkname(), newentry(), newproc(), p, procclass, procname, progname, puthead(), and TYSUBR.

Referenced by yyparse().

{
        register struct Entrypoint *p;

        p = ALLOC(Entrypoint);
        if(Class == CLMAIN) {
                puthead(CNULL, CLMAIN);
                if (progname)
                    strcpy (main_alias, progname->cextname);
        } else {
                if (progname) {
                        /* Construct an empty subroutine with this name */
                        /* in case the name is needed to force loading */
                        /* of this block-data subprogram: the name can */
                        /* appear elsewhere in an external statement. */
                        entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0);
                        endproc();
                        newproc();
                        }
                puthead(CNULL, CLBLOCK);
                }
        if(Class == CLMAIN)
                newentry( mkname(" MAIN"), 0 )->extinit = 1;
        p->entryname = progname;
        entries = p;

        procclass = Class;
        fprintf(diagfile, "   %s", (Class==CLMAIN ? "MAIN" : "BLOCK DATA") );
        if(progname) {
                fprintf(diagfile, " %s", progname->fextname);
                procname = progname->cextname;
                }
        fprintf(diagfile, ":\n");
        fflush(diagfile);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void unamstring	(	register Addrp	q,
		register char *	s
	)

Definition at line 106 of file proc.c.

References IDENT_LEN, mem(), t, UNAM_CHARP, and UNAM_IDENT.

Referenced by autovar(), and doentry().

{
        register int k;
        register char *t;

        k = strlen(s);
        if (k < IDENT_LEN) {
                q->uname_tag = UNAM_IDENT;
                t = q->user.ident;
                }
        else {
                q->uname_tag = UNAM_CHARP;
                q->user.Charp = t = mem(k+1, 0);
                }
        strcpy(t, s);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

void wr_abbrevs	(	FILE *	outfile,
		int	function_head,
		chainp	vars
	)

Definition at line 1810 of file proc.c.

References Extsym::curno, extern_out(), extsymtab, nice_printf(), and out_name().

Referenced by endproc(), and start_formatting().

{
    for (; vars; vars = vars -> nextp) {
        Namep name = (Namep) vars -> datap;
        if (!name->visused)
                continue;

        if (function_head)
            nice_printf (outfile, "#define ");
        else
            nice_printf (outfile, "#undef ");
        out_name (outfile, name);

        if (function_head) {
            Extsym *comm = &extsymtab[name -> vardesc.varno];

            nice_printf (outfile, " (");
            extern_out (outfile, comm);
            nice_printf (outfile, "%d.", comm->curno);
            nice_printf (outfile, "%s)", name->cvarname);
        } /* if function_head */
        nice_printf (outfile, "\n");
    } /* for */
} /* wr_abbrevs */

Here is the call graph for this function:

Here is the caller graph for this function:

static void zap_changes

(

Void

)

[static]

Definition at line 310 of file proc.c.

References Argtypes::changes, Chain::datap, frchain(), new_procs, and Chain::nextp.

Referenced by endproc().

{
        register chainp cp;
        register Argtypes *at;

        /* arrange to get correct count of prototypes that would
           change by running f2c again */

        if (prev_proc && proc_argchanges)
                proc_protochanges++;
        prev_proc = proc_argchanges = 0;
        for(cp = new_procs; cp; cp = cp->nextp)
                if (at = ((Namep)cp->datap)->arginfo)
                        at->changes &= ~1;
        frchain(&new_procs);
        }

Here is the call graph for this function:

Here is the caller graph for this function:

---

Variable Documentation

char Blank[] = BLANKCOMMON [static]

Definition at line 46 of file proc.c.

Referenced by wr_equiv_init().

chainp new_procs

Definition at line 54 of file proc.c.

Referenced by mkfunct(), and zap_changes().

char* postfix[] [static]

Initial value:

 { "g", "h", "i",

                                        "j",

                                        "r", "d", "c", "z", "g", "h", "i" }

Definition at line 48 of file proc.c.

int prev_proc

Definition at line 55 of file proc.c.

int proc_argchanges

Definition at line 55 of file proc.c.

int proc_protochanges

Definition at line 55 of file proc.c.

Referenced by commonprotos().

---