intr.c

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

/****************************************************************
Copyright 1990, 1992, 1994-5 by AT&T Bell Laboratories and Bellcore.

Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.

AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness.  In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/

#include "defs.h"
#include "names.h"

union
	{
	int ijunk;
	struct Intrpacked bits;
	} packed;

struct Intrbits
	{
	char intrgroup /* :3 */;
	char intrstuff /* result type or number of generics */;
	char intrno /* :7 */;
	char dblcmplx;
	char dblintrno;	/* for -r8 */
	};

/* List of all intrinsic functions.  */

LOCAL struct Intrblock
	{
	char intrfname[8];
	struct Intrbits intrval;
	} intrtab[ ] =
{
"int", 		{ INTRCONV, TYLONG },
"real", 	{ INTRCONV, TYREAL, 1 },
		/* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
"dble", 	{ INTRCONV, TYDREAL },
"cmplx", 	{ INTRCONV, TYCOMPLEX },
"dcmplx", 	{ INTRCONV, TYDCOMPLEX, 0, 1 },
"ifix", 	{ INTRCONV, TYLONG },
"idint", 	{ INTRCONV, TYLONG },
"float", 	{ INTRCONV, TYREAL },
"dfloat",	{ INTRCONV, TYDREAL },
"sngl", 	{ INTRCONV, TYREAL },
"ichar", 	{ INTRCONV, TYLONG },
"iachar", 	{ INTRCONV, TYLONG },
"char", 	{ INTRCONV, TYCHAR },
"achar", 	{ INTRCONV, TYCHAR },

/* any MAX or MIN can be used with any types; the compiler will cast them
   correctly.  So rules against bad syntax in these expressions are not
   enforced */

"max", 		{ INTRMAX, TYUNKNOWN },
"max0", 	{ INTRMAX, TYLONG },
"amax0", 	{ INTRMAX, TYREAL },
"max1", 	{ INTRMAX, TYLONG },
"amax1", 	{ INTRMAX, TYREAL },
"dmax1", 	{ INTRMAX, TYDREAL },

"and",		{ INTRBOOL, TYUNKNOWN, OPBITAND },
"or",		{ INTRBOOL, TYUNKNOWN, OPBITOR },
"xor",		{ INTRBOOL, TYUNKNOWN, OPBITXOR },
"not",		{ INTRBOOL, TYUNKNOWN, OPBITNOT },
"lshift",	{ INTRBOOL, TYUNKNOWN, OPLSHIFT },
"rshift",	{ INTRBOOL, TYUNKNOWN, OPRSHIFT },

"min", 		{ INTRMIN, TYUNKNOWN },
"min0", 	{ INTRMIN, TYLONG },
"amin0", 	{ INTRMIN, TYREAL },
"min1", 	{ INTRMIN, TYLONG },
"amin1", 	{ INTRMIN, TYREAL },
"dmin1", 	{ INTRMIN, TYDREAL },

"aint", 	{ INTRGEN, 2, 0 },
"dint", 	{ INTRSPEC, TYDREAL, 1 },

"anint", 	{ INTRGEN, 2, 2 },
"dnint", 	{ INTRSPEC, TYDREAL, 3 },

"nint", 	{ INTRGEN, 4, 4 },
"idnint", 	{ INTRGEN, 2, 6 },

"abs", 		{ INTRGEN, 6, 8 },
"iabs", 	{ INTRGEN, 2, 9 },
"dabs", 	{ INTRSPEC, TYDREAL, 11 },
"cabs", 	{ INTRSPEC, TYREAL, 12, 0, 13 },
"zabs", 	{ INTRSPEC, TYDREAL, 13, 1 },

"mod", 		{ INTRGEN, 4, 14 },
"amod", 	{ INTRSPEC, TYREAL, 16, 0, 17 },
"dmod", 	{ INTRSPEC, TYDREAL, 17 },

"sign", 	{ INTRGEN, 4, 18 },
"isign", 	{ INTRGEN, 2, 19 },
"dsign", 	{ INTRSPEC, TYDREAL, 21 },

"dim", 		{ INTRGEN, 4, 22 },
"idim", 	{ INTRGEN, 2, 23 },
"ddim", 	{ INTRSPEC, TYDREAL, 25 },

"dprod", 	{ INTRSPEC, TYDREAL, 26 },

"len", 		{ INTRSPEC, TYLONG, 27 },
"index", 	{ INTRSPEC, TYLONG, 29 },

"imag", 	{ INTRGEN, 2, 31 },
"aimag", 	{ INTRSPEC, TYREAL, 31, 0, 32 },
"dimag", 	{ INTRSPEC, TYDREAL, 32 },

"conjg", 	{ INTRGEN, 2, 33 },
"dconjg", 	{ INTRSPEC, TYDCOMPLEX, 34, 1 },

"sqrt", 	{ INTRGEN, 4, 35 },
"dsqrt", 	{ INTRSPEC, TYDREAL, 36 },
"csqrt", 	{ INTRSPEC, TYCOMPLEX, 37, 0, 38 },
"zsqrt", 	{ INTRSPEC, TYDCOMPLEX, 38, 1 },

"exp", 		{ INTRGEN, 4, 39 },
"dexp", 	{ INTRSPEC, TYDREAL, 40 },
"cexp", 	{ INTRSPEC, TYCOMPLEX, 41, 0, 42 },
"zexp", 	{ INTRSPEC, TYDCOMPLEX, 42, 1 },

"log", 		{ INTRGEN, 4, 43 },
"alog", 	{ INTRSPEC, TYREAL, 43, 0, 44 },
"dlog", 	{ INTRSPEC, TYDREAL, 44 },
"clog", 	{ INTRSPEC, TYCOMPLEX, 45, 0, 46 },
"zlog", 	{ INTRSPEC, TYDCOMPLEX, 46, 1 },

"log10", 	{ INTRGEN, 2, 47 },
"alog10", 	{ INTRSPEC, TYREAL, 47, 0, 48 },
"dlog10", 	{ INTRSPEC, TYDREAL, 48 },

"sin", 		{ INTRGEN, 4, 49 },
"dsin", 	{ INTRSPEC, TYDREAL, 50 },
"csin", 	{ INTRSPEC, TYCOMPLEX, 51, 0, 52 },
"zsin", 	{ INTRSPEC, TYDCOMPLEX, 52, 1 },

"cos", 		{ INTRGEN, 4, 53 },
"dcos", 	{ INTRSPEC, TYDREAL, 54 },
"ccos", 	{ INTRSPEC, TYCOMPLEX, 55, 0, 56 },
"zcos", 	{ INTRSPEC, TYDCOMPLEX, 56, 1 },

"tan", 		{ INTRGEN, 2, 57 },
"dtan", 	{ INTRSPEC, TYDREAL, 58 },

"asin", 	{ INTRGEN, 2, 59 },
"dasin", 	{ INTRSPEC, TYDREAL, 60 },

"acos", 	{ INTRGEN, 2, 61 },
"dacos", 	{ INTRSPEC, TYDREAL, 62 },

"atan", 	{ INTRGEN, 2, 63 },
"datan", 	{ INTRSPEC, TYDREAL, 64 },

"atan2", 	{ INTRGEN, 2, 65 },
"datan2", 	{ INTRSPEC, TYDREAL, 66 },

"sinh", 	{ INTRGEN, 2, 67 },
"dsinh", 	{ INTRSPEC, TYDREAL, 68 },

"cosh", 	{ INTRGEN, 2, 69 },
"dcosh", 	{ INTRSPEC, TYDREAL, 70 },

"tanh", 	{ INTRGEN, 2, 71 },
"dtanh", 	{ INTRSPEC, TYDREAL, 72 },

"lge",		{ INTRSPEC, TYLOGICAL, 73},
"lgt",		{ INTRSPEC, TYLOGICAL, 75},
"lle",		{ INTRSPEC, TYLOGICAL, 77},
"llt",		{ INTRSPEC, TYLOGICAL, 79},

#if 0
"epbase",	{ INTRCNST, 4, 0 },
"epprec",	{ INTRCNST, 4, 4 },
"epemin",	{ INTRCNST, 2, 8 },
"epemax",	{ INTRCNST, 2, 10 },
"eptiny",	{ INTRCNST, 2, 12 },
"ephuge",	{ INTRCNST, 4, 14 },
"epmrsp",	{ INTRCNST, 2, 18 },
#endif

"fpexpn",	{ INTRGEN, 4, 81 },
"fpabsp",	{ INTRGEN, 2, 85 },
"fprrsp",	{ INTRGEN, 2, 87 },
"fpfrac",	{ INTRGEN, 2, 89 },
"fpmake",	{ INTRGEN, 2, 91 },
"fpscal",	{ INTRGEN, 2, 93 },

"" };


