tagmanager/fortran.c

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