OSDN Git Service

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