예제 #1
0
wr_struct(FILE *outfile, chainp var_list)
#endif
{
    int last_type = -1;
    int did_one = 0;
    chainp this_var;

    for (this_var = var_list; this_var; this_var = this_var -> nextp) {
	Namep var = (Namep) this_var -> datap;
	int type;
	char *comment = NULL;

	if (var == (Namep) NULL)
	    err ("wr_struct:  null variable");
	else if (var -> tag != TNAME)
	    erri ("wr_struct:  bad tag on variable '%d'",
		    var -> tag);

	type = var -> vtype;

	if (last_type == type && did_one)
	    nice_printf (outfile, ", ");
	else {
	    if (did_one)
		nice_printf (outfile, ";\n");
	    nice_printf (outfile, "%s ",
		    c_type_decl (type, var -> vclass == CLPROC));
	} /* else */

/* Character type is really a string type.  Put out a '*' for parameters
   with unknown length and functions returning character */

	if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
		|| var -> vclass == CLPROC))
	    nice_printf (outfile, "*");

	var -> vstg = STGAUTO;
	out_name (outfile, var);
	if (var -> vclass == CLPROC)
	    nice_printf (outfile, "()");
	else if (var -> vdim)
	    comment = wr_ardecls(outfile, var->vdim,
				var->vtype == TYCHAR && ISICON(var->vleng)
				? var->vleng->constblock.Const.ci : 1L);
	else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
	    ISICON ((var -> vleng)))
	    nice_printf (outfile, "[%ld]",
		    var -> vleng -> constblock.Const.ci);

	if (comment)
	    nice_printf (outfile, "%s", comment);
	did_one = 1;
	last_type = type;
    } /* for this_var */

    if (did_one)
	nice_printf (outfile, ";\n");
} /* wr_struct */
예제 #2
0
iarrlen(register Namep q)
#endif
{
	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);
}
예제 #3
0
p1_const(register Constp cp)
#endif
{
	int type = cp->vtype;
	expptr vleng = cp->vleng;
	union Constant *c = &cp->Const;
	char cdsbuf0[64], cdsbuf1[64];
	char *cds0, *cds1;

    switch (type) {
	case TYINT1:
        case TYSHORT:
	case TYLONG:
#ifdef TYQUAD0
	case TYQUAD:
#endif
	case TYLOGICAL:
	case TYLOGICAL1:
	case TYLOGICAL2:
	    fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
	    break;
#ifndef NO_LONG_LONG
	case TYQUAD:
	    fprintf(pass1_file, "%d: %d %llx\n", P1_CONST, type, c->cq);
	    break;
#endif
	case TYREAL:
	case TYDREAL:
		fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
			cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
	    break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
		if (cp->vstg) {
			cds0 = c->cds[0];
			cds1 = c->cds[1];
			}
		else {
			cds0 = cds(dtos(c->cd[0]), cdsbuf0);
			cds1 = cds(dtos(c->cd[1]), cdsbuf1);
			}
		fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
			cds0, cds1);
	    break;
	case TYCHAR:
	    if (vleng && !ISICON (vleng))
		err("p1_const:  bad vleng\n");
	    else
		fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
			cpexpr((expptr)cp));
	    break;
	default:
	    erri ("p1_const:  bad constant type '%d'", type);
	    break;
    } /* switch */
} /* p1_const */
예제 #4
0
dataval(register expptr repp, register expptr valp)
#endif
{
    int i, nrep;
    ftnint elen;
    register Addrp p;

    if (parstate < INDATA) {
        frexpr(repp);
        goto ret;
    }
    if(repp == NULL)
        nrep = 1;
    else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
        nrep = repp->constblock.Const.ci;
    else
    {
        err("invalid repetition count in DATA statement");
        frexpr(repp);
        goto ret;
    }
    frexpr(repp);

    if( ! ISCONST(valp) ) {
        if (valp->tag == TADDR
                && valp->addrblock.uname_tag == UNAM_CONST) {
            /* kludge */
            frexpr(valp->addrblock.memoffset);
            valp->tag = TCONST;
        }
        else {
            err("non-constant initializer");
            goto ret;
        }
    }

    if(toomanyinit) goto ret;
    for(i = 0 ; i < nrep ; ++i)
    {
        p = nextdata(&elen);
        if(p == NULL)
        {
            err("too many initializers");
            toomanyinit = YES;
            goto ret;
        }
        setdata((Addrp)p, (Constp)valp, elen);
        frexpr((expptr)p);
    }

ret:
    frexpr(valp);
}
예제 #5
0
LOCAL NODE *
putpower(bigptr p)
{
	NODE *p3;
	bigptr base;
	struct bigblock *t1, *t2;
	ftnint k = 0; /* XXX gcc */
	int type;

	if(!ISICON(p->b_expr.rightp) ||
	    (k = p->b_expr.rightp->b_const.fconst.ci)<2)
		fatal("putpower: bad call");
	base = p->b_expr.leftp;
	type = base->vtype;
	t1 = fmktemp(type, NULL);
	t2 = NULL;
	p3 = putassign(cpexpr(t1), cpexpr(base) );
	sendp2(p3);

	for( ; (k&1)==0 && k>2 ; k>>=1 ) {
		p3 = putassign(cpexpr(t1),
		    mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
		sendp2(p3);
	}

	if(k == 2)
		p3 = putx(mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
	else {
		t2 = fmktemp(type, NULL);
		p3 = putassign(cpexpr(t2), cpexpr(t1));
		sendp2(p3);
	
		for(k>>=1 ; k>1 ; k>>=1) {
			p3 = putassign(cpexpr(t1),
			    mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
			sendp2(p3);
			if(k & 1) {
				p3 = putassign(cpexpr(t2),
				    mkexpr(OPSTAR, cpexpr(t2), cpexpr(t1)));
				sendp2(p3);
			}
		}
		p3 = putx( mkexpr(OPSTAR, cpexpr(t2),
		mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
	}
	frexpr(t1);
	if(t2)
		frexpr(t2);
	frexpr(p);
	return p3;
}
예제 #6
0
lencat(register expptr p)
#endif
{
	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
		return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
	else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
		return(p->headblock.vleng->constblock.Const.ci);
	else if(p->tag==TADDR && p->addrblock.varleng!=0)
		return(p->addrblock.varleng);
	else
	{
		err("impossible element in concatenation");
		return(0);
	}
}
예제 #7
0
LOCAL struct bigblock *
putch1(bigptr p)
{
	struct bigblock *t;

	switch(p->tag) {
	case TCONST:
		return( putconst(p) );

	case TADDR:
		return(p);

	case TEXPR:
		switch(p->b_expr.opcode) {
			case OPCALL:
			case OPCCALL:
				t = putcall(p);
				sendp2(callval);
				break;

			case OPCONCAT:
				t = fmktemp(TYCHAR, cpexpr(p->vleng) );
				sendp2(putcat( cpexpr(t), p ));
				break;

			case OPCONV:
				if(!ISICON(p->vleng) ||
				    p->vleng->b_const.fconst.ci!=1
				   || ! XINT(p->b_expr.leftp->vtype) )
					fatal("putch1: bad character conversion");
				t = fmktemp(TYCHAR, MKICON(1) );
				sendp2(putassign( cpexpr(t), p));
				break;
			default:
				fatal1("putch1: invalid opcode %d", p->b_expr.opcode);
				t = NULL; /* XXX gcc */
			}
		return(t);

	default:
		fatal1("putch1: bad tag %d", p->tag);
	}
/* NOTREACHED */
return NULL; /* XXX gcc */
}
예제 #8
0
mktmpn(int nelt, register int type, expptr lengp)
#endif
{
	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);
}
예제 #9
0
autovar(register int nelt0, register int t, expptr lengp, char *name)
#endif
{
	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);
}
예제 #10
0
파일: equiv.c 프로젝트: Gilles86/afni
/* called at end of declarations section to process chains
   created by EQUIVALENCE statements
 */
 void
doequiv(Void)
{
	register int i;
	int inequiv;			/* True if one namep occurs in
					   several EQUIV declarations */
	int comno;		/* Index into Extsym table of the last
				   COMMON block seen (implicitly assuming
				   that only one will be given) */
	int ovarno;
	ftnint comoffset;	/* Index into the COMMON block */
	ftnint offset;		/* Offset from array base */
	ftnint leng;
	register struct Equivblock *equivdecl;
	register struct Eqvchain *q;
	struct Primblock *primp;
	register Namep np;
	int k, k1, ns, pref, t;
	chainp cp;
	extern int type_pref[];
	char *s;

	for(i = 0 ; i < nequiv ; ++i)
	{

/* Handle each equivalence declaration */

		equivdecl = &eqvclass[i];
		equivdecl->eqvbottom = equivdecl->eqvtop = 0;
		comno = -1;



		for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
		{
			offset = 0;
			if (!(primp = q->eqvitem.eqvlhs))
				continue;
			vardcl(np = primp->namep);
			if(primp->argsp || primp->fcharp)
			{
				expptr offp;

/* Pad ones onto the end of an array declaration when needed */

				if(np->vdim!=NULL && np->vdim->ndim>1 &&
				    nsubs(primp->argsp)==1 )
				{
					if(! ftn66flag)
						warni
			("1-dim subscript in EQUIVALENCE, %d-dim declared",
						    np -> vdim -> ndim);
					cp = NULL;
					ns = np->vdim->ndim;
					while(--ns > 0)
						cp = mkchain((char *)ICON(1), cp);
					primp->argsp->listp->nextp = cp;
				}

				offp = suboffset(primp);
				if(ISICON(offp))
					offset = offp->constblock.Const.ci;
				else	{
					dclerr
			("nonconstant subscript in equivalence ",
					    np);
					np = NULL;
				}
				frexpr(offp);
			}

/* Free up the primblock, since we now have a hash table (Namep) entry */

			frexpr((expptr)primp);

			if(np && (leng = iarrlen(np))<0)
			{
				dclerr("adjustable in equivalence", np);
				np = NULL;
			}

			if(np) switch(np->vstg)
			{
			case STGUNKNOWN:
			case STGBSS:
			case STGEQUIV:
				break;

			case STGCOMMON:

/* The code assumes that all COMMON references in a given EQUIVALENCE will
   be to the same COMMON block, and will all be consistent */

				comno = np->vardesc.varno;
				comoffset = np->voffset + offset;
				break;

			default:
				dclerr("bad storage class in equivalence", np);
				np = NULL;
				break;
			}

			if(np)
			{
				q->eqvoffset = offset;

/* eqvbottom   gets the largest difference between the array base address
   and the address specified in the EQUIV declaration */

				equivdecl->eqvbottom =
				    lmin(equivdecl->eqvbottom, -offset);

/* eqvtop   gets the largest difference between the end of the array and
   the address given in the EQUIVALENCE */

				equivdecl->eqvtop =
				    lmax(equivdecl->eqvtop, leng-offset);
			}
			q->eqvitem.eqvname = np;
		}

/* Now all equivalenced variables are in the hash table with the proper
   offset, and   eqvtop and eqvbottom   are set. */

		if(comno >= 0)

/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
   */

			eqvcommon(equivdecl, comno, comoffset);
		else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
		{
			if(np = q->eqvitem.eqvname)
			{
				inequiv = NO;
				if(np->vstg==STGEQUIV)
					if( (ovarno = np->vardesc.varno) == i)
					{

/* Can't EQUIV different elements of the same array */

						if(np->voffset + q->eqvoffset != 0)
							dclerr
			("inconsistent equivalence", np);
					}
					else	{
						offset = np->voffset;
						inequiv = YES;
					}

				np->vstg = STGEQUIV;
				np->vardesc.varno = i;
				np->voffset = - q->eqvoffset;

				if(inequiv)

/* Combine 2 equivalence declarations */

					eqveqv(i, ovarno, q->eqvoffset + offset);
			}
		}
	}

/* Now each equivalence declaration is distinct (all connections have been
   merged in eqveqv()), and some may be empty. */

	for(i = 0 ; i < nequiv ; ++i)
	{
		equivdecl = & eqvclass[i];
		if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {

/* a live chain */

			k = TYCHAR;
			pref = 1;
			for(q = equivdecl->equivs ; q; q = q->eqvnextp)
			    if ((np = q->eqvitem.eqvname)
			    		&& !np->veqvadjust) {
				np->veqvadjust = 1;
				np->voffset -= equivdecl->eqvbottom;
				t = typealign[k1 = np->vtype];
				if (pref < type_pref[k1]) {
					k = k1;
					pref = type_pref[k1];
					}
				if(np->voffset % t != 0) {
					dclerr("bad alignment forced by equivalence", np);
					--nerr; /* don't give bad return code for this */
					}
				}
			equivdecl->eqvtype = k;
		}
		freqchain(equivdecl);
	}
}
예제 #11
0
nextdata(ftnint *elenp)
#endif
{
    register struct Impldoblock *ip;
    struct Primblock *pp;
    register Namep np;
    register struct Rplblock *rp;
    tagptr p;
    expptr neltp;
    register expptr q;
    int skip;
    ftnint off, vlen;

    while(curdtp)
    {
        p = (tagptr)curdtp->datap;
        if(p->tag == TIMPLDO)
        {
            ip = &(p->impldoblock);
            if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
                fatali("bad impldoblock 0%o", (int) ip);
            if(ip->isactive)
                ip->varvp->Const.ci += ip->impdiff;
            else
            {
                q = fixtype(cpexpr(ip->implb));
                if( ! ISICON(q) )
                    goto doerr;
                ip->varvp = (Constp) q;

                if(ip->impstep)
                {
                    q = fixtype(cpexpr(ip->impstep));
                    if( ! ISICON(q) )
                        goto doerr;
                    ip->impdiff = q->constblock.Const.ci;
                    frexpr(q);
                }
                else
                    ip->impdiff = 1;

                q = fixtype(cpexpr(ip->impub));
                if(! ISICON(q))
                    goto doerr;
                ip->implim = q->constblock.Const.ci;
                frexpr(q);

                ip->isactive = YES;
                rp = ALLOC(Rplblock);
                rp->rplnextp = rpllist;
                rpllist = rp;
                rp->rplnp = ip->varnp;
                rp->rplvp = (expptr) (ip->varvp);
                rp->rpltag = TCONST;
            }

            if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
                    || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
            {   /* start new loop */
                curdtp = ip->datalist;
                goto next;
            }

            /* clean up loop */

            if(rpllist)
            {
                rp = rpllist;
                rpllist = rpllist->rplnextp;
                free( (charptr) rp);
            }
            else
                Fatal("rpllist empty");

            frexpr((expptr)ip->varvp);
            ip->isactive = NO;
            curdtp = curdtp->nextp;
            goto next;
        }

        pp = (struct Primblock *) p;
        np = pp->namep;
        cur_varname = np->fvarname;
        skip = YES;

        if(p->primblock.argsp==NULL && np->vdim!=NULL)
        {   /* array initialization */
            q = (expptr) mkaddr(np);
            off = typesize[np->vtype] * curdtelt;
            if(np->vtype == TYCHAR)
                off *= np->vleng->constblock.Const.ci;
            q->addrblock.memoffset =
                mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
            if( (neltp = np->vdim->nelt) && ISCONST(neltp))
            {
                if(++curdtelt < neltp->constblock.Const.ci)
                    skip = NO;
            }
            else
                err("attempt to initialize adjustable array");
        }
        else
            q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
        if(skip)
        {
            curdtp = curdtp->nextp;
            curdtelt = 0;
        }
        if(q->headblock.vtype == TYCHAR)
            if(ISICON(q->headblock.vleng))
                *elenp = q->headblock.vleng->constblock.Const.ci;
            else	{
                err("initialization of string of nonconstant length");
                continue;
            }
        else	*elenp = typesize[q->headblock.vtype];

        if (np->vstg == STGBSS) {
            vlen = np->vtype==TYCHAR
                   ? np->vleng->constblock.Const.ci
                   : typesize[np->vtype];
            if(vlen > 0)
                np->vstg = STGINIT;
        }
        return( (Addrp) q );

doerr:
        err("nonconstant implied DO parameter");
        frexpr(q);
        curdtp = curdtp->nextp;

next:
        curdtelt = 0;
    }

    return(NULL);
}
예제 #12
0
/*
 * Convert a f77 tree statement to something that looks like a
 * pcc expression tree.
 */
NODE *
putx(bigptr q)
{
	struct bigblock *x1;
	NODE *p = NULL; /* XXX */
	int opc;
	int type, k;

#ifdef PCC_DEBUG
	if (tflag) {
		printf("putx %p\n", q);
		fprint(q, 0);
	}
#endif

	switch(q->tag) {
	case TERROR:
		ckfree(q);
		break;

	case TCONST:
		switch(type = q->vtype) {
			case TYLOGICAL:
				type = tyint;
			case TYLONG:
			case TYSHORT:
				p = mklnode(ICON, q->b_const.fconst.ci,
				    0, types2[type]);
				ckfree(q);
				break;

			case TYADDR:
				p = mklnode(ICON, 0, 0, types2[type]);
				p->n_name = copys(memname(STGCONST,
				    (int)q->b_const.fconst.ci));
				ckfree(q);
				break;

			default:
				p = putx(putconst(q));
				break;
			}
		break;

	case TEXPR:
		switch(opc = q->b_expr.opcode) {
			case OPCALL:
			case OPCCALL:
				if( ISCOMPLEX(q->vtype) )
					p = putcxop(q);
				else {
					putcall(q);
					p = callval;
				}
				break;

			case OPMIN:
			case OPMAX:
				p = putmnmx(q);
				break;

			case OPASSIGN:
				if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
				    ISCOMPLEX(q->b_expr.rightp->vtype)) {
					frexpr(putcxeq(q));
				} else if (ISCHAR(q))
					p = putcheq(q);
				else
					goto putopp;
				break;

			case OPEQ:
			case OPNE:
				if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
				    ISCOMPLEX(q->b_expr.rightp->vtype) ) {
					p = putcxcmp(q);
					break;
				}
			case OPLT:
			case OPLE:
			case OPGT:
			case OPGE:
				if(ISCHAR(q->b_expr.leftp))
					p = putchcmp(q);
				else
					goto putopp;
				break;

			case OPPOWER:
				p = putpower(q);
				break;

			case OPSTAR:
				/*   m * (2**k) -> m<<k   */
				if (XINT(q->b_expr.leftp->vtype) &&
				    ISICON(q->b_expr.rightp) &&
				    ((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) {
					q->b_expr.opcode = OPLSHIFT;
					frexpr(q->b_expr.rightp);
					q->b_expr.rightp = MKICON(k);
					goto putopp;
				}

			case OPMOD:
				goto putopp;
			case OPPLUS:
			case OPMINUS:
			case OPSLASH:
			case OPNEG:
				if( ISCOMPLEX(q->vtype) )
					p = putcxop(q);
				else	
					goto putopp;
				break;

			case OPCONV:
				if( ISCOMPLEX(q->vtype) )
					p = putcxop(q);
				else if (ISCOMPLEX(q->b_expr.leftp->vtype)) {
					p = putx(mkconv(q->vtype,
					    realpart(putcx1(q->b_expr.leftp))));
					ckfree(q);
				} else
					goto putopp;
				break;

			case OPAND:
				/* Create logical AND */
				x1 = fmktemp(TYLOGICAL, NULL);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(0)));
				k = newlabel();
				putif(q->b_expr.leftp, k);
				putif(q->b_expr.rightp, k);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(1)));
				putlabel(k);
				p = putx(x1);
				break;

			case OPNOT: /* Logical NOT */
				x1 = fmktemp(TYLOGICAL, NULL);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(1)));
				k = newlabel();
				putif(q->b_expr.leftp, k);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(0)));
				putlabel(k);
				p = putx(x1);
				break;

			case OPOR: /* Create logical OR */
				x1 = fmktemp(TYLOGICAL, NULL);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(1)));
				k = newlabel();
				putif(mkexpr(OPEQ, q->b_expr.leftp,
				    mklogcon(0)), k);
				putif(mkexpr(OPEQ, q->b_expr.rightp,
				    mklogcon(0)), k);
				putexpr(mkexpr(OPASSIGN, cpexpr(x1),
				    mklogcon(0)));
				putlabel(k);
				p = putx(x1);
				break;

			case OPCOMMA:
				for (x1 = q; x1->b_expr.opcode == OPCOMMA; 
				    x1 = x1->b_expr.leftp)
					putexpr(x1->b_expr.rightp);
				p = putx(x1);
				break;

			case OPEQV:
			case OPNEQV:
			case OPADDR:
			case OPBITOR:
			case OPBITAND:
			case OPBITXOR:
			case OPBITNOT:
			case OPLSHIFT:
			case OPRSHIFT:
		putopp:
				p = putop(q);
				break;

			default:
				fatal1("putx: invalid opcode %d", opc);
			}
		break;

	case TADDR:
		p = putaddr(q, YES);
		break;

	default:
		fatal1("putx: impossible tag %d", q->tag);
	}
	return p;
}
예제 #13
0
p1_addr(register struct Addrblock *addrp)
#endif
{
    int stg;

    if (addrp == (struct Addrblock *) NULL)
	return;

    stg = addrp -> vstg;

    if (ONEOF(stg, M(STGINIT)|M(STGREG))
	|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
		(!ISICON(addrp->memoffset)
		|| (addrp->uname_tag == UNAM_NAME
			? addrp->memoffset->constblock.Const.ci
				!= addrp->user.name->voffset
			: addrp->memoffset->constblock.Const.ci))
	|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
		(!ISICON(addrp->memoffset)
			|| addrp->memoffset->constblock.Const.ci)
	|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
	{
		p1_big_addr (addrp);
		return;
	}

/* Write out a level of indirection for non-array arguments, which have
   addrp -> memoffset   set and are handled by   p1_big_addr().
   Lengths are passed by value, so don't check STGLENG
   28-Jun-89 (dmg)  Added the check for != TYCHAR
 */

    if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
	    stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
	p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
	p1_expr (ENULL);	/* Put dummy   vleng   */
    } /* if stg == STGARG */

    switch (addrp -> uname_tag) {
        case UNAM_NAME:
	    p1_name (addrp -> user.name);
	    break;
	case UNAM_IDENT:
	    p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
				addrp->user.ident);
	    break;
	case UNAM_CHARP:
		p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
				addrp->user.Charp);
		break;
	case UNAM_EXTERN:
	    p1putd (P1_EXTERN, (long) addrp -> memno);
	    if (addrp->vclass == CLPROC)
		extsymtab[addrp->memno].extype = addrp->vtype;
	    break;
	case UNAM_CONST:
	    if (addrp -> memno != BAD_MEMNO)
		p1_literal (addrp -> memno);
	    else
		p1_const((struct Constblock *)addrp);
	    break;
	case UNAM_UNKNOWN:
	default:
	    erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
	    break;
    } /* switch */
} /* p1_addr */
예제 #14
0
prolog(FILE *outfile, register chainp p)
#endif
{
	int addif, addif0, i, nd;
	ftnint size;
	int *ac;
	register Namep q;
	register struct Dimblock *dp;
	chainp p0, p1;

	if(procclass == CLBLOCK)
		return;
	p0 = p;
	p1 = p = argsort(p);
	wrote_comment = 0;
	comment_file = outfile;
	ac = 0;

/* Compute the base addresses and offsets for the array parameters, and
   assign these values to local variables */

	addif = addif0 = nentry > 1;
	for(; p ; p = p->nextp)
	{
	    q = (Namep) p->datap;
	    if(dp = q->vdim)	/* if this param is an array ... */
	    {
		expptr Q, expr;

		/* See whether to protect the following with an if. */
		/* This only happens when there are multiple entries. */

		nd = dp->ndim - 1;
		if (addif0) {
			if (!ac)
				ac = count_args();
			if (ac[q->argno] == nentry)
				addif = 0;
			else if (dp->basexpr
				    || dp->baseoffset->constblock.Const.ci)
				addif = 1;
			else for(addif = i = 0; i <= nd; i++)
				if (dp->dims[i].dimexpr
				&& (i < nd || !q->vlastdim)) {
					addif = 1;
					break;
					}
			if (addif) {
				write_comment();
				nice_printf(outfile, "if (%s) {\n", /*}*/
						q->cvarname);
				next_tab(outfile);
				}
			}
		for(i = 0 ; i <= nd; ++i)

/* Store the variable length of each dimension (which is fixed upon
   runtime procedure entry) into a local variable */

		    if ((Q = dp->dims[i].dimexpr)
			&& (i < nd || !q->vlastdim)) {
			expr = (expptr)cpexpr(Q);
			write_comment();
			out_and_free_statement (outfile, mkexpr (OPASSIGN,
				fixtype(cpexpr(dp->dims[i].dimsize)), expr));
		    } /* if dp -> dims[i].dimexpr */

/* size   will equal the size of a single element, or -1 if the type is
   variable length character type */

		size = typesize[ q->vtype ];
		if(q->vtype == TYCHAR)
		    if( ISICON(q->vleng) )
			size *= q->vleng->constblock.Const.ci;
		    else
			size = -1;

		/* Fudge the argument pointers for arrays so subscripts
		 * are 0-based. Not done if array bounds are being checked.
		 */
		if(dp->basexpr) {

/* Compute the base offset for this procedure */

		    write_comment();
		    out_and_free_statement (outfile, mkexpr (OPASSIGN,
			    cpexpr(fixtype(dp->baseoffset)),
			    cpexpr(fixtype(dp->basexpr))));
		} /* if dp -> basexpr */

		if(! checksubs) {
		    if(dp->basexpr) {
			expptr tp;

/* If the base of this array has a variable adjustment ... */

			tp = (expptr) cpexpr (dp -> baseoffset);
			if(size < 0 || q -> vtype == TYCHAR)
			    tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));

			write_comment();
			tp = mkexpr (OPMINUSEQ,
				mkconv (TYADDR, (expptr)p->datap),
				mkconv(TYINT, fixtype
				(fixtype (tp))));
/* Avoid type clash by removing the type conversion */
			tp = prune_left_conv (tp);
			out_and_free_statement (outfile, tp);
		    } else if(dp->baseoffset->constblock.Const.ci != 0) {

/* if the base of this array has a nonzero constant adjustment ... */

			expptr tp;

			write_comment();
			if(size > 0 && q -> vtype != TYCHAR) {
			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
				    mkconv (TYADDR, (expptr)p->datap),
				    mkconv (TYINT, fixtype
				    (cpexpr (dp->baseoffset)))));
			    out_and_free_statement (outfile, tp);
			} else {
			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
				    mkconv (TYADDR, (expptr)p->datap),
				    mkconv (TYINT, fixtype
				    (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
				    cpexpr (q -> vleng))))));
			    out_and_free_statement (outfile, tp);
			} /* else */
		    } /* if dp -> baseoffset -> const */
		} /* if !checksubs */

		if (addif) {
			nice_printf(outfile, /*{*/ "}\n");
			prev_tab(outfile);
			}
	    }
	}
	if (wrote_comment)
	    nice_printf (outfile, "\n/* Function Body */\n");
	if (ac)
		free((char *)ac);
	if (p0 != p1)
		frchain(&p1);
} /* prolog */