LOCAL struct Specblock
	{
	char atype;		/* Argument type; every arg must have
				   this type */
	char rtype;		/* Result type */
	char nargs;		/* Number of arguments */
	char spxname[8];	/* Name of the function in Fortran */
	char othername;		/* index into callbyvalue table */
	} spectab[ ] =
{
	{ TYREAL,TYREAL,1,"r_int" },
	{ TYDREAL,TYDREAL,1,"d_int" },

	{ TYREAL,TYREAL,1,"r_nint" },
	{ TYDREAL,TYDREAL,1,"d_nint" },

	{ TYREAL,TYSHORT,1,"h_nint" },
	{ TYREAL,TYLONG,1,"i_nint" },

	{ TYDREAL,TYSHORT,1,"h_dnnt" },
	{ TYDREAL,TYLONG,1,"i_dnnt" },

	{ TYREAL,TYREAL,1,"r_abs" },
	{ TYSHORT,TYSHORT,1,"h_abs" },
	{ TYLONG,TYLONG,1,"i_abs" },
	{ TYDREAL,TYDREAL,1,"d_abs" },
	{ TYCOMPLEX,TYREAL,1,"c_abs" },
	{ TYDCOMPLEX,TYDREAL,1,"z_abs" },

	{ TYSHORT,TYSHORT,2,"h_mod" },
	{ TYLONG,TYLONG,2,"i_mod" },
	{ TYREAL,TYREAL,2,"r_mod" },
	{ TYDREAL,TYDREAL,2,"d_mod" },

	{ TYREAL,TYREAL,2,"r_sign" },
	{ TYSHORT,TYSHORT,2,"h_sign" },
	{ TYLONG,TYLONG,2,"i_sign" },
	{ TYDREAL,TYDREAL,2,"d_sign" },

	{ TYREAL,TYREAL,2,"r_dim" },
	{ TYSHORT,TYSHORT,2,"h_dim" },
	{ TYLONG,TYLONG,2,"i_dim" },
	{ TYDREAL,TYDREAL,2,"d_dim" },

	{ TYREAL,TYDREAL,2,"d_prod" },

	{ TYCHAR,TYSHORT,1,"h_len" },
	{ TYCHAR,TYLONG,1,"i_len" },

	{ TYCHAR,TYSHORT,2,"h_indx" },
	{ TYCHAR,TYLONG,2,"i_indx" },

	{ TYCOMPLEX,TYREAL,1,"r_imag" },
	{ TYDCOMPLEX,TYDREAL,1,"d_imag" },
	{ TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
	{ TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },

	{ TYREAL,TYREAL,1,"r_sqrt", 1 },
	{ TYDREAL,TYDREAL,1,"d_sqrt", 1 },
	{ TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },

	{ TYREAL,TYREAL,1,"r_exp", 2 },
	{ TYDREAL,TYDREAL,1,"d_exp", 2 },
	{ TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },

	{ TYREAL,TYREAL,1,"r_log", 3 },
	{ TYDREAL,TYDREAL,1,"d_log", 3 },
	{ TYCOMPLEX,TYCOMPLEX,1,"c_log" },
	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },

	{ TYREAL,TYREAL,1,"r_lg10" },
	{ TYDREAL,TYDREAL,1,"d_lg10" },

	{ TYREAL,TYREAL,1,"r_sin", 4 },
	{ TYDREAL,TYDREAL,1,"d_sin", 4 },
	{ TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },

	{ TYREAL,TYREAL,1,"r_cos", 5 },
	{ TYDREAL,TYDREAL,1,"d_cos", 5 },
	{ TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },

	{ TYREAL,TYREAL,1,"r_tan", 6 },
	{ TYDREAL,TYDREAL,1,"d_tan", 6 },

	{ TYREAL,TYREAL,1,"r_asin", 7 },
	{ TYDREAL,TYDREAL,1,"d_asin", 7 },

	{ TYREAL,TYREAL,1,"r_acos", 8 },
	{ TYDREAL,TYDREAL,1,"d_acos", 8 },

	{ TYREAL,TYREAL,1,"r_atan", 9 },
	{ TYDREAL,TYDREAL,1,"d_atan", 9 },

	{ TYREAL,TYREAL,2,"r_atn2", 10 },
	{ TYDREAL,TYDREAL,2,"d_atn2", 10 },

	{ TYREAL,TYREAL,1,"r_sinh", 11 },
	{ TYDREAL,TYDREAL,1,"d_sinh", 11 },

	{ TYREAL,TYREAL,1,"r_cosh", 12 },
	{ TYDREAL,TYDREAL,1,"d_cosh", 12 },

	{ TYREAL,TYREAL,1,"r_tanh", 13 },
	{ TYDREAL,TYDREAL,1,"d_tanh", 13 },

	{ TYCHAR,TYLOGICAL,2,"hl_ge" },
	{ TYCHAR,TYLOGICAL,2,"l_ge" },

	{ TYCHAR,TYLOGICAL,2,"hl_gt" },
	{ TYCHAR,TYLOGICAL,2,"l_gt" },

	{ TYCHAR,TYLOGICAL,2,"hl_le" },
	{ TYCHAR,TYLOGICAL,2,"l_le" },

	{ TYCHAR,TYLOGICAL,2,"hl_lt" },
	{ TYCHAR,TYLOGICAL,2,"l_lt" },

	{ TYREAL,TYSHORT,1,"hr_expn" },
	{ TYREAL,TYLONG,1,"ir_expn" },
	{ TYDREAL,TYSHORT,1,"hd_expn" },
	{ TYDREAL,TYLONG,1,"id_expn" },

	{ TYREAL,TYREAL,1,"r_absp" },
	{ TYDREAL,TYDREAL,1,"d_absp" },

	{ TYREAL,TYDREAL,1,"r_rrsp" },
	{ TYDREAL,TYDREAL,1,"d_rrsp" },

	{ TYREAL,TYREAL,1,"r_frac" },
	{ TYDREAL,TYDREAL,1,"d_frac" },

	{ TYREAL,TYREAL,2,"r_make" },
	{ TYDREAL,TYDREAL,2,"d_make" },

	{ TYREAL,TYREAL,2,"r_scal" },
	{ TYDREAL,TYDREAL,2,"d_scal" },
	{ 0 }
} ;

