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

Collapse All | Expand All

(-)a/gcc/fortran/decl.c (+47 lines)
Lines 7006-7011 gfc_match_derived_decl (void) Link Here
7006
  if (gfc_get_symbol (name, NULL, &sym))
7006
  if (gfc_get_symbol (name, NULL, &sym))
7007
    return MATCH_ERROR;
7007
    return MATCH_ERROR;
7008
7008
7009
  /* If there is already a generic interface with the same name as the derived
7010
     type, rename the interface have the suffix "@". We cannot do a simple
7011
     rename of sym->name and sym->ns->sym_root->name as one needs then to
7012
     properly rebalence the symtree tree.  */
7013
  if (sym->attr.generic)
7014
    {
7015
      gfc_symbol *sym_func;
7016
      gfc_namespace *ns;
7017
      const char *str;
7018
      gfc_symbol *old_symbol, *tlink;
7019
      int refs;
7020
7021
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC name is the "
7022
			  "same as a derived-type name at %C") == FAILURE)
7023
	return MATCH_ERROR;
7024
7025
      if (gfc_get_symbol (gfc_get_string ("%s@", name), NULL, &sym_func))
7026
	return MATCH_ERROR;
7027
      str = sym_func->name;
7028
      ns = sym_func->ns;
7029
      old_symbol = sym_func->old_symbol;
7030
      tlink = sym_func->tlink;
7031
      refs = sym_func->refs;
7032
      *sym_func = *sym;
7033
      sym_func->name = str;
7034
      sym_func->ns = ns;
7035
      sym_func->declared_at = sym->declared_at;
7036
      sym_func->attr.dt_generic = 1;
7037
7038
      str = sym->name;
7039
      ns = sym->ns;
7040
      memset (sym, 0, sizeof (gfc_symbol));
7041
      gfc_clear_ts (&sym->ts);
7042
      gfc_clear_attr (&sym->attr);
7043
      sym->ns = ns;
7044
      sym->name = str;
7045
      sym->declared_at = gfc_current_locus;
7046
      sym->attr.dt_generic = 1;
7047
7048
      sym->old_symbol = sym_func->old_symbol;
7049
      sym->tlink = sym_func->tlink;
7050
      sym->refs = sym_func->refs;
7051
      sym_func->old_symbol = old_symbol;
7052
      sym_func->tlink = tlink;
7053
      sym_func->refs = refs;
7054
    }
7055
7009
  if (sym->ts.type != BT_UNKNOWN)
7056
  if (sym->ts.type != BT_UNKNOWN)
