OSDN Git Service

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