1/* std.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995, 1996 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 Implements the various statements and such like. 27 28 Modifications: 29 21-Nov-91 JCB 2.0 30 Split out actual code generation to ffeste. 31*/ 32 33/* Include files. */ 34 35#include "proj.h" 36#include "std.h" 37#include "bld.h" 38#include "com.h" 39#include "lab.h" 40#include "lex.h" 41#include "malloc.h" 42#include "sta.h" 43#include "ste.h" 44#include "stp.h" 45#include "str.h" 46#include "sts.h" 47#include "stt.h" 48#include "stv.h" 49#include "stw.h" 50#include "symbol.h" 51#include "target.h" 52 53/* Externals defined here. */ 54 55 56/* Simple definitions and enumerations. */ 57 58#define FFESTD_COPY_EASY_ 1 /* 1 for only one _subr_copy_xyz_ fn. */ 59 60#define FFESTD_IS_END_OPTIMIZED_ 1 /* 0=always gen STOP/RETURN before 61 END. */ 62 63typedef enum 64 { 65 FFESTD_stateletSIMPLE_, /* Expecting simple/start. */ 66 FFESTD_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ 67 FFESTD_stateletITEM_, /* Expecting item/itemstart/finish. */ 68 FFESTD_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ 69 FFESTD_ 70 } ffestdStatelet_; 71 72#if FFECOM_TWOPASS 73typedef enum 74 { 75 FFESTD_stmtidENDDOLOOP_, 76 FFESTD_stmtidENDLOGIF_, 77 FFESTD_stmtidEXECLABEL_, 78 FFESTD_stmtidFORMATLABEL_, 79 FFESTD_stmtidR737A_, /* let */ 80 FFESTD_stmtidR803_, /* IF-block */ 81 FFESTD_stmtidR804_, /* ELSE IF */ 82 FFESTD_stmtidR805_, /* ELSE */ 83 FFESTD_stmtidR806_, /* END IF */ 84 FFESTD_stmtidR807_, /* IF-logical */ 85 FFESTD_stmtidR809_, /* SELECT CASE */ 86 FFESTD_stmtidR810_, /* CASE */ 87 FFESTD_stmtidR811_, /* END SELECT */ 88 FFESTD_stmtidR819A_, /* DO-iterative */ 89 FFESTD_stmtidR819B_, /* DO WHILE */ 90 FFESTD_stmtidR825_, /* END DO */ 91 FFESTD_stmtidR834_, /* CYCLE */ 92 FFESTD_stmtidR835_, /* EXIT */ 93 FFESTD_stmtidR836_, /* GOTO */ 94 FFESTD_stmtidR837_, /* GOTO-computed */ 95 FFESTD_stmtidR838_, /* ASSIGN */ 96 FFESTD_stmtidR839_, /* GOTO-assigned */ 97 FFESTD_stmtidR840_, /* IF-arithmetic */ 98 FFESTD_stmtidR841_, /* CONTINUE */ 99 FFESTD_stmtidR842_, /* STOP */ 100 FFESTD_stmtidR843_, /* PAUSE */ 101 FFESTD_stmtidR904_, /* OPEN */ 102 FFESTD_stmtidR907_, /* CLOSE */ 103 FFESTD_stmtidR909_, /* READ */ 104 FFESTD_stmtidR910_, /* WRITE */ 105 FFESTD_stmtidR911_, /* PRINT */ 106 FFESTD_stmtidR919_, /* BACKSPACE */ 107 FFESTD_stmtidR920_, /* ENDFILE */ 108 FFESTD_stmtidR921_, /* REWIND */ 109 FFESTD_stmtidR923A_, /* INQUIRE */ 110 FFESTD_stmtidR923B_, /* INQUIRE-iolength */ 111 FFESTD_stmtidR1001_, /* FORMAT */ 112 FFESTD_stmtidR1103_, /* END_PROGRAM */ 113 FFESTD_stmtidR1112_, /* END_BLOCK_DATA */ 114 FFESTD_stmtidR1212_, /* CALL */ 115 FFESTD_stmtidR1221_, /* END_FUNCTION */ 116 FFESTD_stmtidR1225_, /* END_SUBROUTINE */ 117 FFESTD_stmtidR1226_, /* ENTRY */ 118 FFESTD_stmtidR1227_, /* RETURN */ 119#if FFESTR_VXT 120 FFESTD_stmtidV018_, /* REWRITE */ 121 FFESTD_stmtidV019_, /* ACCEPT */ 122#endif 123 FFESTD_stmtidV020_, /* TYPE */ 124#if FFESTR_VXT 125 FFESTD_stmtidV021_, /* DELETE */ 126 FFESTD_stmtidV022_, /* UNLOCK */ 127 FFESTD_stmtidV023_, /* ENCODE */ 128 FFESTD_stmtidV024_, /* DECODE */ 129 FFESTD_stmtidV025start_, /* DEFINEFILE (start) */ 130 FFESTD_stmtidV025item_, /* (DEFINEFILE item) */ 131 FFESTD_stmtidV025finish_, /* (DEFINEFILE finish) */ 132 FFESTD_stmtidV026_, /* FIND */ 133#endif 134 FFESTD_stmtid_, 135 } ffestdStmtId_; 136 137#endif 138 139/* Internal typedefs. */ 140 141typedef struct _ffestd_expr_item_ *ffestdExprItem_; 142#if FFECOM_TWOPASS 143typedef struct _ffestd_stmt_ *ffestdStmt_; 144#endif 145 146/* Private include files. */ 147 148 149/* Internal structure definitions. */ 150 151struct _ffestd_expr_item_ 152 { 153 ffestdExprItem_ next; 154 ffebld expr; 155 ffelexToken token; 156 }; 157 158#if FFECOM_TWOPASS 159struct _ffestd_stmt_ 160 { 161 ffestdStmt_ next; 162 ffestdStmt_ previous; 163 ffestdStmtId_ id; 164#if FFECOM_targetCURRENT == FFECOM_targetGCC 165 char *filename; 166 int filelinenum; 167#endif 168 union 169 { 170 struct 171 { 172 ffestw block; 173 } 174 enddoloop; 175 struct 176 { 177 ffelab label; 178 } 179 execlabel; 180 struct 181 { 182 ffelab label; 183 } 184 formatlabel; 185 struct 186 { 187 mallocPool pool; 188 ffebld dest; 189 ffebld source; 190 } 191 R737A; 192 struct 193 { 194 mallocPool pool; 195 ffestw block; 196 ffebld expr; 197 } 198 R803; 199 struct 200 { 201 mallocPool pool; 202 ffestw block; 203 ffebld expr; 204 } 205 R804; 206 struct 207 { 208 ffestw block; 209 } 210 R805; 211 struct 212 { 213 ffestw block; 214 } 215 R806; 216 struct 217 { 218 mallocPool pool; 219 ffebld expr; 220 } 221 R807; 222 struct 223 { 224 mallocPool pool; 225 ffestw block; 226 ffebld expr; 227 } 228 R809; 229 struct 230 { 231 mallocPool pool; 232 ffestw block; 233 unsigned long casenum; 234 } 235 R810; 236 struct 237 { 238 ffestw block; 239 } 240 R811; 241 struct 242 { 243 mallocPool pool; 244 ffestw block; 245 ffelab label; 246 ffebld var; 247 ffebld start; 248 ffelexToken start_token; 249 ffebld end; 250 ffelexToken end_token; 251 ffebld incr; 252 ffelexToken incr_token; 253 } 254 R819A; 255 struct 256 { 257 mallocPool pool; 258 ffestw block; 259 ffelab label; 260 ffebld expr; 261 } 262 R819B; 263 struct 264 { 265 ffestw block; 266 } 267 R834; 268 struct 269 { 270 ffestw block; 271 } 272 R835; 273 struct 274 { 275 ffelab label; 276 } 277 R836; 278 struct 279 { 280 mallocPool pool; 281 ffelab *labels; 282 int count; 283 ffebld expr; 284 } 285 R837; 286 struct 287 { 288 mallocPool pool; 289 ffelab label; 290 ffebld target; 291 } 292 R838; 293 struct 294 { 295 mallocPool pool; 296 ffebld target; 297 } 298 R839; 299 struct 300 { 301 mallocPool pool; 302 ffebld expr; 303 ffelab neg; 304 ffelab zero; 305 ffelab pos; 306 } 307 R840; 308 struct 309 { 310 mallocPool pool; 311 ffebld expr; 312 } 313 R842; 314 struct 315 { 316 mallocPool pool; 317 ffebld expr; 318 } 319 R843; 320 struct 321 { 322 mallocPool pool; 323 ffestpOpenStmt *params; 324 } 325 R904; 326 struct 327 { 328 mallocPool pool; 329 ffestpCloseStmt *params; 330 } 331 R907; 332 struct 333 { 334 mallocPool pool; 335 ffestpReadStmt *params; 336 bool only_format; 337 ffestvUnit unit; 338 ffestvFormat format; 339 bool rec; 340 bool key; 341 ffestdExprItem_ list; 342 } 343 R909; 344 struct 345 { 346 mallocPool pool; 347 ffestpWriteStmt *params; 348 ffestvUnit unit; 349 ffestvFormat format; 350 bool rec; 351 ffestdExprItem_ list; 352 } 353 R910; 354 struct 355 { 356 mallocPool pool; 357 ffestpPrintStmt *params; 358 ffestvFormat format; 359 ffestdExprItem_ list; 360 } 361 R911; 362 struct 363 { 364 mallocPool pool; 365 ffestpBeruStmt *params; 366 } 367 R919; 368 struct 369 { 370 mallocPool pool; 371 ffestpBeruStmt *params; 372 } 373 R920; 374 struct 375 { 376 mallocPool pool; 377 ffestpBeruStmt *params; 378 } 379 R921; 380 struct 381 { 382 mallocPool pool; 383 ffestpInquireStmt *params; 384 bool by_file; 385 } 386 R923A; 387 struct 388 { 389 mallocPool pool; 390 ffestpInquireStmt *params; 391 ffestdExprItem_ list; 392 } 393 R923B; 394 struct 395 { 396 ffestsHolder str; 397 } 398 R1001; 399 struct 400 { 401 mallocPool pool; 402 ffebld expr; 403 } 404 R1212; 405 struct 406 { 407 ffesymbol entry; 408 int entrynum; 409 } 410 R1226; 411 struct 412 { 413 mallocPool pool; 414 ffestw block; 415 ffebld expr; 416 } 417 R1227; 418#if FFESTR_VXT 419 struct 420 { 421 mallocPool pool; 422 ffestpRewriteStmt *params; 423 ffestvFormat format; 424 ffestdExprItem_ list; 425 } 426 V018; 427 struct 428 { 429 mallocPool pool; 430 ffestpAcceptStmt *params; 431 ffestvFormat format; 432 ffestdExprItem_ list; 433 } 434 V019; 435#endif 436 struct 437 { 438 mallocPool pool; 439 ffestpTypeStmt *params; 440 ffestvFormat format; 441 ffestdExprItem_ list; 442 } 443 V020; 444#if FFESTR_VXT 445 struct 446 { 447 mallocPool pool; 448 ffestpDeleteStmt *params; 449 } 450 V021; 451 struct 452 { 453 mallocPool pool; 454 ffestpBeruStmt *params; 455 } 456 V022; 457 struct 458 { 459 mallocPool pool; 460 ffestpVxtcodeStmt *params; 461 ffestdExprItem_ list; 462 } 463 V023; 464 struct 465 { 466 mallocPool pool; 467 ffestpVxtcodeStmt *params; 468 ffestdExprItem_ list; 469 } 470 V024; 471 struct 472 { 473 ffebld u; 474 ffebld m; 475 ffebld n; 476 ffebld asv; 477 } 478 V025item; 479 struct 480 { 481 mallocPool pool; 482 } V025finish; 483 struct 484 { 485 mallocPool pool; 486 ffestpFindStmt *params; 487 } 488 V026; 489#endif 490 } 491 u; 492 }; 493 494#endif 495 496/* Static objects accessed by functions in this module. */ 497 498static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_; 499static int ffestd_block_level_ = 0; /* Block level for reachableness. */ 500static bool ffestd_is_reachable_; /* Is the current stmt reachable? */ 501static ffelab ffestd_label_formatdef_ = NULL; 502#if FFECOM_TWOPASS 503static ffestdExprItem_ *ffestd_expr_list_; 504static struct 505 { 506 ffestdStmt_ first; 507 ffestdStmt_ last; 508 } 509 510ffestd_stmt_list_ 511= 512{ 513 NULL, NULL 514}; 515 516#endif 517#if FFECOM_targetCURRENT == FFECOM_targetGCC 518static int ffestd_2pass_entrypoints_ = 0; /* # ENTRY statements 519 pending. */ 520#endif 521 522/* Static functions (internal). */ 523 524#if FFECOM_TWOPASS 525static void ffestd_stmt_append_ (ffestdStmt_ stmt); 526static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id); 527static void ffestd_stmt_pass_ (void); 528#endif 529#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS 530static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max); 531#endif 532#if FFECOM_targetCURRENT == FFECOM_targetGCC 533static void ffestd_subr_vxt_ (void); 534#endif 535#if FFESTR_F90 536static void ffestd_subr_f90_ (void); 537#endif 538static void ffestd_subr_labels_ (bool unexpected); 539static void ffestd_R1001dump_ (ffests s, ffesttFormatList list); 540static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, 541 const char *string); 542static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, 543 const char *string); 544static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, 545 const char *string); 546static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, 547 const char *string); 548static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, 549 const char *string); 550static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, 551 const char *string); 552static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, 553 const char *string); 554static void ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, 555 const char *string); 556static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, 557 const char *string); 558static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, 559 const char *string); 560static void ffestd_R1001error_ (ffesttFormatList f); 561static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr); 562 563/* Internal macros. */ 564 565#if FFECOM_targetCURRENT == FFECOM_targetGCC 566#define ffestd_subr_line_now_() \ 567 ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \ 568 ffelex_token_where_filelinenum (ffesta_tokens[0])) 569#define ffestd_subr_line_restore_(s) \ 570 ffeste_set_line ((s)->filename, (s)->filelinenum) 571#define ffestd_subr_line_save_(s) \ 572 ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]), \ 573 (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0])) 574#else 575#define ffestd_subr_line_now_() 576#if FFECOM_TWOPASS 577#define ffestd_subr_line_restore_(s) 578#define ffestd_subr_line_save_(s) 579#endif /* FFECOM_TWOPASS */ 580#endif /* FFECOM_targetCURRENT != FFECOM_targetGCC */ 581#define ffestd_check_simple_() \ 582 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_) 583#define ffestd_check_start_() \ 584 assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \ 585 ffestd_statelet_ = FFESTD_stateletATTRIB_ 586#define ffestd_check_attrib_() \ 587 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_) 588#define ffestd_check_item_() \ 589 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \ 590 || ffestd_statelet_ == FFESTD_stateletITEM_); \ 591 ffestd_statelet_ = FFESTD_stateletITEM_ 592#define ffestd_check_item_startvals_() \ 593 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \ 594 || ffestd_statelet_ == FFESTD_stateletITEM_); \ 595 ffestd_statelet_ = FFESTD_stateletITEMVALS_ 596#define ffestd_check_item_value_() \ 597 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_) 598#define ffestd_check_item_endvals_() \ 599 assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \ 600 ffestd_statelet_ = FFESTD_stateletITEM_ 601#define ffestd_check_finish_() \ 602 assert(ffestd_statelet_ == FFESTD_stateletATTRIB_ \ 603 || ffestd_statelet_ == FFESTD_stateletITEM_); \ 604 ffestd_statelet_ = FFESTD_stateletSIMPLE_ 605 606#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS 607#define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \ 608 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix) 609#define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \ 610 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix) 611#define ffestd_subr_copy_close_() (ffestpCloseStmt *) \ 612 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix) 613#define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \ 614 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix) 615#define ffestd_subr_copy_find_() (ffestpFindStmt *) \ 616 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix) 617#define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \ 618 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix) 619#define ffestd_subr_copy_open_() (ffestpOpenStmt *) \ 620 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix) 621#define ffestd_subr_copy_print_() (ffestpPrintStmt *) \ 622 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix) 623#define ffestd_subr_copy_read_() (ffestpReadStmt *) \ 624 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix) 625#define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \ 626 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix) 627#define ffestd_subr_copy_type_() (ffestpTypeStmt *) \ 628 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix) 629#define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \ 630 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix) 631#define ffestd_subr_copy_write_() (ffestpWriteStmt *) \ 632 ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix) 633#endif 634 635/* ffestd_stmt_append_ -- Append statement to end of stmt list 636 637 ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */ 638 639#if FFECOM_TWOPASS 640static void 641ffestd_stmt_append_ (ffestdStmt_ stmt) 642{ 643 stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first; 644 stmt->previous = ffestd_stmt_list_.last; 645 stmt->next->previous = stmt; 646 stmt->previous->next = stmt; 647} 648 649#endif 650/* ffestd_stmt_new_ -- Make new statement with given id 651 652 ffestdStmt_ stmt; 653 stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */ 654 655#if FFECOM_TWOPASS 656static ffestdStmt_ 657ffestd_stmt_new_ (ffestdStmtId_ id) 658{ 659 ffestdStmt_ stmt; 660 661 stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt)); 662 stmt->id = id; 663 return stmt; 664} 665 666#endif 667/* ffestd_stmt_pass_ -- Pass all statements on list to ffeste 668 669 ffestd_stmt_pass_(); */ 670 671#if FFECOM_TWOPASS 672static void 673ffestd_stmt_pass_ () 674{ 675 ffestdStmt_ stmt; 676 ffestdExprItem_ expr; /* For traversing lists. */ 677 bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK); 678 679#if FFECOM_targetCURRENT == FFECOM_targetGCC 680 if ((ffestd_2pass_entrypoints_ != 0) && okay) 681 { 682 tree which = ffecom_which_entrypoint_decl (); 683 tree value; 684 tree label; 685 int pushok; 686 int ents = ffestd_2pass_entrypoints_; 687 tree duplicate; 688 689 expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch"); 690 push_momentary (); 691 692 stmt = ffestd_stmt_list_.first; 693 do 694 { 695 while (stmt->id != FFESTD_stmtidR1226_) 696 stmt = stmt->next; 697 698 if (stmt->u.R1226.entry != NULL) 699 { 700 value = build_int_2 (stmt->u.R1226.entrynum, 0); 701 /* Yes, we really want to build a null LABEL_DECL here and not 702 put it on any list. That's what pushcase wants, so that's 703 what it gets! */ 704 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); 705 706 pushok = pushcase (value, convert, label, &duplicate); 707 assert (pushok == 0); 708 709 label = ffecom_temp_label (); 710 TREE_USED (label) = 1; 711 expand_goto (label); 712 clear_momentary (); 713 714 ffesymbol_hook (stmt->u.R1226.entry).length_tree = label; 715 } 716 stmt = stmt->next; 717 } 718 while (--ents != 0); 719 720 pop_momentary (); 721 expand_end_case (which); 722 clear_momentary (); 723 } 724#endif 725 726 for (stmt = ffestd_stmt_list_.first; 727 stmt != (ffestdStmt_) &ffestd_stmt_list_.first; 728 stmt = stmt->next) 729 { 730 switch (stmt->id) 731 { 732 case FFESTD_stmtidENDDOLOOP_: 733 ffestd_subr_line_restore_ (stmt); 734 if (okay) 735 ffeste_do (stmt->u.enddoloop.block); 736 ffestw_kill (stmt->u.enddoloop.block); 737 break; 738 739 case FFESTD_stmtidENDLOGIF_: 740 ffestd_subr_line_restore_ (stmt); 741 if (okay) 742 ffeste_end_R807 (); 743 break; 744 745 case FFESTD_stmtidEXECLABEL_: 746 if (okay) 747 ffeste_labeldef_branch (stmt->u.execlabel.label); 748 break; 749 750 case FFESTD_stmtidFORMATLABEL_: 751 if (okay) 752 ffeste_labeldef_format (stmt->u.formatlabel.label); 753 break; 754 755 case FFESTD_stmtidR737A_: 756 ffestd_subr_line_restore_ (stmt); 757 if (okay) 758 ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source); 759 malloc_pool_kill (stmt->u.R737A.pool); 760 break; 761 762 case FFESTD_stmtidR803_: 763 ffestd_subr_line_restore_ (stmt); 764 if (okay) 765 ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr); 766 malloc_pool_kill (stmt->u.R803.pool); 767 break; 768 769 case FFESTD_stmtidR804_: 770 ffestd_subr_line_restore_ (stmt); 771 if (okay) 772 ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr); 773 malloc_pool_kill (stmt->u.R804.pool); 774 break; 775 776 case FFESTD_stmtidR805_: 777 ffestd_subr_line_restore_ (stmt); 778 if (okay) 779 ffeste_R805 (stmt->u.R803.block); 780 break; 781 782 case FFESTD_stmtidR806_: 783 ffestd_subr_line_restore_ (stmt); 784 if (okay) 785 ffeste_R806 (stmt->u.R806.block); 786 ffestw_kill (stmt->u.R806.block); 787 break; 788 789 case FFESTD_stmtidR807_: 790 ffestd_subr_line_restore_ (stmt); 791 if (okay) 792 ffeste_R807 (stmt->u.R807.expr); 793 malloc_pool_kill (stmt->u.R807.pool); 794 break; 795 796 case FFESTD_stmtidR809_: 797 ffestd_subr_line_restore_ (stmt); 798 if (okay) 799 ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr); 800 malloc_pool_kill (stmt->u.R809.pool); 801 break; 802 803 case FFESTD_stmtidR810_: 804 ffestd_subr_line_restore_ (stmt); 805 if (okay) 806 ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum); 807 malloc_pool_kill (stmt->u.R810.pool); 808 break; 809 810 case FFESTD_stmtidR811_: 811 ffestd_subr_line_restore_ (stmt); 812 if (okay) 813 ffeste_R811 (stmt->u.R811.block); 814 malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool); 815 ffestw_kill (stmt->u.R811.block); 816 break; 817 818 case FFESTD_stmtidR819A_: 819 ffestd_subr_line_restore_ (stmt); 820 if (okay) 821 ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label, 822 stmt->u.R819A.var, 823 stmt->u.R819A.start, stmt->u.R819A.start_token, 824 stmt->u.R819A.end, stmt->u.R819A.end_token, 825 stmt->u.R819A.incr, stmt->u.R819A.incr_token); 826 ffelex_token_kill (stmt->u.R819A.start_token); 827 ffelex_token_kill (stmt->u.R819A.end_token); 828 if (stmt->u.R819A.incr_token != NULL) 829 ffelex_token_kill (stmt->u.R819A.incr_token); 830 malloc_pool_kill (stmt->u.R819A.pool); 831 break; 832 833 case FFESTD_stmtidR819B_: 834 ffestd_subr_line_restore_ (stmt); 835 if (okay) 836 ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label, 837 stmt->u.R819B.expr); 838 malloc_pool_kill (stmt->u.R819B.pool); 839 break; 840 841 case FFESTD_stmtidR825_: 842 ffestd_subr_line_restore_ (stmt); 843 if (okay) 844 ffeste_R825 (); 845 break; 846 847 case FFESTD_stmtidR834_: 848 ffestd_subr_line_restore_ (stmt); 849 if (okay) 850 ffeste_R834 (stmt->u.R834.block); 851 break; 852 853 case FFESTD_stmtidR835_: 854 ffestd_subr_line_restore_ (stmt); 855 if (okay) 856 ffeste_R835 (stmt->u.R835.block); 857 break; 858 859 case FFESTD_stmtidR836_: 860 ffestd_subr_line_restore_ (stmt); 861 if (okay) 862 ffeste_R836 (stmt->u.R836.label); 863 break; 864 865 case FFESTD_stmtidR837_: 866 ffestd_subr_line_restore_ (stmt); 867 if (okay) 868 ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count, 869 stmt->u.R837.expr); 870 malloc_pool_kill (stmt->u.R837.pool); 871 break; 872 873 case FFESTD_stmtidR838_: 874 ffestd_subr_line_restore_ (stmt); 875 if (okay) 876 ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target); 877 malloc_pool_kill (stmt->u.R838.pool); 878 break; 879 880 case FFESTD_stmtidR839_: 881 ffestd_subr_line_restore_ (stmt); 882 if (okay) 883 ffeste_R839 (stmt->u.R839.target); 884 malloc_pool_kill (stmt->u.R839.pool); 885 break; 886 887 case FFESTD_stmtidR840_: 888 ffestd_subr_line_restore_ (stmt); 889 if (okay) 890 ffeste_R840 (stmt->u.R840.expr, stmt->u.R840.neg, stmt->u.R840.zero, 891 stmt->u.R840.pos); 892 malloc_pool_kill (stmt->u.R840.pool); 893 break; 894 895 case FFESTD_stmtidR841_: 896 ffestd_subr_line_restore_ (stmt); 897 if (okay) 898 ffeste_R841 (); 899 break; 900 901 case FFESTD_stmtidR842_: 902 ffestd_subr_line_restore_ (stmt); 903 if (okay) 904 ffeste_R842 (stmt->u.R842.expr); 905 if (stmt->u.R842.pool != NULL) 906 malloc_pool_kill (stmt->u.R842.pool); 907 break; 908 909 case FFESTD_stmtidR843_: 910 ffestd_subr_line_restore_ (stmt); 911 if (okay) 912 ffeste_R843 (stmt->u.R843.expr); 913 malloc_pool_kill (stmt->u.R843.pool); 914 break; 915 916 case FFESTD_stmtidR904_: 917 ffestd_subr_line_restore_ (stmt); 918 if (okay) 919 ffeste_R904 (stmt->u.R904.params); 920 malloc_pool_kill (stmt->u.R904.pool); 921 break; 922 923 case FFESTD_stmtidR907_: 924 ffestd_subr_line_restore_ (stmt); 925 if (okay) 926 ffeste_R907 (stmt->u.R907.params); 927 malloc_pool_kill (stmt->u.R907.pool); 928 break; 929 930 case FFESTD_stmtidR909_: 931 ffestd_subr_line_restore_ (stmt); 932 if (okay) 933 ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format, 934 stmt->u.R909.unit, stmt->u.R909.format, 935 stmt->u.R909.rec, stmt->u.R909.key); 936 for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next) 937 { 938 if (okay) 939 ffeste_R909_item (expr->expr, expr->token); 940 ffelex_token_kill (expr->token); 941 } 942 if (okay) 943 ffeste_R909_finish (); 944 malloc_pool_kill (stmt->u.R909.pool); 945 break; 946 947 case FFESTD_stmtidR910_: 948 ffestd_subr_line_restore_ (stmt); 949 if (okay) 950 ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit, 951 stmt->u.R910.format, stmt->u.R910.rec); 952 for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next) 953 { 954 if (okay) 955 ffeste_R910_item (expr->expr, expr->token); 956 ffelex_token_kill (expr->token); 957 } 958 if (okay) 959 ffeste_R910_finish (); 960 malloc_pool_kill (stmt->u.R910.pool); 961 break; 962 963 case FFESTD_stmtidR911_: 964 ffestd_subr_line_restore_ (stmt); 965 if (okay) 966 ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format); 967 for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next) 968 { 969 if (okay) 970 ffeste_R911_item (expr->expr, expr->token); 971 ffelex_token_kill (expr->token); 972 } 973 if (okay) 974 ffeste_R911_finish (); 975 malloc_pool_kill (stmt->u.R911.pool); 976 break; 977 978 case FFESTD_stmtidR919_: 979 ffestd_subr_line_restore_ (stmt); 980 if (okay) 981 ffeste_R919 (stmt->u.R919.params); 982 malloc_pool_kill (stmt->u.R919.pool); 983 break; 984 985 case FFESTD_stmtidR920_: 986 ffestd_subr_line_restore_ (stmt); 987 if (okay) 988 ffeste_R920 (stmt->u.R920.params); 989 malloc_pool_kill (stmt->u.R920.pool); 990 break; 991 992 case FFESTD_stmtidR921_: 993 ffestd_subr_line_restore_ (stmt); 994 if (okay) 995 ffeste_R921 (stmt->u.R921.params); 996 malloc_pool_kill (stmt->u.R921.pool); 997 break; 998 999 case FFESTD_stmtidR923A_: 1000 ffestd_subr_line_restore_ (stmt); 1001 if (okay) 1002 ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file); 1003 malloc_pool_kill (stmt->u.R923A.pool); 1004 break; 1005 1006 case FFESTD_stmtidR923B_: 1007 ffestd_subr_line_restore_ (stmt); 1008 if (okay) 1009 ffeste_R923B_start (stmt->u.R923B.params); 1010 for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next) 1011 { 1012 if (okay) 1013 ffeste_R923B_item (expr->expr); 1014 } 1015 if (okay) 1016 ffeste_R923B_finish (); 1017 malloc_pool_kill (stmt->u.R923B.pool); 1018 break; 1019 1020 case FFESTD_stmtidR1001_: 1021 if (okay) 1022 ffeste_R1001 (&stmt->u.R1001.str); 1023 ffests_kill (&stmt->u.R1001.str); 1024 break; 1025 1026 case FFESTD_stmtidR1103_: 1027 if (okay) 1028 ffeste_R1103 (); 1029 break; 1030 1031 case FFESTD_stmtidR1112_: 1032 if (okay) 1033 ffeste_R1112 (); 1034 break; 1035 1036 case FFESTD_stmtidR1212_: 1037 ffestd_subr_line_restore_ (stmt); 1038 if (okay) 1039 ffeste_R1212 (stmt->u.R1212.expr); 1040 malloc_pool_kill (stmt->u.R1212.pool); 1041 break; 1042 1043 case FFESTD_stmtidR1221_: 1044 if (okay) 1045 ffeste_R1221 (); 1046 break; 1047 1048 case FFESTD_stmtidR1225_: 1049 if (okay) 1050 ffeste_R1225 (); 1051 break; 1052 1053 case FFESTD_stmtidR1226_: 1054 ffestd_subr_line_restore_ (stmt); 1055 if (stmt->u.R1226.entry != NULL) 1056 { 1057 if (okay) 1058 ffeste_R1226 (stmt->u.R1226.entry); 1059 } 1060 break; 1061 1062 case FFESTD_stmtidR1227_: 1063 ffestd_subr_line_restore_ (stmt); 1064 if (okay) 1065 ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr); 1066 malloc_pool_kill (stmt->u.R1227.pool); 1067 break; 1068 1069#if FFESTR_VXT 1070 case FFESTD_stmtidV018_: 1071 ffestd_subr_line_restore_ (stmt); 1072 if (okay) 1073 ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format); 1074 for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next) 1075 { 1076 if (okay) 1077 ffeste_V018_item (expr->expr); 1078 } 1079 if (okay) 1080 ffeste_V018_finish (); 1081 malloc_pool_kill (stmt->u.V018.pool); 1082 break; 1083 1084 case FFESTD_stmtidV019_: 1085 ffestd_subr_line_restore_ (stmt); 1086 if (okay) 1087 ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format); 1088 for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next) 1089 { 1090 if (okay) 1091 ffeste_V019_item (expr->expr); 1092 } 1093 if (okay) 1094 ffeste_V019_finish (); 1095 malloc_pool_kill (stmt->u.V019.pool); 1096 break; 1097#endif 1098 1099 case FFESTD_stmtidV020_: 1100 ffestd_subr_line_restore_ (stmt); 1101 if (okay) 1102 ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format); 1103 for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next) 1104 { 1105 if (okay) 1106 ffeste_V020_item (expr->expr); 1107 } 1108 if (okay) 1109 ffeste_V020_finish (); 1110 malloc_pool_kill (stmt->u.V020.pool); 1111 break; 1112 1113#if FFESTR_VXT 1114 case FFESTD_stmtidV021_: 1115 ffestd_subr_line_restore_ (stmt); 1116 if (okay) 1117 ffeste_V021 (stmt->u.V021.params); 1118 malloc_pool_kill (stmt->u.V021.pool); 1119 break; 1120 1121 case FFESTD_stmtidV023_: 1122 ffestd_subr_line_restore_ (stmt); 1123 if (okay) 1124 ffeste_V023_start (stmt->u.V023.params); 1125 for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next) 1126 { 1127 if (okay) 1128 ffeste_V023_item (expr->expr); 1129 } 1130 if (okay) 1131 ffeste_V023_finish (); 1132 malloc_pool_kill (stmt->u.V023.pool); 1133 break; 1134 1135 case FFESTD_stmtidV024_: 1136 ffestd_subr_line_restore_ (stmt); 1137 if (okay) 1138 ffeste_V024_start (stmt->u.V024.params); 1139 for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next) 1140 { 1141 if (okay) 1142 ffeste_V024_item (expr->expr); 1143 } 1144 if (okay) 1145 ffeste_V024_finish (); 1146 malloc_pool_kill (stmt->u.V024.pool); 1147 break; 1148 1149 case FFESTD_stmtidV025start_: 1150 ffestd_subr_line_restore_ (stmt); 1151 if (okay) 1152 ffeste_V025_start (); 1153 break; 1154 1155 case FFESTD_stmtidV025item_: 1156 if (okay) 1157 ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m, 1158 stmt->u.V025item.n, stmt->u.V025item.asv); 1159 break; 1160 1161 case FFESTD_stmtidV025finish_: 1162 if (okay) 1163 ffeste_V025_finish (); 1164 malloc_pool_kill (stmt->u.V025finish.pool); 1165 break; 1166 1167 case FFESTD_stmtidV026_: 1168 ffestd_subr_line_restore_ (stmt); 1169 if (okay) 1170 ffeste_V026 (stmt->u.V026.params); 1171 malloc_pool_kill (stmt->u.V026.pool); 1172 break; 1173#endif 1174 1175 default: 1176 assert ("bad stmt->id" == NULL); 1177 break; 1178 } 1179 } 1180} 1181 1182#endif 1183/* ffestd_subr_copy_easy_ -- Copy I/O statement data structure 1184 1185 ffestd_subr_copy_easy_(); 1186 1187 Copies all data except tokens in the I/O data structure into a new 1188 structure that lasts as long as the output pool for the current 1189 statement. Assumes that they are 1190 overlaid with each other (union) in stp.h and the typing 1191 and structure references assume (though not necessarily dangerous if 1192 FALSE) that INQUIRE has the most file elements. */ 1193 1194#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS 1195static ffestpInquireStmt * 1196ffestd_subr_copy_easy_ (ffestpInquireIx max) 1197{ 1198 ffestpInquireStmt *stmt; 1199 ffestpInquireIx ix; 1200 1201 stmt = (ffestpInquireStmt *) malloc_new_kp (ffesta_output_pool, 1202 "FFESTD easy", sizeof (ffestpFile) * max); 1203 1204 for (ix = 0; ix < max; ++ix) 1205 { 1206 if ((stmt->inquire_spec[ix].kw_or_val_present 1207 = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present) 1208 && (stmt->inquire_spec[ix].value_present 1209 = ffestp_file.inquire.inquire_spec[ix].value_present)) 1210 { 1211 if ((stmt->inquire_spec[ix].value_is_label 1212 = ffestp_file.inquire.inquire_spec[ix].value_is_label)) 1213 stmt->inquire_spec[ix].u.label 1214 = ffestp_file.inquire.inquire_spec[ix].u.label; 1215 else 1216 stmt->inquire_spec[ix].u.expr 1217 = ffestp_file.inquire.inquire_spec[ix].u.expr; 1218 } 1219 } 1220 1221 return stmt; 1222} 1223 1224#endif 1225/* ffestd_subr_labels_ -- Handle any undefined labels 1226 1227 ffestd_subr_labels_(FALSE); 1228 1229 For every undefined label, generate an error message and either define 1230 label as a FORMAT() statement (for FORMAT labels) or as a STOP statement 1231 (for all other labels). */ 1232 1233static void 1234ffestd_subr_labels_ (bool unexpected) 1235{ 1236 ffelab l; 1237 ffelabHandle h; 1238 ffelabNumber undef; 1239 ffesttFormatList f; 1240 1241 undef = ffelab_number () - ffestv_num_label_defines_; 1242 1243 for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h)) 1244 { 1245 l = ffelab_handle_target (h); 1246 if (ffewhere_line_is_unknown (ffelab_definition_line (l))) 1247 { /* Undefined label. */ 1248 assert (!unexpected); 1249 assert (undef > 0); 1250 undef--; 1251 ffebad_start (FFEBAD_UNDEF_LABEL); 1252 if (ffelab_type (l) == FFELAB_typeLOOPEND) 1253 ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l)); 1254 else if (ffelab_type (l) != FFELAB_typeANY) 1255 ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l)); 1256 else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l))) 1257 ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l)); 1258 else if (!ffewhere_line_is_unknown (ffelab_doref_line (l))) 1259 ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l)); 1260 else 1261 ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l)); 1262 ffebad_finish (); 1263 1264 switch (ffelab_type (l)) 1265 { 1266 case FFELAB_typeFORMAT: 1267 ffelab_set_definition_line (l, 1268 ffewhere_line_use (ffelab_firstref_line (l))); 1269 ffelab_set_definition_column (l, 1270 ffewhere_column_use (ffelab_firstref_column (l))); 1271 ffestv_num_label_defines_++; 1272 f = ffestt_formatlist_create (NULL, NULL); 1273 ffestd_labeldef_format (l); 1274 ffestd_R1001 (f); 1275 ffestt_formatlist_kill (f); 1276 break; 1277 1278 case FFELAB_typeASSIGNABLE: 1279 ffelab_set_definition_line (l, 1280 ffewhere_line_use (ffelab_firstref_line (l))); 1281 ffelab_set_definition_column (l, 1282 ffewhere_column_use (ffelab_firstref_column (l))); 1283 ffestv_num_label_defines_++; 1284 ffelab_set_type (l, FFELAB_typeNOTLOOP); 1285 ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ())); 1286 ffestd_labeldef_notloop (l); 1287 ffestd_R842 (NULL); 1288 break; 1289 1290 case FFELAB_typeNOTLOOP: 1291 ffelab_set_definition_line (l, 1292 ffewhere_line_use (ffelab_firstref_line (l))); 1293 ffelab_set_definition_column (l, 1294 ffewhere_column_use (ffelab_firstref_column (l))); 1295 ffestv_num_label_defines_++; 1296 ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ())); 1297 ffestd_labeldef_notloop (l); 1298 ffestd_R842 (NULL); 1299 break; 1300 1301 default: 1302 assert ("bad label type" == NULL); 1303 /* Fall through. */ 1304 case FFELAB_typeUNKNOWN: 1305 case FFELAB_typeANY: 1306 break; 1307 } 1308 } 1309 } 1310 ffelab_handle_done (h); 1311 assert (undef == 0); 1312} 1313 1314/* ffestd_subr_f90_ -- Report error about lack of full F90 support 1315 1316 ffestd_subr_f90_(); */ 1317 1318#if FFESTR_F90 1319static void 1320ffestd_subr_f90_ () 1321{ 1322 ffebad_start (FFEBAD_F90); 1323 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 1324 ffelex_token_where_column (ffesta_tokens[0])); 1325 ffebad_finish (); 1326} 1327 1328#endif 1329/* ffestd_subr_vxt_ -- Report error about lack of full VXT support 1330 1331 ffestd_subr_vxt_(); */ 1332 1333#if FFECOM_targetCURRENT == FFECOM_targetGCC 1334static void 1335ffestd_subr_vxt_ () 1336{ 1337 ffebad_start (FFEBAD_VXT_UNSUPPORTED); 1338 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 1339 ffelex_token_where_column (ffesta_tokens[0])); 1340 ffebad_finish (); 1341} 1342 1343#endif 1344/* ffestd_begin_uses -- Start a bunch of USE statements 1345 1346 ffestd_begin_uses(); 1347 1348 Invoked before handling the first USE statement in a block of one or 1349 more USE statements. _end_uses_(bool ok) is invoked before handling 1350 the first statement after the block (there are no BEGIN USE and END USE 1351 statements, but the semantics of USE statements effectively requires 1352 handling them as a single block rather than one statement at a time). */ 1353 1354void 1355ffestd_begin_uses () 1356{ 1357#if FFECOM_targetCURRENT == FFECOM_targetFFE 1358 fputs ("; begin_uses\n", dmpout); 1359#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1360#else 1361#error 1362#endif 1363} 1364 1365/* ffestd_do -- End of statement following DO-term-stmt etc 1366 1367 ffestd_do(TRUE); 1368 1369 Also invoked by _labeldef_branch_finish_ (or, in cases 1370 of errors, other _labeldef_ functions) when the label definition is 1371 for a DO-target (LOOPEND) label, once per matching/outstanding DO 1372 block on the stack. These cases invoke this function with ok==TRUE, so 1373 only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE. */ 1374 1375void 1376ffestd_do (bool ok UNUSED) 1377{ 1378#if FFECOM_ONEPASS 1379 ffestd_subr_line_now_ (); 1380 ffeste_do (ffestw_stack_top ()); 1381#else 1382 { 1383 ffestdStmt_ stmt; 1384 1385 stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_); 1386 ffestd_stmt_append_ (stmt); 1387 ffestd_subr_line_save_ (stmt); 1388 stmt->u.enddoloop.block = ffestw_stack_top (); 1389 } 1390#endif 1391 1392 --ffestd_block_level_; 1393 assert (ffestd_block_level_ >= 0); 1394} 1395 1396/* ffestd_end_uses -- End a bunch of USE statements 1397 1398 ffestd_end_uses(TRUE); 1399 1400 ok==TRUE means simply not popping due to ffestd_eof_() 1401 being called, because there is no formal END USES statement in Fortran. */ 1402 1403#if FFESTR_F90 1404void 1405ffestd_end_uses (bool ok) 1406{ 1407#if FFECOM_targetCURRENT == FFECOM_targetFFE 1408 fputs ("; end_uses\n", dmpout); 1409#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1410#else 1411#error 1412#endif 1413} 1414 1415/* ffestd_end_R740 -- End a WHERE(-THEN) 1416 1417 ffestd_end_R740(TRUE); */ 1418 1419void 1420ffestd_end_R740 (bool ok) 1421{ 1422 return; /* F90. */ 1423} 1424 1425#endif 1426/* ffestd_end_R807 -- End of statement following logical IF 1427 1428 ffestd_end_R807(TRUE); 1429 1430 Applies ONLY to logical IF, not to IF-THEN. For example, does not 1431 ffelex_token_kill the construct name for an IF-THEN block (the name 1432 field is invalid for logical IF). ok==TRUE iff statement following 1433 logical IF (substatement) is valid; else, statement is invalid or 1434 stack forcibly popped due to ffestd_eof_(). */ 1435 1436void 1437ffestd_end_R807 (bool ok UNUSED) 1438{ 1439#if FFECOM_ONEPASS 1440 ffestd_subr_line_now_ (); 1441 ffeste_end_R807 (); 1442#else 1443 { 1444 ffestdStmt_ stmt; 1445 1446 stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_); 1447 ffestd_stmt_append_ (stmt); 1448 ffestd_subr_line_save_ (stmt); 1449 } 1450#endif 1451 1452 --ffestd_block_level_; 1453 assert (ffestd_block_level_ >= 0); 1454} 1455 1456/* ffestd_exec_begin -- Executable statements can start coming in now 1457 1458 ffestd_exec_begin(); */ 1459 1460void 1461ffestd_exec_begin () 1462{ 1463 ffecom_exec_transition (); 1464 1465#if FFECOM_targetCURRENT == FFECOM_targetFFE 1466 fputs ("{ begin_exec\n", dmpout); 1467#endif 1468 1469#if FFECOM_targetCURRENT == FFECOM_targetGCC 1470 if (ffestd_2pass_entrypoints_ != 0) 1471 { /* Process pending ENTRY statements now that 1472 info filled in. */ 1473 ffestdStmt_ stmt; 1474 int ents = ffestd_2pass_entrypoints_; 1475 1476 stmt = ffestd_stmt_list_.first; 1477 do 1478 { 1479 while (stmt->id != FFESTD_stmtidR1226_) 1480 stmt = stmt->next; 1481 1482 if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry)) 1483 { 1484 stmt->u.R1226.entry = NULL; 1485 --ffestd_2pass_entrypoints_; 1486 } 1487 stmt = stmt->next; 1488 } 1489 while (--ents != 0); 1490 } 1491#endif 1492} 1493 1494/* ffestd_exec_end -- Executable statements can no longer come in now 1495 1496 ffestd_exec_end(); */ 1497 1498void 1499ffestd_exec_end () 1500{ 1501#if FFECOM_targetCURRENT == FFECOM_targetGCC 1502 int old_lineno = lineno; 1503 char *old_input_filename = input_filename; 1504#endif 1505 1506 ffecom_end_transition (); 1507 1508#if FFECOM_TWOPASS 1509 ffestd_stmt_pass_ (); 1510#endif 1511 1512#if FFECOM_targetCURRENT == FFECOM_targetFFE 1513 fputs ("} end_exec\n", dmpout); 1514 fputs ("> end_unit\n", dmpout); 1515#endif 1516 1517#if FFECOM_targetCURRENT == FFECOM_targetGCC 1518 ffecom_finish_progunit (); 1519 1520 if (ffestd_2pass_entrypoints_ != 0) 1521 { 1522 int ents = ffestd_2pass_entrypoints_; 1523 ffestdStmt_ stmt = ffestd_stmt_list_.first; 1524 1525 do 1526 { 1527 while (stmt->id != FFESTD_stmtidR1226_) 1528 stmt = stmt->next; 1529 1530 if (stmt->u.R1226.entry != NULL) 1531 { 1532 ffestd_subr_line_restore_ (stmt); 1533 ffecom_2pass_do_entrypoint (stmt->u.R1226.entry); 1534 } 1535 stmt = stmt->next; 1536 } 1537 while (--ents != 0); 1538 } 1539 1540 ffestd_stmt_list_.first = NULL; 1541 ffestd_stmt_list_.last = NULL; 1542 ffestd_2pass_entrypoints_ = 0; 1543 1544 lineno = old_lineno; 1545 input_filename = old_input_filename; 1546#endif 1547} 1548 1549/* ffestd_init_3 -- Initialize for any program unit 1550 1551 ffestd_init_3(); */ 1552 1553void 1554ffestd_init_3 () 1555{ 1556#if FFECOM_TWOPASS 1557 ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first; 1558 ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first; 1559#endif 1560} 1561 1562/* Generate "code" for "any" label def. */ 1563 1564void 1565ffestd_labeldef_any (ffelab label UNUSED) 1566{ 1567#if FFECOM_targetCURRENT == FFECOM_targetFFE 1568 fprintf (dmpout, "; any_label_def %lu\n", ffelab_value (label)); 1569#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1570#else 1571#error 1572#endif 1573} 1574 1575/* ffestd_labeldef_branch -- Generate "code" for branch label def 1576 1577 ffestd_labeldef_branch(label); */ 1578 1579void 1580ffestd_labeldef_branch (ffelab label) 1581{ 1582#if FFECOM_ONEPASS 1583 ffeste_labeldef_branch (label); 1584#else 1585 { 1586 ffestdStmt_ stmt; 1587 1588 stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_); 1589 ffestd_stmt_append_ (stmt); 1590 stmt->u.execlabel.label = label; 1591 } 1592#endif 1593 1594 ffestd_is_reachable_ = TRUE; 1595} 1596 1597/* ffestd_labeldef_format -- Generate "code" for FORMAT label def 1598 1599 ffestd_labeldef_format(label); */ 1600 1601void 1602ffestd_labeldef_format (ffelab label) 1603{ 1604 ffestd_label_formatdef_ = label; 1605 1606#if FFECOM_ONEPASS 1607 ffeste_labeldef_format (label); 1608#else 1609 { 1610 ffestdStmt_ stmt; 1611 1612 stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_); 1613#if 0 1614 /* Don't bother with this. See FORMAT statement. */ 1615 /* Prepend FORMAT label instead of appending it, so all the 1616 FORMAT label/statement pairs end up at the top of the list. 1617 This helps ensure all decls for a block (in the GBE) are 1618 known before any executable statements are generated. */ 1619 stmt->previous = (ffestdStmt_) &ffestd_stmt_list_.first; 1620 stmt->next = ffestd_stmt_list_.first; 1621 stmt->next->previous = stmt; 1622 stmt->previous->next = stmt; 1623#else 1624 ffestd_stmt_append_ (stmt); 1625#endif 1626 stmt->u.formatlabel.label = label; 1627 } 1628#endif 1629} 1630 1631/* ffestd_labeldef_useless -- Generate "code" for useless label def 1632 1633 ffestd_labeldef_useless(label); */ 1634 1635void 1636ffestd_labeldef_useless (ffelab label UNUSED) 1637{ 1638#if FFECOM_targetCURRENT == FFECOM_targetFFE 1639 fprintf (dmpout, "; useless_label_def %lu\n", ffelab_value (label)); 1640#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1641#else 1642#error 1643#endif 1644} 1645 1646/* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement) 1647 1648 ffestd_R423A(); */ 1649 1650#if FFESTR_F90 1651void 1652ffestd_R423A () 1653{ 1654 ffestd_check_simple_ (); 1655 1656#if FFECOM_targetCURRENT == FFECOM_targetFFE 1657 fputs ("* PRIVATE_derived_type\n", dmpout); 1658#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1659#else 1660#error 1661#endif 1662} 1663 1664/* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt) 1665 1666 ffestd_R423B(); */ 1667 1668void 1669ffestd_R423B () 1670{ 1671 ffestd_check_simple_ (); 1672 1673#if FFECOM_targetCURRENT == FFECOM_targetFFE 1674 fputs ("* SEQUENCE_derived_type\n", dmpout); 1675#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1676#else 1677#error 1678#endif 1679} 1680 1681/* ffestd_R424 -- derived-TYPE-def statement 1682 1683 ffestd_R424(access_token,access_kw,name_token); 1684 1685 Handle a derived-type definition. */ 1686 1687void 1688ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name) 1689{ 1690 ffestd_check_simple_ (); 1691 1692 ffestd_subr_f90_ (); 1693 return; 1694 1695#ifdef FFESTD_F90 1696 char *a; 1697 1698 if (access == NULL) 1699 fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name)); 1700 else 1701 { 1702 switch (access_kw) 1703 { 1704 case FFESTR_otherPUBLIC: 1705 a = "PUBLIC"; 1706 break; 1707 1708 case FFESTR_otherPRIVATE: 1709 a = "PRIVATE"; 1710 break; 1711 1712 default: 1713 assert (FALSE); 1714 } 1715 fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name)); 1716 } 1717#endif 1718} 1719 1720/* ffestd_R425 -- End a TYPE 1721 1722 ffestd_R425(TRUE); */ 1723 1724void 1725ffestd_R425 (bool ok) 1726{ 1727#if FFECOM_targetCURRENT == FFECOM_targetFFE 1728 fprintf (dmpout, "* END_TYPE %s\n", ffelex_token_text (ffestw_name (ffestw_stack_top ()))); 1729#elif FFECOM_targetCURRENT == FFECOM_targetGCC 1730#else 1731#error 1732#endif 1733} 1734 1735/* ffestd_R519_start -- INTENT statement list begin 1736 1737 ffestd_R519_start(); 1738 1739 Verify that INTENT is valid here, and begin accepting items in the list. */ 1740 1741void 1742ffestd_R519_start (ffestrOther intent_kw) 1743{ 1744 ffestd_check_start_ (); 1745 1746 ffestd_subr_f90_ (); 1747 return; 1748 1749#ifdef FFESTD_F90 1750 char *a; 1751 1752 switch (intent_kw) 1753 { 1754 case FFESTR_otherIN: 1755 a = "IN"; 1756 break; 1757 1758 case FFESTR_otherOUT: 1759 a = "OUT"; 1760 break; 1761 1762 case FFESTR_otherINOUT: 1763 a = "INOUT"; 1764 break; 1765 1766 default: 1767 assert (FALSE); 1768 } 1769 fprintf (dmpout, "* INTENT (%s) ", a); 1770#endif 1771} 1772 1773/* ffestd_R519_item -- INTENT statement for name 1774 1775 ffestd_R519_item(name_token); 1776 1777 Make sure name_token identifies a valid object to be INTENTed. */ 1778 1779void 1780ffestd_R519_item (ffelexToken name) 1781{ 1782 ffestd_check_item_ (); 1783 1784 return; /* F90. */ 1785 1786#ifdef FFESTD_F90 1787 fprintf (dmpout, "%s,", ffelex_token_text (name)); 1788#endif 1789} 1790 1791/* ffestd_R519_finish -- INTENT statement list complete 1792 1793 ffestd_R519_finish(); 1794 1795 Just wrap up any local activities. */ 1796 1797void 1798ffestd_R519_finish () 1799{ 1800 ffestd_check_finish_ (); 1801 1802 return; /* F90. */ 1803 1804#ifdef FFESTD_F90 1805 fputc ('\n', dmpout); 1806#endif 1807} 1808 1809/* ffestd_R520_start -- OPTIONAL statement list begin 1810 1811 ffestd_R520_start(); 1812 1813 Verify that OPTIONAL is valid here, and begin accepting items in the list. */ 1814 1815void 1816ffestd_R520_start () 1817{ 1818 ffestd_check_start_ (); 1819 1820 ffestd_subr_f90_ (); 1821 return; 1822 1823#ifdef FFESTD_F90 1824 fputs ("* OPTIONAL ", dmpout); 1825#endif 1826} 1827 1828/* ffestd_R520_item -- OPTIONAL statement for name 1829 1830 ffestd_R520_item(name_token); 1831 1832 Make sure name_token identifies a valid object to be OPTIONALed. */ 1833 1834void 1835ffestd_R520_item (ffelexToken name) 1836{ 1837 ffestd_check_item_ (); 1838 1839 return; /* F90. */ 1840 1841#ifdef FFESTD_F90 1842 fprintf (dmpout, "%s,", ffelex_token_text (name)); 1843#endif 1844} 1845 1846/* ffestd_R520_finish -- OPTIONAL statement list complete 1847 1848 ffestd_R520_finish(); 1849 1850 Just wrap up any local activities. */ 1851 1852void 1853ffestd_R520_finish () 1854{ 1855 ffestd_check_finish_ (); 1856 1857 return; /* F90. */ 1858 1859#ifdef FFESTD_F90 1860 fputc ('\n', dmpout); 1861#endif 1862} 1863 1864/* ffestd_R521A -- PUBLIC statement 1865 1866 ffestd_R521A(); 1867 1868 Verify that PUBLIC is valid here. */ 1869 1870void 1871ffestd_R521A () 1872{ 1873 ffestd_check_simple_ (); 1874 1875 ffestd_subr_f90_ (); 1876 return; 1877 1878#ifdef FFESTD_F90 1879 fputs ("* PUBLIC\n", dmpout); 1880#endif 1881} 1882 1883/* ffestd_R521Astart -- PUBLIC statement list begin 1884 1885 ffestd_R521Astart(); 1886 1887 Verify that PUBLIC is valid here, and begin accepting items in the list. */ 1888 1889void 1890ffestd_R521Astart () 1891{ 1892 ffestd_check_start_ (); 1893 1894 ffestd_subr_f90_ (); 1895 return; 1896 1897#ifdef FFESTD_F90 1898 fputs ("* PUBLIC ", dmpout); 1899#endif 1900} 1901 1902/* ffestd_R521Aitem -- PUBLIC statement for name 1903 1904 ffestd_R521Aitem(name_token); 1905 1906 Make sure name_token identifies a valid object to be PUBLICed. */ 1907 1908void 1909ffestd_R521Aitem (ffelexToken name) 1910{ 1911 ffestd_check_item_ (); 1912 1913 return; /* F90. */ 1914 1915#ifdef FFESTD_F90 1916 fprintf (dmpout, "%s,", ffelex_token_text (name)); 1917#endif 1918} 1919 1920/* ffestd_R521Afinish -- PUBLIC statement list complete 1921 1922 ffestd_R521Afinish(); 1923 1924 Just wrap up any local activities. */ 1925 1926void 1927ffestd_R521Afinish () 1928{ 1929 ffestd_check_finish_ (); 1930 1931 return; /* F90. */ 1932 1933#ifdef FFESTD_F90 1934 fputc ('\n', dmpout); 1935#endif 1936} 1937 1938/* ffestd_R521B -- PRIVATE statement 1939 1940 ffestd_R521B(); 1941 1942 Verify that PRIVATE is valid here (outside a derived-type statement). */ 1943 1944void 1945ffestd_R521B () 1946{ 1947 ffestd_check_simple_ (); 1948 1949 ffestd_subr_f90_ (); 1950 return; 1951 1952#ifdef FFESTD_F90 1953 fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout); 1954#endif 1955} 1956 1957/* ffestd_R521Bstart -- PRIVATE statement list begin 1958 1959 ffestd_R521Bstart(); 1960 1961 Verify that PRIVATE is valid here, and begin accepting items in the list. */ 1962 1963void 1964ffestd_R521Bstart () 1965{ 1966 ffestd_check_start_ (); 1967 1968 ffestd_subr_f90_ (); 1969 return; 1970 1971#ifdef FFESTD_F90 1972 fputs ("* PRIVATE ", dmpout); 1973#endif 1974} 1975 1976/* ffestd_R521Bitem -- PRIVATE statement for name 1977 1978 ffestd_R521Bitem(name_token); 1979 1980 Make sure name_token identifies a valid object to be PRIVATEed. */ 1981 1982void 1983ffestd_R521Bitem (ffelexToken name) 1984{ 1985 ffestd_check_item_ (); 1986 1987 return; /* F90. */ 1988 1989#ifdef FFESTD_F90 1990 fprintf (dmpout, "%s,", ffelex_token_text (name)); 1991#endif 1992} 1993 1994/* ffestd_R521Bfinish -- PRIVATE statement list complete 1995 1996 ffestd_R521Bfinish(); 1997 1998 Just wrap up any local activities. */ 1999 2000void 2001ffestd_R521Bfinish () 2002{ 2003 ffestd_check_finish_ (); 2004 2005 return; /* F90. */ 2006 2007#ifdef FFESTD_F90 2008 fputc ('\n', dmpout); 2009#endif 2010} 2011 2012#endif 2013/* ffestd_R522 -- SAVE statement with no list 2014 2015 ffestd_R522(); 2016 2017 Verify that SAVE is valid here, and flag everything as SAVEd. */ 2018 2019void 2020ffestd_R522 () 2021{ 2022 ffestd_check_simple_ (); 2023 2024#if FFECOM_targetCURRENT == FFECOM_targetFFE 2025 fputs ("* SAVE_all\n", dmpout); 2026#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2027#else 2028#error 2029#endif 2030} 2031 2032/* ffestd_R522start -- SAVE statement list begin 2033 2034 ffestd_R522start(); 2035 2036 Verify that SAVE is valid here, and begin accepting items in the list. */ 2037 2038void 2039ffestd_R522start () 2040{ 2041 ffestd_check_start_ (); 2042 2043#if FFECOM_targetCURRENT == FFECOM_targetFFE 2044 fputs ("* SAVE ", dmpout); 2045#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2046#else 2047#error 2048#endif 2049} 2050 2051/* ffestd_R522item_object -- SAVE statement for object-name 2052 2053 ffestd_R522item_object(name_token); 2054 2055 Make sure name_token identifies a valid object to be SAVEd. */ 2056 2057void 2058ffestd_R522item_object (ffelexToken name UNUSED) 2059{ 2060 ffestd_check_item_ (); 2061 2062#if FFECOM_targetCURRENT == FFECOM_targetFFE 2063 fprintf (dmpout, "%s,", ffelex_token_text (name)); 2064#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2065#else 2066#error 2067#endif 2068} 2069 2070/* ffestd_R522item_cblock -- SAVE statement for common-block-name 2071 2072 ffestd_R522item_cblock(name_token); 2073 2074 Make sure name_token identifies a valid common block to be SAVEd. */ 2075 2076void 2077ffestd_R522item_cblock (ffelexToken name UNUSED) 2078{ 2079 ffestd_check_item_ (); 2080 2081#if FFECOM_targetCURRENT == FFECOM_targetFFE 2082 fprintf (dmpout, "/%s/,", ffelex_token_text (name)); 2083#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2084#else 2085#error 2086#endif 2087} 2088 2089/* ffestd_R522finish -- SAVE statement list complete 2090 2091 ffestd_R522finish(); 2092 2093 Just wrap up any local activities. */ 2094 2095void 2096ffestd_R522finish () 2097{ 2098 ffestd_check_finish_ (); 2099 2100#if FFECOM_targetCURRENT == FFECOM_targetFFE 2101 fputc ('\n', dmpout); 2102#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2103#else 2104#error 2105#endif 2106} 2107 2108/* ffestd_R524_start -- DIMENSION statement list begin 2109 2110 ffestd_R524_start(bool virtual); 2111 2112 Verify that DIMENSION is valid here, and begin accepting items in the list. */ 2113 2114void 2115ffestd_R524_start (bool virtual UNUSED) 2116{ 2117 ffestd_check_start_ (); 2118 2119#if FFECOM_targetCURRENT == FFECOM_targetFFE 2120 if (virtual) 2121 fputs ("* VIRTUAL ", dmpout); /* V028. */ 2122 else 2123 fputs ("* DIMENSION ", dmpout); 2124#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2125#else 2126#error 2127#endif 2128} 2129 2130/* ffestd_R524_item -- DIMENSION statement for object-name 2131 2132 ffestd_R524_item(name_token,dim_list); 2133 2134 Make sure name_token identifies a valid object to be DIMENSIONd. */ 2135 2136void 2137ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED) 2138{ 2139 ffestd_check_item_ (); 2140 2141#if FFECOM_targetCURRENT == FFECOM_targetFFE 2142 fputs (ffelex_token_text (name), dmpout); 2143 fputc ('(', dmpout); 2144 ffestt_dimlist_dump (dims); 2145 fputs ("),", dmpout); 2146#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2147#else 2148#error 2149#endif 2150} 2151 2152/* ffestd_R524_finish -- DIMENSION statement list complete 2153 2154 ffestd_R524_finish(); 2155 2156 Just wrap up any local activities. */ 2157 2158void 2159ffestd_R524_finish () 2160{ 2161 ffestd_check_finish_ (); 2162 2163#if FFECOM_targetCURRENT == FFECOM_targetFFE 2164 fputc ('\n', dmpout); 2165#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2166#else 2167#error 2168#endif 2169} 2170 2171/* ffestd_R525_start -- ALLOCATABLE statement list begin 2172 2173 ffestd_R525_start(); 2174 2175 Verify that ALLOCATABLE is valid here, and begin accepting items in the 2176 list. */ 2177 2178#if FFESTR_F90 2179void 2180ffestd_R525_start () 2181{ 2182 ffestd_check_start_ (); 2183 2184 ffestd_subr_f90_ (); 2185 return; 2186 2187#ifdef FFESTD_F90 2188 fputs ("* ALLOCATABLE ", dmpout); 2189#endif 2190} 2191 2192/* ffestd_R525_item -- ALLOCATABLE statement for object-name 2193 2194 ffestd_R525_item(name_token,dim_list); 2195 2196 Make sure name_token identifies a valid object to be ALLOCATABLEd. */ 2197 2198void 2199ffestd_R525_item (ffelexToken name, ffesttDimList dims) 2200{ 2201 ffestd_check_item_ (); 2202 2203 return; /* F90. */ 2204 2205#ifdef FFESTD_F90 2206 fputs (ffelex_token_text (name), dmpout); 2207 if (dims != NULL) 2208 { 2209 fputc ('(', dmpout); 2210 ffestt_dimlist_dump (dims); 2211 fputc (')', dmpout); 2212 } 2213 fputc (',', dmpout); 2214#endif 2215} 2216 2217/* ffestd_R525_finish -- ALLOCATABLE statement list complete 2218 2219 ffestd_R525_finish(); 2220 2221 Just wrap up any local activities. */ 2222 2223void 2224ffestd_R525_finish () 2225{ 2226 ffestd_check_finish_ (); 2227 2228 return; /* F90. */ 2229 2230#ifdef FFESTD_F90 2231 fputc ('\n', dmpout); 2232#endif 2233} 2234 2235/* ffestd_R526_start -- POINTER statement list begin 2236 2237 ffestd_R526_start(); 2238 2239 Verify that POINTER is valid here, and begin accepting items in the 2240 list. */ 2241 2242void 2243ffestd_R526_start () 2244{ 2245 ffestd_check_start_ (); 2246 2247 ffestd_subr_f90_ (); 2248 return; 2249 2250#ifdef FFESTD_F90 2251 fputs ("* POINTER ", dmpout); 2252#endif 2253} 2254 2255/* ffestd_R526_item -- POINTER statement for object-name 2256 2257 ffestd_R526_item(name_token,dim_list); 2258 2259 Make sure name_token identifies a valid object to be POINTERd. */ 2260 2261void 2262ffestd_R526_item (ffelexToken name, ffesttDimList dims) 2263{ 2264 ffestd_check_item_ (); 2265 2266 return; /* F90. */ 2267 2268#ifdef FFESTD_F90 2269 fputs (ffelex_token_text (name), dmpout); 2270 if (dims != NULL) 2271 { 2272 fputc ('(', dmpout); 2273 ffestt_dimlist_dump (dims); 2274 fputc (')', dmpout); 2275 } 2276 fputc (',', dmpout); 2277#endif 2278} 2279 2280/* ffestd_R526_finish -- POINTER statement list complete 2281 2282 ffestd_R526_finish(); 2283 2284 Just wrap up any local activities. */ 2285 2286void 2287ffestd_R526_finish () 2288{ 2289 ffestd_check_finish_ (); 2290 2291 return; /* F90. */ 2292 2293#ifdef FFESTD_F90 2294 fputc ('\n', dmpout); 2295#endif 2296} 2297 2298/* ffestd_R527_start -- TARGET statement list begin 2299 2300 ffestd_R527_start(); 2301 2302 Verify that TARGET is valid here, and begin accepting items in the 2303 list. */ 2304 2305void 2306ffestd_R527_start () 2307{ 2308 ffestd_check_start_ (); 2309 2310 ffestd_subr_f90_ (); 2311 return; 2312 2313#ifdef FFESTD_F90 2314 fputs ("* TARGET ", dmpout); 2315#endif 2316} 2317 2318/* ffestd_R527_item -- TARGET statement for object-name 2319 2320 ffestd_R527_item(name_token,dim_list); 2321 2322 Make sure name_token identifies a valid object to be TARGETd. */ 2323 2324void 2325ffestd_R527_item (ffelexToken name, ffesttDimList dims) 2326{ 2327 ffestd_check_item_ (); 2328 2329 return; /* F90. */ 2330 2331#ifdef FFESTD_F90 2332 fputs (ffelex_token_text (name), dmpout); 2333 if (dims != NULL) 2334 { 2335 fputc ('(', dmpout); 2336 ffestt_dimlist_dump (dims); 2337 fputc (')', dmpout); 2338 } 2339 fputc (',', dmpout); 2340#endif 2341} 2342 2343/* ffestd_R527_finish -- TARGET statement list complete 2344 2345 ffestd_R527_finish(); 2346 2347 Just wrap up any local activities. */ 2348 2349void 2350ffestd_R527_finish () 2351{ 2352 ffestd_check_finish_ (); 2353 2354 return; /* F90. */ 2355 2356#ifdef FFESTD_F90 2357 fputc ('\n', dmpout); 2358#endif 2359} 2360 2361#endif 2362/* ffestd_R537_start -- PARAMETER statement list begin 2363 2364 ffestd_R537_start(); 2365 2366 Verify that PARAMETER is valid here, and begin accepting items in the list. */ 2367 2368void 2369ffestd_R537_start () 2370{ 2371 ffestd_check_start_ (); 2372 2373#if FFECOM_targetCURRENT == FFECOM_targetFFE 2374 fputs ("* PARAMETER (", dmpout); 2375#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2376#else 2377#error 2378#endif 2379} 2380 2381/* ffestd_R537_item -- PARAMETER statement assignment 2382 2383 ffestd_R537_item(dest,dest_token,source,source_token); 2384 2385 Make sure the source is a valid source for the destination; make the 2386 assignment. */ 2387 2388void 2389ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED) 2390{ 2391 ffestd_check_item_ (); 2392 2393#if FFECOM_targetCURRENT == FFECOM_targetFFE 2394 ffebld_dump (dest); 2395 fputc ('=', dmpout); 2396 ffebld_dump (source); 2397 fputc (',', dmpout); 2398#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2399#else 2400#error 2401#endif 2402} 2403 2404/* ffestd_R537_finish -- PARAMETER statement list complete 2405 2406 ffestd_R537_finish(); 2407 2408 Just wrap up any local activities. */ 2409 2410void 2411ffestd_R537_finish () 2412{ 2413 ffestd_check_finish_ (); 2414 2415#if FFECOM_targetCURRENT == FFECOM_targetFFE 2416 fputs (")\n", dmpout); 2417#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2418#else 2419#error 2420#endif 2421} 2422 2423/* ffestd_R539 -- IMPLICIT NONE statement 2424 2425 ffestd_R539(); 2426 2427 Verify that the IMPLICIT NONE statement is ok here and implement. */ 2428 2429void 2430ffestd_R539 () 2431{ 2432 ffestd_check_simple_ (); 2433 2434#if FFECOM_targetCURRENT == FFECOM_targetFFE 2435 fputs ("* IMPLICIT_NONE\n", dmpout); 2436#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2437#else 2438#error 2439#endif 2440} 2441 2442/* ffestd_R539start -- IMPLICIT statement 2443 2444 ffestd_R539start(); 2445 2446 Verify that the IMPLICIT statement is ok here and implement. */ 2447 2448void 2449ffestd_R539start () 2450{ 2451 ffestd_check_start_ (); 2452 2453#if FFECOM_targetCURRENT == FFECOM_targetFFE 2454 fputs ("* IMPLICIT ", dmpout); 2455#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2456#else 2457#error 2458#endif 2459} 2460 2461/* ffestd_R539item -- IMPLICIT statement specification (R540) 2462 2463 ffestd_R539item(...); 2464 2465 Verify that the type and letter list are all ok and implement. */ 2466 2467void 2468ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED, 2469 ffelexToken kindt UNUSED, ffebld len UNUSED, 2470 ffelexToken lent UNUSED, ffesttImpList letters UNUSED) 2471{ 2472#if FFECOM_targetCURRENT == FFECOM_targetFFE 2473 char *a; 2474#endif 2475 2476 ffestd_check_item_ (); 2477 2478#if FFECOM_targetCURRENT == FFECOM_targetFFE 2479 switch (type) 2480 { 2481 case FFESTP_typeINTEGER: 2482 a = "INTEGER"; 2483 break; 2484 2485 case FFESTP_typeBYTE: 2486 a = "BYTE"; 2487 break; 2488 2489 case FFESTP_typeWORD: 2490 a = "WORD"; 2491 break; 2492 2493 case FFESTP_typeREAL: 2494 a = "REAL"; 2495 break; 2496 2497 case FFESTP_typeCOMPLEX: 2498 a = "COMPLEX"; 2499 break; 2500 2501 case FFESTP_typeLOGICAL: 2502 a = "LOGICAL"; 2503 break; 2504 2505 case FFESTP_typeCHARACTER: 2506 a = "CHARACTER"; 2507 break; 2508 2509 case FFESTP_typeDBLPRCSN: 2510 a = "DOUBLE PRECISION"; 2511 break; 2512 2513 case FFESTP_typeDBLCMPLX: 2514 a = "DOUBLE COMPLEX"; 2515 break; 2516 2517#if FFESTR_F90 2518 case FFESTP_typeTYPE: 2519 a = "TYPE"; 2520 break; 2521#endif 2522 2523 default: 2524 assert (FALSE); 2525 a = "?"; 2526 break; 2527 } 2528 fprintf (dmpout, "%s(", a); 2529 if (kindt != NULL) 2530 { 2531 fputs ("kind=", dmpout); 2532 if (kind == NULL) 2533 fputs (ffelex_token_text (kindt), dmpout); 2534 else 2535 ffebld_dump (kind); 2536 if (lent != NULL) 2537 fputc (',', dmpout); 2538 } 2539 if (lent != NULL) 2540 { 2541 fputs ("len=", dmpout); 2542 if (len == NULL) 2543 fputs (ffelex_token_text (lent), dmpout); 2544 else 2545 ffebld_dump (len); 2546 } 2547 fputs (")(", dmpout); 2548 ffestt_implist_dump (letters); 2549 fputs ("),", dmpout); 2550#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2551#else 2552#error 2553#endif 2554} 2555 2556/* ffestd_R539finish -- IMPLICIT statement 2557 2558 ffestd_R539finish(); 2559 2560 Finish up any local activities. */ 2561 2562void 2563ffestd_R539finish () 2564{ 2565 ffestd_check_finish_ (); 2566 2567#if FFECOM_targetCURRENT == FFECOM_targetFFE 2568 fputc ('\n', dmpout); 2569#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2570#else 2571#error 2572#endif 2573} 2574 2575/* ffestd_R542_start -- NAMELIST statement list begin 2576 2577 ffestd_R542_start(); 2578 2579 Verify that NAMELIST is valid here, and begin accepting items in the list. */ 2580 2581void 2582ffestd_R542_start () 2583{ 2584 ffestd_check_start_ (); 2585 2586#if FFECOM_targetCURRENT == FFECOM_targetFFE 2587 fputs ("* NAMELIST ", dmpout); 2588#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2589#else 2590#error 2591#endif 2592} 2593 2594/* ffestd_R542_item_nlist -- NAMELIST statement for group-name 2595 2596 ffestd_R542_item_nlist(groupname_token); 2597 2598 Make sure name_token identifies a valid object to be NAMELISTd. */ 2599 2600void 2601ffestd_R542_item_nlist (ffelexToken name UNUSED) 2602{ 2603 ffestd_check_item_ (); 2604 2605#if FFECOM_targetCURRENT == FFECOM_targetFFE 2606 fprintf (dmpout, "/%s/", ffelex_token_text (name)); 2607#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2608#else 2609#error 2610#endif 2611} 2612 2613/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name 2614 2615 ffestd_R542_item_nitem(name_token); 2616 2617 Make sure name_token identifies a valid object to be NAMELISTd. */ 2618 2619void 2620ffestd_R542_item_nitem (ffelexToken name UNUSED) 2621{ 2622 ffestd_check_item_ (); 2623 2624#if FFECOM_targetCURRENT == FFECOM_targetFFE 2625 fprintf (dmpout, "%s,", ffelex_token_text (name)); 2626#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2627#else 2628#error 2629#endif 2630} 2631 2632/* ffestd_R542_finish -- NAMELIST statement list complete 2633 2634 ffestd_R542_finish(); 2635 2636 Just wrap up any local activities. */ 2637 2638void 2639ffestd_R542_finish () 2640{ 2641 ffestd_check_finish_ (); 2642 2643#if FFECOM_targetCURRENT == FFECOM_targetFFE 2644 fputc ('\n', dmpout); 2645#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2646#else 2647#error 2648#endif 2649} 2650 2651/* ffestd_R544_start -- EQUIVALENCE statement list begin 2652 2653 ffestd_R544_start(); 2654 2655 Verify that EQUIVALENCE is valid here, and begin accepting items in the 2656 list. */ 2657 2658#if 0 2659void 2660ffestd_R544_start () 2661{ 2662 ffestd_check_start_ (); 2663 2664#if FFECOM_targetCURRENT == FFECOM_targetFFE 2665 fputs ("* EQUIVALENCE (", dmpout); 2666#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2667#else 2668#error 2669#endif 2670} 2671 2672#endif 2673/* ffestd_R544_item -- EQUIVALENCE statement assignment 2674 2675 ffestd_R544_item(exprlist); 2676 2677 Make sure the equivalence is valid, then implement it. */ 2678 2679#if 0 2680void 2681ffestd_R544_item (ffesttExprList exprlist) 2682{ 2683 ffestd_check_item_ (); 2684 2685#if FFECOM_targetCURRENT == FFECOM_targetFFE 2686 ffestt_exprlist_dump (exprlist); 2687 fputs ("),", dmpout); 2688#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2689#else 2690#error 2691#endif 2692} 2693 2694#endif 2695/* ffestd_R544_finish -- EQUIVALENCE statement list complete 2696 2697 ffestd_R544_finish(); 2698 2699 Just wrap up any local activities. */ 2700 2701#if 0 2702void 2703ffestd_R544_finish () 2704{ 2705 ffestd_check_finish_ (); 2706 2707#if FFECOM_targetCURRENT == FFECOM_targetFFE 2708 fputs (")\n", dmpout); 2709#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2710#else 2711#error 2712#endif 2713} 2714 2715#endif 2716/* ffestd_R547_start -- COMMON statement list begin 2717 2718 ffestd_R547_start(); 2719 2720 Verify that COMMON is valid here, and begin accepting items in the list. */ 2721 2722void 2723ffestd_R547_start () 2724{ 2725 ffestd_check_start_ (); 2726 2727#if FFECOM_targetCURRENT == FFECOM_targetFFE 2728 fputs ("* COMMON ", dmpout); 2729#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2730#else 2731#error 2732#endif 2733} 2734 2735/* ffestd_R547_item_object -- COMMON statement for object-name 2736 2737 ffestd_R547_item_object(name_token,dim_list); 2738 2739 Make sure name_token identifies a valid object to be COMMONd. */ 2740 2741void 2742ffestd_R547_item_object (ffelexToken name UNUSED, 2743 ffesttDimList dims UNUSED) 2744{ 2745 ffestd_check_item_ (); 2746 2747#if FFECOM_targetCURRENT == FFECOM_targetFFE 2748 fputs (ffelex_token_text (name), dmpout); 2749 if (dims != NULL) 2750 { 2751 fputc ('(', dmpout); 2752 ffestt_dimlist_dump (dims); 2753 fputc (')', dmpout); 2754 } 2755 fputc (',', dmpout); 2756#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2757#else 2758#error 2759#endif 2760} 2761 2762/* ffestd_R547_item_cblock -- COMMON statement for common-block-name 2763 2764 ffestd_R547_item_cblock(name_token); 2765 2766 Make sure name_token identifies a valid common block to be COMMONd. */ 2767 2768void 2769ffestd_R547_item_cblock (ffelexToken name UNUSED) 2770{ 2771 ffestd_check_item_ (); 2772 2773#if FFECOM_targetCURRENT == FFECOM_targetFFE 2774 if (name == NULL) 2775 fputs ("//,", dmpout); 2776 else 2777 fprintf (dmpout, "/%s/,", ffelex_token_text (name)); 2778#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2779#else 2780#error 2781#endif 2782} 2783 2784/* ffestd_R547_finish -- COMMON statement list complete 2785 2786 ffestd_R547_finish(); 2787 2788 Just wrap up any local activities. */ 2789 2790void 2791ffestd_R547_finish () 2792{ 2793 ffestd_check_finish_ (); 2794 2795#if FFECOM_targetCURRENT == FFECOM_targetFFE 2796 fputc ('\n', dmpout); 2797#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2798#else 2799#error 2800#endif 2801} 2802 2803/* ffestd_R620 -- ALLOCATE statement 2804 2805 ffestd_R620(exprlist,stat,stat_token); 2806 2807 Make sure the expression list is valid, then implement it. */ 2808 2809#if FFESTR_F90 2810void 2811ffestd_R620 (ffesttExprList exprlist, ffebld stat) 2812{ 2813 ffestd_check_simple_ (); 2814 2815 ffestd_subr_f90_ (); 2816 return; 2817 2818#ifdef FFESTD_F90 2819 fputs ("+ ALLOCATE (", dmpout); 2820 ffestt_exprlist_dump (exprlist); 2821 if (stat != NULL) 2822 { 2823 fputs (",stat=", dmpout); 2824 ffebld_dump (stat); 2825 } 2826 fputs (")\n", dmpout); 2827#endif 2828} 2829 2830/* ffestd_R624 -- NULLIFY statement 2831 2832 ffestd_R624(pointer_name_list); 2833 2834 Make sure pointer_name_list identifies valid pointers for a NULLIFY. */ 2835 2836void 2837ffestd_R624 (ffesttExprList pointers) 2838{ 2839 ffestd_check_simple_ (); 2840 2841 ffestd_subr_f90_ (); 2842 return; 2843 2844#ifdef FFESTD_F90 2845 fputs ("+ NULLIFY (", dmpout); 2846 assert (pointers != NULL); 2847 ffestt_exprlist_dump (pointers); 2848 fputs (")\n", dmpout); 2849#endif 2850} 2851 2852/* ffestd_R625 -- DEALLOCATE statement 2853 2854 ffestd_R625(exprlist,stat,stat_token); 2855 2856 Make sure the equivalence is valid, then implement it. */ 2857 2858void 2859ffestd_R625 (ffesttExprList exprlist, ffebld stat) 2860{ 2861 ffestd_check_simple_ (); 2862 2863 ffestd_subr_f90_ (); 2864 return; 2865 2866#ifdef FFESTD_F90 2867 fputs ("+ DEALLOCATE (", dmpout); 2868 ffestt_exprlist_dump (exprlist); 2869 if (stat != NULL) 2870 { 2871 fputs (",stat=", dmpout); 2872 ffebld_dump (stat); 2873 } 2874 fputs (")\n", dmpout); 2875#endif 2876} 2877 2878#endif 2879/* ffestd_R737A -- Assignment statement outside of WHERE 2880 2881 ffestd_R737A(dest_expr,source_expr); */ 2882 2883void 2884ffestd_R737A (ffebld dest, ffebld source) 2885{ 2886 ffestd_check_simple_ (); 2887 2888#if FFECOM_ONEPASS 2889 ffestd_subr_line_now_ (); 2890 ffeste_R737A (dest, source); 2891#else 2892 { 2893 ffestdStmt_ stmt; 2894 2895 stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_); 2896 ffestd_stmt_append_ (stmt); 2897 ffestd_subr_line_save_ (stmt); 2898 stmt->u.R737A.pool = ffesta_output_pool; 2899 stmt->u.R737A.dest = dest; 2900 stmt->u.R737A.source = source; 2901 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 2902 } 2903#endif 2904} 2905 2906/* ffestd_R737B -- Assignment statement inside of WHERE 2907 2908 ffestd_R737B(dest_expr,source_expr); */ 2909 2910#if FFESTR_F90 2911void 2912ffestd_R737B (ffebld dest, ffebld source) 2913{ 2914 ffestd_check_simple_ (); 2915 2916 return; /* F90. */ 2917 2918#ifdef FFESTD_F90 2919 fputs ("+ let_inside_where ", dmpout); 2920 ffebld_dump (dest); 2921 fputs ("=", dmpout); 2922 ffebld_dump (source); 2923 fputc ('\n', dmpout); 2924#endif 2925} 2926 2927/* ffestd_R738 -- Pointer assignment statement 2928 2929 ffestd_R738(dest_expr,source_expr,source_token); 2930 2931 Make sure the assignment is valid. */ 2932 2933void 2934ffestd_R738 (ffebld dest, ffebld source) 2935{ 2936 ffestd_check_simple_ (); 2937 2938 ffestd_subr_f90_ (); 2939 return; 2940 2941#ifdef FFESTD_F90 2942 fputs ("+ let_pointer ", dmpout); 2943 ffebld_dump (dest); 2944 fputs ("=>", dmpout); 2945 ffebld_dump (source); 2946 fputc ('\n', dmpout); 2947#endif 2948} 2949 2950/* ffestd_R740 -- WHERE statement 2951 2952 ffestd_R740(expr,expr_token); 2953 2954 Make sure statement is valid here; implement. */ 2955 2956void 2957ffestd_R740 (ffebld expr) 2958{ 2959 ffestd_check_simple_ (); 2960 2961 ffestd_subr_f90_ (); 2962 return; 2963 2964#ifdef FFESTD_F90 2965 fputs ("+ WHERE (", dmpout); 2966 ffebld_dump (expr); 2967 fputs (")\n", dmpout); 2968 2969 ++ffestd_block_level_; 2970 assert (ffestd_block_level_ > 0); 2971#endif 2972} 2973 2974/* ffestd_R742 -- WHERE-construct statement 2975 2976 ffestd_R742(expr,expr_token); 2977 2978 Make sure statement is valid here; implement. */ 2979 2980void 2981ffestd_R742 (ffebld expr) 2982{ 2983 ffestd_check_simple_ (); 2984 2985 ffestd_subr_f90_ (); 2986 return; 2987 2988#ifdef FFESTD_F90 2989 fputs ("+ WHERE_construct (", dmpout); 2990 ffebld_dump (expr); 2991 fputs (")\n", dmpout); 2992 2993 ++ffestd_block_level_; 2994 assert (ffestd_block_level_ > 0); 2995#endif 2996} 2997 2998/* ffestd_R744 -- ELSE WHERE statement 2999 3000 ffestd_R744(); 3001 3002 Make sure ffestd_kind_ identifies a WHERE block. 3003 Implement the ELSE of the current WHERE block. */ 3004 3005void 3006ffestd_R744 () 3007{ 3008 ffestd_check_simple_ (); 3009 3010 return; /* F90. */ 3011 3012#ifdef FFESTD_F90 3013 fputs ("+ ELSE_WHERE\n", dmpout); 3014#endif 3015} 3016 3017/* ffestd_R745 -- Implicit END WHERE statement. */ 3018 3019void 3020ffestd_R745 (bool ok) 3021{ 3022 return; /* F90. */ 3023 3024#ifdef FFESTD_F90 3025 fputs ("+ END_WHERE\n", dmpout); /* Also see ffestd_R745. */ 3026 3027 --ffestd_block_level_; 3028 assert (ffestd_block_level_ >= 0); 3029#endif 3030} 3031 3032#endif 3033 3034/* Block IF (IF-THEN) statement. */ 3035 3036void 3037ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) 3038{ 3039 ffestd_check_simple_ (); 3040 3041#if FFECOM_ONEPASS 3042 ffestd_subr_line_now_ (); 3043 ffeste_R803 (expr); /* Don't bother with name. */ 3044#else 3045 { 3046 ffestdStmt_ stmt; 3047 3048 stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_); 3049 ffestd_stmt_append_ (stmt); 3050 ffestd_subr_line_save_ (stmt); 3051 stmt->u.R803.pool = ffesta_output_pool; 3052 stmt->u.R803.block = ffestw_use (ffestw_stack_top ()); 3053 stmt->u.R803.expr = expr; 3054 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3055 } 3056#endif 3057 3058 ++ffestd_block_level_; 3059 assert (ffestd_block_level_ > 0); 3060} 3061 3062/* ELSE IF statement. */ 3063 3064void 3065ffestd_R804 (ffebld expr, ffelexToken name UNUSED) 3066{ 3067 ffestd_check_simple_ (); 3068 3069#if FFECOM_ONEPASS 3070 ffestd_subr_line_now_ (); 3071 ffeste_R804 (expr); /* Don't bother with name. */ 3072#else 3073 { 3074 ffestdStmt_ stmt; 3075 3076 stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_); 3077 ffestd_stmt_append_ (stmt); 3078 ffestd_subr_line_save_ (stmt); 3079 stmt->u.R804.pool = ffesta_output_pool; 3080 stmt->u.R804.block = ffestw_use (ffestw_stack_top ()); 3081 stmt->u.R804.expr = expr; 3082 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3083 } 3084#endif 3085} 3086 3087/* ELSE statement. */ 3088 3089void 3090ffestd_R805 (ffelexToken name UNUSED) 3091{ 3092 ffestd_check_simple_ (); 3093 3094#if FFECOM_ONEPASS 3095 ffestd_subr_line_now_ (); 3096 ffeste_R805 (); /* Don't bother with name. */ 3097#else 3098 { 3099 ffestdStmt_ stmt; 3100 3101 stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_); 3102 ffestd_stmt_append_ (stmt); 3103 ffestd_subr_line_save_ (stmt); 3104 stmt->u.R805.block = ffestw_use (ffestw_stack_top ()); 3105 } 3106#endif 3107} 3108 3109/* END IF statement. */ 3110 3111void 3112ffestd_R806 (bool ok UNUSED) 3113{ 3114#if FFECOM_ONEPASS 3115 ffestd_subr_line_now_ (); 3116 ffeste_R806 (); 3117#else 3118 { 3119 ffestdStmt_ stmt; 3120 3121 stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_); 3122 ffestd_stmt_append_ (stmt); 3123 ffestd_subr_line_save_ (stmt); 3124 stmt->u.R806.block = ffestw_use (ffestw_stack_top ()); 3125 } 3126#endif 3127 3128 --ffestd_block_level_; 3129 assert (ffestd_block_level_ >= 0); 3130} 3131 3132/* ffestd_R807 -- Logical IF statement 3133 3134 ffestd_R807(expr,expr_token); 3135 3136 Make sure statement is valid here; implement. */ 3137 3138void 3139ffestd_R807 (ffebld expr) 3140{ 3141 ffestd_check_simple_ (); 3142 3143#if FFECOM_ONEPASS 3144 ffestd_subr_line_now_ (); 3145 ffeste_R807 (expr); 3146#else 3147 { 3148 ffestdStmt_ stmt; 3149 3150 stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_); 3151 ffestd_stmt_append_ (stmt); 3152 ffestd_subr_line_save_ (stmt); 3153 stmt->u.R807.pool = ffesta_output_pool; 3154 stmt->u.R807.expr = expr; 3155 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3156 } 3157#endif 3158 3159 ++ffestd_block_level_; 3160 assert (ffestd_block_level_ > 0); 3161} 3162 3163/* ffestd_R809 -- SELECT CASE statement 3164 3165 ffestd_R809(construct_name,expr,expr_token); 3166 3167 Make sure statement is valid here; implement. */ 3168 3169void 3170ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr) 3171{ 3172 ffestd_check_simple_ (); 3173 3174#if FFECOM_ONEPASS 3175 ffestd_subr_line_now_ (); 3176 ffeste_R809 (ffestw_stack_top (), expr); 3177#else 3178 { 3179 ffestdStmt_ stmt; 3180 3181 stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_); 3182 ffestd_stmt_append_ (stmt); 3183 ffestd_subr_line_save_ (stmt); 3184 stmt->u.R809.pool = ffesta_output_pool; 3185 stmt->u.R809.block = ffestw_use (ffestw_stack_top ()); 3186 stmt->u.R809.expr = expr; 3187 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3188 malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool); 3189 } 3190#endif 3191 3192 ++ffestd_block_level_; 3193 assert (ffestd_block_level_ > 0); 3194} 3195 3196/* ffestd_R810 -- CASE statement 3197 3198 ffestd_R810(case_value_range_list,name); 3199 3200 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at 3201 the start of the first_stmt list in the select object at the top of 3202 the stack that match casenum. */ 3203 3204void 3205ffestd_R810 (unsigned long casenum) 3206{ 3207 ffestd_check_simple_ (); 3208 3209#if FFECOM_ONEPASS 3210 ffestd_subr_line_now_ (); 3211 ffeste_R810 (ffestw_stack_top (), casenum); 3212#else 3213 { 3214 ffestdStmt_ stmt; 3215 3216 stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_); 3217 ffestd_stmt_append_ (stmt); 3218 ffestd_subr_line_save_ (stmt); 3219 stmt->u.R810.pool = ffesta_output_pool; 3220 stmt->u.R810.block = ffestw_stack_top (); 3221 stmt->u.R810.casenum = casenum; 3222 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3223 } 3224#endif 3225} 3226 3227/* ffestd_R811 -- End a SELECT 3228 3229 ffestd_R811(TRUE); */ 3230 3231void 3232ffestd_R811 (bool ok UNUSED) 3233{ 3234#if FFECOM_ONEPASS 3235 ffestd_subr_line_now_ (); 3236 ffeste_R811 (ffestw_stack_top ()); 3237#else 3238 { 3239 ffestdStmt_ stmt; 3240 3241 stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_); 3242 ffestd_stmt_append_ (stmt); 3243 ffestd_subr_line_save_ (stmt); 3244 stmt->u.R811.block = ffestw_stack_top (); 3245 } 3246#endif 3247 3248 --ffestd_block_level_; 3249 assert (ffestd_block_level_ >= 0); 3250} 3251 3252/* ffestd_R819A -- Iterative DO statement 3253 3254 ffestd_R819A(construct_name,label_token,expr,expr_token); 3255 3256 Make sure statement is valid here; implement. */ 3257 3258void 3259ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label, 3260 ffebld var, ffebld start, ffelexToken start_token, 3261 ffebld end, ffelexToken end_token, 3262 ffebld incr, ffelexToken incr_token) 3263{ 3264 ffestd_check_simple_ (); 3265 3266#if FFECOM_ONEPASS 3267 ffestd_subr_line_now_ (); 3268 ffeste_R819A (ffestw_stack_top (), label, var, start, end, incr, 3269 incr_token); 3270#else 3271 { 3272 ffestdStmt_ stmt; 3273 3274 stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_); 3275 ffestd_stmt_append_ (stmt); 3276 ffestd_subr_line_save_ (stmt); 3277 stmt->u.R819A.pool = ffesta_output_pool; 3278 stmt->u.R819A.block = ffestw_use (ffestw_stack_top ()); 3279 stmt->u.R819A.label = label; 3280 stmt->u.R819A.var = var; 3281 stmt->u.R819A.start = start; 3282 stmt->u.R819A.start_token = ffelex_token_use (start_token); 3283 stmt->u.R819A.end = end; 3284 stmt->u.R819A.end_token = ffelex_token_use (end_token); 3285 stmt->u.R819A.incr = incr; 3286 stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL 3287 : ffelex_token_use (incr_token); 3288 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3289 } 3290#endif 3291 3292 ++ffestd_block_level_; 3293 assert (ffestd_block_level_ > 0); 3294} 3295 3296/* ffestd_R819B -- DO WHILE statement 3297 3298 ffestd_R819B(construct_name,label_token,expr,expr_token); 3299 3300 Make sure statement is valid here; implement. */ 3301 3302void 3303ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label, 3304 ffebld expr) 3305{ 3306 ffestd_check_simple_ (); 3307 3308#if FFECOM_ONEPASS 3309 ffestd_subr_line_now_ (); 3310 ffeste_R819B (ffestw_stack_top (), label, expr); 3311#else 3312 { 3313 ffestdStmt_ stmt; 3314 3315 stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_); 3316 ffestd_stmt_append_ (stmt); 3317 ffestd_subr_line_save_ (stmt); 3318 stmt->u.R819B.pool = ffesta_output_pool; 3319 stmt->u.R819B.block = ffestw_use (ffestw_stack_top ()); 3320 stmt->u.R819B.label = label; 3321 stmt->u.R819B.expr = expr; 3322 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3323 } 3324#endif 3325 3326 ++ffestd_block_level_; 3327 assert (ffestd_block_level_ > 0); 3328} 3329 3330/* ffestd_R825 -- END DO statement 3331 3332 ffestd_R825(name_token); 3333 3334 Make sure ffestd_kind_ identifies a DO block. If not 3335 NULL, make sure name_token gives the correct name. Do whatever 3336 is specific to seeing END DO with a DO-target label definition on it, 3337 where the END DO is really treated as a CONTINUE (i.e. generate th 3338 same code you would for CONTINUE). ffestd_do handles the actual 3339 generation of end-loop code. */ 3340 3341void 3342ffestd_R825 (ffelexToken name UNUSED) 3343{ 3344 ffestd_check_simple_ (); 3345 3346#if FFECOM_ONEPASS 3347 ffestd_subr_line_now_ (); 3348 ffeste_R825 (); 3349#else 3350 { 3351 ffestdStmt_ stmt; 3352 3353 stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_); 3354 ffestd_stmt_append_ (stmt); 3355 ffestd_subr_line_save_ (stmt); 3356 } 3357#endif 3358} 3359 3360/* ffestd_R834 -- CYCLE statement 3361 3362 ffestd_R834(name_token); 3363 3364 Handle a CYCLE within a loop. */ 3365 3366void 3367ffestd_R834 (ffestw block) 3368{ 3369 ffestd_check_simple_ (); 3370 3371#if FFECOM_ONEPASS 3372 ffestd_subr_line_now_ (); 3373 ffeste_R834 (block); 3374#else 3375 { 3376 ffestdStmt_ stmt; 3377 3378 stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_); 3379 ffestd_stmt_append_ (stmt); 3380 ffestd_subr_line_save_ (stmt); 3381 stmt->u.R834.block = block; 3382 } 3383#endif 3384} 3385 3386/* ffestd_R835 -- EXIT statement 3387 3388 ffestd_R835(name_token); 3389 3390 Handle a EXIT within a loop. */ 3391 3392void 3393ffestd_R835 (ffestw block) 3394{ 3395 ffestd_check_simple_ (); 3396 3397#if FFECOM_ONEPASS 3398 ffestd_subr_line_now_ (); 3399 ffeste_R835 (block); 3400#else 3401 { 3402 ffestdStmt_ stmt; 3403 3404 stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_); 3405 ffestd_stmt_append_ (stmt); 3406 ffestd_subr_line_save_ (stmt); 3407 stmt->u.R835.block = block; 3408 } 3409#endif 3410} 3411 3412/* ffestd_R836 -- GOTO statement 3413 3414 ffestd_R836(label); 3415 3416 Make sure label_token identifies a valid label for a GOTO. Update 3417 that label's info to indicate it is the target of a GOTO. */ 3418 3419void 3420ffestd_R836 (ffelab label) 3421{ 3422 ffestd_check_simple_ (); 3423 3424#if FFECOM_ONEPASS 3425 ffestd_subr_line_now_ (); 3426 ffeste_R836 (label); 3427#else 3428 { 3429 ffestdStmt_ stmt; 3430 3431 stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_); 3432 ffestd_stmt_append_ (stmt); 3433 ffestd_subr_line_save_ (stmt); 3434 stmt->u.R836.label = label; 3435 } 3436#endif 3437 3438 if (ffestd_block_level_ == 0) 3439 ffestd_is_reachable_ = FALSE; 3440} 3441 3442/* ffestd_R837 -- Computed GOTO statement 3443 3444 ffestd_R837(labels,expr); 3445 3446 Make sure label_list identifies valid labels for a GOTO. Update 3447 each label's info to indicate it is the target of a GOTO. */ 3448 3449void 3450ffestd_R837 (ffelab *labels, int count, ffebld expr) 3451{ 3452 ffestd_check_simple_ (); 3453 3454#if FFECOM_ONEPASS 3455 ffestd_subr_line_now_ (); 3456 ffeste_R837 (labels, count, expr); 3457#else 3458 { 3459 ffestdStmt_ stmt; 3460 3461 stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_); 3462 ffestd_stmt_append_ (stmt); 3463 ffestd_subr_line_save_ (stmt); 3464 stmt->u.R837.pool = ffesta_output_pool; 3465 stmt->u.R837.labels = labels; 3466 stmt->u.R837.count = count; 3467 stmt->u.R837.expr = expr; 3468 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3469 } 3470#endif 3471} 3472 3473/* ffestd_R838 -- ASSIGN statement 3474 3475 ffestd_R838(label_token,target_variable,target_token); 3476 3477 Make sure label_token identifies a valid label for an assignment. Update 3478 that label's info to indicate it is the source of an assignment. Update 3479 target_variable's info to indicate it is the target the assignment of that 3480 label. */ 3481 3482void 3483ffestd_R838 (ffelab label, ffebld target) 3484{ 3485 ffestd_check_simple_ (); 3486 3487#if FFECOM_ONEPASS 3488 ffestd_subr_line_now_ (); 3489 ffeste_R838 (label, target); 3490#else 3491 { 3492 ffestdStmt_ stmt; 3493 3494 stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_); 3495 ffestd_stmt_append_ (stmt); 3496 ffestd_subr_line_save_ (stmt); 3497 stmt->u.R838.pool = ffesta_output_pool; 3498 stmt->u.R838.label = label; 3499 stmt->u.R838.target = target; 3500 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3501 } 3502#endif 3503} 3504 3505/* ffestd_R839 -- Assigned GOTO statement 3506 3507 ffestd_R839(target,labels); 3508 3509 Make sure label_list identifies valid labels for a GOTO. Update 3510 each label's info to indicate it is the target of a GOTO. */ 3511 3512void 3513ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED) 3514{ 3515 ffestd_check_simple_ (); 3516 3517#if FFECOM_ONEPASS 3518 ffestd_subr_line_now_ (); 3519 ffeste_R839 (target); 3520#else 3521 { 3522 ffestdStmt_ stmt; 3523 3524 stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_); 3525 ffestd_stmt_append_ (stmt); 3526 ffestd_subr_line_save_ (stmt); 3527 stmt->u.R839.pool = ffesta_output_pool; 3528 stmt->u.R839.target = target; 3529 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3530 } 3531#endif 3532 3533 if (ffestd_block_level_ == 0) 3534 ffestd_is_reachable_ = FALSE; 3535} 3536 3537/* ffestd_R840 -- Arithmetic IF statement 3538 3539 ffestd_R840(expr,expr_token,neg,zero,pos); 3540 3541 Make sure the labels are valid; implement. */ 3542 3543void 3544ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) 3545{ 3546 ffestd_check_simple_ (); 3547 3548#if FFECOM_ONEPASS 3549 ffestd_subr_line_now_ (); 3550 ffeste_R840 (expr, neg, zero, pos); 3551#else 3552 { 3553 ffestdStmt_ stmt; 3554 3555 stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_); 3556 ffestd_stmt_append_ (stmt); 3557 ffestd_subr_line_save_ (stmt); 3558 stmt->u.R840.pool = ffesta_output_pool; 3559 stmt->u.R840.expr = expr; 3560 stmt->u.R840.neg = neg; 3561 stmt->u.R840.zero = zero; 3562 stmt->u.R840.pos = pos; 3563 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3564 } 3565#endif 3566 3567 if (ffestd_block_level_ == 0) 3568 ffestd_is_reachable_ = FALSE; 3569} 3570 3571/* ffestd_R841 -- CONTINUE statement 3572 3573 ffestd_R841(); */ 3574 3575void 3576ffestd_R841 (bool in_where UNUSED) 3577{ 3578 ffestd_check_simple_ (); 3579 3580#if FFECOM_ONEPASS 3581 ffestd_subr_line_now_ (); 3582 ffeste_R841 (); 3583#else 3584 { 3585 ffestdStmt_ stmt; 3586 3587 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); 3588 ffestd_stmt_append_ (stmt); 3589 ffestd_subr_line_save_ (stmt); 3590 } 3591#endif 3592} 3593 3594/* ffestd_R842 -- STOP statement 3595 3596 ffestd_R842(expr); */ 3597 3598void 3599ffestd_R842 (ffebld expr) 3600{ 3601 ffestd_check_simple_ (); 3602 3603#if FFECOM_ONEPASS 3604 ffestd_subr_line_now_ (); 3605 ffeste_R842 (expr); 3606#else 3607 { 3608 ffestdStmt_ stmt; 3609 3610 stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_); 3611 ffestd_stmt_append_ (stmt); 3612 ffestd_subr_line_save_ (stmt); 3613 if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE) 3614 { 3615 /* This is a "spurious" (automatically-generated) STOP 3616 that follows a previous STOP or other statement. 3617 Make sure we don't have an expression in the pool, 3618 and then mark that the pool has already been killed. */ 3619 assert (expr == NULL); 3620 stmt->u.R842.pool = NULL; 3621 stmt->u.R842.expr = NULL; 3622 } 3623 else 3624 { 3625 stmt->u.R842.pool = ffesta_output_pool; 3626 stmt->u.R842.expr = expr; 3627 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3628 } 3629 } 3630#endif 3631 3632 if (ffestd_block_level_ == 0) 3633 ffestd_is_reachable_ = FALSE; 3634} 3635 3636/* ffestd_R843 -- PAUSE statement 3637 3638 ffestd_R843(expr,expr_token); 3639 3640 Make sure statement is valid here; implement. expr and expr_token are 3641 both NULL if there was no expression. */ 3642 3643void 3644ffestd_R843 (ffebld expr) 3645{ 3646 ffestd_check_simple_ (); 3647 3648#if FFECOM_ONEPASS 3649 ffestd_subr_line_now_ (); 3650 ffeste_R843 (expr); 3651#else 3652 { 3653 ffestdStmt_ stmt; 3654 3655 stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_); 3656 ffestd_stmt_append_ (stmt); 3657 ffestd_subr_line_save_ (stmt); 3658 stmt->u.R843.pool = ffesta_output_pool; 3659 stmt->u.R843.expr = expr; 3660 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3661 } 3662#endif 3663} 3664 3665/* ffestd_R904 -- OPEN statement 3666 3667 ffestd_R904(); 3668 3669 Make sure an OPEN is valid in the current context, and implement it. */ 3670 3671void 3672ffestd_R904 () 3673{ 3674 ffestd_check_simple_ (); 3675 3676#if FFECOM_targetCURRENT == FFECOM_targetGCC 3677#define specified(something) \ 3678 (ffestp_file.open.open_spec[something].kw_or_val_present) 3679 3680 /* Warn if there are any thing we don't handle via f2c libraries. */ 3681 3682 if (specified (FFESTP_openixACTION) 3683 || specified (FFESTP_openixASSOCIATEVARIABLE) 3684 || specified (FFESTP_openixBLOCKSIZE) 3685 || specified (FFESTP_openixBUFFERCOUNT) 3686 || specified (FFESTP_openixCARRIAGECONTROL) 3687 || specified (FFESTP_openixDEFAULTFILE) 3688 || specified (FFESTP_openixDELIM) 3689 || specified (FFESTP_openixDISPOSE) 3690 || specified (FFESTP_openixEXTENDSIZE) 3691 || specified (FFESTP_openixINITIALSIZE) 3692 || specified (FFESTP_openixKEY) 3693 || specified (FFESTP_openixMAXREC) 3694 || specified (FFESTP_openixNOSPANBLOCKS) 3695 || specified (FFESTP_openixORGANIZATION) 3696 || specified (FFESTP_openixPAD) 3697 || specified (FFESTP_openixPOSITION) 3698 || specified (FFESTP_openixREADONLY) 3699 || specified (FFESTP_openixRECORDTYPE) 3700 || specified (FFESTP_openixSHARED) 3701 || specified (FFESTP_openixUSEROPEN)) 3702 { 3703 ffebad_start (FFEBAD_OPEN_UNSUPPORTED); 3704 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 3705 ffelex_token_where_column (ffesta_tokens[0])); 3706 ffebad_finish (); 3707 } 3708 3709#undef specified 3710#endif 3711 3712#if FFECOM_ONEPASS 3713 ffestd_subr_line_now_ (); 3714 ffeste_R904 (&ffestp_file.open); 3715#else 3716 { 3717 ffestdStmt_ stmt; 3718 3719 stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_); 3720 ffestd_stmt_append_ (stmt); 3721 ffestd_subr_line_save_ (stmt); 3722 stmt->u.R904.pool = ffesta_output_pool; 3723 stmt->u.R904.params = ffestd_subr_copy_open_ (); 3724 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3725 } 3726#endif 3727} 3728 3729/* ffestd_R907 -- CLOSE statement 3730 3731 ffestd_R907(); 3732 3733 Make sure a CLOSE is valid in the current context, and implement it. */ 3734 3735void 3736ffestd_R907 () 3737{ 3738 ffestd_check_simple_ (); 3739 3740#if FFECOM_ONEPASS 3741 ffestd_subr_line_now_ (); 3742 ffeste_R907 (&ffestp_file.close); 3743#else 3744 { 3745 ffestdStmt_ stmt; 3746 3747 stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_); 3748 ffestd_stmt_append_ (stmt); 3749 ffestd_subr_line_save_ (stmt); 3750 stmt->u.R907.pool = ffesta_output_pool; 3751 stmt->u.R907.params = ffestd_subr_copy_close_ (); 3752 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3753 } 3754#endif 3755} 3756 3757/* ffestd_R909_start -- READ(...) statement list begin 3758 3759 ffestd_R909_start(FALSE); 3760 3761 Verify that READ is valid here, and begin accepting items in the 3762 list. */ 3763 3764void 3765ffestd_R909_start (bool only_format, ffestvUnit unit, 3766 ffestvFormat format, bool rec, bool key) 3767{ 3768 ffestd_check_start_ (); 3769 3770#if FFECOM_targetCURRENT == FFECOM_targetGCC 3771#define specified(something) \ 3772 (ffestp_file.read.read_spec[something].kw_or_val_present) 3773 3774 /* Warn if there are any thing we don't handle via f2c libraries. */ 3775 if (specified (FFESTP_readixADVANCE) 3776 || specified (FFESTP_readixEOR) 3777 || specified (FFESTP_readixKEYEQ) 3778 || specified (FFESTP_readixKEYGE) 3779 || specified (FFESTP_readixKEYGT) 3780 || specified (FFESTP_readixKEYID) 3781 || specified (FFESTP_readixNULLS) 3782 || specified (FFESTP_readixSIZE)) 3783 { 3784 ffebad_start (FFEBAD_READ_UNSUPPORTED); 3785 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 3786 ffelex_token_where_column (ffesta_tokens[0])); 3787 ffebad_finish (); 3788 } 3789 3790#undef specified 3791#endif 3792 3793#if FFECOM_ONEPASS 3794 ffestd_subr_line_now_ (); 3795 ffeste_R909_start (&ffestp_file.read, only_format, unit, format, rec, key); 3796#else 3797 { 3798 ffestdStmt_ stmt; 3799 3800 stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_); 3801 ffestd_stmt_append_ (stmt); 3802 ffestd_subr_line_save_ (stmt); 3803 stmt->u.R909.pool = ffesta_output_pool; 3804 stmt->u.R909.params = ffestd_subr_copy_read_ (); 3805 stmt->u.R909.only_format = only_format; 3806 stmt->u.R909.unit = unit; 3807 stmt->u.R909.format = format; 3808 stmt->u.R909.rec = rec; 3809 stmt->u.R909.key = key; 3810 stmt->u.R909.list = NULL; 3811 ffestd_expr_list_ = &stmt->u.R909.list; 3812 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3813 } 3814#endif 3815} 3816 3817/* ffestd_R909_item -- READ statement i/o item 3818 3819 ffestd_R909_item(expr,expr_token); 3820 3821 Implement output-list expression. */ 3822 3823void 3824ffestd_R909_item (ffebld expr, ffelexToken expr_token) 3825{ 3826 ffestd_check_item_ (); 3827 3828#if FFECOM_ONEPASS 3829 ffeste_R909_item (expr); 3830#else 3831 { 3832 ffestdExprItem_ item 3833 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 3834 sizeof (*item)); 3835 3836 item->next = NULL; 3837 item->expr = expr; 3838 item->token = ffelex_token_use (expr_token); 3839 *ffestd_expr_list_ = item; 3840 ffestd_expr_list_ = &item->next; 3841 } 3842#endif 3843} 3844 3845/* ffestd_R909_finish -- READ statement list complete 3846 3847 ffestd_R909_finish(); 3848 3849 Just wrap up any local activities. */ 3850 3851void 3852ffestd_R909_finish () 3853{ 3854 ffestd_check_finish_ (); 3855 3856#if FFECOM_ONEPASS 3857 ffeste_R909_finish (); 3858#else 3859 /* Nothing to do, it's implicit. */ 3860#endif 3861} 3862 3863/* ffestd_R910_start -- WRITE(...) statement list begin 3864 3865 ffestd_R910_start(); 3866 3867 Verify that WRITE is valid here, and begin accepting items in the 3868 list. */ 3869 3870void 3871ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec) 3872{ 3873 ffestd_check_start_ (); 3874 3875#if FFECOM_targetCURRENT == FFECOM_targetGCC 3876#define specified(something) \ 3877 (ffestp_file.write.write_spec[something].kw_or_val_present) 3878 3879 /* Warn if there are any thing we don't handle via f2c libraries. */ 3880 if (specified (FFESTP_writeixADVANCE) 3881 || specified (FFESTP_writeixEOR)) 3882 { 3883 ffebad_start (FFEBAD_WRITE_UNSUPPORTED); 3884 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 3885 ffelex_token_where_column (ffesta_tokens[0])); 3886 ffebad_finish (); 3887 } 3888 3889#undef specified 3890#endif 3891 3892#if FFECOM_ONEPASS 3893 ffestd_subr_line_now_ (); 3894 ffeste_R910_start (&ffestp_file.write, unit, format, rec); 3895#else 3896 { 3897 ffestdStmt_ stmt; 3898 3899 stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_); 3900 ffestd_stmt_append_ (stmt); 3901 ffestd_subr_line_save_ (stmt); 3902 stmt->u.R910.pool = ffesta_output_pool; 3903 stmt->u.R910.params = ffestd_subr_copy_write_ (); 3904 stmt->u.R910.unit = unit; 3905 stmt->u.R910.format = format; 3906 stmt->u.R910.rec = rec; 3907 stmt->u.R910.list = NULL; 3908 ffestd_expr_list_ = &stmt->u.R910.list; 3909 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3910 } 3911#endif 3912} 3913 3914/* ffestd_R910_item -- WRITE statement i/o item 3915 3916 ffestd_R910_item(expr,expr_token); 3917 3918 Implement output-list expression. */ 3919 3920void 3921ffestd_R910_item (ffebld expr, ffelexToken expr_token) 3922{ 3923 ffestd_check_item_ (); 3924 3925#if FFECOM_ONEPASS 3926 ffeste_R910_item (expr); 3927#else 3928 { 3929 ffestdExprItem_ item 3930 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 3931 sizeof (*item)); 3932 3933 item->next = NULL; 3934 item->expr = expr; 3935 item->token = ffelex_token_use (expr_token); 3936 *ffestd_expr_list_ = item; 3937 ffestd_expr_list_ = &item->next; 3938 } 3939#endif 3940} 3941 3942/* ffestd_R910_finish -- WRITE statement list complete 3943 3944 ffestd_R910_finish(); 3945 3946 Just wrap up any local activities. */ 3947 3948void 3949ffestd_R910_finish () 3950{ 3951 ffestd_check_finish_ (); 3952 3953#if FFECOM_ONEPASS 3954 ffeste_R910_finish (); 3955#else 3956 /* Nothing to do, it's implicit. */ 3957#endif 3958} 3959 3960/* ffestd_R911_start -- PRINT statement list begin 3961 3962 ffestd_R911_start(); 3963 3964 Verify that PRINT is valid here, and begin accepting items in the 3965 list. */ 3966 3967void 3968ffestd_R911_start (ffestvFormat format) 3969{ 3970 ffestd_check_start_ (); 3971 3972#if FFECOM_ONEPASS 3973 ffestd_subr_line_now_ (); 3974 ffeste_R911_start (&ffestp_file.print, format); 3975#else 3976 { 3977 ffestdStmt_ stmt; 3978 3979 stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_); 3980 ffestd_stmt_append_ (stmt); 3981 ffestd_subr_line_save_ (stmt); 3982 stmt->u.R911.pool = ffesta_output_pool; 3983 stmt->u.R911.params = ffestd_subr_copy_print_ (); 3984 stmt->u.R911.format = format; 3985 stmt->u.R911.list = NULL; 3986 ffestd_expr_list_ = &stmt->u.R911.list; 3987 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 3988 } 3989#endif 3990} 3991 3992/* ffestd_R911_item -- PRINT statement i/o item 3993 3994 ffestd_R911_item(expr,expr_token); 3995 3996 Implement output-list expression. */ 3997 3998void 3999ffestd_R911_item (ffebld expr, ffelexToken expr_token) 4000{ 4001 ffestd_check_item_ (); 4002 4003#if FFECOM_ONEPASS 4004 ffeste_R911_item (expr); 4005#else 4006 { 4007 ffestdExprItem_ item 4008 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 4009 sizeof (*item)); 4010 4011 item->next = NULL; 4012 item->expr = expr; 4013 item->token = ffelex_token_use (expr_token); 4014 *ffestd_expr_list_ = item; 4015 ffestd_expr_list_ = &item->next; 4016 } 4017#endif 4018} 4019 4020/* ffestd_R911_finish -- PRINT statement list complete 4021 4022 ffestd_R911_finish(); 4023 4024 Just wrap up any local activities. */ 4025 4026void 4027ffestd_R911_finish () 4028{ 4029 ffestd_check_finish_ (); 4030 4031#if FFECOM_ONEPASS 4032 ffeste_R911_finish (); 4033#else 4034 /* Nothing to do, it's implicit. */ 4035#endif 4036} 4037 4038/* ffestd_R919 -- BACKSPACE statement 4039 4040 ffestd_R919(); 4041 4042 Make sure a BACKSPACE is valid in the current context, and implement it. */ 4043 4044void 4045ffestd_R919 () 4046{ 4047 ffestd_check_simple_ (); 4048 4049#if FFECOM_ONEPASS 4050 ffestd_subr_line_now_ (); 4051 ffeste_R919 (&ffestp_file.beru); 4052#else 4053 { 4054 ffestdStmt_ stmt; 4055 4056 stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_); 4057 ffestd_stmt_append_ (stmt); 4058 ffestd_subr_line_save_ (stmt); 4059 stmt->u.R919.pool = ffesta_output_pool; 4060 stmt->u.R919.params = ffestd_subr_copy_beru_ (); 4061 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 4062 } 4063#endif 4064} 4065 4066/* ffestd_R920 -- ENDFILE statement 4067 4068 ffestd_R920(); 4069 4070 Make sure a ENDFILE is valid in the current context, and implement it. */ 4071 4072void 4073ffestd_R920 () 4074{ 4075 ffestd_check_simple_ (); 4076 4077#if FFECOM_ONEPASS 4078 ffestd_subr_line_now_ (); 4079 ffeste_R920 (&ffestp_file.beru); 4080#else 4081 { 4082 ffestdStmt_ stmt; 4083 4084 stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_); 4085 ffestd_stmt_append_ (stmt); 4086 ffestd_subr_line_save_ (stmt); 4087 stmt->u.R920.pool = ffesta_output_pool; 4088 stmt->u.R920.params = ffestd_subr_copy_beru_ (); 4089 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 4090 } 4091#endif 4092} 4093 4094/* ffestd_R921 -- REWIND statement 4095 4096 ffestd_R921(); 4097 4098 Make sure a REWIND is valid in the current context, and implement it. */ 4099 4100void 4101ffestd_R921 () 4102{ 4103 ffestd_check_simple_ (); 4104 4105#if FFECOM_ONEPASS 4106 ffestd_subr_line_now_ (); 4107 ffeste_R921 (&ffestp_file.beru); 4108#else 4109 { 4110 ffestdStmt_ stmt; 4111 4112 stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_); 4113 ffestd_stmt_append_ (stmt); 4114 ffestd_subr_line_save_ (stmt); 4115 stmt->u.R921.pool = ffesta_output_pool; 4116 stmt->u.R921.params = ffestd_subr_copy_beru_ (); 4117 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 4118 } 4119#endif 4120} 4121 4122/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version) 4123 4124 ffestd_R923A(bool by_file); 4125 4126 Make sure an INQUIRE is valid in the current context, and implement it. */ 4127 4128void 4129ffestd_R923A (bool by_file) 4130{ 4131 ffestd_check_simple_ (); 4132 4133#if FFECOM_targetCURRENT == FFECOM_targetGCC 4134#define specified(something) \ 4135 (ffestp_file.inquire.inquire_spec[something].kw_or_val_present) 4136 4137 /* Warn if there are any thing we don't handle via f2c libraries. */ 4138 if (specified (FFESTP_inquireixACTION) 4139 || specified (FFESTP_inquireixCARRIAGECONTROL) 4140 || specified (FFESTP_inquireixDEFAULTFILE) 4141 || specified (FFESTP_inquireixDELIM) 4142 || specified (FFESTP_inquireixKEYED) 4143 || specified (FFESTP_inquireixORGANIZATION) 4144 || specified (FFESTP_inquireixPAD) 4145 || specified (FFESTP_inquireixPOSITION) 4146 || specified (FFESTP_inquireixREAD) 4147 || specified (FFESTP_inquireixREADWRITE) 4148 || specified (FFESTP_inquireixRECORDTYPE) 4149 || specified (FFESTP_inquireixWRITE)) 4150 { 4151 ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED); 4152 ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), 4153 ffelex_token_where_column (ffesta_tokens[0])); 4154 ffebad_finish (); 4155 } 4156 4157#undef specified 4158#endif 4159 4160#if FFECOM_ONEPASS 4161 ffestd_subr_line_now_ (); 4162 ffeste_R923A (&ffestp_file.inquire, by_file); 4163#else 4164 { 4165 ffestdStmt_ stmt; 4166 4167 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_); 4168 ffestd_stmt_append_ (stmt); 4169 ffestd_subr_line_save_ (stmt); 4170 stmt->u.R923A.pool = ffesta_output_pool; 4171 stmt->u.R923A.params = ffestd_subr_copy_inquire_ (); 4172 stmt->u.R923A.by_file = by_file; 4173 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 4174 } 4175#endif 4176} 4177 4178/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin 4179 4180 ffestd_R923B_start(); 4181 4182 Verify that INQUIRE is valid here, and begin accepting items in the 4183 list. */ 4184 4185void 4186ffestd_R923B_start () 4187{ 4188 ffestd_check_start_ (); 4189 4190#if FFECOM_ONEPASS 4191 ffestd_subr_line_now_ (); 4192 ffeste_R923B_start (&ffestp_file.inquire); 4193#else 4194 { 4195 ffestdStmt_ stmt; 4196 4197 stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_); 4198 ffestd_stmt_append_ (stmt); 4199 ffestd_subr_line_save_ (stmt); 4200 stmt->u.R923B.pool = ffesta_output_pool; 4201 stmt->u.R923B.params = ffestd_subr_copy_inquire_ (); 4202 stmt->u.R923B.list = NULL; 4203 ffestd_expr_list_ = &stmt->u.R923B.list; 4204 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 4205 } 4206#endif 4207} 4208 4209/* ffestd_R923B_item -- INQUIRE statement i/o item 4210 4211 ffestd_R923B_item(expr,expr_token); 4212 4213 Implement output-list expression. */ 4214 4215void 4216ffestd_R923B_item (ffebld expr) 4217{ 4218 ffestd_check_item_ (); 4219 4220#if FFECOM_ONEPASS 4221 ffeste_R923B_item (expr); 4222#else 4223 { 4224 ffestdExprItem_ item 4225 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 4226 sizeof (*item)); 4227 4228 item->next = NULL; 4229 item->expr = expr; 4230 *ffestd_expr_list_ = item; 4231 ffestd_expr_list_ = &item->next; 4232 } 4233#endif 4234} 4235 4236/* ffestd_R923B_finish -- INQUIRE statement list complete 4237 4238 ffestd_R923B_finish(); 4239 4240 Just wrap up any local activities. */ 4241 4242void 4243ffestd_R923B_finish () 4244{ 4245 ffestd_check_finish_ (); 4246 4247#if FFECOM_ONEPASS 4248 ffeste_R923B_finish (); 4249#else 4250 /* Nothing to do, it's implicit. */ 4251#endif 4252} 4253 4254/* ffestd_R1001 -- FORMAT statement 4255 4256 ffestd_R1001(format_list); */ 4257 4258void 4259ffestd_R1001 (ffesttFormatList f) 4260{ 4261 ffestsHolder str; 4262 ffests s = &str; 4263 4264 ffestd_check_simple_ (); 4265 4266 if (ffestd_label_formatdef_ == NULL) 4267 return; /* Nothing to hook it up to (no label def). */ 4268 4269 ffests_new (s, malloc_pool_image (), 80); 4270 ffests_putc (s, '('); 4271 ffestd_R1001dump_ (s, f); /* Build the string in s. */ 4272 ffests_putc (s, ')'); 4273 4274#if FFECOM_ONEPASS 4275 ffeste_R1001 (s); 4276 ffests_kill (s); /* Kill the string in s. */ 4277#else 4278 { 4279 ffestdStmt_ stmt; 4280 4281 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_); 4282#if 0 4283 /* Don't bother with this. After all, things like cilists also are 4284 declared midway through code-generation. Perhaps the only problems 4285 the gcc back end has with midway declarations are with stack vars, 4286 maybe only with vars that can be put in registers. Unless/until the 4287 need is established, handle FORMAT just like cilists and others; at 4288 that point, they'd likely *all* have to be fixed, which would be 4289 very painful anyway. */ 4290 /* Insert FORMAT statement just after the first item on the 4291 statement list, which must be a FORMAT label, which see. */ 4292 assert (ffestd_stmt_list_.first->id == FFESTD_stmtidFORMATLABEL_); 4293 stmt->previous = ffestd_stmt_list_.first; 4294 stmt->next = ffestd_stmt_list_.first->next; 4295 stmt->next->previous = stmt; 4296 stmt->previous->next = stmt; 4297#else 4298 ffestd_stmt_append_ (stmt); 4299#endif 4300 stmt->u.R1001.str = str; 4301 } 4302#endif 4303 4304 ffestd_label_formatdef_ = NULL; 4305} 4306 4307/* ffestd_R1001dump_ -- Dump list of formats 4308 4309 ffesttFormatList list; 4310 ffestd_R1001dump_(list,0); 4311 4312 The formats in the list are dumped. */ 4313 4314static void 4315ffestd_R1001dump_ (ffests s, ffesttFormatList list) 4316{ 4317 ffesttFormatList next; 4318 4319 for (next = list->next; next != list; next = next->next) 4320 { 4321 if (next != list->next) 4322 ffests_putc (s, ','); 4323 switch (next->type) 4324 { 4325 case FFESTP_formattypeI: 4326 ffestd_R1001dump_1005_3_ (s, next, "I"); 4327 break; 4328 4329 case FFESTP_formattypeB: 4330#if FFECOM_targetCURRENT == FFECOM_targetFFE 4331 ffestd_R1001dump_1005_3_ (s, next, "B"); 4332#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4333 ffestd_R1001error_ (next); 4334#else 4335#error 4336#endif 4337 break; 4338 4339 case FFESTP_formattypeO: 4340 ffestd_R1001dump_1005_3_ (s, next, "O"); 4341 break; 4342 4343 case FFESTP_formattypeZ: 4344 ffestd_R1001dump_1005_3_ (s, next, "Z"); 4345 break; 4346 4347 case FFESTP_formattypeF: 4348 ffestd_R1001dump_1005_4_ (s, next, "F"); 4349 break; 4350 4351 case FFESTP_formattypeE: 4352 ffestd_R1001dump_1005_5_ (s, next, "E"); 4353 break; 4354 4355 case FFESTP_formattypeEN: 4356#if FFECOM_targetCURRENT == FFECOM_targetFFE 4357 ffestd_R1001dump_1005_5_ (s, next, "EN"); 4358#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4359 ffestd_R1001error_ (next); 4360#else 4361#error 4362#endif 4363 break; 4364 4365 case FFESTP_formattypeG: 4366 ffestd_R1001dump_1005_5_ (s, next, "G"); 4367 break; 4368 4369 case FFESTP_formattypeL: 4370 ffestd_R1001dump_1005_2_ (s, next, "L"); 4371 break; 4372 4373 case FFESTP_formattypeA: 4374 ffestd_R1001dump_1005_1_ (s, next, "A"); 4375 break; 4376 4377 case FFESTP_formattypeD: 4378 ffestd_R1001dump_1005_4_ (s, next, "D"); 4379 break; 4380 4381 case FFESTP_formattypeQ: 4382#if FFECOM_targetCURRENT == FFECOM_targetFFE 4383 ffestd_R1001dump_1010_1_ (s, next, "Q"); 4384#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4385 ffestd_R1001error_ (next); 4386#else 4387#error 4388#endif 4389 break; 4390 4391 case FFESTP_formattypeDOLLAR: 4392 ffestd_R1001dump_1010_1_ (s, next, "$"); 4393 break; 4394 4395 case FFESTP_formattypeP: 4396 ffestd_R1001dump_1010_4_ (s, next, "P"); 4397 break; 4398 4399 case FFESTP_formattypeT: 4400 ffestd_R1001dump_1010_5_ (s, next, "T"); 4401 break; 4402 4403 case FFESTP_formattypeTL: 4404 ffestd_R1001dump_1010_5_ (s, next, "TL"); 4405 break; 4406 4407 case FFESTP_formattypeTR: 4408 ffestd_R1001dump_1010_5_ (s, next, "TR"); 4409 break; 4410 4411 case FFESTP_formattypeX: 4412 ffestd_R1001dump_1010_3_ (s, next, "X"); 4413 break; 4414 4415 case FFESTP_formattypeS: 4416 ffestd_R1001dump_1010_1_ (s, next, "S"); 4417 break; 4418 4419 case FFESTP_formattypeSP: 4420 ffestd_R1001dump_1010_1_ (s, next, "SP"); 4421 break; 4422 4423 case FFESTP_formattypeSS: 4424 ffestd_R1001dump_1010_1_ (s, next, "SS"); 4425 break; 4426 4427 case FFESTP_formattypeBN: 4428 ffestd_R1001dump_1010_1_ (s, next, "BN"); 4429 break; 4430 4431 case FFESTP_formattypeBZ: 4432 ffestd_R1001dump_1010_1_ (s, next, "BZ"); 4433 break; 4434 4435 case FFESTP_formattypeSLASH: 4436 ffestd_R1001dump_1010_2_ (s, next, "/"); 4437 break; 4438 4439 case FFESTP_formattypeCOLON: 4440 ffestd_R1001dump_1010_1_ (s, next, ":"); 4441 break; 4442 4443 case FFESTP_formattypeR1016: 4444 switch (ffelex_token_type (next->t)) 4445 { 4446 case FFELEX_typeCHARACTER: 4447 { 4448 char *p = ffelex_token_text (next->t); 4449 ffeTokenLength i = ffelex_token_length (next->t); 4450 4451 ffests_putc (s, '\002'); 4452 while (i-- != 0) 4453 { 4454 if (*p == '\002') 4455 ffests_putc (s, '\002'); 4456 ffests_putc (s, *p); 4457 ++p; 4458 } 4459 ffests_putc (s, '\002'); 4460 } 4461 break; 4462 4463 case FFELEX_typeHOLLERITH: 4464 { 4465 char *p = ffelex_token_text (next->t); 4466 ffeTokenLength i = ffelex_token_length (next->t); 4467 4468 ffests_printf_1U (s, 4469 "%" ffeTokenLength_f "uH", 4470 i); 4471 while (i-- != 0) 4472 { 4473 ffests_putc (s, *p); 4474 ++p; 4475 } 4476 } 4477 break; 4478 4479 default: 4480 assert (FALSE); 4481 } 4482 break; 4483 4484 case FFESTP_formattypeFORMAT: 4485 if (next->u.R1003D.R1004.present) 4486 { 4487 if (next->u.R1003D.R1004.rtexpr) 4488 ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr); 4489 else 4490 ffests_printf_1U (s, "%lu", 4491 next->u.R1003D.R1004.u.unsigned_val); 4492 } 4493 4494 ffests_putc (s, '('); 4495 ffestd_R1001dump_ (s, next->u.R1003D.format); 4496 ffests_putc (s, ')'); 4497 break; 4498 4499 default: 4500 assert (FALSE); 4501 } 4502 } 4503} 4504 4505/* ffestd_R1001dump_1005_1_ -- Dump a particular format 4506 4507 ffesttFormatList f; 4508 ffestd_R1001dump_1005_1_(f,"I"); 4509 4510 The format is dumped with form [r]X[w]. */ 4511 4512static void 4513ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string) 4514{ 4515 assert (!f->u.R1005.R1007_or_R1008.present); 4516 assert (!f->u.R1005.R1009.present); 4517 4518 if (f->u.R1005.R1004.present) 4519 { 4520 if (f->u.R1005.R1004.rtexpr) 4521 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); 4522 else 4523 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); 4524 } 4525 4526 ffests_puts (s, string); 4527 4528 if (f->u.R1005.R1006.present) 4529 { 4530 if (f->u.R1005.R1006.rtexpr) 4531 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); 4532 else 4533 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val); 4534 } 4535} 4536 4537/* ffestd_R1001dump_1005_2_ -- Dump a particular format 4538 4539 ffesttFormatList f; 4540 ffestd_R1001dump_1005_2_(f,"I"); 4541 4542 The format is dumped with form [r]Xw. */ 4543 4544static void 4545ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string) 4546{ 4547 assert (!f->u.R1005.R1007_or_R1008.present); 4548 assert (!f->u.R1005.R1009.present); 4549 assert (f->u.R1005.R1006.present); 4550 4551 if (f->u.R1005.R1004.present) 4552 { 4553 if (f->u.R1005.R1004.rtexpr) 4554 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); 4555 else 4556 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); 4557 } 4558 4559 ffests_puts (s, string); 4560 4561 if (f->u.R1005.R1006.rtexpr) 4562 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); 4563 else 4564 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val); 4565} 4566 4567/* ffestd_R1001dump_1005_3_ -- Dump a particular format 4568 4569 ffesttFormatList f; 4570 ffestd_R1001dump_1005_3_(f,"I"); 4571 4572 The format is dumped with form [r]Xw[.m]. */ 4573 4574static void 4575ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string) 4576{ 4577 assert (!f->u.R1005.R1009.present); 4578 assert (f->u.R1005.R1006.present); 4579 4580 if (f->u.R1005.R1004.present) 4581 { 4582 if (f->u.R1005.R1004.rtexpr) 4583 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); 4584 else 4585 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); 4586 } 4587 4588 ffests_puts (s, string); 4589 4590 if (f->u.R1005.R1006.rtexpr) 4591 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); 4592 else 4593 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val); 4594 4595 if (f->u.R1005.R1007_or_R1008.present) 4596 { 4597 ffests_putc (s, '.'); 4598 if (f->u.R1005.R1007_or_R1008.rtexpr) 4599 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); 4600 else 4601 ffests_printf_1U (s, "%lu", 4602 f->u.R1005.R1007_or_R1008.u.unsigned_val); 4603 } 4604} 4605 4606/* ffestd_R1001dump_1005_4_ -- Dump a particular format 4607 4608 ffesttFormatList f; 4609 ffestd_R1001dump_1005_4_(f,"I"); 4610 4611 The format is dumped with form [r]Xw.d. */ 4612 4613static void 4614ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string) 4615{ 4616 assert (!f->u.R1005.R1009.present); 4617 assert (f->u.R1005.R1007_or_R1008.present); 4618 assert (f->u.R1005.R1006.present); 4619 4620 if (f->u.R1005.R1004.present) 4621 { 4622 if (f->u.R1005.R1004.rtexpr) 4623 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); 4624 else 4625 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); 4626 } 4627 4628 ffests_puts (s, string); 4629 4630 if (f->u.R1005.R1006.rtexpr) 4631 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); 4632 else 4633 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val); 4634 4635 ffests_putc (s, '.'); 4636 if (f->u.R1005.R1007_or_R1008.rtexpr) 4637 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); 4638 else 4639 ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); 4640} 4641 4642/* ffestd_R1001dump_1005_5_ -- Dump a particular format 4643 4644 ffesttFormatList f; 4645 ffestd_R1001dump_1005_5_(f,"I"); 4646 4647 The format is dumped with form [r]Xw.d[Ee]. */ 4648 4649static void 4650ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string) 4651{ 4652 assert (f->u.R1005.R1007_or_R1008.present); 4653 assert (f->u.R1005.R1006.present); 4654 4655 if (f->u.R1005.R1004.present) 4656 { 4657 if (f->u.R1005.R1004.rtexpr) 4658 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr); 4659 else 4660 ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val); 4661 } 4662 4663 ffests_puts (s, string); 4664 4665 if (f->u.R1005.R1006.rtexpr) 4666 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr); 4667 else 4668 ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val); 4669 4670 ffests_putc (s, '.'); 4671 if (f->u.R1005.R1007_or_R1008.rtexpr) 4672 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr); 4673 else 4674 ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val); 4675 4676 if (f->u.R1005.R1009.present) 4677 { 4678 ffests_putc (s, 'E'); 4679 if (f->u.R1005.R1009.rtexpr) 4680 ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr); 4681 else 4682 ffests_printf_1U (s, "%lu", f->u.R1005.R1009.u.unsigned_val); 4683 } 4684} 4685 4686/* ffestd_R1001dump_1010_1_ -- Dump a particular format 4687 4688 ffesttFormatList f; 4689 ffestd_R1001dump_1010_1_(f,"I"); 4690 4691 The format is dumped with form X. */ 4692 4693static void 4694ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string) 4695{ 4696 assert (!f->u.R1010.val.present); 4697 4698 ffests_puts (s, string); 4699} 4700 4701/* ffestd_R1001dump_1010_2_ -- Dump a particular format 4702 4703 ffesttFormatList f; 4704 ffestd_R1001dump_1010_2_(f,"I"); 4705 4706 The format is dumped with form [r]X. */ 4707 4708static void 4709ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string) 4710{ 4711 if (f->u.R1010.val.present) 4712 { 4713 if (f->u.R1010.val.rtexpr) 4714 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); 4715 else 4716 ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val); 4717 } 4718 4719 ffests_puts (s, string); 4720} 4721 4722/* ffestd_R1001dump_1010_3_ -- Dump a particular format 4723 4724 ffesttFormatList f; 4725 ffestd_R1001dump_1010_3_(f,"I"); 4726 4727 The format is dumped with form nX. */ 4728 4729static void 4730ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, const char *string) 4731{ 4732 assert (f->u.R1010.val.present); 4733 4734 if (f->u.R1010.val.rtexpr) 4735 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); 4736 else 4737 ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val); 4738 4739 ffests_puts (s, string); 4740} 4741 4742/* ffestd_R1001dump_1010_4_ -- Dump a particular format 4743 4744 ffesttFormatList f; 4745 ffestd_R1001dump_1010_4_(f,"I"); 4746 4747 The format is dumped with form kX. Note that k is signed. */ 4748 4749static void 4750ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string) 4751{ 4752 assert (f->u.R1010.val.present); 4753 4754 if (f->u.R1010.val.rtexpr) 4755 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); 4756 else 4757 ffests_printf_1D (s, "%ld", f->u.R1010.val.u.signed_val); 4758 4759 ffests_puts (s, string); 4760} 4761 4762/* ffestd_R1001dump_1010_5_ -- Dump a particular format 4763 4764 ffesttFormatList f; 4765 ffestd_R1001dump_1010_5_(f,"I"); 4766 4767 The format is dumped with form Xn. */ 4768 4769static void 4770ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string) 4771{ 4772 assert (f->u.R1010.val.present); 4773 4774 ffests_puts (s, string); 4775 4776 if (f->u.R1010.val.rtexpr) 4777 ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr); 4778 else 4779 ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val); 4780} 4781 4782/* ffestd_R1001error_ -- Complain about FORMAT specification not supported 4783 4784 ffesttFormatList f; 4785 ffestd_R1001error_(f); 4786 4787 An error message is produced. */ 4788 4789static void 4790ffestd_R1001error_ (ffesttFormatList f) 4791{ 4792 ffebad_start (FFEBAD_FORMAT_UNSUPPORTED); 4793 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); 4794 ffebad_finish (); 4795} 4796 4797static void 4798ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr) 4799{ 4800 if ((expr == NULL) 4801 || (ffebld_op (expr) != FFEBLD_opCONTER) 4802 || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER) 4803 || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4)) 4804 { 4805 ffebad_start (FFEBAD_FORMAT_VARIABLE); 4806 ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t)); 4807 ffebad_finish (); 4808 } 4809 else 4810 { 4811 int val; 4812 4813 switch (ffeinfo_kindtype (ffebld_info (expr))) 4814 { 4815#if FFETARGET_okINTEGER1 4816 case FFEINFO_kindtypeINTEGER1: 4817 val = ffebld_constant_integer1 (ffebld_conter (expr)); 4818 break; 4819#endif 4820 4821#if FFETARGET_okINTEGER2 4822 case FFEINFO_kindtypeINTEGER2: 4823 val = ffebld_constant_integer2 (ffebld_conter (expr)); 4824 break; 4825#endif 4826 4827#if FFETARGET_okINTEGER3 4828 case FFEINFO_kindtypeINTEGER3: 4829 val = ffebld_constant_integer3 (ffebld_conter (expr)); 4830 break; 4831#endif 4832 4833 default: 4834 assert ("bad INTEGER constant kind type" == NULL); 4835 /* Fall through. */ 4836 case FFEINFO_kindtypeANY: 4837 return; 4838 } 4839 ffests_printf_1D (s, "%ld", val); 4840 } 4841} 4842 4843/* ffestd_R1102 -- PROGRAM statement 4844 4845 ffestd_R1102(name_token); 4846 4847 Make sure ffestd_kind_ identifies an empty block. Make sure name_token 4848 gives a valid name. Implement the beginning of a main program. */ 4849 4850void 4851ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED) 4852{ 4853 ffestd_check_simple_ (); 4854 4855 assert (ffestd_block_level_ == 0); 4856 ffestd_is_reachable_ = TRUE; 4857 4858 ffecom_notify_primary_entry (s); 4859 ffe_set_is_mainprog (TRUE); /* Is a main program. */ 4860 ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */ 4861 4862 ffestw_set_sym (ffestw_stack_top (), s); 4863 4864#if FFECOM_targetCURRENT == FFECOM_targetFFE 4865 if (name == NULL) 4866 fputs ("< PROGRAM_unnamed\n", dmpout); 4867 else 4868 fprintf (dmpout, "< PROGRAM %s\n", ffelex_token_text (name)); 4869#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4870#else 4871#error 4872#endif 4873} 4874 4875/* ffestd_R1103 -- End a PROGRAM 4876 4877 ffestd_R1103(); */ 4878 4879void 4880ffestd_R1103 (bool ok UNUSED) 4881{ 4882 assert (ffestd_block_level_ == 0); 4883 4884 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) 4885 ffestd_R842 (NULL); /* Generate STOP. */ 4886 4887 if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5) 4888 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ 4889 4890#if FFECOM_ONEPASS 4891 ffeste_R1103 (); 4892#else 4893 { 4894 ffestdStmt_ stmt; 4895 4896 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_); 4897 ffestd_stmt_append_ (stmt); 4898 } 4899#endif 4900} 4901 4902/* ffestd_R1105 -- MODULE statement 4903 4904 ffestd_R1105(name_token); 4905 4906 Make sure ffestd_kind_ identifies an empty block. Make sure name_token 4907 gives a valid name. Implement the beginning of a module. */ 4908 4909#if FFESTR_F90 4910void 4911ffestd_R1105 (ffelexToken name) 4912{ 4913 assert (ffestd_block_level_ == 0); 4914 4915 ffestd_check_simple_ (); 4916 4917 ffestd_subr_f90_ (); 4918 return; 4919 4920#ifdef FFESTD_F90 4921 fprintf (dmpout, "* MODULE %s\n", ffelex_token_text (name)); 4922#endif 4923} 4924 4925/* ffestd_R1106 -- End a MODULE 4926 4927 ffestd_R1106(TRUE); */ 4928 4929void 4930ffestd_R1106 (bool ok) 4931{ 4932 assert (ffestd_block_level_ == 0); 4933 4934 /* Generate any wrap-up code here (unlikely in MODULE!). */ 4935 4936 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5) 4937 ffestd_subr_labels_ (TRUE); /* Handle any undefined labels (unlikely). */ 4938 4939 return; /* F90. */ 4940 4941#ifdef FFESTD_F90 4942 fprintf (dmpout, "< END_MODULE %s\n", 4943 ffelex_token_text (ffestw_name (ffestw_stack_top ()))); 4944#endif 4945} 4946 4947/* ffestd_R1107_start -- USE statement list begin 4948 4949 ffestd_R1107_start(); 4950 4951 Verify that USE is valid here, and begin accepting items in the list. */ 4952 4953void 4954ffestd_R1107_start (ffelexToken name, bool only) 4955{ 4956 ffestd_check_start_ (); 4957 4958 ffestd_subr_f90_ (); 4959 return; 4960 4961#ifdef FFESTD_F90 4962 fprintf (dmpout, "* USE %s,", ffelex_token_text (name)); /* NB 4963 _shriek_begin_uses_. */ 4964 if (only) 4965 fputs ("only: ", dmpout); 4966#endif 4967} 4968 4969/* ffestd_R1107_item -- USE statement for name 4970 4971 ffestd_R1107_item(local_token,use_token); 4972 4973 Make sure name_token identifies a valid object to be USEed. local_token 4974 may be NULL if _start_ was called with only==TRUE. */ 4975 4976void 4977ffestd_R1107_item (ffelexToken local, ffelexToken use) 4978{ 4979 ffestd_check_item_ (); 4980 assert (use != NULL); 4981 4982 return; /* F90. */ 4983 4984#ifdef FFESTD_F90 4985 if (local != NULL) 4986 fprintf (dmpout, "%s=>", ffelex_token_text (local)); 4987 fprintf (dmpout, "%s,", ffelex_token_text (use)); 4988#endif 4989} 4990 4991/* ffestd_R1107_finish -- USE statement list complete 4992 4993 ffestd_R1107_finish(); 4994 4995 Just wrap up any local activities. */ 4996 4997void 4998ffestd_R1107_finish () 4999{ 5000 ffestd_check_finish_ (); 5001 5002 return; /* F90. */ 5003 5004#ifdef FFESTD_F90 5005 fputc ('\n', dmpout); 5006#endif 5007} 5008 5009#endif 5010/* ffestd_R1111 -- BLOCK DATA statement 5011 5012 ffestd_R1111(name_token); 5013 5014 Make sure ffestd_kind_ identifies no current program unit. If not 5015 NULL, make sure name_token gives a valid name. Implement the beginning 5016 of a block data program unit. */ 5017 5018void 5019ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED) 5020{ 5021 assert (ffestd_block_level_ == 0); 5022 ffestd_is_reachable_ = TRUE; 5023 5024 ffestd_check_simple_ (); 5025 5026 ffecom_notify_primary_entry (s); 5027 ffestw_set_sym (ffestw_stack_top (), s); 5028 5029#if FFECOM_targetCURRENT == FFECOM_targetFFE 5030 if (name == NULL) 5031 fputs ("< BLOCK_DATA_unnamed\n", dmpout); 5032 else 5033 fprintf (dmpout, "< BLOCK_DATA %s\n", ffelex_token_text (name)); 5034#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5035#else 5036#error 5037#endif 5038} 5039 5040/* ffestd_R1112 -- End a BLOCK DATA 5041 5042 ffestd_R1112(TRUE); */ 5043 5044void 5045ffestd_R1112 (bool ok UNUSED) 5046{ 5047 assert (ffestd_block_level_ == 0); 5048 5049 /* Generate any return-like code here (not likely for BLOCK DATA!). */ 5050 5051 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5) 5052 ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */ 5053 5054#if FFECOM_ONEPASS 5055 ffeste_R1112 (); 5056#else 5057 { 5058 ffestdStmt_ stmt; 5059 5060 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_); 5061 ffestd_stmt_append_ (stmt); 5062 } 5063#endif 5064} 5065 5066/* ffestd_R1202 -- INTERFACE statement 5067 5068 ffestd_R1202(operator,defined_name); 5069 5070 Make sure ffestd_kind_ identifies an INTERFACE block. 5071 Implement the end of the current interface. 5072 5073 06-Jun-90 JCB 1.1 5074 Allow no operator or name to mean INTERFACE by itself; missed this 5075 valid form when originally doing syntactic analysis code. */ 5076 5077#if FFESTR_F90 5078void 5079ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name) 5080{ 5081 ffestd_check_simple_ (); 5082 5083 ffestd_subr_f90_ (); 5084 return; 5085 5086#ifdef FFESTD_F90 5087 switch (operator) 5088 { 5089 case FFESTP_definedoperatorNone: 5090 if (name == NULL) 5091 fputs ("* INTERFACE_unnamed\n", dmpout); 5092 else 5093 fprintf (dmpout, "* INTERFACE %s\n", ffelex_token_text (name)); 5094 break; 5095 5096 case FFESTP_definedoperatorOPERATOR: 5097 fprintf (dmpout, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name)); 5098 break; 5099 5100 case FFESTP_definedoperatorASSIGNMENT: 5101 fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout); 5102 break; 5103 5104 case FFESTP_definedoperatorPOWER: 5105 fputs ("* INTERFACE_OPERATOR (**)\n", dmpout); 5106 break; 5107 5108 case FFESTP_definedoperatorMULT: 5109 fputs ("* INTERFACE_OPERATOR (*)\n", dmpout); 5110 break; 5111 5112 case FFESTP_definedoperatorADD: 5113 fputs ("* INTERFACE_OPERATOR (+)\n", dmpout); 5114 break; 5115 5116 case FFESTP_definedoperatorCONCAT: 5117 fputs ("* INTERFACE_OPERATOR (//)\n", dmpout); 5118 break; 5119 5120 case FFESTP_definedoperatorDIVIDE: 5121 fputs ("* INTERFACE_OPERATOR (/)\n", dmpout); 5122 break; 5123 5124 case FFESTP_definedoperatorSUBTRACT: 5125 fputs ("* INTERFACE_OPERATOR (-)\n", dmpout); 5126 break; 5127 5128 case FFESTP_definedoperatorNOT: 5129 fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout); 5130 break; 5131 5132 case FFESTP_definedoperatorAND: 5133 fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout); 5134 break; 5135 5136 case FFESTP_definedoperatorOR: 5137 fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout); 5138 break; 5139 5140 case FFESTP_definedoperatorEQV: 5141 fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout); 5142 break; 5143 5144 case FFESTP_definedoperatorNEQV: 5145 fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout); 5146 break; 5147 5148 case FFESTP_definedoperatorEQ: 5149 fputs ("* INTERFACE_OPERATOR (==)\n", dmpout); 5150 break; 5151 5152 case FFESTP_definedoperatorNE: 5153 fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout); 5154 break; 5155 5156 case FFESTP_definedoperatorLT: 5157 fputs ("* INTERFACE_OPERATOR (<)\n", dmpout); 5158 break; 5159 5160 case FFESTP_definedoperatorLE: 5161 fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout); 5162 break; 5163 5164 case FFESTP_definedoperatorGT: 5165 fputs ("* INTERFACE_OPERATOR (>)\n", dmpout); 5166 break; 5167 5168 case FFESTP_definedoperatorGE: 5169 fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout); 5170 break; 5171 5172 default: 5173 assert (FALSE); 5174 break; 5175 } 5176#endif 5177} 5178 5179/* ffestd_R1203 -- End an INTERFACE 5180 5181 ffestd_R1203(TRUE); */ 5182 5183void 5184ffestd_R1203 (bool ok) 5185{ 5186 return; /* F90. */ 5187 5188#ifdef FFESTD_F90 5189 fputs ("* END_INTERFACE\n", dmpout); 5190#endif 5191} 5192 5193/* ffestd_R1205_start -- MODULE PROCEDURE statement list begin 5194 5195 ffestd_R1205_start(); 5196 5197 Verify that MODULE PROCEDURE is valid here, and begin accepting items in 5198 the list. */ 5199 5200void 5201ffestd_R1205_start () 5202{ 5203 ffestd_check_start_ (); 5204 5205 return; /* F90. */ 5206 5207#ifdef FFESTD_F90 5208 fputs ("* MODULE_PROCEDURE ", dmpout); 5209#endif 5210} 5211 5212/* ffestd_R1205_item -- MODULE PROCEDURE statement for name 5213 5214 ffestd_R1205_item(name_token); 5215 5216 Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */ 5217 5218void 5219ffestd_R1205_item (ffelexToken name) 5220{ 5221 ffestd_check_item_ (); 5222 assert (name != NULL); 5223 5224 return; /* F90. */ 5225 5226#ifdef FFESTD_F90 5227 fprintf (dmpout, "%s,", ffelex_token_text (name)); 5228#endif 5229} 5230 5231/* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete 5232 5233 ffestd_R1205_finish(); 5234 5235 Just wrap up any local activities. */ 5236 5237void 5238ffestd_R1205_finish () 5239{ 5240 ffestd_check_finish_ (); 5241 5242 return; /* F90. */ 5243 5244#ifdef FFESTD_F90 5245 fputc ('\n', dmpout); 5246#endif 5247} 5248 5249#endif 5250/* ffestd_R1207_start -- EXTERNAL statement list begin 5251 5252 ffestd_R1207_start(); 5253 5254 Verify that EXTERNAL is valid here, and begin accepting items in the list. */ 5255 5256void 5257ffestd_R1207_start () 5258{ 5259 ffestd_check_start_ (); 5260 5261#if FFECOM_targetCURRENT == FFECOM_targetFFE 5262 fputs ("* EXTERNAL (", dmpout); 5263#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5264#else 5265#error 5266#endif 5267} 5268 5269/* ffestd_R1207_item -- EXTERNAL statement for name 5270 5271 ffestd_R1207_item(name_token); 5272 5273 Make sure name_token identifies a valid object to be EXTERNALd. */ 5274 5275void 5276ffestd_R1207_item (ffelexToken name) 5277{ 5278 ffestd_check_item_ (); 5279 assert (name != NULL); 5280 5281#if FFECOM_targetCURRENT == FFECOM_targetFFE 5282 fprintf (dmpout, "%s,", ffelex_token_text (name)); 5283#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5284#else 5285#error 5286#endif 5287} 5288 5289/* ffestd_R1207_finish -- EXTERNAL statement list complete 5290 5291 ffestd_R1207_finish(); 5292 5293 Just wrap up any local activities. */ 5294 5295void 5296ffestd_R1207_finish () 5297{ 5298 ffestd_check_finish_ (); 5299 5300#if FFECOM_targetCURRENT == FFECOM_targetFFE 5301 fputs (")\n", dmpout); 5302#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5303#else 5304#error 5305#endif 5306} 5307 5308/* ffestd_R1208_start -- INTRINSIC statement list begin 5309 5310 ffestd_R1208_start(); 5311 5312 Verify that INTRINSIC is valid here, and begin accepting items in the list. */ 5313 5314void 5315ffestd_R1208_start () 5316{ 5317 ffestd_check_start_ (); 5318 5319#if FFECOM_targetCURRENT == FFECOM_targetFFE 5320 fputs ("* INTRINSIC (", dmpout); 5321#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5322#else 5323#error 5324#endif 5325} 5326 5327/* ffestd_R1208_item -- INTRINSIC statement for name 5328 5329 ffestd_R1208_item(name_token); 5330 5331 Make sure name_token identifies a valid object to be INTRINSICd. */ 5332 5333void 5334ffestd_R1208_item (ffelexToken name) 5335{ 5336 ffestd_check_item_ (); 5337 assert (name != NULL); 5338 5339#if FFECOM_targetCURRENT == FFECOM_targetFFE 5340 fprintf (dmpout, "%s,", ffelex_token_text (name)); 5341#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5342#else 5343#error 5344#endif 5345} 5346 5347/* ffestd_R1208_finish -- INTRINSIC statement list complete 5348 5349 ffestd_R1208_finish(); 5350 5351 Just wrap up any local activities. */ 5352 5353void 5354ffestd_R1208_finish () 5355{ 5356 ffestd_check_finish_ (); 5357 5358#if FFECOM_targetCURRENT == FFECOM_targetFFE 5359 fputs (")\n", dmpout); 5360#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5361#else 5362#error 5363#endif 5364} 5365 5366/* ffestd_R1212 -- CALL statement 5367 5368 ffestd_R1212(expr,expr_token); 5369 5370 Make sure statement is valid here; implement. */ 5371 5372void 5373ffestd_R1212 (ffebld expr) 5374{ 5375 ffestd_check_simple_ (); 5376 5377#if FFECOM_ONEPASS 5378 ffestd_subr_line_now_ (); 5379 ffeste_R1212 (expr); 5380#else 5381 { 5382 ffestdStmt_ stmt; 5383 5384 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_); 5385 ffestd_stmt_append_ (stmt); 5386 ffestd_subr_line_save_ (stmt); 5387 stmt->u.R1212.pool = ffesta_output_pool; 5388 stmt->u.R1212.expr = expr; 5389 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 5390 } 5391#endif 5392} 5393 5394/* ffestd_R1213 -- Defined assignment statement 5395 5396 ffestd_R1213(dest_expr,source_expr,source_token); 5397 5398 Make sure the assignment is valid. */ 5399 5400#if FFESTR_F90 5401void 5402ffestd_R1213 (ffebld dest, ffebld source) 5403{ 5404 ffestd_check_simple_ (); 5405 5406 ffestd_subr_f90_ (); 5407 return; 5408 5409#ifdef FFESTD_F90 5410 fputs ("+ let_defined ", dmpout); 5411 ffebld_dump (dest); 5412 fputs ("=", dmpout); 5413 ffebld_dump (source); 5414 fputc ('\n', dmpout); 5415#endif 5416} 5417 5418#endif 5419/* ffestd_R1219 -- FUNCTION statement 5420 5421 ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent, 5422 recursive); 5423 5424 Make sure statement is valid here, register arguments for the 5425 function name, and so on. 5426 5427 06-Jun-90 JCB 2.0 5428 Added the kind, len, and recursive arguments. */ 5429 5430void 5431ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED, 5432 ffesttTokenList args UNUSED, ffestpType type UNUSED, 5433 ffebld kind UNUSED, ffelexToken kindt UNUSED, 5434 ffebld len UNUSED, ffelexToken lent UNUSED, 5435 bool recursive UNUSED, ffelexToken result UNUSED, 5436 bool separate_result UNUSED) 5437{ 5438#if FFECOM_targetCURRENT == FFECOM_targetFFE 5439 char *a; 5440#endif 5441 5442 assert (ffestd_block_level_ == 0); 5443 ffestd_is_reachable_ = TRUE; 5444 5445 ffestd_check_simple_ (); 5446 5447 ffecom_notify_primary_entry (s); 5448 ffestw_set_sym (ffestw_stack_top (), s); 5449 5450#if FFECOM_targetCURRENT == FFECOM_targetFFE 5451 switch (type) 5452 { 5453 case FFESTP_typeINTEGER: 5454 a = "INTEGER"; 5455 break; 5456 5457 case FFESTP_typeBYTE: 5458 a = "BYTE"; 5459 break; 5460 5461 case FFESTP_typeWORD: 5462 a = "WORD"; 5463 break; 5464 5465 case FFESTP_typeREAL: 5466 a = "REAL"; 5467 break; 5468 5469 case FFESTP_typeCOMPLEX: 5470 a = "COMPLEX"; 5471 break; 5472 5473 case FFESTP_typeLOGICAL: 5474 a = "LOGICAL"; 5475 break; 5476 5477 case FFESTP_typeCHARACTER: 5478 a = "CHARACTER"; 5479 break; 5480 5481 case FFESTP_typeDBLPRCSN: 5482 a = "DOUBLE PRECISION"; 5483 break; 5484 5485 case FFESTP_typeDBLCMPLX: 5486 a = "DOUBLE COMPLEX"; 5487 break; 5488 5489#if FFESTR_F90 5490 case FFESTP_typeTYPE: 5491 a = "TYPE"; 5492 break; 5493#endif 5494 5495 case FFESTP_typeNone: 5496 a = ""; 5497 break; 5498 5499 default: 5500 assert (FALSE); 5501 a = "?"; 5502 break; 5503 } 5504 fprintf (dmpout, "< FUNCTION %s ", ffelex_token_text (funcname)); 5505 if (recursive) 5506 fputs ("RECURSIVE ", dmpout); 5507 fprintf (dmpout, "%s(", a); 5508 if (kindt != NULL) 5509 { 5510 fputs ("kind=", dmpout); 5511 if (kind == NULL) 5512 fputs (ffelex_token_text (kindt), dmpout); 5513 else 5514 ffebld_dump (kind); 5515 if (lent != NULL) 5516 fputc (',', dmpout); 5517 } 5518 if (lent != NULL) 5519 { 5520 fputs ("len=", dmpout); 5521 if (len == NULL) 5522 fputs (ffelex_token_text (lent), dmpout); 5523 else 5524 ffebld_dump (len); 5525 } 5526 fprintf (dmpout, ")"); 5527 if (args != NULL) 5528 { 5529 fputs (" (", dmpout); 5530 ffestt_tokenlist_dump (args); 5531 fputc (')', dmpout); 5532 } 5533 if (result != NULL) 5534 fprintf (dmpout, " result(%s)", ffelex_token_text (result)); 5535 fputc ('\n', dmpout); 5536#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5537#else 5538#error 5539#endif 5540} 5541 5542/* ffestd_R1221 -- End a FUNCTION 5543 5544 ffestd_R1221(TRUE); */ 5545 5546void 5547ffestd_R1221 (bool ok UNUSED) 5548{ 5549 assert (ffestd_block_level_ == 0); 5550 5551 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) 5552 ffestd_R1227 (NULL); /* Generate RETURN. */ 5553 5554 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5) 5555 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ 5556 5557#if FFECOM_ONEPASS 5558 ffeste_R1221 (); 5559#else 5560 { 5561 ffestdStmt_ stmt; 5562 5563 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_); 5564 ffestd_stmt_append_ (stmt); 5565 } 5566#endif 5567} 5568 5569/* ffestd_R1223 -- SUBROUTINE statement 5570 5571 ffestd_R1223(subrname,arglist,ending_token,recursive_token); 5572 5573 Make sure statement is valid here, register arguments for the 5574 subroutine name, and so on. 5575 5576 06-Jun-90 JCB 2.0 5577 Added the recursive argument. */ 5578 5579void 5580ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED, 5581 ffesttTokenList args UNUSED, ffelexToken final UNUSED, 5582 bool recursive UNUSED) 5583{ 5584 assert (ffestd_block_level_ == 0); 5585 ffestd_is_reachable_ = TRUE; 5586 5587 ffestd_check_simple_ (); 5588 5589 ffecom_notify_primary_entry (s); 5590 ffestw_set_sym (ffestw_stack_top (), s); 5591 5592#if FFECOM_targetCURRENT == FFECOM_targetFFE 5593 fprintf (dmpout, "< SUBROUTINE %s ", ffelex_token_text (subrname)); 5594 if (recursive) 5595 fputs ("recursive ", dmpout); 5596 if (args != NULL) 5597 { 5598 fputc ('(', dmpout); 5599 ffestt_tokenlist_dump (args); 5600 fputc (')', dmpout); 5601 } 5602 fputc ('\n', dmpout); 5603#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5604#else 5605#error 5606#endif 5607} 5608 5609/* ffestd_R1225 -- End a SUBROUTINE 5610 5611 ffestd_R1225(TRUE); */ 5612 5613void 5614ffestd_R1225 (bool ok UNUSED) 5615{ 5616 assert (ffestd_block_level_ == 0); 5617 5618 if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_) 5619 ffestd_R1227 (NULL); /* Generate RETURN. */ 5620 5621 if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5) 5622 ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */ 5623 5624#if FFECOM_ONEPASS 5625 ffeste_R1225 (); 5626#else 5627 { 5628 ffestdStmt_ stmt; 5629 5630 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_); 5631 ffestd_stmt_append_ (stmt); 5632 } 5633#endif 5634} 5635 5636/* ffestd_R1226 -- ENTRY statement 5637 5638 ffestd_R1226(entryname,arglist,ending_token); 5639 5640 Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the 5641 entry point name, and so on. */ 5642 5643void 5644ffestd_R1226 (ffesymbol entry) 5645{ 5646 ffestd_check_simple_ (); 5647 5648#if (FFECOM_targetCURRENT == FFECOM_targetFFE) || FFECOM_ONEPASS 5649 ffestd_subr_line_now_ (); 5650 ffeste_R1226 (entry); 5651#else 5652 if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry)) 5653 { 5654 ffestdStmt_ stmt; 5655 5656 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_); 5657 ffestd_stmt_append_ (stmt); 5658 ffestd_subr_line_save_ (stmt); 5659 stmt->u.R1226.entry = entry; 5660 stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_; 5661 } 5662#endif 5663 5664 ffestd_is_reachable_ = TRUE; 5665} 5666 5667/* ffestd_R1227 -- RETURN statement 5668 5669 ffestd_R1227(expr); 5670 5671 Make sure statement is valid here; implement. expr and expr_token are 5672 both NULL if there was no expression. */ 5673 5674void 5675ffestd_R1227 (ffebld expr) 5676{ 5677 ffestd_check_simple_ (); 5678 5679#if FFECOM_ONEPASS 5680 ffestd_subr_line_now_ (); 5681 ffeste_R1227 (ffestw_stack_top (), expr); 5682#else 5683 { 5684 ffestdStmt_ stmt; 5685 5686 stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_); 5687 ffestd_stmt_append_ (stmt); 5688 ffestd_subr_line_save_ (stmt); 5689 stmt->u.R1227.pool = ffesta_output_pool; 5690 stmt->u.R1227.block = ffestw_stack_top (); 5691 stmt->u.R1227.expr = expr; 5692 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 5693 } 5694#endif 5695 5696 if (ffestd_block_level_ == 0) 5697 ffestd_is_reachable_ = FALSE; 5698} 5699 5700/* ffestd_R1228 -- CONTAINS statement 5701 5702 ffestd_R1228(); */ 5703 5704#if FFESTR_F90 5705void 5706ffestd_R1228 () 5707{ 5708 assert (ffestd_block_level_ == 0); 5709 5710 ffestd_check_simple_ (); 5711 5712 /* Generate RETURN/STOP code here */ 5713 5714 ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ()) 5715 == FFESTV_stateMODULE5); /* Handle any undefined 5716 labels. */ 5717 5718 ffestd_subr_f90_ (); 5719 return; 5720 5721#ifdef FFESTD_F90 5722 fputs ("- CONTAINS\n", dmpout); 5723#endif 5724} 5725 5726#endif 5727/* ffestd_R1229_start -- STMTFUNCTION statement begin 5728 5729 ffestd_R1229_start(func_name,func_arg_list,close_paren); 5730 5731 This function does not really need to do anything, since _finish_ 5732 gets all the info needed, and ffestc_R1229_start has already 5733 done all the stuff that makes a two-phase operation (start and 5734 finish) for handling statement functions necessary. 5735 5736 03-Jan-91 JCB 2.0 5737 Do nothing, now that _finish_ does everything. */ 5738 5739void 5740ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED) 5741{ 5742 ffestd_check_start_ (); 5743 5744#if FFECOM_targetCURRENT == FFECOM_targetFFE 5745#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5746#else 5747#error 5748#endif 5749} 5750 5751/* ffestd_R1229_finish -- STMTFUNCTION statement list complete 5752 5753 ffestd_R1229_finish(s); 5754 5755 The statement function's symbol is passed. Its list of dummy args is 5756 accessed via ffesymbol_dummyargs and its expansion expression (expr) 5757 is accessed via ffesymbol_sfexpr. 5758 5759 If sfexpr is NULL, an error occurred parsing the expansion expression, so 5760 just cancel the effects of ffestd_R1229_start and pretend nothing 5761 happened. Otherwise, install the expression as the expansion for the 5762 statement function, then clean up. 5763 5764 03-Jan-91 JCB 2.0 5765 Takes sfunc sym instead of just the expansion expression as an 5766 argument, so this function can do all the work, and _start_ is just 5767 a nicety than can do nothing in a back end. */ 5768 5769void 5770ffestd_R1229_finish (ffesymbol s) 5771{ 5772#if FFECOM_targetCURRENT == FFECOM_targetFFE 5773 ffebld args = ffesymbol_dummyargs (s); 5774#endif 5775 ffebld expr = ffesymbol_sfexpr (s); 5776 5777 ffestd_check_finish_ (); 5778 5779 if (expr == NULL) 5780 return; /* Nothing to do, definition didn't work. */ 5781 5782#if FFECOM_targetCURRENT == FFECOM_targetFFE 5783 fprintf (dmpout, "* stmtfunction %s(", ffesymbol_text (s)); 5784 for (; args != NULL; args = ffebld_trail (args)) 5785 fprintf (dmpout, "%s,", ffesymbol_text (ffebld_symter (ffebld_head (args)))); 5786 fputs (")=", dmpout); 5787 ffebld_dump (expr); 5788 fputc ('\n', dmpout); 5789#if 0 /* Normally no need to preserve the 5790 expression. */ 5791 ffesymbol_set_sfexpr (s, NULL); /* Except expr.c sees NULL 5792 as recursive reference! 5793 So until we can use something 5794 convenient, like a "permanent" 5795 expression, don't worry about 5796 wasting some memory in the 5797 stand-alone FFE. */ 5798#else 5799 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 5800#endif 5801#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5802 /* With gcc, cannot do anything here, because the backend hasn't even 5803 (necessarily) been notified that we're compiling a program unit! */ 5804 5805#if 0 /* Must preserve the expression for gcc. */ 5806 ffesymbol_set_sfexpr (s, NULL); 5807#else 5808 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 5809#endif 5810#else 5811#error 5812#endif 5813} 5814 5815/* ffestd_S3P4 -- INCLUDE line 5816 5817 ffestd_S3P4(filename,filename_token); 5818 5819 Make sure INCLUDE not preceded by any semicolons or a label def; implement. */ 5820 5821void 5822ffestd_S3P4 (ffebld filename) 5823{ 5824 FILE *fi; 5825 ffetargetCharacterDefault buildname; 5826 ffewhereFile wf; 5827 5828 ffestd_check_simple_ (); 5829 5830 assert (filename != NULL); 5831 if (ffebld_op (filename) != FFEBLD_opANY) 5832 { 5833 assert (ffebld_op (filename) == FFEBLD_opCONTER); 5834 assert (ffeinfo_basictype (ffebld_info (filename)) 5835 == FFEINFO_basictypeCHARACTER); 5836 assert (ffeinfo_kindtype (ffebld_info (filename)) 5837 == FFEINFO_kindtypeCHARACTERDEFAULT); 5838 buildname = ffebld_constant_characterdefault (ffebld_conter (filename)); 5839 wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname), 5840 ffetarget_length_characterdefault (buildname)); 5841 fi = ffecom_open_include (ffewhere_file_name (wf), 5842 ffelex_token_where_line (ffesta_tokens[0]), 5843 ffelex_token_where_column (ffesta_tokens[0])); 5844 if (fi == NULL) 5845 ffewhere_file_kill (wf); 5846 else 5847 ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0]) 5848 == FFELEX_typeNAME), fi); 5849 } 5850} 5851 5852/* ffestd_V003_start -- STRUCTURE statement list begin 5853 5854 ffestd_V003_start(structure_name); 5855 5856 Verify that STRUCTURE is valid here, and begin accepting items in the list. */ 5857 5858#if FFESTR_VXT 5859void 5860ffestd_V003_start (ffelexToken structure_name) 5861{ 5862 ffestd_check_start_ (); 5863 5864#if FFECOM_targetCURRENT == FFECOM_targetFFE 5865 if (structure_name == NULL) 5866 fputs ("* STRUCTURE_unnamed ", dmpout); 5867 else 5868 fprintf (dmpout, "* STRUCTURE %s ", ffelex_token_text (structure_name)); 5869#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5870 ffestd_subr_vxt_ (); 5871#else 5872#error 5873#endif 5874} 5875 5876/* ffestd_V003_item -- STRUCTURE statement for object-name 5877 5878 ffestd_V003_item(name_token,dim_list); 5879 5880 Make sure name_token identifies a valid object to be STRUCTUREd. */ 5881 5882void 5883ffestd_V003_item (ffelexToken name, ffesttDimList dims) 5884{ 5885 ffestd_check_item_ (); 5886 5887#if FFECOM_targetCURRENT == FFECOM_targetFFE 5888 fputs (ffelex_token_text (name), dmpout); 5889 if (dims != NULL) 5890 { 5891 fputc ('(', dmpout); 5892 ffestt_dimlist_dump (dims); 5893 fputc (')', dmpout); 5894 } 5895 fputc (',', dmpout); 5896#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5897#else 5898#error 5899#endif 5900} 5901 5902/* ffestd_V003_finish -- STRUCTURE statement list complete 5903 5904 ffestd_V003_finish(); 5905 5906 Just wrap up any local activities. */ 5907 5908void 5909ffestd_V003_finish () 5910{ 5911 ffestd_check_finish_ (); 5912 5913#if FFECOM_targetCURRENT == FFECOM_targetFFE 5914 fputc ('\n', dmpout); 5915#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5916#else 5917#error 5918#endif 5919} 5920 5921/* ffestd_V004 -- End a STRUCTURE 5922 5923 ffestd_V004(TRUE); */ 5924 5925void 5926ffestd_V004 (bool ok) 5927{ 5928#if FFECOM_targetCURRENT == FFECOM_targetFFE 5929 fputs ("* END_STRUCTURE\n", dmpout); 5930#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5931#else 5932#error 5933#endif 5934} 5935 5936/* ffestd_V009 -- UNION statement 5937 5938 ffestd_V009(); */ 5939 5940void 5941ffestd_V009 () 5942{ 5943 ffestd_check_simple_ (); 5944 5945#if FFECOM_targetCURRENT == FFECOM_targetFFE 5946 fputs ("* UNION\n", dmpout); 5947#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5948#else 5949#error 5950#endif 5951} 5952 5953/* ffestd_V010 -- End a UNION 5954 5955 ffestd_V010(TRUE); */ 5956 5957void 5958ffestd_V010 (bool ok) 5959{ 5960#if FFECOM_targetCURRENT == FFECOM_targetFFE 5961 fputs ("* END_UNION\n", dmpout); 5962#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5963#else 5964#error 5965#endif 5966} 5967 5968/* ffestd_V012 -- MAP statement 5969 5970 ffestd_V012(); */ 5971 5972void 5973ffestd_V012 () 5974{ 5975 ffestd_check_simple_ (); 5976 5977#if FFECOM_targetCURRENT == FFECOM_targetFFE 5978 fputs ("* MAP\n", dmpout); 5979#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5980#else 5981#error 5982#endif 5983} 5984 5985/* ffestd_V013 -- End a MAP 5986 5987 ffestd_V013(TRUE); */ 5988 5989void 5990ffestd_V013 (bool ok) 5991{ 5992#if FFECOM_targetCURRENT == FFECOM_targetFFE 5993 fputs ("* END_MAP\n", dmpout); 5994#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5995#else 5996#error 5997#endif 5998} 5999 6000#endif 6001/* ffestd_V014_start -- VOLATILE statement list begin 6002 6003 ffestd_V014_start(); 6004 6005 Verify that VOLATILE is valid here, and begin accepting items in the list. */ 6006 6007void 6008ffestd_V014_start () 6009{ 6010 ffestd_check_start_ (); 6011 6012#if FFECOM_targetCURRENT == FFECOM_targetFFE 6013 fputs ("* VOLATILE (", dmpout); 6014#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6015 ffestd_subr_vxt_ (); 6016#else 6017#error 6018#endif 6019} 6020 6021/* ffestd_V014_item_object -- VOLATILE statement for object-name 6022 6023 ffestd_V014_item_object(name_token); 6024 6025 Make sure name_token identifies a valid object to be VOLATILEd. */ 6026 6027void 6028ffestd_V014_item_object (ffelexToken name UNUSED) 6029{ 6030 ffestd_check_item_ (); 6031 6032#if FFECOM_targetCURRENT == FFECOM_targetFFE 6033 fprintf (dmpout, "%s,", ffelex_token_text (name)); 6034#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6035#else 6036#error 6037#endif 6038} 6039 6040/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name 6041 6042 ffestd_V014_item_cblock(name_token); 6043 6044 Make sure name_token identifies a valid common block to be VOLATILEd. */ 6045 6046void 6047ffestd_V014_item_cblock (ffelexToken name UNUSED) 6048{ 6049 ffestd_check_item_ (); 6050 6051#if FFECOM_targetCURRENT == FFECOM_targetFFE 6052 fprintf (dmpout, "/%s/,", ffelex_token_text (name)); 6053#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6054#else 6055#error 6056#endif 6057} 6058 6059/* ffestd_V014_finish -- VOLATILE statement list complete 6060 6061 ffestd_V014_finish(); 6062 6063 Just wrap up any local activities. */ 6064 6065void 6066ffestd_V014_finish () 6067{ 6068 ffestd_check_finish_ (); 6069 6070#if FFECOM_targetCURRENT == FFECOM_targetFFE 6071 fputs (")\n", dmpout); 6072#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6073#else 6074#error 6075#endif 6076} 6077 6078/* ffestd_V016_start -- RECORD statement list begin 6079 6080 ffestd_V016_start(); 6081 6082 Verify that RECORD is valid here, and begin accepting items in the list. */ 6083 6084#if FFESTR_VXT 6085void 6086ffestd_V016_start () 6087{ 6088 ffestd_check_start_ (); 6089 6090#if FFECOM_targetCURRENT == FFECOM_targetFFE 6091 fputs ("* RECORD ", dmpout); 6092#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6093 ffestd_subr_vxt_ (); 6094#else 6095#error 6096#endif 6097} 6098 6099/* ffestd_V016_item_structure -- RECORD statement for common-block-name 6100 6101 ffestd_V016_item_structure(name_token); 6102 6103 Make sure name_token identifies a valid structure to be RECORDed. */ 6104 6105void 6106ffestd_V016_item_structure (ffelexToken name) 6107{ 6108 ffestd_check_item_ (); 6109 6110#if FFECOM_targetCURRENT == FFECOM_targetFFE 6111 fprintf (dmpout, "/%s/,", ffelex_token_text (name)); 6112#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6113#else 6114#error 6115#endif 6116} 6117 6118/* ffestd_V016_item_object -- RECORD statement for object-name 6119 6120 ffestd_V016_item_object(name_token,dim_list); 6121 6122 Make sure name_token identifies a valid object to be RECORDd. */ 6123 6124void 6125ffestd_V016_item_object (ffelexToken name, ffesttDimList dims) 6126{ 6127 ffestd_check_item_ (); 6128 6129#if FFECOM_targetCURRENT == FFECOM_targetFFE 6130 fputs (ffelex_token_text (name), dmpout); 6131 if (dims != NULL) 6132 { 6133 fputc ('(', dmpout); 6134 ffestt_dimlist_dump (dims); 6135 fputc (')', dmpout); 6136 } 6137 fputc (',', dmpout); 6138#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6139#else 6140#error 6141#endif 6142} 6143 6144/* ffestd_V016_finish -- RECORD statement list complete 6145 6146 ffestd_V016_finish(); 6147 6148 Just wrap up any local activities. */ 6149 6150void 6151ffestd_V016_finish () 6152{ 6153 ffestd_check_finish_ (); 6154 6155#if FFECOM_targetCURRENT == FFECOM_targetFFE 6156 fputc ('\n', dmpout); 6157#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6158#else 6159#error 6160#endif 6161} 6162 6163/* ffestd_V018_start -- REWRITE(...) statement list begin 6164 6165 ffestd_V018_start(); 6166 6167 Verify that REWRITE is valid here, and begin accepting items in the 6168 list. */ 6169 6170void 6171ffestd_V018_start (ffestvFormat format) 6172{ 6173 ffestd_check_start_ (); 6174 6175#if FFECOM_targetCURRENT == FFECOM_targetFFE 6176 6177#if FFECOM_ONEPASS 6178 ffestd_subr_line_now_ (); 6179 ffeste_V018_start (&ffestp_file.rewrite, format); 6180#else 6181 { 6182 ffestdStmt_ stmt; 6183 6184 stmt = ffestd_stmt_new_ (FFESTD_stmtidV018_); 6185 ffestd_stmt_append_ (stmt); 6186 ffestd_subr_line_save_ (stmt); 6187 stmt->u.V018.pool = ffesta_output_pool; 6188 stmt->u.V018.params = ffestd_subr_copy_rewrite_ (); 6189 stmt->u.V018.format = format; 6190 stmt->u.V018.list = NULL; 6191 ffestd_expr_list_ = &stmt->u.V018.list; 6192 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6193 } 6194#endif 6195 6196#endif 6197#if FFECOM_targetCURRENT == FFECOM_targetGCC 6198 ffestd_subr_vxt_ (); 6199#endif 6200} 6201 6202/* ffestd_V018_item -- REWRITE statement i/o item 6203 6204 ffestd_V018_item(expr,expr_token); 6205 6206 Implement output-list expression. */ 6207 6208void 6209ffestd_V018_item (ffebld expr) 6210{ 6211 ffestd_check_item_ (); 6212 6213#if FFECOM_targetCURRENT == FFECOM_targetFFE 6214 6215#if FFECOM_ONEPASS 6216 ffeste_V018_item (expr); 6217#else 6218 { 6219 ffestdExprItem_ item 6220 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 6221 sizeof (*item)); 6222 6223 item->next = NULL; 6224 item->expr = expr; 6225 *ffestd_expr_list_ = item; 6226 ffestd_expr_list_ = &item->next; 6227 } 6228#endif 6229 6230#endif 6231#if FFECOM_targetCURRENT == FFECOM_targetGCC 6232#endif 6233} 6234 6235/* ffestd_V018_finish -- REWRITE statement list complete 6236 6237 ffestd_V018_finish(); 6238 6239 Just wrap up any local activities. */ 6240 6241void 6242ffestd_V018_finish () 6243{ 6244 ffestd_check_finish_ (); 6245 6246#if FFECOM_targetCURRENT == FFECOM_targetFFE 6247 6248#if FFECOM_ONEPASS 6249 ffeste_V018_finish (); 6250#else 6251 /* Nothing to do, it's implicit. */ 6252#endif 6253 6254#endif 6255#if FFECOM_targetCURRENT == FFECOM_targetGCC 6256#endif 6257} 6258 6259/* ffestd_V019_start -- ACCEPT statement list begin 6260 6261 ffestd_V019_start(); 6262 6263 Verify that ACCEPT is valid here, and begin accepting items in the 6264 list. */ 6265 6266void 6267ffestd_V019_start (ffestvFormat format) 6268{ 6269 ffestd_check_start_ (); 6270 6271#if FFECOM_targetCURRENT == FFECOM_targetFFE 6272 6273#if FFECOM_ONEPASS 6274 ffestd_subr_line_now_ (); 6275 ffeste_V019_start (&ffestp_file.accept, format); 6276#else 6277 { 6278 ffestdStmt_ stmt; 6279 6280 stmt = ffestd_stmt_new_ (FFESTD_stmtidV019_); 6281 ffestd_stmt_append_ (stmt); 6282 ffestd_subr_line_save_ (stmt); 6283 stmt->u.V019.pool = ffesta_output_pool; 6284 stmt->u.V019.params = ffestd_subr_copy_accept_ (); 6285 stmt->u.V019.format = format; 6286 stmt->u.V019.list = NULL; 6287 ffestd_expr_list_ = &stmt->u.V019.list; 6288 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6289 } 6290#endif 6291 6292#endif 6293#if FFECOM_targetCURRENT == FFECOM_targetGCC 6294 ffestd_subr_vxt_ (); 6295#endif 6296} 6297 6298/* ffestd_V019_item -- ACCEPT statement i/o item 6299 6300 ffestd_V019_item(expr,expr_token); 6301 6302 Implement output-list expression. */ 6303 6304void 6305ffestd_V019_item (ffebld expr) 6306{ 6307 ffestd_check_item_ (); 6308 6309#if FFECOM_targetCURRENT == FFECOM_targetFFE 6310 6311#if FFECOM_ONEPASS 6312 ffeste_V019_item (expr); 6313#else 6314 { 6315 ffestdExprItem_ item 6316 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 6317 sizeof (*item)); 6318 6319 item->next = NULL; 6320 item->expr = expr; 6321 *ffestd_expr_list_ = item; 6322 ffestd_expr_list_ = &item->next; 6323 } 6324#endif 6325 6326#endif 6327#if FFECOM_targetCURRENT == FFECOM_targetGCC 6328#endif 6329} 6330 6331/* ffestd_V019_finish -- ACCEPT statement list complete 6332 6333 ffestd_V019_finish(); 6334 6335 Just wrap up any local activities. */ 6336 6337void 6338ffestd_V019_finish () 6339{ 6340 ffestd_check_finish_ (); 6341 6342#if FFECOM_targetCURRENT == FFECOM_targetFFE 6343 6344#if FFECOM_ONEPASS 6345 ffeste_V019_finish (); 6346#else 6347 /* Nothing to do, it's implicit. */ 6348#endif 6349 6350#endif 6351#if FFECOM_targetCURRENT == FFECOM_targetGCC 6352#endif 6353} 6354 6355#endif 6356/* ffestd_V020_start -- TYPE statement list begin 6357 6358 ffestd_V020_start(); 6359 6360 Verify that TYPE is valid here, and begin accepting items in the 6361 list. */ 6362 6363void 6364ffestd_V020_start (ffestvFormat format UNUSED) 6365{ 6366 ffestd_check_start_ (); 6367 6368#if FFECOM_targetCURRENT == FFECOM_targetFFE 6369 6370#if FFECOM_ONEPASS 6371 ffestd_subr_line_now_ (); 6372 ffeste_V020_start (&ffestp_file.type, format); 6373#else 6374 { 6375 ffestdStmt_ stmt; 6376 6377 stmt = ffestd_stmt_new_ (FFESTD_stmtidV020_); 6378 ffestd_stmt_append_ (stmt); 6379 ffestd_subr_line_save_ (stmt); 6380 stmt->u.V020.pool = ffesta_output_pool; 6381 stmt->u.V020.params = ffestd_subr_copy_type_ (); 6382 stmt->u.V020.format = format; 6383 stmt->u.V020.list = NULL; 6384 ffestd_expr_list_ = &stmt->u.V020.list; 6385 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6386 } 6387#endif 6388 6389#endif 6390#if FFECOM_targetCURRENT == FFECOM_targetGCC 6391 ffestd_subr_vxt_ (); 6392#endif 6393} 6394 6395/* ffestd_V020_item -- TYPE statement i/o item 6396 6397 ffestd_V020_item(expr,expr_token); 6398 6399 Implement output-list expression. */ 6400 6401void 6402ffestd_V020_item (ffebld expr UNUSED) 6403{ 6404 ffestd_check_item_ (); 6405 6406#if FFECOM_targetCURRENT == FFECOM_targetFFE 6407 6408#if FFECOM_ONEPASS 6409 ffeste_V020_item (expr); 6410#else 6411 { 6412 ffestdExprItem_ item 6413 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 6414 sizeof (*item)); 6415 6416 item->next = NULL; 6417 item->expr = expr; 6418 *ffestd_expr_list_ = item; 6419 ffestd_expr_list_ = &item->next; 6420 } 6421#endif 6422 6423#endif 6424#if FFECOM_targetCURRENT == FFECOM_targetGCC 6425#endif 6426} 6427 6428/* ffestd_V020_finish -- TYPE statement list complete 6429 6430 ffestd_V020_finish(); 6431 6432 Just wrap up any local activities. */ 6433 6434void 6435ffestd_V020_finish () 6436{ 6437 ffestd_check_finish_ (); 6438 6439#if FFECOM_targetCURRENT == FFECOM_targetFFE 6440 6441#if FFECOM_ONEPASS 6442 ffeste_V020_finish (); 6443#else 6444 /* Nothing to do, it's implicit. */ 6445#endif 6446 6447#endif 6448#if FFECOM_targetCURRENT == FFECOM_targetGCC 6449#endif 6450} 6451 6452/* ffestd_V021 -- DELETE statement 6453 6454 ffestd_V021(); 6455 6456 Make sure a DELETE is valid in the current context, and implement it. */ 6457 6458#if FFESTR_VXT 6459void 6460ffestd_V021 () 6461{ 6462 ffestd_check_simple_ (); 6463 6464#if FFECOM_targetCURRENT == FFECOM_targetFFE 6465 6466#if FFECOM_ONEPASS 6467 ffestd_subr_line_now_ (); 6468 ffeste_V021 (&ffestp_file.delete); 6469#else 6470 { 6471 ffestdStmt_ stmt; 6472 6473 stmt = ffestd_stmt_new_ (FFESTD_stmtidV021_); 6474 ffestd_stmt_append_ (stmt); 6475 ffestd_subr_line_save_ (stmt); 6476 stmt->u.V021.pool = ffesta_output_pool; 6477 stmt->u.V021.params = ffestd_subr_copy_delete_ (); 6478 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6479 } 6480#endif 6481 6482#endif 6483#if FFECOM_targetCURRENT == FFECOM_targetGCC 6484 ffestd_subr_vxt_ (); 6485#endif 6486} 6487 6488/* ffestd_V022 -- UNLOCK statement 6489 6490 ffestd_V022(); 6491 6492 Make sure a UNLOCK is valid in the current context, and implement it. */ 6493 6494void 6495ffestd_V022 () 6496{ 6497 ffestd_check_simple_ (); 6498 6499#if FFECOM_targetCURRENT == FFECOM_targetFFE 6500 6501#if FFECOM_ONEPASS 6502 ffestd_subr_line_now_ (); 6503 ffeste_V022 (&ffestp_file.beru); 6504#else 6505 { 6506 ffestdStmt_ stmt; 6507 6508 stmt = ffestd_stmt_new_ (FFESTD_stmtidV022_); 6509 ffestd_stmt_append_ (stmt); 6510 ffestd_subr_line_save_ (stmt); 6511 stmt->u.V022.pool = ffesta_output_pool; 6512 stmt->u.V022.params = ffestd_subr_copy_beru_ (); 6513 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6514 } 6515#endif 6516 6517#endif 6518#if FFECOM_targetCURRENT == FFECOM_targetGCC 6519 ffestd_subr_vxt_ (); 6520#endif 6521} 6522 6523/* ffestd_V023_start -- ENCODE(...) statement list begin 6524 6525 ffestd_V023_start(); 6526 6527 Verify that ENCODE is valid here, and begin accepting items in the 6528 list. */ 6529 6530void 6531ffestd_V023_start () 6532{ 6533 ffestd_check_start_ (); 6534 6535#if FFECOM_targetCURRENT == FFECOM_targetFFE 6536 6537#if FFECOM_ONEPASS 6538 ffestd_subr_line_now_ (); 6539 ffeste_V023_start (&ffestp_file.vxtcode); 6540#else 6541 { 6542 ffestdStmt_ stmt; 6543 6544 stmt = ffestd_stmt_new_ (FFESTD_stmtidV023_); 6545 ffestd_stmt_append_ (stmt); 6546 ffestd_subr_line_save_ (stmt); 6547 stmt->u.V023.pool = ffesta_output_pool; 6548 stmt->u.V023.params = ffestd_subr_copy_vxtcode_ (); 6549 stmt->u.V023.list = NULL; 6550 ffestd_expr_list_ = &stmt->u.V023.list; 6551 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6552 } 6553#endif 6554 6555#endif 6556#if FFECOM_targetCURRENT == FFECOM_targetGCC 6557 ffestd_subr_vxt_ (); 6558#endif 6559} 6560 6561/* ffestd_V023_item -- ENCODE statement i/o item 6562 6563 ffestd_V023_item(expr,expr_token); 6564 6565 Implement output-list expression. */ 6566 6567void 6568ffestd_V023_item (ffebld expr) 6569{ 6570 ffestd_check_item_ (); 6571 6572#if FFECOM_targetCURRENT == FFECOM_targetFFE 6573 6574#if FFECOM_ONEPASS 6575 ffeste_V023_item (expr); 6576#else 6577 { 6578 ffestdExprItem_ item 6579 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 6580 sizeof (*item)); 6581 6582 item->next = NULL; 6583 item->expr = expr; 6584 *ffestd_expr_list_ = item; 6585 ffestd_expr_list_ = &item->next; 6586 } 6587#endif 6588 6589#endif 6590#if FFECOM_targetCURRENT == FFECOM_targetGCC 6591#endif 6592} 6593 6594/* ffestd_V023_finish -- ENCODE statement list complete 6595 6596 ffestd_V023_finish(); 6597 6598 Just wrap up any local activities. */ 6599 6600void 6601ffestd_V023_finish () 6602{ 6603 ffestd_check_finish_ (); 6604 6605#if FFECOM_targetCURRENT == FFECOM_targetFFE 6606 6607#if FFECOM_ONEPASS 6608 ffeste_V023_finish (); 6609#else 6610 /* Nothing to do, it's implicit. */ 6611#endif 6612 6613#endif 6614#if FFECOM_targetCURRENT == FFECOM_targetGCC 6615#endif 6616} 6617 6618/* ffestd_V024_start -- DECODE(...) statement list begin 6619 6620 ffestd_V024_start(); 6621 6622 Verify that DECODE is valid here, and begin accepting items in the 6623 list. */ 6624 6625void 6626ffestd_V024_start () 6627{ 6628 ffestd_check_start_ (); 6629 6630#if FFECOM_targetCURRENT == FFECOM_targetFFE 6631 6632#if FFECOM_ONEPASS 6633 ffestd_subr_line_now_ (); 6634 ffeste_V024_start (&ffestp_file.vxtcode); 6635#else 6636 { 6637 ffestdStmt_ stmt; 6638 6639 stmt = ffestd_stmt_new_ (FFESTD_stmtidV024_); 6640 ffestd_stmt_append_ (stmt); 6641 ffestd_subr_line_save_ (stmt); 6642 stmt->u.V024.pool = ffesta_output_pool; 6643 stmt->u.V024.params = ffestd_subr_copy_vxtcode_ (); 6644 stmt->u.V024.list = NULL; 6645 ffestd_expr_list_ = &stmt->u.V024.list; 6646 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6647 } 6648#endif 6649 6650#endif 6651#if FFECOM_targetCURRENT == FFECOM_targetGCC 6652 ffestd_subr_vxt_ (); 6653#endif 6654} 6655 6656/* ffestd_V024_item -- DECODE statement i/o item 6657 6658 ffestd_V024_item(expr,expr_token); 6659 6660 Implement output-list expression. */ 6661 6662void 6663ffestd_V024_item (ffebld expr) 6664{ 6665 ffestd_check_item_ (); 6666 6667#if FFECOM_targetCURRENT == FFECOM_targetFFE 6668 6669#if FFECOM_ONEPASS 6670 ffeste_V024_item (expr); 6671#else 6672 { 6673 ffestdExprItem_ item 6674 = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", 6675 sizeof (*item)); 6676 6677 item->next = NULL; 6678 item->expr = expr; 6679 *ffestd_expr_list_ = item; 6680 ffestd_expr_list_ = &item->next; 6681 } 6682#endif 6683 6684#endif 6685#if FFECOM_targetCURRENT == FFECOM_targetGCC 6686#endif 6687} 6688 6689/* ffestd_V024_finish -- DECODE statement list complete 6690 6691 ffestd_V024_finish(); 6692 6693 Just wrap up any local activities. */ 6694 6695void 6696ffestd_V024_finish () 6697{ 6698 ffestd_check_finish_ (); 6699 6700#if FFECOM_targetCURRENT == FFECOM_targetFFE 6701 6702#if FFECOM_ONEPASS 6703 ffeste_V024_finish (); 6704#else 6705 /* Nothing to do, it's implicit. */ 6706#endif 6707 6708#endif 6709#if FFECOM_targetCURRENT == FFECOM_targetGCC 6710#endif 6711} 6712 6713/* ffestd_V025_start -- DEFINEFILE statement list begin 6714 6715 ffestd_V025_start(); 6716 6717 Verify that DEFINEFILE is valid here, and begin accepting items in the 6718 list. */ 6719 6720void 6721ffestd_V025_start () 6722{ 6723 ffestd_check_start_ (); 6724 6725#if FFECOM_targetCURRENT == FFECOM_targetFFE 6726 6727#if FFECOM_ONEPASS 6728 ffestd_subr_line_now_ (); 6729 ffeste_V025_start (); 6730#else 6731 { 6732 ffestdStmt_ stmt; 6733 6734 stmt = ffestd_stmt_new_ (FFESTD_stmtidV025start_); 6735 ffestd_stmt_append_ (stmt); 6736 ffestd_subr_line_save_ (stmt); 6737 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6738 } 6739#endif 6740 6741#endif 6742#if FFECOM_targetCURRENT == FFECOM_targetGCC 6743 ffestd_subr_vxt_ (); 6744#endif 6745} 6746 6747/* ffestd_V025_item -- DEFINE FILE statement item 6748 6749 ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt); 6750 6751 Implement item. Treat each item kind of like a separate statement, 6752 since there's really no need to treat them as an aggregate. */ 6753 6754void 6755ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv) 6756{ 6757 ffestd_check_item_ (); 6758 6759#if FFECOM_targetCURRENT == FFECOM_targetFFE 6760 6761#if FFECOM_ONEPASS 6762 ffeste_V025_item (u, m, n, asv); 6763#else 6764 { 6765 ffestdStmt_ stmt; 6766 6767 stmt = ffestd_stmt_new_ (FFESTD_stmtidV025item_); 6768 ffestd_stmt_append_ (stmt); 6769 stmt->u.V025item.u = u; 6770 stmt->u.V025item.m = m; 6771 stmt->u.V025item.n = n; 6772 stmt->u.V025item.asv = asv; 6773 } 6774#endif 6775 6776#endif 6777#if FFECOM_targetCURRENT == FFECOM_targetGCC 6778#endif 6779} 6780 6781/* ffestd_V025_finish -- DEFINE FILE statement list complete 6782 6783 ffestd_V025_finish(); 6784 6785 Just wrap up any local activities. */ 6786 6787void 6788ffestd_V025_finish () 6789{ 6790 ffestd_check_finish_ (); 6791 6792#if FFECOM_targetCURRENT == FFECOM_targetFFE 6793 6794#if FFECOM_ONEPASS 6795 ffeste_V025_finish (); 6796#else 6797 { 6798 ffestdStmt_ stmt; 6799 6800 stmt = ffestd_stmt_new_ (FFESTD_stmtidV025finish_); 6801 stmt->u.V025finish.pool = ffesta_output_pool; 6802 ffestd_stmt_append_ (stmt); 6803 } 6804#endif 6805 6806#endif 6807#if FFECOM_targetCURRENT == FFECOM_targetGCC 6808#endif 6809} 6810 6811/* ffestd_V026 -- FIND statement 6812 6813 ffestd_V026(); 6814 6815 Make sure a FIND is valid in the current context, and implement it. */ 6816 6817void 6818ffestd_V026 () 6819{ 6820 ffestd_check_simple_ (); 6821 6822#if FFECOM_targetCURRENT == FFECOM_targetFFE 6823 6824#if FFECOM_ONEPASS 6825 ffestd_subr_line_now_ (); 6826 ffeste_V026 (&ffestp_file.find); 6827#else 6828 { 6829 ffestdStmt_ stmt; 6830 6831 stmt = ffestd_stmt_new_ (FFESTD_stmtidV026_); 6832 ffestd_stmt_append_ (stmt); 6833 ffestd_subr_line_save_ (stmt); 6834 stmt->u.V026.pool = ffesta_output_pool; 6835 stmt->u.V026.params = ffestd_subr_copy_find_ (); 6836 ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); 6837 } 6838#endif 6839 6840#endif 6841#if FFECOM_targetCURRENT == FFECOM_targetGCC 6842 ffestd_subr_vxt_ (); 6843#endif 6844} 6845 6846#endif 6847/* ffestd_V027_start -- VXT PARAMETER statement list begin 6848 6849 ffestd_V027_start(); 6850 6851 Verify that PARAMETER is valid here, and begin accepting items in the list. */ 6852 6853void 6854ffestd_V027_start () 6855{ 6856 ffestd_check_start_ (); 6857 6858#if FFECOM_targetCURRENT == FFECOM_targetFFE 6859 fputs ("* PARAMETER_vxt ", dmpout); 6860#else 6861#if FFECOM_targetCURRENT == FFECOM_targetGCC 6862 ffestd_subr_vxt_ (); 6863#endif 6864#endif 6865} 6866 6867/* ffestd_V027_item -- VXT PARAMETER statement assignment 6868 6869 ffestd_V027_item(dest,dest_token,source,source_token); 6870 6871 Make sure the source is a valid source for the destination; make the 6872 assignment. */ 6873 6874void 6875ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED) 6876{ 6877 ffestd_check_item_ (); 6878 6879#if FFECOM_targetCURRENT == FFECOM_targetFFE 6880 fputs (ffelex_token_text (dest_token), dmpout); 6881 fputc ('=', dmpout); 6882 ffebld_dump (source); 6883 fputc (',', dmpout); 6884#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6885#else 6886#error 6887#endif 6888} 6889 6890/* ffestd_V027_finish -- VXT PARAMETER statement list complete 6891 6892 ffestd_V027_finish(); 6893 6894 Just wrap up any local activities. */ 6895 6896void 6897ffestd_V027_finish () 6898{ 6899 ffestd_check_finish_ (); 6900 6901#if FFECOM_targetCURRENT == FFECOM_targetFFE 6902 fputc ('\n', dmpout); 6903#elif FFECOM_targetCURRENT == FFECOM_targetGCC 6904#else 6905#error 6906#endif 6907} 6908 6909/* Any executable statement. */ 6910 6911void 6912ffestd_any () 6913{ 6914 ffestd_check_simple_ (); 6915 6916#if FFECOM_ONEPASS 6917 ffestd_subr_line_now_ (); 6918 ffeste_R841 (); 6919#else 6920 { 6921 ffestdStmt_ stmt; 6922 6923 stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_); 6924 ffestd_stmt_append_ (stmt); 6925 ffestd_subr_line_save_ (stmt); 6926 } 6927#endif 6928} 6929