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