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