1 /*
2 * Copyright (c) 1998-2003, Darren Hiebert
3 *
4 * This source code is released for free distribution under the terms of the
5 * GNU General Public License version 2 or (at your option) any later version.
6 *
7 * This module contains functions for generating tags for Fortran language
8 * files.
9 */
10
11 /*
12 * INCLUDE FILES
13 */
14 #include "general.h" /* must always come first */
15
16 #include <string.h>
17 #include <limits.h>
18 #include <ctype.h> /* to define tolower () */
19
20 #include "debug.h"
21 #include "entry.h"
22 #include "keyword.h"
23 #include "options.h"
24 #include "parse.h"
25 #include "read.h"
26 #include "routines.h"
27 #include "vstring.h"
28 #include "xtag.h"
29
30 /*
31 * MACROS
32 */
33 #define isident(c) (isalnum(c) || (c) == '_')
34 #define isBlank(c) (bool) (c == ' ' || c == '\t')
35 #define isType(token,t) (bool) ((token)->type == (t))
36 #define isKeyword(token,k) (bool) ((token)->keyword == (k))
37 #define isSecondaryKeyword(token,k) (bool) ((token)->secondary == NULL ? \
38 false : (token)->secondary->keyword == (k))
39
40 /*
41 * DATA DECLARATIONS
42 */
43 /* Used to designate type of line read in fixed source form.
44 */
45 typedef enum eFortranLineType {
46 LTYPE_UNDETERMINED,
47 LTYPE_INVALID,
48 LTYPE_COMMENT,
49 LTYPE_CONTINUATION,
50 LTYPE_EOF,
51 LTYPE_INITIAL,
52 LTYPE_SHORT
53 } lineType;
54
55 /* Used to specify type of keyword.
56 */
57 enum eKeywordId {
58 KEYWORD_abstract,
59 KEYWORD_allocatable,
60 KEYWORD_assignment,
61 KEYWORD_associate,
62 KEYWORD_automatic,
63 KEYWORD_bind,
64 KEYWORD_block,
65 KEYWORD_byte,
66 KEYWORD_cexternal,
67 KEYWORD_cglobal,
68 KEYWORD_class,
69 KEYWORD_character,
70 KEYWORD_codimension,
71 KEYWORD_common,
72 KEYWORD_complex,
73 KEYWORD_contains,
74 KEYWORD_data,
75 KEYWORD_deferred,
76 KEYWORD_dimension,
77 KEYWORD_dllexport,
78 KEYWORD_dllimport,
79 KEYWORD_do,
80 KEYWORD_double,
81 KEYWORD_elemental,
82 KEYWORD_end,
83 KEYWORD_entry,
84 KEYWORD_enum,
85 KEYWORD_enumerator,
86 KEYWORD_equivalence,
87 KEYWORD_extends,
88 KEYWORD_external,
89 KEYWORD_final,
90 KEYWORD_forall,
91 KEYWORD_format,
92 KEYWORD_function,
93 KEYWORD_generic,
94 KEYWORD_if,
95 KEYWORD_implicit,
96 KEYWORD_import,
97 KEYWORD_include,
98 KEYWORD_inline,
99 KEYWORD_integer,
100 KEYWORD_intent,
101 KEYWORD_interface,
102 KEYWORD_intrinsic,
103 KEYWORD_kind,
104 KEYWORD_len,
105 KEYWORD_logical,
106 KEYWORD_map,
107 KEYWORD_module,
108 KEYWORD_namelist,
109 KEYWORD_non_overridable,
110 KEYWORD_nopass,
111 KEYWORD_operator,
112 KEYWORD_optional,
113 KEYWORD_parameter,
114 KEYWORD_pascal,
115 KEYWORD_pass,
116 KEYWORD_pexternal,
117 KEYWORD_pglobal,
118 KEYWORD_pointer,
119 KEYWORD_precision,
120 KEYWORD_private,
121 KEYWORD_procedure,
122 KEYWORD_program,
123 KEYWORD_protected,
124 KEYWORD_public,
125 KEYWORD_pure,
126 KEYWORD_real,
127 KEYWORD_record,
128 KEYWORD_recursive,
129 KEYWORD_save,
130 KEYWORD_select,
131 KEYWORD_sequence,
132 KEYWORD_static,
133 KEYWORD_stdcall,
134 KEYWORD_structure,
135 KEYWORD_submodule,
136 KEYWORD_subroutine,
137 KEYWORD_target,
138 KEYWORD_then,
139 KEYWORD_type,
140 KEYWORD_union,
141 KEYWORD_use,
142 KEYWORD_value,
143 KEYWORD_virtual,
144 KEYWORD_volatile,
145 KEYWORD_where,
146 KEYWORD_while
147 };
148 typedef int keywordId; /* to allow KEYWORD_NONE */
149
150 typedef enum eTokenType {
151 TOKEN_UNDEFINED,
152 TOKEN_EOF,
153 TOKEN_COMMA,
154 TOKEN_DOUBLE_COLON,
155 TOKEN_IDENTIFIER,
156 TOKEN_KEYWORD,
157 TOKEN_LABEL,
158 TOKEN_NUMERIC,
159 TOKEN_OPERATOR,
160 TOKEN_PAREN_CLOSE,
161 TOKEN_PAREN_OPEN,
162 TOKEN_SQUARE_OPEN,
163 TOKEN_SQUARE_CLOSE,
164 TOKEN_PERCENT,
165 TOKEN_STATEMENT_END,
166 TOKEN_STRING,
167 TOKEN_COLON,
168 } tokenType;
169
170 typedef enum eTagType {
171 TAG_UNDEFINED = -1,
172 TAG_BLOCK_DATA,
173 TAG_COMMON_BLOCK,
174 TAG_ENTRY_POINT,
175 TAG_ENUM,
176 TAG_FUNCTION,
177 TAG_INTERFACE,
178 TAG_COMPONENT,
179 TAG_LABEL,
180 TAG_LOCAL,
181 TAG_MODULE,
182 TAG_METHOD,
183 TAG_NAMELIST,
184 TAG_ENUMERATOR,
185 TAG_PROGRAM,
186 TAG_PROTOTYPE,
187 TAG_SUBROUTINE,
188 TAG_DERIVED_TYPE,
189 TAG_VARIABLE,
190 TAG_SUBMODULE,
191 TAG_COUNT /* must be last */
192 } tagType;
193
194 typedef enum eImplementation {
195 IMP_DEFAULT,
196 IMP_ABSTRACT,
197 IMP_DEFERRED,
198 IMP_NON_OVERRIDABLE,
199 IMP_COUNT
200 } impType;
201
202 typedef struct sTokenInfo {
203 tokenType type;
204 keywordId keyword;
205 tagType tag;
206 vString* string;
207 vString* parentType;
208 vString* signature;
209 impType implementation;
210 bool isMethod;
211 struct sTokenInfo *secondary;
212 unsigned long lineNumber;
213 MIOPos filePosition;
214 bool anonymous;
215 } tokenInfo;
216
217 /*
218 * DATA DEFINITIONS
219 */
220
221 static langType Lang_fortran;
222 static int Ungetc;
223 static unsigned int Column;
224 static bool FreeSourceForm;
225 static bool FreeSourceFormFound = false;
226 static bool ParsingString;
227
228 /* indexed by tagType */
229 static kindDefinition FortranKinds [] = {
230 { true, 'b', "blockData", "block data"},
231 { true, 'c', "common", "common blocks"},
232 { true, 'e', "entry", "entry points"},
233 { true, 'E', "enum", "enumerations"},
234 { true, 'f', "function", "functions"},
235 { true, 'i', "interface", "interface contents, generic names, and operators"},
236 { true, 'k', "component", "type and structure components"},
237 { true, 'l', "label", "labels"},
238 { false, 'L', "local", "local, common block, and namelist variables"},
239 { true, 'm', "module", "modules"},
240 { true, 'M', "method", "type bound procedures"},
241 { true, 'n', "namelist", "namelists"},
242 { true, 'N', "enumerator", "enumeration values"},
243 { true, 'p', "program", "programs"},
244 { false, 'P', "prototype", "subprogram prototypes"},
245 { true, 's', "subroutine", "subroutines"},
246 { true, 't', "type", "derived types and structures"},
247 { true, 'v', "variable", "program (global) and module variables"},
248 { true, 'S', "submodule", "submodules"},
249 };
250
251 /* For definitions of Fortran 77 with extensions:
252 * http://www.fortran.com/fortran/F77_std/rjcnf0001.html
253 * http://scienide.uwaterloo.ca/MIPSpro7/007-2362-004/sgi_html/index.html
254 *
255 * For the Compaq Fortran Reference Manual:
256 * http://h18009.www1.hp.com/fortran/docs/lrm/dflrm.htm
257 */
258
259 static const keywordTable FortranKeywordTable [] = {
260 /* keyword keyword ID */
261 { "abstract", KEYWORD_abstract },
262 { "allocatable", KEYWORD_allocatable },
263 { "assignment", KEYWORD_assignment },
264 { "associate", KEYWORD_associate },
265 { "automatic", KEYWORD_automatic },
266 { "bind", KEYWORD_bind },
267 { "block", KEYWORD_block },
268 { "byte", KEYWORD_byte },
269 { "cexternal", KEYWORD_cexternal },
270 { "cglobal", KEYWORD_cglobal },
271 { "class", KEYWORD_class },
272 { "character", KEYWORD_character },
273 { "codimension", KEYWORD_codimension },
274 { "common", KEYWORD_common },
275 { "complex", KEYWORD_complex },
276 { "contains", KEYWORD_contains },
277 { "data", KEYWORD_data },
278 { "deferred", KEYWORD_deferred },
279 { "dimension", KEYWORD_dimension },
280 { "dll_export", KEYWORD_dllexport },
281 { "dll_import", KEYWORD_dllimport },
282 { "do", KEYWORD_do },
283 { "double", KEYWORD_double },
284 { "elemental", KEYWORD_elemental },
285 { "end", KEYWORD_end },
286 { "entry", KEYWORD_entry },
287 { "enum", KEYWORD_enum },
288 { "enumerator", KEYWORD_enumerator },
289 { "equivalence", KEYWORD_equivalence },
290 { "extends", KEYWORD_extends },
291 { "external", KEYWORD_external },
292 { "final", KEYWORD_final },
293 { "forall", KEYWORD_forall },
294 { "format", KEYWORD_format },
295 { "function", KEYWORD_function },
296 { "generic", KEYWORD_generic },
297 { "if", KEYWORD_if },
298 { "implicit", KEYWORD_implicit },
299 { "import", KEYWORD_import },
300 { "include", KEYWORD_include },
301 { "inline", KEYWORD_inline },
302 { "integer", KEYWORD_integer },
303 { "intent", KEYWORD_intent },
304 { "interface", KEYWORD_interface },
305 { "intrinsic", KEYWORD_intrinsic },
306 { "kind", KEYWORD_kind },
307 { "len", KEYWORD_len },
308 { "logical", KEYWORD_logical },
309 { "map", KEYWORD_map },
310 { "module", KEYWORD_module },
311 { "namelist", KEYWORD_namelist },
312 { "non_overridable", KEYWORD_non_overridable },
313 { "nopass", KEYWORD_nopass },
314 { "operator", KEYWORD_operator },
315 { "optional", KEYWORD_optional },
316 { "parameter", KEYWORD_parameter },
317 { "pascal", KEYWORD_pascal },
318 { "pass", KEYWORD_pass },
319 { "pexternal", KEYWORD_pexternal },
320 { "pglobal", KEYWORD_pglobal },
321 { "pointer", KEYWORD_pointer },
322 { "precision", KEYWORD_precision },
323 { "private", KEYWORD_private },
324 { "procedure", KEYWORD_procedure },
325 { "program", KEYWORD_program },
326 { "protected", KEYWORD_protected },
327 { "public", KEYWORD_public },
328 { "pure", KEYWORD_pure },
329 { "real", KEYWORD_real },
330 { "record", KEYWORD_record },
331 { "recursive", KEYWORD_recursive },
332 { "save", KEYWORD_save },
333 { "select", KEYWORD_select },
334 { "sequence", KEYWORD_sequence },
335 { "static", KEYWORD_static },
336 { "stdcall", KEYWORD_stdcall },
337 { "structure", KEYWORD_structure },
338 { "submodule", KEYWORD_submodule },
339 { "subroutine", KEYWORD_subroutine },
340 { "target", KEYWORD_target },
341 { "then", KEYWORD_then },
342 { "type", KEYWORD_type },
343 { "union", KEYWORD_union },
344 { "use", KEYWORD_use },
345 { "value", KEYWORD_value },
346 { "virtual", KEYWORD_virtual },
347 { "volatile", KEYWORD_volatile },
348 { "where", KEYWORD_where },
349 { "while", KEYWORD_while }
350 };
351
352 static struct {
353 unsigned int count;
354 unsigned int max;
355 tokenInfo* list;
356 } Ancestors = { 0, 0, NULL };
357
358 /*
359 * FUNCTION PROTOTYPES
360 */
361 static void parseStructureStmt (tokenInfo *const token);
362 static void parseUnionStmt (tokenInfo *const token);
363 static void parseDerivedTypeDef (tokenInfo *const token);
364 static void parseSubprogram (tokenInfo *const token);
365
366 /*
367 * FUNCTION DEFINITIONS
368 */
369
ancestorPush(tokenInfo * const token)370 static void ancestorPush (tokenInfo *const token)
371 {
372 enum { incrementalIncrease = 10 };
373 if (Ancestors.list == NULL)
374 {
375 Assert (Ancestors.max == 0);
376 Ancestors.count = 0;
377 Ancestors.max = incrementalIncrease;
378 Ancestors.list = xMalloc (Ancestors.max, tokenInfo);
379 }
380 else if (Ancestors.count == Ancestors.max)
381 {
382 Ancestors.max += incrementalIncrease;
383 Ancestors.list = xRealloc (Ancestors.list, Ancestors.max, tokenInfo);
384 }
385 Ancestors.list [Ancestors.count] = *token;
386 Ancestors.list [Ancestors.count].string = vStringNewCopy (token->string);
387 Ancestors.list [Ancestors.count].signature = token->signature? vStringNewCopy (token->signature): NULL;
388 Ancestors.count++;
389 }
390
ancestorPop(void)391 static void ancestorPop (void)
392 {
393 Assert (Ancestors.count > 0);
394 --Ancestors.count;
395 vStringDelete (Ancestors.list [Ancestors.count].string);
396 vStringDelete (Ancestors.list [Ancestors.count].signature);
397
398 Ancestors.list [Ancestors.count].type = TOKEN_UNDEFINED;
399 Ancestors.list [Ancestors.count].keyword = KEYWORD_NONE;
400 Ancestors.list [Ancestors.count].secondary = NULL;
401 Ancestors.list [Ancestors.count].tag = TAG_UNDEFINED;
402 Ancestors.list [Ancestors.count].string = NULL;
403 Ancestors.list [Ancestors.count].lineNumber = 0L;
404 Ancestors.list [Ancestors.count].implementation = IMP_DEFAULT;
405 Ancestors.list [Ancestors.count].isMethod = false;
406 }
407
ancestorScope(void)408 static const tokenInfo* ancestorScope (void)
409 {
410 tokenInfo *result = NULL;
411 unsigned int i;
412 for (i = Ancestors.count ; i > 0 && result == NULL ; --i)
413 {
414 tokenInfo *const token = Ancestors.list + i - 1;
415 if (token->type == TOKEN_IDENTIFIER &&
416 token->tag != TAG_UNDEFINED)
417 result = token;
418 }
419 return result;
420 }
421
ancestorTop(void)422 static const tokenInfo* ancestorTop (void)
423 {
424 Assert (Ancestors.count > 0);
425 return &Ancestors.list [Ancestors.count - 1];
426 }
427
428 #define ancestorCount() (Ancestors.count)
429
ancestorClear(void)430 static void ancestorClear (void)
431 {
432 while (Ancestors.count > 0)
433 ancestorPop ();
434 if (Ancestors.list != NULL)
435 eFree (Ancestors.list);
436 Ancestors.list = NULL;
437 Ancestors.count = 0;
438 Ancestors.max = 0;
439 }
440
insideInterface(void)441 static bool insideInterface (void)
442 {
443 bool result = false;
444 unsigned int i;
445 for (i = 0 ; i < Ancestors.count && !result ; ++i)
446 {
447 if (Ancestors.list [i].tag == TAG_INTERFACE)
448 result = true;
449 }
450 return result;
451 }
452
453 /*
454 * Tag generation functions
455 */
newToken(void)456 static tokenInfo *newToken (void)
457 {
458 tokenInfo *const token = xMalloc (1, tokenInfo);
459
460 token->type = TOKEN_UNDEFINED;
461 token->keyword = KEYWORD_NONE;
462 token->tag = TAG_UNDEFINED;
463 token->string = vStringNew ();
464 token->secondary = NULL;
465 token->parentType = NULL;
466 token->signature = NULL;
467 token->implementation = IMP_DEFAULT;
468 token->isMethod = false;
469 token->lineNumber = getInputLineNumber ();
470 token->filePosition = getInputFilePosition ();
471 token->anonymous = false;
472
473 return token;
474 }
475
newTokenFromFull(tokenInfo * const token,bool copyStr)476 static tokenInfo *newTokenFromFull (tokenInfo *const token, bool copyStr)
477 {
478 tokenInfo *result = xMalloc (1, tokenInfo);
479 *result = *token;
480 result->string = copyStr? vStringNewCopy (token->string): vStringNew();
481 token->secondary = NULL;
482 token->parentType = NULL;
483 token->signature = NULL;
484 return result;
485 }
486
newTokenFrom(tokenInfo * const token)487 static tokenInfo *newTokenFrom (tokenInfo *const token)
488 {
489 return newTokenFromFull (token, true);
490 }
491
newAnonTokenFrom(tokenInfo * const token,unsigned int uTagKind)492 static tokenInfo *newAnonTokenFrom (tokenInfo *const token, unsigned int uTagKind)
493 {
494 tokenInfo *result = newTokenFromFull (token, false);
495 result->anonymous = true;
496 anonGenerate (result->string, "__anon", uTagKind);
497 return result;
498 }
499
deleteToken(tokenInfo * const token)500 static void deleteToken (tokenInfo *const token)
501 {
502 if (token != NULL)
503 {
504 vStringDelete (token->string);
505 vStringDelete (token->parentType);
506 vStringDelete (token->signature);
507 deleteToken (token->secondary);
508 token->secondary = NULL;
509 eFree (token);
510 }
511 }
512
isFileScope(const tagType type)513 static bool isFileScope (const tagType type)
514 {
515 return (bool) (type == TAG_LABEL || type == TAG_LOCAL);
516 }
517
includeTag(const tagType type)518 static bool includeTag (const tagType type)
519 {
520 bool include;
521 Assert (type != TAG_UNDEFINED);
522 include = FortranKinds [(int) type].enabled;
523 if (include && isFileScope (type))
524 include = isXtagEnabled(XTAG_FILE_SCOPE);
525 return include;
526 }
527
implementationString(const impType imp)528 static const char *implementationString (const impType imp)
529 {
530 static const char *const names [] ={
531 "?", "abstract", "deferred", "non_overridable"
532 };
533 Assert (ARRAY_SIZE (names) == IMP_COUNT);
534 Assert ((int) imp < IMP_COUNT);
535 return names [(int) imp];
536 }
537
makeFortranTag(tokenInfo * const token,tagType tag)538 static void makeFortranTag (tokenInfo *const token, tagType tag)
539 {
540 token->tag = tag;
541 if (includeTag (token->tag))
542 {
543 const char *const name = vStringValue (token->string);
544 tagEntryInfo e;
545
546 initTagEntry (&e, name, token->tag);
547
548 if (token->tag == TAG_COMMON_BLOCK)
549 e.lineNumberEntry = canUseLineNumberAsLocator();
550
551 if (token->anonymous)
552 markTagExtraBit (&e, XTAG_ANONYMOUS);
553
554 e.lineNumber = token->lineNumber;
555 e.filePosition = token->filePosition;
556 e.isFileScope = isFileScope (token->tag);
557 if (e.isFileScope)
558 markTagExtraBit (&e, XTAG_FILE_SCOPE);
559 e.truncateLineAfterTag = (bool) (token->tag != TAG_LABEL);
560
561 if (ancestorCount () > 0)
562 {
563 const tokenInfo* const scope = ancestorScope ();
564 if (scope != NULL)
565 {
566 e.extensionFields.scopeKindIndex = scope->tag;
567 e.extensionFields.scopeName = vStringValue (scope->string);
568 }
569 }
570 if (token->parentType != NULL &&
571 vStringLength (token->parentType) > 0 &&
572 (token->tag == TAG_DERIVED_TYPE || (token->tag == TAG_SUBMODULE)))
573 e.extensionFields.inheritance = vStringValue (token->parentType);
574 if (token->implementation != IMP_DEFAULT)
575 e.extensionFields.implementation =
576 implementationString (token->implementation);
577 if (token->signature &&
578 vStringLength (token->signature) > 0 &&
579 (token->tag == TAG_FUNCTION ||
580 token->tag == TAG_SUBROUTINE ||
581 token->tag == TAG_PROTOTYPE))
582 e.extensionFields.signature = vStringValue (token->signature);
583 makeTagEntry (&e);
584 }
585 }
586
587 /*
588 * Parsing functions
589 */
590
skipLine(void)591 static int skipLine (void)
592 {
593 int c;
594
595 do
596 c = getcFromInputFile ();
597 while (c != EOF && c != '\n');
598
599 return c;
600 }
601
makeLabelTag(vString * const label)602 static void makeLabelTag (vString *const label)
603 {
604 tokenInfo *token = newToken ();
605 token->type = TOKEN_LABEL;
606 vStringCopy (token->string, label);
607 makeFortranTag (token, TAG_LABEL);
608 deleteToken (token);
609 }
610
getLineType(void)611 static lineType getLineType (void)
612 {
613 static vString *label = NULL;
614 int column = 0;
615 lineType type = LTYPE_UNDETERMINED;
616
617 label = vStringNewOrClear (label);
618 do /* read in first 6 "margin" characters */
619 {
620 int c = getcFromInputFile ();
621
622 /* 3.2.1 Comment_Line. A comment line is any line that contains
623 * a C or an asterisk in column 1, or contains only blank characters
624 * in columns 1 through 72. A comment line that contains a C or
625 * an asterisk in column 1 may contain any character capable of
626 * representation in the processor in columns 2 through 72.
627 */
628 /* EXCEPTION! Some compilers permit '!' as a comment character here.
629 *
630 * Treat # and $ in column 1 as comment to permit preprocessor directives.
631 * Treat D and d in column 1 as comment for HP debug statements.
632 */
633 if (column == 0 && strchr ("*Cc!#$Dd", c) != NULL)
634 type = LTYPE_COMMENT;
635 else if (c == '\t') /* EXCEPTION! Some compilers permit a tab here */
636 {
637 column = 8;
638 type = LTYPE_INITIAL;
639 }
640 else if (column == 5)
641 {
642 /* 3.2.2 Initial_Line. An initial line is any line that is not
643 * a comment line and contains the character blank or the digit 0
644 * in column 6. Columns 1 through 5 may contain a statement label
645 * (3.4), or each of the columns 1 through 5 must contain the
646 * character blank.
647 */
648 if (c == ' ' || c == '0')
649 type = LTYPE_INITIAL;
650
651 /* 3.2.3 Continuation_Line. A continuation line is any line that
652 * contains any character of the FORTRAN character set other than
653 * the character blank or the digit 0 in column 6 and contains
654 * only blank characters in columns 1 through 5.
655 */
656 else if (vStringLength (label) == 0)
657 type = LTYPE_CONTINUATION;
658 else
659 type = LTYPE_INVALID;
660 }
661 else if (c == ' ')
662 ;
663 else if (c == EOF)
664 type = LTYPE_EOF;
665 else if (c == '\n')
666 type = LTYPE_SHORT;
667 else if (isdigit (c))
668 vStringPut (label, c);
669 else
670 type = LTYPE_INVALID;
671
672 ++column;
673 } while (column < 6 && type == LTYPE_UNDETERMINED);
674
675 Assert (type != LTYPE_UNDETERMINED);
676
677 if (vStringLength (label) > 0)
678 makeLabelTag (label);
679 return type;
680 }
681
getFixedFormChar(void)682 static int getFixedFormChar (void)
683 {
684 bool newline = false;
685 lineType type;
686 int c = '\0';
687
688 if (Column > 0)
689 {
690 #ifdef STRICT_FIXED_FORM
691 /* EXCEPTION! Some compilers permit more than 72 characters per line.
692 */
693 if (Column > 71)
694 c = skipLine ();
695 else
696 #endif
697 {
698 c = getcFromInputFile ();
699 ++Column;
700 }
701 if (c == '\n')
702 {
703 newline = true; /* need to check for continuation line */
704 Column = 0;
705 }
706 else if (c == '!' && ! ParsingString)
707 {
708 c = skipLine ();
709 newline = true; /* need to check for continuation line */
710 Column = 0;
711 }
712 else if (c == '&') /* check for free source form */
713 {
714 const int c2 = getcFromInputFile ();
715 if (c2 == '\n')
716 FreeSourceFormFound = true;
717 else
718 ungetcToInputFile (c2);
719 }
720 }
721 while (Column == 0)
722 {
723 type = getLineType ();
724 switch (type)
725 {
726 case LTYPE_UNDETERMINED:
727 case LTYPE_INVALID:
728 FreeSourceFormFound = true;
729 if (! FreeSourceForm)
730 return EOF;
731
732 case LTYPE_SHORT: break;
733 case LTYPE_COMMENT: skipLine (); break;
734
735 case LTYPE_EOF:
736 Column = 6;
737 if (newline)
738 c = '\n';
739 else
740 c = EOF;
741 break;
742
743 case LTYPE_INITIAL:
744 if (newline)
745 {
746 c = '\n';
747 Column = 6;
748 break;
749 }
750 /* fall through to next case */
751 case LTYPE_CONTINUATION:
752 Column = 5;
753 do
754 {
755 c = getcFromInputFile ();
756 ++Column;
757 } while (isBlank (c));
758 if (c == '\n')
759 Column = 0;
760 else if (Column > 6)
761 {
762 ungetcToInputFile (c);
763 c = ' ';
764 }
765 break;
766
767 default:
768 Assert ("Unexpected line type" == NULL);
769 }
770 }
771 return c;
772 }
773
skipToNextLine(void)774 static int skipToNextLine (void)
775 {
776 int c = skipLine ();
777 if (c != EOF)
778 c = getcFromInputFile ();
779 return c;
780 }
781
getFreeFormChar(void)782 static int getFreeFormChar (void)
783 {
784 static bool newline = true;
785 bool advanceLine = false;
786 int c = getcFromInputFile ();
787
788 /* If the last nonblank, non-comment character of a FORTRAN 90
789 * free-format text line is an ampersand then the next non-comment
790 * line is a continuation line.
791 */
792 if (c == '&')
793 {
794 do
795 c = getcFromInputFile ();
796 while (isspace (c) && c != '\n');
797 if (c == '\n')
798 {
799 newline = true;
800 advanceLine = true;
801 }
802 else if (c == '!')
803 advanceLine = true;
804 else
805 {
806 ungetcToInputFile (c);
807 c = '&';
808 }
809 }
810 else if (newline && (c == '!' || c == '#'))
811 advanceLine = true;
812 while (advanceLine)
813 {
814 while (isspace (c))
815 c = getcFromInputFile ();
816 if (c == '!' || (newline && c == '#'))
817 {
818 c = skipToNextLine ();
819 newline = true;
820 continue;
821 }
822 if (c == '&')
823 c = getcFromInputFile ();
824 else
825 advanceLine = false;
826 }
827 newline = (bool) (c == '\n');
828 return c;
829 }
830
getChar(void)831 static int getChar (void)
832 {
833 int c;
834
835 if (Ungetc != '\0')
836 {
837 c = Ungetc;
838 Ungetc = '\0';
839 }
840 else if (FreeSourceForm)
841 c = getFreeFormChar ();
842 else
843 c = getFixedFormChar ();
844 return c;
845 }
846
ungetChar(const int c)847 static void ungetChar (const int c)
848 {
849 Ungetc = c;
850 }
851
852 /* If a numeric is passed in 'c', this is used as the first digit of the
853 * numeric being parsed.
854 */
parseInteger(int c)855 static vString *parseInteger (int c)
856 {
857 vString *string = vStringNew ();
858
859 if (c == '-')
860 {
861 vStringPut (string, c);
862 c = getChar ();
863 }
864 else if (! isdigit (c))
865 c = getChar ();
866 while (c != EOF && isdigit (c))
867 {
868 vStringPut (string, c);
869 c = getChar ();
870 }
871
872 if (c == '_')
873 {
874 do
875 c = getChar ();
876 while (c != EOF && isalpha (c));
877 }
878 ungetChar (c);
879
880 return string;
881 }
882
parseNumeric(int c)883 static vString *parseNumeric (int c)
884 {
885 vString *string = parseInteger (c);
886
887 c = getChar ();
888 if (c == '.')
889 {
890 vString *integer = parseInteger ('\0');
891 vStringPut (string, c);
892 vStringCat (string, integer);
893 vStringDelete (integer);
894 c = getChar ();
895 }
896 if (tolower (c) == 'e')
897 {
898 vString *integer = parseInteger ('\0');
899 vStringPut (string, c);
900 vStringCat (string, integer);
901 vStringDelete (integer);
902 }
903 else
904 ungetChar (c);
905
906 return string;
907 }
908
parseString(vString * const string,const int delimiter)909 static void parseString (vString *const string, const int delimiter)
910 {
911 const unsigned long inputLineNumber = getInputLineNumber ();
912 int c;
913 ParsingString = true;
914 c = getChar ();
915 while (c != delimiter && c != '\n' && c != EOF)
916 {
917 vStringPut (string, c);
918 c = getChar ();
919 }
920 if (c == '\n' || c == EOF)
921 {
922 verbose ("%s: unterminated character string at line %lu\n",
923 getInputFileName (), inputLineNumber);
924 if (c != EOF && ! FreeSourceForm)
925 FreeSourceFormFound = true;
926 }
927 ParsingString = false;
928 }
929
930 /* Read a C identifier beginning with "firstChar" and places it into "name".
931 */
parseIdentifier(vString * const string,const int firstChar)932 static void parseIdentifier (vString *const string, const int firstChar)
933 {
934 int c = firstChar;
935
936 do
937 {
938 vStringPut (string, c);
939 c = getChar ();
940 } while (isident (c));
941
942 ungetChar (c); /* unget non-identifier character */
943 }
944
checkForLabel(void)945 static void checkForLabel (void)
946 {
947 tokenInfo* token = NULL;
948 int length;
949 int c;
950
951 do
952 c = getChar ();
953 while (isBlank (c));
954
955 for (length = 0 ; isdigit (c) && length < 5 ; ++length)
956 {
957 if (token == NULL)
958 {
959 token = newToken ();
960 token->type = TOKEN_LABEL;
961 }
962 vStringPut (token->string, c);
963 c = getChar ();
964 }
965 if (length > 0 && token != NULL)
966 {
967 makeFortranTag (token, TAG_LABEL);
968 deleteToken (token);
969 }
970 ungetChar (c);
971 }
972
readIdentifier(tokenInfo * const token,const int c)973 static void readIdentifier (tokenInfo *const token, const int c)
974 {
975 parseIdentifier (token->string, c);
976 token->keyword = lookupCaseKeyword (vStringValue (token->string), Lang_fortran);
977 if (! isKeyword (token, KEYWORD_NONE))
978 token->type = TOKEN_KEYWORD;
979 else
980 {
981 token->type = TOKEN_IDENTIFIER;
982 if (strncmp (vStringValue (token->string), "end", 3) == 0)
983 {
984 vString *const sub = vStringNewInit (vStringValue (token->string) + 3);
985 const keywordId kw = lookupCaseKeyword (vStringValue (sub), Lang_fortran);
986 vStringDelete (sub);
987 if (kw != KEYWORD_NONE)
988 {
989 token->secondary = newToken ();
990 token->secondary->type = TOKEN_KEYWORD;
991 token->secondary->keyword = kw;
992 token->keyword = KEYWORD_end;
993 }
994 }
995 }
996 }
997
readToken(tokenInfo * const token)998 static void readToken (tokenInfo *const token)
999 {
1000 int c;
1001
1002 deleteToken (token->secondary);
1003 token->type = TOKEN_UNDEFINED;
1004 token->tag = TAG_UNDEFINED;
1005 token->keyword = KEYWORD_NONE;
1006 token->secondary = NULL;
1007 token->implementation = IMP_DEFAULT;
1008 vStringClear (token->string);
1009 vStringDelete (token->parentType);
1010 vStringDelete (token->signature);
1011 token->parentType = NULL;
1012 token->isMethod = false;
1013 token->signature = NULL;
1014
1015 getNextChar:
1016 c = getChar ();
1017
1018 token->lineNumber = getInputLineNumber ();
1019 token->filePosition = getInputFilePosition ();
1020
1021 switch (c)
1022 {
1023 case EOF: token->type = TOKEN_EOF; break;
1024 case ' ': goto getNextChar;
1025 case '\t': goto getNextChar;
1026 case ',': token->type = TOKEN_COMMA; break;
1027 case '(': token->type = TOKEN_PAREN_OPEN; break;
1028 case ')': token->type = TOKEN_PAREN_CLOSE; break;
1029 case '[': token->type = TOKEN_SQUARE_OPEN; break;
1030 case ']': token->type = TOKEN_SQUARE_CLOSE; break;
1031 case '%': token->type = TOKEN_PERCENT; break;
1032
1033 case '*':
1034 case '/':
1035 case '+':
1036 case '-':
1037 case '=':
1038 case '<':
1039 case '>':
1040 {
1041 const char *const operatorChars = "*/+=<>";
1042 do {
1043 vStringPut (token->string, c);
1044 c = getChar ();
1045 } while (strchr (operatorChars, c) != NULL);
1046 ungetChar (c);
1047 token->type = TOKEN_OPERATOR;
1048 break;
1049 }
1050
1051 case '!':
1052 if (FreeSourceForm)
1053 {
1054 do
1055 c = getChar ();
1056 while (c != '\n' && c != EOF);
1057 }
1058 else
1059 {
1060 skipLine ();
1061 Column = 0;
1062 }
1063 /* fall through to newline case */
1064 case '\n':
1065 token->type = TOKEN_STATEMENT_END;
1066 if (FreeSourceForm)
1067 checkForLabel ();
1068 break;
1069
1070 case '.':
1071 parseIdentifier (token->string, c);
1072 c = getChar ();
1073 if (c == '.')
1074 {
1075 vStringPut (token->string, c);
1076 token->type = TOKEN_OPERATOR;
1077 }
1078 else
1079 {
1080 ungetChar (c);
1081 token->type = TOKEN_UNDEFINED;
1082 }
1083 break;
1084
1085 case '"':
1086 case '\'':
1087 parseString (token->string, c);
1088 token->type = TOKEN_STRING;
1089 break;
1090
1091 case ';':
1092 token->type = TOKEN_STATEMENT_END;
1093 break;
1094
1095 case ':':
1096 c = getChar ();
1097 if (c == ':')
1098 token->type = TOKEN_DOUBLE_COLON;
1099 else
1100 {
1101 ungetChar (c);
1102 token->type = TOKEN_COLON;
1103 }
1104 break;
1105
1106 default:
1107 if (isalpha (c))
1108 readIdentifier (token, c);
1109 else if (isdigit (c))
1110 {
1111 vString *numeric = parseNumeric (c);
1112 vStringCat (token->string, numeric);
1113 vStringDelete (numeric);
1114 token->type = TOKEN_NUMERIC;
1115 }
1116 else
1117 token->type = TOKEN_UNDEFINED;
1118 break;
1119 }
1120 }
1121
readSubToken(tokenInfo * const token)1122 static void readSubToken (tokenInfo *const token)
1123 {
1124 if (token->secondary == NULL)
1125 {
1126 token->secondary = newToken ();
1127 readToken (token->secondary);
1128 }
1129 }
1130
1131 /*
1132 * Scanning functions
1133 */
1134
skipToToken(tokenInfo * const token,tokenType type)1135 static void skipToToken (tokenInfo *const token, tokenType type)
1136 {
1137 while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END) &&
1138 !(token->secondary != NULL && isType (token->secondary, TOKEN_STATEMENT_END)) &&
1139 ! isType (token, TOKEN_EOF))
1140 readToken (token);
1141 }
1142
skipPast(tokenInfo * const token,tokenType type)1143 static void skipPast (tokenInfo *const token, tokenType type)
1144 {
1145 skipToToken (token, type);
1146 if (! isType (token, TOKEN_STATEMENT_END))
1147 readToken (token);
1148 }
1149
skipToNextStatement(tokenInfo * const token)1150 static void skipToNextStatement (tokenInfo *const token)
1151 {
1152 do
1153 {
1154 skipToToken (token, TOKEN_STATEMENT_END);
1155 readToken (token);
1156 } while (isType (token, TOKEN_STATEMENT_END));
1157 }
1158
1159 /* skip over paired tokens, managing nested pairs and stopping at statement end
1160 * or right after closing token, whatever comes first.
1161 */
skipOverPairsFull(tokenInfo * const token,tokenType topen,tokenType tclose,void (* token_cb)(tokenInfo * const,void *),void * user_data)1162 static void skipOverPairsFull (tokenInfo *const token,
1163 tokenType topen,
1164 tokenType tclose,
1165 void (* token_cb) (tokenInfo *const, void *),
1166 void *user_data)
1167 {
1168 int level = 0;
1169 do {
1170 if (isType (token, TOKEN_STATEMENT_END))
1171 break;
1172 else if (isType (token, topen))
1173 ++level;
1174 else if (isType (token, tclose))
1175 --level;
1176 else if (token_cb)
1177 token_cb (token, user_data);
1178 readToken (token);
1179 } while (level > 0 && !isType (token, TOKEN_EOF));
1180 }
1181
skipOverParensFull(tokenInfo * const token,void (* token_cb)(tokenInfo * const,void *),void * user_data)1182 static void skipOverParensFull (tokenInfo *const token,
1183 void (* token_cb) (tokenInfo *const, void *),
1184 void *user_data)
1185 {
1186 skipOverPairsFull (token, TOKEN_PAREN_OPEN,
1187 TOKEN_PAREN_CLOSE,
1188 token_cb, user_data);
1189 }
1190
skipOverSquaresFull(tokenInfo * const token,void (* token_cb)(tokenInfo * const,void *),void * user_data)1191 static void skipOverSquaresFull (tokenInfo *const token,
1192 void (* token_cb) (tokenInfo *const, void *),
1193 void *user_data)
1194 {
1195 skipOverPairsFull (token, TOKEN_SQUARE_OPEN,
1196 TOKEN_SQUARE_CLOSE,
1197 token_cb, user_data);
1198 }
1199
skipOverParens(tokenInfo * const token)1200 static void skipOverParens (tokenInfo *const token)
1201 {
1202 skipOverParensFull (token, NULL, NULL);
1203 }
1204
skipOverSquares(tokenInfo * const token)1205 static void skipOverSquares (tokenInfo *const token)
1206 {
1207 skipOverSquaresFull (token, NULL, NULL);
1208 }
1209
isTypeSpec(tokenInfo * const token)1210 static bool isTypeSpec (tokenInfo *const token)
1211 {
1212 bool result;
1213 switch (token->keyword)
1214 {
1215 case KEYWORD_byte:
1216 case KEYWORD_integer:
1217 case KEYWORD_real:
1218 case KEYWORD_double:
1219 case KEYWORD_complex:
1220 case KEYWORD_character:
1221 case KEYWORD_logical:
1222 case KEYWORD_record:
1223 case KEYWORD_type:
1224 case KEYWORD_procedure:
1225 case KEYWORD_final:
1226 case KEYWORD_generic:
1227 case KEYWORD_class:
1228 case KEYWORD_enumerator:
1229 result = true;
1230 break;
1231 default:
1232 result = false;
1233 break;
1234 }
1235 return result;
1236 }
1237
isSubprogramPrefix(tokenInfo * const token)1238 static bool isSubprogramPrefix (tokenInfo *const token)
1239 {
1240 bool result;
1241 switch (token->keyword)
1242 {
1243 case KEYWORD_elemental:
1244 case KEYWORD_pure:
1245 case KEYWORD_recursive:
1246 case KEYWORD_stdcall:
1247 result = true;
1248 break;
1249 default:
1250 result = false;
1251 break;
1252 }
1253 return result;
1254 }
1255
parseKindSelector(tokenInfo * const token)1256 static void parseKindSelector (tokenInfo *const token)
1257 {
1258 if (isType (token, TOKEN_PAREN_OPEN))
1259 skipOverParens (token); /* skip kind-selector */
1260 if (isType (token, TOKEN_OPERATOR) &&
1261 strcmp (vStringValue (token->string), "*") == 0)
1262 {
1263 readToken (token);
1264 if (isType (token, TOKEN_PAREN_OPEN))
1265 skipOverParens (token);
1266 else
1267 readToken (token);
1268 }
1269 }
1270
1271 /* type-spec
1272 * is INTEGER [kind-selector]
1273 * or REAL [kind-selector] is ( etc. )
1274 * or DOUBLE PRECISION
1275 * or COMPLEX [kind-selector]
1276 * or CHARACTER [kind-selector]
1277 * or LOGICAL [kind-selector]
1278 * or TYPE ( type-name )
1279 *
1280 * Note that INTEGER and REAL may be followed by "*N" where "N" is an integer
1281 */
parseTypeSpec(tokenInfo * const token)1282 static void parseTypeSpec (tokenInfo *const token)
1283 {
1284 /* parse type-spec, leaving `token' at first token following type-spec */
1285 Assert (isTypeSpec (token));
1286 switch (token->keyword)
1287 {
1288 case KEYWORD_character:
1289 /* skip char-selector */
1290 readToken (token);
1291 if (isType (token, TOKEN_OPERATOR) &&
1292 strcmp (vStringValue (token->string), "*") == 0)
1293 readToken (token);
1294 if (isType (token, TOKEN_PAREN_OPEN))
1295 skipOverParens (token);
1296 else if (isType (token, TOKEN_NUMERIC))
1297 readToken (token);
1298 break;
1299
1300
1301 case KEYWORD_byte:
1302 case KEYWORD_complex:
1303 case KEYWORD_integer:
1304 case KEYWORD_logical:
1305 case KEYWORD_real:
1306 case KEYWORD_procedure:
1307 case KEYWORD_class:
1308 readToken (token);
1309 parseKindSelector (token);
1310 break;
1311
1312 case KEYWORD_double:
1313 readToken (token);
1314 if (isKeyword (token, KEYWORD_complex) ||
1315 isKeyword (token, KEYWORD_precision))
1316 readToken (token);
1317 else
1318 skipToToken (token, TOKEN_STATEMENT_END);
1319 break;
1320
1321 case KEYWORD_record:
1322 readToken (token);
1323 if (isType (token, TOKEN_OPERATOR) &&
1324 strcmp (vStringValue (token->string), "/") == 0)
1325 {
1326 readToken (token); /* skip to structure name */
1327 readToken (token); /* skip to '/' */
1328 readToken (token); /* skip to variable name */
1329 }
1330 break;
1331
1332 case KEYWORD_type:
1333 readToken (token);
1334 if (isType (token, TOKEN_PAREN_OPEN))
1335 skipOverParens (token); /* skip type-name */
1336 else
1337 parseDerivedTypeDef (token);
1338 break;
1339
1340 case KEYWORD_final:
1341 case KEYWORD_generic:
1342 case KEYWORD_enumerator:
1343 readToken (token);
1344 break;
1345
1346 default:
1347 skipToToken (token, TOKEN_STATEMENT_END);
1348 break;
1349 }
1350 }
1351
skipStatementIfKeyword(tokenInfo * const token,keywordId keyword)1352 static bool skipStatementIfKeyword (tokenInfo *const token, keywordId keyword)
1353 {
1354 bool result = false;
1355 if (isKeyword (token, keyword))
1356 {
1357 result = true;
1358 skipToNextStatement (token);
1359 }
1360 return result;
1361 }
1362
1363 /* parse extends qualifier, leaving token at first token following close
1364 * parenthesis.
1365 */
1366
attachParentType(tokenInfo * const token,vString * parentType)1367 static void attachParentType (tokenInfo *const token, vString* parentType)
1368 {
1369 if (token->parentType)
1370 vStringDelete (token->parentType);
1371 token->parentType = parentType;
1372 }
1373
makeParentType(tokenInfo * const token,void * userData)1374 static void makeParentType (tokenInfo *const token, void *userData)
1375 {
1376 attachParentType ((tokenInfo *const)userData,
1377 vStringNewCopy (token->string));
1378 }
1379
parseExtendsQualifier(tokenInfo * const token,tokenInfo * const qualifierToken)1380 static void parseExtendsQualifier (tokenInfo *const token,
1381 tokenInfo *const qualifierToken)
1382 {
1383 skipOverParensFull (token, makeParentType, qualifierToken);
1384 }
1385
parseAbstractQualifier(tokenInfo * const token,tokenInfo * const qualifierToken)1386 static void parseAbstractQualifier (tokenInfo *const token,
1387 tokenInfo *const qualifierToken)
1388 {
1389 Assert (isKeyword (token, KEYWORD_abstract));
1390 qualifierToken->implementation = IMP_ABSTRACT;
1391 readToken (token);
1392 }
1393
parseDeferredQualifier(tokenInfo * const token,tokenInfo * const qualifierToken)1394 static void parseDeferredQualifier (tokenInfo *const token,
1395 tokenInfo *const qualifierToken)
1396 {
1397 Assert (isKeyword (token, KEYWORD_deferred));
1398 qualifierToken->implementation = IMP_DEFERRED;
1399 readToken (token);
1400 }
1401
parseNonOverridableQualifier(tokenInfo * const token,tokenInfo * const qualifierToken)1402 static void parseNonOverridableQualifier (tokenInfo *const token,
1403 tokenInfo *const qualifierToken)
1404 {
1405 Assert (isKeyword (token, KEYWORD_non_overridable));
1406 qualifierToken->implementation = IMP_NON_OVERRIDABLE;
1407 readToken (token);
1408 }
1409
1410 /* parse a list of qualifying specifiers, leaving `token' at first token
1411 * following list. Examples of such specifiers are:
1412 * [[, attr-spec] ::]
1413 * [[, component-attr-spec-list] ::]
1414 *
1415 * attr-spec
1416 * is PARAMETER
1417 * or access-spec (is PUBLIC or PRIVATE)
1418 * or ALLOCATABLE
1419 * or DIMENSION ( array-spec )
1420 * or EXTENDS ( extends-spec )
1421 * or EXTERNAL
1422 * or INTENT ( intent-spec )
1423 * or INTRINSIC
1424 * or OPTIONAL
1425 * or POINTER
1426 * or SAVE
1427 * or TARGET
1428 * or PASS
1429 * or NOPASS
1430 * or DEFERRED
1431 * or NON_OVERRIDABLE
1432 * or ABSTRACT
1433 *
1434 * component-attr-spec
1435 * is POINTER
1436 * or DIMENSION ( component-array-spec )
1437 */
parseQualifierSpecList(tokenInfo * const token)1438 static tokenInfo *parseQualifierSpecList (tokenInfo *const token)
1439 {
1440 tokenInfo *qualifierToken = newToken ();
1441
1442 do
1443 {
1444 readToken (token); /* should be an attr-spec */
1445 switch (token->keyword)
1446 {
1447 case KEYWORD_parameter:
1448 case KEYWORD_allocatable:
1449 case KEYWORD_external:
1450 case KEYWORD_intrinsic:
1451 case KEYWORD_kind:
1452 case KEYWORD_len:
1453 case KEYWORD_optional:
1454 case KEYWORD_private:
1455 case KEYWORD_pointer:
1456 case KEYWORD_protected:
1457 case KEYWORD_public:
1458 case KEYWORD_save:
1459 case KEYWORD_target:
1460 case KEYWORD_nopass:
1461 readToken (token);
1462 break;
1463
1464 case KEYWORD_dimension:
1465 case KEYWORD_intent:
1466 case KEYWORD_bind:
1467 readToken (token);
1468 skipOverParens (token);
1469 break;
1470
1471 case KEYWORD_extends:
1472 readToken (token);
1473 parseExtendsQualifier (token, qualifierToken);
1474 break;
1475
1476 case KEYWORD_pass:
1477 readToken (token);
1478 if (isType (token, TOKEN_PAREN_OPEN))
1479 skipOverParens (token);
1480 break;
1481
1482 case KEYWORD_abstract:
1483 parseAbstractQualifier (token, qualifierToken);
1484 break;
1485
1486 case KEYWORD_deferred:
1487 parseDeferredQualifier (token, qualifierToken);
1488 break;
1489
1490 case KEYWORD_non_overridable:
1491 parseNonOverridableQualifier (token, qualifierToken);
1492 break;
1493
1494 case KEYWORD_codimension:
1495 readToken (token);
1496 skipOverSquares (token);
1497 break;
1498
1499 default: skipToToken (token, TOKEN_STATEMENT_END); break;
1500 }
1501 } while (isType (token, TOKEN_COMMA));
1502 if (! isType (token, TOKEN_DOUBLE_COLON))
1503 skipToToken (token, TOKEN_STATEMENT_END);
1504
1505 return qualifierToken;
1506 }
1507
variableTagType(tokenInfo * const st)1508 static tagType variableTagType (tokenInfo *const st)
1509 {
1510 tagType result = TAG_VARIABLE;
1511 if (ancestorCount () > 0)
1512 {
1513 const tokenInfo* const parent = ancestorTop ();
1514 switch (parent->tag)
1515 {
1516 case TAG_SUBMODULE: /* Fall through */
1517 case TAG_MODULE: result = TAG_VARIABLE; break;
1518 case TAG_DERIVED_TYPE:
1519 if (st && st->isMethod)
1520 result = TAG_METHOD;
1521 else
1522 result = TAG_COMPONENT;
1523 break;
1524 case TAG_FUNCTION: result = TAG_LOCAL; break;
1525 case TAG_SUBROUTINE: result = TAG_LOCAL; break;
1526 case TAG_PROTOTYPE: result = TAG_LOCAL; break;
1527 case TAG_ENUM: result = TAG_ENUMERATOR; break;
1528 default: result = TAG_VARIABLE; break;
1529 }
1530 }
1531 return result;
1532 }
1533
parseEntityDecl(tokenInfo * const token,tokenInfo * const st)1534 static void parseEntityDecl (tokenInfo *const token,
1535 tokenInfo *const st)
1536 {
1537 Assert (isType (token, TOKEN_IDENTIFIER));
1538 if (st && st->implementation != IMP_DEFAULT)
1539 token->implementation = st->implementation;
1540 makeFortranTag (token, variableTagType (st));
1541 readToken (token);
1542 /* we check for both '()' and '[]'
1543 * coarray syntax permits variable(), variable[], or variable()[]
1544 */
1545 if (isType (token, TOKEN_PAREN_OPEN))
1546 skipOverParens (token);
1547 if (isType (token, TOKEN_SQUARE_OPEN))
1548 skipOverSquares (token);
1549 if (isType (token, TOKEN_OPERATOR) &&
1550 strcmp (vStringValue (token->string), "*") == 0)
1551 {
1552 readToken (token); /* read char-length */
1553 if (isType (token, TOKEN_PAREN_OPEN))
1554 skipOverParens (token);
1555 else
1556 readToken (token);
1557 }
1558 if (isType (token, TOKEN_OPERATOR))
1559 {
1560 if (strcmp (vStringValue (token->string), "/") == 0)
1561 { /* skip over initializations of structure field */
1562 readToken (token);
1563 skipPast (token, TOKEN_OPERATOR);
1564 }
1565 else if (strcmp (vStringValue (token->string), "=") == 0 ||
1566 strcmp (vStringValue (token->string), "=>") == 0)
1567 {
1568 while (! isType (token, TOKEN_COMMA) &&
1569 ! isType (token, TOKEN_STATEMENT_END) &&
1570 ! isType (token, TOKEN_EOF))
1571 {
1572 readToken (token);
1573 /* another coarray check, for () and [] */
1574 if (isType (token, TOKEN_PAREN_OPEN))
1575 skipOverParens (token);
1576 if (isType (token, TOKEN_SQUARE_OPEN))
1577 skipOverSquares (token);
1578 }
1579 }
1580 }
1581 /* token left at either comma or statement end */
1582 }
1583
parseEntityDeclList(tokenInfo * const token,tokenInfo * const st)1584 static void parseEntityDeclList (tokenInfo *const token,
1585 tokenInfo *const st)
1586 {
1587 if (isType (token, TOKEN_PERCENT))
1588 skipToNextStatement (token);
1589 else while (isType (token, TOKEN_IDENTIFIER) ||
1590 (isType (token, TOKEN_KEYWORD) &&
1591 !isKeyword (token, KEYWORD_function) &&
1592 !isKeyword (token, KEYWORD_subroutine)))
1593 {
1594 /* compilers accept keywords as identifiers */
1595 if (isType (token, TOKEN_KEYWORD))
1596 token->type = TOKEN_IDENTIFIER;
1597 parseEntityDecl (token, st);
1598 if (isType (token, TOKEN_COMMA))
1599 readToken (token);
1600 else if (isType (token, TOKEN_STATEMENT_END))
1601 {
1602 skipToNextStatement (token);
1603 break;
1604 }
1605 }
1606 }
1607
1608 /* type-declaration-stmt is
1609 * type-spec [[, attr-spec] ... ::] entity-decl-list
1610 */
parseTypeDeclarationStmt(tokenInfo * const token)1611 static void parseTypeDeclarationStmt (tokenInfo *const token)
1612 {
1613 Assert (isTypeSpec (token));
1614 parseTypeSpec (token);
1615 if (!isType (token, TOKEN_STATEMENT_END)) /* if not end of derived type... */
1616 {
1617 if (isType (token, TOKEN_COMMA))
1618 {
1619 tokenInfo* qualifierToken = parseQualifierSpecList (token);
1620 deleteToken (qualifierToken);
1621 }
1622 if (isType (token, TOKEN_DOUBLE_COLON))
1623 readToken (token);
1624 parseEntityDeclList (token, NULL);
1625 }
1626 if (isType (token, TOKEN_STATEMENT_END))
1627 skipToNextStatement (token);
1628 }
1629
1630 /* namelist-stmt is
1631 * NAMELIST /namelist-group-name/ namelist-group-object-list
1632 * [[,]/[namelist-group-name]/ namelist-block-object-list] ...
1633 *
1634 * namelist-group-object is
1635 * variable-name
1636 *
1637 * common-stmt is
1638 * COMMON [/[common-block-name]/] common-block-object-list
1639 * [[,]/[common-block-name]/ common-block-object-list] ...
1640 *
1641 * common-block-object is
1642 * variable-name [ ( explicit-shape-spec-list ) ]
1643 */
parseCommonNamelistStmt(tokenInfo * const token,tagType type)1644 static void parseCommonNamelistStmt (tokenInfo *const token, tagType type)
1645 {
1646 Assert (isKeyword (token, KEYWORD_common) ||
1647 isKeyword (token, KEYWORD_namelist));
1648 readToken (token);
1649 do
1650 {
1651 if (isType (token, TOKEN_OPERATOR) &&
1652 strcmp (vStringValue (token->string), "/") == 0)
1653 {
1654 readToken (token);
1655 if (isType (token, TOKEN_IDENTIFIER))
1656 {
1657 makeFortranTag (token, type);
1658 readToken (token);
1659 }
1660 skipPast (token, TOKEN_OPERATOR);
1661 }
1662 if (isType (token, TOKEN_IDENTIFIER))
1663 makeFortranTag (token, TAG_LOCAL);
1664 readToken (token);
1665 if (isType (token, TOKEN_PAREN_OPEN))
1666 skipOverParens (token); /* skip explicit-shape-spec-list */
1667 if (isType (token, TOKEN_COMMA))
1668 readToken (token);
1669 } while (! isType (token, TOKEN_STATEMENT_END) &&
1670 ! isType (token, TOKEN_EOF));
1671 skipToNextStatement (token);
1672 }
1673
parseFieldDefinition(tokenInfo * const token)1674 static void parseFieldDefinition (tokenInfo *const token)
1675 {
1676 if (isTypeSpec (token))
1677 parseTypeDeclarationStmt (token);
1678 else if (isKeyword (token, KEYWORD_structure))
1679 parseStructureStmt (token);
1680 else if (isKeyword (token, KEYWORD_union))
1681 parseUnionStmt (token);
1682 else
1683 skipToNextStatement (token);
1684 }
1685
parseMap(tokenInfo * const token)1686 static void parseMap (tokenInfo *const token)
1687 {
1688 Assert (isKeyword (token, KEYWORD_map));
1689 skipToNextStatement (token);
1690 while (! isKeyword (token, KEYWORD_end) &&
1691 ! isType (token, TOKEN_EOF))
1692 parseFieldDefinition (token);
1693 readSubToken (token);
1694 /* should be at KEYWORD_map token */
1695 skipToNextStatement (token);
1696 }
1697
1698 /* UNION
1699 * MAP
1700 * [field-definition] [field-definition] ...
1701 * END MAP
1702 * MAP
1703 * [field-definition] [field-definition] ...
1704 * END MAP
1705 * [MAP
1706 * [field-definition]
1707 * [field-definition] ...
1708 * END MAP] ...
1709 * END UNION
1710 * *
1711 *
1712 * Typed data declarations (variables or arrays) in structure declarations
1713 * have the form of normal Fortran typed data declarations. Data items with
1714 * different types can be freely intermixed within a structure declaration.
1715 *
1716 * Unnamed fields can be declared in a structure by specifying the pseudo
1717 * name %FILL in place of an actual field name. You can use this mechanism to
1718 * generate empty space in a record for purposes such as alignment.
1719 *
1720 * All mapped field declarations that are made within a UNION declaration
1721 * share a common location within the containing structure. When initializing
1722 * the fields within a UNION, the final initialization value assigned
1723 * overlays any value previously assigned to a field definition that shares
1724 * that field.
1725 */
parseUnionStmt(tokenInfo * const token)1726 static void parseUnionStmt (tokenInfo *const token)
1727 {
1728 Assert (isKeyword (token, KEYWORD_union));
1729 skipToNextStatement (token);
1730 while (isKeyword (token, KEYWORD_map))
1731 parseMap (token);
1732 /* should be at KEYWORD_end token */
1733 readSubToken (token);
1734 /* secondary token should be KEYWORD_end token */
1735 skipToNextStatement (token);
1736 }
1737
1738 /* STRUCTURE [/structure-name/] [field-names]
1739 * [field-definition]
1740 * [field-definition] ...
1741 * END STRUCTURE
1742 *
1743 * structure-name
1744 * identifies the structure in a subsequent RECORD statement.
1745 * Substructures can be established within a structure by means of either
1746 * a nested STRUCTURE declaration or a RECORD statement.
1747 *
1748 * field-names
1749 * (for substructure declarations only) one or more names having the
1750 * structure of the substructure being defined.
1751 *
1752 * field-definition
1753 * can be one or more of the following:
1754 *
1755 * Typed data declarations, which can optionally include one or more
1756 * data initialization values.
1757 *
1758 * Substructure declarations (defined by either RECORD statements or
1759 * subsequent STRUCTURE statements).
1760 *
1761 * UNION declarations, which are mapped fields defined by a block of
1762 * statements. The syntax of a UNION declaration is described below.
1763 *
1764 * PARAMETER statements, which do not affect the form of the
1765 * structure.
1766 */
parseStructureStmt(tokenInfo * const token)1767 static void parseStructureStmt (tokenInfo *const token)
1768 {
1769 tokenInfo *name = NULL;
1770 Assert (isKeyword (token, KEYWORD_structure));
1771 readToken (token);
1772 if (isType (token, TOKEN_OPERATOR) &&
1773 strcmp (vStringValue (token->string), "/") == 0)
1774 { /* read structure name */
1775 readToken (token);
1776 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
1777 {
1778 name = newTokenFrom (token);
1779 name->type = TOKEN_IDENTIFIER;
1780 }
1781 skipPast (token, TOKEN_OPERATOR);
1782 }
1783 if (name == NULL)
1784 { /* fake out anonymous structure */
1785 name = newAnonTokenFrom (token, TAG_COMPONENT);
1786 name->type = TOKEN_IDENTIFIER;
1787 name->tag = TAG_DERIVED_TYPE;
1788 }
1789 makeFortranTag (name, TAG_DERIVED_TYPE);
1790 while (isType (token, TOKEN_IDENTIFIER))
1791 { /* read field names */
1792 makeFortranTag (token, TAG_COMPONENT);
1793 readToken (token);
1794 if (isType (token, TOKEN_COMMA))
1795 readToken (token);
1796 }
1797 skipToNextStatement (token);
1798 ancestorPush (name);
1799 while (! isKeyword (token, KEYWORD_end) &&
1800 ! isType (token, TOKEN_EOF))
1801 parseFieldDefinition (token);
1802 readSubToken (token);
1803 /* secondary token should be KEYWORD_structure token */
1804 skipToNextStatement (token);
1805 ancestorPop ();
1806 deleteToken (name);
1807 }
1808
1809 /* specification-stmt
1810 * is access-stmt (is access-spec [[::] access-id-list)
1811 * or allocatable-stmt (is ALLOCATABLE [::] array-name etc.)
1812 * or common-stmt (is COMMON [ / [common-block-name] /] etc.)
1813 * or data-stmt (is DATA data-stmt-list [[,] data-stmt-set] ...)
1814 * or dimension-stmt (is DIMENSION [::] array-name etc.)
1815 * or equivalence-stmt (is EQUIVALENCE equivalence-set-list)
1816 * or external-stmt (is EXTERNAL etc.)
1817 * or intent-stmt (is INTENT ( intent-spec ) [::] etc.)
1818 * or intrinsic-stmt (is INTRINSIC etc.)
1819 * or namelist-stmt (is NAMELIST / namelist-group-name / etc.)
1820 * or optional-stmt (is OPTIONAL [::] etc.)
1821 * or pointer-stmt (is POINTER [::] object-name etc.)
1822 * or save-stmt (is SAVE etc.)
1823 * or target-stmt (is TARGET [::] object-name etc.)
1824 *
1825 * access-spec is PUBLIC or PRIVATE
1826 */
parseSpecificationStmt(tokenInfo * const token)1827 static bool parseSpecificationStmt (tokenInfo *const token)
1828 {
1829 bool result = true;
1830 switch (token->keyword)
1831 {
1832 case KEYWORD_common:
1833 parseCommonNamelistStmt (token, TAG_COMMON_BLOCK);
1834 break;
1835
1836 case KEYWORD_namelist:
1837 parseCommonNamelistStmt (token, TAG_NAMELIST);
1838 break;
1839
1840 case KEYWORD_structure:
1841 parseStructureStmt (token);
1842 break;
1843
1844 case KEYWORD_allocatable:
1845 case KEYWORD_data:
1846 case KEYWORD_dimension:
1847 case KEYWORD_equivalence:
1848 case KEYWORD_external:
1849 case KEYWORD_intent:
1850 case KEYWORD_intrinsic:
1851 case KEYWORD_optional:
1852 case KEYWORD_pointer:
1853 case KEYWORD_private:
1854 case KEYWORD_protected:
1855 case KEYWORD_public:
1856 case KEYWORD_save:
1857 case KEYWORD_target:
1858 skipToNextStatement (token);
1859 break;
1860
1861 default:
1862 result = false;
1863 break;
1864 }
1865 return result;
1866 }
1867
1868 /* Type bound generic procedure is:
1869 * GENERIC [, access-spec ] :: generic-spec => binding-name1 [, binding-name2]...
1870 * access-spec: PUBLIC or PRIVATE
1871 * generic-spec: 1. generic name; 2. OPERATOR(op); 3. ASSIGNMENT(=)
1872 * binding-name: type bound procedure
1873 */
parseGenericMethod(tokenInfo * const token)1874 static void parseGenericMethod (tokenInfo *const token)
1875 {
1876 if (isKeyword (token, KEYWORD_assignment) ||
1877 isKeyword (token, KEYWORD_operator))
1878 {
1879 readToken (token);
1880 if (isType (token, TOKEN_PAREN_OPEN))
1881 readToken (token);
1882 if (isType (token, TOKEN_OPERATOR))
1883 makeFortranTag (token, TAG_METHOD);
1884 }
1885 else
1886 {
1887 if (isType (token, TOKEN_KEYWORD))
1888 token->type = TOKEN_IDENTIFIER;
1889 makeFortranTag (token, TAG_METHOD);
1890 }
1891 skipToNextStatement (token);
1892 }
1893
1894 /* component-def-stmt is
1895 * type-spec [[, component-attr-spec-list] ::] component-decl-list
1896 *
1897 * component-decl is
1898 * component-name [ ( component-array-spec ) ] [ * char-length ]
1899 */
parseComponentDefStmt(tokenInfo * const token)1900 static void parseComponentDefStmt (tokenInfo *const token)
1901 {
1902 tokenInfo* st = newToken ();
1903 tokenInfo* qt = NULL;
1904 bool isGeneric = false;
1905
1906 Assert (isTypeSpec (token));
1907 if (isKeyword (token, KEYWORD_procedure) ||
1908 isKeyword (token, KEYWORD_final) ||
1909 isKeyword (token, KEYWORD_generic))
1910 st->isMethod = true;
1911 if (isKeyword (token, KEYWORD_generic))
1912 isGeneric = true;
1913 parseTypeSpec (token);
1914 if (isType (token, TOKEN_COMMA))
1915 {
1916 qt = parseQualifierSpecList (token);
1917 if (qt->implementation != IMP_DEFAULT)
1918 st->implementation = qt->implementation;
1919 deleteToken (qt);
1920 }
1921 if (isType (token, TOKEN_DOUBLE_COLON))
1922 readToken (token);
1923 if (isGeneric)
1924 parseGenericMethod (token);
1925 else
1926 parseEntityDeclList (token, st);
1927 deleteToken (st);
1928 }
1929
1930 /* derived-type-def is
1931 * derived-type-stmt is (TYPE [[, access-spec] ::] type-name
1932 * [private-sequence-stmt] ... (is PRIVATE or SEQUENCE)
1933 * component-def-stmt
1934 * [component-def-stmt] ...
1935 * end-type-stmt
1936 */
parseDerivedTypeDef(tokenInfo * const token)1937 static void parseDerivedTypeDef (tokenInfo *const token)
1938 {
1939 tokenInfo *qualifierToken = NULL;
1940
1941 if (isType (token, TOKEN_COMMA))
1942 qualifierToken = parseQualifierSpecList (token);
1943 if (isType (token, TOKEN_DOUBLE_COLON))
1944 readToken (token);
1945 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
1946 {
1947 token->type = TOKEN_IDENTIFIER;
1948 if (qualifierToken)
1949 {
1950 if (qualifierToken->parentType)
1951 token->parentType = vStringNewCopy (qualifierToken->parentType);
1952 if (qualifierToken->implementation != IMP_DEFAULT)
1953 token->implementation = qualifierToken->implementation;
1954 }
1955 makeFortranTag (token, TAG_DERIVED_TYPE);
1956 }
1957 deleteToken (qualifierToken);
1958 ancestorPush (token);
1959 skipToNextStatement (token);
1960 if (isKeyword (token, KEYWORD_private) ||
1961 isKeyword (token, KEYWORD_sequence))
1962 {
1963 skipToNextStatement (token);
1964 }
1965 while (! isKeyword (token, KEYWORD_end) &&
1966 ! isType (token, TOKEN_EOF))
1967 {
1968 if (isTypeSpec (token))
1969 parseComponentDefStmt (token);
1970 else
1971 skipToNextStatement (token);
1972 }
1973 readSubToken (token);
1974 /* secondary token should be KEYWORD_type token */
1975 skipToToken (token, TOKEN_STATEMENT_END);
1976 ancestorPop ();
1977 }
1978
1979 /* interface-block
1980 * interface-stmt (is INTERFACE [generic-spec])
1981 * [interface-body]
1982 * [module-procedure-stmt] ...
1983 * end-interface-stmt (is END INTERFACE)
1984 *
1985 * generic-spec
1986 * is generic-name
1987 * or OPERATOR ( defined-operator )
1988 * or ASSIGNMENT ( = )
1989 *
1990 * interface-body
1991 * is function-stmt
1992 * [specification-part]
1993 * end-function-stmt
1994 * or subroutine-stmt
1995 * [specification-part]
1996 * end-subroutine-stmt
1997 *
1998 * module-procedure-stmt is
1999 * MODULE PROCEDURE procedure-name-list
2000 */
parseInterfaceBlock(tokenInfo * const token)2001 static void parseInterfaceBlock (tokenInfo *const token)
2002 {
2003 tokenInfo *name = NULL;
2004 Assert (isKeyword (token, KEYWORD_interface));
2005 readToken (token);
2006 if (isKeyword (token, KEYWORD_assignment) ||
2007 isKeyword (token, KEYWORD_operator))
2008 {
2009 readToken (token);
2010 if (isType (token, TOKEN_PAREN_OPEN))
2011 readToken (token);
2012 if (isType (token, TOKEN_OPERATOR))
2013 name = newTokenFrom (token);
2014 }
2015 else if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2016 {
2017 name = newTokenFrom (token);
2018 name->type = TOKEN_IDENTIFIER;
2019 }
2020 if (name == NULL)
2021 {
2022 name = newAnonTokenFrom (token, TAG_INTERFACE);
2023 name->type = TOKEN_IDENTIFIER;
2024 name->tag = TAG_INTERFACE;
2025 }
2026 makeFortranTag (name, TAG_INTERFACE);
2027 ancestorPush (name);
2028 while (! isKeyword (token, KEYWORD_end) &&
2029 ! isType (token, TOKEN_EOF))
2030 {
2031 switch (token->keyword)
2032 {
2033 case KEYWORD_function:
2034 case KEYWORD_subroutine: parseSubprogram (token); break;
2035
2036 default:
2037 if (isSubprogramPrefix (token))
2038 readToken (token);
2039 else if (isTypeSpec (token))
2040 parseTypeSpec (token);
2041 else
2042 skipToNextStatement (token);
2043 break;
2044 }
2045 }
2046 readSubToken (token);
2047 /* secondary token should be KEYWORD_interface token */
2048 skipToNextStatement (token);
2049 ancestorPop ();
2050 deleteToken (name);
2051 }
2052
2053 /* enum-block
2054 * enum-stmt (is ENUM, BIND(C) [ :: type-alias-name ]
2055 * or ENUM [ kind-selector ] [ :: ] [ type-alias-name ])
2056 * [ enum-body (is ENUMERATOR [ :: ] enumerator-list) ]
2057 * end-enum-stmt (is END ENUM)
2058 */
parseEnumBlock(tokenInfo * const token)2059 static void parseEnumBlock (tokenInfo *const token)
2060 {
2061 tokenInfo *name = NULL;
2062 Assert (isKeyword (token, KEYWORD_enum));
2063 readToken (token);
2064 if (isType (token, TOKEN_COMMA))
2065 {
2066 readToken (token);
2067 if (isType (token, TOKEN_KEYWORD))
2068 readToken (token);
2069 if (isType (token, TOKEN_PAREN_OPEN))
2070 skipOverParens (token);
2071 }
2072 parseKindSelector (token);
2073 if (isType (token, TOKEN_DOUBLE_COLON))
2074 readToken (token);
2075 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2076 {
2077 name = newTokenFrom (token);
2078 name->type = TOKEN_IDENTIFIER;
2079 }
2080 if (name == NULL)
2081 {
2082 name = newAnonTokenFrom (token, TAG_ENUM);
2083 name->type = TOKEN_IDENTIFIER;
2084 name->tag = TAG_ENUM;
2085 }
2086 makeFortranTag (name, TAG_ENUM);
2087 skipToNextStatement (token);
2088 ancestorPush (name);
2089 while (! isKeyword (token, KEYWORD_end) &&
2090 ! isType(token, TOKEN_EOF))
2091 {
2092 if (isTypeSpec (token))
2093 parseTypeDeclarationStmt (token);
2094 else
2095 skipToNextStatement (token);
2096 }
2097 readSubToken (token);
2098 /* secondary token should be KEYWORD_enum token */
2099 skipToNextStatement (token);
2100 ancestorPop ();
2101 deleteToken (name);
2102 }
2103
2104 /* entry-stmt is
2105 * ENTRY entry-name [ ( dummy-arg-list ) ]
2106 */
parseEntryStmt(tokenInfo * const token)2107 static void parseEntryStmt (tokenInfo *const token)
2108 {
2109 Assert (isKeyword (token, KEYWORD_entry));
2110 readToken (token);
2111 if (isType (token, TOKEN_IDENTIFIER))
2112 makeFortranTag (token, TAG_ENTRY_POINT);
2113 skipToNextStatement (token);
2114 }
2115
2116 /* stmt-function-stmt is
2117 * function-name ([dummy-arg-name-list]) = scalar-expr
2118 */
parseStmtFunctionStmt(tokenInfo * const token)2119 static bool parseStmtFunctionStmt (tokenInfo *const token)
2120 {
2121 bool result = false;
2122 Assert (isType (token, TOKEN_IDENTIFIER));
2123 #if 0 /* cannot reliably parse this yet */
2124 makeFortranTag (token, TAG_FUNCTION);
2125 #endif
2126 readToken (token);
2127 if (isType (token, TOKEN_PAREN_OPEN))
2128 {
2129 skipOverParens (token);
2130 result = (bool) (isType (token, TOKEN_OPERATOR) &&
2131 strcmp (vStringValue (token->string), "=") == 0);
2132 }
2133 skipToNextStatement (token);
2134 return result;
2135 }
2136
isIgnoredDeclaration(tokenInfo * const token)2137 static bool isIgnoredDeclaration (tokenInfo *const token)
2138 {
2139 bool result;
2140 switch (token->keyword)
2141 {
2142 case KEYWORD_cexternal:
2143 case KEYWORD_cglobal:
2144 case KEYWORD_dllexport:
2145 case KEYWORD_dllimport:
2146 case KEYWORD_external:
2147 case KEYWORD_format:
2148 case KEYWORD_include:
2149 case KEYWORD_inline:
2150 case KEYWORD_parameter:
2151 case KEYWORD_pascal:
2152 case KEYWORD_pexternal:
2153 case KEYWORD_pglobal:
2154 case KEYWORD_static:
2155 case KEYWORD_value:
2156 case KEYWORD_virtual:
2157 case KEYWORD_volatile:
2158 result = true;
2159 break;
2160
2161 default:
2162 result = false;
2163 break;
2164 }
2165 return result;
2166 }
2167
2168 /* declaration-construct
2169 * [derived-type-def]
2170 * [interface-block]
2171 * [type-declaration-stmt]
2172 * [specification-stmt]
2173 * [parameter-stmt] (is PARAMETER ( named-constant-def-list )
2174 * [format-stmt] (is FORMAT format-specification)
2175 * [entry-stmt]
2176 * [stmt-function-stmt]
2177 */
parseDeclarationConstruct(tokenInfo * const token)2178 static bool parseDeclarationConstruct (tokenInfo *const token)
2179 {
2180 bool result = true;
2181 switch (token->keyword)
2182 {
2183 case KEYWORD_entry: parseEntryStmt (token); break;
2184 case KEYWORD_interface: parseInterfaceBlock (token); break;
2185 case KEYWORD_enum: parseEnumBlock (token); break;
2186 case KEYWORD_stdcall: readToken (token); break;
2187 /* derived type handled by parseTypeDeclarationStmt(); */
2188
2189 case KEYWORD_abstract:
2190 readToken (token);
2191 if (isKeyword (token, KEYWORD_interface))
2192 parseInterfaceBlock (token);
2193 else
2194 skipToNextStatement (token);
2195 result = true;
2196 break;
2197
2198 case KEYWORD_automatic:
2199 readToken (token);
2200 if (isTypeSpec (token))
2201 parseTypeDeclarationStmt (token);
2202 else
2203 skipToNextStatement (token);
2204 result = true;
2205 break;
2206
2207 default:
2208 if (isIgnoredDeclaration (token))
2209 skipToNextStatement (token);
2210 else if (isTypeSpec (token))
2211 {
2212 parseTypeDeclarationStmt (token);
2213 result = true;
2214 }
2215 else if (isType (token, TOKEN_IDENTIFIER))
2216 result = parseStmtFunctionStmt (token);
2217 else
2218 result = parseSpecificationStmt (token);
2219 break;
2220 }
2221 return result;
2222 }
2223
2224 /* implicit-part-stmt
2225 * is [implicit-stmt] (is IMPLICIT etc.)
2226 * or [parameter-stmt] (is PARAMETER etc.)
2227 * or [format-stmt] (is FORMAT etc.)
2228 * or [entry-stmt] (is ENTRY entry-name etc.)
2229 */
parseImplicitPartStmt(tokenInfo * const token)2230 static bool parseImplicitPartStmt (tokenInfo *const token)
2231 {
2232 bool result = true;
2233 switch (token->keyword)
2234 {
2235 case KEYWORD_entry: parseEntryStmt (token); break;
2236
2237 case KEYWORD_implicit:
2238 case KEYWORD_include:
2239 case KEYWORD_parameter:
2240 case KEYWORD_format:
2241 skipToNextStatement (token);
2242 break;
2243
2244 default: result = false; break;
2245 }
2246 return result;
2247 }
2248
2249 /* specification-part is
2250 * [use-stmt] ... (is USE module-name etc.)
2251 * [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt])
2252 * [declaration-construct] ...
2253 */
parseSpecificationPart(tokenInfo * const token)2254 static bool parseSpecificationPart (tokenInfo *const token)
2255 {
2256 bool result = false;
2257 while (skipStatementIfKeyword (token, KEYWORD_use))
2258 result = true;
2259 while (skipStatementIfKeyword (token, KEYWORD_import))
2260 result = true;
2261 while (parseImplicitPartStmt (token))
2262 result = true;
2263 while (parseDeclarationConstruct (token))
2264 result = true;
2265 return result;
2266 }
2267
2268 /* block-data is
2269 * block-data-stmt (is BLOCK DATA [block-data-name]
2270 * [specification-part]
2271 * end-block-data-stmt (is END [BLOCK DATA [block-data-name]])
2272 */
parseBlockData(tokenInfo * const token)2273 static void parseBlockData (tokenInfo *const token)
2274 {
2275 Assert (isKeyword (token, KEYWORD_block));
2276 readToken (token);
2277 if (isKeyword (token, KEYWORD_data))
2278 {
2279 readToken (token);
2280 if (isType (token, TOKEN_IDENTIFIER))
2281 makeFortranTag (token, TAG_BLOCK_DATA);
2282 }
2283 ancestorPush (token);
2284 skipToNextStatement (token);
2285 parseSpecificationPart (token);
2286 while (! isKeyword (token, KEYWORD_end) &&
2287 ! isType (token, TOKEN_EOF))
2288 skipToNextStatement (token);
2289 readSubToken (token);
2290 /* secondary token should be KEYWORD_NONE or KEYWORD_block token */
2291 skipToNextStatement (token);
2292 ancestorPop ();
2293 }
2294
2295 /* internal-subprogram-part is
2296 * contains-stmt (is CONTAINS)
2297 * internal-subprogram
2298 * [internal-subprogram] ...
2299 *
2300 * internal-subprogram
2301 * is function-subprogram
2302 * or subroutine-subprogram
2303 */
parseInternalSubprogramPart(tokenInfo * const token)2304 static void parseInternalSubprogramPart (tokenInfo *const token)
2305 {
2306 bool done = false;
2307 if (isKeyword (token, KEYWORD_contains))
2308 skipToNextStatement (token);
2309 do
2310 {
2311 switch (token->keyword)
2312 {
2313 case KEYWORD_function:
2314 case KEYWORD_subroutine: parseSubprogram (token); break;
2315 case KEYWORD_end: done = true; break;
2316
2317 default:
2318 if (isSubprogramPrefix (token))
2319 readToken (token);
2320 else if (isTypeSpec (token))
2321 parseTypeSpec (token);
2322 else
2323 readToken (token);
2324 break;
2325 }
2326 } while (! done && ! isType (token, TOKEN_EOF));
2327 }
2328
2329 /* submodule is
2330 * submodule-stmt (is SUBMODULE ( parent-identifier ) submodule-name)
2331 * [specification-part]
2332 * [module-subprogram-part]
2333 * end-submodule-stmt (is END [SUBMODULE [submodule-name]])
2334 *
2335 * parent-identifier is
2336 * ancestor_module_name [ : parent_submodule_name ]*
2337 *
2338 * ------------------------------------------------------------------
2339 * XL Fortran for AIX, V15.1.3
2340 * Language Reference
2341 * Program units and procedures
2342 * https://www.ibm.com/support/knowledgecenter/en/SSGH4D_15.1.3/com.ibm.xlf1513.aix.doc/language_ref/submodules.html
2343 * -------------------------------------------------------------------
2344 */
parserParentIdentifierOfSubmoduleStatement(tokenInfo * const token)2345 static vString *parserParentIdentifierOfSubmoduleStatement (tokenInfo *const token)
2346 {
2347 vString *parentId;
2348
2349 if (!isType (token, TOKEN_PAREN_OPEN))
2350 return NULL;
2351
2352 parentId = vStringNew();
2353
2354 while (1)
2355 {
2356 readToken (token);
2357 if (isType (token, TOKEN_IDENTIFIER))
2358 vStringCat (parentId, token->string);
2359 else if (isType (token, TOKEN_COLON))
2360 vStringPut (parentId, ':');
2361 else if (isType (token, TOKEN_PAREN_CLOSE))
2362 break;
2363 else
2364 {
2365 /* Unexpected token (including EOF) */
2366 vStringClear (parentId);
2367 break;
2368 }
2369 }
2370
2371 if (vStringLength (parentId) == 0)
2372 {
2373 vStringDelete (parentId);
2374 parentId = NULL;
2375 }
2376 return parentId;
2377 }
2378
2379 /* module is
2380 * module-stmt (is MODULE module-name)
2381 * [specification-part]
2382 * [module-subprogram-part]
2383 * end-module-stmt (is END [MODULE [module-name]])
2384 *
2385 * module-subprogram-part
2386 * contains-stmt (is CONTAINS)
2387 * module-subprogram
2388 * [module-subprogram] ...
2389 *
2390 * module-subprogram
2391 * is function-subprogram
2392 * or subroutine-subprogram
2393 */
parseModule(tokenInfo * const token,bool isSubmodule)2394 static void parseModule (tokenInfo *const token, bool isSubmodule)
2395 {
2396 vString *parentIdentifier = NULL;
2397
2398 Assert (((!isSubmodule) && isKeyword (token, KEYWORD_module))
2399 || (isSubmodule && isKeyword (token, KEYWORD_submodule)));
2400
2401
2402 if (isSubmodule)
2403 {
2404 readToken (token);
2405 parentIdentifier = parserParentIdentifierOfSubmoduleStatement (token);
2406 if (parentIdentifier == NULL)
2407 {
2408 /* Unexpected syntax */
2409 skipToNextStatement (token);
2410 return;
2411 }
2412 }
2413
2414 readToken (token);
2415 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2416 {
2417 token->type = TOKEN_IDENTIFIER;
2418 if (isSubmodule)
2419 {
2420 attachParentType (token, parentIdentifier);
2421 parentIdentifier = NULL;
2422 }
2423 makeFortranTag (token, isSubmodule? TAG_SUBMODULE: TAG_MODULE);
2424 }
2425 ancestorPush (token);
2426 skipToNextStatement (token);
2427 parseSpecificationPart (token);
2428 if (isKeyword (token, KEYWORD_contains))
2429 parseInternalSubprogramPart (token);
2430 while (! isKeyword (token, KEYWORD_end) &&
2431 ! isType (token, TOKEN_EOF))
2432 skipToNextStatement (token);
2433 readSubToken (token);
2434 /* secondary token should be KEYWORD_NONE or KEYWORD_module token */
2435 skipToNextStatement (token);
2436 ancestorPop ();
2437
2438 if (parentIdentifier)
2439 vStringDelete (parentIdentifier);
2440 }
2441
2442 /* execution-part
2443 * executable-construct
2444 *
2445 * executable-construct is
2446 * execution-part-construct [execution-part-construct]
2447 *
2448 * execution-part-construct
2449 * is executable-construct
2450 * or format-stmt
2451 * or data-stmt
2452 * or entry-stmt
2453 */
parseExecutionPart(tokenInfo * const token)2454 static bool parseExecutionPart (tokenInfo *const token)
2455 {
2456 bool result = false;
2457 bool done = false;
2458 while (! done && ! isType (token, TOKEN_EOF))
2459 {
2460 switch (token->keyword)
2461 {
2462 default:
2463 if (isSubprogramPrefix (token))
2464 readToken (token);
2465 else
2466 skipToNextStatement (token);
2467 result = true;
2468 break;
2469
2470 case KEYWORD_entry:
2471 parseEntryStmt (token);
2472 result = true;
2473 break;
2474
2475 case KEYWORD_contains:
2476 case KEYWORD_function:
2477 case KEYWORD_subroutine:
2478 done = true;
2479 break;
2480
2481 case KEYWORD_end:
2482 readSubToken (token);
2483 if (isSecondaryKeyword (token, KEYWORD_do) ||
2484 isSecondaryKeyword (token, KEYWORD_enum) ||
2485 isSecondaryKeyword (token, KEYWORD_if) ||
2486 isSecondaryKeyword (token, KEYWORD_select) ||
2487 isSecondaryKeyword (token, KEYWORD_where) ||
2488 isSecondaryKeyword (token, KEYWORD_forall) ||
2489 isSecondaryKeyword (token, KEYWORD_associate) ||
2490 isSecondaryKeyword (token, KEYWORD_block))
2491 {
2492 skipToNextStatement (token);
2493 result = true;
2494 }
2495 else
2496 done = true;
2497 break;
2498 }
2499 }
2500 return result;
2501 }
2502
makeSignature(tokenInfo * const token,void * signature)2503 static void makeSignature (tokenInfo *const token, void* signature)
2504 {
2505 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2506 vStringCat ((vString *)signature, token->string);
2507 else if (isType (token, TOKEN_COMMA))
2508 vStringCatS ((vString *)signature, ", ");
2509 }
2510
parseSignature(tokenInfo * const token)2511 static vString* parseSignature (tokenInfo *const token)
2512 {
2513 vString* signature = vStringNew ();
2514
2515 readToken (token);
2516 if (isType (token, TOKEN_PAREN_OPEN))
2517 {
2518 vStringPut (signature, '(');
2519 skipOverParensFull (token, makeSignature, signature);
2520 vStringPut (signature, ')');
2521 }
2522 return signature;
2523 }
2524
parseSubprogramFull(tokenInfo * const token,const tagType tag)2525 static void parseSubprogramFull (tokenInfo *const token, const tagType tag)
2526 {
2527 Assert (isKeyword (token, KEYWORD_program) ||
2528 isKeyword (token, KEYWORD_function) ||
2529 isKeyword (token, KEYWORD_subroutine));
2530 readToken (token);
2531 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2532 {
2533 tokenInfo* name = newTokenFrom (token);
2534 token->type = TOKEN_IDENTIFIER;
2535 if (tag == TAG_SUBROUTINE ||
2536 tag == TAG_PROTOTYPE)
2537 name->signature = parseSignature (token);
2538 makeFortranTag (name, tag);
2539 ancestorPush (name);
2540 deleteToken (name);
2541 }
2542 else
2543 ancestorPush (token);
2544 skipToNextStatement (token);
2545 parseSpecificationPart (token);
2546 parseExecutionPart (token);
2547 if (isKeyword (token, KEYWORD_contains))
2548 parseInternalSubprogramPart (token);
2549 /* should be at KEYWORD_end token */
2550 readSubToken (token);
2551 /* secondary token should be one of KEYWORD_NONE, KEYWORD_program,
2552 * KEYWORD_function, KEYWORD_function
2553 */
2554 skipToNextStatement (token);
2555 ancestorPop ();
2556 }
2557
subprogramTagType(tokenInfo * const token)2558 static tagType subprogramTagType (tokenInfo *const token)
2559 {
2560 tagType result = TAG_UNDEFINED;
2561
2562 if (insideInterface ())
2563 result = TAG_PROTOTYPE;
2564 else if (isKeyword (token, KEYWORD_subroutine))
2565 result = TAG_SUBROUTINE;
2566 else if (isKeyword (token, KEYWORD_function))
2567 result = TAG_FUNCTION;
2568
2569 Assert (result != TAG_UNDEFINED);
2570
2571 return result;
2572 }
2573
2574 /* function-subprogram is
2575 * function-stmt (is [prefix] FUNCTION function-name etc.)
2576 * [specification-part]
2577 * [execution-part]
2578 * [internal-subprogram-part]
2579 * end-function-stmt (is END [FUNCTION [function-name]])
2580 *
2581 * prefix
2582 * is type-spec [RECURSIVE]
2583 * or [RECURSIVE] type-spec
2584 */
2585 /* subroutine-subprogram is
2586 * subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.)
2587 * [specification-part]
2588 * [execution-part]
2589 * [internal-subprogram-part]
2590 * end-subroutine-stmt (is END [SUBROUTINE [function-name]])
2591 */
parseSubprogram(tokenInfo * const token)2592 static void parseSubprogram (tokenInfo *const token)
2593 {
2594 parseSubprogramFull (token, subprogramTagType (token));
2595 }
2596
2597 /* main-program is
2598 * [program-stmt] (is PROGRAM program-name)
2599 * [specification-part]
2600 * [execution-part]
2601 * [internal-subprogram-part ]
2602 * end-program-stmt
2603 */
parseMainProgram(tokenInfo * const token)2604 static void parseMainProgram (tokenInfo *const token)
2605 {
2606 parseSubprogramFull (token, TAG_PROGRAM);
2607 }
2608
2609 /* program-unit
2610 * is main-program
2611 * or external-subprogram (is function-subprogram or subroutine-subprogram)
2612 * or module
2613 * or block-data
2614 */
parseProgramUnit(tokenInfo * const token)2615 static void parseProgramUnit (tokenInfo *const token)
2616 {
2617 readToken (token);
2618 do
2619 {
2620 if (isType (token, TOKEN_STATEMENT_END))
2621 readToken (token);
2622 else switch (token->keyword)
2623 {
2624 case KEYWORD_block: parseBlockData (token); break;
2625 case KEYWORD_end: skipToNextStatement (token); break;
2626 case KEYWORD_function:
2627 case KEYWORD_subroutine: parseSubprogram (token); break;
2628 case KEYWORD_submodule: parseModule (token, true); break;
2629 case KEYWORD_module: parseModule (token, false); break;
2630 case KEYWORD_program: parseMainProgram (token); break;
2631
2632 default:
2633 if (isSubprogramPrefix (token))
2634 readToken (token);
2635 else
2636 {
2637 bool one = parseSpecificationPart (token);
2638 bool two = parseExecutionPart (token);
2639 if (! (one || two))
2640 readToken (token);
2641 }
2642 break;
2643 }
2644 } while (! isType (token, TOKEN_EOF));
2645 }
2646
findFortranTags(const unsigned int passCount)2647 static rescanReason findFortranTags (const unsigned int passCount)
2648 {
2649 tokenInfo *token;
2650 rescanReason rescan;
2651
2652 Assert (passCount < 3);
2653 token = newToken ();
2654
2655 FreeSourceForm = (bool) (passCount > 1);
2656 Column = 0;
2657 parseProgramUnit (token);
2658 if (FreeSourceFormFound && ! FreeSourceForm)
2659 {
2660 verbose ("%s: not fixed source form; retry as free source form\n",
2661 getInputFileName ());
2662 rescan = RESCAN_FAILED;
2663 }
2664 else
2665 {
2666 rescan = RESCAN_NONE;
2667 }
2668 ancestorClear ();
2669 deleteToken (token);
2670
2671 return rescan;
2672 }
2673
initialize(const langType language)2674 static void initialize (const langType language)
2675 {
2676 Lang_fortran = language;
2677 }
2678
FortranParser(void)2679 extern parserDefinition* FortranParser (void)
2680 {
2681 static const char *const extensions [] = {
2682 "f", "for", "ftn", "f77", "f90", "f95", "f03", "f08", "f15",
2683 #ifndef CASE_INSENSITIVE_FILENAMES
2684 "F", "FOR", "FTN", "F77", "F90", "F95", "F03", "F08", "F15",
2685 #endif
2686 NULL
2687 };
2688 parserDefinition* def = parserNew ("Fortran");
2689 def->kindTable = FortranKinds;
2690 def->kindCount = ARRAY_SIZE (FortranKinds);
2691 def->extensions = extensions;
2692 def->parser2 = findFortranTags;
2693 def->initialize = initialize;
2694 def->keywordTable = FortranKeywordTable;
2695 def->keywordCount = ARRAY_SIZE (FortranKeywordTable);
2696 return def;
2697 }
2698