]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* IO Code translation/library interface |
ec378180 | 2 | Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
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 2, or (at your option) any later | |
10 | version. | |
6de9cd9a | 11 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 18 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
19 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
20 | 02110-1301, USA. */ | |
6de9cd9a DN |
21 | |
22 | ||
23 | #include "config.h" | |
24 | #include "system.h" | |
25 | #include "coretypes.h" | |
26 | #include "tree.h" | |
eadf906f | 27 | #include "tree-gimple.h" |
6de9cd9a DN |
28 | #include "ggc.h" |
29 | #include "toplev.h" | |
30 | #include "real.h" | |
6de9cd9a DN |
31 | #include "gfortran.h" |
32 | #include "trans.h" | |
33 | #include "trans-stmt.h" | |
34 | #include "trans-array.h" | |
35 | #include "trans-types.h" | |
36 | #include "trans-const.h" | |
37 | ||
38 | ||
6de9cd9a DN |
39 | /* Members of the ioparm structure. */ |
40 | ||
41 | static GTY(()) tree ioparm_unit; | |
42 | static GTY(()) tree ioparm_err; | |
43 | static GTY(()) tree ioparm_end; | |
44 | static GTY(()) tree ioparm_eor; | |
45 | static GTY(()) tree ioparm_list_format; | |
46 | static GTY(()) tree ioparm_library_return; | |
47 | static GTY(()) tree ioparm_iostat; | |
48 | static GTY(()) tree ioparm_exist; | |
49 | static GTY(()) tree ioparm_opened; | |
50 | static GTY(()) tree ioparm_number; | |
51 | static GTY(()) tree ioparm_named; | |
52 | static GTY(()) tree ioparm_rec; | |
53 | static GTY(()) tree ioparm_nextrec; | |
54 | static GTY(()) tree ioparm_size; | |
55 | static GTY(()) tree ioparm_recl_in; | |
56 | static GTY(()) tree ioparm_recl_out; | |
8750f9cd | 57 | static GTY(()) tree ioparm_iolength; |
6de9cd9a DN |
58 | static GTY(()) tree ioparm_file; |
59 | static GTY(()) tree ioparm_file_len; | |
60 | static GTY(()) tree ioparm_status; | |
61 | static GTY(()) tree ioparm_status_len; | |
62 | static GTY(()) tree ioparm_access; | |
63 | static GTY(()) tree ioparm_access_len; | |
64 | static GTY(()) tree ioparm_form; | |
65 | static GTY(()) tree ioparm_form_len; | |
66 | static GTY(()) tree ioparm_blank; | |
67 | static GTY(()) tree ioparm_blank_len; | |
68 | static GTY(()) tree ioparm_position; | |
69 | static GTY(()) tree ioparm_position_len; | |
70 | static GTY(()) tree ioparm_action; | |
71 | static GTY(()) tree ioparm_action_len; | |
72 | static GTY(()) tree ioparm_delim; | |
73 | static GTY(()) tree ioparm_delim_len; | |
74 | static GTY(()) tree ioparm_pad; | |
75 | static GTY(()) tree ioparm_pad_len; | |
76 | static GTY(()) tree ioparm_format; | |
77 | static GTY(()) tree ioparm_format_len; | |
78 | static GTY(()) tree ioparm_advance; | |
79 | static GTY(()) tree ioparm_advance_len; | |
80 | static GTY(()) tree ioparm_name; | |
81 | static GTY(()) tree ioparm_name_len; | |
82 | static GTY(()) tree ioparm_internal_unit; | |
83 | static GTY(()) tree ioparm_internal_unit_len; | |
109b0ac2 | 84 | static GTY(()) tree ioparm_internal_unit_desc; |
6de9cd9a DN |
85 | static GTY(()) tree ioparm_sequential; |
86 | static GTY(()) tree ioparm_sequential_len; | |
87 | static GTY(()) tree ioparm_direct; | |
88 | static GTY(()) tree ioparm_direct_len; | |
89 | static GTY(()) tree ioparm_formatted; | |
90 | static GTY(()) tree ioparm_formatted_len; | |
91 | static GTY(()) tree ioparm_unformatted; | |
92 | static GTY(()) tree ioparm_unformatted_len; | |
93 | static GTY(()) tree ioparm_read; | |
94 | static GTY(()) tree ioparm_read_len; | |
95 | static GTY(()) tree ioparm_write; | |
96 | static GTY(()) tree ioparm_write_len; | |
97 | static GTY(()) tree ioparm_readwrite; | |
98 | static GTY(()) tree ioparm_readwrite_len; | |
99 | static GTY(()) tree ioparm_namelist_name; | |
100 | static GTY(()) tree ioparm_namelist_name_len; | |
101 | static GTY(()) tree ioparm_namelist_read_mode; | |
7aba8abe TK |
102 | static GTY(()) tree ioparm_iomsg; |
103 | static GTY(()) tree ioparm_iomsg_len; | |
6de9cd9a DN |
104 | |
105 | /* The global I/O variables */ | |
106 | ||
107 | static GTY(()) tree ioparm_var; | |
108 | static GTY(()) tree locus_file; | |
109 | static GTY(()) tree locus_line; | |
110 | ||
111 | ||
112 | /* Library I/O subroutines */ | |
113 | ||
114 | static GTY(()) tree iocall_read; | |
115 | static GTY(()) tree iocall_read_done; | |
116 | static GTY(()) tree iocall_write; | |
117 | static GTY(()) tree iocall_write_done; | |
118 | static GTY(()) tree iocall_x_integer; | |
119 | static GTY(()) tree iocall_x_logical; | |
120 | static GTY(()) tree iocall_x_character; | |
121 | static GTY(()) tree iocall_x_real; | |
122 | static GTY(()) tree iocall_x_complex; | |
123 | static GTY(()) tree iocall_open; | |
124 | static GTY(()) tree iocall_close; | |
125 | static GTY(()) tree iocall_inquire; | |
8750f9cd JB |
126 | static GTY(()) tree iocall_iolength; |
127 | static GTY(()) tree iocall_iolength_done; | |
6de9cd9a DN |
128 | static GTY(()) tree iocall_rewind; |
129 | static GTY(()) tree iocall_backspace; | |
130 | static GTY(()) tree iocall_endfile; | |
6403ec5f | 131 | static GTY(()) tree iocall_flush; |
29dc5138 PT |
132 | static GTY(()) tree iocall_set_nml_val; |
133 | static GTY(()) tree iocall_set_nml_val_dim; | |
6de9cd9a DN |
134 | |
135 | /* Variable for keeping track of what the last data transfer statement | |
136 | was. Used for deciding which subroutine to call when the data | |
f7b529fa | 137 | transfer is complete. */ |
8750f9cd | 138 | static enum { READ, WRITE, IOLENGTH } last_dt; |
6de9cd9a DN |
139 | |
140 | #define ADD_FIELD(name, type) \ | |
141 | ioparm_ ## name = gfc_add_field_to_struct \ | |
142 | (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ | |
143 | get_identifier (stringize(name)), type) | |
144 | ||
145 | #define ADD_STRING(name) \ | |
146 | ioparm_ ## name = gfc_add_field_to_struct \ | |
147 | (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ | |
148 | get_identifier (stringize(name)), pchar_type_node); \ | |
149 | ioparm_ ## name ## _len = gfc_add_field_to_struct \ | |
150 | (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ | |
b8d5e926 | 151 | get_identifier (stringize(name) "_len"), gfc_charlen_type_node) |
6de9cd9a DN |
152 | |
153 | ||
154 | /* Create function decls for IO library functions. */ | |
155 | ||
156 | void | |
157 | gfc_build_io_library_fndecls (void) | |
158 | { | |
e2cad04b RH |
159 | tree gfc_int4_type_node; |
160 | tree gfc_pint4_type_node; | |
6de9cd9a DN |
161 | tree ioparm_type; |
162 | ||
e2cad04b | 163 | gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
164 | gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); |
165 | ||
e2cad04b RH |
166 | /* Build the st_parameter structure. Information associated with I/O |
167 | calls are transferred here. This must match the one defined in the | |
f7b529fa | 168 | library exactly. */ |
6de9cd9a DN |
169 | |
170 | ioparm_type = make_node (RECORD_TYPE); | |
171 | TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm"); | |
172 | ||
173 | ADD_FIELD (unit, gfc_int4_type_node); | |
174 | ADD_FIELD (err, gfc_int4_type_node); | |
175 | ADD_FIELD (end, gfc_int4_type_node); | |
176 | ADD_FIELD (eor, gfc_int4_type_node); | |
177 | ADD_FIELD (list_format, gfc_int4_type_node); | |
178 | ADD_FIELD (library_return, gfc_int4_type_node); | |
179 | ||
180 | ADD_FIELD (iostat, gfc_pint4_type_node); | |
181 | ADD_FIELD (exist, gfc_pint4_type_node); | |
182 | ADD_FIELD (opened, gfc_pint4_type_node); | |
183 | ADD_FIELD (number, gfc_pint4_type_node); | |
184 | ADD_FIELD (named, gfc_pint4_type_node); | |
b8d5e926 | 185 | ADD_FIELD (rec, gfc_int4_type_node); |
6de9cd9a DN |
186 | ADD_FIELD (nextrec, gfc_pint4_type_node); |
187 | ADD_FIELD (size, gfc_pint4_type_node); | |
188 | ||
b8d5e926 | 189 | ADD_FIELD (recl_in, gfc_int4_type_node); |
6de9cd9a DN |
190 | ADD_FIELD (recl_out, gfc_pint4_type_node); |
191 | ||
8750f9cd JB |
192 | ADD_FIELD (iolength, gfc_pint4_type_node); |
193 | ||
6de9cd9a DN |
194 | ADD_STRING (file); |
195 | ADD_STRING (status); | |
196 | ||
197 | ADD_STRING (access); | |
198 | ADD_STRING (form); | |
199 | ADD_STRING (blank); | |
200 | ADD_STRING (position); | |
201 | ADD_STRING (action); | |
202 | ADD_STRING (delim); | |
203 | ADD_STRING (pad); | |
204 | ADD_STRING (format); | |
205 | ADD_STRING (advance); | |
206 | ADD_STRING (name); | |
207 | ADD_STRING (internal_unit); | |
109b0ac2 | 208 | ADD_FIELD (internal_unit_desc, pchar_type_node); |
6de9cd9a DN |
209 | ADD_STRING (sequential); |
210 | ||
211 | ADD_STRING (direct); | |
212 | ADD_STRING (formatted); | |
213 | ADD_STRING (unformatted); | |
214 | ADD_STRING (read); | |
215 | ADD_STRING (write); | |
216 | ADD_STRING (readwrite); | |
217 | ||
218 | ADD_STRING (namelist_name); | |
219 | ADD_FIELD (namelist_read_mode, gfc_int4_type_node); | |
7aba8abe | 220 | ADD_STRING (iomsg); |
6de9cd9a DN |
221 | |
222 | gfc_finish_type (ioparm_type); | |
223 | ||
224 | ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")), | |
225 | ioparm_type); | |
226 | DECL_EXTERNAL (ioparm_var) = 1; | |
227 | TREE_PUBLIC (ioparm_var) = 1; | |
228 | ||
229 | locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")), | |
230 | gfc_int4_type_node); | |
231 | DECL_EXTERNAL (locus_line) = 1; | |
232 | TREE_PUBLIC (locus_line) = 1; | |
233 | ||
234 | locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")), | |
235 | pchar_type_node); | |
236 | DECL_EXTERNAL (locus_file) = 1; | |
237 | TREE_PUBLIC (locus_file) = 1; | |
238 | ||
239 | /* Define the transfer functions. */ | |
240 | ||
241 | iocall_x_integer = | |
242 | gfc_build_library_function_decl (get_identifier | |
243 | (PREFIX("transfer_integer")), | |
244 | void_type_node, 2, pvoid_type_node, | |
245 | gfc_int4_type_node); | |
246 | ||
247 | iocall_x_logical = | |
248 | gfc_build_library_function_decl (get_identifier | |
249 | (PREFIX("transfer_logical")), | |
250 | void_type_node, 2, pvoid_type_node, | |
251 | gfc_int4_type_node); | |
252 | ||
253 | iocall_x_character = | |
254 | gfc_build_library_function_decl (get_identifier | |
255 | (PREFIX("transfer_character")), | |
256 | void_type_node, 2, pvoid_type_node, | |
257 | gfc_int4_type_node); | |
258 | ||
259 | iocall_x_real = | |
260 | gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")), | |
261 | void_type_node, 2, | |
262 | pvoid_type_node, gfc_int4_type_node); | |
263 | ||
264 | iocall_x_complex = | |
265 | gfc_build_library_function_decl (get_identifier | |
266 | (PREFIX("transfer_complex")), | |
267 | void_type_node, 2, pvoid_type_node, | |
268 | gfc_int4_type_node); | |
269 | ||
270 | /* Library entry points */ | |
271 | ||
272 | iocall_read = | |
273 | gfc_build_library_function_decl (get_identifier (PREFIX("st_read")), | |
274 | void_type_node, 0); | |
275 | ||
276 | iocall_write = | |
277 | gfc_build_library_function_decl (get_identifier (PREFIX("st_write")), | |
278 | void_type_node, 0); | |
279 | iocall_open = | |
280 | gfc_build_library_function_decl (get_identifier (PREFIX("st_open")), | |
281 | void_type_node, 0); | |
282 | ||
283 | iocall_close = | |
284 | gfc_build_library_function_decl (get_identifier (PREFIX("st_close")), | |
285 | void_type_node, 0); | |
286 | ||
287 | iocall_inquire = | |
288 | gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")), | |
289 | gfc_int4_type_node, 0); | |
290 | ||
8750f9cd JB |
291 | iocall_iolength = |
292 | gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")), | |
293 | void_type_node, 0); | |
294 | ||
6de9cd9a DN |
295 | iocall_rewind = |
296 | gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")), | |
297 | gfc_int4_type_node, 0); | |
298 | ||
299 | iocall_backspace = | |
300 | gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")), | |
301 | gfc_int4_type_node, 0); | |
302 | ||
303 | iocall_endfile = | |
304 | gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")), | |
305 | gfc_int4_type_node, 0); | |
6403ec5f JB |
306 | |
307 | iocall_flush = | |
308 | gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")), | |
309 | gfc_int4_type_node, 0); | |
310 | ||
6de9cd9a DN |
311 | /* Library helpers */ |
312 | ||
313 | iocall_read_done = | |
314 | gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")), | |
315 | gfc_int4_type_node, 0); | |
316 | ||
317 | iocall_write_done = | |
318 | gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")), | |
319 | gfc_int4_type_node, 0); | |
8750f9cd JB |
320 | |
321 | iocall_iolength_done = | |
322 | gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")), | |
323 | gfc_int4_type_node, 0); | |
324 | ||
6de9cd9a | 325 | |
29dc5138 PT |
326 | iocall_set_nml_val = |
327 | gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")), | |
3bc268e6 | 328 | void_type_node, 5, |
6de9cd9a | 329 | pvoid_type_node, pvoid_type_node, |
29dc5138 PT |
330 | gfc_int4_type_node, gfc_charlen_type_node, |
331 | gfc_int4_type_node); | |
6de9cd9a | 332 | |
29dc5138 PT |
333 | iocall_set_nml_val_dim = |
334 | gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")), | |
335 | void_type_node, 4, | |
336 | gfc_int4_type_node, gfc_int4_type_node, | |
337 | gfc_int4_type_node, gfc_int4_type_node); | |
6de9cd9a DN |
338 | } |
339 | ||
340 | ||
49de9e73 | 341 | /* Generate code to store a non-string I/O parameter into the |
6de9cd9a DN |
342 | ioparm structure. This is a pass by value. */ |
343 | ||
344 | static void | |
345 | set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e) | |
346 | { | |
347 | gfc_se se; | |
348 | tree tmp; | |
349 | ||
350 | gfc_init_se (&se, NULL); | |
351 | gfc_conv_expr_type (&se, e, TREE_TYPE (var)); | |
352 | gfc_add_block_to_block (block, &se.pre); | |
353 | ||
923ab88c | 354 | tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); |
6de9cd9a DN |
355 | gfc_add_modify_expr (block, tmp, se.expr); |
356 | } | |
357 | ||
358 | ||
49de9e73 | 359 | /* Generate code to store a non-string I/O parameter into the |
6de9cd9a DN |
360 | ioparm structure. This is pass by reference. */ |
361 | ||
362 | static void | |
363 | set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e) | |
364 | { | |
365 | gfc_se se; | |
366 | tree tmp; | |
367 | ||
368 | gfc_init_se (&se, NULL); | |
369 | se.want_pointer = 1; | |
370 | ||
371 | gfc_conv_expr_type (&se, e, TREE_TYPE (var)); | |
372 | gfc_add_block_to_block (block, &se.pre); | |
373 | ||
923ab88c | 374 | tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); |
6de9cd9a DN |
375 | gfc_add_modify_expr (block, tmp, se.expr); |
376 | } | |
377 | ||
d3642f89 FW |
378 | /* Given an array expr, find its address and length to get a string. If the |
379 | array is full, the string's address is the address of array's first element | |
380 | and the length is the size of the whole array. If it is an element, the | |
381 | string's address is the element's address and the length is the rest size of | |
382 | the array. | |
383 | */ | |
384 | ||
385 | static void | |
386 | gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) | |
387 | { | |
388 | tree tmp; | |
389 | tree array; | |
390 | tree type; | |
391 | tree size; | |
392 | int rank; | |
393 | gfc_symbol *sym; | |
394 | ||
395 | sym = e->symtree->n.sym; | |
396 | rank = sym->as->rank - 1; | |
397 | ||
398 | if (e->ref->u.ar.type == AR_FULL) | |
399 | { | |
400 | se->expr = gfc_get_symbol_decl (sym); | |
401 | se->expr = gfc_conv_array_data (se->expr); | |
402 | } | |
403 | else | |
404 | { | |
405 | gfc_conv_expr (se, e); | |
406 | } | |
407 | ||
408 | array = sym->backend_decl; | |
409 | type = TREE_TYPE (array); | |
410 | ||
411 | if (GFC_ARRAY_TYPE_P (type)) | |
412 | size = GFC_TYPE_ARRAY_SIZE (type); | |
413 | else | |
414 | { | |
415 | gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); | |
416 | size = gfc_conv_array_stride (array, rank); | |
417 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, | |
418 | gfc_conv_array_ubound (array, rank), | |
419 | gfc_conv_array_lbound (array, rank)); | |
420 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, | |
421 | gfc_index_one_node); | |
422 | size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size); | |
423 | } | |
424 | ||
425 | gcc_assert (size); | |
426 | ||
427 | /* If it is an element, we need the its address and size of the rest. */ | |
428 | if (e->ref->u.ar.type == AR_ELEMENT) | |
429 | { | |
430 | size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size, | |
431 | TREE_OPERAND (se->expr, 1)); | |
432 | se->expr = gfc_build_addr_expr (NULL, se->expr); | |
433 | } | |
434 | ||
435 | tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); | |
436 | size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); | |
437 | ||
438 | se->string_length = fold_convert (gfc_charlen_type_node, size); | |
439 | } | |
6de9cd9a | 440 | |
109b0ac2 | 441 | |
6de9cd9a DN |
442 | /* Generate code to store a string and its length into the |
443 | ioparm structure. */ | |
444 | ||
445 | static void | |
446 | set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, | |
447 | tree var_len, gfc_expr * e) | |
448 | { | |
449 | gfc_se se; | |
450 | tree tmp; | |
451 | tree msg; | |
452 | tree io; | |
453 | tree len; | |
454 | ||
455 | gfc_init_se (&se, NULL); | |
6de9cd9a | 456 | |
923ab88c TS |
457 | io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); |
458 | len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len, | |
459 | NULL_TREE); | |
6de9cd9a | 460 | |
7ab92584 | 461 | /* Integer variable assigned a format label. */ |
6de9cd9a DN |
462 | if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) |
463 | { | |
ce2df7c6 | 464 | gfc_conv_label_variable (&se, e); |
6de9cd9a | 465 | msg = |
95638988 | 466 | gfc_build_cstring_const ("Assigned label is not a format label"); |
6de9cd9a | 467 | tmp = GFC_DECL_STRING_LEN (se.expr); |
923ab88c TS |
468 | tmp = build2 (LE_EXPR, boolean_type_node, |
469 | tmp, convert (TREE_TYPE (tmp), integer_minus_one_node)); | |
6de9cd9a | 470 | gfc_trans_runtime_check (tmp, msg, &se.pre); |
b078dfbf FW |
471 | gfc_add_modify_expr (&se.pre, io, |
472 | fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); | |
6de9cd9a DN |
473 | gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); |
474 | } | |
475 | else | |
476 | { | |
d3642f89 FW |
477 | /* General character. */ |
478 | if (e->ts.type == BT_CHARACTER && e->rank == 0) | |
479 | gfc_conv_expr (&se, e); | |
480 | /* Array assigned Hollerith constant or character array. */ | |
481 | else if (e->symtree && (e->symtree->n.sym->as->rank > 0)) | |
482 | gfc_convert_array_to_string (&se, e); | |
483 | else | |
484 | gcc_unreachable (); | |
485 | ||
6de9cd9a | 486 | gfc_conv_string_parameter (&se); |
7ab92584 | 487 | gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); |
6de9cd9a DN |
488 | gfc_add_modify_expr (&se.pre, len, se.string_length); |
489 | } | |
490 | ||
491 | gfc_add_block_to_block (block, &se.pre); | |
492 | gfc_add_block_to_block (postblock, &se.post); | |
6de9cd9a DN |
493 | } |
494 | ||
495 | ||
109b0ac2 PT |
496 | /* Generate code to store the character (array) and the character length |
497 | for an internal unit. */ | |
498 | ||
499 | static void | |
500 | set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len, | |
501 | tree iunit_desc, gfc_expr * e) | |
502 | { | |
503 | gfc_se se; | |
504 | tree io; | |
505 | tree len; | |
506 | tree desc; | |
507 | tree tmp; | |
508 | ||
509 | gfc_init_se (&se, NULL); | |
510 | ||
511 | io = build3 (COMPONENT_REF, TREE_TYPE (iunit), ioparm_var, iunit, NULL_TREE); | |
512 | len = build3 (COMPONENT_REF, TREE_TYPE (iunit_len), ioparm_var, iunit_len, | |
513 | NULL_TREE); | |
514 | desc = build3 (COMPONENT_REF, TREE_TYPE (iunit_desc), ioparm_var, iunit_desc, | |
515 | NULL_TREE); | |
516 | ||
517 | gcc_assert (e->ts.type == BT_CHARACTER); | |
518 | ||
519 | /* Character scalars. */ | |
520 | if (e->rank == 0) | |
521 | { | |
522 | gfc_conv_expr (&se, e); | |
523 | gfc_conv_string_parameter (&se); | |
524 | tmp = se.expr; | |
525 | se.expr = fold_convert (pchar_type_node, integer_zero_node); | |
526 | } | |
527 | ||
528 | /* Character array. */ | |
529 | else if (e->symtree && (e->symtree->n.sym->as->rank > 0)) | |
530 | { | |
531 | se.ss = gfc_walk_expr (e); | |
532 | ||
533 | /* Return the data pointer and rank from the descriptor. */ | |
534 | gfc_conv_expr_descriptor (&se, e, se.ss); | |
535 | tmp = gfc_conv_descriptor_data_get (se.expr); | |
536 | se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); | |
537 | } | |
538 | else | |
539 | gcc_unreachable (); | |
540 | ||
541 | /* The cast is needed for character substrings and the descriptor | |
542 | data. */ | |
543 | gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); | |
544 | gfc_add_modify_expr (&se.pre, len, se.string_length); | |
545 | gfc_add_modify_expr (&se.pre, desc, se.expr); | |
546 | ||
547 | gfc_add_block_to_block (block, &se.pre); | |
548 | } | |
549 | ||
6de9cd9a DN |
550 | /* Set a member of the ioparm structure to one. */ |
551 | static void | |
552 | set_flag (stmtblock_t *block, tree var) | |
553 | { | |
7ab92584 | 554 | tree tmp, type = TREE_TYPE (var); |
6de9cd9a | 555 | |
923ab88c | 556 | tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE); |
7ab92584 | 557 | gfc_add_modify_expr (block, tmp, convert (type, integer_one_node)); |
6de9cd9a DN |
558 | } |
559 | ||
560 | ||
561 | /* Add a case to a IO-result switch. */ | |
562 | ||
563 | static void | |
564 | add_case (int label_value, gfc_st_label * label, stmtblock_t * body) | |
565 | { | |
566 | tree tmp, value; | |
567 | ||
568 | if (label == NULL) | |
569 | return; /* No label, no case */ | |
570 | ||
7d60be94 | 571 | value = build_int_cst (NULL_TREE, label_value); |
6de9cd9a DN |
572 | |
573 | /* Make a backend label for this case. */ | |
c006df4e | 574 | tmp = gfc_build_label_decl (NULL_TREE); |
6de9cd9a DN |
575 | |
576 | /* And the case itself. */ | |
923ab88c | 577 | tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp); |
6de9cd9a DN |
578 | gfc_add_expr_to_block (body, tmp); |
579 | ||
580 | /* Jump to the label. */ | |
581 | tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label)); | |
582 | gfc_add_expr_to_block (body, tmp); | |
583 | } | |
584 | ||
585 | ||
586 | /* Generate a switch statement that branches to the correct I/O | |
587 | result label. The last statement of an I/O call stores the | |
588 | result into a variable because there is often cleanup that | |
589 | must be done before the switch, so a temporary would have to | |
590 | be created anyway. */ | |
591 | ||
592 | static void | |
593 | io_result (stmtblock_t * block, gfc_st_label * err_label, | |
594 | gfc_st_label * end_label, gfc_st_label * eor_label) | |
595 | { | |
596 | stmtblock_t body; | |
597 | tree tmp, rc; | |
598 | ||
599 | /* If no labels are specified, ignore the result instead | |
600 | of building an empty switch. */ | |
601 | if (err_label == NULL | |
602 | && end_label == NULL | |
603 | && eor_label == NULL) | |
604 | return; | |
605 | ||
606 | /* Build a switch statement. */ | |
607 | gfc_start_block (&body); | |
608 | ||
609 | /* The label values here must be the same as the values | |
610 | in the library_return enum in the runtime library */ | |
611 | add_case (1, err_label, &body); | |
612 | add_case (2, end_label, &body); | |
613 | add_case (3, eor_label, &body); | |
614 | ||
615 | tmp = gfc_finish_block (&body); | |
616 | ||
923ab88c TS |
617 | rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var, |
618 | ioparm_library_return, NULL_TREE); | |
6de9cd9a | 619 | |
923ab88c | 620 | tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE); |
6de9cd9a DN |
621 | |
622 | gfc_add_expr_to_block (block, tmp); | |
623 | } | |
624 | ||
625 | ||
626 | /* Store the current file and line number to variables so that if a | |
627 | library call goes awry, we can tell the user where the problem is. */ | |
628 | ||
629 | static void | |
630 | set_error_locus (stmtblock_t * block, locus * where) | |
631 | { | |
632 | gfc_file *f; | |
633 | tree tmp; | |
634 | int line; | |
635 | ||
d4fa05b9 | 636 | f = where->lb->file; |
95638988 | 637 | tmp = gfc_build_cstring_const (f->filename); |
6de9cd9a DN |
638 | |
639 | tmp = gfc_build_addr_expr (pchar_type_node, tmp); | |
640 | gfc_add_modify_expr (block, locus_file, tmp); | |
641 | ||
c8cc8542 PB |
642 | #ifdef USE_MAPPED_LOCATION |
643 | line = LOCATION_LINE (where->lb->location); | |
644 | #else | |
d4fa05b9 | 645 | line = where->lb->linenum; |
c8cc8542 | 646 | #endif |
7d60be94 | 647 | gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line)); |
6de9cd9a DN |
648 | } |
649 | ||
650 | ||
651 | /* Translate an OPEN statement. */ | |
652 | ||
653 | tree | |
654 | gfc_trans_open (gfc_code * code) | |
655 | { | |
656 | stmtblock_t block, post_block; | |
657 | gfc_open *p; | |
658 | tree tmp; | |
659 | ||
660 | gfc_init_block (&block); | |
661 | gfc_init_block (&post_block); | |
662 | ||
663 | set_error_locus (&block, &code->loc); | |
664 | p = code->ext.open; | |
665 | ||
666 | if (p->unit) | |
667 | set_parameter_value (&block, ioparm_unit, p->unit); | |
668 | ||
669 | if (p->file) | |
670 | set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); | |
671 | ||
672 | if (p->status) | |
673 | set_string (&block, &post_block, ioparm_status, | |
674 | ioparm_status_len, p->status); | |
675 | ||
676 | if (p->access) | |
677 | set_string (&block, &post_block, ioparm_access, | |
678 | ioparm_access_len, p->access); | |
679 | ||
680 | if (p->form) | |
681 | set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form); | |
682 | ||
683 | if (p->recl) | |
684 | set_parameter_value (&block, ioparm_recl_in, p->recl); | |
685 | ||
686 | if (p->blank) | |
687 | set_string (&block, &post_block, ioparm_blank, ioparm_blank_len, | |
688 | p->blank); | |
689 | ||
690 | if (p->position) | |
691 | set_string (&block, &post_block, ioparm_position, | |
692 | ioparm_position_len, p->position); | |
693 | ||
694 | if (p->action) | |
695 | set_string (&block, &post_block, ioparm_action, | |
696 | ioparm_action_len, p->action); | |
697 | ||
698 | if (p->delim) | |
699 | set_string (&block, &post_block, ioparm_delim, ioparm_delim_len, | |
700 | p->delim); | |
701 | ||
702 | if (p->pad) | |
703 | set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad); | |
704 | ||
7aba8abe TK |
705 | if (p->iomsg) |
706 | set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, | |
707 | p->iomsg); | |
708 | ||
6de9cd9a DN |
709 | if (p->iostat) |
710 | set_parameter_ref (&block, ioparm_iostat, p->iostat); | |
711 | ||
712 | if (p->err) | |
713 | set_flag (&block, ioparm_err); | |
714 | ||
715 | tmp = gfc_build_function_call (iocall_open, NULL_TREE); | |
716 | gfc_add_expr_to_block (&block, tmp); | |
717 | ||
718 | gfc_add_block_to_block (&block, &post_block); | |
719 | ||
720 | io_result (&block, p->err, NULL, NULL); | |
721 | ||
722 | return gfc_finish_block (&block); | |
723 | } | |
724 | ||
725 | ||
726 | /* Translate a CLOSE statement. */ | |
727 | ||
728 | tree | |
729 | gfc_trans_close (gfc_code * code) | |
730 | { | |
731 | stmtblock_t block, post_block; | |
732 | gfc_close *p; | |
733 | tree tmp; | |
734 | ||
735 | gfc_init_block (&block); | |
736 | gfc_init_block (&post_block); | |
737 | ||
738 | set_error_locus (&block, &code->loc); | |
739 | p = code->ext.close; | |
740 | ||
741 | if (p->unit) | |
742 | set_parameter_value (&block, ioparm_unit, p->unit); | |
743 | ||
744 | if (p->status) | |
745 | set_string (&block, &post_block, ioparm_status, | |
746 | ioparm_status_len, p->status); | |
747 | ||
7aba8abe TK |
748 | if (p->iomsg) |
749 | set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, | |
750 | p->iomsg); | |
751 | ||
6de9cd9a DN |
752 | if (p->iostat) |
753 | set_parameter_ref (&block, ioparm_iostat, p->iostat); | |
754 | ||
755 | if (p->err) | |
756 | set_flag (&block, ioparm_err); | |
757 | ||
758 | tmp = gfc_build_function_call (iocall_close, NULL_TREE); | |
759 | gfc_add_expr_to_block (&block, tmp); | |
760 | ||
761 | gfc_add_block_to_block (&block, &post_block); | |
762 | ||
763 | io_result (&block, p->err, NULL, NULL); | |
764 | ||
765 | return gfc_finish_block (&block); | |
766 | } | |
767 | ||
768 | ||
769 | /* Common subroutine for building a file positioning statement. */ | |
770 | ||
771 | static tree | |
772 | build_filepos (tree function, gfc_code * code) | |
773 | { | |
7aba8abe | 774 | stmtblock_t block, post_block; |
6de9cd9a DN |
775 | gfc_filepos *p; |
776 | tree tmp; | |
777 | ||
778 | p = code->ext.filepos; | |
779 | ||
780 | gfc_init_block (&block); | |
7aba8abe | 781 | gfc_init_block (&post_block); |
6de9cd9a DN |
782 | |
783 | set_error_locus (&block, &code->loc); | |
784 | ||
785 | if (p->unit) | |
786 | set_parameter_value (&block, ioparm_unit, p->unit); | |
787 | ||
7aba8abe TK |
788 | if (p->iomsg) |
789 | set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, | |
790 | p->iomsg); | |
791 | ||
6de9cd9a DN |
792 | if (p->iostat) |
793 | set_parameter_ref (&block, ioparm_iostat, p->iostat); | |
794 | ||
795 | if (p->err) | |
796 | set_flag (&block, ioparm_err); | |
797 | ||
798 | tmp = gfc_build_function_call (function, NULL); | |
799 | gfc_add_expr_to_block (&block, tmp); | |
800 | ||
7aba8abe TK |
801 | gfc_add_block_to_block (&block, &post_block); |
802 | ||
6de9cd9a DN |
803 | io_result (&block, p->err, NULL, NULL); |
804 | ||
805 | return gfc_finish_block (&block); | |
806 | } | |
807 | ||
808 | ||
809 | /* Translate a BACKSPACE statement. */ | |
810 | ||
811 | tree | |
812 | gfc_trans_backspace (gfc_code * code) | |
813 | { | |
814 | ||
815 | return build_filepos (iocall_backspace, code); | |
816 | } | |
817 | ||
818 | ||
819 | /* Translate an ENDFILE statement. */ | |
820 | ||
821 | tree | |
822 | gfc_trans_endfile (gfc_code * code) | |
823 | { | |
824 | ||
825 | return build_filepos (iocall_endfile, code); | |
826 | } | |
827 | ||
828 | ||
829 | /* Translate a REWIND statement. */ | |
830 | ||
831 | tree | |
832 | gfc_trans_rewind (gfc_code * code) | |
833 | { | |
834 | ||
835 | return build_filepos (iocall_rewind, code); | |
836 | } | |
837 | ||
838 | ||
6403ec5f JB |
839 | /* Translate a FLUSH statement. */ |
840 | ||
841 | tree | |
842 | gfc_trans_flush (gfc_code * code) | |
843 | { | |
844 | ||
845 | return build_filepos (iocall_flush, code); | |
846 | } | |
847 | ||
848 | ||
6de9cd9a DN |
849 | /* Translate the non-IOLENGTH form of an INQUIRE statement. */ |
850 | ||
851 | tree | |
852 | gfc_trans_inquire (gfc_code * code) | |
853 | { | |
854 | stmtblock_t block, post_block; | |
855 | gfc_inquire *p; | |
856 | tree tmp; | |
857 | ||
858 | gfc_init_block (&block); | |
859 | gfc_init_block (&post_block); | |
860 | ||
861 | set_error_locus (&block, &code->loc); | |
862 | p = code->ext.inquire; | |
863 | ||
6403ec5f JB |
864 | /* Sanity check. */ |
865 | if (p->unit && p->file) | |
866 | gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc); | |
867 | ||
6de9cd9a DN |
868 | if (p->unit) |
869 | set_parameter_value (&block, ioparm_unit, p->unit); | |
870 | ||
871 | if (p->file) | |
872 | set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); | |
873 | ||
7aba8abe TK |
874 | if (p->iomsg) |
875 | set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, | |
876 | p->iomsg); | |
877 | ||
6de9cd9a DN |
878 | if (p->iostat) |
879 | set_parameter_ref (&block, ioparm_iostat, p->iostat); | |
880 | ||
881 | if (p->exist) | |
882 | set_parameter_ref (&block, ioparm_exist, p->exist); | |
883 | ||
884 | if (p->opened) | |
885 | set_parameter_ref (&block, ioparm_opened, p->opened); | |
886 | ||
887 | if (p->number) | |
888 | set_parameter_ref (&block, ioparm_number, p->number); | |
889 | ||
890 | if (p->named) | |
891 | set_parameter_ref (&block, ioparm_named, p->named); | |
892 | ||
893 | if (p->name) | |
894 | set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name); | |
895 | ||
896 | if (p->access) | |
897 | set_string (&block, &post_block, ioparm_access, | |
898 | ioparm_access_len, p->access); | |
899 | ||
900 | if (p->sequential) | |
901 | set_string (&block, &post_block, ioparm_sequential, | |
902 | ioparm_sequential_len, p->sequential); | |
903 | ||
904 | if (p->direct) | |
905 | set_string (&block, &post_block, ioparm_direct, | |
906 | ioparm_direct_len, p->direct); | |
907 | ||
908 | if (p->form) | |
909 | set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form); | |
910 | ||
911 | if (p->formatted) | |
912 | set_string (&block, &post_block, ioparm_formatted, | |
913 | ioparm_formatted_len, p->formatted); | |
914 | ||
915 | if (p->unformatted) | |
916 | set_string (&block, &post_block, ioparm_unformatted, | |
917 | ioparm_unformatted_len, p->unformatted); | |
918 | ||
919 | if (p->recl) | |
920 | set_parameter_ref (&block, ioparm_recl_out, p->recl); | |
921 | ||
922 | if (p->nextrec) | |
923 | set_parameter_ref (&block, ioparm_nextrec, p->nextrec); | |
924 | ||
925 | if (p->blank) | |
926 | set_string (&block, &post_block, ioparm_blank, ioparm_blank_len, | |
927 | p->blank); | |
928 | ||
929 | if (p->position) | |
930 | set_string (&block, &post_block, ioparm_position, | |
931 | ioparm_position_len, p->position); | |
932 | ||
933 | if (p->action) | |
934 | set_string (&block, &post_block, ioparm_action, | |
935 | ioparm_action_len, p->action); | |
936 | ||
937 | if (p->read) | |
938 | set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read); | |
939 | ||
940 | if (p->write) | |
941 | set_string (&block, &post_block, ioparm_write, | |
942 | ioparm_write_len, p->write); | |
943 | ||
944 | if (p->readwrite) | |
945 | set_string (&block, &post_block, ioparm_readwrite, | |
946 | ioparm_readwrite_len, p->readwrite); | |
947 | ||
948 | if (p->delim) | |
949 | set_string (&block, &post_block, ioparm_delim, ioparm_delim_len, | |
950 | p->delim); | |
951 | ||
dae24534 BD |
952 | if (p->pad) |
953 | set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, | |
954 | p->pad); | |
955 | ||
6de9cd9a DN |
956 | if (p->err) |
957 | set_flag (&block, ioparm_err); | |
958 | ||
959 | tmp = gfc_build_function_call (iocall_inquire, NULL); | |
960 | gfc_add_expr_to_block (&block, tmp); | |
961 | ||
962 | gfc_add_block_to_block (&block, &post_block); | |
963 | ||
964 | io_result (&block, p->err, NULL, NULL); | |
965 | ||
966 | return gfc_finish_block (&block); | |
967 | } | |
968 | ||
6de9cd9a | 969 | static gfc_expr * |
cb9e4f55 | 970 | gfc_new_nml_name_expr (const char * name) |
6de9cd9a DN |
971 | { |
972 | gfc_expr * nml_name; | |
29dc5138 | 973 | |
6de9cd9a DN |
974 | nml_name = gfc_get_expr(); |
975 | nml_name->ref = NULL; | |
976 | nml_name->expr_type = EXPR_CONSTANT; | |
9d64df18 | 977 | nml_name->ts.kind = gfc_default_character_kind; |
6de9cd9a DN |
978 | nml_name->ts.type = BT_CHARACTER; |
979 | nml_name->value.character.length = strlen(name); | |
cb9e4f55 TS |
980 | nml_name->value.character.string = gfc_getmem (strlen (name) + 1); |
981 | strcpy (nml_name->value.character.string, name); | |
6de9cd9a DN |
982 | |
983 | return nml_name; | |
984 | } | |
985 | ||
29dc5138 PT |
986 | /* nml_full_name builds up the fully qualified name of a |
987 | derived type component. */ | |
988 | ||
989 | static char* | |
990 | nml_full_name (const char* var_name, const char* cmp_name) | |
6de9cd9a | 991 | { |
29dc5138 PT |
992 | int full_name_length; |
993 | char * full_name; | |
994 | ||
995 | full_name_length = strlen (var_name) + strlen (cmp_name) + 1; | |
996 | full_name = (char*)gfc_getmem (full_name_length + 1); | |
997 | strcpy (full_name, var_name); | |
998 | full_name = strcat (full_name, "%"); | |
999 | full_name = strcat (full_name, cmp_name); | |
1000 | return full_name; | |
6de9cd9a DN |
1001 | } |
1002 | ||
29dc5138 PT |
1003 | /* nml_get_addr_expr builds an address expression from the |
1004 | gfc_symbol or gfc_component backend_decl's. An offset is | |
1005 | provided so that the address of an element of an array of | |
1006 | derived types is returned. This is used in the runtime to | |
1007 | determine that span of the derived type. */ | |
1008 | ||
1009 | static tree | |
1010 | nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, | |
1011 | tree base_addr) | |
1012 | { | |
1013 | tree decl = NULL_TREE; | |
1014 | tree tmp; | |
1015 | tree itmp; | |
1016 | int array_flagged; | |
1017 | int dummy_arg_flagged; | |
1018 | ||
1019 | if (sym) | |
1020 | { | |
1021 | sym->attr.referenced = 1; | |
1022 | decl = gfc_get_symbol_decl (sym); | |
1023 | } | |
1024 | else | |
1025 | decl = c->backend_decl; | |
1026 | ||
1027 | gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL | |
1028 | || TREE_CODE (decl) == VAR_DECL | |
1029 | || TREE_CODE (decl) == PARM_DECL) | |
1030 | || TREE_CODE (decl) == COMPONENT_REF)); | |
1031 | ||
1032 | tmp = decl; | |
1033 | ||
1034 | /* Build indirect reference, if dummy argument. */ | |
1035 | ||
1036 | dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp)); | |
1037 | ||
1038 | itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp; | |
1039 | ||
1040 | /* If an array, set flag and use indirect ref. if built. */ | |
1041 | ||
1042 | array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE | |
1043 | && !TYPE_STRING_FLAG (TREE_TYPE (itmp))); | |
1044 | ||
1045 | if (array_flagged) | |
1046 | tmp = itmp; | |
1047 | ||
1048 | /* Treat the component of a derived type, using base_addr for | |
1049 | the derived type. */ | |
1050 | ||
1051 | if (TREE_CODE (decl) == FIELD_DECL) | |
1052 | tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp), | |
1053 | base_addr, tmp, NULL_TREE); | |
1054 | ||
1055 | /* If we have a derived type component, a reference to the first | |
1056 | element of the array is built. This is done so that base_addr, | |
1057 | used in the build of the component reference, always points to | |
1058 | a RECORD_TYPE. */ | |
1059 | ||
1060 | if (array_flagged) | |
1061 | tmp = gfc_build_array_ref (tmp, gfc_index_zero_node); | |
1062 | ||
1063 | /* Now build the address expression. */ | |
1064 | ||
1065 | tmp = gfc_build_addr_expr (NULL, tmp); | |
1066 | ||
1067 | /* If scalar dummy, resolve indirect reference now. */ | |
1068 | ||
1069 | if (dummy_arg_flagged && !array_flagged) | |
1070 | tmp = gfc_build_indirect_ref (tmp); | |
1071 | ||
1072 | gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); | |
1073 | ||
1074 | return tmp; | |
1075 | } | |
3bc268e6 | 1076 | |
29dc5138 PT |
1077 | /* For an object VAR_NAME whose base address is BASE_ADDR, generate a |
1078 | call to iocall_set_nml_val. For derived type variable, recursively | |
1079 | generate calls to iocall_set_nml_val for each component. */ | |
3bc268e6 | 1080 | |
29dc5138 PT |
1081 | #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a) |
1082 | #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a) | |
1083 | #define IARG(i) build_int_cst (gfc_array_index_type, i) | |
3bc268e6 VL |
1084 | |
1085 | static void | |
29dc5138 PT |
1086 | transfer_namelist_element (stmtblock_t * block, const char * var_name, |
1087 | gfc_symbol * sym, gfc_component * c, | |
1088 | tree base_addr) | |
3bc268e6 | 1089 | { |
29dc5138 PT |
1090 | gfc_typespec * ts = NULL; |
1091 | gfc_array_spec * as = NULL; | |
1092 | tree addr_expr = NULL; | |
1093 | tree dt = NULL; | |
1094 | tree string; | |
1095 | tree tmp; | |
1096 | tree args; | |
1097 | tree dtype; | |
1098 | int n_dim; | |
1099 | int itype; | |
1100 | int rank = 0; | |
3bc268e6 | 1101 | |
29dc5138 | 1102 | gcc_assert (sym || c); |
3bc268e6 | 1103 | |
29dc5138 PT |
1104 | /* Build the namelist object name. */ |
1105 | ||
1106 | string = gfc_build_cstring_const (var_name); | |
1107 | string = gfc_build_addr_expr (pchar_type_node, string); | |
1108 | ||
1109 | /* Build ts, as and data address using symbol or component. */ | |
1110 | ||
1111 | ts = (sym) ? &sym->ts : &c->ts; | |
1112 | as = (sym) ? sym->as : c->as; | |
1113 | ||
1114 | addr_expr = nml_get_addr_expr (sym, c, base_addr); | |
1115 | ||
1116 | if (as) | |
1117 | rank = as->rank; | |
1118 | ||
1119 | if (rank) | |
3bc268e6 | 1120 | { |
29dc5138 PT |
1121 | dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl); |
1122 | dtype = gfc_get_dtype (dt); | |
3bc268e6 | 1123 | } |
29dc5138 PT |
1124 | else |
1125 | { | |
1126 | itype = GFC_DTYPE_UNKNOWN; | |
3bc268e6 | 1127 | |
29dc5138 | 1128 | switch (ts->type) |
3bc268e6 | 1129 | |
29dc5138 PT |
1130 | { |
1131 | case BT_INTEGER: | |
1132 | itype = GFC_DTYPE_INTEGER; | |
1133 | break; | |
1134 | case BT_LOGICAL: | |
1135 | itype = GFC_DTYPE_LOGICAL; | |
1136 | break; | |
1137 | case BT_REAL: | |
1138 | itype = GFC_DTYPE_REAL; | |
1139 | break; | |
1140 | case BT_COMPLEX: | |
1141 | itype = GFC_DTYPE_COMPLEX; | |
1142 | break; | |
1143 | case BT_DERIVED: | |
1144 | itype = GFC_DTYPE_DERIVED; | |
1145 | break; | |
1146 | case BT_CHARACTER: | |
1147 | itype = GFC_DTYPE_CHARACTER; | |
1148 | break; | |
1149 | default: | |
1150 | gcc_unreachable (); | |
1151 | } | |
1152 | ||
1153 | dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT); | |
3bc268e6 VL |
1154 | } |
1155 | ||
29dc5138 PT |
1156 | /* Build up the arguments for the transfer call. |
1157 | The call for the scalar part transfers: | |
1158 | (address, name, type, kind or string_length, dtype) */ | |
1159 | ||
1160 | NML_FIRST_ARG (addr_expr); | |
1161 | NML_ADD_ARG (string); | |
1162 | NML_ADD_ARG (IARG (ts->kind)); | |
1163 | ||
1164 | if (ts->type == BT_CHARACTER) | |
1165 | NML_ADD_ARG (ts->cl->backend_decl); | |
1166 | else | |
1167 | NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node)); | |
1168 | ||
1169 | NML_ADD_ARG (dtype); | |
1170 | tmp = gfc_build_function_call (iocall_set_nml_val, args); | |
3bc268e6 | 1171 | gfc_add_expr_to_block (block, tmp); |
29dc5138 PT |
1172 | |
1173 | /* If the object is an array, transfer rank times: | |
1174 | (null pointer, name, stride, lbound, ubound) */ | |
1175 | ||
1176 | for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) | |
1177 | { | |
1178 | NML_FIRST_ARG (IARG (n_dim)); | |
1179 | NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim)); | |
1180 | NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim)); | |
1181 | NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim)); | |
1182 | tmp = gfc_build_function_call (iocall_set_nml_val_dim, args); | |
1183 | gfc_add_expr_to_block (block, tmp); | |
1184 | } | |
1185 | ||
1186 | if (ts->type == BT_DERIVED) | |
1187 | { | |
1188 | gfc_component *cmp; | |
1189 | ||
1190 | /* Provide the RECORD_TYPE to build component references. */ | |
1191 | ||
1192 | tree expr = gfc_build_indirect_ref (addr_expr); | |
1193 | ||
1194 | for (cmp = ts->derived->components; cmp; cmp = cmp->next) | |
1195 | { | |
1196 | char *full_name = nml_full_name (var_name, cmp->name); | |
1197 | transfer_namelist_element (block, | |
1198 | full_name, | |
1199 | NULL, cmp, expr); | |
1200 | gfc_free (full_name); | |
1201 | } | |
1202 | } | |
3bc268e6 | 1203 | } |
6de9cd9a | 1204 | |
29dc5138 PT |
1205 | #undef IARG |
1206 | #undef NML_ADD_ARG | |
1207 | #undef NML_FIRST_ARG | |
1208 | ||
6de9cd9a DN |
1209 | /* Create a data transfer statement. Not all of the fields are valid |
1210 | for both reading and writing, but improper use has been filtered | |
1211 | out by now. */ | |
1212 | ||
1213 | static tree | |
1214 | build_dt (tree * function, gfc_code * code) | |
1215 | { | |
1216 | stmtblock_t block, post_block; | |
1217 | gfc_dt *dt; | |
3bc268e6 | 1218 | tree tmp; |
29dc5138 | 1219 | gfc_expr *nmlname; |
3bc268e6 | 1220 | gfc_namelist *nml; |
6de9cd9a DN |
1221 | |
1222 | gfc_init_block (&block); | |
1223 | gfc_init_block (&post_block); | |
1224 | ||
1225 | set_error_locus (&block, &code->loc); | |
1226 | dt = code->ext.dt; | |
1227 | ||
6e45f57b | 1228 | gcc_assert (dt != NULL); |
8750f9cd | 1229 | |
6de9cd9a DN |
1230 | if (dt->io_unit) |
1231 | { | |
1232 | if (dt->io_unit->ts.type == BT_CHARACTER) | |
1233 | { | |
109b0ac2 PT |
1234 | set_internal_unit (&block, |
1235 | ioparm_internal_unit, | |
1236 | ioparm_internal_unit_len, | |
1237 | ioparm_internal_unit_desc, | |
1238 | dt->io_unit); | |
6de9cd9a DN |
1239 | } |
1240 | else | |
1241 | set_parameter_value (&block, ioparm_unit, dt->io_unit); | |
1242 | } | |
1243 | ||
1244 | if (dt->rec) | |
1245 | set_parameter_value (&block, ioparm_rec, dt->rec); | |
1246 | ||
1247 | if (dt->advance) | |
1248 | set_string (&block, &post_block, ioparm_advance, ioparm_advance_len, | |
1249 | dt->advance); | |
1250 | ||
1251 | if (dt->format_expr) | |
1252 | set_string (&block, &post_block, ioparm_format, ioparm_format_len, | |
1253 | dt->format_expr); | |
1254 | ||
1255 | if (dt->format_label) | |
1256 | { | |
1257 | if (dt->format_label == &format_asterisk) | |
1258 | set_flag (&block, ioparm_list_format); | |
1259 | else | |
1260 | set_string (&block, &post_block, ioparm_format, | |
1261 | ioparm_format_len, dt->format_label->format); | |
1262 | } | |
1263 | ||
7aba8abe TK |
1264 | if (dt->iomsg) |
1265 | set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, | |
1266 | dt->iomsg); | |
1267 | ||
6de9cd9a DN |
1268 | if (dt->iostat) |
1269 | set_parameter_ref (&block, ioparm_iostat, dt->iostat); | |
1270 | ||
1271 | if (dt->size) | |
1272 | set_parameter_ref (&block, ioparm_size, dt->size); | |
1273 | ||
1274 | if (dt->err) | |
1275 | set_flag (&block, ioparm_err); | |
1276 | ||
1277 | if (dt->eor) | |
1278 | set_flag(&block, ioparm_eor); | |
1279 | ||
1280 | if (dt->end) | |
1281 | set_flag(&block, ioparm_end); | |
1282 | ||
1283 | if (dt->namelist) | |
1284 | { | |
29dc5138 PT |
1285 | if (dt->format_expr || dt->format_label) |
1286 | gfc_internal_error ("build_dt: format with namelist"); | |
1287 | ||
1288 | nmlname = gfc_new_nml_name_expr(dt->namelist->name); | |
1289 | ||
1290 | set_string (&block, &post_block, ioparm_namelist_name, | |
1291 | ioparm_namelist_name_len, nmlname); | |
1292 | ||
1293 | if (last_dt == READ) | |
1294 | set_flag (&block, ioparm_namelist_read_mode); | |
1295 | ||
1296 | for (nml = dt->namelist->namelist; nml; nml = nml->next) | |
1297 | transfer_namelist_element (&block, nml->sym->name, nml->sym, | |
1298 | NULL, NULL); | |
6de9cd9a DN |
1299 | } |
1300 | ||
1301 | tmp = gfc_build_function_call (*function, NULL_TREE); | |
1302 | gfc_add_expr_to_block (&block, tmp); | |
1303 | ||
1304 | gfc_add_block_to_block (&block, &post_block); | |
1305 | ||
1306 | return gfc_finish_block (&block); | |
1307 | } | |
1308 | ||
1309 | ||
8750f9cd JB |
1310 | /* Translate the IOLENGTH form of an INQUIRE statement. We treat |
1311 | this as a third sort of data transfer statement, except that | |
e7dc5b4f | 1312 | lengths are summed instead of actually transferring any data. */ |
8750f9cd JB |
1313 | |
1314 | tree | |
1315 | gfc_trans_iolength (gfc_code * code) | |
1316 | { | |
1317 | stmtblock_t block; | |
1318 | gfc_inquire *inq; | |
1319 | tree dt; | |
1320 | ||
1321 | gfc_init_block (&block); | |
1322 | ||
1323 | set_error_locus (&block, &code->loc); | |
1324 | ||
1325 | inq = code->ext.inquire; | |
1326 | ||
1327 | /* First check that preconditions are met. */ | |
6e45f57b PB |
1328 | gcc_assert (inq != NULL); |
1329 | gcc_assert (inq->iolength != NULL); | |
8750f9cd JB |
1330 | |
1331 | /* Connect to the iolength variable. */ | |
1332 | if (inq->iolength) | |
1333 | set_parameter_ref (&block, ioparm_iolength, inq->iolength); | |
1334 | ||
1335 | /* Actual logic. */ | |
1336 | last_dt = IOLENGTH; | |
1337 | dt = build_dt(&iocall_iolength, code); | |
1338 | ||
1339 | gfc_add_expr_to_block (&block, dt); | |
1340 | ||
1341 | return gfc_finish_block (&block); | |
1342 | } | |
1343 | ||
1344 | ||
6de9cd9a DN |
1345 | /* Translate a READ statement. */ |
1346 | ||
1347 | tree | |
1348 | gfc_trans_read (gfc_code * code) | |
1349 | { | |
1350 | ||
1351 | last_dt = READ; | |
1352 | return build_dt (&iocall_read, code); | |
1353 | } | |
1354 | ||
1355 | ||
1356 | /* Translate a WRITE statement */ | |
1357 | ||
1358 | tree | |
1359 | gfc_trans_write (gfc_code * code) | |
1360 | { | |
1361 | ||
1362 | last_dt = WRITE; | |
1363 | return build_dt (&iocall_write, code); | |
1364 | } | |
1365 | ||
1366 | ||
1367 | /* Finish a data transfer statement. */ | |
1368 | ||
1369 | tree | |
1370 | gfc_trans_dt_end (gfc_code * code) | |
1371 | { | |
1372 | tree function, tmp; | |
1373 | stmtblock_t block; | |
1374 | ||
1375 | gfc_init_block (&block); | |
1376 | ||
8750f9cd JB |
1377 | switch (last_dt) |
1378 | { | |
1379 | case READ: | |
1380 | function = iocall_read_done; | |
1381 | break; | |
1382 | ||
1383 | case WRITE: | |
1384 | function = iocall_write_done; | |
1385 | break; | |
1386 | ||
1387 | case IOLENGTH: | |
1388 | function = iocall_iolength_done; | |
1389 | break; | |
1390 | ||
1391 | default: | |
6e45f57b | 1392 | gcc_unreachable (); |
8750f9cd | 1393 | } |
6de9cd9a DN |
1394 | |
1395 | tmp = gfc_build_function_call (function, NULL); | |
1396 | gfc_add_expr_to_block (&block, tmp); | |
1397 | ||
8750f9cd JB |
1398 | if (last_dt != IOLENGTH) |
1399 | { | |
6e45f57b | 1400 | gcc_assert (code->ext.dt != NULL); |
8750f9cd JB |
1401 | io_result (&block, code->ext.dt->err, |
1402 | code->ext.dt->end, code->ext.dt->eor); | |
1403 | } | |
6de9cd9a DN |
1404 | |
1405 | return gfc_finish_block (&block); | |
1406 | } | |
1407 | ||
d2ccf6aa VL |
1408 | static void |
1409 | transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr); | |
1410 | ||
1411 | /* Given an array field in a derived type variable, generate the code | |
1412 | for the loop that iterates over array elements, and the code that | |
1413 | accesses those array elements. Use transfer_expr to generate code | |
1414 | for transferring that element. Because elements may also be | |
1415 | derived types, transfer_expr and transfer_array_component are mutually | |
1416 | recursive. */ | |
1417 | ||
1418 | static tree | |
1419 | transfer_array_component (tree expr, gfc_component * cm) | |
1420 | { | |
1421 | tree tmp; | |
1422 | stmtblock_t body; | |
1423 | stmtblock_t block; | |
1424 | gfc_loopinfo loop; | |
1425 | int n; | |
1426 | gfc_ss *ss; | |
1427 | gfc_se se; | |
1428 | ||
1429 | gfc_start_block (&block); | |
1430 | gfc_init_se (&se, NULL); | |
1431 | ||
1432 | /* Create and initialize Scalarization Status. Unlike in | |
1433 | gfc_trans_transfer, we can't simply use gfc_walk_expr to take | |
1434 | care of this task, because we don't have a gfc_expr at hand. | |
1435 | Build one manually, as in gfc_trans_subarray_assign. */ | |
1436 | ||
1437 | ss = gfc_get_ss (); | |
1438 | ss->type = GFC_SS_COMPONENT; | |
1439 | ss->expr = NULL; | |
1440 | ss->shape = gfc_get_shape (cm->as->rank); | |
1441 | ss->next = gfc_ss_terminator; | |
1442 | ss->data.info.dimen = cm->as->rank; | |
1443 | ss->data.info.descriptor = expr; | |
1444 | ss->data.info.data = gfc_conv_array_data (expr); | |
1445 | ss->data.info.offset = gfc_conv_array_offset (expr); | |
1446 | for (n = 0; n < cm->as->rank; n++) | |
1447 | { | |
1448 | ss->data.info.dim[n] = n; | |
1449 | ss->data.info.start[n] = gfc_conv_array_lbound (expr, n); | |
1450 | ss->data.info.stride[n] = gfc_index_one_node; | |
1451 | ||
1452 | mpz_init (ss->shape[n]); | |
1453 | mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer, | |
1454 | cm->as->lower[n]->value.integer); | |
1455 | mpz_add_ui (ss->shape[n], ss->shape[n], 1); | |
1456 | } | |
1457 | ||
f7b529fa | 1458 | /* Once we got ss, we use scalarizer to create the loop. */ |
d2ccf6aa VL |
1459 | |
1460 | gfc_init_loopinfo (&loop); | |
1461 | gfc_add_ss_to_loop (&loop, ss); | |
1462 | gfc_conv_ss_startstride (&loop); | |
1463 | gfc_conv_loop_setup (&loop); | |
1464 | gfc_mark_ss_chain_used (ss, 1); | |
1465 | gfc_start_scalarized_body (&loop, &body); | |
1466 | ||
1467 | gfc_copy_loopinfo_to_se (&se, &loop); | |
1468 | se.ss = ss; | |
1469 | ||
1470 | /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */ | |
1471 | se.expr = expr; | |
1472 | gfc_conv_tmp_array_ref (&se); | |
1473 | ||
1474 | /* Now se.expr contains an element of the array. Take the address and pass | |
1475 | it to the IO routines. */ | |
1476 | tmp = gfc_build_addr_expr (NULL, se.expr); | |
1477 | transfer_expr (&se, &cm->ts, tmp); | |
1478 | ||
1479 | /* We are done now with the loop body. Wrap up the scalarizer and | |
f7b529fa | 1480 | return. */ |
d2ccf6aa VL |
1481 | |
1482 | gfc_add_block_to_block (&body, &se.pre); | |
1483 | gfc_add_block_to_block (&body, &se.post); | |
1484 | ||
1485 | gfc_trans_scalarizing_loops (&loop, &body); | |
1486 | ||
1487 | gfc_add_block_to_block (&block, &loop.pre); | |
1488 | gfc_add_block_to_block (&block, &loop.post); | |
1489 | ||
d2ccf6aa VL |
1490 | for (n = 0; n < cm->as->rank; n++) |
1491 | mpz_clear (ss->shape[n]); | |
1492 | gfc_free (ss->shape); | |
1493 | ||
96654664 PB |
1494 | gfc_cleanup_loop (&loop); |
1495 | ||
d2ccf6aa VL |
1496 | return gfc_finish_block (&block); |
1497 | } | |
6de9cd9a DN |
1498 | |
1499 | /* Generate the call for a scalar transfer node. */ | |
1500 | ||
1501 | static void | |
1502 | transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) | |
1503 | { | |
1504 | tree args, tmp, function, arg2, field, expr; | |
1505 | gfc_component *c; | |
1506 | int kind; | |
1507 | ||
1508 | kind = ts->kind; | |
1509 | function = NULL; | |
1510 | arg2 = NULL; | |
1511 | ||
1512 | switch (ts->type) | |
1513 | { | |
1514 | case BT_INTEGER: | |
7d60be94 | 1515 | arg2 = build_int_cst (NULL_TREE, kind); |
6de9cd9a DN |
1516 | function = iocall_x_integer; |
1517 | break; | |
1518 | ||
1519 | case BT_REAL: | |
7d60be94 | 1520 | arg2 = build_int_cst (NULL_TREE, kind); |
6de9cd9a DN |
1521 | function = iocall_x_real; |
1522 | break; | |
1523 | ||
1524 | case BT_COMPLEX: | |
7d60be94 | 1525 | arg2 = build_int_cst (NULL_TREE, kind); |
6de9cd9a DN |
1526 | function = iocall_x_complex; |
1527 | break; | |
1528 | ||
1529 | case BT_LOGICAL: | |
7d60be94 | 1530 | arg2 = build_int_cst (NULL_TREE, kind); |
6de9cd9a DN |
1531 | function = iocall_x_logical; |
1532 | break; | |
1533 | ||
1534 | case BT_CHARACTER: | |
d2ccf6aa VL |
1535 | if (se->string_length) |
1536 | arg2 = se->string_length; | |
1537 | else | |
1538 | { | |
1539 | tmp = gfc_build_indirect_ref (addr_expr); | |
1540 | gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); | |
1541 | arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); | |
1542 | } | |
6de9cd9a DN |
1543 | function = iocall_x_character; |
1544 | break; | |
1545 | ||
1546 | case BT_DERIVED: | |
d2ccf6aa | 1547 | /* Recurse into the elements of the derived type. */ |
6de9cd9a DN |
1548 | expr = gfc_evaluate_now (addr_expr, &se->pre); |
1549 | expr = gfc_build_indirect_ref (expr); | |
1550 | ||
1551 | for (c = ts->derived->components; c; c = c->next) | |
1552 | { | |
1553 | field = c->backend_decl; | |
6e45f57b | 1554 | gcc_assert (field && TREE_CODE (field) == FIELD_DECL); |
6de9cd9a | 1555 | |
923ab88c TS |
1556 | tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field, |
1557 | NULL_TREE); | |
6de9cd9a | 1558 | |
d2ccf6aa VL |
1559 | if (c->dimension) |
1560 | { | |
1561 | tmp = transfer_array_component (tmp, c); | |
1562 | gfc_add_expr_to_block (&se->pre, tmp); | |
1563 | } | |
1564 | else | |
1565 | { | |
1566 | if (!c->pointer) | |
1567 | tmp = gfc_build_addr_expr (NULL, tmp); | |
1568 | transfer_expr (se, &c->ts, tmp); | |
1569 | } | |
6de9cd9a DN |
1570 | } |
1571 | return; | |
1572 | ||
1573 | default: | |
1574 | internal_error ("Bad IO basetype (%d)", ts->type); | |
1575 | } | |
1576 | ||
1577 | args = gfc_chainon_list (NULL_TREE, addr_expr); | |
1578 | args = gfc_chainon_list (args, arg2); | |
1579 | ||
1580 | tmp = gfc_build_function_call (function, args); | |
1581 | gfc_add_expr_to_block (&se->pre, tmp); | |
1582 | gfc_add_block_to_block (&se->pre, &se->post); | |
8750f9cd | 1583 | |
6de9cd9a DN |
1584 | } |
1585 | ||
1586 | ||
1587 | /* gfc_trans_transfer()-- Translate a TRANSFER code node */ | |
1588 | ||
1589 | tree | |
1590 | gfc_trans_transfer (gfc_code * code) | |
1591 | { | |
1592 | stmtblock_t block, body; | |
1593 | gfc_loopinfo loop; | |
1594 | gfc_expr *expr; | |
1595 | gfc_ss *ss; | |
1596 | gfc_se se; | |
1597 | tree tmp; | |
1598 | ||
1599 | gfc_start_block (&block); | |
1600 | ||
1601 | expr = code->expr; | |
1602 | ss = gfc_walk_expr (expr); | |
1603 | ||
1604 | gfc_init_se (&se, NULL); | |
1605 | ||
1606 | if (ss == gfc_ss_terminator) | |
1607 | gfc_init_block (&body); | |
1608 | else | |
1609 | { | |
1610 | /* Initialize the scalarizer. */ | |
1611 | gfc_init_loopinfo (&loop); | |
1612 | gfc_add_ss_to_loop (&loop, ss); | |
1613 | ||
1614 | /* Initialize the loop. */ | |
1615 | gfc_conv_ss_startstride (&loop); | |
1616 | gfc_conv_loop_setup (&loop); | |
1617 | ||
1618 | /* The main loop body. */ | |
1619 | gfc_mark_ss_chain_used (ss, 1); | |
1620 | gfc_start_scalarized_body (&loop, &body); | |
1621 | ||
1622 | gfc_copy_loopinfo_to_se (&se, &loop); | |
1623 | se.ss = ss; | |
1624 | } | |
1625 | ||
1626 | gfc_conv_expr_reference (&se, expr); | |
1627 | ||
1628 | transfer_expr (&se, &expr->ts, se.expr); | |
1629 | ||
1630 | gfc_add_block_to_block (&body, &se.pre); | |
1631 | gfc_add_block_to_block (&body, &se.post); | |
1632 | ||
1633 | if (se.ss == NULL) | |
1634 | tmp = gfc_finish_block (&body); | |
1635 | else | |
1636 | { | |
6e45f57b | 1637 | gcc_assert (se.ss == gfc_ss_terminator); |
6de9cd9a DN |
1638 | gfc_trans_scalarizing_loops (&loop, &body); |
1639 | ||
1640 | gfc_add_block_to_block (&loop.pre, &loop.post); | |
1641 | tmp = gfc_finish_block (&loop.pre); | |
1642 | gfc_cleanup_loop (&loop); | |
1643 | } | |
1644 | ||
1645 | gfc_add_expr_to_block (&block, tmp); | |
1646 | ||
d2ccf6aa | 1647 | return gfc_finish_block (&block); |
6de9cd9a DN |
1648 | } |
1649 | ||
1650 | #include "gt-fortran-trans-io.h" | |
1651 |