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

Collapse All | Expand All | Context: (Patch / File /
)

(-)gcc/testsuite/gfortran.dg/entry_7.f90 (-1 / +1 lines)
 Lines 9-15    Link Here 
9
MODULE TT
9
MODULE TT
10
CONTAINS
10
CONTAINS
11
  FUNCTION K(I) RESULT(J)
11
  FUNCTION K(I) RESULT(J)
12
    ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" }
12
    ENTRY J() ! { dg-error "conflicts with RESULT attribute" }
13
  END FUNCTION K
13
  END FUNCTION K
14
14
15
  integer function foo ()
15
  integer function foo ()
(-)gcc/testsuite/gfortran.dg/proc_ptr_2.f90 (-1 / +4 lines)
 Lines 6-13    Link Here 
6
6
7
PROCEDURE(REAL), POINTER :: ptr
7
PROCEDURE(REAL), POINTER :: ptr
8
PROCEDURE(REAL), SAVE    :: noptr    ! { dg-error "attribute conflicts with" }
8
PROCEDURE(REAL), SAVE    :: noptr    ! { dg-error "attribute conflicts with" }
9
REAL :: x
9
10
10
ptr => cos(4.0)        ! { dg-error "Invalid character" }
11
ptr => cos(4.0)        ! { dg-error "Invalid procedure pointer assignment" }
12
ptr => x               ! { dg-error "Invalid procedure pointer assignment" }
13
ptr => sin(x)          ! { dg-error "Invalid procedure pointer assignment" }
11
14
12
ALLOCATE(ptr)          ! { dg-error "must be ALLOCATABLE" }
15
ALLOCATE(ptr)          ! { dg-error "must be ALLOCATABLE" }
13
16
(-)gcc/fortran/decl.c (-2 / +1 lines)
 Lines 3974-3981   match_result (gfc_symbol *function, gfc_ Link Here 
3974
  if (gfc_get_symbol (name, NULL, &r))
3974
  if (gfc_get_symbol (name, NULL, &r))
3975
    return MATCH_ERROR;
3975
    return MATCH_ERROR;
3976
3976
3977
  if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3977
  if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3978
      || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3979
    return MATCH_ERROR;
3978
    return MATCH_ERROR;
3980
3979
3981
  *result = r;
3980
  *result = r;
(-)gcc/fortran/expr.c (-2 / +14 lines)
 Lines 3112-3120   gfc_check_pointer_assign (gfc_expr *lval Link Here 
3112
  if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3112
  if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3113
    return SUCCESS;
3113
    return SUCCESS;
3114
3114
3115
  /* TODO checks on rvalue for a procedure pointer assignment.  */
3115
  /* Checks on rvalue for procedure pointer assignments.  */
3116
  if (lvalue->symtree->n.sym->attr.proc_pointer)
3116
  if (lvalue->symtree->n.sym->attr.proc_pointer)
3117
    return SUCCESS;
3117
    {
3118
      attr = gfc_expr_attr (rvalue);
3119
      if (!((rvalue->expr_type == EXPR_NULL)
3120
	    || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3121
	    || (rvalue->expr_type == EXPR_VARIABLE
3122
		&& attr.flavor == FL_PROCEDURE)))
3123
	{
3124
	  gfc_error ("Invalid procedure pointer assignment at %L",
3125
		     &rvalue->where);
3126
	  return FAILURE;
3127
	}
3128
      return SUCCESS;
3129
    }
3118
3130
3119
  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3131
  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3120
    {
3132
    {
(-)gcc/fortran/trans-types.c (-2 / +5 lines)
 Lines 1613-1620   gfc_sym_type (gfc_symbol * sym) Link Here 
1613
  tree type;
1613
  tree type;
1614
  int byref;
1614
  int byref;
1615
1615
1616
  /* Procedure Pointers inside COMMON blocks.  */
1616
  /* Procedure Pointers inside COMMON blocks or as function result.  */
1617
  if (sym->attr.proc_pointer && sym->attr.in_common)
1617
  if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result))
1618
    {
1618
    {
1619
      /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
1619
      /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
1620
      sym->attr.proc_pointer = 0;
1620
      sym->attr.proc_pointer = 0;
 Lines 2143-2148   gfc_get_function_type (gfc_symbol * sym) Link Here 
2143
      type = gfc_typenode_for_spec (&sym->ts);
2143
      type = gfc_typenode_for_spec (&sym->ts);
2144
      sym->ts.kind = gfc_default_real_kind;
2144
      sym->ts.kind = gfc_default_real_kind;
2145
    }
2145
    }
2146
  else if (sym->result && sym->result->attr.proc_pointer)
2147
    /* Procedure pointer return values.  */
2148
    type = gfc_sym_type (sym->result);
2146
  else
2149
  else
2147
    type = gfc_sym_type (sym);
2150
    type = gfc_sym_type (sym);
2148
2151
(-)gcc/fortran/primary.c (-2 / +1 lines)
 Lines 2509-2519   gfc_match_rvalue (gfc_expr **result) Link Here 
2509
      if (gfc_matching_procptr_assignment)
2509
      if (gfc_matching_procptr_assignment)
2510
	{
2510
	{
2511
	  gfc_gobble_whitespace ();
2511
	  gfc_gobble_whitespace ();
2512
	  if (sym->attr.function && gfc_peek_ascii_char () == '(')
2512
	  if (gfc_peek_ascii_char () == '(')
2513
	    /* Parse functions returning a procptr.  */
2513
	    /* Parse functions returning a procptr.  */
2514
	    goto function0;
2514
	    goto function0;
2515
2515
2516
	  if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
2517
	  if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2516
	  if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2518
	      || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2517
	      || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2519
	    sym->attr.intrinsic = 1;
2518
	    sym->attr.intrinsic = 1;

Return to bug 36704