1/* IO Code translation/library interface 2 Copyright (C) 2002-2015 Free Software Foundation, Inc. 3 Contributed by Paul Brook 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21 22#include "config.h" 23#include "system.h" 24#include "coretypes.h" 25#include "hash-set.h" 26#include "machmode.h" 27#include "vec.h" 28#include "double-int.h" 29#include "input.h" 30#include "alias.h" 31#include "symtab.h" 32#include "options.h" 33#include "wide-int.h" 34#include "inchash.h" 35#include "tree.h" 36#include "fold-const.h" 37#include "stringpool.h" 38#include "stor-layout.h" 39#include "ggc.h" 40#include "gfortran.h" 41#include "diagnostic-core.h" /* For internal_error. */ 42#include "trans.h" 43#include "trans-stmt.h" 44#include "trans-array.h" 45#include "trans-types.h" 46#include "trans-const.h" 47 48/* Members of the ioparm structure. */ 49 50enum ioparam_type 51{ 52 IOPARM_ptype_common, 53 IOPARM_ptype_open, 54 IOPARM_ptype_close, 55 IOPARM_ptype_filepos, 56 IOPARM_ptype_inquire, 57 IOPARM_ptype_dt, 58 IOPARM_ptype_wait, 59 IOPARM_ptype_num 60}; 61 62enum iofield_type 63{ 64 IOPARM_type_int4, 65 IOPARM_type_intio, 66 IOPARM_type_pint4, 67 IOPARM_type_pintio, 68 IOPARM_type_pchar, 69 IOPARM_type_parray, 70 IOPARM_type_pad, 71 IOPARM_type_char1, 72 IOPARM_type_char2, 73 IOPARM_type_common, 74 IOPARM_type_num 75}; 76 77typedef struct GTY(()) gfc_st_parameter_field { 78 const char *name; 79 unsigned int mask; 80 enum ioparam_type param_type; 81 enum iofield_type type; 82 tree field; 83 tree field_len; 84} 85gfc_st_parameter_field; 86 87typedef struct GTY(()) gfc_st_parameter { 88 const char *name; 89 tree type; 90} 91gfc_st_parameter; 92 93enum iofield 94{ 95#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name, 96#include "ioparm.def" 97#undef IOPARM 98 IOPARM_field_num 99}; 100 101static GTY(()) gfc_st_parameter st_parameter[] = 102{ 103 { "common", NULL }, 104 { "open", NULL }, 105 { "close", NULL }, 106 { "filepos", NULL }, 107 { "inquire", NULL }, 108 { "dt", NULL }, 109 { "wait", NULL } 110}; 111 112static GTY(()) gfc_st_parameter_field st_parameter_field[] = 113{ 114#define IOPARM(param_type, name, mask, type) \ 115 { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL }, 116#include "ioparm.def" 117#undef IOPARM 118 { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL } 119}; 120 121/* Library I/O subroutines */ 122 123enum iocall 124{ 125 IOCALL_READ, 126 IOCALL_READ_DONE, 127 IOCALL_WRITE, 128 IOCALL_WRITE_DONE, 129 IOCALL_X_INTEGER, 130 IOCALL_X_INTEGER_WRITE, 131 IOCALL_X_LOGICAL, 132 IOCALL_X_LOGICAL_WRITE, 133 IOCALL_X_CHARACTER, 134 IOCALL_X_CHARACTER_WRITE, 135 IOCALL_X_CHARACTER_WIDE, 136 IOCALL_X_CHARACTER_WIDE_WRITE, 137 IOCALL_X_REAL, 138 IOCALL_X_REAL_WRITE, 139 IOCALL_X_COMPLEX, 140 IOCALL_X_COMPLEX_WRITE, 141 IOCALL_X_REAL128, 142 IOCALL_X_REAL128_WRITE, 143 IOCALL_X_COMPLEX128, 144 IOCALL_X_COMPLEX128_WRITE, 145 IOCALL_X_ARRAY, 146 IOCALL_X_ARRAY_WRITE, 147 IOCALL_OPEN, 148 IOCALL_CLOSE, 149 IOCALL_INQUIRE, 150 IOCALL_IOLENGTH, 151 IOCALL_IOLENGTH_DONE, 152 IOCALL_REWIND, 153 IOCALL_BACKSPACE, 154 IOCALL_ENDFILE, 155 IOCALL_FLUSH, 156 IOCALL_SET_NML_VAL, 157 IOCALL_SET_NML_VAL_DIM, 158 IOCALL_WAIT, 159 IOCALL_NUM 160}; 161 162static GTY(()) tree iocall[IOCALL_NUM]; 163 164/* Variable for keeping track of what the last data transfer statement 165 was. Used for deciding which subroutine to call when the data 166 transfer is complete. */ 167static enum { READ, WRITE, IOLENGTH } last_dt; 168 169/* The data transfer parameter block that should be shared by all 170 data transfer calls belonging to the same read/write/iolength. */ 171static GTY(()) tree dt_parm; 172static stmtblock_t *dt_post_end_block; 173 174static void 175gfc_build_st_parameter (enum ioparam_type ptype, tree *types) 176{ 177 unsigned int type; 178 gfc_st_parameter_field *p; 179 char name[64]; 180 size_t len; 181 tree t = make_node (RECORD_TYPE); 182 tree *chain = NULL; 183 184 len = strlen (st_parameter[ptype].name); 185 gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_")); 186 memcpy (name, "__st_parameter_", sizeof ("__st_parameter_")); 187 memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name, 188 len + 1); 189 TYPE_NAME (t) = get_identifier (name); 190 191 for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++) 192 if (p->param_type == ptype) 193 switch (p->type) 194 { 195 case IOPARM_type_int4: 196 case IOPARM_type_intio: 197 case IOPARM_type_pint4: 198 case IOPARM_type_pintio: 199 case IOPARM_type_parray: 200 case IOPARM_type_pchar: 201 case IOPARM_type_pad: 202 p->field = gfc_add_field_to_struct (t, get_identifier (p->name), 203 types[p->type], &chain); 204 break; 205 case IOPARM_type_char1: 206 p->field = gfc_add_field_to_struct (t, get_identifier (p->name), 207 pchar_type_node, &chain); 208 /* FALLTHROUGH */ 209 case IOPARM_type_char2: 210 len = strlen (p->name); 211 gcc_assert (len <= sizeof (name) - sizeof ("_len")); 212 memcpy (name, p->name, len); 213 memcpy (name + len, "_len", sizeof ("_len")); 214 p->field_len = gfc_add_field_to_struct (t, get_identifier (name), 215 gfc_charlen_type_node, 216 &chain); 217 if (p->type == IOPARM_type_char2) 218 p->field = gfc_add_field_to_struct (t, get_identifier (p->name), 219 pchar_type_node, &chain); 220 break; 221 case IOPARM_type_common: 222 p->field 223 = gfc_add_field_to_struct (t, 224 get_identifier (p->name), 225 st_parameter[IOPARM_ptype_common].type, 226 &chain); 227 break; 228 case IOPARM_type_num: 229 gcc_unreachable (); 230 } 231 232 gfc_finish_type (t); 233 st_parameter[ptype].type = t; 234} 235 236 237/* Build code to test an error condition and call generate_error if needed. 238 Note: This builds calls to generate_error in the runtime library function. 239 The function generate_error is dependent on certain parameters in the 240 st_parameter_common flags to be set. (See libgfortran/runtime/error.c) 241 Therefore, the code to set these flags must be generated before 242 this function is used. */ 243 244static void 245gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var, 246 int error_code, const char * msgid, 247 stmtblock_t * pblock) 248{ 249 stmtblock_t block; 250 tree body; 251 tree tmp; 252 tree arg1, arg2, arg3; 253 char *message; 254 255 if (integer_zerop (cond)) 256 return; 257 258 /* The code to generate the error. */ 259 gfc_start_block (&block); 260 261 if (has_iostat) 262 gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO, 263 NOT_TAKEN)); 264 else 265 gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN, 266 NOT_TAKEN)); 267 268 arg1 = gfc_build_addr_expr (NULL_TREE, var); 269 270 arg2 = build_int_cst (integer_type_node, error_code), 271 272 message = xasprintf ("%s", _(msgid)); 273 arg3 = gfc_build_addr_expr (pchar_type_node, 274 gfc_build_localized_cstring_const (message)); 275 free (message); 276 277 tmp = build_call_expr_loc (input_location, 278 gfor_fndecl_generate_error, 3, arg1, arg2, arg3); 279 280 gfc_add_expr_to_block (&block, tmp); 281 282 body = gfc_finish_block (&block); 283 284 if (integer_onep (cond)) 285 { 286 gfc_add_expr_to_block (pblock, body); 287 } 288 else 289 { 290 tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); 291 gfc_add_expr_to_block (pblock, tmp); 292 } 293} 294 295 296/* Create function decls for IO library functions. */ 297 298void 299gfc_build_io_library_fndecls (void) 300{ 301 tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node; 302 tree gfc_intio_type_node; 303 tree parm_type, dt_parm_type; 304 HOST_WIDE_INT pad_size; 305 unsigned int ptype; 306 307 types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4); 308 types[IOPARM_type_intio] = gfc_intio_type_node 309 = gfc_get_int_type (gfc_intio_kind); 310 types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node); 311 types[IOPARM_type_pintio] 312 = build_pointer_type (gfc_intio_type_node); 313 types[IOPARM_type_parray] = pchar_type_node; 314 types[IOPARM_type_pchar] = pchar_type_node; 315 pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node)); 316 pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node)); 317 pad_idx = build_index_type (size_int (pad_size - 1)); 318 types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx); 319 320 /* pad actually contains pointers and integers so it needs to have an 321 alignment that is at least as large as the needed alignment for those 322 types. See the st_parameter_dt structure in libgfortran/io/io.h for 323 what really goes into this space. */ 324 TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node), 325 TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind))); 326 327 for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) 328 gfc_build_st_parameter ((enum ioparam_type) ptype, types); 329 330 /* Define the transfer functions. */ 331 332 dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); 333 334 iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec ( 335 get_identifier (PREFIX("transfer_integer")), ".wW", 336 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 337 338 iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec ( 339 get_identifier (PREFIX("transfer_integer_write")), ".wR", 340 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 341 342 iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec ( 343 get_identifier (PREFIX("transfer_logical")), ".wW", 344 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 345 346 iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec ( 347 get_identifier (PREFIX("transfer_logical_write")), ".wR", 348 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 349 350 iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( 351 get_identifier (PREFIX("transfer_character")), ".wW", 352 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 353 354 iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec ( 355 get_identifier (PREFIX("transfer_character_write")), ".wR", 356 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 357 358 iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( 359 get_identifier (PREFIX("transfer_character_wide")), ".wW", 360 void_type_node, 4, dt_parm_type, pvoid_type_node, 361 gfc_charlen_type_node, gfc_int4_type_node); 362 363 iocall[IOCALL_X_CHARACTER_WIDE_WRITE] = 364 gfc_build_library_function_decl_with_spec ( 365 get_identifier (PREFIX("transfer_character_wide_write")), ".wR", 366 void_type_node, 4, dt_parm_type, pvoid_type_node, 367 gfc_charlen_type_node, gfc_int4_type_node); 368 369 iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec ( 370 get_identifier (PREFIX("transfer_real")), ".wW", 371 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 372 373 iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec ( 374 get_identifier (PREFIX("transfer_real_write")), ".wR", 375 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 376 377 iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec ( 378 get_identifier (PREFIX("transfer_complex")), ".wW", 379 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 380 381 iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec ( 382 get_identifier (PREFIX("transfer_complex_write")), ".wR", 383 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 384 385 /* Version for __float128. */ 386 iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec ( 387 get_identifier (PREFIX("transfer_real128")), ".wW", 388 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 389 390 iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec ( 391 get_identifier (PREFIX("transfer_real128_write")), ".wR", 392 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 393 394 iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec ( 395 get_identifier (PREFIX("transfer_complex128")), ".wW", 396 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 397 398 iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec ( 399 get_identifier (PREFIX("transfer_complex128_write")), ".wR", 400 void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); 401 402 iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec ( 403 get_identifier (PREFIX("transfer_array")), ".ww", 404 void_type_node, 4, dt_parm_type, pvoid_type_node, 405 integer_type_node, gfc_charlen_type_node); 406 407 iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec ( 408 get_identifier (PREFIX("transfer_array_write")), ".wr", 409 void_type_node, 4, dt_parm_type, pvoid_type_node, 410 integer_type_node, gfc_charlen_type_node); 411 412 /* Library entry points */ 413 414 iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( 415 get_identifier (PREFIX("st_read")), ".w", 416 void_type_node, 1, dt_parm_type); 417 418 iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec ( 419 get_identifier (PREFIX("st_write")), ".w", 420 void_type_node, 1, dt_parm_type); 421 422 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type); 423 iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec ( 424 get_identifier (PREFIX("st_open")), ".w", 425 void_type_node, 1, parm_type); 426 427 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type); 428 iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec ( 429 get_identifier (PREFIX("st_close")), ".w", 430 void_type_node, 1, parm_type); 431 432 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type); 433 iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec ( 434 get_identifier (PREFIX("st_inquire")), ".w", 435 void_type_node, 1, parm_type); 436 437 iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec( 438 get_identifier (PREFIX("st_iolength")), ".w", 439 void_type_node, 1, dt_parm_type); 440 441 /* TODO: Change when asynchronous I/O is implemented. */ 442 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); 443 iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec ( 444 get_identifier (PREFIX("st_wait")), ".X", 445 void_type_node, 1, parm_type); 446 447 parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); 448 iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec ( 449 get_identifier (PREFIX("st_rewind")), ".w", 450 void_type_node, 1, parm_type); 451 452 iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec ( 453 get_identifier (PREFIX("st_backspace")), ".w", 454 void_type_node, 1, parm_type); 455 456 iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec ( 457 get_identifier (PREFIX("st_endfile")), ".w", 458 void_type_node, 1, parm_type); 459 460 iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec ( 461 get_identifier (PREFIX("st_flush")), ".w", 462 void_type_node, 1, parm_type); 463 464 /* Library helpers */ 465 466 iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec ( 467 get_identifier (PREFIX("st_read_done")), ".w", 468 void_type_node, 1, dt_parm_type); 469 470 iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec ( 471 get_identifier (PREFIX("st_write_done")), ".w", 472 void_type_node, 1, dt_parm_type); 473 474 iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec ( 475 get_identifier (PREFIX("st_iolength_done")), ".w", 476 void_type_node, 1, dt_parm_type); 477 478 iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec ( 479 get_identifier (PREFIX("st_set_nml_var")), ".w.R", 480 void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, 481 gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node); 482 483 iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( 484 get_identifier (PREFIX("st_set_nml_var_dim")), ".w", 485 void_type_node, 5, dt_parm_type, gfc_int4_type_node, 486 gfc_array_index_type, gfc_array_index_type, gfc_array_index_type); 487} 488 489 490/* Generate code to store an integer constant into the 491 st_parameter_XXX structure. */ 492 493static unsigned int 494set_parameter_const (stmtblock_t *block, tree var, enum iofield type, 495 unsigned int val) 496{ 497 tree tmp; 498 gfc_st_parameter_field *p = &st_parameter_field[type]; 499 500 if (p->param_type == IOPARM_ptype_common) 501 var = fold_build3_loc (input_location, COMPONENT_REF, 502 st_parameter[IOPARM_ptype_common].type, 503 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 504 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), 505 var, p->field, NULL_TREE); 506 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val)); 507 return p->mask; 508} 509 510 511/* Generate code to store a non-string I/O parameter into the 512 st_parameter_XXX structure. This is a pass by value. */ 513 514static unsigned int 515set_parameter_value (stmtblock_t *block, tree var, enum iofield type, 516 gfc_expr *e) 517{ 518 gfc_se se; 519 tree tmp; 520 gfc_st_parameter_field *p = &st_parameter_field[type]; 521 tree dest_type = TREE_TYPE (p->field); 522 523 gfc_init_se (&se, NULL); 524 gfc_conv_expr_val (&se, e); 525 526 se.expr = convert (dest_type, se.expr); 527 gfc_add_block_to_block (block, &se.pre); 528 529 if (p->param_type == IOPARM_ptype_common) 530 var = fold_build3_loc (input_location, COMPONENT_REF, 531 st_parameter[IOPARM_ptype_common].type, 532 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 533 534 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, 535 p->field, NULL_TREE); 536 gfc_add_modify (block, tmp, se.expr); 537 return p->mask; 538} 539 540 541/* Similar to set_parameter_value except generate runtime 542 error checks. */ 543 544static unsigned int 545set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, 546 enum iofield type, gfc_expr *e) 547{ 548 gfc_se se; 549 tree tmp; 550 gfc_st_parameter_field *p = &st_parameter_field[type]; 551 tree dest_type = TREE_TYPE (p->field); 552 553 gfc_init_se (&se, NULL); 554 gfc_conv_expr_val (&se, e); 555 556 /* If we're storing a UNIT number, we need to check it first. */ 557 if (type == IOPARM_common_unit && e->ts.kind > 4) 558 { 559 tree cond, val; 560 int i; 561 562 /* Don't evaluate the UNIT number multiple times. */ 563 se.expr = gfc_evaluate_now (se.expr, &se.pre); 564 565 /* UNIT numbers should be greater than the min. */ 566 i = gfc_validate_kind (BT_INTEGER, 4, false); 567 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); 568 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 569 se.expr, 570 fold_convert (TREE_TYPE (se.expr), val)); 571 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, 572 "Unit number in I/O statement too small", 573 &se.pre); 574 575 /* UNIT numbers should be less than the max. */ 576 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); 577 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, 578 se.expr, 579 fold_convert (TREE_TYPE (se.expr), val)); 580 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, 581 "Unit number in I/O statement too large", 582 &se.pre); 583 } 584 585 se.expr = convert (dest_type, se.expr); 586 gfc_add_block_to_block (block, &se.pre); 587 588 if (p->param_type == IOPARM_ptype_common) 589 var = fold_build3_loc (input_location, COMPONENT_REF, 590 st_parameter[IOPARM_ptype_common].type, 591 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 592 593 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, 594 p->field, NULL_TREE); 595 gfc_add_modify (block, tmp, se.expr); 596 return p->mask; 597} 598 599 600/* Build code to check the unit range if KIND=8 is used. Similar to 601 set_parameter_value_chk but we do not generate error calls for 602 inquire statements. */ 603 604static unsigned int 605set_parameter_value_inquire (stmtblock_t *block, tree var, 606 enum iofield type, gfc_expr *e) 607{ 608 gfc_se se; 609 gfc_st_parameter_field *p = &st_parameter_field[type]; 610 tree dest_type = TREE_TYPE (p->field); 611 612 gfc_init_se (&se, NULL); 613 gfc_conv_expr_val (&se, e); 614 615 /* If we're inquiring on a UNIT number, we need to check to make 616 sure it exists for larger than kind = 4. */ 617 if (type == IOPARM_common_unit && e->ts.kind > 4) 618 { 619 stmtblock_t newblock; 620 tree cond1, cond2, cond3, val, body; 621 int i; 622 623 /* Don't evaluate the UNIT number multiple times. */ 624 se.expr = gfc_evaluate_now (se.expr, &se.pre); 625 626 /* UNIT numbers should be greater than zero. */ 627 i = gfc_validate_kind (BT_INTEGER, 4, false); 628 cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node, 629 se.expr, 630 fold_convert (TREE_TYPE (se.expr), 631 integer_zero_node)); 632 /* UNIT numbers should be less than the max. */ 633 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); 634 cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node, 635 se.expr, 636 fold_convert (TREE_TYPE (se.expr), val)); 637 cond3 = build2_loc (input_location, TRUTH_OR_EXPR, 638 boolean_type_node, cond1, cond2); 639 640 gfc_start_block (&newblock); 641 642 /* The unit number GFC_INVALID_UNIT is reserved. No units can 643 ever have this value. It is used here to signal to the 644 runtime library that the inquire unit number is outside the 645 allowable range and so cannot exist. It is needed when 646 -fdefault-integer-8 is used. */ 647 set_parameter_const (&newblock, var, IOPARM_common_unit, 648 GFC_INVALID_UNIT); 649 650 body = gfc_finish_block (&newblock); 651 652 cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO); 653 var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location)); 654 gfc_add_expr_to_block (&se.pre, var); 655 } 656 657 se.expr = convert (dest_type, se.expr); 658 gfc_add_block_to_block (block, &se.pre); 659 660 return p->mask; 661} 662 663 664/* Generate code to store a non-string I/O parameter into the 665 st_parameter_XXX structure. This is pass by reference. */ 666 667static unsigned int 668set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, 669 tree var, enum iofield type, gfc_expr *e) 670{ 671 gfc_se se; 672 tree tmp, addr; 673 gfc_st_parameter_field *p = &st_parameter_field[type]; 674 675 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL); 676 gfc_init_se (&se, NULL); 677 gfc_conv_expr_lhs (&se, e); 678 679 gfc_add_block_to_block (block, &se.pre); 680 681 if (TYPE_MODE (TREE_TYPE (se.expr)) 682 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) 683 { 684 addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr)); 685 686 /* If this is for the iostat variable initialize the 687 user variable to LIBERROR_OK which is zero. */ 688 if (type == IOPARM_common_iostat) 689 gfc_add_modify (block, se.expr, 690 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK)); 691 } 692 else 693 { 694 /* The type used by the library has different size 695 from the type of the variable supplied by the user. 696 Need to use a temporary. */ 697 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), 698 st_parameter_field[type].name); 699 700 /* If this is for the iostat variable, initialize the 701 user variable to LIBERROR_OK which is zero. */ 702 if (type == IOPARM_common_iostat) 703 gfc_add_modify (block, tmpvar, 704 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK)); 705 706 addr = gfc_build_addr_expr (NULL_TREE, tmpvar); 707 /* After the I/O operation, we set the variable from the temporary. */ 708 tmp = convert (TREE_TYPE (se.expr), tmpvar); 709 gfc_add_modify (postblock, se.expr, tmp); 710 } 711 712 if (p->param_type == IOPARM_ptype_common) 713 var = fold_build3_loc (input_location, COMPONENT_REF, 714 st_parameter[IOPARM_ptype_common].type, 715 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 716 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), 717 var, p->field, NULL_TREE); 718 gfc_add_modify (block, tmp, addr); 719 return p->mask; 720} 721 722/* Given an array expr, find its address and length to get a string. If the 723 array is full, the string's address is the address of array's first element 724 and the length is the size of the whole array. If it is an element, the 725 string's address is the element's address and the length is the rest size of 726 the array. */ 727 728static void 729gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) 730{ 731 tree size; 732 733 if (e->rank == 0) 734 { 735 tree type, array, tmp; 736 gfc_symbol *sym; 737 int rank; 738 739 /* If it is an element, we need its address and size of the rest. */ 740 gcc_assert (e->expr_type == EXPR_VARIABLE); 741 gcc_assert (e->ref->u.ar.type == AR_ELEMENT); 742 sym = e->symtree->n.sym; 743 rank = sym->as->rank - 1; 744 gfc_conv_expr (se, e); 745 746 array = sym->backend_decl; 747 type = TREE_TYPE (array); 748 749 if (GFC_ARRAY_TYPE_P (type)) 750 size = GFC_TYPE_ARRAY_SIZE (type); 751 else 752 { 753 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 754 size = gfc_conv_array_stride (array, rank); 755 tmp = fold_build2_loc (input_location, MINUS_EXPR, 756 gfc_array_index_type, 757 gfc_conv_array_ubound (array, rank), 758 gfc_conv_array_lbound (array, rank)); 759 tmp = fold_build2_loc (input_location, PLUS_EXPR, 760 gfc_array_index_type, tmp, 761 gfc_index_one_node); 762 size = fold_build2_loc (input_location, MULT_EXPR, 763 gfc_array_index_type, tmp, size); 764 } 765 gcc_assert (size); 766 767 size = fold_build2_loc (input_location, MINUS_EXPR, 768 gfc_array_index_type, size, 769 TREE_OPERAND (se->expr, 1)); 770 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); 771 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 772 size = fold_build2_loc (input_location, MULT_EXPR, 773 gfc_array_index_type, size, 774 fold_convert (gfc_array_index_type, tmp)); 775 se->string_length = fold_convert (gfc_charlen_type_node, size); 776 return; 777 } 778 779 gfc_conv_array_parameter (se, e, true, NULL, NULL, &size); 780 se->string_length = fold_convert (gfc_charlen_type_node, size); 781} 782 783 784/* Generate code to store a string and its length into the 785 st_parameter_XXX structure. */ 786 787static unsigned int 788set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, 789 enum iofield type, gfc_expr * e) 790{ 791 gfc_se se; 792 tree tmp; 793 tree io; 794 tree len; 795 gfc_st_parameter_field *p = &st_parameter_field[type]; 796 797 gfc_init_se (&se, NULL); 798 799 if (p->param_type == IOPARM_ptype_common) 800 var = fold_build3_loc (input_location, COMPONENT_REF, 801 st_parameter[IOPARM_ptype_common].type, 802 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 803 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), 804 var, p->field, NULL_TREE); 805 len = fold_build3_loc (input_location, COMPONENT_REF, 806 TREE_TYPE (p->field_len), 807 var, p->field_len, NULL_TREE); 808 809 /* Integer variable assigned a format label. */ 810 if (e->ts.type == BT_INTEGER 811 && e->rank == 0 812 && e->symtree->n.sym->attr.assign == 1) 813 { 814 char * msg; 815 tree cond; 816 817 gfc_conv_label_variable (&se, e); 818 tmp = GFC_DECL_STRING_LEN (se.expr); 819 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 820 tmp, build_int_cst (TREE_TYPE (tmp), 0)); 821 822 msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format " 823 "label", e->symtree->name); 824 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg, 825 fold_convert (long_integer_type_node, tmp)); 826 free (msg); 827 828 gfc_add_modify (&se.pre, io, 829 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); 830 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); 831 } 832 else 833 { 834 /* General character. */ 835 if (e->ts.type == BT_CHARACTER && e->rank == 0) 836 gfc_conv_expr (&se, e); 837 /* Array assigned Hollerith constant or character array. */ 838 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0)) 839 gfc_convert_array_to_string (&se, e); 840 else 841 gcc_unreachable (); 842 843 gfc_conv_string_parameter (&se); 844 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); 845 gfc_add_modify (&se.pre, len, se.string_length); 846 } 847 848 gfc_add_block_to_block (block, &se.pre); 849 gfc_add_block_to_block (postblock, &se.post); 850 return p->mask; 851} 852 853 854/* Generate code to store the character (array) and the character length 855 for an internal unit. */ 856 857static unsigned int 858set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, 859 tree var, gfc_expr * e) 860{ 861 gfc_se se; 862 tree io; 863 tree len; 864 tree desc; 865 tree tmp; 866 gfc_st_parameter_field *p; 867 unsigned int mask; 868 869 gfc_init_se (&se, NULL); 870 871 p = &st_parameter_field[IOPARM_dt_internal_unit]; 872 mask = p->mask; 873 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), 874 var, p->field, NULL_TREE); 875 len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len), 876 var, p->field_len, NULL_TREE); 877 p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; 878 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), 879 var, p->field, NULL_TREE); 880 881 gcc_assert (e->ts.type == BT_CHARACTER); 882 883 /* Character scalars. */ 884 if (e->rank == 0) 885 { 886 gfc_conv_expr (&se, e); 887 gfc_conv_string_parameter (&se); 888 tmp = se.expr; 889 se.expr = build_int_cst (pchar_type_node, 0); 890 } 891 892 /* Character array. */ 893 else if (e->rank > 0) 894 { 895 if (is_subref_array (e)) 896 { 897 /* Use a temporary for components of arrays of derived types 898 or substring array references. */ 899 gfc_conv_subref_array_arg (&se, e, 0, 900 last_dt == READ ? INTENT_IN : INTENT_OUT, false); 901 tmp = build_fold_indirect_ref_loc (input_location, 902 se.expr); 903 se.expr = gfc_build_addr_expr (pchar_type_node, tmp); 904 tmp = gfc_conv_descriptor_data_get (tmp); 905 } 906 else 907 { 908 /* Return the data pointer and rank from the descriptor. */ 909 gfc_conv_expr_descriptor (&se, e); 910 tmp = gfc_conv_descriptor_data_get (se.expr); 911 se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); 912 } 913 } 914 else 915 gcc_unreachable (); 916 917 /* The cast is needed for character substrings and the descriptor 918 data. */ 919 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); 920 gfc_add_modify (&se.pre, len, 921 fold_convert (TREE_TYPE (len), se.string_length)); 922 gfc_add_modify (&se.pre, desc, se.expr); 923 924 gfc_add_block_to_block (block, &se.pre); 925 gfc_add_block_to_block (post_block, &se.post); 926 return mask; 927} 928 929/* Add a case to a IO-result switch. */ 930 931static void 932add_case (int label_value, gfc_st_label * label, stmtblock_t * body) 933{ 934 tree tmp, value; 935 936 if (label == NULL) 937 return; /* No label, no case */ 938 939 value = build_int_cst (integer_type_node, label_value); 940 941 /* Make a backend label for this case. */ 942 tmp = gfc_build_label_decl (NULL_TREE); 943 944 /* And the case itself. */ 945 tmp = build_case_label (value, NULL_TREE, tmp); 946 gfc_add_expr_to_block (body, tmp); 947 948 /* Jump to the label. */ 949 tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label)); 950 gfc_add_expr_to_block (body, tmp); 951} 952 953 954/* Generate a switch statement that branches to the correct I/O 955 result label. The last statement of an I/O call stores the 956 result into a variable because there is often cleanup that 957 must be done before the switch, so a temporary would have to 958 be created anyway. */ 959 960static void 961io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, 962 gfc_st_label * end_label, gfc_st_label * eor_label) 963{ 964 stmtblock_t body; 965 tree tmp, rc; 966 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; 967 968 /* If no labels are specified, ignore the result instead 969 of building an empty switch. */ 970 if (err_label == NULL 971 && end_label == NULL 972 && eor_label == NULL) 973 return; 974 975 /* Build a switch statement. */ 976 gfc_start_block (&body); 977 978 /* The label values here must be the same as the values 979 in the library_return enum in the runtime library */ 980 add_case (1, err_label, &body); 981 add_case (2, end_label, &body); 982 add_case (3, eor_label, &body); 983 984 tmp = gfc_finish_block (&body); 985 986 var = fold_build3_loc (input_location, COMPONENT_REF, 987 st_parameter[IOPARM_ptype_common].type, 988 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 989 rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), 990 var, p->field, NULL_TREE); 991 rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc), 992 rc, build_int_cst (TREE_TYPE (rc), 993 IOPARM_common_libreturn_mask)); 994 995 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE, 996 rc, tmp, NULL_TREE); 997 998 gfc_add_expr_to_block (block, tmp); 999} 1000 1001 1002/* Store the current file and line number to variables so that if a 1003 library call goes awry, we can tell the user where the problem is. */ 1004 1005static void 1006set_error_locus (stmtblock_t * block, tree var, locus * where) 1007{ 1008 gfc_file *f; 1009 tree str, locus_file; 1010 int line; 1011 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; 1012 1013 locus_file = fold_build3_loc (input_location, COMPONENT_REF, 1014 st_parameter[IOPARM_ptype_common].type, 1015 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); 1016 locus_file = fold_build3_loc (input_location, COMPONENT_REF, 1017 TREE_TYPE (p->field), locus_file, 1018 p->field, NULL_TREE); 1019 f = where->lb->file; 1020 str = gfc_build_cstring_const (f->filename); 1021 1022 str = gfc_build_addr_expr (pchar_type_node, str); 1023 gfc_add_modify (block, locus_file, str); 1024 1025 line = LOCATION_LINE (where->lb->location); 1026 set_parameter_const (block, var, IOPARM_common_line, line); 1027} 1028 1029 1030/* Translate an OPEN statement. */ 1031 1032tree 1033gfc_trans_open (gfc_code * code) 1034{ 1035 stmtblock_t block, post_block; 1036 gfc_open *p; 1037 tree tmp, var; 1038 unsigned int mask = 0; 1039 1040 gfc_start_block (&block); 1041 gfc_init_block (&post_block); 1042 1043 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm"); 1044 1045 set_error_locus (&block, var, &code->loc); 1046 p = code->ext.open; 1047 1048 if (p->iomsg) 1049 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, 1050 p->iomsg); 1051 1052 if (p->iostat) 1053 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, 1054 p->iostat); 1055 1056 if (p->err) 1057 mask |= IOPARM_common_err; 1058 1059 if (p->file) 1060 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file); 1061 1062 if (p->status) 1063 mask |= set_string (&block, &post_block, var, IOPARM_open_status, 1064 p->status); 1065 1066 if (p->access) 1067 mask |= set_string (&block, &post_block, var, IOPARM_open_access, 1068 p->access); 1069 1070 if (p->form) 1071 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); 1072 1073 if (p->recl) 1074 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, 1075 p->recl); 1076 1077 if (p->blank) 1078 mask |= set_string (&block, &post_block, var, IOPARM_open_blank, 1079 p->blank); 1080 1081 if (p->position) 1082 mask |= set_string (&block, &post_block, var, IOPARM_open_position, 1083 p->position); 1084 1085 if (p->action) 1086 mask |= set_string (&block, &post_block, var, IOPARM_open_action, 1087 p->action); 1088 1089 if (p->delim) 1090 mask |= set_string (&block, &post_block, var, IOPARM_open_delim, 1091 p->delim); 1092 1093 if (p->pad) 1094 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); 1095 1096 if (p->decimal) 1097 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal, 1098 p->decimal); 1099 1100 if (p->encoding) 1101 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding, 1102 p->encoding); 1103 1104 if (p->round) 1105 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round); 1106 1107 if (p->sign) 1108 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign); 1109 1110 if (p->asynchronous) 1111 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous, 1112 p->asynchronous); 1113 1114 if (p->convert) 1115 mask |= set_string (&block, &post_block, var, IOPARM_open_convert, 1116 p->convert); 1117 1118 if (p->newunit) 1119 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit, 1120 p->newunit); 1121 1122 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1123 1124 if (p->unit) 1125 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); 1126 else 1127 set_parameter_const (&block, var, IOPARM_common_unit, 0); 1128 1129 tmp = gfc_build_addr_expr (NULL_TREE, var); 1130 tmp = build_call_expr_loc (input_location, 1131 iocall[IOCALL_OPEN], 1, tmp); 1132 gfc_add_expr_to_block (&block, tmp); 1133 1134 gfc_add_block_to_block (&block, &post_block); 1135 1136 io_result (&block, var, p->err, NULL, NULL); 1137 1138 return gfc_finish_block (&block); 1139} 1140 1141 1142/* Translate a CLOSE statement. */ 1143 1144tree 1145gfc_trans_close (gfc_code * code) 1146{ 1147 stmtblock_t block, post_block; 1148 gfc_close *p; 1149 tree tmp, var; 1150 unsigned int mask = 0; 1151 1152 gfc_start_block (&block); 1153 gfc_init_block (&post_block); 1154 1155 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm"); 1156 1157 set_error_locus (&block, var, &code->loc); 1158 p = code->ext.close; 1159 1160 if (p->iomsg) 1161 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, 1162 p->iomsg); 1163 1164 if (p->iostat) 1165 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, 1166 p->iostat); 1167 1168 if (p->err) 1169 mask |= IOPARM_common_err; 1170 1171 if (p->status) 1172 mask |= set_string (&block, &post_block, var, IOPARM_close_status, 1173 p->status); 1174 1175 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1176 1177 if (p->unit) 1178 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); 1179 else 1180 set_parameter_const (&block, var, IOPARM_common_unit, 0); 1181 1182 tmp = gfc_build_addr_expr (NULL_TREE, var); 1183 tmp = build_call_expr_loc (input_location, 1184 iocall[IOCALL_CLOSE], 1, tmp); 1185 gfc_add_expr_to_block (&block, tmp); 1186 1187 gfc_add_block_to_block (&block, &post_block); 1188 1189 io_result (&block, var, p->err, NULL, NULL); 1190 1191 return gfc_finish_block (&block); 1192} 1193 1194 1195/* Common subroutine for building a file positioning statement. */ 1196 1197static tree 1198build_filepos (tree function, gfc_code * code) 1199{ 1200 stmtblock_t block, post_block; 1201 gfc_filepos *p; 1202 tree tmp, var; 1203 unsigned int mask = 0; 1204 1205 p = code->ext.filepos; 1206 1207 gfc_start_block (&block); 1208 gfc_init_block (&post_block); 1209 1210 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type, 1211 "filepos_parm"); 1212 1213 set_error_locus (&block, var, &code->loc); 1214 1215 if (p->iomsg) 1216 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, 1217 p->iomsg); 1218 1219 if (p->iostat) 1220 mask |= set_parameter_ref (&block, &post_block, var, 1221 IOPARM_common_iostat, p->iostat); 1222 1223 if (p->err) 1224 mask |= IOPARM_common_err; 1225 1226 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1227 1228 if (p->unit) 1229 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, 1230 p->unit); 1231 else 1232 set_parameter_const (&block, var, IOPARM_common_unit, 0); 1233 1234 tmp = gfc_build_addr_expr (NULL_TREE, var); 1235 tmp = build_call_expr_loc (input_location, 1236 function, 1, tmp); 1237 gfc_add_expr_to_block (&block, tmp); 1238 1239 gfc_add_block_to_block (&block, &post_block); 1240 1241 io_result (&block, var, p->err, NULL, NULL); 1242 1243 return gfc_finish_block (&block); 1244} 1245 1246 1247/* Translate a BACKSPACE statement. */ 1248 1249tree 1250gfc_trans_backspace (gfc_code * code) 1251{ 1252 return build_filepos (iocall[IOCALL_BACKSPACE], code); 1253} 1254 1255 1256/* Translate an ENDFILE statement. */ 1257 1258tree 1259gfc_trans_endfile (gfc_code * code) 1260{ 1261 return build_filepos (iocall[IOCALL_ENDFILE], code); 1262} 1263 1264 1265/* Translate a REWIND statement. */ 1266 1267tree 1268gfc_trans_rewind (gfc_code * code) 1269{ 1270 return build_filepos (iocall[IOCALL_REWIND], code); 1271} 1272 1273 1274/* Translate a FLUSH statement. */ 1275 1276tree 1277gfc_trans_flush (gfc_code * code) 1278{ 1279 return build_filepos (iocall[IOCALL_FLUSH], code); 1280} 1281 1282 1283/* Translate the non-IOLENGTH form of an INQUIRE statement. */ 1284 1285tree 1286gfc_trans_inquire (gfc_code * code) 1287{ 1288 stmtblock_t block, post_block; 1289 gfc_inquire *p; 1290 tree tmp, var; 1291 unsigned int mask = 0, mask2 = 0; 1292 1293 gfc_start_block (&block); 1294 gfc_init_block (&post_block); 1295 1296 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type, 1297 "inquire_parm"); 1298 1299 set_error_locus (&block, var, &code->loc); 1300 p = code->ext.inquire; 1301 1302 if (p->iomsg) 1303 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, 1304 p->iomsg); 1305 1306 if (p->iostat) 1307 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, 1308 p->iostat); 1309 1310 if (p->err) 1311 mask |= IOPARM_common_err; 1312 1313 /* Sanity check. */ 1314 if (p->unit && p->file) 1315 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); 1316 1317 if (p->file) 1318 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, 1319 p->file); 1320 1321 if (p->exist) 1322 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, 1323 p->exist); 1324 1325 if (p->opened) 1326 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, 1327 p->opened); 1328 1329 if (p->number) 1330 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number, 1331 p->number); 1332 1333 if (p->named) 1334 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named, 1335 p->named); 1336 1337 if (p->name) 1338 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name, 1339 p->name); 1340 1341 if (p->access) 1342 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access, 1343 p->access); 1344 1345 if (p->sequential) 1346 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential, 1347 p->sequential); 1348 1349 if (p->direct) 1350 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct, 1351 p->direct); 1352 1353 if (p->form) 1354 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form, 1355 p->form); 1356 1357 if (p->formatted) 1358 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted, 1359 p->formatted); 1360 1361 if (p->unformatted) 1362 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted, 1363 p->unformatted); 1364 1365 if (p->recl) 1366 mask |= set_parameter_ref (&block, &post_block, var, 1367 IOPARM_inquire_recl_out, p->recl); 1368 1369 if (p->nextrec) 1370 mask |= set_parameter_ref (&block, &post_block, var, 1371 IOPARM_inquire_nextrec, p->nextrec); 1372 1373 if (p->blank) 1374 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank, 1375 p->blank); 1376 1377 if (p->delim) 1378 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim, 1379 p->delim); 1380 1381 if (p->position) 1382 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position, 1383 p->position); 1384 1385 if (p->action) 1386 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action, 1387 p->action); 1388 1389 if (p->read) 1390 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read, 1391 p->read); 1392 1393 if (p->write) 1394 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write, 1395 p->write); 1396 1397 if (p->readwrite) 1398 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite, 1399 p->readwrite); 1400 1401 if (p->pad) 1402 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, 1403 p->pad); 1404 1405 if (p->convert) 1406 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert, 1407 p->convert); 1408 1409 if (p->strm_pos) 1410 mask |= set_parameter_ref (&block, &post_block, var, 1411 IOPARM_inquire_strm_pos_out, p->strm_pos); 1412 1413 /* The second series of flags. */ 1414 if (p->asynchronous) 1415 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous, 1416 p->asynchronous); 1417 1418 if (p->decimal) 1419 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal, 1420 p->decimal); 1421 1422 if (p->encoding) 1423 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding, 1424 p->encoding); 1425 1426 if (p->round) 1427 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round, 1428 p->round); 1429 1430 if (p->sign) 1431 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign, 1432 p->sign); 1433 1434 if (p->pending) 1435 mask2 |= set_parameter_ref (&block, &post_block, var, 1436 IOPARM_inquire_pending, p->pending); 1437 1438 if (p->size) 1439 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size, 1440 p->size); 1441 1442 if (p->id) 1443 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id, 1444 p->id); 1445 if (p->iqstream) 1446 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream, 1447 p->iqstream); 1448 1449 if (mask2) 1450 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); 1451 1452 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1453 1454 if (p->unit) 1455 { 1456 set_parameter_value (&block, var, IOPARM_common_unit, p->unit); 1457 set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit); 1458 } 1459 else 1460 set_parameter_const (&block, var, IOPARM_common_unit, 0); 1461 1462 tmp = gfc_build_addr_expr (NULL_TREE, var); 1463 tmp = build_call_expr_loc (input_location, 1464 iocall[IOCALL_INQUIRE], 1, tmp); 1465 gfc_add_expr_to_block (&block, tmp); 1466 1467 gfc_add_block_to_block (&block, &post_block); 1468 1469 io_result (&block, var, p->err, NULL, NULL); 1470 1471 return gfc_finish_block (&block); 1472} 1473 1474 1475tree 1476gfc_trans_wait (gfc_code * code) 1477{ 1478 stmtblock_t block, post_block; 1479 gfc_wait *p; 1480 tree tmp, var; 1481 unsigned int mask = 0; 1482 1483 gfc_start_block (&block); 1484 gfc_init_block (&post_block); 1485 1486 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type, 1487 "wait_parm"); 1488 1489 set_error_locus (&block, var, &code->loc); 1490 p = code->ext.wait; 1491 1492 /* Set parameters here. */ 1493 if (p->iomsg) 1494 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, 1495 p->iomsg); 1496 1497 if (p->iostat) 1498 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, 1499 p->iostat); 1500 1501 if (p->err) 1502 mask |= IOPARM_common_err; 1503 1504 if (p->id) 1505 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id); 1506 1507 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1508 1509 if (p->unit) 1510 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); 1511 1512 tmp = gfc_build_addr_expr (NULL_TREE, var); 1513 tmp = build_call_expr_loc (input_location, 1514 iocall[IOCALL_WAIT], 1, tmp); 1515 gfc_add_expr_to_block (&block, tmp); 1516 1517 gfc_add_block_to_block (&block, &post_block); 1518 1519 io_result (&block, var, p->err, NULL, NULL); 1520 1521 return gfc_finish_block (&block); 1522 1523} 1524 1525 1526/* nml_full_name builds up the fully qualified name of a 1527 derived type component. '+' is used to denote a type extension. */ 1528 1529static char* 1530nml_full_name (const char* var_name, const char* cmp_name, bool parent) 1531{ 1532 int full_name_length; 1533 char * full_name; 1534 1535 full_name_length = strlen (var_name) + strlen (cmp_name) + 1; 1536 full_name = XCNEWVEC (char, full_name_length + 1); 1537 strcpy (full_name, var_name); 1538 full_name = strcat (full_name, parent ? "+" : "%"); 1539 full_name = strcat (full_name, cmp_name); 1540 return full_name; 1541} 1542 1543 1544/* nml_get_addr_expr builds an address expression from the 1545 gfc_symbol or gfc_component backend_decl's. An offset is 1546 provided so that the address of an element of an array of 1547 derived types is returned. This is used in the runtime to 1548 determine that span of the derived type. */ 1549 1550static tree 1551nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, 1552 tree base_addr) 1553{ 1554 tree decl = NULL_TREE; 1555 tree tmp; 1556 1557 if (sym) 1558 { 1559 sym->attr.referenced = 1; 1560 decl = gfc_get_symbol_decl (sym); 1561 1562 /* If this is the enclosing function declaration, use 1563 the fake result instead. */ 1564 if (decl == current_function_decl) 1565 decl = gfc_get_fake_result_decl (sym, 0); 1566 else if (decl == DECL_CONTEXT (current_function_decl)) 1567 decl = gfc_get_fake_result_decl (sym, 1); 1568 } 1569 else 1570 decl = c->backend_decl; 1571 1572 gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL 1573 || TREE_CODE (decl) == VAR_DECL 1574 || TREE_CODE (decl) == PARM_DECL) 1575 || TREE_CODE (decl) == COMPONENT_REF)); 1576 1577 tmp = decl; 1578 1579 /* Build indirect reference, if dummy argument. */ 1580 1581 if (POINTER_TYPE_P (TREE_TYPE(tmp))) 1582 tmp = build_fold_indirect_ref_loc (input_location, tmp); 1583 1584 /* Treat the component of a derived type, using base_addr for 1585 the derived type. */ 1586 1587 if (TREE_CODE (decl) == FIELD_DECL) 1588 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), 1589 base_addr, tmp, NULL_TREE); 1590 1591 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 1592 tmp = gfc_conv_array_data (tmp); 1593 else 1594 { 1595 if (!POINTER_TYPE_P (TREE_TYPE (tmp))) 1596 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 1597 1598 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) 1599 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL); 1600 1601 if (!POINTER_TYPE_P (TREE_TYPE (tmp))) 1602 tmp = build_fold_indirect_ref_loc (input_location, 1603 tmp); 1604 } 1605 1606 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); 1607 1608 return tmp; 1609} 1610 1611 1612/* For an object VAR_NAME whose base address is BASE_ADDR, generate a 1613 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively 1614 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */ 1615 1616#define IARG(i) build_int_cst (gfc_array_index_type, i) 1617 1618static void 1619transfer_namelist_element (stmtblock_t * block, const char * var_name, 1620 gfc_symbol * sym, gfc_component * c, 1621 tree base_addr) 1622{ 1623 gfc_typespec * ts = NULL; 1624 gfc_array_spec * as = NULL; 1625 tree addr_expr = NULL; 1626 tree dt = NULL; 1627 tree string; 1628 tree tmp; 1629 tree dtype; 1630 tree dt_parm_addr; 1631 tree decl = NULL_TREE; 1632 tree gfc_int4_type_node = gfc_get_int_type (4); 1633 int n_dim; 1634 int itype; 1635 int rank = 0; 1636 1637 gcc_assert (sym || c); 1638 1639 /* Build the namelist object name. */ 1640 1641 string = gfc_build_cstring_const (var_name); 1642 string = gfc_build_addr_expr (pchar_type_node, string); 1643 1644 /* Build ts, as and data address using symbol or component. */ 1645 1646 ts = (sym) ? &sym->ts : &c->ts; 1647 as = (sym) ? sym->as : c->as; 1648 1649 addr_expr = nml_get_addr_expr (sym, c, base_addr); 1650 1651 if (as) 1652 rank = as->rank; 1653 1654 if (rank) 1655 { 1656 decl = (sym) ? sym->backend_decl : c->backend_decl; 1657 if (sym && sym->attr.dummy) 1658 decl = build_fold_indirect_ref_loc (input_location, decl); 1659 dt = TREE_TYPE (decl); 1660 dtype = gfc_get_dtype (dt); 1661 } 1662 else 1663 { 1664 itype = ts->type; 1665 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT); 1666 } 1667 1668 /* Build up the arguments for the transfer call. 1669 The call for the scalar part transfers: 1670 (address, name, type, kind or string_length, dtype) */ 1671 1672 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); 1673 1674 if (ts->type == BT_CHARACTER) 1675 tmp = ts->u.cl->backend_decl; 1676 else 1677 tmp = build_int_cst (gfc_charlen_type_node, 0); 1678 tmp = build_call_expr_loc (input_location, 1679 iocall[IOCALL_SET_NML_VAL], 6, 1680 dt_parm_addr, addr_expr, string, 1681 build_int_cst (gfc_int4_type_node, ts->kind), 1682 tmp, dtype); 1683 gfc_add_expr_to_block (block, tmp); 1684 1685 /* If the object is an array, transfer rank times: 1686 (null pointer, name, stride, lbound, ubound) */ 1687 1688 for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) 1689 { 1690 tmp = build_call_expr_loc (input_location, 1691 iocall[IOCALL_SET_NML_VAL_DIM], 5, 1692 dt_parm_addr, 1693 build_int_cst (gfc_int4_type_node, n_dim), 1694 gfc_conv_array_stride (decl, n_dim), 1695 gfc_conv_array_lbound (decl, n_dim), 1696 gfc_conv_array_ubound (decl, n_dim)); 1697 gfc_add_expr_to_block (block, tmp); 1698 } 1699 1700 if (ts->type == BT_DERIVED && ts->u.derived->components) 1701 { 1702 gfc_component *cmp; 1703 1704 /* Provide the RECORD_TYPE to build component references. */ 1705 1706 tree expr = build_fold_indirect_ref_loc (input_location, 1707 addr_expr); 1708 1709 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next) 1710 { 1711 char *full_name = nml_full_name (var_name, cmp->name, 1712 ts->u.derived->attr.extension); 1713 transfer_namelist_element (block, 1714 full_name, 1715 NULL, cmp, expr); 1716 free (full_name); 1717 } 1718 } 1719} 1720 1721#undef IARG 1722 1723/* Create a data transfer statement. Not all of the fields are valid 1724 for both reading and writing, but improper use has been filtered 1725 out by now. */ 1726 1727static tree 1728build_dt (tree function, gfc_code * code) 1729{ 1730 stmtblock_t block, post_block, post_end_block, post_iu_block; 1731 gfc_dt *dt; 1732 tree tmp, var; 1733 gfc_expr *nmlname; 1734 gfc_namelist *nml; 1735 unsigned int mask = 0; 1736 1737 gfc_start_block (&block); 1738 gfc_init_block (&post_block); 1739 gfc_init_block (&post_end_block); 1740 gfc_init_block (&post_iu_block); 1741 1742 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm"); 1743 1744 set_error_locus (&block, var, &code->loc); 1745 1746 if (last_dt == IOLENGTH) 1747 { 1748 gfc_inquire *inq; 1749 1750 inq = code->ext.inquire; 1751 1752 /* First check that preconditions are met. */ 1753 gcc_assert (inq != NULL); 1754 gcc_assert (inq->iolength != NULL); 1755 1756 /* Connect to the iolength variable. */ 1757 mask |= set_parameter_ref (&block, &post_end_block, var, 1758 IOPARM_dt_iolength, inq->iolength); 1759 dt = NULL; 1760 } 1761 else 1762 { 1763 dt = code->ext.dt; 1764 gcc_assert (dt != NULL); 1765 } 1766 1767 if (dt && dt->io_unit) 1768 { 1769 if (dt->io_unit->ts.type == BT_CHARACTER) 1770 { 1771 mask |= set_internal_unit (&block, &post_iu_block, 1772 var, dt->io_unit); 1773 set_parameter_const (&block, var, IOPARM_common_unit, 1774 dt->io_unit->ts.kind == 1 ? 0 : -1); 1775 } 1776 } 1777 else 1778 set_parameter_const (&block, var, IOPARM_common_unit, 0); 1779 1780 if (dt) 1781 { 1782 if (dt->iomsg) 1783 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, 1784 dt->iomsg); 1785 1786 if (dt->iostat) 1787 mask |= set_parameter_ref (&block, &post_end_block, var, 1788 IOPARM_common_iostat, dt->iostat); 1789 1790 if (dt->err) 1791 mask |= IOPARM_common_err; 1792 1793 if (dt->eor) 1794 mask |= IOPARM_common_eor; 1795 1796 if (dt->end) 1797 mask |= IOPARM_common_end; 1798 1799 if (dt->id) 1800 mask |= set_parameter_ref (&block, &post_end_block, var, 1801 IOPARM_dt_id, dt->id); 1802 1803 if (dt->pos) 1804 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); 1805 1806 if (dt->asynchronous) 1807 mask |= set_string (&block, &post_block, var, 1808 IOPARM_dt_asynchronous, dt->asynchronous); 1809 1810 if (dt->blank) 1811 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, 1812 dt->blank); 1813 1814 if (dt->decimal) 1815 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal, 1816 dt->decimal); 1817 1818 if (dt->delim) 1819 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim, 1820 dt->delim); 1821 1822 if (dt->pad) 1823 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad, 1824 dt->pad); 1825 1826 if (dt->round) 1827 mask |= set_string (&block, &post_block, var, IOPARM_dt_round, 1828 dt->round); 1829 1830 if (dt->sign) 1831 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign, 1832 dt->sign); 1833 1834 if (dt->rec) 1835 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); 1836 1837 if (dt->advance) 1838 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, 1839 dt->advance); 1840 1841 if (dt->format_expr) 1842 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format, 1843 dt->format_expr); 1844 1845 if (dt->format_label) 1846 { 1847 if (dt->format_label == &format_asterisk) 1848 mask |= IOPARM_dt_list_format; 1849 else 1850 mask |= set_string (&block, &post_block, var, IOPARM_dt_format, 1851 dt->format_label->format); 1852 } 1853 1854 if (dt->size) 1855 mask |= set_parameter_ref (&block, &post_end_block, var, 1856 IOPARM_dt_size, dt->size); 1857 1858 if (dt->namelist) 1859 { 1860 if (dt->format_expr || dt->format_label) 1861 gfc_internal_error ("build_dt: format with namelist"); 1862 1863 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL, 1864 dt->namelist->name, 1865 strlen (dt->namelist->name)); 1866 1867 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name, 1868 nmlname); 1869 1870 gfc_free_expr (nmlname); 1871 1872 if (last_dt == READ) 1873 mask |= IOPARM_dt_namelist_read_mode; 1874 1875 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1876 1877 dt_parm = var; 1878 1879 for (nml = dt->namelist->namelist; nml; nml = nml->next) 1880 transfer_namelist_element (&block, nml->sym->name, nml->sym, 1881 NULL, NULL_TREE); 1882 } 1883 else 1884 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1885 1886 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) 1887 set_parameter_value_chk (&block, dt->iostat, var, 1888 IOPARM_common_unit, dt->io_unit); 1889 } 1890 else 1891 set_parameter_const (&block, var, IOPARM_common_flags, mask); 1892 1893 tmp = gfc_build_addr_expr (NULL_TREE, var); 1894 tmp = build_call_expr_loc (UNKNOWN_LOCATION, 1895 function, 1, tmp); 1896 gfc_add_expr_to_block (&block, tmp); 1897 1898 gfc_add_block_to_block (&block, &post_block); 1899 1900 dt_parm = var; 1901 dt_post_end_block = &post_end_block; 1902 1903 /* Set implied do loop exit condition. */ 1904 if (last_dt == READ || last_dt == WRITE) 1905 { 1906 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; 1907 1908 tmp = fold_build3_loc (input_location, COMPONENT_REF, 1909 st_parameter[IOPARM_ptype_common].type, 1910 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), 1911 NULL_TREE); 1912 tmp = fold_build3_loc (input_location, COMPONENT_REF, 1913 TREE_TYPE (p->field), tmp, p->field, NULL_TREE); 1914 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp), 1915 tmp, build_int_cst (TREE_TYPE (tmp), 1916 IOPARM_common_libreturn_mask)); 1917 } 1918 else /* IOLENGTH */ 1919 tmp = NULL_TREE; 1920 1921 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp)); 1922 1923 gfc_add_block_to_block (&block, &post_iu_block); 1924 1925 dt_parm = NULL; 1926 dt_post_end_block = NULL; 1927 1928 return gfc_finish_block (&block); 1929} 1930 1931 1932/* Translate the IOLENGTH form of an INQUIRE statement. We treat 1933 this as a third sort of data transfer statement, except that 1934 lengths are summed instead of actually transferring any data. */ 1935 1936tree 1937gfc_trans_iolength (gfc_code * code) 1938{ 1939 last_dt = IOLENGTH; 1940 return build_dt (iocall[IOCALL_IOLENGTH], code); 1941} 1942 1943 1944/* Translate a READ statement. */ 1945 1946tree 1947gfc_trans_read (gfc_code * code) 1948{ 1949 last_dt = READ; 1950 return build_dt (iocall[IOCALL_READ], code); 1951} 1952 1953 1954/* Translate a WRITE statement */ 1955 1956tree 1957gfc_trans_write (gfc_code * code) 1958{ 1959 last_dt = WRITE; 1960 return build_dt (iocall[IOCALL_WRITE], code); 1961} 1962 1963 1964/* Finish a data transfer statement. */ 1965 1966tree 1967gfc_trans_dt_end (gfc_code * code) 1968{ 1969 tree function, tmp; 1970 stmtblock_t block; 1971 1972 gfc_init_block (&block); 1973 1974 switch (last_dt) 1975 { 1976 case READ: 1977 function = iocall[IOCALL_READ_DONE]; 1978 break; 1979 1980 case WRITE: 1981 function = iocall[IOCALL_WRITE_DONE]; 1982 break; 1983 1984 case IOLENGTH: 1985 function = iocall[IOCALL_IOLENGTH_DONE]; 1986 break; 1987 1988 default: 1989 gcc_unreachable (); 1990 } 1991 1992 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); 1993 tmp = build_call_expr_loc (input_location, 1994 function, 1, tmp); 1995 gfc_add_expr_to_block (&block, tmp); 1996 gfc_add_block_to_block (&block, dt_post_end_block); 1997 gfc_init_block (dt_post_end_block); 1998 1999 if (last_dt != IOLENGTH) 2000 { 2001 gcc_assert (code->ext.dt != NULL); 2002 io_result (&block, dt_parm, code->ext.dt->err, 2003 code->ext.dt->end, code->ext.dt->eor); 2004 } 2005 2006 return gfc_finish_block (&block); 2007} 2008 2009static void 2010transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code); 2011 2012/* Given an array field in a derived type variable, generate the code 2013 for the loop that iterates over array elements, and the code that 2014 accesses those array elements. Use transfer_expr to generate code 2015 for transferring that element. Because elements may also be 2016 derived types, transfer_expr and transfer_array_component are mutually 2017 recursive. */ 2018 2019static tree 2020transfer_array_component (tree expr, gfc_component * cm, locus * where) 2021{ 2022 tree tmp; 2023 stmtblock_t body; 2024 stmtblock_t block; 2025 gfc_loopinfo loop; 2026 int n; 2027 gfc_ss *ss; 2028 gfc_se se; 2029 gfc_array_info *ss_array; 2030 2031 gfc_start_block (&block); 2032 gfc_init_se (&se, NULL); 2033 2034 /* Create and initialize Scalarization Status. Unlike in 2035 gfc_trans_transfer, we can't simply use gfc_walk_expr to take 2036 care of this task, because we don't have a gfc_expr at hand. 2037 Build one manually, as in gfc_trans_subarray_assign. */ 2038 2039 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank, 2040 GFC_SS_COMPONENT); 2041 ss_array = &ss->info->data.array; 2042 ss_array->shape = gfc_get_shape (cm->as->rank); 2043 ss_array->descriptor = expr; 2044 ss_array->data = gfc_conv_array_data (expr); 2045 ss_array->offset = gfc_conv_array_offset (expr); 2046 for (n = 0; n < cm->as->rank; n++) 2047 { 2048 ss_array->start[n] = gfc_conv_array_lbound (expr, n); 2049 ss_array->stride[n] = gfc_index_one_node; 2050 2051 mpz_init (ss_array->shape[n]); 2052 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer, 2053 cm->as->lower[n]->value.integer); 2054 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1); 2055 } 2056 2057 /* Once we got ss, we use scalarizer to create the loop. */ 2058 2059 gfc_init_loopinfo (&loop); 2060 gfc_add_ss_to_loop (&loop, ss); 2061 gfc_conv_ss_startstride (&loop); 2062 gfc_conv_loop_setup (&loop, where); 2063 gfc_mark_ss_chain_used (ss, 1); 2064 gfc_start_scalarized_body (&loop, &body); 2065 2066 gfc_copy_loopinfo_to_se (&se, &loop); 2067 se.ss = ss; 2068 2069 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */ 2070 se.expr = expr; 2071 gfc_conv_tmp_array_ref (&se); 2072 2073 /* Now se.expr contains an element of the array. Take the address and pass 2074 it to the IO routines. */ 2075 tmp = gfc_build_addr_expr (NULL_TREE, se.expr); 2076 transfer_expr (&se, &cm->ts, tmp, NULL); 2077 2078 /* We are done now with the loop body. Wrap up the scalarizer and 2079 return. */ 2080 2081 gfc_add_block_to_block (&body, &se.pre); 2082 gfc_add_block_to_block (&body, &se.post); 2083 2084 gfc_trans_scalarizing_loops (&loop, &body); 2085 2086 gfc_add_block_to_block (&block, &loop.pre); 2087 gfc_add_block_to_block (&block, &loop.post); 2088 2089 gcc_assert (ss_array->shape != NULL); 2090 gfc_free_shape (&ss_array->shape, cm->as->rank); 2091 gfc_cleanup_loop (&loop); 2092 2093 return gfc_finish_block (&block); 2094} 2095 2096/* Generate the call for a scalar transfer node. */ 2097 2098static void 2099transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) 2100{ 2101 tree tmp, function, arg2, arg3, field, expr; 2102 gfc_component *c; 2103 int kind; 2104 2105 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if 2106 the user says something like: print *, 'c_null_ptr: ', c_null_ptr 2107 We need to translate the expression to a constant if it's either 2108 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of 2109 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be 2110 BT_DERIVED (could have been changed by gfc_conv_expr). */ 2111 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER) 2112 && ts->u.derived != NULL 2113 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1)) 2114 { 2115 ts->type = BT_INTEGER; 2116 ts->kind = gfc_index_integer_kind; 2117 } 2118 2119 kind = ts->kind; 2120 function = NULL; 2121 arg2 = NULL; 2122 arg3 = NULL; 2123 2124 switch (ts->type) 2125 { 2126 case BT_INTEGER: 2127 arg2 = build_int_cst (integer_type_node, kind); 2128 if (last_dt == READ) 2129 function = iocall[IOCALL_X_INTEGER]; 2130 else 2131 function = iocall[IOCALL_X_INTEGER_WRITE]; 2132 2133 break; 2134 2135 case BT_REAL: 2136 arg2 = build_int_cst (integer_type_node, kind); 2137 if (last_dt == READ) 2138 { 2139 if (gfc_real16_is_float128 && ts->kind == 16) 2140 function = iocall[IOCALL_X_REAL128]; 2141 else 2142 function = iocall[IOCALL_X_REAL]; 2143 } 2144 else 2145 { 2146 if (gfc_real16_is_float128 && ts->kind == 16) 2147 function = iocall[IOCALL_X_REAL128_WRITE]; 2148 else 2149 function = iocall[IOCALL_X_REAL_WRITE]; 2150 } 2151 2152 break; 2153 2154 case BT_COMPLEX: 2155 arg2 = build_int_cst (integer_type_node, kind); 2156 if (last_dt == READ) 2157 { 2158 if (gfc_real16_is_float128 && ts->kind == 16) 2159 function = iocall[IOCALL_X_COMPLEX128]; 2160 else 2161 function = iocall[IOCALL_X_COMPLEX]; 2162 } 2163 else 2164 { 2165 if (gfc_real16_is_float128 && ts->kind == 16) 2166 function = iocall[IOCALL_X_COMPLEX128_WRITE]; 2167 else 2168 function = iocall[IOCALL_X_COMPLEX_WRITE]; 2169 } 2170 2171 break; 2172 2173 case BT_LOGICAL: 2174 arg2 = build_int_cst (integer_type_node, kind); 2175 if (last_dt == READ) 2176 function = iocall[IOCALL_X_LOGICAL]; 2177 else 2178 function = iocall[IOCALL_X_LOGICAL_WRITE]; 2179 2180 break; 2181 2182 case BT_CHARACTER: 2183 if (kind == 4) 2184 { 2185 if (se->string_length) 2186 arg2 = se->string_length; 2187 else 2188 { 2189 tmp = build_fold_indirect_ref_loc (input_location, 2190 addr_expr); 2191 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); 2192 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); 2193 arg2 = fold_convert (gfc_charlen_type_node, arg2); 2194 } 2195 arg3 = build_int_cst (integer_type_node, kind); 2196 if (last_dt == READ) 2197 function = iocall[IOCALL_X_CHARACTER_WIDE]; 2198 else 2199 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE]; 2200 2201 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); 2202 tmp = build_call_expr_loc (input_location, 2203 function, 4, tmp, addr_expr, arg2, arg3); 2204 gfc_add_expr_to_block (&se->pre, tmp); 2205 gfc_add_block_to_block (&se->pre, &se->post); 2206 return; 2207 } 2208 /* Fall through. */ 2209 case BT_HOLLERITH: 2210 if (se->string_length) 2211 arg2 = se->string_length; 2212 else 2213 { 2214 tmp = build_fold_indirect_ref_loc (input_location, 2215 addr_expr); 2216 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); 2217 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); 2218 } 2219 if (last_dt == READ) 2220 function = iocall[IOCALL_X_CHARACTER]; 2221 else 2222 function = iocall[IOCALL_X_CHARACTER_WRITE]; 2223 2224 break; 2225 2226 case BT_DERIVED: 2227 if (ts->u.derived->components == NULL) 2228 return; 2229 2230 /* Recurse into the elements of the derived type. */ 2231 expr = gfc_evaluate_now (addr_expr, &se->pre); 2232 expr = build_fold_indirect_ref_loc (input_location, 2233 expr); 2234 2235 /* Make sure that the derived type has been built. An external 2236 function, if only referenced in an io statement, requires this 2237 check (see PR58771). */ 2238 if (ts->u.derived->backend_decl == NULL_TREE) 2239 (void) gfc_typenode_for_spec (ts); 2240 2241 for (c = ts->u.derived->components; c; c = c->next) 2242 { 2243 field = c->backend_decl; 2244 gcc_assert (field && TREE_CODE (field) == FIELD_DECL); 2245 2246 tmp = fold_build3_loc (UNKNOWN_LOCATION, 2247 COMPONENT_REF, TREE_TYPE (field), 2248 expr, field, NULL_TREE); 2249 2250 if (c->attr.dimension) 2251 { 2252 tmp = transfer_array_component (tmp, c, & code->loc); 2253 gfc_add_expr_to_block (&se->pre, tmp); 2254 } 2255 else 2256 { 2257 if (!c->attr.pointer) 2258 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 2259 transfer_expr (se, &c->ts, tmp, code); 2260 } 2261 } 2262 return; 2263 2264 default: 2265 gfc_internal_error ("Bad IO basetype (%d)", ts->type); 2266 } 2267 2268 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); 2269 tmp = build_call_expr_loc (input_location, 2270 function, 3, tmp, addr_expr, arg2); 2271 gfc_add_expr_to_block (&se->pre, tmp); 2272 gfc_add_block_to_block (&se->pre, &se->post); 2273 2274} 2275 2276 2277/* Generate a call to pass an array descriptor to the IO library. The 2278 array should be of one of the intrinsic types. */ 2279 2280static void 2281transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) 2282{ 2283 tree tmp, charlen_arg, kind_arg, io_call; 2284 2285 if (ts->type == BT_CHARACTER) 2286 charlen_arg = se->string_length; 2287 else 2288 charlen_arg = build_int_cst (gfc_charlen_type_node, 0); 2289 2290 kind_arg = build_int_cst (integer_type_node, ts->kind); 2291 2292 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); 2293 if (last_dt == READ) 2294 io_call = iocall[IOCALL_X_ARRAY]; 2295 else 2296 io_call = iocall[IOCALL_X_ARRAY_WRITE]; 2297 2298 tmp = build_call_expr_loc (UNKNOWN_LOCATION, 2299 io_call, 4, 2300 tmp, addr_expr, kind_arg, charlen_arg); 2301 gfc_add_expr_to_block (&se->pre, tmp); 2302 gfc_add_block_to_block (&se->pre, &se->post); 2303} 2304 2305 2306/* gfc_trans_transfer()-- Translate a TRANSFER code node */ 2307 2308tree 2309gfc_trans_transfer (gfc_code * code) 2310{ 2311 stmtblock_t block, body; 2312 gfc_loopinfo loop; 2313 gfc_expr *expr; 2314 gfc_ref *ref; 2315 gfc_ss *ss; 2316 gfc_se se; 2317 tree tmp; 2318 int n; 2319 2320 gfc_start_block (&block); 2321 gfc_init_block (&body); 2322 2323 expr = code->expr1; 2324 ref = NULL; 2325 gfc_init_se (&se, NULL); 2326 2327 if (expr->rank == 0) 2328 { 2329 /* Transfer a scalar value. */ 2330 gfc_conv_expr_reference (&se, expr); 2331 transfer_expr (&se, &expr->ts, se.expr, code); 2332 } 2333 else 2334 { 2335 /* Transfer an array. If it is an array of an intrinsic 2336 type, pass the descriptor to the library. Otherwise 2337 scalarize the transfer. */ 2338 if (expr->ref && !gfc_is_proc_ptr_comp (expr)) 2339 { 2340 for (ref = expr->ref; ref && ref->type != REF_ARRAY; 2341 ref = ref->next); 2342 gcc_assert (ref && ref->type == REF_ARRAY); 2343 } 2344 2345 if (expr->ts.type != BT_DERIVED 2346 && ref && ref->next == NULL 2347 && !is_subref_array (expr)) 2348 { 2349 bool seen_vector = false; 2350 2351 if (ref && ref->u.ar.type == AR_SECTION) 2352 { 2353 for (n = 0; n < ref->u.ar.dimen; n++) 2354 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) 2355 { 2356 seen_vector = true; 2357 break; 2358 } 2359 } 2360 2361 if (seen_vector && last_dt == READ) 2362 { 2363 /* Create a temp, read to that and copy it back. */ 2364 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false); 2365 tmp = se.expr; 2366 } 2367 else 2368 { 2369 /* Get the descriptor. */ 2370 gfc_conv_expr_descriptor (&se, expr); 2371 tmp = gfc_build_addr_expr (NULL_TREE, se.expr); 2372 } 2373 2374 transfer_array_desc (&se, &expr->ts, tmp); 2375 goto finish_block_label; 2376 } 2377 2378 /* Initialize the scalarizer. */ 2379 ss = gfc_walk_expr (expr); 2380 gfc_init_loopinfo (&loop); 2381 gfc_add_ss_to_loop (&loop, ss); 2382 2383 /* Initialize the loop. */ 2384 gfc_conv_ss_startstride (&loop); 2385 gfc_conv_loop_setup (&loop, &code->expr1->where); 2386 2387 /* The main loop body. */ 2388 gfc_mark_ss_chain_used (ss, 1); 2389 gfc_start_scalarized_body (&loop, &body); 2390 2391 gfc_copy_loopinfo_to_se (&se, &loop); 2392 se.ss = ss; 2393 2394 gfc_conv_expr_reference (&se, expr); 2395 transfer_expr (&se, &expr->ts, se.expr, code); 2396 } 2397 2398 finish_block_label: 2399 2400 gfc_add_block_to_block (&body, &se.pre); 2401 gfc_add_block_to_block (&body, &se.post); 2402 2403 if (se.ss == NULL) 2404 tmp = gfc_finish_block (&body); 2405 else 2406 { 2407 gcc_assert (expr->rank != 0); 2408 gcc_assert (se.ss == gfc_ss_terminator); 2409 gfc_trans_scalarizing_loops (&loop, &body); 2410 2411 gfc_add_block_to_block (&loop.pre, &loop.post); 2412 tmp = gfc_finish_block (&loop.pre); 2413 gfc_cleanup_loop (&loop); 2414 } 2415 2416 gfc_add_expr_to_block (&block, tmp); 2417 2418 return gfc_finish_block (&block); 2419} 2420 2421#include "gt-fortran-trans-io.h" 2422