path: root/src/fortranscanner.l

/* -*- mode: fundamental; indent-tabs-mode: 1; -*- */
/*****************************************************************************
 * Parser for Fortran90 F subset
 *
 * Copyright (C) by Anke Visser
 * based on the work of Dimitri van Heesch.
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation under the terms of the GNU General Public License is hereby 
 * granted. No representations are made about the suitability of this software 
 * for any purpose. It is provided "as is" without express or implied warranty.
 * See the GNU General Public License for more details.
 *
 * Documents produced by Doxygen are derivative works derived from the
 * input used in their production; they are not affected by this license.
 *
 */ 

/* Developer notes.
 *
 * - Consider using startScope(), endScope() functions with  module, program, 
 * subroutine or any other scope in fortran program.
 *
 * - Symbol modifiers (attributes) are collected using SymbolModifiers |= operator during
 * substructure parsing. When substructure ends all modifiers are applied to actual
 * entries in applyModifiers() functions.
 * 
 * - How case insensitiveness should be handled in code?
 * On one side we have arg->name and entry->name, on another side modifierMap[name].
 * In entries and arguments case is the same as in code, in modifier map case is lowered and
 * then it is compared to lowered entry/argument names.
 *
 * - Do not like constructs like aa{BS} or {BS}bb. Should try to handle blank space
 * with separate rule?: It seems it is often necessary, because we may parse something like 
 * "functionA" or "MyInterface". So constructs like `(^|[ \t])interface({BS_}{ID})?/[ \t\n]'
 * are desired.
 */

%{

#include <stdio.h> 
#include <stdlib.h>
#include <assert.h>
#include <ctype.h>

#include "qtbc.h"
#include <qarray.h>
#include <qstack.h>
#include <qregexp.h>
#include <unistd.h> 
#include <qfile.h>
#include <qmap.h>
  
#include "fortranscanner.h"
#include "entry.h"
#include "message.h"
#include "config.h"
#include "doxygen.h"
#include "util.h"
#include "defargs.h"
#include "language.h"
#include "commentscan.h" 
#include "fortrancode.h"
#include "pre.h"

#define YY_NEVER_INTERACTIVE 1

enum ScanVar { V_IGNORE, V_VARIABLE, V_PARAMETER};

// {{{ ----- Helper structs -----
//! Holds modifiers (ie attributes) for one symbol (variable, function, etc)
struct SymbolModifiers {
  enum Protection {NONE_P, PUBLIC, PRIVATE};
  enum Direction {NONE_D, IN, OUT, INOUT};

  //!< This is only used with function return value.
  QCString type, returnName;
  Protection protection;
  Direction direction;
  bool optional;
  QCString dimension;
  bool allocatable;
  bool external;
  bool intrinsic;
  bool parameter;
  bool pointer;
  bool target;
  bool save;

  SymbolModifiers() : type(), returnName(), protection(NONE_P), direction(NONE_D),
    optional(FALSE), dimension(), allocatable(FALSE),
    external(FALSE), intrinsic(FALSE), parameter(FALSE),
    pointer(FALSE), target(FALSE), save(FALSE) {}

  SymbolModifiers& operator|=(const SymbolModifiers &mdfs);
  SymbolModifiers& operator|=(QCString mdfrString);
};

//ostream& operator<<(ostream& out, const SymbolModifiers& mdfs);

static const char *directionStrs[] = 
{
   "", "intent(in)", "intent(out)", "intent(inout)"
};

// }}}

/* -----------------------------------------------------------------
 *
 *	statics
 */
static ParserInterface *g_thisParser; 
static const char *     inputString;
static int		inputPosition;
static bool             isFixedForm;
static QCString         inputStringPrepass; ///< Input string for prepass of line cont. '&'
static unsigned int     inputPositionPrepass;
static int              lineCountPrepass = 0;

struct CommentInPrepass {
  int column;
  QCString str;
  CommentInPrepass(int column, QCString str) : column(column), str(str) {}
};
static QList<CommentInPrepass>  comments;

#define MAX_INCLUDE_DEPTH 10
YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH];
int include_stack_ptr = 0;

static QFile            inputFile;
static QCString		yyFileName;
static int		yyLineNr     = 1 ;
static Entry*		current_root = 0 ;
static Entry*		global_root  = 0 ;
static Entry*		file_root    = 0 ;
static Entry*		current      = 0 ;
static Entry*		last_entry   = 0 ;
static ScanVar          v_type       = V_IGNORE; // type of parsed variable
static QList<Entry>     moduleProcedures; // list of all interfaces which contain unresolved 
                                          // module procedures
static QCString         docBlock;
static QCString         docBlockName;
static bool             docBlockInBody;
static bool             docBlockJavaStyle;

static MethodTypes 	mtype;
static bool    		gstat;
static Specifier 	virt;

static QCString          debugStr;
static QCString          result; // function result
static Argument          *parameter; // element of parameter list
static QCString          argType;  // fortran type of an argument of a parameter list
static QCString          argName;  // last identifier name in variable list
static QCString          initializer;  // initial value of a variable
static int               initializerScope;  // number if nested array scopes in initializer
static QCString          useModuleName;  // name of module in the use statement
static Protection        defaultProtection;

static char              stringStartSymbol; // single or double quote

//! Accumulated modifiers of current statement, eg variable declaration.
static SymbolModifiers currentModifiers;
//! Holds program scope->symbol name->symbol modifiers.
static QMap<Entry*,QMap<QCString,SymbolModifiers> > modifiers;

//-----------------------------------------------------------------------------

static int yyread(char *buf,int max_size);
static void startCommentBlock(bool);
static void handleCommentBlock(const QCString &doc,bool brief);
static void addCurrentEntry();
static void addModule(const char *name, bool isModule=FALSE);
static void addSubprogram(const char *text);
static void addInterface(QCString name);
static Argument *addFortranParameter(const QCString &type,const QCString &name, const QCString docs);
static void scanner_abort();

static void startScope(Entry *scope);
static bool endScope(Entry *scope, bool isGlobalRoot=FALSE);
static QCString getFullName(Entry *e);
static bool isTypeName(QCString name);
static void resolveModuleProcedures(QList<Entry> &moduleProcedures, Entry *current_root);
static int getAmpersandAtTheStart(const char *buf, int length);
static int getAmpOrExclAtTheEnd(const char *buf, int length);
static void truncatePrepass(int index);
static void pushBuffer(QCString &buffer);
static void popBuffer();
static void extractPrefix(QCString& text);

//-----------------------------------------------------------------------------
#undef	YY_INPUT
#define	YY_INPUT(buf,result,max_size) result=yyread(buf,max_size);
//-----------------------------------------------------------------------------

%}

 //-----------------------------------------------------------------------------
 //-----------------------------------------------------------------------------
IDSYM	  [a-z_A-Z0-9]
NOTIDSYM  [^a-z_A-Z0-9]
SEPARATE  [:, \t]
ID        [a-z_A-Z%]+{IDSYM}*
PP_ID     {ID}
LABELID   [a-z_A-Z]+[a-z_A-Z0-9\-]*
SUBPROG   (subroutine|function|block)
B         [ \t]
BS        [ \t]*
BS_       [ \t]+
COMMA     {BS},{BS}
ARGS      {BS}("("[^)]*")")
NOARGS    {BS}"\n"

