示例#1
0
add_extern_to_list(Addrp addr, chainp *list_store)
#endif
{
    chainp last = CHNULL;
    chainp list;
    int memno;

    if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
	return;

    list = *list_store;
    memno = addr -> memno;

    for (;list; last = list, list = list -> nextp) {
	Addrp This = (Addrp) (list -> datap);

	if (This -> tag == TADDR && This -> uname_tag == UNAM_EXTERN &&
		This -> memno == memno)
	    return;
    } /* for */

    if (*list_store == CHNULL)
	*list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
    else
	last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);

} /* add_extern_to_list */
示例#2
0
LOCAL void
putct1(bigptr q, bigptr lp, bigptr cp, int *ip)
{
	NODE *p;
	int i;
	struct bigblock *lp1, *cp1;

	if(q->tag==TEXPR && q->b_expr.opcode==OPCONCAT) {
		putct1(q->b_expr.leftp, lp, cp, ip);
		putct1(q->b_expr.rightp, lp, cp , ip);
		frexpr(q->vleng);
		ckfree(q);
	} else {
		i = (*ip)++;
		lp1 = cpexpr(lp);
		lp1->b_addr.memoffset =
		    mkexpr(OPPLUS, lp1->b_addr.memoffset, MKICON(i*FSZLENG));
		cp1 = cpexpr(cp);
		cp1->b_addr.memoffset =
		    mkexpr(OPPLUS, cp1->b_addr.memoffset, MKICON(i*FSZADDR));
		p = putassign( lp1, cpexpr(q->vleng) );
		sendp2(p);
		p = putassign( cp1, addrof(putch1(q)) );
		sendp2(p);
	}
}
示例#3
0
copy_data(chainp list)
#endif
{
    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 */
示例#4
0
/* Arithmetic IF  */
void
prarif(bigptr p, int neg, int zer, int pos)
{
	bigptr x1 = fmktemp(p->vtype, NULL);

	putexpr(mkexpr(OPASSIGN, cpexpr(x1), p));
	putif(mkexpr(OPGE, cpexpr(x1), MKICON(0)), neg);
	putif(mkexpr(OPLE, x1, MKICON(0)), pos);
	putgoto(zer);
}
示例#5
0
p1_subr_ret(expptr retexp)
#endif
{

    p1put (P1_SUBR_RET);
    p1_expr (cpexpr(retexp));
} /* p1_subr_ret */
示例#6
0
declare_new_addr(struct Addrblock *addrp)
#endif
{
    extern chainp new_vars;

    new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
} /* declare_new_addr */
示例#7
0
retval(register int t)
#endif
{
	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);
	}
}
示例#8
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 */
}
示例#9
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 */
示例#10
0
mktmp(int type, expptr lengp)
#endif
{
	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;
}
示例#11
0
LOCAL struct bigblock *
intdouble(struct bigblock *p)
{
	struct bigblock *t;

	t = fmktemp(TYDREAL, NULL);

	sendp2(putassign(cpexpr(t), p));
	return(t);
}
示例#12
0
Inline(int fno, int type, struct Chain *args)
#endif
{
	register expptr q, t, t1;

	switch(fno)
	{
	case 8:	/* real abs */
	case 9:	/* short int abs */
	case 10:	/* long int abs */
	case 11:	/* double precision abs */
		if( addressable(q = (expptr) args->datap) )
		{
			t = q;
			q = NULL;
		}
		else
			t = (expptr) mktmp(type,ENULL);
		t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
			cpexpr(t), ENULL);
		if(q)
			t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
		frexpr(t);
		return(t1);

	case 26:	/* dprod */
		q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
			(expptr)args->nextp->datap);
		return(q);

	case 27:	/* len of character string */
		q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
		frexpr((expptr)args->datap);
		return(q);

	case 14:	/* half-integer mod */
	case 15:	/* mod */
		return mkexpr(OPMOD, (expptr) args->datap,
		    		(expptr) args->nextp->datap);
	}
	return(NULL);
}
示例#13
0
void
putcmgo(bigptr x, int nlab, struct labelblock *labels[])
{
	bigptr y;
	int i;

	if (!ISINT(x->vtype)) {
		execerr("computed goto index must be integer", NULL);
		return;
	}

	y = fmktemp(x->vtype, NULL);
	putexpr(mkexpr(OPASSIGN, cpexpr(y), x));
#ifdef notyet /* target-specific computed goto */
	vaxgoto(y, nlab, labels);
#else
	/*
	 * Primitive implementation, should use table here.
	 */
	for(i = 0 ; i < nlab ; ++i)
		putif(mkexpr(OPNE, cpexpr(y), MKICON(i+1)), labels[i]->labelno);
	frexpr(y);
#endif
}
示例#14
0
cast_args(int maxtype, chainp args)
#endif
{
    for (; args; args = args -> nextp) {
	expptr e = (expptr) args->datap;
	if (e -> headblock.vtype != maxtype)
	    if (e -> tag == TCONST)
		args->datap = (char *) mkconv(maxtype, e);
	    else {
		Addrp temp = mktmp(maxtype, ENULL);

		puteq(cpexpr((expptr)temp), e);
		args->datap = (char *)temp;
	    } /* else */
    } /* for */
} /* cast_args */
示例#15
0
realpart(register Addrp p)
#endif
{
	register Addrp q;

	if (p->tag == TADDR
	 && p->uname_tag == UNAM_CONST
	 && ISCOMPLEX (p->vtype))
		return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
			p->user.kludge.vstg1 ? p->user.Const.cds[0]
				: cds(dtos(p->user.Const.cd[0]),CNULL));

	q = (Addrp) cpexpr((expptr) p);
	if( ISCOMPLEX(p->vtype) )
		q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);

	return(q);
}
示例#16
0
imagpart(register Addrp p)
#endif
{
	register Addrp q;

	if( ISCOMPLEX(p->vtype) )
	{
		if (p->tag == TADDR && p->uname_tag == UNAM_CONST)
			return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
				p->user.kludge.vstg1 ? p->user.Const.cds[1]
				: cds(dtos(p->user.Const.cd[1]),CNULL));
		q = (Addrp) cpexpr((expptr) p);
		q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
		return( (expptr) q );
	}
	else

