fortran.c

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

	while (! isKeyword (token, KEYWORD_end))
	{
		if (isTypeSpec (token))
			parseComponentDefStmt (token);
		else
			skipToNextStatement (token);
	}
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_type));
	skipToToken (token, TOKEN_STATEMENT_END);
	ancestorPop ();
}

/*  interface-block
 *      interface-stmt (is INTERFACE [generic-spec])
 *          [interface-body]
 *          [module-procedure-stmt] ...
 *          end-interface-stmt (is END INTERFACE)
 *
 *  generic-spec
 *      is generic-name
 *      or OPERATOR ( defined-operator )
 *      or ASSIGNMENT ( = )
 *
 *  interface-body
 *      is function-stmt
 *          [specification-part]
 *          end-function-stmt
 *      or subroutine-stmt
 *          [specification-part]
 *          end-subroutine-stmt
 *
 *  module-procedure-stmt is
 *      MODULE PROCEDURE procedure-name-list
 */
static void parseInterfaceBlock (tokenInfo *const token)
{
	tokenInfo *name = NULL;
	Assert (isKeyword (token, KEYWORD_interface));
	readToken (token);
	if (isType (token, TOKEN_IDENTIFIER))
	{
		makeFortranTag (token, TAG_INTERFACE);
		name = newTokenFrom (token);
	}
	else if (isKeyword (token, KEYWORD_assignment) ||
			 isKeyword (token, KEYWORD_operator))
	{
		readToken (token);
		if (isType (token, TOKEN_PAREN_OPEN))
			readToken (token);
		if (isType (token, TOKEN_OPERATOR))
		{
			makeFortranTag (token, TAG_INTERFACE);
			name = newTokenFrom (token);
		}
	}
	if (name == NULL)
	{
		name = newToken ();
		name->type = TOKEN_IDENTIFIER;
		name->tag = TAG_INTERFACE;
	}
	ancestorPush (name);
	while (! isKeyword (token, KEYWORD_end))
	{
		switch (token->keyword)
		{
			case KEYWORD_function:   parseFunctionSubprogram (token);   break;
			case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;

			default:
				if (isSubprogramPrefix (token))
					readToken (token);
				else if (isTypeSpec (token))
					parseTypeSpec (token);
				else
					skipToNextStatement (token);
				break;
		}
	}
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_interface));
	skipToNextStatement (token);
	ancestorPop ();
	deleteToken (name);
}

/*  entry-stmt is
 *      ENTRY entry-name [ ( dummy-arg-list ) ]
 */
static void parseEntryStmt (tokenInfo *const token)
{
	Assert (isKeyword (token, KEYWORD_entry));
	readToken (token);
	if (isType (token, TOKEN_IDENTIFIER))
		makeFortranTag (token, TAG_ENTRY_POINT);
	skipToNextStatement (token);
}

/*  stmt-function-stmt is
 *      function-name ([dummy-arg-name-list]) = scalar-expr
 */
static boolean parseStmtFunctionStmt (tokenInfo *const token)
{
	boolean result = FALSE;
	Assert (isType (token, TOKEN_IDENTIFIER));
#if 0  /* cannot reliably parse this yet */
	makeFortranTag (token, TAG_FUNCTION);
#endif
	readToken (token);
	if (isType (token, TOKEN_PAREN_OPEN))
	{
		skipOverParens (token);
		result = (boolean) (isType (token, TOKEN_OPERATOR) &&
			strcmp (vStringValue (token->string), "=") == 0);
	}
	skipToNextStatement (token);
	return result;
}

static boolean isIgnoredDeclaration (tokenInfo *const token)
{
	boolean result;
	switch (token->keyword)
	{
		case KEYWORD_cexternal:
		case KEYWORD_cglobal:
		case KEYWORD_dllexport:
		case KEYWORD_dllimport:
		case KEYWORD_external:
		case KEYWORD_format:
		case KEYWORD_include:
		case KEYWORD_inline:
		case KEYWORD_parameter:
		case KEYWORD_pascal:
		case KEYWORD_pexternal:
		case KEYWORD_pglobal:
		case KEYWORD_static:
		case KEYWORD_value:
		case KEYWORD_virtual:
		case KEYWORD_volatile:
			result = TRUE;
			break;

		default:
			result = FALSE;
			break;
	}
	return result;
}

