fortran.c

Exuberant Ctags is a multilanguage reimplementation of the much-underused ctags(1) program and is i

			 * character blank.
			 */
			if (c == ' '  ||  c == '0')
				type = LTYPE_INITIAL;

			/* 3.2.3  Continuation_Line.  A continuation line is any line that
			 * contains any character of the FORTRAN character set other than
			 * the character blank or the digit 0 in column 6 and contains
			 * only blank characters in columns 1 through 5.
			 */
			else if (vStringLength (label) == 0)
				type = LTYPE_CONTINUATION;
			else
				type = LTYPE_INVALID;
		}
		else if (c == ' ')
			;
		else if (c == EOF)
			type = LTYPE_EOF;
		else if (c == '\n')
			type = LTYPE_SHORT;
		else if (isdigit (c))
			vStringPut (label, c);
		else
			type = LTYPE_INVALID;

		++column;
	} while (column < 6  &&  type == LTYPE_UNDETERMINED);

	Assert (type != LTYPE_UNDETERMINED);

	if (vStringLength (label) > 0)
	{
		vStringTerminate (label);
		makeLabelTag (label);
		vStringClear (label);
	}
	return type;
}

static int getFixedFormChar (void)
{
	boolean newline = FALSE;
	lineType type;
	int c = '\0';

	if (Column > 0)
	{
#ifdef STRICT_FIXED_FORM
		/*  EXCEPTION! Some compilers permit more than 72 characters per line.
		 */
		if (Column > 71)
			c = skipLine ();
		else
#endif
		{
			c = fileGetc ();
			++Column;
		}
		if (c == '\n')
		{
			newline = TRUE;  /* need to check for continuation line */
			Column = 0;
		}
		else if (c == '!'  &&  ! ParsingString)
		{
			c = skipLine ();
			newline = TRUE;  /* need to check for continuation line */
			Column = 0;
		}
		else if (c == '&')  /* check for free source form */
		{
			const int c2 = fileGetc ();
			if (c2 == '\n')
				longjmp (Exception, (int) ExceptionFixedFormat);
			else
				fileUngetc (c2);
		}
	}
	while (Column == 0)
	{
		type = getLineType ();
		switch (type)
		{
			case LTYPE_UNDETERMINED:
			case LTYPE_INVALID:
				longjmp (Exception, (int) ExceptionFixedFormat);
				break;

			case LTYPE_SHORT: break;
			case LTYPE_COMMENT: skipLine (); break;

			case LTYPE_EOF:
				Column = 6;
				if (newline)
					c = '\n';
				else
					c = EOF;
				break;

			case LTYPE_INITIAL:
				if (newline)
				{
					c = '\n';
					Column = 6;
					break;
				}
				/* fall through to next case */
			case LTYPE_CONTINUATION:
				Column = 5;
				do
				{
					c = fileGetc ();
					++Column;
				} while (isBlank (c));
				if (c == '\n')
					Column = 0;
				else if (Column > 6)
				{
					fileUngetc (c);
					c = ' ';
				}
				break;

			default:
				Assert ("Unexpected line type" == NULL);
		}
	}
	return c;
}

static int skipToNextLine (void)
{
	int c = skipLine ();
	if (c != EOF)
		c = fileGetc ();
	return c;
}

static int getFreeFormChar (void)
{
	static boolean newline = TRUE;
	boolean advanceLine = FALSE;
	int c = fileGetc ();

	/* If the last nonblank, non-comment character of a FORTRAN 90
	 * free-format text line is an ampersand then the next non-comment
	 * line is a continuation line.
	 */
	if (c == '&')
	{
		do
			c = fileGetc ();
		while (isspace (c)  &&  c != '\n');
		if (c == '\n')
		{
			newline = TRUE;
			advanceLine = TRUE;
		}
		else if (c == '!')
			advanceLine = TRUE;
		else
		{
			fileUngetc (c);
			c = '&';
		}
	}
	else if (newline && (c == '!' || c == '#'))
		advanceLine = TRUE;
	while (advanceLine)
	{
		while (isspace (c))
			c = fileGetc ();
		if (c == '!' || (newline && c == '#'))
		{
			c = skipToNextLine ();
			newline = TRUE;
			continue;
		}
		if (c == '&')
			c = fileGetc ();
		else
			advanceLine = FALSE;
	}
	newline = (boolean) (c == '\n');
	return c;
}

