/*
*   $Id: fortran.c,v 1.37 2003/07/21 03:38:50 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
} 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
	     * character blank.
	     */
	    if (c == ' '  ||  c == '0')
		type = LTYPE_INITIAL;

	    /* 3.2.3  Continuation_Line.  A continuation line is any line that
	     * contains any character of the FORTRAN character set other than
	     * the character blank or the digit 0 in column 6 and contains
	     * only blank characters in columns 1 through 5.
	     */
	    else if (vStringLength (label) == 0)
		type = LTYPE_CONTINUATION;
	    else
		type = LTYPE_INVALID;
	}
	else if (c == ' ')
	    ;
	else if (c == EOF)
	    type = LTYPE_EOF;
	else if (c == '\n')
	    type = LTYPE_SHORT;
	else if (isdigit (c))
	    vStringPut (label, c);
	else
	    type = LTYPE_INVALID;

	++column;
    } while (column < 6  &&  type == LTYPE_UNDETERMINED);

    Assert (type != LTYPE_UNDETERMINED);

    if (vStringLength (label) > 0)
    {
	vStringTerminate (label);
	makeLabelTag (label);
	vStringClear (label);
    }
    return type;
}

static int getFixedFormChar (void)
{
    boolean newline = FALSE;
    lineType type;
    int c = '\0';

    if (Column > 0)
    {
#ifdef STRICT_FIXED_FORM
	/*  EXCEPTION! Some compilers permit more than 72 characters per line.
	 */
	if (Column > 71)
	    c = skipLine ();
	else
#endif
	{
	    c = fileGetc ();
	    ++Column;
	}
	if (c == '\n')
	{
	    newline = TRUE;	/* need to check for continuation line */
	    Column = 0;
	}
	else if (c == '!'  &&  ! ParsingString)
	{
	    c = skipLine ();
	    newline = TRUE;	/* need to check for continuation line */
	    Column = 0;
	}
	else if (c == '&')	/* check for free source form */
	{
	    const int c2 = fileGetc ();
	    if (c2 == '\n')
		longjmp (Exception, (int) ExceptionFixedFormat);
	    else
		fileUngetc (c2);
	}
    }
    while (Column == 0)
    {
	type = getLineType ();
	switch (type)
	{
	    case LTYPE_UNDETERMINED:
	    case LTYPE_INVALID:
		longjmp (Exception, (int) ExceptionFixedFormat);
		break;

	    case LTYPE_SHORT: break;
	    case LTYPE_COMMENT: skipLine (); break;

	    case LTYPE_EOF:
		Column = 6;
		if (newline)
		    c = '\n';
		else
		    c = EOF;
		break;

	    case LTYPE_INITIAL:
		if (newline)
		{
		    c = '\n';
		    Column = 6;
		    break;
		}
		/* fall through to next case */
	    case LTYPE_CONTINUATION:
		Column = 5;
		do
		{
		    c = fileGetc ();
		    ++Column;
		} while (isBlank (c));
		if (c == '\n')
		    Column = 0;
		else if (Column > 6)
		{
		    fileUngetc (c);
		    c = ' ';
		}
		break;

	    default:
		Assert ("Unexpected line type" == NULL);
	}
    }
    return c;
}

static int skipToNextLine (void)
{
    int c = skipLine ();
    if (c != EOF)
	c = fileGetc ();
    return c;
}

static int getFreeFormChar (void)
{
    static boolean newline = TRUE;
    boolean recurse = FALSE;
    int c = fileGetc ();

    if (c == '&')		/* handle line continuation */
    {
	recurse = TRUE;
	c = fileGetc ();
    }
    else if (newline && (c == '!' || c == '#'))
	recurse = TRUE;
    while (recurse)
    {
	while (isspace (c))
	    c = fileGetc ();
	while (c == '!' || (newline && c == '#'))
	{
	    c = skipToNextLine ();
	    newline = TRUE;
	}
	if (c == '&')
	    c = fileGetc ();
	else
	    recurse = FALSE;
    }
    newline = (boolean) (c == '\n');
    return c;
}

static int getChar (void)
{
    int c;

    if (Ungetc != '\0')
    {
	c = Ungetc;
	Ungetc = '\0';
    }
    else if (FreeSourceForm)
	c = getFreeFormChar ();
    else
	c = getFixedFormChar ();

    return c;
}

static void ungetChar (const int c)
{
    Ungetc = c;
}

/*  If a numeric is passed in 'c', this is used as the first digit of the
 *  numeric being parsed.
 */
