fortran.c

ctags-5.5.4.tar.gz,一个很好的代码开发以及编辑源码

/*
*   $Id: fortran.c,v 1.41 2004/03/15 04:17:36 darren Exp $
*
*   Copyright (c) 1998-2003, Darren Hiebert
*
*   This source code is released for free distribution under the terms of the
*   GNU General Public License.
*
*   This module contains functions for generating tags for Fortran language
*   files.
*/

/*
*   INCLUDE FILES
*/
#include "general.h"	/* must always come first */

#include <string.h>
#include <limits.h>
#include <ctype.h>	/* to define tolower () */
#include <setjmp.h>

#include "debug.h"
#include "entry.h"
#include "keyword.h"
#include "options.h"
#include "parse.h"
#include "read.h"
#include "routines.h"
#include "vstring.h"

/*
*   MACROS
*/
#define isident(c)		(isalnum(c) || (c) == '_')
#define isBlank(c)		(boolean) (c == ' ' || c == '\t')
#define isType(token,t)		(boolean) ((token)->type == (t))
#define isKeyword(token,k)	(boolean) ((token)->keyword == (k))
#define isSecondaryKeyword(token,k)  (boolean) ((token)->secondary == NULL ? \
    FALSE : (token)->secondary->keyword == (k))

/*
*   DATA DECLARATIONS
*/

typedef enum eException {
    ExceptionNone, ExceptionEOF, ExceptionFixedFormat, ExceptionLoop
} exception_t;

/*  Used to designate type of line read in fixed source form.
 */
typedef enum eFortranLineType {
    LTYPE_UNDETERMINED,
    LTYPE_INVALID,
    LTYPE_COMMENT,
    LTYPE_CONTINUATION,
    LTYPE_EOF,
    LTYPE_INITIAL,
    LTYPE_SHORT
} lineType;

/*  Used to specify type of keyword.
 */
typedef enum eKeywordId {
    KEYWORD_NONE = -1,
    KEYWORD_allocatable,
    KEYWORD_assignment,
    KEYWORD_automatic,
    KEYWORD_block,
    KEYWORD_byte,
    KEYWORD_cexternal,
    KEYWORD_cglobal,
    KEYWORD_character,
    KEYWORD_common,
    KEYWORD_complex,
    KEYWORD_contains,
    KEYWORD_data,
    KEYWORD_dimension,
    KEYWORD_dllexport,
    KEYWORD_dllimport,
    KEYWORD_do,
    KEYWORD_double,
    KEYWORD_elemental,
    KEYWORD_end,
    KEYWORD_entry,
    KEYWORD_equivalence,
    KEYWORD_external,
    KEYWORD_format,
    KEYWORD_function,
    KEYWORD_if,
    KEYWORD_implicit,
    KEYWORD_include,
    KEYWORD_inline,
    KEYWORD_integer,
    KEYWORD_intent,
    KEYWORD_interface,
    KEYWORD_intrinsic,
    KEYWORD_logical,
    KEYWORD_map,
    KEYWORD_module,
    KEYWORD_namelist,
    KEYWORD_operator,
    KEYWORD_optional,
    KEYWORD_parameter,
    KEYWORD_pascal,
    KEYWORD_pexternal,
    KEYWORD_pglobal,
    KEYWORD_pointer,
    KEYWORD_precision,
    KEYWORD_private,
    KEYWORD_program,
    KEYWORD_public,
    KEYWORD_pure,
    KEYWORD_real,
    KEYWORD_record,
    KEYWORD_recursive,
    KEYWORD_save,
    KEYWORD_select,
    KEYWORD_sequence,
    KEYWORD_static,
    KEYWORD_stdcall,
    KEYWORD_structure,
    KEYWORD_subroutine,
    KEYWORD_target,
    KEYWORD_then,
    KEYWORD_type,
    KEYWORD_union,
    KEYWORD_use,
    KEYWORD_value,
    KEYWORD_virtual,
    KEYWORD_volatile,
    KEYWORD_where,
    KEYWORD_while
} keywordId;

/*  Used to determine whether keyword is valid for the token language and
 *  what its ID is.
 */
typedef struct sKeywordDesc {
    const char *name;
    keywordId id;
} keywordDesc;

typedef enum eTokenType {
    TOKEN_UNDEFINED,
    TOKEN_COMMA,
    TOKEN_DOUBLE_COLON,
    TOKEN_IDENTIFIER,
    TOKEN_KEYWORD,
    TOKEN_LABEL,
    TOKEN_NUMERIC,
    TOKEN_OPERATOR,
    TOKEN_PAREN_CLOSE,
    TOKEN_PAREN_OPEN,
    TOKEN_PERCENT,
    TOKEN_STATEMENT_END,
    TOKEN_STRING
} tokenType;

