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