]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Backend support for Fortran 95 basic types and derived types. |
9fc4d79b | 2 | Copyright (C) 2002, 2003, 2004 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" | |
29 | #include <stdio.h> | |
30 | #include "ggc.h" | |
31 | #include "toplev.h" | |
32 | #include <assert.h> | |
33 | #include "gfortran.h" | |
34 | #include "trans.h" | |
35 | #include "trans-types.h" | |
36 | #include "trans-const.h" | |
37 | \f | |
38 | ||
39 | #if (GFC_MAX_DIMENSIONS < 10) | |
40 | #define GFC_RANK_DIGITS 1 | |
41 | #define GFC_RANK_PRINTF_FORMAT "%01d" | |
42 | #elif (GFC_MAX_DIMENSIONS < 100) | |
43 | #define GFC_RANK_DIGITS 2 | |
44 | #define GFC_RANK_PRINTF_FORMAT "%02d" | |
45 | #else | |
46 | #error If you really need >99 dimensions, continue the sequence above... | |
47 | #endif | |
48 | ||
49 | static tree gfc_get_derived_type (gfc_symbol * derived); | |
50 | ||
51 | tree gfc_type_nodes[NUM_F95_TYPES]; | |
52 | ||
53 | tree gfc_array_index_type; | |
54 | tree pvoid_type_node; | |
55 | tree ppvoid_type_node; | |
56 | tree pchar_type_node; | |
57 | ||
58 | static GTY(()) tree gfc_desc_dim_type = NULL; | |
59 | ||
60 | static GTY(()) tree gfc_max_array_element_size; | |
61 | ||
62 | /* Create the backend type nodes. We map them to their | |
63 | equivalent C type, at least for now. We also give | |
64 | names to the types here, and we push them in the | |
65 | global binding level context.*/ | |
c3e8c6b8 | 66 | |
6de9cd9a DN |
67 | void |
68 | gfc_init_types (void) | |
69 | { | |
70 | unsigned n; | |
71 | unsigned HOST_WIDE_INT hi; | |
72 | unsigned HOST_WIDE_INT lo; | |
73 | ||
74 | /* Name the types. */ | |
75 | #define PUSH_TYPE(name, node) \ | |
76 | pushdecl (build_decl (TYPE_DECL, get_identifier (name), node)) | |
77 | ||
78 | gfc_int1_type_node = signed_char_type_node; | |
79 | PUSH_TYPE ("int1", gfc_int1_type_node); | |
80 | gfc_int2_type_node = short_integer_type_node; | |
81 | PUSH_TYPE ("int2", gfc_int2_type_node); | |
82 | gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ ); | |
83 | PUSH_TYPE ("int4", gfc_int4_type_node); | |
84 | gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ ); | |
85 | PUSH_TYPE ("int8", gfc_int8_type_node); | |
86 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
87 | gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ ); | |
88 | PUSH_TYPE ("int16", gfc_int16_type_node); | |
89 | #endif | |
90 | ||
91 | gfc_real4_type_node = float_type_node; | |
92 | PUSH_TYPE ("real4", gfc_real4_type_node); | |
93 | gfc_real8_type_node = double_type_node; | |
94 | PUSH_TYPE ("real8", gfc_real8_type_node); | |
95 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
96 | /* Hmm, this will not work. Ref. g77 */ | |
97 | gfc_real16_type_node = long_double_type_node; | |
98 | PUSH_TYPE ("real16", gfc_real16_type_node); | |
99 | #endif | |
100 | ||
101 | gfc_complex4_type_node = complex_float_type_node; | |
102 | PUSH_TYPE ("complex4", gfc_complex4_type_node); | |
103 | gfc_complex8_type_node = complex_double_type_node; | |
104 | PUSH_TYPE ("complex8", gfc_complex8_type_node); | |
105 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
106 | /* Hmm, this will not work. Ref. g77 */ | |
107 | gfc_complex16_type_node = complex_long_double_type_node; | |
108 | PUSH_TYPE ("complex16", gfc_complex16_type_node); | |
109 | #endif | |
110 | ||
111 | gfc_logical1_type_node = make_node (BOOLEAN_TYPE); | |
112 | TYPE_PRECISION (gfc_logical1_type_node) = 8; | |
113 | fixup_unsigned_type (gfc_logical1_type_node); | |
114 | PUSH_TYPE ("logical1", gfc_logical1_type_node); | |
115 | gfc_logical2_type_node = make_node (BOOLEAN_TYPE); | |
116 | TYPE_PRECISION (gfc_logical2_type_node) = 16; | |
117 | fixup_unsigned_type (gfc_logical2_type_node); | |
118 | PUSH_TYPE ("logical2", gfc_logical2_type_node); | |
119 | gfc_logical4_type_node = make_node (BOOLEAN_TYPE); | |
120 | TYPE_PRECISION (gfc_logical4_type_node) = 32; | |
121 | fixup_unsigned_type (gfc_logical4_type_node); | |
122 | PUSH_TYPE ("logical4", gfc_logical4_type_node); | |
123 | gfc_logical8_type_node = make_node (BOOLEAN_TYPE); | |
124 | TYPE_PRECISION (gfc_logical8_type_node) = 64; | |
125 | fixup_unsigned_type (gfc_logical8_type_node); | |
126 | PUSH_TYPE ("logical8", gfc_logical8_type_node); | |
127 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
128 | gfc_logical16_type_node = make_node (BOOLEAN_TYPE); | |
129 | TYPE_PRECISION (gfc_logical16_type_node) = 128; | |
130 | fixup_unsigned_type (gfc_logical16_type_node); | |
131 | PUSH_TYPE ("logical16", gfc_logical16_type_node); | |
132 | #endif | |
133 | ||
134 | gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0); | |
135 | PUSH_TYPE ("char", gfc_character1_type_node); | |
136 | ||
137 | PUSH_TYPE ("byte", unsigned_char_type_node); | |
138 | PUSH_TYPE ("void", void_type_node); | |
139 | ||
140 | /* DBX debugging output gets upset if these aren't set. */ | |
141 | if (!TYPE_NAME (integer_type_node)) | |
142 | PUSH_TYPE ("c_integer", integer_type_node); | |
143 | if (!TYPE_NAME (char_type_node)) | |
144 | PUSH_TYPE ("c_char", char_type_node); | |
145 | #undef PUSH_TYPE | |
146 | ||
147 | pvoid_type_node = build_pointer_type (void_type_node); | |
148 | ppvoid_type_node = build_pointer_type (pvoid_type_node); | |
149 | pchar_type_node = build_pointer_type (gfc_character1_type_node); | |
150 | ||
151 | gfc_index_integer_kind = TYPE_PRECISION (long_unsigned_type_node) / 8; | |
152 | gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); | |
153 | ||
154 | /* The maximum array element size that can be handled is determined | |
155 | by the number of bits available to store this field in the array | |
156 | descriptor. */ | |
157 | ||
158 | n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type)) | |
159 | - GFC_DTYPE_SIZE_SHIFT; | |
160 | ||
161 | if (n > sizeof (HOST_WIDE_INT) * 8) | |
162 | { | |
163 | lo = ~(unsigned HOST_WIDE_INT) 0; | |
164 | hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n); | |
165 | } | |
166 | else | |
167 | { | |
168 | hi = 0; | |
169 | lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n); | |
170 | } | |
4a90aeeb | 171 | gfc_max_array_element_size = build_int_cst (long_unsigned_type_node, lo, hi); |
6de9cd9a DN |
172 | |
173 | size_type_node = gfc_array_index_type; | |
174 | boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ()); | |
175 | ||
4a90aeeb NS |
176 | boolean_true_node = build_int_cst (boolean_type_node, 1, 0); |
177 | boolean_false_node = build_int_cst (boolean_type_node, 0, 0); | |
6de9cd9a DN |
178 | } |
179 | ||
180 | /* Get a type node for an integer kind */ | |
c3e8c6b8 | 181 | |
6de9cd9a DN |
182 | tree |
183 | gfc_get_int_type (int kind) | |
184 | { | |
185 | switch (kind) | |
186 | { | |
187 | case 1: | |
188 | return (gfc_int1_type_node); | |
189 | case 2: | |
190 | return (gfc_int2_type_node); | |
191 | case 4: | |
192 | return (gfc_int4_type_node); | |
193 | case 8: | |
194 | return (gfc_int8_type_node); | |
195 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
196 | case 16: | |
197 | return (95 _int16_type_node); | |
198 | #endif | |
199 | default: | |
200 | fatal_error ("integer kind=%d not available", kind); | |
201 | } | |
202 | } | |
203 | ||
204 | /* Get a type node for a real kind */ | |
c3e8c6b8 | 205 | |
6de9cd9a DN |
206 | tree |
207 | gfc_get_real_type (int kind) | |
208 | { | |
209 | switch (kind) | |
210 | { | |
211 | case 4: | |
212 | return (gfc_real4_type_node); | |
213 | case 8: | |
214 | return (gfc_real8_type_node); | |
215 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
216 | case 16: | |
217 | return (gfc_real16_type_node); | |
218 | #endif | |
219 | default: | |
220 | fatal_error ("real kind=%d not available", kind); | |
221 | } | |
222 | } | |
223 | ||
224 | /* Get a type node for a complex kind */ | |
c3e8c6b8 | 225 | |
6de9cd9a DN |
226 | tree |
227 | gfc_get_complex_type (int kind) | |
228 | { | |
229 | switch (kind) | |
230 | { | |
231 | case 4: | |
232 | return (gfc_complex4_type_node); | |
233 | case 8: | |
234 | return (gfc_complex8_type_node); | |
235 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
236 | case 16: | |
237 | return (gfc_complex16_type_node); | |
238 | #endif | |
239 | default: | |
240 | fatal_error ("complex kind=%d not available", kind); | |
241 | } | |
242 | } | |
243 | ||
244 | /* Get a type node for a logical kind */ | |
c3e8c6b8 | 245 | |
6de9cd9a DN |
246 | tree |
247 | gfc_get_logical_type (int kind) | |
248 | { | |
249 | switch (kind) | |
250 | { | |
251 | case 1: | |
252 | return (gfc_logical1_type_node); | |
253 | case 2: | |
254 | return (gfc_logical2_type_node); | |
255 | case 4: | |
256 | return (gfc_logical4_type_node); | |
257 | case 8: | |
258 | return (gfc_logical8_type_node); | |
259 | #if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) | |
260 | case 16: | |
261 | return (gfc_logical16_type_node); | |
262 | #endif | |
263 | default: | |
264 | fatal_error ("logical kind=%d not available", kind); | |
265 | } | |
266 | } | |
267 | \f | |
268 | /* Get a type node for a character kind. */ | |
c3e8c6b8 | 269 | |
6de9cd9a DN |
270 | tree |
271 | gfc_get_character_type (int kind, gfc_charlen * cl) | |
272 | { | |
273 | tree base; | |
274 | tree type; | |
275 | tree len; | |
276 | tree bounds; | |
277 | ||
278 | switch (kind) | |
279 | { | |
280 | case 1: | |
281 | base = gfc_character1_type_node; | |
282 | break; | |
283 | ||
284 | default: | |
285 | fatal_error ("character kind=%d not available", kind); | |
286 | } | |
287 | ||
288 | len = (cl == 0) ? NULL_TREE : cl->backend_decl; | |
289 | ||
7ab92584 | 290 | bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len); |
6de9cd9a DN |
291 | type = build_array_type (base, bounds); |
292 | TYPE_STRING_FLAG (type) = 1; | |
293 | ||
294 | return type; | |
295 | } | |
296 | \f | |
297 | /* Covert a basic type. This will be an array for character types. */ | |
c3e8c6b8 | 298 | |
6de9cd9a DN |
299 | tree |
300 | gfc_typenode_for_spec (gfc_typespec * spec) | |
301 | { | |
302 | tree basetype; | |
303 | ||
304 | switch (spec->type) | |
305 | { | |
306 | case BT_UNKNOWN: | |
307 | abort (); | |
308 | break; | |
309 | ||
310 | case BT_INTEGER: | |
311 | basetype = gfc_get_int_type (spec->kind); | |
312 | break; | |
313 | ||
314 | case BT_REAL: | |
315 | basetype = gfc_get_real_type (spec->kind); | |
316 | break; | |
317 | ||
318 | case BT_COMPLEX: | |
319 | basetype = gfc_get_complex_type (spec->kind); | |
320 | break; | |
321 | ||
322 | case BT_LOGICAL: | |
323 | basetype = gfc_get_logical_type (spec->kind); | |
324 | break; | |
325 | ||
326 | case BT_CHARACTER: | |
327 | basetype = gfc_get_character_type (spec->kind, spec->cl); | |
328 | break; | |
329 | ||
330 | case BT_DERIVED: | |
331 | basetype = gfc_get_derived_type (spec->derived); | |
332 | break; | |
333 | ||
334 | default: | |
335 | abort (); | |
336 | break; | |
337 | } | |
338 | return basetype; | |
339 | } | |
340 | \f | |
341 | /* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */ | |
c3e8c6b8 | 342 | |
6de9cd9a DN |
343 | static tree |
344 | gfc_conv_array_bound (gfc_expr * expr) | |
345 | { | |
346 | /* If expr is an integer constant, return that. */ | |
347 | if (expr != NULL && expr->expr_type == EXPR_CONSTANT) | |
348 | return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); | |
349 | ||
350 | /* Otherwise return NULL. */ | |
351 | return NULL_TREE; | |
352 | } | |
353 | \f | |
354 | tree | |
355 | gfc_get_element_type (tree type) | |
356 | { | |
357 | tree element; | |
358 | ||
359 | if (GFC_ARRAY_TYPE_P (type)) | |
360 | { | |
361 | if (TREE_CODE (type) == POINTER_TYPE) | |
362 | type = TREE_TYPE (type); | |
363 | assert (TREE_CODE (type) == ARRAY_TYPE); | |
364 | element = TREE_TYPE (type); | |
365 | } | |
366 | else | |
367 | { | |
368 | assert (GFC_DESCRIPTOR_TYPE_P (type)); | |
369 | element = TREE_TYPE (TYPE_FIELDS (type)); | |
370 | ||
371 | assert (TREE_CODE (element) == POINTER_TYPE); | |
372 | element = TREE_TYPE (element); | |
373 | ||
374 | assert (TREE_CODE (element) == ARRAY_TYPE); | |
375 | element = TREE_TYPE (element); | |
376 | } | |
377 | ||
378 | return element; | |
379 | } | |
380 | \f | |
381 | /* Build an array. This function is called from gfc_sym_type(). | |
c3e8c6b8 | 382 | Actually returns array descriptor type. |
6de9cd9a DN |
383 | |
384 | Format of array descriptors is as follows: | |
385 | ||
386 | struct gfc_array_descriptor | |
387 | { | |
388 | array *data | |
389 | index offset; | |
390 | index dtype; | |
391 | struct descriptor_dimension dimension[N_DIM]; | |
392 | } | |
393 | ||
394 | struct descriptor_dimension | |
395 | { | |
396 | index stride; | |
397 | index lbound; | |
398 | index ubound; | |
399 | } | |
400 | ||
401 | Translation code should use gfc_conv_descriptor_* rather than accessing | |
402 | the descriptor directly. Any changes to the array descriptor type will | |
403 | require changes in gfc_conv_descriptor_* and gfc_build_array_initializer. | |
404 | ||
c3e8c6b8 | 405 | This is represented internally as a RECORD_TYPE. The index nodes are |
6de9cd9a DN |
406 | gfc_array_index_type and the data node is a pointer to the data. See below |
407 | for the handling of character types. | |
408 | ||
409 | The dtype member is formatted as follows: | |
410 | rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits | |
411 | type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits | |
412 | size = dtype >> GFC_DTYPE_SIZE_SHIFT | |
413 | ||
c3e8c6b8 | 414 | I originally used nested ARRAY_TYPE nodes to represent arrays, but this |
6de9cd9a | 415 | generated poor code for assumed/deferred size arrays. These require |
c3e8c6b8 | 416 | use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC |
6de9cd9a DN |
417 | grammar. Also, there is no way to explicitly set the array stride, so |
418 | all data must be packed(1). I've tried to mark all the functions which | |
419 | would require modification with a GCC ARRAYS comment. | |
420 | ||
421 | The data component points to the first element in the array. | |
422 | The offset field is the position of the origin of the array | |
423 | (ie element (0, 0 ...)). This may be outsite the bounds of the array. | |
424 | ||
425 | An element is accessed by | |
426 | data[offset + index0*stride0 + index1*stride1 + index2*stride2] | |
c3e8c6b8 | 427 | This gives good performance as the computation does not involve the |
6de9cd9a DN |
428 | bounds of the array. For packed arrays, this is optimized further by |
429 | substituting the known strides. | |
430 | ||
431 | This system has one problem: all array bounds must be withing 2^31 elements | |
432 | of the origin (2^63 on 64-bit machines). For example | |
433 | integer, dimension (80000:90000, 80000:90000, 2) :: array | |
434 | may not work properly on 32-bit machines because 80000*80000 > 2^31, so | |
435 | the calculation for stride02 would overflow. This may still work, but | |
436 | I haven't checked, and it relies on the overflow doing the right thing. | |
437 | ||
438 | The way to fix this problem is to access alements as follows: | |
439 | data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1] | |
440 | Obviously this is much slower. I will make this a compile time option, | |
441 | something like -fsmall-array-offsets. Mixing code compiled with and without | |
442 | this switch will work. | |
443 | ||
444 | (1) This can be worked around by modifying the upper bound of the previous | |
445 | dimension. This requires extra fields in the descriptor (both real_ubound | |
446 | and fake_ubound). In tree.def there is mention of TYPE_SEP, which | |
447 | may allow us to do this. However I can't find mention of this anywhere | |
448 | else. | |
449 | */ | |
450 | ||
451 | ||
452 | /* Returns true if the array sym does not require a descriptor. */ | |
453 | ||
454 | int | |
455 | gfc_is_nodesc_array (gfc_symbol * sym) | |
456 | { | |
457 | assert (sym->attr.dimension); | |
458 | ||
459 | /* We only want local arrays. */ | |
460 | if (sym->attr.pointer || sym->attr.allocatable) | |
461 | return 0; | |
462 | ||
463 | if (sym->attr.dummy) | |
464 | { | |
465 | if (sym->as->type != AS_ASSUMED_SHAPE) | |
466 | return 1; | |
467 | else | |
468 | return 0; | |
469 | } | |
470 | ||
471 | if (sym->attr.result || sym->attr.function) | |
472 | return 0; | |
473 | ||
474 | if (sym->attr.pointer || sym->attr.allocatable) | |
475 | return 0; | |
476 | ||
477 | assert (sym->as->type == AS_EXPLICIT); | |
478 | ||
479 | return 1; | |
480 | } | |
481 | ||
482 | static tree | |
483 | gfc_build_array_type (tree type, gfc_array_spec * as) | |
484 | { | |
485 | tree lbound[GFC_MAX_DIMENSIONS]; | |
486 | tree ubound[GFC_MAX_DIMENSIONS]; | |
487 | int n; | |
488 | ||
489 | for (n = 0; n < as->rank; n++) | |
490 | { | |
491 | /* Create expressions for the known bounds of the array. */ | |
492 | if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL) | |
7ab92584 | 493 | lbound[n] = gfc_index_one_node; |
6de9cd9a DN |
494 | else |
495 | lbound[n] = gfc_conv_array_bound (as->lower[n]); | |
496 | ubound[n] = gfc_conv_array_bound (as->upper[n]); | |
497 | } | |
498 | ||
499 | return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0); | |
500 | } | |
501 | \f | |
502 | /* Returns the struct descriptor_dimension type. */ | |
c3e8c6b8 | 503 | |
6de9cd9a DN |
504 | static tree |
505 | gfc_get_desc_dim_type (void) | |
506 | { | |
507 | tree type; | |
508 | tree decl; | |
509 | tree fieldlist; | |
510 | ||
511 | if (gfc_desc_dim_type) | |
512 | return gfc_desc_dim_type; | |
513 | ||
514 | /* Build the type node. */ | |
515 | type = make_node (RECORD_TYPE); | |
516 | ||
517 | TYPE_NAME (type) = get_identifier ("descriptor_dimension"); | |
518 | TYPE_PACKED (type) = 1; | |
519 | ||
520 | /* Consists of the stride, lbound and ubound members. */ | |
521 | decl = build_decl (FIELD_DECL, | |
522 | get_identifier ("stride"), gfc_array_index_type); | |
523 | DECL_CONTEXT (decl) = type; | |
524 | fieldlist = decl; | |
525 | ||
526 | decl = build_decl (FIELD_DECL, | |
527 | get_identifier ("lbound"), gfc_array_index_type); | |
528 | DECL_CONTEXT (decl) = type; | |
529 | fieldlist = chainon (fieldlist, decl); | |
530 | ||
531 | decl = build_decl (FIELD_DECL, | |
532 | get_identifier ("ubound"), gfc_array_index_type); | |
533 | DECL_CONTEXT (decl) = type; | |
534 | fieldlist = chainon (fieldlist, decl); | |
535 | ||
536 | /* Finish off the type. */ | |
537 | TYPE_FIELDS (type) = fieldlist; | |
538 | ||
539 | gfc_finish_type (type); | |
540 | ||
541 | gfc_desc_dim_type = type; | |
542 | return type; | |
543 | } | |
544 | ||
545 | static tree | |
546 | gfc_get_dtype (tree type, int rank) | |
547 | { | |
548 | tree size; | |
549 | int n; | |
550 | HOST_WIDE_INT i; | |
551 | tree tmp; | |
552 | tree dtype; | |
553 | ||
554 | if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) | |
555 | return (GFC_TYPE_ARRAY_DTYPE (type)); | |
556 | ||
557 | /* TODO: Correctly identify LOGICAL types. */ | |
558 | switch (TREE_CODE (type)) | |
559 | { | |
560 | case INTEGER_TYPE: | |
561 | n = GFC_DTYPE_INTEGER; | |
562 | break; | |
563 | ||
564 | case BOOLEAN_TYPE: | |
565 | n = GFC_DTYPE_LOGICAL; | |
566 | break; | |
567 | ||
568 | case REAL_TYPE: | |
569 | n = GFC_DTYPE_REAL; | |
570 | break; | |
571 | ||
572 | case COMPLEX_TYPE: | |
573 | n = GFC_DTYPE_COMPLEX; | |
574 | break; | |
575 | ||
576 | /* Arrays have already been dealt with. */ | |
577 | case RECORD_TYPE: | |
578 | n = GFC_DTYPE_DERIVED; | |
579 | break; | |
580 | ||
581 | case ARRAY_TYPE: | |
582 | n = GFC_DTYPE_CHARACTER; | |
583 | break; | |
584 | ||
585 | default: | |
586 | abort (); | |
587 | } | |
588 | ||
589 | assert (rank <= GFC_DTYPE_RANK_MASK); | |
590 | size = TYPE_SIZE_UNIT (type); | |
591 | ||
592 | i = rank | (n << GFC_DTYPE_TYPE_SHIFT); | |
593 | if (size && INTEGER_CST_P (size)) | |
594 | { | |
595 | if (tree_int_cst_lt (gfc_max_array_element_size, size)) | |
596 | internal_error ("Array element size too big"); | |
597 | ||
598 | i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; | |
599 | } | |
4a90aeeb | 600 | dtype = build_int_cst (gfc_array_index_type, i, 0); |
6de9cd9a DN |
601 | |
602 | if (size && !INTEGER_CST_P (size)) | |
603 | { | |
4a90aeeb | 604 | tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT, 0); |
6de9cd9a DN |
605 | tmp = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp)); |
606 | dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, dtype)); | |
607 | } | |
608 | /* If we don't know the size we leave it as zero. This should never happen | |
609 | for anything that is actually used. */ | |
610 | /* TODO: Check this is actually true, particularly when repacking | |
611 | assumed size parameters. */ | |
612 | ||
613 | return dtype; | |
614 | } | |
615 | ||
616 | ||
617 | /* Build an array type for use without a descriptor. Valid values of packed | |
618 | are 0=no, 1=partial, 2=full, 3=static. */ | |
619 | ||
620 | tree | |
621 | gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed) | |
622 | { | |
623 | tree range; | |
624 | tree type; | |
625 | tree tmp; | |
626 | int n; | |
627 | int known_stride; | |
628 | int known_offset; | |
629 | mpz_t offset; | |
630 | mpz_t stride; | |
631 | mpz_t delta; | |
632 | gfc_expr *expr; | |
633 | ||
634 | mpz_init_set_ui (offset, 0); | |
635 | mpz_init_set_ui (stride, 1); | |
636 | mpz_init (delta); | |
637 | ||
638 | /* We don't use build_array_type because this does not include include | |
639 | lang-specific information (ie. the bounds of the array) when checking | |
640 | for duplicates. */ | |
641 | type = make_node (ARRAY_TYPE); | |
642 | ||
643 | GFC_ARRAY_TYPE_P (type) = 1; | |
644 | TYPE_LANG_SPECIFIC (type) = (struct lang_type *) | |
645 | ggc_alloc_cleared (sizeof (struct lang_type)); | |
646 | ||
647 | known_stride = (packed != 0); | |
648 | known_offset = 1; | |
649 | for (n = 0; n < as->rank; n++) | |
650 | { | |
651 | /* Fill in the stride and bound components of the type. */ | |
652 | if (known_stride) | |
653 | tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); | |
654 | else | |
655 | tmp = NULL_TREE; | |
656 | GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; | |
657 | ||
658 | expr = as->lower[n]; | |
659 | if (expr->expr_type == EXPR_CONSTANT) | |
660 | { | |
661 | tmp = gfc_conv_mpz_to_tree (expr->value.integer, | |
662 | gfc_index_integer_kind); | |
663 | } | |
664 | else | |
665 | { | |
666 | known_stride = 0; | |
667 | tmp = NULL_TREE; | |
668 | } | |
669 | GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; | |
670 | ||
671 | if (known_stride) | |
672 | { | |
673 | /* Calculate the offset. */ | |
674 | mpz_mul (delta, stride, as->lower[n]->value.integer); | |
675 | mpz_sub (offset, offset, delta); | |
676 | } | |
677 | else | |
678 | known_offset = 0; | |
679 | ||
680 | expr = as->upper[n]; | |
681 | if (expr && expr->expr_type == EXPR_CONSTANT) | |
682 | { | |
683 | tmp = gfc_conv_mpz_to_tree (expr->value.integer, | |
684 | gfc_index_integer_kind); | |
685 | } | |
686 | else | |
687 | { | |
688 | tmp = NULL_TREE; | |
689 | known_stride = 0; | |
690 | } | |
691 | GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; | |
692 | ||
693 | if (known_stride) | |
694 | { | |
695 | /* Calculate the stride. */ | |
696 | mpz_sub (delta, as->upper[n]->value.integer, | |
697 | as->lower[n]->value.integer); | |
698 | mpz_add_ui (delta, delta, 1); | |
699 | mpz_mul (stride, stride, delta); | |
700 | } | |
701 | ||
702 | /* Only the first stride is known for partial packed arrays. */ | |
703 | if (packed < 2) | |
704 | known_stride = 0; | |
705 | } | |
706 | ||
707 | if (known_offset) | |
708 | { | |
709 | GFC_TYPE_ARRAY_OFFSET (type) = | |
710 | gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); | |
711 | } | |
712 | else | |
713 | GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE; | |
714 | ||
715 | if (known_stride) | |
716 | { | |
717 | GFC_TYPE_ARRAY_SIZE (type) = | |
718 | gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); | |
719 | } | |
720 | else | |
721 | GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; | |
722 | ||
723 | GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank); | |
724 | GFC_TYPE_ARRAY_RANK (type) = as->rank; | |
7ab92584 | 725 | range = build_range_type (gfc_array_index_type, gfc_index_zero_node, |
6de9cd9a DN |
726 | NULL_TREE); |
727 | /* TODO: use main type if it is unbounded. */ | |
728 | GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = | |
729 | build_pointer_type (build_array_type (etype, range)); | |
730 | ||
731 | if (known_stride) | |
732 | { | |
733 | mpz_sub_ui (stride, stride, 1); | |
734 | range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); | |
735 | } | |
736 | else | |
737 | range = NULL_TREE; | |
738 | ||
7ab92584 | 739 | range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range); |
6de9cd9a DN |
740 | TYPE_DOMAIN (type) = range; |
741 | ||
742 | build_pointer_type (etype); | |
743 | TREE_TYPE (type) = etype; | |
744 | ||
745 | layout_type (type); | |
746 | ||
747 | mpz_clear (offset); | |
748 | mpz_clear (stride); | |
749 | mpz_clear (delta); | |
750 | ||
751 | if (packed < 3 || !known_stride) | |
752 | { | |
753 | type = build_pointer_type (type); | |
754 | GFC_ARRAY_TYPE_P (type) = 1; | |
755 | TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); | |
756 | } | |
757 | return type; | |
758 | } | |
759 | ||
760 | ||
761 | /* Build an array (descriptor) type with given bounds. */ | |
762 | ||
763 | tree | |
764 | gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, | |
765 | tree * ubound, int packed) | |
766 | { | |
767 | tree fat_type, fat_pointer_type; | |
768 | tree fieldlist; | |
769 | tree arraytype; | |
770 | tree decl; | |
771 | int n; | |
772 | char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN]; | |
773 | const char *typename; | |
774 | tree lower; | |
775 | tree upper; | |
776 | tree stride; | |
777 | tree tmp; | |
778 | ||
779 | /* Build the type node. */ | |
780 | fat_type = make_node (RECORD_TYPE); | |
781 | GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; | |
782 | TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *) | |
783 | ggc_alloc_cleared (sizeof (struct lang_type)); | |
784 | GFC_TYPE_ARRAY_RANK (fat_type) = dimen; | |
785 | GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen); | |
786 | ||
787 | tmp = TYPE_NAME (etype); | |
788 | if (tmp && TREE_CODE (tmp) == TYPE_DECL) | |
789 | tmp = DECL_NAME (tmp); | |
790 | if (tmp) | |
791 | typename = IDENTIFIER_POINTER (tmp); | |
792 | else | |
793 | typename = "unknown"; | |
794 | ||
795 | sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, | |
796 | GFC_MAX_SYMBOL_LEN, typename); | |
797 | TYPE_NAME (fat_type) = get_identifier (name); | |
798 | TYPE_PACKED (fat_type) = 0; | |
799 | ||
800 | fat_pointer_type = build_pointer_type (fat_type); | |
801 | ||
802 | /* Build an array descriptor record type. */ | |
803 | if (packed != 0) | |
7ab92584 | 804 | stride = gfc_index_one_node; |
6de9cd9a DN |
805 | else |
806 | stride = NULL_TREE; | |
807 | ||
808 | for (n = 0; n < dimen; n++) | |
809 | { | |
810 | GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; | |
811 | ||
812 | if (lbound) | |
813 | lower = lbound[n]; | |
814 | else | |
815 | lower = NULL_TREE; | |
816 | ||
817 | if (lower != NULL_TREE) | |
818 | { | |
819 | if (INTEGER_CST_P (lower)) | |
820 | GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower; | |
821 | else | |
822 | lower = NULL_TREE; | |
823 | } | |
824 | ||
825 | upper = ubound[n]; | |
826 | if (upper != NULL_TREE) | |
827 | { | |
828 | if (INTEGER_CST_P (upper)) | |
829 | GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper; | |
830 | else | |
831 | upper = NULL_TREE; | |
832 | } | |
833 | ||
834 | if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) | |
835 | { | |
836 | tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower)); | |
837 | tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, | |
7ab92584 | 838 | gfc_index_one_node)); |
6de9cd9a DN |
839 | stride = |
840 | fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride)); | |
841 | /* Check the folding worked. */ | |
842 | assert (INTEGER_CST_P (stride)); | |
843 | } | |
844 | else | |
845 | stride = NULL_TREE; | |
846 | } | |
847 | GFC_TYPE_ARRAY_SIZE (fat_type) = stride; | |
848 | /* TODO: known offsets for descriptors. */ | |
849 | GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; | |
850 | ||
851 | /* We define data as an unknown size array. Much better than doing | |
852 | pointer arithmetic. */ | |
853 | arraytype = | |
854 | build_array_type (etype, | |
855 | build_range_type (gfc_array_index_type, | |
7ab92584 | 856 | gfc_index_zero_node, NULL_TREE)); |
6de9cd9a DN |
857 | arraytype = build_pointer_type (arraytype); |
858 | GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; | |
859 | ||
860 | /* The pointer to the array data. */ | |
861 | decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype); | |
862 | ||
863 | DECL_CONTEXT (decl) = fat_type; | |
864 | /* Add the data member as the first element of the descriptor. */ | |
865 | fieldlist = decl; | |
866 | ||
867 | /* Add the base component. */ | |
868 | decl = build_decl (FIELD_DECL, get_identifier ("offset"), | |
869 | gfc_array_index_type); | |
870 | DECL_CONTEXT (decl) = fat_type; | |
871 | fieldlist = chainon (fieldlist, decl); | |
872 | ||
873 | /* Add the dtype component. */ | |
874 | decl = build_decl (FIELD_DECL, get_identifier ("dtype"), | |
875 | gfc_array_index_type); | |
876 | DECL_CONTEXT (decl) = fat_type; | |
877 | fieldlist = chainon (fieldlist, decl); | |
878 | ||
879 | /* Build the array type for the stride and bound components. */ | |
880 | arraytype = | |
881 | build_array_type (gfc_get_desc_dim_type (), | |
882 | build_range_type (gfc_array_index_type, | |
7ab92584 | 883 | gfc_index_zero_node, |
6de9cd9a DN |
884 | gfc_rank_cst[dimen - 1])); |
885 | ||
886 | decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype); | |
887 | DECL_CONTEXT (decl) = fat_type; | |
888 | DECL_INITIAL (decl) = NULL_TREE; | |
889 | fieldlist = chainon (fieldlist, decl); | |
890 | ||
891 | /* Finish off the type. */ | |
892 | TYPE_FIELDS (fat_type) = fieldlist; | |
893 | ||
894 | gfc_finish_type (fat_type); | |
895 | ||
896 | return fat_type; | |
897 | } | |
898 | \f | |
899 | /* Build a pointer type. This function is called from gfc_sym_type(). */ | |
c3e8c6b8 | 900 | |
6de9cd9a DN |
901 | static tree |
902 | gfc_build_pointer_type (gfc_symbol * sym, tree type) | |
903 | { | |
904 | /* Array pointer types aren't actualy pointers. */ | |
905 | if (sym->attr.dimension) | |
906 | return type; | |
907 | else | |
908 | return build_pointer_type (type); | |
909 | } | |
910 | \f | |
911 | /* Return the type for a symbol. Special handling is required for character | |
912 | types to get the correct level of indirection. | |
913 | For functions return the return type. | |
ad6e2a18 TS |
914 | For subroutines return void_type_node. |
915 | Calling this multiple times for the same symbol should be avoided, | |
916 | especially for character and array types. */ | |
c3e8c6b8 | 917 | |
6de9cd9a DN |
918 | tree |
919 | gfc_sym_type (gfc_symbol * sym) | |
920 | { | |
921 | tree type; | |
922 | int byref; | |
923 | ||
924 | if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) | |
925 | return void_type_node; | |
926 | ||
927 | if (sym->backend_decl) | |
928 | { | |
929 | if (sym->attr.function) | |
930 | return TREE_TYPE (TREE_TYPE (sym->backend_decl)); | |
931 | else | |
932 | return TREE_TYPE (sym->backend_decl); | |
933 | } | |
934 | ||
935 | /* The frontend doesn't set all the attributes for a function with an | |
936 | explicit result value, so we use that instead when present. */ | |
937 | if (sym->attr.function && sym->result) | |
938 | sym = sym->result; | |
939 | ||
940 | type = gfc_typenode_for_spec (&sym->ts); | |
941 | ||
942 | if (sym->attr.dummy && !sym->attr.function) | |
943 | byref = 1; | |
944 | else | |
945 | byref = 0; | |
946 | ||
947 | if (sym->attr.dimension) | |
948 | { | |
949 | if (gfc_is_nodesc_array (sym)) | |
950 | { | |
951 | /* If this is a character argument of unknown length, just use the | |
952 | base type. */ | |
953 | if (sym->ts.type != BT_CHARACTER | |
954 | || !(sym->attr.dummy || sym->attr.function || sym->attr.result) | |
955 | || sym->ts.cl->backend_decl) | |
956 | { | |
957 | type = gfc_get_nodesc_array_type (type, sym->as, | |
958 | byref ? 2 : 3); | |
959 | byref = 0; | |
960 | } | |
961 | } | |
962 | else | |
963 | type = gfc_build_array_type (type, sym->as); | |
964 | } | |
965 | else | |
966 | { | |
967 | if (sym->attr.allocatable || sym->attr.pointer) | |
968 | type = gfc_build_pointer_type (sym, type); | |
969 | } | |
970 | ||
971 | /* We currently pass all parameters by reference. | |
972 | See f95_get_function_decl. For dummy function parameters return the | |
973 | function type. */ | |
974 | if (byref) | |
1619aa6f PB |
975 | { |
976 | /* We must use pointer types for potentially absent variables. The | |
977 | optimizers assume a reference type argument is never NULL. */ | |
978 | if (sym->attr.optional || sym->ns->proc_name->attr.entry_master) | |
979 | type = build_pointer_type (type); | |
980 | else | |
981 | type = build_reference_type (type); | |
982 | } | |
6de9cd9a DN |
983 | |
984 | return (type); | |
985 | } | |
986 | \f | |
987 | /* Layout and output debug info for a record type. */ | |
c3e8c6b8 | 988 | |
6de9cd9a DN |
989 | void |
990 | gfc_finish_type (tree type) | |
991 | { | |
992 | tree decl; | |
993 | ||
994 | decl = build_decl (TYPE_DECL, NULL_TREE, type); | |
995 | TYPE_STUB_DECL (type) = decl; | |
996 | layout_type (type); | |
997 | rest_of_type_compilation (type, 1); | |
0e6df31e | 998 | rest_of_decl_compilation (decl, 1, 0); |
6de9cd9a DN |
999 | } |
1000 | \f | |
1001 | /* Add a field of given NAME and TYPE to the context of a UNION_TYPE | |
1002 | or RECORD_TYPE pointed to by STYPE. The new field is chained | |
1003 | to the fieldlist pointed to by FIELDLIST. | |
1004 | ||
1005 | Returns a pointer to the new field. */ | |
c3e8c6b8 | 1006 | |
6de9cd9a DN |
1007 | tree |
1008 | gfc_add_field_to_struct (tree *fieldlist, tree context, | |
1009 | tree name, tree type) | |
1010 | { | |
1011 | tree decl; | |
1012 | ||
1013 | decl = build_decl (FIELD_DECL, name, type); | |
1014 | ||
1015 | DECL_CONTEXT (decl) = context; | |
1016 | DECL_INITIAL (decl) = 0; | |
1017 | DECL_ALIGN (decl) = 0; | |
1018 | DECL_USER_ALIGN (decl) = 0; | |
1019 | TREE_CHAIN (decl) = NULL_TREE; | |
1020 | *fieldlist = chainon (*fieldlist, decl); | |
1021 | ||
1022 | return decl; | |
1023 | } | |
1024 | ||
1025 | ||
1026 | /* Build a tree node for a derived type. */ | |
c3e8c6b8 | 1027 | |
6de9cd9a DN |
1028 | static tree |
1029 | gfc_get_derived_type (gfc_symbol * derived) | |
1030 | { | |
1031 | tree typenode, field, field_type, fieldlist; | |
1032 | gfc_component *c; | |
1033 | ||
1034 | assert (derived && derived->attr.flavor == FL_DERIVED); | |
1035 | ||
1036 | /* derived->backend_decl != 0 means we saw it before, but its | |
1037 | component's backend_decl may have not been built. */ | |
1038 | if (derived->backend_decl) | |
1039 | { | |
1040 | /* Its component's backend_decl has been built. */ | |
1041 | if (TYPE_FIELDS (derived->backend_decl)) | |
1042 | return derived->backend_decl; | |
1043 | else | |
1044 | typenode = derived->backend_decl; | |
1045 | } | |
1046 | else | |
1047 | { | |
1048 | /* We see this derived type first time, so build the type node. */ | |
1049 | typenode = make_node (RECORD_TYPE); | |
1050 | TYPE_NAME (typenode) = get_identifier (derived->name); | |
1051 | TYPE_PACKED (typenode) = gfc_option.flag_pack_derived; | |
1052 | derived->backend_decl = typenode; | |
1053 | } | |
1054 | ||
1055 | /* Build the type member list. Install the newly created RECORD_TYPE | |
1056 | node as DECL_CONTEXT of each FIELD_DECL. */ | |
1057 | fieldlist = NULL_TREE; | |
1058 | for (c = derived->components; c; c = c->next) | |
1059 | { | |
1060 | if (c->ts.type == BT_DERIVED && c->pointer) | |
1061 | { | |
1062 | if (c->ts.derived->backend_decl) | |
1063 | field_type = c->ts.derived->backend_decl; | |
1064 | else | |
1065 | { | |
1066 | /* Build the type node. */ | |
1067 | field_type = make_node (RECORD_TYPE); | |
1068 | TYPE_NAME (field_type) = get_identifier (c->ts.derived->name); | |
1069 | TYPE_PACKED (field_type) = gfc_option.flag_pack_derived; | |
1070 | c->ts.derived->backend_decl = field_type; | |
1071 | } | |
1072 | } | |
1073 | else | |
1074 | { | |
1075 | if (c->ts.type == BT_CHARACTER) | |
1076 | { | |
1077 | /* Evaluate the string length. */ | |
1078 | gfc_conv_const_charlen (c->ts.cl); | |
1079 | assert (c->ts.cl->backend_decl); | |
1080 | } | |
1081 | ||
1082 | field_type = gfc_typenode_for_spec (&c->ts); | |
1083 | } | |
1084 | ||
1085 | /* This returns an array descriptor type. Initialisation may be | |
1086 | required. */ | |
1087 | if (c->dimension) | |
1088 | { | |
1089 | if (c->pointer) | |
1090 | { | |
1091 | /* Pointers to arrays aren't actualy pointer types. The | |
1092 | descriptors are seperate, but the data is common. */ | |
1093 | field_type = gfc_build_array_type (field_type, c->as); | |
1094 | } | |
1095 | else | |
1096 | field_type = gfc_get_nodesc_array_type (field_type, c->as, 3); | |
1097 | } | |
1098 | else if (c->pointer) | |
1099 | field_type = build_pointer_type (field_type); | |
1100 | ||
1101 | field = gfc_add_field_to_struct (&fieldlist, typenode, | |
1102 | get_identifier (c->name), | |
1103 | field_type); | |
1104 | ||
1105 | DECL_PACKED (field) |= TYPE_PACKED (typenode); | |
1106 | ||
1107 | assert (!c->backend_decl); | |
1108 | c->backend_decl = field; | |
1109 | } | |
1110 | ||
1111 | /* Now we have the final fieldlist. Record it, then lay out the | |
1112 | derived type, including the fields. */ | |
1113 | TYPE_FIELDS (typenode) = fieldlist; | |
1114 | ||
1115 | gfc_finish_type (typenode); | |
1116 | ||
1117 | derived->backend_decl = typenode; | |
1118 | ||
1119 | return typenode; | |
1120 | } | |
1121 | \f | |
1122 | int | |
1123 | gfc_return_by_reference (gfc_symbol * sym) | |
1124 | { | |
1125 | if (!sym->attr.function) | |
1126 | return 0; | |
1127 | ||
1128 | assert (sym->attr.function); | |
1129 | ||
1130 | if (sym->result) | |
1131 | sym = sym->result; | |
1132 | ||
1133 | if (sym->attr.dimension) | |
1134 | return 1; | |
1135 | ||
1136 | if (sym->ts.type == BT_CHARACTER) | |
1137 | return 1; | |
1138 | ||
1139 | if (sym->ts.type == BT_DERIVED) | |
1140 | gfc_todo_error ("Returning derived types"); | |
1141 | /* Possibly return derived types by reference. */ | |
1142 | return 0; | |
1143 | } | |
1144 | \f | |
c3e8c6b8 | 1145 | |
6de9cd9a DN |
1146 | tree |
1147 | gfc_get_function_type (gfc_symbol * sym) | |
1148 | { | |
1149 | tree type; | |
1150 | tree typelist; | |
1151 | gfc_formal_arglist *f; | |
1152 | gfc_symbol *arg; | |
1153 | int nstr; | |
1154 | int alternate_return; | |
1155 | ||
1156 | /* Make sure this symbol is a function or a subroutine. */ | |
1157 | assert (sym->attr.flavor == FL_PROCEDURE); | |
1158 | ||
1159 | if (sym->backend_decl) | |
1160 | return TREE_TYPE (sym->backend_decl); | |
1161 | ||
1162 | nstr = 0; | |
1163 | alternate_return = 0; | |
1164 | typelist = NULL_TREE; | |
3d79abbd PB |
1165 | |
1166 | if (sym->attr.entry_master) | |
1167 | { | |
1168 | /* Additional parameter for selecting an entry point. */ | |
1169 | typelist = gfc_chainon_list (typelist, gfc_array_index_type); | |
1170 | } | |
1171 | ||
6de9cd9a DN |
1172 | /* Some functions we use an extra parameter for the return value. */ |
1173 | if (gfc_return_by_reference (sym)) | |
1174 | { | |
1175 | if (sym->result) | |
1176 | arg = sym->result; | |
1177 | else | |
1178 | arg = sym; | |
1179 | ||
1180 | if (arg->ts.type == BT_CHARACTER) | |
1181 | gfc_conv_const_charlen (arg->ts.cl); | |
1182 | ||
1183 | type = gfc_sym_type (arg); | |
1184 | if (arg->ts.type == BT_DERIVED | |
1185 | || arg->attr.dimension | |
1186 | || arg->ts.type == BT_CHARACTER) | |
1187 | type = build_reference_type (type); | |
1188 | ||
1189 | typelist = gfc_chainon_list (typelist, type); | |
1190 | if (arg->ts.type == BT_CHARACTER) | |
1191 | typelist = gfc_chainon_list (typelist, gfc_strlen_type_node); | |
1192 | } | |
1193 | ||
1194 | /* Build the argument types for the function */ | |
1195 | for (f = sym->formal; f; f = f->next) | |
1196 | { | |
1197 | arg = f->sym; | |
1198 | if (arg) | |
1199 | { | |
1200 | /* Evaluate constant character lengths here so that they can be | |
1201 | included in the type. */ | |
1202 | if (arg->ts.type == BT_CHARACTER) | |
1203 | gfc_conv_const_charlen (arg->ts.cl); | |
1204 | ||
1205 | if (arg->attr.flavor == FL_PROCEDURE) | |
1206 | { | |
1207 | type = gfc_get_function_type (arg); | |
1208 | type = build_pointer_type (type); | |
1209 | } | |
1210 | else | |
1211 | type = gfc_sym_type (arg); | |
1212 | ||
1213 | /* Parameter Passing Convention | |
1214 | ||
1215 | We currently pass all parameters by reference. | |
1216 | Parameters with INTENT(IN) could be passed by value. | |
1217 | The problem arises if a function is called via an implicit | |
1218 | prototype. In this situation the INTENT is not known. | |
1219 | For this reason all parameters to global functions must be | |
1220 | passed by reference. Passing by value would potentialy | |
1221 | generate bad code. Worse there would be no way of telling that | |
c3e8c6b8 | 1222 | this code was bad, except that it would give incorrect results. |
6de9cd9a DN |
1223 | |
1224 | Contained procedures could pass by value as these are never | |
1225 | used without an explicit interface, and connot be passed as | |
c3e8c6b8 | 1226 | actual parameters for a dummy procedure. */ |
6de9cd9a DN |
1227 | if (arg->ts.type == BT_CHARACTER) |
1228 | nstr++; | |
1229 | typelist = gfc_chainon_list (typelist, type); | |
1230 | } | |
1231 | else | |
1232 | { | |
1233 | if (sym->attr.subroutine) | |
1234 | alternate_return = 1; | |
1235 | } | |
1236 | } | |
1237 | ||
1238 | /* Add hidden string length parameters. */ | |
1239 | while (nstr--) | |
1240 | typelist = gfc_chainon_list (typelist, gfc_strlen_type_node); | |
1241 | ||
1242 | typelist = gfc_chainon_list (typelist, void_type_node); | |
1243 | ||
1244 | if (alternate_return) | |
1245 | type = integer_type_node; | |
1246 | else if (!sym->attr.function || gfc_return_by_reference (sym)) | |
1247 | type = void_type_node; | |
1248 | else | |
1249 | type = gfc_sym_type (sym); | |
1250 | ||
1251 | type = build_function_type (type, typelist); | |
1252 | ||
1253 | return type; | |
1254 | } | |
1255 | \f | |
1256 | /* Routines for getting integer type nodes */ | |
1257 | ||
1258 | ||
1259 | /* Return an integer type with BITS bits of precision, | |
1260 | that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ | |
1261 | ||
1262 | tree | |
1263 | gfc_type_for_size (unsigned bits, int unsignedp) | |
1264 | { | |
1265 | if (bits == TYPE_PRECISION (integer_type_node)) | |
1266 | return unsignedp ? unsigned_type_node : integer_type_node; | |
1267 | ||
1268 | if (bits == TYPE_PRECISION (signed_char_type_node)) | |
1269 | return unsignedp ? unsigned_char_type_node : signed_char_type_node; | |
1270 | ||
1271 | if (bits == TYPE_PRECISION (short_integer_type_node)) | |
1272 | return unsignedp ? short_unsigned_type_node : short_integer_type_node; | |
1273 | ||
1274 | if (bits == TYPE_PRECISION (long_integer_type_node)) | |
1275 | return unsignedp ? long_unsigned_type_node : long_integer_type_node; | |
1276 | ||
1277 | if (bits == TYPE_PRECISION (long_long_integer_type_node)) | |
1278 | return (unsignedp ? long_long_unsigned_type_node | |
1279 | : long_long_integer_type_node); | |
1280 | /*TODO: We currently don't initialise this... | |
1281 | if (bits == TYPE_PRECISION (widest_integer_literal_type_node)) | |
1282 | return (unsignedp ? widest_unsigned_literal_type_node | |
1283 | : widest_integer_literal_type_node);*/ | |
1284 | ||
1285 | if (bits <= TYPE_PRECISION (intQI_type_node)) | |
1286 | return unsignedp ? unsigned_intQI_type_node : intQI_type_node; | |
1287 | ||
1288 | if (bits <= TYPE_PRECISION (intHI_type_node)) | |
1289 | return unsignedp ? unsigned_intHI_type_node : intHI_type_node; | |
1290 | ||
1291 | if (bits <= TYPE_PRECISION (intSI_type_node)) | |
1292 | return unsignedp ? unsigned_intSI_type_node : intSI_type_node; | |
1293 | ||
1294 | if (bits <= TYPE_PRECISION (intDI_type_node)) | |
1295 | return unsignedp ? unsigned_intDI_type_node : intDI_type_node; | |
1296 | ||
1297 | return 0; | |
1298 | } | |
1299 | ||
1300 | /* Return a data type that has machine mode MODE. | |
1301 | If the mode is an integer, | |
1302 | then UNSIGNEDP selects between signed and unsigned types. */ | |
1303 | ||
1304 | tree | |
1305 | gfc_type_for_mode (enum machine_mode mode, int unsignedp) | |
1306 | { | |
1307 | if (mode == TYPE_MODE (integer_type_node)) | |
1308 | return unsignedp ? unsigned_type_node : integer_type_node; | |
1309 | ||
1310 | if (mode == TYPE_MODE (signed_char_type_node)) | |
1311 | return unsignedp ? unsigned_char_type_node : signed_char_type_node; | |
1312 | ||
1313 | if (mode == TYPE_MODE (short_integer_type_node)) | |
1314 | return unsignedp ? short_unsigned_type_node : short_integer_type_node; | |
1315 | ||
1316 | if (mode == TYPE_MODE (long_integer_type_node)) | |
1317 | return unsignedp ? long_unsigned_type_node : long_integer_type_node; | |
1318 | ||
1319 | if (mode == TYPE_MODE (long_long_integer_type_node)) | |
1320 | return unsignedp ? long_long_unsigned_type_node : | |
1321 | long_long_integer_type_node; | |
1322 | ||
1323 | /*TODO: see above | |
1324 | if (mode == TYPE_MODE (widest_integer_literal_type_node)) | |
1325 | return unsignedp ? widest_unsigned_literal_type_node | |
1326 | : widest_integer_literal_type_node; | |
1327 | */ | |
1328 | ||
1329 | if (mode == QImode) | |
1330 | return unsignedp ? unsigned_intQI_type_node : intQI_type_node; | |
1331 | ||
1332 | if (mode == HImode) | |
1333 | return unsignedp ? unsigned_intHI_type_node : intHI_type_node; | |
1334 | ||
1335 | if (mode == SImode) | |
1336 | return unsignedp ? unsigned_intSI_type_node : intSI_type_node; | |
1337 | ||
1338 | if (mode == DImode) | |
1339 | return unsignedp ? unsigned_intDI_type_node : intDI_type_node; | |
1340 | ||
1341 | #if HOST_BITS_PER_WIDE_INT >= 64 | |
1342 | if (mode == TYPE_MODE (intTI_type_node)) | |
1343 | return unsignedp ? unsigned_intTI_type_node : intTI_type_node; | |
1344 | #endif | |
1345 | ||
1346 | if (mode == TYPE_MODE (float_type_node)) | |
1347 | return float_type_node; | |
1348 | ||
1349 | if (mode == TYPE_MODE (double_type_node)) | |
1350 | return double_type_node; | |
1351 | ||
1352 | if (mode == TYPE_MODE (long_double_type_node)) | |
1353 | return long_double_type_node; | |
1354 | ||
1355 | if (mode == TYPE_MODE (build_pointer_type (char_type_node))) | |
1356 | return build_pointer_type (char_type_node); | |
1357 | ||
1358 | if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) | |
1359 | return build_pointer_type (integer_type_node); | |
1360 | ||
1361 | #ifdef VECTOR_MODE_SUPPORTED_P | |
1362 | if (VECTOR_MODE_SUPPORTED_P (mode)) | |
1363 | { | |
1364 | switch (mode) | |
1365 | { | |
1366 | case V16QImode: | |
1367 | return unsignedp ? unsigned_V16QI_type_node : V16QI_type_node; | |
1368 | case V8HImode: | |
1369 | return unsignedp ? unsigned_V8HI_type_node : V8HI_type_node; | |
1370 | case V4SImode: | |
1371 | return unsignedp ? unsigned_V4SI_type_node : V4SI_type_node; | |
1372 | case V2DImode: | |
1373 | return unsignedp ? unsigned_V2DI_type_node : V2DI_type_node; | |
1374 | case V2SImode: | |
1375 | return unsignedp ? unsigned_V2SI_type_node : V2SI_type_node; | |
1376 | case V4HImode: | |
1377 | return unsignedp ? unsigned_V4HI_type_node : V4HI_type_node; | |
1378 | case V8QImode: | |
1379 | return unsignedp ? unsigned_V8QI_type_node : V8QI_type_node; | |
1380 | case V16SFmode: | |
1381 | return V16SF_type_node; | |
1382 | case V4SFmode: | |
1383 | return V4SF_type_node; | |
1384 | case V2SFmode: | |
1385 | return V2SF_type_node; | |
1386 | case V2DFmode: | |
1387 | return V2DF_type_node; | |
1388 | default: | |
1389 | break; | |
1390 | } | |
1391 | } | |
1392 | #endif | |
1393 | ||
1394 | return 0; | |
1395 | } | |
1396 | ||
1397 | /* Return an unsigned type the same as TYPE in other respects. */ | |
c3e8c6b8 | 1398 | |
6de9cd9a DN |
1399 | tree |
1400 | gfc_unsigned_type (tree type) | |
1401 | { | |
1402 | tree type1 = TYPE_MAIN_VARIANT (type); | |
1403 | if (type1 == signed_char_type_node || type1 == char_type_node) | |
1404 | return unsigned_char_type_node; | |
1405 | if (type1 == integer_type_node) | |
1406 | return unsigned_type_node; | |
1407 | if (type1 == short_integer_type_node) | |
1408 | return short_unsigned_type_node; | |
1409 | if (type1 == long_integer_type_node) | |
1410 | return long_unsigned_type_node; | |
1411 | if (type1 == long_long_integer_type_node) | |
1412 | return long_long_unsigned_type_node; | |
1413 | /*TODO :see others | |
1414 | if (type1 == widest_integer_literal_type_node) | |
1415 | return widest_unsigned_literal_type_node; | |
1416 | */ | |
1417 | #if HOST_BITS_PER_WIDE_INT >= 64 | |
1418 | if (type1 == intTI_type_node) | |
1419 | return unsigned_intTI_type_node; | |
1420 | #endif | |
1421 | if (type1 == intDI_type_node) | |
1422 | return unsigned_intDI_type_node; | |
1423 | if (type1 == intSI_type_node) | |
1424 | return unsigned_intSI_type_node; | |
1425 | if (type1 == intHI_type_node) | |
1426 | return unsigned_intHI_type_node; | |
1427 | if (type1 == intQI_type_node) | |
1428 | return unsigned_intQI_type_node; | |
1429 | ||
1430 | return gfc_signed_or_unsigned_type (1, type); | |
1431 | } | |
1432 | ||
1433 | /* Return a signed type the same as TYPE in other respects. */ | |
1434 | ||
1435 | tree | |
1436 | gfc_signed_type (tree type) | |
1437 | { | |
1438 | tree type1 = TYPE_MAIN_VARIANT (type); | |
1439 | if (type1 == unsigned_char_type_node || type1 == char_type_node) | |
1440 | return signed_char_type_node; | |
1441 | if (type1 == unsigned_type_node) | |
1442 | return integer_type_node; | |
1443 | if (type1 == short_unsigned_type_node) | |
1444 | return short_integer_type_node; | |
1445 | if (type1 == long_unsigned_type_node) | |
1446 | return long_integer_type_node; | |
1447 | if (type1 == long_long_unsigned_type_node) | |
1448 | return long_long_integer_type_node; | |
1449 | /*TODO: see others | |
1450 | if (type1 == widest_unsigned_literal_type_node) | |
1451 | return widest_integer_literal_type_node; | |
1452 | */ | |
1453 | #if HOST_BITS_PER_WIDE_INT >= 64 | |
1454 | if (type1 == unsigned_intTI_type_node) | |
1455 | return intTI_type_node; | |
1456 | #endif | |
1457 | if (type1 == unsigned_intDI_type_node) | |
1458 | return intDI_type_node; | |
1459 | if (type1 == unsigned_intSI_type_node) | |
1460 | return intSI_type_node; | |
1461 | if (type1 == unsigned_intHI_type_node) | |
1462 | return intHI_type_node; | |
1463 | if (type1 == unsigned_intQI_type_node) | |
1464 | return intQI_type_node; | |
1465 | ||
1466 | return gfc_signed_or_unsigned_type (0, type); | |
1467 | } | |
1468 | ||
1469 | /* Return a type the same as TYPE except unsigned or | |
1470 | signed according to UNSIGNEDP. */ | |
1471 | ||
1472 | tree | |
1473 | gfc_signed_or_unsigned_type (int unsignedp, tree type) | |
1474 | { | |
1475 | if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp) | |
1476 | return type; | |
1477 | ||
1478 | if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) | |
1479 | return unsignedp ? unsigned_char_type_node : signed_char_type_node; | |
1480 | if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) | |
1481 | return unsignedp ? unsigned_type_node : integer_type_node; | |
1482 | if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) | |
1483 | return unsignedp ? short_unsigned_type_node : short_integer_type_node; | |
1484 | if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) | |
1485 | return unsignedp ? long_unsigned_type_node : long_integer_type_node; | |
1486 | if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) | |
1487 | return (unsignedp ? long_long_unsigned_type_node | |
1488 | : long_long_integer_type_node); | |
1489 | /*TODO: see others | |
1490 | if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node)) | |
1491 | return (unsignedp ? widest_unsigned_literal_type_node | |
1492 | : widest_integer_literal_type_node); | |
1493 | */ | |
1494 | #if HOST_BITS_PER_WIDE_INT >= 64 | |
1495 | if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node)) | |
1496 | return unsignedp ? unsigned_intTI_type_node : intTI_type_node; | |
1497 | #endif | |
1498 | if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node)) | |
1499 | return unsignedp ? unsigned_intDI_type_node : intDI_type_node; | |
1500 | if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node)) | |
1501 | return unsignedp ? unsigned_intSI_type_node : intSI_type_node; | |
1502 | if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node)) | |
1503 | return unsignedp ? unsigned_intHI_type_node : intHI_type_node; | |
1504 | if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node)) | |
1505 | return unsignedp ? unsigned_intQI_type_node : intQI_type_node; | |
1506 | ||
1507 | return type; | |
1508 | } | |
1509 | ||
1510 | #include "gt-fortran-trans-types.h" |