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