static int getChar (void)
{
	int c;

	if (Ungetc != '\0')
	{
		c = Ungetc;
		Ungetc = '\0';
	}
	else if (FreeSourceForm)
		c = getFreeFormChar ();
	else
		c = getFixedFormChar ();
	return c;
}

static void ungetChar (const int c)
{
	Ungetc = c;
}

/*  If a numeric is passed in 'c', this is used as the first digit of the
 *  numeric being parsed.
 */
static vString *parseInteger (int c)
{
	static vString *string = NULL;

	if (string == NULL)
		string = vStringNew ();
	vStringClear (string);

	if (c == '-')
	{
		vStringPut (string, c);
		c = getChar ();
	}
	else if (! isdigit (c))
		c = getChar ();
	while (c != EOF  &&  isdigit (c))
	{
		vStringPut (string, c);
		c = getChar ();
	}
	vStringTerminate (string);

	if (c == '_')
	{
		do
			c = getChar ();
		while (c != EOF  &&  isalpha (c));
	}
	ungetChar (c);

	return string;
}

static vString *parseNumeric (int c)
{
	static vString *string = NULL;

	if (string == NULL)
		string = vStringNew ();
	vStringCopy (string, parseInteger (c));

	c = getChar ();
	if (c == '.')
	{
		vStringPut (string, c);
		vStringCat (string, parseInteger ('\0'));
		c = getChar ();
	}
	if (tolower (c) == 'e')
	{
		vStringPut (string, c);
		vStringCat (string, parseInteger ('\0'));
	}
	else
		ungetChar (c);

	vStringTerminate (string);

	return string;
}

static void parseString (vString *const string, const int delimeter)
{
	const unsigned long inputLineNumber = getInputLineNumber ();
	int c;
	ParsingString = TRUE;
	c = getChar ();
	while (c != delimeter  &&  c != '\n'  &&  c != EOF)
	{
		vStringPut (string, c);
		c = getChar ();
	}
	if (c == '\n'  ||  c == EOF)
	{
		verbose ("%s: unterminated character string at line %lu\n",
				getInputFileName (), inputLineNumber);
		if (c == EOF)
			longjmp (Exception, (int) ExceptionEOF);
		else if (! FreeSourceForm)
			longjmp (Exception, (int) ExceptionFixedFormat);
	}
	vStringTerminate (string);
	ParsingString = FALSE;
}

/*  Read a C identifier beginning with "firstChar" and places it into "name".
 */
static void parseIdentifier (vString *const string, const int firstChar)
{
	int c = firstChar;

	do
	{
		vStringPut (string, c);
		c = getChar ();
	} while (isident (c));

	vStringTerminate (string);
	ungetChar (c);  /* unget non-identifier character */
}

/*  Analyzes the identifier contained in a statement described by the
 *  statement structure and adjusts the structure according the significance
 *  of the identifier.
 */
static keywordId analyzeToken (vString *const name)
{
	static vString *keyword = NULL;
	keywordId id;

	if (keyword == NULL)
		keyword = vStringNew ();
	vStringCopyToLower (keyword, name);
	id = (keywordId) lookupKeyword (vStringValue (keyword), Lang_fortran);

	return id;
}

static void checkForLabel (void)
{
	tokenInfo* token = NULL;
	int length;
	int c;

	do
		c = getChar ();
	while (isBlank (c));

	for (length = 0  ;  isdigit (c)  &&  length < 5  ;  ++length)
	{
		if (token == NULL)
		{
			token = newToken ();
			token->type = TOKEN_LABEL;
		}
		vStringPut (token->string, c);
		c = getChar ();
	}
	if (length > 0)
	{
		Assert (token != NULL);
		vStringTerminate (token->string);
		makeFortranTag (token, TAG_LABEL);
		deleteToken (token);
	}
	ungetChar (c);
}

static void readIdentifier (tokenInfo *const token, const int c)
{
	parseIdentifier (token->string, c);
	token->keyword = analyzeToken (token->string);
	if (! isKeyword (token, KEYWORD_NONE))
		token->type = TOKEN_KEYWORD;
	else
	{
		token->type = TOKEN_IDENTIFIER;
		if (strncmp (vStringValue (token->string), "end", 3) == 0)
		{
			vString *const sub = vStringNewInit (vStringValue (token->string) + 3);
			const keywordId kw = analyzeToken (sub);
			vStringDelete (sub);
			if (kw != KEYWORD_NONE)
			{
				token->secondary = newToken ();
				token->secondary->type = TOKEN_KEYWORD;
				token->secondary->keyword = kw;
				token->keyword = KEYWORD_end;
			}
		}
	}
}

