contrib/gcc-3.4/gcc/f/global.c

   1 /* global.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23
  24    Description:
  25       Manages information kept across individual program units within a single
  26       source file.  This includes reporting errors when a name is defined
  27       multiple times (for example, two program units named FOO) and when a
  28       COMMON block is given initial data in more than one program unit.
  29
  30    Modifications:
  31 */
  32
  33 /* Include files. */
  34
  35 #include "proj.h"
  36 #include "global.h"
  37 #include "info.h"
  38 #include "lex.h"
  39 #include "malloc.h"
  40 #include "name.h"
  41 #include "symbol.h"
  42 #include "top.h"
  43
  44 /* Externals defined here. */
  45
  46
  47 /* Simple definitions and enumerations. */
  48
  49
  50 /* Internal typedefs. */
  51
  52
  53 /* Private include files. */
  54
  55
  56 /* Internal structure definitions. */
  57
  58
  59 /* Static objects accessed by functions in this module. */
  60
  61 #if FFEGLOBAL_ENABLED
  62 static ffenameSpace ffeglobal_filewide_ = NULL;
  63 static const char *const ffeglobal_type_string_[] =
  64 {
  65   [FFEGLOBAL_typeNONE] = "??",
  66   [FFEGLOBAL_typeMAIN] = "main program",
  67   [FFEGLOBAL_typeEXT] = "external",
  68   [FFEGLOBAL_typeSUBR] = "subroutine",
  69   [FFEGLOBAL_typeFUNC] = "function",
  70   [FFEGLOBAL_typeBDATA] = "block data",
  71   [FFEGLOBAL_typeCOMMON] = "common block",
  72   [FFEGLOBAL_typeANY] = "?any?"
  73 };
  74 #endif
  75
  76 /* Static functions (internal). */
  77
  78
  79 /* Internal macros. */
  80 \f
  81
  82 /* Call given fn with all globals
  83
  84    ffeglobal (*fn)(ffeglobal g);
  85    ffeglobal_drive(fn);  */
  86
  87 #if FFEGLOBAL_ENABLED
  88 void
  89 ffeglobal_drive (ffeglobal (*fn) (ffeglobal))
  90 {
  91   if (ffeglobal_filewide_ != NULL)
  92     ffename_space_drive_global (ffeglobal_filewide_, fn);
  93 }
  94
  95 #endif
  96 /* ffeglobal_new_ -- Make new global
  97
  98    ffename n;
  99    ffeglobal g;
 100    g = ffeglobal_new_(n);  */
 101
 102 #if FFEGLOBAL_ENABLED
 103 static ffeglobal
 104 ffeglobal_new_ (ffename n)
 105 {
 106   ffeglobal g;
 107
 108   assert (n != NULL);
 109
 110   g = malloc_new_ks (malloc_pool_image (), "FFEGLOBAL", sizeof (*g));
 111   g->n = n;
 112   g->hook = FFECOM_globalNULL;
 113   g->tick = 0;
 114
 115   ffename_set_global (n, g);
 116
 117   return g;
 118 }
 119
 120 #endif
 121 /* ffeglobal_init_1 -- Initialize per file
 122
 123    ffeglobal_init_1();  */
 124
 125 void
 126 ffeglobal_init_1 (void)
 127 {
 128 #if FFEGLOBAL_ENABLED
 129   if (ffeglobal_filewide_ != NULL)
 130     ffename_space_kill (ffeglobal_filewide_);
 131   ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
 132 #endif
 133 }
 134
 135 /* ffeglobal_init_common -- Initial value specified for common block
 136
 137    ffesymbol s;  // the ffesymbol for the common block
 138    ffelexToken t;  // the token with the point of initialization
 139    ffeglobal_init_common(s,t);
 140
 141    For back ends where file-wide global symbols are not maintained, does
 142    nothing.  Otherwise, makes sure this common block hasn't already been
 143    initialized in a previous program unit, and flag that it's been
 144    initialized in this one.  */
 145
 146 void
 147 ffeglobal_init_common (ffesymbol s, ffelexToken t)
 148 {
 149 #if FFEGLOBAL_ENABLED
 150   ffeglobal g;
 151
 152   g = ffesymbol_global (s);
 153
 154   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
 155     return;
 156   if (g->type == FFEGLOBAL_typeANY)
 157     return;
 158
 159   if (g->tick == ffe_count_2)
 160     return;
 161
 162   if (g->tick != 0)
 163     {
 164       if (g->u.common.initt != NULL)
 165         {
 166           ffebad_start (FFEBAD_COMMON_ALREADY_INIT);
 167           ffebad_string (ffesymbol_text (s));
 168           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 169           ffebad_here (1, ffelex_token_where_line (g->u.common.initt),
 170                        ffelex_token_where_column (g->u.common.initt));
 171           ffebad_finish ();
 172         }
 173
 174       /* Complain about just one attempt to reinit per program unit, but
 175          continue referring back to the first such successful attempt.  */
 176     }
 177   else
 178     {
 179       if (g->u.common.blank)
 180         {
 181           /* Not supposed to initialize blank common, though it works.  */
 182           ffebad_start (FFEBAD_COMMON_BLANK_INIT);
 183           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 184           ffebad_finish ();
 185         }
 186
 187       g->u.common.initt = ffelex_token_use (t);
 188     }
 189
 190   g->tick = ffe_count_2;
 191 #endif
 192 }
 193
 194 /* ffeglobal_new_common -- New common block
 195
 196    ffesymbol s;  // the ffesymbol for the new common block
 197    ffelexToken t;  // the token with the name of the common block
 198    bool blank;  // TRUE if blank common
 199    ffeglobal_new_common(s,t,blank);
 200
 201    For back ends where file-wide global symbols are not maintained, does
 202    nothing.  Otherwise, makes sure this symbol hasn't been seen before or
 203    is known as a common block.  */
 204
 205 void
 206 ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
 207 {
 208 #if FFEGLOBAL_ENABLED
 209   ffename n;
 210   ffeglobal g;
 211
 212   if (ffesymbol_global (s) == NULL)
 213     {
 214       n = ffename_find (ffeglobal_filewide_, t);
 215       g = ffename_global (n);
 216     }
 217   else
 218     {
 219       g = ffesymbol_global (s);
 220       n = NULL;
 221     }
 222
 223   if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
 224     return;
 225
 226   if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
 227     {
 228       if (g->type == FFEGLOBAL_typeCOMMON)
 229         {
 230           /* The names match, so the "blankness" should match too!  */
 231           assert (g->u.common.blank == blank);
 232         }
 233       else
 234         {
 235           /* This global name has already been established,
 236              but as something other than a common block.  */
 237           if (ffe_is_globals () || ffe_is_warn_globals ())
 238             {
 239               ffebad_start (ffe_is_globals ()
 240                             ? FFEBAD_FILEWIDE_ALREADY_SEEN
 241                             : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
 242               ffebad_string (ffelex_token_text (t));
 243               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 244               ffebad_here (1, ffelex_token_where_line (g->t),
 245                            ffelex_token_where_column (g->t));
 246               ffebad_finish ();
 247             }
 248           g->type = FFEGLOBAL_typeANY;
 249         }
 250     }
 251   else
 252     {
 253       if (g == NULL)
 254         {
 255           g = ffeglobal_new_ (n);
 256           g->intrinsic = FALSE;
 257         }
 258       else if (g->intrinsic
 259                && !g->explicit_intrinsic
 260                && ffe_is_warn_globals ())
 261         {
 262           /* Common name previously used as intrinsic.  Though it works,
 263              warn, because the intrinsic reference might have been intended
 264              as a ref to an external procedure, but g77's vast list of
 265              intrinsics happened to snarf the name.  */
 266           ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
 267           ffebad_string (ffelex_token_text (t));
 268           ffebad_string ("common block");
 269           ffebad_string ("intrinsic");
 270           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 271           ffebad_here (1, ffelex_token_where_line (g->t),
 272                        ffelex_token_where_column (g->t));
 273           ffebad_finish ();
 274         }
 275       g->t = ffelex_token_use (t);
 276       g->type = FFEGLOBAL_typeCOMMON;
 277       g->u.common.have_pad = FALSE;
 278       g->u.common.have_save = FALSE;
 279       g->u.common.have_size = FALSE;
 280       g->u.common.blank = blank;
 281     }
 282
 283   ffesymbol_set_global (s, g);
 284 #endif
 285 }
 286
 287 /* ffeglobal_new_progunit_ -- New program unit
 288
 289    ffesymbol s;  // the ffesymbol for the new unit
 290    ffelexToken t;  // the token with the name of the unit
 291    ffeglobalType type;  // the type of the new unit
 292    ffeglobal_new_progunit_(s,t,type);
 293
 294    For back ends where file-wide global symbols are not maintained, does
 295    nothing.  Otherwise, makes sure this symbol hasn't been seen before.  */
 296
 297 void
 298 ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
 299 {
 300 #if FFEGLOBAL_ENABLED
 301   ffename n;
 302   ffeglobal g;
 303
 304   n = ffename_find (ffeglobal_filewide_, t);
 305   g = ffename_global (n);
 306   if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
 307     return;
 308
 309   if ((g != NULL)
 310       && ((g->type == FFEGLOBAL_typeMAIN)
 311           || (g->type == FFEGLOBAL_typeSUBR)
 312           || (g->type == FFEGLOBAL_typeFUNC)
 313           || (g->type == FFEGLOBAL_typeBDATA))
 314       && g->u.proc.defined)
 315     {
 316       /* This program unit has already been defined.  */
 317       if (ffe_is_globals () || ffe_is_warn_globals ())
 318         {
 319           ffebad_start (ffe_is_globals ()
 320                         ? FFEBAD_FILEWIDE_ALREADY_SEEN
 321                         : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
 322           ffebad_string (ffelex_token_text (t));
 323           ffebad_here (0, ffelex_token_where_line (t),
 324                        ffelex_token_where_column (t));
 325           ffebad_here (1, ffelex_token_where_line (g->t),
 326                        ffelex_token_where_column (g->t));
 327           ffebad_finish ();
 328         }
 329       g->type = FFEGLOBAL_typeANY;
 330     }
 331   else if ((g != NULL)
 332            && (g->type != FFEGLOBAL_typeNONE)
 333            && (g->type != FFEGLOBAL_typeEXT)
 334            && (g->type != type))
 335     {
 336       /* A reference to this program unit has been seen, but its
 337          context disagrees about the new definition regarding
 338          what kind of program unit it is.  (E.g. `call foo' followed
 339          by `function foo'.)  But `external foo' alone doesn't mean
 340          disagreement with either a function or subroutine, though
 341          g77 normally interprets it as a request to force-load
 342          a block data program unit by that name (to cope with libs).  */
 343       if (ffe_is_globals () || ffe_is_warn_globals ())
 344         {
 345           ffebad_start (ffe_is_globals ()
 346                         ? FFEBAD_FILEWIDE_DISAGREEMENT
 347                         : FFEBAD_FILEWIDE_DISAGREEMENT_W);
 348           ffebad_string (ffelex_token_text (t));
 349           ffebad_string (ffeglobal_type_string_[type]);
 350           ffebad_string (ffeglobal_type_string_[g->type]);
 351           ffebad_here (0, ffelex_token_where_line (t),
 352                        ffelex_token_where_column (t));
 353           ffebad_here (1, ffelex_token_where_line (g->t),
 354                        ffelex_token_where_column (g->t));
 355           ffebad_finish ();
 356         }
 357       g->type = FFEGLOBAL_typeANY;
 358     }
 359   else
 360     {
 361       if (g == NULL)
 362         {
 363           g = ffeglobal_new_ (n);
 364           g->intrinsic = FALSE;
 365           g->u.proc.n_args = -1;
 366           g->u.proc.other_t = NULL;
 367         }
 368       else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
 369                && (g->type == FFEGLOBAL_typeFUNC)
 370                && ((ffesymbol_basictype (s) != g->u.proc.bt)
 371                    || (ffesymbol_kindtype (s) != g->u.proc.kt)
 372                    || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE)
 373                        && (ffesymbol_size (s) != g->u.proc.sz))))
 374         {
 375           /* The previous reference and this new function definition
 376              disagree about the type of the function.  I (Burley) think
 377              this rarely occurs, because when this code is reached,
 378              the type info doesn't appear to be filled in yet.  */
 379           if (ffe_is_globals () || ffe_is_warn_globals ())
 380             {
 381               ffebad_start (ffe_is_globals ()
 382                             ? FFEBAD_FILEWIDE_TYPE_MISMATCH
 383                             : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
 384               ffebad_string (ffelex_token_text (t));
 385               ffebad_here (0, ffelex_token_where_line (t),
 386                            ffelex_token_where_column (t));
 387               ffebad_here (1, ffelex_token_where_line (g->t),
 388                            ffelex_token_where_column (g->t));
 389               ffebad_finish ();
 390             }
 391           g->type = FFEGLOBAL_typeANY;
 392           return;
 393         }
 394       if (g->intrinsic
 395           && !g->explicit_intrinsic
 396           && ffe_is_warn_globals ())
 397         {
 398           /* This name, previously used as an intrinsic, now is known
 399              to also be a global procedure name.  Warn, since the previous
 400              use as an intrinsic might have been intended to refer to
 401              this procedure.  */
 402           ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
 403           ffebad_string (ffelex_token_text (t));
 404           ffebad_string ("global");
 405           ffebad_string ("intrinsic");
 406           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 407           ffebad_here (1, ffelex_token_where_line (g->t),
 408                        ffelex_token_where_column (g->t));
 409           ffebad_finish ();
 410         }
 411       g->t = ffelex_token_use (t);
 412       if ((g->tick == 0)
 413           || (g->u.proc.bt == FFEINFO_basictypeNONE)
 414           || (g->u.proc.kt == FFEINFO_kindtypeNONE))
 415         {
 416           g->u.proc.bt = ffesymbol_basictype (s);
 417           g->u.proc.kt = ffesymbol_kindtype (s);
 418           g->u.proc.sz = ffesymbol_size (s);
 419         }
 420       /* If there's a known disagreement about the kind of program
 421          unit, then don't even bother tracking arglist argreement.  */
 422       if ((g->tick != 0)
 423           && (g->type != type))
 424         g->u.proc.n_args = -1;
 425       g->tick = ffe_count_2;
 426       g->type = type;
 427       g->u.proc.defined = TRUE;
 428     }
 429
 430   ffesymbol_set_global (s, g);
 431 #endif
 432 }
 433
 434 /* ffeglobal_pad_common -- Check initial padding of common area
 435
 436    ffesymbol s;  // the common area
 437    ffetargetAlign pad;  // the initial padding
 438    ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
 439          ffesymbol_where_column(s));
 440
 441    In global-enabled mode, make sure the padding agrees with any existing
 442    padding established for the common area, otherwise complain.
 443    In global-disabled mode, warn about nonzero padding.  */
 444
 445 void
 446 ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
 447                       ffewhereColumn wc)
 448 {
 449 #if FFEGLOBAL_ENABLED
 450   ffeglobal g;
 451
 452   g = ffesymbol_global (s);
 453   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
 454     return;                     /* Let someone else catch this! */
 455   if (g->type == FFEGLOBAL_typeANY)
 456     return;
 457
 458   if (!g->u.common.have_pad)
 459     {
 460       g->u.common.have_pad = TRUE;
 461       g->u.common.pad = pad;
 462       g->u.common.pad_where_line = ffewhere_line_use (wl);
 463       g->u.common.pad_where_col = ffewhere_column_use (wc);
 464
 465       if (pad != 0)
 466         {
 467           char padding[20];
 468
 469           sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
 470           ffebad_start (FFEBAD_COMMON_INIT_PAD);
 471           ffebad_string (ffesymbol_text (s));
 472           ffebad_string (padding);
 473           ffebad_string ((pad == 1)
 474                          ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
 475           ffebad_here (0, wl, wc);
 476           ffebad_finish ();
 477         }
 478     }
 479   else
 480     {
 481       if (g->u.common.pad != pad)
 482         {
 483           char padding_1[20];
 484           char padding_2[20];
 485
 486           sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
 487           sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad);
 488           ffebad_start (FFEBAD_COMMON_DIFF_PAD);
 489           ffebad_string (ffesymbol_text (s));
 490           ffebad_string (padding_1);
 491           ffebad_here (0, wl, wc);
 492           ffebad_string (padding_2);
 493           ffebad_string ((pad == 1)
 494                          ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
 495           ffebad_string ((g->u.common.pad == 1)
 496                          ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
 497           ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col);
 498           ffebad_finish ();
 499         }
 500
 501       if (g->u.common.pad < pad)
 502         {
 503           g->u.common.pad = pad;
 504           g->u.common.pad_where_line = ffewhere_line_use (wl);
 505           g->u.common.pad_where_col = ffewhere_column_use (wc);
 506         }
 507     }
 508 #endif
 509 }
 510
 511 /* Collect info for a global's argument.  */
 512
 513 void
 514 ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
 515                         ffeinfoBasictype bt, ffeinfoKindtype kt,
 516                         bool array)
 517 {
 518   ffeglobal g = ffesymbol_global (s);
 519   ffeglobalArgInfo_ ai;
 520
 521   assert (g != NULL);
 522
 523   if (g->type == FFEGLOBAL_typeANY)
 524     return;
 525
 526   assert (g->u.proc.n_args >= 0);
 527
 528   if (argno >= g->u.proc.n_args)
 529     return;     /* Already complained about this discrepancy. */
 530
 531   ai = &g->u.proc.arg_info[argno];
 532
 533   /* Maybe warn about previous references.  */
 534
 535   if ((ai->t != NULL)
 536       && ffe_is_warn_globals ())
 537     {
 538       const char *refwhy = NULL;
 539       const char *defwhy = NULL;
 540       bool warn = FALSE;
 541
 542       switch (as)
 543         {
 544         case FFEGLOBAL_argsummaryREF:
 545           if ((ai->as != FFEGLOBAL_argsummaryREF)
 546               && (ai->as != FFEGLOBAL_argsummaryNONE)
 547               && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
 548                   || (ai->bt != FFEINFO_basictypeCHARACTER)
 549                   || (ai->bt == bt)))
 550             {
 551               warn = TRUE;
 552               refwhy = "passed by reference";
 553             }
 554           break;
 555
 556         case FFEGLOBAL_argsummaryDESCR:
 557           if ((ai->as != FFEGLOBAL_argsummaryDESCR)
 558               && (ai->as != FFEGLOBAL_argsummaryNONE)
 559               && ((ai->as != FFEGLOBAL_argsummaryREF)   /* Choose better message. */
 560                   || (bt != FFEINFO_basictypeCHARACTER)
 561                   || (ai->bt == bt)))
 562             {
 563               warn = TRUE;
 564               refwhy = "passed by descriptor";
 565             }
 566           break;
 567
 568         case FFEGLOBAL_argsummaryPROC:
 569           if ((ai->as != FFEGLOBAL_argsummaryPROC)
 570               && (ai->as != FFEGLOBAL_argsummarySUBR)
 571               && (ai->as != FFEGLOBAL_argsummaryFUNC)
 572               && (ai->as != FFEGLOBAL_argsummaryNONE))
 573             {
 574               warn = TRUE;
 575               refwhy = "a procedure";
 576             }
 577           break;
 578
 579         case FFEGLOBAL_argsummarySUBR:
 580           if ((ai->as != FFEGLOBAL_argsummaryPROC)
 581               && (ai->as != FFEGLOBAL_argsummarySUBR)
 582               && (ai->as != FFEGLOBAL_argsummaryNONE))
 583             {
 584               warn = TRUE;
 585               refwhy = "a subroutine";
 586             }
 587           break;
 588
 589         case FFEGLOBAL_argsummaryFUNC:
 590           if ((ai->as != FFEGLOBAL_argsummaryPROC)
 591               && (ai->as != FFEGLOBAL_argsummaryFUNC)
 592               && (ai->as != FFEGLOBAL_argsummaryNONE))
 593             {
 594               warn = TRUE;
 595               refwhy = "a function";
 596             }
 597           break;
 598
 599         case FFEGLOBAL_argsummaryALTRTN:
 600           if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
 601               && (ai->as != FFEGLOBAL_argsummaryNONE))
 602             {
 603               warn = TRUE;
 604               refwhy = "an alternate-return label";
 605             }
 606           break;
 607
 608         default:
 609           break;
 610         }
 611
 612       if ((refwhy != NULL) && (defwhy == NULL))
 613         {
 614           /* Fill in the def info.  */
 615
 616           switch (ai->as)
 617             {
 618             case FFEGLOBAL_argsummaryNONE:
 619               defwhy = "omitted";
 620               break;
 621
 622             case FFEGLOBAL_argsummaryVAL:
 623               defwhy = "passed by value";
 624               break;
 625
 626             case FFEGLOBAL_argsummaryREF:
 627               defwhy = "passed by reference";
 628               break;
 629
 630             case FFEGLOBAL_argsummaryDESCR:
 631               defwhy = "passed by descriptor";
 632               break;
 633
 634             case FFEGLOBAL_argsummaryPROC:
 635               defwhy = "a procedure";
 636               break;
 637
 638             case FFEGLOBAL_argsummarySUBR:
 639               defwhy = "a subroutine";
 640               break;
 641
 642             case FFEGLOBAL_argsummaryFUNC:
 643               defwhy = "a function";
 644               break;
 645
 646             case FFEGLOBAL_argsummaryALTRTN:
 647               defwhy = "an alternate-return label";
 648               break;
 649
 650 #if 0
 651             case FFEGLOBAL_argsummaryPTR:
 652               defwhy = "a pointer";
 653               break;
 654 #endif
 655
 656             default:
 657               defwhy = "???";
 658               break;
 659             }
 660         }
 661
 662       if (!warn
 663           && (bt != FFEINFO_basictypeHOLLERITH)
 664           && (bt != FFEINFO_basictypeTYPELESS)
 665           && (bt != FFEINFO_basictypeNONE)
 666           && (ai->bt != FFEINFO_basictypeHOLLERITH)
 667           && (ai->bt != FFEINFO_basictypeTYPELESS)
 668           && (ai->bt != FFEINFO_basictypeNONE))
 669         {
 670           /* Check types.  */
 671
 672           if ((bt != ai->bt)
 673               && ((bt != FFEINFO_basictypeREAL)
 674                   || (ai->bt != FFEINFO_basictypeCOMPLEX))
 675               && ((bt != FFEINFO_basictypeCOMPLEX)
 676                   || (ai->bt != FFEINFO_basictypeREAL)))
 677             {
 678               warn = TRUE;      /* We can cope with these differences. */
 679               refwhy = "one type";
 680               defwhy = "some other type";
 681             }
 682
 683           if (!warn && (kt != ai->kt))
 684             {
 685               warn = TRUE;
 686               refwhy = "one precision";
 687               defwhy = "some other precision";
 688             }
 689         }
 690
 691       if (warn)
 692         {
 693           char num[60];
 694
 695           if (name == NULL)
 696             sprintf (&num[0], "%d", argno + 1);
 697           else
 698             {
 699               if (strlen (name) < 30)
 700                 sprintf (&num[0], "%d (named `%s')", argno + 1, name);
 701               else
 702                 sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name);
 703             }
 704           ffebad_start (FFEBAD_FILEWIDE_ARG_W);
 705           ffebad_string (ffesymbol_text (s));
 706           ffebad_string (num);
 707           ffebad_string (refwhy);
 708           ffebad_string (defwhy);
 709           ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t));
 710           ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
 711           ffebad_finish ();
 712         }
 713     }
 714
 715   /* Define this argument.  */
 716
 717   if (ai->t != NULL)
 718     ffelex_token_kill (ai->t);
 719   if ((as != FFEGLOBAL_argsummaryPROC)
 720       || (ai->t == NULL))
 721     ai->as = as;        /* Otherwise leave SUBR/FUNC info intact. */
 722   ai->t = ffelex_token_use (g->t);
 723   if (name == NULL)
 724     ai->name = NULL;
 725   else
 726     {
 727       ai->name = malloc_new_ks (malloc_pool_image (),
 728                                 "ffeglobalArgInfo_ name",
 729                                 strlen (name) + 1);
 730       strcpy (ai->name, name);
 731     }
 732   ai->bt = bt;
 733   ai->kt = kt;
 734   ai->array = array;
 735 }
 736
 737 /* Collect info on #args a global accepts.  */
 738
 739 void
 740 ffeglobal_proc_def_nargs (ffesymbol s, int n_args)
 741 {
 742   ffeglobal g = ffesymbol_global (s);
 743
 744   assert (g != NULL);
 745
 746   if (g->type == FFEGLOBAL_typeANY)
 747     return;
 748
 749   if (g->u.proc.n_args >= 0)
 750     {
 751       if (g->u.proc.n_args == n_args)
 752         return;
 753
 754       if (ffe_is_warn_globals ())
 755         {
 756           ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
 757           ffebad_string (ffesymbol_text (s));
 758           if (g->u.proc.n_args > n_args)
 759             ffebad_string ("few");
 760           else
 761             ffebad_string ("many");
 762           ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t),
 763                        ffelex_token_where_column (g->u.proc.other_t));
 764           ffebad_here (1, ffelex_token_where_line (g->t),
 765                        ffelex_token_where_column (g->t));
 766           ffebad_finish ();
 767         }
 768     }
 769
 770   /* This is new info we can use in cross-checking future references
 771      and a possible future definition.  */
 772
 773   g->u.proc.n_args = n_args;
 774   g->u.proc.other_t = NULL;     /* No other reference yet. */
 775
 776   if (n_args == 0)
 777     {
 778       g->u.proc.arg_info = NULL;
 779       return;
 780     }
 781
 782   g->u.proc.arg_info = malloc_new_ks (malloc_pool_image (),
 783                                       "ffeglobalArgInfo_",
 784                                       n_args * sizeof (g->u.proc.arg_info[0]));
 785   while (n_args-- > 0)
 786     g->u.proc.arg_info[n_args].t = NULL;
 787 }
 788
 789 /* Verify that the info for a global's argument is valid.  */
 790
 791 bool
 792 ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
 793                         ffeinfoBasictype bt, ffeinfoKindtype kt,
 794                         bool array, ffelexToken t)
 795 {
 796   ffeglobal g = ffesymbol_global (s);
 797   ffeglobalArgInfo_ ai;
 798
 799   assert (g != NULL);
 800
 801   if (g->type == FFEGLOBAL_typeANY)
 802     return FALSE;
 803
 804   assert (g->u.proc.n_args >= 0);
 805
 806   if (argno >= g->u.proc.n_args)
 807     return TRUE;        /* Already complained about this discrepancy. */
 808
 809   ai = &g->u.proc.arg_info[argno];
 810
 811   /* Warn about previous references.  */
 812
 813   if (ai->t != NULL)
 814     {
 815       const char *refwhy = NULL;
 816       const char *defwhy = NULL;
 817       bool fail = FALSE;
 818       bool warn = FALSE;
 819
 820       switch (as)
 821         {
 822         case FFEGLOBAL_argsummaryNONE:
 823           if (g->u.proc.defined)
 824             {
 825               fail = TRUE;
 826               refwhy = "omitted";
 827               defwhy = "not optional";
 828             }
 829           break;
 830
 831         case FFEGLOBAL_argsummaryVAL:
 832           if (ai->as != FFEGLOBAL_argsummaryVAL)
 833             {
 834               fail = TRUE;
 835               refwhy = "passed by value";
 836             }
 837           break;
 838
 839         case FFEGLOBAL_argsummaryREF:
 840           if ((ai->as != FFEGLOBAL_argsummaryREF)
 841               && (ai->as != FFEGLOBAL_argsummaryNONE)
 842               && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */
 843                   || (ai->bt != FFEINFO_basictypeCHARACTER)
 844                   || (ai->bt == bt)))
 845             {
 846               fail = TRUE;
 847               refwhy = "passed by reference";
 848             }
 849           break;
 850
 851         case FFEGLOBAL_argsummaryDESCR:
 852           if ((ai->as != FFEGLOBAL_argsummaryDESCR)
 853               && (ai->as != FFEGLOBAL_argsummaryNONE)
 854               && ((ai->as != FFEGLOBAL_argsummaryREF)   /* Choose better message. */
 855                   || (bt != FFEINFO_basictypeCHARACTER)
 856                   || (ai->bt == bt)))
 857             {
 858               fail = TRUE;
 859               refwhy = "passed by descriptor";
 860             }
 861           break;
 862
 863         case FFEGLOBAL_argsummaryPROC:
 864           if ((ai->as != FFEGLOBAL_argsummaryPROC)
 865               && (ai->as != FFEGLOBAL_argsummarySUBR)
 866               && (ai->as != FFEGLOBAL_argsummaryFUNC)
 867               && (ai->as != FFEGLOBAL_argsummaryNONE))
 868             {
 869               fail = TRUE;
 870               refwhy = "a procedure";
 871             }
 872           break;
 873
 874         case FFEGLOBAL_argsummarySUBR:
 875           if ((ai->as != FFEGLOBAL_argsummaryPROC)
 876               && (ai->as != FFEGLOBAL_argsummarySUBR)
 877               && (ai->as != FFEGLOBAL_argsummaryNONE))
 878             {
 879               fail = TRUE;
 880               refwhy = "a subroutine";
 881             }
 882           break;
 883
 884         case FFEGLOBAL_argsummaryFUNC:
 885           if ((ai->as != FFEGLOBAL_argsummaryPROC)
 886               && (ai->as != FFEGLOBAL_argsummaryFUNC)
 887               && (ai->as != FFEGLOBAL_argsummaryNONE))
 888             {
 889               fail = TRUE;
 890               refwhy = "a function";
 891             }
 892           break;
 893
 894         case FFEGLOBAL_argsummaryALTRTN:
 895           if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
 896               && (ai->as != FFEGLOBAL_argsummaryNONE))
 897             {
 898               fail = TRUE;
 899               refwhy = "an alternate-return label";
 900             }
 901           break;
 902
 903 #if 0
 904         case FFEGLOBAL_argsummaryPTR:
 905           if ((ai->as != FFEGLOBAL_argsummaryPTR)
 906               && (ai->as != FFEGLOBAL_argsummaryNONE))
 907             {
 908               fail = TRUE;
 909               refwhy = "a pointer";
 910             }
 911           break;
 912 #endif
 913
 914         default:
 915           break;
 916         }
 917
 918       if ((refwhy != NULL) && (defwhy == NULL))
 919         {
 920           /* Fill in the def info.  */
 921
 922           switch (ai->as)
 923             {
 924             case FFEGLOBAL_argsummaryNONE:
 925               defwhy = "omitted";
 926               break;
 927
 928             case FFEGLOBAL_argsummaryVAL:
 929               defwhy = "passed by value";
 930               break;
 931
 932             case FFEGLOBAL_argsummaryREF:
 933               defwhy = "passed by reference";
 934               break;
 935
 936             case FFEGLOBAL_argsummaryDESCR:
 937               defwhy = "passed by descriptor";
 938               break;
 939
 940             case FFEGLOBAL_argsummaryPROC:
 941               defwhy = "a procedure";
 942               break;
 943
 944             case FFEGLOBAL_argsummarySUBR:
 945               defwhy = "a subroutine";
 946               break;
 947
 948             case FFEGLOBAL_argsummaryFUNC:
 949               defwhy = "a function";
 950               break;
 951
 952             case FFEGLOBAL_argsummaryALTRTN:
 953               defwhy = "an alternate-return label";
 954               break;
 955
 956 #if 0
 957             case FFEGLOBAL_argsummaryPTR:
 958               defwhy = "a pointer";
 959               break;
 960 #endif
 961
 962             default:
 963               defwhy = "???";
 964               break;
 965             }
 966         }
 967
 968       if (!fail && !warn
 969           && (bt != FFEINFO_basictypeHOLLERITH)
 970           && (bt != FFEINFO_basictypeTYPELESS)
 971           && (bt != FFEINFO_basictypeNONE)
 972           && (ai->bt != FFEINFO_basictypeHOLLERITH)
 973           && (ai->bt != FFEINFO_basictypeNONE)
 974           && (ai->bt != FFEINFO_basictypeTYPELESS))
 975         {
 976           /* Check types.  */
 977
 978           if ((bt != ai->bt)
 979               && ((bt != FFEINFO_basictypeREAL)
 980                   || (ai->bt != FFEINFO_basictypeCOMPLEX))
 981               && ((bt != FFEINFO_basictypeCOMPLEX)
 982                   || (ai->bt != FFEINFO_basictypeREAL)))
 983             {
 984               if (((bt == FFEINFO_basictypeINTEGER)
 985                    && (ai->bt == FFEINFO_basictypeLOGICAL))
 986                   || ((bt == FFEINFO_basictypeLOGICAL)
 987                    && (ai->bt == FFEINFO_basictypeINTEGER)))
 988                 warn = TRUE;    /* We can cope with these differences. */
 989               else
 990                 fail = TRUE;
 991               refwhy = "one type";
 992               defwhy = "some other type";
 993             }
 994
 995           if (!fail && !warn && (kt != ai->kt))
 996             {
 997               fail = TRUE;
 998               refwhy = "one precision";
 999               defwhy = "some other precision";
1000             }
1001         }
1002
1003       if (fail && ! g->u.proc.defined)
1004         {
1005           /* No point failing if we're worried only about invocations.  */
1006           fail = FALSE;
1007           warn = TRUE;
1008         }
1009
1010       if (fail && ! ffe_is_globals ())
1011         {
1012           warn = TRUE;
1013           fail = FALSE;
1014         }
1015
1016       if (fail || (warn && ffe_is_warn_globals ()))
1017         {
1018           char num[60];
1019
1020           if (ai->name == NULL)
1021             sprintf (&num[0], "%d", argno + 1);
1022           else
1023             {
1024               if (strlen (ai->name) < 30)
1025                 sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name);
1026               else
1027                 sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name);
1028             }
1029           ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W);
1030           ffebad_string (ffesymbol_text (s));
1031           ffebad_string (num);
1032           ffebad_string (refwhy);
1033           ffebad_string (defwhy);
1034           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1035           ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
1036           ffebad_finish ();
1037           return (fail ? FALSE : TRUE);
1038         }
1039
1040       if (warn)
1041         return TRUE;
1042     }
1043
1044   /* Define this argument.  */
1045
1046   if (ai->t != NULL)
1047     ffelex_token_kill (ai->t);
1048   if ((as != FFEGLOBAL_argsummaryPROC)
1049       || (ai->t == NULL))
1050     ai->as = as;
1051   ai->t = ffelex_token_use (g->t);
1052   ai->name = NULL;
1053   ai->bt = bt;
1054   ai->kt = kt;
1055   ai->array = array;
1056   return TRUE;
1057 }
1058
1059 bool
1060 ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t)
1061 {
1062   ffeglobal g = ffesymbol_global (s);
1063
1064   assert (g != NULL);
1065
1066   if (g->type == FFEGLOBAL_typeANY)
1067     return FALSE;
1068
1069   if (g->u.proc.n_args >= 0)
1070     {
1071       if (g->u.proc.n_args == n_args)
1072         return TRUE;
1073
1074       if (g->u.proc.defined && ffe_is_globals ())
1075         {
1076           ffebad_start (FFEBAD_FILEWIDE_NARGS);
1077           ffebad_string (ffesymbol_text (s));
1078           if (g->u.proc.n_args > n_args)
1079             ffebad_string ("few");
1080           else
1081             ffebad_string ("many");
1082           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1083           ffebad_here (1, ffelex_token_where_line (g->t),
1084                        ffelex_token_where_column (g->t));
1085           ffebad_finish ();
1086           return FALSE;
1087         }
1088
1089       if (ffe_is_warn_globals ())
1090         {
1091           ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
1092           ffebad_string (ffesymbol_text (s));
1093           if (g->u.proc.n_args > n_args)
1094             ffebad_string ("few");
1095           else
1096             ffebad_string ("many");
1097           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1098           ffebad_here (1, ffelex_token_where_line (g->t),
1099                        ffelex_token_where_column (g->t));
1100           ffebad_finish ();
1101         }
1102
1103       return TRUE;              /* Don't replace the info we already have. */
1104     }
1105
1106   /* This is new info we can use in cross-checking future references
1107      and a possible future definition.  */
1108
1109   g->u.proc.n_args = n_args;
1110   g->u.proc.other_t = ffelex_token_use (t);
1111
1112   /* Make this "the" place we found the global, since it has the most info.  */
1113
1114   if (g->t != NULL)
1115     ffelex_token_kill (g->t);
1116   g->t = ffelex_token_use (t);
1117
1118   if (n_args == 0)
1119     {
1120       g->u.proc.arg_info = NULL;
1121       return TRUE;
1122     }
1123
1124   g->u.proc.arg_info = malloc_new_ks (malloc_pool_image (),
1125                                       "ffeglobalArgInfo_",
1126                                       n_args * sizeof (g->u.proc.arg_info[0]));
1127   while (n_args-- > 0)
1128     g->u.proc.arg_info[n_args].t = NULL;
1129
1130   return TRUE;
1131 }
1132
1133 /* Return a global for a promoted symbol (one that has heretofore
1134    been assumed to be local, but since discovered to be global).  */
1135
1136 ffeglobal
1137 ffeglobal_promoted (ffesymbol s)
1138 {
1139 #if FFEGLOBAL_ENABLED
1140   ffename n;
1141   ffeglobal g;
1142
1143   assert (ffesymbol_global (s) == NULL);
1144
1145   n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s)));
1146   g = ffename_global (n);
1147
1148   return g;
1149 #else
1150   return NULL;
1151 #endif
1152 }
1153
1154 /* Register a reference to an intrinsic.  Such a reference is always
1155    valid, though a warning might be in order if the same name has
1156    already been used for a global.  */
1157
1158 void
1159 ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
1160 {
1161 #if FFEGLOBAL_ENABLED
1162   ffename n;
1163   ffeglobal g;
1164
1165   if (ffesymbol_global (s) == NULL)
1166     {
1167       n = ffename_find (ffeglobal_filewide_, t);
1168       g = ffename_global (n);
1169     }
1170   else
1171     {
1172       g = ffesymbol_global (s);
1173       n = NULL;
1174     }
1175
1176   if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1177     return;
1178
1179   if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
1180     {
1181       if (! explicit
1182           && ! g->intrinsic
1183           && ffe_is_warn_globals ())
1184         {
1185           /* This name, previously used as a global, now is used
1186              for an intrinsic.  Warn, since this new use as an
1187              intrinsic might have been intended to refer to
1188              the global procedure.  */
1189           ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1190           ffebad_string (ffelex_token_text (t));
1191           ffebad_string ("intrinsic");
1192           ffebad_string ("global");
1193           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1194           ffebad_here (1, ffelex_token_where_line (g->t),
1195                        ffelex_token_where_column (g->t));
1196           ffebad_finish ();
1197         }
1198     }
1199   else
1200     {
1201       if (g == NULL)
1202         {
1203           g = ffeglobal_new_ (n);
1204           g->tick = ffe_count_2;
1205           g->type = FFEGLOBAL_typeNONE;
1206           g->intrinsic = TRUE;
1207           g->explicit_intrinsic = explicit;
1208           g->t = ffelex_token_use (t);
1209         }
1210       else if (g->intrinsic
1211                && (explicit != g->explicit_intrinsic)
1212                && (g->tick != ffe_count_2)
1213                && ffe_is_warn_globals ())
1214         {
1215           /* An earlier reference to this intrinsic disagrees with
1216              this reference vis-a-vis explicit `intrinsic foo',
1217              which suggests that the one relying on implicit
1218              intrinsicacity might have actually intended to refer
1219              to a global of the same name.  */
1220           ffebad_start (FFEBAD_INTRINSIC_EXPIMP);
1221           ffebad_string (ffelex_token_text (t));
1222           ffebad_string (explicit ? "explicit" : "implicit");
1223           ffebad_string (explicit ? "implicit" : "explicit");
1224           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1225           ffebad_here (1, ffelex_token_where_line (g->t),
1226                        ffelex_token_where_column (g->t));
1227           ffebad_finish ();
1228         }
1229     }
1230
1231   g->intrinsic = TRUE;
1232   if (explicit)
1233     g->explicit_intrinsic = TRUE;
1234
1235   ffesymbol_set_global (s, g);
1236 #endif
1237 }
1238
1239 /* Register a reference to a global.  Returns TRUE if the reference
1240    is valid.  */
1241
1242 bool
1243 ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
1244 {
1245 #if FFEGLOBAL_ENABLED
1246   ffename n = NULL;
1247   ffeglobal g;
1248
1249   /* It is never really _known_ that an EXTERNAL statement
1250      names a BLOCK DATA by just looking at the program unit,
1251      so override a different notion here.  */
1252   if (type == FFEGLOBAL_typeBDATA)
1253     type = FFEGLOBAL_typeEXT;
1254
1255   g = ffesymbol_global (s);
1256   if (g == NULL)
1257     {
1258       n = ffename_find (ffeglobal_filewide_, t);
1259       g = ffename_global (n);
1260       if (g != NULL)
1261         ffesymbol_set_global (s, g);
1262     }
1263
1264   if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
1265     return TRUE;
1266
1267   if ((g != NULL)
1268       && (g->type != FFEGLOBAL_typeNONE)
1269       && (g->type != FFEGLOBAL_typeEXT)
1270       && (g->type != type)
1271       && (type != FFEGLOBAL_typeEXT))
1272     {
1273       /* Disagreement about (fully refined) class of program unit
1274          (main, subroutine, function, block data).  Treat EXTERNAL/
1275          COMMON disagreements distinctly.  */
1276       if ((((type == FFEGLOBAL_typeBDATA)
1277             && (g->type != FFEGLOBAL_typeCOMMON))
1278            || ((g->type == FFEGLOBAL_typeBDATA)
1279                && (type != FFEGLOBAL_typeCOMMON)
1280                && ! g->u.proc.defined)))
1281         {
1282 #if 0   /* This is likely to just annoy people. */
1283           if (ffe_is_warn_globals ())
1284             {
1285               /* Warn about EXTERNAL of a COMMON name, though it works.  */
1286               ffebad_start (FFEBAD_FILEWIDE_TIFF);
1287               ffebad_string (ffelex_token_text (t));
1288               ffebad_string (ffeglobal_type_string_[type]);
1289               ffebad_string (ffeglobal_type_string_[g->type]);
1290               ffebad_here (0, ffelex_token_where_line (t),
1291                            ffelex_token_where_column (t));
1292               ffebad_here (1, ffelex_token_where_line (g->t),
1293                            ffelex_token_where_column (g->t));
1294               ffebad_finish ();
1295             }
1296 #endif
1297         }
1298       else if (ffe_is_globals () || ffe_is_warn_globals ())
1299         {
1300           ffebad_start (ffe_is_globals ()
1301                         ? FFEBAD_FILEWIDE_DISAGREEMENT
1302                         : FFEBAD_FILEWIDE_DISAGREEMENT_W);
1303           ffebad_string (ffelex_token_text (t));
1304           ffebad_string (ffeglobal_type_string_[type]);
1305           ffebad_string (ffeglobal_type_string_[g->type]);
1306           ffebad_here (0, ffelex_token_where_line (t),
1307                        ffelex_token_where_column (t));
1308           ffebad_here (1, ffelex_token_where_line (g->t),
1309                        ffelex_token_where_column (g->t));
1310           ffebad_finish ();
1311           g->type = FFEGLOBAL_typeANY;
1312           return (! ffe_is_globals ());
1313         }
1314     }
1315
1316   if ((g != NULL)
1317       && (type == FFEGLOBAL_typeFUNC))
1318     {
1319       /* If just filling in this function's type, do so.  */
1320       if ((g->tick == ffe_count_2)
1321           && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
1322           && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE))
1323         {
1324           g->u.proc.bt = ffesymbol_basictype (s);
1325           g->u.proc.kt = ffesymbol_kindtype (s);
1326           g->u.proc.sz = ffesymbol_size (s);
1327         }
1328       /* Make sure there is type agreement.  */
1329       if (g->type == FFEGLOBAL_typeFUNC
1330           && g->u.proc.bt != FFEINFO_basictypeNONE
1331           && ffesymbol_basictype (s) != FFEINFO_basictypeNONE
1332           && (ffesymbol_basictype (s) != g->u.proc.bt
1333               || ffesymbol_kindtype (s) != g->u.proc.kt
1334               /* CHARACTER*n disagreements matter only once a
1335                  definition is involved, since the definition might
1336                  be CHARACTER*(*), which accepts all references.  */
1337               || (g->u.proc.defined
1338                   && ffesymbol_size (s) != g->u.proc.sz
1339                   && ffesymbol_size (s) != FFETARGET_charactersizeNONE
1340                   && g->u.proc.sz != FFETARGET_charactersizeNONE)))
1341         {
1342           int error;
1343
1344           /* Type mismatch between function reference/definition and
1345              this subsequent reference (which might just be the filling-in
1346              of type info for the definition, but we can't reach here
1347              if that's the case and there was a previous definition).
1348
1349              It's an error given a previous definition, since that
1350              implies inlining can crash the compiler, unless the user
1351              asked for no such inlining.  */
1352           error = (g->tick != ffe_count_2
1353                    && g->u.proc.defined
1354                    && ffe_is_globals ());
1355           if (error || ffe_is_warn_globals ())
1356             {
1357               ffebad_start (error
1358                             ? FFEBAD_FILEWIDE_TYPE_MISMATCH
1359                             : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
1360               ffebad_string (ffelex_token_text (t));
1361               if (g->tick == ffe_count_2)
1362                 {
1363                   /* Current reference fills in type info for definition.
1364                      The current token doesn't necessarily point to the actual
1365                      definition of the function, so use the definition pointer
1366                      and the pointer to the pre-definition type info.  */
1367                   ffebad_here (0, ffelex_token_where_line (g->t),
1368                                ffelex_token_where_column (g->t));
1369                   ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t),
1370                                ffelex_token_where_column (g->u.proc.other_t));
1371                 }
1372               else
1373                 {
1374                   /* Current reference is not a filling-in of a current
1375                      definition.  The current token is fine, as is
1376                      the previous-mention token.  */
1377                   ffebad_here (0, ffelex_token_where_line (t),
1378                                ffelex_token_where_column (t));
1379                   ffebad_here (1, ffelex_token_where_line (g->t),
1380                                ffelex_token_where_column (g->t));
1381                 }
1382               ffebad_finish ();
1383               if (error)
1384                 g->type = FFEGLOBAL_typeANY;
1385               return FALSE;
1386             }
1387         }
1388     }
1389
1390   if (g == NULL)
1391     {
1392       g = ffeglobal_new_ (n);
1393       g->t = ffelex_token_use (t);
1394       g->tick = ffe_count_2;
1395       g->intrinsic = FALSE;
1396       g->type = type;
1397       g->u.proc.defined = FALSE;
1398       g->u.proc.bt = ffesymbol_basictype (s);
1399       g->u.proc.kt = ffesymbol_kindtype (s);
1400       g->u.proc.sz = ffesymbol_size (s);
1401       g->u.proc.n_args = -1;
1402       ffesymbol_set_global (s, g);
1403     }
1404   else if (g->intrinsic
1405            && !g->explicit_intrinsic
1406            && (g->tick != ffe_count_2)
1407            && ffe_is_warn_globals ())
1408     {
1409       /* Now known as a global, this name previously was seen as an
1410          intrinsic.  Warn, in case the previous reference was intended
1411          for the same global.  */
1412       ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
1413       ffebad_string (ffelex_token_text (t));
1414       ffebad_string ("global");
1415       ffebad_string ("intrinsic");
1416       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1417       ffebad_here (1, ffelex_token_where_line (g->t),
1418                    ffelex_token_where_column (g->t));
1419       ffebad_finish ();
1420     }
1421
1422   if ((g->type != type)
1423       && (type != FFEGLOBAL_typeEXT))
1424     {
1425       /* We've learned more, so point to where we learned it.  */
1426       g->t = ffelex_token_use (t);
1427       g->type = type;
1428       g->hook = FFECOM_globalNULL;      /* Discard previous _DECL. */
1429       g->u.proc.n_args = -1;
1430     }
1431
1432   return TRUE;
1433 #endif
1434 }
1435
1436 /* ffeglobal_save_common -- Check SAVE status of common area
1437
1438    ffesymbol s;  // the common area
1439    bool save;  // TRUE if SAVEd, FALSE otherwise
1440    ffeglobal_save_common(s,save,ffesymbol_where_line(s),
1441          ffesymbol_where_column(s));
1442
1443    In global-enabled mode, make sure the save info agrees with any existing
1444    info established for the common area, otherwise complain.
1445    In global-disabled mode, do nothing.  */
1446
1447 void
1448 ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
1449                        ffewhereColumn wc)
1450 {
1451 #if FFEGLOBAL_ENABLED
1452   ffeglobal g;
1453
1454   g = ffesymbol_global (s);
1455   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1456     return;                     /* Let someone else catch this! */
1457   if (g->type == FFEGLOBAL_typeANY)
1458     return;
1459
1460   if (!g->u.common.have_save)
1461     {
1462       g->u.common.have_save = TRUE;
1463       g->u.common.save = save;
1464       g->u.common.save_where_line = ffewhere_line_use (wl);
1465       g->u.common.save_where_col = ffewhere_column_use (wc);
1466     }
1467   else
1468     {
1469       if ((g->u.common.save != save) && ffe_is_pedantic ())
1470         {
1471           ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
1472           ffebad_string (ffesymbol_text (s));
1473           ffebad_here (save ? 0 : 1, wl, wc);
1474           ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col);
1475           ffebad_finish ();
1476         }
1477     }
1478 #endif
1479 }
1480
1481 /* ffeglobal_size_common -- Establish size of COMMON area
1482
1483    ffesymbol s;  // the common area
1484    ffetargetOffset size;  // size in units
1485    if (ffeglobal_size_common(s,size))  // new size is largest seen
1486
1487    In global-enabled mode, set the size if it current size isn't known or is
1488    smaller than new size, and for non-blank common, complain if old size
1489    is different from new.  Return TRUE if the new size is the largest seen
1490    for this COMMON area (or if no size was known for it previously).
1491    In global-disabled mode, do nothing.  */
1492
1493 #if FFEGLOBAL_ENABLED
1494 bool
1495 ffeglobal_size_common (ffesymbol s, ffetargetOffset size)
1496 {
1497   ffeglobal g;
1498
1499   g = ffesymbol_global (s);
1500   if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
1501     return FALSE;
1502   if (g->type == FFEGLOBAL_typeANY)
1503     return FALSE;
1504
1505   if (!g->u.common.have_size)
1506     {
1507       g->u.common.have_size = TRUE;
1508       g->u.common.size = size;
1509       return TRUE;
1510     }
1511
1512   if ((g->tick > 0) && (g->tick < ffe_count_2)
1513       && (g->u.common.size < size))
1514     {
1515       char oldsize[40];
1516       char newsize[40];
1517
1518       /* Common block initialized in a previous program unit, which
1519          effectively freezes its size, but now the program is trying
1520          to enlarge it.  */
1521
1522       sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
1523       sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
1524
1525       ffebad_start (FFEBAD_COMMON_ENLARGED);
1526       ffebad_string (ffesymbol_text (s));
1527       ffebad_string (oldsize);
1528       ffebad_string (newsize);
1529       ffebad_string ((g->u.common.size == 1)
1530                      ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1531       ffebad_string ((size == 1)
1532                      ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1533       ffebad_here (0, ffelex_token_where_line (g->u.common.initt),
1534                    ffelex_token_where_column (g->u.common.initt));
1535       ffebad_here (1, ffesymbol_where_line (s),
1536                    ffesymbol_where_column (s));
1537       ffebad_finish ();
1538     }
1539   else if ((g->u.common.size != size) && !g->u.common.blank)
1540     {
1541       char oldsize[40];
1542       char newsize[40];
1543
1544       /* Warn about this even if not -pedantic, because putting all
1545          program units in a single source file is the only way to
1546          detect this.  Apparently UNIX-model linkers neither handle
1547          nor report when they make a common unit smaller than
1548          requested, such as when the smaller-declared version is
1549          initialized and the larger-declared version is not.  So
1550          if people complain about strange overwriting, we can tell
1551          them to put all their code in a single file and compile
1552          that way.  Warnings about differing sizes must therefore
1553          always be issued.  */
1554
1555       sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
1556       sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);
1557
1558       ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
1559       ffebad_string (ffesymbol_text (s));
1560       ffebad_string (oldsize);
1561       ffebad_string (newsize);
1562       ffebad_string ((g->u.common.size == 1)
1563                      ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1564       ffebad_string ((size == 1)
1565                      ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
1566       ffebad_here (0, ffelex_token_where_line (g->t),
1567                    ffelex_token_where_column (g->t));
1568       ffebad_here (1, ffesymbol_where_line (s),
1569                    ffesymbol_where_column (s));
1570       ffebad_finish ();
1571     }
1572
1573   if (size > g->u.common.size)
1574     {
1575       g->u.common.size = size;
1576       return TRUE;
1577     }
1578
1579   return FALSE;
1580 }
1581
1582 #endif
1583 void
1584 ffeglobal_terminate_1 (void)
1585 {
1586 }