misc.c

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

#else
frchain(register chainp *p)
#endif
{
	register chainp q;

	if(p==0 || *p==0)
		return;

	for(q = *p; q->nextp ; q = q->nextp)
		;
	q->nextp = chains;
	chains = *p;
	*p = 0;
}

 void
#ifdef KR_headers
frexchain(p)
	register chainp *p;
#else
frexchain(register chainp *p)
#endif
{
	register chainp q, r;

	if (q = *p) {
		for(;;q = r) {
			frexpr((expptr)q->datap);
			if (!(r = q->nextp))
				break;
			}
		q->nextp = chains;
		chains = *p;
		*p = 0;
		}
	}


 tagptr
#ifdef KR_headers
cpblock(n, p)
	register int n;
	register char *p;
#else
cpblock(register int n, register char *p)
#endif
{
	register ptr q;

	memcpy((char *)(q = ckalloc(n)), (char *)p, n);
	return( (tagptr) q);
}



 ftnint
#ifdef KR_headers
lmax(a, b)
	ftnint a;
	ftnint b;
#else
lmax(ftnint a, ftnint b)
#endif
{
	return( a>b ? a : b);
}

 ftnint
#ifdef KR_headers
lmin(a, b)
	ftnint a;
	ftnint b;
#else
lmin(ftnint a, ftnint b)
#endif
{
	return(a < b ? a : b);
}




#ifdef KR_headers
maxtype(t1, t2)
	int t1;
	int t2;
#else
maxtype(int t1, int t2)
#endif
{
	int t;

	t = t1 >= t2 ? t1 : t2;
	if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
		t = TYDCOMPLEX;
	return(t);
}



/* return log base 2 of n if n a power of 2; otherwise -1 */
 int
#ifdef KR_headers
log_2(n)
	ftnint n;
#else
log_2(ftnint n)
#endif
{
	int k;

	/* trick based on binary representation */

	if(n<=0 || (n & (n-1))!=0)
		return(-1);

	for(k = 0 ;  n >>= 1  ; ++k)
		;
	return(k);
}


 void
frrpl(Void)
{
	struct Rplblock *rp;

	while(rpllist)
	{
		rp = rpllist->rplnextp;
		free( (charptr) rpllist);
		rpllist = rp;
	}
}



/* Call a Fortran function with an arbitrary list of arguments */

int callk_kludge;

 expptr
#ifdef KR_headers
callk(type, name, args)
	int type;
	char *name;
	chainp args;
#else
callk(int type, char *name, chainp args)
#endif
{
	register expptr p;

	p = mkexpr(OPCALL,
		(expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
		(expptr)args);
	p->exprblock.vtype = type;
	return(p);
}



 expptr
#ifdef KR_headers
call4(type, name, arg1, arg2, arg3, arg4)
	int type;
	char *name;
	expptr arg1;
	expptr arg2;
	expptr arg3;
	expptr arg4;
#else
call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4)
#endif
{
	struct Listblock *args;
	args = mklist( mkchain((char *)arg1,
			mkchain((char *)arg2,
				mkchain((char *)arg3,
	    				mkchain((char *)arg4, CHNULL)) ) ) );
	return( callk(type, name, (chainp)args) );
}




 expptr
#ifdef KR_headers
call3(type, name, arg1, arg2, arg3)
	int type;
	char *name;
	expptr arg1;
	expptr arg2;
	expptr arg3;
#else
call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3)
#endif
{
	struct Listblock *args;
	args = mklist( mkchain((char *)arg1,
			mkchain((char *)arg2,
				mkchain((char *)arg3, CHNULL) ) ) );
	return( callk(type, name, (chainp)args) );
}





 expptr
#ifdef KR_headers
call2(type, name, arg1, arg2)
	int type;
	char *name;
	expptr arg1;
	expptr arg2;
#else
call2(int type, char *name, expptr arg1, expptr arg2)
#endif
{
	struct Listblock *args;

	args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
	return( callk(type,name, (chainp)args) );
}




 expptr
#ifdef KR_headers
call1(type, name, arg)
	int type;
	char *name;
	expptr arg;
#else
call1(int type, char *name, expptr arg)
#endif
{
	return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
}


 expptr
