pread.c

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

		case 'l':
			if (!strcmp(Ptok+1, "ogical")) {
				checklogical(1);
				return TYLOGICAL;
				}
			if (!strcmp(Ptok+1, "ogical1"))
				return TYLOGICAL1;
#ifdef TYQUAD
			if (!strcmp(Ptok+1, "ongint"))
				return TYQUAD;
#endif
			break;
		case 'r':
			if (!strcmp(Ptok+1, "eal")) {
				checkreal(0);
				return TYREAL;
				}
			break;
		case 's':
			if (!strcmp(Ptok+1, "hortint"))
				return TYSHORT;
			if (!strcmp(Ptok+1, "hortlogical")) {
				checklogical(0);
				return TYLOGICAL2;
				}
			break;
		}
	bad_type();
	/* NOT REACHED */
	return 0;
	}

 static void
#ifdef KR_headers
wanted(i, what)
	int i;
	char *what;
#else
wanted(int i, char *what)
#endif
{
	if (i != P_anum) {
		Ptok[0] = i;
		Ptok[1] = 0;
		}
	fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n",
		what, Ptok, Plineno, Pfname);
	exit(2);
	}

 static int
#ifdef KR_headers
Ptype(pf)
	FILE *pf;
#else
Ptype(FILE *pf)
#endif
{
	int i, rv;

	i = Ptoken(pf,0);
	if (i == ')')
		return 0;
	if (i != P_anum)
		badchar(i);

	rv = 0;
	switch(Ptok[0]) {
		case 'C':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYCOMPLEX+200;
			break;
		case 'D':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYDREAL+200;
			break;
		case 'E':
		case 'R':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYREAL+200;
			break;
		case 'H':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYCHAR+200;
			break;
		case 'I':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYLONG+200;
			else if (!strcmp(Ptok+1, "1_fp"))
				rv = TYINT1+200;
#ifdef TYQUAD
			else if (!strcmp(Ptok+1, "8_fp"))
				rv = TYQUAD+200;
#endif
			break;
		case 'J':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYSHORT+200;
			break;
		case 'K':
			checklogical(0);
			goto Logical;
		case 'L':
			checklogical(1);
 Logical:
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYLOGICAL+200;
			else if (!strcmp(Ptok+1, "1_fp"))
				rv = TYLOGICAL1+200;
			else if (!strcmp(Ptok+1, "2_fp"))
				rv = TYLOGICAL2+200;
			break;
		case 'S':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYSUBR+200;
			break;
		case 'U':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYUNKNOWN+300;
			break;
		case 'Z':
			if (!strcmp(Ptok+1, "_fp"))
				rv = TYDCOMPLEX+200;
			break;
		case 'c':
			if (!strcmp(Ptok+1, "har"))
				rv = TYCHAR;
			else if (!strcmp(Ptok+1, "omplex"))
				rv = TYCOMPLEX;
			break;
		case 'd':
			if (!strcmp(Ptok+1, "oublereal"))
				rv = TYDREAL;
			else if (!strcmp(Ptok+1, "oublecomplex"))
				rv = TYDCOMPLEX;
			break;
		case 'f':
			if (!strcmp(Ptok+1, "tnlen"))
				rv = TYFTNLEN+100;
			break;
		case 'i':
			if (!strncmp(Ptok+1, "nteger", 6)) {
				if (!Ptok[7])
					rv = TYLONG;
				else if (Ptok[7] == '1' && !Ptok[8])
					rv = TYINT1;
				}
			break;
		case 'l':
			if (!strncmp(Ptok+1, "ogical", 6)) {
				if (!Ptok[7]) {
					checklogical(1);
					rv = TYLOGICAL;
					}
				else if (Ptok[7] == '1' && !Ptok[8])
					rv = TYLOGICAL1;
				}
#ifdef TYQUAD
			else if (!strcmp(Ptok+1,"ongint"))
				rv = TYQUAD;
#endif
			break;
		case 'r':
			if (!strcmp(Ptok+1, "eal"))
				rv = TYREAL;
			break;
		case 's':
			if (!strcmp(Ptok+1, "hortint"))
				rv = TYSHORT;
			else if (!strcmp(Ptok+1, "hortlogical")) {
				checklogical(0);
				rv = TYLOGICAL2;
				}
			break;
		case 'v':
			if (tnext == tfirst && !strcmp(Ptok+1, "oid")) {
				if ((i = Ptoken(pf,0)) != /*(*/ ')')
					wanted(i, /*(*/ "\")\"");
				return 0;
				}
		}
	if (!rv)
		bad_type();
	if (rv < 100 && (i = Ptoken(pf,0)) != '*')
			wanted(i, "\"*\"");
	if ((i = Ptoken(pf,0)) == P_anum)
		i = Ptoken(pf,0);	/* skip variable name */
	switch(i) {
		case ')':
			ungetc(i,pf);
			break;
		case ',':
			break;
		default:
			wanted(i, "\",\" or \")\"");
		}
	return rv;
	}

 static char *
