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