lex.c

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

			{
				erri("%dH too big", nh);
				nh = lastch - i;
				if (nh > MAXTOKENLEN)
					nh = MAXTOKENLEN;
				nh0 = -1;
			}
			j0[1] = MYQUOTE; /* special marker */
			j = j0 + 1;
			while(nh-- > 0)
			{
				if (++i > lastch) {
 hol_overflow:
					if (nh0 >= 0)
					  erri("escapes make %dH too big",
						nh0);
					break;
					}
				if(*i == '\\' && use_bs) {
					if (++i > lastch)
						goto hol_overflow;
					*i = escapes[*(unsigned char *)i];
					}
				*++j = *i;
			}
			j[1] = MYQUOTE;
			j+=2;
			prvstr = j;
		}
		else	{
			if(*i == '(') parseen = ++parlev;
			else if(*i == ')') --parlev;
			else if(parlev == 0)
				if(*i == '=') expeql = 1;
				else if(*i == ',') expcom = 1;
copychar:		/*not a string or space -- copy, shifting case if necessary */
			if(shiftcase && isupper(*i))
				*j++ = tolower(*i);
			else	*j++ = *i;
		}
	}
	lastch = j - 1;
	nextch = sbuf;
}

 LOCAL void
analyz(Void)
{
	register char *i;

	if(parlev != 0)
	{
		err("unbalanced parentheses, statement skipped");
		stkey = SUNKNOWN;
		lastch = sbuf - 1; /* prevent double error msg */
		return;
	}
	if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
	{
		/* assignment or if statement -- look at character after balancing paren */
		parlev = 1;
		for(i=nextch+3 ; i<=lastch; ++i)
			if(*i == (MYQUOTE))
			{
				while(*++i != MYQUOTE)
					;
			}
			else if(*i == '(')
				++parlev;
			else if(*i == ')')
			{
				if(--parlev == 0)
					break;
			}
		if(i >= lastch)
			stkey = SLOGIF;
		else if(i[1] == '=')
			stkey = SLET;
		else if( isdigit(i[1]) )
			stkey = SARITHIF;
		else	stkey = SLOGIF;
		if(stkey != SLET)
			nextch += 2;
	}
	else if(expeql) /* may be an assignment */
	{
		if(expcom && nextch<lastch &&
		    nextch[0]=='d' && nextch[1]=='o')
		{
			stkey = SDO;
			nextch += 2;
		}
		else	stkey = SLET;
	}
	else if (parseen && nextch + 7 < lastch
			&& nextch[2] != 'u' /* screen out "double..." early */
			&& nextch[0] == 'd' && nextch[1] == 'o'
			&& ((nextch[2] >= '0' && nextch[2] <= '9')
				|| nextch[2] == ','
				|| nextch[2] == 'w'))
		{
		stkey = SDO;
		nextch += 2;
		needwkey = 1;
		}
	/* otherwise search for keyword */
	else	{
		stkey = getkwd();
		if(stkey==SGOTO && lastch>=nextch)
			if(nextch[0]=='(')
				stkey = SCOMPGOTO;
			else if(isalpha_(* USC nextch))
				stkey = SASGOTO;
	}
	parlev = 0;
}



 LOCAL int
getkwd(Void)
{
	register char *i, *j;
	register struct Keylist *pk, *pend;
	int k;

	if(! isalpha_(* USC nextch) )
		return(SUNKNOWN);
	k = letter(nextch[0]);
	if(pk = keystart[k])
		for(pend = keyend[k] ; pk<=pend ; ++pk )
		{
			i = pk->keyname;
			j = nextch;
			while(*++i==*++j && *i!='\0')
				;
			if(*i=='\0' && j<=lastch+1)
			{
				nextch = j;
				if(no66flag && pk->notinf66)
					errstr("Not a Fortran 66 keyword: %s",
					    pk->keyname);
				return(pk->keyval);
			}
		}
	return(SUNKNOWN);
}

 void
initkey(Void)
{
	register struct Keylist *p;
	register int i,j;
	register char *s;

	for(i = 0 ; i<26 ; ++i)
		keystart[i] = NULL;

	for(p = keys ; p->keyname ; ++p) {
		j = letter(p->keyname[0]);
		if(keystart[j] == NULL)
			keystart[j] = p;
		keyend[j] = p;
		}
	i = (maxcontin + 2) * 66;
	sbuf = (char *)ckalloc(i + 70);
	send = sbuf + i;
	maxcont = maxcontin + 1;
	linestart = (char **)ckalloc(maxcont*sizeof(char*));
	comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] =
	comstart['#'] = 1;
#ifdef EOF_CHAR
	comstart[EOF_CHAR] = 1;