NUM_TYPE  (complex|integer|logical|real)
KIND      {ARGS}
CHAR      (CHARACTER{ARGS}?|CHARACTER{BS}"*"({BS}[0-9]+|{ARGS}))
TYPE_SPEC (({NUM_TYPE}({BS}"*"{BS}[0-9]+)?)|({NUM_TYPE}{KIND})|DOUBLE{BS_}PRECISION|{CHAR}|TYPE{ARGS})

INTENT_SPEC intent{BS}"("{BS}(in|out|in{BS}out){BS}")"
ATTR_SPEC (ALLOCATABLE|DIMENSION{ARGS}|EXTERNAL|{INTENT_SPEC}|INTRINSIC|OPTIONAL|PARAMETER|POINTER|PRIVATE|PUBLIC|SAVE|TARGET)
ACCESS_SPEC (PRIVATE|PUBLIC)
/* Assume that attribute statements are almost the same as attributes. */
ATTR_STMT {ATTR_SPEC}|DIMENSION|{ACCESS_SPEC}

CONTAINS  CONTAINS
PREFIX    (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTAL)?

%option noyywrap
%option stack
%option caseless
/*%option debug */

 //---------------------------------------------------------------------------------

 /** fortran parsing states */
%x	Subprog
%x	SubprogPrefix
%x	Parameterlist
%x	SubprogBody
%x	SubprogBodyContains
%x	Start
%x	Comment
%x      Module
%x      Program
%x      ModuleBody
%x	ModuleBodyContains
%x	AttributeList
%x      Variable
%x      Initialization
%x      ArrayInitializer
%x      Typedef
%x      TypedefBody
%x      InterfaceBody
%x      StrIgnore
%x      String
%x      Use
%x      UseOnly
%x      ModuleProcedure

%x      Prepass

 /** comment parsing states */
%x	DocBlock
%x	DocBackLine
%x	EndDoc

%%

 /*-----------------------------------------------------------------------------------*/

<*>^.*\n                                { // prepass: look for line continuations

                                          //fprintf(stderr, "---%s", yytext);

                                            int indexStart = getAmpersandAtTheStart(yytext, yyleng);                              
                                            int indexEnd = getAmpOrExclAtTheEnd(yytext, yyleng);
					    if (indexEnd>=0 && yytext[indexEnd]!='&') //we are only interested in amp
					      indexEnd=-1;

                                            if(indexEnd<0){ // ----- no ampersand as line continuation
                                               if(YY_START == Prepass) { // last line in "continuation"

                                                 // Only take input after initial ampersand
                                                 inputStringPrepass+=(const char*)(yytext+(indexStart+1));
   
                                                 pushBuffer(inputStringPrepass);
                                                 yy_pop_state();
                                               } else { // simple line
                                                 REJECT;
                                               }

                                            } else { // ----- line with continuation
                                              if(YY_START != Prepass) {
                                                comments.setAutoDelete(TRUE);
						comments.clear();
                                                yy_push_state(Prepass);
                                              }

                                              int length = inputStringPrepass.length();

                                              // Only take input after initial ampersand
                                              inputStringPrepass+=(const char*)(yytext+(indexStart+1));
                                              lineCountPrepass ++;

                                              // cut off & and remove following comment if present
					      truncatePrepass(length+indexEnd-(indexStart+1));
                                            }

                                        }


 /*------ ignore strings */ 
<*>"\\\\"                               { /* ignore \\  */}
<*>"\\\""|\\\'                          { /* ignore \" and \'  */}

<String>\"|\'                           { // string ends with next quote without previous backspace
                                          if (yytext[0]!=stringStartSymbol) REJECT; // single vs double quote
                                          // fprintf(stderr,"string end: %s\n",debugStr.data());
                                          yy_pop_state();
                                        }           

<String>.                               { debugStr+=yytext; } // ignore String contents (especially '!') 

<*>\"|\'                                { /* string starts */
					  if (YY_START == StrIgnore) REJECT; // ignore in simple comments
                                          // fprintf(stderr,"string start: %c %d\n",yytext[0],yyLineNr);
                                          yy_push_state(YY_START);
                                          stringStartSymbol=yytext[0]; // single or double quote
                                          BEGIN(String); debugStr="!^!";
                                        }

 /*------ ignore simple comment (not documentation comments) */

<*>"!"/[^<>\n]                         {  if (YY_START == String) REJECT; // "!" is ignored in strings
                                          // skip comment line (without docu comments "!>" "!<" ) 
                                          /* ignore further "!" and ignore comments in Strings */
                                          if ((YY_START != StrIgnore) && (YY_START != String)) 
					  {
                                            yy_push_state(YY_START);
                                            BEGIN(StrIgnore); 
                                            debugStr="*!";
                                            //fprintf(stderr,"start comment %d\n",yyLineNr);
                                           }      
                                        }
<StrIgnore>.?/\n                        { yy_pop_state(); // comment ends with endline character
                                          //fprintf(stderr,"end comment %d %s\n",yyLineNr,debugStr.data());
                                        } // comment line ends
<StrIgnore>.                            { debugStr+=yytext; } 


 /*------ use handling ------------------------------------------------------------*/

<Start,ModuleBody,TypedefBody,SubprogBody>"use"{BS_} {
                                          if(YY_START == Start)
                                          {
                                            addModule(NULL); 
                                            yy_push_state(ModuleBody); //anon program
                                          }
                                          yy_push_state(Use);
                                        }
<Use>{ID}                               { 
                                          //fprintf(stderr,"using dir %s\n",yytext);
                                          current->name=yytext;
                                          current->fileName = yyFileName; 
  					  current->section=Entry::USINGDIR_SEC;
					  current_root->addSubEntry(current);
					  current = new Entry;
                                          yy_pop_state();
                                        }
<Use>{ID}/,                             { 
                                          useModuleName=yytext;
                                        }
<Use>,{BS}"ONLY"                        { BEGIN(UseOnly); 
                                        }           
<UseOnly>{BS},{BS}                      {}
<UseOnly>{ID}                           {
  					  current->name= useModuleName+"::"+yytext;
                                          current->fileName = yyFileName; 
  					  current->section=Entry::USINGDECL_SEC;
					  current_root->addSubEntry(current);
					  current = new Entry ;
  					}
<Use,UseOnly>"\n"                       {
                                          unput(*yytext);
                                          yy_pop_state();
                                        }

 /*------ ignore special fortran statements */
<Start,ModuleBody,SubprogBody>^[ \t]*interface({BS_}{ID}({BS}\({BS}[^ \t()]+{BS}\))?)?/{BS}(!|\n) { // handle interface block
                                          if(YY_START == Start)
                                          {
                                            addModule(NULL); 
                                            yy_push_state(ModuleBody); //anon program
                                          }

					  QCString name = yytext;
					  int index = name.find("interface", 0, FALSE);
					  index = name.find(QRegExp("[^ \\t]"), index+9);
					  //printf(stderr,"%s,%d\n",name.data(),index);
					  if (index!=-1)
					    name = name.right(name.length()-index);
					  else // interface without name, must be inside subprog
					    name = "interface"; 
					  addInterface(name);
					  yy_push_state(InterfaceBody);
 					  startScope(last_entry);
                                        }