/* Cast an integer type onto a Double Real type */

		return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
}
示例#17
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);
}
示例#18
0
putconst(register Constp p)
#endif
{
	register Addrp q;
	struct Literal *litp, *lastlit;
	int k, len, type;
	int litflavor;
	double cd[2];
	ftnint nblanks;
	char *strp;
	char cdsbuf0[64], cdsbuf1[64], *ds[2];

	if (p->tag != TCONST)
		badtag("putconst", p->tag);

	q = ALLOC(Addrblock);
	q->tag = TADDR;
	type = p->vtype;
	q->vtype = ( type==TYADDR ? tyint : type );
	q->vleng = (expptr) cpexpr(p->vleng);
	q->vstg = STGCONST;

/* Create the new label for the constant.  This is wasteful of labels
   because when the constant value already exists in the literal pool,
   this label gets thrown away and is never reclaimed.  It might be
   cleaner to move this down past the first   switch()   statement below */

	q->memno = newlabel();
	q->memoffset = ICON(0);
	q -> uname_tag = UNAM_CONST;

/* Copy the constant info into the Addrblock; do this by copying the
   largest storage elts */

	q -> user.Const = p -> Const;
	q->user.kludge.vstg1 = p->vstg;	/* distinguish string from binary fp */

	/* check for value in literal pool, and update pool if necessary */

	k = 1;
	switch(type)
	{
	case TYCHAR:
		if (halign) {
			strp = p->Const.ccp;
			nblanks = p->Const.ccp1.blanks;
			len = p->vleng->constblock.Const.ci;
			litflavor = LIT_CHAR;
			goto loop;
			}
		else
			q->memno = BAD_MEMNO;
		break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
		k = 2;
		if (p->vstg)
			cd[1] = atof(ds[1] = p->Const.cds[1]);
		else
			ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
	case TYREAL:
	case TYDREAL:
		litflavor = LIT_FLOAT;
		if (p->vstg)
			cd[0] = atof(ds[0] = p->Const.cds[0]);
		else
			ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
		goto loop;

	case TYLOGICAL1:
	case TYLOGICAL2:
	case TYLOGICAL:
		type = tylogical;
		goto lit_int_flavor;
	case TYLONG:
		type = tyint;
	case TYSHORT:
	case TYINT1:
#ifdef TYQUAD
	case TYQUAD:
#endif
 lit_int_flavor:
		litflavor = LIT_INT;

/* Scan the literal pool for this constant value.  If this same constant
   has been assigned before, use the same label.  Note that this routine
   does NOT consider two differently-typed constants with the same bit
   pattern to be the same constant */

 loop:
		lastlit = litpool + nliterals;
		for(litp = litpool ; litp<lastlit ; ++litp)

/* Remove this type checking to ensure that all bit patterns are reused */

			if(type == litp->littype) switch(litflavor)
			{
			case LIT_CHAR:
				if (len == (int)litp->litval.litival2[0]
				&& nblanks == litp->litval.litival2[1]
				&& !memcmp(strp, litp->cds[0], len)) {
					q->memno = litp->litnum;
					frexpr((expptr)p);
					q->user.Const.ccp1.ccp0 = litp->cds[0];
					return(q);
					}
				break;
			case LIT_FLOAT:
				if(cd[0] == litp->litval.litdval[0]
				&& !strcmp(ds[0], litp->cds[0])
				&& (k == 1 ||
				    cd[1] == litp->litval.litdval[1]
				    && !strcmp(ds[1], litp->cds[1]))) {
ret:
					q->memno = litp->litnum;
					frexpr((expptr)p);
					return(q);
					}
				break;

			case LIT_INT:
				if(p->Const.ci == litp->litval.litival)
					goto ret;
				break;
			}

/* If there's room in the literal pool, add this new value to the pool */

		if(nliterals < maxliterals)
		{
			++nliterals;

			/* litp   now points to the next free elt */

			litp->littype = type;
			litp->litnum = q->memno;
			switch(litflavor)
			{
			case LIT_CHAR:
				litp->litval.litival2[0] = len;
				litp->litval.litival2[1] = nblanks;
				q->user.Const.ccp = litp->cds[0] =
					memcpy(gmem(len,0), strp, len);
				break;

			case LIT_FLOAT:
				litp->litval.litdval[0] = cd[0];
				litp->cds[0] = copys(ds[0]);
				if (k == 2) {
					litp->litval.litdval[1] = cd[1];
					litp->cds[1] = copys(ds[1]);
					}
				break;

			case LIT_INT:
				litp->litval.litival = p->Const.ci;
				break;
			} /* switch (litflavor) */
		}
		else
			many("literal constants", 'L', maxliterals);

		break;
	case TYADDR:
	    break;
	default:
		badtype ("putconst", p -> vtype);
		break;
	} /* switch */

	if (type != TYCHAR || halign)
	    frexpr((expptr)p);
	return( q );
}
示例#19
0
putsteq(Addrp a, Addrp b)
#endif
{
	return putx( fixexpr((Exprp)
		mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
}
示例#20
0
setbound(Namep v, int nd, struct Dims *dims)
#endif
{
	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;
}
示例#21
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 */
示例#22
0
LOCAL struct bigblock *
putcx1(bigptr qq)
{
	struct bigblock *q, *lp, *rp;
	register struct bigblock *resp;
	NODE *p;
	int opcode;
	int ltype, rtype;

	ltype = rtype = 0; /* XXX gcc */
	if(qq == NULL)
		return(NULL);

	switch(qq->tag) {
	case TCONST:
		if( ISCOMPLEX(qq->vtype) )
			qq = putconst(qq);
		return( qq );

	case TADDR:
		if( ! addressable(qq) ) {
			resp = fmktemp(tyint, NULL);
			p = putassign( cpexpr(resp), qq->b_addr.memoffset );
			sendp2(p);
			qq->b_addr.memoffset = resp;
		}
		return( qq );

	case TEXPR:
		if( ISCOMPLEX(qq->vtype) )
			break;
		resp = fmktemp(TYDREAL, NO);
		p = putassign( cpexpr(resp), qq);
		sendp2(p);
		return(resp);

	default:
		fatal1("putcx1: bad tag %d", qq->tag);
	}

	opcode = qq->b_expr.opcode;
	if(opcode==OPCALL || opcode==OPCCALL) {
		q = putcall(qq);
		sendp2(callval);
		return(q);
	} else if(opcode == OPASSIGN) {
		return( putcxeq(qq) );
	}

	resp = fmktemp(qq->vtype, NULL);
	if((lp = putcx1(qq->b_expr.leftp) ))
		ltype = lp->vtype;
	if((rp = putcx1(qq->b_expr.rightp) ))
		rtype = rp->vtype;

	switch(opcode) {
	case OPCOMMA:
		frexpr(resp);
		resp = rp;
		rp = NULL;
		break;

	case OPNEG:
		p = putassign(realpart(resp),
		    mkexpr(OPNEG, realpart(lp), NULL));
		sendp2(p);
		p = putassign(imagpart(resp),
		    mkexpr(OPNEG, imagpart(lp), NULL));
		sendp2(p);
		break;

	case OPPLUS:
	case OPMINUS:
		p = putassign( realpart(resp),
		    mkexpr(opcode, realpart(lp), realpart(rp) ));
		sendp2(p);
		if(rtype < TYCOMPLEX) {
			p = putassign(imagpart(resp), imagpart(lp) );
		} else if(ltype < TYCOMPLEX) {
			if(opcode == OPPLUS)
				p = putassign( imagpart(resp), imagpart(rp) );
			else
				p = putassign( imagpart(resp),
				    mkexpr(OPNEG, imagpart(rp), NULL) );
		} else
			p = putassign( imagpart(resp),
			    mkexpr(opcode, imagpart(lp), imagpart(rp) ));
		sendp2(p);
		break;

	case OPSTAR:
		if(ltype < TYCOMPLEX) {
			if( ISINT(ltype) )
				lp = intdouble(lp);
			p = putassign( realpart(resp),
			    mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
			sendp2(p);
			p = putassign( imagpart(resp),
			    mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
		} else if(rtype < TYCOMPLEX) {
			if( ISINT(rtype) )
				rp = intdouble(rp);
			p = putassign( realpart(resp),
			    mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
			sendp2(p);
			p = putassign( imagpart(resp),
			    mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
		} else {
			p = putassign( realpart(resp), mkexpr(OPMINUS,
				mkexpr(OPSTAR, realpart(lp), realpart(rp)),
				mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
			sendp2(p);
			p = putassign( imagpart(resp), mkexpr(OPPLUS,
				mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
				mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
		}
		sendp2(p);
		break;

	case OPSLASH:
		/* fixexpr has already replaced all divisions
		 * by a complex by a function call
		 */
		if( ISINT(rtype) )
			rp = intdouble(rp);
		p = putassign( realpart(resp),
		    mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
		sendp2(p);
		p = putassign( imagpart(resp),
		    mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
		sendp2(p);
		break;

	case OPCONV:
		p = putassign( realpart(resp), realpart(lp) );
		if( ISCOMPLEX(lp->vtype) )
			q = imagpart(lp);
		else if(rp != NULL)
			q = realpart(rp);
		else
			q = mkrealcon(TYDREAL, 0.0);
		sendp2(p);
		p = putassign( imagpart(resp), q);
		sendp2(p);
		break;

	default:
		fatal1("putcx1 of invalid opcode %d", opcode);
	}

	frexpr(lp);
	frexpr(rp);
	ckfree(qq);
	return(resp);
}
示例#23
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;
}
示例#24
0
LOCAL NODE *
putop(bigptr q)
{
	NODE *p;
	int k;
	bigptr lp, tp;
	int pt, lt;

#ifdef PCC_DEBUG
	if (tflag) {
		printf("putop %p\n", q);
		fprint(q, 0);
	}
#endif
	switch(q->b_expr.opcode) { /* check for special cases and rewrite */
	case OPCONV:
		pt = q->vtype;
		lp = q->b_expr.leftp;
		lt = lp->vtype;
		while(q->tag==TEXPR && q->b_expr.opcode==OPCONV &&
		     ((ISREAL(pt)&&ISREAL(lt)) ||
			(XINT(pt)&&(ONEOF(lt,MSKINT|MSKADDR))) )) {
			if(lp->tag != TEXPR) {
				if(pt==TYINT && lt==TYLONG)
					break;
				if(lt==TYINT && pt==TYLONG)
					break;
			}
			ckfree(q);
			q = lp;
			pt = lt;
			lp = q->b_expr.leftp;
			lt = lp->vtype;
		}
		if(q->tag==TEXPR && q->b_expr.opcode==OPCONV)
			break;
		p = putx(q);
		return p;

	case OPADDR:
		lp = q->b_expr.leftp;
		if(lp->tag != TADDR) {
			tp = fmktemp(lp->vtype, lp->vleng);
			p = putx(mkexpr(OPASSIGN, cpexpr(tp), lp));
			sendp2(p);
			lp = tp;
		}
		p = putaddr(lp, NO);
		ckfree(q);
		return p;
	}

	if ((k = ops2[q->b_expr.opcode]) <= 0)
		fatal1("putop: invalid opcode %d (%d)", q->b_expr.opcode, k);
	p = putx(q->b_expr.leftp);
	if(q->b_expr.rightp)
		p = mkbinode(k, p, putx(q->b_expr.rightp), types2[q->vtype]);
	else
		p = mkunode(k, p, 0, types2[q->vtype]);

	if(q->vleng)
		frexpr(q->vleng);
	ckfree(q);
	return p;
}
示例#25
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;
}
示例#26
0
static NODE *
putaddr(bigptr q, int indir)
{
	int type, type2, funct;
	NODE *p, *p1, *p2;
	ftnint offset;
	bigptr offp;

	p = p1 = p2 = NULL; /* XXX */

	type = q->vtype;
	type2 = types2[type];
	funct = (q->vclass==CLPROC ? FTN<<TSHIFT : 0);

	offp = (q->b_addr.memoffset ? cpexpr(q->b_addr.memoffset) : NULL);

	offset = simoffset(&offp);
	if(offp)
		offp = mkconv(TYINT, offp);

	switch(q->vstg) {
	case STGAUTO:
		if(indir && !offp) {
			p = oregtree(offset, AUTOREG, type2);
			break;
		}

		if(!indir && !offp && !offset) {
			p = mklnode(REG, 0, AUTOREG, INCREF(type2));
			break;
		}

		p = mklnode(REG, 0, AUTOREG, INCREF(type2));
		if(offp) {
			p1 = putx(offp);
			if(offset)
				p2 = mklnode(ICON, offset, 0, INT);
		} else
			p1 = mklnode(ICON, offset, 0, INT);
		if (offp && offset)
			p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
		p = mkbinode(PLUS, p, p1, INCREF(type2));
		if (indir)
			p = mkunode(UMUL, p, 0, type2);
		break;

	case STGARG:
		p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
		    ARGREG, INCREF(type2)|funct);

		if (offp)
			p1 = putx(offp);
		if (offset)
			p2 = mklnode(ICON, offset, 0, INT);
		if (offp && offset)
			p1 = mkbinode(PLUS, p1, p2, INCREF(type2));
		else if (offset)
			p1 = p2;
		if (offp || offset)
			p = mkbinode(PLUS, p, p1, INCREF(type2));
		if (indir)
			p = mkunode(UMUL, p, 0, type2);
		break;

	case STGLENG:
		if(indir) {
			p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno),
			    ARGREG, INCREF(type2)|funct);
		} else	{
			fatal1("faddrnode: STGLENG: fixme!");
#if 0
			p2op(P2PLUS, types2[TYLENG] | P2PTR );
			p2reg(ARGREG, types2[TYLENG] | P2PTR );
			p2icon( ARGOFFSET +
				(ftnint) (FUDGEOFFSET*p->b_addr.memno), P2INT);
#endif
		}
		break;


	case STGBSS:
	case STGINIT:
	case STGEXT:
	case STGCOMMON:
	case STGEQUIV:
	case STGCONST:
		if(offp) {
			p1 = putx(offp);
			p2 = putmem(q, ICON, offset);
			p = mkbinode(PLUS, p1, p2, INCREF(type2));
			if(indir)
				p = mkunode(UMUL, p, 0, type2);
		} else
			p = putmem(q, (indir ? NAME : ICON), offset);
		break;

	case STGREG:
		if(indir)
			p = mklnode(REG, 0, q->b_addr.memno, type2);
		else
			fatal("attempt to take address of a register");
		break;

	default:
		fatal1("putaddr: invalid vstg %d", q->vstg);
	}
	frexpr(q);
	return p;
}