7010
    {
7057
    {
7011
      gfc_error ("Derived type name '%s' at %C already has a basic type "
7058
      gfc_error ("Derived type name '%s' at %C already has a basic type "
(-)a/gcc/fortran/gfortran.h (-1 / +2 lines)
Lines 683-689 typedef struct Link Here
683
683
684
  unsigned in_namelist:1, in_common:1, in_equivalence:1;
684
  unsigned in_namelist:1, in_common:1, in_equivalence:1;
685
  unsigned function:1, subroutine:1, procedure:1;
685
  unsigned function:1, subroutine:1, procedure:1;
686
  unsigned generic:1, generic_copy:1;
686
  unsigned generic:1, generic_copy:1, dt_generic:1;
687
  unsigned implicit_type:1;	/* Type defined via implicit rules.  */
687
  unsigned implicit_type:1;	/* Type defined via implicit rules.  */
688
  unsigned untyped:1;		/* No implicit type could be found.  */
688
  unsigned untyped:1;		/* No implicit type could be found.  */
689
689
Lines 2760-2765 match gfc_match_rvalue (gfc_expr **); Link Here
2760
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2760
match gfc_match_varspec (gfc_expr*, int, bool, bool);
2761
int gfc_check_digit (char, int);
2761
int gfc_check_digit (char, int);
2762
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2762
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
2763
gfc_try gfc_convert_to_structure_constructor (gfc_expr *expr);
2763
2764
2764
/* trans.c */
2765
/* trans.c */
2765
void gfc_generate_code (gfc_namespace *);
2766
void gfc_generate_code (gfc_namespace *);
(-)a/gcc/fortran/interface.c (-2 / +30 lines)
Lines 183-189 syntax: Link Here
183
match
183
match
184
gfc_match_interface (void)
184
gfc_match_interface (void)
185
{
185
{
186
  char name[GFC_MAX_SYMBOL_LEN + 1];
186
  char name[GFC_MAX_SYMBOL_LEN + 2];
187
  interface_type type;
187
  interface_type type;
188
  gfc_symbol *sym;
188
  gfc_symbol *sym;
189
  gfc_intrinsic_op op;
189
  gfc_intrinsic_op op;
Lines 212-217 gfc_match_interface (void) Link Here
212
      if (gfc_get_symbol (name, NULL, &sym))
212
      if (gfc_get_symbol (name, NULL, &sym))
213
	return MATCH_ERROR;
213
	return MATCH_ERROR;
214
214
215
      /* Special case: Generic procedure with same name as a derived type.  */
216
      if (sym->attr.flavor == FL_DERIVED)
217
	{
218
	  size_t len;
219
	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC name is "
220
			      "the same as a derived-type name at %C")
221
	      == FAILURE)
222
	    return MATCH_ERROR;
223
224
	  sym->attr.dt_generic = 1;
225
226
	  len = strlen (name);
227
	  name[len] = '@';
228
	  name[len+1] = '\0';
229
230
	  if (gfc_get_symbol (name, NULL, &sym))
231
	    return MATCH_ERROR;
232
233
	  sym->attr.dt_generic = 1;
234
	}
235
215
      if (!sym->attr.generic 
236
      if (!sym->attr.generic 
216
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
237
	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
217
	return MATCH_ERROR;
238
	return MATCH_ERROR;
Lines 275-281 gfc_match_abstract_interface (void) Link Here
275
match
296
match
276
gfc_match_end_interface (void)
297
gfc_match_end_interface (void)
277
{
298
{
278
  char name[GFC_MAX_SYMBOL_LEN + 1];
299
  char name[GFC_MAX_SYMBOL_LEN + 2];
279
  interface_type type;
300
  interface_type type;
280
  gfc_intrinsic_op op;
301
  gfc_intrinsic_op op;
281
  match m;
302
  match m;
Lines 338-343 gfc_match_end_interface (void) Link Here
338
      break;
359
      break;
339
360
340
    case INTERFACE_GENERIC:
361
    case INTERFACE_GENERIC:
362
      if (current_interface.sym->attr.dt_generic)
363
	{
364
	  size_t len = strlen (name);
365
	  name[len] = '@';
366
	  name[len+1] = '\0';
367
	}
368
341
      if (type != current_interface.type
369
      if (type != current_interface.type
342
	  || strcmp (current_interface.sym->name, name) != 0)
370
	  || strcmp (current_interface.sym->name, name) != 0)
343
	{
371
	{
(-)a/gcc/fortran/module.c (-2 / +12 lines)
Lines 1674-1680 typedef enum Link Here
1674
  AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1674
  AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1675
  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1675
  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1676
  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1676
  AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1677
  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
1677
  AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_DT_GENERIC
1678
}
1678
}
1679
ab_attribute;
1679
ab_attribute;
1680
1680
Lines 1722-1727 static const mstring attr_bits[] = Link Here
1722
    minit ("PROC_POINTER", AB_PROC_POINTER),
1722
    minit ("PROC_POINTER", AB_PROC_POINTER),
1723
    minit ("VTYPE", AB_VTYPE),
1723
    minit ("VTYPE", AB_VTYPE),
1724
    minit ("VTAB", AB_VTAB),
1724
    minit ("VTAB", AB_VTAB),
1725
    minit ("DT_GENERIC", AB_DT_GENERIC),
1725
    minit (NULL, -1)
1726
    minit (NULL, -1)
1726
};
1727
};
1727
1728
Lines 1886-1891 mio_symbol_attribute (symbol_attribute *attr) Link Here
1886
	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
1887
	MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
1887
      if (attr->vtab)
1888
      if (attr->vtab)
1888
	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
1889
	MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
1890
      if (attr->dt_generic)
1891
	MIO_NAME (ab_attribute) (AB_DT_GENERIC, attr_bits);
1889
1892
1890
      mio_rparen ();
1893
      mio_rparen ();
1891
1894
Lines 2028-2033 mio_symbol_attribute (symbol_attribute *attr) Link Here
2028
	    case AB_VTAB:
2031
	    case AB_VTAB:
2029
	      attr->vtab = 1;
2032
	      attr->vtab = 1;
2030
	      break;
2033
	      break;
2034
	    case AB_DT_GENERIC:
2035
	      attr->dt_generic = 1;
2036
	      break;
2031
	    }
2037
	    }
2032
	}
2038
	}
2033
    }
2039
    }
