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