OSDN Git Service

2010-03-17 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-types.c
1 /* Backend support for Fortran 95 basic types and derived types.
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3    Free Software Foundation, Inc.
4    Contributed by Paul Brook <paul@nowt.org>
5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
22
23 /* trans-types.c -- gfortran backend types */
24
25 #include "config.h"
26 #include "system.h"
27 #include "coretypes.h"
28 #include "tree.h"
29 #include "langhooks.h"
30 #include "tm.h"
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"
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 (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, lbound, ubound, 0, akind,
1225                                     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, bool restricted)
1541 {
1542   tree fat_type, fieldlist, decl, arraytype;
1543   char name[16 + GFC_RANK_DIGITS + 1];
1544   int idx = 2 * (dimen - 1) + restricted;
1545
1546   gcc_assert (dimen >= 1 && 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);
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[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, tree * lbound,
1607                            tree * ubound, int packed,
1608                            enum gfc_array_kind akind, bool restricted)
1609 {
1610   char name[8 + GFC_RANK_DIGITS + 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, 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, 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,
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       else
1797         {
1798           enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
1799           if (sym->attr.pointer)
1800             akind = GFC_ARRAY_POINTER;
1801           else if (sym->attr.allocatable)
1802             akind = GFC_ARRAY_ALLOCATABLE;
1803           type = gfc_build_array_type (type, sym->as, akind, restricted);
1804         }
1805     }
1806   else
1807     {
1808       if (sym->attr.allocatable || sym->attr.pointer)
1809         type = gfc_build_pointer_type (sym, type);
1810       if (sym->attr.pointer)
1811         GFC_POINTER_TYPE_P (type) = 1;
1812     }
1813
1814   /* We currently pass all parameters by reference.
1815      See f95_get_function_decl.  For dummy function parameters return the
1816      function type.  */
1817   if (byref)
1818     {
1819       /* We must use pointer types for potentially absent variables.  The
1820          optimizers assume a reference type argument is never NULL.  */
1821       if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
1822         type = build_pointer_type (type);
1823       else
1824         {
1825           type = build_reference_type (type);
1826           if (restricted)
1827             type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
1828         }
1829     }
1830
1831   return (type);
1832 }
1833 \f
1834 /* Layout and output debug info for a record type.  */
1835
1836 void
1837 gfc_finish_type (tree type)
1838 {
1839   tree decl;
1840
1841   decl = build_decl (input_location,
1842                      TYPE_DECL, NULL_TREE, type);
1843   TYPE_STUB_DECL (type) = decl;
1844   layout_type (type);
1845   rest_of_type_compilation (type, 1);
1846   rest_of_decl_compilation (decl, 1, 0);
1847 }
1848 \f
1849 /* Add a field of given NAME and TYPE to the context of a UNION_TYPE
1850    or RECORD_TYPE pointed to by STYPE.  The new field is chained
1851    to the fieldlist pointed to by FIELDLIST.
1852
1853    Returns a pointer to the new field.  */
1854
1855 tree
1856 gfc_add_field_to_struct (tree *fieldlist, tree context,
1857                          tree name, tree type)
1858 {
1859   tree decl;
1860
1861   decl = build_decl (input_location,
1862                      FIELD_DECL, name, type);
1863
1864   DECL_CONTEXT (decl) = context;
1865   DECL_INITIAL (decl) = 0;
1866   DECL_ALIGN (decl) = 0;
1867   DECL_USER_ALIGN (decl) = 0;
1868   TREE_CHAIN (decl) = NULL_TREE;
1869   *fieldlist = chainon (*fieldlist, decl);
1870
1871   return decl;
1872 }
1873
1874
1875 /* Copy the backend_decl and component backend_decls if
1876    the two derived type symbols are "equal", as described
1877    in 4.4.2 and resolved by gfc_compare_derived_types.  */
1878
1879 static int
1880 copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
1881                        bool from_gsym)
1882 {
1883   gfc_component *to_cm;
1884   gfc_component *from_cm;
1885
1886   if (from->backend_decl == NULL
1887         || !gfc_compare_derived_types (from, to))
1888     return 0;
1889
1890   to->backend_decl = from->backend_decl;
1891
1892   to_cm = to->components;
1893   from_cm = from->components;
1894
1895   /* Copy the component declarations.  If a component is itself
1896      a derived type, we need a copy of its component declarations.
1897      This is done by recursing into gfc_get_derived_type and
1898      ensures that the component's component declarations have
1899      been built.  If it is a character, we need the character 
1900      length, as well.  */
1901   for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
1902     {
1903       to_cm->backend_decl = from_cm->backend_decl;
1904       if ((!from_cm->attr.pointer || from_gsym)
1905               && from_cm->ts.type == BT_DERIVED)
1906         gfc_get_derived_type (to_cm->ts.u.derived);
1907
1908       else if (from_cm->ts.type == BT_CHARACTER)
1909         to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
1910     }
1911
1912   return 1;
1913 }
1914
1915
1916 /* Build a tree node for a procedure pointer component.  */
1917
1918 tree
1919 gfc_get_ppc_type (gfc_component* c)
1920 {
1921   tree t;
1922
1923   /* Explicit interface.  */
1924   if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
1925     return build_pointer_type (gfc_get_function_type (c->ts.interface));
1926
1927   /* Implicit interface (only return value may be known).  */
1928   if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
1929     t = gfc_typenode_for_spec (&c->ts);
1930   else
1931     t = void_type_node;
1932
1933   return build_pointer_type (build_function_type (t, NULL_TREE));
1934 }
1935
1936
1937 /* Build a tree node for a derived type.  If there are equal
1938    derived types, with different local names, these are built
1939    at the same time.  If an equal derived type has been built
1940    in a parent namespace, this is used.  */
1941
1942 tree
1943 gfc_get_derived_type (gfc_symbol * derived)
1944 {
1945   tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
1946   tree canonical = NULL_TREE;
1947   bool got_canonical = false;
1948   gfc_component *c;
1949   gfc_dt_list *dt;
1950   gfc_namespace *ns;
1951   gfc_gsymbol *gsym;
1952
1953   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
1954
1955   /* See if it's one of the iso_c_binding derived types.  */
1956   if (derived->attr.is_iso_c == 1)
1957     {
1958       if (derived->backend_decl)
1959         return derived->backend_decl;
1960
1961       if (derived->intmod_sym_id == ISOCBINDING_PTR)
1962         derived->backend_decl = ptr_type_node;
1963       else
1964         derived->backend_decl = pfunc_type_node;
1965
1966       /* Create a backend_decl for the __c_ptr_c_address field.  */
1967       derived->components->backend_decl =
1968         gfc_add_field_to_struct (&(derived->backend_decl->type.values),
1969                                  derived->backend_decl,
1970                                  get_identifier (derived->components->name),
1971                                  gfc_typenode_for_spec (
1972                                    &(derived->components->ts)));
1973
1974       derived->ts.kind = gfc_index_integer_kind;
1975       derived->ts.type = BT_INTEGER;
1976       /* Set the f90_type to BT_VOID as a way to recognize something of type
1977          BT_INTEGER that needs to fit a void * for the purpose of the
1978          iso_c_binding derived types.  */
1979       derived->ts.f90_type = BT_VOID;
1980       
1981       return derived->backend_decl;
1982     }
1983
1984 /* If use associated, use the module type for this one.  */
1985   if (gfc_option.flag_whole_file
1986         && derived->backend_decl == NULL
1987         && derived->attr.use_assoc
1988         && derived->module)
1989     {
1990       gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
1991       if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1992         {
1993           gfc_symbol *s;
1994           s = NULL;
1995           gfc_find_symbol (derived->name, gsym->ns, 0, &s);
1996           if (s && s->backend_decl)
1997             {
1998               copy_dt_decls_ifequal (s, derived, true);
1999               goto copy_derived_types;
2000             }
2001         }
2002     }
2003
2004   /* If a whole file compilation, the derived types from an earlier
2005      namespace can be used as the the canonical type.  */
2006   if (gfc_option.flag_whole_file
2007         && derived->backend_decl == NULL
2008         && !derived->attr.use_assoc
2009         && gfc_global_ns_list)
2010     {
2011       for (ns = gfc_global_ns_list;
2012            ns->translated && !got_canonical;
2013            ns = ns->sibling)
2014         {
2015           dt = ns->derived_types;
2016           for (; dt && !canonical; dt = dt->next)
2017             {
2018               copy_dt_decls_ifequal (dt->derived, derived, true);
2019               if (derived->backend_decl)
2020                 got_canonical = true;
2021             }
2022         }
2023     }
2024
2025   /* Store up the canonical type to be added to this one.  */
2026   if (got_canonical)
2027     {
2028       if (TYPE_CANONICAL (derived->backend_decl))
2029         canonical = TYPE_CANONICAL (derived->backend_decl);
2030       else
2031         canonical = derived->backend_decl;
2032
2033       derived->backend_decl = NULL_TREE;
2034     }
2035
2036   /* derived->backend_decl != 0 means we saw it before, but its
2037      components' backend_decl may have not been built.  */
2038   if (derived->backend_decl)
2039     {
2040       /* Its components' backend_decl have been built or we are
2041          seeing recursion through the formal arglist of a procedure
2042          pointer component.  */
2043       if (TYPE_FIELDS (derived->backend_decl)
2044             || derived->attr.proc_pointer_comp)
2045         return derived->backend_decl;
2046       else
2047         typenode = derived->backend_decl;
2048     }
2049   else
2050     {
2051       /* We see this derived type first time, so build the type node.  */
2052       typenode = make_node (RECORD_TYPE);
2053       TYPE_NAME (typenode) = get_identifier (derived->name);
2054       TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
2055       derived->backend_decl = typenode;
2056     }
2057
2058   /* Go through the derived type components, building them as
2059      necessary. The reason for doing this now is that it is
2060      possible to recurse back to this derived type through a
2061      pointer component (PR24092). If this happens, the fields
2062      will be built and so we can return the type.  */
2063   for (c = derived->components; c; c = c->next)
2064     {
2065       if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
2066         continue;
2067
2068       if ((!c->attr.pointer && !c->attr.proc_pointer)
2069           || c->ts.u.derived->backend_decl == NULL)
2070         c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
2071
2072       if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
2073         {
2074           /* Need to copy the modified ts from the derived type.  The
2075              typespec was modified because C_PTR/C_FUNPTR are translated
2076              into (void *) from derived types.  */
2077           c->ts.type = c->ts.u.derived->ts.type;
2078           c->ts.kind = c->ts.u.derived->ts.kind;
2079           c->ts.f90_type = c->ts.u.derived->ts.f90_type;
2080           if (c->initializer)
2081             {
2082               c->initializer->ts.type = c->ts.type;
2083               c->initializer->ts.kind = c->ts.kind;
2084               c->initializer->ts.f90_type = c->ts.f90_type;
2085               c->initializer->expr_type = EXPR_NULL;
2086             }
2087         }
2088     }
2089
2090   if (TYPE_FIELDS (derived->backend_decl))
2091     return derived->backend_decl;
2092
2093   /* Build the type member list. Install the newly created RECORD_TYPE
2094      node as DECL_CONTEXT of each FIELD_DECL.  */
2095   fieldlist = NULL_TREE;
2096   for (c = derived->components; c; c = c->next)
2097     {
2098       if (c->attr.proc_pointer)
2099         field_type = gfc_get_ppc_type (c);
2100       else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2101         field_type = c->ts.u.derived->backend_decl;
2102       else
2103         {
2104           if (c->ts.type == BT_CHARACTER)
2105             {
2106               /* Evaluate the string length.  */
2107               gfc_conv_const_charlen (c->ts.u.cl);
2108               gcc_assert (c->ts.u.cl->backend_decl);
2109             }
2110
2111           field_type = gfc_typenode_for_spec (&c->ts);
2112         }
2113
2114       /* This returns an array descriptor type.  Initialization may be
2115          required.  */
2116       if (c->attr.dimension && !c->attr.proc_pointer)
2117         {
2118           if (c->attr.pointer || c->attr.allocatable)
2119             {
2120               enum gfc_array_kind akind;
2121               if (c->attr.pointer)
2122                 akind = GFC_ARRAY_POINTER;
2123               else
2124                 akind = GFC_ARRAY_ALLOCATABLE;
2125               /* Pointers to arrays aren't actually pointer types.  The
2126                  descriptors are separate, but the data is common.  */
2127               field_type = gfc_build_array_type (field_type, c->as, akind,
2128                                                  !c->attr.target
2129                                                  && !c->attr.pointer);
2130             }
2131           else
2132             field_type = gfc_get_nodesc_array_type (field_type, c->as,
2133                                                     PACKED_STATIC,
2134                                                     !c->attr.target);
2135         }
2136       else if ((c->attr.pointer || c->attr.allocatable)
2137                && !c->attr.proc_pointer)
2138         field_type = build_pointer_type (field_type);
2139
2140       field = gfc_add_field_to_struct (&fieldlist, typenode,
2141                                        get_identifier (c->name), field_type);
2142       if (c->loc.lb)
2143         gfc_set_decl_location (field, &c->loc);
2144       else if (derived->declared_at.lb)
2145         gfc_set_decl_location (field, &derived->declared_at);
2146
2147       DECL_PACKED (field) |= TYPE_PACKED (typenode);
2148
2149       gcc_assert (field);
2150       if (!c->backend_decl)
2151         c->backend_decl = field;
2152     }
2153
2154   /* Now we have the final fieldlist.  Record it, then lay out the
2155      derived type, including the fields.  */
2156   TYPE_FIELDS (typenode) = fieldlist;
2157   if (canonical)
2158     TYPE_CANONICAL (typenode) = canonical;
2159
2160   gfc_finish_type (typenode);
2161   gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
2162   if (derived->module && derived->ns->proc_name
2163       && derived->ns->proc_name->attr.flavor == FL_MODULE)
2164     {
2165       if (derived->ns->proc_name->backend_decl
2166           && TREE_CODE (derived->ns->proc_name->backend_decl)
2167              == NAMESPACE_DECL)
2168         {
2169           TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
2170           DECL_CONTEXT (TYPE_STUB_DECL (typenode))
2171             = derived->ns->proc_name->backend_decl;
2172         }
2173     }
2174
2175   derived->backend_decl = typenode;
2176
2177 copy_derived_types:
2178
2179   for (dt = gfc_derived_types; dt; dt = dt->next)
2180     copy_dt_decls_ifequal (derived, dt->derived, false);
2181
2182   return derived->backend_decl;
2183 }
2184
2185
2186 int
2187 gfc_return_by_reference (gfc_symbol * sym)
2188 {
2189   if (!sym->attr.function)
2190     return 0;
2191
2192   if (sym->attr.dimension)
2193     return 1;
2194
2195   if (sym->ts.type == BT_CHARACTER
2196       && !sym->attr.is_bind_c
2197       && (!sym->attr.result
2198           || !sym->ns->proc_name
2199           || !sym->ns->proc_name->attr.is_bind_c))
2200     return 1;
2201
2202   /* Possibly return complex numbers by reference for g77 compatibility.
2203      We don't do this for calls to intrinsics (as the library uses the
2204      -fno-f2c calling convention), nor for calls to functions which always
2205      require an explicit interface, as no compatibility problems can
2206      arise there.  */
2207   if (gfc_option.flag_f2c
2208       && sym->ts.type == BT_COMPLEX
2209       && !sym->attr.intrinsic && !sym->attr.always_explicit)
2210     return 1;
2211
2212   return 0;
2213 }
2214 \f
2215 static tree
2216 gfc_get_mixed_entry_union (gfc_namespace *ns)
2217 {
2218   tree type;
2219   tree decl;
2220   tree fieldlist;
2221   char name[GFC_MAX_SYMBOL_LEN + 1];
2222   gfc_entry_list *el, *el2;
2223
2224   gcc_assert (ns->proc_name->attr.mixed_entry_master);
2225   gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
2226
2227   snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
2228
2229   /* Build the type node.  */
2230   type = make_node (UNION_TYPE);
2231
2232   TYPE_NAME (type) = get_identifier (name);
2233   fieldlist = NULL;
2234
2235   for (el = ns->entries; el; el = el->next)
2236     {
2237       /* Search for duplicates.  */
2238       for (el2 = ns->entries; el2 != el; el2 = el2->next)
2239         if (el2->sym->result == el->sym->result)
2240           break;
2241
2242       if (el == el2)
2243         {
2244           decl = build_decl (input_location,
2245                              FIELD_DECL,
2246                              get_identifier (el->sym->result->name),
2247                              gfc_sym_type (el->sym->result));
2248           DECL_CONTEXT (decl) = type;
2249           fieldlist = chainon (fieldlist, decl);
2250         }
2251     }
2252
2253   /* Finish off the type.  */
2254   TYPE_FIELDS (type) = fieldlist;
2255
2256   gfc_finish_type (type);
2257   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
2258   return type;
2259 }
2260 \f
2261 tree
2262 gfc_get_function_type (gfc_symbol * sym)
2263 {
2264   tree type;
2265   tree typelist;
2266   gfc_formal_arglist *f;
2267   gfc_symbol *arg;
2268   int nstr;
2269   int alternate_return;
2270
2271   /* Make sure this symbol is a function, a subroutine or the main
2272      program.  */
2273   gcc_assert (sym->attr.flavor == FL_PROCEDURE
2274               || sym->attr.flavor == FL_PROGRAM);
2275
2276   if (sym->backend_decl)
2277     return TREE_TYPE (sym->backend_decl);
2278
2279   nstr = 0;
2280   alternate_return = 0;
2281   typelist = NULL_TREE;
2282
2283   if (sym->attr.entry_master)
2284     {
2285       /* Additional parameter for selecting an entry point.  */
2286       typelist = gfc_chainon_list (typelist, gfc_array_index_type);
2287     }
2288
2289   if (sym->result)
2290     arg = sym->result;
2291   else
2292     arg = sym;
2293
2294   if (arg->ts.type == BT_CHARACTER)
2295     gfc_conv_const_charlen (arg->ts.u.cl);
2296
2297   /* Some functions we use an extra parameter for the return value.  */
2298   if (gfc_return_by_reference (sym))
2299     {
2300       type = gfc_sym_type (arg);
2301       if (arg->ts.type == BT_COMPLEX
2302           || arg->attr.dimension
2303           || arg->ts.type == BT_CHARACTER)
2304         type = build_reference_type (type);
2305
2306       typelist = gfc_chainon_list (typelist, type);
2307       if (arg->ts.type == BT_CHARACTER)
2308         typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2309     }
2310
2311   /* Build the argument types for the function.  */
2312   for (f = sym->formal; f; f = f->next)
2313     {
2314       arg = f->sym;
2315       if (arg)
2316         {
2317           /* Evaluate constant character lengths here so that they can be
2318              included in the type.  */
2319           if (arg->ts.type == BT_CHARACTER)
2320             gfc_conv_const_charlen (arg->ts.u.cl);
2321
2322           if (arg->attr.flavor == FL_PROCEDURE)
2323             {
2324               type = gfc_get_function_type (arg);
2325               type = build_pointer_type (type);
2326             }
2327           else
2328             type = gfc_sym_type (arg);
2329
2330           /* Parameter Passing Convention
2331
2332              We currently pass all parameters by reference.
2333              Parameters with INTENT(IN) could be passed by value.
2334              The problem arises if a function is called via an implicit
2335              prototype. In this situation the INTENT is not known.
2336              For this reason all parameters to global functions must be
2337              passed by reference.  Passing by value would potentially
2338              generate bad code.  Worse there would be no way of telling that
2339              this code was bad, except that it would give incorrect results.
2340
2341              Contained procedures could pass by value as these are never
2342              used without an explicit interface, and cannot be passed as
2343              actual parameters for a dummy procedure.  */
2344           if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2345             nstr++;
2346           typelist = gfc_chainon_list (typelist, type);
2347         }
2348       else
2349         {
2350           if (sym->attr.subroutine)
2351             alternate_return = 1;
2352         }
2353     }
2354
2355   /* Add hidden string length parameters.  */
2356   while (nstr--)
2357     typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
2358
2359   if (typelist)
2360     typelist = gfc_chainon_list (typelist, void_type_node);
2361
2362   if (alternate_return)
2363     type = integer_type_node;
2364   else if (!sym->attr.function || gfc_return_by_reference (sym))
2365     type = void_type_node;
2366   else if (sym->attr.mixed_entry_master)
2367     type = gfc_get_mixed_entry_union (sym->ns);
2368   else if (gfc_option.flag_f2c
2369            && sym->ts.type == BT_REAL
2370            && sym->ts.kind == gfc_default_real_kind
2371            && !sym->attr.always_explicit)
2372     {
2373       /* Special case: f2c calling conventions require that (scalar) 
2374          default REAL functions return the C type double instead.  f2c
2375          compatibility is only an issue with functions that don't
2376          require an explicit interface, as only these could be
2377          implemented in Fortran 77.  */
2378       sym->ts.kind = gfc_default_double_kind;
2379       type = gfc_typenode_for_spec (&sym->ts);
2380       sym->ts.kind = gfc_default_real_kind;
2381     }
2382   else if (sym->result && sym->result->attr.proc_pointer)
2383     /* Procedure pointer return values.  */
2384     {
2385       if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
2386         {
2387           /* Unset proc_pointer as gfc_get_function_type
2388              is called recursively.  */
2389           sym->result->attr.proc_pointer = 0;
2390           type = build_pointer_type (gfc_get_function_type (sym->result));
2391           sym->result->attr.proc_pointer = 1;
2392         }
2393       else
2394        type = gfc_sym_type (sym->result);
2395     }
2396   else
2397     type = gfc_sym_type (sym);
2398
2399   type = build_function_type (type, typelist);
2400
2401   return type;
2402 }
2403 \f
2404 /* Language hooks for middle-end access to type nodes.  */
2405
2406 /* Return an integer type with BITS bits of precision,
2407    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
2408
2409 tree
2410 gfc_type_for_size (unsigned bits, int unsignedp)
2411 {
2412   if (!unsignedp)
2413     {
2414       int i;
2415       for (i = 0; i <= MAX_INT_KINDS; ++i)
2416         {
2417           tree type = gfc_integer_types[i];
2418           if (type && bits == TYPE_PRECISION (type))
2419             return type;
2420         }
2421
2422       /* Handle TImode as a special case because it is used by some backends
2423          (e.g. ARM) even though it is not available for normal use.  */
2424 #if HOST_BITS_PER_WIDE_INT >= 64
2425       if (bits == TYPE_PRECISION (intTI_type_node))
2426         return intTI_type_node;
2427 #endif
2428     }
2429   else
2430     {
2431       if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
2432         return unsigned_intQI_type_node;
2433       if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
2434         return unsigned_intHI_type_node;
2435       if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
2436         return unsigned_intSI_type_node;
2437       if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
2438         return unsigned_intDI_type_node;
2439       if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
2440         return unsigned_intTI_type_node;
2441     }
2442
2443   return NULL_TREE;
2444 }
2445
2446 /* Return a data type that has machine mode MODE.  If the mode is an
2447    integer, then UNSIGNEDP selects between signed and unsigned types.  */
2448
2449 tree
2450 gfc_type_for_mode (enum machine_mode mode, int unsignedp)
2451 {
2452   int i;
2453   tree *base;
2454
2455   if (GET_MODE_CLASS (mode) == MODE_FLOAT)
2456     base = gfc_real_types;
2457   else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
2458     base = gfc_complex_types;
2459   else if (SCALAR_INT_MODE_P (mode))
2460     return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
2461   else if (VECTOR_MODE_P (mode))
2462     {
2463       enum machine_mode inner_mode = GET_MODE_INNER (mode);
2464       tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
2465       if (inner_type != NULL_TREE)
2466         return build_vector_type_for_mode (inner_type, mode);
2467       return NULL_TREE;
2468     }
2469   else
2470     return NULL_TREE;
2471
2472   for (i = 0; i <= MAX_REAL_KINDS; ++i)
2473     {
2474       tree type = base[i];
2475       if (type && mode == TYPE_MODE (type))
2476         return type;
2477     }
2478
2479   return NULL_TREE;
2480 }
2481
2482 /* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
2483    in that case.  */
2484
2485 bool
2486 gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
2487 {
2488   int rank, dim;
2489   bool indirect = false;
2490   tree etype, ptype, field, t, base_decl;
2491   tree data_off, dim_off, dim_size, elem_size;
2492   tree lower_suboff, upper_suboff, stride_suboff;
2493
2494   if (! GFC_DESCRIPTOR_TYPE_P (type))
2495     {
2496       if (! POINTER_TYPE_P (type))
2497         return false;
2498       type = TREE_TYPE (type);
2499       if (! GFC_DESCRIPTOR_TYPE_P (type))
2500         return false;
2501       indirect = true;
2502     }
2503
2504   rank = GFC_TYPE_ARRAY_RANK (type);
2505   if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
2506     return false;
2507
2508   etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2509   gcc_assert (POINTER_TYPE_P (etype));
2510   etype = TREE_TYPE (etype);
2511   gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
2512   etype = TREE_TYPE (etype);
2513   /* Can't handle variable sized elements yet.  */
2514   if (int_size_in_bytes (etype) <= 0)
2515     return false;
2516   /* Nor non-constant lower bounds in assumed shape arrays.  */
2517   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2518     {
2519       for (dim = 0; dim < rank; dim++)
2520         if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
2521             || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
2522           return false;
2523     }
2524
2525   memset (info, '\0', sizeof (*info));
2526   info->ndimensions = rank;
2527   info->element_type = etype;
2528   ptype = build_pointer_type (gfc_array_index_type);
2529   base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
2530   if (!base_decl)
2531     {
2532       base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
2533                               indirect ? build_pointer_type (ptype) : ptype);
2534       GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
2535     }
2536   info->base_decl = base_decl;
2537   if (indirect)
2538     base_decl = build1 (INDIRECT_REF, ptype, base_decl);
2539
2540   if (GFC_TYPE_ARRAY_SPAN (type))
2541     elem_size = GFC_TYPE_ARRAY_SPAN (type);
2542   else
2543     elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
2544   field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
2545   data_off = byte_position (field);
2546   field = TREE_CHAIN (field);
2547   field = TREE_CHAIN (field);
2548   field = TREE_CHAIN (field);
2549   dim_off = byte_position (field);
2550   dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
2551   field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
2552   stride_suboff = byte_position (field);
2553   field = TREE_CHAIN (field);
2554   lower_suboff = byte_position (field);
2555   field = TREE_CHAIN (field);
2556   upper_suboff = byte_position (field);
2557
2558   t = base_decl;
2559   if (!integer_zerop (data_off))
2560     t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
2561   t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
2562   info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
2563   if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
2564     info->allocated = build2 (NE_EXPR, boolean_type_node,
2565                               info->data_location, null_pointer_node);
2566   else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
2567     info->associated = build2 (NE_EXPR, boolean_type_node,
2568                                info->data_location, null_pointer_node);
2569
2570   for (dim = 0; dim < rank; dim++)
2571     {
2572       t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2573                   size_binop (PLUS_EXPR, dim_off, lower_suboff));
2574       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2575       info->dimen[dim].lower_bound = t;
2576       t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2577                   size_binop (PLUS_EXPR, dim_off, upper_suboff));
2578       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2579       info->dimen[dim].upper_bound = t;
2580       if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
2581         {
2582           /* Assumed shape arrays have known lower bounds.  */
2583           info->dimen[dim].upper_bound
2584             = build2 (MINUS_EXPR, gfc_array_index_type,
2585                       info->dimen[dim].upper_bound,
2586                       info->dimen[dim].lower_bound);
2587           info->dimen[dim].lower_bound
2588             = fold_convert (gfc_array_index_type,
2589                             GFC_TYPE_ARRAY_LBOUND (type, dim));
2590           info->dimen[dim].upper_bound
2591             = build2 (PLUS_EXPR, gfc_array_index_type,
2592                       info->dimen[dim].lower_bound,
2593                       info->dimen[dim].upper_bound);
2594         }
2595       t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
2596                   size_binop (PLUS_EXPR, dim_off, stride_suboff));
2597       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
2598       t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
2599       info->dimen[dim].stride = t;
2600       dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
2601     }
2602
2603   return true;
2604 }
2605
2606 #include "gt-fortran-trans-types.h"