<InterfaceBody>^{BS}"end"({BS}"interface"({BS_}{ID})?)?{BS}/(\n|!)   {
					  if (!endScope(current_root))
					    yyterminate();
					  yy_pop_state();
                                        }
<InterfaceBody>module{BS}procedure      { yy_push_state(YY_START);
                                          BEGIN(ModuleProcedure);
                                        }
<ModuleProcedure>{ID}                   {                       			
                                          current->section = Entry::FUNCTION_SEC ;
                                          current->name = yytext; 
 	                                  moduleProcedures.append(current);
                                          addCurrentEntry();
                                        }
<ModuleProcedure>"\n"                   { unput(*yytext); 
                                          yy_pop_state();
                                        }
<InterfaceBody>.                        {}

 /*-- Contains handling --*/
<Start>^{BS}{CONTAINS}/({BS}|\n|!)      {
                                          if(YY_START == Start)
                                          {
                                            addModule(NULL); 
                                            yy_push_state(ModuleBodyContains); //anon program
                                          }                                            
                                        }
<ModuleBody>^{BS}{CONTAINS}/({BS}|\n|!)   { BEGIN(ModuleBodyContains); }
<SubprogBody>^{BS}{CONTAINS}/({BS}|\n|!)  { BEGIN(SubprogBodyContains); }

 /*------ module handling ------------------------------------------------------------*/ 
<Start>module|program{BS_}             {  //
					    if(yytext[0]=='m' || yytext[0]=='M')
					      yy_push_state(Module);
					    else
					      yy_push_state(Program);
                                            defaultProtection = Public;
                                       }
<Start,ModuleBody,ModuleBodyContains>^{BS}"end"({BS}(module|program)({BS_}{ID})?)?{BS}/(\n|!) { // end module	
					    resolveModuleProcedures(moduleProcedures, current_root);
					    if (!endScope(current_root))
					      yyterminate();
                                            defaultProtection = Public;
					    yy_pop_state();
                                       }
<Module>{ID}                           {  
                                            addModule(yytext, TRUE);
					    BEGIN(ModuleBody);
                                       }

<Program>{ID}                           {  
                                            addModule(yytext, FALSE);
					    BEGIN(ModuleBody);
                                       }

  /*------- access specification --------------------------------------------------------------------------*/

<ModuleBody>private/{BS}(\n|"!")         { defaultProtection = Private; }
<ModuleBody>public/{BS}(\n|"!")          { defaultProtection = Public; }

 /*------- type definition  -------------------------------------------------------------------------------*/

<Start,ModuleBody>"type"({BS_}|({COMMA}{ACCESS_SPEC})) { /* type definition found : TYPE , access-spec::type-name |*/
                                          if(YY_START == Start)
                                          {
                                            addModule(NULL); 
                                            yy_push_state(ModuleBody); //anon program
                                          }

 					    yy_push_state(Typedef);
					    current->protection = defaultProtection;
                                        }
<Typedef>{ACCESS_SPEC}          	{ 	
                                            QCString type= yytext;				    
                                        }
<Typedef>{ID}                        	{ /* type name found */
                                            //cout << "=========> got typedef " << yytext << ": " << yyLineNr << endl; 
                                            current->section = Entry::CLASS_SEC; // was Entry::STRUCT_SEC;
   					    current->spec = Entry::Struct;        	
  					    current->name = yytext;

                                            /* if type is part of a module, mod name is necessary for output */
                                            if ((current_root) && 
                                               (current_root->section ==  Entry::CLASS_SEC ||
					        current_root->section ==  Entry::NAMESPACE_SEC))
						//current_root->section ==  Entry::INTERFACE_SEC)) 
					    {
                                              current->name= current_root->name+"::"+current->name;
                                            }
					    current->fileName = yyFileName;
					    current->bodyLine  = yyLineNr; 
                                            addCurrentEntry();
					    startScope(last_entry); 
                                            BEGIN(TypedefBody);
                                        }
<TypedefBody>^{BS}"end"{BS}"type"({BS_}{ID})?{BS}/(\n|!)         { /* end type definition */
                                           //printf("=========> got typedef end \n"); 
					   if (!endScope(current_root))
					     yyterminate();
                                           yy_pop_state();
                                        } 

 /*------- module/global/typedef variable ---------------------------------------------------*/

<SubprogBody,SubprogBodyContains>^{BS}"end"({BS}{SUBPROG}({BS_}{ID})?)?{BS}/(\n|!) {  
                                           //fprintf(stderr,"1e=========> got end subprog: %s\n", yytext);

                                           /* args is used for parameters in list of functions, argList for 
                                             parameters in detailed function descripttion */
                                           //current->args = argListToString(current->argList); 
					   //current->endBodyLine  = yyLineNr; // ??? what ist endBodyLine for
					   if (!endScope(current_root))
					     yyterminate();
					   yy_pop_state() ;
				       } 
<Start,ModuleBody,TypedefBody,SubprogBody>{
^{BS}{TYPE_SPEC}/{SEPARATE}			{
                                          /* variable declaration starts */
                                          if(YY_START == Start)
                                          {
                                            addModule(NULL); 
                                            yy_push_state(ModuleBody); //anon program
                                          }
                                          //fprintf(stderr,"4=========> got variable type: %s\n",yytext);
 					  QCString help=yytext;
					  help= help.simplifyWhiteSpace();
					  argType= help;
					  yy_push_state(AttributeList);
                                        }
^{BS}{PP_ID}{KIND}?			{ /* check for preprocessor symbol expand to type */
					  QCString str = yytext;
					  str = str.stripWhiteSpace();
					  DefineDict* defines = getFileDefineDict();
					  QCString name;
					  int index = str.find("(");
					  if (index != -1)
					    name = str.left(index).stripWhiteSpace();
					  else
					    name = str;

					  Define *define = (*defines)[name];
					  if (define != 0 && isTypeName(define->definition)) 
					  {
					    argType = str;
					    yy_push_state(AttributeList);
					  } 
					  else 
					  {
					    REJECT;
					  }
					}
{ATTR_STMT}/{BS_}{ID}		       |
{ATTR_STMT}/{BS}"::"                   { 
                                          /* attribute statement starts */
                                          //fprintf(stderr,"5=========> Attribute statement: %s\n", yytext); 
                                          QCString tmp = yytext;
                                          currentModifiers |= tmp.stripWhiteSpace();
					  argType="";
					  yy_push_state(YY_START);
					  BEGIN( AttributeList ) ;
  				       }
{ID}	                               {
                                       }  
}
<AttributeList>{
{COMMA}					{}
{BS}					{}
{ATTR_SPEC}				{ /* update current modifiers */
                                          QCString tmp = yytext;
                                          currentModifiers |= (tmp);
					}
"::"					{ /* end attribute list */
					  BEGIN( Variable );
					}
.					{ /* unknown attribute, consider variable name */
					  //cout<<"start variables, unput "<<*yytext<<endl;
					  unput(*yytext);
					  BEGIN( Variable );
					}
}

