]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Backend support for Fortran 95 basic types and derived types. |
ef1b6bcd | 2 | Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | and Steven Bosscher <s.bosscher@student.tudelft.nl> | |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
10 | Software Foundation; either version 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b TS |
19 | along with GCC; see the file COPYING. If not, write to the Free |
20 | Software Foundation, 59 Temple Place - Suite 330, Boston, MA | |
21 | 02111-1307, USA. */ | |
6de9cd9a DN |
22 | |
23 | /* trans-types.c -- gfortran backend types */ | |
24 | ||
25 | #include "config.h" | |
26 | #include "system.h" | |
27 | #include "coretypes.h" | |
28 | #include "tree.h" | |
5e8e542f RH |
29 | #include "tm.h" |
30 | #include "target.h" | |
6de9cd9a DN |
31 | #include "ggc.h" |
32 | #include "toplev.h" | |
6de9cd9a DN |
33 | #include "gfortran.h" |
34 | #include "trans.h" | |
35 | #include "trans-types.h" | |
36 | #include "trans-const.h" | |
5e8e542f | 37 | #include "real.h" |
6de9cd9a DN |
38 | \f |
39 | ||
40 | #if (GFC_MAX_DIMENSIONS < 10) | |
41 | #define GFC_RANK_DIGITS 1 | |
42 | #define GFC_RANK_PRINTF_FORMAT "%01d" | |
43 | #elif (GFC_MAX_DIMENSIONS < 100) | |
44 | #define GFC_RANK_DIGITS 2 | |
45 | #define GFC_RANK_PRINTF_FORMAT "%02d" | |
46 | #else | |
47 | #error If you really need >99 dimensions, continue the sequence above... | |
48 | #endif | |
49 | ||
50 | static tree gfc_get_derived_type (gfc_symbol * derived); | |
51 | ||
6de9cd9a | 52 | tree gfc_array_index_type; |
b4838d29 | 53 | tree gfc_array_range_type; |
6de9cd9a DN |
54 | tree pvoid_type_node; |
55 | tree ppvoid_type_node; | |
56 | tree pchar_type_node; | |
e2cad04b | 57 | tree gfc_character1_type_node; |
d7177ab2 | 58 | tree gfc_charlen_type_node; |
6de9cd9a | 59 | |
e2cad04b | 60 | static GTY(()) tree gfc_desc_dim_type; |
6de9cd9a | 61 | static GTY(()) tree gfc_max_array_element_size; |
4c73896d | 62 | static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS]; |
6de9cd9a | 63 | |
5e8e542f RH |
64 | /* Arrays for all integral and real kinds. We'll fill this in at runtime |
65 | after the target has a chance to process command-line options. */ | |
66 | ||
67 | #define MAX_INT_KINDS 5 | |
68 | gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1]; | |
69 | gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1]; | |
e2cad04b RH |
70 | static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1]; |
71 | static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1]; | |
5e8e542f RH |
72 | |
73 | #define MAX_REAL_KINDS 4 | |
74 | gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; | |
e2cad04b RH |
75 | static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1]; |
76 | static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1]; | |
5e8e542f RH |
77 | |
78 | /* The integer kind to use for array indices. This will be set to the | |
79 | proper value based on target information from the backend. */ | |
80 | ||
81 | int gfc_index_integer_kind; | |
82 | ||
83 | /* The default kinds of the various types. */ | |
84 | ||
9d64df18 | 85 | int gfc_default_integer_kind; |
f4e7375a | 86 | int gfc_max_integer_kind; |
9d64df18 TS |
87 | int gfc_default_real_kind; |
88 | int gfc_default_double_kind; | |
89 | int gfc_default_character_kind; | |
90 | int gfc_default_logical_kind; | |
91 | int gfc_default_complex_kind; | |
e8525382 | 92 | int gfc_c_int_kind; |
5e8e542f RH |
93 | |
94 | /* Query the target to determine which machine modes are available for | |
95 | computation. Choose KIND numbers for them. */ | |
96 | ||
97 | void | |
98 | gfc_init_kinds (void) | |
99 | { | |
100 | enum machine_mode mode; | |
101 | int i_index, r_index; | |
102 | bool saw_i4 = false, saw_i8 = false; | |
103 | bool saw_r4 = false, saw_r8 = false, saw_r16 = false; | |
104 | ||
105 | for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++) | |
106 | { | |
107 | int kind, bitsize; | |
108 | ||
109 | if (!targetm.scalar_mode_supported_p (mode)) | |
110 | continue; | |
111 | ||
04204c2f RH |
112 | /* The middle end doesn't support constants larger than 2*HWI. |
113 | Perhaps the target hook shouldn't have accepted these either, | |
114 | but just to be safe... */ | |
115 | bitsize = GET_MODE_BITSIZE (mode); | |
116 | if (bitsize > 2*HOST_BITS_PER_WIDE_INT) | |
117 | continue; | |
118 | ||
6e45f57b | 119 | gcc_assert (i_index != MAX_INT_KINDS); |
5e8e542f RH |
120 | |
121 | /* Let the kind equal the bit size divided by 8. This insulates the | |
122 | programmer from the underlying byte size. */ | |
5e8e542f RH |
123 | kind = bitsize / 8; |
124 | ||
125 | if (kind == 4) | |
126 | saw_i4 = true; | |
127 | if (kind == 8) | |
128 | saw_i8 = true; | |
129 | ||
130 | gfc_integer_kinds[i_index].kind = kind; | |
131 | gfc_integer_kinds[i_index].radix = 2; | |
132 | gfc_integer_kinds[i_index].digits = bitsize - 1; | |
133 | gfc_integer_kinds[i_index].bit_size = bitsize; | |
134 | ||
135 | gfc_logical_kinds[i_index].kind = kind; | |
136 | gfc_logical_kinds[i_index].bit_size = bitsize; | |
137 | ||
138 | i_index += 1; | |
139 | } | |
140 | ||
f4e7375a SK |
141 | /* Set the maximum integer kind. Used with at least BOZ constants. */ |
142 | gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind; | |
143 | ||
5e8e542f RH |
144 | for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++) |
145 | { | |
146 | const struct real_format *fmt = REAL_MODE_FORMAT (mode); | |
147 | int kind; | |
148 | ||
149 | if (fmt == NULL) | |
150 | continue; | |
151 | if (!targetm.scalar_mode_supported_p (mode)) | |
152 | continue; | |
153 | ||
154 | /* Let the kind equal the precision divided by 8, rounding up. Again, | |
155 | this insulates the programmer from the underlying byte size. | |
156 | ||
157 | Also, it effectively deals with IEEE extended formats. There, the | |
158 | total size of the type may equal 16, but it's got 6 bytes of padding | |
159 | and the increased size can get in the way of a real IEEE quad format | |
160 | which may also be supported by the target. | |
161 | ||
162 | We round up so as to handle IA-64 __floatreg (RFmode), which is an | |
163 | 82 bit type. Not to be confused with __float80 (XFmode), which is | |
164 | an 80 bit type also supported by IA-64. So XFmode should come out | |
165 | to be kind=10, and RFmode should come out to be kind=11. Egads. */ | |
166 | ||
167 | kind = (GET_MODE_PRECISION (mode) + 7) / 8; | |
168 | ||
169 | if (kind == 4) | |
170 | saw_r4 = true; | |
171 | if (kind == 8) | |
172 | saw_r8 = true; | |
173 | if (kind == 16) | |
174 | saw_r16 = true; | |
175 | ||
176 | /* Careful we don't stumble a wierd internal mode. */ | |
6e45f57b | 177 | gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind); |
5e8e542f | 178 | /* Or have too many modes for the allocated space. */ |
6e45f57b | 179 | gcc_assert (r_index != MAX_REAL_KINDS); |
5e8e542f RH |
180 | |
181 | gfc_real_kinds[r_index].kind = kind; | |
182 | gfc_real_kinds[r_index].radix = fmt->b; | |
183 | gfc_real_kinds[r_index].digits = fmt->p; | |
184 | gfc_real_kinds[r_index].min_exponent = fmt->emin; | |
185 | gfc_real_kinds[r_index].max_exponent = fmt->emax; | |
e2cad04b | 186 | gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode); |
5e8e542f RH |
187 | r_index += 1; |
188 | } | |
189 | ||
190 | /* Choose the default integer kind. We choose 4 unless the user | |
191 | directs us otherwise. */ | |
3ae9eb27 | 192 | if (gfc_option.flag_default_integer) |
5e8e542f RH |
193 | { |
194 | if (!saw_i8) | |
3ae9eb27 | 195 | fatal_error ("integer kind=8 not available for -fdefault-integer-8 option"); |
9d64df18 | 196 | gfc_default_integer_kind = 8; |
5e8e542f RH |
197 | } |
198 | else if (saw_i4) | |
9d64df18 | 199 | gfc_default_integer_kind = 4; |
5e8e542f | 200 | else |
9d64df18 | 201 | gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind; |
5e8e542f RH |
202 | |
203 | /* Choose the default real kind. Again, we choose 4 when possible. */ | |
3ae9eb27 | 204 | if (gfc_option.flag_default_real) |
5e8e542f RH |
205 | { |
206 | if (!saw_r8) | |
3ae9eb27 | 207 | fatal_error ("real kind=8 not available for -fdefault-real-8 option"); |
9d64df18 | 208 | gfc_default_real_kind = 8; |
5e8e542f RH |
209 | } |
210 | else if (saw_r4) | |
9d64df18 | 211 | gfc_default_real_kind = 4; |
5e8e542f | 212 | else |
9d64df18 | 213 | gfc_default_real_kind = gfc_real_kinds[0].kind; |
5e8e542f | 214 | |
3ae9eb27 SK |
215 | /* Choose the default double kind. If -fdefault-real and -fdefault-double |
216 | are specified, we use kind=8, if it's available. If -fdefault-real is | |
217 | specified without -fdefault-double, we use kind=16, if it's available. | |
218 | Otherwise we do not change anything. */ | |
219 | if (gfc_option.flag_default_double && !gfc_option.flag_default_real) | |
220 | fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8"); | |
221 | ||
222 | if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8) | |
223 | gfc_default_double_kind = 8; | |
224 | else if (gfc_option.flag_default_real && saw_r16) | |
9d64df18 | 225 | gfc_default_double_kind = 16; |
5e8e542f | 226 | else if (saw_r4 && saw_r8) |
9d64df18 | 227 | gfc_default_double_kind = 8; |
5e8e542f RH |
228 | else |
229 | { | |
230 | /* F95 14.6.3.1: A nonpointer scalar object of type double precision | |
231 | real ... occupies two contiguous numeric storage units. | |
232 | ||
233 | Therefore we must be supplied a kind twice as large as we chose | |
234 | for single precision. There are loopholes, in that double | |
235 | precision must *occupy* two storage units, though it doesn't have | |
236 | to *use* two storage units. Which means that you can make this | |
237 | kind artificially wide by padding it. But at present there are | |
238 | no GCC targets for which a two-word type does not exist, so we | |
239 | just let gfc_validate_kind abort and tell us if something breaks. */ | |
240 | ||
9d64df18 TS |
241 | gfc_default_double_kind |
242 | = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false); | |
5e8e542f RH |
243 | } |
244 | ||
245 | /* The default logical kind is constrained to be the same as the | |
246 | default integer kind. Similarly with complex and real. */ | |
9d64df18 TS |
247 | gfc_default_logical_kind = gfc_default_integer_kind; |
248 | gfc_default_complex_kind = gfc_default_real_kind; | |
5e8e542f RH |
249 | |
250 | /* Choose the smallest integer kind for our default character. */ | |
9d64df18 | 251 | gfc_default_character_kind = gfc_integer_kinds[0].kind; |
5e8e542f RH |
252 | |
253 | /* Choose the integer kind the same size as "void*" for our index kind. */ | |
254 | gfc_index_integer_kind = POINTER_SIZE / 8; | |
e8525382 SK |
255 | /* Pick a kind the same size as the C "int" type. */ |
256 | gfc_c_int_kind = INT_TYPE_SIZE / 8; | |
5e8e542f RH |
257 | } |
258 | ||
5e8e542f RH |
259 | /* Make sure that a valid kind is present. Returns an index into the |
260 | associated kinds array, -1 if the kind is not present. */ | |
261 | ||
262 | static int | |
263 | validate_integer (int kind) | |
264 | { | |
265 | int i; | |
266 | ||
267 | for (i = 0; gfc_integer_kinds[i].kind != 0; i++) | |
268 | if (gfc_integer_kinds[i].kind == kind) | |
269 | return i; | |
270 | ||
271 | return -1; | |
272 | } | |
273 | ||
274 | static int | |
275 | validate_real (int kind) | |
276 | { | |
277 | int i; | |
278 | ||
279 | for (i = 0; gfc_real_kinds[i].kind != 0; i++) | |
280 | if (gfc_real_kinds[i].kind == kind) | |
281 | return i; | |
282 | ||
283 | return -1; | |
284 | } | |
285 | ||
286 | static int | |
287 | validate_logical (int kind) | |
288 | { | |
289 | int i; | |
290 | ||
291 | for (i = 0; gfc_logical_kinds[i].kind; i++) | |
292 | if (gfc_logical_kinds[i].kind == kind) | |
293 | return i; | |
294 | ||
295 | return -1; | |
296 | } | |
297 | ||
298 | static int | |
299 | validate_character (int kind) | |
300 | { | |
9d64df18 | 301 | return kind == gfc_default_character_kind ? 0 : -1; |
5e8e542f RH |
302 | } |
303 | ||
304 | /* Validate a kind given a basic type. The return value is the same | |
305 | for the child functions, with -1 indicating nonexistence of the | |
306 | type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */ | |
307 | ||
308 | int | |
309 | gfc_validate_kind (bt type, int kind, bool may_fail) | |
310 | { | |
311 | int rc; | |
312 | ||
313 | switch (type) | |
314 | { | |
315 | case BT_REAL: /* Fall through */ | |
316 | case BT_COMPLEX: | |
317 | rc = validate_real (kind); | |
318 | break; | |
319 | case BT_INTEGER: | |
320 | rc = validate_integer (kind); | |
321 | break; | |
322 | case BT_LOGICAL: | |
323 | rc = validate_logical (kind); | |
324 | break; | |
325 | case BT_CHARACTER: | |
326 | rc = validate_character (kind); | |
327 | break; | |
328 | ||
329 | default: | |
330 | gfc_internal_error ("gfc_validate_kind(): Got bad type"); | |
331 | } | |
332 | ||
333 | if (rc < 0 && !may_fail) | |
334 | gfc_internal_error ("gfc_validate_kind(): Got bad kind"); | |
335 | ||
336 | return rc; | |
337 | } | |
338 | ||
339 | ||
e2cad04b RH |
340 | /* Four subroutines of gfc_init_types. Create type nodes for the given kind. |
341 | Reuse common type nodes where possible. Recognize if the kind matches up | |
342 | with a C type. This will be used later in determining which routines may | |
343 | be scarfed from libm. */ | |
344 | ||
345 | static tree | |
346 | gfc_build_int_type (gfc_integer_info *info) | |
347 | { | |
348 | int mode_precision = info->bit_size; | |
349 | ||
350 | if (mode_precision == CHAR_TYPE_SIZE) | |
351 | info->c_char = 1; | |
352 | if (mode_precision == SHORT_TYPE_SIZE) | |
353 | info->c_short = 1; | |
354 | if (mode_precision == INT_TYPE_SIZE) | |
355 | info->c_int = 1; | |
356 | if (mode_precision == LONG_TYPE_SIZE) | |
357 | info->c_long = 1; | |
358 | if (mode_precision == LONG_LONG_TYPE_SIZE) | |
359 | info->c_long_long = 1; | |
360 | ||
361 | if (TYPE_PRECISION (intQI_type_node) == mode_precision) | |
362 | return intQI_type_node; | |
363 | if (TYPE_PRECISION (intHI_type_node) == mode_precision) | |
364 | return intHI_type_node; | |
365 | if (TYPE_PRECISION (intSI_type_node) == mode_precision) | |
366 | return intSI_type_node; | |
367 | if (TYPE_PRECISION (intDI_type_node) == mode_precision) | |
368 | return intDI_type_node; | |
369 | if (TYPE_PRECISION (intTI_type_node) == mode_precision) | |
370 | return intTI_type_node; | |
371 | ||
372 | return make_signed_type (mode_precision); | |
373 | } | |
374 | ||
375 | static tree | |
376 | gfc_build_real_type (gfc_real_info *info) | |
377 | { | |
378 | int mode_precision = info->mode_precision; | |
379 | tree new_type; | |
380 | ||
381 | if (mode_precision == FLOAT_TYPE_SIZE) | |
382 | info->c_float = 1; | |
383 | if (mode_precision == DOUBLE_TYPE_SIZE) | |
384 | info->c_double = 1; | |
385 | if (mode_precision == LONG_DOUBLE_TYPE_SIZE) | |
386 | info->c_long_double = 1; | |
387 | ||
388 | if (TYPE_PRECISION (float_type_node) == mode_precision) | |
389 | return float_type_node; | |
390 | if (TYPE_PRECISION (double_type_node) == mode_precision) | |
391 | return double_type_node; | |
392 | if (TYPE_PRECISION (long_double_type_node) == mode_precision) | |
393 | return long_double_type_node; | |
394 | ||
395 | new_type = make_node (REAL_TYPE); | |
396 | TYPE_PRECISION (new_type) = mode_precision; | |
397 | layout_type (new_type); | |
398 | return new_type; | |
399 | } | |
400 | ||
401 | static tree | |
402 | gfc_build_complex_type (tree scalar_type) | |
403 | { | |
404 | tree new_type; | |
405 | ||
406 | if (scalar_type == NULL) | |
407 | return NULL; | |
408 | if (scalar_type == float_type_node) | |
409 | return complex_float_type_node; | |
410 | if (scalar_type == double_type_node) | |
411 | return complex_double_type_node; | |
412 | if (scalar_type == long_double_type_node) | |
413 | return complex_long_double_type_node; | |
414 | ||
415 | new_type = make_node (COMPLEX_TYPE); | |
416 | TREE_TYPE (new_type) = scalar_type; | |
417 | layout_type (new_type); | |
418 | return new_type; | |
419 | } | |
420 | ||
421 | static tree | |
422 | gfc_build_logical_type (gfc_logical_info *info) | |
423 | { | |
424 | int bit_size = info->bit_size; | |
425 | tree new_type; | |
426 | ||
427 | if (bit_size == BOOL_TYPE_SIZE) | |
428 | { | |
429 | info->c_bool = 1; | |
430 | return boolean_type_node; | |
431 | } | |
432 | ||
433 | new_type = make_unsigned_type (bit_size); | |
434 | TREE_SET_CODE (new_type, BOOLEAN_TYPE); | |
435 | TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1); | |
436 | TYPE_PRECISION (new_type) = 1; | |
437 | ||
438 | return new_type; | |
439 | } | |
440 | ||
441 | #if 0 | |
442 | /* Return the bit size of the C "size_t". */ | |
443 | ||
444 | static unsigned int | |
445 | c_size_t_size (void) | |
446 | { | |
447 | #ifdef SIZE_TYPE | |
448 | if (strcmp (SIZE_TYPE, "unsigned int") == 0) | |
449 | return INT_TYPE_SIZE; | |
450 | if (strcmp (SIZE_TYPE, "long unsigned int") == 0) | |
451 | return LONG_TYPE_SIZE; | |
452 | if (strcmp (SIZE_TYPE, "short unsigned int") == 0) | |
453 | return SHORT_TYPE_SIZE; | |
6e45f57b | 454 | gcc_unreachable (); |
e2cad04b RH |
455 | #else |
456 | return LONG_TYPE_SIZE; | |
457 | #endif | |
458 | } | |
459 | #endif | |
460 | ||
6de9cd9a DN |
461 | /* Create the backend type nodes. We map them to their |
462 | equivalent C type, at least for now. We also give | |
463 | names to the types here, and we push them in the | |
464 | global binding level context.*/ | |
c3e8c6b8 | 465 | |
6de9cd9a DN |
466 | void |
467 | gfc_init_types (void) | |
468 | { | |
e2cad04b RH |
469 | char name_buf[16]; |
470 | int index; | |
471 | tree type; | |
6de9cd9a DN |
472 | unsigned n; |
473 | unsigned HOST_WIDE_INT hi; | |
474 | unsigned HOST_WIDE_INT lo; | |
475 | ||
e2cad04b | 476 | /* Create and name the types. */ |
6de9cd9a DN |
477 | #define PUSH_TYPE(name, node) \ |
478 | pushdecl (build_decl (TYPE_DECL, get_identifier (name), node)) | |
479 | ||
e2cad04b RH |
480 | for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) |
481 | { | |
482 | type = gfc_build_int_type (&gfc_integer_kinds[index]); | |
483 | gfc_integer_types[index] = type; | |
484 | snprintf (name_buf, sizeof(name_buf), "int%d", | |
485 | gfc_integer_kinds[index].kind); | |
486 | PUSH_TYPE (name_buf, type); | |
487 | } | |
6de9cd9a | 488 | |
e2cad04b RH |
489 | for (index = 0; gfc_logical_kinds[index].kind != 0; ++index) |
490 | { | |
491 | type = gfc_build_logical_type (&gfc_logical_kinds[index]); | |
492 | gfc_logical_types[index] = type; | |
493 | snprintf (name_buf, sizeof(name_buf), "logical%d", | |
494 | gfc_logical_kinds[index].kind); | |
495 | PUSH_TYPE (name_buf, type); | |
496 | } | |
6de9cd9a | 497 | |
e2cad04b RH |
498 | for (index = 0; gfc_real_kinds[index].kind != 0; index++) |
499 | { | |
500 | type = gfc_build_real_type (&gfc_real_kinds[index]); | |
501 | gfc_real_types[index] = type; | |
502 | snprintf (name_buf, sizeof(name_buf), "real%d", | |
503 | gfc_real_kinds[index].kind); | |
504 | PUSH_TYPE (name_buf, type); | |
505 | ||
506 | type = gfc_build_complex_type (type); | |
507 | gfc_complex_types[index] = type; | |
508 | snprintf (name_buf, sizeof(name_buf), "complex%d", | |
509 | gfc_real_kinds[index].kind); | |
510 | PUSH_TYPE (name_buf, type); | |
511 | } | |
6de9cd9a | 512 | |
149a42dd TS |
513 | gfc_character1_type_node = build_type_variant (unsigned_char_type_node, |
514 | 0, 0); | |
6de9cd9a DN |
515 | PUSH_TYPE ("char", gfc_character1_type_node); |
516 | ||
517 | PUSH_TYPE ("byte", unsigned_char_type_node); | |
518 | PUSH_TYPE ("void", void_type_node); | |
519 | ||
520 | /* DBX debugging output gets upset if these aren't set. */ | |
521 | if (!TYPE_NAME (integer_type_node)) | |
522 | PUSH_TYPE ("c_integer", integer_type_node); | |
523 | if (!TYPE_NAME (char_type_node)) | |
524 | PUSH_TYPE ("c_char", char_type_node); | |
e2cad04b | 525 | |
6de9cd9a DN |
526 | #undef PUSH_TYPE |
527 | ||
528 | pvoid_type_node = build_pointer_type (void_type_node); | |
529 | ppvoid_type_node = build_pointer_type (pvoid_type_node); | |
530 | pchar_type_node = build_pointer_type (gfc_character1_type_node); | |
531 | ||
6de9cd9a | 532 | gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); |
b4838d29 ZD |
533 | /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type, |
534 | since this function is called before gfc_init_constants. */ | |
535 | gfc_array_range_type | |
536 | = build_range_type (gfc_array_index_type, | |
537 | build_int_cst (gfc_array_index_type, 0), | |
538 | NULL_TREE); | |
6de9cd9a DN |
539 | |
540 | /* The maximum array element size that can be handled is determined | |
541 | by the number of bits available to store this field in the array | |
542 | descriptor. */ | |
543 | ||
e2cad04b RH |
544 | n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT; |
545 | lo = ~ (unsigned HOST_WIDE_INT) 0; | |
546 | if (n > HOST_BITS_PER_WIDE_INT) | |
547 | hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n); | |
6de9cd9a | 548 | else |
e2cad04b | 549 | hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n; |
7d60be94 NS |
550 | gfc_max_array_element_size |
551 | = build_int_cst_wide (long_unsigned_type_node, lo, hi); | |
6de9cd9a DN |
552 | |
553 | size_type_node = gfc_array_index_type; | |
6de9cd9a | 554 | |
e2cad04b | 555 | boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind); |
7d60be94 NS |
556 | boolean_true_node = build_int_cst (boolean_type_node, 1); |
557 | boolean_false_node = build_int_cst (boolean_type_node, 0); | |
e2cad04b RH |
558 | |
559 | /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */ | |
d7177ab2 | 560 | gfc_charlen_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
561 | } |
562 | ||
e2cad04b | 563 | /* Get the type node for the given type and kind. */ |
c3e8c6b8 | 564 | |
6de9cd9a DN |
565 | tree |
566 | gfc_get_int_type (int kind) | |
567 | { | |
e2cad04b RH |
568 | int index = gfc_validate_kind (BT_INTEGER, kind, false); |
569 | return gfc_integer_types[index]; | |
6de9cd9a DN |
570 | } |
571 | ||
6de9cd9a DN |
572 | tree |
573 | gfc_get_real_type (int kind) | |
574 | { | |
e2cad04b RH |
575 | int index = gfc_validate_kind (BT_REAL, kind, false); |
576 | return gfc_real_types[index]; | |
6de9cd9a DN |
577 | } |
578 | ||
6de9cd9a DN |
579 | tree |
580 | gfc_get_complex_type (int kind) | |
581 | { | |
e2cad04b RH |
582 | int index = gfc_validate_kind (BT_COMPLEX, kind, false); |
583 | return gfc_complex_types[index]; | |
6de9cd9a DN |
584 | } |
585 | ||
6de9cd9a DN |
586 | tree |
587 | gfc_get_logical_type (int kind) | |
588 | { | |
e2cad04b RH |
589 | int index = gfc_validate_kind (BT_LOGICAL, kind, false); |
590 | return gfc_logical_types[index]; | |
6de9cd9a DN |
591 | } |
592 | \f | |
40f20186 | 593 | /* Create a character type with the given kind and length. */ |
c3e8c6b8 | 594 | |
6de9cd9a | 595 | tree |
40f20186 | 596 | gfc_get_character_type_len (int kind, tree len) |
6de9cd9a | 597 | { |
e2cad04b | 598 | tree bounds, type; |
6de9cd9a | 599 | |
e2cad04b | 600 | gfc_validate_kind (BT_CHARACTER, kind, false); |
6de9cd9a | 601 | |
5e3b8727 | 602 | bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); |
e2cad04b | 603 | type = build_array_type (gfc_character1_type_node, bounds); |
6de9cd9a DN |
604 | TYPE_STRING_FLAG (type) = 1; |
605 | ||
606 | return type; | |
607 | } | |
40f20186 PB |
608 | |
609 | ||
610 | /* Get a type node for a character kind. */ | |
611 | ||
612 | tree | |
613 | gfc_get_character_type (int kind, gfc_charlen * cl) | |
614 | { | |
615 | tree len; | |
616 | ||
617 | len = (cl == NULL) ? NULL_TREE : cl->backend_decl; | |
618 | ||
619 | return gfc_get_character_type_len (kind, len); | |
620 | } | |
6de9cd9a DN |
621 | \f |
622 | /* Covert a basic type. This will be an array for character types. */ | |
c3e8c6b8 | 623 | |
6de9cd9a DN |
624 | tree |
625 | gfc_typenode_for_spec (gfc_typespec * spec) | |
626 | { | |
627 | tree basetype; | |
628 | ||
629 | switch (spec->type) | |
630 | { | |
631 | case BT_UNKNOWN: | |
6e45f57b | 632 | gcc_unreachable (); |
6de9cd9a DN |
633 | |
634 | case BT_INTEGER: | |
635 | basetype = gfc_get_int_type (spec->kind); | |
636 | break; | |
637 | ||
638 | case BT_REAL: | |
639 | basetype = gfc_get_real_type (spec->kind); | |
640 | break; | |
641 | ||
642 | case BT_COMPLEX: | |
643 | basetype = gfc_get_complex_type (spec->kind); | |
644 | break; | |
645 | ||
646 | case BT_LOGICAL: | |
647 | basetype = gfc_get_logical_type (spec->kind); | |
648 | break; | |
649 | ||
650 | case BT_CHARACTER: | |
651 | basetype = gfc_get_character_type (spec->kind, spec->cl); | |
652 | break; | |
653 | ||
654 | case BT_DERIVED: | |
655 | basetype = gfc_get_derived_type (spec->derived); | |
656 | break; | |
657 | ||
658 | default: | |
6e45f57b | 659 | gcc_unreachable (); |
6de9cd9a DN |
660 | } |
661 | return basetype; | |
662 | } | |
663 | \f | |
664 | /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */ | |
c3e8c6b8 | 665 | |
6de9cd9a DN |
666 | static tree |
667 | gfc_conv_array_bound (gfc_expr * expr) | |
668 | { | |
669 | /* If expr is an integer constant, return that. */ | |
670 | if (expr != NULL && expr->expr_type == EXPR_CONSTANT) | |
671 | return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); | |
672 | ||
673 | /* Otherwise return NULL. */ | |
674 | return NULL_TREE; | |
675 | } | |
676 | \f | |
677 | tree | |
678 | gfc_get_element_type (tree type) | |
679 | { | |
680 | tree element; | |
681 | ||
682 | if (GFC_ARRAY_TYPE_P (type)) | |
683 | { | |
684 | if (TREE_CODE (type) == POINTER_TYPE) | |
685 | type = TREE_TYPE (type); | |
6e45f57b | 686 | gcc_assert (TREE_CODE (type) == ARRAY_TYPE); |
6de9cd9a DN |
687 | element = TREE_TYPE (type); |
688 | } | |
689 | else | |
690 | { | |
6e45f57b | 691 | gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); |
4c73896d | 692 | element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); |
6de9cd9a | 693 | |
6e45f57b | 694 | gcc_assert (TREE_CODE (element) == POINTER_TYPE); |
6de9cd9a DN |
695 | element = TREE_TYPE (element); |
696 | ||
6e45f57b | 697 | gcc_assert (TREE_CODE (element) == ARRAY_TYPE); |
6de9cd9a DN |
698 | element = TREE_TYPE (element); |
699 | } | |
700 | ||
701 | return element; | |
702 | } | |
703 | \f | |
704 | /* Build an array. This function is called from gfc_sym_type(). | |
c3e8c6b8 | 705 | Actually returns array descriptor type. |
6de9cd9a DN |
706 | |
707 | Format of array descriptors is as follows: | |
708 | ||
709 | struct gfc_array_descriptor | |
710 | { | |
711 | array *data | |
712 | index offset; | |
713 | index dtype; | |
714 | struct descriptor_dimension dimension[N_DIM]; | |
715 | } | |
716 | ||
717 | struct descriptor_dimension | |
718 | { | |
719 | index stride; | |
720 | index lbound; | |
721 | index ubound; | |
722 | } | |
723 | ||
724 | Translation code should use gfc_conv_descriptor_* rather than accessing | |
725 | the descriptor directly. Any changes to the array descriptor type will | |
726 | require changes in gfc_conv_descriptor_* and gfc_build_array_initializer. | |
727 | ||
c3e8c6b8 | 728 | This is represented internally as a RECORD_TYPE. The index nodes are |
6de9cd9a DN |
729 | gfc_array_index_type and the data node is a pointer to the data. See below |
730 | for the handling of character types. | |
731 | ||
732 | The dtype member is formatted as follows: | |
733 | rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits | |
734 | type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits | |
735 | size = dtype >> GFC_DTYPE_SIZE_SHIFT | |
736 | ||
c3e8c6b8 | 737 | I originally used nested ARRAY_TYPE nodes to represent arrays, but this |
6de9cd9a | 738 | generated poor code for assumed/deferred size arrays. These require |
c3e8c6b8 | 739 | use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC |
6de9cd9a DN |
740 | grammar. Also, there is no way to explicitly set the array stride, so |
741 | all data must be packed(1). I've tried to mark all the functions which | |
742 | would require modification with a GCC ARRAYS comment. | |
743 | ||
744 | The data component points to the first element in the array. | |
745 | The offset field is the position of the origin of the array | |
746 | (ie element (0, 0 ...)). This may be outsite the bounds of the array. | |
747 | ||
748 | An element is accessed by | |
749 | data[offset + index0*stride0 + index1*stride1 + index2*stride2] | |
c3e8c6b8 | 750 | This gives good performance as the computation does not involve the |
6de9cd9a DN |
751 | bounds of the array. For packed arrays, this is optimized further by |
752 | substituting the known strides. | |
753 | ||
754 | This system has one problem: all array bounds must be withing 2^31 elements | |
755 | of the origin (2^63 on 64-bit machines). For example | |
756 | integer, dimension (80000:90000, 80000:90000, 2) :: array | |
757 | may not work properly on 32-bit machines because 80000*80000 > 2^31, so | |
758 | the calculation for stride02 would overflow. This may still work, but | |
759 | I haven't checked, and it relies on the overflow doing the right thing. | |
760 | ||
1f2959f0 | 761 | The way to fix this problem is to access elements as follows: |
6de9cd9a DN |
762 | data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1] |
763 | Obviously this is much slower. I will make this a compile time option, | |
764 | something like -fsmall-array-offsets. Mixing code compiled with and without | |
765 | this switch will work. | |
766 | ||
767 | (1) This can be worked around by modifying the upper bound of the previous | |
768 | dimension. This requires extra fields in the descriptor (both real_ubound | |
769 | and fake_ubound). In tree.def there is mention of TYPE_SEP, which | |
770 | may allow us to do this. However I can't find mention of this anywhere | |
436529ea | 771 | else. */ |
6de9cd9a DN |
772 | |
773 | ||
774 | /* Returns true if the array sym does not require a descriptor. */ | |
775 | ||
776 | int | |
777 | gfc_is_nodesc_array (gfc_symbol * sym) | |
778 | { | |
6e45f57b | 779 | gcc_assert (sym->attr.dimension); |
6de9cd9a DN |
780 | |
781 | /* We only want local arrays. */ | |
782 | if (sym->attr.pointer || sym->attr.allocatable) | |
783 | return 0; | |
784 | ||
785 | if (sym->attr.dummy) | |
786 | { | |
787 | if (sym->as->type != AS_ASSUMED_SHAPE) | |
788 | return 1; | |
789 | else | |
790 | return 0; | |
791 | } | |
792 | ||
793 | if (sym->attr.result || sym->attr.function) | |
794 | return 0; | |
795 | ||
6e45f57b | 796 | gcc_assert (sym->as->type == AS_EXPLICIT); |
6de9cd9a DN |
797 | |
798 | return 1; | |
799 | } | |
800 | ||
40f20186 PB |
801 | |
802 | /* Create an array descriptor type. */ | |
803 | ||
6de9cd9a DN |
804 | static tree |
805 | gfc_build_array_type (tree type, gfc_array_spec * as) | |
806 | { | |
807 | tree lbound[GFC_MAX_DIMENSIONS]; | |
808 | tree ubound[GFC_MAX_DIMENSIONS]; | |
809 | int n; | |
810 | ||
811 | for (n = 0; n < as->rank; n++) | |
812 | { | |
813 | /* Create expressions for the known bounds of the array. */ | |
814 | if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL) | |
7ab92584 | 815 | lbound[n] = gfc_index_one_node; |
6de9cd9a DN |
816 | else |
817 | lbound[n] = gfc_conv_array_bound (as->lower[n]); | |
818 | ubound[n] = gfc_conv_array_bound (as->upper[n]); | |
819 | } | |
820 | ||
821 | return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0); | |
822 | } | |
823 | \f | |
824 | /* Returns the struct descriptor_dimension type. */ | |
c3e8c6b8 | 825 | |
6de9cd9a DN |
826 | static tree |
827 | gfc_get_desc_dim_type (void) | |
828 | { | |
829 | tree type; | |
830 | tree decl; | |
831 | tree fieldlist; | |
832 | ||
833 | if (gfc_desc_dim_type) | |
834 | return gfc_desc_dim_type; | |
835 | ||
836 | /* Build the type node. */ | |
837 | type = make_node (RECORD_TYPE); | |
838 | ||
839 | TYPE_NAME (type) = get_identifier ("descriptor_dimension"); | |
840 | TYPE_PACKED (type) = 1; | |
841 | ||
842 | /* Consists of the stride, lbound and ubound members. */ | |
843 | decl = build_decl (FIELD_DECL, | |
844 | get_identifier ("stride"), gfc_array_index_type); | |
845 | DECL_CONTEXT (decl) = type; | |
846 | fieldlist = decl; | |
847 | ||
848 | decl = build_decl (FIELD_DECL, | |
849 | get_identifier ("lbound"), gfc_array_index_type); | |
850 | DECL_CONTEXT (decl) = type; | |
851 | fieldlist = chainon (fieldlist, decl); | |
852 | ||
853 | decl = build_decl (FIELD_DECL, | |
854 | get_identifier ("ubound"), gfc_array_index_type); | |
855 | DECL_CONTEXT (decl) = type; | |
856 | fieldlist = chainon (fieldlist, decl); | |
857 | ||
858 | /* Finish off the type. */ | |
859 | TYPE_FIELDS (type) = fieldlist; | |
860 | ||
861 | gfc_finish_type (type); | |
862 | ||
863 | gfc_desc_dim_type = type; | |
864 | return type; | |
865 | } | |
866 | ||
40b026d8 | 867 | |
43a5ef69 | 868 | /* Return the DTYPE for an array. This describes the type and type parameters |
40b026d8 PB |
869 | of the array. */ |
870 | /* TODO: Only call this when the value is actually used, and make all the | |
871 | unknown cases abort. */ | |
872 | ||
873 | tree | |
874 | gfc_get_dtype (tree type) | |
6de9cd9a DN |
875 | { |
876 | tree size; | |
877 | int n; | |
878 | HOST_WIDE_INT i; | |
879 | tree tmp; | |
880 | tree dtype; | |
40b026d8 PB |
881 | tree etype; |
882 | int rank; | |
883 | ||
884 | gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); | |
885 | ||
886 | if (GFC_TYPE_ARRAY_DTYPE (type)) | |
887 | return GFC_TYPE_ARRAY_DTYPE (type); | |
6de9cd9a | 888 | |
40b026d8 PB |
889 | rank = GFC_TYPE_ARRAY_RANK (type); |
890 | etype = gfc_get_element_type (type); | |
6de9cd9a | 891 | |
40b026d8 | 892 | switch (TREE_CODE (etype)) |
6de9cd9a DN |
893 | { |
894 | case INTEGER_TYPE: | |
895 | n = GFC_DTYPE_INTEGER; | |
896 | break; | |
897 | ||
898 | case BOOLEAN_TYPE: | |
899 | n = GFC_DTYPE_LOGICAL; | |
900 | break; | |
901 | ||
902 | case REAL_TYPE: | |
903 | n = GFC_DTYPE_REAL; | |
904 | break; | |
905 | ||
906 | case COMPLEX_TYPE: | |
907 | n = GFC_DTYPE_COMPLEX; | |
908 | break; | |
909 | ||
40b026d8 | 910 | /* We will never have arrays of arrays. */ |
6de9cd9a DN |
911 | case RECORD_TYPE: |
912 | n = GFC_DTYPE_DERIVED; | |
913 | break; | |
914 | ||
915 | case ARRAY_TYPE: | |
916 | n = GFC_DTYPE_CHARACTER; | |
917 | break; | |
918 | ||
919 | default: | |
40f20186 PB |
920 | /* TODO: Don't do dtype for temporary descriptorless arrays. */ |
921 | /* We can strange array types for temporary arrays. */ | |
922 | return gfc_index_zero_node; | |
6de9cd9a DN |
923 | } |
924 | ||
6e45f57b | 925 | gcc_assert (rank <= GFC_DTYPE_RANK_MASK); |
40b026d8 | 926 | size = TYPE_SIZE_UNIT (etype); |
f676971a | 927 | |
6de9cd9a DN |
928 | i = rank | (n << GFC_DTYPE_TYPE_SHIFT); |
929 | if (size && INTEGER_CST_P (size)) | |
930 | { | |
931 | if (tree_int_cst_lt (gfc_max_array_element_size, size)) | |
932 | internal_error ("Array element size too big"); | |
933 | ||
934 | i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; | |
935 | } | |
7d60be94 | 936 | dtype = build_int_cst (gfc_array_index_type, i); |
6de9cd9a DN |
937 | |
938 | if (size && !INTEGER_CST_P (size)) | |
939 | { | |
7d60be94 | 940 | tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT); |
10c7a96f SB |
941 | tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp); |
942 | dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype); | |
6de9cd9a DN |
943 | } |
944 | /* If we don't know the size we leave it as zero. This should never happen | |
945 | for anything that is actually used. */ | |
946 | /* TODO: Check this is actually true, particularly when repacking | |
947 | assumed size parameters. */ | |
948 | ||
40b026d8 | 949 | GFC_TYPE_ARRAY_DTYPE (type) = dtype; |
6de9cd9a DN |
950 | return dtype; |
951 | } | |
952 | ||
953 | ||
954 | /* Build an array type for use without a descriptor. Valid values of packed | |
955 | are 0=no, 1=partial, 2=full, 3=static. */ | |
956 | ||
957 | tree | |
958 | gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed) | |
959 | { | |
960 | tree range; | |
961 | tree type; | |
962 | tree tmp; | |
963 | int n; | |
964 | int known_stride; | |
965 | int known_offset; | |
966 | mpz_t offset; | |
967 | mpz_t stride; | |
968 | mpz_t delta; | |
969 | gfc_expr *expr; | |
970 | ||
971 | mpz_init_set_ui (offset, 0); | |
972 | mpz_init_set_ui (stride, 1); | |
973 | mpz_init (delta); | |
974 | ||
975 | /* We don't use build_array_type because this does not include include | |
13795658 | 976 | lang-specific information (i.e. the bounds of the array) when checking |
6de9cd9a DN |
977 | for duplicates. */ |
978 | type = make_node (ARRAY_TYPE); | |
979 | ||
980 | GFC_ARRAY_TYPE_P (type) = 1; | |
981 | TYPE_LANG_SPECIFIC (type) = (struct lang_type *) | |
982 | ggc_alloc_cleared (sizeof (struct lang_type)); | |
983 | ||
984 | known_stride = (packed != 0); | |
985 | known_offset = 1; | |
986 | for (n = 0; n < as->rank; n++) | |
987 | { | |
988 | /* Fill in the stride and bound components of the type. */ | |
989 | if (known_stride) | |
990 | tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); | |
991 | else | |
992 | tmp = NULL_TREE; | |
993 | GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; | |
994 | ||
995 | expr = as->lower[n]; | |
996 | if (expr->expr_type == EXPR_CONSTANT) | |
997 | { | |
998 | tmp = gfc_conv_mpz_to_tree (expr->value.integer, | |
999 | gfc_index_integer_kind); | |
1000 | } | |
1001 | else | |
1002 | { | |
1003 | known_stride = 0; | |
1004 | tmp = NULL_TREE; | |
1005 | } | |
1006 | GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; | |
1007 | ||
1008 | if (known_stride) | |
1009 | { | |
1010 | /* Calculate the offset. */ | |
1011 | mpz_mul (delta, stride, as->lower[n]->value.integer); | |
1012 | mpz_sub (offset, offset, delta); | |
1013 | } | |
1014 | else | |
1015 | known_offset = 0; | |
1016 | ||
1017 | expr = as->upper[n]; | |
1018 | if (expr && expr->expr_type == EXPR_CONSTANT) | |
1019 | { | |
1020 | tmp = gfc_conv_mpz_to_tree (expr->value.integer, | |
1021 | gfc_index_integer_kind); | |
1022 | } | |
1023 | else | |
1024 | { | |
1025 | tmp = NULL_TREE; | |
1026 | known_stride = 0; | |
1027 | } | |
1028 | GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; | |
1029 | ||
1030 | if (known_stride) | |
1031 | { | |
1032 | /* Calculate the stride. */ | |
1033 | mpz_sub (delta, as->upper[n]->value.integer, | |
1034 | as->lower[n]->value.integer); | |
1035 | mpz_add_ui (delta, delta, 1); | |
1036 | mpz_mul (stride, stride, delta); | |
1037 | } | |
1038 | ||
1039 | /* Only the first stride is known for partial packed arrays. */ | |
1040 | if (packed < 2) | |
1041 | known_stride = 0; | |
1042 | } | |
1043 | ||
1044 | if (known_offset) | |
1045 | { | |
1046 | GFC_TYPE_ARRAY_OFFSET (type) = | |
1047 | gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); | |
1048 | } | |
1049 | else | |
1050 | GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE; | |
1051 | ||
1052 | if (known_stride) | |
1053 | { | |
1054 | GFC_TYPE_ARRAY_SIZE (type) = | |
1055 | gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); | |
1056 | } | |
1057 | else | |
1058 | GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; | |
1059 | ||
6de9cd9a | 1060 | GFC_TYPE_ARRAY_RANK (type) = as->rank; |
40b026d8 | 1061 | GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE; |
7ab92584 | 1062 | range = build_range_type (gfc_array_index_type, gfc_index_zero_node, |
6de9cd9a DN |
1063 | NULL_TREE); |
1064 | /* TODO: use main type if it is unbounded. */ | |
1065 | GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = | |
1066 | build_pointer_type (build_array_type (etype, range)); | |
1067 | ||
1068 | if (known_stride) | |
1069 | { | |
1070 | mpz_sub_ui (stride, stride, 1); | |
1071 | range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); | |
1072 | } | |
1073 | else | |
1074 | range = NULL_TREE; | |
1075 | ||
7ab92584 | 1076 | range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range); |
6de9cd9a DN |
1077 | TYPE_DOMAIN (type) = range; |
1078 | ||
1079 | build_pointer_type (etype); | |
1080 | TREE_TYPE (type) = etype; | |
1081 | ||
1082 | layout_type (type); | |
1083 | ||
1084 | mpz_clear (offset); | |
1085 | mpz_clear (stride); | |
1086 | mpz_clear (delta); | |
1087 | ||
1088 | if (packed < 3 || !known_stride) | |
1089 | { | |
841b0c1f PB |
1090 | /* For dummy arrays and automatic (heap allocated) arrays we |
1091 | want a pointer to the array. */ | |
6de9cd9a DN |
1092 | type = build_pointer_type (type); |
1093 | GFC_ARRAY_TYPE_P (type) = 1; | |
1094 | TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); | |
1095 | } | |
1096 | return type; | |
1097 | } | |
1098 | ||
4c73896d RH |
1099 | /* Return or create the base type for an array descriptor. */ |
1100 | ||
1101 | static tree | |
1102 | gfc_get_array_descriptor_base (int dimen) | |
1103 | { | |
1104 | tree fat_type, fieldlist, decl, arraytype; | |
1105 | char name[16 + GFC_RANK_DIGITS + 1]; | |
1106 | ||
1107 | gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS); | |
1108 | if (gfc_array_descriptor_base[dimen - 1]) | |
1109 | return gfc_array_descriptor_base[dimen - 1]; | |
1110 | ||
1111 | /* Build the type node. */ | |
1112 | fat_type = make_node (RECORD_TYPE); | |
1113 | ||
1114 | sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen); | |
1115 | TYPE_NAME (fat_type) = get_identifier (name); | |
1116 | ||
1117 | /* Add the data member as the first element of the descriptor. */ | |
1118 | decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node); | |
1119 | ||
1120 | DECL_CONTEXT (decl) = fat_type; | |
1121 | fieldlist = decl; | |
1122 | ||
1123 | /* Add the base component. */ | |
1124 | decl = build_decl (FIELD_DECL, get_identifier ("offset"), | |
1125 | gfc_array_index_type); | |
1126 | DECL_CONTEXT (decl) = fat_type; | |
1127 | fieldlist = chainon (fieldlist, decl); | |
1128 | ||
1129 | /* Add the dtype component. */ | |
1130 | decl = build_decl (FIELD_DECL, get_identifier ("dtype"), | |
1131 | gfc_array_index_type); | |
1132 | DECL_CONTEXT (decl) = fat_type; | |
1133 | fieldlist = chainon (fieldlist, decl); | |
1134 | ||
1135 | /* Build the array type for the stride and bound components. */ | |
1136 | arraytype = | |
1137 | build_array_type (gfc_get_desc_dim_type (), | |
1138 | build_range_type (gfc_array_index_type, | |
1139 | gfc_index_zero_node, | |
1140 | gfc_rank_cst[dimen - 1])); | |
1141 | ||
1142 | decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype); | |
1143 | DECL_CONTEXT (decl) = fat_type; | |
1144 | fieldlist = chainon (fieldlist, decl); | |
1145 | ||
1146 | /* Finish off the type. */ | |
1147 | TYPE_FIELDS (fat_type) = fieldlist; | |
1148 | ||
1149 | gfc_finish_type (fat_type); | |
1150 | ||
1151 | gfc_array_descriptor_base[dimen - 1] = fat_type; | |
1152 | return fat_type; | |
1153 | } | |
6de9cd9a DN |
1154 | |
1155 | /* Build an array (descriptor) type with given bounds. */ | |
1156 | ||
1157 | tree | |
1158 | gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, | |
1159 | tree * ubound, int packed) | |
1160 | { | |
6de9cd9a | 1161 | char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN]; |
4c73896d | 1162 | tree fat_type, base_type, arraytype, lower, upper, stride, tmp; |
6de9cd9a | 1163 | const char *typename; |
4c73896d | 1164 | int n; |
6de9cd9a | 1165 | |
4c73896d RH |
1166 | base_type = gfc_get_array_descriptor_base (dimen); |
1167 | fat_type = build_variant_type_copy (base_type); | |
6de9cd9a DN |
1168 | |
1169 | tmp = TYPE_NAME (etype); | |
1170 | if (tmp && TREE_CODE (tmp) == TYPE_DECL) | |
1171 | tmp = DECL_NAME (tmp); | |
1172 | if (tmp) | |
1173 | typename = IDENTIFIER_POINTER (tmp); | |
1174 | else | |
1175 | typename = "unknown"; | |
6de9cd9a DN |
1176 | sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, |
1177 | GFC_MAX_SYMBOL_LEN, typename); | |
1178 | TYPE_NAME (fat_type) = get_identifier (name); | |
6de9cd9a | 1179 | |
4c73896d RH |
1180 | GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; |
1181 | TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *) | |
1182 | ggc_alloc_cleared (sizeof (struct lang_type)); | |
1183 | ||
1184 | GFC_TYPE_ARRAY_RANK (fat_type) = dimen; | |
1185 | GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; | |
6de9cd9a DN |
1186 | |
1187 | /* Build an array descriptor record type. */ | |
1188 | if (packed != 0) | |
7ab92584 | 1189 | stride = gfc_index_one_node; |
6de9cd9a DN |
1190 | else |
1191 | stride = NULL_TREE; | |
6de9cd9a DN |
1192 | for (n = 0; n < dimen; n++) |
1193 | { | |
1194 | GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; | |
1195 | ||
1196 | if (lbound) | |
1197 | lower = lbound[n]; | |
1198 | else | |
1199 | lower = NULL_TREE; | |
1200 | ||
1201 | if (lower != NULL_TREE) | |
1202 | { | |
1203 | if (INTEGER_CST_P (lower)) | |
1204 | GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower; | |
1205 | else | |
1206 | lower = NULL_TREE; | |
1207 | } | |
1208 | ||
1209 | upper = ubound[n]; | |
1210 | if (upper != NULL_TREE) | |
1211 | { | |
1212 | if (INTEGER_CST_P (upper)) | |
1213 | GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper; | |
1214 | else | |
1215 | upper = NULL_TREE; | |
1216 | } | |
1217 | ||
1218 | if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) | |
1219 | { | |
10c7a96f SB |
1220 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); |
1221 | tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, | |
1222 | gfc_index_one_node); | |
6de9cd9a | 1223 | stride = |
10c7a96f | 1224 | fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride); |
6de9cd9a | 1225 | /* Check the folding worked. */ |
6e45f57b | 1226 | gcc_assert (INTEGER_CST_P (stride)); |
6de9cd9a DN |
1227 | } |
1228 | else | |
1229 | stride = NULL_TREE; | |
1230 | } | |
1231 | GFC_TYPE_ARRAY_SIZE (fat_type) = stride; | |
4c73896d | 1232 | |
6de9cd9a DN |
1233 | /* TODO: known offsets for descriptors. */ |
1234 | GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; | |
1235 | ||
1236 | /* We define data as an unknown size array. Much better than doing | |
1237 | pointer arithmetic. */ | |
1238 | arraytype = | |
b4838d29 | 1239 | build_array_type (etype, gfc_array_range_type); |
6de9cd9a DN |
1240 | arraytype = build_pointer_type (arraytype); |
1241 | GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; | |
1242 | ||
6de9cd9a DN |
1243 | return fat_type; |
1244 | } | |
1245 | \f | |
1246 | /* Build a pointer type. This function is called from gfc_sym_type(). */ | |
c3e8c6b8 | 1247 | |
6de9cd9a DN |
1248 | static tree |
1249 | gfc_build_pointer_type (gfc_symbol * sym, tree type) | |
1250 | { | |
436529ea | 1251 | /* Array pointer types aren't actually pointers. */ |
6de9cd9a DN |
1252 | if (sym->attr.dimension) |
1253 | return type; | |
1254 | else | |
1255 | return build_pointer_type (type); | |
1256 | } | |
1257 | \f | |
1258 | /* Return the type for a symbol. Special handling is required for character | |
1259 | types to get the correct level of indirection. | |
1260 | For functions return the return type. | |
ad6e2a18 TS |
1261 | For subroutines return void_type_node. |
1262 | Calling this multiple times for the same symbol should be avoided, | |
1263 | especially for character and array types. */ | |
c3e8c6b8 | 1264 | |
6de9cd9a DN |
1265 | tree |
1266 | gfc_sym_type (gfc_symbol * sym) | |
1267 | { | |
1268 | tree type; | |
1269 | int byref; | |
1270 | ||
1271 | if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) | |
1272 | return void_type_node; | |
1273 | ||
1274 | if (sym->backend_decl) | |
1275 | { | |
1276 | if (sym->attr.function) | |
1277 | return TREE_TYPE (TREE_TYPE (sym->backend_decl)); | |
1278 | else | |
1279 | return TREE_TYPE (sym->backend_decl); | |
1280 | } | |
1281 | ||
6de9cd9a | 1282 | type = gfc_typenode_for_spec (&sym->ts); |
973ff4c0 TS |
1283 | if (gfc_option.flag_f2c |
1284 | && sym->attr.function | |
1285 | && sym->ts.type == BT_REAL | |
1286 | && sym->ts.kind == gfc_default_real_kind | |
1287 | && !sym->attr.always_explicit) | |
1288 | { | |
1289 | /* Special case: f2c calling conventions require that (scalar) | |
1290 | default REAL functions return the C type double instead. */ | |
1291 | sym->ts.kind = gfc_default_double_kind; | |
1292 | type = gfc_typenode_for_spec (&sym->ts); | |
1293 | sym->ts.kind = gfc_default_real_kind; | |
1294 | } | |
6de9cd9a DN |
1295 | |
1296 | if (sym->attr.dummy && !sym->attr.function) | |
1297 | byref = 1; | |
1298 | else | |
1299 | byref = 0; | |
1300 | ||
1301 | if (sym->attr.dimension) | |
1302 | { | |
1303 | if (gfc_is_nodesc_array (sym)) | |
1304 | { | |
1305 | /* If this is a character argument of unknown length, just use the | |
1306 | base type. */ | |
1307 | if (sym->ts.type != BT_CHARACTER | |
b49a3de7 | 1308 | || !(sym->attr.dummy || sym->attr.function) |
6de9cd9a DN |
1309 | || sym->ts.cl->backend_decl) |
1310 | { | |
1311 | type = gfc_get_nodesc_array_type (type, sym->as, | |
1312 | byref ? 2 : 3); | |
1313 | byref = 0; | |
1314 | } | |
1315 | } | |
1316 | else | |
1317 | type = gfc_build_array_type (type, sym->as); | |
1318 | } | |
1319 | else | |
1320 | { | |
1321 | if (sym->attr.allocatable || sym->attr.pointer) | |
1322 | type = gfc_build_pointer_type (sym, type); | |
1323 | } | |
1324 | ||
1325 | /* We currently pass all parameters by reference. | |
1326 | See f95_get_function_decl. For dummy function parameters return the | |
1327 | function type. */ | |
1328 | if (byref) | |
1619aa6f PB |
1329 | { |
1330 | /* We must use pointer types for potentially absent variables. The | |
1331 | optimizers assume a reference type argument is never NULL. */ | |
1332 | if (sym->attr.optional || sym->ns->proc_name->attr.entry_master) | |
1333 | type = build_pointer_type (type); | |
1334 | else | |
1335 | type = build_reference_type (type); | |
1336 | } | |
6de9cd9a DN |
1337 | |
1338 | return (type); | |
1339 | } | |
1340 | \f | |
1341 | /* Layout and output debug info for a record type. */ | |
c3e8c6b8 | 1342 | |
6de9cd9a DN |
1343 | void |
1344 | gfc_finish_type (tree type) | |
1345 | { | |
1346 | tree decl; | |
1347 | ||
1348 | decl = build_decl (TYPE_DECL, NULL_TREE, type); | |
1349 | TYPE_STUB_DECL (type) = decl; | |
1350 | layout_type (type); | |
1351 | rest_of_type_compilation (type, 1); | |
0e6df31e | 1352 | rest_of_decl_compilation (decl, 1, 0); |
6de9cd9a DN |
1353 | } |
1354 | \f | |
1355 | /* Add a field of given NAME and TYPE to the context of a UNION_TYPE | |
1356 | or RECORD_TYPE pointed to by STYPE. The new field is chained | |
1357 | to the fieldlist pointed to by FIELDLIST. | |
1358 | ||
1359 | Returns a pointer to the new field. */ | |
c3e8c6b8 | 1360 | |
6de9cd9a DN |
1361 | tree |
1362 | gfc_add_field_to_struct (tree *fieldlist, tree context, | |
1363 | tree name, tree type) | |
1364 | { | |
1365 | tree decl; | |
1366 | ||
1367 | decl = build_decl (FIELD_DECL, name, type); | |
1368 | ||
1369 | DECL_CONTEXT (decl) = context; | |
1370 | DECL_INITIAL (decl) = 0; | |
1371 | DECL_ALIGN (decl) = 0; | |
1372 | DECL_USER_ALIGN (decl) = 0; | |
1373 | TREE_CHAIN (decl) = NULL_TREE; | |
1374 | *fieldlist = chainon (*fieldlist, decl); | |
1375 | ||
1376 | return decl; | |
1377 | } | |
1378 | ||
1379 | ||
1380 | /* Build a tree node for a derived type. */ | |
c3e8c6b8 | 1381 | |
6de9cd9a DN |
1382 | static tree |
1383 | gfc_get_derived_type (gfc_symbol * derived) | |
1384 | { | |
1385 | tree typenode, field, field_type, fieldlist; | |
1386 | gfc_component *c; | |
1387 | ||
6e45f57b | 1388 | gcc_assert (derived && derived->attr.flavor == FL_DERIVED); |
6de9cd9a DN |
1389 | |
1390 | /* derived->backend_decl != 0 means we saw it before, but its | |
436529ea | 1391 | components' backend_decl may have not been built. */ |
6de9cd9a DN |
1392 | if (derived->backend_decl) |
1393 | { | |
436529ea | 1394 | /* Its components' backend_decl have been built. */ |
6de9cd9a DN |
1395 | if (TYPE_FIELDS (derived->backend_decl)) |
1396 | return derived->backend_decl; | |
1397 | else | |
1398 | typenode = derived->backend_decl; | |
1399 | } | |
1400 | else | |
1401 | { | |
1402 | /* We see this derived type first time, so build the type node. */ | |
1403 | typenode = make_node (RECORD_TYPE); | |
1404 | TYPE_NAME (typenode) = get_identifier (derived->name); | |
1405 | TYPE_PACKED (typenode) = gfc_option.flag_pack_derived; | |
1406 | derived->backend_decl = typenode; | |
1407 | } | |
1408 | ||
1409 | /* Build the type member list. Install the newly created RECORD_TYPE | |
1410 | node as DECL_CONTEXT of each FIELD_DECL. */ | |
1411 | fieldlist = NULL_TREE; | |
1412 | for (c = derived->components; c; c = c->next) | |
1413 | { | |
1414 | if (c->ts.type == BT_DERIVED && c->pointer) | |
1415 | { | |
1416 | if (c->ts.derived->backend_decl) | |
40b026d8 PB |
1417 | /* We already saw this derived type so use the exiting type. |
1418 | It doesn't matter if it is incomplete. */ | |
1419 | field_type = c->ts.derived->backend_decl; | |
6de9cd9a | 1420 | else |
40b026d8 PB |
1421 | /* Recurse into the type. */ |
1422 | field_type = gfc_get_derived_type (c->ts.derived); | |
6de9cd9a DN |
1423 | } |
1424 | else | |
1425 | { | |
1426 | if (c->ts.type == BT_CHARACTER) | |
1427 | { | |
1428 | /* Evaluate the string length. */ | |
1429 | gfc_conv_const_charlen (c->ts.cl); | |
6e45f57b | 1430 | gcc_assert (c->ts.cl->backend_decl); |
6de9cd9a DN |
1431 | } |
1432 | ||
1433 | field_type = gfc_typenode_for_spec (&c->ts); | |
1434 | } | |
1435 | ||
1f2959f0 | 1436 | /* This returns an array descriptor type. Initialization may be |
6de9cd9a DN |
1437 | required. */ |
1438 | if (c->dimension) | |
1439 | { | |
1440 | if (c->pointer) | |
1441 | { | |
1f2959f0 | 1442 | /* Pointers to arrays aren't actually pointer types. The |
e7dc5b4f | 1443 | descriptors are separate, but the data is common. */ |
6de9cd9a DN |
1444 | field_type = gfc_build_array_type (field_type, c->as); |
1445 | } | |
1446 | else | |
1447 | field_type = gfc_get_nodesc_array_type (field_type, c->as, 3); | |
1448 | } | |
1449 | else if (c->pointer) | |
1450 | field_type = build_pointer_type (field_type); | |
1451 | ||
1452 | field = gfc_add_field_to_struct (&fieldlist, typenode, | |
1453 | get_identifier (c->name), | |
1454 | field_type); | |
1455 | ||
1456 | DECL_PACKED (field) |= TYPE_PACKED (typenode); | |
1457 | ||
6e45f57b | 1458 | gcc_assert (!c->backend_decl); |
6de9cd9a DN |
1459 | c->backend_decl = field; |
1460 | } | |
1461 | ||
1462 | /* Now we have the final fieldlist. Record it, then lay out the | |
1463 | derived type, including the fields. */ | |
1464 | TYPE_FIELDS (typenode) = fieldlist; | |
1465 | ||
1466 | gfc_finish_type (typenode); | |
1467 | ||
1468 | derived->backend_decl = typenode; | |
1469 | ||
1470 | return typenode; | |
1471 | } | |
1472 | \f | |
1473 | int | |
1474 | gfc_return_by_reference (gfc_symbol * sym) | |
1475 | { | |
1476 | if (!sym->attr.function) | |
1477 | return 0; | |
1478 | ||
b49a3de7 | 1479 | if (sym->attr.dimension) |
6de9cd9a DN |
1480 | return 1; |
1481 | ||
b49a3de7 | 1482 | if (sym->ts.type == BT_CHARACTER) |
6de9cd9a DN |
1483 | return 1; |
1484 | ||
973ff4c0 TS |
1485 | /* Possibly return complex numbers by reference for g77 compatibility. |
1486 | We don't do this for calls to intrinsics (as the library uses the | |
1487 | -fno-f2c calling convention), nor for calls to functions which always | |
1488 | require an explicit interface, as no compatibility problems can | |
1489 | arise there. */ | |
1490 | if (gfc_option.flag_f2c | |
b49a3de7 | 1491 | && sym->ts.type == BT_COMPLEX |
973ff4c0 TS |
1492 | && !sym->attr.intrinsic && !sym->attr.always_explicit) |
1493 | return 1; | |
1494 | ||
6de9cd9a DN |
1495 | return 0; |
1496 | } | |
1497 | \f | |
d198b59a JJ |
1498 | static tree |
1499 | gfc_get_mixed_entry_union (gfc_namespace *ns) | |
1500 | { | |
1501 | tree type; | |
1502 | tree decl; | |
1503 | tree fieldlist; | |
1504 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
1505 | gfc_entry_list *el, *el2; | |
1506 | ||
1507 | gcc_assert (ns->proc_name->attr.mixed_entry_master); | |
1508 | gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0); | |
1509 | ||
1510 | snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7); | |
1511 | ||
1512 | /* Build the type node. */ | |
1513 | type = make_node (UNION_TYPE); | |
1514 | ||
1515 | TYPE_NAME (type) = get_identifier (name); | |
1516 | fieldlist = NULL; | |
1517 | ||
1518 | for (el = ns->entries; el; el = el->next) | |
1519 | { | |
1520 | /* Search for duplicates. */ | |
1521 | for (el2 = ns->entries; el2 != el; el2 = el2->next) | |
1522 | if (el2->sym->result == el->sym->result) | |
1523 | break; | |
1524 | ||
1525 | if (el == el2) | |
1526 | { | |
1527 | decl = build_decl (FIELD_DECL, | |
1528 | get_identifier (el->sym->result->name), | |
1529 | gfc_sym_type (el->sym->result)); | |
1530 | DECL_CONTEXT (decl) = type; | |
1531 | fieldlist = chainon (fieldlist, decl); | |
1532 | } | |
1533 | } | |
1534 | ||
1535 | /* Finish off the type. */ | |
1536 | TYPE_FIELDS (type) = fieldlist; | |
1537 | ||
1538 | gfc_finish_type (type); | |
1539 | return type; | |
1540 | } | |
1541 | \f | |
6de9cd9a DN |
1542 | tree |
1543 | gfc_get_function_type (gfc_symbol * sym) | |
1544 | { | |
1545 | tree type; | |
1546 | tree typelist; | |
1547 | gfc_formal_arglist *f; | |
1548 | gfc_symbol *arg; | |
1549 | int nstr; | |
1550 | int alternate_return; | |
1551 | ||
1552 | /* Make sure this symbol is a function or a subroutine. */ | |
6e45f57b | 1553 | gcc_assert (sym->attr.flavor == FL_PROCEDURE); |
6de9cd9a DN |
1554 | |
1555 | if (sym->backend_decl) | |
1556 | return TREE_TYPE (sym->backend_decl); | |
1557 | ||
1558 | nstr = 0; | |
1559 | alternate_return = 0; | |
1560 | typelist = NULL_TREE; | |
3d79abbd PB |
1561 | |
1562 | if (sym->attr.entry_master) | |
1563 | { | |
1564 | /* Additional parameter for selecting an entry point. */ | |
1565 | typelist = gfc_chainon_list (typelist, gfc_array_index_type); | |
1566 | } | |
1567 | ||
6de9cd9a DN |
1568 | /* Some functions we use an extra parameter for the return value. */ |
1569 | if (gfc_return_by_reference (sym)) | |
1570 | { | |
1571 | if (sym->result) | |
1572 | arg = sym->result; | |
1573 | else | |
1574 | arg = sym; | |
1575 | ||
1576 | if (arg->ts.type == BT_CHARACTER) | |
1577 | gfc_conv_const_charlen (arg->ts.cl); | |
1578 | ||
1579 | type = gfc_sym_type (arg); | |
973ff4c0 | 1580 | if (arg->ts.type == BT_COMPLEX |
6de9cd9a DN |
1581 | || arg->attr.dimension |
1582 | || arg->ts.type == BT_CHARACTER) | |
1583 | type = build_reference_type (type); | |
1584 | ||
1585 | typelist = gfc_chainon_list (typelist, type); | |
1586 | if (arg->ts.type == BT_CHARACTER) | |
d7177ab2 | 1587 | typelist = gfc_chainon_list (typelist, gfc_charlen_type_node); |
6de9cd9a DN |
1588 | } |
1589 | ||
436529ea | 1590 | /* Build the argument types for the function. */ |
6de9cd9a DN |
1591 | for (f = sym->formal; f; f = f->next) |
1592 | { | |
1593 | arg = f->sym; | |
1594 | if (arg) | |
1595 | { | |
1596 | /* Evaluate constant character lengths here so that they can be | |
1597 | included in the type. */ | |
1598 | if (arg->ts.type == BT_CHARACTER) | |
1599 | gfc_conv_const_charlen (arg->ts.cl); | |
1600 | ||
1601 | if (arg->attr.flavor == FL_PROCEDURE) | |
1602 | { | |
1603 | type = gfc_get_function_type (arg); | |
1604 | type = build_pointer_type (type); | |
1605 | } | |
1606 | else | |
1607 | type = gfc_sym_type (arg); | |
1608 | ||
1609 | /* Parameter Passing Convention | |
1610 | ||
1611 | We currently pass all parameters by reference. | |
1612 | Parameters with INTENT(IN) could be passed by value. | |
1613 | The problem arises if a function is called via an implicit | |
1614 | prototype. In this situation the INTENT is not known. | |
1615 | For this reason all parameters to global functions must be | |
aa9c57ec | 1616 | passed by reference. Passing by value would potentially |
6de9cd9a | 1617 | generate bad code. Worse there would be no way of telling that |
c3e8c6b8 | 1618 | this code was bad, except that it would give incorrect results. |
6de9cd9a DN |
1619 | |
1620 | Contained procedures could pass by value as these are never | |
1621 | used without an explicit interface, and connot be passed as | |
c3e8c6b8 | 1622 | actual parameters for a dummy procedure. */ |
6de9cd9a DN |
1623 | if (arg->ts.type == BT_CHARACTER) |
1624 | nstr++; | |
1625 | typelist = gfc_chainon_list (typelist, type); | |
1626 | } | |
1627 | else | |
1628 | { | |
1629 | if (sym->attr.subroutine) | |
1630 | alternate_return = 1; | |
1631 | } | |
1632 | } | |
1633 | ||
1634 | /* Add hidden string length parameters. */ | |
1635 | while (nstr--) | |
d7177ab2 | 1636 | typelist = gfc_chainon_list (typelist, gfc_charlen_type_node); |
6de9cd9a DN |
1637 | |
1638 | typelist = gfc_chainon_list (typelist, void_type_node); | |
1639 | ||
1640 | if (alternate_return) | |
1641 | type = integer_type_node; | |
1642 | else if (!sym->attr.function || gfc_return_by_reference (sym)) | |
1643 | type = void_type_node; | |
d198b59a JJ |
1644 | else if (sym->attr.mixed_entry_master) |
1645 | type = gfc_get_mixed_entry_union (sym->ns); | |
6de9cd9a DN |
1646 | else |
1647 | type = gfc_sym_type (sym); | |
1648 | ||
1649 | type = build_function_type (type, typelist); | |
1650 | ||
1651 | return type; | |
1652 | } | |
1653 | \f | |
e2cad04b | 1654 | /* Language hooks for middle-end access to type nodes. */ |
6de9cd9a DN |
1655 | |
1656 | /* Return an integer type with BITS bits of precision, | |
1657 | that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ | |
1658 | ||
1659 | tree | |
1660 | gfc_type_for_size (unsigned bits, int unsignedp) | |
1661 | { | |
e2cad04b RH |
1662 | if (!unsignedp) |
1663 | { | |
1664 | int i; | |
1665 | for (i = 0; i <= MAX_INT_KINDS; ++i) | |
1666 | { | |
1667 | tree type = gfc_integer_types[i]; | |
1668 | if (type && bits == TYPE_PRECISION (type)) | |
1669 | return type; | |
1670 | } | |
1671 | } | |
1672 | else | |
1673 | { | |
1674 | if (bits == TYPE_PRECISION (unsigned_intQI_type_node)) | |
1675 | return unsigned_intQI_type_node; | |
1676 | if (bits == TYPE_PRECISION (unsigned_intHI_type_node)) | |
1677 | return unsigned_intHI_type_node; | |
1678 | if (bits == TYPE_PRECISION (unsigned_intSI_type_node)) | |
1679 | return unsigned_intSI_type_node; | |
1680 | if (bits == TYPE_PRECISION (unsigned_intDI_type_node)) | |
1681 | return unsigned_intDI_type_node; | |
1682 | if (bits == TYPE_PRECISION (unsigned_intTI_type_node)) | |
1683 | return unsigned_intTI_type_node; | |
1684 | } | |
6de9cd9a | 1685 | |
e2cad04b | 1686 | return NULL_TREE; |
6de9cd9a DN |
1687 | } |
1688 | ||
e2cad04b RH |
1689 | /* Return a data type that has machine mode MODE. If the mode is an |
1690 | integer, then UNSIGNEDP selects between signed and unsigned types. */ | |
6de9cd9a DN |
1691 | |
1692 | tree | |
1693 | gfc_type_for_mode (enum machine_mode mode, int unsignedp) | |
1694 | { | |
e2cad04b RH |
1695 | int i; |
1696 | tree *base; | |
1697 | ||
1698 | if (GET_MODE_CLASS (mode) == MODE_FLOAT) | |
1699 | base = gfc_real_types; | |
1700 | else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT) | |
1701 | base = gfc_complex_types; | |
1702 | else if (SCALAR_INT_MODE_P (mode)) | |
1703 | return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp); | |
1704 | else if (VECTOR_MODE_P (mode)) | |
6de9cd9a | 1705 | { |
f676971a EC |
1706 | enum machine_mode inner_mode = GET_MODE_INNER (mode); |
1707 | tree inner_type = gfc_type_for_mode (inner_mode, unsignedp); | |
1708 | if (inner_type != NULL_TREE) | |
1709 | return build_vector_type_for_mode (inner_type, mode); | |
e2cad04b | 1710 | return NULL_TREE; |
6de9cd9a | 1711 | } |
e2cad04b | 1712 | else |
1a5ffec4 | 1713 | return NULL_TREE; |
6de9cd9a | 1714 | |
e2cad04b RH |
1715 | for (i = 0; i <= MAX_REAL_KINDS; ++i) |
1716 | { | |
1717 | tree type = base[i]; | |
1718 | if (type && mode == TYPE_MODE (type)) | |
1719 | return type; | |
1720 | } | |
1721 | ||
1722 | return NULL_TREE; | |
1723 | } | |
1724 | ||
1725 | /* Return a type the same as TYPE except unsigned or | |
1726 | signed according to UNSIGNEDP. */ | |
1727 | ||
1728 | tree | |
1729 | gfc_signed_or_unsigned_type (int unsignedp, tree type) | |
1730 | { | |
1731 | if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp) | |
1732 | return type; | |
1733 | else | |
1734 | return gfc_type_for_size (TYPE_PRECISION (type), unsignedp); | |
6de9cd9a DN |
1735 | } |
1736 | ||
1737 | /* Return an unsigned type the same as TYPE in other respects. */ | |
c3e8c6b8 | 1738 | |
6de9cd9a DN |
1739 | tree |
1740 | gfc_unsigned_type (tree type) | |
1741 | { | |
6de9cd9a DN |
1742 | return gfc_signed_or_unsigned_type (1, type); |
1743 | } | |
1744 | ||
1745 | /* Return a signed type the same as TYPE in other respects. */ | |
1746 | ||
1747 | tree | |
1748 | gfc_signed_type (tree type) | |
1749 | { | |
6de9cd9a DN |
1750 | return gfc_signed_or_unsigned_type (0, type); |
1751 | } | |
1752 | ||
6de9cd9a | 1753 | #include "gt-fortran-trans-types.h" |