fortran.c

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