gcc/f/global.c

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