View | Details | Raw Unified | Return to bug 20541 | Differences between
and this patch

Collapse All | Expand All

(-)gcc/fortran/interface.c (+3 lines)
Lines 374-379 Link Here
374
      if (dt1->dimension != dt2->dimension)
374
      if (dt1->dimension != dt2->dimension)
375
	return 0;
375
	return 0;
376
376
377
     if (dt1->allocatable != dt2->allocatable)
378
	return 0;
379
377
      if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
380
      if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
378
	return 0;
381
	return 0;
379
382
(-)gcc/fortran/intrinsic.c (+5 lines)
Lines 2318-2323 Link Here
2318
	      length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2318
	      length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2319
	      trim_name, BT_LOGICAL, dl, OPTIONAL);
2319
	      trim_name, BT_LOGICAL, dl, OPTIONAL);
2320
2320
2321
  add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003,
2322
	      gfc_check_move_alloc, NULL, NULL,
2323
	      f, BT_UNKNOWN, 0, REQUIRED,
2324
	      t, BT_UNKNOWN, 0, REQUIRED);
2325
2321
  add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2326
  add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2322
	      gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2327
	      gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2323
	      f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2328
	      f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
(-)gcc/fortran/trans-expr.c (-18 / +189 lines)
Lines 42-48 Link Here
42
#include "trans-stmt.h"
42
#include "trans-stmt.h"
43
#include "dependency.h"
43
#include "dependency.h"
44
44
45
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45
static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
46
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
46
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
47
						 gfc_expr *);
47
						 gfc_expr *);
48
48
Lines 1702-1708 Link Here
1702
1702
1703
  if (intent != INTENT_OUT)
1703
  if (intent != INTENT_OUT)
1704
    {
1704
    {
1705
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1705
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1706
      gfc_add_expr_to_block (&body, tmp);
1706
      gfc_add_expr_to_block (&body, tmp);
1707
      gcc_assert (rse.ss == gfc_ss_terminator);
1707
      gcc_assert (rse.ss == gfc_ss_terminator);
1708
      gfc_trans_scalarizing_loops (&loop, &body);
1708
      gfc_trans_scalarizing_loops (&loop, &body);
Lines 1787-1793 Link Here
1787
1787
1788
  gcc_assert (lse.ss == gfc_ss_terminator);
1788
  gcc_assert (lse.ss == gfc_ss_terminator);
1789
1789
1790
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1790
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1791
  gfc_add_expr_to_block (&body, tmp);
1791
  gfc_add_expr_to_block (&body, tmp);
1792
  
1792
  
1793
  /* Generate the copying loops.  */
1793
  /* Generate the copying loops.  */
Lines 1859-1864 Link Here
1859
  gfc_ss *argss;
1859
  gfc_ss *argss;
1860
  gfc_ss_info *info;
1860
  gfc_ss_info *info;
1861
  int byref;
1861
  int byref;
1862
  int parm_kind;
1862
  tree type;
1863
  tree type;
1863
  tree var;
1864
  tree var;
1864
  tree len;
1865
  tree len;
Lines 1872-1877 Link Here
1872
  gfc_expr *e;
1873
  gfc_expr *e;
1873
  gfc_symbol *fsym;
1874
  gfc_symbol *fsym;
1874
  stmtblock_t post;
1875
  stmtblock_t post;
1876
  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1875
1877
1876
  arglist = NULL_TREE;
1878
  arglist = NULL_TREE;
1877
  retargs = NULL_TREE;
1879
  retargs = NULL_TREE;
Lines 1914-1919 Link Here
1914
    {
1916
    {
1915
      e = arg->expr;
1917
      e = arg->expr;
1916
      fsym = formal ? formal->sym : NULL;
1918
      fsym = formal ? formal->sym : NULL;
1919
      parm_kind = MISSING;
1917
      if (e == NULL)
1920
      if (e == NULL)
1918
	{
1921
	{
1919
1922
Lines 1942-1947 Link Here
1942
	  /* An elemental function inside a scalarized loop.  */
1945
	  /* An elemental function inside a scalarized loop.  */
1943
          gfc_init_se (&parmse, se);
1946
          gfc_init_se (&parmse, se);
1944
          gfc_conv_expr_reference (&parmse, e);
1947
          gfc_conv_expr_reference (&parmse, e);
1948
	  parm_kind = ELEMENTAL;
1945
	}
1949
	}
1946
      else
1950
      else
1947
	{
1951
	{
Lines 1952-1963 Link Here
1952
	  if (argss == gfc_ss_terminator)
1956
	  if (argss == gfc_ss_terminator)
1953
            {
1957
            {
1954
	      gfc_conv_expr_reference (&parmse, e);
1958
	      gfc_conv_expr_reference (&parmse, e);
1959
	      parm_kind = SCALAR;
1955
              if (fsym && fsym->attr.pointer
1960
              if (fsym && fsym->attr.pointer
1956
		  && e->expr_type != EXPR_NULL)
1961
		  && e->expr_type != EXPR_NULL)
1957
                {
1962
                {
1958
                  /* Scalar pointer dummy args require an extra level of
1963
                  /* Scalar pointer dummy args require an extra level of
1959
		  indirection. The null pointer already contains
1964
		  indirection. The null pointer already contains
1960
		  this level of indirection.  */
1965
		  this level of indirection.  */
1966
		  parm_kind = SCALAR_POINTER;
1961
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1967
                  parmse.expr = build_fold_addr_expr (parmse.expr);
1962
                }
1968
                }
1963
            }
1969
            }
Lines 2014-2019 Link Here
2014
      gfc_add_block_to_block (&se->pre, &parmse.pre);
2020
      gfc_add_block_to_block (&se->pre, &parmse.pre);
2015
      gfc_add_block_to_block (&post, &parmse.post);
2021
      gfc_add_block_to_block (&post, &parmse.post);
2016
2022
2023
      /* Allocated allocatable components of derived types must be
2024
	 deallocated for INTENT(OUT) dummy arguments and non-variable
2025
         scalars.  Non-variable arrays are dealt with in trans-array.c
2026
         (gfc_conv_array_parameter).  */
2027
      if (e && e->ts.type == BT_DERIVED
2028
	    && e->ts.derived->attr.alloc_comp
2029
	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
2030
		   ||
2031
		(e->expr_type != EXPR_VARIABLE && !e->rank)))
2032
        {
2033
	  int parm_rank;
2034
	  tmp = build_fold_indirect_ref (parmse.expr);
2035
	  parm_rank = e->rank;
2036
	  switch (parm_kind)
2037
	    {
2038
	    case (ELEMENTAL):
2039
	    case (SCALAR):
2040
	      parm_rank = 0;
2041
	      break;
2042
2043
	    case (SCALAR_POINTER):
2044
              tmp = build_fold_indirect_ref (tmp);
2045
	      break;
2046
	    case (ARRAY):
2047
              tmp = parmse.expr;
2048
	      break;
2049
	    }
2050
2051
          tmp = deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2052
	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2053
	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2054
			    tmp, build_empty_stmt ());
2055
2056
	  if (e->expr_type == EXPR_FUNCTION)
2057
	    /* Don't deallocate function results until they have been used.  */
2058
	    gfc_add_expr_to_block (&se->post, tmp);
2059
	  else
2060
	    gfc_add_expr_to_block (&se->pre, tmp);
2061
        }
2062
2017
      /* Character strings are passed as two parameters, a length and a
2063
      /* Character strings are passed as two parameters, a length and a
2018
         pointer.  */
2064
         pointer.  */
2019
      if (parmse.string_length != NULL_TREE)
2065
      if (parmse.string_length != NULL_TREE)
Lines 2590-2596 Link Here
2590
2636
2591
  gfc_conv_expr (&rse, expr);
2637
  gfc_conv_expr (&rse, expr);
2592
2638
2593
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2639
  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2594
  gfc_add_expr_to_block (&body, tmp);
2640
  gfc_add_expr_to_block (&body, tmp);
2595
2641
2596
  gcc_assert (rse.ss == gfc_ss_terminator);
2642
  gcc_assert (rse.ss == gfc_ss_terminator);
Lines 2614-2627 Link Here
2614
/* Assign a single component of a derived type constructor.  */
2660
/* Assign a single component of a derived type constructor.  */
2615
2661
2616
static tree
2662
static tree
2617
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2663
gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
2664
			       gfc_component * cm, gfc_expr * expr)
2618
{
2665
{
2619
  gfc_se se;
2666
  gfc_se se;
2667
  gfc_se lse;
2620
  gfc_ss *rss;
2668
  gfc_ss *rss;
2621
  stmtblock_t block;
2669
  stmtblock_t block;
2622
  tree tmp;
2670
  tree tmp;
2671
  tree offset;
2672
  int n;
2623
2673
2624
  gfc_start_block (&block);
2674
  gfc_start_block (&block);
2675
2676
#if 0
2677
  if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2678
    gfc_todo_error ("derived types with allocatable components as "
2679
		    "arguments of derived type constructors");
2680
#endif
2625
  if (cm->pointer)
2681
  if (cm->pointer)
2626
    {
2682
    {
2627
      gfc_init_se (&se, NULL);
2683
      gfc_init_se (&se, NULL);
Lines 2654-2673 Link Here
2654
    }
2710
    }
2655
  else if (cm->dimension)
2711
  else if (cm->dimension)
2656
    {
2712
    {
2657
      tmp = gfc_trans_subarray_assign (dest, cm, expr);
2713
      if (cm->allocatable && expr->expr_type == EXPR_NULL)
2658
      gfc_add_expr_to_block (&block, tmp);
2714
	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2715
      else if (cm->allocatable)
2716
	{
2717
	  tree tmp2;
2718
2719
	  gfc_init_se (&se, NULL);
2720
	  gfc_init_se (&lse, NULL);
2721
2722
	  se.want_pointer = 0;
2723
	  gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
2724
	  if (cm->ts.type == BT_CHARACTER)
2725
	    lse.string_length = cm->ts.cl->backend_decl;
2726
2727
	  lse.expr = dest;
2728
2729
	  /* Clean up temporaries at the right time.  */
2730
	  if (expr->expr_type == EXPR_FUNCTION)
2731
	    {
2732
	      stmtblock_t tmp_block;
2733
2734
	      /* Prevent the freeing of the memory after the array assignment to
2735
		 the derived type component....  */
2736
	      gfc_init_block (&tmp_block);
2737
	      gfc_add_block_to_block (&tmp_block, &se.post);
2738
	      gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
2739
	      gfc_add_block_to_block (&se.post, &tmp_block);
2740
2741
	      /* ...and do it when the derived type is completed.  */
2742
	      tmp = gfc_conv_descriptor_data_get (lse.expr);
2743
	      tmp = convert (pvoid_type_node, tmp);
2744
	      tmp = gfc_chainon_list (NULL_TREE, tmp);
2745
	      tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2746
	      gfc_add_expr_to_block (&outer_se->post, tmp);
2747
	    }
2748
2749
	  tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2750
	  gfc_add_expr_to_block (&block, tmp);
2751
2752
	  /* Shift the lbound and ubound of temporaries to being unity, rather
2753
	     than zero, based.  Calculate the offset for all cases.  */
2754
	  offset = gfc_conv_descriptor_offset (dest);
2755
	  gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2756
	  tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2757
	  for (n = 0; n < expr->rank; n++)
2758
	    {
2759
	      if (expr->expr_type != EXPR_VARIABLE
2760
		    && expr->expr_type != EXPR_CONSTANT)
2761
		{
2762
		  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2763
		  gfc_add_modify_expr (&block, tmp,
2764
				       fold_build2 (PLUS_EXPR, gfc_array_index_type,
2765
						    tmp, gfc_index_one_node));
2766
		  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2767
		  gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2768
		}
2769
	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2770
				 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
2771
				 gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
2772
	      gfc_add_modify_expr (&block, tmp2, tmp);
2773
	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2774
	      gfc_add_modify_expr (&block, offset, tmp);
2775
	    }  
2776
	}
2777
      else
2778
	{
2779
	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
2780
	  gfc_add_expr_to_block (&block, tmp);
2781
	}
2659
    }
2782
    }
2660
  else if (expr->ts.type == BT_DERIVED)
2783
  else if (expr->ts.type == BT_DERIVED)
2661
    {
2784
    {
2662
      /* Nested derived type.  */
2785
      /* Nested derived type.  */
2663
      tmp = gfc_trans_structure_assign (dest, expr);
2786
      tmp = gfc_trans_structure_assign (outer_se, dest, expr);
2664
      gfc_add_expr_to_block (&block, tmp);
2787
      gfc_add_expr_to_block (&block, tmp);
2665
    }
2788
    }
2666
  else
2789
  else
2667
    {
2790
    {
2668
      /* Scalar component.  */
2791
      /* Scalar component.  */
2669
      gfc_se lse;
2670
2671
      gfc_init_se (&se, NULL);
2792
      gfc_init_se (&se, NULL);
2672
      gfc_init_se (&lse, NULL);
2793
      gfc_init_se (&lse, NULL);
2673
2794
Lines 2675-2681 Link Here
2675
      if (cm->ts.type == BT_CHARACTER)
2796
      if (cm->ts.type == BT_CHARACTER)
2676
	lse.string_length = cm->ts.cl->backend_decl;
2797
	lse.string_length = cm->ts.cl->backend_decl;
2677
      lse.expr = dest;
2798
      lse.expr = dest;
2678
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2799
      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2679
      gfc_add_expr_to_block (&block, tmp);
2800
      gfc_add_expr_to_block (&block, tmp);
2680
    }
2801
    }
2681
  return gfc_finish_block (&block);
2802
  return gfc_finish_block (&block);
Lines 2684-2690 Link Here
2684
/* Assign a derived type constructor to a variable.  */
2805
/* Assign a derived type constructor to a variable.  */
2685
2806
2686
static tree
2807
static tree
2687
gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2808
gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
2688
{
2809
{
2689
  gfc_constructor *c;
2810
  gfc_constructor *c;
2690
  gfc_component *cm;
2811
  gfc_component *cm;
Lines 2702-2708 Link Here
2702
2823
2703
      field = cm->backend_decl;
2824
      field = cm->backend_decl;
2704
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2825
      tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2705
      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2826
      tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
2706
      gfc_add_expr_to_block (&block, tmp);
2827
      gfc_add_expr_to_block (&block, tmp);
2707
    }
2828
    }
2708
  return gfc_finish_block (&block);
2829
  return gfc_finish_block (&block);
Lines 2729-2735 Link Here
2729
    {
2850
    {
2730
      /* Create a temporary variable and fill it in.  */
2851
      /* Create a temporary variable and fill it in.  */
2731
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2852
      se->expr = gfc_create_var (type, expr->ts.derived->name);
2732
      tmp = gfc_trans_structure_assign (se->expr, expr);
2853
      tmp = gfc_trans_structure_assign (se, se->expr, expr);
2733
      gfc_add_expr_to_block (&se->pre, tmp);
2854
      gfc_add_expr_to_block (&se->pre, tmp);
2734
      return;
2855
      return;
2735
    }
2856
    }
Lines 3036-3048 Link Here
3036
   strings.  */
3157
   strings.  */
3037
3158
3038
tree
3159
tree
3039
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
3160
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3161
			 bool l_is_temp, bool r_is_var)
3040
{
3162
{
3041
  stmtblock_t block;
3163
  stmtblock_t block;
3164
  tree tmp;
3165
  tree cond;
3042
3166
3043
  gfc_init_block (&block);
3167
  gfc_init_block (&block);
3044
3168
3045
  if (type == BT_CHARACTER)
3169
  if (ts.type == BT_CHARACTER)
3046
    {
3170
    {
3047
      gcc_assert (lse->string_length != NULL_TREE
3171
      gcc_assert (lse->string_length != NULL_TREE
3048
	      && rse->string_length != NULL_TREE);
3172
	      && rse->string_length != NULL_TREE);
Lines 3056-3061 Link Here
3056
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3180
      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3057
			     rse->string_length, rse->expr);
3181
			     rse->string_length, rse->expr);
3058
    }
3182
    }
3183
  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3184
    {
3185
      cond = NULL_TREE;
3186
3187
      /* Are the rhs and the lhs the same?  */
3188
      if (r_is_var)
3189
	{
3190
	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
3191
			      build_fold_addr_expr (lse->expr),
3192
			      build_fold_addr_expr (rse->expr));
3193
	  cond = gfc_evaluate_now (cond, &lse->pre);
3194
	}
3195
3196
      /* Deallocate the lhs allocated components as long as it is not
3197
	 the same as the rhs.  */
3198
      if (!l_is_temp)
3199
	{
3200
	  tmp = deallocate_alloc_comp (ts.derived, lse->expr, 0);
3201
	  if (r_is_var)
3202
	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3203
	  gfc_add_expr_to_block (&lse->pre, tmp);
3204
	}
3205
	
3206
      gfc_add_block_to_block (&block, &lse->pre);
3207
      gfc_add_block_to_block (&block, &rse->pre);
3208
3209
      gfc_add_modify_expr (&block, lse->expr,
3210
			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
3211
3212
      /* Do a deep copy if the rhs is a variable, as long as it is not the
3213
	 same as the lhs.  Otherwise, nullify the data fields so that the
3214
	 lhs retains the allocated resources.  */
3215
      if (r_is_var)
3216
	{
3217
	  tmp = copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3218
	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3219
	  gfc_add_expr_to_block (&block, tmp);
3220
	}
3221
      else
3222
	{
3223
	  tmp = nullify_alloc_comp (ts.derived, rse->expr, 0);
3224
	  gfc_add_expr_to_block (&block, tmp);
3225
	}
3226
    }
3059
  else
3227
  else
3060
    {
3228
    {
3061
      gfc_add_block_to_block (&block, &lse->pre);
3229
      gfc_add_block_to_block (&block, &lse->pre);
Lines 3250-3256 Link Here
3250
  else
3418
  else
3251
    gfc_conv_expr (&lse, expr1);
3419
    gfc_conv_expr (&lse, expr1);
3252
3420
3253
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3421
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3422
				 loop.temp_ss != NULL,
3423
				 expr2->expr_type == EXPR_VARIABLE);
3254
  gfc_add_expr_to_block (&body, tmp);
3424
  gfc_add_expr_to_block (&body, tmp);
3255
3425
3256
  if (lss == gfc_ss_terminator)
3426
  if (lss == gfc_ss_terminator)
Lines 3283-3291 Link Here
3283
	  gcc_assert (lse.ss == gfc_ss_terminator
3453
	  gcc_assert (lse.ss == gfc_ss_terminator
3284
		      && rse.ss == gfc_ss_terminator);
3454
		      && rse.ss == gfc_ss_terminator);
3285
3455
3286
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3456
	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3287
	  gfc_add_expr_to_block (&body, tmp);
3457
	  gfc_add_expr_to_block (&body, tmp);
3288
	}
3458
	}
3459
3289
      /* Generate the copying loops.  */
3460
      /* Generate the copying loops.  */
3290
      gfc_trans_scalarizing_loops (&loop, &body);
3461
      gfc_trans_scalarizing_loops (&loop, &body);
3291
3462
(-)gcc/fortran/trans-array.c (-18 / +337 lines)
Lines 3316-3321 Link Here
3316
  tmp = gfc_conv_descriptor_offset (se->expr);
3316
  tmp = gfc_conv_descriptor_offset (se->expr);
3317
  gfc_add_modify_expr (&se->pre, tmp, offset);
3317
  gfc_add_modify_expr (&se->pre, tmp, offset);
3318
3318
3319
  if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3320
    {
3321
      tmp = nullify_alloc_comp (expr->ts.derived, se->expr, ref->u.ar.as->rank);
3322
      gfc_add_expr_to_block (&se->pre, tmp);
3323
    }
3324
3319
  return true;
3325
  return true;
3320
}
3326
}
3321
3327
Lines 3456-3461 Link Here
3456
        }
3462
        }
3457
      break;
3463
      break;
3458
3464
3465
    case EXPR_NULL:
3466
      return gfc_build_null_descriptor (type);
3467
3459
    default:
3468
    default:
3460
      gcc_unreachable ();
3469
      gcc_unreachable ();
3461
    }
3470
    }
Lines 4524-4530 Link Here
4524
        }
4533
        }
4525
      if (sym->attr.allocatable)
4534
      if (sym->attr.allocatable)
4526
        {
4535
        {
4527
          se->expr = gfc_conv_array_data (tmp);
4536
	  if (sym->attr.dummy)
4537
	    se->expr = tmp;
4538
	  else
4539
            se->expr = gfc_conv_array_data (tmp);
4528
          return;
4540
          return;
4529
        }
4541
        }
4530
    }
4542
    }
Lines 4532-4537 Link Here
4532
  se->want_pointer = 1;
4544
  se->want_pointer = 1;
4533
  gfc_conv_expr_descriptor (se, expr, ss);
4545
  gfc_conv_expr_descriptor (se, expr, ss);
4534
4546
4547
  /* Deallocate the allocatable components of structures that are
4548
     not variable.  */
4549
  if (expr->ts.type == BT_DERIVED
4550
	&& expr->ts.derived->attr.alloc_comp
4551
	&& expr->expr_type != EXPR_VARIABLE)
4552
    {
4553
      tmp = build_fold_indirect_ref (se->expr);
4554
      tmp = deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
4555
      gfc_add_expr_to_block (&se->post, tmp);
4556
    }
4557
4535
  if (g77)
4558
  if (g77)
4536
    {
4559
    {
4537
      desc = se->expr;
4560
      desc = se->expr;
Lines 4580-4603 Link Here
4580
gfc_trans_dealloc_allocated (tree descriptor)
4603
gfc_trans_dealloc_allocated (tree descriptor)
4581
{ 
4604
{ 
4582
  tree tmp;
4605
  tree tmp;
4583
  tree deallocate;
4606
  tree ptr;
4607
  tree var;
4584
  stmtblock_t block;
4608
  stmtblock_t block;
4585
4609
4586
  gfc_start_block (&block);
4610
  gfc_start_block (&block);
4587
  deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
4588
4611
4589
  tmp = gfc_conv_descriptor_data_get (descriptor);
4612
  tmp = gfc_conv_descriptor_data_addr (descriptor);
4590
  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4613
  var = gfc_evaluate_now (tmp, &block);
4591
                build_int_cst (TREE_TYPE (tmp), 0));
4614
  tmp = gfc_create_var (gfc_array_index_type, NULL);
4592
  tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
4615
  ptr = build_fold_addr_expr (tmp);
4616
4617
  /* Call array_deallocate with an int* present in the second argument.
4618
     Although it is ignored here, it's presence ensures that arrays that
4619
     are already deallocated are ignored.  */
4620
  tmp = gfc_chainon_list (NULL_TREE, var);
4621
  tmp = gfc_chainon_list (tmp, ptr);
4622
  tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
4593
  gfc_add_expr_to_block (&block, tmp);
4623
  gfc_add_expr_to_block (&block, tmp);
4624
  return gfc_finish_block (&block);
4625
}
4594
4626
4595
  tmp = gfc_finish_block (&block);
4596
4627
4597
  return tmp;
4628
/* This helper function calculates the size in words of a full array.  */
4629
4630
static tree
4631
get_full_array_size (stmtblock_t *block, tree decl, int rank)
4632
{
4633
  tree idx;
4634
  tree nelems;
4635
  tree tmp;
4636
  idx = gfc_rank_cst[rank - 1];
4637
  nelems = gfc_conv_descriptor_ubound (decl, idx);
4638
  tmp = gfc_conv_descriptor_lbound (decl, idx);
4639
  tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
4640
  tmp = build2 (PLUS_EXPR, gfc_array_index_type,
4641
		tmp, gfc_index_one_node);
4642
  tmp = gfc_evaluate_now (tmp, block);
4643
4644
  nelems = gfc_conv_descriptor_stride (decl, idx);
4645
  tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
4646
  return gfc_evaluate_now (tmp, block);
4598
}
4647
}
4599
4648
4600
4649
4650
/* Recursively traverse an object of derived type, generating code to deallocate,
4651
   nullify or copy allocatable components.  This is the work horse function for
4652
   the functions named in this enum.  */
4653
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
4654
4655
static tree
4656
structure_alloc_comps (gfc_symbol * der_type, tree decl,
4657
		       tree dest, int rank, int purpose)
4658
{
4659
  gfc_component *c;
4660
  gfc_loopinfo loop;
4661
  stmtblock_t fnblock;
4662
  stmtblock_t loopbody;
4663
  tree tmp;
4664
  tree comp;
4665
  tree dcmp;
4666
  tree nelems;
4667
  tree index;
4668
  tree var;
4669
  tree cdecl;
4670
  tree ctype;
4671
4672
  gfc_init_block (&fnblock);
4673
4674
  /* If this an array of derived types with allocatable components
4675
     build a loop and recursively call this function.  */
4676
  if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
4677
	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4678
    {
4679
      tmp = gfc_conv_array_data (decl);
4680
      var = build_fold_indirect_ref (tmp);
4681
	
4682
      /* Get the number of elements - 1 and set the counter.  */
4683
      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
4684
	{
4685
	  /* Use the descriptor for an allocatable array.  Since this
4686
	     is a full array reference, we only need the descriptor
4687
	     information from dimension = rank.  */
4688
	  nelems = get_full_array_size (&fnblock, decl, rank);
4689
4690
	  /* Set the result to -1 if already deallocated, so that the
4691
	     loop does not run.  */
4692
	  tmp = gfc_conv_descriptor_data_get (decl);
4693
	  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
4694
			build_int_cst (TREE_TYPE (tmp), 0));
4695
	  tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
4696
			nelems, gfc_index_zero_node);
4697
	  tmp = gfc_evaluate_now (tmp, &fnblock);
4698
	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
4699
			   tmp, gfc_index_one_node);
4700
	}
4701
      else
4702
	{
4703
	  /*  Otherwise use the TYPE_DOMAIN information.  */
4704
	  tmp =  array_type_nelts (TREE_TYPE (decl));
4705
	  tmp = fold_convert (gfc_array_index_type, tmp);
4706
	}
4707
4708
      nelems = gfc_evaluate_now (tmp, &fnblock);
4709
      index = gfc_create_var (gfc_array_index_type, "S");
4710
4711
      /* Build the body of the loop.  */
4712
      gfc_init_block (&loopbody);
4713
4714
      tmp = gfc_build_array_ref (var, index);
4715
4716
      if (purpose == COPY_ALLOC_COMP)
4717
        tmp = structure_alloc_comps (der_type, tmp,
4718
				     gfc_build_array_ref (dest, index),
4719
				     0, purpose);
4720
      else
4721
        tmp = structure_alloc_comps (der_type, tmp, NULL_TREE, 0, purpose);
4722
4723
      gfc_add_expr_to_block (&loopbody, tmp);
4724
4725
      /* Build the loop and return. */
4726
      gfc_init_loopinfo (&loop);
4727
      loop.dimen = 1;
4728
      loop.from[0] = gfc_index_zero_node;
4729
      loop.loopvar[0] = index;
4730
      loop.to[0] = nelems;
4731
      gfc_trans_scalarizing_loops (&loop, &loopbody);
4732
      gfc_add_block_to_block (&fnblock, &loop.pre);
4733
      return gfc_finish_block (&fnblock);
4734
    }
4735
4736
  /* Otherwise, deallocate the components or recursively call self to
4737
     deallocate the components of components. */
4738
  for (c = der_type->components; c; c = c->next)
4739
    {
4740
      cdecl = c->backend_decl;
4741
      ctype = TREE_TYPE (cdecl);
4742
4743
      switch (purpose)
4744
	{
4745
	case DEALLOCATE_ALLOC_COMP:
4746
	  /* Do not deallocate the components of ultimate pointer
4747
	     components.  */
4748
	  if (c->ts.type == BT_DERIVED
4749
		&& c->ts.derived->attr.alloc_comp
4750
		&& !c->pointer)
4751
	    {
4752
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4753
	      rank = c->as ? c->as->rank : 0;
4754
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4755
					   rank, purpose);
4756
	      gfc_add_expr_to_block (&fnblock, tmp);
4757
	    }
4758
4759
	  if (c->allocatable)
4760
	    {
4761
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4762
	      tmp = gfc_trans_dealloc_allocated (comp);
4763
	      gfc_add_expr_to_block (&fnblock, tmp);
4764
	    }
4765
	  break;
4766
4767
	case NULLIFY_ALLOC_COMP:
4768
	  if (c->pointer)
4769
	    continue;
4770
	  else if (c->allocatable)
4771
	    {
4772
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4773
	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
4774
	    }
4775
          else if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4776
	    {
4777
	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4778
	      rank = c->as ? c->as->rank : 0;
4779
	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
4780
					   rank, purpose);
4781
	      gfc_add_expr_to_block (&fnblock, tmp);
4782
	    }
4783
	  break;
4784
4785
	case COPY_ALLOC_COMP:
4786
	  if (c->pointer)
4787
	    continue;
4788
4789
	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
4790
	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
4791
	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
4792
4793
	  if (c->allocatable)
4794
	    {
4795
	      tree size;
4796
	      tree args;
4797
	      tree null_cond;
4798
	      tree null_data;
4799
	      stmtblock_t block;
4800
4801
	      /* If the source is null, set the destination to null. */
4802
	      gfc_init_block (&block);
4803
	      gfc_conv_descriptor_data_set (&block, dcmp,
4804
					    null_pointer_node);
4805
	      null_data = gfc_finish_block (&block);
4806
4807
	      gfc_init_block (&block);
4808
	      nelems = get_full_array_size (&block, comp, c->as->rank);
4809
	      size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
4810
				  TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
4811
4812
	      /* Allocate memory to the destination.  */
4813
	      tmp = gfc_chainon_list (NULL_TREE, size);
4814
	      if (gfc_index_integer_kind == 4)
4815
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
4816
	      else if (gfc_index_integer_kind == 8)
4817
		tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
4818
	      else
4819
		gcc_unreachable ();
4820
	      tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (comp)),
4821
		          tmp));
4822
	      gfc_conv_descriptor_data_set (&block, dcmp, tmp);
4823
4824
	      /* We know the temporary and the value will be the same length,
4825
		 so can use memcpy.  */
4826
	      tmp = gfc_conv_descriptor_data_get (dcmp);
4827
	      args = gfc_chainon_list (NULL_TREE, tmp);
4828
	      tmp = gfc_conv_descriptor_data_get (comp);
4829
	      args = gfc_chainon_list (args, tmp);
4830
	      args = gfc_chainon_list (args, size);
4831
	      tmp = built_in_decls[BUILT_IN_MEMCPY];
4832
	      tmp = build_function_call_expr (tmp, args);
4833
	      gfc_add_expr_to_block (&block, tmp);
4834
	      tmp = gfc_finish_block (&block);
4835
4836
	      /* Null the destination if the source is null; otherwise do
4837
		 the allocate and copy.  */
4838
	      null_cond = gfc_conv_descriptor_data_get (comp);
4839
	      null_cond = convert (pvoid_type_node, null_cond);
4840
	      null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
4841
				  null_pointer_node);
4842
	      tmp = build3_v (COND_EXPR, null_cond, tmp, null_data);
4843
	      gfc_add_expr_to_block (&fnblock, tmp);
4844
	    }
4845
4846
          if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
4847
	    {
4848
	      rank = c->as ? c->as->rank : 0;
4849
	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
4850
					   rank, purpose);
4851
	      gfc_add_expr_to_block (&fnblock, tmp);
4852
	    }
4853
	  break;
4854
4855
	default:
4856
	  gcc_unreachable ();
4857
	  break;
4858
	}
4859
    }
4860
4861
  return gfc_finish_block (&fnblock);
4862
}
4863
4864
/* Recursively traverse an object of derived type, generating code to
4865
   nullify allocatable components.  */
4866
4867
tree
4868
nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4869
{
4870
  return structure_alloc_comps (der_type, decl, NULL_TREE, 
4871
				rank, NULLIFY_ALLOC_COMP);
4872
}
4873
4874
4875
/* Recursively traverse an object of derived type, generating code to
4876
   deallocate allocatable components.  */
4877
4878
tree
4879
deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
4880
{
4881
  return structure_alloc_comps (der_type, decl, NULL_TREE,
4882
				rank, DEALLOCATE_ALLOC_COMP);
4883
}
4884
4885
4886
/* Recursively traverse an object of derived type, generating code to
4887
   copy its allocatable components.  */
4888
4889
tree
4890
copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
4891
{
4892
  return structure_alloc_comps (der_type, decl, dest,
4893
				rank, COPY_ALLOC_COMP);
4894
}
4895
4896
4601
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4897
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
4602
4898
4603
tree
4899
tree
Lines 4608-4623 Link Here
4608
  tree descriptor;
4904
  tree descriptor;
4609
  stmtblock_t fnblock;
4905
  stmtblock_t fnblock;
4610
  locus loc;
4906
  locus loc;
4907
  int rank;
4611
4908
4612
  /* Make sure the frontend gets these right.  */
4909
  /* Make sure the frontend gets these right.  */
4613
  if (!(sym->attr.pointer || sym->attr.allocatable))
4910
  if (!(sym->attr.pointer || sym->attr.allocatable
4614
    fatal_error
4911
	|| (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
4615
      ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
4912
    fatal_error ("Possible frontend bug: Deferred array size without pointer"
4913
		 "allocatable attribute.");
4616
4914
4617
  gfc_init_block (&fnblock);
4915
  gfc_init_block (&fnblock);
4618
4916
4619
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4917
  gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
4620
                || TREE_CODE (sym->backend_decl) == PARM_DECL);
4918
		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
4621
4919
4622
  if (sym->ts.type == BT_CHARACTER
4920
  if (sym->ts.type == BT_CHARACTER
4623
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
4921
      && !INTEGER_CST_P (sym->ts.cl->backend_decl))
Lines 4647-4668 Link Here
4647
4945
4648
  /* Get the descriptor type.  */
4946
  /* Get the descriptor type.  */
4649
  type = TREE_TYPE (sym->backend_decl);
4947
  type = TREE_TYPE (sym->backend_decl);
4650
  if (!GFC_DESCRIPTOR_TYPE_P (type))
4948
    
4949
  if (sym->ts.type == BT_DERIVED
4950
	&& sym->ts.derived->attr.alloc_comp
4951
	&& !(sym->attr.pointer || sym->attr.allocatable))
4651
    {
4952
    {
4953
      rank = sym->as ? sym->as->rank : 0;
4954
      tmp = nullify_alloc_comp (sym->ts.derived, descriptor, rank);
4955
      gfc_add_expr_to_block (&fnblock, tmp);
4956
    }
4957
  else if (!GFC_DESCRIPTOR_TYPE_P (type))
4958
    {
4652
      /* If the backend_decl is not a descriptor, we must have a pointer
4959
      /* If the backend_decl is not a descriptor, we must have a pointer
4653
	 to one.  */
4960
	 to one.  */
4654
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4961
      descriptor = build_fold_indirect_ref (sym->backend_decl);
4655
      type = TREE_TYPE (descriptor);
4962
      type = TREE_TYPE (descriptor);
4656
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
4657
    }
4963
    }
4658
4964
  
4659
  /* NULLIFY the data pointer.  */
4965
  /* NULLIFY the data pointer.  */
4660
  gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4966
  if (GFC_DESCRIPTOR_TYPE_P (type))
4967
    gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
4661
4968
4662
  gfc_add_expr_to_block (&fnblock, body);
4969
  gfc_add_expr_to_block (&fnblock, body);
4663
4970
4664
  gfc_set_backend_locus (&loc);
4971
  gfc_set_backend_locus (&loc);
4665
  /* Allocatable arrays need to be freed when they go out of scope.  */
4972
4973
  /* Allocatable arrays need to be freed when they go out of scope.
4974
     The allocatable components of pointers must not be touched.  */
4975
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
4976
      && !(sym->attr.function || sym->attr.result)
4977
      && !sym->attr.pointer)
4978
    {
4979
      int rank;
4980
      rank = sym->as ? sym->as->rank : 0;
4981
      tmp = deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
4982
      gfc_add_expr_to_block (&fnblock, tmp);
4983
    }
4984
4666
  if (sym->attr.allocatable)
4985
  if (sym->attr.allocatable)
4667
    {
4986
    {
4668
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
4987
      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
(-)gcc/fortran/symbol.c (+2 lines)
Lines 1523-1528 Link Here
1523
1523
1524
  c->dimension = attr->dimension;
1524
  c->dimension = attr->dimension;
1525
  c->pointer = attr->pointer;
1525
  c->pointer = attr->pointer;
1526
  c->allocatable = attr->allocatable;
1526
}
1527
}
1527
1528
1528
1529
Lines 1536-1541 Link Here
1536
  gfc_clear_attr (attr);
1537
  gfc_clear_attr (attr);
1537
  attr->dimension = c->dimension;
1538
  attr->dimension = c->dimension;
1538
  attr->pointer = c->pointer;
1539
  attr->pointer = c->pointer;
1540
  attr->allocatable = c->allocatable;
1539
}
1541
}
1540
1542
1541
1543
(-)gcc/fortran/decl.c (-8 / +38 lines)
Lines 963-979 Link Here
963
963
964
  /* Check array components.  */
964
  /* Check array components.  */
965
  if (!c->dimension)
965
  if (!c->dimension)
966
    return SUCCESS;
966
    {
967
      if (c->allocatable)
968
	{
969
	  gfc_error ("Allocatable component at %C must be an array");
970
	  return FAILURE;
971
	}
972
      else
973
	return SUCCESS;
974
    }
967
975
968
  if (c->pointer)
976
  if (c->pointer)
969
    {
977
    {
970
      if (c->as->type != AS_DEFERRED)
978
      if (c->as->type != AS_DEFERRED)
971
	{
979
	{
972
	  gfc_error ("Pointer array component of structure at %C "
980
	  gfc_error ("Pointer array component of structure at %C must have a "
973
		     "must have a deferred shape");
981
		     "deferred shape");
974
	  return FAILURE;
982
	  return FAILURE;
975
	}
983
	}
976
    }
984
    }
985
  else if (c->allocatable)
986
    {
987
      if (c->as->type != AS_DEFERRED)
988
	{
989
	  gfc_error ("Allocatable component of structure at %C must have a "
990
		     "deferred shape");
991
	  return FAILURE;
992
	}
993
    }
977
  else
994
  else
978
    {
995
    {
979
      if (c->as->type != AS_EXPLICIT)
996
      if (c->as->type != AS_EXPLICIT)
Lines 2142-2152 Link Here
2142
	  && d != DECL_DIMENSION && d != DECL_POINTER
2159
	  && d != DECL_DIMENSION && d != DECL_POINTER
2143
	  && d != DECL_COLON && d != DECL_NONE)
2160
	  && d != DECL_COLON && d != DECL_NONE)
2144
	{
2161
	{
2145
2162
	  if (d == DECL_ALLOCATABLE)
2146
	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2163
	    {
2147
		     &seen_at[d]);
2164
	      if (gfc_notify_std (GFC_STD_F2003, 
2148
	  m = MATCH_ERROR;
2165
				   "In the selected standard, the ALLOCATABLE "
2149
	  goto cleanup;
2166
				   "attribute at %C is not allowed in a TYPE "
2167
				   "definition") == FAILURE)         
2168
		{
2169
		  m = MATCH_ERROR;
2170
		  goto cleanup;
2171
		}
2172
            }
2173
          else
2174
	    {
2175
	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2176
			  &seen_at[d]);
2177
	      m = MATCH_ERROR;
2178
	      goto cleanup;
2179
	    }
2150
	}
2180
	}
2151
2181
2152
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2182
      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
(-)gcc/fortran/intrinsic.h (+1 lines)
Lines 149-154 Link Here
149
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
149
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
150
try gfc_check_gerror (gfc_expr *);
150
try gfc_check_gerror (gfc_expr *);
151
try gfc_check_getlog (gfc_expr *);
151
try gfc_check_getlog (gfc_expr *);
152
try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
152
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
153
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
153
		      gfc_expr *);
154
		      gfc_expr *);
154
try gfc_check_random_number (gfc_expr *);
155
try gfc_check_random_number (gfc_expr *);
(-)gcc/fortran/trans-array.h (+7 lines)
Lines 43-48 Link Here
43
tree gfc_trans_g77_array (gfc_symbol *, tree);
43
tree gfc_trans_g77_array (gfc_symbol *, tree);
44
/* Generate code to deallocate an array, if it is allocated.  */
44
/* Generate code to deallocate an array, if it is allocated.  */
45
tree gfc_trans_dealloc_allocated (tree);
45
tree gfc_trans_dealloc_allocated (tree);
46
47
tree nullify_alloc_comp (gfc_symbol *, tree, int);
48
49
tree deallocate_alloc_comp (gfc_symbol *, tree, int);
50
51
tree copy_alloc_comp (gfc_symbol *, tree, tree, int);
52
46
/* Add initialization for deferred arrays.  */
53
/* Add initialization for deferred arrays.  */
47
tree gfc_trans_deferred_array (gfc_symbol *, tree);
54
tree gfc_trans_deferred_array (gfc_symbol *, tree);
48
/* Generate an initializer for a static pointer or allocatable array.  */
55
/* Generate an initializer for a static pointer or allocatable array.  */
(-)gcc/fortran/gfortran.h (-1 / +5 lines)
Lines 522-527 Link Here
522
  /* Special attributes for Cray pointers, pointees.  */
522
  /* Special attributes for Cray pointers, pointees.  */
523
  unsigned cray_pointer:1, cray_pointee:1;
523
  unsigned cray_pointer:1, cray_pointee:1;
524
524
525
  /* The symbol is a derived type with allocatable components, possibly nested.
526
   */
527
  unsigned alloc_comp:1;
525
}
528
}
526
symbol_attribute;
529
symbol_attribute;
527
530
Lines 639-645 Link Here
639
  const char *name;
642
  const char *name;
640
  gfc_typespec ts;
643
  gfc_typespec ts;
641
644
642
  int pointer, dimension;
645
  int pointer, allocatable, dimension;
643
  gfc_array_spec *as;
646
  gfc_array_spec *as;
644
647
645
  tree backend_decl;
648
  tree backend_decl;
Lines 1958-1963 Link Here
1958
void gfc_free_actual_arglist (gfc_actual_arglist *);
1961
void gfc_free_actual_arglist (gfc_actual_arglist *);
1959
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1962
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
1960
const char *gfc_extract_int (gfc_expr *, int *);
1963
const char *gfc_extract_int (gfc_expr *, int *);
1964
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
1961
1965
1962
gfc_expr *gfc_build_conversion (gfc_expr *);
1966
gfc_expr *gfc_build_conversion (gfc_expr *);
1963
void gfc_free_ref_list (gfc_ref *);
1967
void gfc_free_ref_list (gfc_ref *);
(-)gcc/fortran/trans-stmt.c (-6 / +27 lines)
Lines 1795-1801 Link Here
1795
      gfc_conv_expr (&lse, expr);
1795
      gfc_conv_expr (&lse, expr);
1796
1796
1797
      /* Use the scalar assignment.  */
1797
      /* Use the scalar assignment.  */
1798
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1798
      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1799
1799
1800
      /* Form the mask expression according to the mask tree list.  */
1800
      /* Form the mask expression according to the mask tree list.  */
1801
      if (wheremask)
1801
      if (wheremask)
Lines 1890-1896 Link Here
1890
    }
1890
    }
1891
1891
1892
  /* Use the scalar assignment.  */
1892
  /* Use the scalar assignment.  */
1893
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1893
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);
1894
1894
1895
  /* Form the mask expression according to the mask tree list.  */
1895
  /* Form the mask expression according to the mask tree list.  */
1896
  if (wheremask)
1896
  if (wheremask)
Lines 2971-2977 Link Here
2971
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2971
    maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2972
2972
2973
  /* Use the scalar assignment as is.  */
2973
  /* Use the scalar assignment as is.  */
2974
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2974
  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
2975
				 loop.temp_ss != NULL, false);
2975
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2976
  tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2976
2977
2977
  gfc_add_expr_to_block (&body, tmp);
2978
  gfc_add_expr_to_block (&body, tmp);
Lines 3024-3030 Link Here
3024
				    maskexpr);
3025
				    maskexpr);
3025
3026
3026
          /* Use the scalar assignment as is.  */
3027
          /* Use the scalar assignment as is.  */
3027
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
3028
          tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3028
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3029
          tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3029
          gfc_add_expr_to_block (&body, tmp);
3030
          gfc_add_expr_to_block (&body, tmp);
3030
3031
Lines 3399-3406 Link Here
3399
        gfc_conv_expr (&edse, edst);
3400
        gfc_conv_expr (&edse, edst);
3400
    }
3401
    }
3401
3402
3402
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
3403
  tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3403
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
3404
  estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3404
		 : build_empty_stmt ();
3405
		 : build_empty_stmt ();
3405
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3406
  tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3406
  gfc_add_expr_to_block (&body, tmp);
3407
  gfc_add_expr_to_block (&body, tmp);
Lines 3668-3673 Link Here
3668
      se.descriptor_only = 1;
3669
      se.descriptor_only = 1;
3669
      gfc_conv_expr (&se, expr);
3670
      gfc_conv_expr (&se, expr);
3670
3671
3672
      if (expr->ts.type == BT_DERIVED
3673
	    && expr->ts.derived->attr.alloc_comp)
3674
        {
3675
	  gfc_ref *ref;
3676
	  gfc_ref *last = NULL;
3677
	  for (ref = expr->ref; ref; ref = ref->next)
3678
	    if (ref->type == REF_COMPONENT)
3679
	      last = ref;
3680
3681
	  /* Do not deallocate the components of a derived type
3682
	     ultimate pointer component.  */
3683
	  if (!(last && last->u.c.component->pointer)
3684
		   && !(!last && expr->symtree->n.sym->attr.pointer))
3685
	    {
3686
	      tmp = deallocate_alloc_comp (expr->ts.derived, se.expr,
3687
					   expr->rank);
3688
	      gfc_add_expr_to_block (&se.pre, tmp);
3689
	    }
3690
	}
3691
3671
      if (expr->rank)
3692
      if (expr->rank)
3672
	tmp = gfc_array_deallocate (se.expr, pstat);
3693
	tmp = gfc_array_deallocate (se.expr, pstat);
3673
      else
3694
      else
(-)gcc/fortran/expr.c (+32 lines)
Lines 2535-2537 Link Here
2535
          break;
2535
          break;
2536
        }
2536
        }
2537
}
2537
}
2538
2539
2540
/* Given the expression node e for an allocatable/pointer of derived type to be
2541
   allocated, get the expression node to be initialized afterwards (needed for
2542
   derived types with default initializers, and derived types with allocatable
2543
   components that need nullification.)  */
2544
2545
gfc_expr *
2546
gfc_expr_to_initialize (gfc_expr * e)
2547
{
2548
  gfc_expr *result;
2549
  gfc_ref *ref;
2550
  int i;
2551
2552
  result = gfc_copy_expr (e);
2553
2554
  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
2555
  for (ref = result->ref; ref; ref = ref->next)
2556
    if (ref->type == REF_ARRAY && ref->next == NULL)
2557
      {
2558
        ref->u.ar.type = AR_FULL;
2559
2560
        for (i = 0; i < ref->u.ar.dimen; i++)
2561
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2562
2563
        result->rank = ref->u.ar.dimen; 
2564
        break;
2565
      }
2566
2567
  return result;
2568
}
2569
(-)gcc/fortran/module.c (-1 / +10 lines)
Lines 1435-1441 Link Here
1435
  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
1435
  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
1436
  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1436
  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1437
  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
1437
  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
1438
  AB_CRAY_POINTEE, AB_THREADPRIVATE
1438
  AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP
1439
}
1439
}
1440
ab_attribute;
1440
ab_attribute;
1441
1441
Lines 1465-1470 Link Here
1465
    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1465
    minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1466
    minit ("CRAY_POINTER", AB_CRAY_POINTER),
1466
    minit ("CRAY_POINTER", AB_CRAY_POINTER),
1467
    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1467
    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1468
    minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1469
    minit ("ALLOC_COMP", AB_ALLOC_COMP),
1468
    minit (NULL, -1)
1470
    minit (NULL, -1)
1469
};
1471
};
1470
1472
Lines 1556-1561 Link Here
1556
      if (attr->cray_pointee)
1558
      if (attr->cray_pointee)
1557
	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1559
	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1558
1560
1561
      if (attr->alloc_comp)
1562
	MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
1563
1559
      mio_rparen ();
1564
      mio_rparen ();
1560
1565
1561
    }
1566
    }
Lines 1644-1649 Link Here
1644
	    case AB_CRAY_POINTEE:
1649
	    case AB_CRAY_POINTEE:
1645
	      attr->cray_pointee = 1;
1650
	      attr->cray_pointee = 1;
1646
	      break;
1651
	      break;
1652
	    case AB_ALLOC_COMP:
1653
	      attr->alloc_comp = 1;
1654
	      break;
1647
	    }
1655
	    }
1648
	}
1656
	}
1649
    }
1657
    }
Lines 1951-1956 Link Here
1951
1959
1952
  mio_integer (&c->dimension);
1960
  mio_integer (&c->dimension);
1953
  mio_integer (&c->pointer);
1961
  mio_integer (&c->pointer);
1962
  mio_integer (&c->allocatable);
1954
1963
1955
  mio_expr (&c->initializer);
1964
  mio_expr (&c->initializer);
1956
  mio_rparen ();
1965
  mio_rparen ();
(-)gcc/fortran/trans-types.c (-1 / +1 lines)
Lines 1532-1538 Link Here
1532
         required.  */
1532
         required.  */
1533
      if (c->dimension)
1533
      if (c->dimension)
1534
	{
1534
	{
1535
	  if (c->pointer)
1535
	  if (c->pointer || c->allocatable)
1536
	    {
1536
	    {
1537
	      /* Pointers to arrays aren't actually pointer types.  The
1537
	      /* Pointers to arrays aren't actually pointer types.  The
1538
	         descriptors are separate, but the data is common.  */
1538
	         descriptors are separate, but the data is common.  */
(-)gcc/fortran/trans.h (-1 / +1 lines)
Lines 307-313 Link Here
307
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
307
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
308
308
309
/* Generate code for a scalar assignment.  */
309
/* Generate code for a scalar assignment.  */
310
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt);
310
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool);
311
311
312
/* Translate COMMON blocks.  */
312
/* Translate COMMON blocks.  */
313
void gfc_trans_common (gfc_namespace *);
313
void gfc_trans_common (gfc_namespace *);
(-)gcc/fortran/resolve.c (-41 / +8 lines)
Lines 911-923 Link Here
911
911
912
912
913
/* Do the checks of the actual argument list that are specific to elemental
913
/* Do the checks of the actual argument list that are specific to elemental
914
   procedures.  If called with c == NULL, we have a function, otherwise if
914
   procedures.  */
915
   expr == NULL, we have a subroutine.  */
916
static try
915
static try
917
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
916
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
918
{
917
{
919
  gfc_actual_arglist *arg0;
918
  gfc_actual_arglist * arg0;
920
  gfc_actual_arglist *arg;
919
  gfc_actual_arglist * arg;
921
  gfc_symbol *esym = NULL;
920
  gfc_symbol *esym = NULL;
922
  gfc_intrinsic_sym *isym = NULL;
921
  gfc_intrinsic_sym *isym = NULL;
923
  gfc_expr *e = NULL;
922
  gfc_expr *e = NULL;
Lines 928-934 Link Here
928
  int i;
927
  int i;
929
  int rank = 0;
928
  int rank = 0;
930
929
931
  /* Is this an elemental procedure?  */
932
  if (expr && expr->value.function.actual != NULL)
930
  if (expr && expr->value.function.actual != NULL)
933
    {
931
    {
934
      if (expr->value.function.esym != NULL
932
      if (expr->value.function.esym != NULL
Lines 965-971 Link Here
965
		&& arg->expr->symtree->n.sym->attr.optional)
963
		&& arg->expr->symtree->n.sym->attr.optional)
966
	    set_by_optional = true;
964
	    set_by_optional = true;
967
965
968
	  /* Function specific; set the result rank and shape.  */
966
	  /* Function specific.  */
969
	  if (expr)
967
	  if (expr)
970
	    {
968
	    {
971
	      expr->rank = rank;
969
	      expr->rank = rank;
Lines 1007-1013 Link Here
1007
      else if (isym)
1005
      else if (isym)
1008
	formal_optional = true;
1006
	formal_optional = true;
1009
1007
1010
      if (arg->expr != NULL
1008
      if (arg->expr !=NULL
1011
	    && arg->expr->expr_type == EXPR_VARIABLE
1009
	    && arg->expr->expr_type == EXPR_VARIABLE
1012
	    && arg->expr->symtree->n.sym->attr.optional
1010
	    && arg->expr->symtree->n.sym->attr.optional
1013
	    && formal_optional
1011
	    && formal_optional
Lines 3299-3334 Link Here
3299
}
3297
}
3300
3298
3301
3299
3302
/* Given the expression node e for an allocatable/pointer of derived type to be
3303
   allocated, get the expression node to be initialized afterwards (needed for
3304
   derived types with default initializers).  */
3305
3306
static gfc_expr *
3307
expr_to_initialize (gfc_expr * e)
3308
{
3309
  gfc_expr *result;
3310
  gfc_ref *ref;
3311
  int i;
3312
3313
  result = gfc_copy_expr (e);
3314
3315
  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
3316
  for (ref = result->ref; ref; ref = ref->next)
3317
    if (ref->type == REF_ARRAY && ref->next == NULL)
3318
      {
3319
        ref->u.ar.type = AR_FULL;
3320
3321
        for (i = 0; i < ref->u.ar.dimen; i++)
3322
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3323
3324
        result->rank = ref->u.ar.dimen; 
3325
        break;
3326
      }
3327
3328
  return result;
3329
}
3330
3331
3332
/* Resolve the expression in an ALLOCATE statement, doing the additional
3300
/* Resolve the expression in an ALLOCATE statement, doing the additional
3333
   checks to see whether the expression is OK or not.  The expression must
3301
   checks to see whether the expression is OK or not.  The expression must
3334
   have a trailing array reference that gives the size of the array.  */
3302
   have a trailing array reference that gives the size of the array.  */
Lines 3409-3417 Link Here
3409
        init_st = gfc_get_code ();
3377
        init_st = gfc_get_code ();
3410
        init_st->loc = code->loc;
3378
        init_st->loc = code->loc;
3411
        init_st->op = EXEC_ASSIGN;
3379
        init_st->op = EXEC_ASSIGN;
3412
        init_st->expr = expr_to_initialize (e);
3380
        init_st->expr = gfc_expr_to_initialize (e);
3413
        init_st->expr2 = init_e;
3381
	init_st->expr2 = init_e;
3414
3415
        init_st->next = code->next;
3382
        init_st->next = code->next;
3416
        code->next = init_st;
3383
        code->next = init_st;
3417
    }
3384
    }
Lines 5390-5396 Link Here
5390
	  return FAILURE;
5357
	  return FAILURE;
5391
	}
5358
	}
5392
5359
5393
      if (c->pointer || c->as == NULL)
5360
      if (c->pointer || c->allocatable ||  c->as == NULL)
5394
	continue;
5361
	continue;
5395
5362
5396
      for (i = 0; i < c->as->rank; i++)
5363
      for (i = 0; i < c->as->rank; i++)
(-)gcc/fortran/trans-decl.c (-3 / +27 lines)
Lines 945-950 Link Here
945
	GFC_DECL_PACKED_ARRAY (decl) = 1;
945
	GFC_DECL_PACKED_ARRAY (decl) = 1;
946
    }
946
    }
947
947
948
  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
949
    gfc_defer_symbol_init (sym);
950
948
  gfc_finish_var_decl (decl, sym);
951
  gfc_finish_var_decl (decl, sym);
949
952
950
  if (sym->ts.type == BT_CHARACTER)
953
  if (sym->ts.type == BT_CHARACTER)
Lines 2587-2599 Link Here
2587
	      break;
2590
	      break;
2588
2591
2589
	    case AS_DEFERRED:
2592
	    case AS_DEFERRED:
2590
	      fnbody = gfc_trans_deferred_array (sym, fnbody);
2593
	      if (!(sym->ts.type == BT_DERIVED
2594
		      && sym->ts.derived->attr.alloc_comp))
2595
		fnbody = gfc_trans_deferred_array (sym, fnbody);
2591
	      break;
2596
	      break;
2592
2597
2593
	    default:
2598
	    default:
2594
	      gcc_unreachable ();
2599
	      gcc_unreachable ();
2595
	    }
2600
	    }
2601
	  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2602
	    fnbody = gfc_trans_deferred_array (sym, fnbody);
2596
	}
2603
	}
2604
      else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
2605
	fnbody = gfc_trans_deferred_array (sym, fnbody);
2597
      else if (sym->ts.type == BT_CHARACTER)
2606
      else if (sym->ts.type == BT_CHARACTER)
2598
	{
2607
	{
2599
	  gfc_get_backend_locus (&loc);
2608
	  gfc_get_backend_locus (&loc);
Lines 2829-2838 Link Here
2829
  tree old_context;
2838
  tree old_context;
2830
  tree decl;
2839
  tree decl;
2831
  tree tmp;
2840
  tree tmp;
2841
  tree tmp2;
2832
  stmtblock_t block;
2842
  stmtblock_t block;
2833
  stmtblock_t body;
2843
  stmtblock_t body;
2834
  tree result;
2844
  tree result;
2835
  gfc_symbol *sym;
2845
  gfc_symbol *sym;
2846
  int rank;
2836
2847
2837
  sym = ns->proc_name;
2848
  sym = ns->proc_name;
2838
2849
Lines 2992-2998 Link Here
2992
  tmp = gfc_finish_block (&body);
3003
  tmp = gfc_finish_block (&body);
2993
  /* Add code to create and cleanup arrays.  */
3004
  /* Add code to create and cleanup arrays.  */
2994
  tmp = gfc_trans_deferred_vars (sym, tmp);
3005
  tmp = gfc_trans_deferred_vars (sym, tmp);
2995
  gfc_add_expr_to_block (&block, tmp);
2996
3006
2997
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3007
  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2998
    {
3008
    {
Lines 3007-3013 Link Here
3007
      else
3017
      else
3008
	result = sym->result->backend_decl;
3018
	result = sym->result->backend_decl;
3009
3019
3010
      if (result == NULL_TREE)
3020
      if (result != NULL_TREE && sym->attr.function
3021
	    && sym->ts.type == BT_DERIVED
3022
	    && sym->ts.derived->attr.alloc_comp)
3023
	{
3024
	  rank = sym->as ? sym->as->rank : 0;
3025
	  tmp2 = nullify_alloc_comp (sym->ts.derived, result, rank);
3026
	  gfc_add_expr_to_block (&block, tmp2);
3027
	}
3028
3029
     gfc_add_expr_to_block (&block, tmp);
3030
3031
     if (result == NULL_TREE)
3011
	warning (0, "Function return value not set");
3032
	warning (0, "Function return value not set");
3012
      else
3033
      else
3013
	{
3034
	{
Lines 3018-3024 Link Here
3018
	  gfc_add_expr_to_block (&block, tmp);
3039
	  gfc_add_expr_to_block (&block, tmp);
3019
	}
3040
	}
3020
    }
3041
    }
3042
  else
3043
    gfc_add_expr_to_block (&block, tmp);
3021
3044
3045
3022
  /* Add all the decls we created during processing.  */
3046
  /* Add all the decls we created during processing.  */
3023
  decl = saved_function_decls;
3047
  decl = saved_function_decls;
3024
  while (decl)
3048
  while (decl)
(-)gcc/fortran/parse.c (+13 lines)
Lines 1500-1505 Link Here
1500
  gfc_statement st;
1500
  gfc_statement st;
1501
  gfc_component *c;
1501
  gfc_component *c;
1502
  gfc_state_data s;
1502
  gfc_state_data s;
1503
  gfc_symbol *sym;
1503
1504
1504
  error_flag = 0;
1505
  error_flag = 0;
1505
1506
Lines 1610-1615 Link Here
1610
	  }
1611
	  }
1611
      }
1612
      }
1612
1613
1614
  /* Look for allocatable components.  */
1615
  sym = gfc_current_block ();
1616
  for (c = sym->components; c; c = c->next)
1617
    {
1618
      if (c->allocatable || (c->ts.type == BT_DERIVED
1619
		    	     && c->ts.derived->attr.alloc_comp))
1620
	{
1621
	  sym->attr.alloc_comp = 1;
1622
	  break;
1623
	}
1624
     }
1625
1613
  pop_state ();
1626
  pop_state ();
1614
}
1627
}
1615
1628
(-)gcc/fortran/check.c (-1 / +62 lines)
Lines 461-473 Link Here
461
try
461
try
462
gfc_check_allocated (gfc_expr * array)
462
gfc_check_allocated (gfc_expr * array)
463
{
463
{
464
  symbol_attribute attr;
465
464
  if (variable_check (array, 0) == FAILURE)
466
  if (variable_check (array, 0) == FAILURE)
465
    return FAILURE;
467
    return FAILURE;
466
468
467
  if (array_check (array, 0) == FAILURE)
469
  if (array_check (array, 0) == FAILURE)
468
    return FAILURE;
470
    return FAILURE;
469
471
470
  if (!array->symtree->n.sym->attr.allocatable)
472
  attr = gfc_variable_attr (array, NULL);
473
  if (!attr.allocatable)
471
    {
474
    {
472
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
475
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
473
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
476
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
Lines 1753-1759 Link Here
1753
  return SUCCESS;
1756
  return SUCCESS;
1754
}
1757
}
1755
1758
1759
try
1760
gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
1761
{
1762
  symbol_attribute attr;
1756
1763
1764
  if (variable_check (from, 0) == FAILURE)
1765
    return FAILURE;
1766
1767
  if (array_check (from, 0) == FAILURE)
1768
    return FAILURE;
1769
1770
  attr = gfc_variable_attr (from, NULL);
1771
  if (!attr.allocatable)
1772
    {
1773
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1774
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1775
		 &from->where);
1776
      return FAILURE;
1777
    }
1778
1779
  if (variable_check (to, 0) == FAILURE)
1780
    return FAILURE;
1781
1782
  if (array_check (to, 0) == FAILURE)
1783
    return FAILURE;
1784
1785
  attr = gfc_variable_attr (to, NULL);
1786
  if (!attr.allocatable)
1787
    {
1788
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
1789
		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
1790
		 &to->where);
1791
      return FAILURE;
1792
    }
1793
1794
  if (same_type_check (from, 0, to, 1) == FAILURE)
1795
    return FAILURE;
1796
1797
  if (to->rank != from->rank)
1798
    {
1799
      gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1800
		 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
1801
		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1802
		 &to->where,  from->rank, to->rank);
1803
      return FAILURE;
1804
    }
1805
1806
  if (to->ts.kind != from->ts.kind)
1807
    {
1808
      gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
1809
		 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
1810
		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
1811
		 &to->where, from->ts.kind, to->ts.kind);
1812
      return FAILURE;
1813
    }
1814
1815
  return SUCCESS;
1816
}
1817
1757
try
1818
try
1758
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1819
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
1759
{
1820
{
(-)gcc/fortran/primary.c (-4 / +7 lines)
Lines 1711-1717 Link Here
1711
symbol_attribute
1711
symbol_attribute
1712
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1712
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1713
{
1713
{
1714
  int dimension, pointer, target;
1714
  int dimension, pointer, allocatable, target;
1715
  symbol_attribute attr;
1715
  symbol_attribute attr;
1716
  gfc_ref *ref;
1716
  gfc_ref *ref;
1717
1717
Lines 1723-1728 Link Here
1723
1723
1724
  dimension = attr.dimension;
1724
  dimension = attr.dimension;
1725
  pointer = attr.pointer;
1725
  pointer = attr.pointer;
1726
  allocatable = attr.allocatable;
1726
1727
1727
  target = attr.target;
1728
  target = attr.target;
1728
  if (pointer)
1729
  if (pointer)
Lines 1743-1754 Link Here
1743
	    break;
1744
	    break;
1744
1745
1745
	  case AR_SECTION:
1746
	  case AR_SECTION:
1746
	    pointer = 0;
1747
	    allocatable = pointer = 0;
1747
	    dimension = 1;
1748
	    dimension = 1;
1748
	    break;
1749
	    break;
1749
1750
1750
	  case AR_ELEMENT:
1751
	  case AR_ELEMENT:
1751
	    pointer = 0;
1752
	    allocatable = pointer = 0;
1752
	    break;
1753
	    break;
1753
1754
1754
	  case AR_UNKNOWN:
1755
	  case AR_UNKNOWN:
Lines 1763-1780 Link Here
1763
	  *ts = ref->u.c.component->ts;
1764
	  *ts = ref->u.c.component->ts;
1764
1765
1765
	pointer = ref->u.c.component->pointer;
1766
	pointer = ref->u.c.component->pointer;
1767
	allocatable = ref->u.c.component->allocatable;
1766
	if (pointer)
1768
	if (pointer)
1767
	  target = 1;
1769
	  target = 1;
1768
1770
1769
	break;
1771
	break;
1770
1772
1771
      case REF_SUBSTRING:
1773
      case REF_SUBSTRING:
1772
	pointer = 0;
1774
	allocatable = pointer = 0;
1773
	break;
1775
	break;
1774
      }
1776
      }
1775
1777
1776
  attr.dimension = dimension;
1778
  attr.dimension = dimension;
1777
  attr.pointer = pointer;
1779
  attr.pointer = pointer;
1780
  attr.allocatable = allocatable;
1778
  attr.target = target;
1781
  attr.target = target;
1779
1782
1780
  return attr;
1783
  return attr;
(-)libgfortran/intrinsics/pack_generic.c (+38 lines)
Lines 469-471 Link Here
469
{
469
{
470
  pack_s_internal (ret, array, mask, vector, array_length);
470
  pack_s_internal (ret, array, mask, vector, array_length);
471
}
471
}
472
473
extern void move_alloc (gfc_array_char *, gfc_array_char *);
474
export_proto(move_alloc);
475
476
void
477
move_alloc (gfc_array_char * from, gfc_array_char * to)
478
{
479
  int i;
480
481
  internal_free (to->data);
482
483
  for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
484
    {
485
      to->dim[i].lbound = from->dim[i].lbound;
486
      to->dim[i].ubound = from->dim[i].ubound;
487
      to->dim[i].stride = from->dim[i].stride;
488
      from->dim[i].stride = 0;
489
      from->dim[i].ubound = from->dim[i].lbound;
490
    }
491
492
  to->offset = from->offset;
493
  to->dtype = from->dtype;
494
  to->data = from->data;
495
  from->data = NULL;
496
}
497
498
extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
499
			  gfc_array_char *, GFC_INTEGER_4);
500
export_proto(move_alloc_c);
501
502
void
503
move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
504
	      gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
505
{
506
  move_alloc (from, to);
507
}
508
509

Return to bug 20541