1/* ste.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 ste.c 24 25 Description: 26 Implements the various statements and such like. 27 28 Modifications: 29*/ 30 31/* Include files. */ 32 33#include "proj.h" 34 35#if FFECOM_targetCURRENT == FFECOM_targetGCC 36#include "rtl.j" 37#include "toplev.j" 38#endif 39 40#include "ste.h" 41#include "bld.h" 42#include "com.h" 43#include "expr.h" 44#include "lab.h" 45#include "lex.h" 46#include "sta.h" 47#include "stp.h" 48#include "str.h" 49#include "sts.h" 50#include "stt.h" 51#include "stv.h" 52#include "stw.h" 53#include "symbol.h" 54 55/* Externals defined here. */ 56 57 58/* Simple definitions and enumerations. */ 59 60typedef enum 61 { 62 FFESTE_stateletSIMPLE_, /* Expecting simple/start. */ 63 FFESTE_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ 64 FFESTE_stateletITEM_, /* Expecting item/itemstart/finish. */ 65 FFESTE_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ 66 FFESTE_ 67 } ffesteStatelet_; 68 69/* Internal typedefs. */ 70 71 72/* Private include files. */ 73 74 75/* Internal structure definitions. */ 76 77 78/* Static objects accessed by functions in this module. */ 79 80static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_; 81#if FFECOM_targetCURRENT == FFECOM_targetGCC 82static ffelab ffeste_label_formatdef_ = NULL; 83static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */ 84static ffecomGfrt ffeste_io_endgfrt_; /* end function to call. */ 85static tree ffeste_io_abort_; /* abort-io label or NULL_TREE. */ 86static bool ffeste_io_abort_is_temp_; /* abort-io label is a temp. */ 87static tree ffeste_io_end_; /* END= label or NULL_TREE. */ 88static tree ffeste_io_err_; /* ERR= label or NULL_TREE. */ 89static tree ffeste_io_iostat_; /* IOSTAT= var or NULL_TREE. */ 90static bool ffeste_io_iostat_is_temp_; /* IOSTAT= var is a temp. */ 91#endif 92 93/* Static functions (internal). */ 94 95#if FFECOM_targetCURRENT == FFECOM_targetGCC 96static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr, 97 tree *xitersvar, ffebld var, 98 ffebld start, ffelexToken start_token, 99 ffebld end, ffelexToken end_token, 100 ffebld incr, ffelexToken incr_token, 101 const char *msg); 102static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, 103 tree itersvar); 104static void ffeste_io_call_ (tree call, bool do_check); 105static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token); 106static tree ffeste_io_dofio_ (ffebld expr); 107static tree ffeste_io_dolio_ (ffebld expr); 108static tree ffeste_io_douio_ (ffebld expr); 109static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit, 110 ffebld unit_expr, int unit_dflt); 111static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit, 112 ffebld unit_expr, int unit_dflt, 113 bool have_end, ffestvFormat format, 114 ffestpFile *format_spec, bool rec, 115 ffebld rec_expr); 116static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr, 117 ffestpFile *stat_spec); 118static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr, 119 bool have_end, ffestvFormat format, 120 ffestpFile *format_spec); 121static tree ffeste_io_inlist_ (bool have_err, 122 ffestpFile *unit_spec, 123 ffestpFile *file_spec, 124 ffestpFile *exist_spec, 125 ffestpFile *open_spec, 126 ffestpFile *number_spec, 127 ffestpFile *named_spec, 128 ffestpFile *name_spec, 129 ffestpFile *access_spec, 130 ffestpFile *sequential_spec, 131 ffestpFile *direct_spec, 132 ffestpFile *form_spec, 133 ffestpFile *formatted_spec, 134 ffestpFile *unformatted_spec, 135 ffestpFile *recl_spec, 136 ffestpFile *nextrec_spec, 137 ffestpFile *blank_spec); 138static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr, 139 ffestpFile *file_spec, 140 ffestpFile *stat_spec, 141 ffestpFile *access_spec, 142 ffestpFile *form_spec, 143 ffestpFile *recl_spec, 144 ffestpFile *blank_spec); 145static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt); 146#elif FFECOM_targetCURRENT == FFECOM_targetFFE 147static void ffeste_subr_file_ (const char *kw, ffestpFile *spec); 148#else 149#error 150#endif 151 152/* Internal macros. */ 153 154#if FFECOM_targetCURRENT == FFECOM_targetGCC 155#define ffeste_emit_line_note_() \ 156 emit_line_note (input_filename, lineno) 157#endif 158#define ffeste_check_simple_() \ 159 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_) 160#define ffeste_check_start_() \ 161 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \ 162 ffeste_statelet_ = FFESTE_stateletATTRIB_ 163#define ffeste_check_attrib_() \ 164 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_) 165#define ffeste_check_item_() \ 166 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \ 167 || ffeste_statelet_ == FFESTE_stateletITEM_); \ 168 ffeste_statelet_ = FFESTE_stateletITEM_ 169#define ffeste_check_item_startvals_() \ 170 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \ 171 || ffeste_statelet_ == FFESTE_stateletITEM_); \ 172 ffeste_statelet_ = FFESTE_stateletITEMVALS_ 173#define ffeste_check_item_value_() \ 174 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_) 175#define ffeste_check_item_endvals_() \ 176 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \ 177 ffeste_statelet_ = FFESTE_stateletITEM_ 178#define ffeste_check_finish_() \ 179 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \ 180 || ffeste_statelet_ == FFESTE_stateletITEM_); \ 181 ffeste_statelet_ = FFESTE_stateletSIMPLE_ 182 183#define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \ 184 do \ 185 { \ 186 if ((Spec)->kw_or_val_present) \ 187 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \ 188 else \ 189 Exp = null_pointer_node; \ 190 if (Exp) \ 191 Init = Exp; \ 192 else \ 193 { \ 194 Init = null_pointer_node; \ 195 constantp = FALSE; \ 196 } \ 197 } while(0) 198 199#define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \ 200 do \ 201 { \ 202 if ((Spec)->kw_or_val_present) \ 203 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \ 204 else \ 205 { \ 206 Exp = null_pointer_node; \ 207 Lenexp = ffecom_f2c_ftnlen_zero_node; \ 208 } \ 209 if (Exp) \ 210 Init = Exp; \ 211 else \ 212 { \ 213 Init = null_pointer_node; \ 214 constantp = FALSE; \ 215 } \ 216 if (Lenexp) \ 217 Leninit = Lenexp; \ 218 else \ 219 { \ 220 Leninit = ffecom_f2c_ftnlen_zero_node; \ 221 constantp = FALSE; \ 222 } \ 223 } while(0) 224 225#define ffeste_f2c_init_flag_(Flag,Init) \ 226 do \ 227 { \ 228 Init = convert (ffecom_f2c_flag_type_node, \ 229 (Flag) ? integer_one_node : integer_zero_node); \ 230 } while(0) 231 232#define ffeste_f2c_init_format_(Exp,Init,Spec) \ 233 do \ 234 { \ 235 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \ 236 if (Exp) \ 237 Init = Exp; \ 238 else \ 239 { \ 240 Init = null_pointer_node; \ 241 constantp = FALSE; \ 242 } \ 243 } while(0) 244 245#define ffeste_f2c_init_int_(Exp,Init,Spec) \ 246 do \ 247 { \ 248 if ((Spec)->kw_or_val_present) \ 249 Exp = ffecom_const_expr ((Spec)->u.expr); \ 250 else \ 251 Exp = ffecom_integer_zero_node; \ 252 if (Exp) \ 253 Init = Exp; \ 254 else \ 255 { \ 256 Init = ffecom_integer_zero_node; \ 257 constantp = FALSE; \ 258 } \ 259 } while(0) 260 261#define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \ 262 do \ 263 { \ 264 if ((Spec)->kw_or_val_present) \ 265 Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \ 266 else \ 267 Exp = null_pointer_node; \ 268 if (Exp) \ 269 Init = Exp; \ 270 else \ 271 { \ 272 Init = null_pointer_node; \ 273 constantp = FALSE; \ 274 } \ 275 } while(0) 276 277#define ffeste_f2c_init_next_(Init) \ 278 do \ 279 { \ 280 TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \ 281 (Init)); \ 282 initn = TREE_CHAIN(initn); \ 283 } while(0) 284 285#define ffeste_f2c_prepare_charnolen_(Spec,Exp) \ 286 do \ 287 { \ 288 if (! (Exp)) \ 289 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ 290 } while(0) 291 292#define ffeste_f2c_prepare_char_(Spec,Exp) \ 293 do \ 294 { \ 295 if (! (Exp)) \ 296 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ 297 } while(0) 298 299#define ffeste_f2c_prepare_format_(Spec,Exp) \ 300 do \ 301 { \ 302 if (! (Exp)) \ 303 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ 304 } while(0) 305 306#define ffeste_f2c_prepare_int_(Spec,Exp) \ 307 do \ 308 { \ 309 if (! (Exp)) \ 310 ffecom_prepare_expr ((Spec)->u.expr); \ 311 } while(0) 312 313#define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \ 314 do \ 315 { \ 316 if (! (Exp)) \ 317 ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \ 318 } while(0) 319 320#define ffeste_f2c_compile_(Field,Exp) \ 321 do \ 322 { \ 323 tree exz; \ 324 if ((Exp)) \ 325 { \ 326 exz = ffecom_modify (void_type_node, \ 327 ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \ 328 t, (Field)), \ 329 (Exp)); \ 330 expand_expr_stmt (exz); \ 331 } \ 332 } while(0) 333 334#define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \ 335 do \ 336 { \ 337 tree exq; \ 338 if (! (Exp)) \ 339 { \ 340 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \ 341 ffeste_f2c_compile_ ((Field), exq); \ 342 } \ 343 } while(0) 344 345#define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \ 346 do \ 347 { \ 348 tree exq = (Exp); \ 349 tree lenexq = (Lenexp); \ 350 int need_exq = (! exq); \ 351 int need_lenexq = (! lenexq); \ 352 if (need_exq || need_lenexq) \ 353 { \ 354 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \ 355 if (need_exq) \ 356 ffeste_f2c_compile_ ((Field), exq); \ 357 if (need_lenexq) \ 358 ffeste_f2c_compile_ ((Lenfield), lenexq); \ 359 } \ 360 } while(0) 361 362#define ffeste_f2c_compile_format_(Field,Spec,Exp) \ 363 do \ 364 { \ 365 tree exq; \ 366 if (! (Exp)) \ 367 { \ 368 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \ 369 ffeste_f2c_compile_ ((Field), exq); \ 370 } \ 371 } while(0) 372 373#define ffeste_f2c_compile_int_(Field,Spec,Exp) \ 374 do \ 375 { \ 376 tree exq; \ 377 if (! (Exp)) \ 378 { \ 379 exq = ffecom_expr ((Spec)->u.expr); \ 380 ffeste_f2c_compile_ ((Field), exq); \ 381 } \ 382 } while(0) 383 384#define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \ 385 do \ 386 { \ 387 tree exq; \ 388 if (! (Exp)) \ 389 { \ 390 exq = ffecom_ptr_to_expr ((Spec)->u.expr); \ 391 ffeste_f2c_compile_ ((Field), exq); \ 392 } \ 393 } while(0) 394 395/* Start a Fortran block. */ 396 397#ifdef ENABLE_CHECKING 398 399typedef struct gbe_block 400{ 401 struct gbe_block *outer; 402 ffestw block; 403 int lineno; 404 char *input_filename; 405 bool is_stmt; 406} *gbe_block; 407 408gbe_block ffeste_top_block_ = NULL; 409 410static void 411ffeste_start_block_ (ffestw block) 412{ 413 gbe_block b = xmalloc (sizeof (*b)); 414 415 b->outer = ffeste_top_block_; 416 b->block = block; 417 b->lineno = lineno; 418 b->input_filename = input_filename; 419 b->is_stmt = FALSE; 420 421 ffeste_top_block_ = b; 422 423 ffecom_start_compstmt (); 424} 425 426/* End a Fortran block. */ 427 428static void 429ffeste_end_block_ (ffestw block) 430{ 431 gbe_block b = ffeste_top_block_; 432 433 assert (b); 434 assert (! b->is_stmt); 435 assert (b->block == block); 436 assert (! b->is_stmt); 437 438 ffeste_top_block_ = b->outer; 439 440 free (b); 441 442 clear_momentary (); 443 444 ffecom_end_compstmt (); 445} 446 447/* Start a Fortran statement. 448 449 Starts a back-end block, so temporaries can be managed, clean-ups 450 properly handled, etc. Nesting of statements *is* allowed -- the 451 handling of I/O items, even implied-DO I/O lists, within a READ, 452 PRINT, or WRITE statement is one example. */ 453 454static void 455ffeste_start_stmt_(void) 456{ 457 gbe_block b = xmalloc (sizeof (*b)); 458 459 b->outer = ffeste_top_block_; 460 b->block = NULL; 461 b->lineno = lineno; 462 b->input_filename = input_filename; 463 b->is_stmt = TRUE; 464 465 ffeste_top_block_ = b; 466 467 ffecom_start_compstmt (); 468} 469 470/* End a Fortran statement. */ 471 472static void 473ffeste_end_stmt_(void) 474{ 475 gbe_block b = ffeste_top_block_; 476 477 assert (b); 478 assert (b->is_stmt); 479 480 ffeste_top_block_ = b->outer; 481 482 free (b); 483 484 clear_momentary (); 485 486 ffecom_end_compstmt (); 487} 488 489#else /* ! defined (ENABLE_CHECKING) */ 490 491#define ffeste_start_block_(b) ffecom_start_compstmt () 492#define ffeste_end_block_(b) \ 493 do \ 494 { \ 495 clear_momentary (); \ 496 ffecom_end_compstmt (); \ 497 } while(0) 498#define ffeste_start_stmt_() ffeste_start_block_(NULL) 499#define ffeste_end_stmt_() ffeste_end_block_(NULL) 500 501#endif /* ! defined (ENABLE_CHECKING) */ 502 503/* Begin an iterative DO loop. Pass the block to start if applicable. 504 505 NOTE: Does _two_ push_momentary () calls, which the caller must 506 undo (by calling ffeste_end_iterdo_). */ 507 508#if FFECOM_targetCURRENT == FFECOM_targetGCC 509static void 510ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, 511 tree *xitersvar, ffebld var, 512 ffebld start, ffelexToken start_token, 513 ffebld end, ffelexToken end_token, 514 ffebld incr, ffelexToken incr_token, 515 const char *msg) 516{ 517 tree tvar; 518 tree expr; 519 tree tstart; 520 tree tend; 521 tree tincr; 522 tree tincr_saved; 523 tree niters; 524 struct nesting *expanded_loop; 525 526 /* Want to have tvar, tincr, and niters for the whole loop body. */ 527 528 if (block) 529 ffeste_start_block_ (block); 530 else 531 ffeste_start_stmt_ (); 532 533 niters = ffecom_make_tempvar (block ? "do" : "impdo", 534 ffecom_integer_type_node, 535 FFETARGET_charactersizeNONE, -1); 536 537 ffecom_prepare_expr (incr); 538 ffecom_prepare_expr_rw (NULL_TREE, var); 539 540 ffecom_prepare_end (); 541 542 tvar = ffecom_expr_rw (NULL_TREE, var); 543 tincr = ffecom_expr (incr); 544 545 if (TREE_CODE (tvar) == ERROR_MARK 546 || TREE_CODE (tincr) == ERROR_MARK) 547 { 548 if (block) 549 { 550 ffeste_end_block_ (block); 551 ffestw_set_do_tvar (block, error_mark_node); 552 } 553 else 554 { 555 ffeste_end_stmt_ (); 556 *xtvar = error_mark_node; 557 } 558 return; 559 } 560 561 /* Check whether incr is known to be zero, complain and fix. */ 562 563 if (integer_zerop (tincr) || real_zerop (tincr)) 564 { 565 ffebad_start (FFEBAD_DO_STEP_ZERO); 566 ffebad_here (0, ffelex_token_where_line (incr_token), 567 ffelex_token_where_column (incr_token)); 568 ffebad_string (msg); 569 ffebad_finish (); 570 tincr = convert (TREE_TYPE (tvar), integer_one_node); 571 } 572 573 tincr_saved = ffecom_save_tree (tincr); 574 575 preserve_momentary (); 576 577 /* Want to have tstart, tend for just this statement. */ 578 579 ffeste_start_stmt_ (); 580 581 ffecom_prepare_expr (start); 582 ffecom_prepare_expr (end); 583 584 ffecom_prepare_end (); 585 586 tstart = ffecom_expr (start); 587 tend = ffecom_expr (end); 588 589 if (TREE_CODE (tstart) == ERROR_MARK 590 || TREE_CODE (tend) == ERROR_MARK) 591 { 592 ffeste_end_stmt_ (); 593 594 if (block) 595 { 596 ffeste_end_block_ (block); 597 ffestw_set_do_tvar (block, error_mark_node); 598 } 599 else 600 { 601 ffeste_end_stmt_ (); 602 *xtvar = error_mark_node; 603 } 604 return; 605 } 606 607 /* For warnings only, nothing else happens here. */ 608 { 609 tree try; 610 611 if (! ffe_is_onetrip ()) 612 { 613 try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar), 614 tend, 615 tstart); 616 617 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar), 618 try, 619 tincr); 620 621 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE) 622 try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try, 623 tincr); 624 else 625 try = convert (integer_type_node, 626 ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar), 627 try, 628 tincr)); 629 630 /* Warn if loop never executed, since we've done the evaluation 631 of the unofficial iteration count already. */ 632 633 try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node, 634 try, 635 convert (TREE_TYPE (tvar), 636 integer_zero_node))); 637 638 if (integer_onep (try)) 639 { 640 ffebad_start (FFEBAD_DO_NULL); 641 ffebad_here (0, ffelex_token_where_line (start_token), 642 ffelex_token_where_column (start_token)); 643 ffebad_string (msg); 644 ffebad_finish (); 645 } 646 } 647 648 /* Warn if end plus incr would overflow. */ 649 650 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar), 651 tend, 652 tincr); 653 654 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c') 655 && TREE_CONSTANT_OVERFLOW (try)) 656 { 657 ffebad_start (FFEBAD_DO_END_OVERFLOW); 658 ffebad_here (0, ffelex_token_where_line (end_token), 659 ffelex_token_where_column (end_token)); 660 ffebad_string (msg); 661 ffebad_finish (); 662 } 663 } 664 665 /* Do the initial assignment into the DO var. */ 666 667 tstart = ffecom_save_tree (tstart); 668 669 expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar), 670 tend, 671 tstart); 672 673 if (! ffe_is_onetrip ()) 674 { 675 expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr), 676 expr, 677 convert (TREE_TYPE (expr), tincr_saved)); 678 } 679 680 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE) 681 expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr), 682 expr, 683 tincr_saved); 684 else 685 expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr), 686 expr, 687 tincr_saved); 688 689#if 1 /* New, F90-approved approach: convert to default INTEGER. */ 690 if (TREE_TYPE (tvar) != error_mark_node) 691 expr = convert (ffecom_integer_type_node, expr); 692#else /* Old approach; convert to INTEGER unless that's a narrowing. */ 693 if ((TREE_TYPE (tvar) != error_mark_node) 694 && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE) 695 || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE) 696 && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar))) 697 != INTEGER_CST) 698 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar))) 699 <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node))))))) 700 /* Convert unless promoting INTEGER type of any kind downward to 701 default INTEGER; else leave as, say, INTEGER*8 (long long int). */ 702 expr = convert (ffecom_integer_type_node, expr); 703#endif 704 705 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters)) 706 == TYPE_MAIN_VARIANT (TREE_TYPE (expr))); 707 708 expr = ffecom_modify (void_type_node, niters, expr); 709 expand_expr_stmt (expr); 710 711 expr = ffecom_modify (void_type_node, tvar, tstart); 712 expand_expr_stmt (expr); 713 714 ffeste_end_stmt_ (); 715 716 expanded_loop = expand_start_loop_continue_elsewhere (!! block); 717 if (block) 718 ffestw_set_do_hook (block, expanded_loop); 719 720 if (! ffe_is_onetrip ()) 721 { 722 expr = ffecom_truth_value 723 (ffecom_2 (GE_EXPR, integer_type_node, 724 ffecom_2 (PREDECREMENT_EXPR, 725 TREE_TYPE (niters), 726 niters, 727 convert (TREE_TYPE (niters), 728 ffecom_integer_one_node)), 729 convert (TREE_TYPE (niters), 730 ffecom_integer_zero_node))); 731 732 expand_exit_loop_if_false (0, expr); 733 } 734 735 if (block) 736 { 737 ffestw_set_do_tvar (block, tvar); 738 ffestw_set_do_incr_saved (block, tincr_saved); 739 ffestw_set_do_count_var (block, niters); 740 } 741 else 742 { 743 *xtvar = tvar; 744 *xtincr = tincr_saved; 745 *xitersvar = niters; 746 } 747} 748 749#endif 750 751/* End an iterative DO loop. Pass the same iteration variable and increment 752 value trees that were generated in the paired _begin_ call. */ 753 754#if FFECOM_targetCURRENT == FFECOM_targetGCC 755static void 756ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar) 757{ 758 tree expr; 759 tree niters = itersvar; 760 761 if (tvar == error_mark_node) 762 return; 763 764 expand_loop_continue_here (); 765 766 ffeste_start_stmt_ (); 767 768 if (ffe_is_onetrip ()) 769 { 770 expr = ffecom_truth_value 771 (ffecom_2 (GE_EXPR, integer_type_node, 772 ffecom_2 (PREDECREMENT_EXPR, 773 TREE_TYPE (niters), 774 niters, 775 convert (TREE_TYPE (niters), 776 ffecom_integer_one_node)), 777 convert (TREE_TYPE (niters), 778 ffecom_integer_zero_node))); 779 780 expand_exit_loop_if_false (0, expr); 781 } 782 783 expr = ffecom_modify (void_type_node, tvar, 784 ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar), 785 tvar, 786 tincr)); 787 expand_expr_stmt (expr); 788 789 /* Lose the stuff we just built. */ 790 ffeste_end_stmt_ (); 791 792 expand_end_loop (); 793 794 /* Lose the tvar and incr_saved trees. */ 795 if (block) 796 ffeste_end_block_ (block); 797 else 798 ffeste_end_stmt_ (); 799} 800#endif 801 802/* Generate call to run-time I/O routine. */ 803 804#if FFECOM_targetCURRENT == FFECOM_targetGCC 805static void 806ffeste_io_call_ (tree call, bool do_check) 807{ 808 /* Generate the call and optional assignment into iostat var. */ 809 810 TREE_SIDE_EFFECTS (call) = 1; 811 if (ffeste_io_iostat_ != NULL_TREE) 812 call = ffecom_modify (do_check ? NULL_TREE : void_type_node, 813 ffeste_io_iostat_, call); 814 expand_expr_stmt (call); 815 816 if (! do_check 817 || ffeste_io_abort_ == NULL_TREE 818 || TREE_CODE (ffeste_io_abort_) == ERROR_MARK) 819 return; 820 821 /* Generate optional test. */ 822 823 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0); 824 expand_goto (ffeste_io_abort_); 825 expand_end_cond (); 826} 827#endif 828 829/* Handle implied-DO in I/O list. 830 831 Expands code to start up the DO loop. Then for each item in the 832 DO loop, handles appropriately (possibly including recursively calling 833 itself). Then expands code to end the DO loop. */ 834 835#if FFECOM_targetCURRENT == FFECOM_targetGCC 836static void 837ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token) 838{ 839 ffebld var = ffebld_head (ffebld_right (impdo)); 840 ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo))); 841 ffebld end = ffebld_head (ffebld_trail (ffebld_trail 842 (ffebld_right (impdo)))); 843 ffebld incr = ffebld_head (ffebld_trail (ffebld_trail 844 (ffebld_trail (ffebld_right (impdo))))); 845 ffebld list; 846 ffebld item; 847 tree tvar; 848 tree tincr; 849 tree titervar; 850 851 if (incr == NULL) 852 { 853 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); 854 ffebld_set_info (incr, ffeinfo_new 855 (FFEINFO_basictypeINTEGER, 856 FFEINFO_kindtypeINTEGERDEFAULT, 857 0, 858 FFEINFO_kindENTITY, 859 FFEINFO_whereCONSTANT, 860 FFETARGET_charactersizeNONE)); 861 } 862 863 /* Start the DO loop. */ 864 865 start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token, 866 FFEEXPR_contextLET); 867 end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token, 868 FFEEXPR_contextLET); 869 incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token, 870 FFEEXPR_contextLET); 871 872 ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var, 873 start, impdo_token, 874 end, impdo_token, 875 incr, impdo_token, 876 "Implied DO loop"); 877 878 /* Handle the list of items. */ 879 880 for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list)) 881 { 882 item = ffebld_head (list); 883 if (item == NULL) 884 continue; 885 886 /* Strip parens off items such as in "READ *,(A)". This is really a bug 887 in the user's code, but I've been told lots of code does this. */ 888 while (ffebld_op (item) == FFEBLD_opPAREN) 889 item = ffebld_left (item); 890 891 if (ffebld_op (item) == FFEBLD_opANY) 892 continue; 893 894 if (ffebld_op (item) == FFEBLD_opIMPDO) 895 ffeste_io_impdo_ (item, impdo_token); 896 else 897 { 898 ffeste_start_stmt_ (); 899 900 ffecom_prepare_arg_ptr_to_expr (item); 901 902 ffecom_prepare_end (); 903 904 ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE); 905 906 ffeste_end_stmt_ (); 907 } 908 } 909 910 /* Generate end of implied-do construct. */ 911 912 ffeste_end_iterdo_ (NULL, tvar, tincr, titervar); 913} 914#endif 915 916/* I/O driver for formatted I/O item (do_fio) 917 918 Returns a tree for a CALL_EXPR to the do_fio function, which handles 919 a formatted I/O list item, along with the appropriate arguments for 920 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag 921 for the CALL_EXPR, expand (emit) the expression, emit any assignment 922 of the result to an IOSTAT= variable, and emit any checking of the 923 result for errors. */ 924 925#if FFECOM_targetCURRENT == FFECOM_targetGCC 926static tree 927ffeste_io_dofio_ (ffebld expr) 928{ 929 tree num_elements; 930 tree variable; 931 tree size; 932 tree arglist; 933 ffeinfoBasictype bt; 934 ffeinfoKindtype kt; 935 bool is_complex; 936 937 bt = ffeinfo_basictype (ffebld_info (expr)); 938 kt = ffeinfo_kindtype (ffebld_info (expr)); 939 940 if ((bt == FFEINFO_basictypeANY) 941 || (kt == FFEINFO_kindtypeANY)) 942 return error_mark_node; 943 944 if (bt == FFEINFO_basictypeCOMPLEX) 945 { 946 is_complex = TRUE; 947 bt = FFEINFO_basictypeREAL; 948 } 949 else 950 is_complex = FALSE; 951 952 variable = ffecom_arg_ptr_to_expr (expr, &size); 953 954 if ((variable == error_mark_node) 955 || (size == error_mark_node)) 956 return error_mark_node; 957 958 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */ 959 { /* "(ftnlen) sizeof(type)" */ 960 size = size_binop (CEIL_DIV_EXPR, 961 TYPE_SIZE (ffecom_tree_type[bt][kt]), 962 size_int (TYPE_PRECISION (char_type_node))); 963#if 0 /* Assume that while it is possible that char * is wider than 964 ftnlen, no object in Fortran space can get big enough for its 965 size to be wider than ftnlen. I really hope nobody wastes 966 time debugging a case where it can! */ 967 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) 968 >= TYPE_PRECISION (TREE_TYPE (size))); 969#endif 970 size = convert (ffecom_f2c_ftnlen_type_node, size); 971 } 972 973 if (ffeinfo_rank (ffebld_info (expr)) == 0 974 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE) 975 num_elements 976 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node; 977 else 978 { 979 num_elements = size_binop (CEIL_DIV_EXPR, 980 TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), 981 size); 982 num_elements = size_binop (CEIL_DIV_EXPR, 983 num_elements, 984 size_int (TYPE_PRECISION 985 (char_type_node))); 986 num_elements = convert (ffecom_f2c_ftnlen_type_node, 987 num_elements); 988 } 989 990 num_elements 991 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, 992 num_elements); 993 994 variable = convert (string_type_node, variable); 995 996 arglist = build_tree_list (NULL_TREE, num_elements); 997 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable); 998 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size); 999 1000 return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE); 1001} 1002 1003#endif 1004/* I/O driver for list-directed I/O item (do_lio) 1005 1006 Returns a tree for a CALL_EXPR to the do_lio function, which handles 1007 a list-directed I/O list item, along with the appropriate arguments for 1008 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag 1009 for the CALL_EXPR, expand (emit) the expression, emit any assignment 1010 of the result to an IOSTAT= variable, and emit any checking of the 1011 result for errors. */ 1012 1013#if FFECOM_targetCURRENT == FFECOM_targetGCC 1014static tree 1015ffeste_io_dolio_ (ffebld expr) 1016{ 1017 tree type_id; 1018 tree num_elements; 1019 tree variable; 1020 tree size; 1021 tree arglist; 1022 ffeinfoBasictype bt; 1023 ffeinfoKindtype kt; 1024 int tc; 1025 1026 bt = ffeinfo_basictype (ffebld_info (expr)); 1027 kt = ffeinfo_kindtype (ffebld_info (expr)); 1028 1029 if ((bt == FFEINFO_basictypeANY) 1030 || (kt == FFEINFO_kindtypeANY)) 1031 return error_mark_node; 1032 1033 tc = ffecom_f2c_typecode (bt, kt); 1034 assert (tc != -1); 1035 type_id = build_int_2 (tc, 0); 1036 1037 type_id 1038 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node, 1039 convert (ffecom_f2c_ftnint_type_node, 1040 type_id)); 1041 1042 variable = ffecom_arg_ptr_to_expr (expr, &size); 1043 1044 if ((type_id == error_mark_node) 1045 || (variable == error_mark_node) 1046 || (size == error_mark_node)) 1047 return error_mark_node; 1048 1049 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */ 1050 { /* "(ftnlen) sizeof(type)" */ 1051 size = size_binop (CEIL_DIV_EXPR, 1052 TYPE_SIZE (ffecom_tree_type[bt][kt]), 1053 size_int (TYPE_PRECISION (char_type_node))); 1054#if 0 /* Assume that while it is possible that char * is wider than 1055 ftnlen, no object in Fortran space can get big enough for its 1056 size to be wider than ftnlen. I really hope nobody wastes 1057 time debugging a case where it can! */ 1058 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) 1059 >= TYPE_PRECISION (TREE_TYPE (size))); 1060#endif 1061 size = convert (ffecom_f2c_ftnlen_type_node, size); 1062 } 1063 1064 if (ffeinfo_rank (ffebld_info (expr)) == 0 1065 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE) 1066 num_elements = ffecom_integer_one_node; 1067 else 1068 { 1069 num_elements = size_binop (CEIL_DIV_EXPR, 1070 TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), 1071 size); 1072 num_elements = size_binop (CEIL_DIV_EXPR, 1073 num_elements, 1074 size_int (TYPE_PRECISION 1075 (char_type_node))); 1076 num_elements = convert (ffecom_f2c_ftnlen_type_node, 1077 num_elements); 1078 } 1079 1080 num_elements 1081 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, 1082 num_elements); 1083 1084 variable = convert (string_type_node, variable); 1085 1086 arglist = build_tree_list (NULL_TREE, type_id); 1087 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements); 1088 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable); 1089 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist))) 1090 = build_tree_list (NULL_TREE, size); 1091 1092 return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE); 1093} 1094 1095#endif 1096/* I/O driver for unformatted I/O item (do_uio) 1097 1098 Returns a tree for a CALL_EXPR to the do_uio function, which handles 1099 an unformatted I/O list item, along with the appropriate arguments for 1100 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag 1101 for the CALL_EXPR, expand (emit) the expression, emit any assignment 1102 of the result to an IOSTAT= variable, and emit any checking of the 1103 result for errors. */ 1104 1105#if FFECOM_targetCURRENT == FFECOM_targetGCC 1106static tree 1107ffeste_io_douio_ (ffebld expr) 1108{ 1109 tree num_elements; 1110 tree variable; 1111 tree size; 1112 tree arglist; 1113 ffeinfoBasictype bt; 1114 ffeinfoKindtype kt; 1115 bool is_complex; 1116 1117 bt = ffeinfo_basictype (ffebld_info (expr)); 1118 kt = ffeinfo_kindtype (ffebld_info (expr)); 1119 1120 if ((bt == FFEINFO_basictypeANY) 1121 || (kt == FFEINFO_kindtypeANY)) 1122 return error_mark_node; 1123 1124 if (bt == FFEINFO_basictypeCOMPLEX) 1125 { 1126 is_complex = TRUE; 1127 bt = FFEINFO_basictypeREAL; 1128 } 1129 else 1130 is_complex = FALSE; 1131 1132 variable = ffecom_arg_ptr_to_expr (expr, &size); 1133 1134 if ((variable == error_mark_node) 1135 || (size == error_mark_node)) 1136 return error_mark_node; 1137 1138 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */ 1139 { /* "(ftnlen) sizeof(type)" */ 1140 size = size_binop (CEIL_DIV_EXPR, 1141 TYPE_SIZE (ffecom_tree_type[bt][kt]), 1142 size_int (TYPE_PRECISION (char_type_node))); 1143#if 0 /* Assume that while it is possible that char * is wider than 1144 ftnlen, no object in Fortran space can get big enough for its 1145 size to be wider than ftnlen. I really hope nobody wastes 1146 time debugging a case where it can! */ 1147 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) 1148 >= TYPE_PRECISION (TREE_TYPE (size))); 1149#endif 1150 size = convert (ffecom_f2c_ftnlen_type_node, size); 1151 } 1152 1153 if (ffeinfo_rank (ffebld_info (expr)) == 0 1154 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE) 1155 num_elements 1156 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node; 1157 else 1158 { 1159 num_elements = size_binop (CEIL_DIV_EXPR, 1160 TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), 1161 size); 1162 num_elements = size_binop (CEIL_DIV_EXPR, num_elements, 1163 size_int (TYPE_PRECISION 1164 (char_type_node))); 1165 num_elements = convert (ffecom_f2c_ftnlen_type_node, 1166 num_elements); 1167 } 1168 1169 num_elements 1170 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, 1171 num_elements); 1172 1173 variable = convert (string_type_node, variable); 1174 1175 arglist = build_tree_list (NULL_TREE, num_elements); 1176 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable); 1177 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size); 1178 1179 return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE); 1180} 1181 1182#endif 1183/* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list. 1184 1185 Returns a tree suitable as an argument list containing a pointer to 1186 a BACKSPACE/ENDFILE/REWIND control list. First, generates that control 1187 list, if necessary, along with any static and run-time initializations 1188 that are needed as specified by the arguments to this function. 1189 1190 Must ensure that all expressions are prepared before being evaluated, 1191 for any whose evaluation might result in the generation of temporaries. 1192 1193 Note that this means this function causes a transition, within the 1194 current block being code-generated via the back end, from the 1195 declaration of variables (temporaries) to the expanding of expressions, 1196 statements, etc. */ 1197 1198#if FFECOM_targetCURRENT == FFECOM_targetGCC 1199static tree 1200ffeste_io_ialist_ (bool have_err, 1201 ffestvUnit unit, 1202 ffebld unit_expr, 1203 int unit_dflt) 1204{ 1205 static tree f2c_alist_struct = NULL_TREE; 1206 tree t; 1207 tree ttype; 1208 int yes; 1209 tree field; 1210 tree inits, initn; 1211 bool constantp = TRUE; 1212 static tree errfield, unitfield; 1213 tree errinit, unitinit; 1214 tree unitexp; 1215 static int mynumber = 0; 1216 1217 if (f2c_alist_struct == NULL_TREE) 1218 { 1219 tree ref; 1220 1221 push_obstacks_nochange (); 1222 end_temporary_allocation (); 1223 1224 ref = make_node (RECORD_TYPE); 1225 1226 errfield = ffecom_decl_field (ref, NULL_TREE, "err", 1227 ffecom_f2c_flag_type_node); 1228 unitfield = ffecom_decl_field (ref, errfield, "unit", 1229 ffecom_f2c_ftnint_type_node); 1230 1231 TYPE_FIELDS (ref) = errfield; 1232 layout_type (ref); 1233 1234 resume_temporary_allocation (); 1235 pop_obstacks (); 1236 1237 f2c_alist_struct = ref; 1238 } 1239 1240 /* Try to do as much compile-time initialization of the structure 1241 as possible, to save run time. */ 1242 1243 ffeste_f2c_init_flag_ (have_err, errinit); 1244 1245 switch (unit) 1246 { 1247 case FFESTV_unitNONE: 1248 case FFESTV_unitASTERISK: 1249 unitinit = build_int_2 (unit_dflt, 0); 1250 unitexp = unitinit; 1251 break; 1252 1253 case FFESTV_unitINTEXPR: 1254 unitexp = ffecom_const_expr (unit_expr); 1255 if (unitexp) 1256 unitinit = unitexp; 1257 else 1258 { 1259 unitinit = ffecom_integer_zero_node; 1260 constantp = FALSE; 1261 } 1262 break; 1263 1264 default: 1265 assert ("bad unit spec" == NULL); 1266 unitinit = ffecom_integer_zero_node; 1267 unitexp = unitinit; 1268 break; 1269 } 1270 1271 inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit); 1272 initn = inits; 1273 ffeste_f2c_init_next_ (unitinit); 1274 1275 inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits); 1276 TREE_CONSTANT (inits) = constantp ? 1 : 0; 1277 TREE_STATIC (inits) = 1; 1278 1279 yes = suspend_momentary (); 1280 1281 t = build_decl (VAR_DECL, 1282 ffecom_get_invented_identifier ("__g77_alist_%d", NULL, 1283 mynumber++), 1284 f2c_alist_struct); 1285 TREE_STATIC (t) = 1; 1286 t = ffecom_start_decl (t, 1); 1287 ffecom_finish_decl (t, inits, 0); 1288 1289 resume_momentary (yes); 1290 1291 /* Prepare run-time expressions. */ 1292 1293 if (! unitexp) 1294 ffecom_prepare_expr (unit_expr); 1295 1296 ffecom_prepare_end (); 1297 1298 /* Now evaluate run-time expressions as needed. */ 1299 1300 if (! unitexp) 1301 { 1302 unitexp = ffecom_expr (unit_expr); 1303 ffeste_f2c_compile_ (unitfield, unitexp); 1304 } 1305 1306 ttype = build_pointer_type (TREE_TYPE (t)); 1307 t = ffecom_1 (ADDR_EXPR, ttype, t); 1308 1309 t = build_tree_list (NULL_TREE, t); 1310 1311 return t; 1312} 1313 1314#endif 1315/* Make arglist with ptr to external-I/O control list. 1316 1317 Returns a tree suitable as an argument list containing a pointer to 1318 an external-I/O control list. First, generates that control 1319 list, if necessary, along with any static and run-time initializations 1320 that are needed as specified by the arguments to this function. 1321 1322 Must ensure that all expressions are prepared before being evaluated, 1323 for any whose evaluation might result in the generation of temporaries. 1324 1325 Note that this means this function causes a transition, within the 1326 current block being code-generated via the back end, from the 1327 declaration of variables (temporaries) to the expanding of expressions, 1328 statements, etc. */ 1329 1330#if FFECOM_targetCURRENT == FFECOM_targetGCC 1331static tree 1332ffeste_io_cilist_ (bool have_err, 1333 ffestvUnit unit, 1334 ffebld unit_expr, 1335 int unit_dflt, 1336 bool have_end, 1337 ffestvFormat format, 1338 ffestpFile *format_spec, 1339 bool rec, 1340 ffebld rec_expr) 1341{ 1342 static tree f2c_cilist_struct = NULL_TREE; 1343 tree t; 1344 tree ttype; 1345 int yes; 1346 tree field; 1347 tree inits, initn; 1348 bool constantp = TRUE; 1349 static tree errfield, unitfield, endfield, formatfield, recfield; 1350 tree errinit, unitinit, endinit, formatinit, recinit; 1351 tree unitexp, formatexp, recexp; 1352 static int mynumber = 0; 1353 1354 if (f2c_cilist_struct == NULL_TREE) 1355 { 1356 tree ref; 1357 1358 push_obstacks_nochange (); 1359 end_temporary_allocation (); 1360 1361 ref = make_node (RECORD_TYPE); 1362 1363 errfield = ffecom_decl_field (ref, NULL_TREE, "err", 1364 ffecom_f2c_flag_type_node); 1365 unitfield = ffecom_decl_field (ref, errfield, "unit", 1366 ffecom_f2c_ftnint_type_node); 1367 endfield = ffecom_decl_field (ref, unitfield, "end", 1368 ffecom_f2c_flag_type_node); 1369 formatfield = ffecom_decl_field (ref, endfield, "format", 1370 string_type_node); 1371 recfield = ffecom_decl_field (ref, formatfield, "rec", 1372 ffecom_f2c_ftnint_type_node); 1373 1374 TYPE_FIELDS (ref) = errfield; 1375 layout_type (ref); 1376 1377 resume_temporary_allocation (); 1378 pop_obstacks (); 1379 1380 f2c_cilist_struct = ref; 1381 } 1382 1383 /* Try to do as much compile-time initialization of the structure 1384 as possible, to save run time. */ 1385 1386 ffeste_f2c_init_flag_ (have_err, errinit); 1387 1388 switch (unit) 1389 { 1390 case FFESTV_unitNONE: 1391 case FFESTV_unitASTERISK: 1392 unitinit = build_int_2 (unit_dflt, 0); 1393 unitexp = unitinit; 1394 break; 1395 1396 case FFESTV_unitINTEXPR: 1397 unitexp = ffecom_const_expr (unit_expr); 1398 if (unitexp) 1399 unitinit = unitexp; 1400 else 1401 { 1402 unitinit = ffecom_integer_zero_node; 1403 constantp = FALSE; 1404 } 1405 break; 1406 1407 default: 1408 assert ("bad unit spec" == NULL); 1409 unitinit = ffecom_integer_zero_node; 1410 unitexp = unitinit; 1411 break; 1412 } 1413 1414 switch (format) 1415 { 1416 case FFESTV_formatNONE: 1417 formatinit = null_pointer_node; 1418 formatexp = formatinit; 1419 break; 1420 1421 case FFESTV_formatLABEL: 1422 formatexp = error_mark_node; 1423 formatinit = ffecom_lookup_label (format_spec->u.label); 1424 if ((formatinit == NULL_TREE) 1425 || (TREE_CODE (formatinit) == ERROR_MARK)) 1426 break; 1427 formatinit = ffecom_1 (ADDR_EXPR, 1428 build_pointer_type (void_type_node), 1429 formatinit); 1430 TREE_CONSTANT (formatinit) = 1; 1431 break; 1432 1433 case FFESTV_formatCHAREXPR: 1434 formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL); 1435 if (formatexp) 1436 formatinit = formatexp; 1437 else 1438 { 1439 formatinit = null_pointer_node; 1440 constantp = FALSE; 1441 } 1442 break; 1443 1444 case FFESTV_formatASTERISK: 1445 formatinit = null_pointer_node; 1446 formatexp = formatinit; 1447 break; 1448 1449 case FFESTV_formatINTEXPR: 1450 formatinit = null_pointer_node; 1451 formatexp = ffecom_expr_assign (format_spec->u.expr); 1452 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp))) 1453 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) 1454 error ("ASSIGNed FORMAT specifier is too small"); 1455 formatexp = convert (string_type_node, formatexp); 1456 break; 1457 1458 case FFESTV_formatNAMELIST: 1459 formatinit = ffecom_expr (format_spec->u.expr); 1460 formatexp = formatinit; 1461 break; 1462 1463 default: 1464 assert ("bad format spec" == NULL); 1465 formatinit = integer_zero_node; 1466 formatexp = formatinit; 1467 break; 1468 } 1469 1470 ffeste_f2c_init_flag_ (have_end, endinit); 1471 1472 if (rec) 1473 recexp = ffecom_const_expr (rec_expr); 1474 else 1475 recexp = ffecom_integer_zero_node; 1476 if (recexp) 1477 recinit = recexp; 1478 else 1479 { 1480 recinit = ffecom_integer_zero_node; 1481 constantp = FALSE; 1482 } 1483 1484 inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit); 1485 initn = inits; 1486 ffeste_f2c_init_next_ (unitinit); 1487 ffeste_f2c_init_next_ (endinit); 1488 ffeste_f2c_init_next_ (formatinit); 1489 ffeste_f2c_init_next_ (recinit); 1490 1491 inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits); 1492 TREE_CONSTANT (inits) = constantp ? 1 : 0; 1493 TREE_STATIC (inits) = 1; 1494 1495 yes = suspend_momentary (); 1496 1497 t = build_decl (VAR_DECL, 1498 ffecom_get_invented_identifier ("__g77_cilist_%d", NULL, 1499 mynumber++), 1500 f2c_cilist_struct); 1501 TREE_STATIC (t) = 1; 1502 t = ffecom_start_decl (t, 1); 1503 ffecom_finish_decl (t, inits, 0); 1504 1505 resume_momentary (yes); 1506 1507 /* Prepare run-time expressions. */ 1508 1509 if (! unitexp) 1510 ffecom_prepare_expr (unit_expr); 1511 1512 if (! formatexp) 1513 ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr); 1514 1515 if (! recexp) 1516 ffecom_prepare_expr (rec_expr); 1517 1518 ffecom_prepare_end (); 1519 1520 /* Now evaluate run-time expressions as needed. */ 1521 1522 if (! unitexp) 1523 { 1524 unitexp = ffecom_expr (unit_expr); 1525 ffeste_f2c_compile_ (unitfield, unitexp); 1526 } 1527 1528 if (! formatexp) 1529 { 1530 formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL); 1531 ffeste_f2c_compile_ (formatfield, formatexp); 1532 } 1533 else if (format == FFESTV_formatINTEXPR) 1534 ffeste_f2c_compile_ (formatfield, formatexp); 1535 1536 if (! recexp) 1537 { 1538 recexp = ffecom_expr (rec_expr); 1539 ffeste_f2c_compile_ (recfield, recexp); 1540 } 1541 1542 ttype = build_pointer_type (TREE_TYPE (t)); 1543 t = ffecom_1 (ADDR_EXPR, ttype, t); 1544 1545 t = build_tree_list (NULL_TREE, t); 1546 1547 return t; 1548} 1549 1550#endif 1551/* Make arglist with ptr to CLOSE control list. 1552 1553 Returns a tree suitable as an argument list containing a pointer to 1554 a CLOSE-statement control list. First, generates that control 1555 list, if necessary, along with any static and run-time initializations 1556 that are needed as specified by the arguments to this function. 1557 1558 Must ensure that all expressions are prepared before being evaluated, 1559 for any whose evaluation might result in the generation of temporaries. 1560 1561 Note that this means this function causes a transition, within the 1562 current block being code-generated via the back end, from the 1563 declaration of variables (temporaries) to the expanding of expressions, 1564 statements, etc. */ 1565 1566#if FFECOM_targetCURRENT == FFECOM_targetGCC 1567static tree 1568ffeste_io_cllist_ (bool have_err, 1569 ffebld unit_expr, 1570 ffestpFile *stat_spec) 1571{ 1572 static tree f2c_close_struct = NULL_TREE; 1573 tree t; 1574 tree ttype; 1575 int yes; 1576 tree field; 1577 tree inits, initn; 1578 tree ignore; /* Ignore length info for certain fields. */ 1579 bool constantp = TRUE; 1580 static tree errfield, unitfield, statfield; 1581 tree errinit, unitinit, statinit; 1582 tree unitexp, statexp; 1583 static int mynumber = 0; 1584 1585 if (f2c_close_struct == NULL_TREE) 1586 { 1587 tree ref; 1588 1589 push_obstacks_nochange (); 1590 end_temporary_allocation (); 1591 1592 ref = make_node (RECORD_TYPE); 1593 1594 errfield = ffecom_decl_field (ref, NULL_TREE, "err", 1595 ffecom_f2c_flag_type_node); 1596 unitfield = ffecom_decl_field (ref, errfield, "unit", 1597 ffecom_f2c_ftnint_type_node); 1598 statfield = ffecom_decl_field (ref, unitfield, "stat", 1599 string_type_node); 1600 1601 TYPE_FIELDS (ref) = errfield; 1602 layout_type (ref); 1603 1604 resume_temporary_allocation (); 1605 pop_obstacks (); 1606 1607 f2c_close_struct = ref; 1608 } 1609 1610 /* Try to do as much compile-time initialization of the structure 1611 as possible, to save run time. */ 1612 1613 ffeste_f2c_init_flag_ (have_err, errinit); 1614 1615 unitexp = ffecom_const_expr (unit_expr); 1616 if (unitexp) 1617 unitinit = unitexp; 1618 else 1619 { 1620 unitinit = ffecom_integer_zero_node; 1621 constantp = FALSE; 1622 } 1623 1624 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec); 1625 1626 inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit); 1627 initn = inits; 1628 ffeste_f2c_init_next_ (unitinit); 1629 ffeste_f2c_init_next_ (statinit); 1630 1631 inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits); 1632 TREE_CONSTANT (inits) = constantp ? 1 : 0; 1633 TREE_STATIC (inits) = 1; 1634 1635 yes = suspend_momentary (); 1636 1637 t = build_decl (VAR_DECL, 1638 ffecom_get_invented_identifier ("__g77_cllist_%d", NULL, 1639 mynumber++), 1640 f2c_close_struct); 1641 TREE_STATIC (t) = 1; 1642 t = ffecom_start_decl (t, 1); 1643 ffecom_finish_decl (t, inits, 0); 1644 1645 resume_momentary (yes); 1646 1647 /* Prepare run-time expressions. */ 1648 1649 if (! unitexp) 1650 ffecom_prepare_expr (unit_expr); 1651 1652 if (! statexp) 1653 ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr); 1654 1655 ffecom_prepare_end (); 1656 1657 /* Now evaluate run-time expressions as needed. */ 1658 1659 if (! unitexp) 1660 { 1661 unitexp = ffecom_expr (unit_expr); 1662 ffeste_f2c_compile_ (unitfield, unitexp); 1663 } 1664 1665 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp); 1666 1667 ttype = build_pointer_type (TREE_TYPE (t)); 1668 t = ffecom_1 (ADDR_EXPR, ttype, t); 1669 1670 t = build_tree_list (NULL_TREE, t); 1671 1672 return t; 1673} 1674 1675#endif 1676/* Make arglist with ptr to internal-I/O control list. 1677 1678 Returns a tree suitable as an argument list containing a pointer to 1679 an internal-I/O control list. First, generates that control 1680 list, if necessary, along with any static and run-time initializations 1681 that are needed as specified by the arguments to this function. 1682 1683 Must ensure that all expressions are prepared before being evaluated, 1684 for any whose evaluation might result in the generation of temporaries. 1685 1686 Note that this means this function causes a transition, within the 1687 current block being code-generated via the back end, from the 1688 declaration of variables (temporaries) to the expanding of expressions, 1689 statements, etc. */ 1690 1691#if FFECOM_targetCURRENT == FFECOM_targetGCC 1692static tree 1693ffeste_io_icilist_ (bool have_err, 1694 ffebld unit_expr, 1695 bool have_end, 1696 ffestvFormat format, 1697 ffestpFile *format_spec) 1698{ 1699 static tree f2c_icilist_struct = NULL_TREE; 1700 tree t; 1701 tree ttype; 1702 int yes; 1703 tree field; 1704 tree inits, initn; 1705 bool constantp = TRUE; 1706 static tree errfield, unitfield, endfield, formatfield, unitlenfield, 1707 unitnumfield; 1708 tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit; 1709 tree unitexp, formatexp, unitlenexp, unitnumexp; 1710 static int mynumber = 0; 1711 1712 if (f2c_icilist_struct == NULL_TREE) 1713 { 1714 tree ref; 1715 1716 push_obstacks_nochange (); 1717 end_temporary_allocation (); 1718 1719 ref = make_node (RECORD_TYPE); 1720 1721 errfield = ffecom_decl_field (ref, NULL_TREE, "err", 1722 ffecom_f2c_flag_type_node); 1723 unitfield = ffecom_decl_field (ref, errfield, "unit", 1724 string_type_node); 1725 endfield = ffecom_decl_field (ref, unitfield, "end", 1726 ffecom_f2c_flag_type_node); 1727 formatfield = ffecom_decl_field (ref, endfield, "format", 1728 string_type_node); 1729 unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen", 1730 ffecom_f2c_ftnint_type_node); 1731 unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum", 1732 ffecom_f2c_ftnint_type_node); 1733 1734 TYPE_FIELDS (ref) = errfield; 1735 layout_type (ref); 1736 1737 resume_temporary_allocation (); 1738 pop_obstacks (); 1739 1740 f2c_icilist_struct = ref; 1741 } 1742 1743 /* Try to do as much compile-time initialization of the structure 1744 as possible, to save run time. */ 1745 1746 ffeste_f2c_init_flag_ (have_err, errinit); 1747 1748 unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp); 1749 if (unitexp) 1750 unitinit = unitexp; 1751 else 1752 { 1753 unitinit = null_pointer_node; 1754 constantp = FALSE; 1755 } 1756 if (unitlenexp) 1757 unitleninit = unitlenexp; 1758 else 1759 { 1760 unitleninit = ffecom_integer_zero_node; 1761 constantp = FALSE; 1762 } 1763 1764 /* Now see if we can fully initialize the number of elements, or 1765 if we have to compute that at run time. */ 1766 if (ffeinfo_rank (ffebld_info (unit_expr)) == 0 1767 || (unitexp 1768 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE)) 1769 { 1770 /* Not an array, so just one element. */ 1771 unitnuminit = ffecom_integer_one_node; 1772 unitnumexp = unitnuminit; 1773 } 1774 else if (unitexp && unitlenexp) 1775 { 1776 /* An array, but all the info is constant, so compute now. */ 1777 unitnuminit = size_binop (CEIL_DIV_EXPR, 1778 TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), 1779 unitlenexp); 1780 unitnuminit = size_binop (CEIL_DIV_EXPR, 1781 unitnuminit, 1782 size_int (TYPE_PRECISION 1783 (char_type_node))); 1784 unitnumexp = unitnuminit; 1785 } 1786 else 1787 { 1788 /* Put off computing until run time. */ 1789 unitnuminit = ffecom_integer_zero_node; 1790 unitnumexp = NULL_TREE; 1791 constantp = FALSE; 1792 } 1793 1794 switch (format) 1795 { 1796 case FFESTV_formatNONE: 1797 formatinit = null_pointer_node; 1798 formatexp = formatinit; 1799 break; 1800 1801 case FFESTV_formatLABEL: 1802 formatexp = error_mark_node; 1803 formatinit = ffecom_lookup_label (format_spec->u.label); 1804 if ((formatinit == NULL_TREE) 1805 || (TREE_CODE (formatinit) == ERROR_MARK)) 1806 break; 1807 formatinit = ffecom_1 (ADDR_EXPR, 1808 build_pointer_type (void_type_node), 1809 formatinit); 1810 TREE_CONSTANT (formatinit) = 1; 1811 break; 1812 1813 case FFESTV_formatCHAREXPR: 1814 ffeste_f2c_init_format_ (formatexp, formatinit, format_spec); 1815 break; 1816 1817 case FFESTV_formatASTERISK: 1818 formatinit = null_pointer_node; 1819 formatexp = formatinit; 1820 break; 1821 1822 case FFESTV_formatINTEXPR: 1823 formatinit = null_pointer_node; 1824 formatexp = ffecom_expr_assign (format_spec->u.expr); 1825 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp))) 1826 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) 1827 error ("ASSIGNed FORMAT specifier is too small"); 1828 formatexp = convert (string_type_node, formatexp); 1829 break; 1830 1831 default: 1832 assert ("bad format spec" == NULL); 1833 formatinit = ffecom_integer_zero_node; 1834 formatexp = formatinit; 1835 break; 1836 } 1837 1838 ffeste_f2c_init_flag_ (have_end, endinit); 1839 1840 inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)), 1841 errinit); 1842 initn = inits; 1843 ffeste_f2c_init_next_ (unitinit); 1844 ffeste_f2c_init_next_ (endinit); 1845 ffeste_f2c_init_next_ (formatinit); 1846 ffeste_f2c_init_next_ (unitleninit); 1847 ffeste_f2c_init_next_ (unitnuminit); 1848 1849 inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits); 1850 TREE_CONSTANT (inits) = constantp ? 1 : 0; 1851 TREE_STATIC (inits) = 1; 1852 1853 yes = suspend_momentary (); 1854 1855 t = build_decl (VAR_DECL, 1856 ffecom_get_invented_identifier ("__g77_icilist_%d", NULL, 1857 mynumber++), 1858 f2c_icilist_struct); 1859 TREE_STATIC (t) = 1; 1860 t = ffecom_start_decl (t, 1); 1861 ffecom_finish_decl (t, inits, 0); 1862 1863 resume_momentary (yes); 1864 1865 /* Prepare run-time expressions. */ 1866 1867 if (! unitexp) 1868 ffecom_prepare_arg_ptr_to_expr (unit_expr); 1869 1870 ffeste_f2c_prepare_format_ (format_spec, formatexp); 1871 1872 ffecom_prepare_end (); 1873 1874 /* Now evaluate run-time expressions as needed. */ 1875 1876 if (! unitexp || ! unitlenexp) 1877 { 1878 int need_unitexp = (! unitexp); 1879 int need_unitlenexp = (! unitlenexp); 1880 1881 unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp); 1882 if (need_unitexp) 1883 ffeste_f2c_compile_ (unitfield, unitexp); 1884 if (need_unitlenexp) 1885 ffeste_f2c_compile_ (unitlenfield, unitlenexp); 1886 } 1887 1888 if (! unitnumexp 1889 && unitexp != error_mark_node 1890 && unitlenexp != error_mark_node) 1891 { 1892 unitnumexp = size_binop (CEIL_DIV_EXPR, 1893 TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), 1894 unitlenexp); 1895 unitnumexp = size_binop (CEIL_DIV_EXPR, 1896 unitnumexp, 1897 size_int (TYPE_PRECISION 1898 (char_type_node))); 1899 ffeste_f2c_compile_ (unitnumfield, unitnumexp); 1900 } 1901 1902 if (format == FFESTV_formatINTEXPR) 1903 ffeste_f2c_compile_ (formatfield, formatexp); 1904 else 1905 ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp); 1906 1907 ttype = build_pointer_type (TREE_TYPE (t)); 1908 t = ffecom_1 (ADDR_EXPR, ttype, t); 1909 1910 t = build_tree_list (NULL_TREE, t); 1911 1912 return t; 1913} 1914#endif 1915 1916/* Make arglist with ptr to INQUIRE control list 1917 1918 Returns a tree suitable as an argument list containing a pointer to 1919 an INQUIRE-statement control list. First, generates that control 1920 list, if necessary, along with any static and run-time initializations 1921 that are needed as specified by the arguments to this function. 1922 1923 Must ensure that all expressions are prepared before being evaluated, 1924 for any whose evaluation might result in the generation of temporaries. 1925 1926 Note that this means this function causes a transition, within the 1927 current block being code-generated via the back end, from the 1928 declaration of variables (temporaries) to the expanding of expressions, 1929 statements, etc. */ 1930 1931#if FFECOM_targetCURRENT == FFECOM_targetGCC 1932static tree 1933ffeste_io_inlist_ (bool have_err, 1934 ffestpFile *unit_spec, 1935 ffestpFile *file_spec, 1936 ffestpFile *exist_spec, 1937 ffestpFile *open_spec, 1938 ffestpFile *number_spec, 1939 ffestpFile *named_spec, 1940 ffestpFile *name_spec, 1941 ffestpFile *access_spec, 1942 ffestpFile *sequential_spec, 1943 ffestpFile *direct_spec, 1944 ffestpFile *form_spec, 1945 ffestpFile *formatted_spec, 1946 ffestpFile *unformatted_spec, 1947 ffestpFile *recl_spec, 1948 ffestpFile *nextrec_spec, 1949 ffestpFile *blank_spec) 1950{ 1951 static tree f2c_inquire_struct = NULL_TREE; 1952 tree t; 1953 tree ttype; 1954 int yes; 1955 tree field; 1956 tree inits, initn; 1957 bool constantp = TRUE; 1958 static tree errfield, unitfield, filefield, filelenfield, existfield, 1959 openfield, numberfield, namedfield, namefield, namelenfield, accessfield, 1960 accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield, 1961 formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield, 1962 unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield; 1963 tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit, 1964 namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit, 1965 sequentialleninit, directinit, directleninit, forminit, formleninit, 1966 formattedinit, formattedleninit, unformattedinit, unformattedleninit, 1967 reclinit, nextrecinit, blankinit, blankleninit; 1968 tree 1969 unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp, 1970 nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp, 1971 directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp, 1972 unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp; 1973 static int mynumber = 0; 1974 1975 if (f2c_inquire_struct == NULL_TREE) 1976 { 1977 tree ref; 1978 1979 push_obstacks_nochange (); 1980 end_temporary_allocation (); 1981 1982 ref = make_node (RECORD_TYPE); 1983 1984 errfield = ffecom_decl_field (ref, NULL_TREE, "err", 1985 ffecom_f2c_flag_type_node); 1986 unitfield = ffecom_decl_field (ref, errfield, "unit", 1987 ffecom_f2c_ftnint_type_node); 1988 filefield = ffecom_decl_field (ref, unitfield, "file", 1989 string_type_node); 1990 filelenfield = ffecom_decl_field (ref, filefield, "filelen", 1991 ffecom_f2c_ftnlen_type_node); 1992 existfield = ffecom_decl_field (ref, filelenfield, "exist", 1993 ffecom_f2c_ptr_to_ftnint_type_node); 1994 openfield = ffecom_decl_field (ref, existfield, "open", 1995 ffecom_f2c_ptr_to_ftnint_type_node); 1996 numberfield = ffecom_decl_field (ref, openfield, "number", 1997 ffecom_f2c_ptr_to_ftnint_type_node); 1998 namedfield = ffecom_decl_field (ref, numberfield, "named", 1999 ffecom_f2c_ptr_to_ftnint_type_node); 2000 namefield = ffecom_decl_field (ref, namedfield, "name", 2001 string_type_node); 2002 namelenfield = ffecom_decl_field (ref, namefield, "namelen", 2003 ffecom_f2c_ftnlen_type_node); 2004 accessfield = ffecom_decl_field (ref, namelenfield, "access", 2005 string_type_node); 2006 accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen", 2007 ffecom_f2c_ftnlen_type_node); 2008 sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential", 2009 string_type_node); 2010 sequentiallenfield = ffecom_decl_field (ref, sequentialfield, 2011 "sequentiallen", 2012 ffecom_f2c_ftnlen_type_node); 2013 directfield = ffecom_decl_field (ref, sequentiallenfield, "direct", 2014 string_type_node); 2015 directlenfield = ffecom_decl_field (ref, directfield, "directlen", 2016 ffecom_f2c_ftnlen_type_node); 2017 formfield = ffecom_decl_field (ref, directlenfield, "form", 2018 string_type_node); 2019 formlenfield = ffecom_decl_field (ref, formfield, "formlen", 2020 ffecom_f2c_ftnlen_type_node); 2021 formattedfield = ffecom_decl_field (ref, formlenfield, "formatted", 2022 string_type_node); 2023 formattedlenfield = ffecom_decl_field (ref, formattedfield, 2024 "formattedlen", 2025 ffecom_f2c_ftnlen_type_node); 2026 unformattedfield = ffecom_decl_field (ref, formattedlenfield, 2027 "unformatted", 2028 string_type_node); 2029 unformattedlenfield = ffecom_decl_field (ref, unformattedfield, 2030 "unformattedlen", 2031 ffecom_f2c_ftnlen_type_node); 2032 reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl", 2033 ffecom_f2c_ptr_to_ftnint_type_node); 2034 nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec", 2035 ffecom_f2c_ptr_to_ftnint_type_node); 2036 blankfield = ffecom_decl_field (ref, nextrecfield, "blank", 2037 string_type_node); 2038 blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen", 2039 ffecom_f2c_ftnlen_type_node); 2040 2041 TYPE_FIELDS (ref) = errfield; 2042 layout_type (ref); 2043 2044 resume_temporary_allocation (); 2045 pop_obstacks (); 2046 2047 f2c_inquire_struct = ref; 2048 } 2049 2050 /* Try to do as much compile-time initialization of the structure 2051 as possible, to save run time. */ 2052 2053 ffeste_f2c_init_flag_ (have_err, errinit); 2054 ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec); 2055 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit, 2056 file_spec); 2057 ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec); 2058 ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec); 2059 ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec); 2060 ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec); 2061 ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit, 2062 name_spec); 2063 ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp, 2064 accessleninit, access_spec); 2065 ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp, 2066 sequentialleninit, sequential_spec); 2067 ffeste_f2c_init_char_ (directexp, directinit, directlenexp, 2068 directleninit, direct_spec); 2069 ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit, 2070 form_spec); 2071 ffeste_f2c_init_char_ (formattedexp, formattedinit, 2072 formattedlenexp, formattedleninit, formatted_spec); 2073 ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp, 2074 unformattedleninit, unformatted_spec); 2075 ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec); 2076 ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec); 2077 ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp, 2078 blankleninit, blank_spec); 2079 2080 inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)), 2081 errinit); 2082 initn = inits; 2083 ffeste_f2c_init_next_ (unitinit); 2084 ffeste_f2c_init_next_ (fileinit); 2085 ffeste_f2c_init_next_ (fileleninit); 2086 ffeste_f2c_init_next_ (existinit); 2087 ffeste_f2c_init_next_ (openinit); 2088 ffeste_f2c_init_next_ (numberinit); 2089 ffeste_f2c_init_next_ (namedinit); 2090 ffeste_f2c_init_next_ (nameinit); 2091 ffeste_f2c_init_next_ (nameleninit); 2092 ffeste_f2c_init_next_ (accessinit); 2093 ffeste_f2c_init_next_ (accessleninit); 2094 ffeste_f2c_init_next_ (sequentialinit); 2095 ffeste_f2c_init_next_ (sequentialleninit); 2096 ffeste_f2c_init_next_ (directinit); 2097 ffeste_f2c_init_next_ (directleninit); 2098 ffeste_f2c_init_next_ (forminit); 2099 ffeste_f2c_init_next_ (formleninit); 2100 ffeste_f2c_init_next_ (formattedinit); 2101 ffeste_f2c_init_next_ (formattedleninit); 2102 ffeste_f2c_init_next_ (unformattedinit); 2103 ffeste_f2c_init_next_ (unformattedleninit); 2104 ffeste_f2c_init_next_ (reclinit); 2105 ffeste_f2c_init_next_ (nextrecinit); 2106 ffeste_f2c_init_next_ (blankinit); 2107 ffeste_f2c_init_next_ (blankleninit); 2108 2109 inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits); 2110 TREE_CONSTANT (inits) = constantp ? 1 : 0; 2111 TREE_STATIC (inits) = 1; 2112 2113 yes = suspend_momentary (); 2114 2115 t = build_decl (VAR_DECL, 2116 ffecom_get_invented_identifier ("__g77_inlist_%d", NULL, 2117 mynumber++), 2118 f2c_inquire_struct); 2119 TREE_STATIC (t) = 1; 2120 t = ffecom_start_decl (t, 1); 2121 ffecom_finish_decl (t, inits, 0); 2122 2123 resume_momentary (yes); 2124 2125 /* Prepare run-time expressions. */ 2126 2127 ffeste_f2c_prepare_int_ (unit_spec, unitexp); 2128 ffeste_f2c_prepare_char_ (file_spec, fileexp); 2129 ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp); 2130 ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp); 2131 ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp); 2132 ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp); 2133 ffeste_f2c_prepare_char_ (name_spec, nameexp); 2134 ffeste_f2c_prepare_char_ (access_spec, accessexp); 2135 ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp); 2136 ffeste_f2c_prepare_char_ (direct_spec, directexp); 2137 ffeste_f2c_prepare_char_ (form_spec, formexp); 2138 ffeste_f2c_prepare_char_ (formatted_spec, formattedexp); 2139 ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp); 2140 ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp); 2141 ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp); 2142 ffeste_f2c_prepare_char_ (blank_spec, blankexp); 2143 2144 ffecom_prepare_end (); 2145 2146 /* Now evaluate run-time expressions as needed. */ 2147 2148 ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp); 2149 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, 2150 fileexp, filelenexp); 2151 ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp); 2152 ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp); 2153 ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp); 2154 ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp); 2155 ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp, 2156 namelenexp); 2157 ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec, 2158 accessexp, accesslenexp); 2159 ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield, 2160 sequential_spec, sequentialexp, 2161 sequentiallenexp); 2162 ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec, 2163 directexp, directlenexp); 2164 ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp, 2165 formlenexp); 2166 ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec, 2167 formattedexp, formattedlenexp); 2168 ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield, 2169 unformatted_spec, unformattedexp, 2170 unformattedlenexp); 2171 ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp); 2172 ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp); 2173 ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp, 2174 blanklenexp); 2175 2176 ttype = build_pointer_type (TREE_TYPE (t)); 2177 t = ffecom_1 (ADDR_EXPR, ttype, t); 2178 2179 t = build_tree_list (NULL_TREE, t); 2180 2181 return t; 2182} 2183 2184#endif 2185/* Make arglist with ptr to OPEN control list 2186 2187 Returns a tree suitable as an argument list containing a pointer to 2188 an OPEN-statement control list. First, generates that control 2189 list, if necessary, along with any static and run-time initializations 2190 that are needed as specified by the arguments to this function. 2191 2192 Must ensure that all expressions are prepared before being evaluated, 2193 for any whose evaluation might result in the generation of temporaries. 2194 2195 Note that this means this function causes a transition, within the 2196 current block being code-generated via the back end, from the 2197 declaration of variables (temporaries) to the expanding of expressions, 2198 statements, etc. */ 2199 2200#if FFECOM_targetCURRENT == FFECOM_targetGCC 2201static tree 2202ffeste_io_olist_ (bool have_err, 2203 ffebld unit_expr, 2204 ffestpFile *file_spec, 2205 ffestpFile *stat_spec, 2206 ffestpFile *access_spec, 2207 ffestpFile *form_spec, 2208 ffestpFile *recl_spec, 2209 ffestpFile *blank_spec) 2210{ 2211 static tree f2c_open_struct = NULL_TREE; 2212 tree t; 2213 tree ttype; 2214 int yes; 2215 tree field; 2216 tree inits, initn; 2217 tree ignore; /* Ignore length info for certain fields. */ 2218 bool constantp = TRUE; 2219 static tree errfield, unitfield, filefield, filelenfield, statfield, 2220 accessfield, formfield, reclfield, blankfield; 2221 tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit, 2222 forminit, reclinit, blankinit; 2223 tree 2224 unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp, 2225 blankexp; 2226 static int mynumber = 0; 2227 2228 if (f2c_open_struct == NULL_TREE) 2229 { 2230 tree ref; 2231 2232 push_obstacks_nochange (); 2233 end_temporary_allocation (); 2234 2235 ref = make_node (RECORD_TYPE); 2236 2237 errfield = ffecom_decl_field (ref, NULL_TREE, "err", 2238 ffecom_f2c_flag_type_node); 2239 unitfield = ffecom_decl_field (ref, errfield, "unit", 2240 ffecom_f2c_ftnint_type_node); 2241 filefield = ffecom_decl_field (ref, unitfield, "file", 2242 string_type_node); 2243 filelenfield = ffecom_decl_field (ref, filefield, "filelen", 2244 ffecom_f2c_ftnlen_type_node); 2245 statfield = ffecom_decl_field (ref, filelenfield, "stat", 2246 string_type_node); 2247 accessfield = ffecom_decl_field (ref, statfield, "access", 2248 string_type_node); 2249 formfield = ffecom_decl_field (ref, accessfield, "form", 2250 string_type_node); 2251 reclfield = ffecom_decl_field (ref, formfield, "recl", 2252 ffecom_f2c_ftnint_type_node); 2253 blankfield = ffecom_decl_field (ref, reclfield, "blank", 2254 string_type_node); 2255 2256 TYPE_FIELDS (ref) = errfield; 2257 layout_type (ref); 2258 2259 resume_temporary_allocation (); 2260 pop_obstacks (); 2261 2262 f2c_open_struct = ref; 2263 } 2264 2265 /* Try to do as much compile-time initialization of the structure 2266 as possible, to save run time. */ 2267 2268 ffeste_f2c_init_flag_ (have_err, errinit); 2269 2270 unitexp = ffecom_const_expr (unit_expr); 2271 if (unitexp) 2272 unitinit = unitexp; 2273 else 2274 { 2275 unitinit = ffecom_integer_zero_node; 2276 constantp = FALSE; 2277 } 2278 2279 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit, 2280 file_spec); 2281 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec); 2282 ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec); 2283 ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec); 2284 ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec); 2285 ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec); 2286 2287 inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit); 2288 initn = inits; 2289 ffeste_f2c_init_next_ (unitinit); 2290 ffeste_f2c_init_next_ (fileinit); 2291 ffeste_f2c_init_next_ (fileleninit); 2292 ffeste_f2c_init_next_ (statinit); 2293 ffeste_f2c_init_next_ (accessinit); 2294 ffeste_f2c_init_next_ (forminit); 2295 ffeste_f2c_init_next_ (reclinit); 2296 ffeste_f2c_init_next_ (blankinit); 2297 2298 inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits); 2299 TREE_CONSTANT (inits) = constantp ? 1 : 0; 2300 TREE_STATIC (inits) = 1; 2301 2302 yes = suspend_momentary (); 2303 2304 t = build_decl (VAR_DECL, 2305 ffecom_get_invented_identifier ("__g77_olist_%d", NULL, 2306 mynumber++), 2307 f2c_open_struct); 2308 TREE_STATIC (t) = 1; 2309 t = ffecom_start_decl (t, 1); 2310 ffecom_finish_decl (t, inits, 0); 2311 2312 resume_momentary (yes); 2313 2314 /* Prepare run-time expressions. */ 2315 2316 if (! unitexp) 2317 ffecom_prepare_expr (unit_expr); 2318 2319 ffeste_f2c_prepare_char_ (file_spec, fileexp); 2320 ffeste_f2c_prepare_charnolen_ (stat_spec, statexp); 2321 ffeste_f2c_prepare_charnolen_ (access_spec, accessexp); 2322 ffeste_f2c_prepare_charnolen_ (form_spec, formexp); 2323 ffeste_f2c_prepare_int_ (recl_spec, reclexp); 2324 ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp); 2325 2326 ffecom_prepare_end (); 2327 2328 /* Now evaluate run-time expressions as needed. */ 2329 2330 if (! unitexp) 2331 { 2332 unitexp = ffecom_expr (unit_expr); 2333 ffeste_f2c_compile_ (unitfield, unitexp); 2334 } 2335 2336 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp, 2337 filelenexp); 2338 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp); 2339 ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp); 2340 ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp); 2341 ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp); 2342 ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp); 2343 2344 ttype = build_pointer_type (TREE_TYPE (t)); 2345 t = ffecom_1 (ADDR_EXPR, ttype, t); 2346 2347 t = build_tree_list (NULL_TREE, t); 2348 2349 return t; 2350} 2351 2352#endif 2353/* Display file-statement specifier. */ 2354 2355#if FFECOM_targetCURRENT == FFECOM_targetFFE 2356static void 2357ffeste_subr_file_ (const char *kw, ffestpFile *spec) 2358{ 2359 if (!spec->kw_or_val_present) 2360 return; 2361 fputs (kw, dmpout); 2362 if (spec->value_present) 2363 { 2364 fputc ('=', dmpout); 2365 if (spec->value_is_label) 2366 { 2367 assert (spec->value_is_label == 2); /* Temporary checking only. */ 2368 fprintf (dmpout, "%" ffelabValue_f "u", 2369 ffelab_value (spec->u.label)); 2370 } 2371 else 2372 ffebld_dump (spec->u.expr); 2373 } 2374 fputc (',', dmpout); 2375} 2376#endif 2377 2378/* Generate code for BACKSPACE/ENDFILE/REWIND. */ 2379 2380#if FFECOM_targetCURRENT == FFECOM_targetGCC 2381static void 2382ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) 2383{ 2384 tree alist; 2385 bool iostat; 2386 bool errl; 2387 2388 ffeste_emit_line_note_ (); 2389 2390#define specified(something) (info->beru_spec[something].kw_or_val_present) 2391 2392 iostat = specified (FFESTP_beruixIOSTAT); 2393 errl = specified (FFESTP_beruixERR); 2394 2395#undef specified 2396 2397 /* ~~For now, we assume the unit number is specified and is not ASTERISK, 2398 because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE 2399 without any unit specifier. f2c, however, supports the former 2400 construct. When it is time to add this feature to the FFE, which 2401 probably is fairly easy, ffestc_R919 and company will want to pass an 2402 ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to 2403 ffeste_R919 and company, and they will want to pass that same value to 2404 this function, and that argument will replace the constant _unitINTEXPR_ 2405 in the call below. Right now, the default unit number, 6, is ignored. */ 2406 2407 ffeste_start_stmt_ (); 2408 2409 if (errl) 2410 { 2411 /* Have ERR= specification. */ 2412 2413 ffeste_io_err_ 2414 = ffeste_io_abort_ 2415 = ffecom_lookup_label 2416 (info->beru_spec[FFESTP_beruixERR].u.label); 2417 ffeste_io_abort_is_temp_ = FALSE; 2418 } 2419 else 2420 { 2421 /* No ERR= specification. */ 2422 2423 ffeste_io_err_ = NULL_TREE; 2424 2425 if ((ffeste_io_abort_is_temp_ = iostat)) 2426 ffeste_io_abort_ = ffecom_temp_label (); 2427 else 2428 ffeste_io_abort_ = NULL_TREE; 2429 } 2430 2431 if (iostat) 2432 { 2433 /* Have IOSTAT= specification. */ 2434 2435 ffeste_io_iostat_is_temp_ = FALSE; 2436 ffeste_io_iostat_ = ffecom_expr 2437 (info->beru_spec[FFESTP_beruixIOSTAT].u.expr); 2438 } 2439 else if (ffeste_io_abort_ != NULL_TREE) 2440 { 2441 /* Have no IOSTAT= but have ERR=. */ 2442 2443 ffeste_io_iostat_is_temp_ = TRUE; 2444 ffeste_io_iostat_ 2445 = ffecom_make_tempvar ("beru", ffecom_integer_type_node, 2446 FFETARGET_charactersizeNONE, -1); 2447 } 2448 else 2449 { 2450 /* No IOSTAT= or ERR= specification. */ 2451 2452 ffeste_io_iostat_is_temp_ = FALSE; 2453 ffeste_io_iostat_ = NULL_TREE; 2454 } 2455 2456 /* Now prescan, then convert, all the arguments. */ 2457 2458 alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR, 2459 info->beru_spec[FFESTP_beruixUNIT].u.expr, 6); 2460 2461 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort 2462 label, since we're gonna fall through to there anyway. */ 2463 2464 ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE), 2465 ! ffeste_io_abort_is_temp_); 2466 2467 /* If we've got a temp label, generate its code here. */ 2468 2469 if (ffeste_io_abort_is_temp_) 2470 { 2471 DECL_INITIAL (ffeste_io_abort_) = error_mark_node; 2472 emit_nop (); 2473 expand_label (ffeste_io_abort_); 2474 2475 assert (ffeste_io_err_ == NULL_TREE); 2476 } 2477 2478 ffeste_end_stmt_ (); 2479} 2480#endif 2481 2482/* END DO statement 2483 2484 Also invoked by _labeldef_branch_finish_ (or, in cases 2485 of errors, other _labeldef_ functions) when the label definition is 2486 for a DO-target (LOOPEND) label, once per matching/outstanding DO 2487 block on the stack. */ 2488 2489void 2490ffeste_do (ffestw block) 2491{ 2492#if FFECOM_targetCURRENT == FFECOM_targetFFE 2493 fputs ("+ END_DO\n", dmpout); 2494#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2495 ffeste_emit_line_note_ (); 2496 2497 if (ffestw_do_tvar (block) == 0) 2498 { 2499 expand_end_loop (); /* DO WHILE and just DO. */ 2500 2501 ffeste_end_block_ (block); 2502 } 2503 else 2504 ffeste_end_iterdo_ (block, 2505 ffestw_do_tvar (block), 2506 ffestw_do_incr_saved (block), 2507 ffestw_do_count_var (block)); 2508#else 2509#error 2510#endif 2511} 2512 2513/* End of statement following logical IF. 2514 2515 Applies to *only* logical IF, not to IF-THEN. */ 2516 2517void 2518ffeste_end_R807 () 2519{ 2520#if FFECOM_targetCURRENT == FFECOM_targetFFE 2521 fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */ 2522#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2523 ffeste_emit_line_note_ (); 2524 2525 expand_end_cond (); 2526 2527 ffeste_end_block_ (NULL); 2528#else 2529#error 2530#endif 2531} 2532 2533/* Generate "code" for branch label definition. */ 2534 2535void 2536ffeste_labeldef_branch (ffelab label) 2537{ 2538#if FFECOM_targetCURRENT == FFECOM_targetFFE 2539 fprintf (dmpout, "+ label %lu\n", ffelab_value (label)); 2540#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2541 { 2542 tree glabel; 2543 2544 glabel = ffecom_lookup_label (label); 2545 assert (glabel != NULL_TREE); 2546 if (TREE_CODE (glabel) == ERROR_MARK) 2547 return; 2548 2549 assert (DECL_INITIAL (glabel) == NULL_TREE); 2550 2551 DECL_INITIAL (glabel) = error_mark_node; 2552 DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label); 2553 DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label); 2554 2555 emit_nop (); 2556 2557 expand_label (glabel); 2558 } 2559#else 2560#error 2561#endif 2562} 2563 2564/* Generate "code" for FORMAT label definition. */ 2565 2566void 2567ffeste_labeldef_format (ffelab label) 2568{ 2569#if FFECOM_targetCURRENT == FFECOM_targetFFE 2570 fprintf (dmpout, "$ label %lu\n", ffelab_value (label)); 2571#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2572 ffeste_label_formatdef_ = label; 2573#else 2574#error 2575#endif 2576} 2577 2578/* Assignment statement (outside of WHERE). */ 2579 2580void 2581ffeste_R737A (ffebld dest, ffebld source) 2582{ 2583 ffeste_check_simple_ (); 2584 2585#if FFECOM_targetCURRENT == FFECOM_targetFFE 2586 fputs ("+ let ", dmpout); 2587 ffebld_dump (dest); 2588 fputs ("=", dmpout); 2589 ffebld_dump (source); 2590 fputc ('\n', dmpout); 2591#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2592 ffeste_emit_line_note_ (); 2593 2594 ffeste_start_stmt_ (); 2595 2596 ffecom_expand_let_stmt (dest, source); 2597 2598 ffeste_end_stmt_ (); 2599#else 2600#error 2601#endif 2602} 2603 2604/* Block IF (IF-THEN) statement. */ 2605 2606void 2607ffeste_R803 (ffestw block, ffebld expr) 2608{ 2609 ffeste_check_simple_ (); 2610 2611#if FFECOM_targetCURRENT == FFECOM_targetFFE 2612 fputs ("+ IF_block (", dmpout); 2613 ffebld_dump (expr); 2614 fputs (")\n", dmpout); 2615#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2616 { 2617 tree temp; 2618 2619 ffeste_emit_line_note_ (); 2620 2621 ffeste_start_block_ (block); 2622 2623 temp = ffecom_make_tempvar ("ifthen", integer_type_node, 2624 FFETARGET_charactersizeNONE, -1); 2625 2626 ffeste_start_stmt_ (); 2627 2628 ffecom_prepare_expr (expr); 2629 2630 if (ffecom_prepare_end ()) 2631 { 2632 tree result; 2633 2634 result = ffecom_modify (void_type_node, 2635 temp, 2636 ffecom_truth_value (ffecom_expr (expr))); 2637 2638 expand_expr_stmt (result); 2639 2640 ffeste_end_stmt_ (); 2641 } 2642 else 2643 { 2644 ffeste_end_stmt_ (); 2645 2646 temp = ffecom_truth_value (ffecom_expr (expr)); 2647 } 2648 2649 expand_start_cond (temp, 0); 2650 2651 /* No fake `else' constructs introduced (yet). */ 2652 ffestw_set_ifthen_fake_else (block, 0); 2653 } 2654#else 2655#error 2656#endif 2657} 2658 2659/* ELSE IF statement. */ 2660 2661void 2662ffeste_R804 (ffestw block, ffebld expr) 2663{ 2664 ffeste_check_simple_ (); 2665 2666#if FFECOM_targetCURRENT == FFECOM_targetFFE 2667 fputs ("+ ELSE_IF (", dmpout); 2668 ffebld_dump (expr); 2669 fputs (")\n", dmpout); 2670#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2671 { 2672 tree temp; 2673 2674 ffeste_emit_line_note_ (); 2675 2676 /* Since ELSEIF(expr) might require preparations for expr, 2677 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */ 2678 2679 expand_start_else (); 2680 2681 ffeste_start_block_ (block); 2682 2683 temp = ffecom_make_tempvar ("elseif", integer_type_node, 2684 FFETARGET_charactersizeNONE, -1); 2685 2686 ffeste_start_stmt_ (); 2687 2688 ffecom_prepare_expr (expr); 2689 2690 if (ffecom_prepare_end ()) 2691 { 2692 tree result; 2693 2694 result = ffecom_modify (void_type_node, 2695 temp, 2696 ffecom_truth_value (ffecom_expr (expr))); 2697 2698 expand_expr_stmt (result); 2699 2700 ffeste_end_stmt_ (); 2701 } 2702 else 2703 { 2704 /* In this case, we could probably have used expand_start_elseif 2705 instead, saving the need for a fake `else' construct. But, 2706 until it's clear that'd improve performance, it's easier this 2707 way, since we have to expand_start_else before we get to this 2708 test, given the current design. */ 2709 2710 ffeste_end_stmt_ (); 2711 2712 temp = ffecom_truth_value (ffecom_expr (expr)); 2713 } 2714 2715 expand_start_cond (temp, 0); 2716 2717 /* Increment number of fake `else' constructs introduced. */ 2718 ffestw_set_ifthen_fake_else (block, 2719 ffestw_ifthen_fake_else (block) + 1); 2720 } 2721#else 2722#error 2723#endif 2724} 2725 2726/* ELSE statement. */ 2727 2728void 2729ffeste_R805 (ffestw block UNUSED) 2730{ 2731 ffeste_check_simple_ (); 2732 2733#if FFECOM_targetCURRENT == FFECOM_targetFFE 2734 fputs ("+ ELSE\n", dmpout); 2735#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2736 ffeste_emit_line_note_ (); 2737 2738 expand_start_else (); 2739#else 2740#error 2741#endif 2742} 2743 2744/* END IF statement. */ 2745 2746void 2747ffeste_R806 (ffestw block) 2748{ 2749#if FFECOM_targetCURRENT == FFECOM_targetFFE 2750 fputs ("+ END_IF_then\n", dmpout); /* Also see ffeste_shriek_if_. */ 2751#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2752 { 2753 int i = ffestw_ifthen_fake_else (block) + 1; 2754 2755 ffeste_emit_line_note_ (); 2756 2757 for (; i; --i) 2758 { 2759 expand_end_cond (); 2760 2761 ffeste_end_block_ (block); 2762 } 2763 } 2764#else 2765#error 2766#endif 2767} 2768 2769/* Logical IF statement. */ 2770 2771void 2772ffeste_R807 (ffebld expr) 2773{ 2774 ffeste_check_simple_ (); 2775 2776#if FFECOM_targetCURRENT == FFECOM_targetFFE 2777 fputs ("+ IF_logical (", dmpout); 2778 ffebld_dump (expr); 2779 fputs (")\n", dmpout); 2780#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2781 { 2782 tree temp; 2783 2784 ffeste_emit_line_note_ (); 2785 2786 ffeste_start_block_ (NULL); 2787 2788 temp = ffecom_make_tempvar ("if", integer_type_node, 2789 FFETARGET_charactersizeNONE, -1); 2790 2791 ffeste_start_stmt_ (); 2792 2793 ffecom_prepare_expr (expr); 2794 2795 if (ffecom_prepare_end ()) 2796 { 2797 tree result; 2798 2799 result = ffecom_modify (void_type_node, 2800 temp, 2801 ffecom_truth_value (ffecom_expr (expr))); 2802 2803 expand_expr_stmt (result); 2804 2805 ffeste_end_stmt_ (); 2806 } 2807 else 2808 { 2809 ffeste_end_stmt_ (); 2810 2811 temp = ffecom_truth_value (ffecom_expr (expr)); 2812 } 2813 2814 expand_start_cond (temp, 0); 2815 } 2816#else 2817#error 2818#endif 2819} 2820 2821/* SELECT CASE statement. */ 2822 2823void 2824ffeste_R809 (ffestw block, ffebld expr) 2825{ 2826 ffeste_check_simple_ (); 2827 2828#if FFECOM_targetCURRENT == FFECOM_targetFFE 2829 fputs ("+ SELECT_CASE (", dmpout); 2830 ffebld_dump (expr); 2831 fputs (")\n", dmpout); 2832#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2833 ffeste_emit_line_note_ (); 2834 2835 ffeste_start_block_ (block); 2836 2837 if ((expr == NULL) 2838 || (ffeinfo_basictype (ffebld_info (expr)) 2839 == FFEINFO_basictypeANY)) 2840 ffestw_set_select_texpr (block, error_mark_node); 2841 else if (ffeinfo_basictype (ffebld_info (expr)) 2842 == FFEINFO_basictypeCHARACTER) 2843 { 2844 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */ 2845 2846 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry", 2847 FFEBAD_severityFATAL); 2848 ffebad_here (0, ffestw_line (block), ffestw_col (block)); 2849 ffebad_finish (); 2850 ffestw_set_select_texpr (block, error_mark_node); 2851 } 2852 else 2853 { 2854 tree result; 2855 tree texpr; 2856 2857 result = ffecom_make_tempvar ("select", ffecom_type_expr (expr), 2858 ffeinfo_size (ffebld_info (expr)), 2859 -1); 2860 2861 ffeste_start_stmt_ (); 2862 2863 ffecom_prepare_expr (expr); 2864 2865 ffecom_prepare_end (); 2866 2867 texpr = ffecom_expr (expr); 2868 2869 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr)) 2870 == TYPE_MAIN_VARIANT (TREE_TYPE (result))); 2871 2872 texpr = ffecom_modify (void_type_node, 2873 result, 2874 texpr); 2875 expand_expr_stmt (texpr); 2876 2877 ffeste_end_stmt_ (); 2878 2879 expand_start_case (1, result, TREE_TYPE (result), 2880 "SELECT CASE statement"); 2881 ffestw_set_select_texpr (block, texpr); 2882 ffestw_set_select_break (block, FALSE); 2883 } 2884#else 2885#error 2886#endif 2887} 2888 2889/* CASE statement. 2890 2891 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at 2892 the start of the first_stmt list in the select object at the top of 2893 the stack that match casenum. */ 2894 2895void 2896ffeste_R810 (ffestw block, unsigned long casenum) 2897{ 2898 ffestwSelect s = ffestw_select (block); 2899 ffestwCase c; 2900 2901 ffeste_check_simple_ (); 2902 2903 if (s->first_stmt == (ffestwCase) &s->first_rel) 2904 c = NULL; 2905 else 2906 c = s->first_stmt; 2907 2908#if FFECOM_targetCURRENT == FFECOM_targetFFE 2909 if ((c == NULL) || (casenum != c->casenum)) 2910 { 2911 if (casenum == 0) /* Intentional CASE DEFAULT. */ 2912 fputs ("+ CASE_DEFAULT", dmpout); 2913 } 2914 else 2915 { 2916 bool comma = FALSE; 2917 2918 fputs ("+ CASE (", dmpout); 2919 do 2920 { 2921 if (comma) 2922 fputc (',', dmpout); 2923 else 2924 comma = TRUE; 2925 if (c->low != NULL) 2926 ffebld_constant_dump (c->low); 2927 if (c->low != c->high) 2928 { 2929 fputc (':', dmpout); 2930 if (c->high != NULL) 2931 ffebld_constant_dump (c->high); 2932 } 2933 c = c->next_stmt; 2934 /* Unlink prev. */ 2935 c->previous_stmt->previous_stmt->next_stmt = c; 2936 c->previous_stmt = c->previous_stmt->previous_stmt; 2937 } 2938 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum)); 2939 fputc (')', dmpout); 2940 } 2941 2942 fputc ('\n', dmpout); 2943#elif FFECOM_targetCURRENT == FFECOM_targetGCC 2944 { 2945 tree texprlow; 2946 tree texprhigh; 2947 tree tlabel; 2948 int pushok; 2949 tree duplicate; 2950 2951 ffeste_emit_line_note_ (); 2952 2953 if (ffestw_select_texpr (block) == error_mark_node) 2954 return; 2955 2956 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */ 2957 2958 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); 2959 2960 if (ffestw_select_break (block)) 2961 expand_exit_something (); 2962 else 2963 ffestw_set_select_break (block, TRUE); 2964 2965 if ((c == NULL) || (casenum != c->casenum)) 2966 { 2967 if (casenum == 0) /* Intentional CASE DEFAULT. */ 2968 { 2969 pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate); 2970 assert (pushok == 0); 2971 } 2972 } 2973 else 2974 do 2975 { 2976 texprlow = (c->low == NULL) ? NULL_TREE 2977 : ffecom_constantunion (&ffebld_constant_union (c->low), s->type, 2978 s->kindtype, ffecom_tree_type[s->type][s->kindtype]); 2979 if (c->low != c->high) 2980 { 2981 texprhigh = (c->high == NULL) ? NULL_TREE 2982 : ffecom_constantunion (&ffebld_constant_union (c->high), 2983 s->type, s->kindtype, ffecom_tree_type[s->type][s->kindtype]); 2984 pushok = pushcase_range (texprlow, texprhigh, convert, 2985 tlabel, &duplicate); 2986 } 2987 else 2988 pushok = pushcase (texprlow, convert, tlabel, &duplicate); 2989 assert (pushok == 0); 2990 c = c->next_stmt; 2991 /* Unlink prev. */ 2992 c->previous_stmt->previous_stmt->next_stmt = c; 2993 c->previous_stmt = c->previous_stmt->previous_stmt; 2994 } 2995 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum)); 2996 2997 clear_momentary (); 2998 } 2999#else 3000#error 3001#endif 3002} 3003 3004/* END SELECT statement. */ 3005 3006void 3007ffeste_R811 (ffestw block) 3008{ 3009#if FFECOM_targetCURRENT == FFECOM_targetFFE 3010 fputs ("+ END_SELECT\n", dmpout); 3011#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3012 ffeste_emit_line_note_ (); 3013 3014 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */ 3015 3016 if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK) 3017 expand_end_case (ffestw_select_texpr (block)); 3018 3019 ffeste_end_block_ (block); 3020#else 3021#error 3022#endif 3023} 3024 3025/* Iterative DO statement. */ 3026 3027void 3028ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var, 3029 ffebld start, ffelexToken start_token, 3030 ffebld end, ffelexToken end_token, 3031 ffebld incr, ffelexToken incr_token) 3032{ 3033 ffeste_check_simple_ (); 3034 3035#if FFECOM_targetCURRENT == FFECOM_targetFFE 3036 if ((ffebld_op (incr) == FFEBLD_opCONTER) 3037 && (ffebld_constant_is_zero (ffebld_conter (incr)))) 3038 { 3039 ffebad_start (FFEBAD_DO_STEP_ZERO); 3040 ffebad_here (0, ffelex_token_where_line (incr_token), 3041 ffelex_token_where_column (incr_token)); 3042 ffebad_string ("Iterative DO loop"); 3043 ffebad_finish (); 3044 /* Don't bother replacing it with 1 yet. */ 3045 } 3046 3047 if (label == NULL) 3048 fputs ("+ DO_iterative_nonlabeled (", dmpout); 3049 else 3050 fprintf (dmpout, "+ DO_iterative_labeled %lu (", ffelab_value (label)); 3051 ffebld_dump (var); 3052 fputc ('=', dmpout); 3053 ffebld_dump (start); 3054 fputc (',', dmpout); 3055 ffebld_dump (end); 3056 fputc (',', dmpout); 3057 ffebld_dump (incr); 3058 fputs (")\n", dmpout); 3059#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3060 { 3061 ffeste_emit_line_note_ (); 3062 3063 ffeste_begin_iterdo_ (block, NULL, NULL, NULL, 3064 var, 3065 start, start_token, 3066 end, end_token, 3067 incr, incr_token, 3068 "Iterative DO loop"); 3069 } 3070#else 3071#error 3072#endif 3073} 3074 3075/* DO WHILE statement. */ 3076 3077void 3078ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr) 3079{ 3080 ffeste_check_simple_ (); 3081 3082#if FFECOM_targetCURRENT == FFECOM_targetFFE 3083 if (label == NULL) 3084 fputs ("+ DO_WHILE_nonlabeled (", dmpout); 3085 else 3086 fprintf (dmpout, "+ DO_WHILE_labeled %lu (", ffelab_value (label)); 3087 ffebld_dump (expr); 3088 fputs (")\n", dmpout); 3089#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3090 { 3091 tree result; 3092 3093 ffeste_emit_line_note_ (); 3094 3095 ffeste_start_block_ (block); 3096 3097 if (expr) 3098 { 3099 struct nesting *loop; 3100 tree mod; 3101 3102 result = ffecom_make_tempvar ("dowhile", integer_type_node, 3103 FFETARGET_charactersizeNONE, -1); 3104 loop = expand_start_loop (1); 3105 3106 ffeste_start_stmt_ (); 3107 3108 ffecom_prepare_expr (expr); 3109 3110 ffecom_prepare_end (); 3111 3112 mod = ffecom_modify (void_type_node, 3113 result, 3114 ffecom_truth_value (ffecom_expr (expr))); 3115 expand_expr_stmt (mod); 3116 3117 ffeste_end_stmt_ (); 3118 3119 ffestw_set_do_hook (block, loop); 3120 expand_exit_loop_if_false (0, result); 3121 } 3122 else 3123 ffestw_set_do_hook (block, expand_start_loop (1)); 3124 3125 ffestw_set_do_tvar (block, NULL_TREE); 3126 } 3127#else 3128#error 3129#endif 3130} 3131 3132/* END DO statement. 3133 3134 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to 3135 CONTINUE (except that it has to have a label that is the target of 3136 one or more iterative DO statement), not the Fortran-90 structured 3137 END DO, which is handled elsewhere, as is the actual mechanism of 3138 ending an iterative DO statement, even one that ends at a label. */ 3139 3140void 3141ffeste_R825 () 3142{ 3143 ffeste_check_simple_ (); 3144 3145#if FFECOM_targetCURRENT == FFECOM_targetFFE 3146 fputs ("+ END_DO_sugar\n", dmpout); 3147#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3148 ffeste_emit_line_note_ (); 3149 3150 emit_nop (); 3151#else 3152#error 3153#endif 3154} 3155 3156/* CYCLE statement. */ 3157 3158void 3159ffeste_R834 (ffestw block) 3160{ 3161 ffeste_check_simple_ (); 3162 3163#if FFECOM_targetCURRENT == FFECOM_targetFFE 3164 fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block)); 3165#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3166 ffeste_emit_line_note_ (); 3167 3168 expand_continue_loop (ffestw_do_hook (block)); 3169#else 3170#error 3171#endif 3172} 3173 3174/* EXIT statement. */ 3175 3176void 3177ffeste_R835 (ffestw block) 3178{ 3179 ffeste_check_simple_ (); 3180 3181#if FFECOM_targetCURRENT == FFECOM_targetFFE 3182 fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block)); 3183#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3184 ffeste_emit_line_note_ (); 3185 3186 expand_exit_loop (ffestw_do_hook (block)); 3187#else 3188#error 3189#endif 3190} 3191 3192/* GOTO statement. */ 3193 3194void 3195ffeste_R836 (ffelab label) 3196{ 3197 ffeste_check_simple_ (); 3198 3199#if FFECOM_targetCURRENT == FFECOM_targetFFE 3200 fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label)); 3201#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3202 { 3203 tree glabel; 3204 3205 ffeste_emit_line_note_ (); 3206 3207 glabel = ffecom_lookup_label (label); 3208 if ((glabel != NULL_TREE) 3209 && (TREE_CODE (glabel) != ERROR_MARK)) 3210 { 3211 expand_goto (glabel); 3212 TREE_USED (glabel) = 1; 3213 } 3214 } 3215#else 3216#error 3217#endif 3218} 3219 3220/* Computed GOTO statement. */ 3221 3222void 3223ffeste_R837 (ffelab *labels, int count, ffebld expr) 3224{ 3225 int i; 3226 3227 ffeste_check_simple_ (); 3228 3229#if FFECOM_targetCURRENT == FFECOM_targetFFE 3230 fputs ("+ CGOTO (", dmpout); 3231 for (i = 0; i < count; ++i) 3232 { 3233 if (i != 0) 3234 fputc (',', dmpout); 3235 fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i])); 3236 } 3237 fputs ("),", dmpout); 3238 ffebld_dump (expr); 3239 fputc ('\n', dmpout); 3240#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3241 { 3242 tree texpr; 3243 tree value; 3244 tree tlabel; 3245 int pushok; 3246 tree duplicate; 3247 3248 ffeste_emit_line_note_ (); 3249 3250 ffeste_start_stmt_ (); 3251 3252 ffecom_prepare_expr (expr); 3253 3254 ffecom_prepare_end (); 3255 3256 texpr = ffecom_expr (expr); 3257 3258 expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement"); 3259 3260 for (i = 0; i < count; ++i) 3261 { 3262 value = build_int_2 (i + 1, 0); 3263 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); 3264 3265 pushok = pushcase (value, convert, tlabel, &duplicate); 3266 assert (pushok == 0); 3267 3268 tlabel = ffecom_lookup_label (labels[i]); 3269 if ((tlabel == NULL_TREE) 3270 || (TREE_CODE (tlabel) == ERROR_MARK)) 3271 continue; 3272 3273 expand_goto (tlabel); 3274 TREE_USED (tlabel) = 1; 3275 } 3276 expand_end_case (texpr); 3277 3278 ffeste_end_stmt_ (); 3279 } 3280#else 3281#error 3282#endif 3283} 3284 3285/* ASSIGN statement. */ 3286 3287void 3288ffeste_R838 (ffelab label, ffebld target) 3289{ 3290 ffeste_check_simple_ (); 3291 3292#if FFECOM_targetCURRENT == FFECOM_targetFFE 3293 fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label)); 3294 ffebld_dump (target); 3295 fputc ('\n', dmpout); 3296#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3297 { 3298 tree expr_tree; 3299 tree label_tree; 3300 tree target_tree; 3301 3302 ffeste_emit_line_note_ (); 3303 3304 /* No need to call ffeste_start_stmt_(), as the sorts of expressions 3305 seen here should never require use of temporaries. */ 3306 3307 label_tree = ffecom_lookup_label (label); 3308 if ((label_tree != NULL_TREE) 3309 && (TREE_CODE (label_tree) != ERROR_MARK)) 3310 { 3311 label_tree = ffecom_1 (ADDR_EXPR, 3312 build_pointer_type (void_type_node), 3313 label_tree); 3314 TREE_CONSTANT (label_tree) = 1; 3315 3316 target_tree = ffecom_expr_assign_w (target); 3317 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree))) 3318 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree)))) 3319 error ("ASSIGN to variable that is too small"); 3320 3321 label_tree = convert (TREE_TYPE (target_tree), label_tree); 3322 3323 expr_tree = ffecom_modify (void_type_node, 3324 target_tree, 3325 label_tree); 3326 expand_expr_stmt (expr_tree); 3327 3328 clear_momentary (); 3329 } 3330 } 3331#else 3332#error 3333#endif 3334} 3335 3336/* Assigned GOTO statement. */ 3337 3338void 3339ffeste_R839 (ffebld target) 3340{ 3341 ffeste_check_simple_ (); 3342 3343#if FFECOM_targetCURRENT == FFECOM_targetFFE 3344 fputs ("+ AGOTO ", dmpout); 3345 ffebld_dump (target); 3346 fputc ('\n', dmpout); 3347#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3348 { 3349 tree t; 3350 3351 ffeste_emit_line_note_ (); 3352 3353 /* No need to call ffeste_start_stmt_(), as the sorts of expressions 3354 seen here should never require use of temporaries. */ 3355 3356 t = ffecom_expr_assign (target); 3357 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t))) 3358 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) 3359 error ("ASSIGNed GOTO target variable is too small"); 3360 3361 expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t)); 3362 3363 clear_momentary (); 3364 } 3365#else 3366#error 3367#endif 3368} 3369 3370/* Arithmetic IF statement. */ 3371 3372void 3373ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) 3374{ 3375 ffeste_check_simple_ (); 3376 3377#if FFECOM_targetCURRENT == FFECOM_targetFFE 3378 fputs ("+ IF_arithmetic (", dmpout); 3379 ffebld_dump (expr); 3380 fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n", 3381 ffelab_value (neg), ffelab_value (zero), ffelab_value (pos)); 3382#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3383 { 3384 tree gneg = ffecom_lookup_label (neg); 3385 tree gzero = ffecom_lookup_label (zero); 3386 tree gpos = ffecom_lookup_label (pos); 3387 tree texpr; 3388 3389 ffeste_emit_line_note_ (); 3390 3391 if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE)) 3392 return; 3393 if ((TREE_CODE (gneg) == ERROR_MARK) 3394 || (TREE_CODE (gzero) == ERROR_MARK) 3395 || (TREE_CODE (gpos) == ERROR_MARK)) 3396 return; 3397 3398 ffeste_start_stmt_ (); 3399 3400 ffecom_prepare_expr (expr); 3401 3402 ffecom_prepare_end (); 3403 3404 if (neg == zero) 3405 { 3406 if (neg == pos) 3407 expand_goto (gzero); 3408 else 3409 { 3410 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */ 3411 texpr = ffecom_expr (expr); 3412 texpr = ffecom_2 (LE_EXPR, integer_type_node, 3413 texpr, 3414 convert (TREE_TYPE (texpr), 3415 integer_zero_node)); 3416 expand_start_cond (ffecom_truth_value (texpr), 0); 3417 expand_goto (gzero); 3418 expand_start_else (); 3419 expand_goto (gpos); 3420 expand_end_cond (); 3421 } 3422 } 3423 else if (neg == pos) 3424 { 3425 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */ 3426 texpr = ffecom_expr (expr); 3427 texpr = ffecom_2 (NE_EXPR, integer_type_node, 3428 texpr, 3429 convert (TREE_TYPE (texpr), 3430 integer_zero_node)); 3431 expand_start_cond (ffecom_truth_value (texpr), 0); 3432 expand_goto (gneg); 3433 expand_start_else (); 3434 expand_goto (gzero); 3435 expand_end_cond (); 3436 } 3437 else if (zero == pos) 3438 { 3439 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */ 3440 texpr = ffecom_expr (expr); 3441 texpr = ffecom_2 (GE_EXPR, integer_type_node, 3442 texpr, 3443 convert (TREE_TYPE (texpr), 3444 integer_zero_node)); 3445 expand_start_cond (ffecom_truth_value (texpr), 0); 3446 expand_goto (gzero); 3447 expand_start_else (); 3448 expand_goto (gneg); 3449 expand_end_cond (); 3450 } 3451 else 3452 { 3453 /* Use a SAVE_EXPR in combo with: 3454 IF (expr.LT.0) THEN GOTO neg 3455 ELSEIF (expr.GT.0) THEN GOTO pos 3456 ELSE GOTO zero. */ 3457 tree expr_saved = ffecom_save_tree (ffecom_expr (expr)); 3458 3459 texpr = ffecom_2 (LT_EXPR, integer_type_node, 3460 expr_saved, 3461 convert (TREE_TYPE (expr_saved), 3462 integer_zero_node)); 3463 expand_start_cond (ffecom_truth_value (texpr), 0); 3464 expand_goto (gneg); 3465 texpr = ffecom_2 (GT_EXPR, integer_type_node, 3466 expr_saved, 3467 convert (TREE_TYPE (expr_saved), 3468 integer_zero_node)); 3469 expand_start_elseif (ffecom_truth_value (texpr)); 3470 expand_goto (gpos); 3471 expand_start_else (); 3472 expand_goto (gzero); 3473 expand_end_cond (); 3474 } 3475 3476 ffeste_end_stmt_ (); 3477 } 3478#else 3479#error 3480#endif 3481} 3482 3483/* CONTINUE statement. */ 3484 3485void 3486ffeste_R841 () 3487{ 3488 ffeste_check_simple_ (); 3489 3490#if FFECOM_targetCURRENT == FFECOM_targetFFE 3491 fputs ("+ CONTINUE\n", dmpout); 3492#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3493 ffeste_emit_line_note_ (); 3494 3495 emit_nop (); 3496#else 3497#error 3498#endif 3499} 3500 3501/* STOP statement. */ 3502 3503void 3504ffeste_R842 (ffebld expr) 3505{ 3506 ffeste_check_simple_ (); 3507 3508#if FFECOM_targetCURRENT == FFECOM_targetFFE 3509 if (expr == NULL) 3510 { 3511 fputs ("+ STOP\n", dmpout); 3512 } 3513 else 3514 { 3515 fputs ("+ STOP_coded ", dmpout); 3516 ffebld_dump (expr); 3517 fputc ('\n', dmpout); 3518 } 3519#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3520 { 3521 tree callit; 3522 ffelexToken msg; 3523 3524 ffeste_emit_line_note_ (); 3525 3526 if ((expr == NULL) 3527 || (ffeinfo_basictype (ffebld_info (expr)) 3528 == FFEINFO_basictypeANY)) 3529 { 3530 msg = ffelex_token_new_character ("", ffelex_token_where_line 3531 (ffesta_tokens[0]), ffelex_token_where_column 3532 (ffesta_tokens[0])); 3533 expr = ffebld_new_conter (ffebld_constant_new_characterdefault 3534 (msg)); 3535 ffelex_token_kill (msg); 3536 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, 3537 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, 3538 FFEINFO_whereCONSTANT, 0)); 3539 } 3540 else if (ffeinfo_basictype (ffebld_info (expr)) 3541 == FFEINFO_basictypeINTEGER) 3542 { 3543 char num[50]; 3544 3545 assert (ffebld_op (expr) == FFEBLD_opCONTER); 3546 assert (ffeinfo_kindtype (ffebld_info (expr)) 3547 == FFEINFO_kindtypeINTEGERDEFAULT); 3548 sprintf (num, "%" ffetargetIntegerDefault_f "d", 3549 ffebld_constant_integer1 (ffebld_conter (expr))); 3550 msg = ffelex_token_new_character (num, ffelex_token_where_line 3551 (ffesta_tokens[0]), ffelex_token_where_column 3552 (ffesta_tokens[0])); 3553 expr = ffebld_new_conter (ffebld_constant_new_characterdefault 3554 (msg)); 3555 ffelex_token_kill (msg); 3556 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, 3557 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, 3558 FFEINFO_whereCONSTANT, 0)); 3559 } 3560 else 3561 { 3562 assert (ffeinfo_basictype (ffebld_info (expr)) 3563 == FFEINFO_basictypeCHARACTER); 3564 assert (ffebld_op (expr) == FFEBLD_opCONTER); 3565 assert (ffeinfo_kindtype (ffebld_info (expr)) 3566 == FFEINFO_kindtypeCHARACTERDEFAULT); 3567 } 3568 3569 /* No need to call ffeste_start_stmt_(), as the sorts of expressions 3570 seen here should never require use of temporaries. */ 3571 3572 callit = ffecom_call_gfrt (FFECOM_gfrtSTOP, 3573 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)), 3574 NULL_TREE); 3575 TREE_SIDE_EFFECTS (callit) = 1; 3576 3577 expand_expr_stmt (callit); 3578 3579 clear_momentary (); 3580 } 3581#else 3582#error 3583#endif 3584} 3585 3586/* PAUSE statement. */ 3587 3588void 3589ffeste_R843 (ffebld expr) 3590{ 3591 ffeste_check_simple_ (); 3592 3593#if FFECOM_targetCURRENT == FFECOM_targetFFE 3594 if (expr == NULL) 3595 { 3596 fputs ("+ PAUSE\n", dmpout); 3597 } 3598 else 3599 { 3600 fputs ("+ PAUSE_coded ", dmpout); 3601 ffebld_dump (expr); 3602 fputc ('\n', dmpout); 3603 } 3604#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3605 { 3606 tree callit; 3607 ffelexToken msg; 3608 3609 ffeste_emit_line_note_ (); 3610 3611 if ((expr == NULL) 3612 || (ffeinfo_basictype (ffebld_info (expr)) 3613 == FFEINFO_basictypeANY)) 3614 { 3615 msg = ffelex_token_new_character ("", ffelex_token_where_line 3616 (ffesta_tokens[0]), ffelex_token_where_column 3617 (ffesta_tokens[0])); 3618 expr = ffebld_new_conter (ffebld_constant_new_characterdefault 3619 (msg)); 3620 ffelex_token_kill (msg); 3621 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, 3622 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, 3623 FFEINFO_whereCONSTANT, 0)); 3624 } 3625 else if (ffeinfo_basictype (ffebld_info (expr)) 3626 == FFEINFO_basictypeINTEGER) 3627 { 3628 char num[50]; 3629 3630 assert (ffebld_op (expr) == FFEBLD_opCONTER); 3631 assert (ffeinfo_kindtype (ffebld_info (expr)) 3632 == FFEINFO_kindtypeINTEGERDEFAULT); 3633 sprintf (num, "%" ffetargetIntegerDefault_f "d", 3634 ffebld_constant_integer1 (ffebld_conter (expr))); 3635 msg = ffelex_token_new_character (num, ffelex_token_where_line 3636 (ffesta_tokens[0]), ffelex_token_where_column 3637 (ffesta_tokens[0])); 3638 expr = ffebld_new_conter (ffebld_constant_new_characterdefault 3639 (msg)); 3640 ffelex_token_kill (msg); 3641 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, 3642 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, 3643 FFEINFO_whereCONSTANT, 0)); 3644 } 3645 else 3646 { 3647 assert (ffeinfo_basictype (ffebld_info (expr)) 3648 == FFEINFO_basictypeCHARACTER); 3649 assert (ffebld_op (expr) == FFEBLD_opCONTER); 3650 assert (ffeinfo_kindtype (ffebld_info (expr)) 3651 == FFEINFO_kindtypeCHARACTERDEFAULT); 3652 } 3653 3654 /* No need to call ffeste_start_stmt_(), as the sorts of expressions 3655 seen here should never require use of temporaries. */ 3656 3657 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE, 3658 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)), 3659 NULL_TREE); 3660 TREE_SIDE_EFFECTS (callit) = 1; 3661 3662 expand_expr_stmt (callit); 3663 3664 clear_momentary (); 3665 } 3666#if 0 /* Old approach for phantom g77 run-time 3667 library. */ 3668 { 3669 tree callit; 3670 3671 ffeste_emit_line_note_ (); 3672 3673 if (expr == NULL) 3674 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE, NULL_TREE); 3675 else if (ffeinfo_basictype (ffebld_info (expr)) 3676 == FFEINFO_basictypeINTEGER) 3677 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT, 3678 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)), 3679 NULL_TREE); 3680 else if (ffeinfo_basictype (ffebld_info (expr)) 3681 == FFEINFO_basictypeCHARACTER) 3682 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR, 3683 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)), 3684 NULL_TREE); 3685 else 3686 abort (); 3687 TREE_SIDE_EFFECTS (callit) = 1; 3688 3689 expand_expr_stmt (callit); 3690 3691 clear_momentary (); 3692 } 3693#endif 3694#else 3695#error 3696#endif 3697} 3698 3699/* OPEN statement. */ 3700 3701void 3702ffeste_R904 (ffestpOpenStmt *info) 3703{ 3704 ffeste_check_simple_ (); 3705 3706#if FFECOM_targetCURRENT == FFECOM_targetFFE 3707 fputs ("+ OPEN (", dmpout); 3708 ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]); 3709 ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]); 3710 ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]); 3711 ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]); 3712 ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]); 3713 ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]); 3714 ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]); 3715 ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]); 3716 ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]); 3717 ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]); 3718 ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]); 3719 ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]); 3720 ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]); 3721 ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]); 3722 ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]); 3723 ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]); 3724 ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]); 3725 ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]); 3726 ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]); 3727 ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]); 3728 ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]); 3729 ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]); 3730 ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]); 3731 ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]); 3732 ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]); 3733 ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]); 3734 ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]); 3735 ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]); 3736 ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]); 3737 fputs (")\n", dmpout); 3738#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3739 { 3740 tree args; 3741 bool iostat; 3742 bool errl; 3743 3744 ffeste_emit_line_note_ (); 3745 3746#define specified(something) (info->open_spec[something].kw_or_val_present) 3747 3748 iostat = specified (FFESTP_openixIOSTAT); 3749 errl = specified (FFESTP_openixERR); 3750 3751#undef specified 3752 3753 ffeste_start_stmt_ (); 3754 3755 if (errl) 3756 { 3757 ffeste_io_err_ 3758 = ffeste_io_abort_ 3759 = ffecom_lookup_label 3760 (info->open_spec[FFESTP_openixERR].u.label); 3761 ffeste_io_abort_is_temp_ = FALSE; 3762 } 3763 else 3764 { 3765 ffeste_io_err_ = NULL_TREE; 3766 3767 if ((ffeste_io_abort_is_temp_ = iostat)) 3768 ffeste_io_abort_ = ffecom_temp_label (); 3769 else 3770 ffeste_io_abort_ = NULL_TREE; 3771 } 3772 3773 if (iostat) 3774 { 3775 /* Have IOSTAT= specification. */ 3776 3777 ffeste_io_iostat_is_temp_ = FALSE; 3778 ffeste_io_iostat_ = ffecom_expr 3779 (info->open_spec[FFESTP_openixIOSTAT].u.expr); 3780 } 3781 else if (ffeste_io_abort_ != NULL_TREE) 3782 { 3783 /* Have no IOSTAT= but have ERR=. */ 3784 3785 ffeste_io_iostat_is_temp_ = TRUE; 3786 ffeste_io_iostat_ 3787 = ffecom_make_tempvar ("open", ffecom_integer_type_node, 3788 FFETARGET_charactersizeNONE, -1); 3789 } 3790 else 3791 { 3792 /* No IOSTAT= or ERR= specification. */ 3793 3794 ffeste_io_iostat_is_temp_ = FALSE; 3795 ffeste_io_iostat_ = NULL_TREE; 3796 } 3797 3798 /* Now prescan, then convert, all the arguments. */ 3799 3800 args = ffeste_io_olist_ (errl || iostat, 3801 info->open_spec[FFESTP_openixUNIT].u.expr, 3802 &info->open_spec[FFESTP_openixFILE], 3803 &info->open_spec[FFESTP_openixSTATUS], 3804 &info->open_spec[FFESTP_openixACCESS], 3805 &info->open_spec[FFESTP_openixFORM], 3806 &info->open_spec[FFESTP_openixRECL], 3807 &info->open_spec[FFESTP_openixBLANK]); 3808 3809 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort 3810 label, since we're gonna fall through to there anyway. */ 3811 3812 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE), 3813 ! ffeste_io_abort_is_temp_); 3814 3815 /* If we've got a temp label, generate its code here. */ 3816 3817 if (ffeste_io_abort_is_temp_) 3818 { 3819 DECL_INITIAL (ffeste_io_abort_) = error_mark_node; 3820 emit_nop (); 3821 expand_label (ffeste_io_abort_); 3822 3823 assert (ffeste_io_err_ == NULL_TREE); 3824 } 3825 3826 ffeste_end_stmt_ (); 3827 } 3828#else 3829#error 3830#endif 3831} 3832 3833/* CLOSE statement. */ 3834 3835void 3836ffeste_R907 (ffestpCloseStmt *info) 3837{ 3838 ffeste_check_simple_ (); 3839 3840#if FFECOM_targetCURRENT == FFECOM_targetFFE 3841 fputs ("+ CLOSE (", dmpout); 3842 ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]); 3843 ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]); 3844 ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]); 3845 ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]); 3846 fputs (")\n", dmpout); 3847#elif FFECOM_targetCURRENT == FFECOM_targetGCC 3848 { 3849 tree args; 3850 bool iostat; 3851 bool errl; 3852 3853 ffeste_emit_line_note_ (); 3854 3855#define specified(something) (info->close_spec[something].kw_or_val_present) 3856 3857 iostat = specified (FFESTP_closeixIOSTAT); 3858 errl = specified (FFESTP_closeixERR); 3859 3860#undef specified 3861 3862 ffeste_start_stmt_ (); 3863 3864 if (errl) 3865 { 3866 ffeste_io_err_ 3867 = ffeste_io_abort_ 3868 = ffecom_lookup_label 3869 (info->close_spec[FFESTP_closeixERR].u.label); 3870 ffeste_io_abort_is_temp_ = FALSE; 3871 } 3872 else 3873 { 3874 ffeste_io_err_ = NULL_TREE; 3875 3876 if ((ffeste_io_abort_is_temp_ = iostat)) 3877 ffeste_io_abort_ = ffecom_temp_label (); 3878 else 3879 ffeste_io_abort_ = NULL_TREE; 3880 } 3881 3882 if (iostat) 3883 { 3884 /* Have IOSTAT= specification. */ 3885 3886 ffeste_io_iostat_is_temp_ = FALSE; 3887 ffeste_io_iostat_ = ffecom_expr 3888 (info->close_spec[FFESTP_closeixIOSTAT].u.expr); 3889 } 3890 else if (ffeste_io_abort_ != NULL_TREE) 3891 { 3892 /* Have no IOSTAT= but have ERR=. */ 3893 3894 ffeste_io_iostat_is_temp_ = TRUE; 3895 ffeste_io_iostat_ 3896 = ffecom_make_tempvar ("close", ffecom_integer_type_node, 3897 FFETARGET_charactersizeNONE, -1); 3898 } 3899 else 3900 { 3901 /* No IOSTAT= or ERR= specification. */ 3902 3903 ffeste_io_iostat_is_temp_ = FALSE; 3904 ffeste_io_iostat_ = NULL_TREE; 3905 } 3906 3907 /* Now prescan, then convert, all the arguments. */ 3908 3909 args = ffeste_io_cllist_ (errl || iostat, 3910 info->close_spec[FFESTP_closeixUNIT].u.expr, 3911 &info->close_spec[FFESTP_closeixSTATUS]); 3912 3913 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort 3914 label, since we're gonna fall through to there anyway. */ 3915 3916 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE), 3917 ! ffeste_io_abort_is_temp_); 3918 3919 /* If we've got a temp label, generate its code here. */ 3920 3921 if (ffeste_io_abort_is_temp_) 3922 { 3923 DECL_INITIAL (ffeste_io_abort_) = error_mark_node; 3924 emit_nop (); 3925 expand_label (ffeste_io_abort_); 3926 3927 assert (ffeste_io_err_ == NULL_TREE); 3928 } 3929 3930 ffeste_end_stmt_ (); 3931 } 3932#else 3933#error 3934#endif 3935} 3936 3937/* READ(...) statement -- start. */ 3938 3939void 3940ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED, 3941 ffestvUnit unit, ffestvFormat format, bool rec, 3942 bool key UNUSED) 3943{ 3944 ffeste_check_start_ (); 3945 3946#if FFECOM_targetCURRENT == FFECOM_targetFFE 3947 switch (format) 3948 { 3949 case FFESTV_formatNONE: 3950 if (rec) 3951 fputs ("+ READ_ufdac", dmpout); 3952 else if (key) 3953 fputs ("+ READ_ufidx", dmpout); 3954 else 3955 fputs ("+ READ_ufseq", dmpout); 3956 break; 3957 3958 case FFESTV_formatLABEL: 3959 case FFESTV_formatCHAREXPR: 3960 case FFESTV_formatINTEXPR: 3961 if (rec) 3962 fputs ("+ READ_fmdac", dmpout); 3963 else if (key) 3964 fputs ("+ READ_fmidx", dmpout); 3965 else if (unit == FFESTV_unitCHAREXPR) 3966 fputs ("+ READ_fmint", dmpout); 3967 else 3968 fputs ("+ READ_fmseq", dmpout); 3969 break; 3970 3971 case FFESTV_formatASTERISK: 3972 if (unit == FFESTV_unitCHAREXPR) 3973 fputs ("+ READ_lsint", dmpout); 3974 else 3975 fputs ("+ READ_lsseq", dmpout); 3976 break; 3977 3978 case FFESTV_formatNAMELIST: 3979 fputs ("+ READ_nlseq", dmpout); 3980 break; 3981 3982 default: 3983 assert ("Unexpected kind of format item in R909 READ" == NULL); 3984 } 3985 3986 if (only_format) 3987 { 3988 fputc (' ', dmpout); 3989 ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]); 3990 fputc (' ', dmpout); 3991 3992 return; 3993 } 3994 3995 fputs (" (", dmpout); 3996 ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]); 3997 ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]); 3998 ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]); 3999 ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]); 4000 ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]); 4001 ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]); 4002 ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]); 4003 ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]); 4004 ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]); 4005 ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]); 4006 ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]); 4007 ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]); 4008 ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]); 4009 ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]); 4010 fputs (") ", dmpout); 4011#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4012 4013 ffeste_emit_line_note_ (); 4014 4015 { 4016 ffecomGfrt start; 4017 ffecomGfrt end; 4018 tree cilist; 4019 bool iostat; 4020 bool errl; 4021 bool endl; 4022 4023 /* First determine the start, per-item, and end run-time functions to 4024 call. The per-item function is picked by choosing an ffeste function 4025 to call to handle a given item; it knows how to generate a call to the 4026 appropriate run-time function, and is called an "I/O driver". */ 4027 4028 switch (format) 4029 { 4030 case FFESTV_formatNONE: /* no FMT= */ 4031 ffeste_io_driver_ = ffeste_io_douio_; 4032 if (rec) 4033 start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE; 4034#if 0 4035 else if (key) 4036 start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE; 4037#endif 4038 else 4039 start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE; 4040 break; 4041 4042 case FFESTV_formatLABEL: /* FMT=10 */ 4043 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */ 4044 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */ 4045 ffeste_io_driver_ = ffeste_io_dofio_; 4046 if (rec) 4047 start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE; 4048#if 0 4049 else if (key) 4050 start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE; 4051#endif 4052 else if (unit == FFESTV_unitCHAREXPR) 4053 start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI; 4054 else 4055 start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE; 4056 break; 4057 4058 case FFESTV_formatASTERISK: /* FMT=* */ 4059 ffeste_io_driver_ = ffeste_io_dolio_; 4060 if (unit == FFESTV_unitCHAREXPR) 4061 start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI; 4062 else 4063 start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE; 4064 break; 4065 4066 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST 4067 /FOO/] */ 4068 ffeste_io_driver_ = NULL; /* No start or driver function. */ 4069 start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt; 4070 break; 4071 4072 default: 4073 assert ("Weird stuff" == NULL); 4074 start = FFECOM_gfrt, end = FFECOM_gfrt; 4075 break; 4076 } 4077 ffeste_io_endgfrt_ = end; 4078 4079#define specified(something) (info->read_spec[something].kw_or_val_present) 4080 4081 iostat = specified (FFESTP_readixIOSTAT); 4082 errl = specified (FFESTP_readixERR); 4083 endl = specified (FFESTP_readixEND); 4084 4085#undef specified 4086 4087 ffeste_start_stmt_ (); 4088 4089 if (errl) 4090 { 4091 /* Have ERR= specification. */ 4092 4093 ffeste_io_err_ 4094 = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label); 4095 4096 if (endl) 4097 { 4098 /* Have both ERR= and END=. Need a temp label to handle both. */ 4099 ffeste_io_end_ 4100 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label); 4101 ffeste_io_abort_is_temp_ = TRUE; 4102 ffeste_io_abort_ = ffecom_temp_label (); 4103 } 4104 else 4105 { 4106 /* Have ERR= but no END=. */ 4107 ffeste_io_end_ = NULL_TREE; 4108 if ((ffeste_io_abort_is_temp_ = iostat)) 4109 ffeste_io_abort_ = ffecom_temp_label (); 4110 else 4111 ffeste_io_abort_ = ffeste_io_err_; 4112 } 4113 } 4114 else 4115 { 4116 /* No ERR= specification. */ 4117 4118 ffeste_io_err_ = NULL_TREE; 4119 if (endl) 4120 { 4121 /* Have END= but no ERR=. */ 4122 ffeste_io_end_ 4123 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label); 4124 if ((ffeste_io_abort_is_temp_ = iostat)) 4125 ffeste_io_abort_ = ffecom_temp_label (); 4126 else 4127 ffeste_io_abort_ = ffeste_io_end_; 4128 } 4129 else 4130 { 4131 /* Have no ERR= or END=. */ 4132 4133 ffeste_io_end_ = NULL_TREE; 4134 if ((ffeste_io_abort_is_temp_ = iostat)) 4135 ffeste_io_abort_ = ffecom_temp_label (); 4136 else 4137 ffeste_io_abort_ = NULL_TREE; 4138 } 4139 } 4140 4141 if (iostat) 4142 { 4143 /* Have IOSTAT= specification. */ 4144 4145 ffeste_io_iostat_is_temp_ = FALSE; 4146 ffeste_io_iostat_ 4147 = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr); 4148 } 4149 else if (ffeste_io_abort_ != NULL_TREE) 4150 { 4151 /* Have no IOSTAT= but have ERR= and/or END=. */ 4152 4153 ffeste_io_iostat_is_temp_ = TRUE; 4154 ffeste_io_iostat_ 4155 = ffecom_make_tempvar ("read", ffecom_integer_type_node, 4156 FFETARGET_charactersizeNONE, -1); 4157 } 4158 else 4159 { 4160 /* No IOSTAT=, ERR=, or END= specification. */ 4161 4162 ffeste_io_iostat_is_temp_ = FALSE; 4163 ffeste_io_iostat_ = NULL_TREE; 4164 } 4165 4166 /* Now prescan, then convert, all the arguments. */ 4167 4168 if (unit == FFESTV_unitCHAREXPR) 4169 cilist = ffeste_io_icilist_ (errl || iostat, 4170 info->read_spec[FFESTP_readixUNIT].u.expr, 4171 endl || iostat, format, 4172 &info->read_spec[FFESTP_readixFORMAT]); 4173 else 4174 cilist = ffeste_io_cilist_ (errl || iostat, unit, 4175 info->read_spec[FFESTP_readixUNIT].u.expr, 4176 5, endl || iostat, format, 4177 &info->read_spec[FFESTP_readixFORMAT], 4178 rec, 4179 info->read_spec[FFESTP_readixREC].u.expr); 4180 4181 /* If there is no end function, then there are no item functions (i.e. 4182 it's a NAMELIST), and vice versa by the way. In this situation, don't 4183 generate the "if (iostat != 0) goto label;" if the label is temp abort 4184 label, since we're gonna fall through to there anyway. */ 4185 4186 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE), 4187 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt)); 4188 } 4189#else 4190#error 4191#endif 4192} 4193 4194/* READ statement -- I/O item. */ 4195 4196void 4197ffeste_R909_item (ffebld expr, ffelexToken expr_token) 4198{ 4199 ffeste_check_item_ (); 4200 4201#if FFECOM_targetCURRENT == FFECOM_targetFFE 4202 ffebld_dump (expr); 4203 fputc (',', dmpout); 4204#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4205 if (expr == NULL) 4206 return; 4207 4208 /* Strip parens off items such as in "READ *,(A)". This is really a bug 4209 in the user's code, but I've been told lots of code does this. */ 4210 while (ffebld_op (expr) == FFEBLD_opPAREN) 4211 expr = ffebld_left (expr); 4212 4213 if (ffebld_op (expr) == FFEBLD_opANY) 4214 return; 4215 4216 if (ffebld_op (expr) == FFEBLD_opIMPDO) 4217 ffeste_io_impdo_ (expr, expr_token); 4218 else 4219 { 4220 ffeste_start_stmt_ (); 4221 4222 ffecom_prepare_arg_ptr_to_expr (expr); 4223 4224 ffecom_prepare_end (); 4225 4226 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE); 4227 4228 ffeste_end_stmt_ (); 4229 } 4230#else 4231#error 4232#endif 4233} 4234 4235/* READ statement -- end. */ 4236 4237void 4238ffeste_R909_finish () 4239{ 4240 ffeste_check_finish_ (); 4241 4242#if FFECOM_targetCURRENT == FFECOM_targetFFE 4243 fputc ('\n', dmpout); 4244#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4245 4246 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort 4247 label, since we're gonna fall through to there anyway. */ 4248 4249 if (ffeste_io_endgfrt_ != FFECOM_gfrt) 4250 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE, 4251 NULL_TREE), 4252 ! ffeste_io_abort_is_temp_); 4253 4254 /* If we've got a temp label, generate its code here and have it fan out 4255 to the END= or ERR= label as appropriate. */ 4256 4257 if (ffeste_io_abort_is_temp_) 4258 { 4259 DECL_INITIAL (ffeste_io_abort_) = error_mark_node; 4260 emit_nop (); 4261 expand_label (ffeste_io_abort_); 4262 4263 /* "if (iostat<0) goto end_label;". */ 4264 4265 if ((ffeste_io_end_ != NULL_TREE) 4266 && (TREE_CODE (ffeste_io_end_) != ERROR_MARK)) 4267 { 4268 expand_start_cond (ffecom_truth_value 4269 (ffecom_2 (LT_EXPR, integer_type_node, 4270 ffeste_io_iostat_, 4271 ffecom_integer_zero_node)), 4272 0); 4273 expand_goto (ffeste_io_end_); 4274 expand_end_cond (); 4275 } 4276 4277 /* "if (iostat>0) goto err_label;". */ 4278 4279 if ((ffeste_io_err_ != NULL_TREE) 4280 && (TREE_CODE (ffeste_io_err_) != ERROR_MARK)) 4281 { 4282 expand_start_cond (ffecom_truth_value 4283 (ffecom_2 (GT_EXPR, integer_type_node, 4284 ffeste_io_iostat_, 4285 ffecom_integer_zero_node)), 4286 0); 4287 expand_goto (ffeste_io_err_); 4288 expand_end_cond (); 4289 } 4290 } 4291 4292 ffeste_end_stmt_ (); 4293#else 4294#error 4295#endif 4296} 4297 4298/* WRITE statement -- start. */ 4299 4300void 4301ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, 4302 ffestvFormat format, bool rec) 4303{ 4304 ffeste_check_start_ (); 4305 4306#if FFECOM_targetCURRENT == FFECOM_targetFFE 4307 switch (format) 4308 { 4309 case FFESTV_formatNONE: 4310 if (rec) 4311 fputs ("+ WRITE_ufdac (", dmpout); 4312 else 4313 fputs ("+ WRITE_ufseq_or_idx (", dmpout); 4314 break; 4315 4316 case FFESTV_formatLABEL: 4317 case FFESTV_formatCHAREXPR: 4318 case FFESTV_formatINTEXPR: 4319 if (rec) 4320 fputs ("+ WRITE_fmdac (", dmpout); 4321 else if (unit == FFESTV_unitCHAREXPR) 4322 fputs ("+ WRITE_fmint (", dmpout); 4323 else 4324 fputs ("+ WRITE_fmseq_or_idx (", dmpout); 4325 break; 4326 4327 case FFESTV_formatASTERISK: 4328 if (unit == FFESTV_unitCHAREXPR) 4329 fputs ("+ WRITE_lsint (", dmpout); 4330 else 4331 fputs ("+ WRITE_lsseq (", dmpout); 4332 break; 4333 4334 case FFESTV_formatNAMELIST: 4335 fputs ("+ WRITE_nlseq (", dmpout); 4336 break; 4337 4338 default: 4339 assert ("Unexpected kind of format item in R910 WRITE" == NULL); 4340 } 4341 4342 ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]); 4343 ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]); 4344 ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]); 4345 ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]); 4346 ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]); 4347 ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]); 4348 ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]); 4349 fputs (") ", dmpout); 4350#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4351 4352 ffeste_emit_line_note_ (); 4353 4354 { 4355 ffecomGfrt start; 4356 ffecomGfrt end; 4357 tree cilist; 4358 bool iostat; 4359 bool errl; 4360 4361 /* First determine the start, per-item, and end run-time functions to 4362 call. The per-item function is picked by choosing an ffeste function 4363 to call to handle a given item; it knows how to generate a call to the 4364 appropriate run-time function, and is called an "I/O driver". */ 4365 4366 switch (format) 4367 { 4368 case FFESTV_formatNONE: /* no FMT= */ 4369 ffeste_io_driver_ = ffeste_io_douio_; 4370 if (rec) 4371 start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE; 4372 else 4373 start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE; 4374 break; 4375 4376 case FFESTV_formatLABEL: /* FMT=10 */ 4377 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */ 4378 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */ 4379 ffeste_io_driver_ = ffeste_io_dofio_; 4380 if (rec) 4381 start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE; 4382 else if (unit == FFESTV_unitCHAREXPR) 4383 start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI; 4384 else 4385 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE; 4386 break; 4387 4388 case FFESTV_formatASTERISK: /* FMT=* */ 4389 ffeste_io_driver_ = ffeste_io_dolio_; 4390 if (unit == FFESTV_unitCHAREXPR) 4391 start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI; 4392 else 4393 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE; 4394 break; 4395 4396 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST 4397 /FOO/] */ 4398 ffeste_io_driver_ = NULL; /* No start or driver function. */ 4399 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt; 4400 break; 4401 4402 default: 4403 assert ("Weird stuff" == NULL); 4404 start = FFECOM_gfrt, end = FFECOM_gfrt; 4405 break; 4406 } 4407 ffeste_io_endgfrt_ = end; 4408 4409#define specified(something) (info->write_spec[something].kw_or_val_present) 4410 4411 iostat = specified (FFESTP_writeixIOSTAT); 4412 errl = specified (FFESTP_writeixERR); 4413 4414#undef specified 4415 4416 ffeste_start_stmt_ (); 4417 4418 ffeste_io_end_ = NULL_TREE; 4419 4420 if (errl) 4421 { 4422 /* Have ERR= specification. */ 4423 4424 ffeste_io_err_ 4425 = ffeste_io_abort_ 4426 = ffecom_lookup_label 4427 (info->write_spec[FFESTP_writeixERR].u.label); 4428 ffeste_io_abort_is_temp_ = FALSE; 4429 } 4430 else 4431 { 4432 /* No ERR= specification. */ 4433 4434 ffeste_io_err_ = NULL_TREE; 4435 4436 if ((ffeste_io_abort_is_temp_ = iostat)) 4437 ffeste_io_abort_ = ffecom_temp_label (); 4438 else 4439 ffeste_io_abort_ = NULL_TREE; 4440 } 4441 4442 if (iostat) 4443 { 4444 /* Have IOSTAT= specification. */ 4445 4446 ffeste_io_iostat_is_temp_ = FALSE; 4447 ffeste_io_iostat_ = ffecom_expr 4448 (info->write_spec[FFESTP_writeixIOSTAT].u.expr); 4449 } 4450 else if (ffeste_io_abort_ != NULL_TREE) 4451 { 4452 /* Have no IOSTAT= but have ERR=. */ 4453 4454 ffeste_io_iostat_is_temp_ = TRUE; 4455 ffeste_io_iostat_ 4456 = ffecom_make_tempvar ("write", ffecom_integer_type_node, 4457 FFETARGET_charactersizeNONE, -1); 4458 } 4459 else 4460 { 4461 /* No IOSTAT= or ERR= specification. */ 4462 4463 ffeste_io_iostat_is_temp_ = FALSE; 4464 ffeste_io_iostat_ = NULL_TREE; 4465 } 4466 4467 /* Now prescan, then convert, all the arguments. */ 4468 4469 if (unit == FFESTV_unitCHAREXPR) 4470 cilist = ffeste_io_icilist_ (errl || iostat, 4471 info->write_spec[FFESTP_writeixUNIT].u.expr, 4472 FALSE, format, 4473 &info->write_spec[FFESTP_writeixFORMAT]); 4474 else 4475 cilist = ffeste_io_cilist_ (errl || iostat, unit, 4476 info->write_spec[FFESTP_writeixUNIT].u.expr, 4477 6, FALSE, format, 4478 &info->write_spec[FFESTP_writeixFORMAT], 4479 rec, 4480 info->write_spec[FFESTP_writeixREC].u.expr); 4481 4482 /* If there is no end function, then there are no item functions (i.e. 4483 it's a NAMELIST), and vice versa by the way. In this situation, don't 4484 generate the "if (iostat != 0) goto label;" if the label is temp abort 4485 label, since we're gonna fall through to there anyway. */ 4486 4487 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE), 4488 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt)); 4489 } 4490#else 4491#error 4492#endif 4493} 4494 4495/* WRITE statement -- I/O item. */ 4496 4497void 4498ffeste_R910_item (ffebld expr, ffelexToken expr_token) 4499{ 4500 ffeste_check_item_ (); 4501 4502#if FFECOM_targetCURRENT == FFECOM_targetFFE 4503 ffebld_dump (expr); 4504 fputc (',', dmpout); 4505#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4506 if (expr == NULL) 4507 return; 4508 4509 if (ffebld_op (expr) == FFEBLD_opANY) 4510 return; 4511 4512 if (ffebld_op (expr) == FFEBLD_opIMPDO) 4513 ffeste_io_impdo_ (expr, expr_token); 4514 else 4515 { 4516 ffeste_start_stmt_ (); 4517 4518 ffecom_prepare_arg_ptr_to_expr (expr); 4519 4520 ffecom_prepare_end (); 4521 4522 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE); 4523 4524 ffeste_end_stmt_ (); 4525 } 4526#else 4527#error 4528#endif 4529} 4530 4531/* WRITE statement -- end. */ 4532 4533void 4534ffeste_R910_finish () 4535{ 4536 ffeste_check_finish_ (); 4537 4538#if FFECOM_targetCURRENT == FFECOM_targetFFE 4539 fputc ('\n', dmpout); 4540#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4541 4542 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort 4543 label, since we're gonna fall through to there anyway. */ 4544 4545 if (ffeste_io_endgfrt_ != FFECOM_gfrt) 4546 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE, 4547 NULL_TREE), 4548 ! ffeste_io_abort_is_temp_); 4549 4550 /* If we've got a temp label, generate its code here. */ 4551 4552 if (ffeste_io_abort_is_temp_) 4553 { 4554 DECL_INITIAL (ffeste_io_abort_) = error_mark_node; 4555 emit_nop (); 4556 expand_label (ffeste_io_abort_); 4557 4558 assert (ffeste_io_err_ == NULL_TREE); 4559 } 4560 4561 ffeste_end_stmt_ (); 4562#else 4563#error 4564#endif 4565} 4566 4567/* PRINT statement -- start. */ 4568 4569void 4570ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format) 4571{ 4572 ffeste_check_start_ (); 4573 4574#if FFECOM_targetCURRENT == FFECOM_targetFFE 4575 switch (format) 4576 { 4577 case FFESTV_formatLABEL: 4578 case FFESTV_formatCHAREXPR: 4579 case FFESTV_formatINTEXPR: 4580 fputs ("+ PRINT_fm ", dmpout); 4581 break; 4582 4583 case FFESTV_formatASTERISK: 4584 fputs ("+ PRINT_ls ", dmpout); 4585 break; 4586 4587 case FFESTV_formatNAMELIST: 4588 fputs ("+ PRINT_nl ", dmpout); 4589 break; 4590 4591 default: 4592 assert ("Unexpected kind of format item in R911 PRINT" == NULL); 4593 } 4594 ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]); 4595 fputc (' ', dmpout); 4596#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4597 4598 ffeste_emit_line_note_ (); 4599 4600 { 4601 ffecomGfrt start; 4602 ffecomGfrt end; 4603 tree cilist; 4604 4605 /* First determine the start, per-item, and end run-time functions to 4606 call. The per-item function is picked by choosing an ffeste function 4607 to call to handle a given item; it knows how to generate a call to the 4608 appropriate run-time function, and is called an "I/O driver". */ 4609 4610 switch (format) 4611 { 4612 case FFESTV_formatLABEL: /* FMT=10 */ 4613 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */ 4614 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */ 4615 ffeste_io_driver_ = ffeste_io_dofio_; 4616 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE; 4617 break; 4618 4619 case FFESTV_formatASTERISK: /* FMT=* */ 4620 ffeste_io_driver_ = ffeste_io_dolio_; 4621 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE; 4622 break; 4623 4624 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST 4625 /FOO/] */ 4626 ffeste_io_driver_ = NULL; /* No start or driver function. */ 4627 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt; 4628 break; 4629 4630 default: 4631 assert ("Weird stuff" == NULL); 4632 start = FFECOM_gfrt, end = FFECOM_gfrt; 4633 break; 4634 } 4635 ffeste_io_endgfrt_ = end; 4636 4637 ffeste_start_stmt_ (); 4638 4639 ffeste_io_end_ = NULL_TREE; 4640 ffeste_io_err_ = NULL_TREE; 4641 ffeste_io_abort_ = NULL_TREE; 4642 ffeste_io_abort_is_temp_ = FALSE; 4643 ffeste_io_iostat_is_temp_ = FALSE; 4644 ffeste_io_iostat_ = NULL_TREE; 4645 4646 /* Now prescan, then convert, all the arguments. */ 4647 4648 cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format, 4649 &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL); 4650 4651 /* If there is no end function, then there are no item functions (i.e. 4652 it's a NAMELIST), and vice versa by the way. In this situation, don't 4653 generate the "if (iostat != 0) goto label;" if the label is temp abort 4654 label, since we're gonna fall through to there anyway. */ 4655 4656 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE), 4657 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt)); 4658 } 4659#else 4660#error 4661#endif 4662} 4663 4664/* PRINT statement -- I/O item. */ 4665 4666void 4667ffeste_R911_item (ffebld expr, ffelexToken expr_token) 4668{ 4669 ffeste_check_item_ (); 4670 4671#if FFECOM_targetCURRENT == FFECOM_targetFFE 4672 ffebld_dump (expr); 4673 fputc (',', dmpout); 4674#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4675 if (expr == NULL) 4676 return; 4677 4678 if (ffebld_op (expr) == FFEBLD_opANY) 4679 return; 4680 4681 if (ffebld_op (expr) == FFEBLD_opIMPDO) 4682 ffeste_io_impdo_ (expr, expr_token); 4683 else 4684 { 4685 ffeste_start_stmt_ (); 4686 4687 ffecom_prepare_arg_ptr_to_expr (expr); 4688 4689 ffecom_prepare_end (); 4690 4691 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE); 4692 4693 ffeste_end_stmt_ (); 4694 } 4695#else 4696#error 4697#endif 4698} 4699 4700/* PRINT statement -- end. */ 4701 4702void 4703ffeste_R911_finish () 4704{ 4705 ffeste_check_finish_ (); 4706 4707#if FFECOM_targetCURRENT == FFECOM_targetFFE 4708 fputc ('\n', dmpout); 4709#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4710 4711 if (ffeste_io_endgfrt_ != FFECOM_gfrt) 4712 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE, 4713 NULL_TREE), 4714 FALSE); 4715 4716 ffeste_end_stmt_ (); 4717#else 4718#error 4719#endif 4720} 4721 4722/* BACKSPACE statement. */ 4723 4724void 4725ffeste_R919 (ffestpBeruStmt *info) 4726{ 4727 ffeste_check_simple_ (); 4728 4729#if FFECOM_targetCURRENT == FFECOM_targetFFE 4730 fputs ("+ BACKSPACE (", dmpout); 4731 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); 4732 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); 4733 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); 4734 fputs (")\n", dmpout); 4735#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4736 ffeste_subr_beru_ (info, FFECOM_gfrtFBACK); 4737#else 4738#error 4739#endif 4740} 4741 4742/* ENDFILE statement. */ 4743 4744void 4745ffeste_R920 (ffestpBeruStmt *info) 4746{ 4747 ffeste_check_simple_ (); 4748 4749#if FFECOM_targetCURRENT == FFECOM_targetFFE 4750 fputs ("+ ENDFILE (", dmpout); 4751 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); 4752 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); 4753 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); 4754 fputs (")\n", dmpout); 4755#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4756 ffeste_subr_beru_ (info, FFECOM_gfrtFEND); 4757#else 4758#error 4759#endif 4760} 4761 4762/* REWIND statement. */ 4763 4764void 4765ffeste_R921 (ffestpBeruStmt *info) 4766{ 4767 ffeste_check_simple_ (); 4768 4769#if FFECOM_targetCURRENT == FFECOM_targetFFE 4770 fputs ("+ REWIND (", dmpout); 4771 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); 4772 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); 4773 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); 4774 fputs (")\n", dmpout); 4775#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4776 ffeste_subr_beru_ (info, FFECOM_gfrtFREW); 4777#else 4778#error 4779#endif 4780} 4781 4782/* INQUIRE statement (non-IOLENGTH version). */ 4783 4784void 4785ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED) 4786{ 4787 ffeste_check_simple_ (); 4788 4789#if FFECOM_targetCURRENT == FFECOM_targetFFE 4790 if (by_file) 4791 { 4792 fputs ("+ INQUIRE_file (", dmpout); 4793 ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]); 4794 } 4795 else 4796 { 4797 fputs ("+ INQUIRE_unit (", dmpout); 4798 ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]); 4799 } 4800 ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]); 4801 ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]); 4802 ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]); 4803 ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]); 4804 ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]); 4805 ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]); 4806 ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]); 4807 ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]); 4808 ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]); 4809 ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]); 4810 ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]); 4811 ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]); 4812 ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]); 4813 ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]); 4814 ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]); 4815 ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]); 4816 ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]); 4817 ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]); 4818 ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]); 4819 ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]); 4820 ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]); 4821 ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]); 4822 ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]); 4823 ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]); 4824 ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]); 4825 ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]); 4826 ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]); 4827 ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]); 4828 fputs (")\n", dmpout); 4829#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4830 { 4831 tree args; 4832 bool iostat; 4833 bool errl; 4834 4835 ffeste_emit_line_note_ (); 4836 4837#define specified(something) (info->inquire_spec[something].kw_or_val_present) 4838 4839 iostat = specified (FFESTP_inquireixIOSTAT); 4840 errl = specified (FFESTP_inquireixERR); 4841 4842#undef specified 4843 4844 ffeste_start_stmt_ (); 4845 4846 if (errl) 4847 { 4848 ffeste_io_err_ 4849 = ffeste_io_abort_ 4850 = ffecom_lookup_label 4851 (info->inquire_spec[FFESTP_inquireixERR].u.label); 4852 ffeste_io_abort_is_temp_ = FALSE; 4853 } 4854 else 4855 { 4856 ffeste_io_err_ = NULL_TREE; 4857 4858 if ((ffeste_io_abort_is_temp_ = iostat)) 4859 ffeste_io_abort_ = ffecom_temp_label (); 4860 else 4861 ffeste_io_abort_ = NULL_TREE; 4862 } 4863 4864 if (iostat) 4865 { 4866 /* Have IOSTAT= specification. */ 4867 4868 ffeste_io_iostat_is_temp_ = FALSE; 4869 ffeste_io_iostat_ = ffecom_expr 4870 (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr); 4871 } 4872 else if (ffeste_io_abort_ != NULL_TREE) 4873 { 4874 /* Have no IOSTAT= but have ERR=. */ 4875 4876 ffeste_io_iostat_is_temp_ = TRUE; 4877 ffeste_io_iostat_ 4878 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node, 4879 FFETARGET_charactersizeNONE, -1); 4880 } 4881 else 4882 { 4883 /* No IOSTAT= or ERR= specification. */ 4884 4885 ffeste_io_iostat_is_temp_ = FALSE; 4886 ffeste_io_iostat_ = NULL_TREE; 4887 } 4888 4889 /* Now prescan, then convert, all the arguments. */ 4890 4891 args 4892 = ffeste_io_inlist_ (errl || iostat, 4893 &info->inquire_spec[FFESTP_inquireixUNIT], 4894 &info->inquire_spec[FFESTP_inquireixFILE], 4895 &info->inquire_spec[FFESTP_inquireixEXIST], 4896 &info->inquire_spec[FFESTP_inquireixOPENED], 4897 &info->inquire_spec[FFESTP_inquireixNUMBER], 4898 &info->inquire_spec[FFESTP_inquireixNAMED], 4899 &info->inquire_spec[FFESTP_inquireixNAME], 4900 &info->inquire_spec[FFESTP_inquireixACCESS], 4901 &info->inquire_spec[FFESTP_inquireixSEQUENTIAL], 4902 &info->inquire_spec[FFESTP_inquireixDIRECT], 4903 &info->inquire_spec[FFESTP_inquireixFORM], 4904 &info->inquire_spec[FFESTP_inquireixFORMATTED], 4905 &info->inquire_spec[FFESTP_inquireixUNFORMATTED], 4906 &info->inquire_spec[FFESTP_inquireixRECL], 4907 &info->inquire_spec[FFESTP_inquireixNEXTREC], 4908 &info->inquire_spec[FFESTP_inquireixBLANK]); 4909 4910 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort 4911 label, since we're gonna fall through to there anyway. */ 4912 4913 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE), 4914 ! ffeste_io_abort_is_temp_); 4915 4916 /* If we've got a temp label, generate its code here. */ 4917 4918 if (ffeste_io_abort_is_temp_) 4919 { 4920 DECL_INITIAL (ffeste_io_abort_) = error_mark_node; 4921 emit_nop (); 4922 expand_label (ffeste_io_abort_); 4923 4924 assert (ffeste_io_err_ == NULL_TREE); 4925 } 4926 4927 ffeste_end_stmt_ (); 4928 } 4929#else 4930#error 4931#endif 4932} 4933 4934/* INQUIRE(IOLENGTH=expr) statement -- start. */ 4935 4936void 4937ffeste_R923B_start (ffestpInquireStmt *info UNUSED) 4938{ 4939 ffeste_check_start_ (); 4940 4941#if FFECOM_targetCURRENT == FFECOM_targetFFE 4942 fputs ("+ INQUIRE (", dmpout); 4943 ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]); 4944 fputs (") ", dmpout); 4945#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4946 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL); 4947 4948 ffeste_emit_line_note_ (); 4949#else 4950#error 4951#endif 4952} 4953 4954/* INQUIRE(IOLENGTH=expr) statement -- I/O item. */ 4955 4956void 4957ffeste_R923B_item (ffebld expr UNUSED) 4958{ 4959 ffeste_check_item_ (); 4960 4961#if FFECOM_targetCURRENT == FFECOM_targetFFE 4962 ffebld_dump (expr); 4963 fputc (',', dmpout); 4964#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4965#else 4966#error 4967#endif 4968} 4969 4970/* INQUIRE(IOLENGTH=expr) statement -- end. */ 4971 4972void 4973ffeste_R923B_finish () 4974{ 4975 ffeste_check_finish_ (); 4976 4977#if FFECOM_targetCURRENT == FFECOM_targetFFE 4978 fputc ('\n', dmpout); 4979#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4980#else 4981#error 4982#endif 4983} 4984 4985/* ffeste_R1001 -- FORMAT statement 4986 4987 ffeste_R1001(format_list); */ 4988 4989void 4990ffeste_R1001 (ffests s) 4991{ 4992 ffeste_check_simple_ (); 4993 4994#if FFECOM_targetCURRENT == FFECOM_targetFFE 4995 fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s)); 4996#elif FFECOM_targetCURRENT == FFECOM_targetGCC 4997 { 4998 tree t; 4999 tree ttype; 5000 tree maxindex; 5001 tree var; 5002 5003 assert (ffeste_label_formatdef_ != NULL); 5004 5005 ffeste_emit_line_note_ (); 5006 5007 t = build_string (ffests_length (s), ffests_text (s)); 5008 5009 TREE_TYPE (t) 5010 = build_type_variant (build_array_type 5011 (char_type_node, 5012 build_range_type (integer_type_node, 5013 integer_one_node, 5014 build_int_2 (ffests_length (s), 5015 0))), 5016 1, 0); 5017 TREE_CONSTANT (t) = 1; 5018 TREE_STATIC (t) = 1; 5019 5020 push_obstacks_nochange (); 5021 end_temporary_allocation (); 5022 5023 var = ffecom_lookup_label (ffeste_label_formatdef_); 5024 if ((var != NULL_TREE) 5025 && (TREE_CODE (var) == VAR_DECL)) 5026 { 5027 DECL_INITIAL (var) = t; 5028 maxindex = build_int_2 (ffests_length (s) - 1, 0); 5029 ttype = TREE_TYPE (var); 5030 TYPE_DOMAIN (ttype) = build_range_type (integer_type_node, 5031 integer_zero_node, 5032 maxindex); 5033 if (!TREE_TYPE (maxindex)) 5034 TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype); 5035 layout_type (ttype); 5036 rest_of_decl_compilation (var, NULL, 1, 0); 5037 expand_decl (var); 5038 expand_decl_init (var); 5039 } 5040 5041 resume_temporary_allocation (); 5042 pop_obstacks (); 5043 5044 ffeste_label_formatdef_ = NULL; 5045 } 5046#else 5047#error 5048#endif 5049} 5050 5051/* END PROGRAM. */ 5052 5053void 5054ffeste_R1103 () 5055{ 5056#if FFECOM_targetCURRENT == FFECOM_targetFFE 5057 fputs ("+ END_PROGRAM\n", dmpout); 5058#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5059#else 5060#error 5061#endif 5062} 5063 5064/* END BLOCK DATA. */ 5065 5066void 5067ffeste_R1112 () 5068{ 5069#if FFECOM_targetCURRENT == FFECOM_targetFFE 5070 fputs ("* END_BLOCK_DATA\n", dmpout); 5071#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5072#else 5073#error 5074#endif 5075} 5076 5077/* CALL statement. */ 5078 5079void 5080ffeste_R1212 (ffebld expr) 5081{ 5082 ffeste_check_simple_ (); 5083 5084#if FFECOM_targetCURRENT == FFECOM_targetFFE 5085 fputs ("+ CALL ", dmpout); 5086 ffebld_dump (expr); 5087 fputc ('\n', dmpout); 5088#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5089 { 5090 ffebld args = ffebld_right (expr); 5091 ffebld arg; 5092 ffebld labels = NULL; /* First in list of LABTERs. */ 5093 ffebld prevlabels = NULL; 5094 ffebld prevargs = NULL; 5095 5096 ffeste_emit_line_note_ (); 5097 5098 /* Here we split the list at ffebld_right(expr) into two lists: one at 5099 ffebld_right(expr) consisting of all items that are not LABTERs, the 5100 other at labels consisting of all items that are LABTERs. Then, if 5101 the latter list is NULL, we have an ordinary call, else we have a call 5102 with alternate returns. */ 5103 5104 for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args)) 5105 { 5106 if (((arg = ffebld_head (args)) == NULL) 5107 || (ffebld_op (arg) != FFEBLD_opLABTER)) 5108 { 5109 if (prevargs == NULL) 5110 { 5111 prevargs = args; 5112 ffebld_set_right (expr, args); 5113 } 5114 else 5115 { 5116 ffebld_set_trail (prevargs, args); 5117 prevargs = args; 5118 } 5119 } 5120 else 5121 { 5122 if (prevlabels == NULL) 5123 { 5124 prevlabels = labels = args; 5125 } 5126 else 5127 { 5128 ffebld_set_trail (prevlabels, args); 5129 prevlabels = args; 5130 } 5131 } 5132 } 5133 if (prevlabels == NULL) 5134 labels = NULL; 5135 else 5136 ffebld_set_trail (prevlabels, NULL); 5137 if (prevargs == NULL) 5138 ffebld_set_right (expr, NULL); 5139 else 5140 ffebld_set_trail (prevargs, NULL); 5141 5142 ffeste_start_stmt_ (); 5143 5144 /* No temporaries are actually needed at this level, but we go 5145 through the motions anyway, just to be sure in case they do 5146 get made. Temporaries needed for arguments should be in the 5147 scopes of inner blocks, and if clean-up actions are supported, 5148 such as CALL-ing an intrinsic that writes to an argument of one 5149 type when a variable of a different type is provided (requiring 5150 assignment to the variable from a temporary after the library 5151 routine returns), the clean-up must be done by the expression 5152 evaluator, generally, to handle alternate returns (which we hope 5153 won't ever be supported by intrinsics, but might be a similar 5154 issue, such as CALL-ing an F90-style subroutine with an INTERFACE 5155 block). That implies the expression evaluator will have to 5156 recognize the need for its own temporary anyway, meaning it'll 5157 construct a block within the one constructed here. */ 5158 5159 ffecom_prepare_expr (expr); 5160 5161 ffecom_prepare_end (); 5162 5163 if (labels == NULL) 5164 expand_expr_stmt (ffecom_expr (expr)); 5165 else 5166 { 5167 tree texpr; 5168 tree value; 5169 tree tlabel; 5170 int caseno; 5171 int pushok; 5172 tree duplicate; 5173 ffebld label; 5174 5175 texpr = ffecom_expr (expr); 5176 expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement"); 5177 5178 for (caseno = 1, label = labels; 5179 label != NULL; 5180 ++caseno, label = ffebld_trail (label)) 5181 { 5182 value = build_int_2 (caseno, 0); 5183 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); 5184 5185 pushok = pushcase (value, convert, tlabel, &duplicate); 5186 assert (pushok == 0); 5187 5188 tlabel 5189 = ffecom_lookup_label (ffebld_labter (ffebld_head (label))); 5190 if ((tlabel == NULL_TREE) 5191 || (TREE_CODE (tlabel) == ERROR_MARK)) 5192 continue; 5193 TREE_USED (tlabel) = 1; 5194 expand_goto (tlabel); 5195 } 5196 5197 expand_end_case (texpr); 5198 } 5199 5200 ffeste_end_stmt_ (); 5201 } 5202#else 5203#error 5204#endif 5205} 5206 5207/* END FUNCTION. */ 5208 5209void 5210ffeste_R1221 () 5211{ 5212#if FFECOM_targetCURRENT == FFECOM_targetFFE 5213 fputs ("+ END_FUNCTION\n", dmpout); 5214#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5215#else 5216#error 5217#endif 5218} 5219 5220/* END SUBROUTINE. */ 5221 5222void 5223ffeste_R1225 () 5224{ 5225#if FFECOM_targetCURRENT == FFECOM_targetFFE 5226 fprintf (dmpout, "+ END_SUBROUTINE\n"); 5227#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5228#else 5229#error 5230#endif 5231} 5232 5233/* ENTRY statement. */ 5234 5235void 5236ffeste_R1226 (ffesymbol entry) 5237{ 5238 ffeste_check_simple_ (); 5239 5240#if FFECOM_targetCURRENT == FFECOM_targetFFE 5241 fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry)); 5242 if (ffesymbol_dummyargs (entry) != NULL) 5243 { 5244 ffebld argh; 5245 5246 fputc ('(', dmpout); 5247 for (argh = ffesymbol_dummyargs (entry); 5248 argh != NULL; 5249 argh = ffebld_trail (argh)) 5250 { 5251 assert (ffebld_head (argh) != NULL); 5252 switch (ffebld_op (ffebld_head (argh))) 5253 { 5254 case FFEBLD_opSYMTER: 5255 fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))), 5256 dmpout); 5257 break; 5258 5259 case FFEBLD_opSTAR: 5260 fputc ('*', dmpout); 5261 break; 5262 5263 default: 5264 fputc ('?', dmpout); 5265 ffebld_dump (ffebld_head (argh)); 5266 fputc ('?', dmpout); 5267 break; 5268 } 5269 if (ffebld_trail (argh) != NULL) 5270 fputc (',', dmpout); 5271 } 5272 fputc (')', dmpout); 5273 } 5274 fputc ('\n', dmpout); 5275#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5276 { 5277 tree label = ffesymbol_hook (entry).length_tree; 5278 5279 ffeste_emit_line_note_ (); 5280 5281 if (label == error_mark_node) 5282 return; 5283 5284 DECL_INITIAL (label) = error_mark_node; 5285 emit_nop (); 5286 expand_label (label); 5287 } 5288#else 5289#error 5290#endif 5291} 5292 5293/* RETURN statement. */ 5294 5295void 5296ffeste_R1227 (ffestw block UNUSED, ffebld expr) 5297{ 5298 ffeste_check_simple_ (); 5299 5300#if FFECOM_targetCURRENT == FFECOM_targetFFE 5301 if (expr == NULL) 5302 { 5303 fputs ("+ RETURN\n", dmpout); 5304 } 5305 else 5306 { 5307 fputs ("+ RETURN_alternate ", dmpout); 5308 ffebld_dump (expr); 5309 fputc ('\n', dmpout); 5310 } 5311#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5312 { 5313 tree rtn; 5314 5315 ffeste_emit_line_note_ (); 5316 5317 ffeste_start_stmt_ (); 5318 5319 ffecom_prepare_return_expr (expr); 5320 5321 ffecom_prepare_end (); 5322 5323 rtn = ffecom_return_expr (expr); 5324 5325 if ((rtn == NULL_TREE) 5326 || (rtn == error_mark_node)) 5327 expand_null_return (); 5328 else 5329 { 5330 tree result = DECL_RESULT (current_function_decl); 5331 5332 if ((result != error_mark_node) 5333 && (TREE_TYPE (result) != error_mark_node)) 5334 expand_return (ffecom_modify (NULL_TREE, 5335 result, 5336 convert (TREE_TYPE (result), 5337 rtn))); 5338 else 5339 expand_null_return (); 5340 } 5341 5342 ffeste_end_stmt_ (); 5343 } 5344#else 5345#error 5346#endif 5347} 5348 5349/* REWRITE statement -- start. */ 5350 5351#if FFESTR_VXT 5352void 5353ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format) 5354{ 5355 ffeste_check_start_ (); 5356 5357#if FFECOM_targetCURRENT == FFECOM_targetFFE 5358 switch (format) 5359 { 5360 case FFESTV_formatNONE: 5361 fputs ("+ REWRITE_uf (", dmpout); 5362 break; 5363 5364 case FFESTV_formatLABEL: 5365 case FFESTV_formatCHAREXPR: 5366 case FFESTV_formatINTEXPR: 5367 fputs ("+ REWRITE_fm (", dmpout); 5368 break; 5369 5370 default: 5371 assert ("Unexpected kind of format item in V018 REWRITE" == NULL); 5372 } 5373 ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]); 5374 ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]); 5375 ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]); 5376 ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]); 5377 fputs (") ", dmpout); 5378#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5379#else 5380#error 5381#endif 5382} 5383 5384/* REWRITE statement -- I/O item. */ 5385 5386void 5387ffeste_V018_item (ffebld expr) 5388{ 5389 ffeste_check_item_ (); 5390 5391#if FFECOM_targetCURRENT == FFECOM_targetFFE 5392 ffebld_dump (expr); 5393 fputc (',', dmpout); 5394#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5395#else 5396#error 5397#endif 5398} 5399 5400/* REWRITE statement -- end. */ 5401 5402void 5403ffeste_V018_finish () 5404{ 5405 ffeste_check_finish_ (); 5406 5407#if FFECOM_targetCURRENT == FFECOM_targetFFE 5408 fputc ('\n', dmpout); 5409#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5410#else 5411#error 5412#endif 5413} 5414 5415/* ACCEPT statement -- start. */ 5416 5417void 5418ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format) 5419{ 5420 ffeste_check_start_ (); 5421 5422#if FFECOM_targetCURRENT == FFECOM_targetFFE 5423 switch (format) 5424 { 5425 case FFESTV_formatLABEL: 5426 case FFESTV_formatCHAREXPR: 5427 case FFESTV_formatINTEXPR: 5428 fputs ("+ ACCEPT_fm ", dmpout); 5429 break; 5430 5431 case FFESTV_formatASTERISK: 5432 fputs ("+ ACCEPT_ls ", dmpout); 5433 break; 5434 5435 case FFESTV_formatNAMELIST: 5436 fputs ("+ ACCEPT_nl ", dmpout); 5437 break; 5438 5439 default: 5440 assert ("Unexpected kind of format item in V019 ACCEPT" == NULL); 5441 } 5442 ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]); 5443 fputc (' ', dmpout); 5444#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5445#else 5446#error 5447#endif 5448} 5449 5450/* ACCEPT statement -- I/O item. */ 5451 5452void 5453ffeste_V019_item (ffebld expr) 5454{ 5455 ffeste_check_item_ (); 5456 5457#if FFECOM_targetCURRENT == FFECOM_targetFFE 5458 ffebld_dump (expr); 5459 fputc (',', dmpout); 5460#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5461#else 5462#error 5463#endif 5464} 5465 5466/* ACCEPT statement -- end. */ 5467 5468void 5469ffeste_V019_finish () 5470{ 5471 ffeste_check_finish_ (); 5472 5473#if FFECOM_targetCURRENT == FFECOM_targetFFE 5474 fputc ('\n', dmpout); 5475#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5476#else 5477#error 5478#endif 5479} 5480 5481#endif 5482/* TYPE statement -- start. */ 5483 5484void 5485ffeste_V020_start (ffestpTypeStmt *info UNUSED, 5486 ffestvFormat format UNUSED) 5487{ 5488 ffeste_check_start_ (); 5489 5490#if FFECOM_targetCURRENT == FFECOM_targetFFE 5491 switch (format) 5492 { 5493 case FFESTV_formatLABEL: 5494 case FFESTV_formatCHAREXPR: 5495 case FFESTV_formatINTEXPR: 5496 fputs ("+ TYPE_fm ", dmpout); 5497 break; 5498 5499 case FFESTV_formatASTERISK: 5500 fputs ("+ TYPE_ls ", dmpout); 5501 break; 5502 5503 case FFESTV_formatNAMELIST: 5504 fputs ("* TYPE_nl ", dmpout); 5505 break; 5506 5507 default: 5508 assert ("Unexpected kind of format item in V020 TYPE" == NULL); 5509 } 5510 ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]); 5511 fputc (' ', dmpout); 5512#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5513#else 5514#error 5515#endif 5516} 5517 5518/* TYPE statement -- I/O item. */ 5519 5520void 5521ffeste_V020_item (ffebld expr UNUSED) 5522{ 5523 ffeste_check_item_ (); 5524 5525#if FFECOM_targetCURRENT == FFECOM_targetFFE 5526 ffebld_dump (expr); 5527 fputc (',', dmpout); 5528#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5529#else 5530#error 5531#endif 5532} 5533 5534/* TYPE statement -- end. */ 5535 5536void 5537ffeste_V020_finish () 5538{ 5539 ffeste_check_finish_ (); 5540 5541#if FFECOM_targetCURRENT == FFECOM_targetFFE 5542 fputc ('\n', dmpout); 5543#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5544#else 5545#error 5546#endif 5547} 5548 5549/* DELETE statement. */ 5550 5551#if FFESTR_VXT 5552void 5553ffeste_V021 (ffestpDeleteStmt *info) 5554{ 5555 ffeste_check_simple_ (); 5556 5557#if FFECOM_targetCURRENT == FFECOM_targetFFE 5558 fputs ("+ DELETE (", dmpout); 5559 ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]); 5560 ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]); 5561 ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]); 5562 ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]); 5563 fputs (")\n", dmpout); 5564#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5565#else 5566#error 5567#endif 5568} 5569 5570/* UNLOCK statement. */ 5571 5572void 5573ffeste_V022 (ffestpBeruStmt *info) 5574{ 5575 ffeste_check_simple_ (); 5576 5577#if FFECOM_targetCURRENT == FFECOM_targetFFE 5578 fputs ("+ UNLOCK (", dmpout); 5579 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); 5580 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); 5581 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); 5582 fputs (")\n", dmpout); 5583#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5584#else 5585#error 5586#endif 5587} 5588 5589/* ENCODE statement -- start. */ 5590 5591void 5592ffeste_V023_start (ffestpVxtcodeStmt *info) 5593{ 5594 ffeste_check_start_ (); 5595 5596#if FFECOM_targetCURRENT == FFECOM_targetFFE 5597 fputs ("+ ENCODE (", dmpout); 5598 ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]); 5599 ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]); 5600 ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]); 5601 ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]); 5602 ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]); 5603 fputs (") ", dmpout); 5604#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5605#else 5606#error 5607#endif 5608} 5609 5610/* ENCODE statement -- I/O item. */ 5611 5612void 5613ffeste_V023_item (ffebld expr) 5614{ 5615 ffeste_check_item_ (); 5616 5617#if FFECOM_targetCURRENT == FFECOM_targetFFE 5618 ffebld_dump (expr); 5619 fputc (',', dmpout); 5620#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5621#else 5622#error 5623#endif 5624} 5625 5626/* ENCODE statement -- end. */ 5627 5628void 5629ffeste_V023_finish () 5630{ 5631 ffeste_check_finish_ (); 5632 5633#if FFECOM_targetCURRENT == FFECOM_targetFFE 5634 fputc ('\n', dmpout); 5635#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5636#else 5637#error 5638#endif 5639} 5640 5641/* DECODE statement -- start. */ 5642 5643void 5644ffeste_V024_start (ffestpVxtcodeStmt *info) 5645{ 5646 ffeste_check_start_ (); 5647 5648#if FFECOM_targetCURRENT == FFECOM_targetFFE 5649 fputs ("+ DECODE (", dmpout); 5650 ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]); 5651 ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]); 5652 ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]); 5653 ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]); 5654 ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]); 5655 fputs (") ", dmpout); 5656#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5657#else 5658#error 5659#endif 5660} 5661 5662/* DECODE statement -- I/O item. */ 5663 5664void 5665ffeste_V024_item (ffebld expr) 5666{ 5667 ffeste_check_item_ (); 5668 5669#if FFECOM_targetCURRENT == FFECOM_targetFFE 5670 ffebld_dump (expr); 5671 fputc (',', dmpout); 5672#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5673#else 5674#error 5675#endif 5676} 5677 5678/* DECODE statement -- end. */ 5679 5680void 5681ffeste_V024_finish () 5682{ 5683 ffeste_check_finish_ (); 5684 5685#if FFECOM_targetCURRENT == FFECOM_targetFFE 5686 fputc ('\n', dmpout); 5687#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5688#else 5689#error 5690#endif 5691} 5692 5693/* DEFINEFILE statement -- start. */ 5694 5695void 5696ffeste_V025_start () 5697{ 5698 ffeste_check_start_ (); 5699 5700#if FFECOM_targetCURRENT == FFECOM_targetFFE 5701 fputs ("+ DEFINE_FILE ", dmpout); 5702#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5703#else 5704#error 5705#endif 5706} 5707 5708/* DEFINE FILE statement -- item. */ 5709 5710void 5711ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv) 5712{ 5713 ffeste_check_item_ (); 5714 5715#if FFECOM_targetCURRENT == FFECOM_targetFFE 5716 ffebld_dump (u); 5717 fputc ('(', dmpout); 5718 ffebld_dump (m); 5719 fputc (',', dmpout); 5720 ffebld_dump (n); 5721 fputs (",U,", dmpout); 5722 ffebld_dump (asv); 5723 fputs ("),", dmpout); 5724#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5725#else 5726#error 5727#endif 5728} 5729 5730/* DEFINE FILE statement -- end. */ 5731 5732void 5733ffeste_V025_finish () 5734{ 5735 ffeste_check_finish_ (); 5736 5737#if FFECOM_targetCURRENT == FFECOM_targetFFE 5738 fputc ('\n', dmpout); 5739#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5740#else 5741#error 5742#endif 5743} 5744 5745/* FIND statement. */ 5746 5747void 5748ffeste_V026 (ffestpFindStmt *info) 5749{ 5750 ffeste_check_simple_ (); 5751 5752#if FFECOM_targetCURRENT == FFECOM_targetFFE 5753 fputs ("+ FIND (", dmpout); 5754 ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]); 5755 ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]); 5756 ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]); 5757 ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]); 5758 fputs (")\n", dmpout); 5759#elif FFECOM_targetCURRENT == FFECOM_targetGCC 5760#else 5761#error 5762#endif 5763} 5764 5765#endif 5766 5767#ifdef ENABLE_CHECKING 5768void 5769ffeste_terminate_2 (void) 5770{ 5771 assert (! ffeste_top_block_); 5772} 5773#endif 5774