OSDN Git Service

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