fortran.c

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

static boolean isTypeSpec (tokenInfo *const token)
{
	boolean result;
	switch (token->keyword)
	{
		case KEYWORD_byte:
		case KEYWORD_integer:
		case KEYWORD_real:
		case KEYWORD_double:
		case KEYWORD_complex:
		case KEYWORD_character:
		case KEYWORD_logical:
		case KEYWORD_record:
		case KEYWORD_type:
			result = TRUE;
			break;
		default:
			result = FALSE;
			break;
	}
	return result;
}

static boolean isSubprogramPrefix (tokenInfo *const token)
{
	boolean result;
	switch (token->keyword)
	{
		case KEYWORD_elemental:
		case KEYWORD_pure:
		case KEYWORD_recursive:
		case KEYWORD_stdcall:
			result = TRUE;
			break;
		default:
			result = FALSE;
			break;
	}
	return result;
}

/*  type-spec
 *      is INTEGER [kind-selector]
 *      or REAL [kind-selector] is ( etc. )
 *      or DOUBLE PRECISION
 *      or COMPLEX [kind-selector]
 *      or CHARACTER [kind-selector]
 *      or LOGICAL [kind-selector]
 *      or TYPE ( type-name )
 *
 *  Note that INTEGER and REAL may be followed by "*N" where "N" is an integer
 */
static void parseTypeSpec (tokenInfo *const token)
{
	/* parse type-spec, leaving `token' at first token following type-spec */
	Assert (isTypeSpec (token));
	switch (token->keyword)
	{
		case KEYWORD_character:
			/* skip char-selector */
			readToken (token);
			if (isType (token, TOKEN_OPERATOR) &&
					 strcmp (vStringValue (token->string), "*") == 0)
				readToken (token);
			if (isType (token, TOKEN_PAREN_OPEN))
				skipOverParens (token);
			else if (isType (token, TOKEN_NUMERIC))
				readToken (token);
			break;


		case KEYWORD_byte:
		case KEYWORD_complex:
		case KEYWORD_integer:
		case KEYWORD_logical:
		case KEYWORD_real:
			readToken (token);
			if (isType (token, TOKEN_PAREN_OPEN))
				skipOverParens (token);  /* skip kind-selector */
			if (isType (token, TOKEN_OPERATOR) &&
				strcmp (vStringValue (token->string), "*") == 0)
			{
				readToken (token);
				readToken (token);
			}
			break;

		case KEYWORD_double:
			readToken (token);
			if (isKeyword (token, KEYWORD_complex) ||
				isKeyword (token, KEYWORD_precision))
					readToken (token);
			else
				skipToToken (token, TOKEN_STATEMENT_END);
			break;

		case KEYWORD_record:
			readToken (token);
			if (isType (token, TOKEN_OPERATOR) &&
				strcmp (vStringValue (token->string), "/") == 0)
			{
				readToken (token);  /* skip to structure name */
				readToken (token);  /* skip to '/' */
				readToken (token);  /* skip to variable name */
			}
			break;

		case KEYWORD_type:
			readToken (token);
			if (isType (token, TOKEN_PAREN_OPEN))
				skipOverParens (token);  /* skip type-name */
			else
				parseDerivedTypeDef (token);
			break;

		default:
			skipToToken (token, TOKEN_STATEMENT_END);
			break;
	}
}

static boolean skipStatementIfKeyword (tokenInfo *const token, keywordId keyword)
{
	boolean result = FALSE;
	if (isKeyword (token, keyword))
	{
		result = TRUE;
		skipToNextStatement (token);
	}
	return result;
}

/* parse a list of qualifying specifiers, leaving `token' at first token
 * following list. Examples of such specifiers are:
 *      [[, attr-spec] ::]
 *      [[, component-attr-spec-list] ::]
 *
 *  attr-spec
 *      is PARAMETER
 *      or access-spec (is PUBLIC or PRIVATE)
 *      or ALLOCATABLE
 *      or DIMENSION ( array-spec )
 *      or EXTERNAL
 *      or INTENT ( intent-spec )
 *      or INTRINSIC
 *      or OPTIONAL
 *      or POINTER
 *      or SAVE
 *      or TARGET
 * 
 *  component-attr-spec
 *      is POINTER
 *      or DIMENSION ( component-array-spec )
 */