/*  declaration-construct
 *      [derived-type-def]
 *      [interface-block]
 *      [type-declaration-stmt]
 *      [specification-stmt]
 *      [parameter-stmt] (is PARAMETER ( named-constant-def-list )
 *      [format-stmt]    (is FORMAT format-specification)
 *      [entry-stmt]
 *      [stmt-function-stmt]
 */
static boolean parseDeclarationConstruct (tokenInfo *const token)
{
	boolean result = TRUE;
	switch (token->keyword)
	{
		case KEYWORD_entry:		parseEntryStmt (token);      break;
		case KEYWORD_interface:	parseInterfaceBlock (token); break;
		case KEYWORD_stdcall:   readToken (token);           break;
		/* derived type handled by parseTypeDeclarationStmt(); */

		case KEYWORD_automatic:
			readToken (token);
			if (isTypeSpec (token))
				parseTypeDeclarationStmt (token);
			else
				skipToNextStatement (token);
			result = TRUE;
			break;

		default:
			if (isIgnoredDeclaration (token))
				skipToNextStatement (token);
			else if (isTypeSpec (token))
			{
				parseTypeDeclarationStmt (token);
				result = TRUE;
			}
			else if (isType (token, TOKEN_IDENTIFIER))
				result = parseStmtFunctionStmt (token);
			else
				result = parseSpecificationStmt (token);
			break;
	}
	return result;
}

/*  implicit-part-stmt
 *      is [implicit-stmt] (is IMPLICIT etc.)
 *      or [parameter-stmt] (is PARAMETER etc.)
 *      or [format-stmt] (is FORMAT etc.)
 *      or [entry-stmt] (is ENTRY entry-name etc.)
 */
static boolean parseImplicitPartStmt (tokenInfo *const token)
{
	boolean result = TRUE;
	switch (token->keyword)
	{
		case KEYWORD_entry: parseEntryStmt (token); break;

		case KEYWORD_implicit:
		case KEYWORD_include:
		case KEYWORD_parameter:
		case KEYWORD_format:
			skipToNextStatement (token);
			break;

		default: result = FALSE; break;
	}
	return result;
}

/*  specification-part is
 *      [use-stmt] ... (is USE module-name etc.)
 *      [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt])
 *      [declaration-construct] ...
 */
static boolean parseSpecificationPart (tokenInfo *const token)
{
	boolean result = FALSE;
	while (skipStatementIfKeyword (token, KEYWORD_use))
		result = TRUE;
	while (parseImplicitPartStmt (token))
		result = TRUE;
	while (parseDeclarationConstruct (token))
		result = TRUE;
	return result;
}

/*  block-data is
 *      block-data-stmt (is BLOCK DATA [block-data-name]
 *          [specification-part]
 *          end-block-data-stmt (is END [BLOCK DATA [block-data-name]])
 */
static void parseBlockData (tokenInfo *const token)
{
	Assert (isKeyword (token, KEYWORD_block));
	readToken (token);
	if (isKeyword (token, KEYWORD_data))
	{
		readToken (token);
		if (isType (token, TOKEN_IDENTIFIER))
			makeFortranTag (token, TAG_BLOCK_DATA);
	}
	ancestorPush (token);
	skipToNextStatement (token);
	parseSpecificationPart (token);
	while (! isKeyword (token, KEYWORD_end))
		skipToNextStatement (token);
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
			isSecondaryKeyword (token, KEYWORD_block));
	skipToNextStatement (token);
	ancestorPop ();
}

