lex.c

变尺度法的源程序

			st_move1(curtok->val);
			*endp++ = (char)c;
			if (flimpl) {
				flimpl--;
			}
			if (flformat) {
				flformat--;
			}
			break;
	case ',':	curtok->val = TK_COMMA;
			st_move1(curtok->val);
			*endp++ = (char)c;
			if (flimpl == 1) {
				st_move1(TK_IMPLICIT);
			}
			break;
	case '-':	curtok->val = TK_MINUS;
			st_move1(curtok->val);
			*endp++ = (char)c;
			break;
	case ';':	curtok->val = TK_SCLN;
			st_move1(curtok->val);
			*endp++ = (char)c;
			if (!f77fl) {
				onequalsym = NULL;	/* they are stoppers */
				flimpl = 0;
				flformat = 0;
			}
			break;
	case '*':	*endp++ = (char)c;
			c = getsym(lmode);
			if (c == '*') 
				*endp++ = (char)c;
			else {
				curtok->val = TK_STAR;
				ungetsym(c);
			}
			st_move1(curtok->val);
			break;
	case '|':	
	case '&':	*endp++ = (char)c;
			c0 = c;
			c = getsym(lmode);
			if (c == c0) 
				*endp++ = (char)c;
			else
				ungetsym(c);
			st_move1(curtok->val);
			break;
	case '!':
	case '=':	*endp++ = (char)c;
			if (c == '=' && onequalsym) {
				set_pos(onequalline);
				fppmess(WARN_PINSUB,symname(onequalsym));
				onequalsym = NULL;
			}
			c = getsym(lmode);
			if (c == '=') 
				*endp++ = (char)c;
			else
				ungetsym(c);
			st_move1(curtok->val);
			break;
	case '<':
	case '>':	*endp++ = (char)c;
			c0 = c;
			c = getsym(lmode);
			if (c == c0 || c == '=')
				*endp++ = (char)c;
			else
				ungetsym(c);
			st_move1(curtok->val);
			break;
	case '.':	*endp++ = (char)c;
			if (!f77fl) {
				if (!fllogic || fllogic == 2) fllogic++;
			}
			*endp = 0;
			st_move1(curtok->val);
			break;
	case '"':
	case '\'':	c0 = c;
			*endp++ = (char)c;
			if (c0 == '\'' && st_is(ST_RDWR)) 	/* READ(10'3) syntax exception */
				break;
			for (;;) {
				c = getsym((mode&MOD_CONT)|MOD_RAW);
				if (c=='\n' || c==SYM_EOF || c==SYM_EOC) {
					ungetsym(c);
					if (falselvl == 0 && c != SYM_EOC)
						fppmess(ERR_STR,c0);
					if (mode & MOD_FPP) 
						*endp++ = (char)c0;
					break;
				}
				else if (c == c0) {
					*endp++ = (char)c;
					break;
				}
				else if (is_special(c))
					c = ' ';
				*endp++ = (char)c;
				if (endp - curtok->token >= MAXTOKENSIZE) {
					curtok->length = MAXTOKENSIZE;
					outtok(curtok);
					endp = curtok->token;
				}
			}
			if (fixedformfl && c0 == '\'') {
				c = getsym(lmode);
				if (lowcase(c) == 'o' || lowcase(c) == 'x') {
					curtok->val = TK_BOZ;
					*endp++ = (char)c;
				}
				else
					ungetsym(c);
			}
			st_move1(curtok->val);
			break;
	case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
	case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
	case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U': 
	case 'V': case 'W': case 'X': case 'Y': case 'Z':
	case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
	case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
	case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': 
	case 'v': case 'w': case 'x': case 'y': case 'z': case '_':

                       	/* Check if we are dealing with *kind* of a logical constant
			 * which should be taken without the leading underscore
			 */
			if (!f77fl && c == '_' && fllogic == 3) {
				*endp++ = (char)c;
				*endp = 0;
				fllogic = 0;
				goto exit;
			}

			/* Collect a name */
			while (is_alphanum(c)) {
				*endp++ = (char)c;
				if (endp - curtok->token >= MAXTOKENSIZE) {
					curtok->length = MAXTOKENSIZE;
					outtok(curtok);
					endp = curtok->token;
				}
				c = getsym(lmode);
			}
			*endp = 0;
			ungetsym(c);
			if ((lmode & MOD_SPACE) && line > sym_line) {
			        while (sym_line < line) {
				        ungetsym('\n'); /* it decreases the line */
					ungetsym('\\');
				}
			}

			/* Check if we are dealing with a BOZ constant
			 */
			if (c == '\'' || c== '"') {
				if ((endp - curtok->token) == 1) { 
				 	if (lowcase(curtok->token[0]) == 'b' ||
					    lowcase(curtok->token[0]) == 'o' ||
					    lowcase(curtok->token[0]) == 'z') {
						curtok->val = TK_BOZ;
						goto exit;
					}
					if (fixedformfl && lowcase(curtok->token[0]) == 'x') {
						curtok->val = TK_BOZ;
						goto exit;
					}
				}
				else if (!f77fl && endp[-1] == '_') {
					ungetsym(*--endp);
					*endp = 0;
				}
			}

			curtok->val = TK_NAME;
			if ((outfl || falselvl || !substfl) && !dosubstfl) {

			        /* The following is for syntax like WRITE(10'3), etc.
				 */
				if (fixedformfl && st_is(ST_BOS)) {
					symp = symget(curtok->token,CL_KEY);
					if (symp)
						curtok->val = get_tkop(symp);
				}
			}
			else {
				int	n;
				
				if (!(mode & MOD_SPACE)) {
					if (st_is(ST_BOS)) 
						symp = symget(curtok->token,CL_NM|CL_KEY);
					else if (st_is(ST_IMPL0)) {
						symp = symget(curtok->token,CL_NM|CL_KEY);
						if (symp && (symtype(symp) & CL_KEY)) {
							curtok->val = get_tkop(symp);
							if (curtok->val != TK_TYPE0 && 
							    curtok->val != TK_TYPE ) {
								curtok->val = TK_NAME;
								symp = NULL;
							}
						}
					}
					else
						symp = symget(curtok->token,CL_NM);
					if ((endp - curtok->token) == 1 && st_is(ST_IMPL))
						curtok->val = TK_NAME0;
					if (symp) {
						if (symtype(symp) & CL_NM) {
							if (curtok->val == TK_NAME0) {
								fppmess(WARN_IMPL,curtok->token);
							}
							else if (flformat > 1 && isfspec(curtok->token)) {
								fppmess(WARN_FORMAT,curtok->token);
							}
							else if (substitute(symp, lmode)) {
								st_move1(curtok->val);
								goto exit;
							}
							else goto loop;
						}
						else {
							curtok->val = get_tkop(symp);
							if (curtok->val == TK_IMPLICIT)
								flimpl = 1;
							else if (curtok->val == TK_FORMAT)
								flformat = 1;
						}
					}
				}
				else {
					if (st_is(ST_BOS)) {
						symp = symgetm(curtok->token,CL_NM|CL_KEY);
						if (symp) {
							n = strlen(symname(symp));
							if (n < endp - curtok->token && n < MAXNAMELEN) {
								if (symtype(symp) & CL_NM && !onequalsym) { 
									onequalsym = symp;
									onequalline = curtok->lineno;
								}
								ungetstr(curtok->token+n, 
									 (endp - curtok->token) - n);
								ungetsym(SYM_DUMMY);
								endp = curtok->token + n;
								*endp = 0;
							}
							if (symtype(symp) & CL_NM) {
								if (symflag(symp)) 
									fppmess(WARN_PINSUB,curtok->token);
								if (substitute(symp, lmode)) {
									st_move1(curtok->val);
									goto exit;
								}
								else goto loop;
							}
							else {
								curtok->val = get_tkop(symp);
								if (curtok->val == TK_IMPLICIT)
									flimpl = 1;
								else if (curtok->val == TK_FORMAT)
									flformat = 1;
							}
						}
					}
					else if (st_is(ST_DO) || st_is(ST_ASSIGN)) {
						symp = symgetm(curtok->token,CL_NM);
						if (symp) {
							n = strlen(symname(symp));
							ungetstr(curtok->token + n,
								 (endp - curtok->token) - n);
							ungetsym(SYM_DUMMY);
							endp = curtok->token + n;
							*endp = 0;
							if (substitute(symp, lmode)) {
								st_move1(curtok->val);
								goto exit;
							}
							else goto loop;
						}
						if (st_is(ST_DO))
							fppmess(WARN_PIOP,"do");
						else
							fppmess(WARN_PIOP,"assign");
						curtok->val = TK_DUMMY;
					}
					else if (st_is(ST_ASSIGNUM)) {
						if (!strncmp(curtok->token,"to",2)) {
							ungetstr(curtok->token+2,
								 (endp - curtok->token) - 2);
							ungetsym(SYM_DUMMY);
							endp = curtok->token+2;
							*endp = 0;
							curtok->val = TK_DUMMY;
						}
						else {
							symp = symgetm(curtok->token,CL_NM);
							if (symp) {
								if (substitute(symp, lmode)) {
									st_move1(curtok->val);
									goto exit;
								}
								else goto loop;
							}
							fppmess(WARN_PIOP,"assign");
							curtok->val = TK_DUMMY;
						}
					}
					else if (st_is(ST_TYPE1)) {
						if (!strncmp(curtok->token,"function",8)) {
							ungetstr(curtok->token+8,
								 (endp - curtok->token) - 8);
							ungetsym(SYM_DUMMY);
							endp = curtok->token+8;
							*endp = 0;
							curtok->val = TK_KEY;
						}
						else if (!strncmp(curtok->token,"recursive",9)) {
							ungetstr(curtok->token+9,
								 (endp - curtok->token) - 9);
							ungetsym(SYM_DUMMY);
							endp = curtok->token+9;
							*endp = 0;
							curtok->val = TK_KEY;
						}
						else {
							symp = symgetm(curtok->token,CL_NM);
							if (symp) {
								if (substitute(symp, lmode)) {
									st_move1(curtok->val);
									goto exit;
								}
								else goto loop;
							}
						}
					}
					else if (st_is(ST_IMPL0)) {
						symp = symget(curtok->token,CL_KEY|CL_NM);
						if (symp) {
							if (symtype(symp) & CL_KEY) {
								curtok->val = get_tkop(symp);
								if (curtok->val != TK_TYPE &&
								    curtok->val != TK_TYPE0)
									curtok->val = TK_NAME;
							}
							else if (substitute(symp, lmode)) {
								st_move1(curtok->val);
								goto exit;
							}
							else goto loop;
						}
					}
					else {
						if (endp - curtok->token == 1 && st_is(ST_IMPL))
							curtok->val = TK_NAME0;
						if (symp = symget(curtok->token,CL_NM)) {
							if (curtok->val == TK_NAME0) {
								fppmess(WARN_IMPL,curtok->token);
							}
							else if (flformat > 1 && isfspec(curtok->token)) {
								fppmess(WARN_FORMAT,curtok->token);
							}
							else if (substitute(symp, lmode)) {
								st_move1(curtok->val);
								goto exit;
							}
							else goto loop;
						}
					}
				}
			}
			if (!f77fl && fllogic == 1) {
				*endp = 0;
				if (!strcmp(curtok->token,"true") ||
				    !strcmp(curtok->token,"false")) 
					fllogic++;
				else fllogic = 0;
				/* st_move1(curtok->val);
				goto exit;
				*/
			}
			st_move1(curtok->val);
			break;
	case '0': case '1': case '2': case '3': case '4': 
	case '5': case '6': case '7': case '8': case '9': 
			*endp++ = (char)c;
			flreal=0;
			for (;;) {
			        if (endp - curtok->token >= MAXTOKENSIZE) {
					curtok->length = MAXTOKENSIZE;
					outtok(curtok);
					endp = curtok->token;
				}
				c = getsym(lmode);
				if (is_num(c)) ;	/* that's it */
				else if (c == '.') {
					if (flreal) break;
					if (mode & MOD_IF) break;
					flreal = 1;
				}
				else if (lowcase(c) == 'e'||
					 lowcase(c) == 'd'||
					 lowcase(c) == 'q') {
					if (flreal > 1) break;
					if (flreal == 0 && st_is(ST_TYPE)) break;
					flreal = 2;
					*endp++ = (char)c;
					c = getsym(lmode);
					if (is_alpha0(c)) {
						ungetsym(c);
						ungetsym(*--endp);
						if (endp[-1] == '.') c = *--endp;
						else c = SYM_DUMMY;
						break;
					}
					if (c != '-' && c!='+') {
						ungetsym(c);
						continue;
					}
				}
				else if (fixedformfl && lowcase(c) == 'h') {
					int	count;
					
					/*
					 * Hollerith constant 
					 */
					if (flreal) break;
					if (st_is(ST_TYPE)) break;
					*endp = 0;
					strtoi(curtok->token,&count,10);
					*endp++ = (char)c;
					while (count--) {
						c = getsym((mode&MOD_CONT)|MOD_RAW);
						if (c=='\n' || c==SYM_EOF || c==SYM_EOC) {
							ungetsym(c);
							if (!falselvl && c!=SYM_EOC)
							        fppmess(ERR_HRTH);
							break;
						}
						else if (is_special(c))
							c = ' ';
						*endp++ = (char)c;
						if (endp - curtok->token >= MAXTOKENSIZE) {
						        curtok->length = MAXTOKENSIZE;
							outtok(curtok);
							endp = curtok->token;
						}
					}
					curtok->val = TK_DUMMY;
					st_move1(curtok->val);
					goto exit;
				}
				else if (c == '_' && !f77fl) {		/* kind processing */
					do {
						*endp++ = (char)c;
						if (endp - curtok->token >= MAXTOKENSIZE) {
						        curtok->length = MAXTOKENSIZE;
							outtok(curtok);
							endp = curtok->token;
						}
						c = getsym(lmode);
					} while (is_num(c));
					break;
				}
#if USE_C_HEX_CONST
				else if ((mode & MOD_IF) && 
					 (lowcase(c) == 'x') &&
					 (curtok->token[0] == '0') && 
					 (endp - curtok->token == 1) ) {

					/* C hexadecimal constants are allowed
					 * in #if expression */
					do {
						*endp++ = c;
						if (endp - curtok->token >= MAXTOKENSIZE) {
						        curtok->length = MAXTOKENSIZE;
							outtok(curtok);
							endp = curtok->token;
						}
						c = getsym(lmode);
					} while (is_alphanum(c));
					ungetsym(c);
					curtok->val = TK_BOZ;
					goto exit;
				}
#endif /* USE_C_HEX_CONST */
				else break;
				*endp++ = (char)c;
			}
			ungetsym(c);
			if (flreal) {
				curtok->val = TK_DUMMY;
			}
			else {
				curtok->val = TK_NUM;
			}
			st_move1(curtok->val);
			break;
	default:	if (!is_blank(c)) 
				st_move1(TK_DUMMY);
			*endp++ = (char)c;
			break;
	}