trimunder(Void)
{
	register char *s;
	register int n;
	static char buf[128];

	s = Ptok + strlen(Ptok) - 1;
	if (*s != '_') {
		fprintf(stderr,
			"warning: %s does not end in _ (line %ld of %s)\n",
			Ptok, Plineno, Pfname);
		return Ptok;
		}
	if (s[-1] == '_')
		s--;
	strncpy(buf, Ptok, n = s - Ptok);
	buf[n] = 0;
	return buf;
	}

 static void
#ifdef KR_headers
Pbadmsg(msg, p)
	char *msg;
	Extsym *p;
#else
Pbadmsg(char *msg, Extsym *p)
#endif
{
	Pbad++;
	fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
		p->fextname, Plineno, Pfname);
	p->arginfo->nargs = -1;
	}

 static void
#ifdef KR_headers
Pbadret(ftype, p)
	int ftype;
	Extsym *p;
#else
Pbadret(int ftype, Extsym *p)
#endif
{
	char buf1[32], buf2[32];

	Pbadmsg("inconsistent types",p);
	fprintf(stderr, "here %s, previously %s\n",
		Argtype(ftype+200,buf1),
		Argtype(p->extype+200,buf2));
	}

 static void
#ifdef KR_headers
argverify(ftype, p)
	int ftype;
	Extsym *p;
#else
argverify(int ftype, Extsym *p)
#endif
{
	Argtypes *at;
	register Atype *aty;
	int i, j, k;
	register int *t, *te;
	char buf1[32], buf2[32];

	at = p->arginfo;
	if (at->nargs < 0)
		return;
	if (p->extype != ftype) {
		Pbadret(ftype, p);
		return;
		}
	t = tfirst;
	te = tnext;
	i = te - t;
	if (at->nargs != i) {
		j = at->nargs;
		Pbadmsg("differing numbers of arguments",p);
		fprintf(stderr, "here %d, previously %d\n",
			i, j);
		return;
		}
	for(aty = at->atypes; t < te; t++, aty++) {
		if (*t == aty->type)
			continue;
		j = aty->type;
		k = *t;
		if (k >= 300 || k == j)
			continue;
		if (j >= 300) {
			if (k >= 200) {
				if (k == TYUNKNOWN + 200)
					continue;
				if (j % 100 != k - 200
				 && k != TYSUBR + 200
				 && j != TYUNKNOWN + 300
				 && !type_fixup(at,aty,k))
					goto badtypes;
				}
			else if (j % 100 % TYSUBR != k % TYSUBR
					&& !type_fixup(at,aty,k))
				goto badtypes;
			}
		else if (k < 200 || j < 200)
			goto badtypes;
		else if (k == TYUNKNOWN+200)
			continue;
		else if (j != TYUNKNOWN+200)
			{
 badtypes:
			Pbadmsg("differing calling sequences",p);
			i = t - tfirst + 1;
			fprintf(stderr,
				"arg %d: here %s, prevously %s\n",
				i, Argtype(k,buf1), Argtype(j,buf2));
			return;
			}
		/* We've subsequently learned the right type,
		   as in the call on zoo below...

			subroutine foo(x, zap)
			external zap
			call goo(zap)
			x = zap(3)
			call zoo(zap)
			end
		 */
		aty->type = k;
		at->changes = 1;
		}
	}

 static void
