summaryrefslogtreecommitdiffstats
path: root/src/fortranscanner.l
diff options
context:
space:
mode:
Diffstat (limited to 'src/fortranscanner.l')
-rw-r--r--src/fortranscanner.l199
1 files changed, 139 insertions, 60 deletions
diff --git a/src/fortranscanner.l b/src/fortranscanner.l
index 3156eb1..03f75d4 100644
--- a/src/fortranscanner.l
+++ b/src/fortranscanner.l
@@ -66,6 +66,7 @@
#define YY_NEVER_INTERACTIVE 1
enum ScanVar { V_IGNORE, V_VARIABLE, V_PARAMETER};
+enum InterfaceType { IF_NONE, IF_SPECIFIC, IF_GENERIC, IF_ABSTRACT };
// {{{ ----- Helper structs -----
//! Holds modifiers (ie attributes) for one symbol (variable, function, etc)
@@ -86,11 +87,15 @@ struct SymbolModifiers {
bool pointer;
bool target;
bool save;
+ bool nopass;
+ bool pass;
+ QCString passVar;
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) {}
+ pointer(FALSE), target(FALSE), save(FALSE),
+ nopass(FALSE), pass(FALSE), passVar() {}
SymbolModifiers& operator|=(const SymbolModifiers &mdfs);
SymbolModifiers& operator|=(QCString mdfrString);
@@ -158,6 +163,7 @@ static int initializerArrayScope; // number if nested array scope
static int initializerScope; // number if nested function calls in initializer
static QCString useModuleName; // name of module in the use statement
static Protection defaultProtection;
+static InterfaceType ifType = IF_NONE;
static char stringStartSymbol; // single or double quote
@@ -174,7 +180,7 @@ 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 void addInterface(QCString name, InterfaceType type);
static Argument *addFortranParameter(const QCString &type,const QCString &name, const QCString docs);
static void scanner_abort();
@@ -205,7 +211,7 @@ 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)
+SUBPROG (subroutine|function)
B [ \t]
BS [ \t]*
BS_ [ \t]+
@@ -220,11 +226,12 @@ 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})
+TYPE_SPEC (({NUM_TYPE}({BS}"*"{BS}[0-9]+)?)|({NUM_TYPE}{KIND})|DOUBLE{BS_}PRECISION|{CHAR}|TYPE{ARGS}|PROCEDURE{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)
+ATTR_SPEC (ALLOCATABLE|DIMENSION{ARGS}|EXTERNAL|{INTENT_SPEC}|INTRINSIC|OPTIONAL|PARAMETER|POINTER|PRIVATE|PUBLIC|SAVE|TARGET|NOPASS|PASS{ARGS})
ACCESS_SPEC (PRIVATE|PUBLIC)
+LANGUAGE_BIND_SPEC BIND{BS}"("{BS}C{BS}(,{BS}NAME{BS}"="{BS}"\""(.*)"\""{BS})?")"
/* Assume that attribute statements are almost the same as attributes. */
ATTR_STMT {ATTR_SPEC}|DIMENSION|{ACCESS_SPEC}
@@ -403,38 +410,52 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
yy_pop_state();
}
- /*------ ignore special fortran statements */
-<Start,ModuleBody,SubprogBody>^[ \t]*interface({BS_}{ID}({ARGS}?)?)?/{BS}(!|\n) { // handle interface block
- if(YY_START == Start)
- {
- addModule(NULL);
- yy_push_state(ModuleBody); //anon program
- }
+ /* INTERFACE definitions */
+<Start,ModuleBody,SubprogBody>{
+^{BS}interface { ifType = IF_SPECIFIC;
+ yy_push_state(InterfaceBody);
+ // do not start a scope here, every
+ // interface body is a scope of its own
+ }
- 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);
+^{BS}abstract{BS_}interface { ifType = IF_ABSTRACT;
+ yy_push_state(InterfaceBody);
+ // do not start a scope here, every
+ // interface body is a scope of its own
}
-<InterfaceBody>^{BS}"end"({BS}"interface"({BS_}{ID}{ARGS}?)?)?{BS}/(\n|!) {
- if (!endScope(current_root))
- yyterminate();
- yy_pop_state();
+
+^{BS}interface{BS_}{ID} { ifType = IF_GENERIC;
+ yy_push_state(InterfaceBody);
+
+ // extract generic name
+ QCString name = QCString(yytext).stripWhiteSpace();
+ name = name.right(name.length() - 9).stripWhiteSpace();
+ addInterface(name, ifType);
+
+ startScope(last_entry);
+ }
+}
+
+<InterfaceBody>^{BS}end{BS}interface({BS_}{ID})? {
+ // end scope only if GENERIC interface
+ if (ifType == IF_GENERIC && !endScope(current_root))
+ yyterminate();
+
+ ifType = IF_NONE;
+ yy_pop_state();
}
<InterfaceBody>module{BS}procedure { yy_push_state(YY_START);
BEGIN(ModuleProcedure);
}
-<ModuleProcedure>{ID} {
+<ModuleProcedure>{ID} { if (ifType == IF_ABSTRACT || ifType == IF_SPECIFIC)
+ {
+ addInterface(yytext, ifType);
+ startScope(last_entry);
+ }
+
current->section = Entry::FUNCTION_SEC ;
current->name = yytext;
- moduleProcedures.append(current);
+ moduleProcedures.append(current);
addCurrentEntry();
}
<ModuleProcedure>"\n" { unput(*yytext);
@@ -485,7 +506,7 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
/*------- type definition -------------------------------------------------------------------------------*/
-<Start,ModuleBody>"type"({BS_}|({COMMA}{ACCESS_SPEC})) { /* type definition found : TYPE , access-spec::type-name |*/
+<Start,ModuleBody>"type"({BS_}|({COMMA}{ACCESS_SPEC}|{COMMA}{LANGUAGE_BIND_SPEC})) {
if(YY_START == Start)
{
addModule(NULL);
@@ -498,6 +519,9 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
<Typedef>{ACCESS_SPEC} {
QCString type= yytext;
}
+<Typedef>{LANGUAGE_BIND_SPEC} {
+ /* ignored for now */
+ }
<Typedef>{ID} { /* type name found */
//cout << "=========> got typedef " << yytext << ": " << yyLineNr << endl;
current->section = Entry::CLASS_SEC; // was Entry::STRUCT_SEC;
@@ -528,12 +552,14 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
/*------- module/global/typedef variable ---------------------------------------------------*/
<SubprogBody,SubprogBodyContains>^{BS}[0-9]*{BS}"end"({BS}{SUBPROG}({BS_}{ID})?)?{BS}/(\n|!) {
- //fprintf(stderr,"1e=========> got end subprog: %s\n", yytext);
+ //
+ // ABSTRACT and specific interfaces are stored
+ // in a scope of their own, even if multiple
+ // are group in one INTERFACE/END INTERFACE block.
+ //
+ if (ifType == IF_ABSTRACT || ifType == IF_SPECIFIC)
+ endScope(current_root);
- /* 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() ;
@@ -692,15 +718,18 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
/*------ 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);
- }
+<Start,ModuleBody,SubprogBody,InterfaceBody,ModuleBodyContains,SubprogBodyContains>^{BS}({PREFIX}{BS_})?{TYPE_SPEC}{BS}/{SUBPROG}{BS_} {
+ if (ifType == IF_ABSTRACT || ifType == IF_SPECIFIC)
+ {
+ addInterface(yytext, ifType);
+ startScope(last_entry);
+ }
+
+ // TYPE_SPEC is for old function style function result
+ result = QCString(yytext).stripWhiteSpace();
+ current->type = result;
+ yy_push_state(SubprogPrefix);
+ }
<SubprogPrefix>{BS}{SUBPROG}{BS_} {
// Fortran subroutine or function found
@@ -710,20 +739,30 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
<Start,ModuleBody,SubprogBody,InterfaceBody,ModuleBodyContains,SubprogBodyContains>^{BS}({PREFIX}{BS_})?{SUBPROG}{BS_} {
// Fortran subroutine or function found
- result= yytext;
- result= result.stripWhiteSpace();
- //extractPrefix(result);
+ if (ifType == IF_ABSTRACT || ifType == IF_SPECIFIC)
+ {
+ addInterface("$interface$", ifType);
+ startScope(last_entry);
+ }
+
+ result = QCString(yytext).stripWhiteSpace();
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} {
+<Subprog>{ID} { current->name = yytext;
+ //cout << "1a==========> got " << current->type << " " << yytext << " " << yyLineNr << endl;
+ modifiers[current_root][current->name.lower()].returnName = current->name;
+
+ if (ifType == IF_ABSTRACT || ifType == IF_SPECIFIC)
+ {
+ current_root->name.replace(QRegExp("\\$interface\\$"), yytext);
+ }
+
+ BEGIN(Parameterlist);
+ }
+<Parameterlist>{ARGS} {
//current->type not yet available
QCString arglist= yytext;
//cout << "3=========> got parameterlist " << yytext << endl;
@@ -735,6 +774,7 @@ PREFIX (RECURSIVE{BS_}|PURE{BS_}|ELEMENTAL{BS_}){0,2}(RECURSIVE|PURE|ELEMENTA
current->args = removeRedundantWhiteSpace(current->args);
stringToArgumentList(current->args, current->argList);
addCurrentEntry();
+
startScope(last_entry);
BEGIN(SubprogBody);
}
@@ -1168,6 +1208,9 @@ SymbolModifiers& SymbolModifiers::operator|=(const SymbolModifiers &mdfs)
pointer |= mdfs.pointer;
target |= mdfs.target;
save |= mdfs.save;
+ nopass |= mdfs.nopass;
+ pass |= mdfs.pass;
+ passVar = mdfs.passVar;
return *this;
}
@@ -1230,6 +1273,15 @@ SymbolModifiers& SymbolModifiers::operator|=(QCString mdfString)
{
newMdf.save = TRUE;
}
+ else if (mdfString=="nopass")
+ {
+ newMdf.nopass = TRUE;
+ }
+ else if (mdfString.contains("pass"))
+ {
+ newMdf.pass = TRUE;
+ newMdf.passVar = extractFromParens(mdfString);
+ }
(*this) |= newMdf;
return *this;
@@ -1336,6 +1388,16 @@ static QCString applyModifiers(QCString typeName, SymbolModifiers& mdfs)
typeName += ",";
typeName += "save";
}
+ if (mdfs.nopass)
+ {
+ typeName += ",";
+ typeName += "nopass";
+ }
+ if (mdfs.pass)
+ {
+ typeName += ",";
+ typeName += "pass(" + mdfs.passVar + ")";
+ }
if (mdfs.protection == SymbolModifiers::PUBLIC)
{
typeName += ",";
@@ -1570,23 +1632,40 @@ static void addSubprogram(const char *text)
* \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)
+static void addInterface(QCString name, InterfaceType type)
{
+ if (YY_START == Start)
+ {
+ addModule(NULL);
+ yy_push_state(ModuleBody); //anon program
+ }
+
current->section = Entry::CLASS_SEC; // was Entry::INTERFACE_SEC;
current->spec = Entry::Interface;
current->name = name;
+ switch (type)
+ {
+ case IF_ABSTRACT:
+ current->type = "abstract";
+ break;
+
+ case IF_GENERIC:
+ current->type = "generic";
+ break;
+
+ case IF_SPECIFIC:
+ case IF_NONE:
+ default:
+ current->type = "";
+ }
+
/* 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->name= current_root->name + "::" + current->name;
}
current->fileName = yyFileName;
generated by cgit v0.12 at 2024-11-01 03:16:14 (GMT)