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