#ifdef KR_headers
call0(type, name)
	int type;
	char *name;
#else
call0(int type, char *name)
#endif
{
	return( callk(type, name, CHNULL) );
}



 struct Impldoblock *
#ifdef KR_headers
mkiodo(dospec, list)
	chainp dospec;
	chainp list;
#else
mkiodo(chainp dospec, chainp list)
#endif
{
	register struct Impldoblock *q;

	q = ALLOC(Impldoblock);
	q->tag = TIMPLDO;
	q->impdospec = dospec;
	q->datalist = list;
	return(q);
}




/* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
   memory error */

 ptr
#ifdef KR_headers
ckalloc(n)
	register int n;
#else
ckalloc(register int n)
#endif
{
	register ptr p;
	p = (ptr)calloc(1, (unsigned) n);
	if (p || !n)
		return(p);
	fprintf(stderr, "failing to get %d bytes\n",n);
	Fatal("out of memory");
	/* NOT REACHED */ return 0;
}


 int
#ifdef KR_headers
isaddr(p)
	register expptr p;
#else
isaddr(register expptr p)
#endif
{
	if(p->tag == TADDR)
		return(YES);
	if(p->tag == TEXPR)
		switch(p->exprblock.opcode)
		{
		case OPCOMMA:
			return( isaddr(p->exprblock.rightp) );

		case OPASSIGN:
		case OPASSIGNI:
		case OPPLUSEQ:
		case OPMINUSEQ:
		case OPSLASHEQ:
		case OPMODEQ:
		case OPLSHIFTEQ:
		case OPRSHIFTEQ:
		case OPBITANDEQ:
		case OPBITXOREQ:
		case OPBITOREQ:
			return( isaddr(p->exprblock.leftp) );
		}
	return(NO);
}



 int
#ifdef KR_headers
isstatic(p)
	register expptr p;
#else
isstatic(register expptr p)
#endif
{
	extern int useauto;
	if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
		return(NO);

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

	case TADDR:
		if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
		    ISCONST(p->addrblock.memoffset) && !useauto)
			return(YES);

	default:
		return(NO);
	}
}



/* addressable -- return True iff it is a constant value, or can be
   referenced by constant values */

 int
#ifdef KR_headers
addressable(p)
	register expptr p;
#else
addressable(register expptr p)
#endif
{
	switch(p->tag)
	{
	case TCONST:
		return(YES);

	case TADDR:
		return( addressable(p->addrblock.memoffset) );

	default:
		return(NO);
	}
}


/* isnegative_const -- returns true if the constant is negative.  Returns
   false for imaginary and nonnumeric constants */

 int
#ifdef KR_headers
isnegative_const(cp)
	struct Constblock *cp;
#else
isnegative_const(struct Constblock *cp)
#endif
{
    int retval;

    if (cp == NULL)
	return 0;

    switch (cp -> vtype) {
	case TYINT1:
        case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
	    retval = cp -> Const.ci < 0;
	    break;
	case TYREAL:
	case TYDREAL:
		retval = cp->vstg ? *cp->Const.cds[0] == '-'
				  :  cp->Const.cd[0] < 0.0;
	    break;
	default:

	    retval = 0;
	    break;
    } /* switch */

    return retval;
} /* isnegative_const */

 void
#ifdef KR_headers
negate_const(cp)
	Constp cp;
#else
negate_const(Constp cp)
#endif
{
    if (cp == (struct Constblock *) NULL)
	return;

    switch (cp -> vtype) {
	case TYINT1:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
	    cp -> Const.ci = - cp -> Const.ci;
	    break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
		if (cp->vstg)
		    switch(*cp->Const.cds[1]) {
			case '-':
				++cp->Const.cds[1];
				break;
			case '0':
				break;
			default:
				--cp->Const.cds[1];
			}
		else
	    		cp->Const.cd[1] = -cp->Const.cd[1];
		/* no break */
	case TYREAL:
	case TYDREAL:
		if (cp->vstg)
		    switch(*cp->Const.cds[0]) {
			case '-':
				++cp->Const.cds[0];
				break;
			case '0':
				break;
			default:
				--cp->Const.cds[0];
			}
		else
	    		cp->Const.cd[0] = -cp->Const.cd[0];
	    break;
	case TYCHAR:
	case TYLOGICAL1:
	case TYLOGICAL2:
	case TYLOGICAL:
	    erri ("negate_const:  can't negate type '%d'", cp -> vtype);
	    break;
	default:
	    erri ("negate_const:  bad type '%d'",
		    cp -> vtype);
	    break;
    } /* switch */
} /* negate_const */

 void
