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