#endif
	s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
	while(i = *s++)
		anum_buf[i] = 1;
	s = "0123456789";
	while(i = *s++)
		anum_buf[i] = 2;
	}

 LOCAL int
#ifdef KR_headers
hexcheck(key)
	int key;
#else
hexcheck(int key)
#endif
{
	register int radix;
	register char *p;
	char *kind;

	switch(key) {
		case 'z':
		case 'Z':
		case 'x':
		case 'X':
			radix = 16;
			key = SHEXCON;
			kind = "hexadecimal";
			break;
		case 'o':
		case 'O':
			radix = 8;
			key = SOCTCON;
			kind = "octal";
			break;
		case 'b':
		case 'B':
			radix = 2;
			key = SBITCON;
			kind = "binary";
			break;
		default:
			err("bad bit identifier");
			return(SNAME);
		}
	for(p = token; *p; p++)
		if (hextoi(*p) >= radix) {
			errstr("invalid %s character", kind);
			break;
			}
	return key;
	}

/* gettok -- moves the right amount of text from   nextch   into the   token
   buffer.   token   initially contains garbage (leftovers from the prev token) */

 LOCAL int
gettok(Void)
{
	int havdot, havexp, havdbl;
	int radix, val;
	struct Punctlist *pp;
	struct Dotlist *pd;
	register int ch;

	char *i, *j, *n1, *p;

	ch = * USC nextch;
	if(ch == (MYQUOTE))
	{
		++nextch;
		p = token;
		while(*nextch != MYQUOTE)
			*p++ = *nextch++;
		toklen = p - token;
		*p = 0;
		/* allow octal, binary, hex constants of the form 'abc'x (etc.) */
		if (++nextch <= lastch && isalpha_(val = * USC nextch)) {
			++nextch;
			return hexcheck(val);
			}
		return (SHOLLERITH);
	}

	if(needkwd)
	{
		needkwd = 0;
		return( getkwd() );
	}

	for(pp=puncts; pp->punchar; ++pp)
		if(ch == pp->punchar) {
			val = pp->punval;
			if (++nextch <= lastch)
			    switch(ch) {
				case '/':
					if (*nextch == '/') {
						nextch++;
						val = SCONCAT;
						}
					else if (new_dcl && parlev == 0)
						val = SSLASHD;
					return val;
				case '*':
					if (*nextch == '*') {
						nextch++;
						return SPOWER;
						}
					break;
				case '<':
					if (*nextch == '=') {
						nextch++;
						val = SLE;
						}
					if (*nextch == '>') {
						nextch++;
						val = SNE;
						}
					goto extchk;
				case '=':
					if (*nextch == '=') {
						nextch++;
						val = SEQ;
						goto extchk;
						}
					break;
				case '>':
					if (*nextch == '=') {
						nextch++;
						val = SGE;
						}
 extchk:
					NOEXT("Fortran 8x comparison operator");
					return val;
				}
			else if (ch == '/' && new_dcl && parlev == 0)
				return SSLASHD;
			switch(val) {
				case SLPAR:
					++parlev;
					break;
				case SRPAR:
					--parlev;
				}
			return(val);
			}
	if(ch == '.')
		if(nextch >= lastch) goto badchar;
		else if(isdigit(nextch[1])) goto numconst;
		else	{
			for(pd=dots ; (j=pd->dotname) ; ++pd)
			{
				for(i=nextch+1 ; i<=lastch ; ++i)
					if(*i != *j) break;
					else if(*i != '.') ++j;
					else	{
						nextch = i+1;
						return(pd->dotval);
					}
			}
			goto badchar;
		}
	if( isalpha_(ch) )
	{
		p = token;
		*p++ = *nextch++;
		while(nextch<=lastch)
			if( isalnum_(* USC nextch) )
				*p++ = *nextch++;
			else break;
		toklen = p - token;
		*p = 0;
		if (needwkey) {
			needwkey = 0;
			if (toklen == 5
				&& nextch <= lastch && *nextch == '(' /*)*/
				&& !strcmp(token,"while"))
			return(SWHILE);
			}
		if(inioctl && nextch<=lastch && *nextch=='=')
		{
			++nextch;
			return(SNAMEEQ);
		}
		if(toklen>8 && eqn(8,token,"function")
		&& isalpha_(* USC (token+8)) &&
		    nextch<lastch && nextch[0]=='(' &&
		    (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
		{
			nextch -= (toklen - 8);
			return(SFUNCTION);
		}

		if(toklen > 50)
		{
			char buff[100];
			sprintf(buff, toklen >= 60
				? "name %.56s... too long, truncated to %.*s"
				: "name %s too long, truncated to %.*s",
			    token, 50, token);
			err(buff);
			toklen = 50;
			token[50] = '\0';
		}
		if(toklen==1 && *nextch==MYQUOTE) {
			val = token[0];
			++nextch;
			for(p = token ; *nextch!=MYQUOTE ; )
				*p++ = *nextch++;
			++nextch;
			toklen = p - token;
			*p = 0;
			return hexcheck(val);
		}
		return(SNAME);
	}

	if (isdigit(ch)) {

		/* Check for NAG's special hex constant */

		if (nextch[1] == '#' && nextch < lastch
		||  nextch[2] == '#' && isdigit(nextch[1]
				     && lastch - nextch >= 2)) {

		    radix = atoi (nextch);
		    if (*++nextch != '#')
			nextch++;
		    if (radix != 2 && radix != 8 && radix != 16) {
		        erri("invalid base %d for constant, defaulting to hex",
				radix);
			radix = 16;
		    } /* if */
		    if (++nextch > lastch)
			goto badchar;
		    for (p = token; hextoi(*nextch) < radix;) {
			*p++ = *nextch++;
			if (nextch > lastch)
				break;
			}
		    toklen = p - token;
		    *p = 0;
		    return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
			    SBITCON);
		    }
		}
	else
		goto badchar;
numconst:
	havdot = NO;
	havexp = NO;
	havdbl = NO;
	for(n1 = nextch ; nextch<=lastch ; ++nextch)
	{
		if(*nextch == '.')
			if(havdot) break;
			else if(nextch+2<=lastch && isalpha_(* USC (nextch+1))
			    && isalpha_(* USC (nextch+2)))
				break;
			else	havdot = YES;
		else if( !intonly && (*nextch=='d' || *nextch=='e') )
		{
			p = nextch;
			havexp = YES;
			if(*nextch == 'd')
				havdbl = YES;
			if(nextch<lastch)
				if(nextch[1]=='+' || nextch[1]=='-')
					++nextch;
			if( ! isdigit(*++nextch) )
			{
				nextch = p;
				havdbl = havexp = NO;
				break;
			}
			for(++nextch ;
			    nextch<=lastch && isdigit(* USC nextch);
			    ++nextch);
			break;
		}
		else if( ! isdigit(* USC nextch) )
			break;
	}
	p = token;
	i = n1;
	while(i < nextch)
		*p++ = *i++;
	toklen = p - token;
	*p = 0;
	if(havdbl) return(SDCON);
	if(havdot || havexp) return(SRCON);
	return(SICON);
badchar:
	sbuf[0] = *nextch++;
	return(SUNKNOWN);
}

/* Comment buffering code */

 static void
#ifdef KR_headers
store_comment(str)
	char *str;
#else
store_comment(char *str)
#endif
{
	int len;
	comment_buf *ncb;

	if (nextcd == sbuf) {
		flush_comments();
		p1_comment(str);
		return;
		}
	len = strlen(str) + 1;
	if (cbnext + len > cblast) {
		if (!cbcur || !(ncb = cbcur->next)) {
			ncb = (comment_buf *) Alloc(sizeof(comment_buf));
			if (cbcur) {
				cbcur->last = cbnext;
				cbcur->next = ncb;
				}
			else {
				cbfirst = ncb;
				cbinit = ncb->buf;
				}
			ncb->next = 0;
			}
		cbcur = ncb;
		cbnext = ncb->buf;
		cblast = cbnext + COMMENT_BUF_STORE;
		}
	strcpy(cbnext, str);
	cbnext += len;
	}

 static void
flush_comments(Void)
{
	register char *s, *s1;
	register comment_buf *cb;
	if (cbnext == cbinit)
		return;
	cbcur->last = cbnext;
	for(cb = cbfirst;; cb = cb->next) {
		for(s = cb->buf; s < cb->last; s = s1) {
			/* compute s1 = new s value first, since */
			/* p1_comment may insert nulls into s */
			s1 = s + strlen(s) + 1;
			p1_comment(s);
			}
		if (cb == cbcur)
			break;
		}
	cbcur = cbfirst;
	cbnext = cbinit;
	cblast = cbnext + COMMENT_BUF_STORE;
	}

 void
unclassifiable(Void)
{
	register char *s, *se;

	s = sbuf;
	se = lastch;
	if (se < sbuf)
		return;
	lastch = s - 1;
	if (se - s > 10)
		se = s + 10;
	for(; s < se; s++)
		if (*s == MYQUOTE) {
			se = s;
			break;
			}
	*se = 0;
	errstr("unclassifiable statement (starts \"%s\")", sbuf);
	}