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