fortran.c

ultraEdit的Ctag标签工具的实现源代码

}

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);