static vString *parseInteger (int c)
{
    static vString *string = NULL;

    if (string == NULL)
	string = vStringNew ();
    vStringClear (string);

    if (c == '-')
    {
	vStringPut (string, c);
	c = getChar ();
    }
    else if (! isdigit (c))
	c = getChar ();
    while (c != EOF  &&  isdigit (c))
    {
	vStringPut (string, c);
	c = getChar ();
    }
    vStringTerminate (string);

    if (c == '_')
    {
	do
	    c = getChar ();
	while (c != EOF  &&  isalpha (c));
    }
    ungetChar (c);

    return string;
}

static vString *parseNumeric (int c)
{
    static vString *string = NULL;

    if (string == NULL)
	string = vStringNew ();
    vStringCopy (string, parseInteger (c));

    c = getChar ();
    if (c == '.')
    {
	vStringPut (string, c);
	vStringCat (string, parseInteger ('\0'));
	c = getChar ();
    }
    if (tolower (c) == 'e')
    {
	vStringPut (string, c);
	vStringCat (string, parseInteger ('\0'));
    }
    else
	ungetChar (c);

    vStringTerminate (string);

    return string;
}

static void parseString (vString *const string, const int delimeter)
{
    const unsigned long inputLineNumber = getInputLineNumber ();
    int c;
    ParsingString = TRUE;
    c = getChar ();
    while (c != delimeter  &&  c != '\n'  &&  c != EOF)
    {
	vStringPut (string, c);
	c = getChar ();
    }
    if (c == '\n'  ||  c == EOF)
    {
	verbose ("%s: unterminated character string at line %lu\n",
		getInputFileName (), inputLineNumber);
	if (c == EOF)
	    longjmp (Exception, (int) ExceptionEOF);
	else if (! FreeSourceForm)
	    longjmp (Exception, (int) ExceptionFixedFormat);
    }
    vStringTerminate (string);
    ParsingString = FALSE;
}

/*  Read a C identifier beginning with "firstChar" and places it into "name".
 */
static void parseIdentifier (vString *const string, const int firstChar)
{
    int c = firstChar;

    do
    {
	vStringPut (string, c);
	c = getChar ();
    } while (isident (c));

    vStringTerminate (string);
    ungetChar (c);		/* unget non-identifier character */
}

/*  Analyzes the identifier contained in a statement described by the
 *  statement structure and adjusts the structure according the significance
 *  of the identifier.
 */
static keywordId analyzeToken (vString *const name)
{
    static vString *keyword = NULL;
    keywordId id;

    if (keyword == NULL)
	keyword = vStringNew ();
    vStringCopyToLower (keyword, name);
    id = (keywordId) lookupKeyword (vStringValue (keyword), Lang_fortran);

    return id;
}

static void checkForLabel (void)
{
    tokenInfo* token = NULL;
    int length;
    int c;

    do
	c = getChar ();
    while (isBlank (c));

    for (length = 0  ;  isdigit (c)  &&  length < 5  ;  ++length)
    {
	if (token == NULL)
	{
	    token = newToken ();
	    token->type = TOKEN_LABEL;
	}
	vStringPut (token->string, c);
	c = getChar ();
    }
    if (length > 0)
    {
	Assert (token != NULL);
	vStringTerminate (token->string);
	makeFortranTag (token, TAG_LABEL);
	deleteToken (token);
    }
    ungetChar (c);
}

static void readIdentifier (tokenInfo *const token, const int c)
{
    parseIdentifier (token->string, c);
    token->keyword = analyzeToken (token->string);
    if (! isKeyword (token, KEYWORD_NONE))
	token->type = TOKEN_KEYWORD;
    else
    {
	token->type = TOKEN_IDENTIFIER;
	if (strncmp (vStringValue (token->string), "end", 3) == 0)
	{
	    vString *const sub = vStringNewInit (vStringValue (token->string) + 3);
	    const keywordId kw = analyzeToken (sub);
	    vStringDelete (sub);
	    if (kw != KEYWORD_NONE)
	    {
		token->secondary = newToken ();
		token->secondary->type = TOKEN_KEYWORD;
		token->secondary->keyword = kw;
		token->keyword = KEYWORD_end;
	    }
	}
    }
}