static void parseQualifierSpecList (tokenInfo *const token)
{
	do
	{
		readToken (token);  /* should be an attr-spec */
		switch (token->keyword)
		{
			case KEYWORD_parameter:
			case KEYWORD_allocatable:
			case KEYWORD_external:
			case KEYWORD_intrinsic:
			case KEYWORD_optional:
			case KEYWORD_private:
			case KEYWORD_pointer:
			case KEYWORD_public:
			case KEYWORD_save:
			case KEYWORD_target:
				readToken (token);
				break;

			case KEYWORD_dimension:
			case KEYWORD_intent:
				readToken (token);
				skipOverParens (token);
				break;

			default: skipToToken (token, TOKEN_STATEMENT_END); break;
		}
	} while (isType (token, TOKEN_COMMA));
	if (! isType (token, TOKEN_DOUBLE_COLON))
		skipToToken (token, TOKEN_STATEMENT_END);
}

static tagType variableTagType (void)
{
	tagType result = TAG_VARIABLE;
	if (ancestorCount () > 0)
	{
		const tokenInfo* const parent = ancestorTop ();
		switch (parent->tag)
		{
			case TAG_MODULE:       result = TAG_VARIABLE;  break;
			case TAG_DERIVED_TYPE: result = TAG_COMPONENT; break;
			case TAG_FUNCTION:     result = TAG_LOCAL;     break;
			case TAG_SUBROUTINE:   result = TAG_LOCAL;     break;
			default:               result = TAG_VARIABLE;  break;
		}
	}
	return result;
}

static void parseEntityDecl (tokenInfo *const token)
{
	Assert (isType (token, TOKEN_IDENTIFIER));
	makeFortranTag (token, variableTagType ());
	readToken (token);
	if (isType (token, TOKEN_PAREN_OPEN))
		skipOverParens (token);
	if (isType (token, TOKEN_OPERATOR) &&
			strcmp (vStringValue (token->string), "*") == 0)
	{
		readToken (token);  /* read char-length */
		if (isType (token, TOKEN_PAREN_OPEN))
			skipOverParens (token);
		else
			readToken (token);
	}
	if (isType (token, TOKEN_OPERATOR))
	{
		if (strcmp (vStringValue (token->string), "/") == 0)
		{  /* skip over initializations of structure field */
			readToken (token);
			skipPast (token, TOKEN_OPERATOR);
		}
		else if (strcmp (vStringValue (token->string), "=") == 0)
		{
			while (! isType (token, TOKEN_COMMA) &&
					! isType (token, TOKEN_STATEMENT_END))
			{
				readToken (token);
				if (isType (token, TOKEN_PAREN_OPEN))
					skipOverParens (token);
			}
		}
	}
	/* token left at either comma or statement end */
}

static void parseEntityDeclList (tokenInfo *const token)
{
	if (isType (token, TOKEN_PERCENT))
		skipToNextStatement (token);
	else while (isType (token, TOKEN_IDENTIFIER) ||
				(isType (token, TOKEN_KEYWORD) &&
				 !isKeyword (token, KEYWORD_function) &&
				 !isKeyword (token, KEYWORD_subroutine)))
	{
		/* compilers accept keywoeds as identifiers */
		if (isType (token, TOKEN_KEYWORD))
			token->type = TOKEN_IDENTIFIER;
		parseEntityDecl (token);
		if (isType (token, TOKEN_COMMA))
			readToken (token);
		else if (isType (token, TOKEN_STATEMENT_END))
		{
			skipToNextStatement (token);
			break;
		}
	}
}

/*  type-declaration-stmt is
 *      type-spec [[, attr-spec] ... ::] entity-decl-list
 */
static void parseTypeDeclarationStmt (tokenInfo *const token)
{
	Assert (isTypeSpec (token));
	parseTypeSpec (token);
	if (!isType (token, TOKEN_STATEMENT_END))  /* if not end of derived type... */
	{
		if (isType (token, TOKEN_COMMA))
			parseQualifierSpecList (token);
		if (isType (token, TOKEN_DOUBLE_COLON))
			readToken (token);
		parseEntityDeclList (token);
	}
	if (isType (token, TOKEN_STATEMENT_END))
		skipToNextStatement (token);
}

/*  namelist-stmt is
 *      NAMELIST /namelist-group-name/ namelist-group-object-list
 *			[[,]/[namelist-group-name]/ namelist-block-object-list] ...
 *
 *  namelist-group-object is
 *      variable-name
 *
 *  common-stmt is
 *      COMMON [/[common-block-name]/] common-block-object-list
 *			[[,]/[common-block-name]/ common-block-object-list] ...
 *
 *  common-block-object is
 *      variable-name [ ( explicit-shape-spec-list ) ]
 */
