4 * Copyright (c) 1998-2003, Darren Hiebert
6 * This source code is released for free distribution under the terms of the
7 * GNU General Public License.
9 * This module contains functions for generating tags for Fortran language
16 #include "general.h" /* must always come first */
20 #include <ctype.h> /* to define tolower () */
34 #define isident(c) (isalnum(c) || (c) == '_')
35 #define isBlank(c) (boolean) (c == ' ' || c == '\t')
36 #define isType(token,t) (boolean) ((token)->type == (t))
37 #define isKeyword(token,k) (boolean) ((token)->keyword == (k))
38 #define isSecondaryKeyword(token,k) (boolean) ((token)->secondary == NULL ? \
39 FALSE : (token)->secondary->keyword == (k))
45 typedef enum eException
{
46 ExceptionNone
, ExceptionEOF
, ExceptionFixedFormat
, ExceptionLoop
49 /* Used to designate type of line read in fixed source form.
51 typedef enum eFortranLineType
{
61 /* Used to specify type of keyword.
63 typedef enum eKeywordId
{
136 /* Used to determine whether keyword is valid for the token language and
139 typedef struct sKeywordDesc
{
144 typedef enum eTokenType
{
160 typedef enum eTagType
{
176 TAG_COUNT
/* must be last */
179 typedef struct sTokenInfo
{
184 struct sTokenInfo
*secondary
;
185 unsigned long lineNumber
;
187 int bufferPosition
; /* buffer position of line containing name */
194 static langType Lang_fortran
;
195 static langType Lang_f77
;
196 static jmp_buf Exception
;
197 static int Ungetc
= '\0';
198 static unsigned int Column
= 0;
199 static boolean FreeSourceForm
= FALSE
;
200 static boolean ParsingString
;
201 static tokenInfo
*Parent
= NULL
;
203 /* indexed by tagType */
204 static kindOption FortranKinds
[] = {
205 { TRUE
, 'b', "block data", "block data"},
206 { TRUE
, 'c', "macro", "common blocks"},
207 { TRUE
, 'e', "entry", "entry points"},
208 { TRUE
, 'f', "function", "functions"},
209 { FALSE
, 'i', "struct", "interface contents, generic names, and operators"},
210 { TRUE
, 'k', "component", "type and structure components"},
211 { TRUE
, 'l', "label", "labels"},
212 { FALSE
, 'L', "local", "local, common block, and namelist variables"},
213 { TRUE
, 'm', "namespace", "modules"},
214 { TRUE
, 'n', "namelist", "namelists"},
215 { TRUE
, 'p', "package", "programs"},
216 { TRUE
, 's', "member", "subroutines"},
217 { TRUE
, 't', "typedef", "derived types and structures"},
218 { TRUE
, 'v', "variable", "program (global) and module variables"}
221 /* For efinitions of Fortran 77 with extensions:
222 * http://www.fortran.com/fortran/F77_std/rjcnf0001.html
223 * http://scienide.uwaterloo.ca/MIPSpro7/007-2362-004/sgi_html/index.html
225 * For the Compaq Fortran Reference Manual:
226 * http://h18009.www1.hp.com/fortran/docs/lrm/dflrm.htm
229 static const keywordDesc FortranKeywordTable
[] = {
230 /* keyword keyword ID */
231 { "allocatable", KEYWORD_allocatable
},
232 { "assignment", KEYWORD_assignment
},
233 { "automatic", KEYWORD_automatic
},
234 { "block", KEYWORD_block
},
235 { "byte", KEYWORD_byte
},
236 { "cexternal", KEYWORD_cexternal
},
237 { "cglobal", KEYWORD_cglobal
},
238 { "character", KEYWORD_character
},
239 { "common", KEYWORD_common
},
240 { "complex", KEYWORD_complex
},
241 { "contains", KEYWORD_contains
},
242 { "data", KEYWORD_data
},
243 { "dimension", KEYWORD_dimension
},
244 { "dll_export", KEYWORD_dllexport
},
245 { "dll_import", KEYWORD_dllimport
},
246 { "do", KEYWORD_do
},
247 { "double", KEYWORD_double
},
248 { "elemental", KEYWORD_elemental
},
249 { "end", KEYWORD_end
},
250 { "entry", KEYWORD_entry
},
251 { "equivalence", KEYWORD_equivalence
},
252 { "extends", KEYWORD_extends
},
253 { "external", KEYWORD_external
},
254 { "format", KEYWORD_format
},
255 { "function", KEYWORD_function
},
256 { "if", KEYWORD_if
},
257 { "implicit", KEYWORD_implicit
},
258 { "include", KEYWORD_include
},
259 { "inline", KEYWORD_inline
},
260 { "integer", KEYWORD_integer
},
261 { "intent", KEYWORD_intent
},
262 { "interface", KEYWORD_interface
},
263 { "intrinsic", KEYWORD_intrinsic
},
264 { "logical", KEYWORD_logical
},
265 { "map", KEYWORD_map
},
266 { "module", KEYWORD_module
},
267 { "namelist", KEYWORD_namelist
},
268 { "operator", KEYWORD_operator
},
269 { "optional", KEYWORD_optional
},
270 { "parameter", KEYWORD_parameter
},
271 { "pascal", KEYWORD_pascal
},
272 { "pexternal", KEYWORD_pexternal
},
273 { "pglobal", KEYWORD_pglobal
},
274 { "pointer", KEYWORD_pointer
},
275 { "precision", KEYWORD_precision
},
276 { "private", KEYWORD_private
},
277 { "program", KEYWORD_program
},
278 { "public", KEYWORD_public
},
279 { "pure", KEYWORD_pure
},
280 { "real", KEYWORD_real
},
281 { "record", KEYWORD_record
},
282 { "recursive", KEYWORD_recursive
},
283 { "save", KEYWORD_save
},
284 { "select", KEYWORD_select
},
285 { "sequence", KEYWORD_sequence
},
286 { "static", KEYWORD_static
},
287 { "stdcall", KEYWORD_stdcall
},
288 { "structure", KEYWORD_structure
},
289 { "subroutine", KEYWORD_subroutine
},
290 { "target", KEYWORD_target
},
291 { "then", KEYWORD_then
},
292 { "type", KEYWORD_type
},
293 { "union", KEYWORD_union
},
294 { "use", KEYWORD_use
},
295 { "value", KEYWORD_value
},
296 { "virtual", KEYWORD_virtual
},
297 { "volatile", KEYWORD_volatile
},
298 { "where", KEYWORD_where
},
299 { "while", KEYWORD_while
}
306 } Ancestors
= { 0, 0, NULL
};
309 * FUNCTION PROTOTYPES
311 static void parseStructureStmt (tokenInfo
*const token
);
312 static void parseUnionStmt (tokenInfo
*const token
);
313 static void parseDerivedTypeDef (tokenInfo
*const token
);
314 static void parseFunctionSubprogram (tokenInfo
*const token
);
315 static void parseSubroutineSubprogram (tokenInfo
*const token
);
318 * FUNCTION DEFINITIONS
321 static void ancestorPush (tokenInfo
*const token
)
323 enum { incrementalIncrease
= 10 };
324 if (Ancestors
.list
== NULL
)
326 Assert (Ancestors
.max
== 0);
328 Ancestors
.max
= incrementalIncrease
;
329 Ancestors
.list
= xMalloc (Ancestors
.max
, tokenInfo
);
331 else if (Ancestors
.count
== Ancestors
.max
)
333 Ancestors
.max
+= incrementalIncrease
;
334 Ancestors
.list
= xRealloc (Ancestors
.list
, Ancestors
.max
, tokenInfo
);
336 Ancestors
.list
[Ancestors
.count
] = *token
;
337 Ancestors
.list
[Ancestors
.count
].string
= vStringNewCopy (token
->string
);
341 static void ancestorPop (void)
343 Assert (Ancestors
.count
> 0);
345 vStringDelete (Ancestors
.list
[Ancestors
.count
].string
);
347 Ancestors
.list
[Ancestors
.count
].type
= TOKEN_UNDEFINED
;
348 Ancestors
.list
[Ancestors
.count
].keyword
= KEYWORD_NONE
;
349 Ancestors
.list
[Ancestors
.count
].secondary
= NULL
;
350 Ancestors
.list
[Ancestors
.count
].tag
= TAG_UNDEFINED
;
351 Ancestors
.list
[Ancestors
.count
].string
= NULL
;
352 Ancestors
.list
[Ancestors
.count
].lineNumber
= 0L;
355 static const tokenInfo
* ancestorScope (void)
357 tokenInfo
*result
= NULL
;
359 for (i
= Ancestors
.count
; i
> 0 && result
== NULL
; --i
)
361 tokenInfo
*const token
= Ancestors
.list
+ i
- 1;
362 if (token
->type
== TOKEN_IDENTIFIER
&&
363 token
->tag
!= TAG_UNDEFINED
&& token
->tag
!= TAG_INTERFACE
)
369 static const tokenInfo
* ancestorTop (void)
371 Assert (Ancestors
.count
> 0);
372 return &Ancestors
.list
[Ancestors
.count
- 1];
375 #define ancestorCount() (Ancestors.count)
377 static void ancestorClear (void)
379 while (Ancestors
.count
> 0)
381 if (Ancestors
.list
!= NULL
)
382 eFree (Ancestors
.list
);
383 Ancestors
.list
= NULL
;
388 static boolean
insideInterface (void)
390 boolean result
= FALSE
;
392 for (i
= 0 ; i
< Ancestors
.count
&& !result
; ++i
)
394 if (Ancestors
.list
[i
].tag
== TAG_INTERFACE
)
400 static void buildFortranKeywordHash (const langType language
)
403 sizeof (FortranKeywordTable
) / sizeof (FortranKeywordTable
[0]);
405 for (i
= 0 ; i
< count
; ++i
)
407 const keywordDesc
* const p
= &FortranKeywordTable
[i
];
408 addKeyword (p
->name
, language
, (int) p
->id
);
413 * Tag generation functions
416 static tokenInfo
*newToken (void)
418 tokenInfo
*const token
= xMalloc (1, tokenInfo
);
420 token
->type
= TOKEN_UNDEFINED
;
421 token
->keyword
= KEYWORD_NONE
;
422 token
->tag
= TAG_UNDEFINED
;
423 token
->string
= vStringNew ();
424 token
->secondary
= NULL
;
425 token
->lineNumber
= getSourceLineNumber ();
427 token
->filePosition
= getInputFilePosition ();
429 token
->bufferPosition
= getInputBufferPosition ();
434 static tokenInfo
*newTokenFrom (tokenInfo
*const token
)
436 tokenInfo
*result
= newToken ();
438 result
->string
= vStringNewCopy (token
->string
);
439 token
->secondary
= NULL
;
443 static void deleteToken (tokenInfo
*const token
)
447 vStringDelete (token
->string
);
448 deleteToken (token
->secondary
);
449 token
->secondary
= NULL
;
454 static boolean
isFileScope (const tagType type
)
456 return (boolean
) (type
== TAG_LABEL
|| type
== TAG_LOCAL
);
459 static boolean
includeTag (const tagType type
)
462 Assert (type
!= TAG_UNDEFINED
);
463 include
= FortranKinds
[(int) type
].enabled
;
464 if (include
&& isFileScope (type
))
465 include
= Option
.include
.fileScope
;
469 static void makeFortranTag (tokenInfo
*const token
, tagType tag
)
472 if (includeTag (token
->tag
))
474 const char *const name
= vStringValue (token
->string
);
477 initTagEntry (&e
, name
);
479 if (token
->tag
== TAG_COMMON_BLOCK
)
480 e
.lineNumberEntry
= (boolean
) (Option
.locate
!= EX_PATTERN
);
482 e
.lineNumber
= token
->lineNumber
;
484 e
.filePosition
= token
->filePosition
;
486 e
.bufferPosition
= token
->bufferPosition
;
487 e
.isFileScope
= isFileScope (token
->tag
);
488 e
.kindName
= FortranKinds
[token
->tag
].name
;
489 e
.kind
= FortranKinds
[token
->tag
].letter
;
490 e
.truncateLine
= (boolean
) (token
->tag
!= TAG_LABEL
);
492 if (ancestorCount () > 0)
494 const tokenInfo
* const scope
= ancestorScope ();
497 e
.extensionFields
.scope
[0] = FortranKinds
[scope
->tag
].name
;
498 e
.extensionFields
.scope
[1] = vStringValue (scope
->string
);
501 if (! insideInterface () || includeTag (TAG_INTERFACE
))
510 static int skipLine (void)
516 while (c
!= EOF
&& c
!= '\n');
521 static void makeLabelTag (vString
*const label
)
523 tokenInfo
*token
= newToken ();
524 token
->type
= TOKEN_LABEL
;
525 vStringCopy (token
->string
, label
);
526 makeFortranTag (token
, TAG_LABEL
);
530 static lineType
getLineType (void)
532 vString
*label
= vStringNew ();
534 lineType type
= LTYPE_UNDETERMINED
;
536 do /* read in first 6 "margin" characters */
540 /* 3.2.1 Comment_Line. A comment line is any line that contains
541 * a C or an asterisk in column 1, or contains only blank characters
542 * in columns 1 through 72. A comment line that contains a C or
543 * an asterisk in column 1 may contain any character capable of
544 * representation in the processor in columns 2 through 72.
546 /* EXCEPTION! Some compilers permit '!' as a commment character here.
548 * Treat # and $ in column 1 as comment to permit preprocessor directives.
549 * Treat D and d in column 1 as comment for HP debug statements.
551 if (column
== 0 && strchr ("*Cc!#$Dd", c
) != NULL
)
552 type
= LTYPE_COMMENT
;
553 else if (c
== '\t') /* EXCEPTION! Some compilers permit a tab here */
556 type
= LTYPE_INITIAL
;
558 else if (column
== 5)
560 /* 3.2.2 Initial_Line. An initial line is any line that is not
561 * a comment line and contains the character blank or the digit 0
562 * in column 6. Columns 1 through 5 may contain a statement label
563 * (3.4), or each of the columns 1 through 5 must contain the
566 if (c
== ' ' || c
== '0')
567 type
= LTYPE_INITIAL
;
569 /* 3.2.3 Continuation_Line. A continuation line is any line that
570 * contains any character of the FORTRAN character set other than
571 * the character blank or the digit 0 in column 6 and contains
572 * only blank characters in columns 1 through 5.
574 else if (vStringLength (label
) == 0)
575 type
= LTYPE_CONTINUATION
;
577 type
= LTYPE_INVALID
;
585 else if (isdigit (c
))
586 vStringPut (label
, c
);
588 type
= LTYPE_INVALID
;
591 } while (column
< 6 && type
== LTYPE_UNDETERMINED
);
593 Assert (type
!= LTYPE_UNDETERMINED
);
595 if (vStringLength (label
) > 0)
597 vStringTerminate (label
);
598 makeLabelTag (label
);
600 vStringDelete (label
);
604 static int getFixedFormChar (void)
606 boolean newline
= FALSE
;
612 #ifdef STRICT_FIXED_FORM
613 /* EXCEPTION! Some compilers permit more than 72 characters per line.
625 newline
= TRUE
; /* need to check for continuation line */
628 else if (c
== '!' && ! ParsingString
)
631 newline
= TRUE
; /* need to check for continuation line */
634 else if (c
== '&') /* check for free source form */
636 const int c2
= fileGetc ();
638 longjmp (Exception
, (int) ExceptionFixedFormat
);
645 type
= getLineType ();
648 case LTYPE_UNDETERMINED
:
650 longjmp (Exception
, (int) ExceptionFixedFormat
);
653 case LTYPE_SHORT
: break;
654 case LTYPE_COMMENT
: skipLine (); break;
671 /* fall through to next case */
672 case LTYPE_CONTINUATION
:
678 } while (isBlank (c
));
689 Assert ("Unexpected line type" == NULL
);
695 static int skipToNextLine (void)
703 static int getFreeFormChar (void)
705 static boolean newline
= TRUE
;
706 boolean advanceLine
= FALSE
;
709 /* If the last nonblank, non-comment character of a FORTRAN 90
710 * free-format text line is an ampersand then the next non-comment
711 * line is a continuation line.
717 while (isspace (c
) && c
!= '\n');
731 else if (newline
&& (c
== '!' || c
== '#'))
737 if (c
== '!' || (newline
&& c
== '#'))
739 c
= skipToNextLine ();
748 newline
= (boolean
) (c
== '\n');
752 static int getChar (void)
761 else if (FreeSourceForm
)
762 c
= getFreeFormChar ();
764 c
= getFixedFormChar ();
768 static void ungetChar (const int c
)
773 /* If a numeric is passed in 'c', this is used as the first digit of the
774 * numeric being parsed.
776 static vString
*parseInteger (int c
)
778 vString
*string
= vStringNew ();
782 vStringPut (string
, c
);
785 else if (! isdigit (c
))
787 while (c
!= EOF
&& isdigit (c
))
789 vStringPut (string
, c
);
792 vStringTerminate (string
);
798 while (c
!= EOF
&& isalpha (c
));
805 static vString
*parseNumeric (int c
)
807 vString
*string
= vStringNew ();
808 vString
*integer
= parseInteger (c
);
809 vStringCopy (string
, integer
);
810 vStringDelete (integer
);
815 integer
= parseInteger ('\0');
816 vStringPut (string
, c
);
817 vStringCat (string
, integer
);
818 vStringDelete (integer
);
821 if (tolower (c
) == 'e')
823 integer
= parseInteger ('\0');
824 vStringPut (string
, c
);
825 vStringCat (string
, integer
);
826 vStringDelete (integer
);
831 vStringTerminate (string
);
836 static void parseString (vString
*const string
, const int delimiter
)
838 const unsigned long inputLineNumber
= getInputLineNumber ();
840 ParsingString
= TRUE
;
842 while (c
!= delimiter
&& c
!= '\n' && c
!= EOF
)
844 vStringPut (string
, c
);
847 if (c
== '\n' || c
== EOF
)
849 verbose ("%s: unterminated character string at line %lu\n",
850 getInputFileName (), inputLineNumber
);
852 longjmp (Exception
, (int) ExceptionEOF
);
853 else if (! FreeSourceForm
)
854 longjmp (Exception
, (int) ExceptionFixedFormat
);
856 vStringTerminate (string
);
857 ParsingString
= FALSE
;
860 /* Read a C identifier beginning with "firstChar" and places it into "name".
862 static void parseIdentifier (vString
*const string
, const int firstChar
)
868 vStringPut (string
, c
);
870 } while (isident (c
));
872 vStringTerminate (string
);
873 ungetChar (c
); /* unget non-identifier character */
876 static void checkForLabel (void)
878 tokenInfo
* token
= NULL
;
886 for (length
= 0 ; isdigit (c
) && length
< 5 ; ++length
)
891 token
->type
= TOKEN_LABEL
;
893 vStringPut (token
->string
, c
);
896 if (length
> 0 && token
!= NULL
)
898 vStringTerminate (token
->string
);
899 makeFortranTag (token
, TAG_LABEL
);
905 /* Analyzes the identifier contained in a statement described by the
906 * statement structure and adjusts the structure according the significance
909 static keywordId
analyzeToken (vString
*const name
, langType language
)
911 static vString
*keyword
= NULL
;
915 keyword
= vStringNew ();
916 vStringCopyToLower (keyword
, name
);
917 id
= (keywordId
) lookupKeyword (vStringValue (keyword
), language
);
922 static void readIdentifier (tokenInfo
*const token
, const int c
)
924 parseIdentifier (token
->string
, c
);
925 token
->keyword
= analyzeToken (token
->string
, Lang_fortran
);
926 if (! isKeyword (token
, KEYWORD_NONE
))
927 token
->type
= TOKEN_KEYWORD
;
930 token
->type
= TOKEN_IDENTIFIER
;
931 if (strncmp (vStringValue (token
->string
), "end", 3) == 0)
933 vString
*const sub
= vStringNewInit (vStringValue (token
->string
) + 3);
934 const keywordId kw
= analyzeToken (sub
, Lang_fortran
);
936 if (kw
!= KEYWORD_NONE
)
938 token
->secondary
= newToken ();
939 token
->secondary
->type
= TOKEN_KEYWORD
;
940 token
->secondary
->keyword
= kw
;
941 token
->keyword
= KEYWORD_end
;
947 static void readToken (tokenInfo
*const token
)
951 deleteToken (token
->secondary
);
952 token
->type
= TOKEN_UNDEFINED
;
953 token
->tag
= TAG_UNDEFINED
;
954 token
->keyword
= KEYWORD_NONE
;
955 token
->secondary
= NULL
;
956 vStringClear (token
->string
);
961 token
->lineNumber
= getSourceLineNumber ();
963 token
->filePosition
= getInputFilePosition ();
965 token
->bufferPosition
= getInputBufferPosition ();
969 case EOF
: longjmp (Exception
, (int) ExceptionEOF
); break;
970 case ' ': goto getNextChar
;
971 case '\t': goto getNextChar
;
972 case ',': token
->type
= TOKEN_COMMA
; break;
973 case '(': token
->type
= TOKEN_PAREN_OPEN
; break;
974 case ')': token
->type
= TOKEN_PAREN_CLOSE
; break;
975 case '%': token
->type
= TOKEN_PERCENT
; break;
985 const char *const operatorChars
= "*/+=<>";
987 vStringPut (token
->string
, c
);
989 } while (strchr (operatorChars
, c
) != NULL
);
991 vStringTerminate (token
->string
);
992 token
->type
= TOKEN_OPERATOR
;
1001 while (c
!= '\n' && c
!= EOF
);
1008 /* fall through to newline case */
1010 token
->type
= TOKEN_STATEMENT_END
;
1016 parseIdentifier (token
->string
, c
);
1020 vStringPut (token
->string
, c
);
1021 vStringTerminate (token
->string
);
1022 token
->type
= TOKEN_OPERATOR
;
1027 token
->type
= TOKEN_UNDEFINED
;
1033 parseString (token
->string
, c
);
1034 token
->type
= TOKEN_STRING
;
1038 token
->type
= TOKEN_STATEMENT_END
;
1044 token
->type
= TOKEN_DOUBLE_COLON
;
1048 token
->type
= TOKEN_UNDEFINED
;
1054 readIdentifier (token
, c
);
1055 else if (isdigit (c
))
1057 vString
*numeric
= parseNumeric (c
);
1058 vStringCat (token
->string
, numeric
);
1059 vStringDelete (numeric
);
1060 token
->type
= TOKEN_NUMERIC
;
1063 token
->type
= TOKEN_UNDEFINED
;
1068 static void readSubToken (tokenInfo
*const token
)
1070 if (token
->secondary
== NULL
)
1072 token
->secondary
= newToken ();
1073 readToken (token
->secondary
);
1078 * Scanning functions
1081 static void skipToToken (tokenInfo
*const token
, tokenType type
)
1083 while (! isType (token
, type
) && ! isType (token
, TOKEN_STATEMENT_END
) &&
1084 !(token
->secondary
!= NULL
&& isType (token
->secondary
, TOKEN_STATEMENT_END
)))
1088 static void skipPast (tokenInfo
*const token
, tokenType type
)
1090 skipToToken (token
, type
);
1091 if (! isType (token
, TOKEN_STATEMENT_END
))
1095 static void skipToNextStatement (tokenInfo
*const token
)
1099 skipToToken (token
, TOKEN_STATEMENT_END
);
1101 } while (isType (token
, TOKEN_STATEMENT_END
));
1104 /* skip over parenthesis enclosed contents starting at next token.
1105 * Token is left at the first token following closing parenthesis. If an
1106 * opening parenthesis is not found, `token' is moved to the end of the
1109 static void skipOverParens (tokenInfo
*const token
)
1113 if (isType (token
, TOKEN_STATEMENT_END
))
1115 else if (isType (token
, TOKEN_PAREN_OPEN
))
1117 else if (isType (token
, TOKEN_PAREN_CLOSE
))
1120 } while (level
> 0);
1123 static boolean
isTypeSpec (tokenInfo
*const token
)
1126 switch (token
->keyword
)
1129 case KEYWORD_integer
:
1131 case KEYWORD_double
:
1132 case KEYWORD_complex
:
1133 case KEYWORD_character
:
1134 case KEYWORD_logical
:
1135 case KEYWORD_record
:
1146 static boolean
isSubprogramPrefix (tokenInfo
*const token
)
1149 switch (token
->keyword
)
1151 case KEYWORD_elemental
:
1153 case KEYWORD_recursive
:
1154 case KEYWORD_stdcall
:
1165 * is INTEGER [kind-selector]
1166 * or REAL [kind-selector] is ( etc. )
1167 * or DOUBLE PRECISION
1168 * or COMPLEX [kind-selector]
1169 * or CHARACTER [kind-selector]
1170 * or LOGICAL [kind-selector]
1171 * or TYPE ( type-name )
1173 * Note that INTEGER and REAL may be followed by "*N" where "N" is an integer
1175 static void parseTypeSpec (tokenInfo
*const token
)
1177 /* parse type-spec, leaving `token' at first token following type-spec */
1178 Assert (isTypeSpec (token
));
1179 switch (token
->keyword
)
1181 case KEYWORD_character
:
1182 /* skip char-selector */
1184 if (isType (token
, TOKEN_OPERATOR
) &&
1185 strcmp (vStringValue (token
->string
), "*") == 0)
1187 if (isType (token
, TOKEN_PAREN_OPEN
))
1188 skipOverParens (token
);
1189 else if (isType (token
, TOKEN_NUMERIC
))
1195 case KEYWORD_complex
:
1196 case KEYWORD_integer
:
1197 case KEYWORD_logical
:
1200 if (isType (token
, TOKEN_PAREN_OPEN
))
1201 skipOverParens (token
); /* skip kind-selector */
1202 if (isType (token
, TOKEN_OPERATOR
) &&
1203 strcmp (vStringValue (token
->string
), "*") == 0)
1210 case KEYWORD_double
:
1212 if (isKeyword (token
, KEYWORD_complex
) ||
1213 isKeyword (token
, KEYWORD_precision
))
1216 skipToToken (token
, TOKEN_STATEMENT_END
);
1219 case KEYWORD_record
:
1221 if (isType (token
, TOKEN_OPERATOR
) &&
1222 strcmp (vStringValue (token
->string
), "/") == 0)
1224 readToken (token
); /* skip to structure name */
1225 readToken (token
); /* skip to '/' */
1226 readToken (token
); /* skip to variable name */
1232 if (isType (token
, TOKEN_PAREN_OPEN
))
1233 skipOverParens (token
); /* skip type-name */
1235 parseDerivedTypeDef (token
);
1239 skipToToken (token
, TOKEN_STATEMENT_END
);
1244 static boolean
skipStatementIfKeyword (tokenInfo
*const token
, keywordId keyword
)
1246 boolean result
= FALSE
;
1247 if (isKeyword (token
, keyword
))
1250 skipToNextStatement (token
);
1255 /* parse a list of qualifying specifiers, leaving `token' at first token
1256 * following list. Examples of such specifiers are:
1257 * [[, attr-spec] ::]
1258 * [[, component-attr-spec-list] ::]
1262 * or access-spec (is PUBLIC or PRIVATE)
1264 * or DIMENSION ( array-spec )
1266 * or INTENT ( intent-spec )
1273 * component-attr-spec
1275 * or DIMENSION ( component-array-spec )
1276 * or EXTENDS ( type name )
1278 static void parseQualifierSpecList (tokenInfo
*const token
)
1282 readToken (token
); /* should be an attr-spec */
1283 switch (token
->keyword
)
1285 case KEYWORD_parameter
:
1286 case KEYWORD_allocatable
:
1287 case KEYWORD_external
:
1288 case KEYWORD_intrinsic
:
1289 case KEYWORD_optional
:
1290 case KEYWORD_private
:
1291 case KEYWORD_pointer
:
1292 case KEYWORD_public
:
1294 case KEYWORD_target
:
1298 case KEYWORD_dimension
:
1299 case KEYWORD_extends
:
1300 case KEYWORD_intent
:
1302 skipOverParens (token
);
1305 default: skipToToken (token
, TOKEN_STATEMENT_END
); break;
1307 } while (isType (token
, TOKEN_COMMA
));
1308 if (! isType (token
, TOKEN_DOUBLE_COLON
))
1309 skipToToken (token
, TOKEN_STATEMENT_END
);
1312 static tagType
variableTagType (void)
1314 tagType result
= TAG_VARIABLE
;
1315 if (ancestorCount () > 0)
1317 const tokenInfo
* const parent
= ancestorTop ();
1318 switch (parent
->tag
)
1320 case TAG_MODULE
: result
= TAG_VARIABLE
; break;
1321 case TAG_DERIVED_TYPE
: result
= TAG_COMPONENT
; break;
1322 case TAG_FUNCTION
: result
= TAG_LOCAL
; break;
1323 case TAG_SUBROUTINE
: result
= TAG_LOCAL
; break;
1324 default: result
= TAG_VARIABLE
; break;
1330 static void parseEntityDecl (tokenInfo
*const token
)
1332 Assert (isType (token
, TOKEN_IDENTIFIER
));
1333 makeFortranTag (token
, variableTagType ());
1335 if (isType (token
, TOKEN_PAREN_OPEN
))
1336 skipOverParens (token
);
1337 if (isType (token
, TOKEN_OPERATOR
) &&
1338 strcmp (vStringValue (token
->string
), "*") == 0)
1340 readToken (token
); /* read char-length */
1341 if (isType (token
, TOKEN_PAREN_OPEN
))
1342 skipOverParens (token
);
1346 if (isType (token
, TOKEN_OPERATOR
))
1348 if (strcmp (vStringValue (token
->string
), "/") == 0)
1349 { /* skip over initializations of structure field */
1351 skipPast (token
, TOKEN_OPERATOR
);
1353 else if (strcmp (vStringValue (token
->string
), "=") == 0)
1355 while (! isType (token
, TOKEN_COMMA
) &&
1356 ! isType (token
, TOKEN_STATEMENT_END
))
1359 if (isType (token
, TOKEN_PAREN_OPEN
))
1360 skipOverParens (token
);
1364 /* token left at either comma or statement end */
1367 static void parseEntityDeclList (tokenInfo
*const token
)
1369 if (isType (token
, TOKEN_PERCENT
))
1370 skipToNextStatement (token
);
1371 else while (isType (token
, TOKEN_IDENTIFIER
) ||
1372 (isType (token
, TOKEN_KEYWORD
) &&
1373 !isKeyword (token
, KEYWORD_function
) &&
1374 !isKeyword (token
, KEYWORD_subroutine
)))
1376 /* compilers accept keywoeds as identifiers */
1377 if (isType (token
, TOKEN_KEYWORD
))
1378 token
->type
= TOKEN_IDENTIFIER
;
1379 parseEntityDecl (token
);
1380 if (isType (token
, TOKEN_COMMA
))
1382 else if (isType (token
, TOKEN_STATEMENT_END
))
1384 skipToNextStatement (token
);
1390 /* type-declaration-stmt is
1391 * type-spec [[, attr-spec] ... ::] entity-decl-list
1393 static void parseTypeDeclarationStmt (tokenInfo
*const token
)
1395 Assert (isTypeSpec (token
));
1396 parseTypeSpec (token
);
1397 if (!isType (token
, TOKEN_STATEMENT_END
)) /* if not end of derived type... */
1399 if (isType (token
, TOKEN_COMMA
))
1400 parseQualifierSpecList (token
);
1401 if (isType (token
, TOKEN_DOUBLE_COLON
))
1403 parseEntityDeclList (token
);
1405 if (isType (token
, TOKEN_STATEMENT_END
))
1406 skipToNextStatement (token
);
1410 * NAMELIST /namelist-group-name/ namelist-group-object-list
1411 * [[,]/[namelist-group-name]/ namelist-block-object-list] ...
1413 * namelist-group-object is
1417 * COMMON [/[common-block-name]/] common-block-object-list
1418 * [[,]/[common-block-name]/ common-block-object-list] ...
1420 * common-block-object is
1421 * variable-name [ ( explicit-shape-spec-list ) ]
1423 static void parseCommonNamelistStmt (tokenInfo
*const token
, tagType type
)
1425 Assert (isKeyword (token
, KEYWORD_common
) ||
1426 isKeyword (token
, KEYWORD_namelist
));
1430 if (isType (token
, TOKEN_OPERATOR
) &&
1431 strcmp (vStringValue (token
->string
), "/") == 0)
1434 if (isType (token
, TOKEN_IDENTIFIER
))
1436 makeFortranTag (token
, type
);
1439 skipPast (token
, TOKEN_OPERATOR
);
1441 if (isType (token
, TOKEN_IDENTIFIER
))
1442 makeFortranTag (token
, TAG_LOCAL
);
1444 if (isType (token
, TOKEN_PAREN_OPEN
))
1445 skipOverParens (token
); /* skip explicit-shape-spec-list */
1446 if (isType (token
, TOKEN_COMMA
))
1448 } while (! isType (token
, TOKEN_STATEMENT_END
));
1449 skipToNextStatement (token
);
1452 static void parseFieldDefinition (tokenInfo
*const token
)
1454 if (isTypeSpec (token
))
1455 parseTypeDeclarationStmt (token
);
1456 else if (isKeyword (token
, KEYWORD_structure
))
1457 parseStructureStmt (token
);
1458 else if (isKeyword (token
, KEYWORD_union
))
1459 parseUnionStmt (token
);
1461 skipToNextStatement (token
);
1464 static void parseMap (tokenInfo
*const token
)
1466 Assert (isKeyword (token
, KEYWORD_map
));
1467 skipToNextStatement (token
);
1468 while (! isKeyword (token
, KEYWORD_end
))
1469 parseFieldDefinition (token
);
1470 readSubToken (token
);
1471 /* should be at KEYWORD_map token */
1472 skipToNextStatement (token
);
1477 * [field-definition] [field-definition] ...
1480 * [field-definition] [field-definition] ...
1483 * [field-definition]
1484 * [field-definition] ...
1489 * Typed data declarations (variables or arrays) in structure declarations
1490 * have the form of normal Fortran typed data declarations. Data items with
1491 * different types can be freely intermixed within a structure declaration.
1493 * Unnamed fields can be declared in a structure by specifying the pseudo
1494 * name %FILL in place of an actual field name. You can use this mechanism to
1495 * generate empty space in a record for purposes such as alignment.
1497 * All mapped field declarations that are made within a UNION declaration
1498 * share a common location within the containing structure. When initializing
1499 * the fields within a UNION, the final initialization value assigned
1500 * overlays any value previously assigned to a field definition that shares
1503 static void parseUnionStmt (tokenInfo
*const token
)
1505 Assert (isKeyword (token
, KEYWORD_union
));
1506 skipToNextStatement (token
);
1507 while (isKeyword (token
, KEYWORD_map
))
1509 /* should be at KEYWORD_end token */
1510 readSubToken (token
);
1511 /* secondary token should be KEYWORD_end token */
1512 skipToNextStatement (token
);
1515 /* STRUCTURE [/structure-name/] [field-names]
1516 * [field-definition]
1517 * [field-definition] ...
1521 * identifies the structure in a subsequent RECORD statement.
1522 * Substructures can be established within a structure by means of either
1523 * a nested STRUCTURE declaration or a RECORD statement.
1526 * (for substructure declarations only) one or more names having the
1527 * structure of the substructure being defined.
1530 * can be one or more of the following:
1532 * Typed data declarations, which can optionally include one or more
1533 * data initialization values.
1535 * Substructure declarations (defined by either RECORD statements or
1536 * subsequent STRUCTURE statements).
1538 * UNION declarations, which are mapped fields defined by a block of
1539 * statements. The syntax of a UNION declaration is described below.
1541 * PARAMETER statements, which do not affect the form of the
1544 static void parseStructureStmt (tokenInfo
*const token
)
1547 Assert (isKeyword (token
, KEYWORD_structure
));
1549 if (isType (token
, TOKEN_OPERATOR
) &&
1550 strcmp (vStringValue (token
->string
), "/") == 0)
1551 { /* read structure name */
1553 if (isType (token
, TOKEN_IDENTIFIER
))
1554 makeFortranTag (token
, TAG_DERIVED_TYPE
);
1555 name
= newTokenFrom (token
);
1556 skipPast (token
, TOKEN_OPERATOR
);
1559 { /* fake out anonymous structure */
1561 name
->type
= TOKEN_IDENTIFIER
;
1562 name
->tag
= TAG_DERIVED_TYPE
;
1563 vStringCopyS (name
->string
, "anonymous");
1565 while (isType (token
, TOKEN_IDENTIFIER
))
1566 { /* read field names */
1567 makeFortranTag (token
, TAG_COMPONENT
);
1569 if (isType (token
, TOKEN_COMMA
))
1572 skipToNextStatement (token
);
1573 ancestorPush (name
);
1574 while (! isKeyword (token
, KEYWORD_end
))
1575 parseFieldDefinition (token
);
1576 readSubToken (token
);
1577 /* secondary token should be KEYWORD_structure token */
1578 skipToNextStatement (token
);
1583 /* specification-stmt
1584 * is access-stmt (is access-spec [[::] access-id-list)
1585 * or allocatable-stmt (is ALLOCATABLE [::] array-name etc.)
1586 * or common-stmt (is COMMON [ / [common-block-name] /] etc.)
1587 * or data-stmt (is DATA data-stmt-list [[,] data-stmt-set] ...)
1588 * or dimension-stmt (is DIMENSION [::] array-name etc.)
1589 * or equivalence-stmt (is EQUIVALENCE equivalence-set-list)
1590 * or external-stmt (is EXTERNAL etc.)
1591 * or intent-stmt (is INTENT ( intent-spec ) [::] etc.)
1592 * or instrinsic-stmt (is INTRINSIC etc.)
1593 * or namelist-stmt (is NAMELIST / namelist-group-name / etc.)
1594 * or optional-stmt (is OPTIONAL [::] etc.)
1595 * or pointer-stmt (is POINTER [::] object-name etc.)
1596 * or save-stmt (is SAVE etc.)
1597 * or target-stmt (is TARGET [::] object-name etc.)
1599 * access-spec is PUBLIC or PRIVATE
1601 static boolean
parseSpecificationStmt (tokenInfo
*const token
)
1603 boolean result
= TRUE
;
1604 switch (token
->keyword
)
1606 case KEYWORD_common
:
1607 parseCommonNamelistStmt (token
, TAG_COMMON_BLOCK
);
1610 case KEYWORD_namelist
:
1611 parseCommonNamelistStmt (token
, TAG_NAMELIST
);
1614 case KEYWORD_structure
:
1615 parseStructureStmt (token
);
1618 case KEYWORD_allocatable
:
1620 case KEYWORD_dimension
:
1621 case KEYWORD_equivalence
:
1622 case KEYWORD_extends
:
1623 case KEYWORD_external
:
1624 case KEYWORD_intent
:
1625 case KEYWORD_intrinsic
:
1626 case KEYWORD_optional
:
1627 case KEYWORD_pointer
:
1628 case KEYWORD_private
:
1629 case KEYWORD_public
:
1631 case KEYWORD_target
:
1632 skipToNextStatement (token
);
1642 /* component-def-stmt is
1643 * type-spec [[, component-attr-spec-list] ::] component-decl-list
1646 * component-name [ ( component-array-spec ) ] [ * char-length ]
1648 static void parseComponentDefStmt (tokenInfo
*const token
)
1650 Assert (isTypeSpec (token
));
1651 parseTypeSpec (token
);
1652 if (isType (token
, TOKEN_COMMA
))
1653 parseQualifierSpecList (token
);
1654 if (isType (token
, TOKEN_DOUBLE_COLON
))
1656 parseEntityDeclList (token
);
1659 /* derived-type-def is
1660 * derived-type-stmt is (TYPE [[, access-spec] ::] type-name
1661 * [private-sequence-stmt] ... (is PRIVATE or SEQUENCE)
1662 * component-def-stmt
1663 * [component-def-stmt] ...
1666 static void parseDerivedTypeDef (tokenInfo
*const token
)
1668 if (isType (token
, TOKEN_COMMA
))
1669 parseQualifierSpecList (token
);
1670 if (isType (token
, TOKEN_DOUBLE_COLON
))
1672 if (isType (token
, TOKEN_IDENTIFIER
))
1673 makeFortranTag (token
, TAG_DERIVED_TYPE
);
1674 ancestorPush (token
);
1675 skipToNextStatement (token
);
1676 if (isKeyword (token
, KEYWORD_private
) ||
1677 isKeyword (token
, KEYWORD_sequence
))
1679 skipToNextStatement (token
);
1681 while (! isKeyword (token
, KEYWORD_end
))
1683 if (isTypeSpec (token
))
1684 parseComponentDefStmt (token
);
1686 skipToNextStatement (token
);
1688 readSubToken (token
);
1689 /* secondary token should be KEYWORD_type token */
1690 skipToToken (token
, TOKEN_STATEMENT_END
);
1695 * interface-stmt (is INTERFACE [generic-spec])
1697 * [module-procedure-stmt] ...
1698 * end-interface-stmt (is END INTERFACE)
1702 * or OPERATOR ( defined-operator )
1703 * or ASSIGNMENT ( = )
1707 * [specification-part]
1709 * or subroutine-stmt
1710 * [specification-part]
1711 * end-subroutine-stmt
1713 * module-procedure-stmt is
1714 * MODULE PROCEDURE procedure-name-list
1716 static void parseInterfaceBlock (tokenInfo
*const token
)
1718 tokenInfo
*name
= NULL
;
1719 Assert (isKeyword (token
, KEYWORD_interface
));
1721 if (isType (token
, TOKEN_IDENTIFIER
))
1723 makeFortranTag (token
, TAG_INTERFACE
);
1724 name
= newTokenFrom (token
);
1726 else if (isKeyword (token
, KEYWORD_assignment
) ||
1727 isKeyword (token
, KEYWORD_operator
))
1730 if (isType (token
, TOKEN_PAREN_OPEN
))
1732 if (isType (token
, TOKEN_OPERATOR
))
1734 makeFortranTag (token
, TAG_INTERFACE
);
1735 name
= newTokenFrom (token
);
1741 name
->type
= TOKEN_IDENTIFIER
;
1742 name
->tag
= TAG_INTERFACE
;
1744 ancestorPush (name
);
1745 while (! isKeyword (token
, KEYWORD_end
))
1747 switch (token
->keyword
)
1749 case KEYWORD_function
: parseFunctionSubprogram (token
); break;
1750 case KEYWORD_subroutine
: parseSubroutineSubprogram (token
); break;
1753 if (isSubprogramPrefix (token
))
1755 else if (isTypeSpec (token
))
1756 parseTypeSpec (token
);
1758 skipToNextStatement (token
);
1762 readSubToken (token
);
1763 /* secondary token should be KEYWORD_interface token */
1764 skipToNextStatement (token
);
1770 * ENTRY entry-name [ ( dummy-arg-list ) ]
1772 static void parseEntryStmt (tokenInfo
*const token
)
1774 Assert (isKeyword (token
, KEYWORD_entry
));
1776 if (isType (token
, TOKEN_IDENTIFIER
))
1777 makeFortranTag (token
, TAG_ENTRY_POINT
);
1778 skipToNextStatement (token
);
1781 /* stmt-function-stmt is
1782 * function-name ([dummy-arg-name-list]) = scalar-expr
1784 static boolean
parseStmtFunctionStmt (tokenInfo
*const token
)
1786 boolean result
= FALSE
;
1787 Assert (isType (token
, TOKEN_IDENTIFIER
));
1788 #if 0 /* cannot reliably parse this yet */
1789 makeFortranTag (token
, TAG_FUNCTION
);
1792 if (isType (token
, TOKEN_PAREN_OPEN
))
1794 skipOverParens (token
);
1795 result
= (boolean
) (isType (token
, TOKEN_OPERATOR
) &&
1796 strcmp (vStringValue (token
->string
), "=") == 0);
1798 skipToNextStatement (token
);
1802 static boolean
isIgnoredDeclaration (tokenInfo
*const token
)
1805 switch (token
->keyword
)
1807 case KEYWORD_cexternal
:
1808 case KEYWORD_cglobal
:
1809 case KEYWORD_dllexport
:
1810 case KEYWORD_dllimport
:
1811 case KEYWORD_external
:
1812 case KEYWORD_format
:
1813 case KEYWORD_include
:
1814 case KEYWORD_inline
:
1815 case KEYWORD_parameter
:
1816 case KEYWORD_pascal
:
1817 case KEYWORD_pexternal
:
1818 case KEYWORD_pglobal
:
1819 case KEYWORD_static
:
1821 case KEYWORD_virtual
:
1822 case KEYWORD_volatile
:
1833 /* declaration-construct
1834 * [derived-type-def]
1836 * [type-declaration-stmt]
1837 * [specification-stmt]
1838 * [parameter-stmt] (is PARAMETER ( named-constant-def-list )
1839 * [format-stmt] (is FORMAT format-specification)
1841 * [stmt-function-stmt]
1843 static boolean
parseDeclarationConstruct (tokenInfo
*const token
)
1845 boolean result
= TRUE
;
1846 switch (token
->keyword
)
1848 case KEYWORD_entry
: parseEntryStmt (token
); break;
1849 case KEYWORD_interface
: parseInterfaceBlock (token
); break;
1850 case KEYWORD_stdcall
: readToken (token
); break;
1851 /* derived type handled by parseTypeDeclarationStmt(); */
1853 case KEYWORD_automatic
:
1855 if (isTypeSpec (token
))
1856 parseTypeDeclarationStmt (token
);
1858 skipToNextStatement (token
);
1863 if (isIgnoredDeclaration (token
))
1864 skipToNextStatement (token
);
1865 else if (isTypeSpec (token
))
1867 parseTypeDeclarationStmt (token
);
1870 else if (isType (token
, TOKEN_IDENTIFIER
))
1871 result
= parseStmtFunctionStmt (token
);
1873 result
= parseSpecificationStmt (token
);
1879 /* implicit-part-stmt
1880 * is [implicit-stmt] (is IMPLICIT etc.)
1881 * or [parameter-stmt] (is PARAMETER etc.)
1882 * or [format-stmt] (is FORMAT etc.)
1883 * or [entry-stmt] (is ENTRY entry-name etc.)
1885 static boolean
parseImplicitPartStmt (tokenInfo
*const token
)
1887 boolean result
= TRUE
;
1888 switch (token
->keyword
)
1890 case KEYWORD_entry
: parseEntryStmt (token
); break;
1892 case KEYWORD_implicit
:
1893 case KEYWORD_include
:
1894 case KEYWORD_parameter
:
1895 case KEYWORD_format
:
1896 skipToNextStatement (token
);
1899 default: result
= FALSE
; break;
1904 /* specification-part is
1905 * [use-stmt] ... (is USE module-name etc.)
1906 * [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt])
1907 * [declaration-construct] ...
1909 static boolean
parseSpecificationPart (tokenInfo
*const token
)
1911 boolean result
= FALSE
;
1912 while (skipStatementIfKeyword (token
, KEYWORD_use
))
1914 while (parseImplicitPartStmt (token
))
1916 while (parseDeclarationConstruct (token
))
1922 * block-data-stmt (is BLOCK DATA [block-data-name]
1923 * [specification-part]
1924 * end-block-data-stmt (is END [BLOCK DATA [block-data-name]])
1926 static void parseBlockData (tokenInfo
*const token
)
1928 Assert (isKeyword (token
, KEYWORD_block
));
1930 if (isKeyword (token
, KEYWORD_data
))
1933 if (isType (token
, TOKEN_IDENTIFIER
))
1934 makeFortranTag (token
, TAG_BLOCK_DATA
);
1936 ancestorPush (token
);
1937 skipToNextStatement (token
);
1938 parseSpecificationPart (token
);
1939 while (! isKeyword (token
, KEYWORD_end
))
1940 skipToNextStatement (token
);
1941 readSubToken (token
);
1942 /* secondary token should be KEYWORD_NONE or KEYWORD_block token */
1943 skipToNextStatement (token
);
1947 /* internal-subprogram-part is
1948 * contains-stmt (is CONTAINS)
1949 * internal-subprogram
1950 * [internal-subprogram] ...
1952 * internal-subprogram
1953 * is function-subprogram
1954 * or subroutine-subprogram
1956 static void parseInternalSubprogramPart (tokenInfo
*const token
)
1958 boolean done
= FALSE
;
1959 if (isKeyword (token
, KEYWORD_contains
))
1960 skipToNextStatement (token
);
1963 switch (token
->keyword
)
1965 case KEYWORD_function
: parseFunctionSubprogram (token
); break;
1966 case KEYWORD_subroutine
: parseSubroutineSubprogram (token
); break;
1967 case KEYWORD_end
: done
= TRUE
; break;
1970 if (isSubprogramPrefix (token
))
1972 else if (isTypeSpec (token
))
1973 parseTypeSpec (token
);
1982 * module-stmt (is MODULE module-name)
1983 * [specification-part]
1984 * [module-subprogram-part]
1985 * end-module-stmt (is END [MODULE [module-name]])
1987 * module-subprogram-part
1988 * contains-stmt (is CONTAINS)
1990 * [module-subprogram] ...
1993 * is function-subprogram
1994 * or subroutine-subprogram
1996 static void parseModule (tokenInfo
*const token
)
1998 Assert (isKeyword (token
, KEYWORD_module
));
2000 if (isType (token
, TOKEN_IDENTIFIER
))
2001 makeFortranTag (token
, TAG_MODULE
);
2002 ancestorPush (token
);
2003 skipToNextStatement (token
);
2004 parseSpecificationPart (token
);
2005 if (isKeyword (token
, KEYWORD_contains
))
2006 parseInternalSubprogramPart (token
);
2007 while (! isKeyword (token
, KEYWORD_end
))
2008 skipToNextStatement (token
);
2009 readSubToken (token
);
2010 /* secondary token should be KEYWORD_NONE or KEYWORD_module token */
2011 skipToNextStatement (token
);
2016 * executable-construct
2018 * executable-contstruct is
2019 * execution-part-construct [execution-part-construct]
2021 * execution-part-construct
2022 * is executable-construct
2027 static boolean
parseExecutionPart (tokenInfo
*const token
)
2029 boolean result
= FALSE
;
2030 boolean done
= FALSE
;
2033 switch (token
->keyword
)
2036 if (isSubprogramPrefix (token
))
2039 skipToNextStatement (token
);
2044 parseEntryStmt (token
);
2048 case KEYWORD_contains
:
2049 case KEYWORD_function
:
2050 case KEYWORD_subroutine
:
2055 readSubToken (token
);
2056 if (isSecondaryKeyword (token
, KEYWORD_do
) ||
2057 isSecondaryKeyword (token
, KEYWORD_if
) ||
2058 isSecondaryKeyword (token
, KEYWORD_select
) ||
2059 isSecondaryKeyword (token
, KEYWORD_where
))
2061 skipToNextStatement (token
);
2072 static void parseSubprogram (tokenInfo
*const token
, const tagType tag
)
2074 Assert (isKeyword (token
, KEYWORD_program
) ||
2075 isKeyword (token
, KEYWORD_function
) ||
2076 isKeyword (token
, KEYWORD_subroutine
));
2078 if (isType (token
, TOKEN_IDENTIFIER
))
2079 makeFortranTag (token
, tag
);
2080 ancestorPush (token
);
2081 skipToNextStatement (token
);
2082 parseSpecificationPart (token
);
2083 parseExecutionPart (token
);
2084 if (isKeyword (token
, KEYWORD_contains
))
2085 parseInternalSubprogramPart (token
);
2086 /* should be at KEYWORD_end token */
2087 readSubToken (token
);
2088 /* secondary token should be one of KEYWORD_NONE, KEYWORD_program,
2089 * KEYWORD_function, KEYWORD_function
2091 skipToNextStatement (token
);
2096 /* function-subprogram is
2097 * function-stmt (is [prefix] FUNCTION function-name etc.)
2098 * [specification-part]
2100 * [internal-subprogram-part]
2101 * end-function-stmt (is END [FUNCTION [function-name]])
2104 * is type-spec [RECURSIVE]
2105 * or [RECURSIVE] type-spec
2107 static void parseFunctionSubprogram (tokenInfo
*const token
)
2109 parseSubprogram (token
, TAG_FUNCTION
);
2112 /* subroutine-subprogram is
2113 * subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.)
2114 * [specification-part]
2116 * [internal-subprogram-part]
2117 * end-subroutine-stmt (is END [SUBROUTINE [function-name]])
2119 static void parseSubroutineSubprogram (tokenInfo
*const token
)
2121 parseSubprogram (token
, TAG_SUBROUTINE
);
2125 * [program-stmt] (is PROGRAM program-name)
2126 * [specification-part]
2128 * [internal-subprogram-part ]
2131 static void parseMainProgram (tokenInfo
*const token
)
2133 parseSubprogram (token
, TAG_PROGRAM
);
2138 * or external-subprogram (is function-subprogram or subroutine-subprogram)
2142 static void parseProgramUnit (tokenInfo
*const token
)
2147 if (isType (token
, TOKEN_STATEMENT_END
))
2149 else switch (token
->keyword
)
2151 case KEYWORD_block
: parseBlockData (token
); break;
2152 case KEYWORD_end
: skipToNextStatement (token
); break;
2153 case KEYWORD_function
: parseFunctionSubprogram (token
); break;
2154 case KEYWORD_module
: parseModule (token
); break;
2155 case KEYWORD_program
: parseMainProgram (token
); break;
2156 case KEYWORD_subroutine
: parseSubroutineSubprogram (token
); break;
2159 if (isSubprogramPrefix (token
))
2163 boolean one
= parseSpecificationPart (token
);
2164 boolean two
= parseExecutionPart (token
);
2173 static boolean
findFortranTags (const unsigned int passCount
)
2176 exception_t exception
;
2179 Assert (passCount
< 3);
2180 Parent
= newToken ();
2181 token
= newToken ();
2182 FreeSourceForm
= (boolean
) (passCount
> 1);
2184 exception
= (exception_t
) setjmp (Exception
);
2185 if (exception
== ExceptionEOF
)
2187 else if (exception
== ExceptionFixedFormat
&& ! FreeSourceForm
)
2189 verbose ("%s: not fixed source form; retry as free source form\n",
2190 getInputFileName ());
2195 parseProgramUnit (token
);
2199 deleteToken (token
);
2200 deleteToken (Parent
);
2205 static void initializeFortran (const langType language
)
2207 Lang_fortran
= language
;
2208 buildFortranKeywordHash (language
);
2211 static void initializeF77 (const langType language
)
2213 Lang_f77
= language
;
2214 buildFortranKeywordHash (language
);
2217 extern parserDefinition
* FortranParser (void)
2219 static const char *const extensions
[] = {
2220 "f90", "f95", "f03",
2221 #ifndef CASE_INSENSITIVE_FILENAMES
2222 "F90", "F95", "F03",
2226 parserDefinition
* def
= parserNew ("Fortran");
2227 def
->kinds
= FortranKinds
;
2228 def
->kindCount
= KIND_COUNT (FortranKinds
);
2229 def
->extensions
= extensions
;
2230 def
->parser2
= findFortranTags
;
2231 def
->initialize
= initializeFortran
;
2235 extern parserDefinition
* F77Parser (void)
2237 static const char *const extensions
[] = {
2238 "f", "for", "ftn", "f77",
2239 #ifndef CASE_INSENSITIVE_FILENAMES
2240 "F", "FOR", "FTN", "F77",
2244 parserDefinition
* def
= parserNew ("F77");
2245 def
->kinds
= FortranKinds
;
2246 def
->kindCount
= KIND_COUNT (FortranKinds
);
2247 def
->extensions
= extensions
;
2248 def
->parser2
= findFortranTags
;
2249 def
->initialize
= initializeF77
;
2252 /* vi:set tabstop=4 shiftwidth=4: */