1 /* stu.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995, 1996, 1997, 2002 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5 This file is part of GNU Fortran. 6 7 GNU Fortran is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 2, or (at your option) 10 any later version. 11 12 GNU Fortran is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GNU Fortran; see the file COPYING. If not, write to 19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 20 02111-1307, USA. 21 22 */ 23 24 /* Include files. */ 25 26 #include "proj.h" 27 #include "bld.h" 28 #include "com.h" 29 #include "equiv.h" 30 #include "global.h" 31 #include "info.h" 32 #include "implic.h" 33 #include "intrin.h" 34 #include "stu.h" 35 #include "storag.h" 36 #include "sta.h" 37 #include "symbol.h" 38 #include "target.h" 39 40 /* Externals defined here. */ 41 42 43 /* Simple definitions and enumerations. */ 44 45 46 /* Internal typedefs. */ 47 48 49 /* Private include files. */ 50 51 52 /* Internal structure definitions. */ 53 54 55 /* Static objects accessed by functions in this module. */ 56 57 58 /* Static functions (internal). */ 59 60 static void ffestu_list_exec_transition_ (ffebld list); 61 static bool ffestu_symter_end_transition_ (ffebld expr); 62 static bool ffestu_symter_exec_transition_ (ffebld expr); 63 static bool ffestu_dummies_transition_ (ffesymbol (*symfunc) (ffesymbol), 64 ffebld list); 65 66 /* Internal macros. */ 67 68 #define ffestu_equiv_(s) (((ffesymbol_equiv (s) == NULL) \ 69 || (ffeequiv_common (ffesymbol_equiv (s)) == NULL)) ? FFEINFO_whereLOCAL \ 70 : FFEINFO_whereCOMMON) 71 72 /* Update symbol info just before end of unit. */ 73 74 ffesymbol 75 ffestu_sym_end_transition (ffesymbol s) 76 { 77 ffeinfoKind skd; 78 ffeinfoWhere swh; 79 ffeinfoKind nkd; 80 ffeinfoWhere nwh; 81 ffesymbolAttrs sa; 82 ffesymbolAttrs na; 83 ffesymbolState ss; 84 ffesymbolState ns; 85 bool needs_type = TRUE; /* Implicit type assignment might be 86 necessary. */ 87 88 assert (s != NULL); 89 ss = ffesymbol_state (s); 90 sa = ffesymbol_attrs (s); 91 skd = ffesymbol_kind (s); 92 swh = ffesymbol_where (s); 93 94 switch (ss) 95 { 96 case FFESYMBOL_stateUNCERTAIN: 97 if ((swh == FFEINFO_whereDUMMY) 98 && (ffesymbol_numentries (s) == 0)) 99 { /* Not actually in any dummy list! */ 100 ffesymbol_error (s, ffesta_tokens[0]); 101 return s; 102 } 103 else if (((swh == FFEINFO_whereLOCAL) 104 || (swh == FFEINFO_whereNONE)) 105 && (skd == FFEINFO_kindENTITY) 106 && ffestu_symter_end_transition_ (ffesymbol_dims (s))) 107 { /* Bad dimension expressions. */ 108 ffesymbol_error (s, NULL); 109 return s; 110 } 111 break; 112 113 case FFESYMBOL_stateUNDERSTOOD: 114 if ((swh == FFEINFO_whereLOCAL) 115 && ((skd == FFEINFO_kindFUNCTION) 116 || (skd == FFEINFO_kindSUBROUTINE))) 117 { 118 int n_args; 119 ffebld list; 120 ffebld item; 121 ffeglobalArgSummary as; 122 ffeinfoBasictype bt; 123 ffeinfoKindtype kt; 124 bool array; 125 const char *name = NULL; 126 127 ffestu_dummies_transition_ (ffecom_sym_end_transition, 128 ffesymbol_dummyargs (s)); 129 130 n_args = ffebld_list_length (ffesymbol_dummyargs (s)); 131 ffeglobal_proc_def_nargs (s, n_args); 132 for (list = ffesymbol_dummyargs (s), n_args = 0; 133 list != NULL; 134 list = ffebld_trail (list), ++n_args) 135 { 136 item = ffebld_head (list); 137 array = FALSE; 138 if (item != NULL) 139 { 140 bt = ffeinfo_basictype (ffebld_info (item)); 141 kt = ffeinfo_kindtype (ffebld_info (item)); 142 array = (ffeinfo_rank (ffebld_info (item)) > 0); 143 switch (ffebld_op (item)) 144 { 145 case FFEBLD_opSTAR: 146 as = FFEGLOBAL_argsummaryALTRTN; 147 break; 148 149 case FFEBLD_opSYMTER: 150 name = ffesymbol_text (ffebld_symter (item)); 151 as = FFEGLOBAL_argsummaryNONE; 152 153 switch (ffeinfo_kind (ffebld_info (item))) 154 { 155 case FFEINFO_kindFUNCTION: 156 as = FFEGLOBAL_argsummaryFUNC; 157 break; 158 159 case FFEINFO_kindSUBROUTINE: 160 as = FFEGLOBAL_argsummarySUBR; 161 break; 162 163 case FFEINFO_kindNONE: 164 as = FFEGLOBAL_argsummaryPROC; 165 break; 166 167 default: 168 break; 169 } 170 171 if (as != FFEGLOBAL_argsummaryNONE) 172 break; 173 174 /* Fall through. */ 175 default: 176 if (bt == FFEINFO_basictypeCHARACTER) 177 as = FFEGLOBAL_argsummaryDESCR; 178 else 179 as = FFEGLOBAL_argsummaryREF; 180 break; 181 } 182 } 183 else 184 { 185 as = FFEGLOBAL_argsummaryNONE; 186 bt = FFEINFO_basictypeNONE; 187 kt = FFEINFO_kindtypeNONE; 188 } 189 ffeglobal_proc_def_arg (s, n_args, name, as, bt, kt, array); 190 } 191 } 192 else if (swh == FFEINFO_whereDUMMY) 193 { 194 if (ffesymbol_numentries (s) == 0) 195 { /* Not actually in any dummy list! */ 196 ffesymbol_error (s, ffesta_tokens[0]); 197 return s; 198 } 199 if (ffestu_symter_end_transition_ (ffesymbol_dims (s))) 200 { /* Bad dimension expressions. */ 201 ffesymbol_error (s, NULL); 202 return s; 203 } 204 } 205 else if ((swh == FFEINFO_whereLOCAL) 206 && ffestu_symter_end_transition_ (ffesymbol_dims (s))) 207 { /* Bad dimension expressions. */ 208 ffesymbol_error (s, NULL); 209 return s; 210 } 211 212 ffestorag_end_layout (s); 213 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 214 return s; 215 216 default: 217 assert ("bad status" == NULL); 218 return s; 219 } 220 221 ns = FFESYMBOL_stateUNDERSTOOD; 222 na = sa = ffesymbol_attrs (s); 223 224 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 225 | FFESYMBOL_attrsADJUSTABLE 226 | FFESYMBOL_attrsANYLEN 227 | FFESYMBOL_attrsARRAY 228 | FFESYMBOL_attrsDUMMY 229 | FFESYMBOL_attrsEXTERNAL 230 | FFESYMBOL_attrsSFARG 231 | FFESYMBOL_attrsTYPE))); 232 233 nkd = skd; 234 nwh = swh; 235 236 /* Figure out what kind of object we've got based on previous declarations 237 of or references to the object. */ 238 239 if (sa & FFESYMBOL_attrsEXTERNAL) 240 { 241 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 242 | FFESYMBOL_attrsDUMMY 243 | FFESYMBOL_attrsEXTERNAL 244 | FFESYMBOL_attrsTYPE))); 245 246 if (sa & FFESYMBOL_attrsTYPE) 247 nwh = FFEINFO_whereGLOBAL; 248 else 249 /* Not TYPE. */ 250 { 251 if (sa & FFESYMBOL_attrsDUMMY) 252 { /* Not TYPE. */ 253 ns = FFESYMBOL_stateUNCERTAIN; /* FUNCTION/SUBROUTINE. */ 254 needs_type = FALSE; /* Don't assign type to SUBROUTINE! */ 255 } 256 else if (sa & FFESYMBOL_attrsACTUALARG) 257 { /* Not DUMMY or TYPE. */ 258 ns = FFESYMBOL_stateUNCERTAIN; /* FUNCTION/SUBROUTINE. */ 259 needs_type = FALSE; /* Don't assign type to SUBROUTINE! */ 260 } 261 else 262 /* Not ACTUALARG, DUMMY, or TYPE. */ 263 { /* This is an assumption, essentially. */ 264 nkd = FFEINFO_kindBLOCKDATA; 265 nwh = FFEINFO_whereGLOBAL; 266 needs_type = FALSE; 267 } 268 } 269 } 270 else if (sa & FFESYMBOL_attrsDUMMY) 271 { 272 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 273 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 274 | FFESYMBOL_attrsEXTERNAL 275 | FFESYMBOL_attrsTYPE))); 276 277 /* Honestly, this appears to be a guess. I can't find anyplace in the 278 standard that makes clear whether this unreferenced dummy argument 279 is an ENTITY or a FUNCTION. And yet, for the f2c interface, picking 280 one is critical for CHARACTER entities because it determines whether 281 to expect an additional argument specifying the length of an ENTITY 282 that is not expected (or needed) for a FUNCTION. HOWEVER, F90 makes 283 this guess a correct one, and it does seem that the Section 18 Notes 284 in Appendix B of F77 make it clear the F77 standard at least 285 intended to make this guess correct as well, so this seems ok. */ 286 287 nkd = FFEINFO_kindENTITY; 288 } 289 else if (sa & FFESYMBOL_attrsARRAY) 290 { 291 assert (!(sa & ~(FFESYMBOL_attrsARRAY 292 | FFESYMBOL_attrsADJUSTABLE 293 | FFESYMBOL_attrsTYPE))); 294 295 if (ffestu_symter_end_transition_ (ffesymbol_dims (s))) 296 { 297 ffesymbol_error (s, NULL); 298 return s; 299 } 300 301 if (sa & FFESYMBOL_attrsADJUSTABLE) 302 { /* Not actually in any dummy list! */ 303 if (ffe_is_pedantic () 304 /* xgettext:no-c-format */ 305 && ffebad_start_msg ("Local adjustable symbol `%A' at %0", 306 FFEBAD_severityPEDANTIC)) 307 { 308 ffebad_string (ffesymbol_text (s)); 309 ffebad_here (0, ffesymbol_where_line (s), 310 ffesymbol_where_column (s)); 311 ffebad_finish (); 312 } 313 } 314 nwh = FFEINFO_whereLOCAL; 315 } 316 else if (sa & FFESYMBOL_attrsSFARG) 317 { 318 assert (!(sa & ~(FFESYMBOL_attrsSFARG 319 | FFESYMBOL_attrsTYPE))); 320 321 nwh = FFEINFO_whereLOCAL; 322 } 323 else if (sa & FFESYMBOL_attrsTYPE) 324 { 325 assert (!(sa & (FFESYMBOL_attrsARRAY 326 | FFESYMBOL_attrsDUMMY 327 | FFESYMBOL_attrsEXTERNAL 328 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 329 assert (!(sa & ~(FFESYMBOL_attrsTYPE 330 | FFESYMBOL_attrsADJUSTABLE 331 | FFESYMBOL_attrsANYLEN 332 | FFESYMBOL_attrsARRAY 333 | FFESYMBOL_attrsDUMMY 334 | FFESYMBOL_attrsEXTERNAL 335 | FFESYMBOL_attrsSFARG))); 336 337 if (sa & FFESYMBOL_attrsANYLEN) 338 { /* Can't touch this. */ 339 ffesymbol_signal_change (s); 340 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 341 ffesymbol_resolve_intrin (s); 342 s = ffecom_sym_learned (s); 343 ffesymbol_reference (s, NULL, FALSE); 344 ffestorag_end_layout (s); 345 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 346 return s; 347 } 348 349 nkd = FFEINFO_kindENTITY; 350 nwh = FFEINFO_whereLOCAL; 351 } 352 else 353 assert ("unexpected attribute set" == NULL); 354 355 /* Now see what we've got for a new object: NONE means a new error cropped 356 up; ANY means an old error to be ignored; otherwise, everything's ok, 357 update the object (symbol) and continue on. */ 358 359 if (na == FFESYMBOL_attrsetNONE) 360 ffesymbol_error (s, ffesta_tokens[0]); 361 else if (!(na & FFESYMBOL_attrsANY)) 362 { 363 ffesymbol_signal_change (s); 364 ffesymbol_set_attrs (s, na); /* Establish new info. */ 365 ffesymbol_set_state (s, ns); 366 ffesymbol_set_info (s, 367 ffeinfo_new (ffesymbol_basictype (s), 368 ffesymbol_kindtype (s), 369 ffesymbol_rank (s), 370 nkd, 371 nwh, 372 ffesymbol_size (s))); 373 if (needs_type && !ffeimplic_establish_symbol (s)) 374 ffesymbol_error (s, ffesta_tokens[0]); 375 else 376 ffesymbol_resolve_intrin (s); 377 s = ffecom_sym_learned (s); 378 ffesymbol_reference (s, NULL, FALSE); 379 ffestorag_end_layout (s); 380 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 381 } 382 383 return s; 384 } 385 386 /* ffestu_sym_exec_transition -- Update symbol just before first exec stmt 387 388 ffesymbol s; 389 ffestu_sym_exec_transition(s); */ 390 391 ffesymbol 392 ffestu_sym_exec_transition (ffesymbol s) 393 { 394 ffeinfoKind skd; 395 ffeinfoWhere swh; 396 ffeinfoKind nkd; 397 ffeinfoWhere nwh; 398 ffesymbolAttrs sa; 399 ffesymbolAttrs na; 400 ffesymbolState ss; 401 ffesymbolState ns; 402 ffeintrinGen gen; 403 ffeintrinSpec spec; 404 ffeintrinImp imp; 405 bool needs_type = TRUE; /* Implicit type assignment might be 406 necessary. */ 407 bool resolve_intrin = TRUE; /* Might need to resolve intrinsic. */ 408 409 assert (s != NULL); 410 411 sa = ffesymbol_attrs (s); 412 skd = ffesymbol_kind (s); 413 swh = ffesymbol_where (s); 414 ss = ffesymbol_state (s); 415 416 switch (ss) 417 { 418 case FFESYMBOL_stateNONE: 419 return s; /* Assume caller will handle it. */ 420 421 case FFESYMBOL_stateSEEN: 422 break; 423 424 case FFESYMBOL_stateUNCERTAIN: 425 ffestorag_exec_layout (s); 426 return s; /* Already processed this one, or not 427 necessary. */ 428 429 case FFESYMBOL_stateUNDERSTOOD: 430 if (skd == FFEINFO_kindNAMELIST) 431 { 432 ffebld_end_list (ffesymbol_ptr_to_listbottom (s)); 433 ffestu_list_exec_transition_ (ffesymbol_namelist (s)); 434 } 435 else if ((swh == FFEINFO_whereLOCAL) 436 && ((skd == FFEINFO_kindFUNCTION) 437 || (skd == FFEINFO_kindSUBROUTINE))) 438 { 439 ffestu_dummies_transition_ (ffecom_sym_exec_transition, 440 ffesymbol_dummyargs (s)); 441 if ((skd == FFEINFO_kindFUNCTION) 442 && !ffeimplic_establish_symbol (s)) 443 ffesymbol_error (s, ffesta_tokens[0]); 444 } 445 446 ffesymbol_reference (s, NULL, FALSE); 447 ffestorag_exec_layout (s); 448 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 449 return s; 450 451 default: 452 assert ("bad status" == NULL); 453 return s; 454 } 455 456 ns = FFESYMBOL_stateUNDERSTOOD; /* Only a few UNCERTAIN exceptions. */ 457 458 na = sa; 459 nkd = skd; 460 nwh = swh; 461 462 assert (!(sa & FFESYMBOL_attrsANY)); 463 464 if (sa & FFESYMBOL_attrsCOMMON) 465 { 466 assert (!(sa & ~(FFESYMBOL_attrsADJUSTS 467 | FFESYMBOL_attrsARRAY 468 | FFESYMBOL_attrsCOMMON 469 | FFESYMBOL_attrsEQUIV 470 | FFESYMBOL_attrsINIT 471 | FFESYMBOL_attrsNAMELIST 472 | FFESYMBOL_attrsSFARG 473 | FFESYMBOL_attrsTYPE))); 474 475 nkd = FFEINFO_kindENTITY; 476 nwh = FFEINFO_whereCOMMON; 477 } 478 else if (sa & FFESYMBOL_attrsRESULT) 479 { /* Result variable for function. */ 480 assert (!(sa & ~(FFESYMBOL_attrsANYLEN 481 | FFESYMBOL_attrsRESULT 482 | FFESYMBOL_attrsSFARG 483 | FFESYMBOL_attrsTYPE))); 484 485 nkd = FFEINFO_kindENTITY; 486 nwh = FFEINFO_whereRESULT; 487 } 488 else if (sa & FFESYMBOL_attrsSFUNC) 489 { /* Statement function. */ 490 assert (!(sa & ~(FFESYMBOL_attrsSFUNC 491 | FFESYMBOL_attrsTYPE))); 492 493 nkd = FFEINFO_kindFUNCTION; 494 nwh = FFEINFO_whereCONSTANT; 495 } 496 else if (sa & FFESYMBOL_attrsEXTERNAL) 497 { 498 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 499 | FFESYMBOL_attrsEXTERNAL 500 | FFESYMBOL_attrsTYPE))); 501 502 if (sa & FFESYMBOL_attrsTYPE) 503 { 504 nkd = FFEINFO_kindFUNCTION; 505 506 if (sa & FFESYMBOL_attrsDUMMY) 507 nwh = FFEINFO_whereDUMMY; 508 else 509 { 510 if (ffesta_is_entry_valid) 511 { 512 nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL. */ 513 ns = FFESYMBOL_stateUNCERTAIN; 514 } 515 else 516 nwh = FFEINFO_whereGLOBAL; 517 } 518 } 519 else 520 /* No TYPE. */ 521 { 522 nkd = FFEINFO_kindNONE; /* FUNCTION, SUBROUTINE, BLOCKDATA. */ 523 needs_type = FALSE; /* Only gets type if FUNCTION. */ 524 ns = FFESYMBOL_stateUNCERTAIN; 525 526 if (sa & FFESYMBOL_attrsDUMMY) 527 nwh = FFEINFO_whereDUMMY; /* Not BLOCKDATA. */ 528 else 529 { 530 if (ffesta_is_entry_valid) 531 nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL. */ 532 else 533 nwh = FFEINFO_whereGLOBAL; 534 } 535 } 536 } 537 else if (sa & FFESYMBOL_attrsDUMMY) 538 { 539 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 540 assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE /* Possible. */ 541 | FFESYMBOL_attrsADJUSTS /* Possible. */ 542 | FFESYMBOL_attrsANYLEN /* Possible. */ 543 | FFESYMBOL_attrsANYSIZE /* Possible. */ 544 | FFESYMBOL_attrsARRAY /* Possible. */ 545 | FFESYMBOL_attrsDUMMY /* Have it. */ 546 | FFESYMBOL_attrsEXTERNAL 547 | FFESYMBOL_attrsSFARG /* Possible. */ 548 | FFESYMBOL_attrsTYPE))); /* Possible. */ 549 550 nwh = FFEINFO_whereDUMMY; 551 552 if (ffestu_symter_exec_transition_ (ffesymbol_dims (s))) 553 na = FFESYMBOL_attrsetNONE; 554 555 if (sa & (FFESYMBOL_attrsADJUSTS 556 | FFESYMBOL_attrsARRAY 557 | FFESYMBOL_attrsANYLEN 558 | FFESYMBOL_attrsNAMELIST 559 | FFESYMBOL_attrsSFARG)) 560 nkd = FFEINFO_kindENTITY; 561 else if (sa & FFESYMBOL_attrsDUMMY) /* Still okay. */ 562 { 563 if (!(sa & FFESYMBOL_attrsTYPE)) 564 needs_type = FALSE; /* Don't assign type to SUBROUTINE! */ 565 nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION, SUBROUTINE. */ 566 ns = FFESYMBOL_stateUNCERTAIN; 567 } 568 } 569 else if (sa & FFESYMBOL_attrsADJUSTS) 570 { /* Must be DUMMY or COMMON at some point. */ 571 assert (!(sa & (FFESYMBOL_attrsCOMMON 572 | FFESYMBOL_attrsDUMMY))); /* Handled above. */ 573 assert (!(sa & ~(FFESYMBOL_attrsADJUSTS /* Have it. */ 574 | FFESYMBOL_attrsCOMMON 575 | FFESYMBOL_attrsDUMMY 576 | FFESYMBOL_attrsEQUIV /* Possible. */ 577 | FFESYMBOL_attrsINIT /* Possible. */ 578 | FFESYMBOL_attrsNAMELIST /* Possible. */ 579 | FFESYMBOL_attrsSFARG /* Possible. */ 580 | FFESYMBOL_attrsTYPE))); /* Possible. */ 581 582 nkd = FFEINFO_kindENTITY; 583 584 if (sa & FFESYMBOL_attrsEQUIV) 585 { 586 if ((ffesymbol_equiv (s) == NULL) 587 || (ffeequiv_common (ffesymbol_equiv (s)) == NULL)) 588 na = FFESYMBOL_attrsetNONE; /* Not equiv'd into COMMON. */ 589 else 590 nwh = FFEINFO_whereCOMMON; 591 } 592 else if (!ffesta_is_entry_valid 593 || (sa & (FFESYMBOL_attrsINIT 594 | FFESYMBOL_attrsNAMELIST))) 595 na = FFESYMBOL_attrsetNONE; 596 else 597 nwh = FFEINFO_whereDUMMY; 598 } 599 else if (sa & FFESYMBOL_attrsSAVE) 600 { 601 assert (!(sa & ~(FFESYMBOL_attrsARRAY 602 | FFESYMBOL_attrsEQUIV 603 | FFESYMBOL_attrsINIT 604 | FFESYMBOL_attrsNAMELIST 605 | FFESYMBOL_attrsSAVE 606 | FFESYMBOL_attrsSFARG 607 | FFESYMBOL_attrsTYPE))); 608 609 nkd = FFEINFO_kindENTITY; 610 nwh = FFEINFO_whereLOCAL; 611 } 612 else if (sa & FFESYMBOL_attrsEQUIV) 613 { 614 assert (!(sa & FFESYMBOL_attrsCOMMON)); /* Handled above. */ 615 assert (!(sa & ~(FFESYMBOL_attrsADJUSTS /* Possible. */ 616 | FFESYMBOL_attrsARRAY /* Possible. */ 617 | FFESYMBOL_attrsCOMMON 618 | FFESYMBOL_attrsEQUIV /* Have it. */ 619 | FFESYMBOL_attrsINIT /* Possible. */ 620 | FFESYMBOL_attrsNAMELIST /* Possible. */ 621 | FFESYMBOL_attrsSAVE /* Possible. */ 622 | FFESYMBOL_attrsSFARG /* Possible. */ 623 | FFESYMBOL_attrsTYPE))); /* Possible. */ 624 625 nkd = FFEINFO_kindENTITY; 626 nwh = ffestu_equiv_ (s); 627 } 628 else if (sa & FFESYMBOL_attrsNAMELIST) 629 { 630 assert (!(sa & (FFESYMBOL_attrsADJUSTS 631 | FFESYMBOL_attrsCOMMON 632 | FFESYMBOL_attrsEQUIV 633 | FFESYMBOL_attrsSAVE))); /* Handled above. */ 634 assert (!(sa & ~(FFESYMBOL_attrsADJUSTS 635 | FFESYMBOL_attrsARRAY /* Possible. */ 636 | FFESYMBOL_attrsCOMMON 637 | FFESYMBOL_attrsEQUIV 638 | FFESYMBOL_attrsINIT /* Possible. */ 639 | FFESYMBOL_attrsNAMELIST /* Have it. */ 640 | FFESYMBOL_attrsSAVE 641 | FFESYMBOL_attrsSFARG /* Possible. */ 642 | FFESYMBOL_attrsTYPE))); /* Possible. */ 643 644 nkd = FFEINFO_kindENTITY; 645 nwh = FFEINFO_whereLOCAL; 646 } 647 else if (sa & FFESYMBOL_attrsINIT) 648 { 649 assert (!(sa & (FFESYMBOL_attrsADJUSTS 650 | FFESYMBOL_attrsCOMMON 651 | FFESYMBOL_attrsEQUIV 652 | FFESYMBOL_attrsNAMELIST 653 | FFESYMBOL_attrsSAVE))); /* Handled above. */ 654 assert (!(sa & ~(FFESYMBOL_attrsADJUSTS 655 | FFESYMBOL_attrsARRAY /* Possible. */ 656 | FFESYMBOL_attrsCOMMON 657 | FFESYMBOL_attrsEQUIV 658 | FFESYMBOL_attrsINIT /* Have it. */ 659 | FFESYMBOL_attrsNAMELIST 660 | FFESYMBOL_attrsSAVE 661 | FFESYMBOL_attrsSFARG /* Possible. */ 662 | FFESYMBOL_attrsTYPE))); /* Possible. */ 663 664 nkd = FFEINFO_kindENTITY; 665 nwh = FFEINFO_whereLOCAL; 666 } 667 else if (sa & FFESYMBOL_attrsSFARG) 668 { 669 assert (!(sa & (FFESYMBOL_attrsADJUSTS 670 | FFESYMBOL_attrsCOMMON 671 | FFESYMBOL_attrsDUMMY 672 | FFESYMBOL_attrsEQUIV 673 | FFESYMBOL_attrsINIT 674 | FFESYMBOL_attrsNAMELIST 675 | FFESYMBOL_attrsRESULT 676 | FFESYMBOL_attrsSAVE))); /* Handled above. */ 677 assert (!(sa & ~(FFESYMBOL_attrsADJUSTS 678 | FFESYMBOL_attrsCOMMON 679 | FFESYMBOL_attrsDUMMY 680 | FFESYMBOL_attrsEQUIV 681 | FFESYMBOL_attrsINIT 682 | FFESYMBOL_attrsNAMELIST 683 | FFESYMBOL_attrsRESULT 684 | FFESYMBOL_attrsSAVE 685 | FFESYMBOL_attrsSFARG /* Have it. */ 686 | FFESYMBOL_attrsTYPE))); /* Possible. */ 687 688 nkd = FFEINFO_kindENTITY; 689 690 if (ffesta_is_entry_valid) 691 { 692 nwh = FFEINFO_whereNONE; /* DUMMY, LOCAL. */ 693 ns = FFESYMBOL_stateUNCERTAIN; 694 } 695 else 696 nwh = FFEINFO_whereLOCAL; 697 } 698 else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE)) 699 { 700 assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE 701 | FFESYMBOL_attrsANYLEN 702 | FFESYMBOL_attrsANYSIZE 703 | FFESYMBOL_attrsARRAY 704 | FFESYMBOL_attrsTYPE))); 705 706 nkd = FFEINFO_kindENTITY; 707 708 if (ffestu_symter_exec_transition_ (ffesymbol_dims (s))) 709 na = FFESYMBOL_attrsetNONE; 710 711 if (sa & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsANYSIZE)) 712 nwh = FFEINFO_whereDUMMY; 713 else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE)) 714 /* Still okay. */ 715 { 716 nwh = FFEINFO_whereNONE; /* DUMMY, LOCAL. */ 717 ns = FFESYMBOL_stateUNCERTAIN; 718 } 719 } 720 else if (sa & FFESYMBOL_attrsARRAY) 721 { 722 assert (!(sa & (FFESYMBOL_attrsADJUSTABLE 723 | FFESYMBOL_attrsANYSIZE 724 | FFESYMBOL_attrsCOMMON 725 | FFESYMBOL_attrsDUMMY 726 | FFESYMBOL_attrsEQUIV 727 | FFESYMBOL_attrsINIT 728 | FFESYMBOL_attrsNAMELIST 729 | FFESYMBOL_attrsSAVE))); /* Handled above. */ 730 assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE 731 | FFESYMBOL_attrsANYLEN /* Possible. */ 732 | FFESYMBOL_attrsANYSIZE 733 | FFESYMBOL_attrsARRAY /* Have it. */ 734 | FFESYMBOL_attrsCOMMON 735 | FFESYMBOL_attrsDUMMY 736 | FFESYMBOL_attrsEQUIV 737 | FFESYMBOL_attrsINIT 738 | FFESYMBOL_attrsNAMELIST 739 | FFESYMBOL_attrsSAVE 740 | FFESYMBOL_attrsTYPE))); /* Possible. */ 741 742 nkd = FFEINFO_kindENTITY; 743 744 if (sa & FFESYMBOL_attrsANYLEN) 745 { 746 assert (ffesta_is_entry_valid); /* Already diagnosed. */ 747 nwh = FFEINFO_whereDUMMY; 748 } 749 else 750 { 751 if (ffesta_is_entry_valid) 752 { 753 nwh = FFEINFO_whereNONE; /* DUMMY, LOCAL. */ 754 ns = FFESYMBOL_stateUNCERTAIN; 755 } 756 else 757 nwh = FFEINFO_whereLOCAL; 758 } 759 } 760 else if (sa & FFESYMBOL_attrsANYLEN) 761 { 762 assert (!(sa & (FFESYMBOL_attrsADJUSTABLE 763 | FFESYMBOL_attrsANYSIZE 764 | FFESYMBOL_attrsARRAY 765 | FFESYMBOL_attrsDUMMY 766 | FFESYMBOL_attrsRESULT))); /* Handled above. */ 767 assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE 768 | FFESYMBOL_attrsANYLEN /* Have it. */ 769 | FFESYMBOL_attrsANYSIZE 770 | FFESYMBOL_attrsARRAY 771 | FFESYMBOL_attrsDUMMY 772 | FFESYMBOL_attrsRESULT 773 | FFESYMBOL_attrsTYPE))); /* Have it too. */ 774 775 if (ffesta_is_entry_valid) 776 { 777 nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION. */ 778 nwh = FFEINFO_whereNONE; /* DUMMY, INTRINSIC, RESULT. */ 779 ns = FFESYMBOL_stateUNCERTAIN; 780 resolve_intrin = FALSE; 781 } 782 else if (ffeintrin_is_intrinsic (ffesymbol_text (s), NULL, FALSE, 783 &gen, &spec, &imp)) 784 { 785 ffesymbol_signal_change (s); 786 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 787 ffesymbol_set_generic (s, gen); 788 ffesymbol_set_specific (s, spec); 789 ffesymbol_set_implementation (s, imp); 790 ffesymbol_set_info (s, 791 ffeinfo_new (FFEINFO_basictypeNONE, 792 FFEINFO_kindtypeNONE, 793 0, 794 FFEINFO_kindNONE, 795 FFEINFO_whereINTRINSIC, 796 FFETARGET_charactersizeNONE)); 797 ffesymbol_resolve_intrin (s); 798 ffesymbol_reference (s, NULL, FALSE); 799 ffestorag_exec_layout (s); 800 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 801 return s; 802 } 803 else 804 { /* SPECIAL: can't have CHAR*(*) var in 805 PROGRAM/BLOCKDATA, unless it isn't 806 referenced anywhere in the code. */ 807 ffesymbol_signal_change (s); /* Can't touch this. */ 808 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 809 ffesymbol_resolve_intrin (s); 810 ffesymbol_reference (s, NULL, FALSE); 811 ffestorag_exec_layout (s); 812 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 813 return s; 814 } 815 } 816 else if (sa & FFESYMBOL_attrsTYPE) 817 { 818 assert (!(sa & (FFESYMBOL_attrsADJUSTABLE 819 | FFESYMBOL_attrsADJUSTS 820 | FFESYMBOL_attrsANYLEN 821 | FFESYMBOL_attrsANYSIZE 822 | FFESYMBOL_attrsARRAY 823 | FFESYMBOL_attrsCOMMON 824 | FFESYMBOL_attrsDUMMY 825 | FFESYMBOL_attrsEQUIV 826 | FFESYMBOL_attrsEXTERNAL 827 | FFESYMBOL_attrsINIT 828 | FFESYMBOL_attrsNAMELIST 829 | FFESYMBOL_attrsRESULT 830 | FFESYMBOL_attrsSAVE 831 | FFESYMBOL_attrsSFARG 832 | FFESYMBOL_attrsSFUNC))); 833 assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE 834 | FFESYMBOL_attrsADJUSTS 835 | FFESYMBOL_attrsANYLEN 836 | FFESYMBOL_attrsANYSIZE 837 | FFESYMBOL_attrsARRAY 838 | FFESYMBOL_attrsCOMMON 839 | FFESYMBOL_attrsDUMMY 840 | FFESYMBOL_attrsEQUIV 841 | FFESYMBOL_attrsEXTERNAL 842 | FFESYMBOL_attrsINIT 843 | FFESYMBOL_attrsINTRINSIC /* UNDERSTOOD. */ 844 | FFESYMBOL_attrsNAMELIST 845 | FFESYMBOL_attrsRESULT 846 | FFESYMBOL_attrsSAVE 847 | FFESYMBOL_attrsSFARG 848 | FFESYMBOL_attrsSFUNC 849 | FFESYMBOL_attrsTYPE))); /* Have it. */ 850 851 nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION. */ 852 nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */ 853 ns = FFESYMBOL_stateUNCERTAIN; 854 resolve_intrin = FALSE; 855 } 856 else if (sa & (FFESYMBOL_attrsCBLOCK | FFESYMBOL_attrsSAVECBLOCK)) 857 { /* COMMON block. */ 858 assert (!(sa & ~(FFESYMBOL_attrsCBLOCK 859 | FFESYMBOL_attrsSAVECBLOCK))); 860 861 if (sa & FFESYMBOL_attrsCBLOCK) 862 ffebld_end_list (ffesymbol_ptr_to_listbottom (s)); 863 else 864 ffesymbol_set_commonlist (s, NULL); 865 ffestu_list_exec_transition_ (ffesymbol_commonlist (s)); 866 nkd = FFEINFO_kindCOMMON; 867 nwh = FFEINFO_whereLOCAL; 868 needs_type = FALSE; 869 } 870 else 871 { /* First seen in stmt func definition. */ 872 assert (sa == FFESYMBOL_attrsetNONE); 873 assert ("Why are we here again?" == NULL); /* ~~~~~ */ 874 875 nkd = FFEINFO_kindNONE; /* ENTITY, FUNCTION. */ 876 nwh = FFEINFO_whereNONE; /* DUMMY, GLOBAL, LOCAL. */ 877 ns = FFESYMBOL_stateUNCERTAIN; /* Will get repromoted by caller. */ 878 needs_type = FALSE; 879 } 880 881 if (na == FFESYMBOL_attrsetNONE) 882 ffesymbol_error (s, ffesta_tokens[0]); 883 else if (!(na & FFESYMBOL_attrsANY) 884 && (needs_type || (nkd != skd) || (nwh != swh) 885 || (na != sa) || (ns != ss))) 886 { 887 ffesymbol_signal_change (s); 888 ffesymbol_set_attrs (s, na); /* Establish new info. */ 889 ffesymbol_set_state (s, ns); 890 if ((ffesymbol_common (s) == NULL) 891 && (ffesymbol_equiv (s) != NULL)) 892 ffesymbol_set_common (s, ffeequiv_common (ffesymbol_equiv (s))); 893 ffesymbol_set_info (s, 894 ffeinfo_new (ffesymbol_basictype (s), 895 ffesymbol_kindtype (s), 896 ffesymbol_rank (s), 897 nkd, 898 nwh, 899 ffesymbol_size (s))); 900 if (needs_type && !ffeimplic_establish_symbol (s)) 901 ffesymbol_error (s, ffesta_tokens[0]); 902 else if (resolve_intrin) 903 ffesymbol_resolve_intrin (s); 904 ffesymbol_reference (s, NULL, FALSE); 905 ffestorag_exec_layout (s); 906 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 907 } 908 909 return s; 910 } 911 912 /* ffestu_list_exec_transition_ -- Update SYMTERs in ITEM list w/in symbol 913 914 ffebld list; 915 ffestu_list_exec_transition_(list); 916 917 list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and 918 other things, too, but we'll ignore the known ones). For each SYMTER, 919 we run sym_exec_transition_ on the corresponding ffesymbol (a recursive 920 call, since that's the function that's calling us) to update it's 921 information. Then we copy that information into the SYMTER. 922 923 Make sure we don't get called recursively ourselves! */ 924 925 static void 926 ffestu_list_exec_transition_ (ffebld list) 927 { 928 static bool in_progress = FALSE; 929 ffebld item; 930 ffesymbol symbol; 931 932 assert (!in_progress); 933 in_progress = TRUE; 934 935 for (; list != NULL; list = ffebld_trail (list)) 936 { 937 if ((item = ffebld_head (list)) == NULL) 938 continue; /* Try next item. */ 939 940 switch (ffebld_op (item)) 941 { 942 case FFEBLD_opSTAR: 943 break; 944 945 case FFEBLD_opSYMTER: 946 symbol = ffebld_symter (item); 947 if (symbol == NULL) 948 break; /* Detached from stmt func dummy list. */ 949 symbol = ffecom_sym_exec_transition (symbol); 950 assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE); 951 assert (ffesymbol_where (symbol) != FFEINFO_whereNONE); 952 ffebld_set_info (item, ffesymbol_info (symbol)); 953 break; 954 955 default: 956 assert ("Unexpected item on list" == NULL); 957 break; 958 } 959 } 960 961 in_progress = FALSE; 962 } 963 964 /* ffestu_symter_end_transition_ -- Update SYMTERs in expr w/in symbol 965 966 ffebld expr; 967 ffestu_symter_end_transition_(expr); 968 969 Any SYMTER in expr's tree with whereNONE gets updated to the 970 (recursively transitioned) sym it identifies (DUMMY or COMMON). */ 971 972 static bool 973 ffestu_symter_end_transition_ (ffebld expr) 974 { 975 ffesymbol symbol; 976 bool any = FALSE; 977 978 /* Label used for tail recursion (reset expr and go here instead of calling 979 self). */ 980 981 tail: /* :::::::::::::::::::: */ 982 983 if (expr == NULL) 984 return any; 985 986 switch (ffebld_op (expr)) 987 { 988 case FFEBLD_opITEM: 989 while (ffebld_trail (expr) != NULL) 990 { 991 if (ffestu_symter_end_transition_ (ffebld_head (expr))) 992 any = TRUE; 993 expr = ffebld_trail (expr); 994 } 995 expr = ffebld_head (expr); 996 goto tail; /* :::::::::::::::::::: */ 997 998 case FFEBLD_opSYMTER: 999 symbol = ffecom_sym_end_transition (ffebld_symter (expr)); 1000 if ((symbol != NULL) 1001 && ffesymbol_attr (symbol, FFESYMBOL_attrANY)) 1002 any = TRUE; 1003 ffebld_set_info (expr, ffesymbol_info (symbol)); 1004 break; 1005 1006 case FFEBLD_opANY: 1007 return TRUE; 1008 1009 default: 1010 break; 1011 } 1012 1013 switch (ffebld_arity (expr)) 1014 { 1015 case 2: 1016 if (ffestu_symter_end_transition_ (ffebld_left (expr))) 1017 any = TRUE; 1018 expr = ffebld_right (expr); 1019 goto tail; /* :::::::::::::::::::: */ 1020 1021 case 1: 1022 expr = ffebld_left (expr); 1023 goto tail; /* :::::::::::::::::::: */ 1024 1025 default: 1026 break; 1027 } 1028 1029 return any; 1030 } 1031 1032 /* ffestu_symter_exec_transition_ -- Update SYMTERs in expr w/in symbol 1033 1034 ffebld expr; 1035 ffestu_symter_exec_transition_(expr); 1036 1037 Any SYMTER in expr's tree with whereNONE gets updated to the 1038 (recursively transitioned) sym it identifies (DUMMY or COMMON). */ 1039 1040 static bool 1041 ffestu_symter_exec_transition_ (ffebld expr) 1042 { 1043 ffesymbol symbol; 1044 bool any = FALSE; 1045 1046 /* Label used for tail recursion (reset expr and go here instead of calling 1047 self). */ 1048 1049 tail: /* :::::::::::::::::::: */ 1050 1051 if (expr == NULL) 1052 return any; 1053 1054 switch (ffebld_op (expr)) 1055 { 1056 case FFEBLD_opITEM: 1057 while (ffebld_trail (expr) != NULL) 1058 { 1059 if (ffestu_symter_exec_transition_ (ffebld_head (expr))) 1060 any = TRUE; 1061 expr = ffebld_trail (expr); 1062 } 1063 expr = ffebld_head (expr); 1064 goto tail; /* :::::::::::::::::::: */ 1065 1066 case FFEBLD_opSYMTER: 1067 symbol = ffecom_sym_exec_transition (ffebld_symter (expr)); 1068 if ((symbol != NULL) 1069 && ffesymbol_attr (symbol, FFESYMBOL_attrANY)) 1070 any = TRUE; 1071 ffebld_set_info (expr, ffesymbol_info (symbol)); 1072 break; 1073 1074 case FFEBLD_opANY: 1075 return TRUE; 1076 1077 default: 1078 break; 1079 } 1080 1081 switch (ffebld_arity (expr)) 1082 { 1083 case 2: 1084 if (ffestu_symter_exec_transition_ (ffebld_left (expr))) 1085 any = TRUE; 1086 expr = ffebld_right (expr); 1087 goto tail; /* :::::::::::::::::::: */ 1088 1089 case 1: 1090 expr = ffebld_left (expr); 1091 goto tail; /* :::::::::::::::::::: */ 1092 1093 default: 1094 break; 1095 } 1096 1097 return any; 1098 } 1099 1100 /* ffestu_dummies_transition_ -- Update SYMTERs in ITEM list w/in entry 1101 1102 ffebld list; 1103 ffesymbol symfunc(ffesymbol s); 1104 if (ffestu_dummies_transition_(symfunc,list)) 1105 // One or more items are still UNCERTAIN. 1106 1107 list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and 1108 other things, too, but we'll ignore the known ones). For each SYMTER, 1109 we run symfunc on the corresponding ffesymbol (a recursive 1110 call, since that's the function that's calling us) to update it's 1111 information. Then we copy that information into the SYMTER. 1112 1113 Return TRUE if any of the SYMTER's has incomplete information. 1114 1115 Make sure we don't get called recursively ourselves! */ 1116 1117 static bool 1118 ffestu_dummies_transition_ (ffesymbol (*symfunc) (ffesymbol), ffebld list) 1119 { 1120 static bool in_progress = FALSE; 1121 ffebld item; 1122 ffesymbol symbol; 1123 bool uncertain = FALSE; 1124 1125 assert (!in_progress); 1126 in_progress = TRUE; 1127 1128 for (; list != NULL; list = ffebld_trail (list)) 1129 { 1130 if ((item = ffebld_head (list)) == NULL) 1131 continue; /* Try next item. */ 1132 1133 switch (ffebld_op (item)) 1134 { 1135 case FFEBLD_opSTAR: 1136 break; 1137 1138 case FFEBLD_opSYMTER: 1139 symbol = ffebld_symter (item); 1140 if (symbol == NULL) 1141 break; /* Detached from stmt func dummy list. */ 1142 symbol = (*symfunc) (symbol); 1143 if (ffesymbol_state (symbol) == FFESYMBOL_stateUNCERTAIN) 1144 uncertain = TRUE; 1145 else 1146 { 1147 assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE); 1148 assert (ffesymbol_where (symbol) != FFEINFO_whereNONE); 1149 } 1150 ffebld_set_info (item, ffesymbol_info (symbol)); 1151 break; 1152 1153 default: 1154 assert ("Unexpected item on list" == NULL); 1155 break; 1156 } 1157 } 1158 1159 in_progress = FALSE; 1160 1161 return uncertain; 1162 } 1163