typedef enum eTagType {
    TAG_UNDEFINED = -1,
    TAG_BLOCK_DATA,
    TAG_COMMON_BLOCK,
    TAG_ENTRY_POINT,
    TAG_FUNCTION,
    TAG_INTERFACE,
    TAG_COMPONENT,
    TAG_LABEL,
    TAG_LOCAL,
    TAG_MODULE,
    TAG_NAMELIST,
    TAG_PROGRAM,
    TAG_SUBROUTINE,
    TAG_DERIVED_TYPE,
    TAG_VARIABLE,
    TAG_COUNT		/* must be last */
} tagType;

typedef struct sTokenInfo {
    tokenType type;
    keywordId keyword;
    tagType tag;
    vString* string;
    struct sTokenInfo *secondary;
    unsigned long lineNumber;
    fpos_t filePosition;
} tokenInfo;

/*
*   DATA DEFINITIONS
*/

static langType Lang_fortran;
static jmp_buf Exception;
static int Ungetc;
static unsigned int Column;
static boolean FreeSourceForm;
static boolean ParsingString;
static tokenInfo *Parent;

/* indexed by tagType */
static kindOption FortranKinds [] = {
    { TRUE,  'b', "block data", "block data"},
    { TRUE,  'c', "common",     "common blocks"},
    { TRUE,  'e', "entry",      "entry points"},
    { TRUE,  'f', "function",   "functions"},
    { FALSE, 'i', "interface",  "interface contents, generic names, and operators"},
    { TRUE,  'k', "component",  "type and structure components"},
    { TRUE,  'l', "label",      "labels"},
    { FALSE, 'L', "local",      "local, common block, and namelist variables"},
    { TRUE,  'm', "module",     "modules"},
    { TRUE,  'n', "namelist",   "namelists"},
    { TRUE,  'p', "program",    "programs"},
    { TRUE,  's', "subroutine", "subroutines"},
    { TRUE,  't', "type",       "derived types and structures"},
    { TRUE,  'v', "variable",   "program (global) and module variables"}
};

/* For a definition of Fortran 77 with extensions:
 * http://scienide.uwaterloo.ca/MIPSpro7/007-2362-004/sgi_html/index.html
 *
 * For the Compaq Fortran Reference Manual:
 * http://h18009.www1.hp.com/fortran/docs/lrm/dflrm.htm
 */

static const keywordDesc FortranKeywordTable [] = {
    /* keyword		keyword ID */
    { "allocatable",	KEYWORD_allocatable	},
    { "assignment",	KEYWORD_assignment	},
    { "automatic",	KEYWORD_automatic	},
    { "block",		KEYWORD_block		},
    { "byte",		KEYWORD_byte		},
    { "cexternal",	KEYWORD_cexternal	},
    { "cglobal",	KEYWORD_cglobal		},
    { "character",	KEYWORD_character	},
    { "common",		KEYWORD_common		},
    { "complex",	KEYWORD_complex		},
    { "contains",	KEYWORD_contains	},
    { "data",		KEYWORD_data		},
    { "dimension",	KEYWORD_dimension	},
    { "dll_export",	KEYWORD_dllexport	},
    { "dll_import",	KEYWORD_dllimport	},
    { "do",		KEYWORD_do		},
    { "double",		KEYWORD_double		},
    { "elemental",	KEYWORD_elemental	},
    { "end",		KEYWORD_end		},
    { "entry",		KEYWORD_entry		},
    { "equivalence",	KEYWORD_equivalence	},
    { "external",	KEYWORD_external	},
    { "format",		KEYWORD_format		},
    { "function",	KEYWORD_function	},
    { "if",		KEYWORD_if		},
    { "implicit",	KEYWORD_implicit	},
    { "include",	KEYWORD_include		},
    { "inline",		KEYWORD_inline		},
    { "integer",	KEYWORD_integer		},
    { "intent",		KEYWORD_intent		},
    { "interface",	KEYWORD_interface	},
    { "intrinsic",	KEYWORD_intrinsic	},
    { "logical",	KEYWORD_logical		},
    { "map",		KEYWORD_map		},
    { "module",		KEYWORD_module		},
    { "namelist",	KEYWORD_namelist	},
    { "operator",	KEYWORD_operator	},
    { "optional",	KEYWORD_optional	},
    { "parameter",	KEYWORD_parameter	},
    { "pascal",		KEYWORD_pascal		},
    { "pexternal",	KEYWORD_pexternal	},
    { "pglobal",	KEYWORD_pglobal		},
    { "pointer",	KEYWORD_pointer		},
    { "precision",	KEYWORD_precision	},
    { "private",	KEYWORD_private		},
    { "program",	KEYWORD_program		},
    { "public",		KEYWORD_public		},
    { "pure",		KEYWORD_pure		},
    { "real",		KEYWORD_real		},
    { "record",		KEYWORD_record		},
    { "recursive",	KEYWORD_recursive	},
    { "save",		KEYWORD_save		},
    { "select",		KEYWORD_select		},
    { "sequence",	KEYWORD_sequence	},
    { "static",		KEYWORD_static		},
    { "stdcall",	KEYWORD_stdcall		},
    { "structure",	KEYWORD_structure	},
    { "subroutine",	KEYWORD_subroutine	},
    { "target",		KEYWORD_target		},
    { "then",		KEYWORD_then		},
    { "type",		KEYWORD_type		},
    { "union",		KEYWORD_union		},
    { "use",		KEYWORD_use		},
    { "value",		KEYWORD_value		},
    { "virtual",	KEYWORD_virtual		},
    { "volatile",	KEYWORD_volatile	},
    { "where",		KEYWORD_where		},
    { "while",		KEYWORD_while		}
};