/*  internal-subprogram-part is
 *      contains-stmt (is CONTAINS)
 *          internal-subprogram
 *          [internal-subprogram] ...
 *
 *  internal-subprogram
 *      is function-subprogram
 *      or subroutine-subprogram
 */
static void parseInternalSubprogramPart (tokenInfo *const token)
{
	boolean done = FALSE;
	if (isKeyword (token, KEYWORD_contains))
		skipToNextStatement (token);
	do
	{
		switch (token->keyword)
		{
			case KEYWORD_function:   parseFunctionSubprogram (token);   break;
			case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
			case KEYWORD_end:        done = TRUE;                       break;

			default:
				if (isSubprogramPrefix (token))
					readToken (token);
				else if (isTypeSpec (token))
					parseTypeSpec (token);
				else
					readToken (token);
				break;
		}
	} while (! done);
}

/*  module is
 *      mudule-stmt (is MODULE module-name)
 *          [specification-part]
 *          [module-subprogram-part]
 *          end-module-stmt (is END [MODULE [module-name]])
 *
 *  module-subprogram-part
 *      contains-stmt (is CONTAINS)
 *          module-subprogram
 *          [module-subprogram] ...
 *
 *  module-subprogram
 *      is function-subprogram
 *      or subroutine-subprogram
 */
static void parseModule (tokenInfo *const token)
{
	Assert (isKeyword (token, KEYWORD_module));
	readToken (token);
	if (isType (token, TOKEN_IDENTIFIER))
		makeFortranTag (token, TAG_MODULE);
	ancestorPush (token);
	skipToNextStatement (token);
	parseSpecificationPart (token);
	if (isKeyword (token, KEYWORD_contains))
		parseInternalSubprogramPart (token);
	while (! isKeyword (token, KEYWORD_end))
		skipToNextStatement (token);
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
			isSecondaryKeyword (token, KEYWORD_module));
	skipToNextStatement (token);
	ancestorPop ();
}

/*  execution-part
 *      executable-construct
 *
 *  executable-contstruct is
 *      execution-part-construct [execution-part-construct]
 *
 *  execution-part-construct
 *      is executable-construct
 *      or format-stmt
 *      or data-stmt
 *      or entry-stmt
 */
static boolean parseExecutionPart (tokenInfo *const token)
{
	boolean result = FALSE;
	boolean done = FALSE;
	while (! done)
	{
		switch (token->keyword)
		{
			default:
				if (isSubprogramPrefix (token))
					readToken (token);
				else
					skipToNextStatement (token);
				result = TRUE;
				break;

			case KEYWORD_entry:
				parseEntryStmt (token);
				result = TRUE;
				break;

			case KEYWORD_contains:
			case KEYWORD_function:
			case KEYWORD_subroutine:
				done = TRUE;
				break;

			case KEYWORD_end:
				readSubToken (token);
				if (isSecondaryKeyword (token, KEYWORD_do) ||
					isSecondaryKeyword (token, KEYWORD_if) ||
					isSecondaryKeyword (token, KEYWORD_select) ||
					isSecondaryKeyword (token, KEYWORD_where))
				{
					skipToNextStatement (token);
					result = TRUE;
				}
				else
					done = TRUE;
				break;
		}
	}
	return result;
}

static void parseSubprogram (tokenInfo *const token, const tagType tag)
{
	Assert (isKeyword (token, KEYWORD_program) ||
			isKeyword (token, KEYWORD_function) ||
			isKeyword (token, KEYWORD_subroutine));
	readToken (token);
	if (isType (token, TOKEN_IDENTIFIER))
		makeFortranTag (token, tag);
	ancestorPush (token);
	skipToNextStatement (token);
	parseSpecificationPart (token);
	parseExecutionPart (token);
	if (isKeyword (token, KEYWORD_contains))
		parseInternalSubprogramPart (token);
	Assert (isKeyword (token, KEYWORD_end));
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
			isSecondaryKeyword (token, KEYWORD_program) ||
			isSecondaryKeyword (token, KEYWORD_function) ||
			isSecondaryKeyword (token, KEYWORD_subroutine));
	skipToNextStatement (token);
	ancestorPop ();
}


