|
111
|
1 /* Backend support for Fortran 95 basic types and derived types.
|
|
145
|
2 Copyright (C) 2002-2020 Free Software Foundation, Inc.
|
|
111
|
3 Contributed by Paul Brook <paul@nowt.org>
|
|
|
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
|
|
5
|
|
|
6 This file is part of GCC.
|
|
|
7
|
|
|
8 GCC is free software; you can redistribute it and/or modify it under
|
|
|
9 the terms of the GNU General Public License as published by the Free
|
|
|
10 Software Foundation; either version 3, or (at your option) any later
|
|
|
11 version.
|
|
|
12
|
|
|
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
|
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
16 for more details.
|
|
|
17
|
|
|
18 You should have received a copy of the GNU General Public License
|
|
|
19 along with GCC; see the file COPYING3. If not see
|
|
|
20 <http://www.gnu.org/licenses/>. */
|
|
|
21
|
|
|
22 /* trans-types.c -- gfortran backend types */
|
|
|
23
|
|
|
24 #include "config.h"
|
|
|
25 #include "system.h"
|
|
|
26 #include "coretypes.h"
|
|
|
27 #include "target.h"
|
|
|
28 #include "tree.h"
|
|
|
29 #include "gfortran.h"
|
|
|
30 #include "trans.h"
|
|
|
31 #include "stringpool.h"
|
|
|
32 #include "fold-const.h"
|
|
|
33 #include "stor-layout.h"
|
|
|
34 #include "langhooks.h" /* For iso-c-bindings.def. */
|
|
|
35 #include "toplev.h" /* For rest_of_decl_compilation. */
|
|
|
36 #include "trans-types.h"
|
|
|
37 #include "trans-const.h"
|
|
|
38 #include "trans-array.h"
|
|
|
39 #include "dwarf2out.h" /* For struct array_descr_info. */
|
|
|
40 #include "attribs.h"
|
|
|
41
|
|
|
42
|
|
|
43 #if (GFC_MAX_DIMENSIONS < 10)
|
|
|
44 #define GFC_RANK_DIGITS 1
|
|
|
45 #define GFC_RANK_PRINTF_FORMAT "%01d"
|
|
|
46 #elif (GFC_MAX_DIMENSIONS < 100)
|
|
|
47 #define GFC_RANK_DIGITS 2
|
|
|
48 #define GFC_RANK_PRINTF_FORMAT "%02d"
|
|
|
49 #else
|
|
|
50 #error If you really need >99 dimensions, continue the sequence above...
|
|
|
51 #endif
|
|
|
52
|
|
|
53 /* array of structs so we don't have to worry about xmalloc or free */
|
|
|
54 CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
|
|
|
55
|
|
|
56 tree gfc_array_index_type;
|
|
|
57 tree gfc_array_range_type;
|
|
|
58 tree gfc_character1_type_node;
|
|
|
59 tree pvoid_type_node;
|
|
|
60 tree prvoid_type_node;
|
|
|
61 tree ppvoid_type_node;
|
|
|
62 tree pchar_type_node;
|
|
|
63 tree pfunc_type_node;
|
|
|
64
|
|
131
|
65 tree logical_type_node;
|
|
|
66 tree logical_true_node;
|
|
|
67 tree logical_false_node;
|
|
111
|
68 tree gfc_charlen_type_node;
|
|
|
69
|
|
|
70 tree gfc_float128_type_node = NULL_TREE;
|
|
|
71 tree gfc_complex_float128_type_node = NULL_TREE;
|
|
|
72
|
|
|
73 bool gfc_real16_is_float128 = false;
|
|
|
74
|
|
|
75 static GTY(()) tree gfc_desc_dim_type;
|
|
|
76 static GTY(()) tree gfc_max_array_element_size;
|
|
|
77 static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
|
|
|
78 static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
|
|
|
79
|
|
|
80 /* Arrays for all integral and real kinds. We'll fill this in at runtime
|
|
|
81 after the target has a chance to process command-line options. */
|
|
|
82
|
|
|
83 #define MAX_INT_KINDS 5
|
|
|
84 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
|
|
|
85 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
|
|
|
86 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
|
|
|
87 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
|
|
|
88
|
|
|
89 #define MAX_REAL_KINDS 5
|
|
|
90 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
|
|
|
91 static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
|
|
|
92 static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
|
|
|
93
|
|
|
94 #define MAX_CHARACTER_KINDS 2
|
|
|
95 gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
|
|
|
96 static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
|
|
|
97 static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
|
|
|
98
|
|
|
99 static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **);
|
|
|
100
|
|
|
101 /* The integer kind to use for array indices. This will be set to the
|
|
|
102 proper value based on target information from the backend. */
|
|
|
103
|
|
|
104 int gfc_index_integer_kind;
|
|
|
105
|
|
|
106 /* The default kinds of the various types. */
|
|
|
107
|
|
|
108 int gfc_default_integer_kind;
|
|
|
109 int gfc_max_integer_kind;
|
|
|
110 int gfc_default_real_kind;
|
|
|
111 int gfc_default_double_kind;
|
|
|
112 int gfc_default_character_kind;
|
|
|
113 int gfc_default_logical_kind;
|
|
|
114 int gfc_default_complex_kind;
|
|
|
115 int gfc_c_int_kind;
|
|
|
116 int gfc_atomic_int_kind;
|
|
|
117 int gfc_atomic_logical_kind;
|
|
|
118
|
|
|
119 /* The kind size used for record offsets. If the target system supports
|
|
|
120 kind=8, this will be set to 8, otherwise it is set to 4. */
|
|
|
121 int gfc_intio_kind;
|
|
|
122
|
|
|
123 /* The integer kind used to store character lengths. */
|
|
|
124 int gfc_charlen_int_kind;
|
|
|
125
|
|
131
|
126 /* Kind of internal integer for storing object sizes. */
|
|
|
127 int gfc_size_kind;
|
|
|
128
|
|
111
|
129 /* The size of the numeric storage unit and character storage unit. */
|
|
|
130 int gfc_numeric_storage_size;
|
|
|
131 int gfc_character_storage_size;
|
|
|
132
|
|
131
|
133 tree dtype_type_node = NULL_TREE;
|
|
|
134
|
|
|
135
|
|
|
136 /* Build the dtype_type_node if necessary. */
|
|
|
137 tree get_dtype_type_node (void)
|
|
|
138 {
|
|
|
139 tree field;
|
|
|
140 tree dtype_node;
|
|
|
141 tree *dtype_chain = NULL;
|
|
|
142
|
|
|
143 if (dtype_type_node == NULL_TREE)
|
|
|
144 {
|
|
|
145 dtype_node = make_node (RECORD_TYPE);
|
|
|
146 TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
|
|
|
147 TYPE_NAMELESS (dtype_node) = 1;
|
|
|
148 field = gfc_add_field_to_struct_1 (dtype_node,
|
|
|
149 get_identifier ("elem_len"),
|
|
|
150 size_type_node, &dtype_chain);
|
|
|
151 TREE_NO_WARNING (field) = 1;
|
|
|
152 field = gfc_add_field_to_struct_1 (dtype_node,
|
|
|
153 get_identifier ("version"),
|
|
|
154 integer_type_node, &dtype_chain);
|
|
|
155 TREE_NO_WARNING (field) = 1;
|
|
|
156 field = gfc_add_field_to_struct_1 (dtype_node,
|
|
|
157 get_identifier ("rank"),
|
|
|
158 signed_char_type_node, &dtype_chain);
|
|
|
159 TREE_NO_WARNING (field) = 1;
|
|
|
160 field = gfc_add_field_to_struct_1 (dtype_node,
|
|
|
161 get_identifier ("type"),
|
|
|
162 signed_char_type_node, &dtype_chain);
|
|
|
163 TREE_NO_WARNING (field) = 1;
|
|
|
164 field = gfc_add_field_to_struct_1 (dtype_node,
|
|
|
165 get_identifier ("attribute"),
|
|
|
166 short_integer_type_node, &dtype_chain);
|
|
|
167 TREE_NO_WARNING (field) = 1;
|
|
|
168 gfc_finish_type (dtype_node);
|
|
|
169 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
|
|
|
170 dtype_type_node = dtype_node;
|
|
|
171 }
|
|
|
172 return dtype_type_node;
|
|
|
173 }
|
|
111
|
174
|
|
|
175 bool
|
|
|
176 gfc_check_any_c_kind (gfc_typespec *ts)
|
|
|
177 {
|
|
|
178 int i;
|
|
|
179
|
|
|
180 for (i = 0; i < ISOCBINDING_NUMBER; i++)
|
|
|
181 {
|
|
|
182 /* Check for any C interoperable kind for the given type/kind in ts.
|
|
|
183 This can be used after verify_c_interop to make sure that the
|
|
|
184 Fortran kind being used exists in at least some form for C. */
|
|
|
185 if (c_interop_kinds_table[i].f90_type == ts->type &&
|
|
|
186 c_interop_kinds_table[i].value == ts->kind)
|
|
|
187 return true;
|
|
|
188 }
|
|
|
189
|
|
|
190 return false;
|
|
|
191 }
|
|
|
192
|
|
|
193
|
|
|
194 static int
|
|
|
195 get_real_kind_from_node (tree type)
|
|
|
196 {
|
|
|
197 int i;
|
|
|
198
|
|
|
199 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
|
|
|
200 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
|
|
|
201 return gfc_real_kinds[i].kind;
|
|
|
202
|
|
|
203 return -4;
|
|
|
204 }
|
|
|
205
|
|
|
206 static int
|
|
|
207 get_int_kind_from_node (tree type)
|
|
|
208 {
|
|
|
209 int i;
|
|
|
210
|
|
|
211 if (!type)
|
|
|
212 return -2;
|
|
|
213
|
|
|
214 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
|
215 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
|
|
|
216 return gfc_integer_kinds[i].kind;
|
|
|
217
|
|
|
218 return -1;
|
|
|
219 }
|
|
|
220
|
|
|
221 static int
|
|
|
222 get_int_kind_from_name (const char *name)
|
|
|
223 {
|
|
|
224 return get_int_kind_from_node (get_typenode_from_name (name));
|
|
|
225 }
|
|
|
226
|
|
|
227
|
|
|
228 /* Get the kind number corresponding to an integer of given size,
|
|
|
229 following the required return values for ISO_FORTRAN_ENV INT* constants:
|
|
|
230 -2 is returned if we support a kind of larger size, -1 otherwise. */
|
|
|
231 int
|
|
|
232 gfc_get_int_kind_from_width_isofortranenv (int size)
|
|
|
233 {
|
|
|
234 int i;
|
|
|
235
|
|
|
236 /* Look for a kind with matching storage size. */
|
|
|
237 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
|
238 if (gfc_integer_kinds[i].bit_size == size)
|
|
|
239 return gfc_integer_kinds[i].kind;
|
|
|
240
|
|
|
241 /* Look for a kind with larger storage size. */
|
|
|
242 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
|
243 if (gfc_integer_kinds[i].bit_size > size)
|
|
|
244 return -2;
|
|
|
245
|
|
|
246 return -1;
|
|
|
247 }
|
|
|
248
|
|
|
249
|
|
|
250 /* Get the kind number corresponding to a real of a given storage size.
|
|
|
251 If two real's have the same storage size, then choose the real with
|
|
|
252 the largest precision. If a kind type is unavailable and a real
|
|
|
253 exists with wider storage, then return -2; otherwise, return -1. */
|
|
|
254
|
|
|
255 int
|
|
|
256 gfc_get_real_kind_from_width_isofortranenv (int size)
|
|
|
257 {
|
|
|
258 int digits, i, kind;
|
|
|
259
|
|
|
260 size /= 8;
|
|
|
261
|
|
|
262 kind = -1;
|
|
|
263 digits = 0;
|
|
|
264
|
|
|
265 /* Look for a kind with matching storage size. */
|
|
|
266 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
|
|
|
267 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
|
|
|
268 {
|
|
|
269 if (gfc_real_kinds[i].digits > digits)
|
|
|
270 {
|
|
|
271 digits = gfc_real_kinds[i].digits;
|
|
|
272 kind = gfc_real_kinds[i].kind;
|
|
|
273 }
|
|
|
274 }
|
|
|
275
|
|
|
276 if (kind != -1)
|
|
|
277 return kind;
|
|
|
278
|
|
|
279 /* Look for a kind with larger storage size. */
|
|
|
280 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
|
|
|
281 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
|
|
|
282 kind = -2;
|
|
|
283
|
|
|
284 return kind;
|
|
|
285 }
|
|
|
286
|
|
|
287
|
|
|
288
|
|
|
289 static int
|
|
|
290 get_int_kind_from_width (int size)
|
|
|
291 {
|
|
|
292 int i;
|
|
|
293
|
|
|
294 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
|
295 if (gfc_integer_kinds[i].bit_size == size)
|
|
|
296 return gfc_integer_kinds[i].kind;
|
|
|
297
|
|
|
298 return -2;
|
|
|
299 }
|
|
|
300
|
|
|
301 static int
|
|
|
302 get_int_kind_from_minimal_width (int size)
|
|
|
303 {
|
|
|
304 int i;
|
|
|
305
|
|
|
306 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
|
307 if (gfc_integer_kinds[i].bit_size >= size)
|
|
|
308 return gfc_integer_kinds[i].kind;
|
|
|
309
|
|
|
310 return -2;
|
|
|
311 }
|
|
|
312
|
|
|
313
|
|
|
314 /* Generate the CInteropKind_t objects for the C interoperable
|
|
|
315 kinds. */
|
|
|
316
|
|
|
317 void
|
|
|
318 gfc_init_c_interop_kinds (void)
|
|
|
319 {
|
|
|
320 int i;
|
|
|
321
|
|
|
322 /* init all pointers in the list to NULL */
|
|
|
323 for (i = 0; i < ISOCBINDING_NUMBER; i++)
|
|
|
324 {
|
|
|
325 /* Initialize the name and value fields. */
|
|
|
326 c_interop_kinds_table[i].name[0] = '\0';
|
|
|
327 c_interop_kinds_table[i].value = -100;
|
|
|
328 c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
|
|
|
329 }
|
|
|
330
|
|
|
331 #define NAMED_INTCST(a,b,c,d) \
|
|
|
332 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
333 c_interop_kinds_table[a].f90_type = BT_INTEGER; \
|
|
|
334 c_interop_kinds_table[a].value = c;
|
|
|
335 #define NAMED_REALCST(a,b,c,d) \
|
|
|
336 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
337 c_interop_kinds_table[a].f90_type = BT_REAL; \
|
|
|
338 c_interop_kinds_table[a].value = c;
|
|
|
339 #define NAMED_CMPXCST(a,b,c,d) \
|
|
|
340 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
341 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
|
|
|
342 c_interop_kinds_table[a].value = c;
|
|
|
343 #define NAMED_LOGCST(a,b,c) \
|
|
|
344 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
345 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
|
|
|
346 c_interop_kinds_table[a].value = c;
|
|
|
347 #define NAMED_CHARKNDCST(a,b,c) \
|
|
|
348 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
349 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
|
|
|
350 c_interop_kinds_table[a].value = c;
|
|
|
351 #define NAMED_CHARCST(a,b,c) \
|
|
|
352 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
353 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
|
|
|
354 c_interop_kinds_table[a].value = c;
|
|
|
355 #define DERIVED_TYPE(a,b,c) \
|
|
|
356 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
357 c_interop_kinds_table[a].f90_type = BT_DERIVED; \
|
|
|
358 c_interop_kinds_table[a].value = c;
|
|
|
359 #define NAMED_FUNCTION(a,b,c,d) \
|
|
|
360 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
361 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
|
|
|
362 c_interop_kinds_table[a].value = c;
|
|
|
363 #define NAMED_SUBROUTINE(a,b,c,d) \
|
|
|
364 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
|
|
|
365 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
|
|
|
366 c_interop_kinds_table[a].value = c;
|
|
|
367 #include "iso-c-binding.def"
|
|
|
368 }
|
|
|
369
|
|
|
370
|
|
|
371 /* Query the target to determine which machine modes are available for
|
|
|
372 computation. Choose KIND numbers for them. */
|
|
|
373
|
|
|
374 void
|
|
|
375 gfc_init_kinds (void)
|
|
|
376 {
|
|
|
377 opt_scalar_int_mode int_mode_iter;
|
|
|
378 opt_scalar_float_mode float_mode_iter;
|
|
|
379 int i_index, r_index, kind;
|
|
|
380 bool saw_i4 = false, saw_i8 = false;
|
|
|
381 bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
|
|
|
382
|
|
|
383 i_index = 0;
|
|
|
384 FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT)
|
|
|
385 {
|
|
|
386 scalar_int_mode mode = int_mode_iter.require ();
|
|
|
387 int kind, bitsize;
|
|
|
388
|
|
|
389 if (!targetm.scalar_mode_supported_p (mode))
|
|
|
390 continue;
|
|
|
391
|
|
|
392 /* The middle end doesn't support constants larger than 2*HWI.
|
|
|
393 Perhaps the target hook shouldn't have accepted these either,
|
|
|
394 but just to be safe... */
|
|
|
395 bitsize = GET_MODE_BITSIZE (mode);
|
|
|
396 if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
|
|
|
397 continue;
|
|
|
398
|
|
|
399 gcc_assert (i_index != MAX_INT_KINDS);
|
|
|
400
|
|
|
401 /* Let the kind equal the bit size divided by 8. This insulates the
|
|
|
402 programmer from the underlying byte size. */
|
|
|
403 kind = bitsize / 8;
|
|
|
404
|
|
|
405 if (kind == 4)
|
|
|
406 saw_i4 = true;
|
|
|
407 if (kind == 8)
|
|
|
408 saw_i8 = true;
|
|
|
409
|
|
|
410 gfc_integer_kinds[i_index].kind = kind;
|
|
|
411 gfc_integer_kinds[i_index].radix = 2;
|
|
|
412 gfc_integer_kinds[i_index].digits = bitsize - 1;
|
|
|
413 gfc_integer_kinds[i_index].bit_size = bitsize;
|
|
|
414
|
|
|
415 gfc_logical_kinds[i_index].kind = kind;
|
|
|
416 gfc_logical_kinds[i_index].bit_size = bitsize;
|
|
|
417
|
|
|
418 i_index += 1;
|
|
|
419 }
|
|
|
420
|
|
|
421 /* Set the kind used to match GFC_INT_IO in libgfortran. This is
|
|
|
422 used for large file access. */
|
|
|
423
|
|
|
424 if (saw_i8)
|
|
|
425 gfc_intio_kind = 8;
|
|
|
426 else
|
|
|
427 gfc_intio_kind = 4;
|
|
|
428
|
|
|
429 /* If we do not at least have kind = 4, everything is pointless. */
|
|
|
430 gcc_assert(saw_i4);
|
|
|
431
|
|
|
432 /* Set the maximum integer kind. Used with at least BOZ constants. */
|
|
|
433 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
|
|
|
434
|
|
|
435 r_index = 0;
|
|
|
436 FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT)
|
|
|
437 {
|
|
|
438 scalar_float_mode mode = float_mode_iter.require ();
|
|
|
439 const struct real_format *fmt = REAL_MODE_FORMAT (mode);
|
|
|
440 int kind;
|
|
|
441
|
|
|
442 if (fmt == NULL)
|
|
|
443 continue;
|
|
|
444 if (!targetm.scalar_mode_supported_p (mode))
|
|
|
445 continue;
|
|
|
446
|
|
|
447 /* Only let float, double, long double and __float128 go through.
|
|
|
448 Runtime support for others is not provided, so they would be
|
|
|
449 useless. */
|
|
|
450 if (!targetm.libgcc_floating_mode_supported_p (mode))
|
|
|
451 continue;
|
|
|
452 if (mode != TYPE_MODE (float_type_node)
|
|
|
453 && (mode != TYPE_MODE (double_type_node))
|
|
|
454 && (mode != TYPE_MODE (long_double_type_node))
|
|
|
455 #if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
|
|
|
456 && (mode != TFmode)
|
|
|
457 #endif
|
|
|
458 )
|
|
|
459 continue;
|
|
|
460
|
|
|
461 /* Let the kind equal the precision divided by 8, rounding up. Again,
|
|
|
462 this insulates the programmer from the underlying byte size.
|
|
|
463
|
|
|
464 Also, it effectively deals with IEEE extended formats. There, the
|
|
|
465 total size of the type may equal 16, but it's got 6 bytes of padding
|
|
|
466 and the increased size can get in the way of a real IEEE quad format
|
|
|
467 which may also be supported by the target.
|
|
|
468
|
|
|
469 We round up so as to handle IA-64 __floatreg (RFmode), which is an
|
|
|
470 82 bit type. Not to be confused with __float80 (XFmode), which is
|
|
|
471 an 80 bit type also supported by IA-64. So XFmode should come out
|
|
|
472 to be kind=10, and RFmode should come out to be kind=11. Egads. */
|
|
|
473
|
|
|
474 kind = (GET_MODE_PRECISION (mode) + 7) / 8;
|
|
|
475
|
|
|
476 if (kind == 4)
|
|
|
477 saw_r4 = true;
|
|
|
478 if (kind == 8)
|
|
|
479 saw_r8 = true;
|
|
|
480 if (kind == 10)
|
|
|
481 saw_r10 = true;
|
|
|
482 if (kind == 16)
|
|
|
483 saw_r16 = true;
|
|
|
484
|
|
|
485 /* Careful we don't stumble a weird internal mode. */
|
|
|
486 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
|
|
|
487 /* Or have too many modes for the allocated space. */
|
|
|
488 gcc_assert (r_index != MAX_REAL_KINDS);
|
|
|
489
|
|
|
490 gfc_real_kinds[r_index].kind = kind;
|
|
|
491 gfc_real_kinds[r_index].radix = fmt->b;
|
|
|
492 gfc_real_kinds[r_index].digits = fmt->p;
|
|
|
493 gfc_real_kinds[r_index].min_exponent = fmt->emin;
|
|
|
494 gfc_real_kinds[r_index].max_exponent = fmt->emax;
|
|
|
495 if (fmt->pnan < fmt->p)
|
|
|
496 /* This is an IBM extended double format (or the MIPS variant)
|
|
|
497 made up of two IEEE doubles. The value of the long double is
|
|
|
498 the sum of the values of the two parts. The most significant
|
|
|
499 part is required to be the value of the long double rounded
|
|
|
500 to the nearest double. If we use emax of 1024 then we can't
|
|
|
501 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
|
|
|
502 rounding will make the most significant part overflow. */
|
|
|
503 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
|
|
|
504 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
|
|
|
505 r_index += 1;
|
|
|
506 }
|
|
|
507
|
|
|
508 /* Choose the default integer kind. We choose 4 unless the user directs us
|
|
|
509 otherwise. Even if the user specified that the default integer kind is 8,
|
|
|
510 the numeric storage size is not 64 bits. In this case, a warning will be
|
|
|
511 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
|
|
|
512
|
|
|
513 gfc_numeric_storage_size = 4 * 8;
|
|
|
514
|
|
|
515 if (flag_default_integer)
|
|
|
516 {
|
|
|
517 if (!saw_i8)
|
|
|
518 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
|
|
|
519 "%<-fdefault-integer-8%> option");
|
|
|
520
|
|
|
521 gfc_default_integer_kind = 8;
|
|
|
522
|
|
|
523 }
|
|
|
524 else if (flag_integer4_kind == 8)
|
|
|
525 {
|
|
|
526 if (!saw_i8)
|
|
|
527 gfc_fatal_error ("INTEGER(KIND=8) is not available for "
|
|
|
528 "%<-finteger-4-integer-8%> option");
|
|
|
529
|
|
|
530 gfc_default_integer_kind = 8;
|
|
|
531 }
|
|
|
532 else if (saw_i4)
|
|
|
533 {
|
|
|
534 gfc_default_integer_kind = 4;
|
|
|
535 }
|
|
|
536 else
|
|
|
537 {
|
|
|
538 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
|
|
|
539 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
|
|
|
540 }
|
|
|
541
|
|
|
542 /* Choose the default real kind. Again, we choose 4 when possible. */
|
|
|
543 if (flag_default_real_8)
|
|
|
544 {
|
|
|
545 if (!saw_r8)
|
|
|
546 gfc_fatal_error ("REAL(KIND=8) is not available for "
|
|
|
547 "%<-fdefault-real-8%> option");
|
|
|
548
|
|
|
549 gfc_default_real_kind = 8;
|
|
|
550 }
|
|
|
551 else if (flag_default_real_10)
|
|
|
552 {
|
|
|
553 if (!saw_r10)
|
|
|
554 gfc_fatal_error ("REAL(KIND=10) is not available for "
|
|
|
555 "%<-fdefault-real-10%> option");
|
|
|
556
|
|
|
557 gfc_default_real_kind = 10;
|
|
|
558 }
|
|
|
559 else if (flag_default_real_16)
|
|
|
560 {
|
|
|
561 if (!saw_r16)
|
|
|
562 gfc_fatal_error ("REAL(KIND=16) is not available for "
|
|
|
563 "%<-fdefault-real-16%> option");
|
|
|
564
|
|
|
565 gfc_default_real_kind = 16;
|
|
|
566 }
|
|
|
567 else if (flag_real4_kind == 8)
|
|
|
568 {
|
|
|
569 if (!saw_r8)
|
|
|
570 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
|
|
|
571 "option");
|
|
|
572
|
|
|
573 gfc_default_real_kind = 8;
|
|
|
574 }
|
|
|
575 else if (flag_real4_kind == 10)
|
|
|
576 {
|
|
|
577 if (!saw_r10)
|
|
|
578 gfc_fatal_error ("REAL(KIND=10) is not available for "
|
|
|
579 "%<-freal-4-real-10%> option");
|
|
|
580
|
|
|
581 gfc_default_real_kind = 10;
|
|
|
582 }
|
|
|
583 else if (flag_real4_kind == 16)
|
|
|
584 {
|
|
|
585 if (!saw_r16)
|
|
|
586 gfc_fatal_error ("REAL(KIND=16) is not available for "
|
|
|
587 "%<-freal-4-real-16%> option");
|
|
|
588
|
|
|
589 gfc_default_real_kind = 16;
|
|
|
590 }
|
|
|
591 else if (saw_r4)
|
|
|
592 gfc_default_real_kind = 4;
|
|
|
593 else
|
|
|
594 gfc_default_real_kind = gfc_real_kinds[0].kind;
|
|
|
595
|
|
|
596 /* Choose the default double kind. If -fdefault-real and -fdefault-double
|
|
|
597 are specified, we use kind=8, if it's available. If -fdefault-real is
|
|
|
598 specified without -fdefault-double, we use kind=16, if it's available.
|
|
|
599 Otherwise we do not change anything. */
|
|
|
600 if (flag_default_double && saw_r8)
|
|
|
601 gfc_default_double_kind = 8;
|
|
|
602 else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16)
|
|
|
603 {
|
|
|
604 /* Use largest available kind. */
|
|
|
605 if (saw_r16)
|
|
|
606 gfc_default_double_kind = 16;
|
|
|
607 else if (saw_r10)
|
|
|
608 gfc_default_double_kind = 10;
|
|
|
609 else if (saw_r8)
|
|
|
610 gfc_default_double_kind = 8;
|
|
|
611 else
|
|
|
612 gfc_default_double_kind = gfc_default_real_kind;
|
|
|
613 }
|
|
|
614 else if (flag_real8_kind == 4)
|
|
|
615 {
|
|
|
616 if (!saw_r4)
|
|
|
617 gfc_fatal_error ("REAL(KIND=4) is not available for "
|
|
|
618 "%<-freal-8-real-4%> option");
|
|
|
619
|
|
|
620 gfc_default_double_kind = 4;
|
|
|
621 }
|
|
|
622 else if (flag_real8_kind == 10 )
|
|
|
623 {
|
|
|
624 if (!saw_r10)
|
|
|
625 gfc_fatal_error ("REAL(KIND=10) is not available for "
|
|
|
626 "%<-freal-8-real-10%> option");
|
|
|
627
|
|
|
628 gfc_default_double_kind = 10;
|
|
|
629 }
|
|
|
630 else if (flag_real8_kind == 16 )
|
|
|
631 {
|
|
|
632 if (!saw_r16)
|
|
|
633 gfc_fatal_error ("REAL(KIND=10) is not available for "
|
|
|
634 "%<-freal-8-real-16%> option");
|
|
|
635
|
|
|
636 gfc_default_double_kind = 16;
|
|
|
637 }
|
|
|
638 else if (saw_r4 && saw_r8)
|
|
|
639 gfc_default_double_kind = 8;
|
|
|
640 else
|
|
|
641 {
|
|
|
642 /* F95 14.6.3.1: A nonpointer scalar object of type double precision
|
|
|
643 real ... occupies two contiguous numeric storage units.
|
|
|
644
|
|
|
645 Therefore we must be supplied a kind twice as large as we chose
|
|
|
646 for single precision. There are loopholes, in that double
|
|
|
647 precision must *occupy* two storage units, though it doesn't have
|
|
|
648 to *use* two storage units. Which means that you can make this
|
|
|
649 kind artificially wide by padding it. But at present there are
|
|
|
650 no GCC targets for which a two-word type does not exist, so we
|
|
|
651 just let gfc_validate_kind abort and tell us if something breaks. */
|
|
|
652
|
|
|
653 gfc_default_double_kind
|
|
|
654 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
|
|
|
655 }
|
|
|
656
|
|
|
657 /* The default logical kind is constrained to be the same as the
|
|
|
658 default integer kind. Similarly with complex and real. */
|
|
|
659 gfc_default_logical_kind = gfc_default_integer_kind;
|
|
|
660 gfc_default_complex_kind = gfc_default_real_kind;
|
|
|
661
|
|
|
662 /* We only have two character kinds: ASCII and UCS-4.
|
|
|
663 ASCII corresponds to a 8-bit integer type, if one is available.
|
|
|
664 UCS-4 corresponds to a 32-bit integer type, if one is available. */
|
|
|
665 i_index = 0;
|
|
|
666 if ((kind = get_int_kind_from_width (8)) > 0)
|
|
|
667 {
|
|
|
668 gfc_character_kinds[i_index].kind = kind;
|
|
|
669 gfc_character_kinds[i_index].bit_size = 8;
|
|
|
670 gfc_character_kinds[i_index].name = "ascii";
|
|
|
671 i_index++;
|
|
|
672 }
|
|
|
673 if ((kind = get_int_kind_from_width (32)) > 0)
|
|
|
674 {
|
|
|
675 gfc_character_kinds[i_index].kind = kind;
|
|
|
676 gfc_character_kinds[i_index].bit_size = 32;
|
|
|
677 gfc_character_kinds[i_index].name = "iso_10646";
|
|
|
678 i_index++;
|
|
|
679 }
|
|
|
680
|
|
|
681 /* Choose the smallest integer kind for our default character. */
|
|
|
682 gfc_default_character_kind = gfc_character_kinds[0].kind;
|
|
|
683 gfc_character_storage_size = gfc_default_character_kind * 8;
|
|
|
684
|
|
|
685 gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);
|
|
|
686
|
|
|
687 /* Pick a kind the same size as the C "int" type. */
|
|
|
688 gfc_c_int_kind = INT_TYPE_SIZE / 8;
|
|
|
689
|
|
|
690 /* Choose atomic kinds to match C's int. */
|
|
|
691 gfc_atomic_int_kind = gfc_c_int_kind;
|
|
|
692 gfc_atomic_logical_kind = gfc_c_int_kind;
|
|
|
693 }
|
|
|
694
|
|
|
695
|
|
|
696 /* Make sure that a valid kind is present. Returns an index into the
|
|
|
697 associated kinds array, -1 if the kind is not present. */
|
|
|
698
|
|
|
699 static int
|
|
|
700 validate_integer (int kind)
|
|
|
701 {
|
|
|
702 int i;
|
|
|
703
|
|
|
704 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
|
705 if (gfc_integer_kinds[i].kind == kind)
|
|
|
706 return i;
|
|
|
707
|
|
|
708 return -1;
|
|
|
709 }
|
|
|
710
|
|
|
711 static int
|
|
|
712 validate_real (int kind)
|
|
|
713 {
|
|
|
714 int i;
|
|
|
715
|
|
|
716 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
|
|
|
717 if (gfc_real_kinds[i].kind == kind)
|
|
|
718 return i;
|
|
|
719
|
|
|
720 return -1;
|
|
|
721 }
|
|
|
722
|
|
|
723 static int
|
|
|
724 validate_logical (int kind)
|
|
|
725 {
|
|
|
726 int i;
|
|
|
727
|
|
|
728 for (i = 0; gfc_logical_kinds[i].kind; i++)
|
|
|
729 if (gfc_logical_kinds[i].kind == kind)
|
|
|
730 return i;
|
|
|
731
|
|
|
732 return -1;
|
|
|
733 }
|
|
|
734
|
|
|
735 static int
|
|
|
736 validate_character (int kind)
|
|
|
737 {
|
|
|
738 int i;
|
|
|
739
|
|
|
740 for (i = 0; gfc_character_kinds[i].kind; i++)
|
|
|
741 if (gfc_character_kinds[i].kind == kind)
|
|
|
742 return i;
|
|
|
743
|
|
|
744 return -1;
|
|
|
745 }
|
|
|
746
|
|
|
747 /* Validate a kind given a basic type. The return value is the same
|
|
|
748 for the child functions, with -1 indicating nonexistence of the
|
|
|
749 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */
|
|
|
750
|
|
|
751 int
|
|
|
752 gfc_validate_kind (bt type, int kind, bool may_fail)
|
|
|
753 {
|
|
|
754 int rc;
|
|
|
755
|
|
|
756 switch (type)
|
|
|
757 {
|
|
|
758 case BT_REAL: /* Fall through */
|
|
|
759 case BT_COMPLEX:
|
|
|
760 rc = validate_real (kind);
|
|
|
761 break;
|
|
|
762 case BT_INTEGER:
|
|
|
763 rc = validate_integer (kind);
|
|
|
764 break;
|
|
|
765 case BT_LOGICAL:
|
|
|
766 rc = validate_logical (kind);
|
|
|
767 break;
|
|
|
768 case BT_CHARACTER:
|
|
|
769 rc = validate_character (kind);
|
|
|
770 break;
|
|
|
771
|
|
|
772 default:
|
|
|
773 gfc_internal_error ("gfc_validate_kind(): Got bad type");
|
|
|
774 }
|
|
|
775
|
|
|
776 if (rc < 0 && !may_fail)
|
|
|
777 gfc_internal_error ("gfc_validate_kind(): Got bad kind");
|
|
|
778
|
|
|
779 return rc;
|
|
|
780 }
|
|
|
781
|
|
|
782
|
|
|
783 /* Four subroutines of gfc_init_types. Create type nodes for the given kind.
|
|
|
784 Reuse common type nodes where possible. Recognize if the kind matches up
|
|
|
785 with a C type. This will be used later in determining which routines may
|
|
|
786 be scarfed from libm. */
|
|
|
787
|
|
|
788 static tree
|
|
|
789 gfc_build_int_type (gfc_integer_info *info)
|
|
|
790 {
|
|
|
791 int mode_precision = info->bit_size;
|
|
|
792
|
|
|
793 if (mode_precision == CHAR_TYPE_SIZE)
|
|
|
794 info->c_char = 1;
|
|
|
795 if (mode_precision == SHORT_TYPE_SIZE)
|
|
|
796 info->c_short = 1;
|
|
|
797 if (mode_precision == INT_TYPE_SIZE)
|
|
|
798 info->c_int = 1;
|
|
|
799 if (mode_precision == LONG_TYPE_SIZE)
|
|
|
800 info->c_long = 1;
|
|
|
801 if (mode_precision == LONG_LONG_TYPE_SIZE)
|
|
|
802 info->c_long_long = 1;
|
|
|
803
|
|
|
804 if (TYPE_PRECISION (intQI_type_node) == mode_precision)
|
|
|
805 return intQI_type_node;
|
|
|
806 if (TYPE_PRECISION (intHI_type_node) == mode_precision)
|
|
|
807 return intHI_type_node;
|
|
|
808 if (TYPE_PRECISION (intSI_type_node) == mode_precision)
|
|
|
809 return intSI_type_node;
|
|
|
810 if (TYPE_PRECISION (intDI_type_node) == mode_precision)
|
|
|
811 return intDI_type_node;
|
|
|
812 if (TYPE_PRECISION (intTI_type_node) == mode_precision)
|
|
|
813 return intTI_type_node;
|
|
|
814
|
|
|
815 return make_signed_type (mode_precision);
|
|
|
816 }
|
|
|
817
|
|
|
818 tree
|
|
|
819 gfc_build_uint_type (int size)
|
|
|
820 {
|
|
|
821 if (size == CHAR_TYPE_SIZE)
|
|
|
822 return unsigned_char_type_node;
|
|
|
823 if (size == SHORT_TYPE_SIZE)
|
|
|
824 return short_unsigned_type_node;
|
|
|
825 if (size == INT_TYPE_SIZE)
|
|
|
826 return unsigned_type_node;
|
|
|
827 if (size == LONG_TYPE_SIZE)
|
|
|
828 return long_unsigned_type_node;
|
|
|
829 if (size == LONG_LONG_TYPE_SIZE)
|
|
|
830 return long_long_unsigned_type_node;
|
|
|
831
|
|
|
832 return make_unsigned_type (size);
|
|
|
833 }
|
|
|
834
|
|
|
835
|
|
|
836 static tree
|
|
|
837 gfc_build_real_type (gfc_real_info *info)
|
|
|
838 {
|
|
|
839 int mode_precision = info->mode_precision;
|
|
|
840 tree new_type;
|
|
|
841
|
|
|
842 if (mode_precision == FLOAT_TYPE_SIZE)
|
|
|
843 info->c_float = 1;
|
|
|
844 if (mode_precision == DOUBLE_TYPE_SIZE)
|
|
|
845 info->c_double = 1;
|
|
|
846 if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
|
|
|
847 info->c_long_double = 1;
|
|
|
848 if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128)
|
|
|
849 {
|
|
|
850 info->c_float128 = 1;
|
|
|
851 gfc_real16_is_float128 = true;
|
|
|
852 }
|
|
|
853
|
|
|
854 if (TYPE_PRECISION (float_type_node) == mode_precision)
|
|
|
855 return float_type_node;
|
|
|
856 if (TYPE_PRECISION (double_type_node) == mode_precision)
|
|
|
857 return double_type_node;
|
|
|
858 if (TYPE_PRECISION (long_double_type_node) == mode_precision)
|
|
|
859 return long_double_type_node;
|
|
|
860
|
|
|
861 new_type = make_node (REAL_TYPE);
|
|
|
862 TYPE_PRECISION (new_type) = mode_precision;
|
|
|
863 layout_type (new_type);
|
|
|
864 return new_type;
|
|
|
865 }
|
|
|
866
|
|
|
867 static tree
|
|
|
868 gfc_build_complex_type (tree scalar_type)
|
|
|
869 {
|
|
|
870 tree new_type;
|
|
|
871
|
|
|
872 if (scalar_type == NULL)
|
|
|
873 return NULL;
|
|
|
874 if (scalar_type == float_type_node)
|
|
|
875 return complex_float_type_node;
|
|
|
876 if (scalar_type == double_type_node)
|
|
|
877 return complex_double_type_node;
|
|
|
878 if (scalar_type == long_double_type_node)
|
|
|
879 return complex_long_double_type_node;
|
|
|
880
|
|
|
881 new_type = make_node (COMPLEX_TYPE);
|
|
|
882 TREE_TYPE (new_type) = scalar_type;
|
|
|
883 layout_type (new_type);
|
|
|
884 return new_type;
|
|
|
885 }
|
|
|
886
|
|
|
887 static tree
|
|
|
888 gfc_build_logical_type (gfc_logical_info *info)
|
|
|
889 {
|
|
|
890 int bit_size = info->bit_size;
|
|
|
891 tree new_type;
|
|
|
892
|
|
|
893 if (bit_size == BOOL_TYPE_SIZE)
|
|
|
894 {
|
|
|
895 info->c_bool = 1;
|
|
|
896 return boolean_type_node;
|
|
|
897 }
|
|
|
898
|
|
|
899 new_type = make_unsigned_type (bit_size);
|
|
|
900 TREE_SET_CODE (new_type, BOOLEAN_TYPE);
|
|
|
901 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
|
|
|
902 TYPE_PRECISION (new_type) = 1;
|
|
|
903
|
|
|
904 return new_type;
|
|
|
905 }
|
|
|
906
|
|
|
907
|
|
|
908 /* Create the backend type nodes. We map them to their
|
|
|
909 equivalent C type, at least for now. We also give
|
|
|
910 names to the types here, and we push them in the
|
|
|
911 global binding level context.*/
|
|
|
912
|
|
|
913 void
|
|
|
914 gfc_init_types (void)
|
|
|
915 {
|
|
|
916 char name_buf[26];
|
|
|
917 int index;
|
|
|
918 tree type;
|
|
|
919 unsigned n;
|
|
|
920
|
|
|
921 /* Create and name the types. */
|
|
|
922 #define PUSH_TYPE(name, node) \
|
|
|
923 pushdecl (build_decl (input_location, \
|
|
|
924 TYPE_DECL, get_identifier (name), node))
|
|
|
925
|
|
|
926 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
|
|
|
927 {
|
|
|
928 type = gfc_build_int_type (&gfc_integer_kinds[index]);
|
|
|
929 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
|
|
|
930 if (TYPE_STRING_FLAG (type))
|
|
|
931 type = make_signed_type (gfc_integer_kinds[index].bit_size);
|
|
|
932 gfc_integer_types[index] = type;
|
|
|
933 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
|
|
|
934 gfc_integer_kinds[index].kind);
|
|
|
935 PUSH_TYPE (name_buf, type);
|
|
|
936 }
|
|
|
937
|
|
|
938 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
|
|
|
939 {
|
|
|
940 type = gfc_build_logical_type (&gfc_logical_kinds[index]);
|
|
|
941 gfc_logical_types[index] = type;
|
|
|
942 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
|
|
|
943 gfc_logical_kinds[index].kind);
|
|
|
944 PUSH_TYPE (name_buf, type);
|
|
|
945 }
|
|
|
946
|
|
|
947 for (index = 0; gfc_real_kinds[index].kind != 0; index++)
|
|
|
948 {
|
|
|
949 type = gfc_build_real_type (&gfc_real_kinds[index]);
|
|
|
950 gfc_real_types[index] = type;
|
|
|
951 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
|
|
|
952 gfc_real_kinds[index].kind);
|
|
|
953 PUSH_TYPE (name_buf, type);
|
|
|
954
|
|
|
955 if (gfc_real_kinds[index].c_float128)
|
|
|
956 gfc_float128_type_node = type;
|
|
|
957
|
|
|
958 type = gfc_build_complex_type (type);
|
|
|
959 gfc_complex_types[index] = type;
|
|
|
960 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
|
|
|
961 gfc_real_kinds[index].kind);
|
|
|
962 PUSH_TYPE (name_buf, type);
|
|
|
963
|
|
|
964 if (gfc_real_kinds[index].c_float128)
|
|
|
965 gfc_complex_float128_type_node = type;
|
|
|
966 }
|
|
|
967
|
|
|
968 for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
|
|
|
969 {
|
|
|
970 type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
|
|
|
971 type = build_qualified_type (type, TYPE_UNQUALIFIED);
|
|
|
972 snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
|
|
|
973 gfc_character_kinds[index].kind);
|
|
|
974 PUSH_TYPE (name_buf, type);
|
|
|
975 gfc_character_types[index] = type;
|
|
|
976 gfc_pcharacter_types[index] = build_pointer_type (type);
|
|
|
977 }
|
|
|
978 gfc_character1_type_node = gfc_character_types[0];
|
|
|
979
|
|
|
980 PUSH_TYPE ("byte", unsigned_char_type_node);
|
|
|
981 PUSH_TYPE ("void", void_type_node);
|
|
|
982
|
|
|
983 /* DBX debugging output gets upset if these aren't set. */
|
|
|
984 if (!TYPE_NAME (integer_type_node))
|
|
|
985 PUSH_TYPE ("c_integer", integer_type_node);
|
|
|
986 if (!TYPE_NAME (char_type_node))
|
|
|
987 PUSH_TYPE ("c_char", char_type_node);
|
|
|
988
|
|
|
989 #undef PUSH_TYPE
|
|
|
990
|
|
|
991 pvoid_type_node = build_pointer_type (void_type_node);
|
|
|
992 prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
|
|
|
993 ppvoid_type_node = build_pointer_type (pvoid_type_node);
|
|
|
994 pchar_type_node = build_pointer_type (gfc_character1_type_node);
|
|
|
995 pfunc_type_node
|
|
|
996 = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
|
|
|
997
|
|
|
998 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
|
|
|
999 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
|
|
|
1000 since this function is called before gfc_init_constants. */
|
|
|
1001 gfc_array_range_type
|
|
|
1002 = build_range_type (gfc_array_index_type,
|
|
|
1003 build_int_cst (gfc_array_index_type, 0),
|
|
|
1004 NULL_TREE);
|
|
|
1005
|
|
|
1006 /* The maximum array element size that can be handled is determined
|
|
|
1007 by the number of bits available to store this field in the array
|
|
|
1008 descriptor. */
|
|
|
1009
|
|
131
|
1010 n = TYPE_PRECISION (size_type_node);
|
|
111
|
1011 gfc_max_array_element_size
|
|
|
1012 = wide_int_to_tree (size_type_node,
|
|
|
1013 wi::mask (n, UNSIGNED,
|
|
|
1014 TYPE_PRECISION (size_type_node)));
|
|
|
1015
|
|
131
|
1016 logical_type_node = gfc_get_logical_type (gfc_default_logical_kind);
|
|
|
1017 logical_true_node = build_int_cst (logical_type_node, 1);
|
|
|
1018 logical_false_node = build_int_cst (logical_type_node, 0);
|
|
|
1019
|
|
|
1020 /* Character lengths are of type size_t, except signed. */
|
|
|
1021 gfc_charlen_int_kind = get_int_kind_from_node (size_type_node);
|
|
111
|
1022 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
|
|
131
|
1023
|
|
|
1024 /* Fortran kind number of size_type_node (size_t). This is used for
|
|
|
1025 the _size member in vtables. */
|
|
|
1026 gfc_size_kind = get_int_kind_from_node (size_type_node);
|
|
111
|
1027 }
|
|
|
1028
|
|
|
1029 /* Get the type node for the given type and kind. */
|
|
|
1030
|
|
|
1031 tree
|
|
|
1032 gfc_get_int_type (int kind)
|
|
|
1033 {
|
|
|
1034 int index = gfc_validate_kind (BT_INTEGER, kind, true);
|
|
|
1035 return index < 0 ? 0 : gfc_integer_types[index];
|
|
|
1036 }
|
|
|
1037
|
|
|
1038 tree
|
|
|
1039 gfc_get_real_type (int kind)
|
|
|
1040 {
|
|
|
1041 int index = gfc_validate_kind (BT_REAL, kind, true);
|
|
|
1042 return index < 0 ? 0 : gfc_real_types[index];
|
|
|
1043 }
|
|
|
1044
|
|
|
1045 tree
|
|
|
1046 gfc_get_complex_type (int kind)
|
|
|
1047 {
|
|
|
1048 int index = gfc_validate_kind (BT_COMPLEX, kind, true);
|
|
|
1049 return index < 0 ? 0 : gfc_complex_types[index];
|
|
|
1050 }
|
|
|
1051
|
|
|
1052 tree
|
|
|
1053 gfc_get_logical_type (int kind)
|
|
|
1054 {
|
|
|
1055 int index = gfc_validate_kind (BT_LOGICAL, kind, true);
|
|
|
1056 return index < 0 ? 0 : gfc_logical_types[index];
|
|
|
1057 }
|
|
|
1058
|
|
|
1059 tree
|
|
|
1060 gfc_get_char_type (int kind)
|
|
|
1061 {
|
|
|
1062 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
|
|
|
1063 return index < 0 ? 0 : gfc_character_types[index];
|
|
|
1064 }
|
|
|
1065
|
|
|
1066 tree
|
|
|
1067 gfc_get_pchar_type (int kind)
|
|
|
1068 {
|
|
|
1069 int index = gfc_validate_kind (BT_CHARACTER, kind, true);
|
|
|
1070 return index < 0 ? 0 : gfc_pcharacter_types[index];
|
|
|
1071 }
|
|
|
1072
|
|
|
1073
|
|
|
1074 /* Create a character type with the given kind and length. */
|
|
|
1075
|
|
|
1076 tree
|
|
|
1077 gfc_get_character_type_len_for_eltype (tree eltype, tree len)
|
|
|
1078 {
|
|
|
1079 tree bounds, type;
|
|
|
1080
|
|
|
1081 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
|
|
|
1082 type = build_array_type (eltype, bounds);
|
|
|
1083 TYPE_STRING_FLAG (type) = 1;
|
|
|
1084
|
|
|
1085 return type;
|
|
|
1086 }
|
|
|
1087
|
|
|
1088 tree
|
|
|
1089 gfc_get_character_type_len (int kind, tree len)
|
|
|
1090 {
|
|
|
1091 gfc_validate_kind (BT_CHARACTER, kind, false);
|
|
|
1092 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
|
|
|
1093 }
|
|
|
1094
|
|
|
1095
|
|
|
1096 /* Get a type node for a character kind. */
|
|
|
1097
|
|
|
1098 tree
|
|
|
1099 gfc_get_character_type (int kind, gfc_charlen * cl)
|
|
|
1100 {
|
|
|
1101 tree len;
|
|
|
1102
|
|
|
1103 len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
|
|
|
1104 if (len && POINTER_TYPE_P (TREE_TYPE (len)))
|
|
|
1105 len = build_fold_indirect_ref (len);
|
|
|
1106
|
|
|
1107 return gfc_get_character_type_len (kind, len);
|
|
|
1108 }
|
|
|
1109
|
|
|
1110 /* Convert a basic type. This will be an array for character types. */
|
|
|
1111
|
|
|
1112 tree
|
|
|
1113 gfc_typenode_for_spec (gfc_typespec * spec, int codim)
|
|
|
1114 {
|
|
|
1115 tree basetype;
|
|
|
1116
|
|
|
1117 switch (spec->type)
|
|
|
1118 {
|
|
|
1119 case BT_UNKNOWN:
|
|
|
1120 gcc_unreachable ();
|
|
|
1121
|
|
|
1122 case BT_INTEGER:
|
|
|
1123 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
|
|
|
1124 has been resolved. This is done so we can convert C_PTR and
|
|
|
1125 C_FUNPTR to simple variables that get translated to (void *). */
|
|
|
1126 if (spec->f90_type == BT_VOID)
|
|
|
1127 {
|
|
|
1128 if (spec->u.derived
|
|
|
1129 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
|
|
|
1130 basetype = ptr_type_node;
|
|
|
1131 else
|
|
|
1132 basetype = pfunc_type_node;
|
|
|
1133 }
|
|
|
1134 else
|
|
|
1135 basetype = gfc_get_int_type (spec->kind);
|
|
|
1136 break;
|
|
|
1137
|
|
|
1138 case BT_REAL:
|
|
|
1139 basetype = gfc_get_real_type (spec->kind);
|
|
|
1140 break;
|
|
|
1141
|
|
|
1142 case BT_COMPLEX:
|
|
|
1143 basetype = gfc_get_complex_type (spec->kind);
|
|
|
1144 break;
|
|
|
1145
|
|
|
1146 case BT_LOGICAL:
|
|
|
1147 basetype = gfc_get_logical_type (spec->kind);
|
|
|
1148 break;
|
|
|
1149
|
|
|
1150 case BT_CHARACTER:
|
|
|
1151 basetype = gfc_get_character_type (spec->kind, spec->u.cl);
|
|
|
1152 break;
|
|
|
1153
|
|
|
1154 case BT_HOLLERITH:
|
|
|
1155 /* Since this cannot be used, return a length one character. */
|
|
|
1156 basetype = gfc_get_character_type_len (gfc_default_character_kind,
|
|
|
1157 gfc_index_one_node);
|
|
|
1158 break;
|
|
|
1159
|
|
|
1160 case BT_UNION:
|
|
|
1161 basetype = gfc_get_union_type (spec->u.derived);
|
|
|
1162 break;
|
|
|
1163
|
|
|
1164 case BT_DERIVED:
|
|
|
1165 case BT_CLASS:
|
|
|
1166 basetype = gfc_get_derived_type (spec->u.derived, codim);
|
|
|
1167
|
|
|
1168 if (spec->type == BT_CLASS)
|
|
|
1169 GFC_CLASS_TYPE_P (basetype) = 1;
|
|
|
1170
|
|
|
1171 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
|
|
|
1172 type and kind to fit a (void *) and the basetype returned was a
|
|
|
1173 ptr_type_node. We need to pass up this new information to the
|
|
|
1174 symbol that was declared of type C_PTR or C_FUNPTR. */
|
|
|
1175 if (spec->u.derived->ts.f90_type == BT_VOID)
|
|
|
1176 {
|
|
|
1177 spec->type = BT_INTEGER;
|
|
|
1178 spec->kind = gfc_index_integer_kind;
|
|
145
|
1179 spec->f90_type = BT_VOID;
|
|
|
1180 spec->is_c_interop = 1; /* Mark as escaping later. */
|
|
111
|
1181 }
|
|
|
1182 break;
|
|
|
1183 case BT_VOID:
|
|
|
1184 case BT_ASSUMED:
|
|
|
1185 /* This is for the second arg to c_f_pointer and c_f_procpointer
|
|
|
1186 of the iso_c_binding module, to accept any ptr type. */
|
|
|
1187 basetype = ptr_type_node;
|
|
|
1188 if (spec->f90_type == BT_VOID)
|
|
|
1189 {
|
|
|
1190 if (spec->u.derived
|
|
|
1191 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
|
|
|
1192 basetype = ptr_type_node;
|
|
|
1193 else
|
|
|
1194 basetype = pfunc_type_node;
|
|
|
1195 }
|
|
|
1196 break;
|
|
145
|
1197 case BT_PROCEDURE:
|
|
|
1198 basetype = pfunc_type_node;
|
|
|
1199 break;
|
|
111
|
1200 default:
|
|
|
1201 gcc_unreachable ();
|
|
|
1202 }
|
|
|
1203 return basetype;
|
|
|
1204 }
|
|
|
1205
|
|
|
1206 /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */
|
|
|
1207
|
|
|
1208 static tree
|
|
|
1209 gfc_conv_array_bound (gfc_expr * expr)
|
|
|
1210 {
|
|
|
1211 /* If expr is an integer constant, return that. */
|
|
|
1212 if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
|
|
|
1213 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
|
|
|
1214
|
|
|
1215 /* Otherwise return NULL. */
|
|
|
1216 return NULL_TREE;
|
|
|
1217 }
|
|
|
1218
|
|
|
1219 /* Return the type of an element of the array. Note that scalar coarrays
|
|
|
1220 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
|
|
|
1221 (with POINTER_TYPE stripped) is returned. */
|
|
|
1222
|
|
|
1223 tree
|
|
|
1224 gfc_get_element_type (tree type)
|
|
|
1225 {
|
|
|
1226 tree element;
|
|
|
1227
|
|
|
1228 if (GFC_ARRAY_TYPE_P (type))
|
|
|
1229 {
|
|
|
1230 if (TREE_CODE (type) == POINTER_TYPE)
|
|
|
1231 type = TREE_TYPE (type);
|
|
|
1232 if (GFC_TYPE_ARRAY_RANK (type) == 0)
|
|
|
1233 {
|
|
|
1234 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
|
|
|
1235 element = type;
|
|
|
1236 }
|
|
|
1237 else
|
|
|
1238 {
|
|
|
1239 gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
|
|
|
1240 element = TREE_TYPE (type);
|
|
|
1241 }
|
|
|
1242 }
|
|
|
1243 else
|
|
|
1244 {
|
|
|
1245 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
|
|
1246 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
|
|
|
1247
|
|
|
1248 gcc_assert (TREE_CODE (element) == POINTER_TYPE);
|
|
|
1249 element = TREE_TYPE (element);
|
|
|
1250
|
|
|
1251 /* For arrays, which are not scalar coarrays. */
|
|
|
1252 if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
|
|
|
1253 element = TREE_TYPE (element);
|
|
|
1254 }
|
|
|
1255
|
|
|
1256 return element;
|
|
|
1257 }
|
|
|
1258
|
|
|
1259 /* Build an array. This function is called from gfc_sym_type().
|
|
|
1260 Actually returns array descriptor type.
|
|
|
1261
|
|
|
1262 Format of array descriptors is as follows:
|
|
|
1263
|
|
|
1264 struct gfc_array_descriptor
|
|
|
1265 {
|
|
131
|
1266 array *data;
|
|
111
|
1267 index offset;
|
|
131
|
1268 struct dtype_type dtype;
|
|
111
|
1269 struct descriptor_dimension dimension[N_DIM];
|
|
|
1270 }
|
|
|
1271
|
|
131
|
1272 struct dtype_type
|
|
|
1273 {
|
|
|
1274 size_t elem_len;
|
|
|
1275 int version;
|
|
|
1276 signed char rank;
|
|
|
1277 signed char type;
|
|
|
1278 signed short attribute;
|
|
|
1279 }
|
|
|
1280
|
|
111
|
1281 struct descriptor_dimension
|
|
|
1282 {
|
|
|
1283 index stride;
|
|
|
1284 index lbound;
|
|
|
1285 index ubound;
|
|
|
1286 }
|
|
|
1287
|
|
|
1288 Translation code should use gfc_conv_descriptor_* rather than
|
|
|
1289 accessing the descriptor directly. Any changes to the array
|
|
|
1290 descriptor type will require changes in gfc_conv_descriptor_* and
|
|
|
1291 gfc_build_array_initializer.
|
|
|
1292
|
|
|
1293 This is represented internally as a RECORD_TYPE. The index nodes
|
|
|
1294 are gfc_array_index_type and the data node is a pointer to the
|
|
|
1295 data. See below for the handling of character types.
|
|
|
1296
|
|
|
1297 I originally used nested ARRAY_TYPE nodes to represent arrays, but
|
|
|
1298 this generated poor code for assumed/deferred size arrays. These
|
|
|
1299 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
|
|
|
1300 of the GENERIC grammar. Also, there is no way to explicitly set
|
|
|
1301 the array stride, so all data must be packed(1). I've tried to
|
|
|
1302 mark all the functions which would require modification with a GCC
|
|
|
1303 ARRAYS comment.
|
|
|
1304
|
|
|
1305 The data component points to the first element in the array. The
|
|
|
1306 offset field is the position of the origin of the array (i.e. element
|
|
|
1307 (0, 0 ...)). This may be outside the bounds of the array.
|
|
|
1308
|
|
|
1309 An element is accessed by
|
|
|
1310 data[offset + index0*stride0 + index1*stride1 + index2*stride2]
|
|
|
1311 This gives good performance as the computation does not involve the
|
|
|
1312 bounds of the array. For packed arrays, this is optimized further
|
|
|
1313 by substituting the known strides.
|
|
|
1314
|
|
|
1315 This system has one problem: all array bounds must be within 2^31
|
|
|
1316 elements of the origin (2^63 on 64-bit machines). For example
|
|
|
1317 integer, dimension (80000:90000, 80000:90000, 2) :: array
|
|
|
1318 may not work properly on 32-bit machines because 80000*80000 >
|
|
|
1319 2^31, so the calculation for stride2 would overflow. This may
|
|
|
1320 still work, but I haven't checked, and it relies on the overflow
|
|
|
1321 doing the right thing.
|
|
|
1322
|
|
|
1323 The way to fix this problem is to access elements as follows:
|
|
|
1324 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
|
|
|
1325 Obviously this is much slower. I will make this a compile time
|
|
|
1326 option, something like -fsmall-array-offsets. Mixing code compiled
|
|
|
1327 with and without this switch will work.
|
|
|
1328
|
|
|
1329 (1) This can be worked around by modifying the upper bound of the
|
|
|
1330 previous dimension. This requires extra fields in the descriptor
|
|
|
1331 (both real_ubound and fake_ubound). */
|
|
|
1332
|
|
|
1333
|
|
|
1334 /* Returns true if the array sym does not require a descriptor. */
|
|
|
1335
|
|
|
1336 int
|
|
|
1337 gfc_is_nodesc_array (gfc_symbol * sym)
|
|
|
1338 {
|
|
|
1339 symbol_attribute *array_attr;
|
|
|
1340 gfc_array_spec *as;
|
|
|
1341 bool is_classarray = IS_CLASS_ARRAY (sym);
|
|
|
1342
|
|
|
1343 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
|
|
|
1344 as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
|
|
|
1345
|
|
|
1346 gcc_assert (array_attr->dimension || array_attr->codimension);
|
|
|
1347
|
|
|
1348 /* We only want local arrays. */
|
|
|
1349 if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
|
|
|
1350 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
|
|
|
1351 || array_attr->allocatable)
|
|
|
1352 return 0;
|
|
|
1353
|
|
|
1354 /* We want a descriptor for associate-name arrays that do not have an
|
|
|
1355 explicitly known shape already. */
|
|
|
1356 if (sym->assoc && as->type != AS_EXPLICIT)
|
|
|
1357 return 0;
|
|
|
1358
|
|
|
1359 /* The dummy is stored in sym and not in the component. */
|
|
|
1360 if (sym->attr.dummy)
|
|
|
1361 return as->type != AS_ASSUMED_SHAPE
|
|
|
1362 && as->type != AS_ASSUMED_RANK;
|
|
|
1363
|
|
|
1364 if (sym->attr.result || sym->attr.function)
|
|
|
1365 return 0;
|
|
|
1366
|
|
|
1367 gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
|
|
|
1368
|
|
|
1369 return 1;
|
|
|
1370 }
|
|
|
1371
|
|
|
1372
|
|
|
1373 /* Create an array descriptor type. */
|
|
|
1374
|
|
|
1375 static tree
|
|
|
1376 gfc_build_array_type (tree type, gfc_array_spec * as,
|
|
|
1377 enum gfc_array_kind akind, bool restricted,
|
|
|
1378 bool contiguous, int codim)
|
|
|
1379 {
|
|
|
1380 tree lbound[GFC_MAX_DIMENSIONS];
|
|
|
1381 tree ubound[GFC_MAX_DIMENSIONS];
|
|
|
1382 int n, corank;
|
|
|
1383
|
|
|
1384 /* Assumed-shape arrays do not have codimension information stored in the
|
|
|
1385 descriptor. */
|
|
|
1386 corank = MAX (as->corank, codim);
|
|
|
1387 if (as->type == AS_ASSUMED_SHAPE ||
|
|
|
1388 (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
|
|
|
1389 corank = codim;
|
|
|
1390
|
|
|
1391 if (as->type == AS_ASSUMED_RANK)
|
|
|
1392 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
|
|
|
1393 {
|
|
|
1394 lbound[n] = NULL_TREE;
|
|
|
1395 ubound[n] = NULL_TREE;
|
|
|
1396 }
|
|
|
1397
|
|
|
1398 for (n = 0; n < as->rank; n++)
|
|
|
1399 {
|
|
|
1400 /* Create expressions for the known bounds of the array. */
|
|
|
1401 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
|
|
|
1402 lbound[n] = gfc_index_one_node;
|
|
|
1403 else
|
|
|
1404 lbound[n] = gfc_conv_array_bound (as->lower[n]);
|
|
|
1405 ubound[n] = gfc_conv_array_bound (as->upper[n]);
|
|
|
1406 }
|
|
|
1407
|
|
|
1408 for (n = as->rank; n < as->rank + corank; n++)
|
|
|
1409 {
|
|
|
1410 if (as->type != AS_DEFERRED && as->lower[n] == NULL)
|
|
|
1411 lbound[n] = gfc_index_one_node;
|
|
|
1412 else
|
|
|
1413 lbound[n] = gfc_conv_array_bound (as->lower[n]);
|
|
|
1414
|
|
|
1415 if (n < as->rank + corank - 1)
|
|
|
1416 ubound[n] = gfc_conv_array_bound (as->upper[n]);
|
|
|
1417 }
|
|
|
1418
|
|
|
1419 if (as->type == AS_ASSUMED_SHAPE)
|
|
|
1420 akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
|
|
|
1421 : GFC_ARRAY_ASSUMED_SHAPE;
|
|
|
1422 else if (as->type == AS_ASSUMED_RANK)
|
|
|
1423 akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
|
|
|
1424 : GFC_ARRAY_ASSUMED_RANK;
|
|
|
1425 return gfc_get_array_type_bounds (type, as->rank == -1
|
|
|
1426 ? GFC_MAX_DIMENSIONS : as->rank,
|
|
|
1427 corank, lbound, ubound, 0, akind,
|
|
|
1428 restricted);
|
|
|
1429 }
|
|
|
1430
|
|
|
1431 /* Returns the struct descriptor_dimension type. */
|
|
|
1432
|
|
|
1433 static tree
|
|
|
1434 gfc_get_desc_dim_type (void)
|
|
|
1435 {
|
|
|
1436 tree type;
|
|
|
1437 tree decl, *chain = NULL;
|
|
|
1438
|
|
|
1439 if (gfc_desc_dim_type)
|
|
|
1440 return gfc_desc_dim_type;
|
|
|
1441
|
|
|
1442 /* Build the type node. */
|
|
|
1443 type = make_node (RECORD_TYPE);
|
|
|
1444
|
|
|
1445 TYPE_NAME (type) = get_identifier ("descriptor_dimension");
|
|
|
1446 TYPE_PACKED (type) = 1;
|
|
|
1447
|
|
|
1448 /* Consists of the stride, lbound and ubound members. */
|
|
|
1449 decl = gfc_add_field_to_struct_1 (type,
|
|
|
1450 get_identifier ("stride"),
|
|
|
1451 gfc_array_index_type, &chain);
|
|
|
1452 TREE_NO_WARNING (decl) = 1;
|
|
|
1453
|
|
|
1454 decl = gfc_add_field_to_struct_1 (type,
|
|
|
1455 get_identifier ("lbound"),
|
|
|
1456 gfc_array_index_type, &chain);
|
|
|
1457 TREE_NO_WARNING (decl) = 1;
|
|
|
1458
|
|
|
1459 decl = gfc_add_field_to_struct_1 (type,
|
|
|
1460 get_identifier ("ubound"),
|
|
|
1461 gfc_array_index_type, &chain);
|
|
|
1462 TREE_NO_WARNING (decl) = 1;
|
|
|
1463
|
|
|
1464 /* Finish off the type. */
|
|
|
1465 gfc_finish_type (type);
|
|
|
1466 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
|
|
|
1467
|
|
|
1468 gfc_desc_dim_type = type;
|
|
|
1469 return type;
|
|
|
1470 }
|
|
|
1471
|
|
|
1472
|
|
|
1473 /* Return the DTYPE for an array. This describes the type and type parameters
|
|
|
1474 of the array. */
|
|
|
1475 /* TODO: Only call this when the value is actually used, and make all the
|
|
|
1476 unknown cases abort. */
|
|
|
1477
|
|
|
1478 tree
|
|
|
1479 gfc_get_dtype_rank_type (int rank, tree etype)
|
|
|
1480 {
|
|
|
1481 tree size;
|
|
|
1482 int n;
|
|
|
1483 tree tmp;
|
|
|
1484 tree dtype;
|
|
131
|
1485 tree field;
|
|
|
1486 vec<constructor_elt, va_gc> *v = NULL;
|
|
|
1487
|
|
|
1488 size = TYPE_SIZE_UNIT (etype);
|
|
111
|
1489
|
|
|
1490 switch (TREE_CODE (etype))
|
|
|
1491 {
|
|
|
1492 case INTEGER_TYPE:
|
|
|
1493 n = BT_INTEGER;
|
|
|
1494 break;
|
|
|
1495
|
|
|
1496 case BOOLEAN_TYPE:
|
|
|
1497 n = BT_LOGICAL;
|
|
|
1498 break;
|
|
|
1499
|
|
|
1500 case REAL_TYPE:
|
|
|
1501 n = BT_REAL;
|
|
|
1502 break;
|
|
|
1503
|
|
|
1504 case COMPLEX_TYPE:
|
|
|
1505 n = BT_COMPLEX;
|
|
|
1506 break;
|
|
|
1507
|
|
131
|
1508 case RECORD_TYPE:
|
|
|
1509 if (GFC_CLASS_TYPE_P (etype))
|
|
|
1510 n = BT_CLASS;
|
|
|
1511 else
|
|
|
1512 n = BT_DERIVED;
|
|
|
1513 break;
|
|
|
1514
|
|
111
|
1515 /* We will never have arrays of arrays. */
|
|
|
1516 case ARRAY_TYPE:
|
|
|
1517 n = BT_CHARACTER;
|
|
131
|
1518 if (size == NULL_TREE)
|
|
|
1519 size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
|
|
111
|
1520 break;
|
|
|
1521
|
|
|
1522 case POINTER_TYPE:
|
|
|
1523 n = BT_ASSUMED;
|
|
131
|
1524 if (TREE_CODE (TREE_TYPE (etype)) != VOID_TYPE)
|
|
|
1525 size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
|
|
|
1526 else
|
|
|
1527 size = build_int_cst (size_type_node, 0);
|
|
|
1528 break;
|
|
111
|
1529
|
|
|
1530 default:
|
|
|
1531 /* TODO: Don't do dtype for temporary descriptorless arrays. */
|
|
131
|
1532 /* We can encounter strange array types for temporary arrays. */
|
|
111
|
1533 return gfc_index_zero_node;
|
|
|
1534 }
|
|
|
1535
|
|
131
|
1536 tmp = get_dtype_type_node ();
|
|
|
1537 field = gfc_advance_chain (TYPE_FIELDS (tmp),
|
|
|
1538 GFC_DTYPE_ELEM_LEN);
|
|
|
1539 CONSTRUCTOR_APPEND_ELT (v, field,
|
|
|
1540 fold_convert (TREE_TYPE (field), size));
|
|
|
1541
|
|
|
1542 field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
|
|
|
1543 GFC_DTYPE_RANK);
|
|
|
1544 CONSTRUCTOR_APPEND_ELT (v, field,
|
|
|
1545 build_int_cst (TREE_TYPE (field), rank));
|
|
|
1546
|
|
|
1547 field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
|
|
|
1548 GFC_DTYPE_TYPE);
|
|
|
1549 CONSTRUCTOR_APPEND_ELT (v, field,
|
|
|
1550 build_int_cst (TREE_TYPE (field), n));
|
|
|
1551
|
|
|
1552 dtype = build_constructor (tmp, v);
|
|
111
|
1553
|
|
|
1554 return dtype;
|
|
|
1555 }
|
|
|
1556
|
|
|
1557
|
|
|
1558 tree
|
|
|
1559 gfc_get_dtype (tree type)
|
|
|
1560 {
|
|
|
1561 tree dtype;
|
|
|
1562 tree etype;
|
|
|
1563 int rank;
|
|
|
1564
|
|
|
1565 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
|
|
|
1566
|
|
|
1567 rank = GFC_TYPE_ARRAY_RANK (type);
|
|
|
1568 etype = gfc_get_element_type (type);
|
|
|
1569 dtype = gfc_get_dtype_rank_type (rank, etype);
|
|
|
1570
|
|
|
1571 GFC_TYPE_ARRAY_DTYPE (type) = dtype;
|
|
|
1572 return dtype;
|
|
|
1573 }
|
|
|
1574
|
|
|
1575
|
|
|
1576 /* Build an array type for use without a descriptor, packed according
|
|
|
1577 to the value of PACKED. */
|
|
|
1578
|
|
|
1579 tree
|
|
|
1580 gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
|
|
|
1581 bool restricted)
|
|
|
1582 {
|
|
|
1583 tree range;
|
|
|
1584 tree type;
|
|
|
1585 tree tmp;
|
|
|
1586 int n;
|
|
|
1587 int known_stride;
|
|
|
1588 int known_offset;
|
|
|
1589 mpz_t offset;
|
|
|
1590 mpz_t stride;
|
|
|
1591 mpz_t delta;
|
|
|
1592 gfc_expr *expr;
|
|
|
1593
|
|
|
1594 mpz_init_set_ui (offset, 0);
|
|
|
1595 mpz_init_set_ui (stride, 1);
|
|
|
1596 mpz_init (delta);
|
|
|
1597
|
|
|
1598 /* We don't use build_array_type because this does not include include
|
|
|
1599 lang-specific information (i.e. the bounds of the array) when checking
|
|
|
1600 for duplicates. */
|
|
|
1601 if (as->rank)
|
|
|
1602 type = make_node (ARRAY_TYPE);
|
|
|
1603 else
|
|
|
1604 type = build_variant_type_copy (etype);
|
|
|
1605
|
|
|
1606 GFC_ARRAY_TYPE_P (type) = 1;
|
|
|
1607 TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
|
|
|
1608
|
|
|
1609 known_stride = (packed != PACKED_NO);
|
|
|
1610 known_offset = 1;
|
|
|
1611 for (n = 0; n < as->rank; n++)
|
|
|
1612 {
|
|
|
1613 /* Fill in the stride and bound components of the type. */
|
|
|
1614 if (known_stride)
|
|
|
1615 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
|
|
|
1616 else
|
|
|
1617 tmp = NULL_TREE;
|
|
|
1618 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
|
|
|
1619
|
|
|
1620 expr = as->lower[n];
|
|
|
1621 if (expr->expr_type == EXPR_CONSTANT)
|
|
|
1622 {
|
|
|
1623 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
|
|
|
1624 gfc_index_integer_kind);
|
|
|
1625 }
|
|
|
1626 else
|
|
|
1627 {
|
|
|
1628 known_stride = 0;
|
|
|
1629 tmp = NULL_TREE;
|
|
|
1630 }
|
|
|
1631 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
|
|
|
1632
|
|
|
1633 if (known_stride)
|
|
|
1634 {
|
|
|
1635 /* Calculate the offset. */
|
|
|
1636 mpz_mul (delta, stride, as->lower[n]->value.integer);
|
|
|
1637 mpz_sub (offset, offset, delta);
|
|
|
1638 }
|
|
|
1639 else
|
|
|
1640 known_offset = 0;
|
|
|
1641
|
|
|
1642 expr = as->upper[n];
|
|
|
1643 if (expr && expr->expr_type == EXPR_CONSTANT)
|
|
|
1644 {
|
|
|
1645 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
|
|
|
1646 gfc_index_integer_kind);
|
|
|
1647 }
|
|
|
1648 else
|
|
|
1649 {
|
|
|
1650 tmp = NULL_TREE;
|
|
|
1651 known_stride = 0;
|
|
|
1652 }
|
|
|
1653 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
|
|
|
1654
|
|
|
1655 if (known_stride)
|
|
|
1656 {
|
|
|
1657 /* Calculate the stride. */
|
|
|
1658 mpz_sub (delta, as->upper[n]->value.integer,
|
|
|
1659 as->lower[n]->value.integer);
|
|
|
1660 mpz_add_ui (delta, delta, 1);
|
|
|
1661 mpz_mul (stride, stride, delta);
|
|
|
1662 }
|
|
|
1663
|
|
|
1664 /* Only the first stride is known for partial packed arrays. */
|
|
|
1665 if (packed == PACKED_NO || packed == PACKED_PARTIAL)
|
|
|
1666 known_stride = 0;
|
|
|
1667 }
|
|
|
1668 for (n = as->rank; n < as->rank + as->corank; n++)
|
|
|
1669 {
|
|
|
1670 expr = as->lower[n];
|
|
|
1671 if (expr->expr_type == EXPR_CONSTANT)
|
|
|
1672 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
|
|
|
1673 gfc_index_integer_kind);
|
|
|
1674 else
|
|
|
1675 tmp = NULL_TREE;
|
|
|
1676 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
|
|
|
1677
|
|
|
1678 expr = as->upper[n];
|
|
|
1679 if (expr && expr->expr_type == EXPR_CONSTANT)
|
|
|
1680 tmp = gfc_conv_mpz_to_tree (expr->value.integer,
|
|
|
1681 gfc_index_integer_kind);
|
|
|
1682 else
|
|
|
1683 tmp = NULL_TREE;
|
|
|
1684 if (n < as->rank + as->corank - 1)
|
|
|
1685 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
|
|
|
1686 }
|
|
|
1687
|
|
|
1688 if (known_offset)
|
|
|
1689 {
|
|
|
1690 GFC_TYPE_ARRAY_OFFSET (type) =
|
|
|
1691 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
|
|
|
1692 }
|
|
|
1693 else
|
|
|
1694 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
|
|
|
1695
|
|
|
1696 if (known_stride)
|
|
|
1697 {
|
|
|
1698 GFC_TYPE_ARRAY_SIZE (type) =
|
|
|
1699 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
|
|
|
1700 }
|
|
|
1701 else
|
|
|
1702 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
|
|
|
1703
|
|
|
1704 GFC_TYPE_ARRAY_RANK (type) = as->rank;
|
|
|
1705 GFC_TYPE_ARRAY_CORANK (type) = as->corank;
|
|
|
1706 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
|
|
|
1707 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
|
|
|
1708 NULL_TREE);
|
|
|
1709 /* TODO: use main type if it is unbounded. */
|
|
|
1710 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
|
|
|
1711 build_pointer_type (build_array_type (etype, range));
|
|
|
1712 if (restricted)
|
|
|
1713 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
|
|
|
1714 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
|
|
|
1715 TYPE_QUAL_RESTRICT);
|
|
|
1716
|
|
|
1717 if (as->rank == 0)
|
|
|
1718 {
|
|
|
1719 if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB)
|
|
|
1720 {
|
|
|
1721 type = build_pointer_type (type);
|
|
|
1722
|
|
|
1723 if (restricted)
|
|
|
1724 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
|
|
1725
|
|
|
1726 GFC_ARRAY_TYPE_P (type) = 1;
|
|
|
1727 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
|
|
|
1728 }
|
|
|
1729
|
|
|
1730 return type;
|
|
|
1731 }
|
|
|
1732
|
|
|
1733 if (known_stride)
|
|
|
1734 {
|
|
|
1735 mpz_sub_ui (stride, stride, 1);
|
|
|
1736 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
|
|
|
1737 }
|
|
|
1738 else
|
|
|
1739 range = NULL_TREE;
|
|
|
1740
|
|
|
1741 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
|
|
|
1742 TYPE_DOMAIN (type) = range;
|
|
|
1743
|
|
|
1744 build_pointer_type (etype);
|
|
|
1745 TREE_TYPE (type) = etype;
|
|
|
1746
|
|
|
1747 layout_type (type);
|
|
|
1748
|
|
|
1749 mpz_clear (offset);
|
|
|
1750 mpz_clear (stride);
|
|
|
1751 mpz_clear (delta);
|
|
|
1752
|
|
|
1753 /* Represent packed arrays as multi-dimensional if they have rank >
|
|
|
1754 1 and with proper bounds, instead of flat arrays. This makes for
|
|
|
1755 better debug info. */
|
|
|
1756 if (known_offset)
|
|
|
1757 {
|
|
|
1758 tree gtype = etype, rtype, type_decl;
|
|
|
1759
|
|
|
1760 for (n = as->rank - 1; n >= 0; n--)
|
|
|
1761 {
|
|
|
1762 rtype = build_range_type (gfc_array_index_type,
|
|
|
1763 GFC_TYPE_ARRAY_LBOUND (type, n),
|
|
|
1764 GFC_TYPE_ARRAY_UBOUND (type, n));
|
|
|
1765 gtype = build_array_type (gtype, rtype);
|
|
|
1766 }
|
|
|
1767 TYPE_NAME (type) = type_decl = build_decl (input_location,
|
|
|
1768 TYPE_DECL, NULL, gtype);
|
|
|
1769 DECL_ORIGINAL_TYPE (type_decl) = gtype;
|
|
|
1770 }
|
|
|
1771
|
|
|
1772 if (packed != PACKED_STATIC || !known_stride
|
|
|
1773 || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
|
|
|
1774 {
|
|
|
1775 /* For dummy arrays and automatic (heap allocated) arrays we
|
|
|
1776 want a pointer to the array. */
|
|
|
1777 type = build_pointer_type (type);
|
|
|
1778 if (restricted)
|
|
|
1779 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
|
|
1780 GFC_ARRAY_TYPE_P (type) = 1;
|
|
|
1781 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
|
|
|
1782 }
|
|
|
1783 return type;
|
|
|
1784 }
|
|
|
1785
|
|
|
1786
|
|
|
1787 /* Return or create the base type for an array descriptor. */
|
|
|
1788
|
|
|
1789 static tree
|
|
|
1790 gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
|
|
|
1791 {
|
|
|
1792 tree fat_type, decl, arraytype, *chain = NULL;
|
|
|
1793 char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
|
|
|
1794 int idx;
|
|
|
1795
|
|
|
1796 /* Assumed-rank array. */
|
|
|
1797 if (dimen == -1)
|
|
|
1798 dimen = GFC_MAX_DIMENSIONS;
|
|
|
1799
|
|
|
1800 idx = 2 * (codimen + dimen) + restricted;
|
|
|
1801
|
|
|
1802 gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
|
|
|
1803
|
|
|
1804 if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
|
|
|
1805 {
|
|
|
1806 if (gfc_array_descriptor_base_caf[idx])
|
|
|
1807 return gfc_array_descriptor_base_caf[idx];
|
|
|
1808 }
|
|
|
1809 else if (gfc_array_descriptor_base[idx])
|
|
|
1810 return gfc_array_descriptor_base[idx];
|
|
|
1811
|
|
|
1812 /* Build the type node. */
|
|
|
1813 fat_type = make_node (RECORD_TYPE);
|
|
|
1814
|
|
|
1815 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
|
|
|
1816 TYPE_NAME (fat_type) = get_identifier (name);
|
|
|
1817 TYPE_NAMELESS (fat_type) = 1;
|
|
|
1818
|
|
|
1819 /* Add the data member as the first element of the descriptor. */
|
|
145
|
1820 gfc_add_field_to_struct_1 (fat_type,
|
|
|
1821 get_identifier ("data"),
|
|
|
1822 (restricted
|
|
|
1823 ? prvoid_type_node
|
|
|
1824 : ptr_type_node), &chain);
|
|
111
|
1825
|
|
|
1826 /* Add the base component. */
|
|
|
1827 decl = gfc_add_field_to_struct_1 (fat_type,
|
|
|
1828 get_identifier ("offset"),
|
|
|
1829 gfc_array_index_type, &chain);
|
|
|
1830 TREE_NO_WARNING (decl) = 1;
|
|
|
1831
|
|
|
1832 /* Add the dtype component. */
|
|
|
1833 decl = gfc_add_field_to_struct_1 (fat_type,
|
|
|
1834 get_identifier ("dtype"),
|
|
131
|
1835 get_dtype_type_node (), &chain);
|
|
111
|
1836 TREE_NO_WARNING (decl) = 1;
|
|
|
1837
|
|
|
1838 /* Add the span component. */
|
|
|
1839 decl = gfc_add_field_to_struct_1 (fat_type,
|
|
|
1840 get_identifier ("span"),
|
|
|
1841 gfc_array_index_type, &chain);
|
|
|
1842 TREE_NO_WARNING (decl) = 1;
|
|
|
1843
|
|
|
1844 /* Build the array type for the stride and bound components. */
|
|
|
1845 if (dimen + codimen > 0)
|
|
|
1846 {
|
|
|
1847 arraytype =
|
|
|
1848 build_array_type (gfc_get_desc_dim_type (),
|
|
|
1849 build_range_type (gfc_array_index_type,
|
|
|
1850 gfc_index_zero_node,
|
|
|
1851 gfc_rank_cst[codimen + dimen - 1]));
|
|
|
1852
|
|
|
1853 decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
|
|
|
1854 arraytype, &chain);
|
|
|
1855 TREE_NO_WARNING (decl) = 1;
|
|
|
1856 }
|
|
|
1857
|
|
131
|
1858 if (flag_coarray == GFC_FCOARRAY_LIB)
|
|
111
|
1859 {
|
|
|
1860 decl = gfc_add_field_to_struct_1 (fat_type,
|
|
|
1861 get_identifier ("token"),
|
|
|
1862 prvoid_type_node, &chain);
|
|
|
1863 TREE_NO_WARNING (decl) = 1;
|
|
|
1864 }
|
|
|
1865
|
|
|
1866 /* Finish off the type. */
|
|
|
1867 gfc_finish_type (fat_type);
|
|
|
1868 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
|
|
|
1869
|
|
|
1870 if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
|
|
|
1871 gfc_array_descriptor_base_caf[idx] = fat_type;
|
|
|
1872 else
|
|
|
1873 gfc_array_descriptor_base[idx] = fat_type;
|
|
|
1874
|
|
|
1875 return fat_type;
|
|
|
1876 }
|
|
|
1877
|
|
|
1878
|
|
|
1879 /* Build an array (descriptor) type with given bounds. */
|
|
|
1880
|
|
|
1881 tree
|
|
|
1882 gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
|
|
|
1883 tree * ubound, int packed,
|
|
|
1884 enum gfc_array_kind akind, bool restricted)
|
|
|
1885 {
|
|
|
1886 char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
|
|
|
1887 tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
|
|
|
1888 const char *type_name;
|
|
|
1889 int n;
|
|
|
1890
|
|
|
1891 base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
|
|
|
1892 fat_type = build_distinct_type_copy (base_type);
|
|
131
|
1893 /* Unshare TYPE_FIELDs. */
|
|
|
1894 for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp))
|
|
|
1895 {
|
|
|
1896 tree next = DECL_CHAIN (*tp);
|
|
|
1897 *tp = copy_node (*tp);
|
|
|
1898 DECL_CONTEXT (*tp) = fat_type;
|
|
|
1899 DECL_CHAIN (*tp) = next;
|
|
|
1900 }
|
|
111
|
1901 /* Make sure that nontarget and target array type have the same canonical
|
|
|
1902 type (and same stub decl for debug info). */
|
|
|
1903 base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
|
|
|
1904 TYPE_CANONICAL (fat_type) = base_type;
|
|
|
1905 TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
|
|
|
1906
|
|
|
1907 tmp = TYPE_NAME (etype);
|
|
|
1908 if (tmp && TREE_CODE (tmp) == TYPE_DECL)
|
|
|
1909 tmp = DECL_NAME (tmp);
|
|
|
1910 if (tmp)
|
|
|
1911 type_name = IDENTIFIER_POINTER (tmp);
|
|
|
1912 else
|
|
|
1913 type_name = "unknown";
|
|
|
1914 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
|
|
|
1915 GFC_MAX_SYMBOL_LEN, type_name);
|
|
|
1916 TYPE_NAME (fat_type) = get_identifier (name);
|
|
|
1917 TYPE_NAMELESS (fat_type) = 1;
|
|
|
1918
|
|
|
1919 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
|
|
|
1920 TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();
|
|
|
1921
|
|
|
1922 GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
|
|
|
1923 GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
|
|
|
1924 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
|
|
|
1925 GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
|
|
|
1926
|
|
|
1927 /* Build an array descriptor record type. */
|
|
|
1928 if (packed != 0)
|
|
|
1929 stride = gfc_index_one_node;
|
|
|
1930 else
|
|
|
1931 stride = NULL_TREE;
|
|
|
1932 for (n = 0; n < dimen + codimen; n++)
|
|
|
1933 {
|
|
|
1934 if (n < dimen)
|
|
|
1935 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
|
|
|
1936
|
|
|
1937 if (lbound)
|
|
|
1938 lower = lbound[n];
|
|
|
1939 else
|
|
|
1940 lower = NULL_TREE;
|
|
|
1941
|
|
|
1942 if (lower != NULL_TREE)
|
|
|
1943 {
|
|
|
1944 if (INTEGER_CST_P (lower))
|
|
|
1945 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
|
|
|
1946 else
|
|
|
1947 lower = NULL_TREE;
|
|
|
1948 }
|
|
|
1949
|
|
|
1950 if (codimen && n == dimen + codimen - 1)
|
|
|
1951 break;
|
|
|
1952
|
|
|
1953 upper = ubound[n];
|
|
|
1954 if (upper != NULL_TREE)
|
|
|
1955 {
|
|
|
1956 if (INTEGER_CST_P (upper))
|
|
|
1957 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
|
|
|
1958 else
|
|
|
1959 upper = NULL_TREE;
|
|
|
1960 }
|
|
|
1961
|
|
|
1962 if (n >= dimen)
|
|
|
1963 continue;
|
|
|
1964
|
|
|
1965 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
|
|
|
1966 {
|
|
|
1967 tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
|
1968 gfc_array_index_type, upper, lower);
|
|
|
1969 tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
|
1970 gfc_array_index_type, tmp,
|
|
|
1971 gfc_index_one_node);
|
|
|
1972 stride = fold_build2_loc (input_location, MULT_EXPR,
|
|
|
1973 gfc_array_index_type, tmp, stride);
|
|
|
1974 /* Check the folding worked. */
|
|
|
1975 gcc_assert (INTEGER_CST_P (stride));
|
|
|
1976 }
|
|
|
1977 else
|
|
|
1978 stride = NULL_TREE;
|
|
|
1979 }
|
|
|
1980 GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
|
|
|
1981
|
|
|
1982 /* TODO: known offsets for descriptors. */
|
|
|
1983 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
|
|
|
1984
|
|
|
1985 if (dimen == 0)
|
|
|
1986 {
|
|
|
1987 arraytype = build_pointer_type (etype);
|
|
|
1988 if (restricted)
|
|
|
1989 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
|
|
|
1990
|
|
|
1991 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
|
|
|
1992 return fat_type;
|
|
|
1993 }
|
|
|
1994
|
|
|
1995 /* We define data as an array with the correct size if possible.
|
|
|
1996 Much better than doing pointer arithmetic. */
|
|
|
1997 if (stride)
|
|
|
1998 rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
|
|
|
1999 int_const_binop (MINUS_EXPR, stride,
|
|
|
2000 build_int_cst (TREE_TYPE (stride), 1)));
|
|
|
2001 else
|
|
|
2002 rtype = gfc_array_range_type;
|
|
|
2003 arraytype = build_array_type (etype, rtype);
|
|
|
2004 arraytype = build_pointer_type (arraytype);
|
|
|
2005 if (restricted)
|
|
|
2006 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
|
|
|
2007 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
|
|
|
2008
|
|
|
2009 /* This will generate the base declarations we need to emit debug
|
|
|
2010 information for this type. FIXME: there must be a better way to
|
|
|
2011 avoid divergence between compilations with and without debug
|
|
|
2012 information. */
|
|
|
2013 {
|
|
|
2014 struct array_descr_info info;
|
|
|
2015 gfc_get_array_descr_info (fat_type, &info);
|
|
|
2016 gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
|
|
|
2017 }
|
|
|
2018
|
|
|
2019 return fat_type;
|
|
|
2020 }
|
|
|
2021
|
|
|
2022 /* Build a pointer type. This function is called from gfc_sym_type(). */
|
|
|
2023
|
|
|
2024 static tree
|
|
|
2025 gfc_build_pointer_type (gfc_symbol * sym, tree type)
|
|
|
2026 {
|
|
|
2027 /* Array pointer types aren't actually pointers. */
|
|
|
2028 if (sym->attr.dimension)
|
|
|
2029 return type;
|
|
|
2030 else
|
|
|
2031 return build_pointer_type (type);
|
|
|
2032 }
|
|
|
2033
|
|
|
2034 static tree gfc_nonrestricted_type (tree t);
|
|
|
2035 /* Given two record or union type nodes TO and FROM, ensure
|
|
|
2036 that all fields in FROM have a corresponding field in TO,
|
|
|
2037 their type being nonrestrict variants. This accepts a TO
|
|
|
2038 node that already has a prefix of the fields in FROM. */
|
|
|
2039 static void
|
|
|
2040 mirror_fields (tree to, tree from)
|
|
|
2041 {
|
|
|
2042 tree fto, ffrom;
|
|
|
2043 tree *chain;
|
|
|
2044
|
|
|
2045 /* Forward to the end of TOs fields. */
|
|
|
2046 fto = TYPE_FIELDS (to);
|
|
|
2047 ffrom = TYPE_FIELDS (from);
|
|
|
2048 chain = &TYPE_FIELDS (to);
|
|
|
2049 while (fto)
|
|
|
2050 {
|
|
|
2051 gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom));
|
|
|
2052 chain = &DECL_CHAIN (fto);
|
|
|
2053 fto = DECL_CHAIN (fto);
|
|
|
2054 ffrom = DECL_CHAIN (ffrom);
|
|
|
2055 }
|
|
|
2056
|
|
|
2057 /* Now add all fields remaining in FROM (starting with ffrom). */
|
|
|
2058 for (; ffrom; ffrom = DECL_CHAIN (ffrom))
|
|
|
2059 {
|
|
|
2060 tree newfield = copy_node (ffrom);
|
|
|
2061 DECL_CONTEXT (newfield) = to;
|
|
|
2062 /* The store to DECL_CHAIN might seem redundant with the
|
|
|
2063 stores to *chain, but not clearing it here would mean
|
|
|
2064 leaving a chain into the old fields. If ever
|
|
|
2065 our called functions would look at them confusion
|
|
|
2066 will arise. */
|
|
|
2067 DECL_CHAIN (newfield) = NULL_TREE;
|
|
|
2068 *chain = newfield;
|
|
|
2069 chain = &DECL_CHAIN (newfield);
|
|
|
2070
|
|
|
2071 if (TREE_CODE (ffrom) == FIELD_DECL)
|
|
|
2072 {
|
|
|
2073 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom));
|
|
|
2074 TREE_TYPE (newfield) = elemtype;
|
|
|
2075 }
|
|
|
2076 }
|
|
|
2077 *chain = NULL_TREE;
|
|
|
2078 }
|
|
|
2079
|
|
|
2080 /* Given a type T, returns a different type of the same structure,
|
|
|
2081 except that all types it refers to (recursively) are always
|
|
|
2082 non-restrict qualified types. */
|
|
|
2083 static tree
|
|
|
2084 gfc_nonrestricted_type (tree t)
|
|
|
2085 {
|
|
|
2086 tree ret = t;
|
|
|
2087
|
|
|
2088 /* If the type isn't laid out yet, don't copy it. If something
|
|
|
2089 needs it for real it should wait until the type got finished. */
|
|
|
2090 if (!TYPE_SIZE (t))
|
|
|
2091 return t;
|
|
|
2092
|
|
|
2093 if (!TYPE_LANG_SPECIFIC (t))
|
|
|
2094 TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
|
|
|
2095 /* If we're dealing with this very node already further up
|
|
|
2096 the call chain (recursion via pointers and struct members)
|
|
|
2097 we haven't yet determined if we really need a new type node.
|
|
|
2098 Assume we don't, return T itself. */
|
|
|
2099 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
|
|
|
2100 return t;
|
|
|
2101
|
|
|
2102 /* If we have calculated this all already, just return it. */
|
|
|
2103 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
|
|
|
2104 return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
|
|
|
2105
|
|
|
2106 /* Mark this type. */
|
|
|
2107 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
|
|
|
2108
|
|
|
2109 switch (TREE_CODE (t))
|
|
|
2110 {
|
|
|
2111 default:
|
|
|
2112 break;
|
|
|
2113
|
|
|
2114 case POINTER_TYPE:
|
|
|
2115 case REFERENCE_TYPE:
|
|
|
2116 {
|
|
|
2117 tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
|
|
|
2118 if (totype == TREE_TYPE (t))
|
|
|
2119 ret = t;
|
|
|
2120 else if (TREE_CODE (t) == POINTER_TYPE)
|
|
|
2121 ret = build_pointer_type (totype);
|
|
|
2122 else
|
|
|
2123 ret = build_reference_type (totype);
|
|
|
2124 ret = build_qualified_type (ret,
|
|
|
2125 TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT);
|
|
|
2126 }
|
|
|
2127 break;
|
|
|
2128
|
|
|
2129 case ARRAY_TYPE:
|
|
|
2130 {
|
|
|
2131 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
|
|
|
2132 if (elemtype == TREE_TYPE (t))
|
|
|
2133 ret = t;
|
|
|
2134 else
|
|
|
2135 {
|
|
|
2136 ret = build_variant_type_copy (t);
|
|
|
2137 TREE_TYPE (ret) = elemtype;
|
|
|
2138 if (TYPE_LANG_SPECIFIC (t)
|
|
|
2139 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
|
|
|
2140 {
|
|
|
2141 tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t);
|
|
|
2142 dataptr_type = gfc_nonrestricted_type (dataptr_type);
|
|
|
2143 if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
|
|
|
2144 {
|
|
|
2145 TYPE_LANG_SPECIFIC (ret)
|
|
|
2146 = ggc_cleared_alloc<struct lang_type> ();
|
|
|
2147 *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
|
|
|
2148 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
|
|
|
2149 }
|
|
|
2150 }
|
|
|
2151 }
|
|
|
2152 }
|
|
|
2153 break;
|
|
|
2154
|
|
|
2155 case RECORD_TYPE:
|
|
|
2156 case UNION_TYPE:
|
|
|
2157 case QUAL_UNION_TYPE:
|
|
|
2158 {
|
|
|
2159 tree field;
|
|
|
2160 /* First determine if we need a new type at all.
|
|
|
2161 Careful, the two calls to gfc_nonrestricted_type per field
|
|
|
2162 might return different values. That happens exactly when
|
|
|
2163 one of the fields reaches back to this very record type
|
|
|
2164 (via pointers). The first calls will assume that we don't
|
|
|
2165 need to copy T (see the error_mark_node marking). If there
|
|
|
2166 are any reasons for copying T apart from having to copy T,
|
|
|
2167 we'll indeed copy it, and the second calls to
|
|
|
2168 gfc_nonrestricted_type will use that new node if they
|
|
|
2169 reach back to T. */
|
|
|
2170 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
|
|
|
2171 if (TREE_CODE (field) == FIELD_DECL)
|
|
|
2172 {
|
|
|
2173 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
|
|
|
2174 if (elemtype != TREE_TYPE (field))
|
|
|
2175 break;
|
|
|
2176 }
|
|
|
2177 if (!field)
|
|
|
2178 break;
|
|
|
2179 ret = build_variant_type_copy (t);
|
|
|
2180 TYPE_FIELDS (ret) = NULL_TREE;
|
|
|
2181
|
|
|
2182 /* Here we make sure that as soon as we know we have to copy
|
|
|
2183 T, that also fields reaching back to us will use the new
|
|
|
2184 copy. It's okay if that copy still contains the old fields,
|
|
|
2185 we won't look at them. */
|
|
|
2186 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
|
|
|
2187 mirror_fields (ret, t);
|
|
|
2188 }
|
|
|
2189 break;
|
|
|
2190 }
|
|
|
2191
|
|
|
2192 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
|
|
|
2193 return ret;
|
|
|
2194 }
|
|
|
2195
|
|
|
2196
|
|
|
2197 /* Return the type for a symbol. Special handling is required for character
|
|
|
2198 types to get the correct level of indirection.
|
|
|
2199 For functions return the return type.
|
|
|
2200 For subroutines return void_type_node.
|
|
|
2201 Calling this multiple times for the same symbol should be avoided,
|
|
|
2202 especially for character and array types. */
|
|
|
2203
|
|
|
2204 tree
|
|
|
2205 gfc_sym_type (gfc_symbol * sym)
|
|
|
2206 {
|
|
|
2207 tree type;
|
|
|
2208 int byref;
|
|
|
2209 bool restricted;
|
|
|
2210
|
|
|
2211 /* Procedure Pointers inside COMMON blocks. */
|
|
|
2212 if (sym->attr.proc_pointer && sym->attr.in_common)
|
|
|
2213 {
|
|
|
2214 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
|
|
|
2215 sym->attr.proc_pointer = 0;
|
|
|
2216 type = build_pointer_type (gfc_get_function_type (sym));
|
|
|
2217 sym->attr.proc_pointer = 1;
|
|
|
2218 return type;
|
|
|
2219 }
|
|
|
2220
|
|
|
2221 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
|
|
|
2222 return void_type_node;
|
|
|
2223
|
|
|
2224 /* In the case of a function the fake result variable may have a
|
|
|
2225 type different from the function type, so don't return early in
|
|
|
2226 that case. */
|
|
|
2227 if (sym->backend_decl && !sym->attr.function)
|
|
|
2228 return TREE_TYPE (sym->backend_decl);
|
|
|
2229
|
|
131
|
2230 if (sym->attr.result
|
|
|
2231 && sym->ts.type == BT_CHARACTER
|
|
|
2232 && sym->ts.u.cl->backend_decl == NULL_TREE
|
|
|
2233 && sym->ns->proc_name
|
|
|
2234 && sym->ns->proc_name->ts.u.cl
|
|
|
2235 && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE)
|
|
|
2236 sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl;
|
|
|
2237
|
|
111
|
2238 if (sym->ts.type == BT_CHARACTER
|
|
|
2239 && ((sym->attr.function && sym->attr.is_bind_c)
|
|
|
2240 || (sym->attr.result
|
|
|
2241 && sym->ns->proc_name
|
|
|
2242 && sym->ns->proc_name->attr.is_bind_c)
|
|
|
2243 || (sym->ts.deferred && (!sym->ts.u.cl
|
|
|
2244 || !sym->ts.u.cl->backend_decl))))
|
|
|
2245 type = gfc_character1_type_node;
|
|
|
2246 else
|
|
|
2247 type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
|
|
|
2248
|
|
|
2249 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
|
|
|
2250 byref = 1;
|
|
|
2251 else
|
|
|
2252 byref = 0;
|
|
|
2253
|
|
|
2254 restricted = !sym->attr.target && !sym->attr.pointer
|
|
|
2255 && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
|
|
|
2256 if (!restricted)
|
|
|
2257 type = gfc_nonrestricted_type (type);
|
|
|
2258
|
|
|
2259 if (sym->attr.dimension || sym->attr.codimension)
|
|
|
2260 {
|
|
|
2261 if (gfc_is_nodesc_array (sym))
|
|
|
2262 {
|
|
|
2263 /* If this is a character argument of unknown length, just use the
|
|
|
2264 base type. */
|
|
|
2265 if (sym->ts.type != BT_CHARACTER
|
|
|
2266 || !(sym->attr.dummy || sym->attr.function)
|
|
|
2267 || sym->ts.u.cl->backend_decl)
|
|
|
2268 {
|
|
|
2269 type = gfc_get_nodesc_array_type (type, sym->as,
|
|
|
2270 byref ? PACKED_FULL
|
|
|
2271 : PACKED_STATIC,
|
|
|
2272 restricted);
|
|
|
2273 byref = 0;
|
|
|
2274 }
|
|
|
2275 }
|
|
|
2276 else
|
|
|
2277 {
|
|
|
2278 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
|
|
|
2279 if (sym->attr.pointer)
|
|
|
2280 akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT
|
|
|
2281 : GFC_ARRAY_POINTER;
|
|
|
2282 else if (sym->attr.allocatable)
|
|
|
2283 akind = GFC_ARRAY_ALLOCATABLE;
|
|
|
2284 type = gfc_build_array_type (type, sym->as, akind, restricted,
|
|
|
2285 sym->attr.contiguous, false);
|
|
|
2286 }
|
|
|
2287 }
|
|
|
2288 else
|
|
|
2289 {
|
|
|
2290 if (sym->attr.allocatable || sym->attr.pointer
|
|
|
2291 || gfc_is_associate_pointer (sym))
|
|
|
2292 type = gfc_build_pointer_type (sym, type);
|
|
|
2293 }
|
|
|
2294
|
|
|
2295 /* We currently pass all parameters by reference.
|
|
|
2296 See f95_get_function_decl. For dummy function parameters return the
|
|
|
2297 function type. */
|
|
|
2298 if (byref)
|
|
|
2299 {
|
|
|
2300 /* We must use pointer types for potentially absent variables. The
|
|
|
2301 optimizers assume a reference type argument is never NULL. */
|
|
|
2302 if (sym->attr.optional
|
|
|
2303 || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
|
|
|
2304 type = build_pointer_type (type);
|
|
|
2305 else
|
|
|
2306 {
|
|
|
2307 type = build_reference_type (type);
|
|
|
2308 if (restricted)
|
|
|
2309 type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
|
|
2310 }
|
|
|
2311 }
|
|
|
2312
|
|
|
2313 return (type);
|
|
|
2314 }
|
|
|
2315
|
|
|
2316 /* Layout and output debug info for a record type. */
|
|
|
2317
|
|
|
2318 void
|
|
|
2319 gfc_finish_type (tree type)
|
|
|
2320 {
|
|
|
2321 tree decl;
|
|
|
2322
|
|
|
2323 decl = build_decl (input_location,
|
|
|
2324 TYPE_DECL, NULL_TREE, type);
|
|
|
2325 TYPE_STUB_DECL (type) = decl;
|
|
|
2326 layout_type (type);
|
|
|
2327 rest_of_type_compilation (type, 1);
|
|
|
2328 rest_of_decl_compilation (decl, 1, 0);
|
|
|
2329 }
|
|
|
2330
|
|
|
2331 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
|
|
|
2332 or RECORD_TYPE pointed to by CONTEXT. The new field is chained
|
|
|
2333 to the end of the field list pointed to by *CHAIN.
|
|
|
2334
|
|
|
2335 Returns a pointer to the new field. */
|
|
|
2336
|
|
|
2337 static tree
|
|
|
2338 gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain)
|
|
|
2339 {
|
|
|
2340 tree decl = build_decl (input_location, FIELD_DECL, name, type);
|
|
|
2341
|
|
|
2342 DECL_CONTEXT (decl) = context;
|
|
|
2343 DECL_CHAIN (decl) = NULL_TREE;
|
|
|
2344 if (TYPE_FIELDS (context) == NULL_TREE)
|
|
|
2345 TYPE_FIELDS (context) = decl;
|
|
|
2346 if (chain != NULL)
|
|
|
2347 {
|
|
|
2348 if (*chain != NULL)
|
|
|
2349 **chain = decl;
|
|
|
2350 *chain = &DECL_CHAIN (decl);
|
|
|
2351 }
|
|
|
2352
|
|
|
2353 return decl;
|
|
|
2354 }
|
|
|
2355
|
|
|
2356 /* Like `gfc_add_field_to_struct_1', but adds alignment
|
|
|
2357 information. */
|
|
|
2358
|
|
|
2359 tree
|
|
|
2360 gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain)
|
|
|
2361 {
|
|
|
2362 tree decl = gfc_add_field_to_struct_1 (context, name, type, chain);
|
|
|
2363
|
|
|
2364 DECL_INITIAL (decl) = 0;
|
|
|
2365 SET_DECL_ALIGN (decl, 0);
|
|
|
2366 DECL_USER_ALIGN (decl) = 0;
|
|
|
2367
|
|
|
2368 return decl;
|
|
|
2369 }
|
|
|
2370
|
|
|
2371
|
|
|
2372 /* Copy the backend_decl and component backend_decls if
|
|
|
2373 the two derived type symbols are "equal", as described
|
|
|
2374 in 4.4.2 and resolved by gfc_compare_derived_types. */
|
|
|
2375
|
|
|
2376 int
|
|
|
2377 gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
|
|
|
2378 bool from_gsym)
|
|
|
2379 {
|
|
|
2380 gfc_component *to_cm;
|
|
|
2381 gfc_component *from_cm;
|
|
|
2382
|
|
|
2383 if (from == to)
|
|
|
2384 return 1;
|
|
|
2385
|
|
|
2386 if (from->backend_decl == NULL
|
|
|
2387 || !gfc_compare_derived_types (from, to))
|
|
|
2388 return 0;
|
|
|
2389
|
|
|
2390 to->backend_decl = from->backend_decl;
|
|
|
2391
|
|
|
2392 to_cm = to->components;
|
|
|
2393 from_cm = from->components;
|
|
|
2394
|
|
|
2395 /* Copy the component declarations. If a component is itself
|
|
|
2396 a derived type, we need a copy of its component declarations.
|
|
|
2397 This is done by recursing into gfc_get_derived_type and
|
|
|
2398 ensures that the component's component declarations have
|
|
|
2399 been built. If it is a character, we need the character
|
|
|
2400 length, as well. */
|
|
|
2401 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
|
|
|
2402 {
|
|
|
2403 to_cm->backend_decl = from_cm->backend_decl;
|
|
131
|
2404 to_cm->caf_token = from_cm->caf_token;
|
|
111
|
2405 if (from_cm->ts.type == BT_UNION)
|
|
|
2406 gfc_get_union_type (to_cm->ts.u.derived);
|
|
|
2407 else if (from_cm->ts.type == BT_DERIVED
|
|
|
2408 && (!from_cm->attr.pointer || from_gsym))
|
|
|
2409 gfc_get_derived_type (to_cm->ts.u.derived);
|
|
|
2410 else if (from_cm->ts.type == BT_CLASS
|
|
|
2411 && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym))
|
|
|
2412 gfc_get_derived_type (to_cm->ts.u.derived);
|
|
|
2413 else if (from_cm->ts.type == BT_CHARACTER)
|
|
|
2414 to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
|
|
|
2415 }
|
|
|
2416
|
|
|
2417 return 1;
|
|
|
2418 }
|
|
|
2419
|
|
|
2420
|
|
|
2421 /* Build a tree node for a procedure pointer component. */
|
|
|
2422
|
|
|
2423 tree
|
|
|
2424 gfc_get_ppc_type (gfc_component* c)
|
|
|
2425 {
|
|
|
2426 tree t;
|
|
|
2427
|
|
|
2428 /* Explicit interface. */
|
|
|
2429 if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
|
|
|
2430 return build_pointer_type (gfc_get_function_type (c->ts.interface));
|
|
|
2431
|
|
|
2432 /* Implicit interface (only return value may be known). */
|
|
|
2433 if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
|
|
|
2434 t = gfc_typenode_for_spec (&c->ts);
|
|
|
2435 else
|
|
|
2436 t = void_type_node;
|
|
|
2437
|
|
|
2438 return build_pointer_type (build_function_type_list (t, NULL_TREE));
|
|
|
2439 }
|
|
|
2440
|
|
|
2441
|
|
|
2442 /* Build a tree node for a union type. Requires building each map
|
|
|
2443 structure which is an element of the union. */
|
|
|
2444
|
|
|
2445 tree
|
|
|
2446 gfc_get_union_type (gfc_symbol *un)
|
|
|
2447 {
|
|
|
2448 gfc_component *map = NULL;
|
|
|
2449 tree typenode = NULL, map_type = NULL, map_field = NULL;
|
|
|
2450 tree *chain = NULL;
|
|
|
2451
|
|
|
2452 if (un->backend_decl)
|
|
|
2453 {
|
|
|
2454 if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp)
|
|
|
2455 return un->backend_decl;
|
|
|
2456 else
|
|
|
2457 typenode = un->backend_decl;
|
|
|
2458 }
|
|
|
2459 else
|
|
|
2460 {
|
|
|
2461 typenode = make_node (UNION_TYPE);
|
|
|
2462 TYPE_NAME (typenode) = get_identifier (un->name);
|
|
|
2463 }
|
|
|
2464
|
|
|
2465 /* Add each contained MAP as a field. */
|
|
|
2466 for (map = un->components; map; map = map->next)
|
|
|
2467 {
|
|
|
2468 gcc_assert (map->ts.type == BT_DERIVED);
|
|
|
2469
|
|
|
2470 /* The map's type node, which is defined within this union's context. */
|
|
|
2471 map_type = gfc_get_derived_type (map->ts.u.derived);
|
|
|
2472 TYPE_CONTEXT (map_type) = typenode;
|
|
|
2473
|
|
|
2474 /* The map field's declaration. */
|
|
|
2475 map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name),
|
|
|
2476 map_type, &chain);
|
|
|
2477 if (map->loc.lb)
|
|
|
2478 gfc_set_decl_location (map_field, &map->loc);
|
|
|
2479 else if (un->declared_at.lb)
|
|
|
2480 gfc_set_decl_location (map_field, &un->declared_at);
|
|
|
2481
|
|
|
2482 DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
|
|
|
2483 DECL_NAMELESS(map_field) = true;
|
|
|
2484
|
|
|
2485 /* We should never clobber another backend declaration for this map,
|
|
|
2486 because each map component is unique. */
|
|
|
2487 if (!map->backend_decl)
|
|
|
2488 map->backend_decl = map_field;
|
|
|
2489 }
|
|
|
2490
|
|
|
2491 un->backend_decl = typenode;
|
|
|
2492 gfc_finish_type (typenode);
|
|
|
2493
|
|
|
2494 return typenode;
|
|
|
2495 }
|
|
|
2496
|
|
|
2497
|
|
|
2498 /* Build a tree node for a derived type. If there are equal
|
|
|
2499 derived types, with different local names, these are built
|
|
|
2500 at the same time. If an equal derived type has been built
|
|
|
2501 in a parent namespace, this is used. */
|
|
|
2502
|
|
|
2503 tree
|
|
|
2504 gfc_get_derived_type (gfc_symbol * derived, int codimen)
|
|
|
2505 {
|
|
|
2506 tree typenode = NULL, field = NULL, field_type = NULL;
|
|
|
2507 tree canonical = NULL_TREE;
|
|
|
2508 tree *chain = NULL;
|
|
|
2509 bool got_canonical = false;
|
|
|
2510 bool unlimited_entity = false;
|
|
|
2511 gfc_component *c;
|
|
|
2512 gfc_namespace *ns;
|
|
|
2513 tree tmp;
|
|
131
|
2514 bool coarray_flag;
|
|
|
2515
|
|
|
2516 coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
|
|
|
2517 && derived->module && !derived->attr.vtype;
|
|
111
|
2518
|
|
|
2519 gcc_assert (!derived->attr.pdt_template);
|
|
|
2520
|
|
|
2521 if (derived->attr.unlimited_polymorphic
|
|
|
2522 || (flag_coarray == GFC_FCOARRAY_LIB
|
|
|
2523 && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
|
|
|
2524 && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE
|
|
131
|
2525 || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
|
|
|
2526 || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)))
|
|
111
|
2527 return ptr_type_node;
|
|
|
2528
|
|
|
2529 if (flag_coarray != GFC_FCOARRAY_LIB
|
|
|
2530 && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
|
|
131
|
2531 && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE
|
|
|
2532 || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))
|
|
111
|
2533 return gfc_get_int_type (gfc_default_integer_kind);
|
|
|
2534
|
|
|
2535 if (derived && derived->attr.flavor == FL_PROCEDURE
|
|
|
2536 && derived->attr.generic)
|
|
|
2537 derived = gfc_find_dt_in_generic (derived);
|
|
|
2538
|
|
|
2539 /* See if it's one of the iso_c_binding derived types. */
|
|
|
2540 if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
|
|
|
2541 {
|
|
|
2542 if (derived->backend_decl)
|
|
|
2543 return derived->backend_decl;
|
|
|
2544
|
|
|
2545 if (derived->intmod_sym_id == ISOCBINDING_PTR)
|
|
|
2546 derived->backend_decl = ptr_type_node;
|
|
|
2547 else
|
|
|
2548 derived->backend_decl = pfunc_type_node;
|
|
|
2549
|
|
|
2550 derived->ts.kind = gfc_index_integer_kind;
|
|
|
2551 derived->ts.type = BT_INTEGER;
|
|
|
2552 /* Set the f90_type to BT_VOID as a way to recognize something of type
|
|
|
2553 BT_INTEGER that needs to fit a void * for the purpose of the
|
|
|
2554 iso_c_binding derived types. */
|
|
|
2555 derived->ts.f90_type = BT_VOID;
|
|
|
2556
|
|
|
2557 return derived->backend_decl;
|
|
|
2558 }
|
|
|
2559
|
|
|
2560 /* If use associated, use the module type for this one. */
|
|
|
2561 if (derived->backend_decl == NULL
|
|
|
2562 && derived->attr.use_assoc
|
|
|
2563 && derived->module
|
|
|
2564 && gfc_get_module_backend_decl (derived))
|
|
|
2565 goto copy_derived_types;
|
|
|
2566
|
|
|
2567 /* The derived types from an earlier namespace can be used as the
|
|
|
2568 canonical type. */
|
|
|
2569 if (derived->backend_decl == NULL && !derived->attr.use_assoc
|
|
|
2570 && gfc_global_ns_list)
|
|
|
2571 {
|
|
|
2572 for (ns = gfc_global_ns_list;
|
|
|
2573 ns->translated && !got_canonical;
|
|
|
2574 ns = ns->sibling)
|
|
|
2575 {
|
|
131
|
2576 if (ns->derived_types)
|
|
111
|
2577 {
|
|
131
|
2578 for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical;
|
|
|
2579 dt = dt->dt_next)
|
|
|
2580 {
|
|
|
2581 gfc_copy_dt_decls_ifequal (dt, derived, true);
|
|
|
2582 if (derived->backend_decl)
|
|
|
2583 got_canonical = true;
|
|
|
2584 if (dt->dt_next == ns->derived_types)
|
|
|
2585 break;
|
|
|
2586 }
|
|
|
2587 }
|
|
|
2588 }
|
|
111
|
2589 }
|
|
|
2590
|
|
|
2591 /* Store up the canonical type to be added to this one. */
|
|
|
2592 if (got_canonical)
|
|
|
2593 {
|
|
|
2594 if (TYPE_CANONICAL (derived->backend_decl))
|
|
|
2595 canonical = TYPE_CANONICAL (derived->backend_decl);
|
|
|
2596 else
|
|
|
2597 canonical = derived->backend_decl;
|
|
|
2598
|
|
|
2599 derived->backend_decl = NULL_TREE;
|
|
|
2600 }
|
|
|
2601
|
|
|
2602 /* derived->backend_decl != 0 means we saw it before, but its
|
|
|
2603 components' backend_decl may have not been built. */
|
|
|
2604 if (derived->backend_decl)
|
|
|
2605 {
|
|
|
2606 /* Its components' backend_decl have been built or we are
|
|
|
2607 seeing recursion through the formal arglist of a procedure
|
|
|
2608 pointer component. */
|
|
|
2609 if (TYPE_FIELDS (derived->backend_decl))
|
|
|
2610 return derived->backend_decl;
|
|
|
2611 else if (derived->attr.abstract
|
|
|
2612 && derived->attr.proc_pointer_comp)
|
|
|
2613 {
|
|
|
2614 /* If an abstract derived type with procedure pointer
|
|
|
2615 components has no other type of component, return the
|
|
|
2616 backend_decl. Otherwise build the components if any of the
|
|
|
2617 non-procedure pointer components have no backend_decl. */
|
|
|
2618 for (c = derived->components; c; c = c->next)
|
|
|
2619 {
|
|
|
2620 bool same_alloc_type = c->attr.allocatable
|
|
|
2621 && derived == c->ts.u.derived;
|
|
|
2622 if (!c->attr.proc_pointer
|
|
|
2623 && !same_alloc_type
|
|
|
2624 && c->backend_decl == NULL)
|
|
|
2625 break;
|
|
|
2626 else if (c->next == NULL)
|
|
|
2627 return derived->backend_decl;
|
|
|
2628 }
|
|
|
2629 typenode = derived->backend_decl;
|
|
|
2630 }
|
|
|
2631 else
|
|
|
2632 typenode = derived->backend_decl;
|
|
|
2633 }
|
|
|
2634 else
|
|
|
2635 {
|
|
|
2636 /* We see this derived type first time, so build the type node. */
|
|
|
2637 typenode = make_node (RECORD_TYPE);
|
|
|
2638 TYPE_NAME (typenode) = get_identifier (derived->name);
|
|
|
2639 TYPE_PACKED (typenode) = flag_pack_derived;
|
|
|
2640 derived->backend_decl = typenode;
|
|
|
2641 }
|
|
|
2642
|
|
|
2643 if (derived->components
|
|
|
2644 && derived->components->ts.type == BT_DERIVED
|
|
|
2645 && strcmp (derived->components->name, "_data") == 0
|
|
|
2646 && derived->components->ts.u.derived->attr.unlimited_polymorphic)
|
|
|
2647 unlimited_entity = true;
|
|
|
2648
|
|
|
2649 /* Go through the derived type components, building them as
|
|
|
2650 necessary. The reason for doing this now is that it is
|
|
|
2651 possible to recurse back to this derived type through a
|
|
|
2652 pointer component (PR24092). If this happens, the fields
|
|
|
2653 will be built and so we can return the type. */
|
|
|
2654 for (c = derived->components; c; c = c->next)
|
|
|
2655 {
|
|
|
2656 bool same_alloc_type = c->attr.allocatable
|
|
|
2657 && derived == c->ts.u.derived;
|
|
|
2658
|
|
|
2659 if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
|
|
|
2660 c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived);
|
|
|
2661
|
|
|
2662 if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
|
|
|
2663 continue;
|
|
|
2664
|
|
|
2665 if ((!c->attr.pointer && !c->attr.proc_pointer
|
|
|
2666 && !same_alloc_type)
|
|
|
2667 || c->ts.u.derived->backend_decl == NULL)
|
|
|
2668 {
|
|
|
2669 int local_codim = c->attr.codimension ? c->as->corank: codimen;
|
|
|
2670 c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
|
|
|
2671 local_codim);
|
|
|
2672 }
|
|
|
2673
|
|
|
2674 if (c->ts.u.derived->attr.is_iso_c)
|
|
|
2675 {
|
|
|
2676 /* Need to copy the modified ts from the derived type. The
|
|
|
2677 typespec was modified because C_PTR/C_FUNPTR are translated
|
|
|
2678 into (void *) from derived types. */
|
|
|
2679 c->ts.type = c->ts.u.derived->ts.type;
|
|
|
2680 c->ts.kind = c->ts.u.derived->ts.kind;
|
|
|
2681 c->ts.f90_type = c->ts.u.derived->ts.f90_type;
|
|
|
2682 if (c->initializer)
|
|
|
2683 {
|
|
|
2684 c->initializer->ts.type = c->ts.type;
|
|
|
2685 c->initializer->ts.kind = c->ts.kind;
|
|
|
2686 c->initializer->ts.f90_type = c->ts.f90_type;
|
|
|
2687 c->initializer->expr_type = EXPR_NULL;
|
|
|
2688 }
|
|
|
2689 }
|
|
|
2690 }
|
|
|
2691
|
|
|
2692 if (TYPE_FIELDS (derived->backend_decl))
|
|
|
2693 return derived->backend_decl;
|
|
|
2694
|
|
|
2695 /* Build the type member list. Install the newly created RECORD_TYPE
|
|
|
2696 node as DECL_CONTEXT of each FIELD_DECL. In this case we must go
|
|
|
2697 through only the top-level linked list of components so we correctly
|
|
|
2698 build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
|
|
|
2699 types are built as part of gfc_get_union_type. */
|
|
|
2700 for (c = derived->components; c; c = c->next)
|
|
|
2701 {
|
|
|
2702 bool same_alloc_type = c->attr.allocatable
|
|
|
2703 && derived == c->ts.u.derived;
|
|
|
2704 /* Prevent infinite recursion, when the procedure pointer type is
|
|
|
2705 the same as derived, by forcing the procedure pointer component to
|
|
|
2706 be built as if the explicit interface does not exist. */
|
|
|
2707 if (c->attr.proc_pointer
|
|
|
2708 && (c->ts.type != BT_DERIVED || (c->ts.u.derived
|
|
|
2709 && !gfc_compare_derived_types (derived, c->ts.u.derived)))
|
|
|
2710 && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
|
|
|
2711 && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
|
|
|
2712 field_type = gfc_get_ppc_type (c);
|
|
|
2713 else if (c->attr.proc_pointer && derived->backend_decl)
|
|
|
2714 {
|
|
|
2715 tmp = build_function_type_list (derived->backend_decl, NULL_TREE);
|
|
|
2716 field_type = build_pointer_type (tmp);
|
|
|
2717 }
|
|
|
2718 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
|
131
|
2719 field_type = c->ts.u.derived->backend_decl;
|
|
|
2720 else if (c->attr.caf_token)
|
|
|
2721 field_type = pvoid_type_node;
|
|
111
|
2722 else
|
|
|
2723 {
|
|
|
2724 if (c->ts.type == BT_CHARACTER
|
|
|
2725 && !c->ts.deferred && !c->attr.pdt_string)
|
|
|
2726 {
|
|
|
2727 /* Evaluate the string length. */
|
|
|
2728 gfc_conv_const_charlen (c->ts.u.cl);
|
|
|
2729 gcc_assert (c->ts.u.cl->backend_decl);
|
|
|
2730 }
|
|
|
2731 else if (c->ts.type == BT_CHARACTER)
|
|
|
2732 c->ts.u.cl->backend_decl
|
|
|
2733 = build_int_cst (gfc_charlen_type_node, 0);
|
|
|
2734
|
|
|
2735 field_type = gfc_typenode_for_spec (&c->ts, codimen);
|
|
|
2736 }
|
|
|
2737
|
|
|
2738 /* This returns an array descriptor type. Initialization may be
|
|
|
2739 required. */
|
|
|
2740 if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
|
|
|
2741 {
|
|
|
2742 if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
|
|
|
2743 {
|
|
|
2744 enum gfc_array_kind akind;
|
|
|
2745 if (c->attr.pointer)
|
|
|
2746 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
|
|
|
2747 : GFC_ARRAY_POINTER;
|
|
|
2748 else
|
|
|
2749 akind = GFC_ARRAY_ALLOCATABLE;
|
|
|
2750 /* Pointers to arrays aren't actually pointer types. The
|
|
|
2751 descriptors are separate, but the data is common. */
|
|
|
2752 field_type = gfc_build_array_type (field_type, c->as, akind,
|
|
|
2753 !c->attr.target
|
|
|
2754 && !c->attr.pointer,
|
|
|
2755 c->attr.contiguous,
|
|
|
2756 codimen);
|
|
|
2757 }
|
|
|
2758 else
|
|
|
2759 field_type = gfc_get_nodesc_array_type (field_type, c->as,
|
|
|
2760 PACKED_STATIC,
|
|
|
2761 !c->attr.target);
|
|
|
2762 }
|
|
|
2763 else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
|
|
|
2764 && !c->attr.proc_pointer
|
|
|
2765 && !(unlimited_entity && c == derived->components))
|
|
|
2766 field_type = build_pointer_type (field_type);
|
|
|
2767
|
|
|
2768 if (c->attr.pointer || same_alloc_type)
|
|
|
2769 field_type = gfc_nonrestricted_type (field_type);
|
|
|
2770
|
|
|
2771 /* vtype fields can point to different types to the base type. */
|
|
|
2772 if (c->ts.type == BT_DERIVED
|
|
|
2773 && c->ts.u.derived && c->ts.u.derived->attr.vtype)
|
|
|
2774 field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
|
|
|
2775 ptr_mode, true);
|
|
|
2776
|
|
|
2777 /* Ensure that the CLASS language specific flag is set. */
|
|
|
2778 if (c->ts.type == BT_CLASS)
|
|
|
2779 {
|
|
|
2780 if (POINTER_TYPE_P (field_type))
|
|
|
2781 GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
|
|
|
2782 else
|
|
|
2783 GFC_CLASS_TYPE_P (field_type) = 1;
|
|
|
2784 }
|
|
|
2785
|
|
|
2786 field = gfc_add_field_to_struct (typenode,
|
|
|
2787 get_identifier (c->name),
|
|
|
2788 field_type, &chain);
|
|
|
2789 if (c->loc.lb)
|
|
|
2790 gfc_set_decl_location (field, &c->loc);
|
|
|
2791 else if (derived->declared_at.lb)
|
|
|
2792 gfc_set_decl_location (field, &derived->declared_at);
|
|
|
2793
|
|
|
2794 gfc_finish_decl_attrs (field, &c->attr);
|
|
|
2795
|
|
|
2796 DECL_PACKED (field) |= TYPE_PACKED (typenode);
|
|
|
2797
|
|
|
2798 gcc_assert (field);
|
|
|
2799 if (!c->backend_decl)
|
|
|
2800 c->backend_decl = field;
|
|
|
2801
|
|
|
2802 if (c->attr.pointer && c->attr.dimension
|
|
|
2803 && !(c->ts.type == BT_DERIVED
|
|
|
2804 && strcmp (c->name, "_data") == 0))
|
|
|
2805 GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
|
|
|
2806 }
|
|
|
2807
|
|
|
2808 /* Now lay out the derived type, including the fields. */
|
|
|
2809 if (canonical)
|
|
|
2810 TYPE_CANONICAL (typenode) = canonical;
|
|
|
2811
|
|
|
2812 gfc_finish_type (typenode);
|
|
|
2813 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
|
|
|
2814 if (derived->module && derived->ns->proc_name
|
|
|
2815 && derived->ns->proc_name->attr.flavor == FL_MODULE)
|
|
|
2816 {
|
|
|
2817 if (derived->ns->proc_name->backend_decl
|
|
|
2818 && TREE_CODE (derived->ns->proc_name->backend_decl)
|
|
|
2819 == NAMESPACE_DECL)
|
|
|
2820 {
|
|
|
2821 TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
|
|
|
2822 DECL_CONTEXT (TYPE_STUB_DECL (typenode))
|
|
|
2823 = derived->ns->proc_name->backend_decl;
|
|
|
2824 }
|
|
|
2825 }
|
|
|
2826
|
|
|
2827 derived->backend_decl = typenode;
|
|
|
2828
|
|
|
2829 copy_derived_types:
|
|
|
2830
|
|
131
|
2831 for (c = derived->components; c; c = c->next)
|
|
|
2832 {
|
|
|
2833 /* Do not add a caf_token field for class container components. */
|
|
|
2834 if ((codimen || coarray_flag)
|
|
|
2835 && !c->attr.dimension && !c->attr.codimension
|
|
|
2836 && (c->attr.allocatable || c->attr.pointer)
|
|
|
2837 && !derived->attr.is_class)
|
|
|
2838 {
|
|
|
2839 char caf_name[GFC_MAX_SYMBOL_LEN];
|
|
|
2840 gfc_component *token;
|
|
|
2841 snprintf (caf_name, GFC_MAX_SYMBOL_LEN, "_caf_%s", c->name);
|
|
|
2842 token = gfc_find_component (derived, caf_name, true, true, NULL);
|
|
|
2843 gcc_assert (token);
|
|
|
2844 c->caf_token = token->backend_decl;
|
|
|
2845 TREE_NO_WARNING (c->caf_token) = 1;
|
|
|
2846 }
|
|
|
2847 }
|
|
|
2848
|
|
|
2849 for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
|
|
|
2850 {
|
|
|
2851 gfc_copy_dt_decls_ifequal (derived, dt, false);
|
|
|
2852 if (dt->dt_next == gfc_derived_types)
|
|
|
2853 break;
|
|
|
2854 }
|
|
111
|
2855
|
|
|
2856 return derived->backend_decl;
|
|
|
2857 }
|
|
|
2858
|
|
|
2859
|
|
|
2860 int
|
|
|
2861 gfc_return_by_reference (gfc_symbol * sym)
|
|
|
2862 {
|
|
|
2863 if (!sym->attr.function)
|
|
|
2864 return 0;
|
|
|
2865
|
|
|
2866 if (sym->attr.dimension)
|
|
|
2867 return 1;
|
|
|
2868
|
|
|
2869 if (sym->ts.type == BT_CHARACTER
|
|
|
2870 && !sym->attr.is_bind_c
|
|
|
2871 && (!sym->attr.result
|
|
|
2872 || !sym->ns->proc_name
|
|
|
2873 || !sym->ns->proc_name->attr.is_bind_c))
|
|
|
2874 return 1;
|
|
|
2875
|
|
|
2876 /* Possibly return complex numbers by reference for g77 compatibility.
|
|
|
2877 We don't do this for calls to intrinsics (as the library uses the
|
|
|
2878 -fno-f2c calling convention), nor for calls to functions which always
|
|
|
2879 require an explicit interface, as no compatibility problems can
|
|
|
2880 arise there. */
|
|
|
2881 if (flag_f2c && sym->ts.type == BT_COMPLEX
|
|
|
2882 && !sym->attr.intrinsic && !sym->attr.always_explicit)
|
|
|
2883 return 1;
|
|
|
2884
|
|
|
2885 return 0;
|
|
|
2886 }
|
|
|
2887
|
|
|
2888 static tree
|
|
|
2889 gfc_get_mixed_entry_union (gfc_namespace *ns)
|
|
|
2890 {
|
|
|
2891 tree type;
|
|
|
2892 tree *chain = NULL;
|
|
|
2893 char name[GFC_MAX_SYMBOL_LEN + 1];
|
|
|
2894 gfc_entry_list *el, *el2;
|
|
|
2895
|
|
|
2896 gcc_assert (ns->proc_name->attr.mixed_entry_master);
|
|
|
2897 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
|
|
|
2898
|
|
|
2899 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
|
|
|
2900
|
|
|
2901 /* Build the type node. */
|
|
|
2902 type = make_node (UNION_TYPE);
|
|
|
2903
|
|
|
2904 TYPE_NAME (type) = get_identifier (name);
|
|
|
2905
|
|
|
2906 for (el = ns->entries; el; el = el->next)
|
|
|
2907 {
|
|
|
2908 /* Search for duplicates. */
|
|
|
2909 for (el2 = ns->entries; el2 != el; el2 = el2->next)
|
|
|
2910 if (el2->sym->result == el->sym->result)
|
|
|
2911 break;
|
|
|
2912
|
|
|
2913 if (el == el2)
|
|
|
2914 gfc_add_field_to_struct_1 (type,
|
|
|
2915 get_identifier (el->sym->result->name),
|
|
|
2916 gfc_sym_type (el->sym->result), &chain);
|
|
|
2917 }
|
|
|
2918
|
|
|
2919 /* Finish off the type. */
|
|
|
2920 gfc_finish_type (type);
|
|
|
2921 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
|
|
|
2922 return type;
|
|
|
2923 }
|
|
|
2924
|
|
|
2925 /* Create a "fn spec" based on the formal arguments;
|
|
|
2926 cf. create_function_arglist. */
|
|
|
2927
|
|
|
2928 static tree
|
|
|
2929 create_fn_spec (gfc_symbol *sym, tree fntype)
|
|
|
2930 {
|
|
|
2931 char spec[150];
|
|
|
2932 size_t spec_len;
|
|
|
2933 gfc_formal_arglist *f;
|
|
|
2934 tree tmp;
|
|
|
2935
|
|
|
2936 memset (&spec, 0, sizeof (spec));
|
|
|
2937 spec[0] = '.';
|
|
|
2938 spec_len = 1;
|
|
|
2939
|
|
|
2940 if (sym->attr.entry_master)
|
|
|
2941 spec[spec_len++] = 'R';
|
|
|
2942 if (gfc_return_by_reference (sym))
|
|
|
2943 {
|
|
|
2944 gfc_symbol *result = sym->result ? sym->result : sym;
|
|
|
2945
|
|
|
2946 if (result->attr.pointer || sym->attr.proc_pointer)
|
|
|
2947 spec[spec_len++] = '.';
|
|
|
2948 else
|
|
|
2949 spec[spec_len++] = 'w';
|
|
|
2950 if (sym->ts.type == BT_CHARACTER)
|
|
|
2951 spec[spec_len++] = 'R';
|
|
|
2952 }
|
|
|
2953
|
|
|
2954 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
|
|
|
2955 if (spec_len < sizeof (spec))
|
|
|
2956 {
|
|
|
2957 if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
|
|
|
2958 || f->sym->attr.external || f->sym->attr.cray_pointer
|
|
|
2959 || (f->sym->ts.type == BT_DERIVED
|
|
|
2960 && (f->sym->ts.u.derived->attr.proc_pointer_comp
|
|
|
2961 || f->sym->ts.u.derived->attr.pointer_comp))
|
|
|
2962 || (f->sym->ts.type == BT_CLASS
|
|
|
2963 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp
|
|
145
|
2964 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))
|
|
|
2965 || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop))
|
|
111
|
2966 spec[spec_len++] = '.';
|
|
|
2967 else if (f->sym->attr.intent == INTENT_IN)
|
|
|
2968 spec[spec_len++] = 'r';
|
|
|
2969 else if (f->sym)
|
|
|
2970 spec[spec_len++] = 'w';
|
|
|
2971 }
|
|
|
2972
|
|
|
2973 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec));
|
|
|
2974 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype));
|
|
|
2975 return build_type_attribute_variant (fntype, tmp);
|
|
|
2976 }
|
|
|
2977
|
|
|
2978 tree
|
|
145
|
2979 gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
|
|
111
|
2980 {
|
|
|
2981 tree type;
|
|
|
2982 vec<tree, va_gc> *typelist = NULL;
|
|
|
2983 gfc_formal_arglist *f;
|
|
|
2984 gfc_symbol *arg;
|
|
|
2985 int alternate_return = 0;
|
|
|
2986 bool is_varargs = true;
|
|
|
2987
|
|
|
2988 /* Make sure this symbol is a function, a subroutine or the main
|
|
|
2989 program. */
|
|
|
2990 gcc_assert (sym->attr.flavor == FL_PROCEDURE
|
|
|
2991 || sym->attr.flavor == FL_PROGRAM);
|
|
|
2992
|
|
|
2993 /* To avoid recursing infinitely on recursive types, we use error_mark_node
|
|
|
2994 so that they can be detected here and handled further down. */
|
|
|
2995 if (sym->backend_decl == NULL)
|
|
|
2996 sym->backend_decl = error_mark_node;
|
|
|
2997 else if (sym->backend_decl == error_mark_node)
|
|
|
2998 goto arg_type_list_done;
|
|
|
2999 else if (sym->attr.proc_pointer)
|
|
|
3000 return TREE_TYPE (TREE_TYPE (sym->backend_decl));
|
|
|
3001 else
|
|
|
3002 return TREE_TYPE (sym->backend_decl);
|
|
|
3003
|
|
|
3004 if (sym->attr.entry_master)
|
|
|
3005 /* Additional parameter for selecting an entry point. */
|
|
|
3006 vec_safe_push (typelist, gfc_array_index_type);
|
|
|
3007
|
|
|
3008 if (sym->result)
|
|
|
3009 arg = sym->result;
|
|
|
3010 else
|
|
|
3011 arg = sym;
|
|
|
3012
|
|
|
3013 if (arg->ts.type == BT_CHARACTER)
|
|
|
3014 gfc_conv_const_charlen (arg->ts.u.cl);
|
|
|
3015
|
|
|
3016 /* Some functions we use an extra parameter for the return value. */
|
|
|
3017 if (gfc_return_by_reference (sym))
|
|
|
3018 {
|
|
|
3019 type = gfc_sym_type (arg);
|
|
|
3020 if (arg->ts.type == BT_COMPLEX
|
|
|
3021 || arg->attr.dimension
|
|
|
3022 || arg->ts.type == BT_CHARACTER)
|
|
|
3023 type = build_reference_type (type);
|
|
|
3024
|
|
|
3025 vec_safe_push (typelist, type);
|
|
|
3026 if (arg->ts.type == BT_CHARACTER)
|
|
|
3027 {
|
|
|
3028 if (!arg->ts.deferred)
|
|
|
3029 /* Transfer by value. */
|
|
|
3030 vec_safe_push (typelist, gfc_charlen_type_node);
|
|
|
3031 else
|
|
|
3032 /* Deferred character lengths are transferred by reference
|
|
|
3033 so that the value can be returned. */
|
|
|
3034 vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
|
|
|
3035 }
|
|
|
3036 }
|
|
145
|
3037 if (sym->backend_decl == error_mark_node && actual_args != NULL
|
|
|
3038 && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
|
|
|
3039 || sym->attr.proc == PROC_UNKNOWN))
|
|
|
3040 gfc_get_formal_from_actual_arglist (sym, actual_args);
|
|
111
|
3041
|
|
|
3042 /* Build the argument types for the function. */
|
|
|
3043 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
|
|
|
3044 {
|
|
|
3045 arg = f->sym;
|
|
|
3046 if (arg)
|
|
|
3047 {
|
|
|
3048 /* Evaluate constant character lengths here so that they can be
|
|
|
3049 included in the type. */
|
|
|
3050 if (arg->ts.type == BT_CHARACTER)
|
|
|
3051 gfc_conv_const_charlen (arg->ts.u.cl);
|
|
|
3052
|
|
|
3053 if (arg->attr.flavor == FL_PROCEDURE)
|
|
|
3054 {
|
|
|
3055 type = gfc_get_function_type (arg);
|
|
|
3056 type = build_pointer_type (type);
|
|
|
3057 }
|
|
|
3058 else
|
|
|
3059 type = gfc_sym_type (arg);
|
|
|
3060
|
|
|
3061 /* Parameter Passing Convention
|
|
|
3062
|
|
|
3063 We currently pass all parameters by reference.
|
|
|
3064 Parameters with INTENT(IN) could be passed by value.
|
|
|
3065 The problem arises if a function is called via an implicit
|
|
|
3066 prototype. In this situation the INTENT is not known.
|
|
|
3067 For this reason all parameters to global functions must be
|
|
|
3068 passed by reference. Passing by value would potentially
|
|
|
3069 generate bad code. Worse there would be no way of telling that
|
|
|
3070 this code was bad, except that it would give incorrect results.
|
|
|
3071
|
|
|
3072 Contained procedures could pass by value as these are never
|
|
|
3073 used without an explicit interface, and cannot be passed as
|
|
|
3074 actual parameters for a dummy procedure. */
|
|
|
3075
|
|
|
3076 vec_safe_push (typelist, type);
|
|
|
3077 }
|
|
|
3078 else
|
|
|
3079 {
|
|
|
3080 if (sym->attr.subroutine)
|
|
|
3081 alternate_return = 1;
|
|
|
3082 }
|
|
|
3083 }
|
|
|
3084
|
|
|
3085 /* Add hidden string length parameters. */
|
|
|
3086 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
|
|
|
3087 {
|
|
|
3088 arg = f->sym;
|
|
|
3089 if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
|
|
|
3090 {
|
|
|
3091 if (!arg->ts.deferred)
|
|
|
3092 /* Transfer by value. */
|
|
|
3093 type = gfc_charlen_type_node;
|
|
|
3094 else
|
|
|
3095 /* Deferred character lengths are transferred by reference
|
|
|
3096 so that the value can be returned. */
|
|
|
3097 type = build_pointer_type (gfc_charlen_type_node);
|
|
|
3098
|
|
|
3099 vec_safe_push (typelist, type);
|
|
|
3100 }
|
|
145
|
3101 /* For noncharacter scalar intrinsic types, VALUE passes the value,
|
|
|
3102 hence, the optional status cannot be transferred via a NULL pointer.
|
|
|
3103 Thus, we will use a hidden argument in that case. */
|
|
|
3104 else if (arg
|
|
|
3105 && arg->attr.optional
|
|
|
3106 && arg->attr.value
|
|
|
3107 && !arg->attr.dimension
|
|
|
3108 && arg->ts.type != BT_CLASS
|
|
|
3109 && !gfc_bt_struct (arg->ts.type))
|
|
|
3110 vec_safe_push (typelist, boolean_type_node);
|
|
111
|
3111 }
|
|
|
3112
|
|
|
3113 if (!vec_safe_is_empty (typelist)
|
|
|
3114 || sym->attr.is_main_program
|
|
|
3115 || sym->attr.if_source != IFSRC_UNKNOWN)
|
|
|
3116 is_varargs = false;
|
|
|
3117
|
|
|
3118 if (sym->backend_decl == error_mark_node)
|
|
|
3119 sym->backend_decl = NULL_TREE;
|
|
|
3120
|
|
|
3121 arg_type_list_done:
|
|
|
3122
|
|
|
3123 if (alternate_return)
|
|
|
3124 type = integer_type_node;
|
|
|
3125 else if (!sym->attr.function || gfc_return_by_reference (sym))
|
|
|
3126 type = void_type_node;
|
|
|
3127 else if (sym->attr.mixed_entry_master)
|
|
|
3128 type = gfc_get_mixed_entry_union (sym->ns);
|
|
|
3129 else if (flag_f2c && sym->ts.type == BT_REAL
|
|
|
3130 && sym->ts.kind == gfc_default_real_kind
|
|
|
3131 && !sym->attr.always_explicit)
|
|
|
3132 {
|
|
|
3133 /* Special case: f2c calling conventions require that (scalar)
|
|
|
3134 default REAL functions return the C type double instead. f2c
|
|
|
3135 compatibility is only an issue with functions that don't
|
|
|
3136 require an explicit interface, as only these could be
|
|
|
3137 implemented in Fortran 77. */
|
|
|
3138 sym->ts.kind = gfc_default_double_kind;
|
|
|
3139 type = gfc_typenode_for_spec (&sym->ts);
|
|
|
3140 sym->ts.kind = gfc_default_real_kind;
|
|
|
3141 }
|
|
|
3142 else if (sym->result && sym->result->attr.proc_pointer)
|
|
|
3143 /* Procedure pointer return values. */
|
|
|
3144 {
|
|
|
3145 if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
|
|
|
3146 {
|
|
|
3147 /* Unset proc_pointer as gfc_get_function_type
|
|
|
3148 is called recursively. */
|
|
|
3149 sym->result->attr.proc_pointer = 0;
|
|
|
3150 type = build_pointer_type (gfc_get_function_type (sym->result));
|
|
|
3151 sym->result->attr.proc_pointer = 1;
|
|
|
3152 }
|
|
|
3153 else
|
|
|
3154 type = gfc_sym_type (sym->result);
|
|
|
3155 }
|
|
|
3156 else
|
|
|
3157 type = gfc_sym_type (sym);
|
|
|
3158
|
|
|
3159 if (is_varargs)
|
|
|
3160 type = build_varargs_function_type_vec (type, typelist);
|
|
|
3161 else
|
|
|
3162 type = build_function_type_vec (type, typelist);
|
|
|
3163 type = create_fn_spec (sym, type);
|
|
|
3164
|
|
|
3165 return type;
|
|
|
3166 }
|
|
|
3167
|
|
|
3168 /* Language hooks for middle-end access to type nodes. */
|
|
|
3169
|
|
|
3170 /* Return an integer type with BITS bits of precision,
|
|
|
3171 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */
|
|
|
3172
|
|
|
3173 tree
|
|
|
3174 gfc_type_for_size (unsigned bits, int unsignedp)
|
|
|
3175 {
|
|
|
3176 if (!unsignedp)
|
|
|
3177 {
|
|
|
3178 int i;
|
|
|
3179 for (i = 0; i <= MAX_INT_KINDS; ++i)
|
|
|
3180 {
|
|
|
3181 tree type = gfc_integer_types[i];
|
|
|
3182 if (type && bits == TYPE_PRECISION (type))
|
|
|
3183 return type;
|
|
|
3184 }
|
|
|
3185
|
|
|
3186 /* Handle TImode as a special case because it is used by some backends
|
|
|
3187 (e.g. ARM) even though it is not available for normal use. */
|
|
|
3188 #if HOST_BITS_PER_WIDE_INT >= 64
|
|
|
3189 if (bits == TYPE_PRECISION (intTI_type_node))
|
|
|
3190 return intTI_type_node;
|
|
|
3191 #endif
|
|
|
3192
|
|
|
3193 if (bits <= TYPE_PRECISION (intQI_type_node))
|
|
|
3194 return intQI_type_node;
|
|
|
3195 if (bits <= TYPE_PRECISION (intHI_type_node))
|
|
|
3196 return intHI_type_node;
|
|
|
3197 if (bits <= TYPE_PRECISION (intSI_type_node))
|
|
|
3198 return intSI_type_node;
|
|
|
3199 if (bits <= TYPE_PRECISION (intDI_type_node))
|
|
|
3200 return intDI_type_node;
|
|
|
3201 if (bits <= TYPE_PRECISION (intTI_type_node))
|
|
|
3202 return intTI_type_node;
|
|
|
3203 }
|
|
|
3204 else
|
|
|
3205 {
|
|
|
3206 if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
|
|
|
3207 return unsigned_intQI_type_node;
|
|
|
3208 if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
|
|
|
3209 return unsigned_intHI_type_node;
|
|
|
3210 if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
|
|
|
3211 return unsigned_intSI_type_node;
|
|
|
3212 if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
|
|
|
3213 return unsigned_intDI_type_node;
|
|
|
3214 if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
|
|
|
3215 return unsigned_intTI_type_node;
|
|
|
3216 }
|
|
|
3217
|
|
|
3218 return NULL_TREE;
|
|
|
3219 }
|
|
|
3220
|
|
|
3221 /* Return a data type that has machine mode MODE. If the mode is an
|
|
|
3222 integer, then UNSIGNEDP selects between signed and unsigned types. */
|
|
|
3223
|
|
|
3224 tree
|
|
|
3225 gfc_type_for_mode (machine_mode mode, int unsignedp)
|
|
|
3226 {
|
|
|
3227 int i;
|
|
|
3228 tree *base;
|
|
|
3229 scalar_int_mode int_mode;
|
|
|
3230
|
|
|
3231 if (GET_MODE_CLASS (mode) == MODE_FLOAT)
|
|
|
3232 base = gfc_real_types;
|
|
|
3233 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
|
|
|
3234 base = gfc_complex_types;
|
|
|
3235 else if (is_a <scalar_int_mode> (mode, &int_mode))
|
|
|
3236 {
|
|
|
3237 tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp);
|
|
|
3238 return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
|
|
|
3239 }
|
|
131
|
3240 else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL
|
|
|
3241 && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
|
|
|
3242 {
|
|
|
3243 unsigned int elem_bits = vector_element_size (GET_MODE_BITSIZE (mode),
|
|
|
3244 GET_MODE_NUNITS (mode));
|
|
|
3245 tree bool_type = build_nonstandard_boolean_type (elem_bits);
|
|
|
3246 return build_vector_type_for_mode (bool_type, mode);
|
|
|
3247 }
|
|
|
3248 else if (VECTOR_MODE_P (mode)
|
|
|
3249 && valid_vector_subparts_p (GET_MODE_NUNITS (mode)))
|
|
111
|
3250 {
|
|
|
3251 machine_mode inner_mode = GET_MODE_INNER (mode);
|
|
|
3252 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
|
|
|
3253 if (inner_type != NULL_TREE)
|
|
|
3254 return build_vector_type_for_mode (inner_type, mode);
|
|
|
3255 return NULL_TREE;
|
|
|
3256 }
|
|
|
3257 else
|
|
|
3258 return NULL_TREE;
|
|
|
3259
|
|
|
3260 for (i = 0; i <= MAX_REAL_KINDS; ++i)
|
|
|
3261 {
|
|
|
3262 tree type = base[i];
|
|
|
3263 if (type && mode == TYPE_MODE (type))
|
|
|
3264 return type;
|
|
|
3265 }
|
|
|
3266
|
|
|
3267 return NULL_TREE;
|
|
|
3268 }
|
|
|
3269
|
|
|
3270 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
|
|
|
3271 in that case. */
|
|
|
3272
|
|
|
3273 bool
|
|
|
3274 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
|
|
|
3275 {
|
|
|
3276 int rank, dim;
|
|
|
3277 bool indirect = false;
|
|
|
3278 tree etype, ptype, t, base_decl;
|
|
145
|
3279 tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
|
|
111
|
3280 tree lower_suboff, upper_suboff, stride_suboff;
|
|
131
|
3281 tree dtype, field, rank_off;
|
|
111
|
3282
|
|
|
3283 if (! GFC_DESCRIPTOR_TYPE_P (type))
|
|
|
3284 {
|
|
|
3285 if (! POINTER_TYPE_P (type))
|
|
|
3286 return false;
|
|
|
3287 type = TREE_TYPE (type);
|
|
|
3288 if (! GFC_DESCRIPTOR_TYPE_P (type))
|
|
|
3289 return false;
|
|
|
3290 indirect = true;
|
|
|
3291 }
|
|
|
3292
|
|
|
3293 rank = GFC_TYPE_ARRAY_RANK (type);
|
|
|
3294 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
|
|
|
3295 return false;
|
|
|
3296
|
|
|
3297 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
|
|
|
3298 gcc_assert (POINTER_TYPE_P (etype));
|
|
|
3299 etype = TREE_TYPE (etype);
|
|
|
3300
|
|
|
3301 /* If the type is not a scalar coarray. */
|
|
|
3302 if (TREE_CODE (etype) == ARRAY_TYPE)
|
|
|
3303 etype = TREE_TYPE (etype);
|
|
|
3304
|
|
|
3305 /* Can't handle variable sized elements yet. */
|
|
|
3306 if (int_size_in_bytes (etype) <= 0)
|
|
|
3307 return false;
|
|
|
3308 /* Nor non-constant lower bounds in assumed shape arrays. */
|
|
|
3309 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
|
|
|
3310 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
|
|
|
3311 {
|
|
|
3312 for (dim = 0; dim < rank; dim++)
|
|
|
3313 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
|
|
|
3314 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
|
|
|
3315 return false;
|
|
|
3316 }
|
|
|
3317
|
|
|
3318 memset (info, '\0', sizeof (*info));
|
|
|
3319 info->ndimensions = rank;
|
|
|
3320 info->ordering = array_descr_ordering_column_major;
|
|
|
3321 info->element_type = etype;
|
|
|
3322 ptype = build_pointer_type (gfc_array_index_type);
|
|
|
3323 base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
|
|
|
3324 if (!base_decl)
|
|
|
3325 {
|
|
|
3326 base_decl = make_node (DEBUG_EXPR_DECL);
|
|
|
3327 DECL_ARTIFICIAL (base_decl) = 1;
|
|
|
3328 TREE_TYPE (base_decl) = indirect ? build_pointer_type (ptype) : ptype;
|
|
|
3329 SET_DECL_MODE (base_decl, TYPE_MODE (TREE_TYPE (base_decl)));
|
|
|
3330 GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
|
|
|
3331 }
|
|
|
3332 info->base_decl = base_decl;
|
|
|
3333 if (indirect)
|
|
|
3334 base_decl = build1 (INDIRECT_REF, ptype, base_decl);
|
|
|
3335
|
|
145
|
3336 gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
|
|
|
3337 &dim_off, &dim_size, &stride_suboff,
|
|
111
|
3338 &lower_suboff, &upper_suboff);
|
|
|
3339
|
|
145
|
3340 t = fold_build_pointer_plus (base_decl, span_off);
|
|
|
3341 elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);
|
|
|
3342
|
|
111
|
3343 t = base_decl;
|
|
|
3344 if (!integer_zerop (data_off))
|
|
|
3345 t = fold_build_pointer_plus (t, data_off);
|
|
|
3346 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
|
|
|
3347 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
|
|
|
3348 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
|
|
131
|
3349 info->allocated = build2 (NE_EXPR, logical_type_node,
|
|
111
|
3350 info->data_location, null_pointer_node);
|
|
|
3351 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
|
|
|
3352 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
|
|
131
|
3353 info->associated = build2 (NE_EXPR, logical_type_node,
|
|
111
|
3354 info->data_location, null_pointer_node);
|
|
|
3355 if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
|
|
|
3356 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
|
|
|
3357 && dwarf_version >= 5)
|
|
|
3358 {
|
|
|
3359 rank = 1;
|
|
|
3360 info->ndimensions = 1;
|
|
|
3361 t = base_decl;
|
|
|
3362 if (!integer_zerop (dtype_off))
|
|
|
3363 t = fold_build_pointer_plus (t, dtype_off);
|
|
131
|
3364 dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
|
|
|
3365 field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
|
|
|
3366 rank_off = byte_position (field);
|
|
|
3367 if (!integer_zerop (dtype_off))
|
|
|
3368 t = fold_build_pointer_plus (t, rank_off);
|
|
|
3369
|
|
111
|
3370 t = build1 (NOP_EXPR, build_pointer_type (gfc_array_index_type), t);
|
|
|
3371 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
|
|
131
|
3372 info->rank = t;
|
|
111
|
3373 t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
|
|
|
3374 t = size_binop (MULT_EXPR, t, dim_size);
|
|
|
3375 dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);
|
|
|
3376 }
|
|
|
3377
|
|
|
3378 for (dim = 0; dim < rank; dim++)
|
|
|
3379 {
|
|
|
3380 t = fold_build_pointer_plus (base_decl,
|
|
|
3381 size_binop (PLUS_EXPR,
|
|
|
3382 dim_off, lower_suboff));
|
|
|
3383 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
|
|
|
3384 info->dimen[dim].lower_bound = t;
|
|
|
3385 t = fold_build_pointer_plus (base_decl,
|
|
|
3386 size_binop (PLUS_EXPR,
|
|
|
3387 dim_off, upper_suboff));
|
|
|
3388 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
|
|
|
3389 info->dimen[dim].upper_bound = t;
|
|
|
3390 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
|
|
|
3391 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
|
|
|
3392 {
|
|
|
3393 /* Assumed shape arrays have known lower bounds. */
|
|
|
3394 info->dimen[dim].upper_bound
|
|
|
3395 = build2 (MINUS_EXPR, gfc_array_index_type,
|
|
|
3396 info->dimen[dim].upper_bound,
|
|
|
3397 info->dimen[dim].lower_bound);
|
|
|
3398 info->dimen[dim].lower_bound
|
|
|
3399 = fold_convert (gfc_array_index_type,
|
|
|
3400 GFC_TYPE_ARRAY_LBOUND (type, dim));
|
|
|
3401 info->dimen[dim].upper_bound
|
|
|
3402 = build2 (PLUS_EXPR, gfc_array_index_type,
|
|
|
3403 info->dimen[dim].lower_bound,
|
|
|
3404 info->dimen[dim].upper_bound);
|
|
|
3405 }
|
|
|
3406 t = fold_build_pointer_plus (base_decl,
|
|
|
3407 size_binop (PLUS_EXPR,
|
|
|
3408 dim_off, stride_suboff));
|
|
|
3409 t = build1 (INDIRECT_REF, gfc_array_index_type, t);
|
|
|
3410 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
|
|
|
3411 info->dimen[dim].stride = t;
|
|
|
3412 if (dim + 1 < rank)
|
|
|
3413 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
|
|
|
3414 }
|
|
|
3415
|
|
|
3416 return true;
|
|
|
3417 }
|
|
|
3418
|
|
|
3419
|
|
|
3420 /* Create a type to handle vector subscripts for coarray library calls. It
|
|
|
3421 has the form:
|
|
|
3422 struct caf_vector_t {
|
|
|
3423 size_t nvec; // size of the vector
|
|
|
3424 union {
|
|
|
3425 struct {
|
|
|
3426 void *vector;
|
|
|
3427 int kind;
|
|
|
3428 } v;
|
|
|
3429 struct {
|
|
|
3430 ptrdiff_t lower_bound;
|
|
|
3431 ptrdiff_t upper_bound;
|
|
|
3432 ptrdiff_t stride;
|
|
|
3433 } triplet;
|
|
|
3434 } u;
|
|
|
3435 }
|
|
|
3436 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
|
|
|
3437 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
|
|
|
3438
|
|
|
3439 tree
|
|
|
3440 gfc_get_caf_vector_type (int dim)
|
|
|
3441 {
|
|
|
3442 static tree vector_types[GFC_MAX_DIMENSIONS];
|
|
|
3443 static tree vec_type = NULL_TREE;
|
|
|
3444 tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
|
|
|
3445
|
|
|
3446 if (vector_types[dim-1] != NULL_TREE)
|
|
|
3447 return vector_types[dim-1];
|
|
|
3448
|
|
|
3449 if (vec_type == NULL_TREE)
|
|
|
3450 {
|
|
|
3451 chain = 0;
|
|
|
3452 vect_struct_type = make_node (RECORD_TYPE);
|
|
|
3453 tmp = gfc_add_field_to_struct_1 (vect_struct_type,
|
|
|
3454 get_identifier ("vector"),
|
|
|
3455 pvoid_type_node, &chain);
|
|
|
3456 TREE_NO_WARNING (tmp) = 1;
|
|
|
3457 tmp = gfc_add_field_to_struct_1 (vect_struct_type,
|
|
|
3458 get_identifier ("kind"),
|
|
|
3459 integer_type_node, &chain);
|
|
|
3460 TREE_NO_WARNING (tmp) = 1;
|
|
|
3461 gfc_finish_type (vect_struct_type);
|
|
|
3462
|
|
|
3463 chain = 0;
|
|
|
3464 triplet_struct_type = make_node (RECORD_TYPE);
|
|
|
3465 tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
|
|
|
3466 get_identifier ("lower_bound"),
|
|
|
3467 gfc_array_index_type, &chain);
|
|
|
3468 TREE_NO_WARNING (tmp) = 1;
|
|
|
3469 tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
|
|
|
3470 get_identifier ("upper_bound"),
|
|
|
3471 gfc_array_index_type, &chain);
|
|
|
3472 TREE_NO_WARNING (tmp) = 1;
|
|
|
3473 tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
|
|
|
3474 gfc_array_index_type, &chain);
|
|
|
3475 TREE_NO_WARNING (tmp) = 1;
|
|
|
3476 gfc_finish_type (triplet_struct_type);
|
|
|
3477
|
|
|
3478 chain = 0;
|
|
|
3479 union_type = make_node (UNION_TYPE);
|
|
|
3480 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
|
|
|
3481 vect_struct_type, &chain);
|
|
|
3482 TREE_NO_WARNING (tmp) = 1;
|
|
|
3483 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
|
|
|
3484 triplet_struct_type, &chain);
|
|
|
3485 TREE_NO_WARNING (tmp) = 1;
|
|
|
3486 gfc_finish_type (union_type);
|
|
|
3487
|
|
|
3488 chain = 0;
|
|
|
3489 vec_type = make_node (RECORD_TYPE);
|
|
|
3490 tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
|
|
|
3491 size_type_node, &chain);
|
|
|
3492 TREE_NO_WARNING (tmp) = 1;
|
|
|
3493 tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
|
|
|
3494 union_type, &chain);
|
|
|
3495 TREE_NO_WARNING (tmp) = 1;
|
|
|
3496 gfc_finish_type (vec_type);
|
|
|
3497 TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
|
|
|
3498 }
|
|
|
3499
|
|
|
3500 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
|
|
|
3501 gfc_rank_cst[dim-1]);
|
|
|
3502 vector_types[dim-1] = build_array_type (vec_type, tmp);
|
|
|
3503 return vector_types[dim-1];
|
|
|
3504 }
|
|
|
3505
|
|
|
3506
|
|
|
3507 tree
|
|
|
3508 gfc_get_caf_reference_type ()
|
|
|
3509 {
|
|
|
3510 static tree reference_type = NULL_TREE;
|
|
|
3511 tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type,
|
|
|
3512 a_struct_type, u_union_type, tmp, *chain;
|
|
|
3513
|
|
|
3514 if (reference_type != NULL_TREE)
|
|
|
3515 return reference_type;
|
|
|
3516
|
|
|
3517 chain = 0;
|
|
|
3518 c_struct_type = make_node (RECORD_TYPE);
|
|
|
3519 tmp = gfc_add_field_to_struct_1 (c_struct_type,
|
|
|
3520 get_identifier ("offset"),
|
|
|
3521 gfc_array_index_type, &chain);
|
|
|
3522 TREE_NO_WARNING (tmp) = 1;
|
|
|
3523 tmp = gfc_add_field_to_struct_1 (c_struct_type,
|
|
|
3524 get_identifier ("caf_token_offset"),
|
|
|
3525 gfc_array_index_type, &chain);
|
|
|
3526 TREE_NO_WARNING (tmp) = 1;
|
|
|
3527 gfc_finish_type (c_struct_type);
|
|
|
3528
|
|
|
3529 chain = 0;
|
|
|
3530 s_struct_type = make_node (RECORD_TYPE);
|
|
|
3531 tmp = gfc_add_field_to_struct_1 (s_struct_type,
|
|
|
3532 get_identifier ("start"),
|
|
|
3533 gfc_array_index_type, &chain);
|
|
|
3534 TREE_NO_WARNING (tmp) = 1;
|
|
|
3535 tmp = gfc_add_field_to_struct_1 (s_struct_type,
|
|
|
3536 get_identifier ("end"),
|
|
|
3537 gfc_array_index_type, &chain);
|
|
|
3538 TREE_NO_WARNING (tmp) = 1;
|
|
|
3539 tmp = gfc_add_field_to_struct_1 (s_struct_type,
|
|
|
3540 get_identifier ("stride"),
|
|
|
3541 gfc_array_index_type, &chain);
|
|
|
3542 TREE_NO_WARNING (tmp) = 1;
|
|
|
3543 gfc_finish_type (s_struct_type);
|
|
|
3544
|
|
|
3545 chain = 0;
|
|
|
3546 v_struct_type = make_node (RECORD_TYPE);
|
|
|
3547 tmp = gfc_add_field_to_struct_1 (v_struct_type,
|
|
|
3548 get_identifier ("vector"),
|
|
|
3549 pvoid_type_node, &chain);
|
|
|
3550 TREE_NO_WARNING (tmp) = 1;
|
|
|
3551 tmp = gfc_add_field_to_struct_1 (v_struct_type,
|
|
|
3552 get_identifier ("nvec"),
|
|
|
3553 size_type_node, &chain);
|
|
|
3554 TREE_NO_WARNING (tmp) = 1;
|
|
|
3555 tmp = gfc_add_field_to_struct_1 (v_struct_type,
|
|
|
3556 get_identifier ("kind"),
|
|
|
3557 integer_type_node, &chain);
|
|
|
3558 TREE_NO_WARNING (tmp) = 1;
|
|
|
3559 gfc_finish_type (v_struct_type);
|
|
|
3560
|
|
|
3561 chain = 0;
|
|
|
3562 union_type = make_node (UNION_TYPE);
|
|
|
3563 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"),
|
|
|
3564 s_struct_type, &chain);
|
|
|
3565 TREE_NO_WARNING (tmp) = 1;
|
|
|
3566 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
|
|
|
3567 v_struct_type, &chain);
|
|
|
3568 TREE_NO_WARNING (tmp) = 1;
|
|
|
3569 gfc_finish_type (union_type);
|
|
|
3570
|
|
|
3571 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
|
|
|
3572 gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]);
|
|
|
3573 dim_union_type = build_array_type (union_type, tmp);
|
|
|
3574
|
|
|
3575 chain = 0;
|
|
|
3576 a_struct_type = make_node (RECORD_TYPE);
|
|
|
3577 tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"),
|
|
|
3578 build_array_type (unsigned_char_type_node,
|
|
|
3579 build_range_type (gfc_array_index_type,
|
|
|
3580 gfc_index_zero_node,
|
|
|
3581 gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])),
|
|
|
3582 &chain);
|
|
|
3583 TREE_NO_WARNING (tmp) = 1;
|
|
|
3584 tmp = gfc_add_field_to_struct_1 (a_struct_type,
|
|
|
3585 get_identifier ("static_array_type"),
|
|
|
3586 integer_type_node, &chain);
|
|
|
3587 TREE_NO_WARNING (tmp) = 1;
|
|
|
3588 tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"),
|
|
|
3589 dim_union_type, &chain);
|
|
|
3590 TREE_NO_WARNING (tmp) = 1;
|
|
|
3591 gfc_finish_type (a_struct_type);
|
|
|
3592
|
|
|
3593 chain = 0;
|
|
|
3594 u_union_type = make_node (UNION_TYPE);
|
|
|
3595 tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"),
|
|
|
3596 c_struct_type, &chain);
|
|
|
3597 TREE_NO_WARNING (tmp) = 1;
|
|
|
3598 tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"),
|
|
|
3599 a_struct_type, &chain);
|
|
|
3600 TREE_NO_WARNING (tmp) = 1;
|
|
|
3601 gfc_finish_type (u_union_type);
|
|
|
3602
|
|
|
3603 chain = 0;
|
|
|
3604 reference_type = make_node (RECORD_TYPE);
|
|
|
3605 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"),
|
|
|
3606 build_pointer_type (reference_type), &chain);
|
|
|
3607 TREE_NO_WARNING (tmp) = 1;
|
|
|
3608 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"),
|
|
|
3609 integer_type_node, &chain);
|
|
|
3610 TREE_NO_WARNING (tmp) = 1;
|
|
|
3611 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"),
|
|
|
3612 size_type_node, &chain);
|
|
|
3613 TREE_NO_WARNING (tmp) = 1;
|
|
|
3614 tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"),
|
|
|
3615 u_union_type, &chain);
|
|
|
3616 TREE_NO_WARNING (tmp) = 1;
|
|
|
3617 gfc_finish_type (reference_type);
|
|
|
3618 TYPE_NAME (reference_type) = get_identifier ("caf_reference_t");
|
|
|
3619
|
|
|
3620 return reference_type;
|
|
|
3621 }
|
|
|
3622
|
|
|
3623 #include "gt-fortran-trans-types.h"
|