static struct {
    unsigned int count;
    unsigned int max;
    tokenInfo* list;
} Ancestors = { 0, 0, NULL };

/*
*   FUNCTION PROTOTYPES
*/
static void parseStructureStmt (tokenInfo *const token);
static void parseUnionStmt (tokenInfo *const token);
static void parseDerivedTypeDef (tokenInfo *const token);
static void parseFunctionSubprogram (tokenInfo *const token);
static void parseSubroutineSubprogram (tokenInfo *const token);

/*
*   FUNCTION DEFINITIONS
*/

static void ancestorPush (tokenInfo *const token)
{
    enum { incrementalIncrease = 10 };
    if (Ancestors.list == NULL)
    {
	Assert (Ancestors.max == 0);
	Ancestors.count = 0;
	Ancestors.max   = incrementalIncrease;
	Ancestors.list  = xMalloc (Ancestors.max, tokenInfo);
    }
    else if (Ancestors.count == Ancestors.max)
    {
	Ancestors.max += incrementalIncrease;
	Ancestors.list = xRealloc (Ancestors.list, Ancestors.max, tokenInfo);
    }
    Ancestors.list [Ancestors.count] = *token;
    Ancestors.list [Ancestors.count].string = vStringNewCopy (token->string);
    Ancestors.count++;
}

static void ancestorPop (void)
{
    Assert (Ancestors.count > 0);
    --Ancestors.count;
    vStringDelete (Ancestors.list [Ancestors.count].string);

    Ancestors.list [Ancestors.count].type       = TOKEN_UNDEFINED;
    Ancestors.list [Ancestors.count].keyword    = KEYWORD_NONE;
    Ancestors.list [Ancestors.count].secondary  = NULL;
    Ancestors.list [Ancestors.count].tag        = TAG_UNDEFINED;
    Ancestors.list [Ancestors.count].string     = NULL;
    Ancestors.list [Ancestors.count].lineNumber = 0L;
}

static const tokenInfo* ancestorScope (void)
{
    tokenInfo *result = NULL;
    unsigned int i;
    for (i = Ancestors.count  ;  i > 0  &&  result == NULL ;  --i)
    {
	tokenInfo *const token = Ancestors.list + i - 1;
	if (token->type == TOKEN_IDENTIFIER &&
	    token->tag != TAG_UNDEFINED  && token->tag != TAG_INTERFACE)
	    result = token;
    }
    return result;
}

static const tokenInfo* ancestorTop (void)
{
    Assert (Ancestors.count > 0);
    return &Ancestors.list [Ancestors.count - 1];
}

#define ancestorCount() (Ancestors.count)

static void ancestorClear (void)
{
    while (Ancestors.count > 0)
	ancestorPop ();
    if (Ancestors.list != NULL)
	eFree (Ancestors.list);
    Ancestors.list = NULL;
    Ancestors.count = 0;
    Ancestors.max = 0;
}

static boolean insideInterface (void)
{
    boolean result = FALSE;
    unsigned int i;
    for (i = 0  ;  i < Ancestors.count && !result ;  ++i)
    {
	if (Ancestors.list [i].tag == TAG_INTERFACE)
	    result = TRUE;
    }
    return result;
}

