|
111
|
1 /* IO Code translation/library interface
|
|
|
2 Copyright (C) 2002-2017 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_int4_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_int4_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 /* 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_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
|
|
|
484 get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
|
|
|
485 void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
|
|
|
486 gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
|
|
|
487 pvoid_type_node, pvoid_type_node);
|
|
|
488
|
|
|
489 iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
|
|
|
490 get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
|
|
|
491 void_type_node, 5, dt_parm_type, gfc_int4_type_node,
|
|
|
492 gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
|
|
|
493 }
|
|
|
494
|
|
|
495
|
|
|
496 static void
|
|
|
497 set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
|
|
|
498 {
|
|
|
499 tree tmp;
|
|
|
500 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
501
|
|
|
502 if (p->param_type == IOPARM_ptype_common)
|
|
|
503 var = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
504 st_parameter[IOPARM_ptype_common].type,
|
|
|
505 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
|
|
506 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
|
|
|
507 var, p->field, NULL_TREE);
|
|
|
508 gfc_add_modify (block, tmp, value);
|
|
|
509 }
|
|
|
510
|
|
|
511
|
|
|
512 /* Generate code to store an integer constant into the
|
|
|
513 st_parameter_XXX structure. */
|
|
|
514
|
|
|
515 static unsigned int
|
|
|
516 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
|
|
|
517 unsigned int val)
|
|
|
518 {
|
|
|
519 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
520
|
|
|
521 set_parameter_tree (block, var, type,
|
|
|
522 build_int_cst (TREE_TYPE (p->field), val));
|
|
|
523 return p->mask;
|
|
|
524 }
|
|
|
525
|
|
|
526
|
|
|
527 /* Generate code to store a non-string I/O parameter into the
|
|
|
528 st_parameter_XXX structure. This is a pass by value. */
|
|
|
529
|
|
|
530 static unsigned int
|
|
|
531 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
|
|
|
532 gfc_expr *e)
|
|
|
533 {
|
|
|
534 gfc_se se;
|
|
|
535 tree tmp;
|
|
|
536 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
537 tree dest_type = TREE_TYPE (p->field);
|
|
|
538
|
|
|
539 gfc_init_se (&se, NULL);
|
|
|
540 gfc_conv_expr_val (&se, e);
|
|
|
541
|
|
|
542 se.expr = convert (dest_type, se.expr);
|
|
|
543 gfc_add_block_to_block (block, &se.pre);
|
|
|
544
|
|
|
545 if (p->param_type == IOPARM_ptype_common)
|
|
|
546 var = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
547 st_parameter[IOPARM_ptype_common].type,
|
|
|
548 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
|
|
549
|
|
|
550 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
|
|
|
551 p->field, NULL_TREE);
|
|
|
552 gfc_add_modify (block, tmp, se.expr);
|
|
|
553 return p->mask;
|
|
|
554 }
|
|
|
555
|
|
|
556
|
|
|
557 /* Similar to set_parameter_value except generate runtime
|
|
|
558 error checks. */
|
|
|
559
|
|
|
560 static unsigned int
|
|
|
561 set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
|
|
|
562 enum iofield type, gfc_expr *e)
|
|
|
563 {
|
|
|
564 gfc_se se;
|
|
|
565 tree tmp;
|
|
|
566 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
567 tree dest_type = TREE_TYPE (p->field);
|
|
|
568
|
|
|
569 gfc_init_se (&se, NULL);
|
|
|
570 gfc_conv_expr_val (&se, e);
|
|
|
571
|
|
|
572 /* If we're storing a UNIT number, we need to check it first. */
|
|
|
573 if (type == IOPARM_common_unit && e->ts.kind > 4)
|
|
|
574 {
|
|
|
575 tree cond, val;
|
|
|
576 int i;
|
|
|
577
|
|
|
578 /* Don't evaluate the UNIT number multiple times. */
|
|
|
579 se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
|
|
580
|
|
|
581 /* UNIT numbers should be greater than the min. */
|
|
|
582 i = gfc_validate_kind (BT_INTEGER, 4, false);
|
|
|
583 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
|
|
|
584 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
|
|
585 se.expr,
|
|
|
586 fold_convert (TREE_TYPE (se.expr), val));
|
|
|
587 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
|
|
|
588 "Unit number in I/O statement too small",
|
|
|
589 &se.pre);
|
|
|
590
|
|
|
591 /* UNIT numbers should be less than the max. */
|
|
|
592 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
|
|
|
593 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
|
|
|
594 se.expr,
|
|
|
595 fold_convert (TREE_TYPE (se.expr), val));
|
|
|
596 gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
|
|
|
597 "Unit number in I/O statement too large",
|
|
|
598 &se.pre);
|
|
|
599 }
|
|
|
600
|
|
|
601 se.expr = convert (dest_type, se.expr);
|
|
|
602 gfc_add_block_to_block (block, &se.pre);
|
|
|
603
|
|
|
604 if (p->param_type == IOPARM_ptype_common)
|
|
|
605 var = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
606 st_parameter[IOPARM_ptype_common].type,
|
|
|
607 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
|
|
608
|
|
|
609 tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
|
|
|
610 p->field, NULL_TREE);
|
|
|
611 gfc_add_modify (block, tmp, se.expr);
|
|
|
612 return p->mask;
|
|
|
613 }
|
|
|
614
|
|
|
615
|
|
|
616 /* Build code to check the unit range if KIND=8 is used. Similar to
|
|
|
617 set_parameter_value_chk but we do not generate error calls for
|
|
|
618 inquire statements. */
|
|
|
619
|
|
|
620 static unsigned int
|
|
|
621 set_parameter_value_inquire (stmtblock_t *block, tree var,
|
|
|
622 enum iofield type, gfc_expr *e)
|
|
|
623 {
|
|
|
624 gfc_se se;
|
|
|
625 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
626 tree dest_type = TREE_TYPE (p->field);
|
|
|
627
|
|
|
628 gfc_init_se (&se, NULL);
|
|
|
629 gfc_conv_expr_val (&se, e);
|
|
|
630
|
|
|
631 /* If we're inquiring on a UNIT number, we need to check to make
|
|
|
632 sure it exists for larger than kind = 4. */
|
|
|
633 if (type == IOPARM_common_unit && e->ts.kind > 4)
|
|
|
634 {
|
|
|
635 stmtblock_t newblock;
|
|
|
636 tree cond1, cond2, cond3, val, body;
|
|
|
637 int i;
|
|
|
638
|
|
|
639 /* Don't evaluate the UNIT number multiple times. */
|
|
|
640 se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
|
|
641
|
|
|
642 /* UNIT numbers should be greater than zero. */
|
|
|
643 i = gfc_validate_kind (BT_INTEGER, 4, false);
|
|
|
644 cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node,
|
|
|
645 se.expr,
|
|
|
646 fold_convert (TREE_TYPE (se.expr),
|
|
|
647 integer_zero_node));
|
|
|
648 /* UNIT numbers should be less than the max. */
|
|
|
649 val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
|
|
|
650 cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node,
|
|
|
651 se.expr,
|
|
|
652 fold_convert (TREE_TYPE (se.expr), val));
|
|
|
653 cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
|
|
|
654 boolean_type_node, cond1, cond2);
|
|
|
655
|
|
|
656 gfc_start_block (&newblock);
|
|
|
657
|
|
|
658 /* The unit number GFC_INVALID_UNIT is reserved. No units can
|
|
|
659 ever have this value. It is used here to signal to the
|
|
|
660 runtime library that the inquire unit number is outside the
|
|
|
661 allowable range and so cannot exist. It is needed when
|
|
|
662 -fdefault-integer-8 is used. */
|
|
|
663 set_parameter_const (&newblock, var, IOPARM_common_unit,
|
|
|
664 GFC_INVALID_UNIT);
|
|
|
665
|
|
|
666 body = gfc_finish_block (&newblock);
|
|
|
667
|
|
|
668 cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
|
|
|
669 var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
|
|
|
670 gfc_add_expr_to_block (&se.pre, var);
|
|
|
671 }
|
|
|
672
|
|
|
673 se.expr = convert (dest_type, se.expr);
|
|
|
674 gfc_add_block_to_block (block, &se.pre);
|
|
|
675
|
|
|
676 return p->mask;
|
|
|
677 }
|
|
|
678
|
|
|
679
|
|
|
680 /* Generate code to store a non-string I/O parameter into the
|
|
|
681 st_parameter_XXX structure. This is pass by reference. */
|
|
|
682
|
|
|
683 static unsigned int
|
|
|
684 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
|
|
|
685 tree var, enum iofield type, gfc_expr *e)
|
|
|
686 {
|
|
|
687 gfc_se se;
|
|
|
688 tree tmp, addr;
|
|
|
689 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
690
|
|
|
691 gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
|
|
|
692 gfc_init_se (&se, NULL);
|
|
|
693 gfc_conv_expr_lhs (&se, e);
|
|
|
694
|
|
|
695 gfc_add_block_to_block (block, &se.pre);
|
|
|
696
|
|
|
697 if (TYPE_MODE (TREE_TYPE (se.expr))
|
|
|
698 == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
|
|
|
699 {
|
|
|
700 addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
|
|
|
701
|
|
|
702 /* If this is for the iostat variable initialize the
|
|
|
703 user variable to LIBERROR_OK which is zero. */
|
|
|
704 if (type == IOPARM_common_iostat)
|
|
|
705 gfc_add_modify (block, se.expr,
|
|
|
706 build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
|
|
|
707 }
|
|
|
708 else
|
|
|
709 {
|
|
|
710 /* The type used by the library has different size
|
|
|
711 from the type of the variable supplied by the user.
|
|
|
712 Need to use a temporary. */
|
|
|
713 tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
|
|
|
714 st_parameter_field[type].name);
|
|
|
715
|
|
|
716 /* If this is for the iostat variable, initialize the
|
|
|
717 user variable to LIBERROR_OK which is zero. */
|
|
|
718 if (type == IOPARM_common_iostat)
|
|
|
719 gfc_add_modify (block, tmpvar,
|
|
|
720 build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
|
|
|
721
|
|
|
722 addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
|
|
|
723 /* After the I/O operation, we set the variable from the temporary. */
|
|
|
724 tmp = convert (TREE_TYPE (se.expr), tmpvar);
|
|
|
725 gfc_add_modify (postblock, se.expr, tmp);
|
|
|
726 }
|
|
|
727
|
|
|
728 set_parameter_tree (block, var, type, addr);
|
|
|
729 return p->mask;
|
|
|
730 }
|
|
|
731
|
|
|
732 /* Given an array expr, find its address and length to get a string. If the
|
|
|
733 array is full, the string's address is the address of array's first element
|
|
|
734 and the length is the size of the whole array. If it is an element, the
|
|
|
735 string's address is the element's address and the length is the rest size of
|
|
|
736 the array. */
|
|
|
737
|
|
|
738 static void
|
|
|
739 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
|
|
|
740 {
|
|
|
741 tree size;
|
|
|
742
|
|
|
743 if (e->rank == 0)
|
|
|
744 {
|
|
|
745 tree type, array, tmp;
|
|
|
746 gfc_symbol *sym;
|
|
|
747 int rank;
|
|
|
748
|
|
|
749 /* If it is an element, we need its address and size of the rest. */
|
|
|
750 gcc_assert (e->expr_type == EXPR_VARIABLE);
|
|
|
751 gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
|
|
|
752 sym = e->symtree->n.sym;
|
|
|
753 rank = sym->as->rank - 1;
|
|
|
754 gfc_conv_expr (se, e);
|
|
|
755
|
|
|
756 array = sym->backend_decl;
|
|
|
757 type = TREE_TYPE (array);
|
|
|
758
|
|
|
759 if (GFC_ARRAY_TYPE_P (type))
|
|
|
760 size = GFC_TYPE_ARRAY_SIZE (type);
|
|
|
761 else
|
|
|
762 {
|
|
|
763 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
|
|
764 size = gfc_conv_array_stride (array, rank);
|
|
|
765 tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
|
766 gfc_array_index_type,
|
|
|
767 gfc_conv_array_ubound (array, rank),
|
|
|
768 gfc_conv_array_lbound (array, rank));
|
|
|
769 tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
|
770 gfc_array_index_type, tmp,
|
|
|
771 gfc_index_one_node);
|
|
|
772 size = fold_build2_loc (input_location, MULT_EXPR,
|
|
|
773 gfc_array_index_type, tmp, size);
|
|
|
774 }
|
|
|
775 gcc_assert (size);
|
|
|
776
|
|
|
777 size = fold_build2_loc (input_location, MINUS_EXPR,
|
|
|
778 gfc_array_index_type, size,
|
|
|
779 TREE_OPERAND (se->expr, 1));
|
|
|
780 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
|
|
|
781 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
|
|
|
782 size = fold_build2_loc (input_location, MULT_EXPR,
|
|
|
783 gfc_array_index_type, size,
|
|
|
784 fold_convert (gfc_array_index_type, tmp));
|
|
|
785 se->string_length = fold_convert (gfc_charlen_type_node, size);
|
|
|
786 return;
|
|
|
787 }
|
|
|
788
|
|
|
789 gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
|
|
|
790 se->string_length = fold_convert (gfc_charlen_type_node, size);
|
|
|
791 }
|
|
|
792
|
|
|
793
|
|
|
794 /* Generate code to store a string and its length into the
|
|
|
795 st_parameter_XXX structure. */
|
|
|
796
|
|
|
797 static unsigned int
|
|
|
798 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
|
|
|
799 enum iofield type, gfc_expr * e)
|
|
|
800 {
|
|
|
801 gfc_se se;
|
|
|
802 tree tmp;
|
|
|
803 tree io;
|
|
|
804 tree len;
|
|
|
805 gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
806
|
|
|
807 gfc_init_se (&se, NULL);
|
|
|
808
|
|
|
809 if (p->param_type == IOPARM_ptype_common)
|
|
|
810 var = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
811 st_parameter[IOPARM_ptype_common].type,
|
|
|
812 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
|
|
813 io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
|
|
|
814 var, p->field, NULL_TREE);
|
|
|
815 len = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
816 TREE_TYPE (p->field_len),
|
|
|
817 var, p->field_len, NULL_TREE);
|
|
|
818
|
|
|
819 /* Integer variable assigned a format label. */
|
|
|
820 if (e->ts.type == BT_INTEGER
|
|
|
821 && e->rank == 0
|
|
|
822 && e->symtree->n.sym->attr.assign == 1)
|
|
|
823 {
|
|
|
824 char * msg;
|
|
|
825 tree cond;
|
|
|
826
|
|
|
827 gfc_conv_label_variable (&se, e);
|
|
|
828 tmp = GFC_DECL_STRING_LEN (se.expr);
|
|
|
829 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
|
|
830 tmp, build_int_cst (TREE_TYPE (tmp), 0));
|
|
|
831
|
|
|
832 msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
|
|
|
833 "label", e->symtree->name);
|
|
|
834 gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
|
|
|
835 fold_convert (long_integer_type_node, tmp));
|
|
|
836 free (msg);
|
|
|
837
|
|
|
838 gfc_add_modify (&se.pre, io,
|
|
|
839 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
|
|
|
840 gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
|
|
|
841 }
|
|
|
842 else
|
|
|
843 {
|
|
|
844 /* General character. */
|
|
|
845 if (e->ts.type == BT_CHARACTER && e->rank == 0)
|
|
|
846 gfc_conv_expr (&se, e);
|
|
|
847 /* Array assigned Hollerith constant or character array. */
|
|
|
848 else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
|
|
|
849 gfc_convert_array_to_string (&se, e);
|
|
|
850 else
|
|
|
851 gcc_unreachable ();
|
|
|
852
|
|
|
853 gfc_conv_string_parameter (&se);
|
|
|
854 gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
|
|
|
855 gfc_add_modify (&se.pre, len, 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_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
|
|
|
1006 rc, tmp, NULL_TREE);
|
|
|
1007
|
|
|
1008 gfc_add_expr_to_block (block, tmp);
|
|
|
1009 }
|
|
|
1010
|
|
|
1011
|
|
|
1012 /* Store the current file and line number to variables so that if a
|
|
|
1013 library call goes awry, we can tell the user where the problem is. */
|
|
|
1014
|
|
|
1015 static void
|
|
|
1016 set_error_locus (stmtblock_t * block, tree var, locus * where)
|
|
|
1017 {
|
|
|
1018 gfc_file *f;
|
|
|
1019 tree str, locus_file;
|
|
|
1020 int line;
|
|
|
1021 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
|
|
|
1022
|
|
|
1023 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
1024 st_parameter[IOPARM_ptype_common].type,
|
|
|
1025 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
|
|
1026 locus_file = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
1027 TREE_TYPE (p->field), locus_file,
|
|
|
1028 p->field, NULL_TREE);
|
|
|
1029 f = where->lb->file;
|
|
|
1030 str = gfc_build_cstring_const (f->filename);
|
|
|
1031
|
|
|
1032 str = gfc_build_addr_expr (pchar_type_node, str);
|
|
|
1033 gfc_add_modify (block, locus_file, str);
|
|
|
1034
|
|
|
1035 line = LOCATION_LINE (where->lb->location);
|
|
|
1036 set_parameter_const (block, var, IOPARM_common_line, line);
|
|
|
1037 }
|
|
|
1038
|
|
|
1039
|
|
|
1040 /* Translate an OPEN statement. */
|
|
|
1041
|
|
|
1042 tree
|
|
|
1043 gfc_trans_open (gfc_code * code)
|
|
|
1044 {
|
|
|
1045 stmtblock_t block, post_block;
|
|
|
1046 gfc_open *p;
|
|
|
1047 tree tmp, var;
|
|
|
1048 unsigned int mask = 0;
|
|
|
1049
|
|
|
1050 gfc_start_block (&block);
|
|
|
1051 gfc_init_block (&post_block);
|
|
|
1052
|
|
|
1053 var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
|
|
|
1054
|
|
|
1055 set_error_locus (&block, var, &code->loc);
|
|
|
1056 p = code->ext.open;
|
|
|
1057
|
|
|
1058 if (p->iomsg)
|
|
|
1059 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
|
|
1060 p->iomsg);
|
|
|
1061
|
|
|
1062 if (p->iostat)
|
|
|
1063 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
|
|
1064 p->iostat);
|
|
|
1065
|
|
|
1066 if (p->err)
|
|
|
1067 mask |= IOPARM_common_err;
|
|
|
1068
|
|
|
1069 if (p->file)
|
|
|
1070 mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
|
|
|
1071
|
|
|
1072 if (p->status)
|
|
|
1073 mask |= set_string (&block, &post_block, var, IOPARM_open_status,
|
|
|
1074 p->status);
|
|
|
1075
|
|
|
1076 if (p->access)
|
|
|
1077 mask |= set_string (&block, &post_block, var, IOPARM_open_access,
|
|
|
1078 p->access);
|
|
|
1079
|
|
|
1080 if (p->form)
|
|
|
1081 mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
|
|
|
1082
|
|
|
1083 if (p->recl)
|
|
|
1084 mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
|
|
|
1085 p->recl);
|
|
|
1086
|
|
|
1087 if (p->blank)
|
|
|
1088 mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
|
|
|
1089 p->blank);
|
|
|
1090
|
|
|
1091 if (p->position)
|
|
|
1092 mask |= set_string (&block, &post_block, var, IOPARM_open_position,
|
|
|
1093 p->position);
|
|
|
1094
|
|
|
1095 if (p->action)
|
|
|
1096 mask |= set_string (&block, &post_block, var, IOPARM_open_action,
|
|
|
1097 p->action);
|
|
|
1098
|
|
|
1099 if (p->delim)
|
|
|
1100 mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
|
|
|
1101 p->delim);
|
|
|
1102
|
|
|
1103 if (p->pad)
|
|
|
1104 mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
|
|
|
1105
|
|
|
1106 if (p->decimal)
|
|
|
1107 mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
|
|
|
1108 p->decimal);
|
|
|
1109
|
|
|
1110 if (p->encoding)
|
|
|
1111 mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
|
|
|
1112 p->encoding);
|
|
|
1113
|
|
|
1114 if (p->round)
|
|
|
1115 mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
|
|
|
1116
|
|
|
1117 if (p->sign)
|
|
|
1118 mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
|
|
|
1119
|
|
|
1120 if (p->asynchronous)
|
|
|
1121 mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
|
|
|
1122 p->asynchronous);
|
|
|
1123
|
|
|
1124 if (p->convert)
|
|
|
1125 mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
|
|
|
1126 p->convert);
|
|
|
1127
|
|
|
1128 if (p->newunit)
|
|
|
1129 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
|
|
|
1130 p->newunit);
|
|
|
1131
|
|
|
1132 if (p->cc)
|
|
|
1133 mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc);
|
|
|
1134
|
|
|
1135 if (p->share)
|
|
|
1136 mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share);
|
|
|
1137
|
|
|
1138 mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly);
|
|
|
1139
|
|
|
1140 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1141
|
|
|
1142 if (p->unit)
|
|
|
1143 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
|
|
|
1144 else
|
|
|
1145 set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
1146
|
|
|
1147 tmp = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
1148 tmp = build_call_expr_loc (input_location,
|
|
|
1149 iocall[IOCALL_OPEN], 1, tmp);
|
|
|
1150 gfc_add_expr_to_block (&block, tmp);
|
|
|
1151
|
|
|
1152 gfc_add_block_to_block (&block, &post_block);
|
|
|
1153
|
|
|
1154 io_result (&block, var, p->err, NULL, NULL);
|
|
|
1155
|
|
|
1156 return gfc_finish_block (&block);
|
|
|
1157 }
|
|
|
1158
|
|
|
1159
|
|
|
1160 /* Translate a CLOSE statement. */
|
|
|
1161
|
|
|
1162 tree
|
|
|
1163 gfc_trans_close (gfc_code * code)
|
|
|
1164 {
|
|
|
1165 stmtblock_t block, post_block;
|
|
|
1166 gfc_close *p;
|
|
|
1167 tree tmp, var;
|
|
|
1168 unsigned int mask = 0;
|
|
|
1169
|
|
|
1170 gfc_start_block (&block);
|
|
|
1171 gfc_init_block (&post_block);
|
|
|
1172
|
|
|
1173 var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
|
|
|
1174
|
|
|
1175 set_error_locus (&block, var, &code->loc);
|
|
|
1176 p = code->ext.close;
|
|
|
1177
|
|
|
1178 if (p->iomsg)
|
|
|
1179 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
|
|
1180 p->iomsg);
|
|
|
1181
|
|
|
1182 if (p->iostat)
|
|
|
1183 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
|
|
1184 p->iostat);
|
|
|
1185
|
|
|
1186 if (p->err)
|
|
|
1187 mask |= IOPARM_common_err;
|
|
|
1188
|
|
|
1189 if (p->status)
|
|
|
1190 mask |= set_string (&block, &post_block, var, IOPARM_close_status,
|
|
|
1191 p->status);
|
|
|
1192
|
|
|
1193 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1194
|
|
|
1195 if (p->unit)
|
|
|
1196 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
|
|
|
1197 else
|
|
|
1198 set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
1199
|
|
|
1200 tmp = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
1201 tmp = build_call_expr_loc (input_location,
|
|
|
1202 iocall[IOCALL_CLOSE], 1, tmp);
|
|
|
1203 gfc_add_expr_to_block (&block, tmp);
|
|
|
1204
|
|
|
1205 gfc_add_block_to_block (&block, &post_block);
|
|
|
1206
|
|
|
1207 io_result (&block, var, p->err, NULL, NULL);
|
|
|
1208
|
|
|
1209 return gfc_finish_block (&block);
|
|
|
1210 }
|
|
|
1211
|
|
|
1212
|
|
|
1213 /* Common subroutine for building a file positioning statement. */
|
|
|
1214
|
|
|
1215 static tree
|
|
|
1216 build_filepos (tree function, gfc_code * code)
|
|
|
1217 {
|
|
|
1218 stmtblock_t block, post_block;
|
|
|
1219 gfc_filepos *p;
|
|
|
1220 tree tmp, var;
|
|
|
1221 unsigned int mask = 0;
|
|
|
1222
|
|
|
1223 p = code->ext.filepos;
|
|
|
1224
|
|
|
1225 gfc_start_block (&block);
|
|
|
1226 gfc_init_block (&post_block);
|
|
|
1227
|
|
|
1228 var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
|
|
|
1229 "filepos_parm");
|
|
|
1230
|
|
|
1231 set_error_locus (&block, var, &code->loc);
|
|
|
1232
|
|
|
1233 if (p->iomsg)
|
|
|
1234 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
|
|
1235 p->iomsg);
|
|
|
1236
|
|
|
1237 if (p->iostat)
|
|
|
1238 mask |= set_parameter_ref (&block, &post_block, var,
|
|
|
1239 IOPARM_common_iostat, p->iostat);
|
|
|
1240
|
|
|
1241 if (p->err)
|
|
|
1242 mask |= IOPARM_common_err;
|
|
|
1243
|
|
|
1244 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1245
|
|
|
1246 if (p->unit)
|
|
|
1247 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
|
|
|
1248 p->unit);
|
|
|
1249 else
|
|
|
1250 set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
1251
|
|
|
1252 tmp = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
1253 tmp = build_call_expr_loc (input_location,
|
|
|
1254 function, 1, tmp);
|
|
|
1255 gfc_add_expr_to_block (&block, tmp);
|
|
|
1256
|
|
|
1257 gfc_add_block_to_block (&block, &post_block);
|
|
|
1258
|
|
|
1259 io_result (&block, var, p->err, NULL, NULL);
|
|
|
1260
|
|
|
1261 return gfc_finish_block (&block);
|
|
|
1262 }
|
|
|
1263
|
|
|
1264
|
|
|
1265 /* Translate a BACKSPACE statement. */
|
|
|
1266
|
|
|
1267 tree
|
|
|
1268 gfc_trans_backspace (gfc_code * code)
|
|
|
1269 {
|
|
|
1270 return build_filepos (iocall[IOCALL_BACKSPACE], code);
|
|
|
1271 }
|
|
|
1272
|
|
|
1273
|
|
|
1274 /* Translate an ENDFILE statement. */
|
|
|
1275
|
|
|
1276 tree
|
|
|
1277 gfc_trans_endfile (gfc_code * code)
|
|
|
1278 {
|
|
|
1279 return build_filepos (iocall[IOCALL_ENDFILE], code);
|
|
|
1280 }
|
|
|
1281
|
|
|
1282
|
|
|
1283 /* Translate a REWIND statement. */
|
|
|
1284
|
|
|
1285 tree
|
|
|
1286 gfc_trans_rewind (gfc_code * code)
|
|
|
1287 {
|
|
|
1288 return build_filepos (iocall[IOCALL_REWIND], code);
|
|
|
1289 }
|
|
|
1290
|
|
|
1291
|
|
|
1292 /* Translate a FLUSH statement. */
|
|
|
1293
|
|
|
1294 tree
|
|
|
1295 gfc_trans_flush (gfc_code * code)
|
|
|
1296 {
|
|
|
1297 return build_filepos (iocall[IOCALL_FLUSH], code);
|
|
|
1298 }
|
|
|
1299
|
|
|
1300
|
|
|
1301 /* Translate the non-IOLENGTH form of an INQUIRE statement. */
|
|
|
1302
|
|
|
1303 tree
|
|
|
1304 gfc_trans_inquire (gfc_code * code)
|
|
|
1305 {
|
|
|
1306 stmtblock_t block, post_block;
|
|
|
1307 gfc_inquire *p;
|
|
|
1308 tree tmp, var;
|
|
|
1309 unsigned int mask = 0, mask2 = 0;
|
|
|
1310
|
|
|
1311 gfc_start_block (&block);
|
|
|
1312 gfc_init_block (&post_block);
|
|
|
1313
|
|
|
1314 var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
|
|
|
1315 "inquire_parm");
|
|
|
1316
|
|
|
1317 set_error_locus (&block, var, &code->loc);
|
|
|
1318 p = code->ext.inquire;
|
|
|
1319
|
|
|
1320 if (p->iomsg)
|
|
|
1321 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
|
|
1322 p->iomsg);
|
|
|
1323
|
|
|
1324 if (p->iostat)
|
|
|
1325 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
|
|
1326 p->iostat);
|
|
|
1327
|
|
|
1328 if (p->err)
|
|
|
1329 mask |= IOPARM_common_err;
|
|
|
1330
|
|
|
1331 /* Sanity check. */
|
|
|
1332 if (p->unit && p->file)
|
|
|
1333 gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
|
|
|
1334
|
|
|
1335 if (p->file)
|
|
|
1336 mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
|
|
|
1337 p->file);
|
|
|
1338
|
|
|
1339 if (p->exist)
|
|
|
1340 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
|
|
|
1341 p->exist);
|
|
|
1342
|
|
|
1343 if (p->opened)
|
|
|
1344 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
|
|
|
1345 p->opened);
|
|
|
1346
|
|
|
1347 if (p->number)
|
|
|
1348 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
|
|
|
1349 p->number);
|
|
|
1350
|
|
|
1351 if (p->named)
|
|
|
1352 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
|
|
|
1353 p->named);
|
|
|
1354
|
|
|
1355 if (p->name)
|
|
|
1356 mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
|
|
|
1357 p->name);
|
|
|
1358
|
|
|
1359 if (p->access)
|
|
|
1360 mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
|
|
|
1361 p->access);
|
|
|
1362
|
|
|
1363 if (p->sequential)
|
|
|
1364 mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
|
|
|
1365 p->sequential);
|
|
|
1366
|
|
|
1367 if (p->direct)
|
|
|
1368 mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
|
|
|
1369 p->direct);
|
|
|
1370
|
|
|
1371 if (p->form)
|
|
|
1372 mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
|
|
|
1373 p->form);
|
|
|
1374
|
|
|
1375 if (p->formatted)
|
|
|
1376 mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
|
|
|
1377 p->formatted);
|
|
|
1378
|
|
|
1379 if (p->unformatted)
|
|
|
1380 mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
|
|
|
1381 p->unformatted);
|
|
|
1382
|
|
|
1383 if (p->recl)
|
|
|
1384 mask |= set_parameter_ref (&block, &post_block, var,
|
|
|
1385 IOPARM_inquire_recl_out, p->recl);
|
|
|
1386
|
|
|
1387 if (p->nextrec)
|
|
|
1388 mask |= set_parameter_ref (&block, &post_block, var,
|
|
|
1389 IOPARM_inquire_nextrec, p->nextrec);
|
|
|
1390
|
|
|
1391 if (p->blank)
|
|
|
1392 mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
|
|
|
1393 p->blank);
|
|
|
1394
|
|
|
1395 if (p->delim)
|
|
|
1396 mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
|
|
|
1397 p->delim);
|
|
|
1398
|
|
|
1399 if (p->position)
|
|
|
1400 mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
|
|
|
1401 p->position);
|
|
|
1402
|
|
|
1403 if (p->action)
|
|
|
1404 mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
|
|
|
1405 p->action);
|
|
|
1406
|
|
|
1407 if (p->read)
|
|
|
1408 mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
|
|
|
1409 p->read);
|
|
|
1410
|
|
|
1411 if (p->write)
|
|
|
1412 mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
|
|
|
1413 p->write);
|
|
|
1414
|
|
|
1415 if (p->readwrite)
|
|
|
1416 mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
|
|
|
1417 p->readwrite);
|
|
|
1418
|
|
|
1419 if (p->pad)
|
|
|
1420 mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
|
|
|
1421 p->pad);
|
|
|
1422
|
|
|
1423 if (p->convert)
|
|
|
1424 mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
|
|
|
1425 p->convert);
|
|
|
1426
|
|
|
1427 if (p->strm_pos)
|
|
|
1428 mask |= set_parameter_ref (&block, &post_block, var,
|
|
|
1429 IOPARM_inquire_strm_pos_out, p->strm_pos);
|
|
|
1430
|
|
|
1431 /* The second series of flags. */
|
|
|
1432 if (p->asynchronous)
|
|
|
1433 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
|
|
|
1434 p->asynchronous);
|
|
|
1435
|
|
|
1436 if (p->decimal)
|
|
|
1437 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
|
|
|
1438 p->decimal);
|
|
|
1439
|
|
|
1440 if (p->encoding)
|
|
|
1441 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
|
|
|
1442 p->encoding);
|
|
|
1443
|
|
|
1444 if (p->round)
|
|
|
1445 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
|
|
|
1446 p->round);
|
|
|
1447
|
|
|
1448 if (p->sign)
|
|
|
1449 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
|
|
|
1450 p->sign);
|
|
|
1451
|
|
|
1452 if (p->pending)
|
|
|
1453 mask2 |= set_parameter_ref (&block, &post_block, var,
|
|
|
1454 IOPARM_inquire_pending, p->pending);
|
|
|
1455
|
|
|
1456 if (p->size)
|
|
|
1457 mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
|
|
|
1458 p->size);
|
|
|
1459
|
|
|
1460 if (p->id)
|
|
|
1461 mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
|
|
|
1462 p->id);
|
|
|
1463 if (p->iqstream)
|
|
|
1464 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
|
|
|
1465 p->iqstream);
|
|
|
1466
|
|
|
1467 if (p->share)
|
|
|
1468 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share,
|
|
|
1469 p->share);
|
|
|
1470
|
|
|
1471 if (p->cc)
|
|
|
1472 mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc);
|
|
|
1473
|
|
|
1474 if (mask2)
|
|
|
1475 mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
|
|
|
1476
|
|
|
1477 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1478
|
|
|
1479 if (p->unit)
|
|
|
1480 {
|
|
|
1481 set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
|
|
1482 set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
|
|
|
1483 }
|
|
|
1484 else
|
|
|
1485 set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
1486
|
|
|
1487 tmp = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
1488 tmp = build_call_expr_loc (input_location,
|
|
|
1489 iocall[IOCALL_INQUIRE], 1, tmp);
|
|
|
1490 gfc_add_expr_to_block (&block, tmp);
|
|
|
1491
|
|
|
1492 gfc_add_block_to_block (&block, &post_block);
|
|
|
1493
|
|
|
1494 io_result (&block, var, p->err, NULL, NULL);
|
|
|
1495
|
|
|
1496 return gfc_finish_block (&block);
|
|
|
1497 }
|
|
|
1498
|
|
|
1499
|
|
|
1500 tree
|
|
|
1501 gfc_trans_wait (gfc_code * code)
|
|
|
1502 {
|
|
|
1503 stmtblock_t block, post_block;
|
|
|
1504 gfc_wait *p;
|
|
|
1505 tree tmp, var;
|
|
|
1506 unsigned int mask = 0;
|
|
|
1507
|
|
|
1508 gfc_start_block (&block);
|
|
|
1509 gfc_init_block (&post_block);
|
|
|
1510
|
|
|
1511 var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
|
|
|
1512 "wait_parm");
|
|
|
1513
|
|
|
1514 set_error_locus (&block, var, &code->loc);
|
|
|
1515 p = code->ext.wait;
|
|
|
1516
|
|
|
1517 /* Set parameters here. */
|
|
|
1518 if (p->iomsg)
|
|
|
1519 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
|
|
1520 p->iomsg);
|
|
|
1521
|
|
|
1522 if (p->iostat)
|
|
|
1523 mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
|
|
1524 p->iostat);
|
|
|
1525
|
|
|
1526 if (p->err)
|
|
|
1527 mask |= IOPARM_common_err;
|
|
|
1528
|
|
|
1529 if (p->id)
|
|
|
1530 mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
|
|
|
1531
|
|
|
1532 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1533
|
|
|
1534 if (p->unit)
|
|
|
1535 set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
|
|
|
1536
|
|
|
1537 tmp = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
1538 tmp = build_call_expr_loc (input_location,
|
|
|
1539 iocall[IOCALL_WAIT], 1, tmp);
|
|
|
1540 gfc_add_expr_to_block (&block, tmp);
|
|
|
1541
|
|
|
1542 gfc_add_block_to_block (&block, &post_block);
|
|
|
1543
|
|
|
1544 io_result (&block, var, p->err, NULL, NULL);
|
|
|
1545
|
|
|
1546 return gfc_finish_block (&block);
|
|
|
1547
|
|
|
1548 }
|
|
|
1549
|
|
|
1550
|
|
|
1551 /* nml_full_name builds up the fully qualified name of a
|
|
|
1552 derived type component. '+' is used to denote a type extension. */
|
|
|
1553
|
|
|
1554 static char*
|
|
|
1555 nml_full_name (const char* var_name, const char* cmp_name, bool parent)
|
|
|
1556 {
|
|
|
1557 int full_name_length;
|
|
|
1558 char * full_name;
|
|
|
1559
|
|
|
1560 full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
|
|
|
1561 full_name = XCNEWVEC (char, full_name_length + 1);
|
|
|
1562 strcpy (full_name, var_name);
|
|
|
1563 full_name = strcat (full_name, parent ? "+" : "%");
|
|
|
1564 full_name = strcat (full_name, cmp_name);
|
|
|
1565 return full_name;
|
|
|
1566 }
|
|
|
1567
|
|
|
1568
|
|
|
1569 /* nml_get_addr_expr builds an address expression from the
|
|
|
1570 gfc_symbol or gfc_component backend_decl's. An offset is
|
|
|
1571 provided so that the address of an element of an array of
|
|
|
1572 derived types is returned. This is used in the runtime to
|
|
|
1573 determine that span of the derived type. */
|
|
|
1574
|
|
|
1575 static tree
|
|
|
1576 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
|
|
|
1577 tree base_addr)
|
|
|
1578 {
|
|
|
1579 tree decl = NULL_TREE;
|
|
|
1580 tree tmp;
|
|
|
1581
|
|
|
1582 if (sym)
|
|
|
1583 {
|
|
|
1584 sym->attr.referenced = 1;
|
|
|
1585 decl = gfc_get_symbol_decl (sym);
|
|
|
1586
|
|
|
1587 /* If this is the enclosing function declaration, use
|
|
|
1588 the fake result instead. */
|
|
|
1589 if (decl == current_function_decl)
|
|
|
1590 decl = gfc_get_fake_result_decl (sym, 0);
|
|
|
1591 else if (decl == DECL_CONTEXT (current_function_decl))
|
|
|
1592 decl = gfc_get_fake_result_decl (sym, 1);
|
|
|
1593 }
|
|
|
1594 else
|
|
|
1595 decl = c->backend_decl;
|
|
|
1596
|
|
|
1597 gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL
|
|
|
1598 || VAR_P (decl)
|
|
|
1599 || TREE_CODE (decl) == PARM_DECL
|
|
|
1600 || TREE_CODE (decl) == COMPONENT_REF));
|
|
|
1601
|
|
|
1602 tmp = decl;
|
|
|
1603
|
|
|
1604 /* Build indirect reference, if dummy argument. */
|
|
|
1605
|
|
|
1606 if (POINTER_TYPE_P (TREE_TYPE(tmp)))
|
|
|
1607 tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
|
|
1608
|
|
|
1609 /* Treat the component of a derived type, using base_addr for
|
|
|
1610 the derived type. */
|
|
|
1611
|
|
|
1612 if (TREE_CODE (decl) == FIELD_DECL)
|
|
|
1613 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
|
|
|
1614 base_addr, tmp, NULL_TREE);
|
|
|
1615
|
|
|
1616 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
|
|
|
1617 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
|
|
|
1618 tmp = gfc_class_data_get (tmp);
|
|
|
1619
|
|
|
1620 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
|
|
|
1621 tmp = gfc_conv_array_data (tmp);
|
|
|
1622 else
|
|
|
1623 {
|
|
|
1624 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
|
|
|
1625 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
|
|
1626
|
|
|
1627 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
|
|
|
1628 tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
|
|
|
1629
|
|
|
1630 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
|
|
|
1631 tmp = build_fold_indirect_ref_loc (input_location,
|
|
|
1632 tmp);
|
|
|
1633 }
|
|
|
1634
|
|
|
1635 gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
|
|
|
1636
|
|
|
1637 return tmp;
|
|
|
1638 }
|
|
|
1639
|
|
|
1640
|
|
|
1641 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
|
|
|
1642 call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
|
|
|
1643 generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
|
|
|
1644
|
|
|
1645 #define IARG(i) build_int_cst (gfc_array_index_type, i)
|
|
|
1646
|
|
|
1647 static void
|
|
|
1648 transfer_namelist_element (stmtblock_t * block, const char * var_name,
|
|
|
1649 gfc_symbol * sym, gfc_component * c,
|
|
|
1650 tree base_addr)
|
|
|
1651 {
|
|
|
1652 gfc_typespec * ts = NULL;
|
|
|
1653 gfc_array_spec * as = NULL;
|
|
|
1654 tree addr_expr = NULL;
|
|
|
1655 tree dt = NULL;
|
|
|
1656 tree string;
|
|
|
1657 tree tmp;
|
|
|
1658 tree dtype;
|
|
|
1659 tree dt_parm_addr;
|
|
|
1660 tree decl = NULL_TREE;
|
|
|
1661 tree gfc_int4_type_node = gfc_get_int_type (4);
|
|
|
1662 tree dtio_proc = null_pointer_node;
|
|
|
1663 tree vtable = null_pointer_node;
|
|
|
1664 int n_dim;
|
|
|
1665 int itype;
|
|
|
1666 int rank = 0;
|
|
|
1667
|
|
|
1668 gcc_assert (sym || c);
|
|
|
1669
|
|
|
1670 /* Build the namelist object name. */
|
|
|
1671
|
|
|
1672 string = gfc_build_cstring_const (var_name);
|
|
|
1673 string = gfc_build_addr_expr (pchar_type_node, string);
|
|
|
1674
|
|
|
1675 /* Build ts, as and data address using symbol or component. */
|
|
|
1676
|
|
|
1677 ts = sym ? &sym->ts : &c->ts;
|
|
|
1678
|
|
|
1679 if (ts->type != BT_CLASS)
|
|
|
1680 as = sym ? sym->as : c->as;
|
|
|
1681 else
|
|
|
1682 as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
|
|
|
1683
|
|
|
1684 addr_expr = nml_get_addr_expr (sym, c, base_addr);
|
|
|
1685
|
|
|
1686 if (as)
|
|
|
1687 rank = as->rank;
|
|
|
1688
|
|
|
1689 if (rank)
|
|
|
1690 {
|
|
|
1691 decl = sym ? sym->backend_decl : c->backend_decl;
|
|
|
1692 if (sym && sym->attr.dummy)
|
|
|
1693 decl = build_fold_indirect_ref_loc (input_location, decl);
|
|
|
1694
|
|
|
1695 if (ts->type == BT_CLASS)
|
|
|
1696 decl = gfc_class_data_get (decl);
|
|
|
1697 dt = TREE_TYPE (decl);
|
|
|
1698 dtype = gfc_get_dtype (dt);
|
|
|
1699 }
|
|
|
1700 else
|
|
|
1701 {
|
|
|
1702 itype = ts->type;
|
|
|
1703 dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
|
|
|
1704 }
|
|
|
1705
|
|
|
1706 /* Build up the arguments for the transfer call.
|
|
|
1707 The call for the scalar part transfers:
|
|
|
1708 (address, name, type, kind or string_length, dtype) */
|
|
|
1709
|
|
|
1710 dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
|
|
1711
|
|
|
1712 /* Check if the derived type has a specific DTIO for the mode.
|
|
|
1713 Note that although namelist io is forbidden to have a format
|
|
|
1714 list, the specific subroutine is of the formatted kind. */
|
|
|
1715 if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
|
|
|
1716 {
|
|
|
1717 gfc_symbol *derived;
|
|
|
1718 if (ts->type==BT_CLASS)
|
|
|
1719 derived = ts->u.derived->components->ts.u.derived;
|
|
|
1720 else
|
|
|
1721 derived = ts->u.derived;
|
|
|
1722
|
|
|
1723 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
|
|
|
1724 last_dt == WRITE, true);
|
|
|
1725
|
|
|
1726 if (ts->type == BT_CLASS && tb_io_st)
|
|
|
1727 {
|
|
|
1728 // polymorphic DTIO call (based on the dynamic type)
|
|
|
1729 gfc_se se;
|
|
|
1730 gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
|
|
|
1731 // build vtable expr
|
|
|
1732 gfc_expr *expr = gfc_get_variable_expr (st);
|
|
|
1733 gfc_add_vptr_component (expr);
|
|
|
1734 gfc_init_se (&se, NULL);
|
|
|
1735 se.want_pointer = 1;
|
|
|
1736 gfc_conv_expr (&se, expr);
|
|
|
1737 vtable = se.expr;
|
|
|
1738 // build dtio expr
|
|
|
1739 gfc_add_component_ref (expr,
|
|
|
1740 tb_io_st->n.tb->u.generic->specific_st->name);
|
|
|
1741 gfc_init_se (&se, NULL);
|
|
|
1742 se.want_pointer = 1;
|
|
|
1743 gfc_conv_expr (&se, expr);
|
|
|
1744 gfc_free_expr (expr);
|
|
|
1745 dtio_proc = se.expr;
|
|
|
1746 }
|
|
|
1747 else
|
|
|
1748 {
|
|
|
1749 // non-polymorphic DTIO call (based on the declared type)
|
|
|
1750 gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
|
|
|
1751 last_dt == WRITE, true);
|
|
|
1752 if (dtio_sub != NULL)
|
|
|
1753 {
|
|
|
1754 dtio_proc = gfc_get_symbol_decl (dtio_sub);
|
|
|
1755 dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
|
|
|
1756 gfc_symbol *vtab = gfc_find_derived_vtab (derived);
|
|
|
1757 vtable = vtab->backend_decl;
|
|
|
1758 if (vtable == NULL_TREE)
|
|
|
1759 vtable = gfc_get_symbol_decl (vtab);
|
|
|
1760 vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
|
|
|
1761 }
|
|
|
1762 }
|
|
|
1763 }
|
|
|
1764
|
|
|
1765 if (ts->type == BT_CHARACTER)
|
|
|
1766 tmp = ts->u.cl->backend_decl;
|
|
|
1767 else
|
|
|
1768 tmp = build_int_cst (gfc_charlen_type_node, 0);
|
|
|
1769
|
|
|
1770 if (dtio_proc == null_pointer_node)
|
|
|
1771 tmp = build_call_expr_loc (input_location,
|
|
|
1772 iocall[IOCALL_SET_NML_VAL], 6,
|
|
|
1773 dt_parm_addr, addr_expr, string,
|
|
|
1774 build_int_cst (gfc_int4_type_node, ts->kind),
|
|
|
1775 tmp, dtype);
|
|
|
1776 else
|
|
|
1777 tmp = build_call_expr_loc (input_location,
|
|
|
1778 iocall[IOCALL_SET_NML_DTIO_VAL], 8,
|
|
|
1779 dt_parm_addr, addr_expr, string,
|
|
|
1780 build_int_cst (gfc_int4_type_node, ts->kind),
|
|
|
1781 tmp, dtype, dtio_proc, vtable);
|
|
|
1782 gfc_add_expr_to_block (block, tmp);
|
|
|
1783
|
|
|
1784 /* If the object is an array, transfer rank times:
|
|
|
1785 (null pointer, name, stride, lbound, ubound) */
|
|
|
1786
|
|
|
1787 for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
|
|
|
1788 {
|
|
|
1789 tmp = build_call_expr_loc (input_location,
|
|
|
1790 iocall[IOCALL_SET_NML_VAL_DIM], 5,
|
|
|
1791 dt_parm_addr,
|
|
|
1792 build_int_cst (gfc_int4_type_node, n_dim),
|
|
|
1793 gfc_conv_array_stride (decl, n_dim),
|
|
|
1794 gfc_conv_array_lbound (decl, n_dim),
|
|
|
1795 gfc_conv_array_ubound (decl, n_dim));
|
|
|
1796 gfc_add_expr_to_block (block, tmp);
|
|
|
1797 }
|
|
|
1798
|
|
|
1799 if (gfc_bt_struct (ts->type) && ts->u.derived->components
|
|
|
1800 && dtio_proc == null_pointer_node)
|
|
|
1801 {
|
|
|
1802 gfc_component *cmp;
|
|
|
1803
|
|
|
1804 /* Provide the RECORD_TYPE to build component references. */
|
|
|
1805
|
|
|
1806 tree expr = build_fold_indirect_ref_loc (input_location,
|
|
|
1807 addr_expr);
|
|
|
1808
|
|
|
1809 for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
|
|
|
1810 {
|
|
|
1811 char *full_name = nml_full_name (var_name, cmp->name,
|
|
|
1812 ts->u.derived->attr.extension);
|
|
|
1813 transfer_namelist_element (block,
|
|
|
1814 full_name,
|
|
|
1815 NULL, cmp, expr);
|
|
|
1816 free (full_name);
|
|
|
1817 }
|
|
|
1818 }
|
|
|
1819 }
|
|
|
1820
|
|
|
1821 #undef IARG
|
|
|
1822
|
|
|
1823 /* Create a data transfer statement. Not all of the fields are valid
|
|
|
1824 for both reading and writing, but improper use has been filtered
|
|
|
1825 out by now. */
|
|
|
1826
|
|
|
1827 static tree
|
|
|
1828 build_dt (tree function, gfc_code * code)
|
|
|
1829 {
|
|
|
1830 stmtblock_t block, post_block, post_end_block, post_iu_block;
|
|
|
1831 gfc_dt *dt;
|
|
|
1832 tree tmp, var;
|
|
|
1833 gfc_expr *nmlname;
|
|
|
1834 gfc_namelist *nml;
|
|
|
1835 unsigned int mask = 0;
|
|
|
1836
|
|
|
1837 gfc_start_block (&block);
|
|
|
1838 gfc_init_block (&post_block);
|
|
|
1839 gfc_init_block (&post_end_block);
|
|
|
1840 gfc_init_block (&post_iu_block);
|
|
|
1841
|
|
|
1842 var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
|
|
|
1843
|
|
|
1844 set_error_locus (&block, var, &code->loc);
|
|
|
1845
|
|
|
1846 if (last_dt == IOLENGTH)
|
|
|
1847 {
|
|
|
1848 gfc_inquire *inq;
|
|
|
1849
|
|
|
1850 inq = code->ext.inquire;
|
|
|
1851
|
|
|
1852 /* First check that preconditions are met. */
|
|
|
1853 gcc_assert (inq != NULL);
|
|
|
1854 gcc_assert (inq->iolength != NULL);
|
|
|
1855
|
|
|
1856 /* Connect to the iolength variable. */
|
|
|
1857 mask |= set_parameter_ref (&block, &post_end_block, var,
|
|
|
1858 IOPARM_dt_iolength, inq->iolength);
|
|
|
1859 dt = NULL;
|
|
|
1860 }
|
|
|
1861 else
|
|
|
1862 {
|
|
|
1863 dt = code->ext.dt;
|
|
|
1864 gcc_assert (dt != NULL);
|
|
|
1865 }
|
|
|
1866
|
|
|
1867 if (dt && dt->io_unit)
|
|
|
1868 {
|
|
|
1869 if (dt->io_unit->ts.type == BT_CHARACTER)
|
|
|
1870 {
|
|
|
1871 mask |= set_internal_unit (&block, &post_iu_block,
|
|
|
1872 var, dt->io_unit);
|
|
|
1873 set_parameter_const (&block, var, IOPARM_common_unit,
|
|
|
1874 dt->io_unit->ts.kind == 1 ?
|
|
|
1875 GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4);
|
|
|
1876 }
|
|
|
1877 }
|
|
|
1878 else
|
|
|
1879 set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
1880
|
|
|
1881 if (dt)
|
|
|
1882 {
|
|
|
1883 if (dt->iomsg)
|
|
|
1884 mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
|
|
1885 dt->iomsg);
|
|
|
1886
|
|
|
1887 if (dt->iostat)
|
|
|
1888 mask |= set_parameter_ref (&block, &post_end_block, var,
|
|
|
1889 IOPARM_common_iostat, dt->iostat);
|
|
|
1890
|
|
|
1891 if (dt->err)
|
|
|
1892 mask |= IOPARM_common_err;
|
|
|
1893
|
|
|
1894 if (dt->eor)
|
|
|
1895 mask |= IOPARM_common_eor;
|
|
|
1896
|
|
|
1897 if (dt->end)
|
|
|
1898 mask |= IOPARM_common_end;
|
|
|
1899
|
|
|
1900 if (dt->id)
|
|
|
1901 mask |= set_parameter_ref (&block, &post_end_block, var,
|
|
|
1902 IOPARM_dt_id, dt->id);
|
|
|
1903
|
|
|
1904 if (dt->pos)
|
|
|
1905 mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
|
|
|
1906
|
|
|
1907 if (dt->asynchronous)
|
|
|
1908 mask |= set_string (&block, &post_block, var,
|
|
|
1909 IOPARM_dt_asynchronous, dt->asynchronous);
|
|
|
1910
|
|
|
1911 if (dt->blank)
|
|
|
1912 mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
|
|
|
1913 dt->blank);
|
|
|
1914
|
|
|
1915 if (dt->decimal)
|
|
|
1916 mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
|
|
|
1917 dt->decimal);
|
|
|
1918
|
|
|
1919 if (dt->delim)
|
|
|
1920 mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
|
|
|
1921 dt->delim);
|
|
|
1922
|
|
|
1923 if (dt->pad)
|
|
|
1924 mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
|
|
|
1925 dt->pad);
|
|
|
1926
|
|
|
1927 if (dt->round)
|
|
|
1928 mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
|
|
|
1929 dt->round);
|
|
|
1930
|
|
|
1931 if (dt->sign)
|
|
|
1932 mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
|
|
|
1933 dt->sign);
|
|
|
1934
|
|
|
1935 if (dt->rec)
|
|
|
1936 mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
|
|
|
1937
|
|
|
1938 if (dt->advance)
|
|
|
1939 mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
|
|
|
1940 dt->advance);
|
|
|
1941
|
|
|
1942 if (dt->format_expr)
|
|
|
1943 mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
|
|
|
1944 dt->format_expr);
|
|
|
1945
|
|
|
1946 if (dt->format_label)
|
|
|
1947 {
|
|
|
1948 if (dt->format_label == &format_asterisk)
|
|
|
1949 mask |= IOPARM_dt_list_format;
|
|
|
1950 else
|
|
|
1951 mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
|
|
|
1952 dt->format_label->format);
|
|
|
1953 }
|
|
|
1954
|
|
|
1955 if (dt->size)
|
|
|
1956 mask |= set_parameter_ref (&block, &post_end_block, var,
|
|
|
1957 IOPARM_dt_size, dt->size);
|
|
|
1958
|
|
|
1959 if (dt->udtio)
|
|
|
1960 mask |= IOPARM_dt_dtio;
|
|
|
1961
|
|
|
1962 if (dt->default_exp)
|
|
|
1963 mask |= IOPARM_dt_default_exp;
|
|
|
1964
|
|
|
1965 if (dt->namelist)
|
|
|
1966 {
|
|
|
1967 if (dt->format_expr || dt->format_label)
|
|
|
1968 gfc_internal_error ("build_dt: format with namelist");
|
|
|
1969
|
|
|
1970 nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
|
|
|
1971 dt->namelist->name,
|
|
|
1972 strlen (dt->namelist->name));
|
|
|
1973
|
|
|
1974 mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
|
|
|
1975 nmlname);
|
|
|
1976
|
|
|
1977 gfc_free_expr (nmlname);
|
|
|
1978
|
|
|
1979 if (last_dt == READ)
|
|
|
1980 mask |= IOPARM_dt_namelist_read_mode;
|
|
|
1981
|
|
|
1982 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1983
|
|
|
1984 dt_parm = var;
|
|
|
1985
|
|
|
1986 for (nml = dt->namelist->namelist; nml; nml = nml->next)
|
|
|
1987 transfer_namelist_element (&block, nml->sym->name, nml->sym,
|
|
|
1988 NULL, NULL_TREE);
|
|
|
1989 }
|
|
|
1990 else
|
|
|
1991 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1992
|
|
|
1993 if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
|
|
|
1994 set_parameter_value_chk (&block, dt->iostat, var,
|
|
|
1995 IOPARM_common_unit, dt->io_unit);
|
|
|
1996 }
|
|
|
1997 else
|
|
|
1998 set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
1999
|
|
|
2000 tmp = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
2001 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
|
|
|
2002 function, 1, tmp);
|
|
|
2003 gfc_add_expr_to_block (&block, tmp);
|
|
|
2004
|
|
|
2005 gfc_add_block_to_block (&block, &post_block);
|
|
|
2006
|
|
|
2007 dt_parm = var;
|
|
|
2008 dt_post_end_block = &post_end_block;
|
|
|
2009
|
|
|
2010 /* Set implied do loop exit condition. */
|
|
|
2011 if (last_dt == READ || last_dt == WRITE)
|
|
|
2012 {
|
|
|
2013 gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
|
|
|
2014
|
|
|
2015 tmp = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
2016 st_parameter[IOPARM_ptype_common].type,
|
|
|
2017 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
|
|
|
2018 NULL_TREE);
|
|
|
2019 tmp = fold_build3_loc (input_location, COMPONENT_REF,
|
|
|
2020 TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
|
|
|
2021 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
|
|
|
2022 tmp, build_int_cst (TREE_TYPE (tmp),
|
|
|
2023 IOPARM_common_libreturn_mask));
|
|
|
2024 }
|
|
|
2025 else /* IOLENGTH */
|
|
|
2026 tmp = NULL_TREE;
|
|
|
2027
|
|
|
2028 gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
|
|
|
2029
|
|
|
2030 gfc_add_block_to_block (&block, &post_iu_block);
|
|
|
2031
|
|
|
2032 dt_parm = NULL;
|
|
|
2033 dt_post_end_block = NULL;
|
|
|
2034
|
|
|
2035 return gfc_finish_block (&block);
|
|
|
2036 }
|
|
|
2037
|
|
|
2038
|
|
|
2039 /* Translate the IOLENGTH form of an INQUIRE statement. We treat
|
|
|
2040 this as a third sort of data transfer statement, except that
|
|
|
2041 lengths are summed instead of actually transferring any data. */
|
|
|
2042
|
|
|
2043 tree
|
|
|
2044 gfc_trans_iolength (gfc_code * code)
|
|
|
2045 {
|
|
|
2046 last_dt = IOLENGTH;
|
|
|
2047 return build_dt (iocall[IOCALL_IOLENGTH], code);
|
|
|
2048 }
|
|
|
2049
|
|
|
2050
|
|
|
2051 /* Translate a READ statement. */
|
|
|
2052
|
|
|
2053 tree
|
|
|
2054 gfc_trans_read (gfc_code * code)
|
|
|
2055 {
|
|
|
2056 last_dt = READ;
|
|
|
2057 return build_dt (iocall[IOCALL_READ], code);
|
|
|
2058 }
|
|
|
2059
|
|
|
2060
|
|
|
2061 /* Translate a WRITE statement */
|
|
|
2062
|
|
|
2063 tree
|
|
|
2064 gfc_trans_write (gfc_code * code)
|
|
|
2065 {
|
|
|
2066 last_dt = WRITE;
|
|
|
2067 return build_dt (iocall[IOCALL_WRITE], code);
|
|
|
2068 }
|
|
|
2069
|
|
|
2070
|
|
|
2071 /* Finish a data transfer statement. */
|
|
|
2072
|
|
|
2073 tree
|
|
|
2074 gfc_trans_dt_end (gfc_code * code)
|
|
|
2075 {
|
|
|
2076 tree function, tmp;
|
|
|
2077 stmtblock_t block;
|
|
|
2078
|
|
|
2079 gfc_init_block (&block);
|
|
|
2080
|
|
|
2081 switch (last_dt)
|
|
|
2082 {
|
|
|
2083 case READ:
|
|
|
2084 function = iocall[IOCALL_READ_DONE];
|
|
|
2085 break;
|
|
|
2086
|
|
|
2087 case WRITE:
|
|
|
2088 function = iocall[IOCALL_WRITE_DONE];
|
|
|
2089 break;
|
|
|
2090
|
|
|
2091 case IOLENGTH:
|
|
|
2092 function = iocall[IOCALL_IOLENGTH_DONE];
|
|
|
2093 break;
|
|
|
2094
|
|
|
2095 default:
|
|
|
2096 gcc_unreachable ();
|
|
|
2097 }
|
|
|
2098
|
|
|
2099 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
|
|
2100 tmp = build_call_expr_loc (input_location,
|
|
|
2101 function, 1, tmp);
|
|
|
2102 gfc_add_expr_to_block (&block, tmp);
|
|
|
2103 gfc_add_block_to_block (&block, dt_post_end_block);
|
|
|
2104 gfc_init_block (dt_post_end_block);
|
|
|
2105
|
|
|
2106 if (last_dt != IOLENGTH)
|
|
|
2107 {
|
|
|
2108 gcc_assert (code->ext.dt != NULL);
|
|
|
2109 io_result (&block, dt_parm, code->ext.dt->err,
|
|
|
2110 code->ext.dt->end, code->ext.dt->eor);
|
|
|
2111 }
|
|
|
2112
|
|
|
2113 return gfc_finish_block (&block);
|
|
|
2114 }
|
|
|
2115
|
|
|
2116 static void
|
|
|
2117 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
|
|
|
2118 gfc_code * code, tree vptr);
|
|
|
2119
|
|
|
2120 /* Given an array field in a derived type variable, generate the code
|
|
|
2121 for the loop that iterates over array elements, and the code that
|
|
|
2122 accesses those array elements. Use transfer_expr to generate code
|
|
|
2123 for transferring that element. Because elements may also be
|
|
|
2124 derived types, transfer_expr and transfer_array_component are mutually
|
|
|
2125 recursive. */
|
|
|
2126
|
|
|
2127 static tree
|
|
|
2128 transfer_array_component (tree expr, gfc_component * cm, locus * where)
|
|
|
2129 {
|
|
|
2130 tree tmp;
|
|
|
2131 stmtblock_t body;
|
|
|
2132 stmtblock_t block;
|
|
|
2133 gfc_loopinfo loop;
|
|
|
2134 int n;
|
|
|
2135 gfc_ss *ss;
|
|
|
2136 gfc_se se;
|
|
|
2137 gfc_array_info *ss_array;
|
|
|
2138
|
|
|
2139 gfc_start_block (&block);
|
|
|
2140 gfc_init_se (&se, NULL);
|
|
|
2141
|
|
|
2142 /* Create and initialize Scalarization Status. Unlike in
|
|
|
2143 gfc_trans_transfer, we can't simply use gfc_walk_expr to take
|
|
|
2144 care of this task, because we don't have a gfc_expr at hand.
|
|
|
2145 Build one manually, as in gfc_trans_subarray_assign. */
|
|
|
2146
|
|
|
2147 ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
|
|
|
2148 GFC_SS_COMPONENT);
|
|
|
2149 ss_array = &ss->info->data.array;
|
|
|
2150 ss_array->shape = gfc_get_shape (cm->as->rank);
|
|
|
2151 ss_array->descriptor = expr;
|
|
|
2152 ss_array->data = gfc_conv_array_data (expr);
|
|
|
2153 ss_array->offset = gfc_conv_array_offset (expr);
|
|
|
2154 for (n = 0; n < cm->as->rank; n++)
|
|
|
2155 {
|
|
|
2156 ss_array->start[n] = gfc_conv_array_lbound (expr, n);
|
|
|
2157 ss_array->stride[n] = gfc_index_one_node;
|
|
|
2158
|
|
|
2159 mpz_init (ss_array->shape[n]);
|
|
|
2160 mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
|
|
|
2161 cm->as->lower[n]->value.integer);
|
|
|
2162 mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
|
|
|
2163 }
|
|
|
2164
|
|
|
2165 /* Once we got ss, we use scalarizer to create the loop. */
|
|
|
2166
|
|
|
2167 gfc_init_loopinfo (&loop);
|
|
|
2168 gfc_add_ss_to_loop (&loop, ss);
|
|
|
2169 gfc_conv_ss_startstride (&loop);
|
|
|
2170 gfc_conv_loop_setup (&loop, where);
|
|
|
2171 gfc_mark_ss_chain_used (ss, 1);
|
|
|
2172 gfc_start_scalarized_body (&loop, &body);
|
|
|
2173
|
|
|
2174 gfc_copy_loopinfo_to_se (&se, &loop);
|
|
|
2175 se.ss = ss;
|
|
|
2176
|
|
|
2177 /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
|
|
|
2178 se.expr = expr;
|
|
|
2179 gfc_conv_tmp_array_ref (&se);
|
|
|
2180
|
|
|
2181 /* Now se.expr contains an element of the array. Take the address and pass
|
|
|
2182 it to the IO routines. */
|
|
|
2183 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
|
|
|
2184 transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
|
|
|
2185
|
|
|
2186 /* We are done now with the loop body. Wrap up the scalarizer and
|
|
|
2187 return. */
|
|
|
2188
|
|
|
2189 gfc_add_block_to_block (&body, &se.pre);
|
|
|
2190 gfc_add_block_to_block (&body, &se.post);
|
|
|
2191
|
|
|
2192 gfc_trans_scalarizing_loops (&loop, &body);
|
|
|
2193
|
|
|
2194 gfc_add_block_to_block (&block, &loop.pre);
|
|
|
2195 gfc_add_block_to_block (&block, &loop.post);
|
|
|
2196
|
|
|
2197 gcc_assert (ss_array->shape != NULL);
|
|
|
2198 gfc_free_shape (&ss_array->shape, cm->as->rank);
|
|
|
2199 gfc_cleanup_loop (&loop);
|
|
|
2200
|
|
|
2201 return gfc_finish_block (&block);
|
|
|
2202 }
|
|
|
2203
|
|
|
2204
|
|
|
2205 /* Helper function for transfer_expr that looks for the DTIO procedure
|
|
|
2206 either as a typebound binding or in a generic interface. If present,
|
|
|
2207 the address expression of the procedure is returned. It is assumed
|
|
|
2208 that the procedure interface has been checked during resolution. */
|
|
|
2209
|
|
|
2210 static tree
|
|
|
2211 get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
|
|
|
2212 {
|
|
|
2213 gfc_symbol *derived;
|
|
|
2214 bool formatted = false;
|
|
|
2215 gfc_dt *dt = code->ext.dt;
|
|
|
2216
|
|
|
2217 if (dt)
|
|
|
2218 {
|
|
|
2219 char *fmt = NULL;
|
|
|
2220
|
|
|
2221 if (dt->format_label == &format_asterisk)
|
|
|
2222 {
|
|
|
2223 /* List directed io must call the formatted DTIO procedure. */
|
|
|
2224 formatted = true;
|
|
|
2225 }
|
|
|
2226 else if (dt->format_expr)
|
|
|
2227 fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
|
|
|
2228 -1);
|
|
|
2229 else if (dt->format_label)
|
|
|
2230 fmt = gfc_widechar_to_char (dt->format_label->format->value.character.string,
|
|
|
2231 -1);
|
|
|
2232 if (fmt && strtok (fmt, "DT") != NULL)
|
|
|
2233 formatted = true;
|
|
|
2234
|
|
|
2235 }
|
|
|
2236
|
|
|
2237 if (ts->type == BT_CLASS)
|
|
|
2238 derived = ts->u.derived->components->ts.u.derived;
|
|
|
2239 else
|
|
|
2240 derived = ts->u.derived;
|
|
|
2241
|
|
|
2242 gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
|
|
|
2243 last_dt == WRITE, formatted);
|
|
|
2244 if (ts->type == BT_CLASS && tb_io_st)
|
|
|
2245 {
|
|
|
2246 // polymorphic DTIO call (based on the dynamic type)
|
|
|
2247 gfc_se se;
|
|
|
2248 gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1);
|
|
|
2249 gfc_add_vptr_component (expr);
|
|
|
2250 gfc_add_component_ref (expr,
|
|
|
2251 tb_io_st->n.tb->u.generic->specific_st->name);
|
|
|
2252 *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym;
|
|
|
2253 gfc_init_se (&se, NULL);
|
|
|
2254 se.want_pointer = 1;
|
|
|
2255 gfc_conv_expr (&se, expr);
|
|
|
2256 gfc_free_expr (expr);
|
|
|
2257 return se.expr;
|
|
|
2258 }
|
|
|
2259 else
|
|
|
2260 {
|
|
|
2261 // non-polymorphic DTIO call (based on the declared type)
|
|
|
2262 *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
|
|
|
2263 formatted);
|
|
|
2264
|
|
|
2265 if (*dtio_sub)
|
|
|
2266 return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
|
|
|
2267 }
|
|
|
2268
|
|
|
2269 return NULL_TREE;
|
|
|
2270 }
|
|
|
2271
|
|
|
2272 /* Generate the call for a scalar transfer node. */
|
|
|
2273
|
|
|
2274 static void
|
|
|
2275 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
|
|
|
2276 gfc_code * code, tree vptr)
|
|
|
2277 {
|
|
|
2278 tree tmp, function, arg2, arg3, field, expr;
|
|
|
2279 gfc_component *c;
|
|
|
2280 int kind;
|
|
|
2281
|
|
|
2282 /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
|
|
|
2283 the user says something like: print *, 'c_null_ptr: ', c_null_ptr
|
|
|
2284 We need to translate the expression to a constant if it's either
|
|
|
2285 C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
|
|
|
2286 type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
|
|
|
2287 BT_DERIVED (could have been changed by gfc_conv_expr). */
|
|
|
2288 if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
|
|
|
2289 && ts->u.derived != NULL
|
|
|
2290 && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
|
|
|
2291 {
|
|
|
2292 ts->type = BT_INTEGER;
|
|
|
2293 ts->kind = gfc_index_integer_kind;
|
|
|
2294 }
|
|
|
2295
|
|
|
2296 kind = ts->kind;
|
|
|
2297 function = NULL;
|
|
|
2298 arg2 = NULL;
|
|
|
2299 arg3 = NULL;
|
|
|
2300
|
|
|
2301 switch (ts->type)
|
|
|
2302 {
|
|
|
2303 case BT_INTEGER:
|
|
|
2304 arg2 = build_int_cst (integer_type_node, kind);
|
|
|
2305 if (last_dt == READ)
|
|
|
2306 function = iocall[IOCALL_X_INTEGER];
|
|
|
2307 else
|
|
|
2308 function = iocall[IOCALL_X_INTEGER_WRITE];
|
|
|
2309
|
|
|
2310 break;
|
|
|
2311
|
|
|
2312 case BT_REAL:
|
|
|
2313 arg2 = build_int_cst (integer_type_node, kind);
|
|
|
2314 if (last_dt == READ)
|
|
|
2315 {
|
|
|
2316 if (gfc_real16_is_float128 && ts->kind == 16)
|
|
|
2317 function = iocall[IOCALL_X_REAL128];
|
|
|
2318 else
|
|
|
2319 function = iocall[IOCALL_X_REAL];
|
|
|
2320 }
|
|
|
2321 else
|
|
|
2322 {
|
|
|
2323 if (gfc_real16_is_float128 && ts->kind == 16)
|
|
|
2324 function = iocall[IOCALL_X_REAL128_WRITE];
|
|
|
2325 else
|
|
|
2326 function = iocall[IOCALL_X_REAL_WRITE];
|
|
|
2327 }
|
|
|
2328
|
|
|
2329 break;
|
|
|
2330
|
|
|
2331 case BT_COMPLEX:
|
|
|
2332 arg2 = build_int_cst (integer_type_node, kind);
|
|
|
2333 if (last_dt == READ)
|
|
|
2334 {
|
|
|
2335 if (gfc_real16_is_float128 && ts->kind == 16)
|
|
|
2336 function = iocall[IOCALL_X_COMPLEX128];
|
|
|
2337 else
|
|
|
2338 function = iocall[IOCALL_X_COMPLEX];
|
|
|
2339 }
|
|
|
2340 else
|
|
|
2341 {
|
|
|
2342 if (gfc_real16_is_float128 && ts->kind == 16)
|
|
|
2343 function = iocall[IOCALL_X_COMPLEX128_WRITE];
|
|
|
2344 else
|
|
|
2345 function = iocall[IOCALL_X_COMPLEX_WRITE];
|
|
|
2346 }
|
|
|
2347
|
|
|
2348 break;
|
|
|
2349
|
|
|
2350 case BT_LOGICAL:
|
|
|
2351 arg2 = build_int_cst (integer_type_node, kind);
|
|
|
2352 if (last_dt == READ)
|
|
|
2353 function = iocall[IOCALL_X_LOGICAL];
|
|
|
2354 else
|
|
|
2355 function = iocall[IOCALL_X_LOGICAL_WRITE];
|
|
|
2356
|
|
|
2357 break;
|
|
|
2358
|
|
|
2359 case BT_CHARACTER:
|
|
|
2360 if (kind == 4)
|
|
|
2361 {
|
|
|
2362 if (se->string_length)
|
|
|
2363 arg2 = se->string_length;
|
|
|
2364 else
|
|
|
2365 {
|
|
|
2366 tmp = build_fold_indirect_ref_loc (input_location,
|
|
|
2367 addr_expr);
|
|
|
2368 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
|
|
|
2369 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
|
|
|
2370 arg2 = fold_convert (gfc_charlen_type_node, arg2);
|
|
|
2371 }
|
|
|
2372 arg3 = build_int_cst (integer_type_node, kind);
|
|
|
2373 if (last_dt == READ)
|
|
|
2374 function = iocall[IOCALL_X_CHARACTER_WIDE];
|
|
|
2375 else
|
|
|
2376 function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
|
|
|
2377
|
|
|
2378 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
|
|
2379 tmp = build_call_expr_loc (input_location,
|
|
|
2380 function, 4, tmp, addr_expr, arg2, arg3);
|
|
|
2381 gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
2382 gfc_add_block_to_block (&se->pre, &se->post);
|
|
|
2383 return;
|
|
|
2384 }
|
|
|
2385 /* Fall through. */
|
|
|
2386 case BT_HOLLERITH:
|
|
|
2387 if (se->string_length)
|
|
|
2388 arg2 = se->string_length;
|
|
|
2389 else
|
|
|
2390 {
|
|
|
2391 tmp = build_fold_indirect_ref_loc (input_location,
|
|
|
2392 addr_expr);
|
|
|
2393 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
|
|
|
2394 arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
|
|
|
2395 }
|
|
|
2396 if (last_dt == READ)
|
|
|
2397 function = iocall[IOCALL_X_CHARACTER];
|
|
|
2398 else
|
|
|
2399 function = iocall[IOCALL_X_CHARACTER_WRITE];
|
|
|
2400
|
|
|
2401 break;
|
|
|
2402
|
|
|
2403 case_bt_struct:
|
|
|
2404 case BT_CLASS:
|
|
|
2405 if (ts->u.derived->components == NULL)
|
|
|
2406 return;
|
|
|
2407 if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS)
|
|
|
2408 {
|
|
|
2409 gfc_symbol *derived;
|
|
|
2410 gfc_symbol *dtio_sub = NULL;
|
|
|
2411 /* Test for a specific DTIO subroutine. */
|
|
|
2412 if (ts->type == BT_DERIVED)
|
|
|
2413 derived = ts->u.derived;
|
|
|
2414 else
|
|
|
2415 derived = ts->u.derived->components->ts.u.derived;
|
|
|
2416
|
|
|
2417 if (derived->attr.has_dtio_procs)
|
|
|
2418 arg2 = get_dtio_proc (ts, code, &dtio_sub);
|
|
|
2419
|
|
|
2420 if ((dtio_sub != NULL) && (last_dt != IOLENGTH))
|
|
|
2421 {
|
|
|
2422 tree decl;
|
|
|
2423 decl = build_fold_indirect_ref_loc (input_location,
|
|
|
2424 se->expr);
|
|
|
2425 /* Remember that the first dummy of the DTIO subroutines
|
|
|
2426 is CLASS(derived) for extensible derived types, so the
|
|
|
2427 conversion must be done here for derived type and for
|
|
|
2428 scalarized CLASS array element io-list objects. */
|
|
|
2429 if ((ts->type == BT_DERIVED
|
|
|
2430 && !(ts->u.derived->attr.sequence
|
|
|
2431 || ts->u.derived->attr.is_bind_c))
|
|
|
2432 || (ts->type == BT_CLASS
|
|
|
2433 && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
|
|
|
2434 gfc_conv_derived_to_class (se, code->expr1,
|
|
|
2435 dtio_sub->formal->sym->ts,
|
|
|
2436 vptr, false, false);
|
|
|
2437 addr_expr = se->expr;
|
|
|
2438 function = iocall[IOCALL_X_DERIVED];
|
|
|
2439 break;
|
|
|
2440 }
|
|
|
2441 else if (gfc_bt_struct (ts->type))
|
|
|
2442 {
|
|
|
2443 /* Recurse into the elements of the derived type. */
|
|
|
2444 expr = gfc_evaluate_now (addr_expr, &se->pre);
|
|
|
2445 expr = build_fold_indirect_ref_loc (input_location,
|
|
|
2446 expr);
|
|
|
2447
|
|
|
2448 /* Make sure that the derived type has been built. An external
|
|
|
2449 function, if only referenced in an io statement, requires this
|
|
|
2450 check (see PR58771). */
|
|
|
2451 if (ts->u.derived->backend_decl == NULL_TREE)
|
|
|
2452 (void) gfc_typenode_for_spec (ts);
|
|
|
2453
|
|
|
2454 for (c = ts->u.derived->components; c; c = c->next)
|
|
|
2455 {
|
|
|
2456 field = c->backend_decl;
|
|
|
2457 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
|
|
|
2458
|
|
|
2459 tmp = fold_build3_loc (UNKNOWN_LOCATION,
|
|
|
2460 COMPONENT_REF, TREE_TYPE (field),
|
|
|
2461 expr, field, NULL_TREE);
|
|
|
2462
|
|
|
2463 if (c->attr.dimension)
|
|
|
2464 {
|
|
|
2465 tmp = transfer_array_component (tmp, c, & code->loc);
|
|
|
2466 gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
2467 }
|
|
|
2468 else
|
|
|
2469 {
|
|
|
2470 if (!c->attr.pointer)
|
|
|
2471 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
|
|
2472 transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
|
|
|
2473 }
|
|
|
2474 }
|
|
|
2475 return;
|
|
|
2476 }
|
|
|
2477 /* If a CLASS object gets through to here, fall through and ICE. */
|
|
|
2478 }
|
|
|
2479 gcc_fallthrough ();
|
|
|
2480 default:
|
|
|
2481 gfc_internal_error ("Bad IO basetype (%d)", ts->type);
|
|
|
2482 }
|
|
|
2483
|
|
|
2484 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
|
|
2485 tmp = build_call_expr_loc (input_location,
|
|
|
2486 function, 3, tmp, addr_expr, arg2);
|
|
|
2487 gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
2488 gfc_add_block_to_block (&se->pre, &se->post);
|
|
|
2489
|
|
|
2490 }
|
|
|
2491
|
|
|
2492
|
|
|
2493 /* Generate a call to pass an array descriptor to the IO library. The
|
|
|
2494 array should be of one of the intrinsic types. */
|
|
|
2495
|
|
|
2496 static void
|
|
|
2497 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
|
|
|
2498 {
|
|
|
2499 tree tmp, charlen_arg, kind_arg, io_call;
|
|
|
2500
|
|
|
2501 if (ts->type == BT_CHARACTER)
|
|
|
2502 charlen_arg = se->string_length;
|
|
|
2503 else
|
|
|
2504 charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
|
|
|
2505
|
|
|
2506 kind_arg = build_int_cst (integer_type_node, ts->kind);
|
|
|
2507
|
|
|
2508 tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
|
|
2509 if (last_dt == READ)
|
|
|
2510 io_call = iocall[IOCALL_X_ARRAY];
|
|
|
2511 else
|
|
|
2512 io_call = iocall[IOCALL_X_ARRAY_WRITE];
|
|
|
2513
|
|
|
2514 tmp = build_call_expr_loc (UNKNOWN_LOCATION,
|
|
|
2515 io_call, 4,
|
|
|
2516 tmp, addr_expr, kind_arg, charlen_arg);
|
|
|
2517 gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
2518 gfc_add_block_to_block (&se->pre, &se->post);
|
|
|
2519 }
|
|
|
2520
|
|
|
2521
|
|
|
2522 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
|
|
|
2523
|
|
|
2524 tree
|
|
|
2525 gfc_trans_transfer (gfc_code * code)
|
|
|
2526 {
|
|
|
2527 stmtblock_t block, body;
|
|
|
2528 gfc_loopinfo loop;
|
|
|
2529 gfc_expr *expr;
|
|
|
2530 gfc_ref *ref;
|
|
|
2531 gfc_ss *ss;
|
|
|
2532 gfc_se se;
|
|
|
2533 tree tmp;
|
|
|
2534 tree vptr;
|
|
|
2535 int n;
|
|
|
2536
|
|
|
2537 gfc_start_block (&block);
|
|
|
2538 gfc_init_block (&body);
|
|
|
2539
|
|
|
2540 expr = code->expr1;
|
|
|
2541 ref = NULL;
|
|
|
2542 gfc_init_se (&se, NULL);
|
|
|
2543
|
|
|
2544 if (expr->rank == 0)
|
|
|
2545 {
|
|
|
2546 /* Transfer a scalar value. */
|
|
|
2547 if (expr->ts.type == BT_CLASS)
|
|
|
2548 {
|
|
|
2549 se.want_pointer = 1;
|
|
|
2550 gfc_conv_expr (&se, expr);
|
|
|
2551 vptr = gfc_get_vptr_from_expr (se.expr);
|
|
|
2552 }
|
|
|
2553 else
|
|
|
2554 {
|
|
|
2555 vptr = NULL_TREE;
|
|
|
2556 gfc_conv_expr_reference (&se, expr);
|
|
|
2557 }
|
|
|
2558 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
|
|
|
2559 }
|
|
|
2560 else
|
|
|
2561 {
|
|
|
2562 /* Transfer an array. If it is an array of an intrinsic
|
|
|
2563 type, pass the descriptor to the library. Otherwise
|
|
|
2564 scalarize the transfer. */
|
|
|
2565 if (expr->ref && !gfc_is_proc_ptr_comp (expr))
|
|
|
2566 {
|
|
|
2567 for (ref = expr->ref; ref && ref->type != REF_ARRAY;
|
|
|
2568 ref = ref->next);
|
|
|
2569 gcc_assert (ref && ref->type == REF_ARRAY);
|
|
|
2570 }
|
|
|
2571
|
|
|
2572 if (expr->ts.type != BT_CLASS
|
|
|
2573 && expr->expr_type == EXPR_VARIABLE
|
|
|
2574 && gfc_expr_attr (expr).pointer)
|
|
|
2575 goto scalarize;
|
|
|
2576
|
|
|
2577
|
|
|
2578 if (!(gfc_bt_struct (expr->ts.type)
|
|
|
2579 || expr->ts.type == BT_CLASS)
|
|
|
2580 && ref && ref->next == NULL
|
|
|
2581 && !is_subref_array (expr))
|
|
|
2582 {
|
|
|
2583 bool seen_vector = false;
|
|
|
2584
|
|
|
2585 if (ref && ref->u.ar.type == AR_SECTION)
|
|
|
2586 {
|
|
|
2587 for (n = 0; n < ref->u.ar.dimen; n++)
|
|
|
2588 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
|
|
|
2589 {
|
|
|
2590 seen_vector = true;
|
|
|
2591 break;
|
|
|
2592 }
|
|
|
2593 }
|
|
|
2594
|
|
|
2595 if (seen_vector && last_dt == READ)
|
|
|
2596 {
|
|
|
2597 /* Create a temp, read to that and copy it back. */
|
|
|
2598 gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
|
|
|
2599 tmp = se.expr;
|
|
|
2600 }
|
|
|
2601 else
|
|
|
2602 {
|
|
|
2603 /* Get the descriptor. */
|
|
|
2604 gfc_conv_expr_descriptor (&se, expr);
|
|
|
2605 tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
|
|
|
2606 }
|
|
|
2607
|
|
|
2608 transfer_array_desc (&se, &expr->ts, tmp);
|
|
|
2609 goto finish_block_label;
|
|
|
2610 }
|
|
|
2611
|
|
|
2612 scalarize:
|
|
|
2613 /* Initialize the scalarizer. */
|
|
|
2614 ss = gfc_walk_expr (expr);
|
|
|
2615 gfc_init_loopinfo (&loop);
|
|
|
2616 gfc_add_ss_to_loop (&loop, ss);
|
|
|
2617
|
|
|
2618 /* Initialize the loop. */
|
|
|
2619 gfc_conv_ss_startstride (&loop);
|
|
|
2620 gfc_conv_loop_setup (&loop, &code->expr1->where);
|
|
|
2621
|
|
|
2622 /* The main loop body. */
|
|
|
2623 gfc_mark_ss_chain_used (ss, 1);
|
|
|
2624 gfc_start_scalarized_body (&loop, &body);
|
|
|
2625
|
|
|
2626 gfc_copy_loopinfo_to_se (&se, &loop);
|
|
|
2627 se.ss = ss;
|
|
|
2628
|
|
|
2629 gfc_conv_expr_reference (&se, expr);
|
|
|
2630
|
|
|
2631 if (expr->ts.type == BT_CLASS)
|
|
|
2632 vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
|
|
|
2633 else
|
|
|
2634 vptr = NULL_TREE;
|
|
|
2635 transfer_expr (&se, &expr->ts, se.expr, code, vptr);
|
|
|
2636 }
|
|
|
2637
|
|
|
2638 finish_block_label:
|
|
|
2639
|
|
|
2640 gfc_add_block_to_block (&body, &se.pre);
|
|
|
2641 gfc_add_block_to_block (&body, &se.post);
|
|
|
2642
|
|
|
2643 if (se.ss == NULL)
|
|
|
2644 tmp = gfc_finish_block (&body);
|
|
|
2645 else
|
|
|
2646 {
|
|
|
2647 gcc_assert (expr->rank != 0);
|
|
|
2648 gcc_assert (se.ss == gfc_ss_terminator);
|
|
|
2649 gfc_trans_scalarizing_loops (&loop, &body);
|
|
|
2650
|
|
|
2651 gfc_add_block_to_block (&loop.pre, &loop.post);
|
|
|
2652 tmp = gfc_finish_block (&loop.pre);
|
|
|
2653 gfc_cleanup_loop (&loop);
|
|
|
2654 }
|
|
|
2655
|
|
|
2656 gfc_add_expr_to_block (&block, tmp);
|
|
|
2657
|
|
|
2658 return gfc_finish_block (&block);
|
|
|
2659 }
|
|
|
2660
|
|
|
2661 #include "gt-fortran-trans-io.h"
|
