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