<Variable>{BS}				{}
<Variable>{ID}				{ /* parse variable declaration */
                                          //cout << "5=========> got variable: " << argType << "::" << yytext << endl;
 					  /* work around for bug in QCString.replace (QCString works) */
					  QCString name=yytext;
					  /* remember attributes for the symbol */
					  modifiers[current_root][name.lower()] |= currentModifiers;
					  argName= name;

					  v_type= V_IGNORE;
  					  if (!argType.isEmpty() && current_root->section!=Entry::FUNCTION_SEC) 
					  { // new variable entry
					    v_type = V_VARIABLE;
                                            current->section = Entry::VARIABLE_SEC;
 					    current->name = argName;
					    current->type = argType;
					    current->fileName = yyFileName;
					    current->bodyLine  = yyLineNr; // used for source reference
                                            addCurrentEntry();
                                          } 
					  else if (!argType.isEmpty())
					  { // deklaration of parameter list: add type for corr. parameter 
					    parameter= addFortranParameter(argType,argName,docBlock);
					    if (parameter) v_type= V_PARAMETER;
					    // save, it may be function return type
					    modifiers[current_root][name.lower()].type = argType;
					    // any accumulated doc for argument should be emptied,
					    // because it is handled other way and this doc can be
					    // unexpectedly passed to the next member.
					    current->doc.resize(0);
					    current->brief.resize(0);
                                          } 
  					}
<Variable>{ARGS}			{ /* dimension of the previous entry. */
					  QCString name(argName);
					  QCString attr("dimension");
					  attr += yytext;
					  modifiers[current_root][name] |= attr;
					}
<Variable>{COMMA}	                {}
<Variable>{BS}"="                       { yy_push_state(YY_START);
                                          initializer="";
                                          initializerScope = 0;
					  BEGIN(Initialization);
                                        }
<Variable>"\n"	                        { currentModifiers = SymbolModifiers();
                                          yy_pop_state(); // end variable deklaration list
                                          yyLineNr++; yyLineNr+=lineCountPrepass; lineCountPrepass=0;
                                          docBlock.resize(0);
                                        }

<Initialization,ArrayInitializer>"(/"   { initializer+=yytext;
                                           initializerScope++;
                                           BEGIN(ArrayInitializer); // initializer may contain comma
                                        }
<ArrayInitializer>"/)"                   { initializer+=yytext;
                                           initializerScope--;
                                           if(initializerScope<=0)
                                           {
                                              initializerScope = 0; // just in case
                                              BEGIN(Initialization);
                                           }
                                        }
<ArrayInitializer>.                     { initializer+=yytext; }
<Initialization>{COMMA}                 { yy_pop_state(); // end initialization
                                          if (v_type == V_VARIABLE) last_entry->initializer= initializer;
                                        }
<Initialization>"\n"|"!"                { //| 
                                          yy_pop_state(); // end initialization
                                          if (v_type == V_VARIABLE) last_entry->initializer= initializer;
 					  unput(*yytext);
                                        }
<Initialization>.                       { initializer+=yytext; }
 
 /*------ fortran subroutine/function handling ------------------------------------------------------------*/
 /*       Start is initial condition                                                                       */
 
<Start,ModuleBody,SubprogBody,InterfaceBody,ModuleBodyContains,SubprogBodyContains>^{BS}({PREFIX}{BS_})?{TYPE_SPEC}{BS}/{SUBPROG}{BS_} {   
		                           // TYPE_SPEC is for old function style function result
                                           result= yytext;
                                           result= result.stripWhiteSpace();
                                           extractPrefix(result);
                                           //fprintf(stderr, "===%s\n", (const char*)result);
  					   current->type = result;
                                           yy_push_state(SubprogPrefix);
                                       }          

<SubprogPrefix>{BS}{SUBPROG}{BS_}     {
                                         // Fortran subroutine or function found
                                         addSubprogram(yytext);
                                         BEGIN(Subprog);
                                       }

<Start,ModuleBody,SubprogBody,InterfaceBody,ModuleBodyContains,SubprogBodyContains>^{BS}({PREFIX}{BS_})?{SUBPROG}{BS_} {
                                         // Fortran subroutine or function found
                                         result= yytext;
                                         result= result.stripWhiteSpace();
                                         extractPrefix(result);
                                         addSubprogram(result);
                                         yy_push_state(Subprog);
                                       }

<Subprog>{BS}                          {   /* ignore white space */   }
<Subprog>{ID}                          {   current->name = yytext;
					   //cout << "1a==========> got " << current->type << " " << yytext << " " << yyLineNr << endl;
					   modifiers[current_root][current->name.lower()].returnName = current->name;
					   BEGIN(Parameterlist);
                                       } 
<Parameterlist>{ARGS}                  {   
				           //current->type not yet available
                                           QCString arglist= yytext;
					   //cout << "3=========> got parameterlist " << yytext << endl;
                                           //yyLineNr+= arglist.contains('\n');
					   //static QRegExp re("&[^\n]*\n");
                                           //arglist = arglist.replace(re,"");
					   //cout << "3=========> got parameterlist " << arglist << endl;
					   current->args = arglist;
					   current->args = removeRedundantWhiteSpace(current->args);
					   stringToArgumentList(current->args, current->argList);
                                           addCurrentEntry();
					   startScope(last_entry);
					   BEGIN(SubprogBody);
 				       } 