Lines 3781-3787 static void Link Here
3781
load_generic_interfaces (void)
3787
load_generic_interfaces (void)
3782
{
3788
{
3783
  const char *p;
3789
  const char *p;
3784
  char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3790
  char name[GFC_MAX_SYMBOL_LEN + 2], module[GFC_MAX_SYMBOL_LEN + 1];
3785
  gfc_symbol *sym;
3791
  gfc_symbol *sym;
3786
  gfc_interface *generic = NULL, *gen = NULL;
3792
  gfc_interface *generic = NULL, *gen = NULL;
3787
  int n, i, renamed;
3793
  int n, i, renamed;
Lines 3852-3863 load_generic_interfaces (void) Link Here
3852
		 better make one.  */
3858
		 better make one.  */
3853
	      if (!sym)
3859
	      if (!sym)
3854
		{
3860
		{
3861
		  size_t len;
3855
		  gfc_get_symbol (p, NULL, &sym);
3862
		  gfc_get_symbol (p, NULL, &sym);
3856
		  sym->name = gfc_get_string (name);
3863
		  sym->name = gfc_get_string (name);
3857
		  sym->module = gfc_get_string (module_name);
3864
		  sym->module = gfc_get_string (module_name);
3858
		  sym->attr.flavor = FL_PROCEDURE;
3865
		  sym->attr.flavor = FL_PROCEDURE;
3859
		  sym->attr.generic = 1;
3866
		  sym->attr.generic = 1;
3860
		  sym->attr.use_assoc = 1;
3867
		  sym->attr.use_assoc = 1;
3868
                  len = strlen (name);
3869
		  if (name[len-1] == '@')
3870
		    sym->attr.dt_generic = 1;
3861
		}
3871
		}
3862
	    }
3872
	    }
3863
	  else
3873
	  else
(-)a/gcc/fortran/primary.c (-1 / +172 lines)
Lines 2238-2243 build_actual_constructor (gfc_structure_ctor_component **comp_head, Link Here
2238
  return SUCCESS;
2238
  return SUCCESS;
2239
}
2239
}
2240
2240
2241
2242
gfc_try
2243
gfc_convert_to_structure_constructor (gfc_expr *expr)
2244
{
2245
  gfc_actual_arglist *actual;
2246
  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2247
  gfc_constructor_base ctor_head = NULL;
2248
  gfc_component *comp; /* Is set NULL when named component is first seen */
2249
  const char* last_name = NULL;
2250
  gfc_symbol *sym;
2251
  locus old_locus;
2252
2253
  old_locus = gfc_current_locus;
2254
  gfc_current_locus = expr->where;
2255
2256
  comp_tail = comp_head = NULL;
2257
  sym = expr->value.function.esym;
2258
2259
  if (sym->attr.abstract)
2260
    {
2261
      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2262
		 sym->name, &expr->where);
2263
      goto cleanup;
2264
    }
2265
2266
  comp = sym->components;
2267
  for (actual = expr->value.function.actual; actual; actual = actual->next)
