Merge commit 'git-svn'
[anjuta-git-plugin.git] / tagmanager / fortran.c
blob949270743a9e75185ab6ae871ebb466af6dd4d16
1 /*
2 * $Id$
4 * Copyright (c) 1998-2003, Darren Hiebert
6 * This source code is released for free distribution under the terms of the
7 * GNU General Public License.
9 * This module contains functions for generating tags for Fortran language
10 * files.
14 * INCLUDE FILES
16 #include "general.h" /* must always come first */
18 #include <string.h>
19 #include <limits.h>
20 #include <ctype.h> /* to define tolower () */
21 #include <setjmp.h>
23 #include "debug.h"
24 #include "entry.h"
25 #include "keyword.h"
26 #include "options.h"
27 #include "parse.h"
28 #include "read.h"
29 #include "routines.h"
30 #include "vstring.h"
33 * MACROS
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))
43 * DATA DECLARATIONS
46 typedef enum eException {
47 ExceptionNone, ExceptionEOF, ExceptionFixedFormat, ExceptionLoop
48 } exception_t;
50 /* Used to designate type of line read in fixed source form.
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;
62 /* Used to specify type of keyword.
64 typedef enum eKeywordId {
65 KEYWORD_NONE = -1,
66 KEYWORD_allocatable,
67 KEYWORD_assignment,
68 KEYWORD_automatic,
69 KEYWORD_block,
70 KEYWORD_byte,
71 KEYWORD_cexternal,
72 KEYWORD_cglobal,
73 KEYWORD_character,
74 KEYWORD_common,
75 KEYWORD_complex,
76 KEYWORD_contains,
77 KEYWORD_data,
78 KEYWORD_dimension,
79 KEYWORD_dllexport,
80 KEYWORD_dllimport,
81 KEYWORD_do,
82 KEYWORD_double,
83 KEYWORD_elemental,
84 KEYWORD_end,
85 KEYWORD_entry,
86 KEYWORD_equivalence,
87 KEYWORD_external,
88 KEYWORD_format,
89 KEYWORD_function,
90 KEYWORD_if,
91 KEYWORD_implicit,
92 KEYWORD_include,
93 KEYWORD_inline,
94 KEYWORD_integer,
95 KEYWORD_intent,
96 KEYWORD_interface,
97 KEYWORD_intrinsic,
98 KEYWORD_logical,
99 KEYWORD_map,
100 KEYWORD_module,
101 KEYWORD_namelist,
102 KEYWORD_operator,
103 KEYWORD_optional,
104 KEYWORD_parameter,
105 KEYWORD_pascal,
106 KEYWORD_pexternal,
107 KEYWORD_pglobal,
108 KEYWORD_pointer,
109 KEYWORD_precision,
110 KEYWORD_private,
111 KEYWORD_program,
112 KEYWORD_public,
113 KEYWORD_pure,
114 KEYWORD_real,
115 KEYWORD_record,
116 KEYWORD_recursive,
117 KEYWORD_save,
118 KEYWORD_select,
119 KEYWORD_sequence,
120 KEYWORD_static,
121 KEYWORD_stdcall,
122 KEYWORD_structure,
123 KEYWORD_subroutine,
124 KEYWORD_target,
125 KEYWORD_then,
126 KEYWORD_type,
127 KEYWORD_union,
128 KEYWORD_use,
129 KEYWORD_value,
130 KEYWORD_virtual,
131 KEYWORD_volatile,
132 KEYWORD_where,
133 KEYWORD_while
134 } keywordId;
136 /* Used to determine whether keyword is valid for the token language and
137 * what its ID is.
139 typedef struct sKeywordDesc {
140 const char *name;
141 keywordId id;
142 } keywordDesc;
144 typedef enum eTokenType {
145 TOKEN_UNDEFINED,
146 TOKEN_COMMA,
147 TOKEN_DOUBLE_COLON,
148 TOKEN_IDENTIFIER,
149 TOKEN_KEYWORD,
150 TOKEN_LABEL,
151 TOKEN_NUMERIC,
152 TOKEN_OPERATOR,
153 TOKEN_PAREN_CLOSE,
154 TOKEN_PAREN_OPEN,
155 TOKEN_PERCENT,
156 TOKEN_STATEMENT_END,
157 TOKEN_STRING
158 } tokenType;
160 typedef enum eTagType {
161 TAG_UNDEFINED = -1,
162 TAG_BLOCK_DATA,
163 TAG_COMMON_BLOCK,
164 TAG_ENTRY_POINT,
165 TAG_FUNCTION,
166 TAG_INTERFACE,
167 TAG_COMPONENT,
168 TAG_LABEL,
169 TAG_LOCAL,
170 TAG_MODULE,
171 TAG_NAMELIST,
172 TAG_PROGRAM,
173 TAG_SUBROUTINE,
174 TAG_DERIVED_TYPE,
175 TAG_VARIABLE,
176 TAG_COUNT /* must be last */
177 } tagType;
179 typedef struct sTokenInfo {
180 tokenType type;
181 keywordId keyword;
182 tagType tag;
183 vString* string;
184 struct sTokenInfo *secondary;
185 unsigned long lineNumber;
186 fpos_t filePosition;
187 } tokenInfo;
190 * DATA DEFINITIONS
193 static langType Lang_fortran;
194 static jmp_buf Exception;
195 static int Ungetc;
196 static unsigned int Column;
197 static boolean FreeSourceForm;
198 static boolean ParsingString;
199 static tokenInfo *Parent;
201 /* indexed by tagType */
202 static kindOption FortranKinds [] = {
203 { TRUE, 'b', "block data", "block data"},
204 { TRUE, 'c', "common", "common blocks"},
205 { TRUE, 'e', "entry", "entry points"},
206 { TRUE, 'f', "function", "functions"},
207 { FALSE, 'i', "interface", "interface contents, generic names, and operators"},
208 { TRUE, 'k', "component", "type and structure components"},
209 { TRUE, 'l', "label", "labels"},
210 { FALSE, 'L', "local", "local, common block, and namelist variables"},
211 { TRUE, 'm', "module", "modules"},
212 { TRUE, 'n', "namelist", "namelists"},
213 { TRUE, 'p', "program", "programs"},
214 { TRUE, 's', "subroutine", "subroutines"},
215 { TRUE, 't', "type", "derived types and structures"},
216 { TRUE, 'v', "variable", "program (global) and module variables"}
219 /* For a definition of Fortran 77 with extensions:
220 * http://scienide.uwaterloo.ca/MIPSpro7/007-2362-004/sgi_html/index.html
222 * For the Compaq Fortran Reference Manual:
223 * http://h18009.www1.hp.com/fortran/docs/lrm/dflrm.htm
226 static const keywordDesc FortranKeywordTable [] = {
227 /* keyword keyword ID */
228 { "allocatable", KEYWORD_allocatable },
229 { "assignment", KEYWORD_assignment },
230 { "automatic", KEYWORD_automatic },
231 { "block", KEYWORD_block },
232 { "byte", KEYWORD_byte },
233 { "cexternal", KEYWORD_cexternal },
234 { "cglobal", KEYWORD_cglobal },
235 { "character", KEYWORD_character },
236 { "common", KEYWORD_common },
237 { "complex", KEYWORD_complex },
238 { "contains", KEYWORD_contains },
239 { "data", KEYWORD_data },
240 { "dimension", KEYWORD_dimension },
241 { "dll_export", KEYWORD_dllexport },
242 { "dll_import", KEYWORD_dllimport },
243 { "do", KEYWORD_do },
244 { "double", KEYWORD_double },
245 { "elemental", KEYWORD_elemental },
246 { "end", KEYWORD_end },
247 { "entry", KEYWORD_entry },
248 { "equivalence", KEYWORD_equivalence },
249 { "external", KEYWORD_external },
250 { "format", KEYWORD_format },
251 { "function", KEYWORD_function },
252 { "if", KEYWORD_if },
253 { "implicit", KEYWORD_implicit },
254 { "include", KEYWORD_include },
255 { "inline", KEYWORD_inline },
256 { "integer", KEYWORD_integer },
257 { "intent", KEYWORD_intent },
258 { "interface", KEYWORD_interface },
259 { "intrinsic", KEYWORD_intrinsic },
260 { "logical", KEYWORD_logical },
261 { "map", KEYWORD_map },
262 { "module", KEYWORD_module },
263 { "namelist", KEYWORD_namelist },
264 { "operator", KEYWORD_operator },
265 { "optional", KEYWORD_optional },
266 { "parameter", KEYWORD_parameter },
267 { "pascal", KEYWORD_pascal },
268 { "pexternal", KEYWORD_pexternal },
269 { "pglobal", KEYWORD_pglobal },
270 { "pointer", KEYWORD_pointer },
271 { "precision", KEYWORD_precision },
272 { "private", KEYWORD_private },
273 { "program", KEYWORD_program },
274 { "public", KEYWORD_public },
275 { "pure", KEYWORD_pure },
276 { "real", KEYWORD_real },
277 { "record", KEYWORD_record },
278 { "recursive", KEYWORD_recursive },
279 { "save", KEYWORD_save },
280 { "select", KEYWORD_select },
281 { "sequence", KEYWORD_sequence },
282 { "static", KEYWORD_static },
283 { "stdcall", KEYWORD_stdcall },
284 { "structure", KEYWORD_structure },
285 { "subroutine", KEYWORD_subroutine },
286 { "target", KEYWORD_target },
287 { "then", KEYWORD_then },
288 { "type", KEYWORD_type },
289 { "union", KEYWORD_union },
290 { "use", KEYWORD_use },
291 { "value", KEYWORD_value },
292 { "virtual", KEYWORD_virtual },
293 { "volatile", KEYWORD_volatile },
294 { "where", KEYWORD_where },
295 { "while", KEYWORD_while }
298 static struct {
299 unsigned int count;
300 unsigned int max;
301 tokenInfo* list;
302 } Ancestors = { 0, 0, NULL };
305 * FUNCTION PROTOTYPES
307 static void parseStructureStmt (tokenInfo *const token);
308 static void parseUnionStmt (tokenInfo *const token);
309 static void parseDerivedTypeDef (tokenInfo *const token);
310 static void parseFunctionSubprogram (tokenInfo *const token);
311 static void parseSubroutineSubprogram (tokenInfo *const token);
314 * FUNCTION DEFINITIONS
317 static void ancestorPush (tokenInfo *const token)
319 enum { incrementalIncrease = 10 };
320 if (Ancestors.list == NULL)
322 Assert (Ancestors.max == 0);
323 Ancestors.count = 0;
324 Ancestors.max = incrementalIncrease;
325 Ancestors.list = xMalloc (Ancestors.max, tokenInfo);
327 else if (Ancestors.count == Ancestors.max)
329 Ancestors.max += incrementalIncrease;
330 Ancestors.list = xRealloc (Ancestors.list, Ancestors.max, tokenInfo);
332 Ancestors.list [Ancestors.count] = *token;
333 Ancestors.list [Ancestors.count].string = vStringNewCopy (token->string);
334 Ancestors.count++;
337 static void ancestorPop (void)
339 Assert (Ancestors.count > 0);
340 --Ancestors.count;
341 vStringDelete (Ancestors.list [Ancestors.count].string);
343 Ancestors.list [Ancestors.count].type = TOKEN_UNDEFINED;
344 Ancestors.list [Ancestors.count].keyword = KEYWORD_NONE;
345 Ancestors.list [Ancestors.count].secondary = NULL;
346 Ancestors.list [Ancestors.count].tag = TAG_UNDEFINED;
347 Ancestors.list [Ancestors.count].string = NULL;
348 Ancestors.list [Ancestors.count].lineNumber = 0L;
351 static const tokenInfo* ancestorScope (void)
353 tokenInfo *result = NULL;
354 unsigned int i;
355 for (i = Ancestors.count ; i > 0 && result == NULL ; --i)
357 tokenInfo *const token = Ancestors.list + i - 1;
358 if (token->type == TOKEN_IDENTIFIER &&
359 token->tag != TAG_UNDEFINED && token->tag != TAG_INTERFACE)
360 result = token;
362 return result;
365 static const tokenInfo* ancestorTop (void)
367 Assert (Ancestors.count > 0);
368 return &Ancestors.list [Ancestors.count - 1];
371 #define ancestorCount() (Ancestors.count)
373 static void ancestorClear (void)
375 while (Ancestors.count > 0)
376 ancestorPop ();
377 if (Ancestors.list != NULL)
378 eFree (Ancestors.list);
379 Ancestors.list = NULL;
380 Ancestors.count = 0;
381 Ancestors.max = 0;
384 static boolean insideInterface (void)
386 boolean result = FALSE;
387 unsigned int i;
388 for (i = 0 ; i < Ancestors.count && !result ; ++i)
390 if (Ancestors.list [i].tag == TAG_INTERFACE)
391 result = TRUE;
393 return result;
396 static void buildFortranKeywordHash (void)
398 const size_t count =
399 sizeof (FortranKeywordTable) / sizeof (FortranKeywordTable [0]);
400 size_t i;
401 for (i = 0 ; i < count ; ++i)
403 const keywordDesc* const p = &FortranKeywordTable [i];
404 addKeyword (p->name, Lang_fortran, (int) p->id);
409 * Tag generation functions
412 static tokenInfo *newToken (void)
414 tokenInfo *const token = xMalloc (1, tokenInfo);
416 token->type = TOKEN_UNDEFINED;
417 token->keyword = KEYWORD_NONE;
418 token->tag = TAG_UNDEFINED;
419 token->string = vStringNew ();
420 token->secondary = NULL;
421 token->lineNumber = getSourceLineNumber ();
422 token->filePosition = getInputFilePosition ();
424 return token;
427 static tokenInfo *newTokenFrom (tokenInfo *const token)
429 tokenInfo *result = newToken ();
430 *result = *token;
431 result->string = vStringNewCopy (token->string);
432 token->secondary = NULL;
433 return result;
436 static void deleteToken (tokenInfo *const token)
438 if (token != NULL)
440 vStringDelete (token->string);
441 deleteToken (token->secondary);
442 token->secondary = NULL;
443 eFree (token);
447 static boolean isFileScope (const tagType type)
449 return (boolean) (type == TAG_LABEL || type == TAG_LOCAL);
452 static boolean includeTag (const tagType type)
454 boolean include;
455 Assert (type != TAG_UNDEFINED);
456 include = FortranKinds [(int) type].enabled;
457 if (include && isFileScope (type))
458 include = Option.include.fileScope;
459 return include;
462 static void makeFortranTag (tokenInfo *const token, tagType tag)
464 token->tag = tag;
465 if (includeTag (token->tag))
467 const char *const name = vStringValue (token->string);
468 tagEntryInfo e;
470 initTagEntry (&e, name);
472 if (token->tag == TAG_COMMON_BLOCK)
473 e.lineNumberEntry = (boolean) (Option.locate != EX_PATTERN);
475 e.lineNumber = token->lineNumber;
476 e.filePosition = token->filePosition;
477 e.isFileScope = isFileScope (token->tag);
478 e.kindName = FortranKinds [token->tag].name;
479 e.kind = FortranKinds [token->tag].letter;
480 e.truncateLine = (boolean) (token->tag != TAG_LABEL);
482 if (ancestorCount () > 0)
484 const tokenInfo* const scope = ancestorScope ();
485 if (scope != NULL)
487 e.extensionFields.scope [0] = FortranKinds [scope->tag].name;
488 e.extensionFields.scope [1] = vStringValue (scope->string);
491 if (! insideInterface () || includeTag (TAG_INTERFACE))
492 makeTagEntry (&e);
497 * Parsing functions
500 static int skipLine (void)
502 int c;
505 c = fileGetc ();
506 while (c != EOF && c != '\n');
508 return c;
511 static void makeLabelTag (vString *const label)
513 tokenInfo *token = newToken ();
514 token->type = TOKEN_LABEL;
515 vStringCopy (token->string, label);
516 makeFortranTag (token, TAG_LABEL);
517 deleteToken (token);
520 static lineType getLineType (void)
522 static vString *label = NULL;
523 int column = 0;
524 lineType type = LTYPE_UNDETERMINED;
526 if (label == NULL)
527 label = vStringNew ();
529 do /* read in first 6 "margin" characters */
531 int c = fileGetc ();
533 /* 3.2.1 Comment_Line. A comment line is any line that contains
534 * a C or an asterisk in column 1, or contains only blank characters
535 * in columns 1 through 72. A comment line that contains a C or
536 * an asterisk in column 1 may contain any character capable of
537 * representation in the processor in columns 2 through 72.
539 /* EXCEPTION! Some compilers permit '!' as a commment character here.
541 * Treat # and $ in column 1 as comment to permit preprocessor directives.
542 * Treat D and d in column 1 as comment for HP debug statements.
544 if (column == 0 && strchr ("*Cc!#$Dd", c) != NULL)
545 type = LTYPE_COMMENT;
546 else if (c == '\t') /* EXCEPTION! Some compilers permit a tab here */
548 column = 8;
549 type = LTYPE_INITIAL;
551 else if (column == 5)
553 /* 3.2.2 Initial_Line. An initial line is any line that is not
554 * a comment line and contains the character blank or the digit 0
555 * in column 6. Columns 1 through 5 may contain a statement label
556 * (3.4), or each of the columns 1 through 5 must contain the
557 * character blank.
559 if (c == ' ' || c == '0')
560 type = LTYPE_INITIAL;
562 /* 3.2.3 Continuation_Line. A continuation line is any line that
563 * contains any character of the FORTRAN character set other than
564 * the character blank or the digit 0 in column 6 and contains
565 * only blank characters in columns 1 through 5.
567 else if (vStringLength (label) == 0)
568 type = LTYPE_CONTINUATION;
569 else
570 type = LTYPE_INVALID;
572 else if (c == ' ')
574 else if (c == EOF)
575 type = LTYPE_EOF;
576 else if (c == '\n')
577 type = LTYPE_SHORT;
578 else if (isdigit (c))
579 vStringPut (label, c);
580 else
581 type = LTYPE_INVALID;
583 ++column;
584 } while (column < 6 && type == LTYPE_UNDETERMINED);
586 Assert (type != LTYPE_UNDETERMINED);
588 if (vStringLength (label) > 0)
590 vStringTerminate (label);
591 makeLabelTag (label);
592 vStringClear (label);
594 return type;
597 static int getFixedFormChar (void)
599 boolean newline = FALSE;
600 lineType type;
601 int c = '\0';
603 if (Column > 0)
605 #ifdef STRICT_FIXED_FORM
606 /* EXCEPTION! Some compilers permit more than 72 characters per line.
608 if (Column > 71)
609 c = skipLine ();
610 else
611 #endif
613 c = fileGetc ();
614 ++Column;
616 if (c == '\n')
618 newline = TRUE; /* need to check for continuation line */
619 Column = 0;
621 else if (c == '!' && ! ParsingString)
623 c = skipLine ();
624 newline = TRUE; /* need to check for continuation line */
625 Column = 0;
627 else if (c == '&') /* check for free source form */
629 const int c2 = fileGetc ();
630 if (c2 == '\n')
631 longjmp (Exception, (int) ExceptionFixedFormat);
632 else
633 fileUngetc (c2);
636 while (Column == 0)
638 type = getLineType ();
639 switch (type)
641 case LTYPE_UNDETERMINED:
642 case LTYPE_INVALID:
643 longjmp (Exception, (int) ExceptionFixedFormat);
644 break;
646 case LTYPE_SHORT: break;
647 case LTYPE_COMMENT: skipLine (); break;
649 case LTYPE_EOF:
650 Column = 6;
651 if (newline)
652 c = '\n';
653 else
654 c = EOF;
655 break;
657 case LTYPE_INITIAL:
658 if (newline)
660 c = '\n';
661 Column = 6;
662 break;
664 /* fall through to next case */
665 case LTYPE_CONTINUATION:
666 Column = 5;
669 c = fileGetc ();
670 ++Column;
671 } while (isBlank (c));
672 if (c == '\n')
673 Column = 0;
674 else if (Column > 6)
676 fileUngetc (c);
677 c = ' ';
679 break;
681 default:
682 Assert ("Unexpected line type" == NULL);
685 return c;
688 static int skipToNextLine (void)
690 int c = skipLine ();
691 if (c != EOF)
692 c = fileGetc ();
693 return c;
696 static int getFreeFormChar (void)
698 static boolean newline = TRUE;
699 boolean advanceLine = FALSE;
700 int c = fileGetc ();
702 /* If the last nonblank, non-comment character of a FORTRAN 90
703 * free-format text line is an ampersand then the next non-comment
704 * line is a continuation line.
706 if (c == '&')
709 c = fileGetc ();
710 while (isspace (c) && c != '\n');
711 if (c == '\n')
713 newline = TRUE;
714 advanceLine = TRUE;
716 else if (c == '!')
717 advanceLine = TRUE;
718 else
720 fileUngetc (c);
721 c = '&';
724 else if (newline && (c == '!' || c == '#'))
725 advanceLine = TRUE;
726 while (advanceLine)
728 while (isspace (c))
729 c = fileGetc ();
730 if (c == '!' || (newline && c == '#'))
732 c = skipToNextLine ();
733 newline = TRUE;
734 continue;
736 if (c == '&')
737 c = fileGetc ();
738 else
739 advanceLine = FALSE;
741 newline = (boolean) (c == '\n');
742 return c;
745 static int getChar (void)
747 int c;
749 if (Ungetc != '\0')
751 c = Ungetc;
752 Ungetc = '\0';
754 else if (FreeSourceForm)
755 c = getFreeFormChar ();
756 else
757 c = getFixedFormChar ();
758 return c;
761 static void ungetChar (const int c)
763 Ungetc = c;
766 /* If a numeric is passed in 'c', this is used as the first digit of the
767 * numeric being parsed.
769 static vString *parseInteger (int c)
771 static vString *string = NULL;
773 if (string == NULL)
774 string = vStringNew ();
775 vStringClear (string);
777 if (c == '-')
779 vStringPut (string, c);
780 c = getChar ();
782 else if (! isdigit (c))
783 c = getChar ();
784 while (c != EOF && isdigit (c))
786 vStringPut (string, c);
787 c = getChar ();
789 vStringTerminate (string);
791 if (c == '_')
794 c = getChar ();
795 while (c != EOF && isalpha (c));
797 ungetChar (c);
799 return string;
802 static vString *parseNumeric (int c)
804 static vString *string = NULL;
806 if (string == NULL)
807 string = vStringNew ();
808 vStringCopy (string, parseInteger (c));
810 c = getChar ();
811 if (c == '.')
813 vStringPut (string, c);
814 vStringCat (string, parseInteger ('\0'));
815 c = getChar ();
817 if (tolower (c) == 'e')
819 vStringPut (string, c);
820 vStringCat (string, parseInteger ('\0'));
822 else
823 ungetChar (c);
825 vStringTerminate (string);
827 return string;
830 static void parseString (vString *const string, const int delimeter)
832 const unsigned long inputLineNumber = getInputLineNumber ();
833 int c;
834 ParsingString = TRUE;
835 c = getChar ();
836 while (c != delimeter && c != '\n' && c != EOF)
838 vStringPut (string, c);
839 c = getChar ();
841 if (c == '\n' || c == EOF)
843 verbose ("%s: unterminated character string at line %lu\n",
844 getInputFileName (), inputLineNumber);
845 if (c == EOF)
846 longjmp (Exception, (int) ExceptionEOF);
847 else if (! FreeSourceForm)
848 longjmp (Exception, (int) ExceptionFixedFormat);
850 vStringTerminate (string);
851 ParsingString = FALSE;
854 /* Read a C identifier beginning with "firstChar" and places it into "name".
856 static void parseIdentifier (vString *const string, const int firstChar)
858 int c = firstChar;
862 vStringPut (string, c);
863 c = getChar ();
864 } while (isident (c));
866 vStringTerminate (string);
867 ungetChar (c); /* unget non-identifier character */
870 /* Analyzes the identifier contained in a statement described by the
871 * statement structure and adjusts the structure according the significance
872 * of the identifier.
874 static keywordId analyzeToken (vString *const name)
876 static vString *keyword = NULL;
877 keywordId id;
879 if (keyword == NULL)
880 keyword = vStringNew ();
881 vStringCopyToLower (keyword, name);
882 id = (keywordId) lookupKeyword (vStringValue (keyword), Lang_fortran);
884 return id;
887 static void checkForLabel (void)
889 tokenInfo* token = NULL;
890 int length;
891 int c;
894 c = getChar ();
895 while (isBlank (c));
897 for (length = 0 ; isdigit (c) && length < 5 ; ++length)
899 if (token == NULL)
901 token = newToken ();
902 token->type = TOKEN_LABEL;
904 vStringPut (token->string, c);
905 c = getChar ();
907 if (length > 0)
909 Assert (token != NULL);
910 vStringTerminate (token->string);
911 makeFortranTag (token, TAG_LABEL);
912 deleteToken (token);
914 ungetChar (c);
917 static void readIdentifier (tokenInfo *const token, const int c)
919 parseIdentifier (token->string, c);
920 token->keyword = analyzeToken (token->string);
921 if (! isKeyword (token, KEYWORD_NONE))
922 token->type = TOKEN_KEYWORD;
923 else
925 token->type = TOKEN_IDENTIFIER;
926 if (strncmp (vStringValue (token->string), "end", 3) == 0)
928 vString *const sub = vStringNewInit (vStringValue (token->string) + 3);
929 const keywordId kw = analyzeToken (sub);
930 vStringDelete (sub);
931 if (kw != KEYWORD_NONE)
933 token->secondary = newToken ();
934 token->secondary->type = TOKEN_KEYWORD;
935 token->secondary->keyword = kw;
936 token->keyword = KEYWORD_end;
942 static void readToken (tokenInfo *const token)
944 int c;
946 deleteToken (token->secondary);
947 token->type = TOKEN_UNDEFINED;
948 token->tag = TAG_UNDEFINED;
949 token->keyword = KEYWORD_NONE;
950 token->secondary = NULL;
951 vStringClear (token->string);
953 getNextChar:
954 c = getChar ();
956 token->lineNumber = getSourceLineNumber ();
957 token->filePosition = getInputFilePosition ();
959 switch (c)
961 case EOF: longjmp (Exception, (int) ExceptionEOF); break;
962 case ' ': goto getNextChar;
963 case '\t': goto getNextChar;
964 case ',': token->type = TOKEN_COMMA; break;
965 case '(': token->type = TOKEN_PAREN_OPEN; break;
966 case ')': token->type = TOKEN_PAREN_CLOSE; break;
967 case '%': token->type = TOKEN_PERCENT; break;
969 case '*':
970 case '/':
971 case '+':
972 case '-':
973 case '=':
974 case '<':
975 case '>':
977 const char *const operatorChars = "*/+=<>";
978 do {
979 vStringPut (token->string, c);
980 c = getChar ();
981 } while (strchr (operatorChars, c) != NULL);
982 ungetChar (c);
983 vStringTerminate (token->string);
984 token->type = TOKEN_OPERATOR;
985 break;
988 case '!':
989 if (FreeSourceForm)
992 c = getChar ();
993 while (c != '\n');
995 else
997 skipLine ();
998 Column = 0;
1000 /* fall through to newline case */
1001 case '\n':
1002 token->type = TOKEN_STATEMENT_END;
1003 if (FreeSourceForm)
1004 checkForLabel ();
1005 break;
1007 case '.':
1008 parseIdentifier (token->string, c);
1009 c = getChar ();
1010 if (c == '.')
1012 vStringPut (token->string, c);
1013 vStringTerminate (token->string);
1014 token->type = TOKEN_OPERATOR;
1016 else
1018 ungetChar (c);
1019 token->type = TOKEN_UNDEFINED;
1021 break;
1023 case '"':
1024 case '\'':
1025 parseString (token->string, c);
1026 token->type = TOKEN_STRING;
1027 break;
1029 case ';':
1030 token->type = TOKEN_STATEMENT_END;
1031 break;
1033 case ':':
1034 c = getChar ();
1035 if (c == ':')
1036 token->type = TOKEN_DOUBLE_COLON;
1037 else
1039 ungetChar (c);
1040 token->type = TOKEN_UNDEFINED;
1042 break;
1044 default:
1045 if (isalpha (c))
1046 readIdentifier (token, c);
1047 else if (isdigit (c))
1049 vStringCat (token->string, parseNumeric (c));
1050 token->type = TOKEN_NUMERIC;
1052 else
1053 token->type = TOKEN_UNDEFINED;
1054 break;
1058 static void readSubToken (tokenInfo *const token)
1060 if (token->secondary == NULL)
1062 token->secondary = newToken ();
1063 readToken (token->secondary);
1065 Assert (token->secondary != NULL);
1069 * Scanning functions
1072 static void skipToToken (tokenInfo *const token, tokenType type)
1074 while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END) &&
1075 !(token->secondary != NULL && isType (token->secondary, TOKEN_STATEMENT_END)))
1076 readToken (token);
1079 static void skipPast (tokenInfo *const token, tokenType type)
1081 skipToToken (token, type);
1082 if (! isType (token, TOKEN_STATEMENT_END))
1083 readToken (token);
1086 static void skipToNextStatement (tokenInfo *const token)
1090 skipToToken (token, TOKEN_STATEMENT_END);
1091 readToken (token);
1092 } while (isType (token, TOKEN_STATEMENT_END));
1095 /* skip over parenthesis enclosed contents starting at next token.
1096 * Token is left at the first token following closing parenthesis. If an
1097 * opening parenthesis is not found, `token' is moved to the end of the
1098 * statement.
1100 static void skipOverParens (tokenInfo *const token)
1102 int level = 0;
1103 do {
1104 if (isType (token, TOKEN_STATEMENT_END))
1105 break;
1106 else if (isType (token, TOKEN_PAREN_OPEN))
1107 ++level;
1108 else if (isType (token, TOKEN_PAREN_CLOSE))
1109 --level;
1110 readToken (token);
1111 } while (level > 0);
1114 static boolean isTypeSpec (tokenInfo *const token)
1116 boolean result;
1117 switch (token->keyword)
1119 case KEYWORD_byte:
1120 case KEYWORD_integer:
1121 case KEYWORD_real:
1122 case KEYWORD_double:
1123 case KEYWORD_complex:
1124 case KEYWORD_character:
1125 case KEYWORD_logical:
1126 case KEYWORD_record:
1127 case KEYWORD_type:
1128 result = TRUE;
1129 break;
1130 default:
1131 result = FALSE;
1132 break;
1134 return result;
1137 static boolean isSubprogramPrefix (tokenInfo *const token)
1139 boolean result;
1140 switch (token->keyword)
1142 case KEYWORD_elemental:
1143 case KEYWORD_pure:
1144 case KEYWORD_recursive:
1145 case KEYWORD_stdcall:
1146 result = TRUE;
1147 break;
1148 default:
1149 result = FALSE;
1150 break;
1152 return result;
1155 /* type-spec
1156 * is INTEGER [kind-selector]
1157 * or REAL [kind-selector] is ( etc. )
1158 * or DOUBLE PRECISION
1159 * or COMPLEX [kind-selector]
1160 * or CHARACTER [kind-selector]
1161 * or LOGICAL [kind-selector]
1162 * or TYPE ( type-name )
1164 * Note that INTEGER and REAL may be followed by "*N" where "N" is an integer
1166 static void parseTypeSpec (tokenInfo *const token)
1168 /* parse type-spec, leaving `token' at first token following type-spec */
1169 Assert (isTypeSpec (token));
1170 switch (token->keyword)
1172 case KEYWORD_character:
1173 /* skip char-selector */
1174 readToken (token);
1175 if (isType (token, TOKEN_OPERATOR) &&
1176 strcmp (vStringValue (token->string), "*") == 0)
1177 readToken (token);
1178 if (isType (token, TOKEN_PAREN_OPEN))
1179 skipOverParens (token);
1180 else if (isType (token, TOKEN_NUMERIC))
1181 readToken (token);
1182 break;
1185 case KEYWORD_byte:
1186 case KEYWORD_complex:
1187 case KEYWORD_integer:
1188 case KEYWORD_logical:
1189 case KEYWORD_real:
1190 readToken (token);
1191 if (isType (token, TOKEN_PAREN_OPEN))
1192 skipOverParens (token); /* skip kind-selector */
1193 if (isType (token, TOKEN_OPERATOR) &&
1194 strcmp (vStringValue (token->string), "*") == 0)
1196 readToken (token);
1197 readToken (token);
1199 break;
1201 case KEYWORD_double:
1202 readToken (token);
1203 if (isKeyword (token, KEYWORD_complex) ||
1204 isKeyword (token, KEYWORD_precision))
1205 readToken (token);
1206 else
1207 skipToToken (token, TOKEN_STATEMENT_END);
1208 break;
1210 case KEYWORD_record:
1211 readToken (token);
1212 if (isType (token, TOKEN_OPERATOR) &&
1213 strcmp (vStringValue (token->string), "/") == 0)
1215 readToken (token); /* skip to structure name */
1216 readToken (token); /* skip to '/' */
1217 readToken (token); /* skip to variable name */
1219 break;
1221 case KEYWORD_type:
1222 readToken (token);
1223 if (isType (token, TOKEN_PAREN_OPEN))
1224 skipOverParens (token); /* skip type-name */
1225 else
1226 parseDerivedTypeDef (token);
1227 break;
1229 default:
1230 skipToToken (token, TOKEN_STATEMENT_END);
1231 break;
1235 static boolean skipStatementIfKeyword (tokenInfo *const token, keywordId keyword)
1237 boolean result = FALSE;
1238 if (isKeyword (token, keyword))
1240 result = TRUE;
1241 skipToNextStatement (token);
1243 return result;
1246 /* parse a list of qualifying specifiers, leaving `token' at first token
1247 * following list. Examples of such specifiers are:
1248 * [[, attr-spec] ::]
1249 * [[, component-attr-spec-list] ::]
1251 * attr-spec
1252 * is PARAMETER
1253 * or access-spec (is PUBLIC or PRIVATE)
1254 * or ALLOCATABLE
1255 * or DIMENSION ( array-spec )
1256 * or EXTERNAL
1257 * or INTENT ( intent-spec )
1258 * or INTRINSIC
1259 * or OPTIONAL
1260 * or POINTER
1261 * or SAVE
1262 * or TARGET
1264 * component-attr-spec
1265 * is POINTER
1266 * or DIMENSION ( component-array-spec )
1268 static void parseQualifierSpecList (tokenInfo *const token)
1272 readToken (token); /* should be an attr-spec */
1273 switch (token->keyword)
1275 case KEYWORD_parameter:
1276 case KEYWORD_allocatable:
1277 case KEYWORD_external:
1278 case KEYWORD_intrinsic:
1279 case KEYWORD_optional:
1280 case KEYWORD_private:
1281 case KEYWORD_pointer:
1282 case KEYWORD_public:
1283 case KEYWORD_save:
1284 case KEYWORD_target:
1285 readToken (token);
1286 break;
1288 case KEYWORD_dimension:
1289 case KEYWORD_intent:
1290 readToken (token);
1291 skipOverParens (token);
1292 break;
1294 default: skipToToken (token, TOKEN_STATEMENT_END); break;
1296 } while (isType (token, TOKEN_COMMA));
1297 if (! isType (token, TOKEN_DOUBLE_COLON))
1298 skipToToken (token, TOKEN_STATEMENT_END);
1301 static tagType variableTagType (void)
1303 tagType result = TAG_VARIABLE;
1304 if (ancestorCount () > 0)
1306 const tokenInfo* const parent = ancestorTop ();
1307 switch (parent->tag)
1309 case TAG_MODULE: result = TAG_VARIABLE; break;
1310 case TAG_DERIVED_TYPE: result = TAG_COMPONENT; break;
1311 case TAG_FUNCTION: result = TAG_LOCAL; break;
1312 case TAG_SUBROUTINE: result = TAG_LOCAL; break;
1313 default: result = TAG_VARIABLE; break;
1316 return result;
1319 static void parseEntityDecl (tokenInfo *const token)
1321 Assert (isType (token, TOKEN_IDENTIFIER));
1322 makeFortranTag (token, variableTagType ());
1323 readToken (token);
1324 if (isType (token, TOKEN_PAREN_OPEN))
1325 skipOverParens (token);
1326 if (isType (token, TOKEN_OPERATOR) &&
1327 strcmp (vStringValue (token->string), "*") == 0)
1329 readToken (token); /* read char-length */
1330 if (isType (token, TOKEN_PAREN_OPEN))
1331 skipOverParens (token);
1332 else
1333 readToken (token);
1335 if (isType (token, TOKEN_OPERATOR))
1337 if (strcmp (vStringValue (token->string), "/") == 0)
1338 { /* skip over initializations of structure field */
1339 readToken (token);
1340 skipPast (token, TOKEN_OPERATOR);
1342 else if (strcmp (vStringValue (token->string), "=") == 0)
1344 while (! isType (token, TOKEN_COMMA) &&
1345 ! isType (token, TOKEN_STATEMENT_END))
1347 readToken (token);
1348 if (isType (token, TOKEN_PAREN_OPEN))
1349 skipOverParens (token);
1353 /* token left at either comma or statement end */
1356 static void parseEntityDeclList (tokenInfo *const token)
1358 if (isType (token, TOKEN_PERCENT))
1359 skipToNextStatement (token);
1360 else while (isType (token, TOKEN_IDENTIFIER) ||
1361 (isType (token, TOKEN_KEYWORD) &&
1362 !isKeyword (token, KEYWORD_function) &&
1363 !isKeyword (token, KEYWORD_subroutine)))
1365 /* compilers accept keywoeds as identifiers */
1366 if (isType (token, TOKEN_KEYWORD))
1367 token->type = TOKEN_IDENTIFIER;
1368 parseEntityDecl (token);
1369 if (isType (token, TOKEN_COMMA))
1370 readToken (token);
1371 else if (isType (token, TOKEN_STATEMENT_END))
1373 skipToNextStatement (token);
1374 break;
1379 /* type-declaration-stmt is
1380 * type-spec [[, attr-spec] ... ::] entity-decl-list
1382 static void parseTypeDeclarationStmt (tokenInfo *const token)
1384 Assert (isTypeSpec (token));
1385 parseTypeSpec (token);
1386 if (!isType (token, TOKEN_STATEMENT_END)) /* if not end of derived type... */
1388 if (isType (token, TOKEN_COMMA))
1389 parseQualifierSpecList (token);
1390 if (isType (token, TOKEN_DOUBLE_COLON))
1391 readToken (token);
1392 parseEntityDeclList (token);
1394 if (isType (token, TOKEN_STATEMENT_END))
1395 skipToNextStatement (token);
1398 /* namelist-stmt is
1399 * NAMELIST /namelist-group-name/ namelist-group-object-list
1400 * [[,]/[namelist-group-name]/ namelist-block-object-list] ...
1402 * namelist-group-object is
1403 * variable-name
1405 * common-stmt is
1406 * COMMON [/[common-block-name]/] common-block-object-list
1407 * [[,]/[common-block-name]/ common-block-object-list] ...
1409 * common-block-object is
1410 * variable-name [ ( explicit-shape-spec-list ) ]
1412 static void parseCommonNamelistStmt (tokenInfo *const token, tagType type)
1414 Assert (isKeyword (token, KEYWORD_common) ||
1415 isKeyword (token, KEYWORD_namelist));
1416 readToken (token);
1419 if (isType (token, TOKEN_OPERATOR) &&
1420 strcmp (vStringValue (token->string), "/") == 0)
1422 readToken (token);
1423 if (isType (token, TOKEN_IDENTIFIER))
1425 makeFortranTag (token, type);
1426 readToken (token);
1428 skipPast (token, TOKEN_OPERATOR);
1430 if (isType (token, TOKEN_IDENTIFIER))
1431 makeFortranTag (token, TAG_LOCAL);
1432 readToken (token);
1433 if (isType (token, TOKEN_PAREN_OPEN))
1434 skipOverParens (token); /* skip explicit-shape-spec-list */
1435 if (isType (token, TOKEN_COMMA))
1436 readToken (token);
1437 } while (! isType (token, TOKEN_STATEMENT_END));
1438 skipToNextStatement (token);
1441 static void parseFieldDefinition (tokenInfo *const token)
1443 if (isTypeSpec (token))
1444 parseTypeDeclarationStmt (token);
1445 else if (isKeyword (token, KEYWORD_structure))
1446 parseStructureStmt (token);
1447 else if (isKeyword (token, KEYWORD_union))
1448 parseUnionStmt (token);
1449 else
1450 skipToNextStatement (token);
1453 static void parseMap (tokenInfo *const token)
1455 Assert (isKeyword (token, KEYWORD_map));
1456 skipToNextStatement (token);
1457 while (! isKeyword (token, KEYWORD_end))
1458 parseFieldDefinition (token);
1459 readSubToken (token);
1460 Assert (isSecondaryKeyword (token, KEYWORD_map));
1461 skipToNextStatement (token);
1464 /* UNION
1465 * MAP
1466 * [field-definition] [field-definition] ...
1467 * END MAP
1468 * MAP
1469 * [field-definition] [field-definition] ...
1470 * END MAP
1471 * [MAP
1472 * [field-definition]
1473 * [field-definition] ...
1474 * END MAP] ...
1475 * END UNION
1478 * Typed data declarations (variables or arrays) in structure declarations
1479 * have the form of normal Fortran typed data declarations. Data items with
1480 * different types can be freely intermixed within a structure declaration.
1482 * Unnamed fields can be declared in a structure by specifying the pseudo
1483 * name %FILL in place of an actual field name. You can use this mechanism to
1484 * generate empty space in a record for purposes such as alignment.
1486 * All mapped field declarations that are made within a UNION declaration
1487 * share a common location within the containing structure. When initializing
1488 * the fields within a UNION, the final initialization value assigned
1489 * overlays any value previously assigned to a field definition that shares
1490 * that field.
1492 static void parseUnionStmt (tokenInfo *const token)
1494 Assert (isKeyword (token, KEYWORD_union));
1495 skipToNextStatement (token);
1496 while (isKeyword (token, KEYWORD_map))
1497 parseMap (token);
1498 Assert (isKeyword (token, KEYWORD_end));
1499 readSubToken (token);
1500 Assert (isSecondaryKeyword (token, KEYWORD_union));
1501 skipToNextStatement (token);
1504 /* STRUCTURE [/structure-name/] [field-names]
1505 * [field-definition]
1506 * [field-definition] ...
1507 * END STRUCTURE
1509 * structure-name
1510 * identifies the structure in a subsequent RECORD statement.
1511 * Substructures can be established within a structure by means of either
1512 * a nested STRUCTURE declaration or a RECORD statement.
1514 * field-names
1515 * (for substructure declarations only) one or more names having the
1516 * structure of the substructure being defined.
1518 * field-definition
1519 * can be one or more of the following:
1521 * Typed data declarations, which can optionally include one or more
1522 * data initialization values.
1524 * Substructure declarations (defined by either RECORD statements or
1525 * subsequent STRUCTURE statements).
1527 * UNION declarations, which are mapped fields defined by a block of
1528 * statements. The syntax of a UNION declaration is described below.
1530 * PARAMETER statements, which do not affect the form of the
1531 * structure.
1533 static void parseStructureStmt (tokenInfo *const token)
1535 tokenInfo *name;
1536 Assert (isKeyword (token, KEYWORD_structure));
1537 readToken (token);
1538 if (isType (token, TOKEN_OPERATOR) &&
1539 strcmp (vStringValue (token->string), "/") == 0)
1540 { /* read structure name */
1541 readToken (token);
1542 if (isType (token, TOKEN_IDENTIFIER))
1543 makeFortranTag (token, TAG_DERIVED_TYPE);
1544 name = newTokenFrom (token);
1545 skipPast (token, TOKEN_OPERATOR);
1547 else
1548 { /* fake out anonymous structure */
1549 name = newToken ();
1550 name->type = TOKEN_IDENTIFIER;
1551 name->tag = TAG_DERIVED_TYPE;
1552 vStringCopyS (name->string, "anonymous");
1554 while (isType (token, TOKEN_IDENTIFIER))
1555 { /* read field names */
1556 makeFortranTag (token, TAG_COMPONENT);
1557 readToken (token);
1558 if (isType (token, TOKEN_COMMA))
1559 readToken (token);
1561 skipToNextStatement (token);
1562 ancestorPush (name);
1563 while (! isKeyword (token, KEYWORD_end))
1564 parseFieldDefinition (token);
1565 readSubToken (token);
1566 Assert (isSecondaryKeyword (token, KEYWORD_structure));
1567 skipToNextStatement (token);
1568 ancestorPop ();
1569 deleteToken (name);
1572 /* specification-stmt
1573 * is access-stmt (is access-spec [[::] access-id-list)
1574 * or allocatable-stmt (is ALLOCATABLE [::] array-name etc.)
1575 * or common-stmt (is COMMON [ / [common-block-name] /] etc.)
1576 * or data-stmt (is DATA data-stmt-list [[,] data-stmt-set] ...)
1577 * or dimension-stmt (is DIMENSION [::] array-name etc.)
1578 * or equivalence-stmt (is EQUIVALENCE equivalence-set-list)
1579 * or external-stmt (is EXTERNAL etc.)
1580 * or intent-stmt (is INTENT ( intent-spec ) [::] etc.)
1581 * or instrinsic-stmt (is INTRINSIC etc.)
1582 * or namelist-stmt (is NAMELIST / namelist-group-name / etc.)
1583 * or optional-stmt (is OPTIONAL [::] etc.)
1584 * or pointer-stmt (is POINTER [::] object-name etc.)
1585 * or save-stmt (is SAVE etc.)
1586 * or target-stmt (is TARGET [::] object-name etc.)
1588 * access-spec is PUBLIC or PRIVATE
1590 static boolean parseSpecificationStmt (tokenInfo *const token)
1592 boolean result = TRUE;
1593 switch (token->keyword)
1595 case KEYWORD_common:
1596 parseCommonNamelistStmt (token, TAG_COMMON_BLOCK);
1597 break;
1599 case KEYWORD_namelist:
1600 parseCommonNamelistStmt (token, TAG_NAMELIST);
1601 break;
1603 case KEYWORD_structure:
1604 parseStructureStmt (token);
1605 break;
1607 case KEYWORD_allocatable:
1608 case KEYWORD_data:
1609 case KEYWORD_dimension:
1610 case KEYWORD_equivalence:
1611 case KEYWORD_external:
1612 case KEYWORD_intent:
1613 case KEYWORD_intrinsic:
1614 case KEYWORD_optional:
1615 case KEYWORD_pointer:
1616 case KEYWORD_private:
1617 case KEYWORD_public:
1618 case KEYWORD_save:
1619 case KEYWORD_target:
1620 skipToNextStatement (token);
1621 break;
1623 default:
1624 result = FALSE;
1625 break;
1627 return result;
1630 /* component-def-stmt is
1631 * type-spec [[, component-attr-spec-list] ::] component-decl-list
1633 * component-decl is
1634 * component-name [ ( component-array-spec ) ] [ * char-length ]
1636 static void parseComponentDefStmt (tokenInfo *const token)
1638 Assert (isTypeSpec (token));
1639 parseTypeSpec (token);
1640 if (isType (token, TOKEN_COMMA))
1641 parseQualifierSpecList (token);
1642 if (isType (token, TOKEN_DOUBLE_COLON))
1643 readToken (token);
1644 parseEntityDeclList (token);
1647 /* derived-type-def is
1648 * derived-type-stmt is (TYPE [[, access-spec] ::] type-name
1649 * [private-sequence-stmt] ... (is PRIVATE or SEQUENCE)
1650 * component-def-stmt
1651 * [component-def-stmt] ...
1652 * end-type-stmt
1654 static void parseDerivedTypeDef (tokenInfo *const token)
1656 if (isType (token, TOKEN_COMMA))
1657 parseQualifierSpecList (token);
1658 if (isType (token, TOKEN_DOUBLE_COLON))
1659 readToken (token);
1660 if (isType (token, TOKEN_IDENTIFIER))
1661 makeFortranTag (token, TAG_DERIVED_TYPE);
1662 ancestorPush (token);
1663 skipToNextStatement (token);
1664 if (isKeyword (token, KEYWORD_private) ||
1665 isKeyword (token, KEYWORD_sequence))
1667 skipToNextStatement (token);
1669 while (! isKeyword (token, KEYWORD_end))
1671 if (isTypeSpec (token))
1672 parseComponentDefStmt (token);
1673 else
1674 skipToNextStatement (token);
1676 readSubToken (token);
1677 Assert (isSecondaryKeyword (token, KEYWORD_type));
1678 skipToToken (token, TOKEN_STATEMENT_END);
1679 ancestorPop ();
1682 /* interface-block
1683 * interface-stmt (is INTERFACE [generic-spec])
1684 * [interface-body]
1685 * [module-procedure-stmt] ...
1686 * end-interface-stmt (is END INTERFACE)
1688 * generic-spec
1689 * is generic-name
1690 * or OPERATOR ( defined-operator )
1691 * or ASSIGNMENT ( = )
1693 * interface-body
1694 * is function-stmt
1695 * [specification-part]
1696 * end-function-stmt
1697 * or subroutine-stmt
1698 * [specification-part]
1699 * end-subroutine-stmt
1701 * module-procedure-stmt is
1702 * MODULE PROCEDURE procedure-name-list
1704 static void parseInterfaceBlock (tokenInfo *const token)
1706 tokenInfo *name = NULL;
1707 Assert (isKeyword (token, KEYWORD_interface));
1708 readToken (token);
1709 if (isType (token, TOKEN_IDENTIFIER))
1711 makeFortranTag (token, TAG_INTERFACE);
1712 name = newTokenFrom (token);
1714 else if (isKeyword (token, KEYWORD_assignment) ||
1715 isKeyword (token, KEYWORD_operator))
1717 readToken (token);
1718 if (isType (token, TOKEN_PAREN_OPEN))
1719 readToken (token);
1720 if (isType (token, TOKEN_OPERATOR))
1722 makeFortranTag (token, TAG_INTERFACE);
1723 name = newTokenFrom (token);
1726 if (name == NULL)
1728 name = newToken ();
1729 name->type = TOKEN_IDENTIFIER;
1730 name->tag = TAG_INTERFACE;
1732 ancestorPush (name);
1733 while (! isKeyword (token, KEYWORD_end))
1735 switch (token->keyword)
1737 case KEYWORD_function: parseFunctionSubprogram (token); break;
1738 case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
1740 default:
1741 if (isSubprogramPrefix (token))
1742 readToken (token);
1743 else if (isTypeSpec (token))
1744 parseTypeSpec (token);
1745 else
1746 skipToNextStatement (token);
1747 break;
1750 readSubToken (token);
1751 Assert (isSecondaryKeyword (token, KEYWORD_interface));
1752 skipToNextStatement (token);
1753 ancestorPop ();
1754 deleteToken (name);
1757 /* entry-stmt is
1758 * ENTRY entry-name [ ( dummy-arg-list ) ]
1760 static void parseEntryStmt (tokenInfo *const token)
1762 Assert (isKeyword (token, KEYWORD_entry));
1763 readToken (token);
1764 if (isType (token, TOKEN_IDENTIFIER))
1765 makeFortranTag (token, TAG_ENTRY_POINT);
1766 skipToNextStatement (token);
1769 /* stmt-function-stmt is
1770 * function-name ([dummy-arg-name-list]) = scalar-expr
1772 static boolean parseStmtFunctionStmt (tokenInfo *const token)
1774 boolean result = FALSE;
1775 Assert (isType (token, TOKEN_IDENTIFIER));
1776 #if 0 /* cannot reliably parse this yet */
1777 makeFortranTag (token, TAG_FUNCTION);
1778 #endif
1779 readToken (token);
1780 if (isType (token, TOKEN_PAREN_OPEN))
1782 skipOverParens (token);
1783 result = (boolean) (isType (token, TOKEN_OPERATOR) &&
1784 strcmp (vStringValue (token->string), "=") == 0);
1786 skipToNextStatement (token);
1787 return result;
1790 static boolean isIgnoredDeclaration (tokenInfo *const token)
1792 boolean result;
1793 switch (token->keyword)
1795 case KEYWORD_cexternal:
1796 case KEYWORD_cglobal:
1797 case KEYWORD_dllexport:
1798 case KEYWORD_dllimport:
1799 case KEYWORD_external:
1800 case KEYWORD_format:
1801 case KEYWORD_include:
1802 case KEYWORD_inline:
1803 case KEYWORD_parameter:
1804 case KEYWORD_pascal:
1805 case KEYWORD_pexternal:
1806 case KEYWORD_pglobal:
1807 case KEYWORD_static:
1808 case KEYWORD_value:
1809 case KEYWORD_virtual:
1810 case KEYWORD_volatile:
1811 result = TRUE;
1812 break;
1814 default:
1815 result = FALSE;
1816 break;
1818 return result;
1821 /* declaration-construct
1822 * [derived-type-def]
1823 * [interface-block]
1824 * [type-declaration-stmt]
1825 * [specification-stmt]
1826 * [parameter-stmt] (is PARAMETER ( named-constant-def-list )
1827 * [format-stmt] (is FORMAT format-specification)
1828 * [entry-stmt]
1829 * [stmt-function-stmt]
1831 static boolean parseDeclarationConstruct (tokenInfo *const token)
1833 boolean result = TRUE;
1834 switch (token->keyword)
1836 case KEYWORD_entry: parseEntryStmt (token); break;
1837 case KEYWORD_interface: parseInterfaceBlock (token); break;
1838 case KEYWORD_stdcall: readToken (token); break;
1839 /* derived type handled by parseTypeDeclarationStmt(); */
1841 case KEYWORD_automatic:
1842 readToken (token);
1843 if (isTypeSpec (token))
1844 parseTypeDeclarationStmt (token);
1845 else
1846 skipToNextStatement (token);
1847 result = TRUE;
1848 break;
1850 default:
1851 if (isIgnoredDeclaration (token))
1852 skipToNextStatement (token);
1853 else if (isTypeSpec (token))
1855 parseTypeDeclarationStmt (token);
1856 result = TRUE;
1858 else if (isType (token, TOKEN_IDENTIFIER))
1859 result = parseStmtFunctionStmt (token);
1860 else
1861 result = parseSpecificationStmt (token);
1862 break;
1864 return result;
1867 /* implicit-part-stmt
1868 * is [implicit-stmt] (is IMPLICIT etc.)
1869 * or [parameter-stmt] (is PARAMETER etc.)
1870 * or [format-stmt] (is FORMAT etc.)
1871 * or [entry-stmt] (is ENTRY entry-name etc.)
1873 static boolean parseImplicitPartStmt (tokenInfo *const token)
1875 boolean result = TRUE;
1876 switch (token->keyword)
1878 case KEYWORD_entry: parseEntryStmt (token); break;
1880 case KEYWORD_implicit:
1881 case KEYWORD_include:
1882 case KEYWORD_parameter:
1883 case KEYWORD_format:
1884 skipToNextStatement (token);
1885 break;
1887 default: result = FALSE; break;
1889 return result;
1892 /* specification-part is
1893 * [use-stmt] ... (is USE module-name etc.)
1894 * [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt])
1895 * [declaration-construct] ...
1897 static boolean parseSpecificationPart (tokenInfo *const token)
1899 boolean result = FALSE;
1900 while (skipStatementIfKeyword (token, KEYWORD_use))
1901 result = TRUE;
1902 while (parseImplicitPartStmt (token))
1903 result = TRUE;
1904 while (parseDeclarationConstruct (token))
1905 result = TRUE;
1906 return result;
1909 /* block-data is
1910 * block-data-stmt (is BLOCK DATA [block-data-name]
1911 * [specification-part]
1912 * end-block-data-stmt (is END [BLOCK DATA [block-data-name]])
1914 static void parseBlockData (tokenInfo *const token)
1916 Assert (isKeyword (token, KEYWORD_block));
1917 readToken (token);
1918 if (isKeyword (token, KEYWORD_data))
1920 readToken (token);
1921 if (isType (token, TOKEN_IDENTIFIER))
1922 makeFortranTag (token, TAG_BLOCK_DATA);
1924 ancestorPush (token);
1925 skipToNextStatement (token);
1926 parseSpecificationPart (token);
1927 while (! isKeyword (token, KEYWORD_end))
1928 skipToNextStatement (token);
1929 readSubToken (token);
1930 Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
1931 isSecondaryKeyword (token, KEYWORD_block));
1932 skipToNextStatement (token);
1933 ancestorPop ();
1936 /* internal-subprogram-part is
1937 * contains-stmt (is CONTAINS)
1938 * internal-subprogram
1939 * [internal-subprogram] ...
1941 * internal-subprogram
1942 * is function-subprogram
1943 * or subroutine-subprogram
1945 static void parseInternalSubprogramPart (tokenInfo *const token)
1947 boolean done = FALSE;
1948 if (isKeyword (token, KEYWORD_contains))
1949 skipToNextStatement (token);
1952 switch (token->keyword)
1954 case KEYWORD_function: parseFunctionSubprogram (token); break;
1955 case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
1956 case KEYWORD_end: done = TRUE; break;
1958 default:
1959 if (isSubprogramPrefix (token))
1960 readToken (token);
1961 else if (isTypeSpec (token))
1962 parseTypeSpec (token);
1963 else
1964 readToken (token);
1965 break;
1967 } while (! done);
1970 /* module is
1971 * mudule-stmt (is MODULE module-name)
1972 * [specification-part]
1973 * [module-subprogram-part]
1974 * end-module-stmt (is END [MODULE [module-name]])
1976 * module-subprogram-part
1977 * contains-stmt (is CONTAINS)
1978 * module-subprogram
1979 * [module-subprogram] ...
1981 * module-subprogram
1982 * is function-subprogram
1983 * or subroutine-subprogram
1985 static void parseModule (tokenInfo *const token)
1987 Assert (isKeyword (token, KEYWORD_module));
1988 readToken (token);
1989 if (isType (token, TOKEN_IDENTIFIER))
1990 makeFortranTag (token, TAG_MODULE);
1991 ancestorPush (token);
1992 skipToNextStatement (token);
1993 parseSpecificationPart (token);
1994 if (isKeyword (token, KEYWORD_contains))
1995 parseInternalSubprogramPart (token);
1996 while (! isKeyword (token, KEYWORD_end))
1997 skipToNextStatement (token);
1998 readSubToken (token);
1999 Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
2000 isSecondaryKeyword (token, KEYWORD_module));
2001 skipToNextStatement (token);
2002 ancestorPop ();
2005 /* execution-part
2006 * executable-construct
2008 * executable-contstruct is
2009 * execution-part-construct [execution-part-construct]
2011 * execution-part-construct
2012 * is executable-construct
2013 * or format-stmt
2014 * or data-stmt
2015 * or entry-stmt
2017 static boolean parseExecutionPart (tokenInfo *const token)
2019 boolean result = FALSE;
2020 boolean done = FALSE;
2021 while (! done)
2023 switch (token->keyword)
2025 default:
2026 if (isSubprogramPrefix (token))
2027 readToken (token);
2028 else
2029 skipToNextStatement (token);
2030 result = TRUE;
2031 break;
2033 case KEYWORD_entry:
2034 parseEntryStmt (token);
2035 result = TRUE;
2036 break;
2038 case KEYWORD_contains:
2039 case KEYWORD_function:
2040 case KEYWORD_subroutine:
2041 done = TRUE;
2042 break;
2044 case KEYWORD_end:
2045 readSubToken (token);
2046 if (isSecondaryKeyword (token, KEYWORD_do) ||
2047 isSecondaryKeyword (token, KEYWORD_if) ||
2048 isSecondaryKeyword (token, KEYWORD_select) ||
2049 isSecondaryKeyword (token, KEYWORD_where))
2051 skipToNextStatement (token);
2052 result = TRUE;
2054 else
2055 done = TRUE;
2056 break;
2059 return result;
2062 static void parseSubprogram (tokenInfo *const token, const tagType tag)
2064 Assert (isKeyword (token, KEYWORD_program) ||
2065 isKeyword (token, KEYWORD_function) ||
2066 isKeyword (token, KEYWORD_subroutine));
2067 readToken (token);
2068 if (isType (token, TOKEN_IDENTIFIER))
2069 makeFortranTag (token, tag);
2070 ancestorPush (token);
2071 skipToNextStatement (token);
2072 parseSpecificationPart (token);
2073 parseExecutionPart (token);
2074 if (isKeyword (token, KEYWORD_contains))
2075 parseInternalSubprogramPart (token);
2076 Assert (isKeyword (token, KEYWORD_end));
2077 readSubToken (token);
2078 Assert (isSecondaryKeyword (token, KEYWORD_NONE) ||
2079 isSecondaryKeyword (token, KEYWORD_program) ||
2080 isSecondaryKeyword (token, KEYWORD_function) ||
2081 isSecondaryKeyword (token, KEYWORD_subroutine));
2082 skipToNextStatement (token);
2083 ancestorPop ();
2087 /* function-subprogram is
2088 * function-stmt (is [prefix] FUNCTION function-name etc.)
2089 * [specification-part]
2090 * [execution-part]
2091 * [internal-subprogram-part]
2092 * end-function-stmt (is END [FUNCTION [function-name]])
2094 * prefix
2095 * is type-spec [RECURSIVE]
2096 * or [RECURSIVE] type-spec
2098 static void parseFunctionSubprogram (tokenInfo *const token)
2100 parseSubprogram (token, TAG_FUNCTION);
2103 /* subroutine-subprogram is
2104 * subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.)
2105 * [specification-part]
2106 * [execution-part]
2107 * [internal-subprogram-part]
2108 * end-subroutine-stmt (is END [SUBROUTINE [function-name]])
2110 static void parseSubroutineSubprogram (tokenInfo *const token)
2112 parseSubprogram (token, TAG_SUBROUTINE);
2115 /* main-program is
2116 * [program-stmt] (is PROGRAM program-name)
2117 * [specification-part]
2118 * [execution-part]
2119 * [internal-subprogram-part ]
2120 * end-program-stmt
2122 static void parseMainProgram (tokenInfo *const token)
2124 parseSubprogram (token, TAG_PROGRAM);
2127 /* program-unit
2128 * is main-program
2129 * or external-subprogram (is function-subprogram or subroutine-subprogram)
2130 * or module
2131 * or block-data
2133 static void parseProgramUnit (tokenInfo *const token)
2135 readToken (token);
2138 if (isType (token, TOKEN_STATEMENT_END))
2139 readToken (token);
2140 else switch (token->keyword)
2142 case KEYWORD_block: parseBlockData (token); break;
2143 case KEYWORD_end: skipToNextStatement (token); break;
2144 case KEYWORD_function: parseFunctionSubprogram (token); break;
2145 case KEYWORD_module: parseModule (token); break;
2146 case KEYWORD_program: parseMainProgram (token); break;
2147 case KEYWORD_subroutine: parseSubroutineSubprogram (token); break;
2149 default:
2150 if (isSubprogramPrefix (token))
2151 readToken (token);
2152 else
2154 boolean one = parseSpecificationPart (token);
2155 boolean two = parseExecutionPart (token);
2156 if (! (one || two))
2157 readToken (token);
2159 break;
2161 } while (TRUE);
2164 static boolean findFortranTags (const unsigned int passCount)
2166 tokenInfo *token;
2167 exception_t exception;
2168 boolean retry;
2170 Assert (passCount < 3);
2171 Parent = newToken ();
2172 token = newToken ();
2173 FreeSourceForm = (boolean) (passCount > 1);
2174 Column = 0;
2175 exception = (exception_t) setjmp (Exception);
2176 if (exception == ExceptionEOF)
2177 retry = FALSE;
2178 else if (exception == ExceptionFixedFormat && ! FreeSourceForm)
2180 verbose ("%s: not fixed source form; retry as free source form\n",
2181 getInputFileName ());
2182 retry = TRUE;
2184 else
2186 parseProgramUnit (token);
2187 retry = FALSE;
2189 ancestorClear ();
2190 deleteToken (token);
2191 deleteToken (Parent);
2193 return retry;
2196 static void initialize (const langType language)
2198 Lang_fortran = language;
2199 buildFortranKeywordHash ();
2202 extern parserDefinition* FortranParser (void)
2204 static const char *const extensions [] = {
2205 "f", "for", "ftn", "f77", "f90", "f95",
2206 #ifndef CASE_INSENSITIVE_FILENAMES
2207 "F", "FOR", "FTN", "F77", "F90", "F95",
2208 #endif
2209 NULL
2211 parserDefinition* def = parserNew ("Fortran");
2212 def->kinds = FortranKinds;
2213 def->kindCount = KIND_COUNT (FortranKinds);
2214 def->extensions = extensions;
2215 def->parser2 = findFortranTags;
2216 def->initialize = initialize;
2217 return def;
2220 /* vi:set tabstop=4 shiftwidth=4: */