OSDN Git Service

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