static void readToken (tokenInfo *const token)
{
	int c;

	deleteToken (token->secondary);
	token->type        = TOKEN_UNDEFINED;
	token->tag         = TAG_UNDEFINED;
	token->keyword     = KEYWORD_NONE;
	token->secondary   = NULL;
	vStringClear (token->string);

getNextChar:
	c = getChar ();

	token->lineNumber	= getSourceLineNumber ();
	token->filePosition	= getInputFilePosition ();

	switch (c)
	{
		case EOF:  longjmp (Exception, (int) ExceptionEOF);  break;
		case ' ':  goto getNextChar;
		case '\t': goto getNextChar;
		case ',':  token->type = TOKEN_COMMA;       break;
		case '(':  token->type = TOKEN_PAREN_OPEN;  break;
		case ')':  token->type = TOKEN_PAREN_CLOSE; break;
		case '%':  token->type = TOKEN_PERCENT;     break;

		case '*':
		case '/':
		case '+':
		case '-':
		case '=':
		case '<':
		case '>':
		{
			const char *const operatorChars = "*/+=<>";
			do {
				vStringPut (token->string, c);
				c = getChar ();
			} while (strchr (operatorChars, c) != NULL);
			ungetChar (c);
			vStringTerminate (token->string);
			token->type = TOKEN_OPERATOR;
			break;
		}

		case '!':
			if (FreeSourceForm)
			{
				do
				   c = getChar ();
				while (c != '\n');
			}
			else
			{
				skipLine ();
				Column = 0;
			}
			/* fall through to newline case */
		case '\n':
			token->type = TOKEN_STATEMENT_END;
			if (FreeSourceForm)
				checkForLabel ();
			break;

		case '.':
			parseIdentifier (token->string, c);
			c = getChar ();
			if (c == '.')
			{
				vStringPut (token->string, c);
				vStringTerminate (token->string);
				token->type = TOKEN_OPERATOR;
			}
			else
			{
				ungetChar (c);
				token->type = TOKEN_UNDEFINED;
			}
			break;

		case '"':
		case '\'':
			parseString (token->string, c);
			token->type = TOKEN_STRING;
			break;

		case ';':
			token->type = TOKEN_STATEMENT_END;
			break;

		case ':':
			c = getChar ();
			if (c == ':')
				token->type = TOKEN_DOUBLE_COLON;
			else
			{
				ungetChar (c);
				token->type = TOKEN_UNDEFINED;
			}
			break;

		default:
			if (isalpha (c))
				readIdentifier (token, c);
			else if (isdigit (c))
			{
				vStringCat (token->string, parseNumeric (c));
				token->type = TOKEN_NUMERIC;
			}
			else
				token->type = TOKEN_UNDEFINED;
			break;
	}
}

static void readSubToken (tokenInfo *const token)
{
	if (token->secondary == NULL)
	{
		token->secondary = newToken ();
		readToken (token->secondary);
	}
	Assert (token->secondary != NULL);
}

/*
*   Scanning functions
*/

static void skipToToken (tokenInfo *const token, tokenType type)
{
	while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END) &&
			!(token->secondary != NULL && isType (token->secondary, TOKEN_STATEMENT_END)))
		readToken (token);
}

static void skipPast (tokenInfo *const token, tokenType type)
{
	skipToToken (token, type);
	if (! isType (token, TOKEN_STATEMENT_END))
		readToken (token);
}

static void skipToNextStatement (tokenInfo *const token)
{
	do
	{
		skipToToken (token, TOKEN_STATEMENT_END);
		readToken (token);
	} while (isType (token, TOKEN_STATEMENT_END));
}

/* skip over parenthesis enclosed contents starting at next token.
 * Token is left at the first token following closing parenthesis. If an
 * opening parenthesis is not found, `token' is moved to the end of the
 * statement.
 */
static void skipOverParens (tokenInfo *const token)
{
	int level = 0;
	do {
		if (isType (token, TOKEN_STATEMENT_END))
			break;
		else if (isType (token, TOKEN_PAREN_OPEN))
			++level;
		else if (isType (token, TOKEN_PAREN_CLOSE))
			--level;
		readToken (token);
	} while (level > 0);
}