static void readToken (tokenInfo *const token)
{
    int c;

    deleteToken (token->secondary);
    token->type        = TOKEN_UNDEFINED;
    token->tag         = TAG_UNDEFINED;
    token->keyword     = KEYWORD_NONE;
    token->secondary   = NULL;
    vStringClear (token->string);

getNextChar:
    c = getChar ();

    token->lineNumber	= getSourceLineNumber ();
    token->filePosition	= getInputFilePosition ();

    switch (c)
    {
	case EOF:  longjmp (Exception, (int) ExceptionEOF);	break;
	case ' ':  goto getNextChar;
	case '\t': goto getNextChar;
	case ',':  token->type = TOKEN_COMMA;		break;
	case '(':  token->type = TOKEN_PAREN_OPEN;	break;
	case ')':  token->type = TOKEN_PAREN_CLOSE;	break;
	case '%':  token->type = TOKEN_PERCENT;		break;

	case '*':
	case '/':
	case '+':
	case '-':
	case '=':
	case '<':
	case '>':
	{
	    const char *const operatorChars = "*/+-=<>";

	    do {
		vStringPut (token->string, c);
		c = getChar ();
	    } while (strchr (operatorChars, c) != NULL);
	    ungetChar (c);
	    vStringTerminate (token->string);
	    token->type = TOKEN_OPERATOR;
	    break;
	}

	case '!':
	    if (FreeSourceForm)
	    {
		do
		   c = getChar ();
		while (c != '\n');
	    }
	    else
	    {
		skipLine ();
		Column = 0;
	    }
	    /* fall through to newline case */
	case '\n':
	    token->type = TOKEN_STATEMENT_END;
	    if (FreeSourceForm)
		checkForLabel ();
	    break;

	case '.':
	    parseIdentifier (token->string, c);
	    c = getChar ();
	    if (c == '.')
	    {
		vStringPut (token->string, c);
		vStringTerminate (token->string);
		token->type = TOKEN_OPERATOR;
	    }
	    else
	    {
		ungetChar (c);
		token->type = TOKEN_UNDEFINED;
	    }
	    break;

	case '"':
	case '\'':
	    parseString (token->string, c);
	    token->type = TOKEN_STRING;
	    break;

	case ';':
	    token->type = TOKEN_STATEMENT_END;
	    break;

	case ':':
	    c = getChar ();
	    if (c == ':')
		token->type = TOKEN_DOUBLE_COLON;
	    else
	    {
		ungetChar (c);
		token->type = TOKEN_UNDEFINED;
	    }
	    break;

	default:
	    if (isalpha (c))
		readIdentifier (token, c);
	    else if (isdigit (c))
	    {
		vStringCat (token->string, parseNumeric (c));
		token->type = TOKEN_NUMERIC;
	    }
	    else
		token->type = TOKEN_UNDEFINED;
	    break;
    }
}

static void readSubToken (tokenInfo *const token)
{
    if (token->secondary == NULL)
    {
	token->secondary = newToken ();
	readToken (token->secondary);
    }
    Assert (token->secondary != NULL);
}

/*
*   Scanning functions
*/

static void skipToToken (tokenInfo *const token, tokenType type)
{
    while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END) &&
	    !(token->secondary != NULL && isType (token->secondary, TOKEN_STATEMENT_END)))
	readToken (token);
}

static void skipPast (tokenInfo *const token, tokenType type)
{
    skipToToken (token, type);
    if (! isType (token, TOKEN_STATEMENT_END))
	readToken (token);
}

static void skipToNextStatement (tokenInfo *const token)
{
    do
    {
	skipToToken (token, TOKEN_STATEMENT_END);
	readToken (token);
    } while (isType (token, TOKEN_STATEMENT_END));
}

/* skip over parenthesis enclosed contents starting at next token.
 * Token is left at the first token following closing parenthesis. If an
 * opening parenthesis is not found, `token' is moved to the end of the
 * statement.
 */
static void skipOverParens (tokenInfo *const token)
{
    int level = 0;
    do {
	if (isType (token, TOKEN_STATEMENT_END))
	    break;
	else if (isType (token, TOKEN_PAREN_OPEN))
	    ++level;
	else if (isType (token, TOKEN_PAREN_CLOSE))
	    --level;
	readToken (token);
    } while (level > 0);
}

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);
    }
    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 void parseSpecificationPart (tokenInfo *const token)
{
    while (skipStatementIfKeyword (token, KEYWORD_use))
	;
    while (parseImplicitPartStmt (token))
	;
    while (parseDeclarationConstruct (token))
	;
}

/*  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;
    Assert (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 void parseExecutionPart (tokenInfo *const token)
{
    boolean done = FALSE;
    while (! done)
    {
	switch (token->keyword)
	{
	    default:
		if (isSubprogramPrefix (token))
		    readToken (token);
		else
		    skipToNextStatement (token);
		break;

	    case KEYWORD_entry:
		parseEntryStmt (token);
		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);
		}
		else
		    done = TRUE;
		break;
	}
    }
}

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
		{
		    parseSpecificationPart (token);
		    parseExecutionPart (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: */