#if 0
LOCAL struct Incstblock
	{
	char atype;
	char rtype;
	char constno;
	} consttab[ ] =
{
	{ TYSHORT, TYLONG, 0 },
	{ TYLONG, TYLONG, 1 },
	{ TYREAL, TYLONG, 2 },
	{ TYDREAL, TYLONG, 3 },

	{ TYSHORT, TYLONG, 4 },
	{ TYLONG, TYLONG, 5 },
	{ TYREAL, TYLONG, 6 },
	{ TYDREAL, TYLONG, 7 },

	{ TYREAL, TYLONG, 8 },
	{ TYDREAL, TYLONG, 9 },

	{ TYREAL, TYLONG, 10 },
	{ TYDREAL, TYLONG, 11 },

	{ TYREAL, TYREAL, 0 },
	{ TYDREAL, TYDREAL, 1 },

	{ TYSHORT, TYLONG, 12 },
	{ TYLONG, TYLONG, 13 },
	{ TYREAL, TYREAL, 2 },
	{ TYDREAL, TYDREAL, 3 },

	{ TYREAL, TYREAL, 4 },
	{ TYDREAL, TYDREAL, 5 }
};
#endif

char *callbyvalue[ ] =
	{0,
	"sqrt",
	"exp",
	"log",
	"sin",
	"cos",
	"tan",
	"asin",
	"acos",
	"atan",
	"atan2",
	"sinh",
	"cosh",
	"tanh"
	};

 void
r8fix(Void)	/* adjust tables for -r8 */
{
	register struct Intrblock *I;
	register struct Specblock *S;

	for(I = intrtab; I->intrfname[0]; I++)
		if (I->intrval.intrgroup != INTRGEN)
		    switch(I->intrval.intrstuff) {
			case TYREAL:
				I->intrval.intrstuff = TYDREAL;
				I->intrval.intrno = I->intrval.dblintrno;
				break;
			case TYCOMPLEX:
				I->intrval.intrstuff = TYDCOMPLEX;
				I->intrval.intrno = I->intrval.dblintrno;
				I->intrval.dblcmplx = 1;
			}

	for(S = spectab; S->atype; S++)
	    switch(S->atype) {
		case TYCOMPLEX:
			S->atype = TYDCOMPLEX;
			if (S->rtype == TYREAL)
				S->rtype = TYDREAL;
			else if (S->rtype == TYCOMPLEX)
				S->rtype = TYDCOMPLEX;
			switch(S->spxname[0]) {
				case 'r':
					S->spxname[0] = 'd';
					break;
				case 'c':
					S->spxname[0] = 'z';
					break;
				default: