OSDN Git Service

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