View | Details | Return to bug 26787
Collapse All | Expand All

(-)gcc/fortran/expr.c (-5 / +35 lines)
Lines 1863-1876 Link Here
1863
      return FAILURE;
1863
      return FAILURE;
1864
    }
1864
    }
1865
1865
1866
  if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
1866
  /* A procedure symbol cannot be an lvalue if it is:  */
1867
  if (sym->attr.flavor == FL_PROCEDURE
1868
	&& sym->attr.proc != PROC_ST_FUNCTION
1869
	&& !sym->attr.external)
1867
    {
1870
    {
1868
      gfc_error ("'%s' in the assignment at %L cannot be an l-value "
1871
      bool bad_proc;
1869
		 "since it is a procedure", sym->name, &lvalue->where);
1872
      bad_proc = false;
1870
      return FAILURE;
1873
1874
      /* (i) Use associated; */
1875
      if (sym->attr.use_assoc)
1876
	bad_proc = true;
1877
1878
      /* (ii) The assignement is in the main program; or  */
1879
      if (gfc_current_ns->proc_name->attr.is_main_program)
1880
	bad_proc = true;
1881
1882
      /* (iii) A module or internal procedure....  */
1883
      if (gfc_current_ns->parent
1884
	  && gfc_current_ns->parent->parent == NULL
1885
	  && gfc_current_ns->parent->proc_name->attr.flavor != FL_PROCEDURE)
1886
	{
1887
	  /* .... that is not a function.... */ 
1888
	  if (!gfc_current_ns->proc_name->attr.function)
1889
	    bad_proc = true;
1890
1891
	  /* .... or is not an entry and has a different name.  */
1892
	  if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
1893
	    bad_proc = true;
1894
	}
1895
1896
      if (bad_proc)
1897
	{
1898
	  gfc_error ("'%s' in the assignment at %L cannot be an l-value "
1899
		     "since it is a procedure", sym->name, &lvalue->where);
1900
	  return FAILURE;
1901
	}
1871
    }
1902
    }
1872
1903
1873
1874
  if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1904
  if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1875
    {
1905
    {
1876
      gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1906
      gfc_error ("Incompatible ranks %d and %d in assignment at %L",

Return to bug 26787