#ifdef KR_headers
newarg(ftype, p)
	int ftype;
	Extsym *p;
#else
newarg(int ftype, Extsym *p)
#endif
{
	Argtypes *at;
	register Atype *aty;
	register int *t, *te;
	int i, k;

	if (p->extstg == STGCOMMON) {
		Pnotboth(p);
		return;
		}
	p->extstg = STGEXT;
	p->extype = ftype;
	p->exproto = 1;
	t = tfirst;
	te = tnext;
	i = te - t;
	k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
	at = p->arginfo = (Argtypes *)gmem(k,1);
	at->dnargs = at->nargs = i;
	at->defined = at->changes = 0;
	for(aty = at->atypes; t < te; aty++) {
		aty->type = *t++;
		aty->cp = 0;
		}
	}

 static int
#ifdef KR_headers
Pfile(fname)
	char *fname;
#else
Pfile(char *fname)
#endif
{
	char *s;
	int ftype, i;
	FILE *pf;
	Extsym *p;

	for(s = fname; *s; s++);
	if (s - fname < 2
	|| s[-2] != '.'
	|| (s[-1] != 'P' && s[-1] != 'p'))
		return 0;

	if (!(pf = fopen(fname, textread))) {
		fprintf(stderr, "can't open %s\n", fname);
		exit(2);
		}
	Pfname = fname;
	Plineno = 1;
	if (!Pct[' ']) {
		for(s = " \t\n\r\v\f"; *s; s++)
			Pct[*s] = P_space;
		for(s = "*,();"; *s; s++)
			Pct[*s] = P_delim;
		for(i = '0'; i <= '9'; i++)
			Pct[i] = P_anum;
		for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++)
			Pct[i] = Pct[i+'A'-'a'] = P_anum;
		Pct['_'] = P_anum;
		Pct['/'] = P_slash;
		}

	for(;;) {
		if (!(i = Ptoken(pf,1)))
			break;
		if (i != P_anum
		|| !strcmp(Ptok, "extern") && (i = Ptoken(pf,0)) != P_anum)
			badchar(i);
		ftype = Pftype();
 getname:
		if ((i = Ptoken(pf,0)) != P_anum)
			badchar(i);
		p = mkext1(trimunder(), Ptok);

		if ((i = Ptoken(pf,0)) != '(')
			badchar(i);
		tnext = tfirst;
		while(i = Ptype(pf)) {
			if (tnext >= tlast)
				trealloc();
			*tnext++ = i;
			}
		if (p->arginfo) {
			argverify(ftype, p);
			if (p->arginfo->nargs < 0)
				newarg(ftype, p);
			}
		else
			newarg(ftype, p);
		p->arginfo->defined = 1;
		i = Ptoken(pf,0);
		switch(i) {
			case ';':
				break;
			case ',':
				goto getname;
			default:
				wanted(i, "\";\" or \",\"");
			}
		}
	fclose(pf);
	return 1;
	}

 void
#ifdef KR_headers
read_Pfiles(ffiles)
	char **ffiles;
#else
read_Pfiles(char **ffiles)
#endif
{
	char **f1files, **f1files0, *s;
	int k;
	register Extsym *e, *ee;
	register Argtypes *at;
	extern int retcode;

	f1files0 = f1files = ffiles;
	while(s = *ffiles++)
		if (!Pfile(s))
			*f1files++ = s;
	if (Pbad)
		retcode = 8;
	if (tfirst) {
		free((char *)tfirst);
		/* following should be unnecessary, as we won't be back here */
		tfirst = tnext = tlast = 0;
		tmax = 0;
		}
	*f1files = 0;
	if (f1files == f1files0)
		f1files[1] = 0;

	k = 0;
	ee = nextext;
	for (e = extsymtab; e < ee; e++)
		if (e->extstg == STGEXT
		&& (at = e->arginfo)) {
			if (at->nargs < 0 || at->changes)
				k++;
			at->changes = 2;
			}
	if (k) {
		fprintf(diagfile,
		"%d prototype%s updated while reading prototypes.\n", k,
			k > 1 ? "s" : "");
		}
	fflush(diagfile);
	}