static void parseCommonNamelistStmt (tokenInfo *const token, tagType type)
{
	Assert (isKeyword (token, KEYWORD_common) ||
			isKeyword (token, KEYWORD_namelist));
	readToken (token);
	do
	{
		if (isType (token, TOKEN_OPERATOR) &&
			strcmp (vStringValue (token->string), "/") == 0)
		{
			readToken (token);
			if (isType (token, TOKEN_IDENTIFIER))
			{
				makeFortranTag (token, type);
				readToken (token);
			}
			skipPast (token, TOKEN_OPERATOR);
		}
		if (isType (token, TOKEN_IDENTIFIER))
			makeFortranTag (token, TAG_LOCAL);
		readToken (token);
		if (isType (token, TOKEN_PAREN_OPEN))
			skipOverParens (token);  /* skip explicit-shape-spec-list */
		if (isType (token, TOKEN_COMMA))
			readToken (token);
	} while (! isType (token, TOKEN_STATEMENT_END));
	skipToNextStatement (token);
}

static void parseFieldDefinition (tokenInfo *const token)
{
	if (isTypeSpec (token))
		parseTypeDeclarationStmt (token);
	else if (isKeyword (token, KEYWORD_structure))
		parseStructureStmt (token);
	else if (isKeyword (token, KEYWORD_union))
		parseUnionStmt (token);
	else
		skipToNextStatement (token);
}

static void parseMap (tokenInfo *const token)
{
	Assert (isKeyword (token, KEYWORD_map));
	skipToNextStatement (token);
	while (! isKeyword (token, KEYWORD_end))
		parseFieldDefinition (token);
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_map));
	skipToNextStatement (token);
}

/* UNION
 *      MAP
 *          [field-definition] [field-definition] ... 
 *      END MAP
 *      MAP
 *          [field-definition] [field-definition] ... 
 *      END MAP
 *      [MAP
 *          [field-definition]
 *          [field-definition] ... 
 *      END MAP] ...
 *  END UNION 
 *      *
 *
 *  Typed data declarations (variables or arrays) in structure declarations
 *  have the form of normal Fortran typed data declarations. Data items with
 *  different types can be freely intermixed within a structure declaration.
 *
 *  Unnamed fields can be declared in a structure by specifying the pseudo
 *  name %FILL in place of an actual field name. You can use this mechanism to
 *  generate empty space in a record for purposes such as alignment.
 *
 *  All mapped field declarations that are made within a UNION declaration
 *  share a common location within the containing structure. When initializing
 *  the fields within a UNION, the final initialization value assigned
 *  overlays any value previously assigned to a field definition that shares
 *  that field. 
 */
static void parseUnionStmt (tokenInfo *const token)
{
	Assert (isKeyword (token, KEYWORD_union));
	skipToNextStatement (token);
	while (isKeyword (token, KEYWORD_map))
		parseMap (token);
	Assert (isKeyword (token, KEYWORD_end));
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_union));
	skipToNextStatement (token);
}

/*  STRUCTURE [/structure-name/] [field-names]
 *      [field-definition]
 *      [field-definition] ...
 *  END STRUCTURE
 *
 *  structure-name
 *		identifies the structure in a subsequent RECORD statement.
 *		Substructures can be established within a structure by means of either
 *		a nested STRUCTURE declaration or a RECORD statement. 
 *
 *   field-names
 *		(for substructure declarations only) one or more names having the
 *		structure of the substructure being defined. 
 *
 *   field-definition
 *		can be one or more of the following:
 *
 *			Typed data declarations, which can optionally include one or more
 *			data initialization values.
 *
 *			Substructure declarations (defined by either RECORD statements or
 *			subsequent STRUCTURE statements).
 *
 *			UNION declarations, which are mapped fields defined by a block of
 *			statements. The syntax of a UNION declaration is described below.
 *
 *			PARAMETER statements, which do not affect the form of the
 *			structure. 
 */
