intr.c

把fortran语言编的程序转为c语言编的程序, 运行环境linux

					Fatal("r8fix bug");
				}
			break;
		case TYREAL:
			S->atype = TYDREAL;
			switch(S->rtype) {
			    case TYREAL:
				S->rtype = TYDREAL;
				if (S->spxname[0] != 'r')
					Fatal("r8fix bug");
				S->spxname[0] = 'd';
			    case TYDREAL:	/* d_prod */
				break;

			    case TYSHORT:
				if (!strcmp(S->spxname, "hr_expn"))
					S->spxname[1] = 'd';
				else if (!strcmp(S->spxname, "h_nint"))
					strcpy(S->spxname, "h_dnnt");
				else Fatal("r8fix bug");
				break;

			    case TYLONG:
				if (!strcmp(S->spxname, "ir_expn"))
					S->spxname[1] = 'd';
				else if (!strcmp(S->spxname, "i_nint"))
					strcpy(S->spxname, "i_dnnt");
				else Fatal("r8fix bug");
				break;

			    default:
				Fatal("r8fix bug");
			    }
		}
	}


 expptr
#ifdef KR_headers
intrcall(np, argsp, nargs)
	Namep np;
	struct Listblock *argsp;
	int nargs;
#else
intrcall(Namep np, struct Listblock *argsp, int nargs)
#endif
{
	int i, rettype;
	Addrp ap;
	register struct Specblock *sp;
	register struct Chain *cp;
	expptr q, ep;
	int mtype;
	int op;
	int f1field, f2field, f3field;

	packed.ijunk = np->vardesc.varno;
	f1field = packed.bits.f1;
	f2field = packed.bits.f2;
	f3field = packed.bits.f3;
	if(nargs == 0)
		goto badnargs;

	mtype = 0;
	for(cp = argsp->listp ; cp ; cp = cp->nextp)
	{
		ep = (expptr)cp->datap;
		if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
			cp->datap = (char *) mkconv(tyint, ep);
		mtype = maxtype(mtype, ep->headblock.vtype);
	}

	switch(f1field)
	{
	case INTRBOOL:
		op = f3field;
		if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
			goto badtype;
		if(op == OPBITNOT)
		{
			if(nargs != 1)
				goto badnargs;
			q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
		}
		else
		{
			if(nargs != 2)
				goto badnargs;
			q = mkexpr(op, (expptr)argsp->listp->datap,
			    		(expptr)argsp->listp->nextp->datap);
		}
		frchain( &(argsp->listp) );
		free( (charptr) argsp);
		return(q);

	case INTRCONV:
		rettype = f2field;
		switch(rettype) {
		  case TYLONG:
			rettype = tyint;
			break;
		  case TYLOGICAL:
			rettype = tylog;
		  }
		if( ISCOMPLEX(rettype) && nargs==2)
		{
			expptr qr, qi;
			qr = (expptr) argsp->listp->datap;
			qi = (expptr) argsp->listp->nextp->datap;
			if (qr->headblock.vtype == TYDREAL
			 || qi->headblock.vtype == TYDREAL)
				rettype = TYDCOMPLEX;
			if(ISCONST(qr) && ISCONST(qi))
				q = mkcxcon(qr,qi);
			else	q = mkexpr(OPCONV,mkconv(rettype-2,qr),
			    mkconv(rettype-2,qi));
		}
		else if(nargs == 1) {
			if (f3field && ((Exprp)argsp->listp->datap)->vtype
					== TYDCOMPLEX)
				rettype = TYDREAL;
			q = mkconv(rettype+100, (expptr)argsp->listp->datap);
			if (q->tag == TADDR)
				q->addrblock.parenused = 1;
			}
		else goto badnargs;

		q->headblock.vtype = rettype;
		frchain(&(argsp->listp));
		free( (charptr) argsp);
		return(q);


#if 0
	case INTRCNST:

/* Machine-dependent f77 stuff that f2c omits:

intcon contains
	radix for short int
	radix for long int
	radix for single precision
	radix for double precision
	precision for short int
	precision for long int
	precision for single precision
	precision for double precision
	emin for single precision
	emin for double precision
	emax for single precision
	emax for double prcision
	largest short int
	largest long int

realcon contains
	tiny for single precision
	tiny for double precision
	huge for single precision
	huge for double precision
	mrsp (epsilon) for single precision
	mrsp (epsilon) for double precision
*/
	{	register struct Incstblock *cstp;
		extern ftnint intcon[14];
		extern double realcon[6];

		cstp = consttab + f3field;
		for(i=0 ; i<f2field ; ++i)
			if(cstp->atype == mtype)
				goto foundconst;
			else
				++cstp;
		goto badtype;

foundconst:
		switch(cstp->rtype)
		{
		case TYLONG:
			return(mkintcon(intcon[cstp->constno]));

		case TYREAL:
		case TYDREAL:
			return(mkrealcon(cstp->rtype,
			    realcon[cstp->constno]) );

		default:
			Fatal("impossible intrinsic constant");
		}
	}
#endif

	case INTRGEN:
		sp = spectab + f3field;
		if(no66flag)
			if(sp->atype == mtype)
				goto specfunct;
			else err66("generic function");

		for(i=0; i<f2field ; ++i)
			if(sp->atype == mtype)
				goto specfunct;
			else
				++sp;
		warn1 ("bad argument type to intrinsic %s", np->fvarname);

/* Made this a warning rather than an error so things like "log (5) ==>
   log (5.0)" can be accommodated.  When none of these cases matches, the
   argument is cast up to the first type in the spectab list; this first
   type is assumed to be the "smallest" type, e.g. REAL before DREAL
   before COMPLEX, before DCOMPLEX */

		sp = spectab + f3field;
		mtype = sp -> atype;
		goto specfunct;

	case INTRSPEC:
		sp = spectab + f3field;
specfunct:
		if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
		    && (sp+1)->atype==sp->atype)
			++sp;

		if(nargs != sp->nargs)
			goto badnargs;
		if(mtype != sp->atype)
			goto badtype;

/* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
   the inline expression wouldn't get put into the constant table */

		fixargs (NO, argsp);
		cast_args (mtype, argsp -> listp);

		if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
		{
			frchain( &(argsp->listp) );
			free( (charptr) argsp);
		} else {

		    if(sp->othername) {
			/* C library routines that return double... */
			/* sp->rtype might be TYREAL */
			ap = builtin(sp->rtype,
				callbyvalue[sp->othername], 1);
			q = fixexpr((Exprp)
				mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
		    } else {
			fixargs(YES, argsp);
			ap = builtin(sp->rtype, sp->spxname, 0);
			q = fixexpr((Exprp)
				mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
		    } /* else */
		} /* else */
		return(q);

	case INTRMIN:
	case INTRMAX:
		if(nargs < 2)
			goto badnargs;
		if( ! ONEOF(mtype, MSKINT|MSKREAL) )
			goto badtype;
		argsp->vtype = mtype;
		q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);

		q->headblock.vtype = mtype;
		rettype = f2field;
		if(rettype == TYLONG)
			rettype = tyint;
		else if(rettype == TYUNKNOWN)
			rettype = mtype;
		return( mkconv(rettype, q) );

	default:
		fatali("intrcall: bad intrgroup %d", f1field);
	}
badnargs:
	errstr("bad number of arguments to intrinsic %s", np->fvarname);
	goto bad;

badtype:
	errstr("bad argument type to intrinsic %s", np->fvarname);

bad:
	return( errnode() );
}



 int
