1/* stc.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 st.c 24 25 Description: 26 Verifies the proper semantics for statements, checking expressions already 27 semantically analyzed individually, collectively, checking label defs and 28 refs, and so on. Uses ffebad to indicate errors in semantics. 29 30 In many cases, both a token and a keyword (ffestrFirst, ffestrSecond, 31 or ffestrOther) is provided. ONLY USE THE TOKEN as a pointer to the 32 source-code location for an error message or similar; use the keyword 33 as the semantic matching for the token, since the token's text might 34 not match the keyword's code. For example, INTENT(IN OUT) A in free 35 source form passes to ffestc_R519_start the token "IN" but the keyword 36 FFESTR_otherINOUT, and the latter is correct. 37 38 Generally, either a single ffestc function handles an entire statement, 39 in which case its name is ffestc_xyz_, or more than one function is 40 needed, in which case its names are ffestc_xyz_start_, 41 ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_. 42 The caller must call _start_ before calling any _item_ functions, and 43 must call _finish_ afterwards. If it is clearly a syntactic matter as 44 to restrictions on the number and variety of _item_ calls, then the caller 45 should report any errors and ffestc_ should presume it has been taken 46 care of and handle any semantic problems with grace and no error messages. 47 If the permitted number and variety of _item_ calls has some basis in 48 semantics, then the caller should not generate any messages and ffestc 49 should do all the checking. 50 51 A few ffestc functions have names rather than grammar numbers, like 52 ffestc_elsewhere and ffestc_end. These are cases where the actual 53 statement depends on its context rather than just its form; ELSE WHERE 54 may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little 55 more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE). The actual 56 ffestc functions do exist and do work, but may or may not be invoked 57 by ffestb depending on whether some form of resolution is possible. 58 For example, ffestc_R1103 end-program-stmt is reachable directly when 59 END PROGRAM [name] is specified, or via ffestc_end when END is specified 60 and the context is a main program. So ffestc_xyz_ should make a quick 61 determination of the context and pick the appropriate ffestc_Nxyz_ 62 function to invoke, without a lot of ceremony. 63 64 Modifications: 65*/ 66 67/* Include files. */ 68 69#include "proj.h" 70#include "stc.h" 71#include "bad.h" 72#include "bld.h" 73#include "data.h" 74#include "expr.h" 75#include "global.h" 76#include "implic.h" 77#include "lex.h" 78#include "malloc.h" 79#include "src.h" 80#include "sta.h" 81#include "std.h" 82#include "stp.h" 83#include "str.h" 84#include "stt.h" 85#include "stw.h" 86 87/* Externals defined here. */ 88 89ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST; 90/* Valid only from READ/WRITE start to finish. */ 91 92/* Simple definitions and enumerations. */ 93 94typedef enum 95 { 96 FFESTC_orderOK_, /* Statement ok in this context, process. */ 97 FFESTC_orderBAD_, /* Statement not ok in this context, don't 98 process. */ 99 FFESTC_orderBADOK_, /* Don't process but push block if 100 applicable. */ 101 FFESTC 102 } ffestcOrder_; 103 104typedef enum 105 { 106 FFESTC_stateletSIMPLE_, /* Expecting simple/start. */ 107 FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ 108 FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */ 109 FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ 110 FFESTC_ 111 } ffestcStatelet_; 112 113/* Internal typedefs. */ 114 115 116/* Private include files. */ 117 118 119/* Internal structure definitions. */ 120 121union ffestc_local_u_ 122 { 123 struct 124 { 125 ffebld initlist; /* For list of one sym in INTEGER I/3/ case. */ 126 ffetargetCharacterSize stmt_size; 127 ffetargetCharacterSize size; 128 ffeinfoBasictype basic_type; 129 ffeinfoKindtype stmt_kind_type; 130 ffeinfoKindtype kind_type; 131 bool per_var_kind_ok; 132 char is_R426; /* 1=R426, 2=R501. */ 133 } 134 decl; 135 struct 136 { 137 ffebld objlist; /* For list of target objects. */ 138 ffebldListBottom list_bottom; /* For building lists. */ 139 } 140 data; 141 struct 142 { 143 ffebldListBottom list_bottom; /* For building lists. */ 144 int entry_num; 145 } 146 dummy; 147 struct 148 { 149 ffesymbol symbol; /* NML symbol. */ 150 } 151 namelist; 152 struct 153 { 154 ffelexToken t; /* First token in list. */ 155 ffeequiv eq; /* Current equivalence being built up. */ 156 ffebld list; /* List of expressions in equivalence. */ 157 ffebldListBottom bottom; 158 bool ok; /* TRUE while current list still being 159 processed. */ 160 bool save; /* TRUE if any var in list is SAVEd. */ 161 } 162 equiv; 163 struct 164 { 165 ffesymbol symbol; /* BCB/NCB symbol. */ 166 } 167 common; 168 struct 169 { 170 ffesymbol symbol; /* SFN symbol. */ 171 } 172 sfunc; 173#if FFESTR_VXT 174 struct 175 { 176 char list_state; /* 0=>no field names allowed, 1=>error 177 reported already, 2=>field names req'd, 178 3=>have a field name. */ 179 } 180 V003; 181#endif 182 }; /* Merge with the one in ffestc later. */ 183 184/* Static objects accessed by functions in this module. */ 185 186static bool ffestc_ok_; /* _start_ fn's send this to _xyz_ fn's. */ 187static bool ffestc_parent_ok_; /* Parent sym for baby sym fn's ok. */ 188static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */ 189static union ffestc_local_u_ ffestc_local_; 190static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_; 191static ffestwShriek ffestc_shriek_after1_ = NULL; 192static unsigned long ffestc_blocknum_ = 0; /* Next block# to assign. */ 193static int ffestc_entry_num_; 194static int ffestc_sfdummy_argno_; 195static int ffestc_saved_entry_num_; 196static ffelab ffestc_label_; 197 198/* Static functions (internal). */ 199 200static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t); 201static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, 202 ffebld len, ffelexToken lent); 203static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, 204 ffebld kind, ffelexToken kindt, 205 ffebld len, ffelexToken lent); 206static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last); 207static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt, 208 ffetargetCharacterSize val); 209static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt, 210 ffetargetCharacterSize val); 211static void ffestc_labeldef_any_ (void); 212static bool ffestc_labeldef_begin_ (void); 213static void ffestc_labeldef_branch_begin_ (void); 214static void ffestc_labeldef_branch_end_ (void); 215static void ffestc_labeldef_endif_ (void); 216static void ffestc_labeldef_format_ (void); 217static void ffestc_labeldef_invalid_ (void); 218static void ffestc_labeldef_notloop_ (void); 219static void ffestc_labeldef_notloop_begin_ (void); 220static void ffestc_labeldef_useless_ (void); 221static bool ffestc_labelref_is_assignable_ (ffelexToken label_token, 222 ffelab *label); 223static bool ffestc_labelref_is_branch_ (ffelexToken label_token, 224 ffelab *label); 225static bool ffestc_labelref_is_format_ (ffelexToken label_token, 226 ffelab *label); 227static bool ffestc_labelref_is_loopend_ (ffelexToken label_token, 228 ffelab *label); 229#if FFESTR_F90 230static ffestcOrder_ ffestc_order_access_ (void); 231#endif 232static ffestcOrder_ ffestc_order_actiondo_ (void); 233static ffestcOrder_ ffestc_order_actionif_ (void); 234static ffestcOrder_ ffestc_order_actionwhere_ (void); 235static void ffestc_order_any_ (void); 236static void ffestc_order_bad_ (void); 237static ffestcOrder_ ffestc_order_blockdata_ (void); 238static ffestcOrder_ ffestc_order_blockspec_ (void); 239#if FFESTR_F90 240static ffestcOrder_ ffestc_order_component_ (void); 241#endif 242#if FFESTR_F90 243static ffestcOrder_ ffestc_order_contains_ (void); 244#endif 245static ffestcOrder_ ffestc_order_data_ (void); 246static ffestcOrder_ ffestc_order_data77_ (void); 247#if FFESTR_F90 248static ffestcOrder_ ffestc_order_derivedtype_ (void); 249#endif 250static ffestcOrder_ ffestc_order_do_ (void); 251static ffestcOrder_ ffestc_order_entry_ (void); 252static ffestcOrder_ ffestc_order_exec_ (void); 253static ffestcOrder_ ffestc_order_format_ (void); 254static ffestcOrder_ ffestc_order_function_ (void); 255static ffestcOrder_ ffestc_order_iface_ (void); 256static ffestcOrder_ ffestc_order_ifthen_ (void); 257static ffestcOrder_ ffestc_order_implicit_ (void); 258static ffestcOrder_ ffestc_order_implicitnone_ (void); 259#if FFESTR_F90 260static ffestcOrder_ ffestc_order_interface_ (void); 261#endif 262#if FFESTR_F90 263static ffestcOrder_ ffestc_order_map_ (void); 264#endif 265#if FFESTR_F90 266static ffestcOrder_ ffestc_order_module_ (void); 267#endif 268static ffestcOrder_ ffestc_order_parameter_ (void); 269static ffestcOrder_ ffestc_order_program_ (void); 270static ffestcOrder_ ffestc_order_progspec_ (void); 271#if FFESTR_F90 272static ffestcOrder_ ffestc_order_record_ (void); 273#endif 274static ffestcOrder_ ffestc_order_selectcase_ (void); 275static ffestcOrder_ ffestc_order_sfunc_ (void); 276#if FFESTR_F90 277static ffestcOrder_ ffestc_order_spec_ (void); 278#endif 279#if FFESTR_VXT 280static ffestcOrder_ ffestc_order_structure_ (void); 281#endif 282static ffestcOrder_ ffestc_order_subroutine_ (void); 283#if FFESTR_F90 284static ffestcOrder_ ffestc_order_type_ (void); 285#endif 286static ffestcOrder_ ffestc_order_typedecl_ (void); 287#if FFESTR_VXT 288static ffestcOrder_ ffestc_order_union_ (void); 289#endif 290static ffestcOrder_ ffestc_order_unit_ (void); 291#if FFESTR_F90 292static ffestcOrder_ ffestc_order_use_ (void); 293#endif 294#if FFESTR_VXT 295static ffestcOrder_ ffestc_order_vxtstructure_ (void); 296#endif 297#if FFESTR_F90 298static ffestcOrder_ ffestc_order_where_ (void); 299#endif 300static void ffestc_promote_dummy_ (ffelexToken t); 301static void ffestc_promote_execdummy_ (ffelexToken t); 302static void ffestc_promote_sfdummy_ (ffelexToken t); 303static void ffestc_shriek_begin_program_ (void); 304#if FFESTR_F90 305static void ffestc_shriek_begin_uses_ (void); 306#endif 307static void ffestc_shriek_blockdata_ (bool ok); 308static void ffestc_shriek_do_ (bool ok); 309static void ffestc_shriek_end_program_ (bool ok); 310#if FFESTR_F90 311static void ffestc_shriek_end_uses_ (bool ok); 312#endif 313static void ffestc_shriek_function_ (bool ok); 314static void ffestc_shriek_if_ (bool ok); 315static void ffestc_shriek_ifthen_ (bool ok); 316#if FFESTR_F90 317static void ffestc_shriek_interface_ (bool ok); 318#endif 319#if FFESTR_F90 320static void ffestc_shriek_map_ (bool ok); 321#endif 322#if FFESTR_F90 323static void ffestc_shriek_module_ (bool ok); 324#endif 325static void ffestc_shriek_select_ (bool ok); 326#if FFESTR_VXT 327static void ffestc_shriek_structure_ (bool ok); 328#endif 329static void ffestc_shriek_subroutine_ (bool ok); 330#if FFESTR_F90 331static void ffestc_shriek_type_ (bool ok); 332#endif 333#if FFESTR_VXT 334static void ffestc_shriek_union_ (bool ok); 335#endif 336#if FFESTR_F90 337static void ffestc_shriek_where_ (bool ok); 338#endif 339#if FFESTR_F90 340static void ffestc_shriek_wherethen_ (bool ok); 341#endif 342static int ffestc_subr_binsrch_ (const char **list, int size, ffestpFile *spec, 343 const char *whine); 344static ffestvFormat ffestc_subr_format_ (ffestpFile *spec); 345static bool ffestc_subr_is_branch_ (ffestpFile *spec); 346static bool ffestc_subr_is_format_ (ffestpFile *spec); 347static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec); 348static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, 349 const char **target, int *length); 350static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec); 351static void ffestc_try_shriek_do_ (void); 352 353/* Internal macros. */ 354 355#define ffestc_check_simple_() \ 356 assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_) 357#define ffestc_check_start_() \ 358 assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \ 359 ffestc_statelet_ = FFESTC_stateletATTRIB_ 360#define ffestc_check_attrib_() \ 361 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_) 362#define ffestc_check_item_() \ 363 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ 364 || ffestc_statelet_ == FFESTC_stateletITEM_); \ 365 ffestc_statelet_ = FFESTC_stateletITEM_ 366#define ffestc_check_item_startvals_() \ 367 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ 368 || ffestc_statelet_ == FFESTC_stateletITEM_); \ 369 ffestc_statelet_ = FFESTC_stateletITEMVALS_ 370#define ffestc_check_item_value_() \ 371 assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_) 372#define ffestc_check_item_endvals_() \ 373 assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \ 374 ffestc_statelet_ = FFESTC_stateletITEM_ 375#define ffestc_check_finish_() \ 376 assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ 377 || ffestc_statelet_ == FFESTC_stateletITEM_); \ 378 ffestc_statelet_ = FFESTC_stateletSIMPLE_ 379#define ffestc_order_action_() ffestc_order_exec_() 380#if FFESTR_F90 381#define ffestc_order_interfacespec_() ffestc_order_derivedtype_() 382#endif 383#define ffestc_shriek_if_lost_ ffestc_shriek_if_ 384#if FFESTR_F90 385#define ffestc_shriek_where_lost_ ffestc_shriek_where_ 386#endif 387 388/* ffestc_establish_declinfo_ -- Determine specific type/params info for entity 389 390 ffestc_establish_declinfo_(kind,kind_token,len,len_token); 391 392 Must be called after _declstmt_ called to establish base type. */ 393 394static void 395ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len, 396 ffelexToken lent) 397{ 398 ffeinfoBasictype bt = ffestc_local_.decl.basic_type; 399 ffeinfoKindtype kt; 400 ffetargetCharacterSize val; 401 402 if (kindt == NULL) 403 kt = ffestc_local_.decl.stmt_kind_type; 404 else if (!ffestc_local_.decl.per_var_kind_ok) 405 { 406 ffebad_start (FFEBAD_KINDTYPE); 407 ffebad_here (0, ffelex_token_where_line (kindt), 408 ffelex_token_where_column (kindt)); 409 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), 410 ffelex_token_where_column (ffesta_tokens[0])); 411 ffebad_finish (); 412 kt = ffestc_local_.decl.stmt_kind_type; 413 } 414 else 415 { 416 if (kind == NULL) 417 { 418 assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); 419 val = atol (ffelex_token_text (kindt)); 420 kt = ffestc_kindtype_star_ (bt, val); 421 } 422 else if (ffebld_op (kind) == FFEBLD_opANY) 423 kt = ffestc_local_.decl.stmt_kind_type; 424 else 425 { 426 assert (ffebld_op (kind) == FFEBLD_opCONTER); 427 assert (ffeinfo_basictype (ffebld_info (kind)) 428 == FFEINFO_basictypeINTEGER); 429 assert (ffeinfo_kindtype (ffebld_info (kind)) 430 == FFEINFO_kindtypeINTEGERDEFAULT); 431 val = ffebld_constant_integerdefault (ffebld_conter (kind)); 432 kt = ffestc_kindtype_kind_ (bt, val); 433 } 434 435 if (kt == FFEINFO_kindtypeNONE) 436 { /* Not valid kind type. */ 437 ffebad_start (FFEBAD_KINDTYPE); 438 ffebad_here (0, ffelex_token_where_line (kindt), 439 ffelex_token_where_column (kindt)); 440 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), 441 ffelex_token_where_column (ffesta_tokens[0])); 442 ffebad_finish (); 443 kt = ffestc_local_.decl.stmt_kind_type; 444 } 445 } 446 447 ffestc_local_.decl.kind_type = kt; 448 449 /* Now check length specification for CHARACTER data type. */ 450 451 if (((len == NULL) && (lent == NULL)) 452 || (bt != FFEINFO_basictypeCHARACTER)) 453 val = ffestc_local_.decl.stmt_size; 454 else 455 { 456 if (len == NULL) 457 { 458 assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); 459 val = atol (ffelex_token_text (lent)); 460 } 461 else if (ffebld_op (len) == FFEBLD_opSTAR) 462 val = FFETARGET_charactersizeNONE; 463 else if (ffebld_op (len) == FFEBLD_opANY) 464 val = FFETARGET_charactersizeNONE; 465 else 466 { 467 assert (ffebld_op (len) == FFEBLD_opCONTER); 468 assert (ffeinfo_basictype (ffebld_info (len)) 469 == FFEINFO_basictypeINTEGER); 470 assert (ffeinfo_kindtype (ffebld_info (len)) 471 == FFEINFO_kindtypeINTEGERDEFAULT); 472 val = ffebld_constant_integerdefault (ffebld_conter (len)); 473 } 474 } 475 476 if ((val == 0) && !(0 && ffe_is_90 ())) 477 { 478 val = 1; 479 ffebad_start (FFEBAD_ZERO_SIZE); 480 ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); 481 ffebad_finish (); 482 } 483 ffestc_local_.decl.size = val; 484} 485 486/* ffestc_establish_declstmt_ -- Establish host-specific type/params info 487 488 ffestc_establish_declstmt_(type,type_token,kind,kind_token,len, 489 len_token); */ 490 491static void 492ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind, 493 ffelexToken kindt, ffebld len, ffelexToken lent) 494{ 495 ffeinfoBasictype bt; 496 ffeinfoKindtype ktd; /* Default kindtype. */ 497 ffeinfoKindtype kt; 498 ffetargetCharacterSize val; 499 bool per_var_kind_ok = TRUE; 500 501 /* Determine basictype and default kindtype. */ 502 503 switch (type) 504 { 505 case FFESTP_typeINTEGER: 506 bt = FFEINFO_basictypeINTEGER; 507 ktd = FFEINFO_kindtypeINTEGERDEFAULT; 508 break; 509 510 case FFESTP_typeBYTE: 511 bt = FFEINFO_basictypeINTEGER; 512 ktd = FFEINFO_kindtypeINTEGER2; 513 break; 514 515 case FFESTP_typeWORD: 516 bt = FFEINFO_basictypeINTEGER; 517 ktd = FFEINFO_kindtypeINTEGER3; 518 break; 519 520 case FFESTP_typeREAL: 521 bt = FFEINFO_basictypeREAL; 522 ktd = FFEINFO_kindtypeREALDEFAULT; 523 break; 524 525 case FFESTP_typeCOMPLEX: 526 bt = FFEINFO_basictypeCOMPLEX; 527 ktd = FFEINFO_kindtypeREALDEFAULT; 528 break; 529 530 case FFESTP_typeLOGICAL: 531 bt = FFEINFO_basictypeLOGICAL; 532 ktd = FFEINFO_kindtypeLOGICALDEFAULT; 533 break; 534 535 case FFESTP_typeCHARACTER: 536 bt = FFEINFO_basictypeCHARACTER; 537 ktd = FFEINFO_kindtypeCHARACTERDEFAULT; 538 break; 539 540 case FFESTP_typeDBLPRCSN: 541 bt = FFEINFO_basictypeREAL; 542 ktd = FFEINFO_kindtypeREALDOUBLE; 543 per_var_kind_ok = FALSE; 544 break; 545 546 case FFESTP_typeDBLCMPLX: 547 bt = FFEINFO_basictypeCOMPLEX; 548#if FFETARGET_okCOMPLEX2 549 ktd = FFEINFO_kindtypeREALDOUBLE; 550#else 551 ktd = FFEINFO_kindtypeREALDEFAULT; 552 ffebad_start (FFEBAD_BAD_DBLCMPLX); 553 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 554 ffelex_token_where_column (ffesta_tokens[0])); 555 ffebad_finish (); 556#endif 557 per_var_kind_ok = FALSE; 558 break; 559 560 default: 561 assert ("Unexpected type (F90 TYPE?)!" == NULL); 562 bt = FFEINFO_basictypeNONE; 563 ktd = FFEINFO_kindtypeNONE; 564 break; 565 } 566 567 if (kindt == NULL) 568 kt = ktd; 569 else 570 { /* Not necessarily default kind type. */ 571 if (kind == NULL) 572 { /* Shouldn't happen for CHARACTER. */ 573 assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); 574 val = atol (ffelex_token_text (kindt)); 575 kt = ffestc_kindtype_star_ (bt, val); 576 } 577 else if (ffebld_op (kind) == FFEBLD_opANY) 578 kt = ktd; 579 else 580 { 581 assert (ffebld_op (kind) == FFEBLD_opCONTER); 582 assert (ffeinfo_basictype (ffebld_info (kind)) 583 == FFEINFO_basictypeINTEGER); 584 assert (ffeinfo_kindtype (ffebld_info (kind)) 585 == FFEINFO_kindtypeINTEGERDEFAULT); 586 val = ffebld_constant_integerdefault (ffebld_conter (kind)); 587 kt = ffestc_kindtype_kind_ (bt, val); 588 } 589 590 if (kt == FFEINFO_kindtypeNONE) 591 { /* Not valid kind type. */ 592 ffebad_start (FFEBAD_KINDTYPE); 593 ffebad_here (0, ffelex_token_where_line (kindt), 594 ffelex_token_where_column (kindt)); 595 ffebad_here (1, ffelex_token_where_line (typet), 596 ffelex_token_where_column (typet)); 597 ffebad_finish (); 598 kt = ktd; 599 } 600 } 601 602 ffestc_local_.decl.basic_type = bt; 603 ffestc_local_.decl.stmt_kind_type = kt; 604 ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok; 605 606 /* Now check length specification for CHARACTER data type. */ 607 608 if (((len == NULL) && (lent == NULL)) 609 || (type != FFESTP_typeCHARACTER)) 610 val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE; 611 else 612 { 613 if (len == NULL) 614 { 615 assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); 616 val = atol (ffelex_token_text (lent)); 617 } 618 else if (ffebld_op (len) == FFEBLD_opSTAR) 619 val = FFETARGET_charactersizeNONE; 620 else if (ffebld_op (len) == FFEBLD_opANY) 621 val = FFETARGET_charactersizeNONE; 622 else 623 { 624 assert (ffebld_op (len) == FFEBLD_opCONTER); 625 assert (ffeinfo_basictype (ffebld_info (len)) 626 == FFEINFO_basictypeINTEGER); 627 assert (ffeinfo_kindtype (ffebld_info (len)) 628 == FFEINFO_kindtypeINTEGERDEFAULT); 629 val = ffebld_constant_integerdefault (ffebld_conter (len)); 630 } 631 } 632 633 if ((val == 0) && !(0 && ffe_is_90 ())) 634 { 635 val = 1; 636 ffebad_start (FFEBAD_ZERO_SIZE); 637 ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); 638 ffebad_finish (); 639 } 640 ffestc_local_.decl.stmt_size = val; 641} 642 643/* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s) 644 645 ffestc_establish_impletter_(first_letter_token,last_letter_token); */ 646 647static void 648ffestc_establish_impletter_ (ffelexToken first, ffelexToken last) 649{ 650 bool ok = FALSE; /* Stays FALSE if first letter > last. */ 651 char c; 652 653 if (last == NULL) 654 ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)), 655 ffestc_local_.decl.basic_type, 656 ffestc_local_.decl.kind_type, 657 ffestc_local_.decl.size); 658 else 659 { 660 for (c = *(ffelex_token_text (first)); 661 c <= *(ffelex_token_text (last)); 662 c++) 663 { 664 ok = ffeimplic_establish_initial (c, 665 ffestc_local_.decl.basic_type, 666 ffestc_local_.decl.kind_type, 667 ffestc_local_.decl.size); 668 if (!ok) 669 break; 670 } 671 } 672 673 if (!ok) 674 { 675 char cs[2]; 676 677 cs[0] = c; 678 cs[1] = '\0'; 679 680 ffebad_start (FFEBAD_BAD_IMPLICIT); 681 ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first)); 682 ffebad_string (cs); 683 ffebad_finish (); 684 } 685} 686 687/* ffestc_init_3 -- Initialize ffestc for new program unit 688 689 ffestc_init_3(); */ 690 691void 692ffestc_init_3 () 693{ 694 ffestv_save_state_ = FFESTV_savestateNONE; 695 ffestc_entry_num_ = 0; 696 ffestv_num_label_defines_ = 0; 697} 698 699/* ffestc_init_4 -- Initialize ffestc for new scoping unit 700 701 ffestc_init_4(); 702 703 For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE- 704 defs, and statement function defs. */ 705 706void 707ffestc_init_4 () 708{ 709 ffestc_saved_entry_num_ = ffestc_entry_num_; 710 ffestc_entry_num_ = 0; 711} 712 713/* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value 714 715 ffeinfoKindtype kt; 716 ffeinfoBasictype bt; 717 ffetargetCharacterSize val; 718 kt = ffestc_kindtype_kind_(bt,val); 719 if (kt == FFEINFO_kindtypeNONE) 720 // unsupported/invalid KIND= value for type */ 721 722static ffeinfoKindtype 723ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val) 724{ 725 ffetype type; 726 ffetype base_type; 727 ffeinfoKindtype kt; 728 729 base_type = ffeinfo_type (bt, 1); /* ~~ */ 730 assert (base_type != NULL); 731 732 type = ffetype_lookup_kind (base_type, (int) val); 733 if (type == NULL) 734 return FFEINFO_kindtypeNONE; 735 736 for (kt = 1; kt < FFEINFO_kindtype; ++kt) 737 if (ffeinfo_type (bt, kt) == type) 738 return kt; 739 740 return FFEINFO_kindtypeNONE; 741} 742 743/* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value 744 745 ffeinfoKindtype kt; 746 ffeinfoBasictype bt; 747 ffetargetCharacterSize val; 748 kt = ffestc_kindtype_star_(bt,val); 749 if (kt == FFEINFO_kindtypeNONE) 750 // unsupported/invalid * value for type */ 751 752static ffeinfoKindtype 753ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val) 754{ 755 ffetype type; 756 ffetype base_type; 757 ffeinfoKindtype kt; 758 759 base_type = ffeinfo_type (bt, 1); /* ~~ */ 760 assert (base_type != NULL); 761 762 type = ffetype_lookup_star (base_type, (int) val); 763 if (type == NULL) 764 return FFEINFO_kindtypeNONE; 765 766 for (kt = 1; kt < FFEINFO_kindtype; ++kt) 767 if (ffeinfo_type (bt, kt) == type) 768 return kt; 769 770 return FFEINFO_kindtypeNONE; 771} 772 773/* Define label as usable for anything without complaint. */ 774 775static void 776ffestc_labeldef_any_ () 777{ 778 if ((ffesta_label_token == NULL) 779 || !ffestc_labeldef_begin_ ()) 780 return; 781 782 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 783 ffestd_labeldef_any (ffestc_label_); 784 785 ffestc_labeldef_branch_end_ (); 786} 787 788/* ffestc_labeldef_begin_ -- Define label as unknown, initially 789 790 ffestc_labeldef_begin_(); */ 791 792static bool 793ffestc_labeldef_begin_ () 794{ 795 ffelabValue label_value; 796 ffelab label; 797 798 label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token)); 799 if ((label_value == 0) || (label_value > FFELAB_valueMAX)) 800 { 801 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); 802 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 803 ffelex_token_where_column (ffesta_label_token)); 804 ffebad_finish (); 805 } 806 807 label = ffelab_find (label_value); 808 if (label == NULL) 809 { 810 label = ffestc_label_ = ffelab_new (label_value); 811 ffestv_num_label_defines_++; 812 ffelab_set_definition_line (label, 813 ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); 814 ffelab_set_definition_column (label, 815 ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); 816 817 return TRUE; 818 } 819 820 if (ffewhere_line_is_unknown (ffelab_definition_line (label))) 821 { 822 ffestv_num_label_defines_++; 823 ffestc_label_ = label; 824 ffelab_set_definition_line (label, 825 ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); 826 ffelab_set_definition_column (label, 827 ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); 828 829 return TRUE; 830 } 831 832 ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED); 833 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 834 ffelex_token_where_column (ffesta_label_token)); 835 ffebad_here (1, ffelab_definition_line (label), 836 ffelab_definition_column (label)); 837 ffebad_string (ffelex_token_text (ffesta_label_token)); 838 ffebad_finish (); 839 840 ffelex_token_kill (ffesta_label_token); 841 ffesta_label_token = NULL; 842 return FALSE; 843} 844 845/* ffestc_labeldef_branch_begin_ -- Define label as a branch target one 846 847 ffestc_labeldef_branch_begin_(); */ 848 849static void 850ffestc_labeldef_branch_begin_ () 851{ 852 if ((ffesta_label_token == NULL) 853 || (ffestc_shriek_after1_ != NULL) 854 || !ffestc_labeldef_begin_ ()) 855 return; 856 857 switch (ffelab_type (ffestc_label_)) 858 { 859 case FFELAB_typeUNKNOWN: 860 case FFELAB_typeASSIGNABLE: 861 ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); 862 ffelab_set_blocknum (ffestc_label_, 863 ffestw_blocknum (ffestw_stack_top ())); 864 ffestd_labeldef_branch (ffestc_label_); 865 break; 866 867 case FFELAB_typeNOTLOOP: 868 if (ffelab_blocknum (ffestc_label_) 869 < ffestw_blocknum (ffestw_stack_top ())) 870 { 871 ffebad_start (FFEBAD_LABEL_BLOCK); 872 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 873 ffelex_token_where_column (ffesta_label_token)); 874 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 875 ffelab_firstref_column (ffestc_label_)); 876 ffebad_finish (); 877 } 878 ffelab_set_blocknum (ffestc_label_, 879 ffestw_blocknum (ffestw_stack_top ())); 880 ffestd_labeldef_branch (ffestc_label_); 881 break; 882 883 case FFELAB_typeLOOPEND: 884 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 885 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) 886 { /* Unterminated block. */ 887 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 888 ffestd_labeldef_any (ffestc_label_); 889 890 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); 891 ffebad_here (0, ffelab_doref_line (ffestc_label_), 892 ffelab_doref_column (ffestc_label_)); 893 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 894 ffebad_here (2, ffelex_token_where_line (ffesta_label_token), 895 ffelex_token_where_column (ffesta_label_token)); 896 ffebad_finish (); 897 break; 898 } 899 ffestd_labeldef_branch (ffestc_label_); 900 /* Leave something around for _branch_end_() to handle. */ 901 return; 902 903 case FFELAB_typeFORMAT: 904 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 905 ffestd_labeldef_any (ffestc_label_); 906 907 ffebad_start (FFEBAD_LABEL_USE_DEF); 908 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 909 ffelex_token_where_column (ffesta_label_token)); 910 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 911 ffelab_firstref_column (ffestc_label_)); 912 ffebad_finish (); 913 break; 914 915 default: 916 assert ("bad label" == NULL); 917 /* Fall through. */ 918 case FFELAB_typeANY: 919 break; 920 } 921 922 ffestc_try_shriek_do_ (); 923 924 ffelex_token_kill (ffesta_label_token); 925 ffesta_label_token = NULL; 926} 927 928/* Define possible end of labeled-DO-loop. Call only after calling 929 ffestc_labeldef_branch_begin_, or when other branch_* functions 930 recognize that a label might also be serving as a branch end (in 931 which case they must issue a diagnostic). */ 932 933static void 934ffestc_labeldef_branch_end_ () 935{ 936 if (ffesta_label_token == NULL) 937 return; 938 939 assert (ffestc_label_ != NULL); 940 assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND) 941 || (ffelab_type (ffestc_label_) == FFELAB_typeANY)); 942 943 while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO) 944 && (ffestw_label (ffestw_stack_top ()) == ffestc_label_)) 945 ffestc_shriek_do_ (TRUE); 946 947 ffestc_try_shriek_do_ (); 948 949 ffelex_token_kill (ffesta_label_token); 950 ffesta_label_token = NULL; 951} 952 953/* ffestc_labeldef_endif_ -- Define label as an END IF one 954 955 ffestc_labeldef_endif_(); */ 956 957static void 958ffestc_labeldef_endif_ () 959{ 960 if ((ffesta_label_token == NULL) 961 || (ffestc_shriek_after1_ != NULL) 962 || !ffestc_labeldef_begin_ ()) 963 return; 964 965 switch (ffelab_type (ffestc_label_)) 966 { 967 case FFELAB_typeUNKNOWN: 968 case FFELAB_typeASSIGNABLE: 969 ffelab_set_type (ffestc_label_, FFELAB_typeENDIF); 970 ffelab_set_blocknum (ffestc_label_, 971 ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); 972 ffestd_labeldef_endif (ffestc_label_); 973 break; 974 975 case FFELAB_typeNOTLOOP: 976 if (ffelab_blocknum (ffestc_label_) 977 < ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))) 978 { 979 ffebad_start (FFEBAD_LABEL_BLOCK); 980 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 981 ffelex_token_where_column (ffesta_label_token)); 982 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 983 ffelab_firstref_column (ffestc_label_)); 984 ffebad_finish (); 985 } 986 ffelab_set_blocknum (ffestc_label_, 987 ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); 988 ffestd_labeldef_endif (ffestc_label_); 989 break; 990 991 case FFELAB_typeLOOPEND: 992 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 993 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) 994 { /* Unterminated block. */ 995 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 996 ffestd_labeldef_any (ffestc_label_); 997 998 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); 999 ffebad_here (0, ffelab_doref_line (ffestc_label_), 1000 ffelab_doref_column (ffestc_label_)); 1001 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 1002 ffebad_here (2, ffelex_token_where_line (ffesta_label_token), 1003 ffelex_token_where_column (ffesta_label_token)); 1004 ffebad_finish (); 1005 break; 1006 } 1007 ffestd_labeldef_endif (ffestc_label_); 1008 ffebad_start (FFEBAD_LABEL_USE_DEF); 1009 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1010 ffelex_token_where_column (ffesta_label_token)); 1011 ffebad_here (1, ffelab_doref_line (ffestc_label_), 1012 ffelab_doref_column (ffestc_label_)); 1013 ffebad_finish (); 1014 ffestc_labeldef_branch_end_ (); 1015 return; 1016 1017 case FFELAB_typeFORMAT: 1018 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1019 ffestd_labeldef_any (ffestc_label_); 1020 1021 ffebad_start (FFEBAD_LABEL_USE_DEF); 1022 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1023 ffelex_token_where_column (ffesta_label_token)); 1024 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1025 ffelab_firstref_column (ffestc_label_)); 1026 ffebad_finish (); 1027 break; 1028 1029 default: 1030 assert ("bad label" == NULL); 1031 /* Fall through. */ 1032 case FFELAB_typeANY: 1033 break; 1034 } 1035 1036 ffestc_try_shriek_do_ (); 1037 1038 ffelex_token_kill (ffesta_label_token); 1039 ffesta_label_token = NULL; 1040} 1041 1042/* ffestc_labeldef_format_ -- Define label as a FORMAT one 1043 1044 ffestc_labeldef_format_(); */ 1045 1046static void 1047ffestc_labeldef_format_ () 1048{ 1049 if ((ffesta_label_token == NULL) 1050 || (ffestc_shriek_after1_ != NULL)) 1051 { 1052 ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF); 1053 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 1054 ffelex_token_where_column (ffesta_tokens[0])); 1055 ffebad_finish (); 1056 return; 1057 } 1058 1059 if (!ffestc_labeldef_begin_ ()) 1060 return; 1061 1062 switch (ffelab_type (ffestc_label_)) 1063 { 1064 case FFELAB_typeUNKNOWN: 1065 case FFELAB_typeASSIGNABLE: 1066 ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT); 1067 ffestd_labeldef_format (ffestc_label_); 1068 break; 1069 1070 case FFELAB_typeFORMAT: 1071 ffestd_labeldef_format (ffestc_label_); 1072 break; 1073 1074 case FFELAB_typeLOOPEND: 1075 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 1076 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) 1077 { /* Unterminated block. */ 1078 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1079 ffestd_labeldef_any (ffestc_label_); 1080 1081 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); 1082 ffebad_here (0, ffelab_doref_line (ffestc_label_), 1083 ffelab_doref_column (ffestc_label_)); 1084 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 1085 ffebad_here (2, ffelex_token_where_line (ffesta_label_token), 1086 ffelex_token_where_column (ffesta_label_token)); 1087 ffebad_finish (); 1088 break; 1089 } 1090 ffestd_labeldef_format (ffestc_label_); 1091 ffebad_start (FFEBAD_LABEL_USE_DEF); 1092 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1093 ffelex_token_where_column (ffesta_label_token)); 1094 ffebad_here (1, ffelab_doref_line (ffestc_label_), 1095 ffelab_doref_column (ffestc_label_)); 1096 ffebad_finish (); 1097 ffestc_labeldef_branch_end_ (); 1098 return; 1099 1100 case FFELAB_typeNOTLOOP: 1101 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1102 ffestd_labeldef_any (ffestc_label_); 1103 1104 ffebad_start (FFEBAD_LABEL_USE_DEF); 1105 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1106 ffelex_token_where_column (ffesta_label_token)); 1107 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1108 ffelab_firstref_column (ffestc_label_)); 1109 ffebad_finish (); 1110 break; 1111 1112 default: 1113 assert ("bad label" == NULL); 1114 /* Fall through. */ 1115 case FFELAB_typeANY: 1116 break; 1117 } 1118 1119 ffestc_try_shriek_do_ (); 1120 1121 ffelex_token_kill (ffesta_label_token); 1122 ffesta_label_token = NULL; 1123} 1124 1125/* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present 1126 1127 ffestc_labeldef_invalid_(); */ 1128 1129static void 1130ffestc_labeldef_invalid_ () 1131{ 1132 if ((ffesta_label_token == NULL) 1133 || (ffestc_shriek_after1_ != NULL) 1134 || !ffestc_labeldef_begin_ ()) 1135 return; 1136 1137 ffebad_start (FFEBAD_INVALID_LABEL_DEF); 1138 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1139 ffelex_token_where_column (ffesta_label_token)); 1140 ffebad_finish (); 1141 1142 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1143 ffestd_labeldef_any (ffestc_label_); 1144 1145 ffestc_try_shriek_do_ (); 1146 1147 ffelex_token_kill (ffesta_label_token); 1148 ffesta_label_token = NULL; 1149} 1150 1151/* Define label as a non-loop-ending one on a statement that can't 1152 be in the "then" part of a logical IF, such as a block-IF statement. */ 1153 1154static void 1155ffestc_labeldef_notloop_ () 1156{ 1157 if (ffesta_label_token == NULL) 1158 return; 1159 1160 assert (ffestc_shriek_after1_ == NULL); 1161 1162 if (!ffestc_labeldef_begin_ ()) 1163 return; 1164 1165 switch (ffelab_type (ffestc_label_)) 1166 { 1167 case FFELAB_typeUNKNOWN: 1168 case FFELAB_typeASSIGNABLE: 1169 ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); 1170 ffelab_set_blocknum (ffestc_label_, 1171 ffestw_blocknum (ffestw_stack_top ())); 1172 ffestd_labeldef_notloop (ffestc_label_); 1173 break; 1174 1175 case FFELAB_typeNOTLOOP: 1176 if (ffelab_blocknum (ffestc_label_) 1177 < ffestw_blocknum (ffestw_stack_top ())) 1178 { 1179 ffebad_start (FFEBAD_LABEL_BLOCK); 1180 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1181 ffelex_token_where_column (ffesta_label_token)); 1182 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1183 ffelab_firstref_column (ffestc_label_)); 1184 ffebad_finish (); 1185 } 1186 ffelab_set_blocknum (ffestc_label_, 1187 ffestw_blocknum (ffestw_stack_top ())); 1188 ffestd_labeldef_notloop (ffestc_label_); 1189 break; 1190 1191 case FFELAB_typeLOOPEND: 1192 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 1193 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) 1194 { /* Unterminated block. */ 1195 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1196 ffestd_labeldef_any (ffestc_label_); 1197 1198 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); 1199 ffebad_here (0, ffelab_doref_line (ffestc_label_), 1200 ffelab_doref_column (ffestc_label_)); 1201 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 1202 ffebad_here (2, ffelex_token_where_line (ffesta_label_token), 1203 ffelex_token_where_column (ffesta_label_token)); 1204 ffebad_finish (); 1205 break; 1206 } 1207 ffestd_labeldef_notloop (ffestc_label_); 1208 ffebad_start (FFEBAD_LABEL_USE_DEF); 1209 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1210 ffelex_token_where_column (ffesta_label_token)); 1211 ffebad_here (1, ffelab_doref_line (ffestc_label_), 1212 ffelab_doref_column (ffestc_label_)); 1213 ffebad_finish (); 1214 ffestc_labeldef_branch_end_ (); 1215 return; 1216 1217 case FFELAB_typeFORMAT: 1218 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1219 ffestd_labeldef_any (ffestc_label_); 1220 1221 ffebad_start (FFEBAD_LABEL_USE_DEF); 1222 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1223 ffelex_token_where_column (ffesta_label_token)); 1224 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1225 ffelab_firstref_column (ffestc_label_)); 1226 ffebad_finish (); 1227 break; 1228 1229 default: 1230 assert ("bad label" == NULL); 1231 /* Fall through. */ 1232 case FFELAB_typeANY: 1233 break; 1234 } 1235 1236 ffestc_try_shriek_do_ (); 1237 1238 ffelex_token_kill (ffesta_label_token); 1239 ffesta_label_token = NULL; 1240} 1241 1242/* Define label as a non-loop-ending one. Use this when it is 1243 possible that the pending label is inhibited because we're in 1244 the midst of a logical-IF, and thus _branch_end_ is going to 1245 be called after the current statement to resolve a potential 1246 loop-ending label. */ 1247 1248static void 1249ffestc_labeldef_notloop_begin_ () 1250{ 1251 if ((ffesta_label_token == NULL) 1252 || (ffestc_shriek_after1_ != NULL) 1253 || !ffestc_labeldef_begin_ ()) 1254 return; 1255 1256 switch (ffelab_type (ffestc_label_)) 1257 { 1258 case FFELAB_typeUNKNOWN: 1259 case FFELAB_typeASSIGNABLE: 1260 ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); 1261 ffelab_set_blocknum (ffestc_label_, 1262 ffestw_blocknum (ffestw_stack_top ())); 1263 ffestd_labeldef_notloop (ffestc_label_); 1264 break; 1265 1266 case FFELAB_typeNOTLOOP: 1267 if (ffelab_blocknum (ffestc_label_) 1268 < ffestw_blocknum (ffestw_stack_top ())) 1269 { 1270 ffebad_start (FFEBAD_LABEL_BLOCK); 1271 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1272 ffelex_token_where_column (ffesta_label_token)); 1273 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1274 ffelab_firstref_column (ffestc_label_)); 1275 ffebad_finish (); 1276 } 1277 ffelab_set_blocknum (ffestc_label_, 1278 ffestw_blocknum (ffestw_stack_top ())); 1279 ffestd_labeldef_notloop (ffestc_label_); 1280 break; 1281 1282 case FFELAB_typeLOOPEND: 1283 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 1284 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) 1285 { /* Unterminated block. */ 1286 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1287 ffestd_labeldef_any (ffestc_label_); 1288 1289 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); 1290 ffebad_here (0, ffelab_doref_line (ffestc_label_), 1291 ffelab_doref_column (ffestc_label_)); 1292 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 1293 ffebad_here (2, ffelex_token_where_line (ffesta_label_token), 1294 ffelex_token_where_column (ffesta_label_token)); 1295 ffebad_finish (); 1296 break; 1297 } 1298 ffestd_labeldef_branch (ffestc_label_); 1299 ffebad_start (FFEBAD_LABEL_USE_DEF); 1300 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1301 ffelex_token_where_column (ffesta_label_token)); 1302 ffebad_here (1, ffelab_doref_line (ffestc_label_), 1303 ffelab_doref_column (ffestc_label_)); 1304 ffebad_finish (); 1305 return; 1306 1307 case FFELAB_typeFORMAT: 1308 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1309 ffestd_labeldef_any (ffestc_label_); 1310 1311 ffebad_start (FFEBAD_LABEL_USE_DEF); 1312 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1313 ffelex_token_where_column (ffesta_label_token)); 1314 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1315 ffelab_firstref_column (ffestc_label_)); 1316 ffebad_finish (); 1317 break; 1318 1319 default: 1320 assert ("bad label" == NULL); 1321 /* Fall through. */ 1322 case FFELAB_typeANY: 1323 break; 1324 } 1325 1326 ffestc_try_shriek_do_ (); 1327 1328 ffelex_token_kill (ffesta_label_token); 1329 ffesta_label_token = NULL; 1330} 1331 1332/* ffestc_labeldef_useless_ -- Define label as a useless one 1333 1334 ffestc_labeldef_useless_(); */ 1335 1336static void 1337ffestc_labeldef_useless_ () 1338{ 1339 if ((ffesta_label_token == NULL) 1340 || (ffestc_shriek_after1_ != NULL) 1341 || !ffestc_labeldef_begin_ ()) 1342 return; 1343 1344 switch (ffelab_type (ffestc_label_)) 1345 { 1346 case FFELAB_typeUNKNOWN: 1347 ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS); 1348 ffestd_labeldef_useless (ffestc_label_); 1349 break; 1350 1351 case FFELAB_typeLOOPEND: 1352 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1353 ffestd_labeldef_any (ffestc_label_); 1354 1355 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 1356 || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) 1357 { /* Unterminated block. */ 1358 ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); 1359 ffebad_here (0, ffelab_doref_line (ffestc_label_), 1360 ffelab_doref_column (ffestc_label_)); 1361 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 1362 ffebad_here (2, ffelex_token_where_line (ffesta_label_token), 1363 ffelex_token_where_column (ffesta_label_token)); 1364 ffebad_finish (); 1365 break; 1366 } 1367 ffebad_start (FFEBAD_LABEL_USE_DEF); 1368 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1369 ffelex_token_where_column (ffesta_label_token)); 1370 ffebad_here (1, ffelab_doref_line (ffestc_label_), 1371 ffelab_doref_column (ffestc_label_)); 1372 ffebad_finish (); 1373 ffestc_labeldef_branch_end_ (); 1374 return; 1375 1376 case FFELAB_typeASSIGNABLE: 1377 case FFELAB_typeFORMAT: 1378 case FFELAB_typeNOTLOOP: 1379 ffelab_set_type (ffestc_label_, FFELAB_typeANY); 1380 ffestd_labeldef_any (ffestc_label_); 1381 1382 ffebad_start (FFEBAD_LABEL_USE_DEF); 1383 ffebad_here (0, ffelex_token_where_line (ffesta_label_token), 1384 ffelex_token_where_column (ffesta_label_token)); 1385 ffebad_here (1, ffelab_firstref_line (ffestc_label_), 1386 ffelab_firstref_column (ffestc_label_)); 1387 ffebad_finish (); 1388 break; 1389 1390 default: 1391 assert ("bad label" == NULL); 1392 /* Fall through. */ 1393 case FFELAB_typeANY: 1394 break; 1395 } 1396 1397 ffestc_try_shriek_do_ (); 1398 1399 ffelex_token_kill (ffesta_label_token); 1400 ffesta_label_token = NULL; 1401} 1402 1403/* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt 1404 1405 if (ffestc_labelref_is_assignable_(label_token,&label)) 1406 // label ref is ok, label is filled in with ffelab object */ 1407 1408static bool 1409ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label) 1410{ 1411 ffelab label; 1412 ffelabValue label_value; 1413 1414 label_value = (ffelabValue) atol (ffelex_token_text (label_token)); 1415 if ((label_value == 0) || (label_value > FFELAB_valueMAX)) 1416 { 1417 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); 1418 ffebad_here (0, ffelex_token_where_line (label_token), 1419 ffelex_token_where_column (label_token)); 1420 ffebad_finish (); 1421 return FALSE; 1422 } 1423 1424 label = ffelab_find (label_value); 1425 if (label == NULL) 1426 { 1427 label = ffelab_new (label_value); 1428 ffelab_set_firstref_line (label, 1429 ffewhere_line_use (ffelex_token_where_line (label_token))); 1430 ffelab_set_firstref_column (label, 1431 ffewhere_column_use (ffelex_token_where_column (label_token))); 1432 } 1433 1434 switch (ffelab_type (label)) 1435 { 1436 case FFELAB_typeUNKNOWN: 1437 ffelab_set_type (label, FFELAB_typeASSIGNABLE); 1438 break; 1439 1440 case FFELAB_typeASSIGNABLE: 1441 case FFELAB_typeLOOPEND: 1442 case FFELAB_typeFORMAT: 1443 case FFELAB_typeNOTLOOP: 1444 case FFELAB_typeENDIF: 1445 break; 1446 1447 case FFELAB_typeUSELESS: 1448 ffelab_set_type (label, FFELAB_typeANY); 1449 ffestd_labeldef_any (label); 1450 1451 ffebad_start (FFEBAD_LABEL_USE_DEF); 1452 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); 1453 ffebad_here (1, ffelex_token_where_line (label_token), 1454 ffelex_token_where_column (label_token)); 1455 ffebad_finish (); 1456 1457 ffestc_try_shriek_do_ (); 1458 1459 return FALSE; 1460 1461 default: 1462 assert ("bad label" == NULL); 1463 /* Fall through. */ 1464 case FFELAB_typeANY: 1465 break; 1466 } 1467 1468 *x_label = label; 1469 return TRUE; 1470} 1471 1472/* ffestc_labelref_is_branch_ -- Reference to label in branch stmt 1473 1474 if (ffestc_labelref_is_branch_(label_token,&label)) 1475 // label ref is ok, label is filled in with ffelab object */ 1476 1477static bool 1478ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label) 1479{ 1480 ffelab label; 1481 ffelabValue label_value; 1482 ffestw block; 1483 unsigned long blocknum; 1484 1485 label_value = (ffelabValue) atol (ffelex_token_text (label_token)); 1486 if ((label_value == 0) || (label_value > FFELAB_valueMAX)) 1487 { 1488 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); 1489 ffebad_here (0, ffelex_token_where_line (label_token), 1490 ffelex_token_where_column (label_token)); 1491 ffebad_finish (); 1492 return FALSE; 1493 } 1494 1495 label = ffelab_find (label_value); 1496 if (label == NULL) 1497 { 1498 label = ffelab_new (label_value); 1499 ffelab_set_firstref_line (label, 1500 ffewhere_line_use (ffelex_token_where_line (label_token))); 1501 ffelab_set_firstref_column (label, 1502 ffewhere_column_use (ffelex_token_where_column (label_token))); 1503 } 1504 1505 switch (ffelab_type (label)) 1506 { 1507 case FFELAB_typeUNKNOWN: 1508 case FFELAB_typeASSIGNABLE: 1509 ffelab_set_type (label, FFELAB_typeNOTLOOP); 1510 ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ())); 1511 break; 1512 1513 case FFELAB_typeLOOPEND: 1514 if (ffelab_blocknum (label) != 0) 1515 break; /* Already taken care of. */ 1516 for (block = ffestw_top_do (ffestw_stack_top ()); 1517 (block != NULL) && (ffestw_label (block) != label); 1518 block = ffestw_top_do (ffestw_previous (block))) 1519 ; /* Find most recent DO <label> ancestor. */ 1520 if (block == NULL) 1521 { /* Reference to within a (dead) block. */ 1522 ffebad_start (FFEBAD_LABEL_BLOCK); 1523 ffebad_here (0, ffelab_definition_line (label), 1524 ffelab_definition_column (label)); 1525 ffebad_here (1, ffelex_token_where_line (label_token), 1526 ffelex_token_where_column (label_token)); 1527 ffebad_finish (); 1528 break; 1529 } 1530 ffelab_set_blocknum (label, ffestw_blocknum (block)); 1531 ffelab_set_firstref_line (label, 1532 ffewhere_line_use (ffelex_token_where_line (label_token))); 1533 ffelab_set_firstref_column (label, 1534 ffewhere_column_use (ffelex_token_where_column (label_token))); 1535 break; 1536 1537 case FFELAB_typeNOTLOOP: 1538 case FFELAB_typeENDIF: 1539 if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ())) 1540 break; 1541 blocknum = ffelab_blocknum (label); 1542 for (block = ffestw_stack_top (); 1543 ffestw_blocknum (block) > blocknum; 1544 block = ffestw_previous (block)) 1545 ; /* Find most recent common ancestor. */ 1546 if (ffelab_blocknum (label) == ffestw_blocknum (block)) 1547 break; /* Check again. */ 1548 if (!ffewhere_line_is_unknown (ffelab_definition_line (label))) 1549 { /* Reference to within a (dead) block. */ 1550 ffebad_start (FFEBAD_LABEL_BLOCK); 1551 ffebad_here (0, ffelab_definition_line (label), 1552 ffelab_definition_column (label)); 1553 ffebad_here (1, ffelex_token_where_line (label_token), 1554 ffelex_token_where_column (label_token)); 1555 ffebad_finish (); 1556 break; 1557 } 1558 ffelab_set_blocknum (label, ffestw_blocknum (block)); 1559 break; 1560 1561 case FFELAB_typeFORMAT: 1562 if (ffewhere_line_is_unknown (ffelab_definition_line (label))) 1563 { 1564 ffelab_set_type (label, FFELAB_typeANY); 1565 ffestd_labeldef_any (label); 1566 1567 ffebad_start (FFEBAD_LABEL_USE_USE); 1568 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); 1569 ffebad_here (1, ffelex_token_where_line (label_token), 1570 ffelex_token_where_column (label_token)); 1571 ffebad_finish (); 1572 1573 ffestc_try_shriek_do_ (); 1574 1575 return FALSE; 1576 } 1577 /* Fall through. */ 1578 case FFELAB_typeUSELESS: 1579 ffelab_set_type (label, FFELAB_typeANY); 1580 ffestd_labeldef_any (label); 1581 1582 ffebad_start (FFEBAD_LABEL_USE_DEF); 1583 ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label)); 1584 ffebad_here (1, ffelex_token_where_line (label_token), 1585 ffelex_token_where_column (label_token)); 1586 ffebad_finish (); 1587 1588 ffestc_try_shriek_do_ (); 1589 1590 return FALSE; 1591 1592 default: 1593 assert ("bad label" == NULL); 1594 /* Fall through. */ 1595 case FFELAB_typeANY: 1596 break; 1597 } 1598 1599 *x_label = label; 1600 return TRUE; 1601} 1602 1603/* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification 1604 1605 if (ffestc_labelref_is_format_(label_token,&label)) 1606 // label ref is ok, label is filled in with ffelab object */ 1607 1608static bool 1609ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label) 1610{ 1611 ffelab label; 1612 ffelabValue label_value; 1613 1614 label_value = (ffelabValue) atol (ffelex_token_text (label_token)); 1615 if ((label_value == 0) || (label_value > FFELAB_valueMAX)) 1616 { 1617 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); 1618 ffebad_here (0, ffelex_token_where_line (label_token), 1619 ffelex_token_where_column (label_token)); 1620 ffebad_finish (); 1621 return FALSE; 1622 } 1623 1624 label = ffelab_find (label_value); 1625 if (label == NULL) 1626 { 1627 label = ffelab_new (label_value); 1628 ffelab_set_firstref_line (label, 1629 ffewhere_line_use (ffelex_token_where_line (label_token))); 1630 ffelab_set_firstref_column (label, 1631 ffewhere_column_use (ffelex_token_where_column (label_token))); 1632 } 1633 1634 switch (ffelab_type (label)) 1635 { 1636 case FFELAB_typeUNKNOWN: 1637 case FFELAB_typeASSIGNABLE: 1638 ffelab_set_type (label, FFELAB_typeFORMAT); 1639 break; 1640 1641 case FFELAB_typeFORMAT: 1642 break; 1643 1644 case FFELAB_typeLOOPEND: 1645 case FFELAB_typeNOTLOOP: 1646 if (ffewhere_line_is_unknown (ffelab_definition_line (label))) 1647 { 1648 ffelab_set_type (label, FFELAB_typeANY); 1649 ffestd_labeldef_any (label); 1650 1651 ffebad_start (FFEBAD_LABEL_USE_USE); 1652 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); 1653 ffebad_here (1, ffelex_token_where_line (label_token), 1654 ffelex_token_where_column (label_token)); 1655 ffebad_finish (); 1656 1657 ffestc_try_shriek_do_ (); 1658 1659 return FALSE; 1660 } 1661 /* Fall through. */ 1662 case FFELAB_typeUSELESS: 1663 case FFELAB_typeENDIF: 1664 ffelab_set_type (label, FFELAB_typeANY); 1665 ffestd_labeldef_any (label); 1666 1667 ffebad_start (FFEBAD_LABEL_USE_DEF); 1668 ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label)); 1669 ffebad_here (1, ffelex_token_where_line (label_token), 1670 ffelex_token_where_column (label_token)); 1671 ffebad_finish (); 1672 1673 ffestc_try_shriek_do_ (); 1674 1675 return FALSE; 1676 1677 default: 1678 assert ("bad label" == NULL); 1679 /* Fall through. */ 1680 case FFELAB_typeANY: 1681 break; 1682 } 1683 1684 ffestc_try_shriek_do_ (); 1685 1686 *x_label = label; 1687 return TRUE; 1688} 1689 1690/* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt 1691 1692 if (ffestc_labelref_is_loopend_(label_token,&label)) 1693 // label ref is ok, label is filled in with ffelab object */ 1694 1695static bool 1696ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label) 1697{ 1698 ffelab label; 1699 ffelabValue label_value; 1700 1701 label_value = (ffelabValue) atol (ffelex_token_text (label_token)); 1702 if ((label_value == 0) || (label_value > FFELAB_valueMAX)) 1703 { 1704 ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); 1705 ffebad_here (0, ffelex_token_where_line (label_token), 1706 ffelex_token_where_column (label_token)); 1707 ffebad_finish (); 1708 return FALSE; 1709 } 1710 1711 label = ffelab_find (label_value); 1712 if (label == NULL) 1713 { 1714 label = ffelab_new (label_value); 1715 ffelab_set_doref_line (label, 1716 ffewhere_line_use (ffelex_token_where_line (label_token))); 1717 ffelab_set_doref_column (label, 1718 ffewhere_column_use (ffelex_token_where_column (label_token))); 1719 } 1720 1721 switch (ffelab_type (label)) 1722 { 1723 case FFELAB_typeASSIGNABLE: 1724 ffelab_set_doref_line (label, 1725 ffewhere_line_use (ffelex_token_where_line (label_token))); 1726 ffelab_set_doref_column (label, 1727 ffewhere_column_use (ffelex_token_where_column (label_token))); 1728 ffewhere_line_kill (ffelab_firstref_line (label)); 1729 ffelab_set_firstref_line (label, ffewhere_line_unknown ()); 1730 ffewhere_column_kill (ffelab_firstref_column (label)); 1731 ffelab_set_firstref_column (label, ffewhere_column_unknown ()); 1732 /* Fall through. */ 1733 case FFELAB_typeUNKNOWN: 1734 ffelab_set_type (label, FFELAB_typeLOOPEND); 1735 ffelab_set_blocknum (label, 0); 1736 break; 1737 1738 case FFELAB_typeLOOPEND: 1739 if (!ffewhere_line_is_unknown (ffelab_definition_line (label))) 1740 { /* Def must follow all refs. */ 1741 ffelab_set_type (label, FFELAB_typeANY); 1742 ffestd_labeldef_any (label); 1743 1744 ffebad_start (FFEBAD_LABEL_DEF_DO); 1745 ffebad_here (0, ffelab_definition_line (label), 1746 ffelab_definition_column (label)); 1747 ffebad_here (1, ffelex_token_where_line (label_token), 1748 ffelex_token_where_column (label_token)); 1749 ffebad_finish (); 1750 1751 ffestc_try_shriek_do_ (); 1752 1753 return FALSE; 1754 } 1755 if (ffelab_blocknum (label) != 0) 1756 { /* Had a branch ref earlier, can't go inside 1757 this new block! */ 1758 ffelab_set_type (label, FFELAB_typeANY); 1759 ffestd_labeldef_any (label); 1760 1761 ffebad_start (FFEBAD_LABEL_USE_USE); 1762 ffebad_here (0, ffelab_firstref_line (label), 1763 ffelab_firstref_column (label)); 1764 ffebad_here (1, ffelex_token_where_line (label_token), 1765 ffelex_token_where_column (label_token)); 1766 ffebad_finish (); 1767 1768 ffestc_try_shriek_do_ (); 1769 1770 return FALSE; 1771 } 1772 if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) 1773 || (ffestw_label (ffestw_stack_top ()) != label)) 1774 { /* Top of stack interrupts flow between two 1775 DOs specifying label. */ 1776 ffelab_set_type (label, FFELAB_typeANY); 1777 ffestd_labeldef_any (label); 1778 1779 ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO); 1780 ffebad_here (0, ffelab_doref_line (label), 1781 ffelab_doref_column (label)); 1782 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 1783 ffebad_here (2, ffelex_token_where_line (label_token), 1784 ffelex_token_where_column (label_token)); 1785 ffebad_finish (); 1786 1787 ffestc_try_shriek_do_ (); 1788 1789 return FALSE; 1790 } 1791 break; 1792 1793 case FFELAB_typeNOTLOOP: 1794 case FFELAB_typeFORMAT: 1795 if (ffewhere_line_is_unknown (ffelab_definition_line (label))) 1796 { 1797 ffelab_set_type (label, FFELAB_typeANY); 1798 ffestd_labeldef_any (label); 1799 1800 ffebad_start (FFEBAD_LABEL_USE_USE); 1801 ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); 1802 ffebad_here (1, ffelex_token_where_line (label_token), 1803 ffelex_token_where_column (label_token)); 1804 ffebad_finish (); 1805 1806 ffestc_try_shriek_do_ (); 1807 1808 return FALSE; 1809 } 1810 /* Fall through. */ 1811 case FFELAB_typeUSELESS: 1812 case FFELAB_typeENDIF: 1813 ffelab_set_type (label, FFELAB_typeANY); 1814 ffestd_labeldef_any (label); 1815 1816 ffebad_start (FFEBAD_LABEL_USE_DEF); 1817 ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label)); 1818 ffebad_here (1, ffelex_token_where_line (label_token), 1819 ffelex_token_where_column (label_token)); 1820 ffebad_finish (); 1821 1822 ffestc_try_shriek_do_ (); 1823 1824 return FALSE; 1825 1826 default: 1827 assert ("bad label" == NULL); 1828 /* Fall through. */ 1829 case FFELAB_typeANY: 1830 break; 1831 } 1832 1833 *x_label = label; 1834 return TRUE; 1835} 1836 1837/* ffestc_order_access_ -- Check ordering on <access> statement 1838 1839 if (ffestc_order_access_() != FFESTC_orderOK_) 1840 return; */ 1841 1842#if FFESTR_F90 1843static ffestcOrder_ 1844ffestc_order_access_ () 1845{ 1846 recurse: 1847 1848 switch (ffestw_state (ffestw_stack_top ())) 1849 { 1850 case FFESTV_stateNIL: 1851 ffestc_shriek_begin_program_ (); 1852 goto recurse; /* :::::::::::::::::::: */ 1853 1854 case FFESTV_stateMODULE0: 1855 case FFESTV_stateMODULE1: 1856 case FFESTV_stateMODULE2: 1857 ffestw_update (NULL); 1858 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 1859 return FFESTC_orderOK_; 1860 1861 case FFESTV_stateMODULE3: 1862 return FFESTC_orderOK_; 1863 1864 case FFESTV_stateUSE: 1865#if FFESTR_F90 1866 ffestc_shriek_end_uses_ (TRUE); 1867#endif 1868 goto recurse; /* :::::::::::::::::::: */ 1869 1870 case FFESTV_stateWHERE: 1871 ffestc_order_bad_ (); 1872#if FFESTR_F90 1873 ffestc_shriek_where_ (FALSE); 1874#endif 1875 return FFESTC_orderBAD_; 1876 1877 case FFESTV_stateIF: 1878 ffestc_order_bad_ (); 1879 ffestc_shriek_if_ (FALSE); 1880 return FFESTC_orderBAD_; 1881 1882 default: 1883 ffestc_order_bad_ (); 1884 return FFESTC_orderBAD_; 1885 } 1886} 1887 1888#endif 1889/* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement 1890 1891 if (ffestc_order_actiondo_() != FFESTC_orderOK_) 1892 return; */ 1893 1894static ffestcOrder_ 1895ffestc_order_actiondo_ () 1896{ 1897 recurse: 1898 1899 switch (ffestw_state (ffestw_stack_top ())) 1900 { 1901 case FFESTV_stateNIL: 1902 ffestc_shriek_begin_program_ (); 1903 goto recurse; /* :::::::::::::::::::: */ 1904 1905 case FFESTV_stateDO: 1906 return FFESTC_orderOK_; 1907 1908 case FFESTV_stateIFTHEN: 1909 case FFESTV_stateSELECT1: 1910 if (ffestw_top_do (ffestw_stack_top ()) == NULL) 1911 break; 1912 return FFESTC_orderOK_; 1913 1914 case FFESTV_stateIF: 1915 if (ffestw_top_do (ffestw_stack_top ()) == NULL) 1916 break; 1917 ffestc_shriek_after1_ = ffestc_shriek_if_; 1918 return FFESTC_orderOK_; 1919 1920 case FFESTV_stateUSE: 1921#if FFESTR_F90 1922 ffestc_shriek_end_uses_ (TRUE); 1923#endif 1924 goto recurse; /* :::::::::::::::::::: */ 1925 1926 case FFESTV_stateWHERE: 1927 ffestc_order_bad_ (); 1928#if FFESTR_F90 1929 ffestc_shriek_where_ (FALSE); 1930#endif 1931 return FFESTC_orderBAD_; 1932 1933 default: 1934 break; 1935 } 1936 ffestc_order_bad_ (); 1937 return FFESTC_orderBAD_; 1938} 1939 1940/* ffestc_order_actionif_ -- Check ordering on <actionif> statement 1941 1942 if (ffestc_order_actionif_() != FFESTC_orderOK_) 1943 return; */ 1944 1945static ffestcOrder_ 1946ffestc_order_actionif_ () 1947{ 1948 bool update; 1949 1950recurse: 1951 1952 switch (ffestw_state (ffestw_stack_top ())) 1953 { 1954 case FFESTV_stateNIL: 1955 ffestc_shriek_begin_program_ (); 1956 goto recurse; /* :::::::::::::::::::: */ 1957 1958 case FFESTV_statePROGRAM0: 1959 case FFESTV_statePROGRAM1: 1960 case FFESTV_statePROGRAM2: 1961 case FFESTV_statePROGRAM3: 1962 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); 1963 update = TRUE; 1964 break; 1965 1966 case FFESTV_stateSUBROUTINE0: 1967 case FFESTV_stateSUBROUTINE1: 1968 case FFESTV_stateSUBROUTINE2: 1969 case FFESTV_stateSUBROUTINE3: 1970 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); 1971 update = TRUE; 1972 break; 1973 1974 case FFESTV_stateFUNCTION0: 1975 case FFESTV_stateFUNCTION1: 1976 case FFESTV_stateFUNCTION2: 1977 case FFESTV_stateFUNCTION3: 1978 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); 1979 update = TRUE; 1980 break; 1981 1982 case FFESTV_statePROGRAM4: 1983 case FFESTV_stateSUBROUTINE4: 1984 case FFESTV_stateFUNCTION4: 1985 update = FALSE; 1986 break; 1987 1988 case FFESTV_stateIFTHEN: 1989 case FFESTV_stateDO: 1990 case FFESTV_stateSELECT1: 1991 return FFESTC_orderOK_; 1992 1993 case FFESTV_stateIF: 1994 ffestc_shriek_after1_ = ffestc_shriek_if_; 1995 return FFESTC_orderOK_; 1996 1997 case FFESTV_stateUSE: 1998#if FFESTR_F90 1999 ffestc_shriek_end_uses_ (TRUE); 2000#endif 2001 goto recurse; /* :::::::::::::::::::: */ 2002 2003 case FFESTV_stateWHERE: 2004 ffestc_order_bad_ (); 2005#if FFESTR_F90 2006 ffestc_shriek_where_ (FALSE); 2007#endif 2008 return FFESTC_orderBAD_; 2009 2010 default: 2011 ffestc_order_bad_ (); 2012 return FFESTC_orderBAD_; 2013 } 2014 2015 switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) 2016 { 2017 case FFESTV_stateINTERFACE0: 2018 ffestc_order_bad_ (); 2019 if (update) 2020 ffestw_update (NULL); 2021 return FFESTC_orderBAD_; 2022 2023 default: 2024 if (update) 2025 ffestw_update (NULL); 2026 return FFESTC_orderOK_; 2027 } 2028} 2029 2030/* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement 2031 2032 if (ffestc_order_actionwhere_() != FFESTC_orderOK_) 2033 return; */ 2034 2035static ffestcOrder_ 2036ffestc_order_actionwhere_ () 2037{ 2038 bool update; 2039 2040recurse: 2041 2042 switch (ffestw_state (ffestw_stack_top ())) 2043 { 2044 case FFESTV_stateNIL: 2045 ffestc_shriek_begin_program_ (); 2046 goto recurse; /* :::::::::::::::::::: */ 2047 2048 case FFESTV_statePROGRAM0: 2049 case FFESTV_statePROGRAM1: 2050 case FFESTV_statePROGRAM2: 2051 case FFESTV_statePROGRAM3: 2052 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); 2053 update = TRUE; 2054 break; 2055 2056 case FFESTV_stateSUBROUTINE0: 2057 case FFESTV_stateSUBROUTINE1: 2058 case FFESTV_stateSUBROUTINE2: 2059 case FFESTV_stateSUBROUTINE3: 2060 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); 2061 update = TRUE; 2062 break; 2063 2064 case FFESTV_stateFUNCTION0: 2065 case FFESTV_stateFUNCTION1: 2066 case FFESTV_stateFUNCTION2: 2067 case FFESTV_stateFUNCTION3: 2068 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); 2069 update = TRUE; 2070 break; 2071 2072 case FFESTV_statePROGRAM4: 2073 case FFESTV_stateSUBROUTINE4: 2074 case FFESTV_stateFUNCTION4: 2075 update = FALSE; 2076 break; 2077 2078 case FFESTV_stateWHERETHEN: 2079 case FFESTV_stateIFTHEN: 2080 case FFESTV_stateDO: 2081 case FFESTV_stateSELECT1: 2082 return FFESTC_orderOK_; 2083 2084 case FFESTV_stateWHERE: 2085#if FFESTR_F90 2086 ffestc_shriek_after1_ = ffestc_shriek_where_; 2087#endif 2088 return FFESTC_orderOK_; 2089 2090 case FFESTV_stateIF: 2091 ffestc_shriek_after1_ = ffestc_shriek_if_; 2092 return FFESTC_orderOK_; 2093 2094 case FFESTV_stateUSE: 2095#if FFESTR_F90 2096 ffestc_shriek_end_uses_ (TRUE); 2097#endif 2098 goto recurse; /* :::::::::::::::::::: */ 2099 2100 default: 2101 ffestc_order_bad_ (); 2102 return FFESTC_orderBAD_; 2103 } 2104 2105 switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) 2106 { 2107 case FFESTV_stateINTERFACE0: 2108 ffestc_order_bad_ (); 2109 if (update) 2110 ffestw_update (NULL); 2111 return FFESTC_orderBAD_; 2112 2113 default: 2114 if (update) 2115 ffestw_update (NULL); 2116 return FFESTC_orderOK_; 2117 } 2118} 2119 2120/* Check ordering on "any" statement. Like _actionwhere_, but 2121 doesn't produce any diagnostics. */ 2122 2123static void 2124ffestc_order_any_ () 2125{ 2126 bool update; 2127 2128recurse: 2129 2130 switch (ffestw_state (ffestw_stack_top ())) 2131 { 2132 case FFESTV_stateNIL: 2133 ffestc_shriek_begin_program_ (); 2134 goto recurse; /* :::::::::::::::::::: */ 2135 2136 case FFESTV_statePROGRAM0: 2137 case FFESTV_statePROGRAM1: 2138 case FFESTV_statePROGRAM2: 2139 case FFESTV_statePROGRAM3: 2140 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); 2141 update = TRUE; 2142 break; 2143 2144 case FFESTV_stateSUBROUTINE0: 2145 case FFESTV_stateSUBROUTINE1: 2146 case FFESTV_stateSUBROUTINE2: 2147 case FFESTV_stateSUBROUTINE3: 2148 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); 2149 update = TRUE; 2150 break; 2151 2152 case FFESTV_stateFUNCTION0: 2153 case FFESTV_stateFUNCTION1: 2154 case FFESTV_stateFUNCTION2: 2155 case FFESTV_stateFUNCTION3: 2156 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); 2157 update = TRUE; 2158 break; 2159 2160 case FFESTV_statePROGRAM4: 2161 case FFESTV_stateSUBROUTINE4: 2162 case FFESTV_stateFUNCTION4: 2163 update = FALSE; 2164 break; 2165 2166 case FFESTV_stateWHERETHEN: 2167 case FFESTV_stateIFTHEN: 2168 case FFESTV_stateDO: 2169 case FFESTV_stateSELECT1: 2170 return; 2171 2172 case FFESTV_stateWHERE: 2173#if FFESTR_F90 2174 ffestc_shriek_after1_ = ffestc_shriek_where_; 2175#endif 2176 return; 2177 2178 case FFESTV_stateIF: 2179 ffestc_shriek_after1_ = ffestc_shriek_if_; 2180 return; 2181 2182 case FFESTV_stateUSE: 2183#if FFESTR_F90 2184 ffestc_shriek_end_uses_ (TRUE); 2185#endif 2186 goto recurse; /* :::::::::::::::::::: */ 2187 2188 default: 2189 return; 2190 } 2191 2192 switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) 2193 { 2194 case FFESTV_stateINTERFACE0: 2195 if (update) 2196 ffestw_update (NULL); 2197 return; 2198 2199 default: 2200 if (update) 2201 ffestw_update (NULL); 2202 return; 2203 } 2204} 2205 2206/* ffestc_order_bad_ -- Whine about statement ordering violation 2207 2208 ffestc_order_bad_(); 2209 2210 Uses current ffesta_tokens[0] and, if available, info on where current 2211 state started to produce generic message. Someday we should do 2212 fancier things than this, but this just gets things creaking along for 2213 now. */ 2214 2215static void 2216ffestc_order_bad_ () 2217{ 2218 if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ()))) 2219 { 2220 ffebad_start (FFEBAD_ORDER_1); 2221 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 2222 ffelex_token_where_column (ffesta_tokens[0])); 2223 ffebad_finish (); 2224 } 2225 else 2226 { 2227 ffebad_start (FFEBAD_ORDER_2); 2228 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 2229 ffelex_token_where_column (ffesta_tokens[0])); 2230 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 2231 ffebad_finish (); 2232 } 2233 ffestc_labeldef_useless_ (); /* Any label definition is useless. */ 2234} 2235 2236/* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement 2237 2238 if (ffestc_order_blockdata_() != FFESTC_orderOK_) 2239 return; */ 2240 2241static ffestcOrder_ 2242ffestc_order_blockdata_ () 2243{ 2244 recurse: 2245 2246 switch (ffestw_state (ffestw_stack_top ())) 2247 { 2248 case FFESTV_stateBLOCKDATA0: 2249 case FFESTV_stateBLOCKDATA1: 2250 case FFESTV_stateBLOCKDATA2: 2251 case FFESTV_stateBLOCKDATA3: 2252 case FFESTV_stateBLOCKDATA4: 2253 case FFESTV_stateBLOCKDATA5: 2254 return FFESTC_orderOK_; 2255 2256 case FFESTV_stateUSE: 2257#if FFESTR_F90 2258 ffestc_shriek_end_uses_ (TRUE); 2259#endif 2260 goto recurse; /* :::::::::::::::::::: */ 2261 2262 case FFESTV_stateWHERE: 2263 ffestc_order_bad_ (); 2264#if FFESTR_F90 2265 ffestc_shriek_where_ (FALSE); 2266#endif 2267 return FFESTC_orderBAD_; 2268 2269 case FFESTV_stateIF: 2270 ffestc_order_bad_ (); 2271 ffestc_shriek_if_ (FALSE); 2272 return FFESTC_orderBAD_; 2273 2274 default: 2275 ffestc_order_bad_ (); 2276 return FFESTC_orderBAD_; 2277 } 2278} 2279 2280/* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement 2281 2282 if (ffestc_order_blockspec_() != FFESTC_orderOK_) 2283 return; */ 2284 2285static ffestcOrder_ 2286ffestc_order_blockspec_ () 2287{ 2288 recurse: 2289 2290 switch (ffestw_state (ffestw_stack_top ())) 2291 { 2292 case FFESTV_stateNIL: 2293 ffestc_shriek_begin_program_ (); 2294 goto recurse; /* :::::::::::::::::::: */ 2295 2296 case FFESTV_statePROGRAM0: 2297 case FFESTV_statePROGRAM1: 2298 case FFESTV_statePROGRAM2: 2299 ffestw_update (NULL); 2300 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 2301 return FFESTC_orderOK_; 2302 2303 case FFESTV_stateSUBROUTINE0: 2304 case FFESTV_stateSUBROUTINE1: 2305 case FFESTV_stateSUBROUTINE2: 2306 ffestw_update (NULL); 2307 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 2308 return FFESTC_orderOK_; 2309 2310 case FFESTV_stateFUNCTION0: 2311 case FFESTV_stateFUNCTION1: 2312 case FFESTV_stateFUNCTION2: 2313 ffestw_update (NULL); 2314 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 2315 return FFESTC_orderOK_; 2316 2317 case FFESTV_stateMODULE0: 2318 case FFESTV_stateMODULE1: 2319 case FFESTV_stateMODULE2: 2320 ffestw_update (NULL); 2321 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 2322 return FFESTC_orderOK_; 2323 2324 case FFESTV_stateBLOCKDATA0: 2325 case FFESTV_stateBLOCKDATA1: 2326 case FFESTV_stateBLOCKDATA2: 2327 ffestw_update (NULL); 2328 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); 2329 return FFESTC_orderOK_; 2330 2331 case FFESTV_statePROGRAM3: 2332 case FFESTV_stateSUBROUTINE3: 2333 case FFESTV_stateFUNCTION3: 2334 case FFESTV_stateMODULE3: 2335 case FFESTV_stateBLOCKDATA3: 2336 return FFESTC_orderOK_; 2337 2338 case FFESTV_stateUSE: 2339#if FFESTR_F90 2340 ffestc_shriek_end_uses_ (TRUE); 2341#endif 2342 goto recurse; /* :::::::::::::::::::: */ 2343 2344 case FFESTV_stateWHERE: 2345 ffestc_order_bad_ (); 2346#if FFESTR_F90 2347 ffestc_shriek_where_ (FALSE); 2348#endif 2349 return FFESTC_orderBAD_; 2350 2351 case FFESTV_stateIF: 2352 ffestc_order_bad_ (); 2353 ffestc_shriek_if_ (FALSE); 2354 return FFESTC_orderBAD_; 2355 2356 default: 2357 ffestc_order_bad_ (); 2358 return FFESTC_orderBAD_; 2359 } 2360} 2361 2362/* ffestc_order_component_ -- Check ordering on <component-decl> statement 2363 2364 if (ffestc_order_component_() != FFESTC_orderOK_) 2365 return; */ 2366 2367#if FFESTR_F90 2368static ffestcOrder_ 2369ffestc_order_component_ () 2370{ 2371 switch (ffestw_state (ffestw_stack_top ())) 2372 { 2373 case FFESTV_stateTYPE: 2374 case FFESTV_stateSTRUCTURE: 2375 case FFESTV_stateMAP: 2376 return FFESTC_orderOK_; 2377 2378 case FFESTV_stateWHERE: 2379 ffestc_order_bad_ (); 2380 ffestc_shriek_where_ (FALSE); 2381 return FFESTC_orderBAD_; 2382 2383 case FFESTV_stateIF: 2384 ffestc_order_bad_ (); 2385 ffestc_shriek_if_ (FALSE); 2386 return FFESTC_orderBAD_; 2387 2388 default: 2389 ffestc_order_bad_ (); 2390 return FFESTC_orderBAD_; 2391 } 2392} 2393 2394#endif 2395/* ffestc_order_contains_ -- Check ordering on CONTAINS statement 2396 2397 if (ffestc_order_contains_() != FFESTC_orderOK_) 2398 return; */ 2399 2400#if FFESTR_F90 2401static ffestcOrder_ 2402ffestc_order_contains_ () 2403{ 2404 recurse: 2405 2406 switch (ffestw_state (ffestw_stack_top ())) 2407 { 2408 case FFESTV_stateNIL: 2409 ffestc_shriek_begin_program_ (); 2410 goto recurse; /* :::::::::::::::::::: */ 2411 2412 case FFESTV_statePROGRAM0: 2413 case FFESTV_statePROGRAM1: 2414 case FFESTV_statePROGRAM2: 2415 case FFESTV_statePROGRAM3: 2416 case FFESTV_statePROGRAM4: 2417 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5); 2418 break; 2419 2420 case FFESTV_stateSUBROUTINE0: 2421 case FFESTV_stateSUBROUTINE1: 2422 case FFESTV_stateSUBROUTINE2: 2423 case FFESTV_stateSUBROUTINE3: 2424 case FFESTV_stateSUBROUTINE4: 2425 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5); 2426 break; 2427 2428 case FFESTV_stateFUNCTION0: 2429 case FFESTV_stateFUNCTION1: 2430 case FFESTV_stateFUNCTION2: 2431 case FFESTV_stateFUNCTION3: 2432 case FFESTV_stateFUNCTION4: 2433 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5); 2434 break; 2435 2436 case FFESTV_stateMODULE0: 2437 case FFESTV_stateMODULE1: 2438 case FFESTV_stateMODULE2: 2439 case FFESTV_stateMODULE3: 2440 case FFESTV_stateMODULE4: 2441 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5); 2442 break; 2443 2444 case FFESTV_stateUSE: 2445 ffestc_shriek_end_uses_ (TRUE); 2446 goto recurse; /* :::::::::::::::::::: */ 2447 2448 case FFESTV_stateWHERE: 2449 ffestc_order_bad_ (); 2450 ffestc_shriek_where_ (FALSE); 2451 return FFESTC_orderBAD_; 2452 2453 case FFESTV_stateIF: 2454 ffestc_order_bad_ (); 2455 ffestc_shriek_if_ (FALSE); 2456 return FFESTC_orderBAD_; 2457 2458 default: 2459 ffestc_order_bad_ (); 2460 return FFESTC_orderBAD_; 2461 } 2462 2463 switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) 2464 { 2465 case FFESTV_stateNIL: 2466 ffestw_update (NULL); 2467 return FFESTC_orderOK_; 2468 2469 default: 2470 ffestc_order_bad_ (); 2471 ffestw_update (NULL); 2472 return FFESTC_orderBAD_; 2473 } 2474} 2475 2476#endif 2477/* ffestc_order_data_ -- Check ordering on DATA statement 2478 2479 if (ffestc_order_data_() != FFESTC_orderOK_) 2480 return; */ 2481 2482static ffestcOrder_ 2483ffestc_order_data_ () 2484{ 2485 recurse: 2486 2487 switch (ffestw_state (ffestw_stack_top ())) 2488 { 2489 case FFESTV_stateNIL: 2490 ffestc_shriek_begin_program_ (); 2491 goto recurse; /* :::::::::::::::::::: */ 2492 2493 case FFESTV_statePROGRAM0: 2494 case FFESTV_statePROGRAM1: 2495 ffestw_update (NULL); 2496 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2); 2497 return FFESTC_orderOK_; 2498 2499 case FFESTV_stateSUBROUTINE0: 2500 case FFESTV_stateSUBROUTINE1: 2501 ffestw_update (NULL); 2502 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2); 2503 return FFESTC_orderOK_; 2504 2505 case FFESTV_stateFUNCTION0: 2506 case FFESTV_stateFUNCTION1: 2507 ffestw_update (NULL); 2508 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2); 2509 return FFESTC_orderOK_; 2510 2511 case FFESTV_stateBLOCKDATA0: 2512 case FFESTV_stateBLOCKDATA1: 2513 ffestw_update (NULL); 2514 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); 2515 return FFESTC_orderOK_; 2516 2517 case FFESTV_statePROGRAM2: 2518 case FFESTV_stateSUBROUTINE2: 2519 case FFESTV_stateFUNCTION2: 2520 case FFESTV_stateBLOCKDATA2: 2521 case FFESTV_statePROGRAM3: 2522 case FFESTV_stateSUBROUTINE3: 2523 case FFESTV_stateFUNCTION3: 2524 case FFESTV_stateBLOCKDATA3: 2525 case FFESTV_statePROGRAM4: 2526 case FFESTV_stateSUBROUTINE4: 2527 case FFESTV_stateFUNCTION4: 2528 case FFESTV_stateBLOCKDATA4: 2529 case FFESTV_stateWHERETHEN: 2530 case FFESTV_stateIFTHEN: 2531 case FFESTV_stateDO: 2532 case FFESTV_stateSELECT0: 2533 case FFESTV_stateSELECT1: 2534 return FFESTC_orderOK_; 2535 2536 case FFESTV_stateUSE: 2537#if FFESTR_F90 2538 ffestc_shriek_end_uses_ (TRUE); 2539#endif 2540 goto recurse; /* :::::::::::::::::::: */ 2541 2542 case FFESTV_stateWHERE: 2543 ffestc_order_bad_ (); 2544#if FFESTR_F90 2545 ffestc_shriek_where_ (FALSE); 2546#endif 2547 return FFESTC_orderBAD_; 2548 2549 case FFESTV_stateIF: 2550 ffestc_order_bad_ (); 2551 ffestc_shriek_if_ (FALSE); 2552 return FFESTC_orderBAD_; 2553 2554 default: 2555 ffestc_order_bad_ (); 2556 return FFESTC_orderBAD_; 2557 } 2558} 2559 2560/* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement 2561 2562 if (ffestc_order_data77_() != FFESTC_orderOK_) 2563 return; */ 2564 2565static ffestcOrder_ 2566ffestc_order_data77_ () 2567{ 2568 recurse: 2569 2570 switch (ffestw_state (ffestw_stack_top ())) 2571 { 2572 case FFESTV_stateNIL: 2573 ffestc_shriek_begin_program_ (); 2574 goto recurse; /* :::::::::::::::::::: */ 2575 2576 case FFESTV_statePROGRAM0: 2577 case FFESTV_statePROGRAM1: 2578 case FFESTV_statePROGRAM2: 2579 case FFESTV_statePROGRAM3: 2580 ffestw_update (NULL); 2581 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); 2582 return FFESTC_orderOK_; 2583 2584 case FFESTV_stateSUBROUTINE0: 2585 case FFESTV_stateSUBROUTINE1: 2586 case FFESTV_stateSUBROUTINE2: 2587 case FFESTV_stateSUBROUTINE3: 2588 ffestw_update (NULL); 2589 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); 2590 return FFESTC_orderOK_; 2591 2592 case FFESTV_stateFUNCTION0: 2593 case FFESTV_stateFUNCTION1: 2594 case FFESTV_stateFUNCTION2: 2595 case FFESTV_stateFUNCTION3: 2596 ffestw_update (NULL); 2597 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); 2598 return FFESTC_orderOK_; 2599 2600 case FFESTV_stateBLOCKDATA0: 2601 case FFESTV_stateBLOCKDATA1: 2602 case FFESTV_stateBLOCKDATA2: 2603 case FFESTV_stateBLOCKDATA3: 2604 ffestw_update (NULL); 2605 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4); 2606 return FFESTC_orderOK_; 2607 2608 case FFESTV_statePROGRAM4: 2609 case FFESTV_stateSUBROUTINE4: 2610 case FFESTV_stateFUNCTION4: 2611 case FFESTV_stateBLOCKDATA4: 2612 return FFESTC_orderOK_; 2613 2614 case FFESTV_stateWHERETHEN: 2615 case FFESTV_stateIFTHEN: 2616 case FFESTV_stateDO: 2617 case FFESTV_stateSELECT0: 2618 case FFESTV_stateSELECT1: 2619 return FFESTC_orderOK_; 2620 2621 case FFESTV_stateUSE: 2622#if FFESTR_F90 2623 ffestc_shriek_end_uses_ (TRUE); 2624#endif 2625 goto recurse; /* :::::::::::::::::::: */ 2626 2627 case FFESTV_stateWHERE: 2628 ffestc_order_bad_ (); 2629#if FFESTR_F90 2630 ffestc_shriek_where_ (FALSE); 2631#endif 2632 return FFESTC_orderBAD_; 2633 2634 case FFESTV_stateIF: 2635 ffestc_order_bad_ (); 2636 ffestc_shriek_if_ (FALSE); 2637 return FFESTC_orderBAD_; 2638 2639 default: 2640 ffestc_order_bad_ (); 2641 return FFESTC_orderBAD_; 2642 } 2643} 2644 2645/* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement 2646 2647 if (ffestc_order_derivedtype_() != FFESTC_orderOK_) 2648 return; */ 2649 2650#if FFESTR_F90 2651static ffestcOrder_ 2652ffestc_order_derivedtype_ () 2653{ 2654 recurse: 2655 2656 switch (ffestw_state (ffestw_stack_top ())) 2657 { 2658 case FFESTV_stateNIL: 2659 ffestc_shriek_begin_program_ (); 2660 goto recurse; /* :::::::::::::::::::: */ 2661 2662 case FFESTV_statePROGRAM0: 2663 case FFESTV_statePROGRAM1: 2664 case FFESTV_statePROGRAM2: 2665 ffestw_update (NULL); 2666 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 2667 return FFESTC_orderOK_; 2668 2669 case FFESTV_stateSUBROUTINE0: 2670 case FFESTV_stateSUBROUTINE1: 2671 case FFESTV_stateSUBROUTINE2: 2672 ffestw_update (NULL); 2673 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 2674 return FFESTC_orderOK_; 2675 2676 case FFESTV_stateFUNCTION0: 2677 case FFESTV_stateFUNCTION1: 2678 case FFESTV_stateFUNCTION2: 2679 ffestw_update (NULL); 2680 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 2681 return FFESTC_orderOK_; 2682 2683 case FFESTV_stateMODULE0: 2684 case FFESTV_stateMODULE1: 2685 case FFESTV_stateMODULE2: 2686 ffestw_update (NULL); 2687 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 2688 return FFESTC_orderOK_; 2689 2690 case FFESTV_statePROGRAM3: 2691 case FFESTV_stateSUBROUTINE3: 2692 case FFESTV_stateFUNCTION3: 2693 case FFESTV_stateMODULE3: 2694 return FFESTC_orderOK_; 2695 2696 case FFESTV_stateUSE: 2697 ffestc_shriek_end_uses_ (TRUE); 2698 goto recurse; /* :::::::::::::::::::: */ 2699 2700 case FFESTV_stateWHERE: 2701 ffestc_order_bad_ (); 2702 ffestc_shriek_where_ (FALSE); 2703 return FFESTC_orderBAD_; 2704 2705 case FFESTV_stateIF: 2706 ffestc_order_bad_ (); 2707 ffestc_shriek_if_ (FALSE); 2708 return FFESTC_orderBAD_; 2709 2710 default: 2711 ffestc_order_bad_ (); 2712 return FFESTC_orderBAD_; 2713 } 2714} 2715 2716#endif 2717/* ffestc_order_do_ -- Check ordering on <do> statement 2718 2719 if (ffestc_order_do_() != FFESTC_orderOK_) 2720 return; */ 2721 2722static ffestcOrder_ 2723ffestc_order_do_ () 2724{ 2725 switch (ffestw_state (ffestw_stack_top ())) 2726 { 2727 case FFESTV_stateDO: 2728 return FFESTC_orderOK_; 2729 2730 case FFESTV_stateWHERE: 2731 ffestc_order_bad_ (); 2732#if FFESTR_F90 2733 ffestc_shriek_where_ (FALSE); 2734#endif 2735 return FFESTC_orderBAD_; 2736 2737 case FFESTV_stateIF: 2738 ffestc_order_bad_ (); 2739 ffestc_shriek_if_ (FALSE); 2740 return FFESTC_orderBAD_; 2741 2742 default: 2743 ffestc_order_bad_ (); 2744 return FFESTC_orderBAD_; 2745 } 2746} 2747 2748/* ffestc_order_entry_ -- Check ordering on ENTRY statement 2749 2750 if (ffestc_order_entry_() != FFESTC_orderOK_) 2751 return; */ 2752 2753static ffestcOrder_ 2754ffestc_order_entry_ () 2755{ 2756 recurse: 2757 2758 switch (ffestw_state (ffestw_stack_top ())) 2759 { 2760 case FFESTV_stateNIL: 2761 ffestc_shriek_begin_program_ (); 2762 goto recurse; /* :::::::::::::::::::: */ 2763 2764 case FFESTV_stateSUBROUTINE0: 2765 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1); 2766 break; 2767 2768 case FFESTV_stateFUNCTION0: 2769 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1); 2770 break; 2771 2772 case FFESTV_stateSUBROUTINE1: 2773 case FFESTV_stateSUBROUTINE2: 2774 case FFESTV_stateFUNCTION1: 2775 case FFESTV_stateFUNCTION2: 2776 case FFESTV_stateSUBROUTINE3: 2777 case FFESTV_stateFUNCTION3: 2778 case FFESTV_stateSUBROUTINE4: 2779 case FFESTV_stateFUNCTION4: 2780 break; 2781 2782 case FFESTV_stateUSE: 2783#if FFESTR_F90 2784 ffestc_shriek_end_uses_ (TRUE); 2785#endif 2786 goto recurse; /* :::::::::::::::::::: */ 2787 2788 case FFESTV_stateWHERE: 2789 ffestc_order_bad_ (); 2790#if FFESTR_F90 2791 ffestc_shriek_where_ (FALSE); 2792#endif 2793 return FFESTC_orderBAD_; 2794 2795 case FFESTV_stateIF: 2796 ffestc_order_bad_ (); 2797 ffestc_shriek_if_ (FALSE); 2798 return FFESTC_orderBAD_; 2799 2800 default: 2801 ffestc_order_bad_ (); 2802 return FFESTC_orderBAD_; 2803 } 2804 2805 switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) 2806 { 2807 case FFESTV_stateNIL: 2808 case FFESTV_stateMODULE5: 2809 ffestw_update (NULL); 2810 return FFESTC_orderOK_; 2811 2812 default: 2813 ffestc_order_bad_ (); 2814 ffestw_update (NULL); 2815 return FFESTC_orderBAD_; 2816 } 2817} 2818 2819/* ffestc_order_exec_ -- Check ordering on <exec> statement 2820 2821 if (ffestc_order_exec_() != FFESTC_orderOK_) 2822 return; */ 2823 2824static ffestcOrder_ 2825ffestc_order_exec_ () 2826{ 2827 bool update; 2828 2829recurse: 2830 2831 switch (ffestw_state (ffestw_stack_top ())) 2832 { 2833 case FFESTV_stateNIL: 2834 ffestc_shriek_begin_program_ (); 2835 goto recurse; /* :::::::::::::::::::: */ 2836 2837 case FFESTV_statePROGRAM0: 2838 case FFESTV_statePROGRAM1: 2839 case FFESTV_statePROGRAM2: 2840 case FFESTV_statePROGRAM3: 2841 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); 2842 update = TRUE; 2843 break; 2844 2845 case FFESTV_stateSUBROUTINE0: 2846 case FFESTV_stateSUBROUTINE1: 2847 case FFESTV_stateSUBROUTINE2: 2848 case FFESTV_stateSUBROUTINE3: 2849 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); 2850 update = TRUE; 2851 break; 2852 2853 case FFESTV_stateFUNCTION0: 2854 case FFESTV_stateFUNCTION1: 2855 case FFESTV_stateFUNCTION2: 2856 case FFESTV_stateFUNCTION3: 2857 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); 2858 update = TRUE; 2859 break; 2860 2861 case FFESTV_statePROGRAM4: 2862 case FFESTV_stateSUBROUTINE4: 2863 case FFESTV_stateFUNCTION4: 2864 update = FALSE; 2865 break; 2866 2867 case FFESTV_stateIFTHEN: 2868 case FFESTV_stateDO: 2869 case FFESTV_stateSELECT1: 2870 return FFESTC_orderOK_; 2871 2872 case FFESTV_stateUSE: 2873#if FFESTR_F90 2874 ffestc_shriek_end_uses_ (TRUE); 2875#endif 2876 goto recurse; /* :::::::::::::::::::: */ 2877 2878 case FFESTV_stateWHERE: 2879 ffestc_order_bad_ (); 2880#if FFESTR_F90 2881 ffestc_shriek_where_ (FALSE); 2882#endif 2883 return FFESTC_orderBAD_; 2884 2885 case FFESTV_stateIF: 2886 ffestc_order_bad_ (); 2887 ffestc_shriek_if_ (FALSE); 2888 return FFESTC_orderBAD_; 2889 2890 default: 2891 ffestc_order_bad_ (); 2892 return FFESTC_orderBAD_; 2893 } 2894 2895 switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) 2896 { 2897 case FFESTV_stateINTERFACE0: 2898 ffestc_order_bad_ (); 2899 if (update) 2900 ffestw_update (NULL); 2901 return FFESTC_orderBAD_; 2902 2903 default: 2904 if (update) 2905 ffestw_update (NULL); 2906 return FFESTC_orderOK_; 2907 } 2908} 2909 2910/* ffestc_order_format_ -- Check ordering on FORMAT statement 2911 2912 if (ffestc_order_format_() != FFESTC_orderOK_) 2913 return; */ 2914 2915static ffestcOrder_ 2916ffestc_order_format_ () 2917{ 2918 recurse: 2919 2920 switch (ffestw_state (ffestw_stack_top ())) 2921 { 2922 case FFESTV_stateNIL: 2923 ffestc_shriek_begin_program_ (); 2924 goto recurse; /* :::::::::::::::::::: */ 2925 2926 case FFESTV_statePROGRAM0: 2927 ffestw_update (NULL); 2928 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1); 2929 return FFESTC_orderOK_; 2930 2931 case FFESTV_stateSUBROUTINE0: 2932 ffestw_update (NULL); 2933 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1); 2934 return FFESTC_orderOK_; 2935 2936 case FFESTV_stateFUNCTION0: 2937 ffestw_update (NULL); 2938 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1); 2939 return FFESTC_orderOK_; 2940 2941 case FFESTV_statePROGRAM1: 2942 case FFESTV_statePROGRAM2: 2943 case FFESTV_stateSUBROUTINE1: 2944 case FFESTV_stateSUBROUTINE2: 2945 case FFESTV_stateFUNCTION1: 2946 case FFESTV_stateFUNCTION2: 2947 case FFESTV_statePROGRAM3: 2948 case FFESTV_stateSUBROUTINE3: 2949 case FFESTV_stateFUNCTION3: 2950 case FFESTV_statePROGRAM4: 2951 case FFESTV_stateSUBROUTINE4: 2952 case FFESTV_stateFUNCTION4: 2953 case FFESTV_stateWHERETHEN: 2954 case FFESTV_stateIFTHEN: 2955 case FFESTV_stateDO: 2956 case FFESTV_stateSELECT0: 2957 case FFESTV_stateSELECT1: 2958 return FFESTC_orderOK_; 2959 2960 case FFESTV_stateUSE: 2961#if FFESTR_F90 2962 ffestc_shriek_end_uses_ (TRUE); 2963#endif 2964 goto recurse; /* :::::::::::::::::::: */ 2965 2966 case FFESTV_stateWHERE: 2967 ffestc_order_bad_ (); 2968#if FFESTR_F90 2969 ffestc_shriek_where_ (FALSE); 2970#endif 2971 return FFESTC_orderBAD_; 2972 2973 case FFESTV_stateIF: 2974 ffestc_order_bad_ (); 2975 ffestc_shriek_if_ (FALSE); 2976 return FFESTC_orderBAD_; 2977 2978 default: 2979 ffestc_order_bad_ (); 2980 return FFESTC_orderBAD_; 2981 } 2982} 2983 2984/* ffestc_order_function_ -- Check ordering on <function> statement 2985 2986 if (ffestc_order_function_() != FFESTC_orderOK_) 2987 return; */ 2988 2989static ffestcOrder_ 2990ffestc_order_function_ () 2991{ 2992 recurse: 2993 2994 switch (ffestw_state (ffestw_stack_top ())) 2995 { 2996 case FFESTV_stateFUNCTION0: 2997 case FFESTV_stateFUNCTION1: 2998 case FFESTV_stateFUNCTION2: 2999 case FFESTV_stateFUNCTION3: 3000 case FFESTV_stateFUNCTION4: 3001 case FFESTV_stateFUNCTION5: 3002 return FFESTC_orderOK_; 3003 3004 case FFESTV_stateUSE: 3005#if FFESTR_F90 3006 ffestc_shriek_end_uses_ (TRUE); 3007#endif 3008 goto recurse; /* :::::::::::::::::::: */ 3009 3010 case FFESTV_stateWHERE: 3011 ffestc_order_bad_ (); 3012#if FFESTR_F90 3013 ffestc_shriek_where_ (FALSE); 3014#endif 3015 return FFESTC_orderBAD_; 3016 3017 case FFESTV_stateIF: 3018 ffestc_order_bad_ (); 3019 ffestc_shriek_if_ (FALSE); 3020 return FFESTC_orderBAD_; 3021 3022 default: 3023 ffestc_order_bad_ (); 3024 return FFESTC_orderBAD_; 3025 } 3026} 3027 3028/* ffestc_order_iface_ -- Check ordering on <iface> statement 3029 3030 if (ffestc_order_iface_() != FFESTC_orderOK_) 3031 return; */ 3032 3033static ffestcOrder_ 3034ffestc_order_iface_ () 3035{ 3036 switch (ffestw_state (ffestw_stack_top ())) 3037 { 3038 case FFESTV_stateNIL: 3039 case FFESTV_statePROGRAM5: 3040 case FFESTV_stateSUBROUTINE5: 3041 case FFESTV_stateFUNCTION5: 3042 case FFESTV_stateMODULE5: 3043 case FFESTV_stateINTERFACE0: 3044 return FFESTC_orderOK_; 3045 3046 case FFESTV_stateWHERE: 3047 ffestc_order_bad_ (); 3048#if FFESTR_F90 3049 ffestc_shriek_where_ (FALSE); 3050#endif 3051 return FFESTC_orderBAD_; 3052 3053 case FFESTV_stateIF: 3054 ffestc_order_bad_ (); 3055 ffestc_shriek_if_ (FALSE); 3056 return FFESTC_orderBAD_; 3057 3058 default: 3059 ffestc_order_bad_ (); 3060 return FFESTC_orderBAD_; 3061 } 3062} 3063 3064/* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement 3065 3066 if (ffestc_order_ifthen_() != FFESTC_orderOK_) 3067 return; */ 3068 3069static ffestcOrder_ 3070ffestc_order_ifthen_ () 3071{ 3072 switch (ffestw_state (ffestw_stack_top ())) 3073 { 3074 case FFESTV_stateIFTHEN: 3075 return FFESTC_orderOK_; 3076 3077 case FFESTV_stateWHERE: 3078 ffestc_order_bad_ (); 3079#if FFESTR_F90 3080 ffestc_shriek_where_ (FALSE); 3081#endif 3082 return FFESTC_orderBAD_; 3083 3084 case FFESTV_stateIF: 3085 ffestc_order_bad_ (); 3086 ffestc_shriek_if_ (FALSE); 3087 return FFESTC_orderBAD_; 3088 3089 default: 3090 ffestc_order_bad_ (); 3091 return FFESTC_orderBAD_; 3092 } 3093} 3094 3095/* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement 3096 3097 if (ffestc_order_implicit_() != FFESTC_orderOK_) 3098 return; */ 3099 3100static ffestcOrder_ 3101ffestc_order_implicit_ () 3102{ 3103 recurse: 3104 3105 switch (ffestw_state (ffestw_stack_top ())) 3106 { 3107 case FFESTV_stateNIL: 3108 ffestc_shriek_begin_program_ (); 3109 goto recurse; /* :::::::::::::::::::: */ 3110 3111 case FFESTV_statePROGRAM0: 3112 case FFESTV_statePROGRAM1: 3113 ffestw_update (NULL); 3114 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2); 3115 return FFESTC_orderOK_; 3116 3117 case FFESTV_stateSUBROUTINE0: 3118 case FFESTV_stateSUBROUTINE1: 3119 ffestw_update (NULL); 3120 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2); 3121 return FFESTC_orderOK_; 3122 3123 case FFESTV_stateFUNCTION0: 3124 case FFESTV_stateFUNCTION1: 3125 ffestw_update (NULL); 3126 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2); 3127 return FFESTC_orderOK_; 3128 3129 case FFESTV_stateMODULE0: 3130 case FFESTV_stateMODULE1: 3131 ffestw_update (NULL); 3132 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2); 3133 return FFESTC_orderOK_; 3134 3135 case FFESTV_stateBLOCKDATA0: 3136 case FFESTV_stateBLOCKDATA1: 3137 ffestw_update (NULL); 3138 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); 3139 return FFESTC_orderOK_; 3140 3141 case FFESTV_statePROGRAM2: 3142 case FFESTV_stateSUBROUTINE2: 3143 case FFESTV_stateFUNCTION2: 3144 case FFESTV_stateMODULE2: 3145 case FFESTV_stateBLOCKDATA2: 3146 return FFESTC_orderOK_; 3147 3148 case FFESTV_stateUSE: 3149#if FFESTR_F90 3150 ffestc_shriek_end_uses_ (TRUE); 3151#endif 3152 goto recurse; /* :::::::::::::::::::: */ 3153 3154 case FFESTV_stateWHERE: 3155 ffestc_order_bad_ (); 3156#if FFESTR_F90 3157 ffestc_shriek_where_ (FALSE); 3158#endif 3159 return FFESTC_orderBAD_; 3160 3161 case FFESTV_stateIF: 3162 ffestc_order_bad_ (); 3163 ffestc_shriek_if_ (FALSE); 3164 return FFESTC_orderBAD_; 3165 3166 default: 3167 ffestc_order_bad_ (); 3168 return FFESTC_orderBAD_; 3169 } 3170} 3171 3172/* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement 3173 3174 if (ffestc_order_implicitnone_() != FFESTC_orderOK_) 3175 return; */ 3176 3177static ffestcOrder_ 3178ffestc_order_implicitnone_ () 3179{ 3180 recurse: 3181 3182 switch (ffestw_state (ffestw_stack_top ())) 3183 { 3184 case FFESTV_stateNIL: 3185 ffestc_shriek_begin_program_ (); 3186 goto recurse; /* :::::::::::::::::::: */ 3187 3188 case FFESTV_statePROGRAM0: 3189 case FFESTV_statePROGRAM1: 3190 ffestw_update (NULL); 3191 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 3192 return FFESTC_orderOK_; 3193 3194 case FFESTV_stateSUBROUTINE0: 3195 case FFESTV_stateSUBROUTINE1: 3196 ffestw_update (NULL); 3197 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 3198 return FFESTC_orderOK_; 3199 3200 case FFESTV_stateFUNCTION0: 3201 case FFESTV_stateFUNCTION1: 3202 ffestw_update (NULL); 3203 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 3204 return FFESTC_orderOK_; 3205 3206 case FFESTV_stateMODULE0: 3207 case FFESTV_stateMODULE1: 3208 ffestw_update (NULL); 3209 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 3210 return FFESTC_orderOK_; 3211 3212 case FFESTV_stateBLOCKDATA0: 3213 case FFESTV_stateBLOCKDATA1: 3214 ffestw_update (NULL); 3215 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); 3216 return FFESTC_orderOK_; 3217 3218 case FFESTV_stateUSE: 3219#if FFESTR_F90 3220 ffestc_shriek_end_uses_ (TRUE); 3221#endif 3222 goto recurse; /* :::::::::::::::::::: */ 3223 3224 case FFESTV_stateWHERE: 3225 ffestc_order_bad_ (); 3226#if FFESTR_F90 3227 ffestc_shriek_where_ (FALSE); 3228#endif 3229 return FFESTC_orderBAD_; 3230 3231 case FFESTV_stateIF: 3232 ffestc_order_bad_ (); 3233 ffestc_shriek_if_ (FALSE); 3234 return FFESTC_orderBAD_; 3235 3236 default: 3237 ffestc_order_bad_ (); 3238 return FFESTC_orderBAD_; 3239 } 3240} 3241 3242/* ffestc_order_interface_ -- Check ordering on <interface> statement 3243 3244 if (ffestc_order_interface_() != FFESTC_orderOK_) 3245 return; */ 3246 3247#if FFESTR_F90 3248static ffestcOrder_ 3249ffestc_order_interface_ () 3250{ 3251 switch (ffestw_state (ffestw_stack_top ())) 3252 { 3253 case FFESTV_stateINTERFACE0: 3254 case FFESTV_stateINTERFACE1: 3255 return FFESTC_orderOK_; 3256 3257 case FFESTV_stateWHERE: 3258 ffestc_order_bad_ (); 3259 ffestc_shriek_where_ (FALSE); 3260 return FFESTC_orderBAD_; 3261 3262 case FFESTV_stateIF: 3263 ffestc_order_bad_ (); 3264 ffestc_shriek_if_ (FALSE); 3265 return FFESTC_orderBAD_; 3266 3267 default: 3268 ffestc_order_bad_ (); 3269 return FFESTC_orderBAD_; 3270 } 3271} 3272 3273#endif 3274/* ffestc_order_map_ -- Check ordering on <map> statement 3275 3276 if (ffestc_order_map_() != FFESTC_orderOK_) 3277 return; */ 3278 3279#if FFESTR_VXT 3280static ffestcOrder_ 3281ffestc_order_map_ () 3282{ 3283 switch (ffestw_state (ffestw_stack_top ())) 3284 { 3285 case FFESTV_stateMAP: 3286 return FFESTC_orderOK_; 3287 3288 case FFESTV_stateWHERE: 3289 ffestc_order_bad_ (); 3290 ffestc_shriek_where_ (FALSE); 3291 return FFESTC_orderBAD_; 3292 3293 case FFESTV_stateIF: 3294 ffestc_order_bad_ (); 3295 ffestc_shriek_if_ (FALSE); 3296 return FFESTC_orderBAD_; 3297 3298 default: 3299 ffestc_order_bad_ (); 3300 return FFESTC_orderBAD_; 3301 } 3302} 3303 3304#endif 3305/* ffestc_order_module_ -- Check ordering on <module> statement 3306 3307 if (ffestc_order_module_() != FFESTC_orderOK_) 3308 return; */ 3309 3310#if FFESTR_F90 3311static ffestcOrder_ 3312ffestc_order_module_ () 3313{ 3314 recurse: 3315 3316 switch (ffestw_state (ffestw_stack_top ())) 3317 { 3318 case FFESTV_stateMODULE0: 3319 case FFESTV_stateMODULE1: 3320 case FFESTV_stateMODULE2: 3321 case FFESTV_stateMODULE3: 3322 case FFESTV_stateMODULE4: 3323 case FFESTV_stateMODULE5: 3324 return FFESTC_orderOK_; 3325 3326 case FFESTV_stateUSE: 3327 ffestc_shriek_end_uses_ (TRUE); 3328 goto recurse; /* :::::::::::::::::::: */ 3329 3330 case FFESTV_stateWHERE: 3331 ffestc_order_bad_ (); 3332 ffestc_shriek_where_ (FALSE); 3333 return FFESTC_orderBAD_; 3334 3335 case FFESTV_stateIF: 3336 ffestc_order_bad_ (); 3337 ffestc_shriek_if_ (FALSE); 3338 return FFESTC_orderBAD_; 3339 3340 default: 3341 ffestc_order_bad_ (); 3342 return FFESTC_orderBAD_; 3343 } 3344} 3345 3346#endif 3347/* ffestc_order_parameter_ -- Check ordering on <parameter> statement 3348 3349 if (ffestc_order_parameter_() != FFESTC_orderOK_) 3350 return; */ 3351 3352static ffestcOrder_ 3353ffestc_order_parameter_ () 3354{ 3355 recurse: 3356 3357 switch (ffestw_state (ffestw_stack_top ())) 3358 { 3359 case FFESTV_stateNIL: 3360 ffestc_shriek_begin_program_ (); 3361 goto recurse; /* :::::::::::::::::::: */ 3362 3363 case FFESTV_statePROGRAM0: 3364 case FFESTV_statePROGRAM1: 3365 ffestw_update (NULL); 3366 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2); 3367 return FFESTC_orderOK_; 3368 3369 case FFESTV_stateSUBROUTINE0: 3370 case FFESTV_stateSUBROUTINE1: 3371 ffestw_update (NULL); 3372 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2); 3373 return FFESTC_orderOK_; 3374 3375 case FFESTV_stateFUNCTION0: 3376 case FFESTV_stateFUNCTION1: 3377 ffestw_update (NULL); 3378 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2); 3379 return FFESTC_orderOK_; 3380 3381 case FFESTV_stateMODULE0: 3382 case FFESTV_stateMODULE1: 3383 ffestw_update (NULL); 3384 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2); 3385 return FFESTC_orderOK_; 3386 3387 case FFESTV_stateBLOCKDATA0: 3388 case FFESTV_stateBLOCKDATA1: 3389 ffestw_update (NULL); 3390 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); 3391 return FFESTC_orderOK_; 3392 3393 case FFESTV_statePROGRAM2: 3394 case FFESTV_stateSUBROUTINE2: 3395 case FFESTV_stateFUNCTION2: 3396 case FFESTV_stateMODULE2: 3397 case FFESTV_stateBLOCKDATA2: 3398 case FFESTV_statePROGRAM3: 3399 case FFESTV_stateSUBROUTINE3: 3400 case FFESTV_stateFUNCTION3: 3401 case FFESTV_stateMODULE3: 3402 case FFESTV_stateBLOCKDATA3: 3403 case FFESTV_stateTYPE: /* GNU extension here! */ 3404 case FFESTV_stateSTRUCTURE: 3405 case FFESTV_stateUNION: 3406 case FFESTV_stateMAP: 3407 return FFESTC_orderOK_; 3408 3409 case FFESTV_stateUSE: 3410#if FFESTR_F90 3411 ffestc_shriek_end_uses_ (TRUE); 3412#endif 3413 goto recurse; /* :::::::::::::::::::: */ 3414 3415 case FFESTV_stateWHERE: 3416 ffestc_order_bad_ (); 3417#if FFESTR_F90 3418 ffestc_shriek_where_ (FALSE); 3419#endif 3420 return FFESTC_orderBAD_; 3421 3422 case FFESTV_stateIF: 3423 ffestc_order_bad_ (); 3424 ffestc_shriek_if_ (FALSE); 3425 return FFESTC_orderBAD_; 3426 3427 default: 3428 ffestc_order_bad_ (); 3429 return FFESTC_orderBAD_; 3430 } 3431} 3432 3433/* ffestc_order_program_ -- Check ordering on <program> statement 3434 3435 if (ffestc_order_program_() != FFESTC_orderOK_) 3436 return; */ 3437 3438static ffestcOrder_ 3439ffestc_order_program_ () 3440{ 3441 recurse: 3442 3443 switch (ffestw_state (ffestw_stack_top ())) 3444 { 3445 case FFESTV_stateNIL: 3446 ffestc_shriek_begin_program_ (); 3447 goto recurse; /* :::::::::::::::::::: */ 3448 3449 case FFESTV_statePROGRAM0: 3450 case FFESTV_statePROGRAM1: 3451 case FFESTV_statePROGRAM2: 3452 case FFESTV_statePROGRAM3: 3453 case FFESTV_statePROGRAM4: 3454 case FFESTV_statePROGRAM5: 3455 return FFESTC_orderOK_; 3456 3457 case FFESTV_stateUSE: 3458#if FFESTR_F90 3459 ffestc_shriek_end_uses_ (TRUE); 3460#endif 3461 goto recurse; /* :::::::::::::::::::: */ 3462 3463 case FFESTV_stateWHERE: 3464 ffestc_order_bad_ (); 3465#if FFESTR_F90 3466 ffestc_shriek_where_ (FALSE); 3467#endif 3468 return FFESTC_orderBAD_; 3469 3470 case FFESTV_stateIF: 3471 ffestc_order_bad_ (); 3472 ffestc_shriek_if_ (FALSE); 3473 return FFESTC_orderBAD_; 3474 3475 default: 3476 ffestc_order_bad_ (); 3477 return FFESTC_orderBAD_; 3478 } 3479} 3480 3481/* ffestc_order_progspec_ -- Check ordering on <progspec> statement 3482 3483 if (ffestc_order_progspec_() != FFESTC_orderOK_) 3484 return; */ 3485 3486static ffestcOrder_ 3487ffestc_order_progspec_ () 3488{ 3489 recurse: 3490 3491 switch (ffestw_state (ffestw_stack_top ())) 3492 { 3493 case FFESTV_stateNIL: 3494 ffestc_shriek_begin_program_ (); 3495 goto recurse; /* :::::::::::::::::::: */ 3496 3497 case FFESTV_statePROGRAM0: 3498 case FFESTV_statePROGRAM1: 3499 case FFESTV_statePROGRAM2: 3500 ffestw_update (NULL); 3501 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 3502 return FFESTC_orderOK_; 3503 3504 case FFESTV_stateSUBROUTINE0: 3505 case FFESTV_stateSUBROUTINE1: 3506 case FFESTV_stateSUBROUTINE2: 3507 ffestw_update (NULL); 3508 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 3509 return FFESTC_orderOK_; 3510 3511 case FFESTV_stateFUNCTION0: 3512 case FFESTV_stateFUNCTION1: 3513 case FFESTV_stateFUNCTION2: 3514 ffestw_update (NULL); 3515 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 3516 return FFESTC_orderOK_; 3517 3518 case FFESTV_stateMODULE0: 3519 case FFESTV_stateMODULE1: 3520 case FFESTV_stateMODULE2: 3521 ffestw_update (NULL); 3522 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 3523 return FFESTC_orderOK_; 3524 3525 case FFESTV_statePROGRAM3: 3526 case FFESTV_stateSUBROUTINE3: 3527 case FFESTV_stateFUNCTION3: 3528 case FFESTV_stateMODULE3: 3529 return FFESTC_orderOK_; 3530 3531 case FFESTV_stateBLOCKDATA0: 3532 case FFESTV_stateBLOCKDATA1: 3533 case FFESTV_stateBLOCKDATA2: 3534 ffestw_update (NULL); 3535 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); 3536 if (ffe_is_pedantic ()) 3537 { 3538 ffebad_start (FFEBAD_BLOCKDATA_STMT); 3539 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 3540 ffelex_token_where_column (ffesta_tokens[0])); 3541 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 3542 ffebad_finish (); 3543 } 3544 return FFESTC_orderOK_; 3545 3546 case FFESTV_stateUSE: 3547#if FFESTR_F90 3548 ffestc_shriek_end_uses_ (TRUE); 3549#endif 3550 goto recurse; /* :::::::::::::::::::: */ 3551 3552 case FFESTV_stateWHERE: 3553 ffestc_order_bad_ (); 3554#if FFESTR_F90 3555 ffestc_shriek_where_ (FALSE); 3556#endif 3557 return FFESTC_orderBAD_; 3558 3559 case FFESTV_stateIF: 3560 ffestc_order_bad_ (); 3561 ffestc_shriek_if_ (FALSE); 3562 return FFESTC_orderBAD_; 3563 3564 default: 3565 ffestc_order_bad_ (); 3566 return FFESTC_orderBAD_; 3567 } 3568} 3569 3570/* ffestc_order_record_ -- Check ordering on RECORD statement 3571 3572 if (ffestc_order_record_() != FFESTC_orderOK_) 3573 return; */ 3574 3575#if FFESTR_VXT 3576static ffestcOrder_ 3577ffestc_order_record_ () 3578{ 3579 recurse: 3580 3581 switch (ffestw_state (ffestw_stack_top ())) 3582 { 3583 case FFESTV_stateNIL: 3584 ffestc_shriek_begin_program_ (); 3585 goto recurse; /* :::::::::::::::::::: */ 3586 3587 case FFESTV_statePROGRAM0: 3588 case FFESTV_statePROGRAM1: 3589 case FFESTV_statePROGRAM2: 3590 ffestw_update (NULL); 3591 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 3592 return FFESTC_orderOK_; 3593 3594 case FFESTV_stateSUBROUTINE0: 3595 case FFESTV_stateSUBROUTINE1: 3596 case FFESTV_stateSUBROUTINE2: 3597 ffestw_update (NULL); 3598 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 3599 return FFESTC_orderOK_; 3600 3601 case FFESTV_stateFUNCTION0: 3602 case FFESTV_stateFUNCTION1: 3603 case FFESTV_stateFUNCTION2: 3604 ffestw_update (NULL); 3605 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 3606 return FFESTC_orderOK_; 3607 3608 case FFESTV_stateMODULE0: 3609 case FFESTV_stateMODULE1: 3610 case FFESTV_stateMODULE2: 3611 ffestw_update (NULL); 3612 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 3613 return FFESTC_orderOK_; 3614 3615 case FFESTV_stateBLOCKDATA0: 3616 case FFESTV_stateBLOCKDATA1: 3617 case FFESTV_stateBLOCKDATA2: 3618 ffestw_update (NULL); 3619 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); 3620 return FFESTC_orderOK_; 3621 3622 case FFESTV_statePROGRAM3: 3623 case FFESTV_stateSUBROUTINE3: 3624 case FFESTV_stateFUNCTION3: 3625 case FFESTV_stateMODULE3: 3626 case FFESTV_stateBLOCKDATA3: 3627 case FFESTV_stateSTRUCTURE: 3628 case FFESTV_stateMAP: 3629 return FFESTC_orderOK_; 3630 3631 case FFESTV_stateUSE: 3632#if FFESTR_F90 3633 ffestc_shriek_end_uses_ (TRUE); 3634#endif 3635 goto recurse; /* :::::::::::::::::::: */ 3636 3637 case FFESTV_stateWHERE: 3638 ffestc_order_bad_ (); 3639#if FFESTR_F90 3640 ffestc_shriek_where_ (FALSE); 3641#endif 3642 return FFESTC_orderBAD_; 3643 3644 case FFESTV_stateIF: 3645 ffestc_order_bad_ (); 3646 ffestc_shriek_if_ (FALSE); 3647 return FFESTC_orderBAD_; 3648 3649 default: 3650 ffestc_order_bad_ (); 3651 return FFESTC_orderBAD_; 3652 } 3653} 3654 3655#endif 3656/* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement 3657 3658 if (ffestc_order_selectcase_() != FFESTC_orderOK_) 3659 return; */ 3660 3661static ffestcOrder_ 3662ffestc_order_selectcase_ () 3663{ 3664 switch (ffestw_state (ffestw_stack_top ())) 3665 { 3666 case FFESTV_stateSELECT0: 3667 case FFESTV_stateSELECT1: 3668 return FFESTC_orderOK_; 3669 3670 case FFESTV_stateWHERE: 3671 ffestc_order_bad_ (); 3672#if FFESTR_F90 3673 ffestc_shriek_where_ (FALSE); 3674#endif 3675 return FFESTC_orderBAD_; 3676 3677 case FFESTV_stateIF: 3678 ffestc_order_bad_ (); 3679 ffestc_shriek_if_ (FALSE); 3680 return FFESTC_orderBAD_; 3681 3682 default: 3683 ffestc_order_bad_ (); 3684 return FFESTC_orderBAD_; 3685 } 3686} 3687 3688/* ffestc_order_sfunc_ -- Check ordering on statement-function definition 3689 3690 if (ffestc_order_sfunc_() != FFESTC_orderOK_) 3691 return; */ 3692 3693static ffestcOrder_ 3694ffestc_order_sfunc_ () 3695{ 3696 recurse: 3697 3698 switch (ffestw_state (ffestw_stack_top ())) 3699 { 3700 case FFESTV_stateNIL: 3701 ffestc_shriek_begin_program_ (); 3702 goto recurse; /* :::::::::::::::::::: */ 3703 3704 case FFESTV_statePROGRAM0: 3705 case FFESTV_statePROGRAM1: 3706 case FFESTV_statePROGRAM2: 3707 ffestw_update (NULL); 3708 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 3709 return FFESTC_orderOK_; 3710 3711 case FFESTV_stateSUBROUTINE0: 3712 case FFESTV_stateSUBROUTINE1: 3713 case FFESTV_stateSUBROUTINE2: 3714 ffestw_update (NULL); 3715 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 3716 return FFESTC_orderOK_; 3717 3718 case FFESTV_stateFUNCTION0: 3719 case FFESTV_stateFUNCTION1: 3720 case FFESTV_stateFUNCTION2: 3721 ffestw_update (NULL); 3722 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 3723 return FFESTC_orderOK_; 3724 3725 case FFESTV_statePROGRAM3: 3726 case FFESTV_stateSUBROUTINE3: 3727 case FFESTV_stateFUNCTION3: 3728 return FFESTC_orderOK_; 3729 3730 case FFESTV_stateUSE: 3731#if FFESTR_F90 3732 ffestc_shriek_end_uses_ (TRUE); 3733#endif 3734 goto recurse; /* :::::::::::::::::::: */ 3735 3736 case FFESTV_stateWHERE: 3737 ffestc_order_bad_ (); 3738#if FFESTR_F90 3739 ffestc_shriek_where_ (FALSE); 3740#endif 3741 return FFESTC_orderBAD_; 3742 3743 case FFESTV_stateIF: 3744 ffestc_order_bad_ (); 3745 ffestc_shriek_if_ (FALSE); 3746 return FFESTC_orderBAD_; 3747 3748 default: 3749 ffestc_order_bad_ (); 3750 return FFESTC_orderBAD_; 3751 } 3752} 3753 3754/* ffestc_order_spec_ -- Check ordering on <spec> statement 3755 3756 if (ffestc_order_spec_() != FFESTC_orderOK_) 3757 return; */ 3758 3759#if FFESTR_F90 3760static ffestcOrder_ 3761ffestc_order_spec_ () 3762{ 3763 recurse: 3764 3765 switch (ffestw_state (ffestw_stack_top ())) 3766 { 3767 case FFESTV_stateNIL: 3768 ffestc_shriek_begin_program_ (); 3769 goto recurse; /* :::::::::::::::::::: */ 3770 3771 case FFESTV_stateSUBROUTINE0: 3772 case FFESTV_stateSUBROUTINE1: 3773 case FFESTV_stateSUBROUTINE2: 3774 ffestw_update (NULL); 3775 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 3776 return FFESTC_orderOK_; 3777 3778 case FFESTV_stateFUNCTION0: 3779 case FFESTV_stateFUNCTION1: 3780 case FFESTV_stateFUNCTION2: 3781 ffestw_update (NULL); 3782 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 3783 return FFESTC_orderOK_; 3784 3785 case FFESTV_stateMODULE0: 3786 case FFESTV_stateMODULE1: 3787 case FFESTV_stateMODULE2: 3788 ffestw_update (NULL); 3789 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 3790 return FFESTC_orderOK_; 3791 3792 case FFESTV_stateSUBROUTINE3: 3793 case FFESTV_stateFUNCTION3: 3794 case FFESTV_stateMODULE3: 3795 return FFESTC_orderOK_; 3796 3797 case FFESTV_stateUSE: 3798#if FFESTR_F90 3799 ffestc_shriek_end_uses_ (TRUE); 3800#endif 3801 goto recurse; /* :::::::::::::::::::: */ 3802 3803 case FFESTV_stateWHERE: 3804 ffestc_order_bad_ (); 3805#if FFESTR_F90 3806 ffestc_shriek_where_ (FALSE); 3807#endif 3808 return FFESTC_orderBAD_; 3809 3810 case FFESTV_stateIF: 3811 ffestc_order_bad_ (); 3812 ffestc_shriek_if_ (FALSE); 3813 return FFESTC_orderBAD_; 3814 3815 default: 3816 ffestc_order_bad_ (); 3817 return FFESTC_orderBAD_; 3818 } 3819} 3820 3821#endif 3822/* ffestc_order_structure_ -- Check ordering on <structure> statement 3823 3824 if (ffestc_order_structure_() != FFESTC_orderOK_) 3825 return; */ 3826 3827#if FFESTR_VXT 3828static ffestcOrder_ 3829ffestc_order_structure_ () 3830{ 3831 switch (ffestw_state (ffestw_stack_top ())) 3832 { 3833 case FFESTV_stateSTRUCTURE: 3834 return FFESTC_orderOK_; 3835 3836 case FFESTV_stateWHERE: 3837 ffestc_order_bad_ (); 3838#if FFESTR_F90 3839 ffestc_shriek_where_ (FALSE); 3840#endif 3841 return FFESTC_orderBAD_; 3842 3843 case FFESTV_stateIF: 3844 ffestc_order_bad_ (); 3845 ffestc_shriek_if_ (FALSE); 3846 return FFESTC_orderBAD_; 3847 3848 default: 3849 ffestc_order_bad_ (); 3850 return FFESTC_orderBAD_; 3851 } 3852} 3853 3854#endif 3855/* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement 3856 3857 if (ffestc_order_subroutine_() != FFESTC_orderOK_) 3858 return; */ 3859 3860static ffestcOrder_ 3861ffestc_order_subroutine_ () 3862{ 3863 recurse: 3864 3865 switch (ffestw_state (ffestw_stack_top ())) 3866 { 3867 case FFESTV_stateSUBROUTINE0: 3868 case FFESTV_stateSUBROUTINE1: 3869 case FFESTV_stateSUBROUTINE2: 3870 case FFESTV_stateSUBROUTINE3: 3871 case FFESTV_stateSUBROUTINE4: 3872 case FFESTV_stateSUBROUTINE5: 3873 return FFESTC_orderOK_; 3874 3875 case FFESTV_stateUSE: 3876#if FFESTR_F90 3877 ffestc_shriek_end_uses_ (TRUE); 3878#endif 3879 goto recurse; /* :::::::::::::::::::: */ 3880 3881 case FFESTV_stateWHERE: 3882 ffestc_order_bad_ (); 3883#if FFESTR_F90 3884 ffestc_shriek_where_ (FALSE); 3885#endif 3886 return FFESTC_orderBAD_; 3887 3888 case FFESTV_stateIF: 3889 ffestc_order_bad_ (); 3890 ffestc_shriek_if_ (FALSE); 3891 return FFESTC_orderBAD_; 3892 3893 default: 3894 ffestc_order_bad_ (); 3895 return FFESTC_orderBAD_; 3896 } 3897} 3898 3899/* ffestc_order_type_ -- Check ordering on <type> statement 3900 3901 if (ffestc_order_type_() != FFESTC_orderOK_) 3902 return; */ 3903 3904#if FFESTR_F90 3905static ffestcOrder_ 3906ffestc_order_type_ () 3907{ 3908 switch (ffestw_state (ffestw_stack_top ())) 3909 { 3910 case FFESTV_stateTYPE: 3911 return FFESTC_orderOK_; 3912 3913 case FFESTV_stateWHERE: 3914 ffestc_order_bad_ (); 3915 ffestc_shriek_where_ (FALSE); 3916 return FFESTC_orderBAD_; 3917 3918 case FFESTV_stateIF: 3919 ffestc_order_bad_ (); 3920 ffestc_shriek_if_ (FALSE); 3921 return FFESTC_orderBAD_; 3922 3923 default: 3924 ffestc_order_bad_ (); 3925 return FFESTC_orderBAD_; 3926 } 3927} 3928 3929#endif 3930/* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement 3931 3932 if (ffestc_order_typedecl_() != FFESTC_orderOK_) 3933 return; */ 3934 3935static ffestcOrder_ 3936ffestc_order_typedecl_ () 3937{ 3938 recurse: 3939 3940 switch (ffestw_state (ffestw_stack_top ())) 3941 { 3942 case FFESTV_stateNIL: 3943 ffestc_shriek_begin_program_ (); 3944 goto recurse; /* :::::::::::::::::::: */ 3945 3946 case FFESTV_statePROGRAM0: 3947 case FFESTV_statePROGRAM1: 3948 case FFESTV_statePROGRAM2: 3949 ffestw_update (NULL); 3950 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 3951 return FFESTC_orderOK_; 3952 3953 case FFESTV_stateSUBROUTINE0: 3954 case FFESTV_stateSUBROUTINE1: 3955 case FFESTV_stateSUBROUTINE2: 3956 ffestw_update (NULL); 3957 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 3958 return FFESTC_orderOK_; 3959 3960 case FFESTV_stateFUNCTION0: 3961 case FFESTV_stateFUNCTION1: 3962 case FFESTV_stateFUNCTION2: 3963 ffestw_update (NULL); 3964 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 3965 return FFESTC_orderOK_; 3966 3967 case FFESTV_stateMODULE0: 3968 case FFESTV_stateMODULE1: 3969 case FFESTV_stateMODULE2: 3970 ffestw_update (NULL); 3971 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 3972 return FFESTC_orderOK_; 3973 3974 case FFESTV_stateBLOCKDATA0: 3975 case FFESTV_stateBLOCKDATA1: 3976 case FFESTV_stateBLOCKDATA2: 3977 ffestw_update (NULL); 3978 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); 3979 return FFESTC_orderOK_; 3980 3981 case FFESTV_statePROGRAM3: 3982 case FFESTV_stateSUBROUTINE3: 3983 case FFESTV_stateFUNCTION3: 3984 case FFESTV_stateMODULE3: 3985 case FFESTV_stateBLOCKDATA3: 3986 return FFESTC_orderOK_; 3987 3988 case FFESTV_stateUSE: 3989#if FFESTR_F90 3990 ffestc_shriek_end_uses_ (TRUE); 3991#endif 3992 goto recurse; /* :::::::::::::::::::: */ 3993 3994 case FFESTV_stateWHERE: 3995 ffestc_order_bad_ (); 3996#if FFESTR_F90 3997 ffestc_shriek_where_ (FALSE); 3998#endif 3999 return FFESTC_orderBAD_; 4000 4001 case FFESTV_stateIF: 4002 ffestc_order_bad_ (); 4003 ffestc_shriek_if_ (FALSE); 4004 return FFESTC_orderBAD_; 4005 4006 default: 4007 ffestc_order_bad_ (); 4008 return FFESTC_orderBAD_; 4009 } 4010} 4011 4012/* ffestc_order_union_ -- Check ordering on <union> statement 4013 4014 if (ffestc_order_union_() != FFESTC_orderOK_) 4015 return; */ 4016 4017#if FFESTR_VXT 4018static ffestcOrder_ 4019ffestc_order_union_ () 4020{ 4021 switch (ffestw_state (ffestw_stack_top ())) 4022 { 4023 case FFESTV_stateUNION: 4024 return FFESTC_orderOK_; 4025 4026 case FFESTV_stateWHERE: 4027 ffestc_order_bad_ (); 4028#if FFESTR_F90 4029 ffestc_shriek_where_ (FALSE); 4030#endif 4031 return FFESTC_orderBAD_; 4032 4033 case FFESTV_stateIF: 4034 ffestc_order_bad_ (); 4035 ffestc_shriek_if_ (FALSE); 4036 return FFESTC_orderBAD_; 4037 4038 default: 4039 ffestc_order_bad_ (); 4040 return FFESTC_orderBAD_; 4041 } 4042} 4043 4044#endif 4045/* ffestc_order_unit_ -- Check ordering on <unit> statement 4046 4047 if (ffestc_order_unit_() != FFESTC_orderOK_) 4048 return; */ 4049 4050static ffestcOrder_ 4051ffestc_order_unit_ () 4052{ 4053 switch (ffestw_state (ffestw_stack_top ())) 4054 { 4055 case FFESTV_stateNIL: 4056 return FFESTC_orderOK_; 4057 4058 case FFESTV_stateWHERE: 4059 ffestc_order_bad_ (); 4060#if FFESTR_F90 4061 ffestc_shriek_where_ (FALSE); 4062#endif 4063 return FFESTC_orderBAD_; 4064 4065 case FFESTV_stateIF: 4066 ffestc_order_bad_ (); 4067 ffestc_shriek_if_ (FALSE); 4068 return FFESTC_orderBAD_; 4069 4070 default: 4071 ffestc_order_bad_ (); 4072 return FFESTC_orderBAD_; 4073 } 4074} 4075 4076/* ffestc_order_use_ -- Check ordering on USE statement 4077 4078 if (ffestc_order_use_() != FFESTC_orderOK_) 4079 return; */ 4080 4081#if FFESTR_F90 4082static ffestcOrder_ 4083ffestc_order_use_ () 4084{ 4085 recurse: 4086 4087 switch (ffestw_state (ffestw_stack_top ())) 4088 { 4089 case FFESTV_stateNIL: 4090 ffestc_shriek_begin_program_ (); 4091 goto recurse; /* :::::::::::::::::::: */ 4092 4093 case FFESTV_statePROGRAM0: 4094 ffestw_update (NULL); 4095 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1); 4096 ffestc_shriek_begin_uses_ (); 4097 goto recurse; /* :::::::::::::::::::: */ 4098 4099 case FFESTV_stateSUBROUTINE0: 4100 ffestw_update (NULL); 4101 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1); 4102 ffestc_shriek_begin_uses_ (); 4103 goto recurse; /* :::::::::::::::::::: */ 4104 4105 case FFESTV_stateFUNCTION0: 4106 ffestw_update (NULL); 4107 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1); 4108 ffestc_shriek_begin_uses_ (); 4109 goto recurse; /* :::::::::::::::::::: */ 4110 4111 case FFESTV_stateMODULE0: 4112 ffestw_update (NULL); 4113 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1); 4114 ffestc_shriek_begin_uses_ (); 4115 goto recurse; /* :::::::::::::::::::: */ 4116 4117 case FFESTV_stateUSE: 4118 return FFESTC_orderOK_; 4119 4120 case FFESTV_stateWHERE: 4121 ffestc_order_bad_ (); 4122 ffestc_shriek_where_ (FALSE); 4123 return FFESTC_orderBAD_; 4124 4125 case FFESTV_stateIF: 4126 ffestc_order_bad_ (); 4127 ffestc_shriek_if_ (FALSE); 4128 return FFESTC_orderBAD_; 4129 4130 default: 4131 ffestc_order_bad_ (); 4132 return FFESTC_orderBAD_; 4133 } 4134} 4135 4136#endif 4137/* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement 4138 4139 if (ffestc_order_vxtstructure_() != FFESTC_orderOK_) 4140 return; */ 4141 4142#if FFESTR_VXT 4143static ffestcOrder_ 4144ffestc_order_vxtstructure_ () 4145{ 4146 recurse: 4147 4148 switch (ffestw_state (ffestw_stack_top ())) 4149 { 4150 case FFESTV_stateNIL: 4151 ffestc_shriek_begin_program_ (); 4152 goto recurse; /* :::::::::::::::::::: */ 4153 4154 case FFESTV_statePROGRAM0: 4155 case FFESTV_statePROGRAM1: 4156 case FFESTV_statePROGRAM2: 4157 ffestw_update (NULL); 4158 ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); 4159 return FFESTC_orderOK_; 4160 4161 case FFESTV_stateSUBROUTINE0: 4162 case FFESTV_stateSUBROUTINE1: 4163 case FFESTV_stateSUBROUTINE2: 4164 ffestw_update (NULL); 4165 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); 4166 return FFESTC_orderOK_; 4167 4168 case FFESTV_stateFUNCTION0: 4169 case FFESTV_stateFUNCTION1: 4170 case FFESTV_stateFUNCTION2: 4171 ffestw_update (NULL); 4172 ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); 4173 return FFESTC_orderOK_; 4174 4175 case FFESTV_stateMODULE0: 4176 case FFESTV_stateMODULE1: 4177 case FFESTV_stateMODULE2: 4178 ffestw_update (NULL); 4179 ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); 4180 return FFESTC_orderOK_; 4181 4182 case FFESTV_stateBLOCKDATA0: 4183 case FFESTV_stateBLOCKDATA1: 4184 case FFESTV_stateBLOCKDATA2: 4185 ffestw_update (NULL); 4186 ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); 4187 return FFESTC_orderOK_; 4188 4189 case FFESTV_statePROGRAM3: 4190 case FFESTV_stateSUBROUTINE3: 4191 case FFESTV_stateFUNCTION3: 4192 case FFESTV_stateMODULE3: 4193 case FFESTV_stateBLOCKDATA3: 4194 case FFESTV_stateSTRUCTURE: 4195 case FFESTV_stateMAP: 4196 return FFESTC_orderOK_; 4197 4198 case FFESTV_stateUSE: 4199#if FFESTR_F90 4200 ffestc_shriek_end_uses_ (TRUE); 4201#endif 4202 goto recurse; /* :::::::::::::::::::: */ 4203 4204 case FFESTV_stateWHERE: 4205 ffestc_order_bad_ (); 4206#if FFESTR_F90 4207 ffestc_shriek_where_ (FALSE); 4208#endif 4209 return FFESTC_orderBAD_; 4210 4211 case FFESTV_stateIF: 4212 ffestc_order_bad_ (); 4213 ffestc_shriek_if_ (FALSE); 4214 return FFESTC_orderBAD_; 4215 4216 default: 4217 ffestc_order_bad_ (); 4218 return FFESTC_orderBAD_; 4219 } 4220} 4221 4222#endif 4223/* ffestc_order_where_ -- Check ordering on <where> statement 4224 4225 if (ffestc_order_where_() != FFESTC_orderOK_) 4226 return; */ 4227 4228#if FFESTR_F90 4229static ffestcOrder_ 4230ffestc_order_where_ () 4231{ 4232 switch (ffestw_state (ffestw_stack_top ())) 4233 { 4234 case FFESTV_stateWHERETHEN: 4235 return FFESTC_orderOK_; 4236 4237 case FFESTV_stateWHERE: 4238 ffestc_order_bad_ (); 4239 ffestc_shriek_where_ (FALSE); 4240 return FFESTC_orderBAD_; 4241 4242 case FFESTV_stateIF: 4243 ffestc_order_bad_ (); 4244 ffestc_shriek_if_ (FALSE); 4245 return FFESTC_orderBAD_; 4246 4247 default: 4248 ffestc_order_bad_ (); 4249 return FFESTC_orderBAD_; 4250 } 4251} 4252 4253#endif 4254/* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and 4255 ENTRY (prior to the first executable statement). */ 4256 4257static void 4258ffestc_promote_dummy_ (ffelexToken t) 4259{ 4260 ffesymbol s; 4261 ffesymbolAttrs sa; 4262 ffesymbolAttrs na; 4263 ffebld e; 4264 bool sfref_ok; 4265 4266 assert (t != NULL); 4267 4268 if (ffelex_token_type (t) == FFELEX_typeASTERISK) 4269 { 4270 ffebld_append_item (&ffestc_local_.dummy.list_bottom, 4271 ffebld_new_star ()); 4272 return; /* Don't bother with alternate returns! */ 4273 } 4274 4275 s = ffesymbol_declare_local (t, FALSE); 4276 sa = ffesymbol_attrs (s); 4277 4278 /* Figure out what kind of object we've got based on previous declarations 4279 of or references to the object. */ 4280 4281 sfref_ok = FALSE; 4282 4283 if (sa & FFESYMBOL_attrsANY) 4284 na = sa; 4285 else if (sa & FFESYMBOL_attrsDUMMY) 4286 { 4287 if (ffestc_entry_num_ == ffesymbol_maxentrynum (s)) 4288 { /* Seen this one twice in this list! */ 4289 na = FFESYMBOL_attrsetNONE; 4290 } 4291 else 4292 na = sa; 4293 sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef 4294 previously, since already declared as a 4295 dummy arg. */ 4296 } 4297 else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE 4298 | FFESYMBOL_attrsADJUSTS 4299 | FFESYMBOL_attrsANY 4300 | FFESYMBOL_attrsANYLEN 4301 | FFESYMBOL_attrsANYSIZE 4302 | FFESYMBOL_attrsARRAY 4303 | FFESYMBOL_attrsDUMMY 4304 | FFESYMBOL_attrsEXTERNAL 4305 | FFESYMBOL_attrsSFARG 4306 | FFESYMBOL_attrsTYPE))) 4307 na = sa | FFESYMBOL_attrsDUMMY; 4308 else 4309 na = FFESYMBOL_attrsetNONE; 4310 4311 if (!ffesymbol_is_specable (s) 4312 && (!sfref_ok 4313 || (ffesymbol_where (s) != FFEINFO_whereDUMMY))) 4314 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 4315 4316 /* Now see what we've got for a new object: NONE means a new error cropped 4317 up; ANY means an old error to be ignored; otherwise, everything's ok, 4318 update the object (symbol) and continue on. */ 4319 4320 if (na == FFESYMBOL_attrsetNONE) 4321 ffesymbol_error (s, t); 4322 else if (!(na & FFESYMBOL_attrsANY)) 4323 { 4324 ffesymbol_set_attrs (s, na); 4325 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 4326 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 4327 ffesymbol_set_maxentrynum (s, ffestc_entry_num_); 4328 ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1); 4329 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 4330 FFEINTRIN_impNONE); 4331 ffebld_set_info (e, 4332 ffeinfo_new (FFEINFO_basictypeNONE, 4333 FFEINFO_kindtypeNONE, 4334 0, 4335 FFEINFO_kindNONE, 4336 FFEINFO_whereNONE, 4337 FFETARGET_charactersizeNONE)); 4338 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e); 4339 ffesymbol_signal_unreported (s); 4340 } 4341} 4342 4343/* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context 4344 4345 ffestc_promote_execdummy_(t); 4346 4347 Invoked for each token in dummy arg list of ENTRY when the statement 4348 follows the first executable statement. */ 4349 4350static void 4351ffestc_promote_execdummy_ (ffelexToken t) 4352{ 4353 ffesymbol s; 4354 ffesymbolAttrs sa; 4355 ffesymbolAttrs na; 4356 ffesymbolState ss; 4357 ffesymbolState ns; 4358 ffeinfoKind kind; 4359 ffeinfoWhere where; 4360 ffebld e; 4361 4362 assert (t != NULL); 4363 4364 if (ffelex_token_type (t) == FFELEX_typeASTERISK) 4365 { 4366 ffebld_append_item (&ffestc_local_.dummy.list_bottom, 4367 ffebld_new_star ()); 4368 return; /* Don't bother with alternate returns! */ 4369 } 4370 4371 s = ffesymbol_declare_local (t, FALSE); 4372 na = sa = ffesymbol_attrs (s); 4373 ss = ffesymbol_state (s); 4374 kind = ffesymbol_kind (s); 4375 where = ffesymbol_where (s); 4376 4377 if (ffestc_entry_num_ == ffesymbol_maxentrynum (s)) 4378 { /* Seen this one twice in this list! */ 4379 na = FFESYMBOL_attrsetNONE; 4380 } 4381 4382 /* Figure out what kind of object we've got based on previous declarations 4383 of or references to the object. */ 4384 4385 ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */ 4386 4387 switch (kind) 4388 { 4389 case FFEINFO_kindENTITY: 4390 case FFEINFO_kindFUNCTION: 4391 case FFEINFO_kindSUBROUTINE: 4392 break; /* These are fine, as far as we know. */ 4393 4394 case FFEINFO_kindNONE: 4395 if (sa & FFESYMBOL_attrsDUMMY) 4396 ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */ 4397 else if (sa & FFESYMBOL_attrsANYLEN) 4398 { 4399 kind = FFEINFO_kindENTITY; 4400 where = FFEINFO_whereDUMMY; 4401 } 4402 else if (sa & FFESYMBOL_attrsACTUALARG) 4403 na = FFESYMBOL_attrsetNONE; 4404 else 4405 { 4406 na = sa | FFESYMBOL_attrsDUMMY; 4407 ns = FFESYMBOL_stateUNCERTAIN; 4408 } 4409 break; 4410 4411 default: 4412 na = FFESYMBOL_attrsetNONE; /* Error. */ 4413 break; 4414 } 4415 4416 switch (where) 4417 { 4418 case FFEINFO_whereDUMMY: 4419 break; /* This is fine. */ 4420 4421 case FFEINFO_whereNONE: 4422 where = FFEINFO_whereDUMMY; 4423 break; 4424 4425 default: 4426 na = FFESYMBOL_attrsetNONE; /* Error. */ 4427 break; 4428 } 4429 4430 /* Now see what we've got for a new object: NONE means a new error cropped 4431 up; ANY means an old error to be ignored; otherwise, everything's ok, 4432 update the object (symbol) and continue on. */ 4433 4434 if (na == FFESYMBOL_attrsetNONE) 4435 ffesymbol_error (s, t); 4436 else if (!(na & FFESYMBOL_attrsANY)) 4437 { 4438 ffesymbol_set_attrs (s, na); 4439 ffesymbol_set_state (s, ns); 4440 ffesymbol_set_maxentrynum (s, ffestc_entry_num_); 4441 ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1); 4442 if ((ns == FFESYMBOL_stateUNDERSTOOD) 4443 && (kind != FFEINFO_kindSUBROUTINE) 4444 && !ffeimplic_establish_symbol (s)) 4445 { 4446 ffesymbol_error (s, t); 4447 return; 4448 } 4449 ffesymbol_set_info (s, 4450 ffeinfo_new (ffesymbol_basictype (s), 4451 ffesymbol_kindtype (s), 4452 ffesymbol_rank (s), 4453 kind, 4454 where, 4455 ffesymbol_size (s))); 4456 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 4457 FFEINTRIN_impNONE); 4458 ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s))); 4459 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e); 4460 s = ffecom_sym_learned (s); 4461 ffesymbol_signal_unreported (s); 4462 } 4463} 4464 4465/* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable 4466 4467 ffestc_promote_sfdummy_(t); 4468 4469 Invoked for each token in dummy arg list of statement function. 4470 4471 22-Oct-91 JCB 1.1 4472 Reject arg if CHARACTER*(*). */ 4473 4474static void 4475ffestc_promote_sfdummy_ (ffelexToken t) 4476{ 4477 ffesymbol s; 4478 ffesymbol sp; /* Parent symbol. */ 4479 ffesymbolAttrs sa; 4480 ffesymbolAttrs na; 4481 ffebld e; 4482 4483 assert (t != NULL); 4484 4485 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj; 4486 also sets sfa_dummy_parent to 4487 parent symbol. */ 4488 if (ffesymbol_state (s) != FFESYMBOL_stateNONE) 4489 { 4490 ffesymbol_error (s, t); /* Dummy already in list. */ 4491 return; 4492 } 4493 4494 sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used 4495 for dummy. */ 4496 sa = ffesymbol_attrs (sp); 4497 4498 /* Figure out what kind of object we've got based on previous declarations 4499 of or references to the object. */ 4500 4501 if (!ffesymbol_is_specable (sp) 4502 && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY) 4503 || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL) 4504 && (ffesymbol_where (sp) != FFEINFO_whereCOMMON) 4505 && (ffesymbol_where (sp) != FFEINFO_whereDUMMY) 4506 && (ffesymbol_where (sp) != FFEINFO_whereNONE)))) 4507 na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */ 4508 else if (sa & FFESYMBOL_attrsANY) 4509 na = sa; 4510 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS 4511 | FFESYMBOL_attrsCOMMON 4512 | FFESYMBOL_attrsDUMMY 4513 | FFESYMBOL_attrsEQUIV 4514 | FFESYMBOL_attrsINIT 4515 | FFESYMBOL_attrsNAMELIST 4516 | FFESYMBOL_attrsRESULT 4517 | FFESYMBOL_attrsSAVE 4518 | FFESYMBOL_attrsSFARG 4519 | FFESYMBOL_attrsTYPE))) 4520 na = sa | FFESYMBOL_attrsSFARG; 4521 else 4522 na = FFESYMBOL_attrsetNONE; 4523 4524 /* Now see what we've got for a new object: NONE means a new error cropped 4525 up; ANY means an old error to be ignored; otherwise, everything's ok, 4526 update the object (symbol) and continue on. */ 4527 4528 if (na == FFESYMBOL_attrsetNONE) 4529 { 4530 ffesymbol_error (sp, t); 4531 ffesymbol_set_info (s, ffeinfo_new_any ()); 4532 } 4533 else if (!(na & FFESYMBOL_attrsANY)) 4534 { 4535 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); 4536 ffesymbol_set_attrs (sp, na); 4537 if (!ffeimplic_establish_symbol (sp) 4538 || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER) 4539 && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE))) 4540 ffesymbol_error (sp, t); 4541 else 4542 ffesymbol_set_info (s, 4543 ffeinfo_new (ffesymbol_basictype (sp), 4544 ffesymbol_kindtype (sp), 4545 0, 4546 FFEINFO_kindENTITY, 4547 FFEINFO_whereDUMMY, 4548 ffesymbol_size (sp))); 4549 4550 ffesymbol_signal_unreported (sp); 4551 } 4552 4553 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 4554 ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++); 4555 ffesymbol_signal_unreported (s); 4556 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 4557 FFEINTRIN_impNONE); 4558 ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s))); 4559 ffebld_append_item (&ffestc_local_.dummy.list_bottom, e); 4560} 4561 4562/* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement 4563 4564 ffestc_shriek_begin_program_(); 4565 4566 Invoked only when a PROGRAM statement is NOT present at the beginning 4567 of a main program unit. */ 4568 4569static void 4570ffestc_shriek_begin_program_ () 4571{ 4572 ffestw b; 4573 ffesymbol s; 4574 4575 ffestc_blocknum_ = 0; 4576 b = ffestw_update (ffestw_push (NULL)); 4577 ffestw_set_top_do (b, NULL); 4578 ffestw_set_state (b, FFESTV_statePROGRAM0); 4579 ffestw_set_blocknum (b, ffestc_blocknum_++); 4580 ffestw_set_shriek (b, ffestc_shriek_end_program_); 4581 ffestw_set_name (b, NULL); 4582 4583 s = ffesymbol_declare_programunit (NULL, 4584 ffelex_token_where_line (ffesta_tokens[0]), 4585 ffelex_token_where_column (ffesta_tokens[0])); 4586 4587 /* Special case: this is one symbol that won't go through 4588 ffestu_exec_transition_ when the first statement in a main program is 4589 executable, because the transition happens in ffest before ffestc is 4590 reached and triggers the implicit generation of a main program. So we 4591 do the exec transition for the implicit main program right here, just 4592 for cleanliness' sake (at the very least). */ 4593 4594 ffesymbol_set_info (s, 4595 ffeinfo_new (FFEINFO_basictypeNONE, 4596 FFEINFO_kindtypeNONE, 4597 0, 4598 FFEINFO_kindPROGRAM, 4599 FFEINFO_whereLOCAL, 4600 FFETARGET_charactersizeNONE)); 4601 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 4602 4603 ffesymbol_signal_unreported (s); 4604 4605 ffestd_R1102 (s, NULL); 4606} 4607 4608/* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements 4609 4610 ffestc_shriek_begin_uses_(); 4611 4612 Invoked before handling the first USE statement in a block of one or 4613 more USE statements. _end_uses_(bool ok) is invoked before handling 4614 the first statement after the block (there are no BEGIN USE and END USE 4615 statements, but the semantics of USE statements effectively requires 4616 handling them as a single block rather than one statement at a time). */ 4617 4618#if FFESTR_F90 4619static void 4620ffestc_shriek_begin_uses_ () 4621{ 4622 ffestw b; 4623 4624 b = ffestw_update (ffestw_push (NULL)); 4625 ffestw_set_top_do (b, NULL); 4626 ffestw_set_state (b, FFESTV_stateUSE); 4627 ffestw_set_blocknum (b, 0); 4628 ffestw_set_shriek (b, ffestc_shriek_end_uses_); 4629 4630 ffestd_begin_uses (); 4631} 4632 4633#endif 4634/* ffestc_shriek_blockdata_ -- End a BLOCK DATA 4635 4636 ffestc_shriek_blockdata_(TRUE); */ 4637 4638static void 4639ffestc_shriek_blockdata_ (bool ok) 4640{ 4641 if (!ffesta_seen_first_exec) 4642 { 4643 ffesta_seen_first_exec = TRUE; 4644 ffestd_exec_begin (); 4645 } 4646 4647 ffestd_R1112 (ok); 4648 4649 ffestd_exec_end (); 4650 4651 if (ffestw_name (ffestw_stack_top ()) != NULL) 4652 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4653 ffestw_kill (ffestw_pop ()); 4654 4655 ffe_terminate_2 (); 4656 ffe_init_2 (); 4657} 4658 4659/* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc 4660 4661 ffestc_shriek_do_(TRUE); 4662 4663 Also invoked by _labeldef_branch_end_ (or, in cases 4664 of errors, other _labeldef_ functions) when the label definition is 4665 for a DO-target (LOOPEND) label, once per matching/outstanding DO 4666 block on the stack. These cases invoke this function with ok==TRUE, so 4667 only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE. */ 4668 4669static void 4670ffestc_shriek_do_ (bool ok) 4671{ 4672 ffelab l; 4673 4674 if (((l = ffestw_label (ffestw_stack_top ())) != NULL) 4675 && (ffewhere_line_is_unknown (ffelab_definition_line (l)))) 4676 { /* DO target is label that is still 4677 undefined. */ 4678 assert ((ffelab_type (l) == FFELAB_typeLOOPEND) 4679 || (ffelab_type (l) == FFELAB_typeANY)); 4680 if (ffelab_type (l) != FFELAB_typeANY) 4681 { 4682 ffelab_set_definition_line (l, 4683 ffewhere_line_use (ffelab_doref_line (l))); 4684 ffelab_set_definition_column (l, 4685 ffewhere_column_use (ffelab_doref_column (l))); 4686 ffestv_num_label_defines_++; 4687 } 4688 ffestd_labeldef_branch (l); 4689 } 4690 4691 ffestd_do (ok); 4692 4693 if (ffestw_name (ffestw_stack_top ()) != NULL) 4694 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4695 if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL) 4696 ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ())); 4697 if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL) 4698 ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE); 4699 ffestw_kill (ffestw_pop ()); 4700} 4701 4702/* ffestc_shriek_end_program_ -- End a PROGRAM 4703 4704 ffestc_shriek_end_program_(); */ 4705 4706static void 4707ffestc_shriek_end_program_ (bool ok) 4708{ 4709 if (!ffesta_seen_first_exec) 4710 { 4711 ffesta_seen_first_exec = TRUE; 4712 ffestd_exec_begin (); 4713 } 4714 4715 ffestd_R1103 (ok); 4716 4717 ffestd_exec_end (); 4718 4719 if (ffestw_name (ffestw_stack_top ()) != NULL) 4720 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4721 ffestw_kill (ffestw_pop ()); 4722 4723 ffe_terminate_2 (); 4724 ffe_init_2 (); 4725} 4726 4727/* ffestc_shriek_end_uses_ -- End a bunch of USE statements 4728 4729 ffestc_shriek_end_uses_(TRUE); 4730 4731 ok==TRUE means simply not popping due to ffestc_eof() 4732 being called, because there is no formal END USES statement in Fortran. */ 4733 4734#if FFESTR_F90 4735static void 4736ffestc_shriek_end_uses_ (bool ok) 4737{ 4738 ffestd_end_uses (ok); 4739 4740 ffestw_kill (ffestw_pop ()); 4741} 4742 4743#endif 4744/* ffestc_shriek_function_ -- End a FUNCTION 4745 4746 ffestc_shriek_function_(TRUE); */ 4747 4748static void 4749ffestc_shriek_function_ (bool ok) 4750{ 4751 if (!ffesta_seen_first_exec) 4752 { 4753 ffesta_seen_first_exec = TRUE; 4754 ffestd_exec_begin (); 4755 } 4756 4757 ffestd_R1221 (ok); 4758 4759 ffestd_exec_end (); 4760 4761 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4762 ffestw_kill (ffestw_pop ()); 4763 ffesta_is_entry_valid = FALSE; 4764 4765 switch (ffestw_state (ffestw_stack_top ())) 4766 { 4767 case FFESTV_stateNIL: 4768 ffe_terminate_2 (); 4769 ffe_init_2 (); 4770 break; 4771 4772 default: 4773 ffe_terminate_3 (); 4774 ffe_init_3 (); 4775 break; 4776 4777 case FFESTV_stateINTERFACE0: 4778 ffe_terminate_4 (); 4779 ffe_init_4 (); 4780 break; 4781 } 4782} 4783 4784/* ffestc_shriek_if_ -- End of statement following logical IF 4785 4786 ffestc_shriek_if_(TRUE); 4787 4788 Applies ONLY to logical IF, not to IF-THEN. For example, does not 4789 ffelex_token_kill the construct name for an IF-THEN block (the name 4790 field is invalid for logical IF). ok==TRUE iff statement following 4791 logical IF (substatement) is valid; else, statement is invalid or 4792 stack forcibly popped due to ffestc_eof(). */ 4793 4794static void 4795ffestc_shriek_if_ (bool ok) 4796{ 4797 ffestd_end_R807 (ok); 4798 4799 ffestw_kill (ffestw_pop ()); 4800 ffestc_shriek_after1_ = NULL; 4801 4802 ffestc_try_shriek_do_ (); 4803} 4804 4805/* ffestc_shriek_ifthen_ -- End an IF-THEN 4806 4807 ffestc_shriek_ifthen_(TRUE); */ 4808 4809static void 4810ffestc_shriek_ifthen_ (bool ok) 4811{ 4812 ffestd_R806 (ok); 4813 4814 if (ffestw_name (ffestw_stack_top ()) != NULL) 4815 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4816 ffestw_kill (ffestw_pop ()); 4817 4818 ffestc_try_shriek_do_ (); 4819} 4820 4821/* ffestc_shriek_interface_ -- End an INTERFACE 4822 4823 ffestc_shriek_interface_(TRUE); */ 4824 4825#if FFESTR_F90 4826static void 4827ffestc_shriek_interface_ (bool ok) 4828{ 4829 ffestd_R1203 (ok); 4830 4831 ffestw_kill (ffestw_pop ()); 4832 4833 ffestc_try_shriek_do_ (); 4834} 4835 4836#endif 4837/* ffestc_shriek_map_ -- End a MAP 4838 4839 ffestc_shriek_map_(TRUE); */ 4840 4841#if FFESTR_VXT 4842static void 4843ffestc_shriek_map_ (bool ok) 4844{ 4845 ffestd_V013 (ok); 4846 4847 ffestw_kill (ffestw_pop ()); 4848 4849 ffestc_try_shriek_do_ (); 4850} 4851 4852#endif 4853/* ffestc_shriek_module_ -- End a MODULE 4854 4855 ffestc_shriek_module_(TRUE); */ 4856 4857#if FFESTR_F90 4858static void 4859ffestc_shriek_module_ (bool ok) 4860{ 4861 if (!ffesta_seen_first_exec) 4862 { 4863 ffesta_seen_first_exec = TRUE; 4864 ffestd_exec_begin (); 4865 } 4866 4867 ffestd_R1106 (ok); 4868 4869 ffestd_exec_end (); 4870 4871 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4872 ffestw_kill (ffestw_pop ()); 4873 4874 ffe_terminate_2 (); 4875 ffe_init_2 (); 4876} 4877 4878#endif 4879/* ffestc_shriek_select_ -- End a SELECT 4880 4881 ffestc_shriek_select_(TRUE); */ 4882 4883static void 4884ffestc_shriek_select_ (bool ok) 4885{ 4886 ffestwSelect s; 4887 ffestwCase c; 4888 4889 ffestd_R811 (ok); 4890 4891 if (ffestw_name (ffestw_stack_top ()) != NULL) 4892 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4893 s = ffestw_select (ffestw_stack_top ()); 4894 ffelex_token_kill (s->t); 4895 for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel) 4896 ffelex_token_kill (c->t); 4897 malloc_pool_kill (s->pool); 4898 4899 ffestw_kill (ffestw_pop ()); 4900 4901 ffestc_try_shriek_do_ (); 4902} 4903 4904/* ffestc_shriek_structure_ -- End a STRUCTURE 4905 4906 ffestc_shriek_structure_(TRUE); */ 4907 4908#if FFESTR_VXT 4909static void 4910ffestc_shriek_structure_ (bool ok) 4911{ 4912 ffestd_V004 (ok); 4913 4914 ffestw_kill (ffestw_pop ()); 4915 4916 ffestc_try_shriek_do_ (); 4917} 4918 4919#endif 4920/* ffestc_shriek_subroutine_ -- End a SUBROUTINE 4921 4922 ffestc_shriek_subroutine_(TRUE); */ 4923 4924static void 4925ffestc_shriek_subroutine_ (bool ok) 4926{ 4927 if (!ffesta_seen_first_exec) 4928 { 4929 ffesta_seen_first_exec = TRUE; 4930 ffestd_exec_begin (); 4931 } 4932 4933 ffestd_R1225 (ok); 4934 4935 ffestd_exec_end (); 4936 4937 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4938 ffestw_kill (ffestw_pop ()); 4939 ffesta_is_entry_valid = FALSE; 4940 4941 switch (ffestw_state (ffestw_stack_top ())) 4942 { 4943 case FFESTV_stateNIL: 4944 ffe_terminate_2 (); 4945 ffe_init_2 (); 4946 break; 4947 4948 default: 4949 ffe_terminate_3 (); 4950 ffe_init_3 (); 4951 break; 4952 4953 case FFESTV_stateINTERFACE0: 4954 ffe_terminate_4 (); 4955 ffe_init_4 (); 4956 break; 4957 } 4958} 4959 4960/* ffestc_shriek_type_ -- End a TYPE 4961 4962 ffestc_shriek_type_(TRUE); */ 4963 4964#if FFESTR_F90 4965static void 4966ffestc_shriek_type_ (bool ok) 4967{ 4968 ffestd_R425 (ok); 4969 4970 ffe_terminate_4 (); 4971 4972 ffelex_token_kill (ffestw_name (ffestw_stack_top ())); 4973 ffestw_kill (ffestw_pop ()); 4974 4975 ffestc_try_shriek_do_ (); 4976} 4977 4978#endif 4979/* ffestc_shriek_union_ -- End a UNION 4980 4981 ffestc_shriek_union_(TRUE); */ 4982 4983#if FFESTR_VXT 4984static void 4985ffestc_shriek_union_ (bool ok) 4986{ 4987 ffestd_V010 (ok); 4988 4989 ffestw_kill (ffestw_pop ()); 4990 4991 ffestc_try_shriek_do_ (); 4992} 4993 4994#endif 4995/* ffestc_shriek_where_ -- Implicit END WHERE statement 4996 4997 ffestc_shriek_where_(TRUE); 4998 4999 Implement the end of the current WHERE "block". ok==TRUE iff statement 5000 following WHERE (substatement) is valid; else, statement is invalid 5001 or stack forcibly popped due to ffestc_eof(). */ 5002 5003#if FFESTR_F90 5004static void 5005ffestc_shriek_where_ (bool ok) 5006{ 5007 ffestd_R745 (ok); 5008 5009 ffestw_kill (ffestw_pop ()); 5010 ffestc_shriek_after1_ = NULL; 5011 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF) 5012 ffestc_shriek_if_ (TRUE); /* "IF (x) WHERE (y) stmt" is only valid 5013 case. */ 5014 5015 ffestc_try_shriek_do_ (); 5016} 5017 5018#endif 5019/* ffestc_shriek_wherethen_ -- End a WHERE(-THEN) 5020 5021 ffestc_shriek_wherethen_(TRUE); */ 5022 5023#if FFESTR_F90 5024static void 5025ffestc_shriek_wherethen_ (bool ok) 5026{ 5027 ffestd_end_R740 (ok); 5028 5029 ffestw_kill (ffestw_pop ()); 5030 5031 ffestc_try_shriek_do_ (); 5032} 5033 5034#endif 5035/* ffestc_subr_binsrch_ -- Binary search of char const in list of strings 5036 5037 i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc"); 5038 5039 search_list contains search_list_size char *'s, spec is checked to see 5040 if it is a char constant and, if so, is binary-searched against the list. 5041 0 is returned if not found, else the "classic" index (beginning with 1) 5042 is returned. Before returning 0 where the search was performed but 5043 fruitless, if "etc" is a non-NULL char *, an error message is displayed 5044 using "etc" as the pick-one-of-these string. */ 5045 5046static int 5047ffestc_subr_binsrch_ (const char **list, int size, ffestpFile *spec, const char *whine) 5048{ 5049 int lowest_tested; 5050 int highest_tested; 5051 int halfway; 5052 int offset; 5053 int c; 5054 const char *str; 5055 int len; 5056 5057 if (size == 0) 5058 return 0; /* Nobody should pass size == 0, but for 5059 elegance.... */ 5060 5061 lowest_tested = -1; 5062 highest_tested = size; 5063 halfway = size >> 1; 5064 5065 list += halfway; 5066 5067 c = ffestc_subr_speccmp_ (*list, spec, &str, &len); 5068 if (c == 2) 5069 return 0; 5070 c = -c; /* Sigh. */ 5071 5072next: /* :::::::::::::::::::: */ 5073 switch (c) 5074 { 5075 case -1: 5076 offset = (halfway - lowest_tested) >> 1; 5077 if (offset == 0) 5078 goto nope; /* :::::::::::::::::::: */ 5079 highest_tested = halfway; 5080 list -= offset; 5081 halfway -= offset; 5082 c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list); 5083 goto next; /* :::::::::::::::::::: */ 5084 5085 case 0: 5086 return halfway + 1; 5087 5088 case 1: 5089 offset = (highest_tested - halfway) >> 1; 5090 if (offset == 0) 5091 goto nope; /* :::::::::::::::::::: */ 5092 lowest_tested = halfway; 5093 list += offset; 5094 halfway += offset; 5095 c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list); 5096 goto next; /* :::::::::::::::::::: */ 5097 5098 default: 5099 assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL); 5100 break; 5101 } 5102 5103nope: /* :::::::::::::::::::: */ 5104 ffebad_start (FFEBAD_SPEC_VALUE); 5105 ffebad_here (0, ffelex_token_where_line (spec->value), 5106 ffelex_token_where_column (spec->value)); 5107 ffebad_string (whine); 5108 ffebad_finish (); 5109 return 0; 5110} 5111 5112/* ffestc_subr_format_ -- Return summary of format specifier 5113 5114 ffestc_subr_format_(&specifier); */ 5115 5116static ffestvFormat 5117ffestc_subr_format_ (ffestpFile *spec) 5118{ 5119 if (!spec->kw_or_val_present) 5120 return FFESTV_formatNONE; 5121 assert (spec->value_present); 5122 if (spec->value_is_label) 5123 return FFESTV_formatLABEL; /* Ok if not a label. */ 5124 5125 assert (spec->value != NULL); 5126 if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR) 5127 return FFESTV_formatASTERISK; 5128 5129 if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST) 5130 return FFESTV_formatNAMELIST; 5131 5132 if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0) 5133 return FFESTV_formatCHAREXPR; /* F77 C5. */ 5134 5135 switch (ffeinfo_basictype (ffebld_info (spec->u.expr))) 5136 { 5137 case FFEINFO_basictypeINTEGER: 5138 return FFESTV_formatINTEXPR; 5139 5140 case FFEINFO_basictypeCHARACTER: 5141 return FFESTV_formatCHAREXPR; 5142 5143 case FFEINFO_basictypeANY: 5144 return FFESTV_formatASTERISK; 5145 5146 default: 5147 assert ("bad basictype" == NULL); 5148 return FFESTV_formatINTEXPR; 5149 } 5150} 5151 5152/* ffestc_subr_is_branch_ -- Handle specifier as branch target label 5153 5154 ffestc_subr_is_branch_(&specifier); */ 5155 5156static bool 5157ffestc_subr_is_branch_ (ffestpFile *spec) 5158{ 5159 if (!spec->kw_or_val_present) 5160 return TRUE; 5161 assert (spec->value_present); 5162 assert (spec->value_is_label); 5163 spec->value_is_label++; /* For checking purposes only; 1=>2. */ 5164 return ffestc_labelref_is_branch_ (spec->value, &spec->u.label); 5165} 5166 5167/* ffestc_subr_is_format_ -- Handle specifier as format target label 5168 5169 ffestc_subr_is_format_(&specifier); */ 5170 5171static bool 5172ffestc_subr_is_format_ (ffestpFile *spec) 5173{ 5174 if (!spec->kw_or_val_present) 5175 return TRUE; 5176 assert (spec->value_present); 5177 if (!spec->value_is_label) 5178 return TRUE; /* Ok if not a label. */ 5179 5180 spec->value_is_label++; /* For checking purposes only; 1=>2. */ 5181 return ffestc_labelref_is_format_ (spec->value, &spec->u.label); 5182} 5183 5184/* ffestc_subr_is_present_ -- Ensure specifier is present, else error 5185 5186 ffestc_subr_is_present_("SPECIFIER",&specifier); */ 5187 5188static bool 5189ffestc_subr_is_present_ (const char *name, ffestpFile *spec) 5190{ 5191 if (spec->kw_or_val_present) 5192 { 5193 assert (spec->value_present); 5194 return TRUE; 5195 } 5196 5197 ffebad_start (FFEBAD_MISSING_SPECIFIER); 5198 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 5199 ffelex_token_where_column (ffesta_tokens[0])); 5200 ffebad_string (name); 5201 ffebad_finish (); 5202 return FALSE; 5203} 5204 5205/* ffestc_subr_speccmp_ -- Compare string to constant expression, if present 5206 5207 if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0) 5208 // specifier value is present and is a char constant "CONSTANT" 5209 5210 Like strcmp, except the return values are defined as: -1 returned in place 5211 of strcmp's generic negative value, 1 in place of it's generic positive 5212 value, and 2 when there is no character constant string to compare. Also, 5213 a case-insensitive comparison is performed, where string is assumed to 5214 already be in InitialCaps form. 5215 5216 If a non-NULL pointer is provided as the char **target, then *target is 5217 written with NULL if 2 is returned, a pointer to the constant string 5218 value of the specifier otherwise. Similarly, length is written with 5219 0 if 2 is returned, the length of the constant string value otherwise. */ 5220 5221static int 5222ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target, 5223 int *length) 5224{ 5225 ffebldConstant c; 5226 int i; 5227 5228 if (!spec->kw_or_val_present || !spec->value_present 5229 || (spec->u.expr == NULL) 5230 || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER)) 5231 { 5232 if (target != NULL) 5233 *target = NULL; 5234 if (length != NULL) 5235 *length = 0; 5236 return 2; 5237 } 5238 5239 if (ffebld_constant_type (c = ffebld_conter (spec->u.expr)) 5240 != FFEBLD_constCHARACTERDEFAULT) 5241 { 5242 if (target != NULL) 5243 *target = NULL; 5244 if (length != NULL) 5245 *length = 0; 5246 return 2; 5247 } 5248 5249 if (target != NULL) 5250 *target = ffebld_constant_characterdefault (c).text; 5251 if (length != NULL) 5252 *length = ffebld_constant_characterdefault (c).length; 5253 5254 i = ffesrc_strcmp_1ns2i (ffe_case_match (), 5255 ffebld_constant_characterdefault (c).text, 5256 ffebld_constant_characterdefault (c).length, 5257 string); 5258 if (i == 0) 5259 return 0; 5260 if (i > 0) 5261 return -1; /* Yes indeed, we reverse the strings to 5262 _strcmpin_. */ 5263 return 1; 5264} 5265 5266/* ffestc_subr_unit_ -- Return summary of unit specifier 5267 5268 ffestc_subr_unit_(&specifier); */ 5269 5270static ffestvUnit 5271ffestc_subr_unit_ (ffestpFile *spec) 5272{ 5273 if (!spec->kw_or_val_present) 5274 return FFESTV_unitNONE; 5275 assert (spec->value_present); 5276 assert (spec->value != NULL); 5277 5278 if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR) 5279 return FFESTV_unitASTERISK; 5280 5281 switch (ffeinfo_basictype (ffebld_info (spec->u.expr))) 5282 { 5283 case FFEINFO_basictypeINTEGER: 5284 return FFESTV_unitINTEXPR; 5285 5286 case FFEINFO_basictypeCHARACTER: 5287 return FFESTV_unitCHAREXPR; 5288 5289 case FFEINFO_basictypeANY: 5290 return FFESTV_unitASTERISK; 5291 5292 default: 5293 assert ("bad basictype" == NULL); 5294 return FFESTV_unitINTEXPR; 5295 } 5296} 5297 5298/* Call this function whenever it's possible that one or more top 5299 stack items are label-targeting DO blocks that have had their 5300 labels defined, but at a time when they weren't at the top of the 5301 stack. This prevents uninformative diagnostics for programs 5302 like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END". */ 5303 5304static void 5305ffestc_try_shriek_do_ () 5306{ 5307 ffelab lab; 5308 ffelabType ty; 5309 5310 while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO) 5311 && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL) 5312 && (((ty = (ffelab_type (lab))) 5313 == FFELAB_typeANY) 5314 || (ty == FFELAB_typeUSELESS) 5315 || (ty == FFELAB_typeFORMAT) 5316 || (ty == FFELAB_typeNOTLOOP) 5317 || (ty == FFELAB_typeENDIF))) 5318 ffestc_shriek_do_ (FALSE); 5319} 5320 5321/* ffestc_decl_start -- R426 or R501 5322 5323 ffestc_decl_start(...); 5324 5325 Verify that R426 component-def-stmt or R501 type-declaration-stmt are 5326 valid here, figure out which one, and implement. */ 5327 5328void 5329ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind, 5330 ffelexToken kindt, ffebld len, ffelexToken lent) 5331{ 5332 switch (ffestw_state (ffestw_stack_top ())) 5333 { 5334 case FFESTV_stateNIL: 5335 case FFESTV_statePROGRAM0: 5336 case FFESTV_stateSUBROUTINE0: 5337 case FFESTV_stateFUNCTION0: 5338 case FFESTV_stateMODULE0: 5339 case FFESTV_stateBLOCKDATA0: 5340 case FFESTV_statePROGRAM1: 5341 case FFESTV_stateSUBROUTINE1: 5342 case FFESTV_stateFUNCTION1: 5343 case FFESTV_stateMODULE1: 5344 case FFESTV_stateBLOCKDATA1: 5345 case FFESTV_statePROGRAM2: 5346 case FFESTV_stateSUBROUTINE2: 5347 case FFESTV_stateFUNCTION2: 5348 case FFESTV_stateMODULE2: 5349 case FFESTV_stateBLOCKDATA2: 5350 case FFESTV_statePROGRAM3: 5351 case FFESTV_stateSUBROUTINE3: 5352 case FFESTV_stateFUNCTION3: 5353 case FFESTV_stateMODULE3: 5354 case FFESTV_stateBLOCKDATA3: 5355 case FFESTV_stateUSE: 5356 ffestc_local_.decl.is_R426 = 2; 5357 break; 5358 5359 case FFESTV_stateTYPE: 5360 case FFESTV_stateSTRUCTURE: 5361 case FFESTV_stateMAP: 5362 ffestc_local_.decl.is_R426 = 1; 5363 break; 5364 5365 default: 5366 ffestc_order_bad_ (); 5367 ffestc_labeldef_useless_ (); 5368 ffestc_local_.decl.is_R426 = 0; 5369 return; 5370 } 5371 5372 switch (ffestc_local_.decl.is_R426) 5373 { 5374#if FFESTR_F90 5375 case 1: 5376 ffestc_R426_start (type, typet, kind, kindt, len, lent); 5377 break; 5378#endif 5379 5380 case 2: 5381 ffestc_R501_start (type, typet, kind, kindt, len, lent); 5382 break; 5383 5384 default: 5385 ffestc_labeldef_useless_ (); 5386 break; 5387 } 5388} 5389 5390/* ffestc_decl_attrib -- R426 or R501 type attribute 5391 5392 ffestc_decl_attrib(...); 5393 5394 Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute 5395 is valid here and implement. */ 5396 5397void 5398ffestc_decl_attrib (ffestpAttrib attrib UNUSED, 5399 ffelexToken attribt UNUSED, 5400 ffestrOther intent_kw UNUSED, 5401 ffesttDimList dims UNUSED) 5402{ 5403#if FFESTR_F90 5404 switch (ffestc_local_.decl.is_R426) 5405 { 5406 case 1: 5407 ffestc_R426_attrib (attrib, attribt, intent_kw, dims); 5408 break; 5409 5410 case 2: 5411 ffestc_R501_attrib (attrib, attribt, intent_kw, dims); 5412 break; 5413 5414 default: 5415 break; 5416 } 5417#else 5418 ffebad_start (FFEBAD_F90); 5419 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 5420 ffelex_token_where_column (ffesta_tokens[0])); 5421 ffebad_finish (); 5422 return; 5423#endif 5424} 5425 5426/* ffestc_decl_item -- R426 or R501 5427 5428 ffestc_decl_item(...); 5429 5430 Establish type for a particular object. */ 5431 5432void 5433ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt, 5434 ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init, 5435 ffelexToken initt, bool clist) 5436{ 5437 switch (ffestc_local_.decl.is_R426) 5438 { 5439#if FFESTR_F90 5440 case 1: 5441 ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt, 5442 clist); 5443 break; 5444#endif 5445 5446 case 2: 5447 ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt, 5448 clist); 5449 break; 5450 5451 default: 5452 break; 5453 } 5454} 5455 5456/* ffestc_decl_itemstartvals -- R426 or R501 start list of values 5457 5458 ffestc_decl_itemstartvals(); 5459 5460 Gonna specify values for the object now. */ 5461 5462void 5463ffestc_decl_itemstartvals () 5464{ 5465 switch (ffestc_local_.decl.is_R426) 5466 { 5467#if FFESTR_F90 5468 case 1: 5469 ffestc_R426_itemstartvals (); 5470 break; 5471#endif 5472 5473 case 2: 5474 ffestc_R501_itemstartvals (); 5475 break; 5476 5477 default: 5478 break; 5479 } 5480} 5481 5482/* ffestc_decl_itemvalue -- R426 or R501 source value 5483 5484 ffestc_decl_itemvalue(repeat,repeat_token,value,value_token); 5485 5486 Make sure repeat and value are valid for the object being initialized. */ 5487 5488void 5489ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token, 5490 ffebld value, ffelexToken value_token) 5491{ 5492 switch (ffestc_local_.decl.is_R426) 5493 { 5494#if FFESTR_F90 5495 case 1: 5496 ffestc_R426_itemvalue (repeat, repeat_token, value, value_token); 5497 break; 5498#endif 5499 5500 case 2: 5501 ffestc_R501_itemvalue (repeat, repeat_token, value, value_token); 5502 break; 5503 5504 default: 5505 break; 5506 } 5507} 5508 5509/* ffestc_decl_itemendvals -- R426 or R501 end list of values 5510 5511 ffelexToken t; // the SLASH token that ends the list. 5512 ffestc_decl_itemendvals(t); 5513 5514 No more values, might specify more objects now. */ 5515 5516void 5517ffestc_decl_itemendvals (ffelexToken t) 5518{ 5519 switch (ffestc_local_.decl.is_R426) 5520 { 5521#if FFESTR_F90 5522 case 1: 5523 ffestc_R426_itemendvals (t); 5524 break; 5525#endif 5526 5527 case 2: 5528 ffestc_R501_itemendvals (t); 5529 break; 5530 5531 default: 5532 break; 5533 } 5534} 5535 5536/* ffestc_decl_finish -- R426 or R501 5537 5538 ffestc_decl_finish(); 5539 5540 Just wrap up any local activities. */ 5541 5542void 5543ffestc_decl_finish () 5544{ 5545 switch (ffestc_local_.decl.is_R426) 5546 { 5547#if FFESTR_F90 5548 case 1: 5549 ffestc_R426_finish (); 5550 break; 5551#endif 5552 5553 case 2: 5554 ffestc_R501_finish (); 5555 break; 5556 5557 default: 5558 break; 5559 } 5560} 5561 5562/* ffestc_elsewhere -- Generic ELSE WHERE statement 5563 5564 ffestc_end(); 5565 5566 Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */ 5567 5568void 5569ffestc_elsewhere (ffelexToken where) 5570{ 5571 switch (ffestw_state (ffestw_stack_top ())) 5572 { 5573 case FFESTV_stateIFTHEN: 5574 ffestc_R805 (where); 5575 break; 5576 5577 default: 5578#if FFESTR_F90 5579 ffestc_R744 (); 5580#endif 5581 break; 5582 } 5583} 5584 5585/* ffestc_end -- Generic END statement 5586 5587 ffestc_end(); 5588 5589 Make sure a generic END is valid in the current context, and implement 5590 it. */ 5591 5592void 5593ffestc_end () 5594{ 5595 ffestw b; 5596 5597 b = ffestw_stack_top (); 5598 5599recurse: 5600 5601 switch (ffestw_state (b)) 5602 { 5603 case FFESTV_stateBLOCKDATA0: 5604 case FFESTV_stateBLOCKDATA1: 5605 case FFESTV_stateBLOCKDATA2: 5606 case FFESTV_stateBLOCKDATA3: 5607 case FFESTV_stateBLOCKDATA4: 5608 case FFESTV_stateBLOCKDATA5: 5609 ffestc_R1112 (NULL); 5610 break; 5611 5612 case FFESTV_stateFUNCTION0: 5613 case FFESTV_stateFUNCTION1: 5614 case FFESTV_stateFUNCTION2: 5615 case FFESTV_stateFUNCTION3: 5616 case FFESTV_stateFUNCTION4: 5617 case FFESTV_stateFUNCTION5: 5618 if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL) 5619 && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0)) 5620 { 5621 ffebad_start (FFEBAD_END_WO); 5622 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 5623 ffelex_token_where_column (ffesta_tokens[0])); 5624 ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b))); 5625 ffebad_string ("FUNCTION"); 5626 ffebad_finish (); 5627 } 5628 ffestc_R1221 (NULL); 5629 break; 5630 5631 case FFESTV_stateMODULE0: 5632 case FFESTV_stateMODULE1: 5633 case FFESTV_stateMODULE2: 5634 case FFESTV_stateMODULE3: 5635 case FFESTV_stateMODULE4: 5636 case FFESTV_stateMODULE5: 5637#if FFESTR_F90 5638 ffestc_R1106 (NULL); 5639#endif 5640 break; 5641 5642 case FFESTV_stateSUBROUTINE0: 5643 case FFESTV_stateSUBROUTINE1: 5644 case FFESTV_stateSUBROUTINE2: 5645 case FFESTV_stateSUBROUTINE3: 5646 case FFESTV_stateSUBROUTINE4: 5647 case FFESTV_stateSUBROUTINE5: 5648 if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL) 5649 && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0)) 5650 { 5651 ffebad_start (FFEBAD_END_WO); 5652 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 5653 ffelex_token_where_column (ffesta_tokens[0])); 5654 ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b))); 5655 ffebad_string ("SUBROUTINE"); 5656 ffebad_finish (); 5657 } 5658 ffestc_R1225 (NULL); 5659 break; 5660 5661 case FFESTV_stateUSE: 5662 b = ffestw_previous (ffestw_stack_top ()); 5663 goto recurse; /* :::::::::::::::::::: */ 5664 5665 default: 5666 ffestc_R1103 (NULL); 5667 break; 5668 } 5669} 5670 5671/* ffestc_eof -- Generic EOF 5672 5673 ffestc_eof(); 5674 5675 Make sure we're at state NIL, or issue an error message and use each 5676 block's shriek function to clean up to state NIL. */ 5677 5678void 5679ffestc_eof () 5680{ 5681 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL) 5682 { 5683 ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END); 5684 ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 5685 ffebad_finish (); 5686 do 5687 (*ffestw_shriek (ffestw_stack_top ()))(FALSE); 5688 while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL); 5689 } 5690} 5691 5692/* ffestc_exec_transition -- Check if ok and move stmt state to executable 5693 5694 if (ffestc_exec_transition()) 5695 // Transition successful (kind of like a CONTINUE stmt was seen). 5696 5697 If the current statement state is a non-nested specification state in 5698 which, say, a CONTINUE statement would be valid, then enter the state 5699 we'd be in after seeing CONTINUE (without, of course, generating any 5700 CONTINUE code), call ffestd_exec_begin, and return TRUE. Otherwise 5701 return FALSE. 5702 5703 This function cannot be invoked once the first executable statement 5704 is seen. This function may choose to always return TRUE by shrieking 5705 away any interceding state stack entries to reach the base level of 5706 specification state, but right now it doesn't, and it is (or should 5707 be) purely an issue of how one wishes errors to be handled (for example, 5708 an unrecognized statement in the middle of a STRUCTURE construct: after 5709 the error message, should subsequent statements still be interpreted as 5710 being within the construct, or should the construct be terminated upon 5711 seeing the unrecognized statement? we do the former at the moment). */ 5712 5713bool 5714ffestc_exec_transition () 5715{ 5716 bool update; 5717 5718recurse: 5719 5720 switch (ffestw_state (ffestw_stack_top ())) 5721 { 5722 case FFESTV_stateNIL: 5723 ffestc_shriek_begin_program_ (); 5724 goto recurse; /* :::::::::::::::::::: */ 5725 5726 case FFESTV_statePROGRAM0: 5727 case FFESTV_stateSUBROUTINE0: 5728 case FFESTV_stateFUNCTION0: 5729 case FFESTV_stateBLOCKDATA0: 5730 ffestw_state (ffestw_stack_top ()) += 4; /* To state UNIT4. */ 5731 update = TRUE; 5732 break; 5733 5734 case FFESTV_statePROGRAM1: 5735 case FFESTV_stateSUBROUTINE1: 5736 case FFESTV_stateFUNCTION1: 5737 case FFESTV_stateBLOCKDATA1: 5738 ffestw_state (ffestw_stack_top ()) += 3; /* To state UNIT4. */ 5739 update = TRUE; 5740 break; 5741 5742 case FFESTV_statePROGRAM2: 5743 case FFESTV_stateSUBROUTINE2: 5744 case FFESTV_stateFUNCTION2: 5745 case FFESTV_stateBLOCKDATA2: 5746 ffestw_state (ffestw_stack_top ()) += 2; /* To state UNIT4. */ 5747 update = TRUE; 5748 break; 5749 5750 case FFESTV_statePROGRAM3: 5751 case FFESTV_stateSUBROUTINE3: 5752 case FFESTV_stateFUNCTION3: 5753 case FFESTV_stateBLOCKDATA3: 5754 ffestw_state (ffestw_stack_top ()) += 1; /* To state UNIT4. */ 5755 update = TRUE; 5756 break; 5757 5758 case FFESTV_stateUSE: 5759#if FFESTR_F90 5760 ffestc_shriek_end_uses_ (TRUE); 5761#endif 5762 goto recurse; /* :::::::::::::::::::: */ 5763 5764 default: 5765 return FALSE; 5766 } 5767 5768 if (update) 5769 ffestw_update (NULL); /* Update state line/col info. */ 5770 5771 ffesta_seen_first_exec = TRUE; 5772 ffestd_exec_begin (); 5773 5774 return TRUE; 5775} 5776 5777/* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var 5778 5779 ffesymbol s; 5780 // call ffebad_start first, of course. 5781 ffestc_ffebad_here_doiter(0,s); 5782 // call ffebad_finish afterwards, naturally. 5783 5784 Searches the stack of blocks backwards for a DO loop that has s 5785 as its iteration variable, then calls ffebad_here with pointers to 5786 that particular reference to the variable. Crashes if the DO loop 5787 can't be found. */ 5788 5789void 5790ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s) 5791{ 5792 ffestw block; 5793 5794 for (block = ffestw_top_do (ffestw_stack_top ()); 5795 (block != NULL) && (ffestw_blocknum (block) != 0); 5796 block = ffestw_top_do (ffestw_previous (block))) 5797 { 5798 if (ffestw_do_iter_var (block) == s) 5799 { 5800 ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)), 5801 ffelex_token_where_column (ffestw_do_iter_var_t (block))); 5802 return; 5803 } 5804 } 5805 assert ("no do block found" == NULL); 5806} 5807 5808/* ffestc_is_decl_not_R1219 -- Context information for FFESTB 5809 5810 if (ffestc_is_decl_not_R1219()) ... 5811 5812 When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)" 5813 is seen, call this function. It returns TRUE if the statement's context 5814 is such that it is a declaration of an object named 5815 "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE 5816 if the statement's context is such that it begins the definition of a 5817 function named "name" havin the dummy argument list "name-list" (this 5818 is the R1219 function-stmt case). */ 5819 5820bool 5821ffestc_is_decl_not_R1219 () 5822{ 5823 switch (ffestw_state (ffestw_stack_top ())) 5824 { 5825 case FFESTV_stateNIL: 5826 case FFESTV_statePROGRAM5: 5827 case FFESTV_stateSUBROUTINE5: 5828 case FFESTV_stateFUNCTION5: 5829 case FFESTV_stateMODULE5: 5830 case FFESTV_stateINTERFACE0: 5831 return FALSE; 5832 5833 default: 5834 return TRUE; 5835 } 5836} 5837 5838/* ffestc_is_entry_in_subr -- Context information for FFESTB 5839 5840 if (ffestc_is_entry_in_subr()) ... 5841 5842 When a statement with the form "ENTRY name(name-list)" 5843 is seen, call this function. It returns TRUE if the statement's context 5844 is such that it may have "*", meaning alternate return, in place of 5845 names in the name list (i.e. if the ENTRY is in a subroutine context). 5846 It also returns TRUE if the ENTRY is not in a function context (invalid 5847 but prevents extra complaints about "*", if present). It returns FALSE 5848 if the ENTRY is in a function context. */ 5849 5850bool 5851ffestc_is_entry_in_subr () 5852{ 5853 ffestvState s; 5854 5855 s = ffestw_state (ffestw_stack_top ()); 5856 5857recurse: 5858 5859 switch (s) 5860 { 5861 case FFESTV_stateFUNCTION0: 5862 case FFESTV_stateFUNCTION1: 5863 case FFESTV_stateFUNCTION2: 5864 case FFESTV_stateFUNCTION3: 5865 case FFESTV_stateFUNCTION4: 5866 return FALSE; 5867 5868 case FFESTV_stateUSE: 5869 s = ffestw_state (ffestw_previous (ffestw_stack_top ())); 5870 goto recurse; /* :::::::::::::::::::: */ 5871 5872 default: 5873 return TRUE; 5874 } 5875} 5876 5877/* ffestc_is_let_not_V027 -- Context information for FFESTB 5878 5879 if (ffestc_is_let_not_V027()) ... 5880 5881 When a statement with the form "PARAMETERname=expr" 5882 is seen, call this function. It returns TRUE if the statement's context 5883 is such that it is an assignment to an object named "PARAMETERname", FALSE 5884 if the statement's context is such that it is a V-extension PARAMETER 5885 statement that is like a PARAMETER(name=expr) statement except that the 5886 type of name is determined by the type of expr, not the implicit or 5887 explicit typing of name. */ 5888 5889bool 5890ffestc_is_let_not_V027 () 5891{ 5892 switch (ffestw_state (ffestw_stack_top ())) 5893 { 5894 case FFESTV_statePROGRAM4: 5895 case FFESTV_stateSUBROUTINE4: 5896 case FFESTV_stateFUNCTION4: 5897 case FFESTV_stateWHERETHEN: 5898 case FFESTV_stateIFTHEN: 5899 case FFESTV_stateDO: 5900 case FFESTV_stateSELECT0: 5901 case FFESTV_stateSELECT1: 5902 case FFESTV_stateWHERE: 5903 case FFESTV_stateIF: 5904 return TRUE; 5905 5906 default: 5907 return FALSE; 5908 } 5909} 5910 5911/* ffestc_module -- MODULE or MODULE PROCEDURE statement 5912 5913 ffestc_module(module_name_token,procedure_name_token); 5914 5915 Decide which is intended, and implement it by calling _R1105_ or 5916 _R1205_. */ 5917 5918#if FFESTR_F90 5919void 5920ffestc_module (ffelexToken module, ffelexToken procedure) 5921{ 5922 switch (ffestw_state (ffestw_stack_top ())) 5923 { 5924 case FFESTV_stateINTERFACE0: 5925 case FFESTV_stateINTERFACE1: 5926 ffestc_R1205_start (); 5927 ffestc_R1205_item (procedure); 5928 ffestc_R1205_finish (); 5929 break; 5930 5931 default: 5932 ffestc_R1105 (module); 5933 break; 5934 } 5935} 5936 5937#endif 5938/* ffestc_private -- Generic PRIVATE statement 5939 5940 ffestc_end(); 5941 5942 This is either a PRIVATE within R422 derived-type statement or an 5943 R521 PRIVATE statement. Figure it out based on context and implement 5944 it, or produce an error. */ 5945 5946#if FFESTR_F90 5947void 5948ffestc_private () 5949{ 5950 switch (ffestw_state (ffestw_stack_top ())) 5951 { 5952 case FFESTV_stateTYPE: 5953 ffestc_R423A (); 5954 break; 5955 5956 default: 5957 ffestc_R521B (); 5958 break; 5959 } 5960} 5961 5962#endif 5963/* ffestc_terminate_4 -- Terminate ffestc after scoping unit 5964 5965 ffestc_terminate_4(); 5966 5967 For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE- 5968 defs, and statement function defs. */ 5969 5970void 5971ffestc_terminate_4 () 5972{ 5973 ffestc_entry_num_ = ffestc_saved_entry_num_; 5974} 5975 5976/* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement) 5977 5978 ffestc_R423A(); */ 5979 5980#if FFESTR_F90 5981void 5982ffestc_R423A () 5983{ 5984 ffestc_check_simple_ (); 5985 if (ffestc_order_type_ () != FFESTC_orderOK_) 5986 return; 5987 ffestc_labeldef_useless_ (); 5988 5989 if (ffestw_substate (ffestw_stack_top ()) != 0) 5990 { 5991 ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST); 5992 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 5993 ffelex_token_where_column (ffesta_tokens[0])); 5994 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 5995 ffebad_finish (); 5996 return; 5997 } 5998 5999 if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3) 6000 { 6001 ffebad_start (FFEBAD_DERIVTYP_ACCESS); 6002 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 6003 ffelex_token_where_column (ffesta_tokens[0])); 6004 ffebad_finish (); 6005 return; 6006 } 6007 6008 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen 6009 private-sequence-stmt. */ 6010 6011 ffestd_R423A (); 6012} 6013 6014/* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt) 6015 6016 ffestc_R423B(); */ 6017 6018void 6019ffestc_R423B () 6020{ 6021 ffestc_check_simple_ (); 6022 if (ffestc_order_type_ () != FFESTC_orderOK_) 6023 return; 6024 ffestc_labeldef_useless_ (); 6025 6026 if (ffestw_substate (ffestw_stack_top ()) != 0) 6027 { 6028 ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST); 6029 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 6030 ffelex_token_where_column (ffesta_tokens[0])); 6031 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 6032 ffebad_finish (); 6033 return; 6034 } 6035 6036 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen 6037 private-sequence-stmt. */ 6038 6039 ffestd_R423B (); 6040} 6041 6042/* ffestc_R424 -- derived-TYPE-def statement 6043 6044 ffestc_R424(access_token,access_kw,name_token); 6045 6046 Handle a derived-type definition. */ 6047 6048void 6049ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name) 6050{ 6051 ffestw b; 6052 6053 assert (name != NULL); 6054 6055 ffestc_check_simple_ (); 6056 if (ffestc_order_derivedtype_ () != FFESTC_orderOK_) 6057 return; 6058 ffestc_labeldef_useless_ (); 6059 6060 if ((access != NULL) 6061 && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3)) 6062 { 6063 ffebad_start (FFEBAD_DERIVTYP_ACCESS); 6064 ffebad_here (0, ffelex_token_where_line (access), 6065 ffelex_token_where_column (access)); 6066 ffebad_finish (); 6067 access = NULL; 6068 } 6069 6070 b = ffestw_update (ffestw_push (NULL)); 6071 ffestw_set_top_do (b, NULL); 6072 ffestw_set_state (b, FFESTV_stateTYPE); 6073 ffestw_set_blocknum (b, 0); 6074 ffestw_set_shriek (b, ffestc_shriek_type_); 6075 ffestw_set_name (b, ffelex_token_use (name)); 6076 ffestw_set_substate (b, 0); /* Awaiting private-sequence-stmt and one 6077 component-def-stmt. */ 6078 6079 ffestd_R424 (access, access_kw, name); 6080 6081 ffe_init_4 (); 6082} 6083 6084/* ffestc_R425 -- END TYPE statement 6085 6086 ffestc_R425(name_token); 6087 6088 Make sure ffestc_kind_ identifies a TYPE definition. If not 6089 NULL, make sure name_token gives the correct name. Implement the end 6090 of the type definition. */ 6091 6092void 6093ffestc_R425 (ffelexToken name) 6094{ 6095 ffestc_check_simple_ (); 6096 if (ffestc_order_type_ () != FFESTC_orderOK_) 6097 return; 6098 ffestc_labeldef_useless_ (); 6099 6100 if (ffestw_substate (ffestw_stack_top ()) != 2) 6101 { 6102 ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS); 6103 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 6104 ffelex_token_where_column (ffesta_tokens[0])); 6105 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 6106 ffebad_finish (); 6107 } 6108 6109 if ((name != NULL) 6110 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) 6111 { 6112 ffebad_start (FFEBAD_TYPE_WRONG_NAME); 6113 ffebad_here (0, ffelex_token_where_line (name), 6114 ffelex_token_where_column (name)); 6115 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 6116 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 6117 ffebad_finish (); 6118 } 6119 6120 ffestc_shriek_type_ (TRUE); 6121} 6122 6123/* ffestc_R426_start -- component-declaration-stmt 6124 6125 ffestc_R426_start(...); 6126 6127 Verify that R426 component-declaration-stmt is 6128 valid here and implement. */ 6129 6130void 6131ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind, 6132 ffelexToken kindt, ffebld len, ffelexToken lent) 6133{ 6134 ffestc_check_start_ (); 6135 if (ffestc_order_component_ () != FFESTC_orderOK_) 6136 { 6137 ffestc_local_.decl.is_R426 = 0; 6138 return; 6139 } 6140 ffestc_labeldef_useless_ (); 6141 6142 switch (ffestw_state (ffestw_stack_top ())) 6143 { 6144 case FFESTV_stateSTRUCTURE: 6145 case FFESTV_stateMAP: 6146 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one 6147 member. */ 6148 break; 6149 6150 case FFESTV_stateTYPE: 6151 ffestw_set_substate (ffestw_stack_top (), 2); 6152 break; 6153 6154 default: 6155 assert ("Component parent state invalid" == NULL); 6156 break; 6157 } 6158} 6159 6160/* ffestc_R426_attrib -- type attribute 6161 6162 ffestc_R426_attrib(...); 6163 6164 Verify that R426 component-declaration-stmt attribute 6165 is valid here and implement. */ 6166 6167void 6168ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt, 6169 ffestrOther intent_kw, ffesttDimList dims) 6170{ 6171 ffestc_check_attrib_ (); 6172} 6173 6174/* ffestc_R426_item -- declared object 6175 6176 ffestc_R426_item(...); 6177 6178 Establish type for a particular object. */ 6179 6180void 6181ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt, 6182 ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init, 6183 ffelexToken initt, bool clist) 6184{ 6185 ffestc_check_item_ (); 6186 assert (name != NULL); 6187 assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */ 6188 assert (kind == NULL); /* No way an expression should get here. */ 6189 6190 if ((dims != NULL) || (init != NULL) || clist) 6191 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6192} 6193 6194/* ffestc_R426_itemstartvals -- Start list of values 6195 6196 ffestc_R426_itemstartvals(); 6197 6198 Gonna specify values for the object now. */ 6199 6200void 6201ffestc_R426_itemstartvals () 6202{ 6203 ffestc_check_item_startvals_ (); 6204} 6205 6206/* ffestc_R426_itemvalue -- Source value 6207 6208 ffestc_R426_itemvalue(repeat,repeat_token,value,value_token); 6209 6210 Make sure repeat and value are valid for the object being initialized. */ 6211 6212void 6213ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token, 6214 ffebld value, ffelexToken value_token) 6215{ 6216 ffestc_check_item_value_ (); 6217} 6218 6219/* ffestc_R426_itemendvals -- End list of values 6220 6221 ffelexToken t; // the SLASH token that ends the list. 6222 ffestc_R426_itemendvals(t); 6223 6224 No more values, might specify more objects now. */ 6225 6226void 6227ffestc_R426_itemendvals (ffelexToken t) 6228{ 6229 ffestc_check_item_endvals_ (); 6230} 6231 6232/* ffestc_R426_finish -- Done 6233 6234 ffestc_R426_finish(); 6235 6236 Just wrap up any local activities. */ 6237 6238void 6239ffestc_R426_finish () 6240{ 6241 ffestc_check_finish_ (); 6242} 6243 6244#endif 6245/* ffestc_R501_start -- type-declaration-stmt 6246 6247 ffestc_R501_start(...); 6248 6249 Verify that R501 type-declaration-stmt is 6250 valid here and implement. */ 6251 6252void 6253ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind, 6254 ffelexToken kindt, ffebld len, ffelexToken lent) 6255{ 6256 ffestc_check_start_ (); 6257 if (ffestc_order_typedecl_ () != FFESTC_orderOK_) 6258 { 6259 ffestc_local_.decl.is_R426 = 0; 6260 return; 6261 } 6262 ffestc_labeldef_useless_ (); 6263 6264 ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent); 6265} 6266 6267/* ffestc_R501_attrib -- type attribute 6268 6269 ffestc_R501_attrib(...); 6270 6271 Verify that R501 type-declaration-stmt attribute 6272 is valid here and implement. */ 6273 6274void 6275ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt, 6276 ffestrOther intent_kw UNUSED, 6277 ffesttDimList dims UNUSED) 6278{ 6279 ffestc_check_attrib_ (); 6280 6281 switch (attrib) 6282 { 6283#if FFESTR_F90 6284 case FFESTP_attribALLOCATABLE: 6285 break; 6286#endif 6287 6288 case FFESTP_attribDIMENSION: 6289 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6290 break; 6291 6292 case FFESTP_attribEXTERNAL: 6293 break; 6294 6295#if FFESTR_F90 6296 case FFESTP_attribINTENT: 6297 break; 6298#endif 6299 6300 case FFESTP_attribINTRINSIC: 6301 break; 6302 6303#if FFESTR_F90 6304 case FFESTP_attribOPTIONAL: 6305 break; 6306#endif 6307 6308 case FFESTP_attribPARAMETER: 6309 break; 6310 6311#if FFESTR_F90 6312 case FFESTP_attribPOINTER: 6313 break; 6314#endif 6315 6316#if FFESTR_F90 6317 case FFESTP_attribPRIVATE: 6318 break; 6319 6320 case FFESTP_attribPUBLIC: 6321 break; 6322#endif 6323 6324 case FFESTP_attribSAVE: 6325 switch (ffestv_save_state_) 6326 { 6327 case FFESTV_savestateNONE: 6328 ffestv_save_state_ = FFESTV_savestateSPECIFIC; 6329 ffestv_save_line_ 6330 = ffewhere_line_use (ffelex_token_where_line (attribt)); 6331 ffestv_save_col_ 6332 = ffewhere_column_use (ffelex_token_where_column (attribt)); 6333 break; 6334 6335 case FFESTV_savestateSPECIFIC: 6336 case FFESTV_savestateANY: 6337 break; 6338 6339 case FFESTV_savestateALL: 6340 if (ffe_is_pedantic ()) 6341 { 6342 ffebad_start (FFEBAD_CONFLICTING_SAVES); 6343 ffebad_here (0, ffestv_save_line_, ffestv_save_col_); 6344 ffebad_here (1, ffelex_token_where_line (attribt), 6345 ffelex_token_where_column (attribt)); 6346 ffebad_finish (); 6347 } 6348 ffestv_save_state_ = FFESTV_savestateANY; 6349 break; 6350 6351 default: 6352 assert ("unexpected save state" == NULL); 6353 break; 6354 } 6355 break; 6356 6357#if FFESTR_F90 6358 case FFESTP_attribTARGET: 6359 break; 6360#endif 6361 6362 default: 6363 assert ("unexpected attribute" == NULL); 6364 break; 6365 } 6366} 6367 6368/* ffestc_R501_item -- declared object 6369 6370 ffestc_R501_item(...); 6371 6372 Establish type for a particular object. */ 6373 6374void 6375ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt, 6376 ffesttDimList dims, ffebld len, ffelexToken lent, 6377 ffebld init, ffelexToken initt, bool clist) 6378{ 6379 ffesymbol s; 6380 ffesymbol sfn; /* FUNCTION symbol. */ 6381 ffebld array_size; 6382 ffebld extents; 6383 ffesymbolAttrs sa; 6384 ffesymbolAttrs na; 6385 ffestpDimtype nd; 6386 bool is_init = (init != NULL) || clist; 6387 bool is_assumed; 6388 bool is_ugly_assumed; 6389 ffeinfoRank rank; 6390 6391 ffestc_check_item_ (); 6392 assert (name != NULL); 6393 assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */ 6394 assert (kind == NULL); /* No way an expression should get here. */ 6395 6396 ffestc_establish_declinfo_ (kind, kindt, len, lent); 6397 6398 is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER) 6399 && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE); 6400 6401 if ((dims != NULL) || is_init) 6402 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6403 6404 s = ffesymbol_declare_local (name, TRUE); 6405 sa = ffesymbol_attrs (s); 6406 6407 /* First figure out what kind of object this is based solely on the current 6408 object situation (type params, dimension list, and initialization). */ 6409 6410 na = FFESYMBOL_attrsTYPE; 6411 6412 if (is_assumed) 6413 na |= FFESYMBOL_attrsANYLEN; 6414 6415 is_ugly_assumed = (ffe_is_ugly_assumed () 6416 && ((sa & FFESYMBOL_attrsDUMMY) 6417 || (ffesymbol_where (s) == FFEINFO_whereDUMMY))); 6418 6419 nd = ffestt_dimlist_type (dims, is_ugly_assumed); 6420 switch (nd) 6421 { 6422 case FFESTP_dimtypeNONE: 6423 break; 6424 6425 case FFESTP_dimtypeKNOWN: 6426 na |= FFESYMBOL_attrsARRAY; 6427 break; 6428 6429 case FFESTP_dimtypeADJUSTABLE: 6430 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE; 6431 break; 6432 6433 case FFESTP_dimtypeASSUMED: 6434 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE; 6435 break; 6436 6437 case FFESTP_dimtypeADJUSTABLEASSUMED: 6438 na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE 6439 | FFESYMBOL_attrsANYSIZE; 6440 break; 6441 6442 default: 6443 assert ("unexpected dimtype" == NULL); 6444 na = FFESYMBOL_attrsetNONE; 6445 break; 6446 } 6447 6448 if (!ffesta_is_entry_valid 6449 && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY)) 6450 == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY)))) 6451 na = FFESYMBOL_attrsetNONE; 6452 6453 if (is_init) 6454 { 6455 if (na == FFESYMBOL_attrsetNONE) 6456 ; 6457 else if (na & (FFESYMBOL_attrsANYLEN 6458 | FFESYMBOL_attrsADJUSTABLE 6459 | FFESYMBOL_attrsANYSIZE)) 6460 na = FFESYMBOL_attrsetNONE; 6461 else 6462 na |= FFESYMBOL_attrsINIT; 6463 } 6464 6465 /* Now figure out what kind of object we've got based on previous 6466 declarations of or references to the object. */ 6467 6468 if (na == FFESYMBOL_attrsetNONE) 6469 ; 6470 else if (!ffesymbol_is_specable (s) 6471 && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT) 6472 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)) 6473 || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT)))) 6474 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't 6475 dimension/init UNDERSTOODs. */ 6476 else if (sa & FFESYMBOL_attrsANY) 6477 na = sa; 6478 else if ((sa & na) 6479 || ((sa & (FFESYMBOL_attrsSFARG 6480 | FFESYMBOL_attrsADJUSTS)) 6481 && (na & (FFESYMBOL_attrsARRAY 6482 | FFESYMBOL_attrsANYLEN))) 6483 || ((sa & FFESYMBOL_attrsRESULT) 6484 && (na & (FFESYMBOL_attrsARRAY 6485 | FFESYMBOL_attrsINIT))) 6486 || ((sa & (FFESYMBOL_attrsSFUNC 6487 | FFESYMBOL_attrsEXTERNAL 6488 | FFESYMBOL_attrsINTRINSIC 6489 | FFESYMBOL_attrsINIT)) 6490 && (na & (FFESYMBOL_attrsARRAY 6491 | FFESYMBOL_attrsANYLEN 6492 | FFESYMBOL_attrsINIT))) 6493 || ((sa & FFESYMBOL_attrsARRAY) 6494 && !ffesta_is_entry_valid 6495 && (na & FFESYMBOL_attrsANYLEN)) 6496 || ((sa & (FFESYMBOL_attrsADJUSTABLE 6497 | FFESYMBOL_attrsANYLEN 6498 | FFESYMBOL_attrsANYSIZE 6499 | FFESYMBOL_attrsDUMMY)) 6500 && (na & FFESYMBOL_attrsINIT)) 6501 || ((sa & (FFESYMBOL_attrsSAVE 6502 | FFESYMBOL_attrsNAMELIST 6503 | FFESYMBOL_attrsCOMMON 6504 | FFESYMBOL_attrsEQUIV)) 6505 && (na & (FFESYMBOL_attrsADJUSTABLE 6506 | FFESYMBOL_attrsANYLEN 6507 | FFESYMBOL_attrsANYSIZE)))) 6508 na = FFESYMBOL_attrsetNONE; 6509 else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY) 6510 && (ffesymbol_where (s) == FFEINFO_whereCONSTANT) 6511 && (na & FFESYMBOL_attrsANYLEN)) 6512 { /* If CHARACTER*(*) FOO after PARAMETER FOO. */ 6513 na |= FFESYMBOL_attrsTYPE; 6514 ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s)); 6515 } 6516 else 6517 na |= sa; 6518 6519 /* Now see what we've got for a new object: NONE means a new error cropped 6520 up; ANY means an old error to be ignored; otherwise, everything's ok, 6521 update the object (symbol) and continue on. */ 6522 6523 if (na == FFESYMBOL_attrsetNONE) 6524 { 6525 ffesymbol_error (s, name); 6526 ffestc_parent_ok_ = FALSE; 6527 } 6528 else if (na & FFESYMBOL_attrsANY) 6529 ffestc_parent_ok_ = FALSE; 6530 else 6531 { 6532 ffesymbol_set_attrs (s, na); 6533 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 6534 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 6535 rank = ffesymbol_rank (s); 6536 if (dims != NULL) 6537 { 6538 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank, 6539 &array_size, 6540 &extents, 6541 is_ugly_assumed)); 6542 ffesymbol_set_arraysize (s, array_size); 6543 ffesymbol_set_extents (s, extents); 6544 if (!(0 && ffe_is_90 ()) 6545 && (ffebld_op (array_size) == FFEBLD_opCONTER) 6546 && (ffebld_constant_integerdefault (ffebld_conter (array_size)) 6547 == 0)) 6548 { 6549 ffebad_start (FFEBAD_ZERO_ARRAY); 6550 ffebad_here (0, ffelex_token_where_line (name), 6551 ffelex_token_where_column (name)); 6552 ffebad_finish (); 6553 } 6554 } 6555 if (init != NULL) 6556 { 6557 ffesymbol_set_init (s, 6558 ffeexpr_convert (init, initt, name, 6559 ffestc_local_.decl.basic_type, 6560 ffestc_local_.decl.kind_type, 6561 rank, 6562 ffestc_local_.decl.size, 6563 FFEEXPR_contextDATA)); 6564 ffecom_notify_init_symbol (s); 6565 ffesymbol_update_init (s); 6566#if FFEGLOBAL_ENABLED 6567 if (ffesymbol_common (s) != NULL) 6568 ffeglobal_init_common (ffesymbol_common (s), initt); 6569#endif 6570 } 6571 else if (clist) 6572 { 6573 ffebld symter; 6574 6575 symter = ffebld_new_symter (s, FFEINTRIN_genNONE, 6576 FFEINTRIN_specNONE, 6577 FFEINTRIN_impNONE); 6578 6579 ffebld_set_info (symter, 6580 ffeinfo_new (ffestc_local_.decl.basic_type, 6581 ffestc_local_.decl.kind_type, 6582 rank, 6583 FFEINFO_kindNONE, 6584 FFEINFO_whereNONE, 6585 ffestc_local_.decl.size)); 6586 ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL); 6587 } 6588 if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE) 6589 { 6590 ffesymbol_set_info (s, 6591 ffeinfo_new (ffestc_local_.decl.basic_type, 6592 ffestc_local_.decl.kind_type, 6593 rank, 6594 ffesymbol_kind (s), 6595 ffesymbol_where (s), 6596 ffestc_local_.decl.size)); 6597 if ((na & FFESYMBOL_attrsRESULT) 6598 && ((sfn = ffesymbol_funcresult (s)) != NULL)) 6599 { 6600 ffesymbol_set_info (sfn, 6601 ffeinfo_new (ffestc_local_.decl.basic_type, 6602 ffestc_local_.decl.kind_type, 6603 rank, 6604 ffesymbol_kind (sfn), 6605 ffesymbol_where (sfn), 6606 ffestc_local_.decl.size)); 6607 ffesymbol_signal_unreported (sfn); 6608 } 6609 } 6610 else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s)) 6611 || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s)) 6612 || ((ffestc_local_.decl.basic_type 6613 == FFEINFO_basictypeCHARACTER) 6614 && (ffestc_local_.decl.size != ffesymbol_size (s)))) 6615 { /* Explicit type disagrees with established 6616 implicit type. */ 6617 ffesymbol_error (s, name); 6618 } 6619 6620 if ((na & FFESYMBOL_attrsADJUSTS) 6621 && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER) 6622 || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1))) 6623 ffesymbol_error (s, name); 6624 6625 ffesymbol_signal_unreported (s); 6626 ffestc_parent_ok_ = TRUE; 6627 } 6628} 6629 6630/* ffestc_R501_itemstartvals -- Start list of values 6631 6632 ffestc_R501_itemstartvals(); 6633 6634 Gonna specify values for the object now. */ 6635 6636void 6637ffestc_R501_itemstartvals () 6638{ 6639 ffestc_check_item_startvals_ (); 6640 6641 if (ffestc_parent_ok_) 6642 ffedata_begin (ffestc_local_.decl.initlist); 6643} 6644 6645/* ffestc_R501_itemvalue -- Source value 6646 6647 ffestc_R501_itemvalue(repeat,repeat_token,value,value_token); 6648 6649 Make sure repeat and value are valid for the object being initialized. */ 6650 6651void 6652ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token, 6653 ffebld value, ffelexToken value_token) 6654{ 6655 ffetargetIntegerDefault rpt; 6656 6657 ffestc_check_item_value_ (); 6658 6659 if (!ffestc_parent_ok_) 6660 return; 6661 6662 if (repeat == NULL) 6663 rpt = 1; 6664 else if (ffebld_op (repeat) == FFEBLD_opCONTER) 6665 rpt = ffebld_constant_integerdefault (ffebld_conter (repeat)); 6666 else 6667 { 6668 ffestc_parent_ok_ = FALSE; 6669 ffedata_end (TRUE, NULL); 6670 return; 6671 } 6672 6673 if (!(ffestc_parent_ok_ = ffedata_value (rpt, value, 6674 (repeat_token == NULL) ? value_token : repeat_token))) 6675 ffedata_end (TRUE, NULL); 6676} 6677 6678/* ffestc_R501_itemendvals -- End list of values 6679 6680 ffelexToken t; // the SLASH token that ends the list. 6681 ffestc_R501_itemendvals(t); 6682 6683 No more values, might specify more objects now. */ 6684 6685void 6686ffestc_R501_itemendvals (ffelexToken t) 6687{ 6688 ffestc_check_item_endvals_ (); 6689 6690 if (ffestc_parent_ok_) 6691 ffestc_parent_ok_ = ffedata_end (FALSE, t); 6692 6693 if (ffestc_parent_ok_) 6694 ffesymbol_signal_unreported (ffebld_symter (ffebld_head 6695 (ffestc_local_.decl.initlist))); 6696} 6697 6698/* ffestc_R501_finish -- Done 6699 6700 ffestc_R501_finish(); 6701 6702 Just wrap up any local activities. */ 6703 6704void 6705ffestc_R501_finish () 6706{ 6707 ffestc_check_finish_ (); 6708} 6709 6710/* ffestc_R519_start -- INTENT statement list begin 6711 6712 ffestc_R519_start(); 6713 6714 Verify that INTENT is valid here, and begin accepting items in the list. */ 6715 6716#if FFESTR_F90 6717void 6718ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw) 6719{ 6720 ffestc_check_start_ (); 6721 if (ffestc_order_spec_ () != FFESTC_orderOK_) 6722 { 6723 ffestc_ok_ = FALSE; 6724 return; 6725 } 6726 ffestc_labeldef_useless_ (); 6727 6728 ffestd_R519_start (intent_kw); 6729 6730 ffestc_ok_ = TRUE; 6731} 6732 6733/* ffestc_R519_item -- INTENT statement for name 6734 6735 ffestc_R519_item(name_token); 6736 6737 Make sure name_token identifies a valid object to be INTENTed. */ 6738 6739void 6740ffestc_R519_item (ffelexToken name) 6741{ 6742 ffestc_check_item_ (); 6743 assert (name != NULL); 6744 if (!ffestc_ok_) 6745 return; 6746 6747 ffestd_R519_item (name); 6748} 6749 6750/* ffestc_R519_finish -- INTENT statement list complete 6751 6752 ffestc_R519_finish(); 6753 6754 Just wrap up any local activities. */ 6755 6756void 6757ffestc_R519_finish () 6758{ 6759 ffestc_check_finish_ (); 6760 if (!ffestc_ok_) 6761 return; 6762 6763 ffestd_R519_finish (); 6764} 6765 6766/* ffestc_R520_start -- OPTIONAL statement list begin 6767 6768 ffestc_R520_start(); 6769 6770 Verify that OPTIONAL is valid here, and begin accepting items in the list. */ 6771 6772void 6773ffestc_R520_start () 6774{ 6775 ffestc_check_start_ (); 6776 if (ffestc_order_spec_ () != FFESTC_orderOK_) 6777 { 6778 ffestc_ok_ = FALSE; 6779 return; 6780 } 6781 ffestc_labeldef_useless_ (); 6782 6783 ffestd_R520_start (); 6784 6785 ffestc_ok_ = TRUE; 6786} 6787 6788/* ffestc_R520_item -- OPTIONAL statement for name 6789 6790 ffestc_R520_item(name_token); 6791 6792 Make sure name_token identifies a valid object to be OPTIONALed. */ 6793 6794void 6795ffestc_R520_item (ffelexToken name) 6796{ 6797 ffestc_check_item_ (); 6798 assert (name != NULL); 6799 if (!ffestc_ok_) 6800 return; 6801 6802 ffestd_R520_item (name); 6803} 6804 6805/* ffestc_R520_finish -- OPTIONAL statement list complete 6806 6807 ffestc_R520_finish(); 6808 6809 Just wrap up any local activities. */ 6810 6811void 6812ffestc_R520_finish () 6813{ 6814 ffestc_check_finish_ (); 6815 if (!ffestc_ok_) 6816 return; 6817 6818 ffestd_R520_finish (); 6819} 6820 6821/* ffestc_R521A -- PUBLIC statement 6822 6823 ffestc_R521A(); 6824 6825 Verify that PUBLIC is valid here. */ 6826 6827void 6828ffestc_R521A () 6829{ 6830 ffestc_check_simple_ (); 6831 if (ffestc_order_access_ () != FFESTC_orderOK_) 6832 return; 6833 ffestc_labeldef_useless_ (); 6834 6835 switch (ffestv_access_state_) 6836 { 6837 case FFESTV_accessstateNONE: 6838 ffestv_access_state_ = FFESTV_accessstatePUBLIC; 6839 ffestv_access_line_ 6840 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); 6841 ffestv_access_col_ 6842 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); 6843 break; 6844 6845 case FFESTV_accessstateANY: 6846 break; 6847 6848 case FFESTV_accessstatePUBLIC: 6849 case FFESTV_accessstatePRIVATE: 6850 ffebad_start (FFEBAD_CONFLICTING_ACCESSES); 6851 ffebad_here (0, ffestv_access_line_, ffestv_access_col_); 6852 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), 6853 ffelex_token_where_column (ffesta_tokens[0])); 6854 ffebad_finish (); 6855 ffestv_access_state_ = FFESTV_accessstateANY; 6856 break; 6857 6858 default: 6859 assert ("unexpected access state" == NULL); 6860 break; 6861 } 6862 6863 ffestd_R521A (); 6864} 6865 6866/* ffestc_R521Astart -- PUBLIC statement list begin 6867 6868 ffestc_R521Astart(); 6869 6870 Verify that PUBLIC is valid here, and begin accepting items in the list. */ 6871 6872void 6873ffestc_R521Astart () 6874{ 6875 ffestc_check_start_ (); 6876 if (ffestc_order_access_ () != FFESTC_orderOK_) 6877 { 6878 ffestc_ok_ = FALSE; 6879 return; 6880 } 6881 ffestc_labeldef_useless_ (); 6882 6883 ffestd_R521Astart (); 6884 6885 ffestc_ok_ = TRUE; 6886} 6887 6888/* ffestc_R521Aitem -- PUBLIC statement for name 6889 6890 ffestc_R521Aitem(name_token); 6891 6892 Make sure name_token identifies a valid object to be PUBLICed. */ 6893 6894void 6895ffestc_R521Aitem (ffelexToken name) 6896{ 6897 ffestc_check_item_ (); 6898 assert (name != NULL); 6899 if (!ffestc_ok_) 6900 return; 6901 6902 ffestd_R521Aitem (name); 6903} 6904 6905/* ffestc_R521Afinish -- PUBLIC statement list complete 6906 6907 ffestc_R521Afinish(); 6908 6909 Just wrap up any local activities. */ 6910 6911void 6912ffestc_R521Afinish () 6913{ 6914 ffestc_check_finish_ (); 6915 if (!ffestc_ok_) 6916 return; 6917 6918 ffestd_R521Afinish (); 6919} 6920 6921/* ffestc_R521B -- PRIVATE statement 6922 6923 ffestc_R521B(); 6924 6925 Verify that PRIVATE is valid here (outside a derived-type statement). */ 6926 6927void 6928ffestc_R521B () 6929{ 6930 ffestc_check_simple_ (); 6931 if (ffestc_order_access_ () != FFESTC_orderOK_) 6932 return; 6933 ffestc_labeldef_useless_ (); 6934 6935 switch (ffestv_access_state_) 6936 { 6937 case FFESTV_accessstateNONE: 6938 ffestv_access_state_ = FFESTV_accessstatePRIVATE; 6939 ffestv_access_line_ 6940 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); 6941 ffestv_access_col_ 6942 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); 6943 break; 6944 6945 case FFESTV_accessstateANY: 6946 break; 6947 6948 case FFESTV_accessstatePUBLIC: 6949 case FFESTV_accessstatePRIVATE: 6950 ffebad_start (FFEBAD_CONFLICTING_ACCESSES); 6951 ffebad_here (0, ffestv_access_line_, ffestv_access_col_); 6952 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), 6953 ffelex_token_where_column (ffesta_tokens[0])); 6954 ffebad_finish (); 6955 ffestv_access_state_ = FFESTV_accessstateANY; 6956 break; 6957 6958 default: 6959 assert ("unexpected access state" == NULL); 6960 break; 6961 } 6962 6963 ffestd_R521B (); 6964} 6965 6966/* ffestc_R521Bstart -- PRIVATE statement list begin 6967 6968 ffestc_R521Bstart(); 6969 6970 Verify that PRIVATE is valid here, and begin accepting items in the list. */ 6971 6972void 6973ffestc_R521Bstart () 6974{ 6975 ffestc_check_start_ (); 6976 if (ffestc_order_access_ () != FFESTC_orderOK_) 6977 { 6978 ffestc_ok_ = FALSE; 6979 return; 6980 } 6981 ffestc_labeldef_useless_ (); 6982 6983 ffestd_R521Bstart (); 6984 6985 ffestc_ok_ = TRUE; 6986} 6987 6988/* ffestc_R521Bitem -- PRIVATE statement for name 6989 6990 ffestc_R521Bitem(name_token); 6991 6992 Make sure name_token identifies a valid object to be PRIVATEed. */ 6993 6994void 6995ffestc_R521Bitem (ffelexToken name) 6996{ 6997 ffestc_check_item_ (); 6998 assert (name != NULL); 6999 if (!ffestc_ok_) 7000 return; 7001 7002 ffestd_R521Bitem (name); 7003} 7004 7005/* ffestc_R521Bfinish -- PRIVATE statement list complete 7006 7007 ffestc_R521Bfinish(); 7008 7009 Just wrap up any local activities. */ 7010 7011void 7012ffestc_R521Bfinish () 7013{ 7014 ffestc_check_finish_ (); 7015 if (!ffestc_ok_) 7016 return; 7017 7018 ffestd_R521Bfinish (); 7019} 7020 7021#endif 7022/* ffestc_R522 -- SAVE statement with no list 7023 7024 ffestc_R522(); 7025 7026 Verify that SAVE is valid here, and flag everything as SAVEd. */ 7027 7028void 7029ffestc_R522 () 7030{ 7031 ffestc_check_simple_ (); 7032 if (ffestc_order_blockspec_ () != FFESTC_orderOK_) 7033 return; 7034 ffestc_labeldef_useless_ (); 7035 7036 switch (ffestv_save_state_) 7037 { 7038 case FFESTV_savestateNONE: 7039 ffestv_save_state_ = FFESTV_savestateALL; 7040 ffestv_save_line_ 7041 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); 7042 ffestv_save_col_ 7043 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); 7044 break; 7045 7046 case FFESTV_savestateANY: 7047 break; 7048 7049 case FFESTV_savestateSPECIFIC: 7050 case FFESTV_savestateALL: 7051 if (ffe_is_pedantic ()) 7052 { 7053 ffebad_start (FFEBAD_CONFLICTING_SAVES); 7054 ffebad_here (0, ffestv_save_line_, ffestv_save_col_); 7055 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), 7056 ffelex_token_where_column (ffesta_tokens[0])); 7057 ffebad_finish (); 7058 } 7059 ffestv_save_state_ = FFESTV_savestateALL; 7060 break; 7061 7062 default: 7063 assert ("unexpected save state" == NULL); 7064 break; 7065 } 7066 7067 ffe_set_is_saveall (TRUE); 7068 7069 ffestd_R522 (); 7070} 7071 7072/* ffestc_R522start -- SAVE statement list begin 7073 7074 ffestc_R522start(); 7075 7076 Verify that SAVE is valid here, and begin accepting items in the list. */ 7077 7078void 7079ffestc_R522start () 7080{ 7081 ffestc_check_start_ (); 7082 if (ffestc_order_blockspec_ () != FFESTC_orderOK_) 7083 { 7084 ffestc_ok_ = FALSE; 7085 return; 7086 } 7087 ffestc_labeldef_useless_ (); 7088 7089 switch (ffestv_save_state_) 7090 { 7091 case FFESTV_savestateNONE: 7092 ffestv_save_state_ = FFESTV_savestateSPECIFIC; 7093 ffestv_save_line_ 7094 = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); 7095 ffestv_save_col_ 7096 = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); 7097 break; 7098 7099 case FFESTV_savestateSPECIFIC: 7100 case FFESTV_savestateANY: 7101 break; 7102 7103 case FFESTV_savestateALL: 7104 if (ffe_is_pedantic ()) 7105 { 7106 ffebad_start (FFEBAD_CONFLICTING_SAVES); 7107 ffebad_here (0, ffestv_save_line_, ffestv_save_col_); 7108 ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), 7109 ffelex_token_where_column (ffesta_tokens[0])); 7110 ffebad_finish (); 7111 } 7112 ffestv_save_state_ = FFESTV_savestateANY; 7113 break; 7114 7115 default: 7116 assert ("unexpected save state" == NULL); 7117 break; 7118 } 7119 7120 ffestd_R522start (); 7121 7122 ffestc_ok_ = TRUE; 7123} 7124 7125/* ffestc_R522item_object -- SAVE statement for object-name 7126 7127 ffestc_R522item_object(name_token); 7128 7129 Make sure name_token identifies a valid object to be SAVEd. */ 7130 7131void 7132ffestc_R522item_object (ffelexToken name) 7133{ 7134 ffesymbol s; 7135 ffesymbolAttrs sa; 7136 ffesymbolAttrs na; 7137 7138 ffestc_check_item_ (); 7139 assert (name != NULL); 7140 if (!ffestc_ok_) 7141 return; 7142 7143 s = ffesymbol_declare_local (name, FALSE); 7144 sa = ffesymbol_attrs (s); 7145 7146 /* Figure out what kind of object we've got based on previous declarations 7147 of or references to the object. */ 7148 7149 if (!ffesymbol_is_specable (s) 7150 && ((ffesymbol_kind (s) != FFEINFO_kindENTITY) 7151 || (ffesymbol_where (s) != FFEINFO_whereLOCAL))) 7152 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 7153 else if (sa & FFESYMBOL_attrsANY) 7154 na = sa; 7155 else if (!(sa & ~(FFESYMBOL_attrsARRAY 7156 | FFESYMBOL_attrsEQUIV 7157 | FFESYMBOL_attrsINIT 7158 | FFESYMBOL_attrsNAMELIST 7159 | FFESYMBOL_attrsSFARG 7160 | FFESYMBOL_attrsTYPE))) 7161 na = sa | FFESYMBOL_attrsSAVE; 7162 else 7163 na = FFESYMBOL_attrsetNONE; 7164 7165 /* Now see what we've got for a new object: NONE means a new error cropped 7166 up; ANY means an old error to be ignored; otherwise, everything's ok, 7167 update the object (symbol) and continue on. */ 7168 7169 if (na == FFESYMBOL_attrsetNONE) 7170 ffesymbol_error (s, name); 7171 else if (!(na & FFESYMBOL_attrsANY)) 7172 { 7173 ffesymbol_set_attrs (s, na); 7174 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 7175 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 7176 ffesymbol_update_save (s); 7177 ffesymbol_signal_unreported (s); 7178 } 7179 7180 ffestd_R522item_object (name); 7181} 7182 7183/* ffestc_R522item_cblock -- SAVE statement for common-block-name 7184 7185 ffestc_R522item_cblock(name_token); 7186 7187 Make sure name_token identifies a valid common block to be SAVEd. */ 7188 7189void 7190ffestc_R522item_cblock (ffelexToken name) 7191{ 7192 ffesymbol s; 7193 ffesymbolAttrs sa; 7194 ffesymbolAttrs na; 7195 7196 ffestc_check_item_ (); 7197 assert (name != NULL); 7198 if (!ffestc_ok_) 7199 return; 7200 7201 s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]), 7202 ffelex_token_where_column (ffesta_tokens[0])); 7203 sa = ffesymbol_attrs (s); 7204 7205 /* Figure out what kind of object we've got based on previous declarations 7206 of or references to the object. */ 7207 7208 if (!ffesymbol_is_specable (s)) 7209 na = FFESYMBOL_attrsetNONE; 7210 else if (sa & FFESYMBOL_attrsANY) 7211 na = sa; /* Already have an error here, say nothing. */ 7212 else if (!(sa & ~(FFESYMBOL_attrsCBLOCK))) 7213 na = sa | FFESYMBOL_attrsSAVECBLOCK; 7214 else 7215 na = FFESYMBOL_attrsetNONE; 7216 7217 /* Now see what we've got for a new object: NONE means a new error cropped 7218 up; ANY means an old error to be ignored; otherwise, everything's ok, 7219 update the object (symbol) and continue on. */ 7220 7221 if (na == FFESYMBOL_attrsetNONE) 7222 ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name); 7223 else if (!(na & FFESYMBOL_attrsANY)) 7224 { 7225 ffesymbol_set_attrs (s, na); 7226 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 7227 ffesymbol_update_save (s); 7228 ffesymbol_signal_unreported (s); 7229 } 7230 7231 ffestd_R522item_cblock (name); 7232} 7233 7234/* ffestc_R522finish -- SAVE statement list complete 7235 7236 ffestc_R522finish(); 7237 7238 Just wrap up any local activities. */ 7239 7240void 7241ffestc_R522finish () 7242{ 7243 ffestc_check_finish_ (); 7244 if (!ffestc_ok_) 7245 return; 7246 7247 ffestd_R522finish (); 7248} 7249 7250/* ffestc_R524_start -- DIMENSION statement list begin 7251 7252 ffestc_R524_start(bool virtual); 7253 7254 Verify that DIMENSION is valid here, and begin accepting items in the 7255 list. */ 7256 7257void 7258ffestc_R524_start (bool virtual) 7259{ 7260 ffestc_check_start_ (); 7261 if (ffestc_order_blockspec_ () != FFESTC_orderOK_) 7262 { 7263 ffestc_ok_ = FALSE; 7264 return; 7265 } 7266 ffestc_labeldef_useless_ (); 7267 7268 ffestd_R524_start (virtual); 7269 7270 ffestc_ok_ = TRUE; 7271} 7272 7273/* ffestc_R524_item -- DIMENSION statement for object-name 7274 7275 ffestc_R524_item(name_token,dim_list); 7276 7277 Make sure name_token identifies a valid object to be DIMENSIONd. */ 7278 7279void 7280ffestc_R524_item (ffelexToken name, ffesttDimList dims) 7281{ 7282 ffesymbol s; 7283 ffebld array_size; 7284 ffebld extents; 7285 ffesymbolAttrs sa; 7286 ffesymbolAttrs na; 7287 ffestpDimtype nd; 7288 ffeinfoRank rank; 7289 bool is_ugly_assumed; 7290 7291 ffestc_check_item_ (); 7292 assert (name != NULL); 7293 assert (dims != NULL); 7294 if (!ffestc_ok_) 7295 return; 7296 7297 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 7298 7299 s = ffesymbol_declare_local (name, FALSE); 7300 sa = ffesymbol_attrs (s); 7301 7302 /* First figure out what kind of object this is based solely on the current 7303 object situation (dimension list). */ 7304 7305 is_ugly_assumed = (ffe_is_ugly_assumed () 7306 && ((sa & FFESYMBOL_attrsDUMMY) 7307 || (ffesymbol_where (s) == FFEINFO_whereDUMMY))); 7308 7309 nd = ffestt_dimlist_type (dims, is_ugly_assumed); 7310 switch (nd) 7311 { 7312 case FFESTP_dimtypeKNOWN: 7313 na = FFESYMBOL_attrsARRAY; 7314 break; 7315 7316 case FFESTP_dimtypeADJUSTABLE: 7317 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE; 7318 break; 7319 7320 case FFESTP_dimtypeASSUMED: 7321 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE; 7322 break; 7323 7324 case FFESTP_dimtypeADJUSTABLEASSUMED: 7325 na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE 7326 | FFESYMBOL_attrsANYSIZE; 7327 break; 7328 7329 default: 7330 assert ("Unexpected dims type" == NULL); 7331 na = FFESYMBOL_attrsetNONE; 7332 break; 7333 } 7334 7335 /* Now figure out what kind of object we've got based on previous 7336 declarations of or references to the object. */ 7337 7338 if (!ffesymbol_is_specable (s)) 7339 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 7340 else if (sa & FFESYMBOL_attrsANY) 7341 na = FFESYMBOL_attrsANY; 7342 else if (!ffesta_is_entry_valid 7343 && (sa & FFESYMBOL_attrsANYLEN)) 7344 na = FFESYMBOL_attrsetNONE; 7345 else if ((sa & FFESYMBOL_attrsARRAY) 7346 || ((sa & (FFESYMBOL_attrsCOMMON 7347 | FFESYMBOL_attrsEQUIV 7348 | FFESYMBOL_attrsNAMELIST 7349 | FFESYMBOL_attrsSAVE)) 7350 && (na & (FFESYMBOL_attrsADJUSTABLE 7351 | FFESYMBOL_attrsANYSIZE)))) 7352 na = FFESYMBOL_attrsetNONE; 7353 else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE 7354 | FFESYMBOL_attrsANYLEN 7355 | FFESYMBOL_attrsANYSIZE 7356 | FFESYMBOL_attrsCOMMON 7357 | FFESYMBOL_attrsDUMMY 7358 | FFESYMBOL_attrsEQUIV 7359 | FFESYMBOL_attrsNAMELIST 7360 | FFESYMBOL_attrsSAVE 7361 | FFESYMBOL_attrsTYPE))) 7362 na |= sa; 7363 else 7364 na = FFESYMBOL_attrsetNONE; 7365 7366 /* Now see what we've got for a new object: NONE means a new error cropped 7367 up; ANY means an old error to be ignored; otherwise, everything's ok, 7368 update the object (symbol) and continue on. */ 7369 7370 if (na == FFESYMBOL_attrsetNONE) 7371 ffesymbol_error (s, name); 7372 else if (!(na & FFESYMBOL_attrsANY)) 7373 { 7374 ffesymbol_set_attrs (s, na); 7375 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 7376 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank, 7377 &array_size, 7378 &extents, 7379 is_ugly_assumed)); 7380 ffesymbol_set_arraysize (s, array_size); 7381 ffesymbol_set_extents (s, extents); 7382 if (!(0 && ffe_is_90 ()) 7383 && (ffebld_op (array_size) == FFEBLD_opCONTER) 7384 && (ffebld_constant_integerdefault (ffebld_conter (array_size)) 7385 == 0)) 7386 { 7387 ffebad_start (FFEBAD_ZERO_ARRAY); 7388 ffebad_here (0, ffelex_token_where_line (name), 7389 ffelex_token_where_column (name)); 7390 ffebad_finish (); 7391 } 7392 ffesymbol_set_info (s, 7393 ffeinfo_new (ffesymbol_basictype (s), 7394 ffesymbol_kindtype (s), 7395 rank, 7396 ffesymbol_kind (s), 7397 ffesymbol_where (s), 7398 ffesymbol_size (s))); 7399 } 7400 7401 ffesymbol_signal_unreported (s); 7402 7403 ffestd_R524_item (name, dims); 7404} 7405 7406/* ffestc_R524_finish -- DIMENSION statement list complete 7407 7408 ffestc_R524_finish(); 7409 7410 Just wrap up any local activities. */ 7411 7412void 7413ffestc_R524_finish () 7414{ 7415 ffestc_check_finish_ (); 7416 if (!ffestc_ok_) 7417 return; 7418 7419 ffestd_R524_finish (); 7420} 7421 7422/* ffestc_R525_start -- ALLOCATABLE statement list begin 7423 7424 ffestc_R525_start(); 7425 7426 Verify that ALLOCATABLE is valid here, and begin accepting items in the 7427 list. */ 7428 7429#if FFESTR_F90 7430void 7431ffestc_R525_start () 7432{ 7433 ffestc_check_start_ (); 7434 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 7435 { 7436 ffestc_ok_ = FALSE; 7437 return; 7438 } 7439 ffestc_labeldef_useless_ (); 7440 7441 ffestd_R525_start (); 7442 7443 ffestc_ok_ = TRUE; 7444} 7445 7446/* ffestc_R525_item -- ALLOCATABLE statement for object-name 7447 7448 ffestc_R525_item(name_token,dim_list); 7449 7450 Make sure name_token identifies a valid object to be ALLOCATABLEd. */ 7451 7452void 7453ffestc_R525_item (ffelexToken name, ffesttDimList dims) 7454{ 7455 ffestc_check_item_ (); 7456 assert (name != NULL); 7457 if (!ffestc_ok_) 7458 return; 7459 7460 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 7461 7462 ffestd_R525_item (name, dims); 7463} 7464 7465/* ffestc_R525_finish -- ALLOCATABLE statement list complete 7466 7467 ffestc_R525_finish(); 7468 7469 Just wrap up any local activities. */ 7470 7471void 7472ffestc_R525_finish () 7473{ 7474 ffestc_check_finish_ (); 7475 if (!ffestc_ok_) 7476 return; 7477 7478 ffestd_R525_finish (); 7479} 7480 7481/* ffestc_R526_start -- POINTER statement list begin 7482 7483 ffestc_R526_start(); 7484 7485 Verify that POINTER is valid here, and begin accepting items in the 7486 list. */ 7487 7488void 7489ffestc_R526_start () 7490{ 7491 ffestc_check_start_ (); 7492 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 7493 { 7494 ffestc_ok_ = FALSE; 7495 return; 7496 } 7497 ffestc_labeldef_useless_ (); 7498 7499 ffestd_R526_start (); 7500 7501 ffestc_ok_ = TRUE; 7502} 7503 7504/* ffestc_R526_item -- POINTER statement for object-name 7505 7506 ffestc_R526_item(name_token,dim_list); 7507 7508 Make sure name_token identifies a valid object to be POINTERd. */ 7509 7510void 7511ffestc_R526_item (ffelexToken name, ffesttDimList dims) 7512{ 7513 ffestc_check_item_ (); 7514 assert (name != NULL); 7515 if (!ffestc_ok_) 7516 return; 7517 7518 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 7519 7520 ffestd_R526_item (name, dims); 7521} 7522 7523/* ffestc_R526_finish -- POINTER statement list complete 7524 7525 ffestc_R526_finish(); 7526 7527 Just wrap up any local activities. */ 7528 7529void 7530ffestc_R526_finish () 7531{ 7532 ffestc_check_finish_ (); 7533 if (!ffestc_ok_) 7534 return; 7535 7536 ffestd_R526_finish (); 7537} 7538 7539/* ffestc_R527_start -- TARGET statement list begin 7540 7541 ffestc_R527_start(); 7542 7543 Verify that TARGET is valid here, and begin accepting items in the 7544 list. */ 7545 7546void 7547ffestc_R527_start () 7548{ 7549 ffestc_check_start_ (); 7550 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 7551 { 7552 ffestc_ok_ = FALSE; 7553 return; 7554 } 7555 ffestc_labeldef_useless_ (); 7556 7557 ffestd_R527_start (); 7558 7559 ffestc_ok_ = TRUE; 7560} 7561 7562/* ffestc_R527_item -- TARGET statement for object-name 7563 7564 ffestc_R527_item(name_token,dim_list); 7565 7566 Make sure name_token identifies a valid object to be TARGETd. */ 7567 7568void 7569ffestc_R527_item (ffelexToken name, ffesttDimList dims) 7570{ 7571 ffestc_check_item_ (); 7572 assert (name != NULL); 7573 if (!ffestc_ok_) 7574 return; 7575 7576 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 7577 7578 ffestd_R527_item (name, dims); 7579} 7580 7581/* ffestc_R527_finish -- TARGET statement list complete 7582 7583 ffestc_R527_finish(); 7584 7585 Just wrap up any local activities. */ 7586 7587void 7588ffestc_R527_finish () 7589{ 7590 ffestc_check_finish_ (); 7591 if (!ffestc_ok_) 7592 return; 7593 7594 ffestd_R527_finish (); 7595} 7596 7597#endif 7598/* ffestc_R528_start -- DATA statement list begin 7599 7600 ffestc_R528_start(); 7601 7602 Verify that DATA is valid here, and begin accepting items in the list. */ 7603 7604void 7605ffestc_R528_start () 7606{ 7607 ffestcOrder_ order; 7608 7609 ffestc_check_start_ (); 7610 if (ffe_is_pedantic_not_90 ()) 7611 order = ffestc_order_data77_ (); 7612 else 7613 order = ffestc_order_data_ (); 7614 if (order != FFESTC_orderOK_) 7615 { 7616 ffestc_ok_ = FALSE; 7617 return; 7618 } 7619 ffestc_labeldef_useless_ (); 7620 7621 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 7622 7623#if 1 7624 ffestc_local_.data.objlist = NULL; 7625#else 7626 ffestd_R528_start_ (); 7627#endif 7628 7629 ffestc_ok_ = TRUE; 7630} 7631 7632/* ffestc_R528_item_object -- DATA statement target object 7633 7634 ffestc_R528_item_object(object,object_token); 7635 7636 Make sure object is valid to be DATAd. */ 7637 7638void 7639ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED) 7640{ 7641 ffestc_check_item_ (); 7642 if (!ffestc_ok_) 7643 return; 7644 7645#if 1 7646 if (ffestc_local_.data.objlist == NULL) 7647 ffebld_init_list (&ffestc_local_.data.objlist, 7648 &ffestc_local_.data.list_bottom); 7649 7650 ffebld_append_item (&ffestc_local_.data.list_bottom, expr); 7651#else 7652 ffestd_R528_item_object_ (expr, expr_token); 7653#endif 7654} 7655 7656/* ffestc_R528_item_startvals -- DATA statement start list of values 7657 7658 ffestc_R528_item_startvals(); 7659 7660 No more objects, gonna specify values for the list of objects now. */ 7661 7662void 7663ffestc_R528_item_startvals () 7664{ 7665 ffestc_check_item_startvals_ (); 7666 if (!ffestc_ok_) 7667 return; 7668 7669#if 1 7670 assert (ffestc_local_.data.objlist != NULL); 7671 ffebld_end_list (&ffestc_local_.data.list_bottom); 7672 ffedata_begin (ffestc_local_.data.objlist); 7673#else 7674 ffestd_R528_item_startvals_ (); 7675#endif 7676} 7677 7678/* ffestc_R528_item_value -- DATA statement source value 7679 7680 ffestc_R528_item_value(repeat,repeat_token,value,value_token); 7681 7682 Make sure repeat and value are valid for the objects being initialized. */ 7683 7684void 7685ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token, 7686 ffebld value, ffelexToken value_token) 7687{ 7688 ffetargetIntegerDefault rpt; 7689 7690 ffestc_check_item_value_ (); 7691 if (!ffestc_ok_) 7692 return; 7693 7694#if 1 7695 if (repeat == NULL) 7696 rpt = 1; 7697 else if (ffebld_op (repeat) == FFEBLD_opCONTER) 7698 rpt = ffebld_constant_integerdefault (ffebld_conter (repeat)); 7699 else 7700 { 7701 ffestc_ok_ = FALSE; 7702 ffedata_end (TRUE, NULL); 7703 return; 7704 } 7705 7706 if (!(ffestc_ok_ = ffedata_value (rpt, value, 7707 (repeat_token == NULL) 7708 ? value_token 7709 : repeat_token))) 7710 ffedata_end (TRUE, NULL); 7711 7712#else 7713 ffestd_R528_item_value_ (repeat, value); 7714#endif 7715} 7716 7717/* ffestc_R528_item_endvals -- DATA statement start list of values 7718 7719 ffelexToken t; // the SLASH token that ends the list. 7720 ffestc_R528_item_endvals(t); 7721 7722 No more values, might specify more objects now. */ 7723 7724void 7725ffestc_R528_item_endvals (ffelexToken t) 7726{ 7727 ffestc_check_item_endvals_ (); 7728 if (!ffestc_ok_) 7729 return; 7730 7731#if 1 7732 ffedata_end (!ffestc_ok_, t); 7733 ffestc_local_.data.objlist = NULL; 7734#else 7735 ffestd_R528_item_endvals_ (t); 7736#endif 7737} 7738 7739/* ffestc_R528_finish -- DATA statement list complete 7740 7741 ffestc_R528_finish(); 7742 7743 Just wrap up any local activities. */ 7744 7745void 7746ffestc_R528_finish () 7747{ 7748 ffestc_check_finish_ (); 7749 7750#if 1 7751#else 7752 ffestd_R528_finish_ (); 7753#endif 7754} 7755 7756/* ffestc_R537_start -- PARAMETER statement list begin 7757 7758 ffestc_R537_start(); 7759 7760 Verify that PARAMETER is valid here, and begin accepting items in the 7761 list. */ 7762 7763void 7764ffestc_R537_start () 7765{ 7766 ffestc_check_start_ (); 7767 if (ffestc_order_parameter_ () != FFESTC_orderOK_) 7768 { 7769 ffestc_ok_ = FALSE; 7770 return; 7771 } 7772 ffestc_labeldef_useless_ (); 7773 7774 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 7775 7776 ffestd_R537_start (); 7777 7778 ffestc_ok_ = TRUE; 7779} 7780 7781/* ffestc_R537_item -- PARAMETER statement assignment 7782 7783 ffestc_R537_item(dest,dest_token,source,source_token); 7784 7785 Make sure the source is a valid source for the destination; make the 7786 assignment. */ 7787 7788void 7789ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source, 7790 ffelexToken source_token) 7791{ 7792 ffesymbol s; 7793 7794 ffestc_check_item_ (); 7795 if (!ffestc_ok_) 7796 return; 7797 7798 if ((ffebld_op (dest) == FFEBLD_opANY) 7799 || (ffebld_op (source) == FFEBLD_opANY)) 7800 { 7801 if (ffebld_op (dest) == FFEBLD_opSYMTER) 7802 { 7803 s = ffebld_symter (dest); 7804 ffesymbol_set_init (s, ffebld_new_any ()); 7805 ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ()); 7806 ffesymbol_signal_unreported (s); 7807 } 7808 ffestd_R537_item (dest, source); 7809 return; 7810 } 7811 7812 assert (ffebld_op (dest) == FFEBLD_opSYMTER); 7813 assert (ffebld_op (source) == FFEBLD_opCONTER); 7814 7815 s = ffebld_symter (dest); 7816 if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) 7817 && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)) 7818 { /* Destination has explicit/implicit 7819 CHARACTER*(*) type; set length. */ 7820 ffesymbol_set_info (s, 7821 ffeinfo_new (ffesymbol_basictype (s), 7822 ffesymbol_kindtype (s), 7823 0, 7824 ffesymbol_kind (s), 7825 ffesymbol_where (s), 7826 ffebld_size (source))); 7827 ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s))); 7828 } 7829 7830 source = ffeexpr_convert_expr (source, source_token, dest, dest_token, 7831 FFEEXPR_contextDATA); 7832 7833 ffesymbol_set_init (s, source); 7834 7835 ffesymbol_signal_unreported (s); 7836 7837 ffestd_R537_item (dest, source); 7838} 7839 7840/* ffestc_R537_finish -- PARAMETER statement list complete 7841 7842 ffestc_R537_finish(); 7843 7844 Just wrap up any local activities. */ 7845 7846void 7847ffestc_R537_finish () 7848{ 7849 ffestc_check_finish_ (); 7850 if (!ffestc_ok_) 7851 return; 7852 7853 ffestd_R537_finish (); 7854} 7855 7856/* ffestc_R539 -- IMPLICIT NONE statement 7857 7858 ffestc_R539(); 7859 7860 Verify that the IMPLICIT NONE statement is ok here and implement. */ 7861 7862void 7863ffestc_R539 () 7864{ 7865 ffestc_check_simple_ (); 7866 if (ffestc_order_implicitnone_ () != FFESTC_orderOK_) 7867 return; 7868 ffestc_labeldef_useless_ (); 7869 7870 ffeimplic_none (); 7871 7872 ffestd_R539 (); 7873} 7874 7875/* ffestc_R539start -- IMPLICIT statement 7876 7877 ffestc_R539start(); 7878 7879 Verify that the IMPLICIT statement is ok here and implement. */ 7880 7881void 7882ffestc_R539start () 7883{ 7884 ffestc_check_start_ (); 7885 if (ffestc_order_implicit_ () != FFESTC_orderOK_) 7886 { 7887 ffestc_ok_ = FALSE; 7888 return; 7889 } 7890 ffestc_labeldef_useless_ (); 7891 7892 ffestd_R539start (); 7893 7894 ffestc_ok_ = TRUE; 7895} 7896 7897/* ffestc_R539item -- IMPLICIT statement specification (R540) 7898 7899 ffestc_R539item(...); 7900 7901 Verify that the type and letter list are all ok and implement. */ 7902 7903void 7904ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt, 7905 ffebld len, ffelexToken lent, ffesttImpList letters) 7906{ 7907 ffestc_check_item_ (); 7908 if (!ffestc_ok_) 7909 return; 7910 7911 if ((type == FFESTP_typeCHARACTER) && (len != NULL) 7912 && (ffebld_op (len) == FFEBLD_opSTAR)) 7913 { /* Complain and pretend they're CHARACTER 7914 [*1]. */ 7915 ffebad_start (FFEBAD_IMPLICIT_ADJLEN); 7916 ffebad_here (0, ffelex_token_where_line (lent), 7917 ffelex_token_where_column (lent)); 7918 ffebad_finish (); 7919 len = NULL; 7920 lent = NULL; 7921 } 7922 ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent); 7923 ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL); 7924 7925 ffestt_implist_drive (letters, ffestc_establish_impletter_); 7926 7927 ffestd_R539item (type, kind, kindt, len, lent, letters); 7928} 7929 7930/* ffestc_R539finish -- IMPLICIT statement 7931 7932 ffestc_R539finish(); 7933 7934 Finish up any local activities. */ 7935 7936void 7937ffestc_R539finish () 7938{ 7939 ffestc_check_finish_ (); 7940 if (!ffestc_ok_) 7941 return; 7942 7943 ffestd_R539finish (); 7944} 7945 7946/* ffestc_R542_start -- NAMELIST statement list begin 7947 7948 ffestc_R542_start(); 7949 7950 Verify that NAMELIST is valid here, and begin accepting items in the 7951 list. */ 7952 7953void 7954ffestc_R542_start () 7955{ 7956 ffestc_check_start_ (); 7957 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 7958 { 7959 ffestc_ok_ = FALSE; 7960 return; 7961 } 7962 ffestc_labeldef_useless_ (); 7963 7964 if (ffe_is_f2c_library () 7965 && (ffe_case_source () == FFE_caseNONE)) 7966 { 7967 ffebad_start (FFEBAD_NAMELIST_CASE); 7968 ffesta_ffebad_here_current_stmt (0); 7969 ffebad_finish (); 7970 } 7971 7972 ffestd_R542_start (); 7973 7974 ffestc_local_.namelist.symbol = NULL; 7975 7976 ffestc_ok_ = TRUE; 7977} 7978 7979/* ffestc_R542_item_nlist -- NAMELIST statement for group-name 7980 7981 ffestc_R542_item_nlist(groupname_token); 7982 7983 Make sure name_token identifies a valid object to be NAMELISTd. */ 7984 7985void 7986ffestc_R542_item_nlist (ffelexToken name) 7987{ 7988 ffesymbol s; 7989 7990 ffestc_check_item_ (); 7991 assert (name != NULL); 7992 if (!ffestc_ok_) 7993 return; 7994 7995 if (ffestc_local_.namelist.symbol != NULL) 7996 ffesymbol_signal_unreported (ffestc_local_.namelist.symbol); 7997 7998 s = ffesymbol_declare_local (name, FALSE); 7999 8000 if ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 8001 || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 8002 && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))) 8003 { 8004 ffestc_parent_ok_ = TRUE; 8005 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 8006 { 8007 ffebld_init_list (ffesymbol_ptr_to_namelist (s), 8008 ffesymbol_ptr_to_listbottom (s)); 8009 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 8010 ffesymbol_set_info (s, 8011 ffeinfo_new (FFEINFO_basictypeNONE, 8012 FFEINFO_kindtypeNONE, 8013 0, 8014 FFEINFO_kindNAMELIST, 8015 FFEINFO_whereLOCAL, 8016 FFETARGET_charactersizeNONE)); 8017 } 8018 } 8019 else 8020 { 8021 if (ffesymbol_kind (s) != FFEINFO_kindANY) 8022 ffesymbol_error (s, name); 8023 ffestc_parent_ok_ = FALSE; 8024 } 8025 8026 ffestc_local_.namelist.symbol = s; 8027 8028 ffestd_R542_item_nlist (name); 8029} 8030 8031/* ffestc_R542_item_nitem -- NAMELIST statement for variable-name 8032 8033 ffestc_R542_item_nitem(name_token); 8034 8035 Make sure name_token identifies a valid object to be NAMELISTd. */ 8036 8037void 8038ffestc_R542_item_nitem (ffelexToken name) 8039{ 8040 ffesymbol s; 8041 ffesymbolAttrs sa; 8042 ffesymbolAttrs na; 8043 ffebld e; 8044 8045 ffestc_check_item_ (); 8046 assert (name != NULL); 8047 if (!ffestc_ok_) 8048 return; 8049 8050 s = ffesymbol_declare_local (name, FALSE); 8051 sa = ffesymbol_attrs (s); 8052 8053 /* Figure out what kind of object we've got based on previous declarations 8054 of or references to the object. */ 8055 8056 if (!ffesymbol_is_specable (s) 8057 && ((ffesymbol_kind (s) != FFEINFO_kindENTITY) 8058 || ((ffesymbol_where (s) != FFEINFO_whereLOCAL) 8059 && (ffesymbol_where (s) != FFEINFO_whereCOMMON)))) 8060 na = FFESYMBOL_attrsetNONE; 8061 else if (sa & FFESYMBOL_attrsANY) 8062 na = FFESYMBOL_attrsANY; 8063 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS 8064 | FFESYMBOL_attrsARRAY 8065 | FFESYMBOL_attrsCOMMON 8066 | FFESYMBOL_attrsEQUIV 8067 | FFESYMBOL_attrsINIT 8068 | FFESYMBOL_attrsNAMELIST 8069 | FFESYMBOL_attrsSAVE 8070 | FFESYMBOL_attrsSFARG 8071 | FFESYMBOL_attrsTYPE))) 8072 na = sa | FFESYMBOL_attrsNAMELIST; 8073 else 8074 na = FFESYMBOL_attrsetNONE; 8075 8076 /* Now see what we've got for a new object: NONE means a new error cropped 8077 up; ANY means an old error to be ignored; otherwise, everything's ok, 8078 update the object (symbol) and continue on. */ 8079 8080 if (na == FFESYMBOL_attrsetNONE) 8081 ffesymbol_error (s, name); 8082 else if (!(na & FFESYMBOL_attrsANY)) 8083 { 8084 ffesymbol_set_attrs (s, na); 8085 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 8086 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 8087 ffesymbol_set_namelisted (s, TRUE); 8088 ffesymbol_signal_unreported (s); 8089#if 0 /* No need to establish type yet! */ 8090 if (!ffeimplic_establish_symbol (s)) 8091 ffesymbol_error (s, name); 8092#endif 8093 } 8094 8095 if (ffestc_parent_ok_) 8096 { 8097 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 8098 FFEINTRIN_impNONE); 8099 ffebld_set_info (e, 8100 ffeinfo_new (FFEINFO_basictypeNONE, 8101 FFEINFO_kindtypeNONE, 0, 8102 FFEINFO_kindNONE, 8103 FFEINFO_whereNONE, 8104 FFETARGET_charactersizeNONE)); 8105 ffebld_append_item 8106 (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e); 8107 } 8108 8109 ffestd_R542_item_nitem (name); 8110} 8111 8112/* ffestc_R542_finish -- NAMELIST statement list complete 8113 8114 ffestc_R542_finish(); 8115 8116 Just wrap up any local activities. */ 8117 8118void 8119ffestc_R542_finish () 8120{ 8121 ffestc_check_finish_ (); 8122 if (!ffestc_ok_) 8123 return; 8124 8125 ffesymbol_signal_unreported (ffestc_local_.namelist.symbol); 8126 8127 ffestd_R542_finish (); 8128} 8129 8130/* ffestc_R544_start -- EQUIVALENCE statement list begin 8131 8132 ffestc_R544_start(); 8133 8134 Verify that EQUIVALENCE is valid here, and begin accepting items in the 8135 list. */ 8136 8137void 8138ffestc_R544_start () 8139{ 8140 ffestc_check_start_ (); 8141 if (ffestc_order_blockspec_ () != FFESTC_orderOK_) 8142 { 8143 ffestc_ok_ = FALSE; 8144 return; 8145 } 8146 ffestc_labeldef_useless_ (); 8147 8148 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 8149 8150 ffestc_ok_ = TRUE; 8151} 8152 8153/* ffestc_R544_item -- EQUIVALENCE statement assignment 8154 8155 ffestc_R544_item(exprlist); 8156 8157 Make sure the equivalence is valid, then implement it. */ 8158 8159void 8160ffestc_R544_item (ffesttExprList exprlist) 8161{ 8162 ffestc_check_item_ (); 8163 if (!ffestc_ok_) 8164 return; 8165 8166 /* First we go through the list and come up with one ffeequiv object that 8167 will describe all items in the list. When an ffeequiv object is first 8168 found, it is used (else we create one as a "local equiv" for the time 8169 being). If subsequent ffeequiv objects are found, they are merged with 8170 the first so we end up with one. However, if more than one COMMON 8171 variable is involved, then an error condition occurs. */ 8172 8173 ffestc_local_.equiv.ok = TRUE; 8174 ffestc_local_.equiv.t = NULL; /* No token yet. */ 8175 ffestc_local_.equiv.eq = NULL;/* No equiv yet. */ 8176 ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */ 8177 8178 ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom); 8179 ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */ 8180 ffebld_end_list (&ffestc_local_.equiv.bottom); 8181 8182 if (!ffestc_local_.equiv.ok) 8183 return; /* Something went wrong, stop bothering with 8184 this stuff. */ 8185 8186 if (ffestc_local_.equiv.eq == NULL) 8187 ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */ 8188 8189 /* Append this list of equivalences to list of such lists for this 8190 equivalence. */ 8191 8192 ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list, 8193 ffestc_local_.equiv.t); 8194 if (ffestc_local_.equiv.save) 8195 ffeequiv_update_save (ffestc_local_.equiv.eq); 8196} 8197 8198/* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list 8199 8200 ffebld expr; 8201 ffelexToken t; 8202 ffestc_R544_equiv_(expr,t); 8203 8204 Record information, if any, on symbol in expr; if symbol has equivalence 8205 object already, merge with outstanding object if present or make it 8206 the outstanding object. */ 8207 8208static void 8209ffestc_R544_equiv_ (ffebld expr, ffelexToken t) 8210{ 8211 ffesymbol s; 8212 8213 if (!ffestc_local_.equiv.ok) 8214 return; 8215 8216 if (ffestc_local_.equiv.t == NULL) 8217 ffestc_local_.equiv.t = t; 8218 8219 switch (ffebld_op (expr)) 8220 { 8221 case FFEBLD_opANY: 8222 return; /* Don't put this on the list. */ 8223 8224 case FFEBLD_opSYMTER: 8225 case FFEBLD_opARRAYREF: 8226 case FFEBLD_opSUBSTR: 8227 break; /* All of these are ok. */ 8228 8229 default: 8230 assert ("ffestc_R544_equiv_ bad op" == NULL); 8231 return; 8232 } 8233 8234 ffebld_append_item (&ffestc_local_.equiv.bottom, expr); 8235 8236 s = ffeequiv_symbol (expr); 8237 8238 /* See if symbol has an equivalence object already. */ 8239 8240 if (ffesymbol_equiv (s) != NULL) 8241 { 8242 if (ffestc_local_.equiv.eq == NULL) 8243 ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */ 8244 else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s)) 8245 { 8246 ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s), 8247 ffestc_local_.equiv.eq, 8248 t); 8249 if (ffestc_local_.equiv.eq == NULL) 8250 ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */ 8251 } 8252 } 8253 8254 if (ffesymbol_is_save (s)) 8255 ffestc_local_.equiv.save = TRUE; 8256} 8257 8258/* ffestc_R544_finish -- EQUIVALENCE statement list complete 8259 8260 ffestc_R544_finish(); 8261 8262 Just wrap up any local activities. */ 8263 8264void 8265ffestc_R544_finish () 8266{ 8267 ffestc_check_finish_ (); 8268} 8269 8270/* ffestc_R547_start -- COMMON statement list begin 8271 8272 ffestc_R547_start(); 8273 8274 Verify that COMMON is valid here, and begin accepting items in the list. */ 8275 8276void 8277ffestc_R547_start () 8278{ 8279 ffestc_check_start_ (); 8280 if (ffestc_order_blockspec_ () != FFESTC_orderOK_) 8281 { 8282 ffestc_ok_ = FALSE; 8283 return; 8284 } 8285 ffestc_labeldef_useless_ (); 8286 8287 ffestc_local_.common.symbol = NULL; /* Blank common is the default. */ 8288 ffestc_parent_ok_ = TRUE; 8289 8290 ffestd_R547_start (); 8291 8292 ffestc_ok_ = TRUE; 8293} 8294 8295/* ffestc_R547_item_object -- COMMON statement for object-name 8296 8297 ffestc_R547_item_object(name_token,dim_list); 8298 8299 Make sure name_token identifies a valid object to be COMMONd. */ 8300 8301void 8302ffestc_R547_item_object (ffelexToken name, ffesttDimList dims) 8303{ 8304 ffesymbol s; 8305 ffebld array_size; 8306 ffebld extents; 8307 ffesymbolAttrs sa; 8308 ffesymbolAttrs na; 8309 ffestpDimtype nd; 8310 ffebld e; 8311 ffeinfoRank rank; 8312 bool is_ugly_assumed; 8313 8314 if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL)) 8315 ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */ 8316 8317 ffestc_check_item_ (); 8318 assert (name != NULL); 8319 if (!ffestc_ok_) 8320 return; 8321 8322 if (dims != NULL) 8323 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 8324 8325 s = ffesymbol_declare_local (name, FALSE); 8326 sa = ffesymbol_attrs (s); 8327 8328 /* First figure out what kind of object this is based solely on the current 8329 object situation (dimension list). */ 8330 8331 is_ugly_assumed = (ffe_is_ugly_assumed () 8332 && ((sa & FFESYMBOL_attrsDUMMY) 8333 || (ffesymbol_where (s) == FFEINFO_whereDUMMY))); 8334 8335 nd = ffestt_dimlist_type (dims, is_ugly_assumed); 8336 switch (nd) 8337 { 8338 case FFESTP_dimtypeNONE: 8339 na = FFESYMBOL_attrsCOMMON; 8340 break; 8341 8342 case FFESTP_dimtypeKNOWN: 8343 na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY; 8344 break; 8345 8346 default: 8347 na = FFESYMBOL_attrsetNONE; 8348 break; 8349 } 8350 8351 /* Figure out what kind of object we've got based on previous declarations 8352 of or references to the object. */ 8353 8354 if (na == FFESYMBOL_attrsetNONE) 8355 ; 8356 else if (!ffesymbol_is_specable (s)) 8357 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 8358 else if (sa & FFESYMBOL_attrsANY) 8359 na = FFESYMBOL_attrsANY; 8360 else if ((sa & (FFESYMBOL_attrsADJUSTS 8361 | FFESYMBOL_attrsARRAY 8362 | FFESYMBOL_attrsINIT 8363 | FFESYMBOL_attrsSFARG)) 8364 && (na & FFESYMBOL_attrsARRAY)) 8365 na = FFESYMBOL_attrsetNONE; 8366 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS 8367 | FFESYMBOL_attrsARRAY 8368 | FFESYMBOL_attrsEQUIV 8369 | FFESYMBOL_attrsINIT 8370 | FFESYMBOL_attrsNAMELIST 8371 | FFESYMBOL_attrsSFARG 8372 | FFESYMBOL_attrsTYPE))) 8373 na |= sa; 8374 else 8375 na = FFESYMBOL_attrsetNONE; 8376 8377 /* Now see what we've got for a new object: NONE means a new error cropped 8378 up; ANY means an old error to be ignored; otherwise, everything's ok, 8379 update the object (symbol) and continue on. */ 8380 8381 if (na == FFESYMBOL_attrsetNONE) 8382 ffesymbol_error (s, name); 8383 else if ((ffesymbol_equiv (s) != NULL) 8384 && (ffeequiv_common (ffesymbol_equiv (s)) != NULL) 8385 && (ffeequiv_common (ffesymbol_equiv (s)) 8386 != ffestc_local_.common.symbol)) 8387 { 8388 /* Oops, just COMMONed a symbol to a different area (via equiv). */ 8389 ffebad_start (FFEBAD_EQUIV_COMMON); 8390 ffebad_here (0, ffelex_token_where_line (name), 8391 ffelex_token_where_column (name)); 8392 ffebad_string (ffesymbol_text (ffestc_local_.common.symbol)); 8393 ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s)))); 8394 ffebad_finish (); 8395 ffesymbol_set_attr (s, na | FFESYMBOL_attrANY); 8396 ffesymbol_set_info (s, ffeinfo_new_any ()); 8397 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 8398 ffesymbol_signal_unreported (s); 8399 } 8400 else if (!(na & FFESYMBOL_attrsANY)) 8401 { 8402 ffesymbol_set_attrs (s, na); 8403 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 8404 ffesymbol_set_common (s, ffestc_local_.common.symbol); 8405#if FFEGLOBAL_ENABLED 8406 if (ffesymbol_is_init (s)) 8407 ffeglobal_init_common (ffestc_local_.common.symbol, name); 8408#endif 8409 if (ffesymbol_is_save (ffestc_local_.common.symbol)) 8410 ffesymbol_update_save (s); 8411 if (ffesymbol_equiv (s) != NULL) 8412 { /* Is this newly COMMONed symbol involved in 8413 an equivalence? */ 8414 if (ffeequiv_common (ffesymbol_equiv (s)) == NULL) 8415 ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */ 8416 ffestc_local_.common.symbol); 8417#if FFEGLOBAL_ENABLED 8418 if (ffeequiv_is_init (ffesymbol_equiv (s))) 8419 ffeglobal_init_common (ffestc_local_.common.symbol, name); 8420#endif 8421 if (ffesymbol_is_save (ffestc_local_.common.symbol)) 8422 ffeequiv_update_save (ffesymbol_equiv (s)); 8423 } 8424 if (dims != NULL) 8425 { 8426 ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank, 8427 &array_size, 8428 &extents, 8429 is_ugly_assumed)); 8430 ffesymbol_set_arraysize (s, array_size); 8431 ffesymbol_set_extents (s, extents); 8432 if (!(0 && ffe_is_90 ()) 8433 && (ffebld_op (array_size) == FFEBLD_opCONTER) 8434 && (ffebld_constant_integerdefault (ffebld_conter (array_size)) 8435 == 0)) 8436 { 8437 ffebad_start (FFEBAD_ZERO_ARRAY); 8438 ffebad_here (0, ffelex_token_where_line (name), 8439 ffelex_token_where_column (name)); 8440 ffebad_finish (); 8441 } 8442 ffesymbol_set_info (s, 8443 ffeinfo_new (ffesymbol_basictype (s), 8444 ffesymbol_kindtype (s), 8445 rank, 8446 ffesymbol_kind (s), 8447 ffesymbol_where (s), 8448 ffesymbol_size (s))); 8449 } 8450 ffesymbol_signal_unreported (s); 8451 } 8452 8453 if (ffestc_parent_ok_) 8454 { 8455 e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 8456 FFEINTRIN_impNONE); 8457 ffebld_set_info (e, 8458 ffeinfo_new (FFEINFO_basictypeNONE, 8459 FFEINFO_kindtypeNONE, 8460 0, 8461 FFEINFO_kindNONE, 8462 FFEINFO_whereNONE, 8463 FFETARGET_charactersizeNONE)); 8464 ffebld_append_item 8465 (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e); 8466 } 8467 8468 ffestd_R547_item_object (name, dims); 8469} 8470 8471/* ffestc_R547_item_cblock -- COMMON statement for common-block-name 8472 8473 ffestc_R547_item_cblock(name_token); 8474 8475 Make sure name_token identifies a valid common block to be COMMONd. */ 8476 8477void 8478ffestc_R547_item_cblock (ffelexToken name) 8479{ 8480 ffesymbol s; 8481 ffesymbolAttrs sa; 8482 ffesymbolAttrs na; 8483 8484 ffestc_check_item_ (); 8485 if (!ffestc_ok_) 8486 return; 8487 8488 if (ffestc_local_.common.symbol != NULL) 8489 ffesymbol_signal_unreported (ffestc_local_.common.symbol); 8490 8491 s = ffesymbol_declare_cblock (name, 8492 ffelex_token_where_line (ffesta_tokens[0]), 8493 ffelex_token_where_column (ffesta_tokens[0])); 8494 sa = ffesymbol_attrs (s); 8495 8496 /* Figure out what kind of object we've got based on previous declarations 8497 of or references to the object. */ 8498 8499 if (!ffesymbol_is_specable (s)) 8500 na = FFESYMBOL_attrsetNONE; 8501 else if (sa & FFESYMBOL_attrsANY) 8502 na = FFESYMBOL_attrsANY; /* Already have an error here, say nothing. */ 8503 else if (!(sa & ~(FFESYMBOL_attrsCBLOCK 8504 | FFESYMBOL_attrsSAVECBLOCK))) 8505 { 8506 if (!(sa & FFESYMBOL_attrsCBLOCK)) 8507 ffebld_init_list (ffesymbol_ptr_to_commonlist (s), 8508 ffesymbol_ptr_to_listbottom (s)); 8509 na = sa | FFESYMBOL_attrsCBLOCK; 8510 } 8511 else 8512 na = FFESYMBOL_attrsetNONE; 8513 8514 /* Now see what we've got for a new object: NONE means a new error cropped 8515 up; ANY means an old error to be ignored; otherwise, everything's ok, 8516 update the object (symbol) and continue on. */ 8517 8518 if (na == FFESYMBOL_attrsetNONE) 8519 { 8520 ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name); 8521 ffestc_parent_ok_ = FALSE; 8522 } 8523 else if (na & FFESYMBOL_attrsANY) 8524 ffestc_parent_ok_ = FALSE; 8525 else 8526 { 8527 ffesymbol_set_attrs (s, na); 8528 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 8529 if (name == NULL) 8530 ffesymbol_update_save (s); 8531 ffestc_parent_ok_ = TRUE; 8532 } 8533 8534 ffestc_local_.common.symbol = s; 8535 8536 ffestd_R547_item_cblock (name); 8537} 8538 8539/* ffestc_R547_finish -- COMMON statement list complete 8540 8541 ffestc_R547_finish(); 8542 8543 Just wrap up any local activities. */ 8544 8545void 8546ffestc_R547_finish () 8547{ 8548 ffestc_check_finish_ (); 8549 if (!ffestc_ok_) 8550 return; 8551 8552 if (ffestc_local_.common.symbol != NULL) 8553 ffesymbol_signal_unreported (ffestc_local_.common.symbol); 8554 8555 ffestd_R547_finish (); 8556} 8557 8558/* ffestc_R620 -- ALLOCATE statement 8559 8560 ffestc_R620(exprlist,stat,stat_token); 8561 8562 Make sure the expression list is valid, then implement it. */ 8563 8564#if FFESTR_F90 8565void 8566ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token) 8567{ 8568 ffestc_check_simple_ (); 8569 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 8570 return; 8571 ffestc_labeldef_branch_begin_ (); 8572 8573 ffestd_R620 (exprlist, stat); 8574 8575 if (ffestc_shriek_after1_ != NULL) 8576 (*ffestc_shriek_after1_) (TRUE); 8577 ffestc_labeldef_branch_end_ (); 8578} 8579 8580/* ffestc_R624 -- NULLIFY statement 8581 8582 ffestc_R624(pointer_name_list); 8583 8584 Make sure pointer_name_list identifies valid pointers for a NULLIFY. */ 8585 8586void 8587ffestc_R624 (ffesttExprList pointers) 8588{ 8589 ffestc_check_simple_ (); 8590 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 8591 return; 8592 ffestc_labeldef_branch_begin_ (); 8593 8594 ffestd_R624 (pointers); 8595 8596 if (ffestc_shriek_after1_ != NULL) 8597 (*ffestc_shriek_after1_) (TRUE); 8598 ffestc_labeldef_branch_end_ (); 8599} 8600 8601/* ffestc_R625 -- DEALLOCATE statement 8602 8603 ffestc_R625(exprlist,stat,stat_token); 8604 8605 Make sure the equivalence is valid, then implement it. */ 8606 8607void 8608ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token) 8609{ 8610 ffestc_check_simple_ (); 8611 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 8612 return; 8613 ffestc_labeldef_branch_begin_ (); 8614 8615 ffestd_R625 (exprlist, stat); 8616 8617 if (ffestc_shriek_after1_ != NULL) 8618 (*ffestc_shriek_after1_) (TRUE); 8619 ffestc_labeldef_branch_end_ (); 8620} 8621 8622#endif 8623/* ffestc_let -- R1213 or R737 8624 8625 ffestc_let(...); 8626 8627 Verify that R1213 defined-assignment or R737 assignment-stmt are 8628 valid here, figure out which one, and implement. */ 8629 8630#if FFESTR_F90 8631void 8632ffestc_let (ffebld dest, ffebld source, ffelexToken source_token) 8633{ 8634 ffestc_R737 (dest, source, source_token); 8635} 8636 8637#endif 8638/* ffestc_R737 -- Assignment statement 8639 8640 ffestc_R737(dest_expr,source_expr,source_token); 8641 8642 Make sure the assignment is valid. */ 8643 8644void 8645ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token) 8646{ 8647 ffestc_check_simple_ (); 8648 8649 switch (ffestw_state (ffestw_stack_top ())) 8650 { 8651#if FFESTR_F90 8652 case FFESTV_stateWHERE: 8653 case FFESTV_stateWHERETHEN: 8654 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_) 8655 return; 8656 ffestc_labeldef_useless_ (); 8657 8658 ffestd_R737B (dest, source); 8659 8660 if (ffestc_shriek_after1_ != NULL) 8661 (*ffestc_shriek_after1_) (TRUE); 8662 return; 8663#endif 8664 8665 default: 8666 break; 8667 } 8668 8669 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_) 8670 return; 8671 ffestc_labeldef_branch_begin_ (); 8672 8673 source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0], 8674 FFEEXPR_contextLET); 8675 8676 ffestd_R737A (dest, source); 8677 8678 if (ffestc_shriek_after1_ != NULL) 8679 (*ffestc_shriek_after1_) (TRUE); 8680 ffestc_labeldef_branch_end_ (); 8681} 8682 8683/* ffestc_R738 -- Pointer assignment statement 8684 8685 ffestc_R738(dest_expr,source_expr,source_token); 8686 8687 Make sure the assignment is valid. */ 8688 8689#if FFESTR_F90 8690void 8691ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token) 8692{ 8693 ffestc_check_simple_ (); 8694 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 8695 return; 8696 ffestc_labeldef_branch_begin_ (); 8697 8698 ffestd_R738 (dest, source); 8699 8700 if (ffestc_shriek_after1_ != NULL) 8701 (*ffestc_shriek_after1_) (TRUE); 8702 ffestc_labeldef_branch_end_ (); 8703} 8704 8705/* ffestc_R740 -- WHERE statement 8706 8707 ffestc_R740(expr,expr_token); 8708 8709 Make sure statement is valid here; implement. */ 8710 8711void 8712ffestc_R740 (ffebld expr, ffelexToken expr_token) 8713{ 8714 ffestw b; 8715 8716 ffestc_check_simple_ (); 8717 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 8718 return; 8719 ffestc_labeldef_branch_begin_ (); 8720 8721 b = ffestw_update (ffestw_push (NULL)); 8722 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); 8723 ffestw_set_state (b, FFESTV_stateWHERE); 8724 ffestw_set_blocknum (b, ffestc_blocknum_++); 8725 ffestw_set_shriek (b, ffestc_shriek_where_lost_); 8726 8727 ffestd_R740 (expr); 8728 8729 /* Leave label finishing to next statement. */ 8730 8731} 8732 8733/* ffestc_R742 -- WHERE-construct statement 8734 8735 ffestc_R742(expr,expr_token); 8736 8737 Make sure statement is valid here; implement. */ 8738 8739void 8740ffestc_R742 (ffebld expr, ffelexToken expr_token) 8741{ 8742 ffestw b; 8743 8744 ffestc_check_simple_ (); 8745 if (ffestc_order_exec_ () != FFESTC_orderOK_) 8746 return; 8747 ffestc_labeldef_notloop_probably_this_wont_work_ (); 8748 8749 b = ffestw_update (ffestw_push (NULL)); 8750 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); 8751 ffestw_set_state (b, FFESTV_stateWHERETHEN); 8752 ffestw_set_blocknum (b, ffestc_blocknum_++); 8753 ffestw_set_shriek (b, ffestc_shriek_wherethen_); 8754 ffestw_set_substate (b, 0); /* Haven't seen ELSEWHERE yet. */ 8755 8756 ffestd_R742 (expr); 8757} 8758 8759/* ffestc_R744 -- ELSE WHERE statement 8760 8761 ffestc_R744(); 8762 8763 Make sure ffestc_kind_ identifies a WHERE block. 8764 Implement the ELSE of the current WHERE block. */ 8765 8766void 8767ffestc_R744 () 8768{ 8769 ffestc_check_simple_ (); 8770 if (ffestc_order_where_ () != FFESTC_orderOK_) 8771 return; 8772 ffestc_labeldef_useless_ (); 8773 8774 if (ffestw_substate (ffestw_stack_top ()) != 0) 8775 { 8776 ffebad_start (FFEBAD_SECOND_ELSE_WHERE); 8777 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 8778 ffelex_token_where_column (ffesta_tokens[0])); 8779 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 8780 ffebad_finish (); 8781 } 8782 8783 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */ 8784 8785 ffestd_R744 (); 8786} 8787 8788/* ffestc_R745 -- END WHERE statement 8789 8790 ffestc_R745(); 8791 8792 Make sure ffestc_kind_ identifies a WHERE block. 8793 Implement the end of the current WHERE block. */ 8794 8795void 8796ffestc_R745 () 8797{ 8798 ffestc_check_simple_ (); 8799 if (ffestc_order_where_ () != FFESTC_orderOK_) 8800 return; 8801 ffestc_labeldef_useless_ (); 8802 8803 ffestc_shriek_wherethen_ (TRUE); 8804} 8805 8806#endif 8807/* ffestc_R803 -- Block IF (IF-THEN) statement 8808 8809 ffestc_R803(construct_name,expr,expr_token); 8810 8811 Make sure statement is valid here; implement. */ 8812 8813void 8814ffestc_R803 (ffelexToken construct_name, ffebld expr, 8815 ffelexToken expr_token UNUSED) 8816{ 8817 ffestw b; 8818 ffesymbol s; 8819 8820 ffestc_check_simple_ (); 8821 if (ffestc_order_exec_ () != FFESTC_orderOK_) 8822 return; 8823 ffestc_labeldef_notloop_ (); 8824 8825 b = ffestw_update (ffestw_push (NULL)); 8826 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); 8827 ffestw_set_state (b, FFESTV_stateIFTHEN); 8828 ffestw_set_blocknum (b, ffestc_blocknum_++); 8829 ffestw_set_shriek (b, ffestc_shriek_ifthen_); 8830 ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */ 8831 8832 if (construct_name == NULL) 8833 ffestw_set_name (b, NULL); 8834 else 8835 { 8836 ffestw_set_name (b, ffelex_token_use (construct_name)); 8837 8838 s = ffesymbol_declare_local (construct_name, FALSE); 8839 8840 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 8841 { 8842 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 8843 ffesymbol_set_info (s, 8844 ffeinfo_new (FFEINFO_basictypeNONE, 8845 FFEINFO_kindtypeNONE, 8846 0, 8847 FFEINFO_kindCONSTRUCT, 8848 FFEINFO_whereLOCAL, 8849 FFETARGET_charactersizeNONE)); 8850 s = ffecom_sym_learned (s); 8851 ffesymbol_signal_unreported (s); 8852 } 8853 else 8854 ffesymbol_error (s, construct_name); 8855 } 8856 8857 ffestd_R803 (construct_name, expr); 8858} 8859 8860/* ffestc_R804 -- ELSE IF statement 8861 8862 ffestc_R804(expr,expr_token,name_token); 8863 8864 Make sure ffestc_kind_ identifies an IF block. If not 8865 NULL, make sure name_token gives the correct name. Implement the else 8866 of the IF block. */ 8867 8868void 8869ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED, 8870 ffelexToken name) 8871{ 8872 ffestc_check_simple_ (); 8873 if (ffestc_order_ifthen_ () != FFESTC_orderOK_) 8874 return; 8875 ffestc_labeldef_useless_ (); 8876 8877 if (name != NULL) 8878 { 8879 if (ffestw_name (ffestw_stack_top ()) == NULL) 8880 { 8881 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); 8882 ffebad_here (0, ffelex_token_where_line (name), 8883 ffelex_token_where_column (name)); 8884 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 8885 ffebad_finish (); 8886 } 8887 else if (ffelex_token_strcmp (name, 8888 ffestw_name (ffestw_stack_top ())) 8889 != 0) 8890 { 8891 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); 8892 ffebad_here (0, ffelex_token_where_line (name), 8893 ffelex_token_where_column (name)); 8894 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 8895 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 8896 ffebad_finish (); 8897 } 8898 } 8899 8900 if (ffestw_substate (ffestw_stack_top ()) != 0) 8901 { 8902 ffebad_start (FFEBAD_AFTER_ELSE); 8903 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 8904 ffelex_token_where_column (ffesta_tokens[0])); 8905 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 8906 ffebad_finish (); 8907 return; /* Don't upset back end with ELSEIF 8908 after ELSE. */ 8909 } 8910 8911 ffestd_R804 (expr, name); 8912} 8913 8914/* ffestc_R805 -- ELSE statement 8915 8916 ffestc_R805(name_token); 8917 8918 Make sure ffestc_kind_ identifies an IF block. If not 8919 NULL, make sure name_token gives the correct name. Implement the ELSE 8920 of the IF block. */ 8921 8922void 8923ffestc_R805 (ffelexToken name) 8924{ 8925 ffestc_check_simple_ (); 8926 if (ffestc_order_ifthen_ () != FFESTC_orderOK_) 8927 return; 8928 ffestc_labeldef_useless_ (); 8929 8930 if (name != NULL) 8931 { 8932 if (ffestw_name (ffestw_stack_top ()) == NULL) 8933 { 8934 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); 8935 ffebad_here (0, ffelex_token_where_line (name), 8936 ffelex_token_where_column (name)); 8937 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 8938 ffebad_finish (); 8939 } 8940 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) 8941 { 8942 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); 8943 ffebad_here (0, ffelex_token_where_line (name), 8944 ffelex_token_where_column (name)); 8945 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 8946 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 8947 ffebad_finish (); 8948 } 8949 } 8950 8951 if (ffestw_substate (ffestw_stack_top ()) != 0) 8952 { 8953 ffebad_start (FFEBAD_AFTER_ELSE); 8954 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 8955 ffelex_token_where_column (ffesta_tokens[0])); 8956 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 8957 ffebad_finish (); 8958 return; /* Tell back end about only one ELSE. */ 8959 } 8960 8961 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */ 8962 8963 ffestd_R805 (name); 8964} 8965 8966/* ffestc_R806 -- END IF statement 8967 8968 ffestc_R806(name_token); 8969 8970 Make sure ffestc_kind_ identifies an IF block. If not 8971 NULL, make sure name_token gives the correct name. Implement the end 8972 of the IF block. */ 8973 8974void 8975ffestc_R806 (ffelexToken name) 8976{ 8977 ffestc_check_simple_ (); 8978 if (ffestc_order_ifthen_ () != FFESTC_orderOK_) 8979 return; 8980 ffestc_labeldef_endif_ (); 8981 8982 if (name == NULL) 8983 { 8984 if (ffestw_name (ffestw_stack_top ()) != NULL) 8985 { 8986 ffebad_start (FFEBAD_CONSTRUCT_NAMED); 8987 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 8988 ffelex_token_where_column (ffesta_tokens[0])); 8989 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 8990 ffebad_finish (); 8991 } 8992 } 8993 else 8994 { 8995 if (ffestw_name (ffestw_stack_top ()) == NULL) 8996 { 8997 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); 8998 ffebad_here (0, ffelex_token_where_line (name), 8999 ffelex_token_where_column (name)); 9000 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9001 ffebad_finish (); 9002 } 9003 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) 9004 { 9005 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); 9006 ffebad_here (0, ffelex_token_where_line (name), 9007 ffelex_token_where_column (name)); 9008 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 9009 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 9010 ffebad_finish (); 9011 } 9012 } 9013 9014 ffestc_shriek_ifthen_ (TRUE); 9015} 9016 9017/* ffestc_R807 -- Logical IF statement 9018 9019 ffestc_R807(expr,expr_token); 9020 9021 Make sure statement is valid here; implement. */ 9022 9023void 9024ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED) 9025{ 9026 ffestw b; 9027 9028 ffestc_check_simple_ (); 9029 if (ffestc_order_action_ () != FFESTC_orderOK_) 9030 return; 9031 ffestc_labeldef_branch_begin_ (); 9032 9033 b = ffestw_update (ffestw_push (NULL)); 9034 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); 9035 ffestw_set_state (b, FFESTV_stateIF); 9036 ffestw_set_blocknum (b, ffestc_blocknum_++); 9037 ffestw_set_shriek (b, ffestc_shriek_if_lost_); 9038 9039 ffestd_R807 (expr); 9040 9041 /* Do the label finishing in the next statement. */ 9042 9043} 9044 9045/* ffestc_R809 -- SELECT CASE statement 9046 9047 ffestc_R809(construct_name,expr,expr_token); 9048 9049 Make sure statement is valid here; implement. */ 9050 9051void 9052ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token) 9053{ 9054 ffestw b; 9055 mallocPool pool; 9056 ffestwSelect s; 9057 ffesymbol sym; 9058 9059 ffestc_check_simple_ (); 9060 if (ffestc_order_exec_ () != FFESTC_orderOK_) 9061 return; 9062 ffestc_labeldef_notloop_ (); 9063 9064 b = ffestw_update (ffestw_push (NULL)); 9065 ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); 9066 ffestw_set_state (b, FFESTV_stateSELECT0); 9067 ffestw_set_blocknum (b, ffestc_blocknum_++); 9068 ffestw_set_shriek (b, ffestc_shriek_select_); 9069 ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */ 9070 9071 /* Init block to manage CASE list. */ 9072 9073 pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024); 9074 s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s)); 9075 s->first_rel = (ffestwCase) &s->first_rel; 9076 s->last_rel = (ffestwCase) &s->first_rel; 9077 s->first_stmt = (ffestwCase) &s->first_rel; 9078 s->last_stmt = (ffestwCase) &s->first_rel; 9079 s->pool = pool; 9080 s->cases = 1; 9081 s->t = ffelex_token_use (expr_token); 9082 s->type = ffeinfo_basictype (ffebld_info (expr)); 9083 s->kindtype = ffeinfo_kindtype (ffebld_info (expr)); 9084 ffestw_set_select (b, s); 9085 9086 if (construct_name == NULL) 9087 ffestw_set_name (b, NULL); 9088 else 9089 { 9090 ffestw_set_name (b, ffelex_token_use (construct_name)); 9091 9092 sym = ffesymbol_declare_local (construct_name, FALSE); 9093 9094 if (ffesymbol_state (sym) == FFESYMBOL_stateNONE) 9095 { 9096 ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD); 9097 ffesymbol_set_info (sym, 9098 ffeinfo_new (FFEINFO_basictypeNONE, 9099 FFEINFO_kindtypeNONE, 0, 9100 FFEINFO_kindCONSTRUCT, 9101 FFEINFO_whereLOCAL, 9102 FFETARGET_charactersizeNONE)); 9103 sym = ffecom_sym_learned (sym); 9104 ffesymbol_signal_unreported (sym); 9105 } 9106 else 9107 ffesymbol_error (sym, construct_name); 9108 } 9109 9110 ffestd_R809 (construct_name, expr); 9111} 9112 9113/* ffestc_R810 -- CASE statement 9114 9115 ffestc_R810(case_value_range_list,name); 9116 9117 If case_value_range_list is NULL, it's CASE DEFAULT. name is the case- 9118 construct-name. Make sure no more than one CASE DEFAULT is present for 9119 a given case-construct and that there aren't any overlapping ranges or 9120 duplicate case values. */ 9121 9122void 9123ffestc_R810 (ffesttCaseList cases, ffelexToken name) 9124{ 9125 ffesttCaseList caseobj; 9126 ffestwSelect s; 9127 ffestwCase c, nc; 9128 ffebldConstant expr1c, expr2c; 9129 9130 ffestc_check_simple_ (); 9131 if (ffestc_order_selectcase_ () != FFESTC_orderOK_) 9132 return; 9133 ffestc_labeldef_useless_ (); 9134 9135 s = ffestw_select (ffestw_stack_top ()); 9136 9137 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0) 9138 { 9139#if 0 /* Not sure we want to have msgs point here 9140 instead of SELECT CASE. */ 9141 ffestw_update (NULL); /* Update state line/col info. */ 9142#endif 9143 ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1); 9144 } 9145 9146 if (name != NULL) 9147 { 9148 if (ffestw_name (ffestw_stack_top ()) == NULL) 9149 { 9150 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); 9151 ffebad_here (0, ffelex_token_where_line (name), 9152 ffelex_token_where_column (name)); 9153 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9154 ffebad_finish (); 9155 } 9156 else if (ffelex_token_strcmp (name, 9157 ffestw_name (ffestw_stack_top ())) 9158 != 0) 9159 { 9160 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); 9161 ffebad_here (0, ffelex_token_where_line (name), 9162 ffelex_token_where_column (name)); 9163 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 9164 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 9165 ffebad_finish (); 9166 } 9167 } 9168 9169 if (cases == NULL) 9170 { 9171 if (ffestw_substate (ffestw_stack_top ()) != 0) 9172 { 9173 ffebad_start (FFEBAD_CASE_SECOND_DEFAULT); 9174 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 9175 ffelex_token_where_column (ffesta_tokens[0])); 9176 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9177 ffebad_finish (); 9178 } 9179 9180 ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */ 9181 } 9182 else 9183 { /* For each case, try to fit into sorted list 9184 of ranges. */ 9185 for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next) 9186 { 9187 if ((caseobj->expr1 == NULL) 9188 && (!caseobj->range 9189 || (caseobj->expr2 == NULL))) 9190 { /* "CASE (:)". */ 9191 ffebad_start (FFEBAD_CASE_BAD_RANGE); 9192 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9193 ffelex_token_where_column (caseobj->t)); 9194 ffebad_finish (); 9195 continue; 9196 } 9197 9198 if (((caseobj->expr1 != NULL) 9199 && ((ffeinfo_basictype (ffebld_info (caseobj->expr1)) 9200 != s->type) 9201 || (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) 9202 != s->kindtype))) 9203 || ((caseobj->range) 9204 && (caseobj->expr2 != NULL) 9205 && ((ffeinfo_basictype (ffebld_info (caseobj->expr2)) 9206 != s->type) 9207 || (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) 9208 != s->kindtype)))) 9209 { 9210 ffebad_start (FFEBAD_CASE_TYPE_DISAGREE); 9211 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9212 ffelex_token_where_column (caseobj->t)); 9213 ffebad_here (1, ffelex_token_where_line (s->t), 9214 ffelex_token_where_column (s->t)); 9215 ffebad_finish (); 9216 continue; 9217 } 9218 9219 if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range)) 9220 { 9221 ffebad_start (FFEBAD_CASE_LOGICAL_RANGE); 9222 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9223 ffelex_token_where_column (caseobj->t)); 9224 ffebad_finish (); 9225 continue; 9226 } 9227 9228 if (caseobj->expr1 == NULL) 9229 expr1c = NULL; 9230 else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER) 9231 continue; /* opANY. */ 9232 else 9233 expr1c = ffebld_conter (caseobj->expr1); 9234 9235 if (!caseobj->range) 9236 expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this 9237 case. */ 9238 else if (caseobj->expr2 == NULL) 9239 expr2c = NULL; 9240 else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER) 9241 continue; /* opANY. */ 9242 else 9243 expr2c = ffebld_conter (caseobj->expr2); 9244 9245 if (expr1c == NULL) 9246 { /* "CASE (:high)", must be first in list. */ 9247 c = s->first_rel; 9248 if ((c != (ffestwCase) &s->first_rel) 9249 && ((c->low == NULL) 9250 || (ffebld_constant_cmp (expr2c, c->low) >= 0))) 9251 { /* Other "CASE (:high)" or lowest "CASE 9252 (low[:high])" low. */ 9253 ffebad_start (FFEBAD_CASE_DUPLICATE); 9254 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9255 ffelex_token_where_column (caseobj->t)); 9256 ffebad_here (1, ffelex_token_where_line (c->t), 9257 ffelex_token_where_column (c->t)); 9258 ffebad_finish (); 9259 continue; 9260 } 9261 } 9262 else if (expr2c == NULL) 9263 { /* "CASE (low:)", must be last in list. */ 9264 c = s->last_rel; 9265 if ((c != (ffestwCase) &s->first_rel) 9266 && ((c->high == NULL) 9267 || (ffebld_constant_cmp (expr1c, c->high) <= 0))) 9268 { /* Other "CASE (low:)" or lowest "CASE 9269 ([low:]high)" high. */ 9270 ffebad_start (FFEBAD_CASE_DUPLICATE); 9271 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9272 ffelex_token_where_column (caseobj->t)); 9273 ffebad_here (1, ffelex_token_where_line (c->t), 9274 ffelex_token_where_column (c->t)); 9275 ffebad_finish (); 9276 continue; 9277 } 9278 c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */ 9279 } 9280 else 9281 { /* (expr1c != NULL) && (expr2c != NULL). */ 9282 if (ffebld_constant_cmp (expr1c, expr2c) > 0) 9283 { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */ 9284 ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */ 9285 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9286 ffelex_token_where_column (caseobj->t)); 9287 ffebad_finish (); 9288 continue; 9289 } 9290 for (c = s->first_rel; 9291 (c != (ffestwCase) &s->first_rel) 9292 && ((c->low == NULL) 9293 || (ffebld_constant_cmp (expr1c, c->low) > 0)); 9294 c = c->next_rel) 9295 ; 9296 nc = c; /* Which one to report? */ 9297 if (((c != (ffestwCase) &s->first_rel) 9298 && (ffebld_constant_cmp (expr2c, c->low) >= 0)) 9299 || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel) 9300 && (ffebld_constant_cmp (expr1c, nc->high) <= 0))) 9301 { /* Interference with range in case nc. */ 9302 ffebad_start (FFEBAD_CASE_DUPLICATE); 9303 ffebad_here (0, ffelex_token_where_line (caseobj->t), 9304 ffelex_token_where_column (caseobj->t)); 9305 ffebad_here (1, ffelex_token_where_line (nc->t), 9306 ffelex_token_where_column (nc->t)); 9307 ffebad_finish (); 9308 continue; 9309 } 9310 } 9311 9312 /* If we reach here for this case range/value, it's ok (sorts into 9313 the list of ranges/values) so we give it its own case object 9314 sorted into the list of case statements. */ 9315 9316 nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc)); 9317 nc->next_rel = c; 9318 nc->previous_rel = c->previous_rel; 9319 nc->next_stmt = (ffestwCase) &s->first_rel; 9320 nc->previous_stmt = s->last_stmt; 9321 nc->low = expr1c; 9322 nc->high = expr2c; 9323 nc->casenum = s->cases; 9324 nc->t = ffelex_token_use (caseobj->t); 9325 nc->next_rel->previous_rel = nc; 9326 nc->previous_rel->next_rel = nc; 9327 nc->next_stmt->previous_stmt = nc; 9328 nc->previous_stmt->next_stmt = nc; 9329 } 9330 } 9331 9332 ffestd_R810 ((cases == NULL) ? 0 : s->cases); 9333 9334 s->cases++; /* Increment # of cases. */ 9335} 9336 9337/* ffestc_R811 -- END SELECT statement 9338 9339 ffestc_R811(name_token); 9340 9341 Make sure ffestc_kind_ identifies a SELECT block. If not 9342 NULL, make sure name_token gives the correct name. Implement the end 9343 of the SELECT block. */ 9344 9345void 9346ffestc_R811 (ffelexToken name) 9347{ 9348 ffestc_check_simple_ (); 9349 if (ffestc_order_selectcase_ () != FFESTC_orderOK_) 9350 return; 9351 ffestc_labeldef_notloop_ (); 9352 9353 if (name == NULL) 9354 { 9355 if (ffestw_name (ffestw_stack_top ()) != NULL) 9356 { 9357 ffebad_start (FFEBAD_CONSTRUCT_NAMED); 9358 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 9359 ffelex_token_where_column (ffesta_tokens[0])); 9360 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9361 ffebad_finish (); 9362 } 9363 } 9364 else 9365 { 9366 if (ffestw_name (ffestw_stack_top ()) == NULL) 9367 { 9368 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); 9369 ffebad_here (0, ffelex_token_where_line (name), 9370 ffelex_token_where_column (name)); 9371 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9372 ffebad_finish (); 9373 } 9374 else if (ffelex_token_strcmp (name, 9375 ffestw_name (ffestw_stack_top ())) 9376 != 0) 9377 { 9378 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); 9379 ffebad_here (0, ffelex_token_where_line (name), 9380 ffelex_token_where_column (name)); 9381 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 9382 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 9383 ffebad_finish (); 9384 } 9385 } 9386 9387 ffestc_shriek_select_ (TRUE); 9388} 9389 9390/* ffestc_R819A -- Iterative labeled DO statement 9391 9392 ffestc_R819A(construct_name,label_token,expr,expr_token); 9393 9394 Make sure statement is valid here; implement. */ 9395 9396void 9397ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var, 9398 ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end, 9399 ffelexToken end_token, ffebld incr, ffelexToken incr_token) 9400{ 9401 ffestw b; 9402 ffelab label; 9403 ffesymbol s; 9404 ffesymbol varsym; 9405 9406 ffestc_check_simple_ (); 9407 if (ffestc_order_exec_ () != FFESTC_orderOK_) 9408 return; 9409 ffestc_labeldef_notloop_ (); 9410 9411 if (!ffestc_labelref_is_loopend_ (label_token, &label)) 9412 return; 9413 9414 b = ffestw_update (ffestw_push (NULL)); 9415 ffestw_set_top_do (b, b); 9416 ffestw_set_state (b, FFESTV_stateDO); 9417 ffestw_set_blocknum (b, ffestc_blocknum_++); 9418 ffestw_set_shriek (b, ffestc_shriek_do_); 9419 ffestw_set_label (b, label); 9420 switch (ffebld_op (var)) 9421 { 9422 case FFEBLD_opSYMTER: 9423 if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL) 9424 && ffe_is_warn_surprising ()) 9425 { 9426 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ 9427 ffebad_here (0, ffelex_token_where_line (var_token), 9428 ffelex_token_where_column (var_token)); 9429 ffebad_string (ffesymbol_text (ffebld_symter (var))); 9430 ffebad_finish (); 9431 } 9432 if (!ffesymbol_is_doiter (varsym = ffebld_symter (var))) 9433 { /* Presumably already complained about by 9434 ffeexpr_lhs_. */ 9435 ffesymbol_set_is_doiter (varsym, TRUE); 9436 ffestw_set_do_iter_var (b, varsym); 9437 ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token)); 9438 break; 9439 } 9440 /* Fall through. */ 9441 case FFEBLD_opANY: 9442 ffestw_set_do_iter_var (b, NULL); 9443 ffestw_set_do_iter_var_t (b, NULL); 9444 break; 9445 9446 default: 9447 assert ("bad iter var" == NULL); 9448 break; 9449 } 9450 9451 if (construct_name == NULL) 9452 ffestw_set_name (b, NULL); 9453 else 9454 { 9455 ffestw_set_name (b, ffelex_token_use (construct_name)); 9456 9457 s = ffesymbol_declare_local (construct_name, FALSE); 9458 9459 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 9460 { 9461 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 9462 ffesymbol_set_info (s, 9463 ffeinfo_new (FFEINFO_basictypeNONE, 9464 FFEINFO_kindtypeNONE, 9465 0, 9466 FFEINFO_kindCONSTRUCT, 9467 FFEINFO_whereLOCAL, 9468 FFETARGET_charactersizeNONE)); 9469 s = ffecom_sym_learned (s); 9470 ffesymbol_signal_unreported (s); 9471 } 9472 else 9473 ffesymbol_error (s, construct_name); 9474 } 9475 9476 if (incr == NULL) 9477 { 9478 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); 9479 ffebld_set_info (incr, ffeinfo_new 9480 (FFEINFO_basictypeINTEGER, 9481 FFEINFO_kindtypeINTEGERDEFAULT, 9482 0, 9483 FFEINFO_kindENTITY, 9484 FFEINFO_whereCONSTANT, 9485 FFETARGET_charactersizeNONE)); 9486 } 9487 9488 start = ffeexpr_convert_expr (start, start_token, var, var_token, 9489 FFEEXPR_contextLET); 9490 end = ffeexpr_convert_expr (end, end_token, var, var_token, 9491 FFEEXPR_contextLET); 9492 incr = ffeexpr_convert_expr (incr, incr_token, var, var_token, 9493 FFEEXPR_contextLET); 9494 9495 ffestd_R819A (construct_name, label, var, 9496 start, start_token, 9497 end, end_token, 9498 incr, incr_token); 9499} 9500 9501/* ffestc_R819B -- Labeled DO WHILE statement 9502 9503 ffestc_R819B(construct_name,label_token,expr,expr_token); 9504 9505 Make sure statement is valid here; implement. */ 9506 9507void 9508ffestc_R819B (ffelexToken construct_name, ffelexToken label_token, 9509 ffebld expr, ffelexToken expr_token UNUSED) 9510{ 9511 ffestw b; 9512 ffelab label; 9513 ffesymbol s; 9514 9515 ffestc_check_simple_ (); 9516 if (ffestc_order_exec_ () != FFESTC_orderOK_) 9517 return; 9518 ffestc_labeldef_notloop_ (); 9519 9520 if (!ffestc_labelref_is_loopend_ (label_token, &label)) 9521 return; 9522 9523 b = ffestw_update (ffestw_push (NULL)); 9524 ffestw_set_top_do (b, b); 9525 ffestw_set_state (b, FFESTV_stateDO); 9526 ffestw_set_blocknum (b, ffestc_blocknum_++); 9527 ffestw_set_shriek (b, ffestc_shriek_do_); 9528 ffestw_set_label (b, label); 9529 ffestw_set_do_iter_var (b, NULL); 9530 ffestw_set_do_iter_var_t (b, NULL); 9531 9532 if (construct_name == NULL) 9533 ffestw_set_name (b, NULL); 9534 else 9535 { 9536 ffestw_set_name (b, ffelex_token_use (construct_name)); 9537 9538 s = ffesymbol_declare_local (construct_name, FALSE); 9539 9540 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 9541 { 9542 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 9543 ffesymbol_set_info (s, 9544 ffeinfo_new (FFEINFO_basictypeNONE, 9545 FFEINFO_kindtypeNONE, 9546 0, 9547 FFEINFO_kindCONSTRUCT, 9548 FFEINFO_whereLOCAL, 9549 FFETARGET_charactersizeNONE)); 9550 s = ffecom_sym_learned (s); 9551 ffesymbol_signal_unreported (s); 9552 } 9553 else 9554 ffesymbol_error (s, construct_name); 9555 } 9556 9557 ffestd_R819B (construct_name, label, expr); 9558} 9559 9560/* ffestc_R820A -- Iterative nonlabeled DO statement 9561 9562 ffestc_R820A(construct_name,expr,expr_token); 9563 9564 Make sure statement is valid here; implement. */ 9565 9566void 9567ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token, 9568 ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token, 9569 ffebld incr, ffelexToken incr_token) 9570{ 9571 ffestw b; 9572 ffesymbol s; 9573 ffesymbol varsym; 9574 9575 ffestc_check_simple_ (); 9576 if (ffestc_order_exec_ () != FFESTC_orderOK_) 9577 return; 9578 ffestc_labeldef_notloop_ (); 9579 9580 b = ffestw_update (ffestw_push (NULL)); 9581 ffestw_set_top_do (b, b); 9582 ffestw_set_state (b, FFESTV_stateDO); 9583 ffestw_set_blocknum (b, ffestc_blocknum_++); 9584 ffestw_set_shriek (b, ffestc_shriek_do_); 9585 ffestw_set_label (b, NULL); 9586 switch (ffebld_op (var)) 9587 { 9588 case FFEBLD_opSYMTER: 9589 if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL) 9590 && ffe_is_warn_surprising ()) 9591 { 9592 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ 9593 ffebad_here (0, ffelex_token_where_line (var_token), 9594 ffelex_token_where_column (var_token)); 9595 ffebad_string (ffesymbol_text (ffebld_symter (var))); 9596 ffebad_finish (); 9597 } 9598 if (!ffesymbol_is_doiter (varsym = ffebld_symter (var))) 9599 { /* Presumably already complained about by 9600 ffeexpr_lhs_. */ 9601 ffesymbol_set_is_doiter (varsym, TRUE); 9602 ffestw_set_do_iter_var (b, varsym); 9603 ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token)); 9604 break; 9605 } 9606 /* Fall through. */ 9607 case FFEBLD_opANY: 9608 ffestw_set_do_iter_var (b, NULL); 9609 ffestw_set_do_iter_var_t (b, NULL); 9610 break; 9611 9612 default: 9613 assert ("bad iter var" == NULL); 9614 break; 9615 } 9616 9617 if (construct_name == NULL) 9618 ffestw_set_name (b, NULL); 9619 else 9620 { 9621 ffestw_set_name (b, ffelex_token_use (construct_name)); 9622 9623 s = ffesymbol_declare_local (construct_name, FALSE); 9624 9625 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 9626 { 9627 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 9628 ffesymbol_set_info (s, 9629 ffeinfo_new (FFEINFO_basictypeNONE, 9630 FFEINFO_kindtypeNONE, 9631 0, 9632 FFEINFO_kindCONSTRUCT, 9633 FFEINFO_whereLOCAL, 9634 FFETARGET_charactersizeNONE)); 9635 s = ffecom_sym_learned (s); 9636 ffesymbol_signal_unreported (s); 9637 } 9638 else 9639 ffesymbol_error (s, construct_name); 9640 } 9641 9642 if (incr == NULL) 9643 { 9644 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); 9645 ffebld_set_info (incr, ffeinfo_new 9646 (FFEINFO_basictypeINTEGER, 9647 FFEINFO_kindtypeINTEGERDEFAULT, 9648 0, 9649 FFEINFO_kindENTITY, 9650 FFEINFO_whereCONSTANT, 9651 FFETARGET_charactersizeNONE)); 9652 } 9653 9654 start = ffeexpr_convert_expr (start, start_token, var, var_token, 9655 FFEEXPR_contextLET); 9656 end = ffeexpr_convert_expr (end, end_token, var, var_token, 9657 FFEEXPR_contextLET); 9658 incr = ffeexpr_convert_expr (incr, incr_token, var, var_token, 9659 FFEEXPR_contextLET); 9660 9661#if 0 9662 if ((ffebld_op (incr) == FFEBLD_opCONTER) 9663 && (ffebld_constant_is_zero (ffebld_conter (incr)))) 9664 { 9665 ffebad_start (FFEBAD_DO_STEP_ZERO); 9666 ffebad_here (0, ffelex_token_where_line (incr_token), 9667 ffelex_token_where_column (incr_token)); 9668 ffebad_string ("Iterative DO loop"); 9669 ffebad_finish (); 9670 } 9671#endif 9672 9673 ffestd_R819A (construct_name, NULL, var, 9674 start, start_token, 9675 end, end_token, 9676 incr, incr_token); 9677} 9678 9679/* ffestc_R820B -- Nonlabeled DO WHILE statement 9680 9681 ffestc_R820B(construct_name,expr,expr_token); 9682 9683 Make sure statement is valid here; implement. */ 9684 9685void 9686ffestc_R820B (ffelexToken construct_name, ffebld expr, 9687 ffelexToken expr_token UNUSED) 9688{ 9689 ffestw b; 9690 ffesymbol s; 9691 9692 ffestc_check_simple_ (); 9693 if (ffestc_order_exec_ () != FFESTC_orderOK_) 9694 return; 9695 ffestc_labeldef_notloop_ (); 9696 9697 b = ffestw_update (ffestw_push (NULL)); 9698 ffestw_set_top_do (b, b); 9699 ffestw_set_state (b, FFESTV_stateDO); 9700 ffestw_set_blocknum (b, ffestc_blocknum_++); 9701 ffestw_set_shriek (b, ffestc_shriek_do_); 9702 ffestw_set_label (b, NULL); 9703 ffestw_set_do_iter_var (b, NULL); 9704 ffestw_set_do_iter_var_t (b, NULL); 9705 9706 if (construct_name == NULL) 9707 ffestw_set_name (b, NULL); 9708 else 9709 { 9710 ffestw_set_name (b, ffelex_token_use (construct_name)); 9711 9712 s = ffesymbol_declare_local (construct_name, FALSE); 9713 9714 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 9715 { 9716 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 9717 ffesymbol_set_info (s, 9718 ffeinfo_new (FFEINFO_basictypeNONE, 9719 FFEINFO_kindtypeNONE, 9720 0, 9721 FFEINFO_kindCONSTRUCT, 9722 FFEINFO_whereLOCAL, 9723 FFETARGET_charactersizeNONE)); 9724 s = ffecom_sym_learned (s); 9725 ffesymbol_signal_unreported (s); 9726 } 9727 else 9728 ffesymbol_error (s, construct_name); 9729 } 9730 9731 ffestd_R819B (construct_name, NULL, expr); 9732} 9733 9734/* ffestc_R825 -- END DO statement 9735 9736 ffestc_R825(name_token); 9737 9738 Make sure ffestc_kind_ identifies a DO block. If not 9739 NULL, make sure name_token gives the correct name. Implement the end 9740 of the DO block. */ 9741 9742void 9743ffestc_R825 (ffelexToken name) 9744{ 9745 ffestc_check_simple_ (); 9746 if (ffestc_order_do_ () != FFESTC_orderOK_) 9747 return; 9748 ffestc_labeldef_branch_begin_ (); 9749 9750 if (name == NULL) 9751 { 9752 if (ffestw_name (ffestw_stack_top ()) != NULL) 9753 { 9754 ffebad_start (FFEBAD_CONSTRUCT_NAMED); 9755 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 9756 ffelex_token_where_column (ffesta_tokens[0])); 9757 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9758 ffebad_finish (); 9759 } 9760 } 9761 else 9762 { 9763 if (ffestw_name (ffestw_stack_top ()) == NULL) 9764 { 9765 ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); 9766 ffebad_here (0, ffelex_token_where_line (name), 9767 ffelex_token_where_column (name)); 9768 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9769 ffebad_finish (); 9770 } 9771 else if (ffelex_token_strcmp (name, 9772 ffestw_name (ffestw_stack_top ())) 9773 != 0) 9774 { 9775 ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); 9776 ffebad_here (0, ffelex_token_where_line (name), 9777 ffelex_token_where_column (name)); 9778 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 9779 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 9780 ffebad_finish (); 9781 } 9782 } 9783 9784 if (ffesta_label_token == NULL) 9785 { /* If top of stack has label, its an error! */ 9786 if (ffestw_label (ffestw_stack_top ()) != NULL) 9787 { 9788 ffebad_start (FFEBAD_DO_HAD_LABEL); 9789 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 9790 ffelex_token_where_column (ffesta_tokens[0])); 9791 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 9792 ffebad_finish (); 9793 } 9794 9795 ffestc_shriek_do_ (TRUE); 9796 9797 ffestc_try_shriek_do_ (); 9798 9799 return; 9800 } 9801 9802 ffestd_R825 (name); 9803 9804 ffestc_labeldef_branch_end_ (); 9805} 9806 9807/* ffestc_R834 -- CYCLE statement 9808 9809 ffestc_R834(name_token); 9810 9811 Handle a CYCLE within a loop. */ 9812 9813void 9814ffestc_R834 (ffelexToken name) 9815{ 9816 ffestw block; 9817 9818 ffestc_check_simple_ (); 9819 if (ffestc_order_actiondo_ () != FFESTC_orderOK_) 9820 return; 9821 ffestc_labeldef_notloop_begin_ (); 9822 9823 if (name == NULL) 9824 block = ffestw_top_do (ffestw_stack_top ()); 9825 else 9826 { /* Search for name. */ 9827 for (block = ffestw_top_do (ffestw_stack_top ()); 9828 (block != NULL) && (ffestw_blocknum (block) != 0); 9829 block = ffestw_top_do (ffestw_previous (block))) 9830 { 9831 if ((ffestw_name (block) != NULL) 9832 && (ffelex_token_strcmp (name, ffestw_name (block)) == 0)) 9833 break; 9834 } 9835 if ((block == NULL) || (ffestw_blocknum (block) == 0)) 9836 { 9837 block = ffestw_top_do (ffestw_stack_top ()); 9838 ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME); 9839 ffebad_here (0, ffelex_token_where_line (name), 9840 ffelex_token_where_column (name)); 9841 ffebad_finish (); 9842 } 9843 } 9844 9845 ffestd_R834 (block); 9846 9847 if (ffestc_shriek_after1_ != NULL) 9848 (*ffestc_shriek_after1_) (TRUE); 9849 9850 /* notloop's that are actionif's can be the target of a loop-end 9851 statement if they're in the "then" part of a logical IF, as 9852 in "DO 10", "10 IF (...) CYCLE". */ 9853 9854 ffestc_labeldef_branch_end_ (); 9855} 9856 9857/* ffestc_R835 -- EXIT statement 9858 9859 ffestc_R835(name_token); 9860 9861 Handle a EXIT within a loop. */ 9862 9863void 9864ffestc_R835 (ffelexToken name) 9865{ 9866 ffestw block; 9867 9868 ffestc_check_simple_ (); 9869 if (ffestc_order_actiondo_ () != FFESTC_orderOK_) 9870 return; 9871 ffestc_labeldef_notloop_begin_ (); 9872 9873 if (name == NULL) 9874 block = ffestw_top_do (ffestw_stack_top ()); 9875 else 9876 { /* Search for name. */ 9877 for (block = ffestw_top_do (ffestw_stack_top ()); 9878 (block != NULL) && (ffestw_blocknum (block) != 0); 9879 block = ffestw_top_do (ffestw_previous (block))) 9880 { 9881 if ((ffestw_name (block) != NULL) 9882 && (ffelex_token_strcmp (name, ffestw_name (block)) == 0)) 9883 break; 9884 } 9885 if ((block == NULL) || (ffestw_blocknum (block) == 0)) 9886 { 9887 block = ffestw_top_do (ffestw_stack_top ()); 9888 ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME); 9889 ffebad_here (0, ffelex_token_where_line (name), 9890 ffelex_token_where_column (name)); 9891 ffebad_finish (); 9892 } 9893 } 9894 9895 ffestd_R835 (block); 9896 9897 if (ffestc_shriek_after1_ != NULL) 9898 (*ffestc_shriek_after1_) (TRUE); 9899 9900 /* notloop's that are actionif's can be the target of a loop-end 9901 statement if they're in the "then" part of a logical IF, as 9902 in "DO 10", "10 IF (...) EXIT". */ 9903 9904 ffestc_labeldef_branch_end_ (); 9905} 9906 9907/* ffestc_R836 -- GOTO statement 9908 9909 ffestc_R836(label_token); 9910 9911 Make sure label_token identifies a valid label for a GOTO. Update 9912 that label's info to indicate it is the target of a GOTO. */ 9913 9914void 9915ffestc_R836 (ffelexToken label_token) 9916{ 9917 ffelab label; 9918 9919 ffestc_check_simple_ (); 9920 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 9921 return; 9922 ffestc_labeldef_notloop_begin_ (); 9923 9924 if (ffestc_labelref_is_branch_ (label_token, &label)) 9925 ffestd_R836 (label); 9926 9927 if (ffestc_shriek_after1_ != NULL) 9928 (*ffestc_shriek_after1_) (TRUE); 9929 9930 /* notloop's that are actionif's can be the target of a loop-end 9931 statement if they're in the "then" part of a logical IF, as 9932 in "DO 10", "10 IF (...) GOTO 100". */ 9933 9934 ffestc_labeldef_branch_end_ (); 9935} 9936 9937/* ffestc_R837 -- Computed GOTO statement 9938 9939 ffestc_R837(label_list,expr,expr_token); 9940 9941 Make sure label_list identifies valid labels for a GOTO. Update 9942 each label's info to indicate it is the target of a GOTO. */ 9943 9944void 9945ffestc_R837 (ffesttTokenList label_toks, ffebld expr, 9946 ffelexToken expr_token UNUSED) 9947{ 9948 ffesttTokenItem ti; 9949 bool ok = TRUE; 9950 int i; 9951 ffelab *labels; 9952 9953 assert (label_toks != NULL); 9954 9955 ffestc_check_simple_ (); 9956 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 9957 return; 9958 ffestc_labeldef_branch_begin_ (); 9959 9960 labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels", 9961 sizeof (*labels) 9962 * ffestt_tokenlist_count (label_toks)); 9963 9964 for (ti = label_toks->first, i = 0; 9965 ti != (ffesttTokenItem) &label_toks->first; 9966 ti = ti->next, ++i) 9967 { 9968 if (!ffestc_labelref_is_branch_ (ti->t, &labels[i])) 9969 { 9970 ok = FALSE; 9971 break; 9972 } 9973 } 9974 9975 if (ok) 9976 ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr); 9977 9978 if (ffestc_shriek_after1_ != NULL) 9979 (*ffestc_shriek_after1_) (TRUE); 9980 ffestc_labeldef_branch_end_ (); 9981} 9982 9983/* ffestc_R838 -- ASSIGN statement 9984 9985 ffestc_R838(label_token,target_variable,target_token); 9986 9987 Make sure label_token identifies a valid label for an assignment. Update 9988 that label's info to indicate it is the source of an assignment. Update 9989 target_variable's info to indicate it is the target the assignment of that 9990 label. */ 9991 9992void 9993ffestc_R838 (ffelexToken label_token, ffebld target, 9994 ffelexToken target_token UNUSED) 9995{ 9996 ffelab label; 9997 9998 ffestc_check_simple_ (); 9999 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10000 return; 10001 ffestc_labeldef_branch_begin_ (); 10002 10003 /* Mark target symbol as target of an ASSIGN. */ 10004 if (ffebld_op (target) == FFEBLD_opSYMTER) 10005 ffesymbol_set_assigned (ffebld_symter (target), TRUE); 10006 10007 if (ffestc_labelref_is_assignable_ (label_token, &label)) 10008 ffestd_R838 (label, target); 10009 10010 if (ffestc_shriek_after1_ != NULL) 10011 (*ffestc_shriek_after1_) (TRUE); 10012 ffestc_labeldef_branch_end_ (); 10013} 10014 10015/* ffestc_R839 -- Assigned GOTO statement 10016 10017 ffestc_R839(target,target_token,label_list); 10018 10019 Make sure label_list identifies valid labels for a GOTO. Update 10020 each label's info to indicate it is the target of a GOTO. */ 10021 10022void 10023ffestc_R839 (ffebld target, ffelexToken target_token UNUSED, 10024 ffesttTokenList label_toks) 10025{ 10026 ffesttTokenItem ti; 10027 bool ok = TRUE; 10028 int i; 10029 ffelab *labels; 10030 10031 ffestc_check_simple_ (); 10032 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10033 return; 10034 ffestc_labeldef_notloop_begin_ (); 10035 10036 if (label_toks == NULL) 10037 { 10038 labels = NULL; 10039 i = 0; 10040 } 10041 else 10042 { 10043 labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels", 10044 sizeof (*labels) * ffestt_tokenlist_count (label_toks)); 10045 10046 for (ti = label_toks->first, i = 0; 10047 ti != (ffesttTokenItem) &label_toks->first; 10048 ti = ti->next, ++i) 10049 { 10050 if (!ffestc_labelref_is_branch_ (ti->t, &labels[i])) 10051 { 10052 ok = FALSE; 10053 break; 10054 } 10055 } 10056 } 10057 10058 if (ok) 10059 ffestd_R839 (target, labels, i); 10060 10061 if (ffestc_shriek_after1_ != NULL) 10062 (*ffestc_shriek_after1_) (TRUE); 10063 10064 /* notloop's that are actionif's can be the target of a loop-end 10065 statement if they're in the "then" part of a logical IF, as 10066 in "DO 10", "10 IF (...) GOTO I". */ 10067 10068 ffestc_labeldef_branch_end_ (); 10069} 10070 10071/* ffestc_R840 -- Arithmetic IF statement 10072 10073 ffestc_R840(expr,expr_token,neg,zero,pos); 10074 10075 Make sure the labels are valid; implement. */ 10076 10077void 10078ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED, 10079 ffelexToken neg_token, ffelexToken zero_token, 10080 ffelexToken pos_token) 10081{ 10082 ffelab neg; 10083 ffelab zero; 10084 ffelab pos; 10085 10086 ffestc_check_simple_ (); 10087 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10088 return; 10089 ffestc_labeldef_notloop_begin_ (); 10090 10091 if (ffestc_labelref_is_branch_ (neg_token, &neg) 10092 && ffestc_labelref_is_branch_ (zero_token, &zero) 10093 && ffestc_labelref_is_branch_ (pos_token, &pos)) 10094 ffestd_R840 (expr, neg, zero, pos); 10095 10096 if (ffestc_shriek_after1_ != NULL) 10097 (*ffestc_shriek_after1_) (TRUE); 10098 10099 /* notloop's that are actionif's can be the target of a loop-end 10100 statement if they're in the "then" part of a logical IF, as 10101 in "DO 10", "10 IF (...) GOTO (100,200,300), I". */ 10102 10103 ffestc_labeldef_branch_end_ (); 10104} 10105 10106/* ffestc_R841 -- CONTINUE statement 10107 10108 ffestc_R841(); */ 10109 10110void 10111ffestc_R841 () 10112{ 10113 ffestc_check_simple_ (); 10114 10115 if (ffestc_order_actionwhere_ () != FFESTC_orderOK_) 10116 return; 10117 10118 switch (ffestw_state (ffestw_stack_top ())) 10119 { 10120#if FFESTR_F90 10121 case FFESTV_stateWHERE: 10122 case FFESTV_stateWHERETHEN: 10123 ffestc_labeldef_useless_ (); 10124 10125 ffestd_R841 (TRUE); 10126 10127 /* It's okay that we call ffestc_labeldef_branch_end_ () below, 10128 since that will be a no-op after calling _useless_ () above. */ 10129 break; 10130#endif 10131 10132 default: 10133 ffestc_labeldef_branch_begin_ (); 10134 10135 ffestd_R841 (FALSE); 10136 10137 break; 10138 } 10139 10140 if (ffestc_shriek_after1_ != NULL) 10141 (*ffestc_shriek_after1_) (TRUE); 10142 ffestc_labeldef_branch_end_ (); 10143} 10144 10145/* ffestc_R842 -- STOP statement 10146 10147 ffestc_R842(expr,expr_token); 10148 10149 Make sure statement is valid here; implement. expr and expr_token are 10150 both NULL if there was no expression. */ 10151 10152void 10153ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED) 10154{ 10155 ffestc_check_simple_ (); 10156 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10157 return; 10158 ffestc_labeldef_notloop_begin_ (); 10159 10160 ffestd_R842 (expr); 10161 10162 if (ffestc_shriek_after1_ != NULL) 10163 (*ffestc_shriek_after1_) (TRUE); 10164 10165 /* notloop's that are actionif's can be the target of a loop-end 10166 statement if they're in the "then" part of a logical IF, as 10167 in "DO 10", "10 IF (...) STOP". */ 10168 10169 ffestc_labeldef_branch_end_ (); 10170} 10171 10172/* ffestc_R843 -- PAUSE statement 10173 10174 ffestc_R843(expr,expr_token); 10175 10176 Make sure statement is valid here; implement. expr and expr_token are 10177 both NULL if there was no expression. */ 10178 10179void 10180ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED) 10181{ 10182 ffestc_check_simple_ (); 10183 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10184 return; 10185 ffestc_labeldef_branch_begin_ (); 10186 10187 ffestd_R843 (expr); 10188 10189 if (ffestc_shriek_after1_ != NULL) 10190 (*ffestc_shriek_after1_) (TRUE); 10191 ffestc_labeldef_branch_end_ (); 10192} 10193 10194/* ffestc_R904 -- OPEN statement 10195 10196 ffestc_R904(); 10197 10198 Make sure an OPEN is valid in the current context, and implement it. */ 10199 10200void 10201ffestc_R904 () 10202{ 10203 int i; 10204 int expect_file; 10205 const char *status_strs[] 10206 = 10207 { 10208 "New", 10209 "Old", 10210 "Replace", 10211 "Scratch", 10212 "Unknown" 10213 }; 10214 const char *access_strs[] 10215 = 10216 { 10217 "Append", 10218 "Direct", 10219 "Keyed", 10220 "Sequential" 10221 }; 10222 const char *blank_strs[] 10223 = 10224 { 10225 "Null", 10226 "Zero" 10227 }; 10228 const char *carriagecontrol_strs[] 10229 = 10230 { 10231 "Fortran", 10232 "List", 10233 "None" 10234 }; 10235 const char *dispose_strs[] 10236 = 10237 { 10238 "Delete", 10239 "Keep", 10240 "Print", 10241 "Print/Delete", 10242 "Save", 10243 "Submit", 10244 "Submit/Delete" 10245 }; 10246 const char *form_strs[] 10247 = 10248 { 10249 "Formatted", 10250 "Unformatted" 10251 }; 10252 const char *organization_strs[] 10253 = 10254 { 10255 "Indexed", 10256 "Relative", 10257 "Sequential" 10258 }; 10259 const char *position_strs[] 10260 = 10261 { 10262 "Append", 10263 "AsIs", 10264 "Rewind" 10265 }; 10266 const char *action_strs[] 10267 = 10268 { 10269 "Read", 10270 "ReadWrite", 10271 "Write" 10272 }; 10273 const char *delim_strs[] 10274 = 10275 { 10276 "Apostrophe", 10277 "None", 10278 "Quote" 10279 }; 10280 const char *recordtype_strs[] 10281 = 10282 { 10283 "Fixed", 10284 "Segmented", 10285 "Stream", 10286 "Stream_CR", 10287 "Stream_LF", 10288 "Variable" 10289 }; 10290 const char *pad_strs[] 10291 = 10292 { 10293 "No", 10294 "Yes" 10295 }; 10296 10297 ffestc_check_simple_ (); 10298 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10299 return; 10300 ffestc_labeldef_branch_begin_ (); 10301 10302 if (ffestc_subr_is_branch_ 10303 (&ffestp_file.open.open_spec[FFESTP_openixERR]) 10304 && ffestc_subr_is_present_ ("UNIT", 10305 &ffestp_file.open.open_spec[FFESTP_openixUNIT])) 10306 { 10307 i = ffestc_subr_binsrch_ (status_strs, 10308 ARRAY_SIZE (status_strs), 10309 &ffestp_file.open.open_spec[FFESTP_openixSTATUS], 10310 "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN"); 10311 switch (i) 10312 { 10313 case 0: /* Unknown. */ 10314 case 5: /* UNKNOWN. */ 10315 expect_file = 2; /* Unknown, don't care about FILE=. */ 10316 break; 10317 10318 case 1: /* NEW. */ 10319 case 2: /* OLD. */ 10320 if (ffe_is_pedantic ()) 10321 expect_file = 1; /* Yes, need FILE=. */ 10322 else 10323 expect_file = 2; /* f2clib doesn't care about FILE=. */ 10324 break; 10325 10326 case 3: /* REPLACE. */ 10327 expect_file = 1; /* Yes, need FILE=. */ 10328 break; 10329 10330 case 4: /* SCRATCH. */ 10331 expect_file = 0; /* No, disallow FILE=. */ 10332 break; 10333 10334 default: 10335 assert ("invalid _binsrch_ result" == NULL); 10336 expect_file = 0; 10337 break; 10338 } 10339 if ((expect_file == 0) 10340 && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present) 10341 { 10342 ffebad_start (FFEBAD_CONFLICTING_SPECS); 10343 assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present); 10344 if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present) 10345 { 10346 ffebad_here (0, ffelex_token_where_line 10347 (ffestp_file.open.open_spec[FFESTP_openixFILE].kw), 10348 ffelex_token_where_column 10349 (ffestp_file.open.open_spec[FFESTP_openixFILE].kw)); 10350 } 10351 else 10352 { 10353 ffebad_here (0, ffelex_token_where_line 10354 (ffestp_file.open.open_spec[FFESTP_openixFILE].value), 10355 ffelex_token_where_column 10356 (ffestp_file.open.open_spec[FFESTP_openixFILE].value)); 10357 } 10358 assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present); 10359 if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present) 10360 { 10361 ffebad_here (1, ffelex_token_where_line 10362 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw), 10363 ffelex_token_where_column 10364 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw)); 10365 } 10366 else 10367 { 10368 ffebad_here (1, ffelex_token_where_line 10369 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value), 10370 ffelex_token_where_column 10371 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value)); 10372 } 10373 ffebad_finish (); 10374 } 10375 else if ((expect_file == 1) 10376 && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present) 10377 { 10378 ffebad_start (FFEBAD_MISSING_SPECIFIER); 10379 assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present); 10380 if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present) 10381 { 10382 ffebad_here (0, ffelex_token_where_line 10383 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw), 10384 ffelex_token_where_column 10385 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw)); 10386 } 10387 else 10388 { 10389 ffebad_here (0, ffelex_token_where_line 10390 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value), 10391 ffelex_token_where_column 10392 (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value)); 10393 } 10394 ffebad_string ("FILE="); 10395 ffebad_finish (); 10396 } 10397 10398 ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs), 10399 &ffestp_file.open.open_spec[FFESTP_openixACCESS], 10400 "APPEND, DIRECT, KEYED, or SEQUENTIAL"); 10401 10402 ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs), 10403 &ffestp_file.open.open_spec[FFESTP_openixBLANK], 10404 "NULL or ZERO"); 10405 10406 ffestc_subr_binsrch_ (carriagecontrol_strs, 10407 ARRAY_SIZE (carriagecontrol_strs), 10408 &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL], 10409 "FORTRAN, LIST, or NONE"); 10410 10411 ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs), 10412 &ffestp_file.open.open_spec[FFESTP_openixDISPOSE], 10413 "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE"); 10414 10415 ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs), 10416 &ffestp_file.open.open_spec[FFESTP_openixFORM], 10417 "FORMATTED or UNFORMATTED"); 10418 10419 ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs), 10420 &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION], 10421 "INDEXED, RELATIVE, or SEQUENTIAL"); 10422 10423 ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs), 10424 &ffestp_file.open.open_spec[FFESTP_openixPOSITION], 10425 "APPEND, ASIS, or REWIND"); 10426 10427 ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs), 10428 &ffestp_file.open.open_spec[FFESTP_openixACTION], 10429 "READ, READWRITE, or WRITE"); 10430 10431 ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs), 10432 &ffestp_file.open.open_spec[FFESTP_openixDELIM], 10433 "APOSTROPHE, NONE, or QUOTE"); 10434 10435 ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs), 10436 &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE], 10437 "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE"); 10438 10439 ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs), 10440 &ffestp_file.open.open_spec[FFESTP_openixPAD], 10441 "NO or YES"); 10442 10443 ffestd_R904 (); 10444 } 10445 10446 if (ffestc_shriek_after1_ != NULL) 10447 (*ffestc_shriek_after1_) (TRUE); 10448 ffestc_labeldef_branch_end_ (); 10449} 10450 10451/* ffestc_R907 -- CLOSE statement 10452 10453 ffestc_R907(); 10454 10455 Make sure a CLOSE is valid in the current context, and implement it. */ 10456 10457void 10458ffestc_R907 () 10459{ 10460 const char *status_strs[] 10461 = 10462 { 10463 "Delete", 10464 "Keep", 10465 "Print", 10466 "Print/Delete", 10467 "Save", 10468 "Submit", 10469 "Submit/Delete" 10470 }; 10471 10472 ffestc_check_simple_ (); 10473 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10474 return; 10475 ffestc_labeldef_branch_begin_ (); 10476 10477 if (ffestc_subr_is_branch_ 10478 (&ffestp_file.close.close_spec[FFESTP_closeixERR]) 10479 && ffestc_subr_is_present_ ("UNIT", 10480 &ffestp_file.close.close_spec[FFESTP_closeixUNIT])) 10481 { 10482 ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs), 10483 &ffestp_file.close.close_spec[FFESTP_closeixSTATUS], 10484 "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE"); 10485 10486 ffestd_R907 (); 10487 } 10488 10489 if (ffestc_shriek_after1_ != NULL) 10490 (*ffestc_shriek_after1_) (TRUE); 10491 ffestc_labeldef_branch_end_ (); 10492} 10493 10494/* ffestc_R909_start -- READ(...) statement list begin 10495 10496 ffestc_R909_start(FALSE); 10497 10498 Verify that READ is valid here, and begin accepting items in the 10499 list. */ 10500 10501void 10502ffestc_R909_start (bool only_format) 10503{ 10504 ffestvUnit unit; 10505 ffestvFormat format; 10506 bool rec; 10507 bool key; 10508 ffestpReadIx keyn; 10509 ffestpReadIx spec1; 10510 ffestpReadIx spec2; 10511 10512 ffestc_check_start_ (); 10513 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10514 { 10515 ffestc_ok_ = FALSE; 10516 return; 10517 } 10518 ffestc_labeldef_branch_begin_ (); 10519 10520 if (!ffestc_subr_is_format_ 10521 (&ffestp_file.read.read_spec[FFESTP_readixFORMAT])) 10522 { 10523 ffestc_ok_ = FALSE; 10524 return; 10525 } 10526 10527 format = ffestc_subr_format_ 10528 (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]); 10529 ffestc_namelist_ = (format == FFESTV_formatNAMELIST); 10530 10531 if (only_format) 10532 { 10533 ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE); 10534 10535 ffestc_ok_ = TRUE; 10536 return; 10537 } 10538 10539 if (!ffestc_subr_is_branch_ 10540 (&ffestp_file.read.read_spec[FFESTP_readixEOR]) 10541 || !ffestc_subr_is_branch_ 10542 (&ffestp_file.read.read_spec[FFESTP_readixERR]) 10543 || !ffestc_subr_is_branch_ 10544 (&ffestp_file.read.read_spec[FFESTP_readixEND])) 10545 { 10546 ffestc_ok_ = FALSE; 10547 return; 10548 } 10549 10550 unit = ffestc_subr_unit_ 10551 (&ffestp_file.read.read_spec[FFESTP_readixUNIT]); 10552 if (unit == FFESTV_unitNONE) 10553 { 10554 ffebad_start (FFEBAD_NO_UNIT_SPEC); 10555 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 10556 ffelex_token_where_column (ffesta_tokens[0])); 10557 ffebad_finish (); 10558 ffestc_ok_ = FALSE; 10559 return; 10560 } 10561 10562 rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present; 10563 10564 if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present) 10565 { 10566 key = TRUE; 10567 keyn = spec1 = FFESTP_readixKEYEQ; 10568 } 10569 else 10570 { 10571 key = FALSE; 10572 keyn = spec1 = FFESTP_readix; 10573 } 10574 10575 if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present) 10576 { 10577 if (key) 10578 { 10579 spec2 = FFESTP_readixKEYGT; 10580 whine: /* :::::::::::::::::::: */ 10581 ffebad_start (FFEBAD_CONFLICTING_SPECS); 10582 assert (ffestp_file.read.read_spec[spec1].kw_or_val_present); 10583 if (ffestp_file.read.read_spec[spec1].kw_present) 10584 { 10585 ffebad_here (0, ffelex_token_where_line 10586 (ffestp_file.read.read_spec[spec1].kw), 10587 ffelex_token_where_column 10588 (ffestp_file.read.read_spec[spec1].kw)); 10589 } 10590 else 10591 { 10592 ffebad_here (0, ffelex_token_where_line 10593 (ffestp_file.read.read_spec[spec1].value), 10594 ffelex_token_where_column 10595 (ffestp_file.read.read_spec[spec1].value)); 10596 } 10597 assert (ffestp_file.read.read_spec[spec2].kw_or_val_present); 10598 if (ffestp_file.read.read_spec[spec2].kw_present) 10599 { 10600 ffebad_here (1, ffelex_token_where_line 10601 (ffestp_file.read.read_spec[spec2].kw), 10602 ffelex_token_where_column 10603 (ffestp_file.read.read_spec[spec2].kw)); 10604 } 10605 else 10606 { 10607 ffebad_here (1, ffelex_token_where_line 10608 (ffestp_file.read.read_spec[spec2].value), 10609 ffelex_token_where_column 10610 (ffestp_file.read.read_spec[spec2].value)); 10611 } 10612 ffebad_finish (); 10613 ffestc_ok_ = FALSE; 10614 return; 10615 } 10616 key = TRUE; 10617 keyn = spec1 = FFESTP_readixKEYGT; 10618 } 10619 10620 if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present) 10621 { 10622 if (key) 10623 { 10624 spec2 = FFESTP_readixKEYGT; 10625 goto whine; /* :::::::::::::::::::: */ 10626 } 10627 key = TRUE; 10628 keyn = FFESTP_readixKEYGT; 10629 } 10630 10631 if (rec) 10632 { 10633 spec1 = FFESTP_readixREC; 10634 if (key) 10635 { 10636 spec2 = keyn; 10637 goto whine; /* :::::::::::::::::::: */ 10638 } 10639 if (unit == FFESTV_unitCHAREXPR) 10640 { 10641 spec2 = FFESTP_readixUNIT; 10642 goto whine; /* :::::::::::::::::::: */ 10643 } 10644 if ((format == FFESTV_formatASTERISK) 10645 || (format == FFESTV_formatNAMELIST)) 10646 { 10647 spec2 = FFESTP_readixFORMAT; 10648 goto whine; /* :::::::::::::::::::: */ 10649 } 10650 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) 10651 { 10652 spec2 = FFESTP_readixADVANCE; 10653 goto whine; /* :::::::::::::::::::: */ 10654 } 10655 if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present) 10656 { 10657 spec2 = FFESTP_readixEND; 10658 goto whine; /* :::::::::::::::::::: */ 10659 } 10660 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present) 10661 { 10662 spec2 = FFESTP_readixNULLS; 10663 goto whine; /* :::::::::::::::::::: */ 10664 } 10665 } 10666 else if (key) 10667 { 10668 spec1 = keyn; 10669 if (unit == FFESTV_unitCHAREXPR) 10670 { 10671 spec2 = FFESTP_readixUNIT; 10672 goto whine; /* :::::::::::::::::::: */ 10673 } 10674 if ((format == FFESTV_formatASTERISK) 10675 || (format == FFESTV_formatNAMELIST)) 10676 { 10677 spec2 = FFESTP_readixFORMAT; 10678 goto whine; /* :::::::::::::::::::: */ 10679 } 10680 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) 10681 { 10682 spec2 = FFESTP_readixADVANCE; 10683 goto whine; /* :::::::::::::::::::: */ 10684 } 10685 if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present) 10686 { 10687 spec2 = FFESTP_readixEND; 10688 goto whine; /* :::::::::::::::::::: */ 10689 } 10690 if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present) 10691 { 10692 spec2 = FFESTP_readixEOR; 10693 goto whine; /* :::::::::::::::::::: */ 10694 } 10695 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present) 10696 { 10697 spec2 = FFESTP_readixNULLS; 10698 goto whine; /* :::::::::::::::::::: */ 10699 } 10700 if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present) 10701 { 10702 spec2 = FFESTP_readixREC; 10703 goto whine; /* :::::::::::::::::::: */ 10704 } 10705 if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present) 10706 { 10707 spec2 = FFESTP_readixSIZE; 10708 goto whine; /* :::::::::::::::::::: */ 10709 } 10710 } 10711 else 10712 { /* Sequential/Internal. */ 10713 if (unit == FFESTV_unitCHAREXPR) 10714 { /* Internal file. */ 10715 spec1 = FFESTP_readixUNIT; 10716 if (format == FFESTV_formatNAMELIST) 10717 { 10718 spec2 = FFESTP_readixFORMAT; 10719 goto whine; /* :::::::::::::::::::: */ 10720 } 10721 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) 10722 { 10723 spec2 = FFESTP_readixADVANCE; 10724 goto whine; /* :::::::::::::::::::: */ 10725 } 10726 } 10727 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) 10728 { /* ADVANCE= specified. */ 10729 spec1 = FFESTP_readixADVANCE; 10730 if (format == FFESTV_formatNONE) 10731 { 10732 ffebad_start (FFEBAD_MISSING_FORMAT_SPEC); 10733 ffebad_here (0, ffelex_token_where_line 10734 (ffestp_file.read.read_spec[spec1].kw), 10735 ffelex_token_where_column 10736 (ffestp_file.read.read_spec[spec1].kw)); 10737 ffebad_finish (); 10738 10739 ffestc_ok_ = FALSE; 10740 return; 10741 } 10742 if (format == FFESTV_formatNAMELIST) 10743 { 10744 spec2 = FFESTP_readixFORMAT; 10745 goto whine; /* :::::::::::::::::::: */ 10746 } 10747 } 10748 if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present) 10749 { /* EOR= specified. */ 10750 spec1 = FFESTP_readixEOR; 10751 if (ffestc_subr_speccmp_ ("No", 10752 &ffestp_file.read.read_spec[FFESTP_readixADVANCE], 10753 NULL, NULL) != 0) 10754 { 10755 goto whine_advance; /* :::::::::::::::::::: */ 10756 } 10757 } 10758 if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present) 10759 { /* NULLS= specified. */ 10760 spec1 = FFESTP_readixNULLS; 10761 if (format != FFESTV_formatASTERISK) 10762 { 10763 spec2 = FFESTP_readixFORMAT; 10764 goto whine; /* :::::::::::::::::::: */ 10765 } 10766 } 10767 if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present) 10768 { /* SIZE= specified. */ 10769 spec1 = FFESTP_readixSIZE; 10770 if (ffestc_subr_speccmp_ ("No", 10771 &ffestp_file.read.read_spec[FFESTP_readixADVANCE], 10772 NULL, NULL) != 0) 10773 { 10774 whine_advance: /* :::::::::::::::::::: */ 10775 if (ffestp_file.read.read_spec[FFESTP_readixADVANCE] 10776 .kw_or_val_present) 10777 { 10778 ffebad_start (FFEBAD_CONFLICTING_SPECS); 10779 ffebad_here (0, ffelex_token_where_line 10780 (ffestp_file.read.read_spec[spec1].kw), 10781 ffelex_token_where_column 10782 (ffestp_file.read.read_spec[spec1].kw)); 10783 ffebad_here (1, ffelex_token_where_line 10784 (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw), 10785 ffelex_token_where_column 10786 (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw)); 10787 ffebad_finish (); 10788 } 10789 else 10790 { 10791 ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC); 10792 ffebad_here (0, ffelex_token_where_line 10793 (ffestp_file.read.read_spec[spec1].kw), 10794 ffelex_token_where_column 10795 (ffestp_file.read.read_spec[spec1].kw)); 10796 ffebad_finish (); 10797 } 10798 10799 ffestc_ok_ = FALSE; 10800 return; 10801 } 10802 } 10803 } 10804 10805 if (unit == FFESTV_unitCHAREXPR) 10806 ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF; 10807 else 10808 ffestc_iolist_context_ = FFEEXPR_contextIOLIST; 10809 10810 ffestd_R909_start (FALSE, unit, format, rec, key); 10811 10812 ffestc_ok_ = TRUE; 10813} 10814 10815/* ffestc_R909_item -- READ statement i/o item 10816 10817 ffestc_R909_item(expr,expr_token); 10818 10819 Implement output-list expression. */ 10820 10821void 10822ffestc_R909_item (ffebld expr, ffelexToken expr_token) 10823{ 10824 ffestc_check_item_ (); 10825 if (!ffestc_ok_) 10826 return; 10827 10828 if (ffestc_namelist_ != 0) 10829 { 10830 if (ffestc_namelist_ == 1) 10831 { 10832 ffestc_namelist_ = 2; 10833 ffebad_start (FFEBAD_NAMELIST_ITEMS); 10834 ffebad_here (0, ffelex_token_where_line (expr_token), 10835 ffelex_token_where_column (expr_token)); 10836 ffebad_finish (); 10837 } 10838 return; 10839 } 10840 10841 ffestd_R909_item (expr, expr_token); 10842} 10843 10844/* ffestc_R909_finish -- READ statement list complete 10845 10846 ffestc_R909_finish(); 10847 10848 Just wrap up any local activities. */ 10849 10850void 10851ffestc_R909_finish () 10852{ 10853 ffestc_check_finish_ (); 10854 if (!ffestc_ok_) 10855 return; 10856 10857 ffestd_R909_finish (); 10858 10859 if (ffestc_shriek_after1_ != NULL) 10860 (*ffestc_shriek_after1_) (TRUE); 10861 ffestc_labeldef_branch_end_ (); 10862} 10863 10864/* ffestc_R910_start -- WRITE(...) statement list begin 10865 10866 ffestc_R910_start(); 10867 10868 Verify that WRITE is valid here, and begin accepting items in the 10869 list. */ 10870 10871void 10872ffestc_R910_start () 10873{ 10874 ffestvUnit unit; 10875 ffestvFormat format; 10876 bool rec; 10877 ffestpWriteIx spec1; 10878 ffestpWriteIx spec2; 10879 10880 ffestc_check_start_ (); 10881 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 10882 { 10883 ffestc_ok_ = FALSE; 10884 return; 10885 } 10886 ffestc_labeldef_branch_begin_ (); 10887 10888 if (!ffestc_subr_is_branch_ 10889 (&ffestp_file.write.write_spec[FFESTP_writeixEOR]) 10890 || !ffestc_subr_is_branch_ 10891 (&ffestp_file.write.write_spec[FFESTP_writeixERR]) 10892 || !ffestc_subr_is_format_ 10893 (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT])) 10894 { 10895 ffestc_ok_ = FALSE; 10896 return; 10897 } 10898 10899 format = ffestc_subr_format_ 10900 (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]); 10901 ffestc_namelist_ = (format == FFESTV_formatNAMELIST); 10902 10903 unit = ffestc_subr_unit_ 10904 (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]); 10905 if (unit == FFESTV_unitNONE) 10906 { 10907 ffebad_start (FFEBAD_NO_UNIT_SPEC); 10908 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 10909 ffelex_token_where_column (ffesta_tokens[0])); 10910 ffebad_finish (); 10911 ffestc_ok_ = FALSE; 10912 return; 10913 } 10914 10915 rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present; 10916 10917 if (rec) 10918 { 10919 spec1 = FFESTP_writeixREC; 10920 if (unit == FFESTV_unitCHAREXPR) 10921 { 10922 spec2 = FFESTP_writeixUNIT; 10923 whine: /* :::::::::::::::::::: */ 10924 ffebad_start (FFEBAD_CONFLICTING_SPECS); 10925 assert (ffestp_file.write.write_spec[spec1].kw_or_val_present); 10926 if (ffestp_file.write.write_spec[spec1].kw_present) 10927 { 10928 ffebad_here (0, ffelex_token_where_line 10929 (ffestp_file.write.write_spec[spec1].kw), 10930 ffelex_token_where_column 10931 (ffestp_file.write.write_spec[spec1].kw)); 10932 } 10933 else 10934 { 10935 ffebad_here (0, ffelex_token_where_line 10936 (ffestp_file.write.write_spec[spec1].value), 10937 ffelex_token_where_column 10938 (ffestp_file.write.write_spec[spec1].value)); 10939 } 10940 assert (ffestp_file.write.write_spec[spec2].kw_or_val_present); 10941 if (ffestp_file.write.write_spec[spec2].kw_present) 10942 { 10943 ffebad_here (1, ffelex_token_where_line 10944 (ffestp_file.write.write_spec[spec2].kw), 10945 ffelex_token_where_column 10946 (ffestp_file.write.write_spec[spec2].kw)); 10947 } 10948 else 10949 { 10950 ffebad_here (1, ffelex_token_where_line 10951 (ffestp_file.write.write_spec[spec2].value), 10952 ffelex_token_where_column 10953 (ffestp_file.write.write_spec[spec2].value)); 10954 } 10955 ffebad_finish (); 10956 ffestc_ok_ = FALSE; 10957 return; 10958 } 10959 if ((format == FFESTV_formatASTERISK) 10960 || (format == FFESTV_formatNAMELIST)) 10961 { 10962 spec2 = FFESTP_writeixFORMAT; 10963 goto whine; /* :::::::::::::::::::: */ 10964 } 10965 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present) 10966 { 10967 spec2 = FFESTP_writeixADVANCE; 10968 goto whine; /* :::::::::::::::::::: */ 10969 } 10970 } 10971 else 10972 { /* Sequential/Indexed/Internal. */ 10973 if (unit == FFESTV_unitCHAREXPR) 10974 { /* Internal file. */ 10975 spec1 = FFESTP_writeixUNIT; 10976 if (format == FFESTV_formatNAMELIST) 10977 { 10978 spec2 = FFESTP_writeixFORMAT; 10979 goto whine; /* :::::::::::::::::::: */ 10980 } 10981 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present) 10982 { 10983 spec2 = FFESTP_writeixADVANCE; 10984 goto whine; /* :::::::::::::::::::: */ 10985 } 10986 } 10987 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present) 10988 { /* ADVANCE= specified. */ 10989 spec1 = FFESTP_writeixADVANCE; 10990 if (format == FFESTV_formatNONE) 10991 { 10992 ffebad_start (FFEBAD_MISSING_FORMAT_SPEC); 10993 ffebad_here (0, ffelex_token_where_line 10994 (ffestp_file.write.write_spec[spec1].kw), 10995 ffelex_token_where_column 10996 (ffestp_file.write.write_spec[spec1].kw)); 10997 ffebad_finish (); 10998 10999 ffestc_ok_ = FALSE; 11000 return; 11001 } 11002 if (format == FFESTV_formatNAMELIST) 11003 { 11004 spec2 = FFESTP_writeixFORMAT; 11005 goto whine; /* :::::::::::::::::::: */ 11006 } 11007 } 11008 if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present) 11009 { /* EOR= specified. */ 11010 spec1 = FFESTP_writeixEOR; 11011 if (ffestc_subr_speccmp_ ("No", 11012 &ffestp_file.write.write_spec[FFESTP_writeixADVANCE], 11013 NULL, NULL) != 0) 11014 { 11015 if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE] 11016 .kw_or_val_present) 11017 { 11018 ffebad_start (FFEBAD_CONFLICTING_SPECS); 11019 ffebad_here (0, ffelex_token_where_line 11020 (ffestp_file.write.write_spec[spec1].kw), 11021 ffelex_token_where_column 11022 (ffestp_file.write.write_spec[spec1].kw)); 11023 ffebad_here (1, ffelex_token_where_line 11024 (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw), 11025 ffelex_token_where_column 11026 (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw)); 11027 ffebad_finish (); 11028 } 11029 else 11030 { 11031 ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC); 11032 ffebad_here (0, ffelex_token_where_line 11033 (ffestp_file.write.write_spec[spec1].kw), 11034 ffelex_token_where_column 11035 (ffestp_file.write.write_spec[spec1].kw)); 11036 ffebad_finish (); 11037 } 11038 11039 ffestc_ok_ = FALSE; 11040 return; 11041 } 11042 } 11043 } 11044 11045 if (unit == FFESTV_unitCHAREXPR) 11046 ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF; 11047 else 11048 ffestc_iolist_context_ = FFEEXPR_contextIOLIST; 11049 11050 ffestd_R910_start (unit, format, rec); 11051 11052 ffestc_ok_ = TRUE; 11053} 11054 11055/* ffestc_R910_item -- WRITE statement i/o item 11056 11057 ffestc_R910_item(expr,expr_token); 11058 11059 Implement output-list expression. */ 11060 11061void 11062ffestc_R910_item (ffebld expr, ffelexToken expr_token) 11063{ 11064 ffestc_check_item_ (); 11065 if (!ffestc_ok_) 11066 return; 11067 11068 if (ffestc_namelist_ != 0) 11069 { 11070 if (ffestc_namelist_ == 1) 11071 { 11072 ffestc_namelist_ = 2; 11073 ffebad_start (FFEBAD_NAMELIST_ITEMS); 11074 ffebad_here (0, ffelex_token_where_line (expr_token), 11075 ffelex_token_where_column (expr_token)); 11076 ffebad_finish (); 11077 } 11078 return; 11079 } 11080 11081 ffestd_R910_item (expr, expr_token); 11082} 11083 11084/* ffestc_R910_finish -- WRITE statement list complete 11085 11086 ffestc_R910_finish(); 11087 11088 Just wrap up any local activities. */ 11089 11090void 11091ffestc_R910_finish () 11092{ 11093 ffestc_check_finish_ (); 11094 if (!ffestc_ok_) 11095 return; 11096 11097 ffestd_R910_finish (); 11098 11099 if (ffestc_shriek_after1_ != NULL) 11100 (*ffestc_shriek_after1_) (TRUE); 11101 ffestc_labeldef_branch_end_ (); 11102} 11103 11104/* ffestc_R911_start -- PRINT(...) statement list begin 11105 11106 ffestc_R911_start(); 11107 11108 Verify that PRINT is valid here, and begin accepting items in the 11109 list. */ 11110 11111void 11112ffestc_R911_start () 11113{ 11114 ffestvFormat format; 11115 11116 ffestc_check_start_ (); 11117 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 11118 { 11119 ffestc_ok_ = FALSE; 11120 return; 11121 } 11122 ffestc_labeldef_branch_begin_ (); 11123 11124 if (!ffestc_subr_is_format_ 11125 (&ffestp_file.print.print_spec[FFESTP_printixFORMAT])) 11126 { 11127 ffestc_ok_ = FALSE; 11128 return; 11129 } 11130 11131 format = ffestc_subr_format_ 11132 (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]); 11133 ffestc_namelist_ = (format == FFESTV_formatNAMELIST); 11134 11135 ffestd_R911_start (format); 11136 11137 ffestc_ok_ = TRUE; 11138} 11139 11140/* ffestc_R911_item -- PRINT statement i/o item 11141 11142 ffestc_R911_item(expr,expr_token); 11143 11144 Implement output-list expression. */ 11145 11146void 11147ffestc_R911_item (ffebld expr, ffelexToken expr_token) 11148{ 11149 ffestc_check_item_ (); 11150 if (!ffestc_ok_) 11151 return; 11152 11153 if (ffestc_namelist_ != 0) 11154 { 11155 if (ffestc_namelist_ == 1) 11156 { 11157 ffestc_namelist_ = 2; 11158 ffebad_start (FFEBAD_NAMELIST_ITEMS); 11159 ffebad_here (0, ffelex_token_where_line (expr_token), 11160 ffelex_token_where_column (expr_token)); 11161 ffebad_finish (); 11162 } 11163 return; 11164 } 11165 11166 ffestd_R911_item (expr, expr_token); 11167} 11168 11169/* ffestc_R911_finish -- PRINT statement list complete 11170 11171 ffestc_R911_finish(); 11172 11173 Just wrap up any local activities. */ 11174 11175void 11176ffestc_R911_finish () 11177{ 11178 ffestc_check_finish_ (); 11179 if (!ffestc_ok_) 11180 return; 11181 11182 ffestd_R911_finish (); 11183 11184 if (ffestc_shriek_after1_ != NULL) 11185 (*ffestc_shriek_after1_) (TRUE); 11186 ffestc_labeldef_branch_end_ (); 11187} 11188 11189/* ffestc_R919 -- BACKSPACE statement 11190 11191 ffestc_R919(); 11192 11193 Make sure a BACKSPACE is valid in the current context, and implement it. */ 11194 11195void 11196ffestc_R919 () 11197{ 11198 ffestc_check_simple_ (); 11199 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 11200 return; 11201 ffestc_labeldef_branch_begin_ (); 11202 11203 if (ffestc_subr_is_branch_ 11204 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) 11205 && ffestc_subr_is_present_ ("UNIT", 11206 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) 11207 ffestd_R919 (); 11208 11209 if (ffestc_shriek_after1_ != NULL) 11210 (*ffestc_shriek_after1_) (TRUE); 11211 ffestc_labeldef_branch_end_ (); 11212} 11213 11214/* ffestc_R920 -- ENDFILE statement 11215 11216 ffestc_R920(); 11217 11218 Make sure a ENDFILE is valid in the current context, and implement it. */ 11219 11220void 11221ffestc_R920 () 11222{ 11223 ffestc_check_simple_ (); 11224 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 11225 return; 11226 ffestc_labeldef_branch_begin_ (); 11227 11228 if (ffestc_subr_is_branch_ 11229 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) 11230 && ffestc_subr_is_present_ ("UNIT", 11231 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) 11232 ffestd_R920 (); 11233 11234 if (ffestc_shriek_after1_ != NULL) 11235 (*ffestc_shriek_after1_) (TRUE); 11236 ffestc_labeldef_branch_end_ (); 11237} 11238 11239/* ffestc_R921 -- REWIND statement 11240 11241 ffestc_R921(); 11242 11243 Make sure a REWIND is valid in the current context, and implement it. */ 11244 11245void 11246ffestc_R921 () 11247{ 11248 ffestc_check_simple_ (); 11249 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 11250 return; 11251 ffestc_labeldef_branch_begin_ (); 11252 11253 if (ffestc_subr_is_branch_ 11254 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) 11255 && ffestc_subr_is_present_ ("UNIT", 11256 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) 11257 ffestd_R921 (); 11258 11259 if (ffestc_shriek_after1_ != NULL) 11260 (*ffestc_shriek_after1_) (TRUE); 11261 ffestc_labeldef_branch_end_ (); 11262} 11263 11264/* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version) 11265 11266 ffestc_R923A(); 11267 11268 Make sure an INQUIRE is valid in the current context, and implement it. */ 11269 11270void 11271ffestc_R923A () 11272{ 11273 bool by_file; 11274 bool by_unit; 11275 11276 ffestc_check_simple_ (); 11277 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 11278 return; 11279 ffestc_labeldef_branch_begin_ (); 11280 11281 if (ffestc_subr_is_branch_ 11282 (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR])) 11283 { 11284 by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE] 11285 .kw_or_val_present; 11286 by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT] 11287 .kw_or_val_present; 11288 if (by_file && by_unit) 11289 { 11290 ffebad_start (FFEBAD_CONFLICTING_SPECS); 11291 assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present); 11292 if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present) 11293 { 11294 ffebad_here (0, ffelex_token_where_line 11295 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw), 11296 ffelex_token_where_column 11297 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw)); 11298 } 11299 else 11300 { 11301 ffebad_here (0, ffelex_token_where_line 11302 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value), 11303 ffelex_token_where_column 11304 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value)); 11305 } 11306 assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present); 11307 if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present) 11308 { 11309 ffebad_here (1, ffelex_token_where_line 11310 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw), 11311 ffelex_token_where_column 11312 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw)); 11313 } 11314 else 11315 { 11316 ffebad_here (1, ffelex_token_where_line 11317 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value), 11318 ffelex_token_where_column 11319 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value)); 11320 } 11321 ffebad_finish (); 11322 } 11323 else if (!by_file && !by_unit) 11324 { 11325 ffebad_start (FFEBAD_MISSING_SPECIFIER); 11326 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 11327 ffelex_token_where_column (ffesta_tokens[0])); 11328 ffebad_string ("UNIT= or FILE="); 11329 ffebad_finish (); 11330 } 11331 else 11332 ffestd_R923A (by_file); 11333 } 11334 11335 if (ffestc_shriek_after1_ != NULL) 11336 (*ffestc_shriek_after1_) (TRUE); 11337 ffestc_labeldef_branch_end_ (); 11338} 11339 11340/* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin 11341 11342 ffestc_R923B_start(); 11343 11344 Verify that INQUIRE is valid here, and begin accepting items in the 11345 list. */ 11346 11347void 11348ffestc_R923B_start () 11349{ 11350 ffestc_check_start_ (); 11351 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 11352 { 11353 ffestc_ok_ = FALSE; 11354 return; 11355 } 11356 ffestc_labeldef_branch_begin_ (); 11357 11358 ffestd_R923B_start (); 11359 11360 ffestc_ok_ = TRUE; 11361} 11362 11363/* ffestc_R923B_item -- INQUIRE statement i/o item 11364 11365 ffestc_R923B_item(expr,expr_token); 11366 11367 Implement output-list expression. */ 11368 11369void 11370ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED) 11371{ 11372 ffestc_check_item_ (); 11373 if (!ffestc_ok_) 11374 return; 11375 11376 ffestd_R923B_item (expr); 11377} 11378 11379/* ffestc_R923B_finish -- INQUIRE statement list complete 11380 11381 ffestc_R923B_finish(); 11382 11383 Just wrap up any local activities. */ 11384 11385void 11386ffestc_R923B_finish () 11387{ 11388 ffestc_check_finish_ (); 11389 if (!ffestc_ok_) 11390 return; 11391 11392 ffestd_R923B_finish (); 11393 11394 if (ffestc_shriek_after1_ != NULL) 11395 (*ffestc_shriek_after1_) (TRUE); 11396 ffestc_labeldef_branch_end_ (); 11397} 11398 11399/* ffestc_R1001 -- FORMAT statement 11400 11401 ffestc_R1001(format_list); 11402 11403 Make sure format_list is valid. Update label's info to indicate it is a 11404 FORMAT label, and (perhaps) warn if there is no label! */ 11405 11406void 11407ffestc_R1001 (ffesttFormatList f) 11408{ 11409 ffestc_check_simple_ (); 11410 if (ffestc_order_format_ () != FFESTC_orderOK_) 11411 return; 11412 ffestc_labeldef_format_ (); 11413 11414 ffestd_R1001 (f); 11415} 11416 11417/* ffestc_R1102 -- PROGRAM statement 11418 11419 ffestc_R1102(name_token); 11420 11421 Make sure ffestc_kind_ identifies an empty block. Make sure name_token 11422 gives a valid name. Implement the beginning of a main program. */ 11423 11424void 11425ffestc_R1102 (ffelexToken name) 11426{ 11427 ffestw b; 11428 ffesymbol s; 11429 11430 assert (name != NULL); 11431 11432 ffestc_check_simple_ (); 11433 if (ffestc_order_unit_ () != FFESTC_orderOK_) 11434 return; 11435 ffestc_labeldef_useless_ (); 11436 11437 ffestc_blocknum_ = 0; 11438 b = ffestw_update (ffestw_push (NULL)); 11439 ffestw_set_top_do (b, NULL); 11440 ffestw_set_state (b, FFESTV_statePROGRAM0); 11441 ffestw_set_blocknum (b, ffestc_blocknum_++); 11442 ffestw_set_shriek (b, ffestc_shriek_end_program_); 11443 11444 ffestw_set_name (b, ffelex_token_use (name)); 11445 11446 s = ffesymbol_declare_programunit (name, 11447 ffelex_token_where_line (ffesta_tokens[0]), 11448 ffelex_token_where_column (ffesta_tokens[0])); 11449 11450 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 11451 { 11452 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 11453 ffesymbol_set_info (s, 11454 ffeinfo_new (FFEINFO_basictypeNONE, 11455 FFEINFO_kindtypeNONE, 11456 0, 11457 FFEINFO_kindPROGRAM, 11458 FFEINFO_whereLOCAL, 11459 FFETARGET_charactersizeNONE)); 11460 ffesymbol_signal_unreported (s); 11461 } 11462 else 11463 ffesymbol_error (s, name); 11464 11465 ffestd_R1102 (s, name); 11466} 11467 11468/* ffestc_R1103 -- END PROGRAM statement 11469 11470 ffestc_R1103(name_token); 11471 11472 Make sure ffestc_kind_ identifies the current kind of program unit. If not 11473 NULL, make sure name_token gives the correct name. Implement the end 11474 of the current program unit. */ 11475 11476void 11477ffestc_R1103 (ffelexToken name) 11478{ 11479 ffestc_check_simple_ (); 11480 if (ffestc_order_program_ () != FFESTC_orderOK_) 11481 return; 11482 ffestc_labeldef_notloop_ (); 11483 11484 if (name != NULL) 11485 { 11486 if (ffestw_name (ffestw_stack_top ()) == NULL) 11487 { 11488 ffebad_start (FFEBAD_PROGRAM_NOT_NAMED); 11489 ffebad_here (0, ffelex_token_where_line (name), 11490 ffelex_token_where_column (name)); 11491 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 11492 ffebad_finish (); 11493 } 11494 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) 11495 { 11496 ffebad_start (FFEBAD_UNIT_WRONG_NAME); 11497 ffebad_here (0, ffelex_token_where_line (name), 11498 ffelex_token_where_column (name)); 11499 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 11500 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 11501 ffebad_finish (); 11502 } 11503 } 11504 11505 ffestc_shriek_end_program_ (TRUE); 11506} 11507 11508/* ffestc_R1105 -- MODULE statement 11509 11510 ffestc_R1105(name_token); 11511 11512 Make sure ffestc_kind_ identifies an empty block. Make sure name_token 11513 gives a valid name. Implement the beginning of a module. */ 11514 11515#if FFESTR_F90 11516void 11517ffestc_R1105 (ffelexToken name) 11518{ 11519 ffestw b; 11520 11521 assert (name != NULL); 11522 11523 ffestc_check_simple_ (); 11524 if (ffestc_order_unit_ () != FFESTC_orderOK_) 11525 return; 11526 ffestc_labeldef_useless_ (); 11527 11528 ffestc_blocknum_ = 0; 11529 b = ffestw_update (ffestw_push (NULL)); 11530 ffestw_set_top_do (b, NULL); 11531 ffestw_set_state (b, FFESTV_stateMODULE0); 11532 ffestw_set_blocknum (b, ffestc_blocknum_++); 11533 ffestw_set_shriek (b, ffestc_shriek_module_); 11534 ffestw_set_name (b, ffelex_token_use (name)); 11535 11536 ffestd_R1105 (name); 11537} 11538 11539/* ffestc_R1106 -- END MODULE statement 11540 11541 ffestc_R1106(name_token); 11542 11543 Make sure ffestc_kind_ identifies the current kind of program unit. If not 11544 NULL, make sure name_token gives the correct name. Implement the end 11545 of the current program unit. */ 11546 11547void 11548ffestc_R1106 (ffelexToken name) 11549{ 11550 ffestc_check_simple_ (); 11551 if (ffestc_order_module_ () != FFESTC_orderOK_) 11552 return; 11553 ffestc_labeldef_useless_ (); 11554 11555 if ((name != NULL) 11556 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) 11557 { 11558 ffebad_start (FFEBAD_UNIT_WRONG_NAME); 11559 ffebad_here (0, ffelex_token_where_line (name), 11560 ffelex_token_where_column (name)); 11561 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 11562 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 11563 ffebad_finish (); 11564 } 11565 11566 ffestc_shriek_module_ (TRUE); 11567} 11568 11569/* ffestc_R1107_start -- USE statement list begin 11570 11571 ffestc_R1107_start(); 11572 11573 Verify that USE is valid here, and begin accepting items in the list. */ 11574 11575void 11576ffestc_R1107_start (ffelexToken name, bool only) 11577{ 11578 ffestc_check_start_ (); 11579 if (ffestc_order_use_ () != FFESTC_orderOK_) 11580 { 11581 ffestc_ok_ = FALSE; 11582 return; 11583 } 11584 ffestc_labeldef_useless_ (); 11585 11586 ffestd_R1107_start (name, only); 11587 11588 ffestc_ok_ = TRUE; 11589} 11590 11591/* ffestc_R1107_item -- USE statement for name 11592 11593 ffestc_R1107_item(local_token,use_token); 11594 11595 Make sure name_token identifies a valid object to be USEed. local_token 11596 may be NULL if _start_ was called with only==TRUE. */ 11597 11598void 11599ffestc_R1107_item (ffelexToken local, ffelexToken use) 11600{ 11601 ffestc_check_item_ (); 11602 assert (use != NULL); 11603 if (!ffestc_ok_) 11604 return; 11605 11606 ffestd_R1107_item (local, use); 11607} 11608 11609/* ffestc_R1107_finish -- USE statement list complete 11610 11611 ffestc_R1107_finish(); 11612 11613 Just wrap up any local activities. */ 11614 11615void 11616ffestc_R1107_finish () 11617{ 11618 ffestc_check_finish_ (); 11619 if (!ffestc_ok_) 11620 return; 11621 11622 ffestd_R1107_finish (); 11623} 11624 11625#endif 11626/* ffestc_R1111 -- BLOCK DATA statement 11627 11628 ffestc_R1111(name_token); 11629 11630 Make sure ffestc_kind_ identifies no current program unit. If not 11631 NULL, make sure name_token gives a valid name. Implement the beginning 11632 of a block data program unit. */ 11633 11634void 11635ffestc_R1111 (ffelexToken name) 11636{ 11637 ffestw b; 11638 ffesymbol s; 11639 11640 ffestc_check_simple_ (); 11641 if (ffestc_order_unit_ () != FFESTC_orderOK_) 11642 return; 11643 ffestc_labeldef_useless_ (); 11644 11645 ffestc_blocknum_ = 0; 11646 b = ffestw_update (ffestw_push (NULL)); 11647 ffestw_set_top_do (b, NULL); 11648 ffestw_set_state (b, FFESTV_stateBLOCKDATA0); 11649 ffestw_set_blocknum (b, ffestc_blocknum_++); 11650 ffestw_set_shriek (b, ffestc_shriek_blockdata_); 11651 11652 if (name == NULL) 11653 ffestw_set_name (b, NULL); 11654 else 11655 ffestw_set_name (b, ffelex_token_use (name)); 11656 11657 s = ffesymbol_declare_blockdataunit (name, 11658 ffelex_token_where_line (ffesta_tokens[0]), 11659 ffelex_token_where_column (ffesta_tokens[0])); 11660 11661 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 11662 { 11663 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 11664 ffesymbol_set_info (s, 11665 ffeinfo_new (FFEINFO_basictypeNONE, 11666 FFEINFO_kindtypeNONE, 11667 0, 11668 FFEINFO_kindBLOCKDATA, 11669 FFEINFO_whereLOCAL, 11670 FFETARGET_charactersizeNONE)); 11671 ffesymbol_signal_unreported (s); 11672 } 11673 else 11674 ffesymbol_error (s, name); 11675 11676 ffestd_R1111 (s, name); 11677} 11678 11679/* ffestc_R1112 -- END BLOCK DATA statement 11680 11681 ffestc_R1112(name_token); 11682 11683 Make sure ffestc_kind_ identifies the current kind of program unit. If not 11684 NULL, make sure name_token gives the correct name. Implement the end 11685 of the current program unit. */ 11686 11687void 11688ffestc_R1112 (ffelexToken name) 11689{ 11690 ffestc_check_simple_ (); 11691 if (ffestc_order_blockdata_ () != FFESTC_orderOK_) 11692 return; 11693 ffestc_labeldef_useless_ (); 11694 11695 if (name != NULL) 11696 { 11697 if (ffestw_name (ffestw_stack_top ()) == NULL) 11698 { 11699 ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED); 11700 ffebad_here (0, ffelex_token_where_line (name), 11701 ffelex_token_where_column (name)); 11702 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 11703 ffebad_finish (); 11704 } 11705 else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) 11706 { 11707 ffebad_start (FFEBAD_UNIT_WRONG_NAME); 11708 ffebad_here (0, ffelex_token_where_line (name), 11709 ffelex_token_where_column (name)); 11710 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 11711 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 11712 ffebad_finish (); 11713 } 11714 } 11715 11716 ffestc_shriek_blockdata_ (TRUE); 11717} 11718 11719/* ffestc_R1202 -- INTERFACE statement 11720 11721 ffestc_R1202(operator,defined_name); 11722 11723 Make sure ffestc_kind_ identifies an INTERFACE block. 11724 Implement the end of the current interface. 11725 11726 15-May-90 JCB 1.1 11727 Allow no operator or name to mean INTERFACE by itself; missed this 11728 valid form when originally doing syntactic analysis code. */ 11729 11730#if FFESTR_F90 11731void 11732ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name) 11733{ 11734 ffestw b; 11735 11736 ffestc_check_simple_ (); 11737 if (ffestc_order_interfacespec_ () != FFESTC_orderOK_) 11738 return; 11739 ffestc_labeldef_useless_ (); 11740 11741 b = ffestw_update (ffestw_push (NULL)); 11742 ffestw_set_top_do (b, NULL); 11743 ffestw_set_state (b, FFESTV_stateINTERFACE0); 11744 ffestw_set_blocknum (b, 0); 11745 ffestw_set_shriek (b, ffestc_shriek_interface_); 11746 11747 if ((operator == FFESTP_definedoperatorNone) && (name == NULL)) 11748 ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE 11749 PROCEDURE. */ 11750 else 11751 ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */ 11752 11753 ffestd_R1202 (operator, name); 11754 11755 ffe_init_4 (); 11756} 11757 11758/* ffestc_R1203 -- END INTERFACE statement 11759 11760 ffestc_R1203(); 11761 11762 Make sure ffestc_kind_ identifies an INTERFACE block. 11763 Implement the end of the current interface. */ 11764 11765void 11766ffestc_R1203 () 11767{ 11768 ffestc_check_simple_ (); 11769 if (ffestc_order_interface_ () != FFESTC_orderOK_) 11770 return; 11771 ffestc_labeldef_useless_ (); 11772 11773 ffestc_shriek_interface_ (TRUE); 11774 11775 ffe_terminate_4 (); 11776} 11777 11778/* ffestc_R1205_start -- MODULE PROCEDURE statement list begin 11779 11780 ffestc_R1205_start(); 11781 11782 Verify that MODULE PROCEDURE is valid here, and begin accepting items in 11783 the list. */ 11784 11785void 11786ffestc_R1205_start () 11787{ 11788 ffestc_check_start_ (); 11789 if (ffestc_order_interface_ () != FFESTC_orderOK_) 11790 { 11791 ffestc_ok_ = FALSE; 11792 return; 11793 } 11794 ffestc_labeldef_useless_ (); 11795 11796 if (ffestw_substate (ffestw_stack_top ()) == 0) 11797 { 11798 ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE); 11799 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 11800 ffelex_token_where_column (ffesta_tokens[0])); 11801 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 11802 ffebad_finish (); 11803 ffestc_ok_ = FALSE; 11804 return; 11805 } 11806 11807 if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0) 11808 { 11809 ffestw_update (NULL); /* Update state line/col info. */ 11810 ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1); 11811 } 11812 11813 ffestd_R1205_start (); 11814 11815 ffestc_ok_ = TRUE; 11816} 11817 11818/* ffestc_R1205_item -- MODULE PROCEDURE statement for name 11819 11820 ffestc_R1205_item(name_token); 11821 11822 Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */ 11823 11824void 11825ffestc_R1205_item (ffelexToken name) 11826{ 11827 ffestc_check_item_ (); 11828 assert (name != NULL); 11829 if (!ffestc_ok_) 11830 return; 11831 11832 ffestd_R1205_item (name); 11833} 11834 11835/* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete 11836 11837 ffestc_R1205_finish(); 11838 11839 Just wrap up any local activities. */ 11840 11841void 11842ffestc_R1205_finish () 11843{ 11844 ffestc_check_finish_ (); 11845 if (!ffestc_ok_) 11846 return; 11847 11848 ffestd_R1205_finish (); 11849} 11850 11851#endif 11852/* ffestc_R1207_start -- EXTERNAL statement list begin 11853 11854 ffestc_R1207_start(); 11855 11856 Verify that EXTERNAL is valid here, and begin accepting items in the list. */ 11857 11858void 11859ffestc_R1207_start () 11860{ 11861 ffestc_check_start_ (); 11862 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 11863 { 11864 ffestc_ok_ = FALSE; 11865 return; 11866 } 11867 ffestc_labeldef_useless_ (); 11868 11869 ffestd_R1207_start (); 11870 11871 ffestc_ok_ = TRUE; 11872} 11873 11874/* ffestc_R1207_item -- EXTERNAL statement for name 11875 11876 ffestc_R1207_item(name_token); 11877 11878 Make sure name_token identifies a valid object to be EXTERNALd. */ 11879 11880void 11881ffestc_R1207_item (ffelexToken name) 11882{ 11883 ffesymbol s; 11884 ffesymbolAttrs sa; 11885 ffesymbolAttrs na; 11886 11887 ffestc_check_item_ (); 11888 assert (name != NULL); 11889 if (!ffestc_ok_) 11890 return; 11891 11892 s = ffesymbol_declare_local (name, FALSE); 11893 sa = ffesymbol_attrs (s); 11894 11895 /* Figure out what kind of object we've got based on previous declarations 11896 of or references to the object. */ 11897 11898 if (!ffesymbol_is_specable (s)) 11899 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 11900 else if (sa & FFESYMBOL_attrsANY) 11901 na = FFESYMBOL_attrsANY; 11902 else if (!(sa & ~(FFESYMBOL_attrsDUMMY 11903 | FFESYMBOL_attrsTYPE))) 11904 na = sa | FFESYMBOL_attrsEXTERNAL; 11905 else 11906 na = FFESYMBOL_attrsetNONE; 11907 11908 /* Now see what we've got for a new object: NONE means a new error cropped 11909 up; ANY means an old error to be ignored; otherwise, everything's ok, 11910 update the object (symbol) and continue on. */ 11911 11912 if (na == FFESYMBOL_attrsetNONE) 11913 ffesymbol_error (s, name); 11914 else if (!(na & FFESYMBOL_attrsANY)) 11915 { 11916 ffesymbol_set_attrs (s, na); 11917 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 11918 ffesymbol_set_explicitwhere (s, TRUE); 11919 ffesymbol_reference (s, name, FALSE); 11920 ffesymbol_signal_unreported (s); 11921 } 11922 11923 ffestd_R1207_item (name); 11924} 11925 11926/* ffestc_R1207_finish -- EXTERNAL statement list complete 11927 11928 ffestc_R1207_finish(); 11929 11930 Just wrap up any local activities. */ 11931 11932void 11933ffestc_R1207_finish () 11934{ 11935 ffestc_check_finish_ (); 11936 if (!ffestc_ok_) 11937 return; 11938 11939 ffestd_R1207_finish (); 11940} 11941 11942/* ffestc_R1208_start -- INTRINSIC statement list begin 11943 11944 ffestc_R1208_start(); 11945 11946 Verify that INTRINSIC is valid here, and begin accepting items in the list. */ 11947 11948void 11949ffestc_R1208_start () 11950{ 11951 ffestc_check_start_ (); 11952 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 11953 { 11954 ffestc_ok_ = FALSE; 11955 return; 11956 } 11957 ffestc_labeldef_useless_ (); 11958 11959 ffestd_R1208_start (); 11960 11961 ffestc_ok_ = TRUE; 11962} 11963 11964/* ffestc_R1208_item -- INTRINSIC statement for name 11965 11966 ffestc_R1208_item(name_token); 11967 11968 Make sure name_token identifies a valid object to be INTRINSICd. */ 11969 11970void 11971ffestc_R1208_item (ffelexToken name) 11972{ 11973 ffesymbol s; 11974 ffesymbolAttrs sa; 11975 ffesymbolAttrs na; 11976 ffeintrinGen gen; 11977 ffeintrinSpec spec; 11978 ffeintrinImp imp; 11979 11980 ffestc_check_item_ (); 11981 assert (name != NULL); 11982 if (!ffestc_ok_) 11983 return; 11984 11985 s = ffesymbol_declare_local (name, TRUE); 11986 sa = ffesymbol_attrs (s); 11987 11988 /* Figure out what kind of object we've got based on previous declarations 11989 of or references to the object. */ 11990 11991 if (!ffesymbol_is_specable (s)) 11992 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 11993 else if (sa & FFESYMBOL_attrsANY) 11994 na = sa; 11995 else if (!(sa & ~FFESYMBOL_attrsTYPE)) 11996 { 11997 if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE, 11998 &gen, &spec, &imp) 11999 && ((imp == FFEINTRIN_impNONE) 12000#if 0 /* Don't bother with this for now. */ 12001 || ((ffeintrin_basictype (spec) 12002 == ffesymbol_basictype (s)) 12003 && (ffeintrin_kindtype (spec) 12004 == ffesymbol_kindtype (s))) 12005#else 12006 || 1 12007#endif 12008 || !(sa & FFESYMBOL_attrsTYPE))) 12009 na = sa | FFESYMBOL_attrsINTRINSIC; 12010 else 12011 na = FFESYMBOL_attrsetNONE; 12012 } 12013 else 12014 na = FFESYMBOL_attrsetNONE; 12015 12016 /* Now see what we've got for a new object: NONE means a new error cropped 12017 up; ANY means an old error to be ignored; otherwise, everything's ok, 12018 update the object (symbol) and continue on. */ 12019 12020 if (na == FFESYMBOL_attrsetNONE) 12021 ffesymbol_error (s, name); 12022 else if (!(na & FFESYMBOL_attrsANY)) 12023 { 12024 ffesymbol_set_attrs (s, na); 12025 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 12026 ffesymbol_set_generic (s, gen); 12027 ffesymbol_set_specific (s, spec); 12028 ffesymbol_set_implementation (s, imp); 12029 ffesymbol_set_info (s, 12030 ffeinfo_new (ffesymbol_basictype (s), 12031 ffesymbol_kindtype (s), 12032 0, 12033 FFEINFO_kindNONE, 12034 FFEINFO_whereINTRINSIC, 12035 ffesymbol_size (s))); 12036 ffesymbol_set_explicitwhere (s, TRUE); 12037 ffesymbol_reference (s, name, TRUE); 12038 } 12039 12040 ffesymbol_signal_unreported (s); 12041 12042 ffestd_R1208_item (name); 12043} 12044 12045/* ffestc_R1208_finish -- INTRINSIC statement list complete 12046 12047 ffestc_R1208_finish(); 12048 12049 Just wrap up any local activities. */ 12050 12051void 12052ffestc_R1208_finish () 12053{ 12054 ffestc_check_finish_ (); 12055 if (!ffestc_ok_) 12056 return; 12057 12058 ffestd_R1208_finish (); 12059} 12060 12061/* ffestc_R1212 -- CALL statement 12062 12063 ffestc_R1212(expr,expr_token); 12064 12065 Make sure statement is valid here; implement. */ 12066 12067void 12068ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED) 12069{ 12070 ffebld item; /* ITEM. */ 12071 ffebld labexpr; /* LABTOK=>LABTER. */ 12072 ffelab label; 12073 bool ok; /* TRUE if all LABTOKs were ok. */ 12074 bool ok1; /* TRUE if a particular LABTOK is ok. */ 12075 12076 ffestc_check_simple_ (); 12077 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 12078 return; 12079 ffestc_labeldef_branch_begin_ (); 12080 12081 if (ffebld_op (expr) != FFEBLD_opSUBRREF) 12082 ffestd_R841 (FALSE); /* CONTINUE. */ 12083 else 12084 { 12085 ok = TRUE; 12086 12087 for (item = ffebld_right (expr); 12088 item != NULL; 12089 item = ffebld_trail (item)) 12090 { 12091 if (((labexpr = ffebld_head (item)) != NULL) 12092 && (ffebld_op (labexpr) == FFEBLD_opLABTOK)) 12093 { 12094 ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr), 12095 &label); 12096 ffelex_token_kill (ffebld_labtok (labexpr)); 12097 if (!ok1) 12098 { 12099 label = NULL; 12100 ok = FALSE; 12101 } 12102 ffebld_set_op (labexpr, FFEBLD_opLABTER); 12103 ffebld_set_labter (labexpr, label); 12104 } 12105 } 12106 12107 if (ok) 12108 ffestd_R1212 (expr); 12109 } 12110 12111 if (ffestc_shriek_after1_ != NULL) 12112 (*ffestc_shriek_after1_) (TRUE); 12113 ffestc_labeldef_branch_end_ (); 12114} 12115 12116/* ffestc_R1213 -- Defined assignment statement 12117 12118 ffestc_R1213(dest_expr,source_expr,source_token); 12119 12120 Make sure the assignment is valid. */ 12121 12122#if FFESTR_F90 12123void 12124ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token) 12125{ 12126 ffestc_check_simple_ (); 12127 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 12128 return; 12129 ffestc_labeldef_branch_begin_ (); 12130 12131 ffestd_R1213 (dest, source); 12132 12133 if (ffestc_shriek_after1_ != NULL) 12134 (*ffestc_shriek_after1_) (TRUE); 12135 ffestc_labeldef_branch_end_ (); 12136} 12137 12138#endif 12139/* ffestc_R1219 -- FUNCTION statement 12140 12141 ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent, 12142 recursive); 12143 12144 Make sure statement is valid here, register arguments for the 12145 function name, and so on. 12146 12147 06-Apr-90 JCB 2.0 12148 Added the kind, len, and recursive arguments. */ 12149 12150void 12151ffestc_R1219 (ffelexToken funcname, ffesttTokenList args, 12152 ffelexToken final UNUSED, ffestpType type, ffebld kind, 12153 ffelexToken kindt, ffebld len, ffelexToken lent, 12154 ffelexToken recursive, ffelexToken result) 12155{ 12156 ffestw b; 12157 ffesymbol s; 12158 ffesymbol fs; /* FUNCTION symbol when dealing with RESULT 12159 symbol. */ 12160 ffesymbolAttrs sa; 12161 ffesymbolAttrs na; 12162 ffelexToken res; 12163 bool separate_result; 12164 12165 assert ((funcname != NULL) 12166 && (ffelex_token_type (funcname) == FFELEX_typeNAME)); 12167 12168 ffestc_check_simple_ (); 12169 if (ffestc_order_iface_ () != FFESTC_orderOK_) 12170 return; 12171 ffestc_labeldef_useless_ (); 12172 12173 ffestc_blocknum_ = 0; 12174 ffesta_is_entry_valid = 12175 (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL); 12176 b = ffestw_update (ffestw_push (NULL)); 12177 ffestw_set_top_do (b, NULL); 12178 ffestw_set_state (b, FFESTV_stateFUNCTION0); 12179 ffestw_set_blocknum (b, ffestc_blocknum_++); 12180 ffestw_set_shriek (b, ffestc_shriek_function_); 12181 ffestw_set_name (b, ffelex_token_use (funcname)); 12182 12183 if (type == FFESTP_typeNone) 12184 { 12185 ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE; 12186 ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE; 12187 ffestc_local_.decl.size = FFETARGET_charactersizeNONE; 12188 } 12189 else 12190 { 12191 ffestc_establish_declstmt_ (type, ffesta_tokens[0], 12192 kind, kindt, len, lent); 12193 ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL); 12194 } 12195 12196 separate_result = (result != NULL) 12197 && (ffelex_token_strcmp (funcname, result) != 0); 12198 12199 if (separate_result) 12200 fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */ 12201 else 12202 fs = ffesymbol_declare_funcunit (funcname); /* Global only. */ 12203 12204 if (ffesymbol_state (fs) == FFESYMBOL_stateNONE) 12205 { 12206 ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD); 12207 ffesymbol_signal_unreported (fs); 12208 12209 /* Note that .basic_type and .kind_type might be NONE here. */ 12210 12211 ffesymbol_set_info (fs, 12212 ffeinfo_new (ffestc_local_.decl.basic_type, 12213 ffestc_local_.decl.kind_type, 12214 0, 12215 FFEINFO_kindFUNCTION, 12216 FFEINFO_whereLOCAL, 12217 ffestc_local_.decl.size)); 12218 12219 /* Check whether the type info fits the filewide expectations; 12220 set ok flag accordingly. */ 12221 12222 ffesymbol_reference (fs, funcname, FALSE); 12223 if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY) 12224 ffestc_parent_ok_ = FALSE; 12225 else 12226 ffestc_parent_ok_ = TRUE; 12227 } 12228 else 12229 { 12230 if (ffesymbol_kind (fs) != FFEINFO_kindANY) 12231 ffesymbol_error (fs, funcname); 12232 ffestc_parent_ok_ = FALSE; 12233 } 12234 12235 if (ffestc_parent_ok_) 12236 { 12237 ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom); 12238 ffestt_tokenlist_drive (args, ffestc_promote_dummy_); 12239 ffebld_end_list (&ffestc_local_.dummy.list_bottom); 12240 } 12241 12242 if (result == NULL) 12243 res = funcname; 12244 else 12245 res = result; 12246 12247 s = ffesymbol_declare_funcresult (res); 12248 sa = ffesymbol_attrs (s); 12249 12250 /* Figure out what kind of object we've got based on previous declarations 12251 of or references to the object. */ 12252 12253 if (sa & FFESYMBOL_attrsANY) 12254 na = FFESYMBOL_attrsANY; 12255 else if (ffesymbol_state (s) != FFESYMBOL_stateNONE) 12256 na = FFESYMBOL_attrsetNONE; 12257 else 12258 { 12259 na = FFESYMBOL_attrsRESULT; 12260 if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE) 12261 { 12262 na |= FFESYMBOL_attrsTYPE; 12263 if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER) 12264 && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE)) 12265 na |= FFESYMBOL_attrsANYLEN; 12266 } 12267 } 12268 12269 /* Now see what we've got for a new object: NONE means a new error cropped 12270 up; ANY means an old error to be ignored; otherwise, everything's ok, 12271 update the object (symbol) and continue on. */ 12272 12273 if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE) 12274 { 12275 if (!(na & FFESYMBOL_attrsANY)) 12276 ffesymbol_error (s, res); 12277 ffesymbol_set_funcresult (fs, NULL); 12278 ffesymbol_set_funcresult (s, NULL); 12279 ffestc_parent_ok_ = FALSE; 12280 } 12281 else 12282 { 12283 ffesymbol_set_attrs (s, na); 12284 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 12285 ffesymbol_set_funcresult (fs, s); 12286 ffesymbol_set_funcresult (s, fs); 12287 if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE) 12288 { 12289 ffesymbol_set_info (s, 12290 ffeinfo_new (ffestc_local_.decl.basic_type, 12291 ffestc_local_.decl.kind_type, 12292 0, 12293 FFEINFO_kindNONE, 12294 FFEINFO_whereNONE, 12295 ffestc_local_.decl.size)); 12296 } 12297 } 12298 12299 ffesymbol_signal_unreported (fs); 12300 12301 ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent, 12302 (recursive != NULL), result, separate_result); 12303} 12304 12305/* ffestc_R1221 -- END FUNCTION statement 12306 12307 ffestc_R1221(name_token); 12308 12309 Make sure ffestc_kind_ identifies the current kind of program unit. If 12310 not NULL, make sure name_token gives the correct name. Implement the end 12311 of the current program unit. */ 12312 12313void 12314ffestc_R1221 (ffelexToken name) 12315{ 12316 ffestc_check_simple_ (); 12317 if (ffestc_order_function_ () != FFESTC_orderOK_) 12318 return; 12319 ffestc_labeldef_notloop_ (); 12320 12321 if ((name != NULL) 12322 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) 12323 { 12324 ffebad_start (FFEBAD_UNIT_WRONG_NAME); 12325 ffebad_here (0, ffelex_token_where_line (name), 12326 ffelex_token_where_column (name)); 12327 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 12328 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 12329 ffebad_finish (); 12330 } 12331 12332 ffestc_shriek_function_ (TRUE); 12333} 12334 12335/* ffestc_R1223 -- SUBROUTINE statement 12336 12337 ffestc_R1223(subrname,arglist,ending_token,recursive_token); 12338 12339 Make sure statement is valid here, register arguments for the 12340 subroutine name, and so on. 12341 12342 06-Apr-90 JCB 2.0 12343 Added the recursive argument. */ 12344 12345void 12346ffestc_R1223 (ffelexToken subrname, ffesttTokenList args, 12347 ffelexToken final, ffelexToken recursive) 12348{ 12349 ffestw b; 12350 ffesymbol s; 12351 12352 assert ((subrname != NULL) 12353 && (ffelex_token_type (subrname) == FFELEX_typeNAME)); 12354 12355 ffestc_check_simple_ (); 12356 if (ffestc_order_iface_ () != FFESTC_orderOK_) 12357 return; 12358 ffestc_labeldef_useless_ (); 12359 12360 ffestc_blocknum_ = 0; 12361 ffesta_is_entry_valid 12362 = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL); 12363 b = ffestw_update (ffestw_push (NULL)); 12364 ffestw_set_top_do (b, NULL); 12365 ffestw_set_state (b, FFESTV_stateSUBROUTINE0); 12366 ffestw_set_blocknum (b, ffestc_blocknum_++); 12367 ffestw_set_shriek (b, ffestc_shriek_subroutine_); 12368 ffestw_set_name (b, ffelex_token_use (subrname)); 12369 12370 s = ffesymbol_declare_subrunit (subrname); 12371 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 12372 { 12373 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 12374 ffesymbol_set_info (s, 12375 ffeinfo_new (FFEINFO_basictypeNONE, 12376 FFEINFO_kindtypeNONE, 12377 0, 12378 FFEINFO_kindSUBROUTINE, 12379 FFEINFO_whereLOCAL, 12380 FFETARGET_charactersizeNONE)); 12381 ffestc_parent_ok_ = TRUE; 12382 } 12383 else 12384 { 12385 if (ffesymbol_kind (s) != FFEINFO_kindANY) 12386 ffesymbol_error (s, subrname); 12387 ffestc_parent_ok_ = FALSE; 12388 } 12389 12390 if (ffestc_parent_ok_) 12391 { 12392 ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom); 12393 ffestt_tokenlist_drive (args, ffestc_promote_dummy_); 12394 ffebld_end_list (&ffestc_local_.dummy.list_bottom); 12395 } 12396 12397 ffesymbol_signal_unreported (s); 12398 12399 ffestd_R1223 (s, subrname, args, final, (recursive != NULL)); 12400} 12401 12402/* ffestc_R1225 -- END SUBROUTINE statement 12403 12404 ffestc_R1225(name_token); 12405 12406 Make sure ffestc_kind_ identifies the current kind of program unit. If 12407 not NULL, make sure name_token gives the correct name. Implement the end 12408 of the current program unit. */ 12409 12410void 12411ffestc_R1225 (ffelexToken name) 12412{ 12413 ffestc_check_simple_ (); 12414 if (ffestc_order_subroutine_ () != FFESTC_orderOK_) 12415 return; 12416 ffestc_labeldef_notloop_ (); 12417 12418 if ((name != NULL) 12419 && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) 12420 { 12421 ffebad_start (FFEBAD_UNIT_WRONG_NAME); 12422 ffebad_here (0, ffelex_token_where_line (name), 12423 ffelex_token_where_column (name)); 12424 ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), 12425 ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); 12426 ffebad_finish (); 12427 } 12428 12429 ffestc_shriek_subroutine_ (TRUE); 12430} 12431 12432/* ffestc_R1226 -- ENTRY statement 12433 12434 ffestc_R1226(entryname,arglist,ending_token); 12435 12436 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the 12437 entry point name, and so on. */ 12438 12439void 12440ffestc_R1226 (ffelexToken entryname, ffesttTokenList args, 12441 ffelexToken final UNUSED) 12442{ 12443 ffesymbol s; 12444 ffesymbol fs; 12445 ffesymbolAttrs sa; 12446 ffesymbolAttrs na; 12447 bool in_spec; /* TRUE if further specification statements 12448 may follow, FALSE if executable stmts. */ 12449 bool in_func; /* TRUE if ENTRY is a FUNCTION, not 12450 SUBROUTINE. */ 12451 12452 assert ((entryname != NULL) 12453 && (ffelex_token_type (entryname) == FFELEX_typeNAME)); 12454 12455 ffestc_check_simple_ (); 12456 if (ffestc_order_entry_ () != FFESTC_orderOK_) 12457 return; 12458 ffestc_labeldef_useless_ (); 12459 12460 switch (ffestw_state (ffestw_stack_top ())) 12461 { 12462 case FFESTV_stateFUNCTION1: 12463 case FFESTV_stateFUNCTION2: 12464 case FFESTV_stateFUNCTION3: 12465 in_func = TRUE; 12466 in_spec = TRUE; 12467 break; 12468 12469 case FFESTV_stateFUNCTION4: 12470 in_func = TRUE; 12471 in_spec = FALSE; 12472 break; 12473 12474 case FFESTV_stateSUBROUTINE1: 12475 case FFESTV_stateSUBROUTINE2: 12476 case FFESTV_stateSUBROUTINE3: 12477 in_func = FALSE; 12478 in_spec = TRUE; 12479 break; 12480 12481 case FFESTV_stateSUBROUTINE4: 12482 in_func = FALSE; 12483 in_spec = FALSE; 12484 break; 12485 12486 default: 12487 assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL); 12488 in_func = FALSE; 12489 in_spec = FALSE; 12490 break; 12491 } 12492 12493 if (in_func) 12494 fs = ffesymbol_declare_funcunit (entryname); 12495 else 12496 fs = ffesymbol_declare_subrunit (entryname); 12497 12498 if (ffesymbol_state (fs) == FFESYMBOL_stateNONE) 12499 ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD); 12500 else 12501 { 12502 if (ffesymbol_kind (fs) != FFEINFO_kindANY) 12503 ffesymbol_error (fs, entryname); 12504 } 12505 12506 ++ffestc_entry_num_; 12507 12508 ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom); 12509 if (in_spec) 12510 ffestt_tokenlist_drive (args, ffestc_promote_dummy_); 12511 else 12512 ffestt_tokenlist_drive (args, ffestc_promote_execdummy_); 12513 ffebld_end_list (&ffestc_local_.dummy.list_bottom); 12514 12515 if (in_func) 12516 { 12517 s = ffesymbol_declare_funcresult (entryname); 12518 ffesymbol_set_funcresult (fs, s); 12519 ffesymbol_set_funcresult (s, fs); 12520 sa = ffesymbol_attrs (s); 12521 12522 /* Figure out what kind of object we've got based on previous 12523 declarations of or references to the object. */ 12524 12525 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 12526 na = FFESYMBOL_attrsetNONE; 12527 else if (sa & FFESYMBOL_attrsANY) 12528 na = FFESYMBOL_attrsANY; 12529 else if (!(sa & ~(FFESYMBOL_attrsANYLEN 12530 | FFESYMBOL_attrsTYPE))) 12531 na = sa | FFESYMBOL_attrsRESULT; 12532 else 12533 na = FFESYMBOL_attrsetNONE; 12534 12535 /* Now see what we've got for a new object: NONE means a new error 12536 cropped up; ANY means an old error to be ignored; otherwise, 12537 everything's ok, update the object (symbol) and continue on. */ 12538 12539 if (na == FFESYMBOL_attrsetNONE) 12540 { 12541 ffesymbol_error (s, entryname); 12542 ffestc_parent_ok_ = FALSE; 12543 } 12544 else if (na & FFESYMBOL_attrsANY) 12545 { 12546 ffestc_parent_ok_ = FALSE; 12547 } 12548 else 12549 { 12550 ffesymbol_set_attrs (s, na); 12551 if (ffesymbol_state (s) == FFESYMBOL_stateNONE) 12552 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 12553 else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN) 12554 { 12555 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 12556 ffesymbol_set_info (s, 12557 ffeinfo_new (ffesymbol_basictype (s), 12558 ffesymbol_kindtype (s), 12559 0, 12560 FFEINFO_kindENTITY, 12561 FFEINFO_whereRESULT, 12562 ffesymbol_size (s))); 12563 ffesymbol_resolve_intrin (s); 12564 ffestorag_exec_layout (s); 12565 } 12566 } 12567 12568 /* Since ENTRY might appear after executable stmts, do what would have 12569 been done if it hadn't -- give symbol implicit type and 12570 exec-transition it. */ 12571 12572 if (!in_spec && ffesymbol_is_specable (s)) 12573 { 12574 if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */ 12575 ffesymbol_error (s, entryname); 12576 s = ffecom_sym_exec_transition (s); 12577 } 12578 12579 /* Use whatever type info is available for ENTRY to set up type for its 12580 global-name-space function symbol relative. */ 12581 12582 ffesymbol_set_info (fs, 12583 ffeinfo_new (ffesymbol_basictype (s), 12584 ffesymbol_kindtype (s), 12585 0, 12586 FFEINFO_kindFUNCTION, 12587 FFEINFO_whereLOCAL, 12588 ffesymbol_size (s))); 12589 12590 12591 /* Check whether the type info fits the filewide expectations; 12592 set ok flag accordingly. */ 12593 12594 ffesymbol_reference (fs, entryname, FALSE); 12595 12596 /* ~~Question??: 12597 When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be 12598 if FOO and IBAR would normally end up with different types? I think 12599 the answer is that FOO is always given whatever type would be chosen 12600 for IBAR, rather than the other way around, and I think it ends up 12601 working that way for FUNCTION FOO() RESULT(IBAR), but this should be 12602 checked out in all its different combos. Related question is, is 12603 there any way that FOO in either case ends up without type info 12604 filled in? Does anyone care? */ 12605 12606 ffesymbol_signal_unreported (s); 12607 } 12608 else 12609 { 12610 ffesymbol_set_info (fs, 12611 ffeinfo_new (FFEINFO_basictypeNONE, 12612 FFEINFO_kindtypeNONE, 12613 0, 12614 FFEINFO_kindSUBROUTINE, 12615 FFEINFO_whereLOCAL, 12616 FFETARGET_charactersizeNONE)); 12617 } 12618 12619 if (!in_spec) 12620 fs = ffecom_sym_exec_transition (fs); 12621 12622 ffesymbol_signal_unreported (fs); 12623 12624 ffestd_R1226 (fs); 12625} 12626 12627/* ffestc_R1227 -- RETURN statement 12628 12629 ffestc_R1227(expr,expr_token); 12630 12631 Make sure statement is valid here; implement. expr and expr_token are 12632 both NULL if there was no expression. */ 12633 12634void 12635ffestc_R1227 (ffebld expr, ffelexToken expr_token) 12636{ 12637 ffestw b; 12638 12639 ffestc_check_simple_ (); 12640 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 12641 return; 12642 ffestc_labeldef_notloop_begin_ (); 12643 12644 for (b = ffestw_stack_top (); ; b = ffestw_previous (b)) 12645 { 12646 switch (ffestw_state (b)) 12647 { 12648 case FFESTV_statePROGRAM4: 12649 case FFESTV_stateSUBROUTINE4: 12650 case FFESTV_stateFUNCTION4: 12651 goto base; /* :::::::::::::::::::: */ 12652 12653 case FFESTV_stateNIL: 12654 assert ("bad state" == NULL); 12655 break; 12656 12657 default: 12658 break; 12659 } 12660 } 12661 12662 base: 12663 switch (ffestw_state (b)) 12664 { 12665 case FFESTV_statePROGRAM4: 12666 if (ffe_is_pedantic ()) 12667 { 12668 ffebad_start (FFEBAD_RETURN_IN_MAIN); 12669 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 12670 ffelex_token_where_column (ffesta_tokens[0])); 12671 ffebad_finish (); 12672 } 12673 if (expr != NULL) 12674 { 12675 ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM); 12676 ffebad_here (0, ffelex_token_where_line (expr_token), 12677 ffelex_token_where_column (expr_token)); 12678 ffebad_finish (); 12679 expr = NULL; 12680 } 12681 break; 12682 12683 case FFESTV_stateSUBROUTINE4: 12684 break; 12685 12686 case FFESTV_stateFUNCTION4: 12687 if (expr != NULL) 12688 { 12689 ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION); 12690 ffebad_here (0, ffelex_token_where_line (expr_token), 12691 ffelex_token_where_column (expr_token)); 12692 ffebad_finish (); 12693 expr = NULL; 12694 } 12695 break; 12696 12697 default: 12698 assert ("bad state #2" == NULL); 12699 break; 12700 } 12701 12702 ffestd_R1227 (expr); 12703 12704 if (ffestc_shriek_after1_ != NULL) 12705 (*ffestc_shriek_after1_) (TRUE); 12706 12707 /* notloop's that are actionif's can be the target of a loop-end 12708 statement if they're in the "then" part of a logical IF, as 12709 in "DO 10", "10 IF (...) RETURN". */ 12710 12711 ffestc_labeldef_branch_end_ (); 12712} 12713 12714/* ffestc_R1228 -- CONTAINS statement 12715 12716 ffestc_R1228(); */ 12717 12718#if FFESTR_F90 12719void 12720ffestc_R1228 () 12721{ 12722 ffestc_check_simple_ (); 12723 if (ffestc_order_contains_ () != FFESTC_orderOK_) 12724 return; 12725 ffestc_labeldef_useless_ (); 12726 12727 ffestd_R1228 (); 12728 12729 ffe_terminate_3 (); 12730 ffe_init_3 (); 12731} 12732 12733#endif 12734/* ffestc_R1229_start -- STMTFUNCTION statement begin 12735 12736 ffestc_R1229_start(func_name,func_arg_list,close_paren); 12737 12738 Verify that STMTFUNCTION is valid here, establish func_arg_list in a new 12739 "live" scope within the current scope, and expect the actual expression 12740 (or NULL) in ffestc_R1229_finish. The reason there are two ffestc 12741 functions to handle this is so the scope can be established, allowing 12742 ffeexpr to assign proper characteristics to references to the dummy 12743 arguments. */ 12744 12745void 12746ffestc_R1229_start (ffelexToken name, ffesttTokenList args, 12747 ffelexToken final UNUSED) 12748{ 12749 ffesymbol s; 12750 ffesymbolAttrs sa; 12751 ffesymbolAttrs na; 12752 12753 ffestc_check_start_ (); 12754 if (ffestc_order_sfunc_ () != FFESTC_orderOK_) 12755 { 12756 ffestc_ok_ = FALSE; 12757 return; 12758 } 12759 ffestc_labeldef_useless_ (); 12760 12761 assert (name != NULL); 12762 assert (args != NULL); 12763 12764 s = ffesymbol_declare_local (name, FALSE); 12765 sa = ffesymbol_attrs (s); 12766 12767 /* Figure out what kind of object we've got based on previous declarations 12768 of or references to the object. */ 12769 12770 if (!ffesymbol_is_specable (s)) 12771 na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ 12772 else if (sa & FFESYMBOL_attrsANY) 12773 na = FFESYMBOL_attrsANY; 12774 else if (!(sa & ~FFESYMBOL_attrsTYPE)) 12775 na = sa | FFESYMBOL_attrsSFUNC; 12776 else 12777 na = FFESYMBOL_attrsetNONE; 12778 12779 /* Now see what we've got for a new object: NONE means a new error cropped 12780 up; ANY means an old error to be ignored; otherwise, everything's ok, 12781 update the object (symbol) and continue on. */ 12782 12783 if (na == FFESYMBOL_attrsetNONE) 12784 { 12785 ffesymbol_error (s, name); 12786 ffestc_parent_ok_ = FALSE; 12787 } 12788 else if (na & FFESYMBOL_attrsANY) 12789 ffestc_parent_ok_ = FALSE; 12790 else 12791 { 12792 ffesymbol_set_attrs (s, na); 12793 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 12794 if (!ffeimplic_establish_symbol (s) 12795 || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) 12796 && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))) 12797 { 12798 ffesymbol_error (s, ffesta_tokens[0]); 12799 ffestc_parent_ok_ = FALSE; 12800 } 12801 else 12802 { 12803 /* Tell ffeexpr that sfunc def is in progress. */ 12804 ffesymbol_set_sfexpr (s, ffebld_new_any ()); 12805 ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ()); 12806 ffestc_parent_ok_ = TRUE; 12807 } 12808 } 12809 12810 ffe_init_4 (); 12811 12812 if (ffestc_parent_ok_) 12813 { 12814 ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom); 12815 ffestc_sfdummy_argno_ = 0; 12816 ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_); 12817 ffebld_end_list (&ffestc_local_.dummy.list_bottom); 12818 } 12819 12820 ffestc_local_.sfunc.symbol = s; 12821 12822 ffestd_R1229_start (name, args); 12823 12824 ffestc_ok_ = TRUE; 12825} 12826 12827/* ffestc_R1229_finish -- STMTFUNCTION statement list complete 12828 12829 ffestc_R1229_finish(expr,expr_token); 12830 12831 If expr is NULL, an error occurred parsing the expansion expression, so 12832 just cancel the effects of ffestc_R1229_start and pretend nothing 12833 happened. Otherwise, install the expression as the expansion for the 12834 statement function named in _start_, then clean up. */ 12835 12836void 12837ffestc_R1229_finish (ffebld expr, ffelexToken expr_token) 12838{ 12839 ffestc_check_finish_ (); 12840 if (!ffestc_ok_) 12841 return; 12842 12843 if (ffestc_parent_ok_ && (expr != NULL)) 12844 ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol, 12845 ffeexpr_convert_to_sym (expr, 12846 expr_token, 12847 ffestc_local_.sfunc.symbol, 12848 ffesta_tokens[0])); 12849 12850 ffestd_R1229_finish (ffestc_local_.sfunc.symbol); 12851 12852 ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol); 12853 12854 ffe_terminate_4 (); 12855} 12856 12857/* ffestc_S3P4 -- INCLUDE line 12858 12859 ffestc_S3P4(filename,filename_token); 12860 12861 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */ 12862 12863void 12864ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED) 12865{ 12866 ffestc_check_simple_ (); 12867 ffestc_labeldef_invalid_ (); 12868 12869 ffestd_S3P4 (filename); 12870} 12871 12872/* ffestc_V003_start -- STRUCTURE statement list begin 12873 12874 ffestc_V003_start(structure_name); 12875 12876 Verify that STRUCTURE is valid here, and begin accepting items in the list. */ 12877 12878#if FFESTR_VXT 12879void 12880ffestc_V003_start (ffelexToken structure_name) 12881{ 12882 ffestw b; 12883 12884 ffestc_check_start_ (); 12885 if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_) 12886 { 12887 ffestc_ok_ = FALSE; 12888 return; 12889 } 12890 ffestc_labeldef_useless_ (); 12891 12892 switch (ffestw_state (ffestw_stack_top ())) 12893 { 12894 case FFESTV_stateSTRUCTURE: 12895 case FFESTV_stateMAP: 12896 ffestc_local_.V003.list_state = 2; /* Require at least one field 12897 name. */ 12898 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one 12899 member. */ 12900 break; 12901 12902 default: 12903 ffestc_local_.V003.list_state = 0; /* No field names required. */ 12904 if (structure_name == NULL) 12905 { 12906 ffebad_start (FFEBAD_STRUCT_MISSING_NAME); 12907 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 12908 ffelex_token_where_column (ffesta_tokens[0])); 12909 ffebad_finish (); 12910 } 12911 break; 12912 } 12913 12914 b = ffestw_update (ffestw_push (NULL)); 12915 ffestw_set_top_do (b, NULL); 12916 ffestw_set_state (b, FFESTV_stateSTRUCTURE); 12917 ffestw_set_blocknum (b, 0); 12918 ffestw_set_shriek (b, ffestc_shriek_structure_); 12919 ffestw_set_substate (b, 0); /* No field-declarations seen yet. */ 12920 12921 ffestd_V003_start (structure_name); 12922 12923 ffestc_ok_ = TRUE; 12924} 12925 12926/* ffestc_V003_item -- STRUCTURE statement for object-name 12927 12928 ffestc_V003_item(name_token,dim_list); 12929 12930 Make sure name_token identifies a valid object to be STRUCTUREd. */ 12931 12932void 12933ffestc_V003_item (ffelexToken name, ffesttDimList dims) 12934{ 12935 ffestc_check_item_ (); 12936 assert (name != NULL); 12937 if (!ffestc_ok_) 12938 return; 12939 12940 if (ffestc_local_.V003.list_state < 2) 12941 { 12942 if (ffestc_local_.V003.list_state == 0) 12943 { 12944 ffestc_local_.V003.list_state = 1; 12945 ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD); 12946 ffebad_here (0, ffelex_token_where_line (name), 12947 ffelex_token_where_column (name)); 12948 ffebad_finish (); 12949 } 12950 return; 12951 } 12952 ffestc_local_.V003.list_state = 3; /* Have at least one field name. */ 12953 12954 if (dims != NULL) 12955 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 12956 12957 ffestd_V003_item (name, dims); 12958} 12959 12960/* ffestc_V003_finish -- STRUCTURE statement list complete 12961 12962 ffestc_V003_finish(); 12963 12964 Just wrap up any local activities. */ 12965 12966void 12967ffestc_V003_finish () 12968{ 12969 ffestc_check_finish_ (); 12970 if (!ffestc_ok_) 12971 return; 12972 12973 if (ffestc_local_.V003.list_state == 2) 12974 { 12975 ffebad_start (FFEBAD_STRUCT_MISSING_FIELD); 12976 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 12977 ffelex_token_where_column (ffesta_tokens[0])); 12978 ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())), 12979 ffestw_col (ffestw_previous (ffestw_stack_top ()))); 12980 ffebad_finish (); 12981 } 12982 12983 ffestd_V003_finish (); 12984} 12985 12986/* ffestc_V004 -- END STRUCTURE statement 12987 12988 ffestc_V004(); 12989 12990 Make sure ffestc_kind_ identifies a STRUCTURE block. 12991 Implement the end of the current STRUCTURE block. */ 12992 12993void 12994ffestc_V004 () 12995{ 12996 ffestc_check_simple_ (); 12997 if (ffestc_order_structure_ () != FFESTC_orderOK_) 12998 return; 12999 ffestc_labeldef_useless_ (); 13000 13001 if (ffestw_substate (ffestw_stack_top ()) != 1) 13002 { 13003 ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS); 13004 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 13005 ffelex_token_where_column (ffesta_tokens[0])); 13006 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 13007 ffebad_finish (); 13008 } 13009 13010 ffestc_shriek_structure_ (TRUE); 13011} 13012 13013/* ffestc_V009 -- UNION statement 13014 13015 ffestc_V009(); */ 13016 13017void 13018ffestc_V009 () 13019{ 13020 ffestw b; 13021 13022 ffestc_check_simple_ (); 13023 if (ffestc_order_structure_ () != FFESTC_orderOK_) 13024 return; 13025 ffestc_labeldef_useless_ (); 13026 13027 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */ 13028 13029 b = ffestw_update (ffestw_push (NULL)); 13030 ffestw_set_top_do (b, NULL); 13031 ffestw_set_state (b, FFESTV_stateUNION); 13032 ffestw_set_blocknum (b, 0); 13033 ffestw_set_shriek (b, ffestc_shriek_union_); 13034 ffestw_set_substate (b, 0); /* No map decls seen yet. */ 13035 13036 ffestd_V009 (); 13037} 13038 13039/* ffestc_V010 -- END UNION statement 13040 13041 ffestc_V010(); 13042 13043 Make sure ffestc_kind_ identifies a UNION block. 13044 Implement the end of the current UNION block. */ 13045 13046void 13047ffestc_V010 () 13048{ 13049 ffestc_check_simple_ (); 13050 if (ffestc_order_union_ () != FFESTC_orderOK_) 13051 return; 13052 ffestc_labeldef_useless_ (); 13053 13054 if (ffestw_substate (ffestw_stack_top ()) != 2) 13055 { 13056 ffebad_start (FFEBAD_UNION_NO_TWO_MAPS); 13057 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 13058 ffelex_token_where_column (ffesta_tokens[0])); 13059 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 13060 ffebad_finish (); 13061 } 13062 13063 ffestc_shriek_union_ (TRUE); 13064} 13065 13066/* ffestc_V012 -- MAP statement 13067 13068 ffestc_V012(); */ 13069 13070void 13071ffestc_V012 () 13072{ 13073 ffestw b; 13074 13075 ffestc_check_simple_ (); 13076 if (ffestc_order_union_ () != FFESTC_orderOK_) 13077 return; 13078 ffestc_labeldef_useless_ (); 13079 13080 if (ffestw_substate (ffestw_stack_top ()) != 2) 13081 ffestw_substate (ffestw_stack_top ())++; /* 0=>1, 1=>2. */ 13082 13083 b = ffestw_update (ffestw_push (NULL)); 13084 ffestw_set_top_do (b, NULL); 13085 ffestw_set_state (b, FFESTV_stateMAP); 13086 ffestw_set_blocknum (b, 0); 13087 ffestw_set_shriek (b, ffestc_shriek_map_); 13088 ffestw_set_substate (b, 0); /* No field-declarations seen yet. */ 13089 13090 ffestd_V012 (); 13091} 13092 13093/* ffestc_V013 -- END MAP statement 13094 13095 ffestc_V013(); 13096 13097 Make sure ffestc_kind_ identifies a MAP block. 13098 Implement the end of the current MAP block. */ 13099 13100void 13101ffestc_V013 () 13102{ 13103 ffestc_check_simple_ (); 13104 if (ffestc_order_map_ () != FFESTC_orderOK_) 13105 return; 13106 ffestc_labeldef_useless_ (); 13107 13108 if (ffestw_substate (ffestw_stack_top ()) != 1) 13109 { 13110 ffebad_start (FFEBAD_MAP_NO_COMPONENTS); 13111 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 13112 ffelex_token_where_column (ffesta_tokens[0])); 13113 ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); 13114 ffebad_finish (); 13115 } 13116 13117 ffestc_shriek_map_ (TRUE); 13118} 13119 13120#endif 13121/* ffestc_V014_start -- VOLATILE statement list begin 13122 13123 ffestc_V014_start(); 13124 13125 Verify that VOLATILE is valid here, and begin accepting items in the 13126 list. */ 13127 13128void 13129ffestc_V014_start () 13130{ 13131 ffestc_check_start_ (); 13132 if (ffestc_order_progspec_ () != FFESTC_orderOK_) 13133 { 13134 ffestc_ok_ = FALSE; 13135 return; 13136 } 13137 ffestc_labeldef_useless_ (); 13138 13139 ffestd_V014_start (); 13140 13141 ffestc_ok_ = TRUE; 13142} 13143 13144/* ffestc_V014_item_object -- VOLATILE statement for object-name 13145 13146 ffestc_V014_item_object(name_token); 13147 13148 Make sure name_token identifies a valid object to be VOLATILEd. */ 13149 13150void 13151ffestc_V014_item_object (ffelexToken name) 13152{ 13153 ffestc_check_item_ (); 13154 assert (name != NULL); 13155 if (!ffestc_ok_) 13156 return; 13157 13158 ffestd_V014_item_object (name); 13159} 13160 13161/* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name 13162 13163 ffestc_V014_item_cblock(name_token); 13164 13165 Make sure name_token identifies a valid common block to be VOLATILEd. */ 13166 13167void 13168ffestc_V014_item_cblock (ffelexToken name) 13169{ 13170 ffestc_check_item_ (); 13171 assert (name != NULL); 13172 if (!ffestc_ok_) 13173 return; 13174 13175 ffestd_V014_item_cblock (name); 13176} 13177 13178/* ffestc_V014_finish -- VOLATILE statement list complete 13179 13180 ffestc_V014_finish(); 13181 13182 Just wrap up any local activities. */ 13183 13184void 13185ffestc_V014_finish () 13186{ 13187 ffestc_check_finish_ (); 13188 if (!ffestc_ok_) 13189 return; 13190 13191 ffestd_V014_finish (); 13192} 13193 13194/* ffestc_V016_start -- RECORD statement list begin 13195 13196 ffestc_V016_start(); 13197 13198 Verify that RECORD is valid here, and begin accepting items in the list. */ 13199 13200#if FFESTR_VXT 13201void 13202ffestc_V016_start () 13203{ 13204 ffestc_check_start_ (); 13205 if (ffestc_order_record_ () != FFESTC_orderOK_) 13206 { 13207 ffestc_ok_ = FALSE; 13208 return; 13209 } 13210 ffestc_labeldef_useless_ (); 13211 13212 switch (ffestw_state (ffestw_stack_top ())) 13213 { 13214 case FFESTV_stateSTRUCTURE: 13215 case FFESTV_stateMAP: 13216 ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one 13217 member. */ 13218 break; 13219 13220 default: 13221 break; 13222 } 13223 13224 ffestd_V016_start (); 13225 13226 ffestc_ok_ = TRUE; 13227} 13228 13229/* ffestc_V016_item_structure -- RECORD statement for common-block-name 13230 13231 ffestc_V016_item_structure(name_token); 13232 13233 Make sure name_token identifies a valid structure to be RECORDed. */ 13234 13235void 13236ffestc_V016_item_structure (ffelexToken name) 13237{ 13238 ffestc_check_item_ (); 13239 assert (name != NULL); 13240 if (!ffestc_ok_) 13241 return; 13242 13243 ffestd_V016_item_structure (name); 13244} 13245 13246/* ffestc_V016_item_object -- RECORD statement for object-name 13247 13248 ffestc_V016_item_object(name_token,dim_list); 13249 13250 Make sure name_token identifies a valid object to be RECORDd. */ 13251 13252void 13253ffestc_V016_item_object (ffelexToken name, ffesttDimList dims) 13254{ 13255 ffestc_check_item_ (); 13256 assert (name != NULL); 13257 if (!ffestc_ok_) 13258 return; 13259 13260 if (dims != NULL) 13261 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 13262 13263 ffestd_V016_item_object (name, dims); 13264} 13265 13266/* ffestc_V016_finish -- RECORD statement list complete 13267 13268 ffestc_V016_finish(); 13269 13270 Just wrap up any local activities. */ 13271 13272void 13273ffestc_V016_finish () 13274{ 13275 ffestc_check_finish_ (); 13276 if (!ffestc_ok_) 13277 return; 13278 13279 ffestd_V016_finish (); 13280} 13281 13282/* ffestc_V018_start -- REWRITE(...) statement list begin 13283 13284 ffestc_V018_start(); 13285 13286 Verify that REWRITE is valid here, and begin accepting items in the 13287 list. */ 13288 13289void 13290ffestc_V018_start () 13291{ 13292 ffestvFormat format; 13293 13294 ffestc_check_start_ (); 13295 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13296 { 13297 ffestc_ok_ = FALSE; 13298 return; 13299 } 13300 ffestc_labeldef_branch_begin_ (); 13301 13302 if (!ffestc_subr_is_branch_ 13303 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR]) 13304 || !ffestc_subr_is_format_ 13305 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]) 13306 || !ffestc_subr_is_present_ ("UNIT", 13307 &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT])) 13308 { 13309 ffestc_ok_ = FALSE; 13310 return; 13311 } 13312 13313 format = ffestc_subr_format_ 13314 (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]); 13315 switch (format) 13316 { 13317 case FFESTV_formatNAMELIST: 13318 case FFESTV_formatASTERISK: 13319 ffebad_start (FFEBAD_CONFLICTING_SPECS); 13320 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 13321 ffelex_token_where_column (ffesta_tokens[0])); 13322 assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present); 13323 if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present) 13324 { 13325 ffebad_here (0, ffelex_token_where_line 13326 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw), 13327 ffelex_token_where_column 13328 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw)); 13329 } 13330 else 13331 { 13332 ffebad_here (1, ffelex_token_where_line 13333 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value), 13334 ffelex_token_where_column 13335 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value)); 13336 } 13337 ffebad_finish (); 13338 ffestc_ok_ = FALSE; 13339 return; 13340 13341 default: 13342 break; 13343 } 13344 13345 ffestd_V018_start (format); 13346 13347 ffestc_ok_ = TRUE; 13348} 13349 13350/* ffestc_V018_item -- REWRITE statement i/o item 13351 13352 ffestc_V018_item(expr,expr_token); 13353 13354 Implement output-list expression. */ 13355 13356void 13357ffestc_V018_item (ffebld expr, ffelexToken expr_token) 13358{ 13359 ffestc_check_item_ (); 13360 if (!ffestc_ok_) 13361 return; 13362 13363 ffestd_V018_item (expr); 13364} 13365 13366/* ffestc_V018_finish -- REWRITE statement list complete 13367 13368 ffestc_V018_finish(); 13369 13370 Just wrap up any local activities. */ 13371 13372void 13373ffestc_V018_finish () 13374{ 13375 ffestc_check_finish_ (); 13376 if (!ffestc_ok_) 13377 return; 13378 13379 ffestd_V018_finish (); 13380 13381 if (ffestc_shriek_after1_ != NULL) 13382 (*ffestc_shriek_after1_) (TRUE); 13383 ffestc_labeldef_branch_end_ (); 13384} 13385 13386/* ffestc_V019_start -- ACCEPT statement list begin 13387 13388 ffestc_V019_start(); 13389 13390 Verify that ACCEPT is valid here, and begin accepting items in the 13391 list. */ 13392 13393void 13394ffestc_V019_start () 13395{ 13396 ffestvFormat format; 13397 13398 ffestc_check_start_ (); 13399 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13400 { 13401 ffestc_ok_ = FALSE; 13402 return; 13403 } 13404 ffestc_labeldef_branch_begin_ (); 13405 13406 if (!ffestc_subr_is_format_ 13407 (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT])) 13408 { 13409 ffestc_ok_ = FALSE; 13410 return; 13411 } 13412 13413 format = ffestc_subr_format_ 13414 (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]); 13415 ffestc_namelist_ = (format == FFESTV_formatNAMELIST); 13416 13417 ffestd_V019_start (format); 13418 13419 ffestc_ok_ = TRUE; 13420} 13421 13422/* ffestc_V019_item -- ACCEPT statement i/o item 13423 13424 ffestc_V019_item(expr,expr_token); 13425 13426 Implement output-list expression. */ 13427 13428void 13429ffestc_V019_item (ffebld expr, ffelexToken expr_token) 13430{ 13431 ffestc_check_item_ (); 13432 if (!ffestc_ok_) 13433 return; 13434 13435 if (ffestc_namelist_ != 0) 13436 { 13437 if (ffestc_namelist_ == 1) 13438 { 13439 ffestc_namelist_ = 2; 13440 ffebad_start (FFEBAD_NAMELIST_ITEMS); 13441 ffebad_here (0, ffelex_token_where_line (expr_token), 13442 ffelex_token_where_column (expr_token)); 13443 ffebad_finish (); 13444 } 13445 return; 13446 } 13447 13448 ffestd_V019_item (expr); 13449} 13450 13451/* ffestc_V019_finish -- ACCEPT statement list complete 13452 13453 ffestc_V019_finish(); 13454 13455 Just wrap up any local activities. */ 13456 13457void 13458ffestc_V019_finish () 13459{ 13460 ffestc_check_finish_ (); 13461 if (!ffestc_ok_) 13462 return; 13463 13464 ffestd_V019_finish (); 13465 13466 if (ffestc_shriek_after1_ != NULL) 13467 (*ffestc_shriek_after1_) (TRUE); 13468 ffestc_labeldef_branch_end_ (); 13469} 13470 13471#endif 13472/* ffestc_V020_start -- TYPE statement list begin 13473 13474 ffestc_V020_start(); 13475 13476 Verify that TYPE is valid here, and begin accepting items in the 13477 list. */ 13478 13479void 13480ffestc_V020_start () 13481{ 13482 ffestvFormat format; 13483 13484 ffestc_check_start_ (); 13485 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13486 { 13487 ffestc_ok_ = FALSE; 13488 return; 13489 } 13490 ffestc_labeldef_branch_begin_ (); 13491 13492 if (!ffestc_subr_is_format_ 13493 (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT])) 13494 { 13495 ffestc_ok_ = FALSE; 13496 return; 13497 } 13498 13499 format = ffestc_subr_format_ 13500 (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]); 13501 ffestc_namelist_ = (format == FFESTV_formatNAMELIST); 13502 13503 ffestd_V020_start (format); 13504 13505 ffestc_ok_ = TRUE; 13506} 13507 13508/* ffestc_V020_item -- TYPE statement i/o item 13509 13510 ffestc_V020_item(expr,expr_token); 13511 13512 Implement output-list expression. */ 13513 13514void 13515ffestc_V020_item (ffebld expr, ffelexToken expr_token) 13516{ 13517 ffestc_check_item_ (); 13518 if (!ffestc_ok_) 13519 return; 13520 13521 if (ffestc_namelist_ != 0) 13522 { 13523 if (ffestc_namelist_ == 1) 13524 { 13525 ffestc_namelist_ = 2; 13526 ffebad_start (FFEBAD_NAMELIST_ITEMS); 13527 ffebad_here (0, ffelex_token_where_line (expr_token), 13528 ffelex_token_where_column (expr_token)); 13529 ffebad_finish (); 13530 } 13531 return; 13532 } 13533 13534 ffestd_V020_item (expr); 13535} 13536 13537/* ffestc_V020_finish -- TYPE statement list complete 13538 13539 ffestc_V020_finish(); 13540 13541 Just wrap up any local activities. */ 13542 13543void 13544ffestc_V020_finish () 13545{ 13546 ffestc_check_finish_ (); 13547 if (!ffestc_ok_) 13548 return; 13549 13550 ffestd_V020_finish (); 13551 13552 if (ffestc_shriek_after1_ != NULL) 13553 (*ffestc_shriek_after1_) (TRUE); 13554 ffestc_labeldef_branch_end_ (); 13555} 13556 13557/* ffestc_V021 -- DELETE statement 13558 13559 ffestc_V021(); 13560 13561 Make sure a DELETE is valid in the current context, and implement it. */ 13562 13563#if FFESTR_VXT 13564void 13565ffestc_V021 () 13566{ 13567 ffestc_check_simple_ (); 13568 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13569 return; 13570 ffestc_labeldef_branch_begin_ (); 13571 13572 if (ffestc_subr_is_branch_ 13573 (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR]) 13574 && ffestc_subr_is_present_ ("UNIT", 13575 &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT])) 13576 ffestd_V021 (); 13577 13578 if (ffestc_shriek_after1_ != NULL) 13579 (*ffestc_shriek_after1_) (TRUE); 13580 ffestc_labeldef_branch_end_ (); 13581} 13582 13583/* ffestc_V022 -- UNLOCK statement 13584 13585 ffestc_V022(); 13586 13587 Make sure a UNLOCK is valid in the current context, and implement it. */ 13588 13589void 13590ffestc_V022 () 13591{ 13592 ffestc_check_simple_ (); 13593 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13594 return; 13595 ffestc_labeldef_branch_begin_ (); 13596 13597 if (ffestc_subr_is_branch_ 13598 (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) 13599 && ffestc_subr_is_present_ ("UNIT", 13600 &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) 13601 ffestd_V022 (); 13602 13603 if (ffestc_shriek_after1_ != NULL) 13604 (*ffestc_shriek_after1_) (TRUE); 13605 ffestc_labeldef_branch_end_ (); 13606} 13607 13608/* ffestc_V023_start -- ENCODE(...) statement list begin 13609 13610 ffestc_V023_start(); 13611 13612 Verify that ENCODE is valid here, and begin accepting items in the 13613 list. */ 13614 13615void 13616ffestc_V023_start () 13617{ 13618 ffestc_check_start_ (); 13619 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13620 { 13621 ffestc_ok_ = FALSE; 13622 return; 13623 } 13624 ffestc_labeldef_branch_begin_ (); 13625 13626 if (!ffestc_subr_is_branch_ 13627 (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR])) 13628 { 13629 ffestc_ok_ = FALSE; 13630 return; 13631 } 13632 13633 ffestd_V023_start (); 13634 13635 ffestc_ok_ = TRUE; 13636} 13637 13638/* ffestc_V023_item -- ENCODE statement i/o item 13639 13640 ffestc_V023_item(expr,expr_token); 13641 13642 Implement output-list expression. */ 13643 13644void 13645ffestc_V023_item (ffebld expr, ffelexToken expr_token) 13646{ 13647 ffestc_check_item_ (); 13648 if (!ffestc_ok_) 13649 return; 13650 13651 ffestd_V023_item (expr); 13652} 13653 13654/* ffestc_V023_finish -- ENCODE statement list complete 13655 13656 ffestc_V023_finish(); 13657 13658 Just wrap up any local activities. */ 13659 13660void 13661ffestc_V023_finish () 13662{ 13663 ffestc_check_finish_ (); 13664 if (!ffestc_ok_) 13665 return; 13666 13667 ffestd_V023_finish (); 13668 13669 if (ffestc_shriek_after1_ != NULL) 13670 (*ffestc_shriek_after1_) (TRUE); 13671 ffestc_labeldef_branch_end_ (); 13672} 13673 13674/* ffestc_V024_start -- DECODE(...) statement list begin 13675 13676 ffestc_V024_start(); 13677 13678 Verify that DECODE is valid here, and begin accepting items in the 13679 list. */ 13680 13681void 13682ffestc_V024_start () 13683{ 13684 ffestc_check_start_ (); 13685 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13686 { 13687 ffestc_ok_ = FALSE; 13688 return; 13689 } 13690 ffestc_labeldef_branch_begin_ (); 13691 13692 if (!ffestc_subr_is_branch_ 13693 (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR])) 13694 { 13695 ffestc_ok_ = FALSE; 13696 return; 13697 } 13698 13699 ffestd_V024_start (); 13700 13701 ffestc_ok_ = TRUE; 13702} 13703 13704/* ffestc_V024_item -- DECODE statement i/o item 13705 13706 ffestc_V024_item(expr,expr_token); 13707 13708 Implement output-list expression. */ 13709 13710void 13711ffestc_V024_item (ffebld expr, ffelexToken expr_token) 13712{ 13713 ffestc_check_item_ (); 13714 if (!ffestc_ok_) 13715 return; 13716 13717 ffestd_V024_item (expr); 13718} 13719 13720/* ffestc_V024_finish -- DECODE statement list complete 13721 13722 ffestc_V024_finish(); 13723 13724 Just wrap up any local activities. */ 13725 13726void 13727ffestc_V024_finish () 13728{ 13729 ffestc_check_finish_ (); 13730 if (!ffestc_ok_) 13731 return; 13732 13733 ffestd_V024_finish (); 13734 13735 if (ffestc_shriek_after1_ != NULL) 13736 (*ffestc_shriek_after1_) (TRUE); 13737 ffestc_labeldef_branch_end_ (); 13738} 13739 13740/* ffestc_V025_start -- DEFINEFILE statement list begin 13741 13742 ffestc_V025_start(); 13743 13744 Verify that DEFINEFILE is valid here, and begin accepting items in the 13745 list. */ 13746 13747void 13748ffestc_V025_start () 13749{ 13750 ffestc_check_start_ (); 13751 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13752 { 13753 ffestc_ok_ = FALSE; 13754 return; 13755 } 13756 ffestc_labeldef_branch_begin_ (); 13757 13758 ffestd_V025_start (); 13759 13760 ffestc_ok_ = TRUE; 13761} 13762 13763/* ffestc_V025_item -- DEFINE FILE statement item 13764 13765 ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt); 13766 13767 Implement item. */ 13768 13769void 13770ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt, 13771 ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt) 13772{ 13773 ffestc_check_item_ (); 13774 if (!ffestc_ok_) 13775 return; 13776 13777 ffestd_V025_item (u, m, n, asv); 13778} 13779 13780/* ffestc_V025_finish -- DEFINE FILE statement list complete 13781 13782 ffestc_V025_finish(); 13783 13784 Just wrap up any local activities. */ 13785 13786void 13787ffestc_V025_finish () 13788{ 13789 ffestc_check_finish_ (); 13790 if (!ffestc_ok_) 13791 return; 13792 13793 ffestd_V025_finish (); 13794 13795 if (ffestc_shriek_after1_ != NULL) 13796 (*ffestc_shriek_after1_) (TRUE); 13797 ffestc_labeldef_branch_end_ (); 13798} 13799 13800/* ffestc_V026 -- FIND statement 13801 13802 ffestc_V026(); 13803 13804 Make sure a FIND is valid in the current context, and implement it. */ 13805 13806void 13807ffestc_V026 () 13808{ 13809 ffestc_check_simple_ (); 13810 if (ffestc_order_actionif_ () != FFESTC_orderOK_) 13811 return; 13812 ffestc_labeldef_branch_begin_ (); 13813 13814 if (ffestc_subr_is_branch_ 13815 (&ffestp_file.find.find_spec[FFESTP_findixERR]) 13816 && ffestc_subr_is_present_ ("UNIT", 13817 &ffestp_file.find.find_spec[FFESTP_findixUNIT]) 13818 && ffestc_subr_is_present_ ("REC", 13819 &ffestp_file.find.find_spec[FFESTP_findixREC])) 13820 ffestd_V026 (); 13821 13822 if (ffestc_shriek_after1_ != NULL) 13823 (*ffestc_shriek_after1_) (TRUE); 13824 ffestc_labeldef_branch_end_ (); 13825} 13826 13827#endif 13828/* ffestc_V027_start -- VXT PARAMETER statement list begin 13829 13830 ffestc_V027_start(); 13831 13832 Verify that PARAMETER is valid here, and begin accepting items in the list. */ 13833 13834void 13835ffestc_V027_start () 13836{ 13837 ffestc_check_start_ (); 13838 if (ffestc_order_parameter_ () != FFESTC_orderOK_) 13839 { 13840 ffestc_ok_ = FALSE; 13841 return; 13842 } 13843 ffestc_labeldef_useless_ (); 13844 13845 ffestd_V027_start (); 13846 13847 ffestc_ok_ = TRUE; 13848} 13849 13850/* ffestc_V027_item -- VXT PARAMETER statement assignment 13851 13852 ffestc_V027_item(dest,dest_token,source,source_token); 13853 13854 Make sure the source is a valid source for the destination; make the 13855 assignment. */ 13856 13857void 13858ffestc_V027_item (ffelexToken dest_token, ffebld source, 13859 ffelexToken source_token UNUSED) 13860{ 13861 ffestc_check_item_ (); 13862 if (!ffestc_ok_) 13863 return; 13864 13865 ffestd_V027_item (dest_token, source); 13866} 13867 13868/* ffestc_V027_finish -- VXT PARAMETER statement list complete 13869 13870 ffestc_V027_finish(); 13871 13872 Just wrap up any local activities. */ 13873 13874void 13875ffestc_V027_finish () 13876{ 13877 ffestc_check_finish_ (); 13878 if (!ffestc_ok_) 13879 return; 13880 13881 ffestd_V027_finish (); 13882} 13883 13884/* Any executable statement. Mainly make sure that one-shot things 13885 like the statement for a logical IF are reset. */ 13886 13887void 13888ffestc_any () 13889{ 13890 ffestc_check_simple_ (); 13891 13892 ffestc_order_any_ (); 13893 13894 ffestc_labeldef_any_ (); 13895 13896 if (ffestc_shriek_after1_ == NULL) 13897 return; 13898 13899 ffestd_any (); 13900 13901 (*ffestc_shriek_after1_) (TRUE); 13902} 13903