fortran.c

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

/*
*   $Id: fortran.c,v 1.42 2006/05/30 04:37:12 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