exit:	*endp = 0;
        curtok->length = endp - curtok->token;
#if DEBUG
	if (debug >= 2) {
	  printf("line %d stid %d token %d: %s\n",
		 curtok->lineno,
		 curtok->stid,
		 curtok->val,
		 curtok->token );
	}
#endif
	return curtok;
}

Token   *
get_token_nl(unsigned mode) {
	wchar 	c;
	char    *endp;
	int	i;

	/* The current state is ST_NL */

	while (skip_comment(mode));	
		
	endp = curtok->token;
	CHECK(colm == 0);
	c = getsym(mode & MOD_LCASE);
	curtok->lineno = line;
	curtok->stid   = cur_stmt_id;
	curtok->val    = TK_DUMMY;
	CHECK(c);
	switch (c) {
	case SYM_FPP:
		curtok->val = TK_FPP;
		st_move(curtok->val);
		*endp++ = (char)c;
		*endp =0;
		curtok->length = 1;
		return curtok;
        case SYM_EOF:
	case '\n':
		curtok->val = TK_NL;
		cur_stmt_id++;
		/* st_move(curtok->val); the state remains ST_NL */
		*endp++ = (char)c;
		*endp = 0;
		curtok->length = 1;
		return curtok;
	case '&':
	        /* continuation symbol in first column;
		 * fixed or free form it is we do the same.
		 */
	        ungetsym(c);
		st_move(TK_SKIP);
		return get_token(mode);
	}

	/* The following moves us in the
	 * BeginOfStatement state
	 */
	st_move(TK_DUMMY);

	if (!fixedformfl) {	/* F90 */
		ungetsym(c);
		return get_token(mode);
	}

	/* Collect first 6 symbols */
	for (i=0;;i++) {
		if (c == '\t') {
			colm = 6;
			line_width = LINE_WIDTH_MAX;
			break;
		}
		else if (c == SYM_DUMMY) {	/* a comment */
			c = ' ';
			colm = 6;
			break;
		}
		else if (c == SYM_EOF || c == '\n') 
			break;
		if (i == 5) break;
		*endp++ = (char)c;
		c = getsym(mode & MOD_LCASE);
	}
	*endp = 0;
	if (is_blank(c) || c == '0') {
	        cont_symbol = (char)c;
		ungetsym(SYM_BOS);
		while (is_blank(endp[-1]) && endp > curtok->token) endp--;
		ungetstr(curtok->token, endp - curtok->token);
	}
	else if (c == SYM_EOF || c == '\n') {
		ungetsym(c);
		if (c == '\n') {
			colm = 6;
			cont_symbol = ' ';
			ungetsym(SYM_BOS);
			while (is_blank(endp[-1]) && endp > curtok->token) endp--;
		}
		ungetstr(curtok->token, endp - curtok->token);
	}
	else {
	        /* We've got a symbol in the 6th column
		 * so this line is a continuation card
		 * no matter how could it happen.
		 * Output collected symbols as is.
		 */
		*endp++ = (char)c;
		curtok->length = endp - curtok->token;
		outtok(curtok);

		/* The state can't be BegOfStatement */
		st_move(TK_SKIP);
	}
	return get_token(mode);
}

void
unget_tok(Token *tokp) {
        if (tokp->val == TK_NL) {
	        cur_stmt_id--;
		if (tokp->token[0] == '\n') {
		        ungetsym(tokp->token[0]);
		}
		else {
		        ungetsym(SYM_EOF);
		}
	}
	else {
	        ungetstr(tokp->token, tokp->length);
	}
}

Token   *
get_cur_tok() {
        return curtok;
}

void
pushtok() {
        curtok++;
	CHECK(curtok == &ltok[1]);
}

void
poptok() {
        curtok--;
	CHECK(curtok == &ltok[0]);
}