?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Sync whitespace in parsers
[geany-mirror.git] / ctags / parsers / fortran.c
blob2de964c297784802e1c619900fec30b0886f244f
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) (boolean) (c == ' ' || c == '\t')
37 #define isType(token,t) (boolean) ((token)->type == (t))
38 #define isKeyword(token,k) (boolean) ((token)->keyword == (k))
39 #define isSecondaryKeyword(token,k) (boolean) ((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 typedef enum eKeywordId {
65 KEYWORD_NONE = -1,
66 KEYWORD_allocatable,
67 KEYWORD_assignment,
68 KEYWORD_associate,
69 KEYWORD_automatic,
70 KEYWORD_bind,
71 KEYWORD_block,
72 KEYWORD_byte,
73 KEYWORD_cexternal,
74 KEYWORD_cglobal,
75 KEYWORD_character,
76 KEYWORD_codimension,
77 KEYWORD_common,
78 KEYWORD_complex,
79 KEYWORD_contains,
80 KEYWORD_data,
81 KEYWORD_dimension,
82 KEYWORD_dllexport,
83 KEYWORD_dllimport,
84 KEYWORD_do,
85 KEYWORD_double,
86 KEYWORD_elemental,
87 KEYWORD_end,
88 KEYWORD_entry,
89 KEYWORD_enum,
90 KEYWORD_enumerator,
91 KEYWORD_equivalence,
92 KEYWORD_extends,
93 KEYWORD_external,
94 KEYWORD_forall,
95 KEYWORD_format,
96 KEYWORD_function,
97 KEYWORD_if,
98 KEYWORD_implicit,
99 KEYWORD_include,
100 KEYWORD_inline,
101 KEYWORD_integer,
102 KEYWORD_intent,
103 KEYWORD_interface,
104 KEYWORD_intrinsic,
105 KEYWORD_kind,
106 KEYWORD_len,
107 KEYWORD_logical,
108 KEYWORD_map,
109 KEYWORD_module,
110 KEYWORD_namelist,
111 KEYWORD_operator,
112 KEYWORD_optional,
113 KEYWORD_parameter,
114 KEYWORD_pascal,
115 KEYWORD_pexternal,
116 KEYWORD_pglobal,
117 KEYWORD_pointer,
118 KEYWORD_precision,
119 KEYWORD_private,
120 KEYWORD_procedure,
121 KEYWORD_program,
122 KEYWORD_public,
123 KEYWORD_pure,
124 KEYWORD_real,
125 KEYWORD_record,
126 KEYWORD_recursive,
127 KEYWORD_save,
128 KEYWORD_select,
129 KEYWORD_sequence,
130 KEYWORD_static,
131 KEYWORD_stdcall,
132 KEYWORD_structure,
133 KEYWORD_subroutine,
134 KEYWORD_target,
135 KEYWORD_then,
136 KEYWORD_type,
137 KEYWORD_union,
138 KEYWORD_use,
139 KEYWORD_value,
140 KEYWORD_virtual,
141 KEYWORD_volatile,
142 KEYWORD_where,
143 KEYWORD_while
144 } keywordId;
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 boolean FreeSourceForm = FALSE;
205 static boolean ParsingString;
206 static tokenInfo *Parent = NULL;
207 static boolean NewLine = TRUE;
208 static unsigned int contextual_fake_count = 0;
209
210 /* indexed by tagType */
211 static kindOption 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
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
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
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
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
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
406 static boolean insideInterface (void)
407 {
408 boolean 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
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
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
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
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
467 static boolean isFileScope (const tagType type)
468 {
469 return (boolean) (type == TAG_LABEL || type == TAG_LOCAL);
470 }
471
472 static boolean includeTag (const tagType type)
473 {
474 boolean include;
475 Assert (type > TAG_UNDEFINED && type < TAG_COUNT);
476 include = FortranKinds [(int) type].enabled;
477 if (include && isFileScope (type))
478 include = Option.include.fileScope;
479 return include;
480 }
481
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, &(FortranKinds [token->tag]));
491
492 if (token->tag == TAG_COMMON_BLOCK)
493 e.lineNumberEntry = (boolean) (Option.locate != EX_PATTERN);
494
495 e.lineNumber = token->lineNumber;
496 e.filePosition = token->filePosition;
497 e.isFileScope = isFileScope (token->tag);
498 e.truncateLine = (boolean) (token->tag != TAG_LABEL);
499
500 if (ancestorCount () > 0)
501 {
502 const tokenInfo* const scope = ancestorScope ();
503 if (scope != NULL)
504 {
505 e.extensionFields.scopeKind = &(FortranKinds [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
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
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
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 {
605 vStringTerminate (label);
606 makeLabelTag (label);
607 }
608 vStringDelete (label);
609 return type;
610 }
611
612 static int getFixedFormChar (void)
613 {
614 boolean newline = FALSE;
615 lineType type;
616 int c = '\0';
617
618 if (Column > 0)
619 {
620 #ifdef STRICT_FIXED_FORM
621 /* EXCEPTION! Some compilers permit more than 72 characters per line.
622 */
623 if (Column > 71)
624 c = skipLine ();
625 else
626 #endif
627 {
628 c = getcFromInputFile ();
629 ++Column;
630 }
631 if (c == '\n')
632 {
633 newline = TRUE; /* need to check for continuation line */
634 Column = 0;
635 }
636 else if (c == '!' && ! ParsingString)
637 {
638 c = skipLine ();
639 newline = TRUE; /* need to check for continuation line */
640 Column = 0;
641 }
642 else if (c == '&') /* check for free source form */
643 {
644 const int c2 = getcFromInputFile ();
645 if (c2 == '\n')
646 longjmp (Exception, (int) ExceptionFixedFormat);
647 else
648 ungetcToInputFile (c2);
649 }
650 }
651 while (Column == 0)
652 {
653 type = getLineType ();
654 switch (type)
655 {
656 case LTYPE_UNDETERMINED:
657 case LTYPE_INVALID:
658 longjmp (Exception, (int) ExceptionFixedFormat);
659 break;
660
661 case LTYPE_SHORT: break;
662 case LTYPE_COMMENT: skipLine (); break;
663
664 case LTYPE_EOF:
665 Column = 6;
666 if (newline)
667 c = '\n';
668 else
669 c = EOF;
670 break;
671
672 case LTYPE_INITIAL:
673 if (newline)
674 {
675 c = '\n';
676 Column = 6;
677 break;
678 }
679 /* fall through to next case */
680 case LTYPE_CONTINUATION:
681 Column = 5;
682 do
683 {
684 c = getcFromInputFile ();
685 ++Column;
686 } while (isBlank (c));
687 if (c == '\n')
688 Column = 0;
689 else if (Column > 6)
690 {
691 ungetcToInputFile (c);
692 c = ' ';
693 }
694 break;
695
696 default:
697 Assert ("Unexpected line type" == NULL);
698 }
699 }
700 return c;
701 }
702
703 static int skipToNextLine (void)
704 {
705 int c = skipLine ();
706 if (c != EOF)
707 c = getcFromInputFile ();
708 return c;
709 }
710
711 static int getFreeFormChar (boolean inComment)
712 {
713 boolean advanceLine = FALSE;
714 int c = getcFromInputFile ();
715
716 /* If the last nonblank, non-comment character of a FORTRAN 90
717 * free-format text line is an ampersand then the next non-comment
718 * line is a continuation line.
719 */
720 if (! inComment && c == '&')
721 {
722 do
723 c = getcFromInputFile ();
724 while (isspace (c) && c != '\n');
725 if (c == '\n')
726 {
727 NewLine = TRUE;
728 advanceLine = TRUE;
729 }
730 else if (c == '!')
731 advanceLine = TRUE;
732 else
733 {
734 ungetcToInputFile (c);
735 c = '&';
736 }
737 }
738 else if (NewLine && (c == '!' || c == '#'))
739 advanceLine = TRUE;
740 while (advanceLine)
741 {
742 while (isspace (c))
743 c = getcFromInputFile ();
744 if (c == '!' || (NewLine && c == '#'))
745 {
746 c = skipToNextLine ();
747 NewLine = TRUE;
748 continue;
749 }
750 if (c == '&')
751 c = getcFromInputFile ();
752 else
753 advanceLine = FALSE;
754 }
755 NewLine = (boolean) (c == '\n');
756 return c;
757 }
758
759 static int getChar (void)
760 {
761 int c;
762
763 if (Ungetc != '\0')
764 {
765 c = Ungetc;
766 Ungetc = '\0';
767 }
768 else if (FreeSourceForm)
769 c = getFreeFormChar (FALSE);
770 else
771 c = getFixedFormChar ();
772 return c;
773 }
774
775 static void ungetChar (const int c)
776 {
777 Ungetc = c;
778 }
779
780 /* If a numeric is passed in 'c', this is used as the first digit of the
781 * numeric being parsed.
782 */
783 static vString *parseInteger (int c)
784 {
785 vString *string = vStringNew ();
786
787 if (c == '-')
788 {
789 vStringPut (string, c);
790 c = getChar ();
791 }
792 else if (! isdigit (c))
793 c = getChar ();
794 while (c != EOF && isdigit (c))
795 {
796 vStringPut (string, c);
797 c = getChar ();
798 }
799 vStringTerminate (string);
800
801 if (c == '_')
802 {
803 do
804 c = getChar ();
805 while (c != EOF && isalpha (c));
806 }
807 ungetChar (c);
808
809 return string;
810 }
811
812 static vString *parseNumeric (int c)
813 {
814 vString *string = vStringNew ();
815 vString *integer = parseInteger (c);
816 vStringCopy (string, integer);
817 vStringDelete (integer);
818
819 c = getChar ();
820 if (c == '.')
821 {
822 integer = parseInteger ('\0');
823 vStringPut (string, c);
824 vStringCat (string, integer);
825 vStringDelete (integer);
826 c = getChar ();
827 }
828 if (tolower (c) == 'e')
829 {
830 integer = parseInteger ('\0');
831 vStringPut (string, c);
832 vStringCat (string, integer);
833 vStringDelete (integer);
834 }
835 else
836 ungetChar (c);
837
838 vStringTerminate (string);
839
840 return string;
841 }
842
843 static void parseString (vString *const string, const int delimiter)
844 {
845 const unsigned long inputLineNumber = getInputLineNumber ();
846 int c;
847 ParsingString = TRUE;
848 c = getChar ();
849 while (c != delimiter && c != '\n' && c != EOF)
850 {
851 vStringPut (string, c);
852 c = getChar ();
853 }
854 if (c == '\n' || c == EOF)
855 {
856 verbose ("%s: unterminated character string at line %lu\n",
857 getInputFileName (), inputLineNumber);
858 if (c == EOF)
859 longjmp (Exception, (int) ExceptionEOF);
860 else if (! FreeSourceForm)
861 longjmp (Exception, (int) ExceptionFixedFormat);
862 }
863 vStringTerminate (string);
864 ParsingString = FALSE;
865 }
866
867 /* Read a C identifier beginning with "firstChar" and places it into "name".
868 */
869 static void parseIdentifier (vString *const string, const int firstChar)
870 {
871 int c = firstChar;
872
873 do
874 {
875 vStringPut (string, c);
876 c = getChar ();
877 } while (isident (c));
878
879 vStringTerminate (string);
880 ungetChar (c); /* unget non-identifier character */
881 }
882
883 static void checkForLabel (void)
884 {
885 tokenInfo* token = NULL;
886 int length;
887 int c;
888
889 do
890 c = getChar ();
891 while (isBlank (c));
892
893 for (length = 0 ; isdigit (c) && length < 5 ; ++length)
894 {
895 if (token == NULL)
896 {
897 token = newToken ();
898 token->type = TOKEN_LABEL;
899 }
900 vStringPut (token->string, c);
901 c = getChar ();
902 }
903 if (length > 0 && token != NULL)
904 {
905 vStringTerminate (token->string);
906 makeFortranTag (token, TAG_LABEL);
907 deleteToken (token);
908 }
909 ungetChar (c);
910 }
911
912 /* Analyzes the identifier contained in a statement described by the
913 * statement structure and adjusts the structure according the significance
914 * of the identifier.
915 */
916 static keywordId analyzeToken (vString *const name, langType language)
917 {
918 static vString *keyword = NULL;
919 keywordId id;
920
921 if (keyword == NULL)
922 keyword = vStringNew ();
923 vStringCopyToLower (keyword, name);
924 id = (keywordId) lookupKeyword (vStringValue (keyword), language);
925
926 return id;
927 }
928
929 static void readIdentifier (tokenInfo *const token, const int c)
930 {
931 parseIdentifier (token->string, c);
932 token->keyword = analyzeToken (token->string, Lang_fortran);
933 if (! isKeyword (token, KEYWORD_NONE))
934 token->type = TOKEN_KEYWORD;
935 else
936 {
937 token->type = TOKEN_IDENTIFIER;
938 if (strncmp (vStringValue (token->string), "end", 3) == 0)
939 {
940 vString *const sub = vStringNewInit (vStringValue (token->string) + 3);
941 const keywordId kw = analyzeToken (sub, Lang_fortran);
942 vStringDelete (sub);
943 if (kw != KEYWORD_NONE)
944 {
945 token->secondary = newToken ();
946 token->secondary->type = TOKEN_KEYWORD;
947 token->secondary->keyword = kw;
948 token->keyword = KEYWORD_end;
949 }
950 }
951 }
952 }
953
954 static void readToken (tokenInfo *const token)
955 {
956 int c;
957
958 deleteToken (token->secondary);
959 token->type = TOKEN_UNDEFINED;
960 token->tag = TAG_UNDEFINED;
961 token->keyword = KEYWORD_NONE;
962 token->secondary = NULL;
963 vStringClear (token->string);
964
965 getNextChar:
966 c = getChar ();
967
968 token->lineNumber = getInputLineNumber ();
969 token->filePosition = getInputFilePosition ();
970
971 switch (c)
972 {
973 case EOF: longjmp (Exception, (int) ExceptionEOF); break;
974 case ' ': goto getNextChar;
975 case '\t': goto getNextChar;
976 case ',': token->type = TOKEN_COMMA; break;
977 case '(': token->type = TOKEN_PAREN_OPEN; break;
978 case ')': token->type = TOKEN_PAREN_CLOSE; break;
979 case '[': token->type = TOKEN_SQUARE_OPEN; break;
980 case ']': token->type = TOKEN_SQUARE_CLOSE; break;
981 case '%': token->type = TOKEN_PERCENT; break;
982
983 case '*':
984 case '/':
985 case '+':
986 case '-':
987 case '=':
988 case '<':
989 case '>':
990 {
991 const char *const operatorChars = "*/+=<>";
992 do {
993 vStringPut (token->string, c);
994 c = getChar ();
995 } while (strchr (operatorChars, c) != NULL);
996 ungetChar (c);
997 vStringTerminate (token->string);
998 token->type = TOKEN_OPERATOR;
999 break;
1000 }
1001
1002 case '!':
1003 if (FreeSourceForm)
1004 {
1005 do
1006 c = getFreeFormChar (TRUE);
1007 while (c != '\n' && c != EOF);
1008 }
1009 else
1010 {
1011 skipLine ();
1012 Column = 0;
1013 }
1014 /* fall through to newline case */
1015 case '\n':
1016 token->type = TOKEN_STATEMENT_END;
1017 if (FreeSourceForm)
1018 checkForLabel ();
1019 break;
1020
1021 case '.':
1022 parseIdentifier (token->string, c);
1023 c = getChar ();
1024 if (c == '.')
1025 {
1026 vStringPut (token->string, c);
1027 vStringTerminate (token->string);
1028 token->type = TOKEN_OPERATOR;
1029 }
1030 else
1031 {
1032 ungetChar (c);
1033 token->type = TOKEN_UNDEFINED;
1034 }
1035 break;
1036
1037 case '"':
1038 case '\'':
1039 parseString (token->string, c);
1040 token->type = TOKEN_STRING;
1041 break;
1042
1043 case ';':
1044 token->type = TOKEN_STATEMENT_END;
1045 break;
1046
1047 case ':':
1048 c = getChar ();
1049 if (c == ':')
1050 token->type = TOKEN_DOUBLE_COLON;
1051 else
1052 {
1053 ungetChar (c);
1054 token->type = TOKEN_UNDEFINED;
1055 }
1056 break;
1057
1058 default:
1059 if (isalpha (c))
1060 readIdentifier (token, c);
1061 else if (isdigit (c))
1062 {
1063 vString *numeric = parseNumeric (c);
1064 vStringCat (token->string, numeric);
1065 vStringDelete (numeric);
1066 token->type = TOKEN_NUMERIC;
1067 }
1068 else
1069 token->type = TOKEN_UNDEFINED;
1070 break;
1071 }
1072 }
1073
1074 static void readSubToken (tokenInfo *const token)
1075 {
1076 if (token->secondary == NULL)
1077 {
1078 token->secondary = newToken ();
1079 readToken (token->secondary);
1080 }
1081 }
1082
1083 /*
1084 * Scanning functions
1085 */
1086
1087 static void skipToToken (tokenInfo *const token, tokenType type)
1088 {
1089 while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END) &&
1090 !(token->secondary != NULL && isType (token->secondary, TOKEN_STATEMENT_END)))
1091 readToken (token);
1092 }
1093
1094 static void skipPast (tokenInfo *const token, tokenType type)
1095 {
1096 skipToToken (token, type);
1097 if (! isType (token, TOKEN_STATEMENT_END))
1098 readToken (token);
1099 }
1100
1101 static void skipToNextStatement (tokenInfo *const token)
1102 {
1103 do
1104 {
1105 skipToToken (token, TOKEN_STATEMENT_END);
1106 readToken (token);
1107 } while (isType (token, TOKEN_STATEMENT_END));
1108 }
1109
1110 /* skip over paired tokens, managing nested pairs and stopping at statement end
1111 * or right after closing token, whatever comes first.
1112 */
1113 static void skipOverPair (tokenInfo *const token, tokenType topen, tokenType tclose)
1114 {
1115 int level = 0;
1116 do {
1117 if (isType (token, TOKEN_STATEMENT_END))
1118 break;
1119 else if (isType (token, topen))
1120 ++level;
1121 else if (isType (token, tclose))
1122 --level;
1123 readToken (token);
1124 } while (level > 0);
1125 }
1126
1127 static void skipOverParens (tokenInfo *const token)
1128 {
1129 skipOverPair (token, TOKEN_PAREN_OPEN, TOKEN_PAREN_CLOSE);
1130 }
1131
1132 static void skipOverSquares (tokenInfo *const token)
1133 {
1134 skipOverPair (token, TOKEN_SQUARE_OPEN, TOKEN_SQUARE_CLOSE);
1135 }
1136
1137 static boolean isTypeSpec (tokenInfo *const token)
1138 {
1139 boolean result;
1140 switch (token->keyword)
1141 {
1142 case KEYWORD_byte:
1143 case KEYWORD_integer:
1144 case KEYWORD_real:
1145 case KEYWORD_double:
1146 case KEYWORD_complex:
1147 case KEYWORD_character:
1148 case KEYWORD_logical:
1149 case KEYWORD_record:
1150 case KEYWORD_type:
1151 case KEYWORD_procedure:
1152 case KEYWORD_enumerator:
1153 result = TRUE;
1154 break;
1155 default:
1156 result = FALSE;
1157 break;
1158 }
1159 return result;
1160 }
1161
1162 static boolean isSubprogramPrefix (tokenInfo *const token)
1163 {
1164 boolean result;
1165 switch (token->keyword)
1166 {
1167 case KEYWORD_elemental:
1168 case KEYWORD_pure:
1169 case KEYWORD_recursive:
1170 case KEYWORD_stdcall:
1171 result = TRUE;
1172 break;
1173 default:
1174 result = FALSE;
1175 break;
1176 }
1177 return result;
1178 }
1179
1180 static void parseKindSelector (tokenInfo *const token)
1181 {
1182 if (isType (token, TOKEN_PAREN_OPEN))
1183 skipOverParens (token); /* skip kind-selector */
1184 if (isType (token, TOKEN_OPERATOR) &&
1185 strcmp (vStringValue (token->string), "*") == 0)
1186 {
1187 readToken (token);
1188 if (isType (token, TOKEN_PAREN_OPEN))
1189 skipOverParens (token);
1190 else
1191 readToken (token);
1192 }
1193 }
1194
1195 /* type-spec
1196 * is INTEGER [kind-selector]
1197 * or REAL [kind-selector] is ( etc. )
1198 * or DOUBLE PRECISION
1199 * or COMPLEX [kind-selector]
1200 * or CHARACTER [kind-selector]
1201 * or LOGICAL [kind-selector]
1202 * or TYPE ( type-name )
1203 *
1204 * Note that INTEGER and REAL may be followed by "*N" where "N" is an integer
1205 */
1206 static void parseTypeSpec (tokenInfo *const token)
1207 {
1208 /* parse type-spec, leaving `token' at first token following type-spec */
1209 Assert (isTypeSpec (token));
1210 switch (token->keyword)
1211 {
1212 case KEYWORD_character:
1213 /* skip char-selector */
1214 readToken (token);
1215 if (isType (token, TOKEN_OPERATOR) &&
1216 strcmp (vStringValue (token->string), "*") == 0)
1217 readToken (token);
1218 if (isType (token, TOKEN_PAREN_OPEN))
1219 skipOverParens (token);
1220 else if (isType (token, TOKEN_NUMERIC))
1221 readToken (token);
1222 break;
1223
1224
1225 case KEYWORD_byte:
1226 case KEYWORD_complex:
1227 case KEYWORD_integer:
1228 case KEYWORD_logical:
1229 case KEYWORD_real:
1230 case KEYWORD_procedure:
1231 readToken (token);
1232 parseKindSelector (token);
1233 break;
1234
1235 case KEYWORD_double:
1236 readToken (token);
1237 if (isKeyword (token, KEYWORD_complex) ||
1238 isKeyword (token, KEYWORD_precision))
1239 readToken (token);
1240 else
1241 skipToToken (token, TOKEN_STATEMENT_END);
1242 break;
1243
1244 case KEYWORD_record:
1245 readToken (token);
1246 if (isType (token, TOKEN_OPERATOR) &&
1247 strcmp (vStringValue (token->string), "/") == 0)
1248 {
1249 readToken (token); /* skip to structure name */
1250 readToken (token); /* skip to '/' */
1251 readToken (token); /* skip to variable name */
1252 }
1253 break;
1254
1255 case KEYWORD_type:
1256 readToken (token);
1257 if (isType (token, TOKEN_PAREN_OPEN))
1258 skipOverParens (token); /* skip type-name */
1259 else
1260 parseDerivedTypeDef (token);
1261 break;
1262
1263 case KEYWORD_enumerator:
1264 readToken (token);
1265 break;
1266
1267 default:
1268 skipToToken (token, TOKEN_STATEMENT_END);
1269 break;
1270 }
1271 }
1272
1273 static boolean skipStatementIfKeyword (tokenInfo *const token, keywordId keyword)
1274 {
1275 boolean result = FALSE;
1276 if (isKeyword (token, keyword))
1277 {
1278 result = TRUE;
1279 skipToNextStatement (token);
1280 }
1281 return result;
1282 }
1283
1284 /* parse a list of qualifying specifiers, leaving `token' at first token
1285 * following list. Examples of such specifiers are:
1286 * [[, attr-spec] ::]
1287 * [[, component-attr-spec-list] ::]
1288 *
1289 * attr-spec
1290 * is PARAMETER
1291 * or access-spec (is PUBLIC or PRIVATE)
1292 * or ALLOCATABLE
1293 * or DIMENSION ( array-spec )
1294 * or EXTERNAL
1295 * or INTENT ( intent-spec )
1296 * or INTRINSIC
1297 * or OPTIONAL
1298 * or POINTER
1299 * or SAVE
1300 * or TARGET
1301 *
1302 * component-attr-spec
1303 * is POINTER
1304 * or DIMENSION ( component-array-spec )
1305 * or EXTENDS ( type name )
1306 */
1307 static void parseQualifierSpecList (tokenInfo *const token)
1308 {
1309 do
1310 {
1311 readToken (token); /* should be an attr-spec */
1312 switch (token->keyword)
1313 {
1314 case KEYWORD_parameter:
1315 case KEYWORD_allocatable:
1316 case KEYWORD_external:
1317 case KEYWORD_intrinsic:
1318 case KEYWORD_kind:
1319 case KEYWORD_len:
1320 case KEYWORD_optional:
1321 case KEYWORD_private:
1322 case KEYWORD_pointer:
1323 case KEYWORD_public:
1324 case KEYWORD_save:
1325 case KEYWORD_target:
1326 readToken (token);
1327 break;
1328
1329 case KEYWORD_codimension:
1330 readToken (token);
1331 skipOverSquares (token);
1332 break;
1333
1334 case KEYWORD_dimension:
1335 case KEYWORD_extends:
1336 case KEYWORD_intent:
1337 readToken (token);
1338 skipOverParens (token);
1339 break;
1340
1341 default: skipToToken (token, TOKEN_STATEMENT_END); break;
1342 }
1343 } while (isType (token, TOKEN_COMMA));
1344 if (! isType (token, TOKEN_DOUBLE_COLON))
1345 skipToToken (token, TOKEN_STATEMENT_END);
1346 }
1347
1348 static tagType variableTagType (void)
1349 {
1350 tagType result = TAG_VARIABLE;
1351 if (ancestorCount () > 0)
1352 {
1353 const tokenInfo* const parent = ancestorTop ();
1354 switch (parent->tag)
1355 {
1356 case TAG_MODULE: result = TAG_VARIABLE; break;
1357 case TAG_DERIVED_TYPE: result = TAG_COMPONENT; break;
1358 case TAG_FUNCTION: result = TAG_LOCAL; break;
1359 case TAG_SUBROUTINE: result = TAG_LOCAL; break;
1360 case TAG_ENUM: result = TAG_ENUMERATOR; break;
1361 default: result = TAG_VARIABLE; break;
1362 }
1363 }
1364 return result;
1365 }
1366
1367 static void parseEntityDecl (tokenInfo *const token)
1368 {
1369 Assert (isType (token, TOKEN_IDENTIFIER));
1370 makeFortranTag (token, variableTagType ());
1371 readToken (token);
1372 /* we check for both '()' and '[]'
1373 * coarray syntax permits variable(), variable[], or variable()[]
1374 */
1375 if (isType (token, TOKEN_PAREN_OPEN))
1376 skipOverParens (token);
1377 if (isType (token, TOKEN_SQUARE_OPEN))
1378 skipOverSquares (token);
1379 if (isType (token, TOKEN_OPERATOR) &&
1380 strcmp (vStringValue (token->string), "*") == 0)
1381 {
1382 readToken (token); /* read char-length */
1383 if (isType (token, TOKEN_PAREN_OPEN))
1384 skipOverParens (token);
1385 else
1386 readToken (token);
1387 }
1388 if (isType (token, TOKEN_OPERATOR))
1389 {
1390 if (strcmp (vStringValue (token->string), "/") == 0)
1391 { /* skip over initializations of structure field */
1392 readToken (token);
1393 skipPast (token, TOKEN_OPERATOR);
1394 }
1395 else if (strcmp (vStringValue (token->string), "=") == 0 ||
1396 strcmp (vStringValue (token->string), "=>") == 0)
1397 {
1398 while (! isType (token, TOKEN_COMMA) &&
1399 ! isType (token, TOKEN_STATEMENT_END))
1400 {
1401 readToken (token);
1402 /* another coarray check, for () and [] */
1403 if (isType (token, TOKEN_PAREN_OPEN))
1404 skipOverParens (token);
1405 if (isType (token, TOKEN_SQUARE_OPEN))
1406 skipOverSquares (token);
1407 }
1408 }
1409 }
1410 /* token left at either comma or statement end */
1411 }
1412
1413 static void parseEntityDeclList (tokenInfo *const token)
1414 {
1415 if (isType (token, TOKEN_PERCENT))
1416 skipToNextStatement (token);
1417 else while (isType (token, TOKEN_IDENTIFIER) ||
1418 (isType (token, TOKEN_KEYWORD) &&
1419 !isKeyword (token, KEYWORD_function) &&
1420 !isKeyword (token, KEYWORD_subroutine)))
1421 {
1422 /* compilers accept keywords as identifiers */
1423 if (isType (token, TOKEN_KEYWORD))
1424 token->type = TOKEN_IDENTIFIER;
1425 parseEntityDecl (token);
1426 if (isType (token, TOKEN_COMMA))
1427 readToken (token);
1428 else if (isType (token, TOKEN_STATEMENT_END))
1429 {
1430 skipToNextStatement (token);
1431 break;
1432 }
1433 }
1434 }
1435
1436 /* type-declaration-stmt is
1437 * type-spec [[, attr-spec] ... ::] entity-decl-list
1438 */
1439 static void parseTypeDeclarationStmt (tokenInfo *const token)
1440 {
1441 Assert (isTypeSpec (token));
1442 parseTypeSpec (token);
1443 if (!isType (token, TOKEN_STATEMENT_END)) /* if not end of derived type... */
1444 {
1445 if (isType (token, TOKEN_COMMA))
1446 parseQualifierSpecList (token);
1447 if (isType (token, TOKEN_DOUBLE_COLON))
1448 readToken (token);
1449 parseEntityDeclList (token);
1450 }
1451 if (isType (token, TOKEN_STATEMENT_END))
1452 skipToNextStatement (token);
1453 }
1454
1455 /* namelist-stmt is
1456 * NAMELIST /namelist-group-name/ namelist-group-object-list
1457 * [[,]/[namelist-group-name]/ namelist-block-object-list] ...
1458 *
1459 * namelist-group-object is
1460 * variable-name
1461 *
1462 * common-stmt is
1463 * COMMON [/[common-block-name]/] common-block-object-list
1464 * [[,]/[common-block-name]/ common-block-object-list] ...
1465 *
1466 * common-block-object is
1467 * variable-name [ ( explicit-shape-spec-list ) ]
1468 */
1469 static void parseCommonNamelistStmt (tokenInfo *const token, tagType type)
1470 {
1471 Assert (isKeyword (token, KEYWORD_common) ||
1472 isKeyword (token, KEYWORD_namelist));
1473 readToken (token);
1474 do
1475 {
1476 if (isType (token, TOKEN_OPERATOR) &&
1477 strcmp (vStringValue (token->string), "/") == 0)
1478 {
1479 readToken (token);
1480 if (isType (token, TOKEN_IDENTIFIER))
1481 {
1482 makeFortranTag (token, type);
1483 readToken (token);
1484 }
1485 skipPast (token, TOKEN_OPERATOR);
1486 }
1487 if (isType (token, TOKEN_IDENTIFIER))
1488 makeFortranTag (token, TAG_LOCAL);
1489 readToken (token);
1490 if (isType (token, TOKEN_PAREN_OPEN))
1491 skipOverParens (token); /* skip explicit-shape-spec-list */
1492 if (isType (token, TOKEN_COMMA))
1493 readToken (token);
1494 } while (! isType (token, TOKEN_STATEMENT_END));
1495 skipToNextStatement (token);
1496 }
1497
1498 static void parseFieldDefinition (tokenInfo *const token)
1499 {
1500 if (isTypeSpec (token))
1501 parseTypeDeclarationStmt (token);
1502 else if (isKeyword (token, KEYWORD_structure))
1503 parseStructureStmt (token);
1504 else if (isKeyword (token, KEYWORD_union))
1505 parseUnionStmt (token);
1506 else
1507 skipToNextStatement (token);
1508 }
1509
1510 static void parseMap (tokenInfo *const token)
1511 {
1512 Assert (isKeyword (token, KEYWORD_map));
1513 skipToNextStatement (token);
1514 while (! isKeyword (token, KEYWORD_end))
1515 parseFieldDefinition (token);
1516 readSubToken (token);
1517 /* should be at KEYWORD_map token */
1518 skipToNextStatement (token);
1519 }
1520
1521 /* UNION
1522 * MAP
1523 * [field-definition] [field-definition] ...
1524 * END MAP
1525 * MAP
1526 * [field-definition] [field-definition] ...
1527 * END MAP
1528 * [MAP
1529 * [field-definition]
1530 * [field-definition] ...
1531 * END MAP] ...
1532 * END UNION
1533 * *
1534 *
1535 * Typed data declarations (variables or arrays) in structure declarations
1536 * have the form of normal Fortran typed data declarations. Data items with
1537 * different types can be freely intermixed within a structure declaration.
1538 *
1539 * Unnamed fields can be declared in a structure by specifying the pseudo
1540 * name %FILL in place of an actual field name. You can use this mechanism to
1541 * generate empty space in a record for purposes such as alignment.
1542 *
1543 * All mapped field declarations that are made within a UNION declaration
1544 * share a common location within the containing structure. When initializing
1545 * the fields within a UNION, the final initialization value assigned
1546 * overlays any value previously assigned to a field definition that shares
1547 * that field.
1548 */
1549 static void parseUnionStmt (tokenInfo *const token)
1550 {
1551 Assert (isKeyword (token, KEYWORD_union));
1552 skipToNextStatement (token);
1553 while (isKeyword (token, KEYWORD_map))
1554 parseMap (token);
1555 /* should be at KEYWORD_end token */
1556 readSubToken (token);
1557 /* secondary token should be KEYWORD_end token */
1558 skipToNextStatement (token);
1559 }
1560
1561 /* STRUCTURE [/structure-name/] [field-names]
1562 * [field-definition]
1563 * [field-definition] ...
1564 * END STRUCTURE
1565 *
1566 * structure-name
1567 * identifies the structure in a subsequent RECORD statement.
1568 * Substructures can be established within a structure by means of either
1569 * a nested STRUCTURE declaration or a RECORD statement.
1570 *
1571 * field-names
1572 * (for substructure declarations only) one or more names having the
1573 * structure of the substructure being defined.
1574 *
1575 * field-definition
1576 * can be one or more of the following:
1577 *
1578 * Typed data declarations, which can optionally include one or more
1579 * data initialization values.
1580 *
1581 * Substructure declarations (defined by either RECORD statements or
1582 * subsequent STRUCTURE statements).
1583 *
1584 * UNION declarations, which are mapped fields defined by a block of
1585 * statements. The syntax of a UNION declaration is described below.
1586 *
1587 * PARAMETER statements, which do not affect the form of the
1588 * structure.
1589 */
1590 static void parseStructureStmt (tokenInfo *const token)
1591 {
1592 tokenInfo *name = NULL;
1593 Assert (isKeyword (token, KEYWORD_structure));
1594 readToken (token);
1595 if (isType (token, TOKEN_OPERATOR) &&
1596 strcmp (vStringValue (token->string), "/") == 0)
1597 { /* read structure name */
1598 readToken (token);
1599 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
1600 {
1601 name = newTokenFrom (token);
1602 name->type = TOKEN_IDENTIFIER;
1603 }
1604 skipPast (token, TOKEN_OPERATOR);
1605 }
1606 if (name == NULL)
1607 { /* fake out anonymous structure */
1608 name = newAnonTokenFrom (token, "Structure");
1609 name->type = TOKEN_IDENTIFIER;
1610 name->tag = TAG_DERIVED_TYPE;
1611 }
1612 makeFortranTag (name, TAG_DERIVED_TYPE);
1613 while (isType (token, TOKEN_IDENTIFIER))
1614 { /* read field names */
1615 makeFortranTag (token, TAG_COMPONENT);
1616 readToken (token);
1617 if (isType (token, TOKEN_COMMA))
1618 readToken (token);
1619 }
1620 skipToNextStatement (token);
1621 ancestorPush (name);
1622 while (! isKeyword (token, KEYWORD_end))
1623 parseFieldDefinition (token);
1624 readSubToken (token);
1625 /* secondary token should be KEYWORD_structure token */
1626 skipToNextStatement (token);
1627 ancestorPop ();
1628 deleteToken (name);
1629 }
1630
1631 /* specification-stmt
1632 * is access-stmt (is access-spec [[::] access-id-list)
1633 * or allocatable-stmt (is ALLOCATABLE [::] array-name etc.)
1634 * or common-stmt (is COMMON [ / [common-block-name] /] etc.)
1635 * or data-stmt (is DATA data-stmt-list [[,] data-stmt-set] ...)
1636 * or dimension-stmt (is DIMENSION [::] array-name etc.)
1637 * or equivalence-stmt (is EQUIVALENCE equivalence-set-list)
1638 * or external-stmt (is EXTERNAL etc.)
1639 * or intent-stmt (is INTENT ( intent-spec ) [::] etc.)
1640 * or intrinsic-stmt (is INTRINSIC etc.)
1641 * or namelist-stmt (is NAMELIST / namelist-group-name / etc.)
1642 * or optional-stmt (is OPTIONAL [::] etc.)
1643 * or pointer-stmt (is POINTER [::] object-name etc.)
1644 * or save-stmt (is SAVE etc.)
1645 * or target-stmt (is TARGET [::] object-name etc.)
1646 *
1647 * access-spec is PUBLIC or PRIVATE
1648 */
1649 static boolean parseSpecificationStmt (tokenInfo *const token)
1650 {
1651 boolean result = TRUE;
1652 switch (token->keyword)
1653 {
1654 case KEYWORD_common:
1655 parseCommonNamelistStmt (token, TAG_COMMON_BLOCK);
1656 break;
1657
1658 case KEYWORD_namelist:
1659 parseCommonNamelistStmt (token, TAG_NAMELIST);
1660 break;
1661
1662 case KEYWORD_structure:
1663 parseStructureStmt (token);
1664 break;
1665
1666 case KEYWORD_allocatable:
1667 case KEYWORD_data:
1668 case KEYWORD_dimension:
1669 case KEYWORD_equivalence:
1670 case KEYWORD_extends:
1671 case KEYWORD_external:
1672 case KEYWORD_intent:
1673 case KEYWORD_intrinsic:
1674 case KEYWORD_optional:
1675 case KEYWORD_pointer:
1676 case KEYWORD_private:
1677 case KEYWORD_public:
1678 case KEYWORD_save:
1679 case KEYWORD_target:
1680 skipToNextStatement (token);
1681 break;
1682
1683 default:
1684 result = FALSE;
1685 break;
1686 }
1687 return result;
1688 }
1689
1690 /* component-def-stmt is
1691 * type-spec [[, component-attr-spec-list] ::] component-decl-list
1692 *
1693 * component-decl is
1694 * component-name [ ( component-array-spec ) ] [ * char-length ]
1695 */
1696 static void parseComponentDefStmt (tokenInfo *const token)
1697 {
1698 Assert (isTypeSpec (token));
1699 parseTypeSpec (token);
1700 if (isType (token, TOKEN_COMMA))
1701 parseQualifierSpecList (token);
1702 if (isType (token, TOKEN_DOUBLE_COLON))
1703 readToken (token);
1704 parseEntityDeclList (token);
1705 }
1706
1707 /* derived-type-def is
1708 * derived-type-stmt is (TYPE [[, access-spec] ::] type-name
1709 * [private-sequence-stmt] ... (is PRIVATE or SEQUENCE)
1710 * component-def-stmt
1711 * [component-def-stmt] ...
1712 * end-type-stmt
1713 */
1714 static void parseDerivedTypeDef (tokenInfo *const token)
1715 {
1716 if (isType (token, TOKEN_COMMA))
1717 parseQualifierSpecList (token);
1718 if (isType (token, TOKEN_DOUBLE_COLON))
1719 readToken (token);
1720 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
1721 {
1722 token->type = TOKEN_IDENTIFIER;
1723 makeFortranTag (token, TAG_DERIVED_TYPE);
1724 }
1725 ancestorPush (token);
1726 skipToNextStatement (token);
1727 if (isKeyword (token, KEYWORD_private) ||
1728 isKeyword (token, KEYWORD_sequence))
1729 {
1730 skipToNextStatement (token);
1731 }
1732 while (! isKeyword (token, KEYWORD_end))
1733 {
1734 if (isTypeSpec (token))
1735 parseComponentDefStmt (token);
1736 else
1737 skipToNextStatement (token);
1738 }
1739 readSubToken (token);
1740 /* secondary token should be KEYWORD_type token */
1741 skipToToken (token, TOKEN_STATEMENT_END);
1742 ancestorPop ();
1743 }
1744
1745 /* interface-block
1746 * interface-stmt (is INTERFACE [generic-spec])
1747 * [interface-body]
1748 * [module-procedure-stmt] ...
1749 * end-interface-stmt (is END INTERFACE)
1750 *
1751 * generic-spec
1752 * is generic-name
1753 * or OPERATOR ( defined-operator )
1754 * or ASSIGNMENT ( = )
1755 *
1756 * interface-body
1757 * is function-stmt
1758 * [specification-part]
1759 * end-function-stmt
1760 * or subroutine-stmt
1761 * [specification-part]
1762 * end-subroutine-stmt
1763 *
1764 * module-procedure-stmt is
1765 * MODULE PROCEDURE procedure-name-list
1766 */
1767 static void parseInterfaceBlock (tokenInfo *const token)
1768 {
1769 tokenInfo *name = NULL;
1770 Assert (isKeyword (token, KEYWORD_interface));
1771 readToken (token);
1772 if (isKeyword (token, KEYWORD_assignment) ||
1773 isKeyword (token, KEYWORD_operator))
1774 {
1775 readToken (token);
1776 if (isType (token, TOKEN_PAREN_OPEN))
1777 readToken (token);
1778 if (isType (token, TOKEN_OPERATOR))
1779 name = newTokenFrom (token);
1780 }
1781 else if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
1782 {
1783 name = newTokenFrom (token);
1784 name->type = TOKEN_IDENTIFIER;
1785 }
1786 if (name == NULL)
1787 {
1788 name = newAnonTokenFrom (token, "Interface");
1789 name->type = TOKEN_IDENTIFIER;
1790 name->tag = TAG_INTERFACE;
1791 }
1792 makeFortranTag (name, TAG_INTERFACE);
1793 ancestorPush (name);
1794 while (! isKeyword (token, KEYWORD_end))
1795 {
1796 switch (token->keyword)
1797 {
1798 case KEYWORD_function: parseFunctionSubprogram (token); break;
1799 case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
1800
1801 default:
1802 if (isSubprogramPrefix (token))
1803 readToken (token);
1804 else if (isTypeSpec (token))
1805 parseTypeSpec (token);
1806 else
1807 skipToNextStatement (token);
1808 break;
1809 }
1810 }
1811 readSubToken (token);
1812 /* secondary token should be KEYWORD_interface token */
1813 skipToNextStatement (token);
1814 ancestorPop ();
1815 deleteToken (name);
1816 }
1817
1818 /* enum-block
1819 * enum-stmt (is ENUM, BIND(C) [ :: type-alias-name ]
1820 * or ENUM [ kind-selector ] [ :: ] [ type-alias-name ])
1821 * [ enum-body (is ENUMERATOR [ :: ] enumerator-list) ]
1822 * end-enum-stmt (is END ENUM)
1823 */
1824 static void parseEnumBlock (tokenInfo *const token)
1825 {
1826 tokenInfo *name = NULL;
1827 Assert (isKeyword (token, KEYWORD_enum));
1828 readToken (token);
1829 if (isType (token, TOKEN_COMMA))
1830 {
1831 readToken (token);
1832 if (isType (token, TOKEN_KEYWORD))
1833 readToken (token);
1834 if (isType (token, TOKEN_PAREN_OPEN))
1835 skipOverParens (token);
1836 }
1837 parseKindSelector (token);
1838 if (isType (token, TOKEN_DOUBLE_COLON))
1839 readToken (token);
1840 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
1841 {
1842 name = newTokenFrom (token);
1843 name->type = TOKEN_IDENTIFIER;
1844 }
1845 if (name == NULL)
1846 {
1847 name = newAnonTokenFrom (token, "Enum");
1848 name->type = TOKEN_IDENTIFIER;
1849 name->tag = TAG_ENUM;
1850 }
1851 makeFortranTag (name, TAG_ENUM);
1852 skipToNextStatement (token);
1853 ancestorPush (name);
1854 while (! isKeyword (token, KEYWORD_end))
1855 {
1856 if (isTypeSpec (token))
1857 parseTypeDeclarationStmt (token);
1858 else
1859 skipToNextStatement (token);
1860 }
1861 readSubToken (token);
1862 /* secondary token should be KEYWORD_enum token */
1863 skipToNextStatement (token);
1864 ancestorPop ();
1865 deleteToken (name);
1866 }
1867
1868 /* entry-stmt is
1869 * ENTRY entry-name [ ( dummy-arg-list ) ]
1870 */
1871 static void parseEntryStmt (tokenInfo *const token)
1872 {
1873 Assert (isKeyword (token, KEYWORD_entry));
1874 readToken (token);
1875 if (isType (token, TOKEN_IDENTIFIER))
1876 makeFortranTag (token, TAG_ENTRY_POINT);
1877 skipToNextStatement (token);
1878 }
1879
1880 /* stmt-function-stmt is
1881 * function-name ([dummy-arg-name-list]) = scalar-expr
1882 */
1883 static boolean parseStmtFunctionStmt (tokenInfo *const token)
1884 {
1885 boolean result = FALSE;
1886 Assert (isType (token, TOKEN_IDENTIFIER));
1887 #if 0 /* cannot reliably parse this yet */
1888 makeFortranTag (token, TAG_FUNCTION);
1889 #endif
1890 readToken (token);
1891 if (isType (token, TOKEN_PAREN_OPEN))
1892 {
1893 skipOverParens (token);
1894 result = (boolean) (isType (token, TOKEN_OPERATOR) &&
1895 strcmp (vStringValue (token->string), "=") == 0);
1896 }
1897 skipToNextStatement (token);
1898 return result;
1899 }
1900
1901 static boolean isIgnoredDeclaration (tokenInfo *const token)
1902 {
1903 boolean result;
1904 switch (token->keyword)
1905 {
1906 case KEYWORD_cexternal:
1907 case KEYWORD_cglobal:
1908 case KEYWORD_dllexport:
1909 case KEYWORD_dllimport:
1910 case KEYWORD_external:
1911 case KEYWORD_format:
1912 case KEYWORD_include:
1913 case KEYWORD_inline:
1914 case KEYWORD_parameter:
1915 case KEYWORD_pascal:
1916 case KEYWORD_pexternal:
1917 case KEYWORD_pglobal:
1918 case KEYWORD_static:
1919 case KEYWORD_value:
1920 case KEYWORD_virtual:
1921 case KEYWORD_volatile:
1922 result = TRUE;
1923 break;
1924
1925 default:
1926 result = FALSE;
1927 break;
1928 }
1929 return result;
1930 }
1931
1932 /* declaration-construct
1933 * [derived-type-def]
1934 * [interface-block]
1935 * [type-declaration-stmt]
1936 * [specification-stmt]
1937 * [parameter-stmt] (is PARAMETER ( named-constant-def-list )
1938 * [format-stmt] (is FORMAT format-specification)
1939 * [entry-stmt]
1940 * [stmt-function-stmt]
1941 */
1942 static boolean parseDeclarationConstruct (tokenInfo *const token)
1943 {
1944 boolean result = TRUE;
1945 switch (token->keyword)
1946 {
1947 case KEYWORD_entry: parseEntryStmt (token); break;
1948 case KEYWORD_interface: parseInterfaceBlock (token); break;
1949 case KEYWORD_enum: parseEnumBlock (token); break;
1950 case KEYWORD_stdcall: readToken (token); break;
1951 /* derived type handled by parseTypeDeclarationStmt(); */
1952
1953 case KEYWORD_automatic:
1954 readToken (token);
1955 if (isTypeSpec (token))
1956 parseTypeDeclarationStmt (token);
1957 else
1958 skipToNextStatement (token);
1959 result = TRUE;
1960 break;
1961
1962 default:
1963 if (isIgnoredDeclaration (token))
1964 skipToNextStatement (token);
1965 else if (isTypeSpec (token))
1966 {
1967 parseTypeDeclarationStmt (token);
1968 result = TRUE;
1969 }
1970 else if (isType (token, TOKEN_IDENTIFIER))
1971 result = parseStmtFunctionStmt (token);
1972 else
1973 result = parseSpecificationStmt (token);
1974 break;
1975 }
1976 return result;
1977 }
1978
1979 /* implicit-part-stmt
1980 * is [implicit-stmt] (is IMPLICIT etc.)
1981 * or [parameter-stmt] (is PARAMETER etc.)
1982 * or [format-stmt] (is FORMAT etc.)
1983 * or [entry-stmt] (is ENTRY entry-name etc.)
1984 */
1985 static boolean parseImplicitPartStmt (tokenInfo *const token)
1986 {
1987 boolean result = TRUE;
1988 switch (token->keyword)
1989 {
1990 case KEYWORD_entry: parseEntryStmt (token); break;
1991
1992 case KEYWORD_implicit:
1993 case KEYWORD_include:
1994 case KEYWORD_parameter:
1995 case KEYWORD_format:
1996 skipToNextStatement (token);
1997 break;
1998
1999 default: result = FALSE; break;
2000 }
2001 return result;
2002 }
2003
2004 /* specification-part is
2005 * [use-stmt] ... (is USE module-name etc.)
2006 * [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt])
2007 * [declaration-construct] ...
2008 */
2009 static boolean parseSpecificationPart (tokenInfo *const token)
2010 {
2011 boolean result = FALSE;
2012 while (skipStatementIfKeyword (token, KEYWORD_use))
2013 result = TRUE;
2014 while (parseImplicitPartStmt (token))
2015 result = TRUE;
2016 while (parseDeclarationConstruct (token))
2017 result = TRUE;
2018 return result;
2019 }
2020
2021 /* block-data is
2022 * block-data-stmt (is BLOCK DATA [block-data-name]
2023 * [specification-part]
2024 * end-block-data-stmt (is END [BLOCK DATA [block-data-name]])
2025 */
2026 static void parseBlockData (tokenInfo *const token)
2027 {
2028 Assert (isKeyword (token, KEYWORD_block));
2029 readToken (token);
2030 if (isKeyword (token, KEYWORD_data))
2031 {
2032 readToken (token);
2033 if (isType (token, TOKEN_IDENTIFIER))
2034 makeFortranTag (token, TAG_BLOCK_DATA);
2035 }
2036 ancestorPush (token);
2037 skipToNextStatement (token);
2038 parseSpecificationPart (token);
2039 while (! isKeyword (token, KEYWORD_end))
2040 skipToNextStatement (token);
2041 readSubToken (token);
2042 /* secondary token should be KEYWORD_NONE or KEYWORD_block token */
2043 skipToNextStatement (token);
2044 ancestorPop ();
2045 }
2046
2047 /* internal-subprogram-part is
2048 * contains-stmt (is CONTAINS)
2049 * internal-subprogram
2050 * [internal-subprogram] ...
2051 *
2052 * internal-subprogram
2053 * is function-subprogram
2054 * or subroutine-subprogram
2055 */
2056 static void parseInternalSubprogramPart (tokenInfo *const token)
2057 {
2058 boolean done = FALSE;
2059 if (isKeyword (token, KEYWORD_contains))
2060 skipToNextStatement (token);
2061 do
2062 {
2063 switch (token->keyword)
2064 {
2065 case KEYWORD_function: parseFunctionSubprogram (token); break;
2066 case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
2067 case KEYWORD_end: done = TRUE; break;
2068
2069 default:
2070 if (isSubprogramPrefix (token))
2071 readToken (token);
2072 else if (isTypeSpec (token))
2073 parseTypeSpec (token);
2074 else
2075 readToken (token);
2076 break;
2077 }
2078 } while (! done);
2079 }
2080
2081 /* module is
2082 * module-stmt (is MODULE module-name)
2083 * [specification-part]
2084 * [module-subprogram-part]
2085 * end-module-stmt (is END [MODULE [module-name]])
2086 *
2087 * module-subprogram-part
2088 * contains-stmt (is CONTAINS)
2089 * module-subprogram
2090 * [module-subprogram] ...
2091 *
2092 * module-subprogram
2093 * is function-subprogram
2094 * or subroutine-subprogram
2095 */
2096 static void parseModule (tokenInfo *const token)
2097 {
2098 Assert (isKeyword (token, KEYWORD_module));
2099 readToken (token);
2100 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2101 {
2102 token->type = TOKEN_IDENTIFIER;
2103 makeFortranTag (token, TAG_MODULE);
2104 }
2105 ancestorPush (token);
2106 skipToNextStatement (token);
2107 parseSpecificationPart (token);
2108 if (isKeyword (token, KEYWORD_contains))
2109 parseInternalSubprogramPart (token);
2110 while (! isKeyword (token, KEYWORD_end))
2111 skipToNextStatement (token);
2112 readSubToken (token);
2113 /* secondary token should be KEYWORD_NONE or KEYWORD_module token */
2114 skipToNextStatement (token);
2115 ancestorPop ();
2116 }
2117
2118 /* execution-part
2119 * executable-construct
2120 *
2121 * executable-construct is
2122 * execution-part-construct [execution-part-construct]
2123 *
2124 * execution-part-construct
2125 * is executable-construct
2126 * or format-stmt
2127 * or data-stmt
2128 * or entry-stmt
2129 */
2130 static boolean parseExecutionPart (tokenInfo *const token)
2131 {
2132 boolean result = FALSE;
2133 boolean done = FALSE;
2134 while (! done)
2135 {
2136 switch (token->keyword)
2137 {
2138 default:
2139 if (isSubprogramPrefix (token))
2140 readToken (token);
2141 else
2142 skipToNextStatement (token);
2143 result = TRUE;
2144 break;
2145
2146 case KEYWORD_entry:
2147 parseEntryStmt (token);
2148 result = TRUE;
2149 break;
2150
2151 case KEYWORD_contains:
2152 case KEYWORD_function:
2153 case KEYWORD_subroutine:
2154 done = TRUE;
2155 break;
2156
2157 case KEYWORD_end:
2158 readSubToken (token);
2159 if (isSecondaryKeyword (token, KEYWORD_do) ||
2160 isSecondaryKeyword (token, KEYWORD_enum) ||
2161 isSecondaryKeyword (token, KEYWORD_if) ||
2162 isSecondaryKeyword (token, KEYWORD_select) ||
2163 isSecondaryKeyword (token, KEYWORD_where) ||
2164 isSecondaryKeyword (token, KEYWORD_forall) ||
2165 isSecondaryKeyword (token, KEYWORD_associate))
2166 {
2167 skipToNextStatement (token);
2168 result = TRUE;
2169 }
2170 else
2171 done = TRUE;
2172 break;
2173 }
2174 }
2175 return result;
2176 }
2177
2178 static void parseSubprogram (tokenInfo *const token, const tagType tag)
2179 {
2180 Assert (isKeyword (token, KEYWORD_program) ||
2181 isKeyword (token, KEYWORD_function) ||
2182 isKeyword (token, KEYWORD_subroutine));
2183 readToken (token);
2184 if (isType (token, TOKEN_IDENTIFIER) || isType (token, TOKEN_KEYWORD))
2185 {
2186 token->type = TOKEN_IDENTIFIER;
2187 makeFortranTag (token, tag);
2188 }
2189 ancestorPush (token);
2190 skipToNextStatement (token);
2191 parseSpecificationPart (token);
2192 parseExecutionPart (token);
2193 if (isKeyword (token, KEYWORD_contains))
2194 parseInternalSubprogramPart (token);
2195 /* should be at KEYWORD_end token */
2196 readSubToken (token);
2197 /* secondary token should be one of KEYWORD_NONE, KEYWORD_program,
2198 * KEYWORD_function, KEYWORD_function
2199 */
2200 skipToNextStatement (token);
2201 ancestorPop ();
2202 }
2203
2204
2205 /* function-subprogram is
2206 * function-stmt (is [prefix] FUNCTION function-name etc.)
2207 * [specification-part]
2208 * [execution-part]
2209 * [internal-subprogram-part]
2210 * end-function-stmt (is END [FUNCTION [function-name]])
2211 *
2212 * prefix
2213 * is type-spec [RECURSIVE]
2214 * or [RECURSIVE] type-spec
2215 */
2216 static void parseFunctionSubprogram (tokenInfo *const token)
2217 {
2218 parseSubprogram (token, TAG_FUNCTION);
2219 }
2220
2221 /* subroutine-subprogram is
2222 * subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.)
2223 * [specification-part]
2224 * [execution-part]
2225 * [internal-subprogram-part]
2226 * end-subroutine-stmt (is END [SUBROUTINE [function-name]])
2227 */
2228 static void parseSubroutineSubprogram (tokenInfo *const token)
2229 {
2230 parseSubprogram (token, TAG_SUBROUTINE);
2231 }
2232
2233 /* main-program is
2234 * [program-stmt] (is PROGRAM program-name)
2235 * [specification-part]
2236 * [execution-part]
2237 * [internal-subprogram-part ]
2238 * end-program-stmt
2239 */
2240 static void parseMainProgram (tokenInfo *const token)
2241 {
2242 parseSubprogram (token, TAG_PROGRAM);
2243 }
2244
2245 /* program-unit
2246 * is main-program
2247 * or external-subprogram (is function-subprogram or subroutine-subprogram)
2248 * or module
2249 * or block-data
2250 */
2251 static void parseProgramUnit (tokenInfo *const token)
2252 {
2253 readToken (token);
2254 do
2255 {
2256 if (isType (token, TOKEN_STATEMENT_END))
2257 readToken (token);
2258 else switch (token->keyword)
2259 {
2260 case KEYWORD_block: parseBlockData (token); break;
2261 case KEYWORD_end: skipToNextStatement (token); break;
2262 case KEYWORD_function: parseFunctionSubprogram (token); break;
2263 case KEYWORD_module: parseModule (token); break;
2264 case KEYWORD_program: parseMainProgram (token); break;
2265 case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
2266
2267 default:
2268 if (isSubprogramPrefix (token))
2269 readToken (token);
2270 else
2271 {
2272 boolean one = parseSpecificationPart (token);
2273 boolean two = parseExecutionPart (token);
2274 if (! (one || two))
2275 readToken (token);
2276 }
2277 break;
2278 }
2279 } while (TRUE);
2280 }
2281
2282 static boolean findFortranTags (const unsigned int passCount)
2283 {
2284 tokenInfo *token;
2285 exception_t exception;
2286 boolean retry;
2287
2288 Assert (passCount < 3);
2289 Parent = newToken ();
2290 token = newToken ();
2291 FreeSourceForm = (boolean) (passCount > 1);
2292 contextual_fake_count = 0;
2293 Column = 0;
2294 NewLine = TRUE;
2295 exception = (exception_t) setjmp (Exception);
2296 if (exception == ExceptionEOF)
2297 retry = FALSE;
2298 else if (exception == ExceptionFixedFormat && ! FreeSourceForm)
2299 {
2300 verbose ("%s: not fixed source form; retry as free source form\n",
2301 getInputFileName ());
2302 retry = TRUE;
2303 }
2304 else
2305 {
2306 parseProgramUnit (token);
2307 retry = FALSE;
2308 }
2309 ancestorClear ();
2310 deleteToken (token);
2311 deleteToken (Parent);
2312
2313 return retry;
2314 }
2315
2316 static void initializeFortran (const langType language)
2317 {
2318 Lang_fortran = language;
2319 }
2320
2321 static void initializeF77 (const langType language)
2322 {
2323 Lang_f77 = language;
2324 }
2325
2326 extern parserDefinition* FortranParser (void)
2327 {
2328 static const char *const extensions [] = {
2329 "f90", "f95", "f03",
2330 #ifndef CASE_INSENSITIVE_FILENAMES
2331 "F90", "F95", "F03",
2332 #endif
2333 NULL
2334 };
2335 parserDefinition* def = parserNew ("Fortran");
2336 def->kinds = FortranKinds;
2337 def->kindCount = ARRAY_SIZE (FortranKinds);
2338 def->extensions = extensions;
2339 def->parser2 = findFortranTags;
2340 def->initialize = initializeFortran;
2341 def->keywordTable = FortranKeywordTable;
2342 def->keywordCount = ARRAY_SIZE (FortranKeywordTable);
2343 return def;
2344 }
2345
2346 extern parserDefinition* F77Parser (void)
2347 {
2348 static const char *const extensions [] = {
2349 "f", "for", "ftn", "f77",
2350 #ifndef CASE_INSENSITIVE_FILENAMES
2351 "F", "FOR", "FTN", "F77",
2352 #endif
2353 NULL
2354 };
2355 parserDefinition* def = parserNew ("F77");
2356 def->kinds = FortranKinds;
2357 def->kindCount = ARRAY_SIZE (FortranKinds);
2358 def->extensions = extensions;
2359 def->parser2 = findFortranTags;
2360 def->initialize = initializeF77;
2361 def->keywordTable = FortranKeywordTable;
2362 def->keywordCount = ARRAY_SIZE (FortranKeywordTable);
2363 return def;
2364 }
2365 /* vi:set tabstop=4 shiftwidth=4: */
A fast and lightweight IDE