ctags/parsers/fortran.c

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