#ifdef KR_headers
intrfunct(s)
	char *s;
#else
intrfunct(char *s)
#endif
{
	register struct Intrblock *p;

	for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
	{
		if( !strcmp(s, p->intrfname) )
		{
			packed.bits.f1 = p->intrval.intrgroup;
			packed.bits.f2 = p->intrval.intrstuff;
			packed.bits.f3 = p->intrval.intrno;
			packed.bits.f4 = p->intrval.dblcmplx;
			return(packed.ijunk);
		}
	}

	return(0);
}





 Addrp
#ifdef KR_headers
intraddr(np)
	Namep np;
#else
intraddr(Namep np)
#endif
{
	Addrp q;
	register struct Specblock *sp;
	int f3field;

	if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
		fatalstr("intraddr: %s is not intrinsic", np->fvarname);
	packed.ijunk = np->vardesc.varno;
	f3field = packed.bits.f3;

	switch(packed.bits.f1)
	{
	case INTRGEN:
		/* imag, log, and log10 arent specific functions */
		if(f3field==31 || f3field==43 || f3field==47)
			goto bad;

	case INTRSPEC:
		sp = spectab + f3field;
		if (tyint == TYLONG
		&& (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
			++sp;
		q = builtin(sp->rtype, sp->spxname,
			sp->othername ? 1 : 0);
		return(q);

	case INTRCONV:
	case INTRMIN:
	case INTRMAX:
	case INTRBOOL:
	case INTRCNST:
bad:
		errstr("cannot pass %s as actual", np->fvarname);
		return((Addrp)errnode());
	}
	fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
	/* NOT REACHED */ return 0;
}



 void
#ifdef KR_headers
cast_args(maxtype, args)
	int maxtype;
	chainp args;
#else
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 */



 expptr
#ifdef KR_headers
Inline(fno, type, args)
	int fno;
	int type;
	struct Chain *args;
#else
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 mkconv(tyioint, q);

	case 14:	/* half-integer mod */
	case 15:	/* mod */
		return mkexpr(OPMOD, (expptr) args->datap,
		    		(expptr) args->nextp->datap);
	}
	return(NULL);
}