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