static void parseStructureStmt (tokenInfo *const token)
{
	tokenInfo *name;
	Assert (isKeyword (token, KEYWORD_structure));
	readToken (token);
	if (isType (token, TOKEN_OPERATOR) &&
		strcmp (vStringValue (token->string), "/") == 0)
	{  /* read structure name */
		readToken (token);
		if (isType (token, TOKEN_IDENTIFIER))
			makeFortranTag (token, TAG_DERIVED_TYPE);
		name = newTokenFrom (token);
		skipPast (token, TOKEN_OPERATOR);
	}
	else
	{  /* fake out anonymous structure */
		name = newToken ();
		name->type = TOKEN_IDENTIFIER;
		name->tag = TAG_DERIVED_TYPE;
		vStringCopyS (name->string, "anonymous");
	}
	while (isType (token, TOKEN_IDENTIFIER))
	{  /* read field names */
		makeFortranTag (token, TAG_COMPONENT);
		readToken (token);
		if (isType (token, TOKEN_COMMA))
			readToken (token);
	}
	skipToNextStatement (token);
	ancestorPush (name);
	while (! isKeyword (token, KEYWORD_end))
		parseFieldDefinition (token);
	readSubToken (token);
	Assert (isSecondaryKeyword (token, KEYWORD_structure));
	skipToNextStatement (token);
	ancestorPop ();
	deleteToken (name);
}

/*  specification-stmt
 *      is access-stmt      (is access-spec [[::] access-id-list)
 *      or allocatable-stmt (is ALLOCATABLE [::] array-name etc.)
 *      or common-stmt      (is COMMON [ / [common-block-name] /] etc.)
 *      or data-stmt        (is DATA data-stmt-list [[,] data-stmt-set] ...)
 *      or dimension-stmt   (is DIMENSION [::] array-name etc.)
 *      or equivalence-stmt (is EQUIVALENCE equivalence-set-list)
 *      or external-stmt    (is EXTERNAL etc.)
 *      or intent-stmt      (is INTENT ( intent-spec ) [::] etc.)
 *      or instrinsic-stmt  (is INTRINSIC etc.)
 *      or namelist-stmt    (is NAMELIST / namelist-group-name / etc.)
 *      or optional-stmt    (is OPTIONAL [::] etc.)
 *      or pointer-stmt     (is POINTER [::] object-name etc.)
 *      or save-stmt        (is SAVE etc.)
 *      or target-stmt      (is TARGET [::] object-name etc.)
 *
 *  access-spec is PUBLIC or PRIVATE
 */
static boolean parseSpecificationStmt (tokenInfo *const token)
{
	boolean result = TRUE;
	switch (token->keyword)
	{
		case KEYWORD_common:
			parseCommonNamelistStmt (token, TAG_COMMON_BLOCK);
			break;

		case KEYWORD_namelist:
			parseCommonNamelistStmt (token, TAG_NAMELIST);
			break;

		case KEYWORD_structure:
			parseStructureStmt (token);
			break;

		case KEYWORD_allocatable:
		case KEYWORD_data:
		case KEYWORD_dimension:
		case KEYWORD_equivalence:
		case KEYWORD_external:
		case KEYWORD_intent:
		case KEYWORD_intrinsic:
		case KEYWORD_optional:
		case KEYWORD_pointer:
		case KEYWORD_private:
		case KEYWORD_public:
		case KEYWORD_save:
		case KEYWORD_target:
			skipToNextStatement (token);
			break;

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

/*  component-def-stmt is
 *      type-spec [[, component-attr-spec-list] ::] component-decl-list
 *
 *  component-decl is
 *      component-name [ ( component-array-spec ) ] [ * char-length ]
 */
static void parseComponentDefStmt (tokenInfo *const token)
{
	Assert (isTypeSpec (token));
	parseTypeSpec (token);
	if (isType (token, TOKEN_COMMA))
		parseQualifierSpecList (token);
	if (isType (token, TOKEN_DOUBLE_COLON))
		readToken (token);
	parseEntityDeclList (token);
}

/*  derived-type-def is
 *      derived-type-stmt is (TYPE [[, access-spec] ::] type-name
 *          [private-sequence-stmt] ... (is PRIVATE or SEQUENCE)
 *          component-def-stmt
 *          [component-def-stmt] ...
 *          end-type-stmt
 */
static void parseDerivedTypeDef (tokenInfo *const token)
{
	if (isType (token, TOKEN_COMMA))
		parseQualifierSpecList (token);
	if (isType (token, TOKEN_DOUBLE_COLON))
		readToken (token);
	if (isType (token, TOKEN_IDENTIFIER))
		makeFortranTag (token, TAG_DERIVED_TYPE);
	ancestorPush (token);
	skipToNextStatement (token);
	if (isKeyword (token, KEYWORD_private) ||
		isKeyword (token, KEYWORD_sequence))
	{
		skipToNextStatement (token);
	}