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