#ifdef KR_headers
ffilecopy(infp, outfp)
	FILE *infp;
	FILE *outfp;
#else
ffilecopy(FILE *infp, FILE *outfp)
#endif
{
    while (!feof (infp)) {
	register c = getc (infp);
	if (!feof (infp))
	putc (c, outfp);
    } /* while */
} /* ffilecopy */


/* in_vector -- verifies whether   str   is in c_keywords.
   If so, the index is returned else  -1  is returned.
   c_keywords must be in alphabetical order (as defined by strcmp).
*/

 int
#ifdef KR_headers
in_vector(str, keywds, n)
	char *str;
	char **keywds;
	register int n;
#else
in_vector(char *str, char **keywds, register int n)
#endif
{
	register char **K = keywds;
	register int n1, t;

	do {
		n1 = n >> 1;
		if (!(t = strcmp(str, K[n1])))
			return K - keywds + n1;
		if (t < 0)
			n = n1;
		else {
			n -= ++n1;
			K += n1;
			}
		}
		while(n > 0);

	return -1;
	} /* in_vector */


 int
#ifdef KR_headers
is_negatable(Const)
	Constp Const;
#else
is_negatable(Constp Const)
#endif
{
    int retval = 0;
    if (Const != (Constp) NULL)
	switch (Const -> vtype) {
	    case TYINT1:
		retval = Const -> Const.ci >= -BIGGEST_CHAR;
		break;
	    case TYSHORT:
	        retval = Const -> Const.ci >= -BIGGEST_SHORT;
	        break;
	    case TYLONG:
#ifdef TYQUAD
	    case TYQUAD:
#endif
	        retval = Const -> Const.ci >= -BIGGEST_LONG;
	        break;
	    case TYREAL:
	    case TYDREAL:
	    case TYCOMPLEX:
	    case TYDCOMPLEX:
	        retval = 1;
	        break;
	    case TYLOGICAL1:
	    case TYLOGICAL2:
	    case TYLOGICAL:
	    case TYCHAR:
	    case TYSUBR:
	    default:
	        retval = 0;
	        break;
	} /* switch */

    return retval;
} /* is_negatable */

 void
#ifdef KR_headers
backup(fname, bname)
	char *fname;
	char *bname;
#else
backup(char *fname, char *bname)
#endif
{
	FILE *b, *f;
	static char couldnt[] = "Couldn't open %.80s";

	if (!(f = fopen(fname, binread))) {
		warn1(couldnt, fname);
		return;
		}
	if (!(b = fopen(bname, binwrite))) {
		warn1(couldnt, bname);
		return;
		}
	ffilecopy(f, b);
	fclose(f);
	fclose(b);
	}


/* struct_eq -- returns YES if structures have the same field names and
   types, NO otherwise */

 int
#ifdef KR_headers
struct_eq(s1, s2)
	chainp s1;
	chainp s2;
#else
struct_eq(chainp s1, chainp s2)
#endif
{
    struct Dimblock *d1, *d2;
    Constp cp1, cp2;

    if (s1 == CHNULL && s2 == CHNULL)
	return YES;
    for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
	register Namep v1 = (Namep) s1 -> datap;
	register Namep v2 = (Namep) s2 -> datap;

	if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
		v2 == (Namep) NULL || v2 -> tag != TNAME)
	    return NO;

	if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
		|| strcmp(v1->fvarname, v2->fvarname))
	    return NO;

	/* compare dimensions (needed for comparing COMMON blocks) */

	if (d1 = v1->vdim) {
		if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST
		||  !(d2 = v2->vdim)
		||  !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
		||  cp1->Const.ci != cp2->Const.ci)
			return NO;
		}
	else if (v2->vdim)
		return NO;
    } /* while s1 != CHNULL && s2 != CHNULL */

    return s1 == CHNULL && s2 == CHNULL;
} /* struct_eq */