2268
    {
2269
      gfc_component *this_comp = NULL;
2270
2271
      if (!comp_head)
2272
	comp_tail = comp_head = gfc_get_structure_ctor_component ();
2273
      else
2274
	{
2275
	  comp_tail->next = gfc_get_structure_ctor_component ();
2276
	  comp_tail = comp_tail->next;
2277
       	}
2278
      if (actual->name)
2279
	{
2280
	  comp_tail->name = actual->name; /*xstrdup (actual->name);*/
2281
	  last_name = comp_tail->name;
2282
	  comp = NULL;
2283
	}
2284
      else
2285
	{
2286
	  /* Components without name are not allowed after the first named
2287
	     component initializer!  */
2288
	  if (!comp)
2289
	    {
2290
	      if (last_name)
2291
		gfc_error ("Component initializer without name after component"
2292
			   " named %s at %L!", last_name,
2293
			   actual->expr ? &actual->expr->where
2294
					: &gfc_current_locus);
2295
	      else
2296
		gfc_error ("Too many components in structure constructor at "
2297
			   "%L!", actual->expr ? &actual->expr->where
2298
					       : &gfc_current_locus);
2299
	      goto cleanup;
2300
	    }
2301
2302
	  comp_tail->name = CONST_CAST (comp->name);
2303
	}
2304
2305
      /* Find the current component in the structure definition and check
2306
	     its access is not private.  */
2307
      if (comp)
2308
	this_comp = gfc_find_component (sym, comp->name, false, false);
2309
      else
2310
	{
2311
	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2312
					  false, false);
2313
	  comp = NULL; /* Reset needed!  */
2314
	}
2315
2316
      /* Here we can check if a component name is given which does not
2317
	 correspond to any component of the defined structure.  */
2318
      if (!this_comp)
2319
	goto cleanup;
2320
2321
      comp_tail->val = actual->expr;
2322
      if (actual->expr != NULL)
2323
	comp_tail->where = actual->expr->where;
2324
2325
2326
      /* Check if this component is already given a value.  */
2327
      for (comp_iter = comp_head; comp_iter != comp_tail; 
2328
	   comp_iter = comp_iter->next)
2329
	{
2330
	  gcc_assert (comp_iter);
2331
	  if (!strcmp (comp_iter->name, comp_tail->name))
2332
	    {
2333
	      gfc_error ("Component '%s' is initialized twice in the structure"
2334
			 " constructor at %L!", comp_tail->name,
2335
			 actual->expr ? &actual->expr->where
2336
				      : &gfc_current_locus);
2337
	      goto cleanup;
2338
	    }
2339
	}
2340
2341
      /* F2008, R457/C725, for PURE C1283.  */
2342
      if (this_comp->attr.pointer && comp_tail->val
2343
	  && gfc_is_coindexed (comp_tail->val))
2344
     	{
2345
       	  gfc_error ("Coindexed expression to pointer component '%s' in "
2346
		     "structure constructor at %L!", comp_tail->name,
2347
		     &comp_tail->where);
2348
	  goto cleanup;
2349
	}
2350
2351
      if (comp)
2352
	comp = comp->next;
2353
    }
2354
2355
  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2356
    goto cleanup;
2357
2358
  /* No component should be left, as this should have caused an error in the
2359
     loop constructing the component-list (name that does not correspond to any
2360
     component in the structure definition).  */
2361
  if (comp_head && sym->attr.extension)
2362
    {
2363
      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2364
	{
2365
	  gfc_error ("component '%s' at %L has already been set by a "
2366
		     "parent derived type constructor", comp_iter->name,
2367
		     &comp_iter->where);
2368
	}
2369
      goto cleanup;
2370
    }
2371
  else
2372
    gcc_assert (!comp_head);
2373
2374
  expr->ts.u.derived = sym;
2375
  expr->ts.kind = 0;
2376
  expr->ts.type = BT_DERIVED;
2377
  expr->value.constructor = ctor_head;
2378
  expr->expr_type = EXPR_STRUCTURE;
2379
2380
  gfc_current_locus = old_locus; 
2381
  return SUCCESS;
2382
2383
  cleanup:
2384
  gfc_current_locus = old_locus; 
2385
2386
  for (comp_iter = comp_head; comp_iter; )
2387
    {
2388
      gfc_structure_ctor_component *next = comp_iter->next;
2389
      gfc_free_structure_ctor_component (comp_iter);
2390
      comp_iter = next;
2391
    }
2392
  gfc_constructor_free (ctor_head);
2393
2394
  return FAILURE;
2395
}
2396
2397
2241
match
2398
match
2242
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2399
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2243
				 bool parent)
2400
				 bool parent)
Lines 2490-2496 match Link Here
2490
gfc_match_rvalue (gfc_expr **result)
2647
gfc_match_rvalue (gfc_expr **result)
2491
{
2648
{
2492
  gfc_actual_arglist *actual_arglist;
2649
  gfc_actual_arglist *actual_arglist;
2493
  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2650
  char name[GFC_MAX_SYMBOL_LEN + 2], argname[GFC_MAX_SYMBOL_LEN + 1];
2494
  gfc_state_data *st;
2651
  gfc_state_data *st;
2495
  gfc_symbol *sym;
2652
  gfc_symbol *sym;
2496
  gfc_symtree *symtree;
2653
  gfc_symtree *symtree;
Lines 2629-2634 gfc_match_rvalue (gfc_expr **result) Link Here
2629
      sym = gfc_use_derived (sym);
2786
      sym = gfc_use_derived (sym);
2630
      if (sym == NULL)
2787
      if (sym == NULL)
2631
	m = MATCH_ERROR;
2788
	m = MATCH_ERROR;
2789
      else if (sym->attr.dt_generic)
2790
	{
2791
	  size_t len = strlen (name);
2792
	  name[len] = '@';
2793
	  name[len+1] = '\0';
2794
	  gfc_find_component (sym, NULL, false, true);
2795
	  goto generic_function;
2796
	}
2632
      else
2797
      else
2633
	m = gfc_match_structure_constructor (sym, &e, false);
2798
	m = gfc_match_structure_constructor (sym, &e, false);
2634
      break;
2799
      break;
Lines 2904-2909 gfc_match_rvalue (gfc_expr **result) Link Here
2904
      e->symtree = symtree;
3069
      e->symtree = symtree;
2905
      e->expr_type = EXPR_FUNCTION;
3070
      e->expr_type = EXPR_FUNCTION;
2906
3071
3072
      /* Save derived type in case one needs it later. */
3073
      if (sym->attr.dt_generic)
3074
	{
3075
	  e->value.function.esym = sym;
3076
	}
3077
2907
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
3078
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2908
      break;
3079
      break;
2909
3080
(-)a/gcc/fortran/resolve.c (-3 / +19 lines)
Lines 1991-1999 generic: Link Here
1991
     that possesses a matching interface.  14.1.2.4  */
1991
     that possesses a matching interface.  14.1.2.4  */
1992
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1992
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
1993
    {
1993
    {
1994
      gfc_error ("There is no specific function for the generic '%s' at %L",
1994
      if (!sym->attr.dt_generic)
1995
		 expr->symtree->n.sym->name, &expr->where);
1995
	{
1996
      return FAILURE;
1996
	  gfc_error ("There is no specific function for the generic '%s' "
1997
		     "at %L", expr->symtree->n.sym->name, &expr->where);
1998
	  return FAILURE;
1999
	}
2000
2001
      if (gfc_convert_to_structure_constructor (expr) != SUCCESS)
2002
	return FAILURE;
2003
2004
      return resolve_structure_cons (expr);
1997
    }
2005
    }
1998
2006
1999
  m = gfc_intrinsic_func_interface (expr, 0);
2007
  m = gfc_intrinsic_func_interface (expr, 0);
Lines 9537-9542 resolve_fl_procedure (gfc_symbol *sym, int mp_flag) Link Here
9537
	  sym->attr.is_bind_c = 0;
9545
	  sym->attr.is_bind_c = 0;
9538
	}
9546
	}
9539
    }
9547
    }
9548
9549
  if (sym->attr.dt_generic && !sym->generic->sym->attr.function)
9550
    {
9551
      gfc_error ("GENERIC interface '%s' must contain functions as the name "
9552
		 "is the same as a derived-type name at %L", sym->name,
9553
		 &sym->declared_at);
9554
	  return FAILURE;
9555
    }
9540
  
9556
  
9541
  if (!sym->attr.proc_pointer)
9557
  if (!sym->attr.proc_pointer)