static void buildFortranKeywordHash (void)
{
    const size_t count = sizeof (FortranKeywordTable) /
			 sizeof (FortranKeywordTable [0]);
    size_t i;
    for (i = 0  ;  i < count  ;  ++i)
    {
	const keywordDesc* const p = &FortranKeywordTable [i];
	addKeyword (p->name, Lang_fortran, (int) p->id);
    }
}

/*
*   Tag generation functions
*/

static tokenInfo *newToken (void)
{
    tokenInfo *const token = xMalloc (1, tokenInfo);

    token->type	        = TOKEN_UNDEFINED;
    token->keyword      = KEYWORD_NONE;
    token->tag	        = TAG_UNDEFINED;
    token->string       = vStringNew ();
    token->secondary    = NULL;
    token->lineNumber   = getSourceLineNumber ();
    token->filePosition	= getInputFilePosition ();

    return token;
}

static tokenInfo *newTokenFrom (tokenInfo *const token)
{
    tokenInfo *result = newToken ();
    *result = *token;
    result->string = vStringNewCopy (token->string);
    token->secondary = NULL;
    return result;
}

static void deleteToken (tokenInfo *const token)
{
    if (token != NULL)
    {
	vStringDelete (token->string);
	deleteToken (token->secondary);
	token->secondary = NULL;
	eFree (token);
    }
}

static boolean isFileScope (const tagType type)
{
    return (boolean) (type == TAG_LABEL || type == TAG_LOCAL);
}

static boolean includeTag (const tagType type)
{
    boolean include;
    Assert (type != TAG_UNDEFINED);
    include = FortranKinds [(int) type].enabled;
    if (include && isFileScope (type))
	include = Option.include.fileScope;
    return include;
}

static void makeFortranTag (tokenInfo *const token, tagType tag)
{
    token->tag = tag;
    if (includeTag (token->tag))
    {
	const char *const name = vStringValue (token->string);
	tagEntryInfo e;

	initTagEntry (&e, name);

	if (token->tag == TAG_COMMON_BLOCK)
	    e.lineNumberEntry = (boolean) (Option.locate != EX_PATTERN);

	e.lineNumber	= token->lineNumber;
	e.filePosition	= token->filePosition;
	e.isFileScope	= isFileScope (token->tag);
	e.kindName	= FortranKinds [token->tag].name;
	e.kind		= FortranKinds [token->tag].letter;
	e.truncateLine	= (boolean) (token->tag != TAG_LABEL);

	if (ancestorCount () > 0)
	{
	    const tokenInfo* const scope = ancestorScope ();
	    if (scope != NULL)
	    {
		e.extensionFields.scope [0] = FortranKinds [scope->tag].name;
		e.extensionFields.scope [1] = vStringValue (scope->string);
	    }
	}
	if (! insideInterface () || includeTag (TAG_INTERFACE))
	    makeTagEntry (&e);
    }
}

/*
*   Parsing functions
*/

static int skipLine (void)
{
    int c;

    do
	c = fileGetc ();
    while (c != EOF  &&  c != '\n');

    return c;
}

static void makeLabelTag (vString *const label)
{
    tokenInfo *token = newToken ();
    token->type  = TOKEN_LABEL;
    vStringCopy (token->string, label);
    makeFortranTag (token, TAG_LABEL);
    deleteToken (token);
}

static lineType getLineType (void)
{
    static vString *label = NULL;
    int column = 0;
    lineType type = LTYPE_UNDETERMINED;

    if (label == NULL)
	label = vStringNew ();

    do		/* read in first 6 "margin" characters */
    {
	int c = fileGetc ();

	/* 3.2.1  Comment_Line.  A comment line is any line that contains
	 * a C or an asterisk in column 1, or contains only blank characters
	 * in  columns 1 through 72.  A comment line that contains a C or
	 * an asterisk in column 1 may contain any character capable  of
	 * representation in the processor in columns 2 through 72.
	 */
	/*  EXCEPTION! Some compilers permit '!' as a commment character here.
	 *
	 *  Treat # and $ in column 1 as comment to permit preprocessor directives.
	 *  Treat D and d in column 1 as comment for HP debug statements.
	 */
	if (column == 0  &&  strchr ("*Cc!#$Dd", c) != NULL)
	    type = LTYPE_COMMENT;
	else if (c == '\t')  /* EXCEPTION! Some compilers permit a tab here */
	{
	    column = 8;
	    type = LTYPE_INITIAL;
	}
	else if (column == 5)
	{
	    /* 3.2.2  Initial_Line.  An initial line is any line that is not
	     * a comment line and contains the character blank or the digit 0
	     * in column 6.  Columns 1 through 5 may contain a statement label
	     * (3.4), or each of the columns 1 through 5 must contain the