fortran.c

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

    }
    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=8 shiftwidth=4: */