9542
    {
9558
    {
(-)a/gcc/fortran/symbol.c (-1 / +3 lines)
Lines 1756-1761 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) Link Here
1756
    goto fail;
1756
    goto fail;
1757
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1757
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1758
    goto fail;
1758
    goto fail;
1759
  if (src->dt_generic)
1760
    dest->dt_generic = 1;
1759
1761
1760
  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1762
  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1761
    goto fail;
1763
    goto fail;
Lines 1914-1920 gfc_use_derived (gfc_symbol *sym) Link Here
1914
  gfc_symtree *st;
1916
  gfc_symtree *st;
1915
  int i;
1917
  int i;
1916
1918
1917
  if (sym->components != NULL || sym->attr.zero_comp)
1919
  if (!sym || sym->components != NULL || sym->attr.zero_comp)
1918
    return sym;               /* Already defined.  */
1920
    return sym;               /* Already defined.  */
1919
1921
1920
  if (sym->ns->parent == NULL)
1922
  if (sym->ns->parent == NULL)
1921
 interface foo
1923
 interface foo
1922
   procedure constructor
1924
   procedure constructor
1923
 end interface
1925
 end interface
1924
 type foo
1926
 type foo
1925
   integer :: bar = -42
1927
   integer :: bar = -42
1926
 end type
1928
 end type
1927
 type(foo) function constructor()
1929
 type(foo) function constructor()
1928
   constructor%bar = 1
1930
   constructor%bar = 1
1929
 end function
1931
 end function
1930
 subroutine test_foo()
1932
 subroutine test_foo()
1931
   type(foo) :: f
1933
   type(foo) :: f
1932
   f = foo()
1934
   f = foo()
1933
   if (f%bar /= 1) call abort ()
1935
   if (f%bar /= 1) call abort ()
1934
   f = foo(2)
1936
   f = foo(2)
1935
   if (f%bar /= 2) call abort ()
1937
   if (f%bar /= 2) call abort ()
1936
   f = foo(bar=22)
1938
   f = foo(bar=22)
1937
   if (f%bar /= 22) call abort ()
1939
   if (f%bar /= 22) call abort ()
1938
 end subroutine test_foo
1940
 end subroutine test_foo
1939
 type bar
1941
 type bar
1940
   integer :: bar = -43
1942
   integer :: bar = -43
1941
 end type
1943
 end type
1942
 interface bar
1944
 interface bar
1943
   procedure constructor
1945
   procedure constructor
1944
 end interface
1946
 end interface
1945
 type(bar) function constructor()
1947
 type(bar) function constructor()
1946
   constructor%bar = 3
1948
   constructor%bar = 3
1947
 end function
1949
 end function
1948
 subroutine test_bar()
1950
 subroutine test_bar()
1949
   type(bar) :: f
1951
   type(bar) :: f
1950
   f = bar()
1952
   f = bar()
1951
   if (f%bar /= 3) call abort ()
1953
   if (f%bar /= 3) call abort ()
1952
   f = bar(4)
1954
   f = bar(4)
1953
   if (f%bar /= 4) call abort ()
1955
   if (f%bar /= 4) call abort ()
1954
   f = bar(bar=44)
1956
   f = bar(bar=44)
1955
   if (f%bar /= 44) call abort ()
1957
   if (f%bar /= 44) call abort ()
1956
 end subroutine test_bar
1958
 end subroutine test_bar
1957
 use foo_module
1959
 use foo_module
1958
 use bar_module
1960
 use bar_module
1959
 implicit none
1961
 implicit none
1960
 type(foo) :: f
1962
 type(foo) :: f
1961
 type(bar) :: b
1963
 type(bar) :: b
1962
 call test_foo()
1964
 call test_foo()
1963
 f = foo()
1965
 f = foo()
1964
 if (f%bar /= 1) call abort ()
1966
 if (f%bar /= 1) call abort ()
1965
 f = foo(2)
1967
 f = foo(2)
1966
 if (f%bar /= 2) call abort ()
1968
 if (f%bar /= 2) call abort ()
1967
 f = foo(bar=22)
1969
 f = foo(bar=22)
1968
 if (f%bar /= 22) call abort ()
1970
 if (f%bar /= 22) call abort ()
1969
 call test_bar()
1971
 call test_bar()
1970
 b = bar()
1972
 b = bar()
1971
 if (b%bar /= 3) call abort ()
1973
 if (b%bar /= 3) call abort ()
1972
 b = bar(4)
1974
 b = bar(4)
1973
 if (b%bar /= 4) call abort ()
1975
 if (b%bar /= 4) call abort ()
1974
 b = bar(bar=44)
1976
 b = bar(bar=44)
1975
 if (b%bar /= 44) call abort ()
1977
 if (b%bar /= 44) call abort ()

Return to bug 39427