<Parameterlist>{NOARGS}                {   
                                           yyLineNr++; yyLineNr+=lineCountPrepass; lineCountPrepass=0;
					   //printf("3=========> without parameterlist \n");
 					   stringToArgumentList("", current->argList);
                                           addCurrentEntry();
					   startScope(last_entry);
					   BEGIN(SubprogBody);				           
}
<SubprogBody>result{BS}\({BS}{ID}      {  
                                           result= yytext;
                                           result= result.right(result.length()-result.find("(")-1);
                                           result= result.stripWhiteSpace();
 					   modifiers[current_root->parent()][current_root->name.lower()].returnName = result;
                                           //cout << "=====> got result " <<  result << endl;
 				       } 

 /*---- documentation comments --------------------------------------------------------------------*/

<Variable>"!<"                           { /* backward docu comment (only one line) */
                                          if (v_type != V_IGNORE) {
                                           yy_push_state(YY_START);
					   current->docLine  = yyLineNr;
 					   docBlockJavaStyle = FALSE;
					   docBlock.resize(0);
					   docBlockJavaStyle = Config_getBool("JAVADOC_AUTOBRIEF");
					   startCommentBlock(TRUE);
					   BEGIN(DocBackLine);
                                          }
  					 }
<DocBackLine>.*    			 { // contents of current comment line
                                          docBlock=yytext;
					  if (v_type == V_VARIABLE) 
					  {
					    Entry *tmp_entry = current; 
					    current = last_entry; // temporarily switch to the previous entry
  					    handleCommentBlock(docBlock,TRUE);
 					    current=tmp_entry;
                                          }
					  else if (v_type == V_PARAMETER) 
					  {
					    parameter->docs=docBlock;
                                          }
                                          yy_pop_state();
 					 }
   
<Start,SubprogBody,ModuleBody,TypedefBody,InterfaceBody,ModuleBodyContains,SubprogBodyContains>"!>"  {
                                          yy_push_state(YY_START);
					  current->docLine  = yyLineNr;
 					  docBlockJavaStyle = FALSE;
					  docBlock.resize(0);
					  docBlockJavaStyle = Config_getBool("JAVADOC_AUTOBRIEF");
					  startCommentBlock(TRUE);
					  BEGIN(DocBlock);
                                          //cout << "start DocBlock " << endl;
					}

<DocBlock>.*    			{ // contents of current comment line
                                          docBlock+=yytext;
  					}
<DocBlock>"\n"{BS}"!"(">"|"!"+)		{ // comment block (next line is also comment line)
					  docBlock+="\n"; // \n is necessary for lists
                                          yyLineNr++; yyLineNr+=lineCountPrepass; lineCountPrepass=0;
  					}
<DocBlock>"\n"        			{ // comment block ends at the end of this line
                                          //cout <<"3=========> comment block : "<< docBlock << endl;
					  unput(*yytext);                                        
 					  handleCommentBlock(docBlock,TRUE);
                                          yy_pop_state();                                          
  					}

 /*------------------------------------------------------------------------------------------------*/

<*>"\n"                                 {
                                          yyLineNr++; yyLineNr+=lineCountPrepass; lineCountPrepass=0;
                                          //if (debugStr.stripWhiteSpace().length() > 0) cout << "ignored text: " << debugStr << " state: " <<YY_START << endl;
                                          debugStr="";
                                        }


 /*---- error: EOF in wrong state --------------------------------------------------------------------*/

<*><<EOF>>                              {
                                          if ( include_stack_ptr <= 0 ) {
                                            if (YY_START!=INITIAL && YY_START!=Start) {
                                              //fprintf(stderr,"==== Error: EOF reached in wrong state (end missing)");
                                              scanner_abort();
                                            }
                                            yyterminate();
                                          } else {
                                            popBuffer();
                                          }
                                        }
 <*>.                 	                {
                                          //debugStr+=yytext;
					  //printf("I:%c\n", *yytext);
                                        } // ignore remaining text 

 /**********************************************************************************/
 /**********************************************************************************/
 /**********************************************************************************/
%%
//----------------------------------------------------------------------------

static void extractPrefix(QCString &text) {
  int prefixIndex = 0;
  int curIndex = 0;
  bool cont = TRUE;
  const char* pre[] = {"RECURSIVE","PURE","ELEMENTAL"};
  while(cont)
  {
    cont = FALSE;
    for(unsigned int i=0; i<3; i++)
    {
      if((prefixIndex=text.find(pre[i], curIndex, FALSE))==0)
      {
        text.remove(0,strlen(pre[i]));
        text.stripWhiteSpace();
        cont = TRUE;
      }
    }
  }
}

static int getAmpersandAtTheStart(const char *buf, int length)
{
  for(int i=0; i<length; i++) {
    switch(buf[i]) {
      case ' ':
      case '\t':
        break;
      case '&':
        return i;
      default:
        return -1;
    }
  }
  return -1;
}

/* Returns ampersand index, comment start index or -1 if neither exist.*/ 
static int getAmpOrExclAtTheEnd(const char *buf, int length)
{
  // Avoid ampersands in string and comments
  int parseState = Start;
  char quoteSymbol = 0;
  int ampIndex = -1;
  int commentIndex = -1;

  for(int i=0; i<length && parseState!=Comment; i++)
  {
    // When in string, skip backslashes
    // Legacy code, not sure whether this is correct?
    if(parseState==String)
    {
      if(buf[i]=='\\') i++;
    }

    switch(buf[i])
    {
        case '\'':
        case '"':
          // Close string, if quote symbol matches.
          // Quote symbol is set iff parseState==String
          if(buf[i]==quoteSymbol)
          {
             parseState = Start;
             quoteSymbol = 0;
          }
          // Start new string, if not already in string or comment
          else if(parseState==Start)
          {
            parseState = String;
            quoteSymbol = buf[i];
          }
          ampIndex = -1; // invalidate prev ampersand
          break;
        case '!':
          // When in string or comment, ignore exclamation mark
          if(parseState==Start)
          {
            parseState = Comment;
            commentIndex = i;
          }
          break;
        case ' ':  // ignore whitespace
        case '\t':
        case '\n': // this may be at the end of line
          break;
        case '&':
          ampIndex = i;
          break;
        default:
          ampIndex = -1; // invalidate prev ampersand
    }
  }

  if (ampIndex>=0)
    return ampIndex;
  else
   return commentIndex;
}

/* Although comments at the end of continuation line are grabbed by this function,
* we still do not know how to use them later in parsing.
*/
void truncatePrepass(int index)
{
  int length = inputStringPrepass.length();
  for (int i=index+1; i<length; i++) {
    if (inputStringPrepass[i]=='!') { // save comment 
      //printf("-----SAVE----- %d:%s", i, (const char*)inputStringPrepass.right(length-i));
      struct CommentInPrepass *c=new CommentInPrepass(index, inputStringPrepass.right(length-i));
      comments.append(c);
    }
  }
  inputStringPrepass.truncate(index);
}

// simplified way to know if this is fixed form
// duplicate in fortrancode.l
static bool recognizeFixedForm(const char* contents)
{
  int column=0;
  bool skipLine=FALSE;

  for(int i=0;;i++) {
    column++;

    switch(contents[i]) {
      case '\n':
        column=0;
        skipLine=FALSE;
        break;
      case ' ':
        break;
      case '\000':
        return FALSE;
      case 'C':
      case 'c':
      case '*':
        if(column==1) return TRUE;
        if(skipLine) break;
        return FALSE;
      case '!':
        if(column>1 && column<7) return FALSE;
        skipLine=TRUE;
        break;
      default:
        if(skipLine) break;
        if(column==7) return TRUE;
        return FALSE;
    }
  }
  return FALSE;
}

/* This function assumes that contents has at least size=length+1 */
static void insertCharacter(char *contents, int length, int pos, char c)
{
  // shift tail by one character
  for(int i=length; i>pos; i--)
    contents[i]=contents[i-1];
  // set the character
  contents[pos] = c;
}

/* change comments and bring line continuation character to previous line */
static const char* prepassFixedForm(const char* contents)
{
  int column=0;
  int prevLineLength=0;
  int prevLineAmpOrExclIndex=-1;
  bool emptyLabel=TRUE;
  int newContentsSize = strlen(contents)+2; // \000 and one spare character (to avoid reallocation)
  char* newContents = (char*)malloc(newContentsSize);

  for(int i=0, j=0;;i++,j++) {
    if(j>=newContentsSize-1) { // check for one spare character, which may be eventually used below (by &)
      newContents = (char*)realloc(newContents, newContentsSize+1000);
      newContentsSize = newContentsSize+1000;
    }

    column++;
    char c = contents[i];
    switch(c) {
      case '\n':
        prevLineLength=column;
        prevLineAmpOrExclIndex=getAmpOrExclAtTheEnd(&contents[i-prevLineLength+1], prevLineLength);
        column=0;
	emptyLabel=TRUE;
        newContents[j]=c;
        break;
      case ' ':
        newContents[j]=c;
        break;
      case '\000':
        newContents[j]='\000';
        return newContents;
      case 'C':
      case 'c':
      case '*':
	emptyLabel=FALSE;
        if(column==1)
	  newContents[j]='!';
        else
          newContents[j]=c;
        break;
      default:
        if(column==6 && emptyLabel) { // continuation
          newContents[j]=' ';

          if(prevLineAmpOrExclIndex==-1) { // add & just before end of previous line
            insertCharacter(newContents, j+1, (j+1)-6-1, '&');
            j++;
          } else { // add & just before end of previous line comment
            insertCharacter(newContents, j+1, (j+1)-6-prevLineLength+prevLineAmpOrExclIndex, '&');
            j++;
          }
	} else {
	  newContents[j]=c;
	  emptyLabel=FALSE;
	}
        break;
    }
  }
  return newContents;
}

static void pushBuffer(QCString& buffer)
{
  if ( include_stack_ptr >= MAX_INCLUDE_DEPTH )
  {
    fprintf( stderr, "Stack buffers nested too deeply" );
    exit( 1 );
  }
  include_stack[include_stack_ptr++] = YY_CURRENT_BUFFER;
  yy_switch_to_buffer(yy_scan_string(buffer));

  //fprintf(stderr, "--PUSH--%s", (const char *)buffer);
  buffer = NULL;
}

static void popBuffer() {
  //fprintf(stderr, "--POP--");
  include_stack_ptr --;
  yy_delete_buffer( YY_CURRENT_BUFFER );
  yy_switch_to_buffer( include_stack[include_stack_ptr] );
}

/** used to copy entry to an interface module procedure */
static void copyEntry(Entry *dest, Entry *src) 
{
   dest->type     = src->type;
   dest->fileName = src->fileName;
   dest->bodyLine = src->bodyLine;
   dest->args     = src->args;
   dest->argList  = new ArgumentList(*src->argList);
}

/** fill empty interface module procedures with info from 
    corresponding module subprogs 
    @TODO: handle procedures in used modules
*/
void resolveModuleProcedures(QList<Entry> &moduleProcedures, Entry *current_root)
{
  if (moduleProcedures.isEmpty()) return;
 
  EntryListIterator eli1(moduleProcedures);
  // for all module procedures
  for (Entry *ce1; (ce1=eli1.current()); ++eli1) 
  {
    // check all entries in this module
    EntryListIterator eli2(*current_root->children());
    for (Entry *ce2; (ce2=eli2.current()); ++eli2) 
    {
      if (ce1->name == ce2->name) 
      {
        copyEntry(ce1, ce2);
      }
    } // for procedures in current module
  } // for all interface module procedures
  moduleProcedures.clear();
}

static bool isTypeName(QCString name)
{
  name = name.lower();
  return name=="integer" || name == "real" || 
    name=="complex" || name == "logical";
}

/*! Extracts string which resides within parentheses of provided string. */
static QCString extractFromParens(const QCString name)
{
  QCString extracted = name;
  int start = extracted.find("(");
  if (start != -1) 
  {
    extracted.remove(0, start+1);
  }
  int end = extracted.findRev(")");
  if (end != -1) 
  {
    int length = extracted.length();
    extracted.remove(end, length);
  }
  extracted = extracted.stripWhiteSpace();

  return extracted;
}

/*! Adds passed modifiers to these modifiers.*/
SymbolModifiers& SymbolModifiers::operator|=(const SymbolModifiers &mdfs)
{
  if (mdfs.protection!=NONE_P) protection = mdfs.protection;
  if (mdfs.direction!=NONE_D) direction = mdfs.direction;
  optional |= mdfs.optional;
  if (!mdfs.dimension.isNull()) dimension = mdfs.dimension;
  allocatable |= mdfs.allocatable;
  external |= mdfs.external;
  intrinsic |= mdfs.intrinsic;
  parameter |= mdfs.parameter;
  pointer |= mdfs.pointer;
  target |= mdfs.target;
  save |= mdfs.save;
  return *this;
}

/*! Extracts  and adds passed modifier to these modifiers.*/
SymbolModifiers& SymbolModifiers::operator|=(QCString mdfString)
{
  mdfString = mdfString.lower();
  SymbolModifiers newMdf;

  if (mdfString.find("dimension")==0) 
  {
    newMdf.dimension=mdfString;
  }
  else if (mdfString.contains("intent")) 
  {
    QCString tmp = extractFromParens(mdfString);
    bool isin = tmp.contains("in");
    bool isout = tmp.contains("out");
    if (isin && isout) newMdf.direction = SymbolModifiers::INOUT;
    else if (isin) newMdf.direction = SymbolModifiers::IN;
    else if (isout) newMdf.direction = SymbolModifiers::OUT;
  }
  else if (mdfString=="public") 
  {
    newMdf.protection = SymbolModifiers::PUBLIC;
  }
  else if (mdfString=="private") 
  {
    newMdf.protection = SymbolModifiers::PRIVATE;
  }
  else if (mdfString=="optional") 
  {
    newMdf.optional = TRUE;
  }
  else if (mdfString=="allocatable") 
  {
    newMdf.allocatable = TRUE;
  }
  else if (mdfString=="external") 
  {
    newMdf.external = TRUE;
  }
  else if (mdfString=="intrinsic") 
  {
    newMdf.intrinsic = TRUE;
  }
  else if (mdfString=="parameter") 
  {
    newMdf.parameter = TRUE;
  }
  else if (mdfString=="pointer") 
  {
    newMdf.pointer = TRUE;
  }
  else if (mdfString=="target") 
  {
    newMdf.target = TRUE;
  }
  else if (mdfString=="save") 
  {
    newMdf.save = TRUE;
  }

  (*this) |= newMdf;
  return *this;
}

/*! For debugging purposes. */
//ostream& operator<<(ostream& out, const SymbolModifiers& mdfs)
//{
//  out<<mdfs.protection<<", "<<mdfs.direction<<", "<<mdfs.optional<<
//    ", "<<(mdfs.dimension.isNull() ? "" : mdfs.dimension.latin1())<<
//    ", "<<mdfs.allocatable<<", "<<mdfs.external<<", "<<mdfs.intrinsic;
//
//  return out;
//}

/*! Find argument with given name in \a subprog entry. */
static Argument *findArgument(Entry* subprog, QCString name, bool byTypeName = FALSE)
{
  QCString cname(name.lower());
  for (unsigned int i=0; i<subprog->argList->count(); i++) 
  {
    Argument *arg = subprog->argList->at(i);
    if ((!byTypeName && arg->name.lower() == cname) ||
	(byTypeName && arg->type.lower() == cname)
       )
    {
      return arg;
    }
  }
  return 0;
}

/*! Find function with given name in \a entry. */
#if 0
static Entry *findFunction(Entry* entry, QCString name)
{
  QCString cname(name.lower());

  EntryListIterator eli(*entry->children());
  Entry *ce;
  for (;(ce=eli.current());++eli) 
  {
    if (ce->section != Entry::FUNCTION_SEC)
      continue;

    if (ce->name.lower() == cname)
      return ce;
  }

  return 0;
}
#endif

/*! Apply modifiers stored in \a mdfs to the \a typeName string. */
static QCString applyModifiers(QCString typeName, SymbolModifiers& mdfs) 
{
  if (!mdfs.dimension.isNull()) 
  {
    typeName += ",";
    typeName += mdfs.dimension;
  }
  if (mdfs.direction!=SymbolModifiers::NONE_D) 
  {
    typeName += ",";
    typeName += directionStrs[mdfs.direction];
  }
  if (mdfs.optional) 
  {
    typeName += ",";
    typeName += "optional";
  }
  if (mdfs.allocatable) 
  {
    typeName += ",";
    typeName += "allocatable";
  }
  if (mdfs.external) 
  {
    typeName += ",";
    typeName += "external";
  }
  if (mdfs.intrinsic) 
  {
    typeName += ",";
    typeName += "intrinsic";
  }
  if (mdfs.parameter) 
  {
    typeName += ",";
    typeName += "parameter";
  }
  if (mdfs.pointer) 
  {
    typeName += ",";
    typeName += "pointer";
  }
  if (mdfs.target) 
  {
    typeName += ",";
    typeName += "target";
  }
  if (mdfs.save) 
  {
    typeName += ",";
    typeName += "save";
  }

  return typeName;
}

/*! Apply modifiers stored in \a mdfs to the \a arg argument. */
static void applyModifiers(Argument *arg, SymbolModifiers& mdfs)
{
  QCString tmp = arg->type;
  arg->type = applyModifiers(tmp, mdfs);
}

/*! Apply modifiers stored in \a mdfs to the \a ent entry. */
static void applyModifiers(Entry *ent, SymbolModifiers& mdfs)
{
  QCString tmp = ent->type;
  ent->type = applyModifiers(tmp, mdfs);

  if (mdfs.protection == SymbolModifiers::PUBLIC)
    ent->protection = Public;
  else if (mdfs.protection == SymbolModifiers::PRIVATE)
    ent->protection = Private;
}

/*! Starts the new scope in fortran program. Consider using this function when
 * starting module, interface, function or other program block.
 * \see endScope()
 */
static void startScope(Entry *scope) 
{
  //cout<<"start scope: "<<scope->name<<endl;
  current_root= scope; /* start substructure */

  QMap<QCString,SymbolModifiers> mdfMap;
  modifiers.insert(scope, mdfMap);
}

/*! Ends scope in fortran program: may update subprogram arguments or module variable attributes.
 * \see startScope()
 */
static bool endScope(Entry *scope, bool isGlobalRoot)
{
  //cout<<"end scope: "<<scope->name<<endl;
  if (current_root->parent() || isGlobalRoot)
  {
    current_root= current_root->parent(); /* end substructure */
  }
  else 
  {
    fprintf(stderr,"parse error in end <scopename>");
    scanner_abort();
    return FALSE;
  }

  // update variables or subprogram arguments with modifiers
  QMap<QCString,SymbolModifiers>& mdfsMap = modifiers[scope];

  if (scope->section == Entry::FUNCTION_SEC) 
  {
    // iterate all symbol modifiers of the scope
    for (QMap<QCString,SymbolModifiers>::Iterator it=mdfsMap.begin(); it!=mdfsMap.end(); it++) 
    {
      //cout<<it.key()<<": "<<it.data()<<endl;
      Argument *arg = findArgument(scope, it.key());

      if (arg)
        applyModifiers(arg, it.data());
    }

    // find return type for function
    //cout<<"RETURN NAME "<<modifiers[current_root][scope->name.lower()].returnName<<endl;
    QCString returnName = modifiers[current_root][scope->name.lower()].returnName.lower();
    if (modifiers[scope].contains(returnName)) 
    {
      scope->type = modifiers[scope][returnName].type; // returning type works
      applyModifiers(scope, modifiers[scope][returnName]); // returning array works
    }

  } 
  if (scope->section == Entry::CLASS_SEC) 
  { // was INTERFACE_SEC
    if (scope->parent()->section == Entry::FUNCTION_SEC) 
    { // interface within function
      // iterate functions of interface and 
      // try to find types for dummy(ie. argument) procedures.
      //cout<<"Search in "<<scope->name<<endl;
      EntryListIterator eli(*scope->children());
      Entry *ce;
      for (;(ce=eli.current());++eli) 
      {
        if (ce->section != Entry::FUNCTION_SEC)
          continue;

        Argument *arg = findArgument(scope->parent(), ce->name, TRUE);
        if (arg != 0) 
	{
          // set type of dummy procedure argument to interface
	  arg->name = arg->type;
          arg->type = scope->name;
        }
      }
    }
  } 
  if (scope->section!=Entry::FUNCTION_SEC) 
  { // not function section 
    // iterate variables: get and apply modifiers
    EntryListIterator eli(*scope->children());
    Entry *ce;
    for (;(ce=eli.current());++eli) 
    {
      if (ce->section != Entry::VARIABLE_SEC && ce->section != Entry::FUNCTION_SEC)
        continue;

      //cout<<ce->name<<", "<<mdfsMap.contains(ce->name.lower())<<mdfsMap.count()<<endl;
      if (mdfsMap.contains(ce->name.lower()))
        applyModifiers(ce, mdfsMap[ce->name.lower()]);
    }
  }

  // clear all modifiers of the scope
  modifiers.remove(scope);

  return TRUE;
}

//! Return full name of the entry. Sometimes we must combine several names recursively.
static QCString getFullName(Entry *e) 
{
  QCString name = e->name;
  if (e->section == Entry::CLASS_SEC //  || e->section == Entry::INTERFACE_SEC
     || !e->parent() || e->parent()->name.isEmpty())
    return name;

  return getFullName(e->parent())+"::"+name;
}

static int yyread(char *buf,int max_size)
{
  int c=0;

  while ( c < max_size && inputString[inputPosition] )
  {
    *buf = inputString[inputPosition++] ;
    c++; buf++;
  }
  return c;
}

static void initParser()
{
  last_entry = 0;
}

static void initEntry()
{
  current->protection = defaultProtection ;
  current->mtype      = mtype;
  current->virt       = virt;
  current->stat       = gstat;
  initGroupInfo(current);
}

/**
  adds current entry to current_root and creates new current
*/
static void addCurrentEntry()
{
  //printf("===Adding entry %s to %s\n", current->name.data(), current_root->name.data());
  current_root->addSubEntry(current);
  last_entry = current;
  current = new Entry ;
  initEntry();
}

static int max(int a, int b) {return a>b?a:b;}

static void addModule(const char *name, bool isModule)
{
  //fprintf(stderr, "0=========> got module %s\n", name);

  if (isModule)
    current->section = Entry::NAMESPACE_SEC;
  else
    current->section = Entry::FUNCTION_SEC;

  if (name!=NULL)
  {
    current->name = name;
  } 
  else
  {
    QCString fname = yyFileName;
    int index = max(fname.findRev('/'), fname.findRev('\\'));
    fname = fname.right(fname.length()-index-1);
    fname = fname.prepend("__").append("__");
    current->name = fname;
  }
  current->type = "program";
  current->fileName  = yyFileName;
  current->bodyLine  = yyLineNr; // used for source reference
  current->protection = Public ;
  addCurrentEntry();
  startScope(last_entry);
}


static void addSubprogram(const char *text)
{
  //fprintf(stderr,"1=========> got subprog, type: %s\n",text); 
  current->section = Entry::FUNCTION_SEC ;
  QCString subtype = text; subtype=subtype.lower().stripWhiteSpace();
  if (!current->type) current->type = subtype;
  current->fileName  = yyFileName;
  current->bodyLine  = yyLineNr; // used for source reference
  current->startLine = -1; // ??? what is startLine for?
  current->args.resize(0);
  current->argList->clear();
  docBlock.resize(0);
}

/*! Adds interface to the root entry.
 * \note Code was brought to this procedure from the parser,
 * because there was/is idea to use it in several parts of the parser.
 */ 
static void addInterface(QCString name) 
{
  current->section = Entry::CLASS_SEC; // was Entry::INTERFACE_SEC;
  current->spec = Entry::Interface;
  current->name = name;

  /* if type is part of a module, mod name is necessary for output */
  if ((current_root) && 
      (current_root->section ==  Entry::CLASS_SEC ||
       current_root->section ==  Entry::NAMESPACE_SEC)) 
  {
    current->name= current_root->name+"::"+current->name;
  }
  if ((current_root) &&
      (current_root->section ==  Entry::FUNCTION_SEC)) 
  {
    current->name = getFullName(current_root) + "__" + QCString(current->name);
  }

  current->fileName = yyFileName;
  current->bodyLine  = yyLineNr; 
  addCurrentEntry();
}


//-----------------------------------------------------------------------------

/*! Update the argument \a name with additional \a type info. 
 */
static Argument *addFortranParameter(const QCString &type,const QCString &name, const QCString docs)
{
  //cout<<"addFortranParameter(): "<<name<<" DOCS:"<<(docs.isNull()?QCString("null"):docs)<<endl;
  Argument *ret = 0;
  if (current_root->argList==0) return 0;
  ArgumentListIterator ali(*current_root->argList);
  Argument *a;
  for (ali.toFirst();(a=ali.current());++ali)
  {
    if (a->type.lower()==name.lower())
    {
      ret=a;
//cout << "addParameter found:   " << type << " , " << name << endl;
      a->type=type.stripWhiteSpace();
      a->name=name.stripWhiteSpace();
      if (!docs.isNull())
        a->docs = docs;
      break;
    }
  } // for
  return ret;
}

  //----------------------------------------------------------------------------
static void startCommentBlock(bool brief)
{
  if (brief)
  {
    current->briefFile = yyFileName;
    current->briefLine = yyLineNr;
  }
  else
  {
    current->docFile = yyFileName;
    current->docLine = yyLineNr;
  }
}

  //----------------------------------------------------------------------------
static void handleCommentBlock(const QCString &doc,bool brief)
{
  docBlockInBody = FALSE;
  bool needsEntry = FALSE;
  static bool hideInBodyDocs = Config_getBool("HIDE_IN_BODY_DOCS");
  int position=0;
  if (docBlockInBody && hideInBodyDocs) return;
  //fprintf(stderr,"call parseCommentBlock [%s]\n",doc.data());
  while (parseCommentBlock(
	g_thisParser,
	docBlockInBody ? last_entry : current,
	doc,        // text
	yyFileName, // file
	brief ? current->briefLine : current->docLine,   // line of block start
	docBlockInBody ? FALSE : brief, 
	docBlockInBody ? FALSE : docBlockJavaStyle,
	docBlockInBody,
	defaultProtection,
        position,
        needsEntry
        )) 
  {
	   //fprintf(stderr,"parseCommentBlock position=%d [%s]  needsEntry=%d\n",position,doc.data()+position,needsEntry);
   if (needsEntry) addCurrentEntry();
  }
  //fprintf(stderr,"parseCommentBlock position=%d [%s]  needsEntry=%d\n",position,doc.data()+position,needsEntry);

  if (needsEntry) addCurrentEntry();
}

//----------------------------------------------------------------------------
static int level=0;
static void debugCompounds(Entry *rt)  // print Entry structure (for debugging)
{
 level++;
  printf("%d) debugCompounds(%s) line %d\n",level, rt->name.data(), rt->bodyLine);
  EntryListIterator eli(*rt->children());
  Entry *ce;
  for (;(ce=eli.current());++eli)
  {
     debugCompounds(ce); 
  } 
level--;
}


static void parseMain(const char *fileName,const char *fileBuf,Entry *rt)
{
  initParser();

  defaultProtection = Public;
  inputString = fileBuf;
  inputPosition = 0;
  inputStringPrepass = NULL;
  inputPositionPrepass = 0;

  //anonCount     = 0;  // don't reset per file
  mtype         = Method;
  gstat         = FALSE;
  virt          = Normal;
  current_root  = rt;
  global_root   = rt;
  inputFile.setName(fileName);
  if (inputFile.open(IO_ReadOnly))
  {
    isFixedForm = recognizeFixedForm(fileBuf);

    if (isFixedForm) {
      printf("Prepassing fixed form of %s\n", yyFileName.data());
      //printf("---strlen=%d\n", strlen(fileBuf));
      //clock_t start=clock();

      inputString = prepassFixedForm(fileBuf);

      //clock_t end=clock();
      //printf("CPU time used=%f\n", ((double) (end-start))/CLOCKS_PER_SEC);
    }

    yyLineNr= 1 ; 
    yyFileName = fileName;
    msg("Parsing file %s...\n",yyFileName.data());

    startScope(rt); // implies current_root = rt
    initParser();
    groupEnterFile(yyFileName,yyLineNr);

    current          = new Entry;
    current->name    = yyFileName;
    current->section = Entry::SOURCE_SEC;
    current_root->addSubEntry(current);
    file_root        = current;
    current          = new Entry;

    fscanYYrestart( fscanYYin );
    {
      BEGIN( Start );
    }

    fscanYYlex();
    groupLeaveFile(yyFileName,yyLineNr);

    endScope(current_root, TRUE); // TRUE - global root

    //debugCompounds(rt); //debug 

    rt->program.resize(0);
    delete current; current=0;
    moduleProcedures.clear();
    if (isFixedForm) {
      free((char*)inputString);
      inputString=NULL;
    }

    inputFile.close();
  }
}

//----------------------------------------------------------------------------

void FortranLanguageScanner::parseInput(const char *fileName,const char *fileBuf,Entry *root)
{
  g_thisParser = this;
  ::parseMain(fileName,fileBuf,root);
}

void FortranLanguageScanner::parseCode(CodeOutputInterface & codeOutIntf,
                   const char * scopeName,
                   const QCString & input,
                   bool isExampleBlock,
                   const char * exampleName,
                   FileDef * fileDef,
                   int startLine,
                   int endLine,
                   bool inlineFragment,
		   MemberDef *memberDef
                  )
{
  ::parseFortranCode(codeOutIntf,scopeName,input,isExampleBlock,exampleName,
                     fileDef,startLine,endLine,inlineFragment,memberDef);
}

bool FortranLanguageScanner::needsPreprocessing(const QCString &extension)
{
  (void)extension;
  return TRUE;
}
void FortranLanguageScanner::resetCodeParserState()
{
  ::resetFortranCodeParserState();
}

void FortranLanguageScanner::parsePrototype(const char *text)
{
  (void)text;
}

static void scanner_abort() 
{
  fprintf(stderr,"********************************************************************\n");
  fprintf(stderr,"Error in file %s line: %d, state: %d\n",yyFileName.data(),yyLineNr,YY_START);
  fprintf(stderr,"********************************************************************\n");
   
  EntryListIterator eli(*global_root->children());
  Entry *ce;
  bool start=FALSE;

  for (;(ce=eli.current());++eli)
  {
     if (ce == file_root) start=TRUE;
     if (start) ce->reset(); 
  } 

  // dummy call to avoid compiler warning
  (void)yy_top_state();
  
  return;
  //exit(-1);
}

//----------------------------------------------------------------------------

#if !defined(YY_FLEX_SUBMINOR_VERSION) 
//----------------------------------------------------------------------------
extern "C" { // some bogus code to keep the compiler happy
  void fscannerYYdummy() { yy_flex_realloc(0,0); } 
}
#endif