/*  function-subprogram is
 *      function-stmt (is [prefix] FUNCTION function-name etc.)
 *          [specification-part]
 *          [execution-part]
 *          [internal-subprogram-part]
 *          end-function-stmt (is END [FUNCTION [function-name]])
 *
 *  prefix
 *      is type-spec [RECURSIVE]
 *      or [RECURSIVE] type-spec
 */
static void parseFunctionSubprogram (tokenInfo *const token)
{
	parseSubprogram (token, TAG_FUNCTION);
}

/*  subroutine-subprogram is
 *      subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.)
 *          [specification-part]
 *          [execution-part]
 *          [internal-subprogram-part]
 *          end-subroutine-stmt (is END [SUBROUTINE [function-name]])
 */
static void parseSubroutineSubprogram (tokenInfo *const token)
{
	parseSubprogram (token, TAG_SUBROUTINE);
}

/*  main-program is
 *      [program-stmt] (is PROGRAM program-name)
 *          [specification-part]
 *          [execution-part]
 *          [internal-subprogram-part ]
 *          end-program-stmt
 */
static void parseMainProgram (tokenInfo *const token)
{
	parseSubprogram (token, TAG_PROGRAM);
}

/*  program-unit
 *      is main-program
 *      or external-subprogram (is function-subprogram or subroutine-subprogram)
 *      or module
 *      or block-data
 */
static void parseProgramUnit (tokenInfo *const token)
{
	readToken (token);
	do
	{
		if (isType (token, TOKEN_STATEMENT_END))
			readToken (token);
		else switch (token->keyword)
		{
			case KEYWORD_block:      parseBlockData (token);            break;
			case KEYWORD_end:        skipToNextStatement (token);       break;
			case KEYWORD_function:   parseFunctionSubprogram (token);   break;
			case KEYWORD_module:     parseModule (token);               break;
			case KEYWORD_program:    parseMainProgram (token);          break;
			case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;

			default:
				if (isSubprogramPrefix (token))
					readToken (token);
				else
				{
					boolean one = parseSpecificationPart (token);
					boolean two = parseExecutionPart (token);
					if (! (one || two))
						readToken (token);
				}
				break;
		}
	} while (TRUE);
}

static boolean findFortranTags (const unsigned int passCount)
{
	tokenInfo *token;
	exception_t exception;
	boolean retry;

	Assert (passCount < 3);
	Parent = newToken ();
	token = newToken ();
	FreeSourceForm = (boolean) (passCount > 1);
	Column = 0;
	exception = (exception_t) setjmp (Exception);
	if (exception == ExceptionEOF)
		retry = FALSE;
	else if (exception == ExceptionFixedFormat  &&  ! FreeSourceForm)
	{
		verbose ("%s: not fixed source form; retry as free source form\n",
				getInputFileName ());
		retry = TRUE;
	}
	else
	{
		parseProgramUnit (token);
		retry = FALSE;
	}
	ancestorClear ();
	deleteToken (token);
	deleteToken (Parent);

	return retry;
}

static void initialize (const langType language)
{
	Lang_fortran = language;
	buildFortranKeywordHash ();
}

extern parserDefinition* FortranParser (void)
{
	static const char *const extensions [] = {
		"f", "for", "ftn", "f77", "f90", "f95",
#ifndef CASE_INSENSITIVE_FILENAMES
		"F", "FOR", "FTN", "F77", "F90", "F95",
#endif
		NULL
	};
	parserDefinition* def = parserNew ("Fortran");
	def->kinds      = FortranKinds;
	def->kindCount  = KIND_COUNT (FortranKinds);
	def->extensions = extensions;
	def->parser2    = findFortranTags;
	def->initialize = initialize;
	return def;
}

/* vi:set tabstop=4 shiftwidth=4: */