tailor.c

<B>Digital的Unix操作系统VAX 4.2源码</B>

#include "defs"


setopt(p,q)
char *p;
char *q;
{
int qval;
qval = (q!=NULL) && ( equals(q, "yes") || equals(q, "on") );

if(equals(p,"debug")) dbgopt = 1;
else if(equals(p,"ndebug")) dbgopt = 0;
else if(equals(p,"pfort")) langopt = 0;
else if(equals(p,"ratfor")) langopt = 1;
else if(equals(p,"efl")) langopt = 2;
else if(equals(p,"dots"))
	dotsopt = qval;
else if(equals(p,"ioerror"))
	{
	if(equals(q,"none"))
		tailor.errmode = IOERRNONE;
	else if(equals(q,"ibm"))
		tailor.errmode = IOERRIBM;
	else if(equals(q,"fortran77"))
		tailor.errmode = IOERRFORT77;
	else execerr("unknown ioerror option %s", q);
	}
else if(equals(p, "system"))
	{
	register struct system *sysp;
	for(sysp = systab ; sysp->sysname ; ++sysp)
		if( equals(q, sysp->sysname) )
			break;

	if(sysp->sysname)
		tailinit(sysp);
	else
		execerr("unknown system %s", q);
	}
else if(equals(p, "continue"))
		tailor.ftncontnu = equals(q, "column1");
else if(equals(p, "procheader"))
	tailor.procheader = (q ? copys(q) : 0);
else if(equals(p, "hollincall"))
	tailor.hollincall = qval;
else if(equals(p, "longcomplextype"))
	{
	tailor.lngcxtype = (q ? copys(q) : CNULL);
	if(qval)
		eflftn[TYLCOMPLEX] = FTNDCOMPLEX;
	}
else if(equals(p, "longcomplexprefix"))
	tailor.lngcxprefix = (q ? copys(q) : CNULL);
else if(equals(p, "fortran77"))
	{
	if(tailor.ftn77 = (q==NULL || qval) )
		tailor.errmode = IOERRFORT77;
	else if(tailor.errmode == IOERRFORT77)
		tailor.errmode = IOERRNONE;
	}

else if( !tailop(p,q) )
	execerr("unknown option %s", p);

if(langopt==2)
	setdot(dotsopt);
else if(langopt==1)
	setdot(1);
}




tailinit(sysp)
register struct system *sysp;
{
register int sysf = sysp->sysno;
tailor.ftncontnu = (sysf==UNIX);
tailor.ftnsys = sysf;
tailor.ftnin = 5;
tailor.ftnout = 6;
tailor.errmode = (sysf==UNIX ? IOERRFORT77 : IOERRIBM);
tailor.charcomp = 2;
tailor.hollincall = YES;
tailor.deltastno = 1;
tailor.dclintrinsics = YES;

tailsize(sysp->chperwd);
tailfmt(sysp->idig, sysp->rdig, sysp->ddig);
}





tailsize(wordsize)
int wordsize;
{
int i;

tailor.ftnchwd = wordsize;
tailor.ftnsize[FTNINT] = wordsize;
tailor.ftnsize[FTNREAL] = wordsize;
tailor.ftnsize[FTNLOG] = wordsize;
tailor.ftnsize[FTNCOMPLEX] = 2*wordsize;
tailor.ftnsize[FTNDOUBLE] = 2*wordsize;
tailor.ftnsize[FTNDCOMPLEX] = 2*wordsize;

for(i = 0 ; i<NFTNTYPES ; ++i)
	tailor.ftnalign[i] = tailor.ftnsize[i];
}




tailfmt(idig, rdig, ddig)
int idig, rdig, ddig;
{
sprintf(msg, "i%d", idig);
tailor.dfltfmt[TYINT] = copys(msg);

sprintf(msg, "e%d.%d", rdig+8, rdig);
tailor.dfltfmt[TYREAL] = copys(msg);

sprintf(msg, "d%d.%d", ddig+8, ddig);
tailor.dfltfmt[TYLREAL] = copys(msg);

sprintf(msg, "1h(,1p%s,2h, ,%s,1h)",
	tailor.dfltfmt[TYREAL], tailor.dfltfmt[TYREAL]);
tailor.dfltfmt[TYCOMPLEX] = copys(msg);

sprintf(msg, "1h(,1p%s,2h, ,%s,1h)",
	tailor.dfltfmt[TYLREAL], tailor.dfltfmt[TYLREAL]);
tailor.dfltfmt[TYLCOMPLEX] = copys(msg);

tailor.dfltfmt[TYLOG] = "l2";
}




tailop(n,v)
char *n, *v;
{
int val;
struct itable { char *optn; int *ioptloc; } *ip;
struct ctable { char *optn; char **coptloc; } *cp;
static struct ctable formats[ ] =  {
	"iformat",	&tailor.dfltfmt[TYINT],
	"rformat",	&tailor.dfltfmt[TYREAL],
	"dformat",	&tailor.dfltfmt[TYLREAL],
	"zformat",	&tailor.dfltfmt[TYCOMPLEX],
	"zdformat",	&tailor.dfltfmt[TYLCOMPLEX],
	"lformat",	&tailor.dfltfmt[TYLOG],
	0, 0  };

static struct itable ints[ ] = {
	"ftnin",	&tailor.ftnin,
	"ftnout",	&tailor.ftnout,
	"charperint",  &tailor.ftnchwd,
	"charcomp",	&tailor.charcomp,
	"deltastno",	&tailor.deltastno,
	"dclintrinsics",	&tailor.dclintrinsics,
	"isize",	&tailor.ftnsize[FTNINT],
	"rsize",	&tailor.ftnsize[FTNREAL],
	"dsize",	&tailor.ftnsize[FTNDOUBLE],
	"lsize",	&tailor.ftnsize[FTNLOG],
	"zsize",	&tailor.ftnsize[FTNCOMPLEX],
	"ialign",	&tailor.ftnalign[FTNINT],
	"ralign",	&tailor.ftnalign[FTNREAL],
	"dalign",	&tailor.ftnalign[FTNDOUBLE],
	"lalign",	&tailor.ftnalign[FTNLOG],
	"zalign",	&tailor.ftnalign[FTNCOMPLEX],
	0, 0 };

for(cp = formats; cp->optn ; ++cp)
	if(equals(n, cp->optn))
		{
		*(cp->coptloc) = copys(v);
		return(1);
		}

for(ip = ints ; ip->optn ; ++ip)
	if(equals(n, ip->optn))
		{
		if( equals(v, "yes") || equals(v, "on") )
			val = 1;
		else if( equals(v, "no") || equals(v, "off") )
			val = 0;
		else	val = convci(v);
		*(ip->ioptloc) = val;
		return(1);
		}

return(0);
}