aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/decl.c3
-rw-r--r--gcc/fortran/expr.c25
-rw-r--r--gcc/fortran/primary.c3
-rw-r--r--gcc/fortran/resolve.c2
-rw-r--r--gcc/fortran/symbol.c5
-rw-r--r--gcc/fortran/trans-types.c7
-rw-r--r--gcc/testsuite/ChangeLog11
-rw-r--r--gcc/testsuite/gfortran.dg/entry_7.f902
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_11.f9030
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_12.f9015
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_2.f905
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_3.f9012
-rw-r--r--gcc/testsuite/gfortran.dg/result_1.f9018
14 files changed, 139 insertions, 14 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 732b0f7..d3ae07f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2008-12-02 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/36704
+ PR fortran/38290
+ * decl.c (match_result): Result may be a standard variable or a
+ procedure pointer.
+ * expr.c (gfc_check_pointer_assign): Additional checks for procedure
+ pointer assignments.
+ * primary.c (gfc_match_rvalue): Bugfix for procedure pointer
+ assignments.
+ * resolve.c (resolve_function): Check for attr.subroutine.
+ * symbol.c (check_conflict): Addtional checks for RESULT statements.
+ * trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure
+ pointers as function result.
+
2008-12-01 Mikael Morin <mikael.morin@tele2.fr>
PR fortran/38252
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 14ccb60..f6677fe 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3974,8 +3974,7 @@ match_result (gfc_symbol *function, gfc_symbol **result)
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
- if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
- || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
+ if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
return MATCH_ERROR;
*result = r;
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 4017cf9..b94e5ac 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3112,9 +3112,30 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
- /* TODO checks on rvalue for a procedure pointer assignment. */
+ /* Checks on rvalue for procedure pointer assignments. */
if (lvalue->symtree->n.sym->attr.proc_pointer)
- return SUCCESS;
+ {
+ attr = gfc_expr_attr (rvalue);
+ if (!((rvalue->expr_type == EXPR_NULL)
+ || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE
+ && attr.flavor == FL_PROCEDURE)))
+ {
+ gfc_error ("Invalid procedure pointer assignment at %L",
+ &rvalue->where);
+ return FAILURE;
+ }
+ if (rvalue->expr_type == EXPR_VARIABLE
+ && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
+ && !gfc_compare_interfaces (lvalue->symtree->n.sym,
+ rvalue->symtree->n.sym, 0))
+ {
+ gfc_error ("Interfaces don't match "
+ "in procedure pointer assignment at %L", &rvalue->where);
+ return FAILURE;
+ }
+ return SUCCESS;
+ }
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index f3e1b03..032fa90 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2509,11 +2509,10 @@ gfc_match_rvalue (gfc_expr **result)
if (gfc_matching_procptr_assignment)
{
gfc_gobble_whitespace ();
- if (sym->attr.function && gfc_peek_ascii_char () == '(')
+ if (gfc_peek_ascii_char () == '(')
/* Parse functions returning a procptr. */
goto function0;
- if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
|| gfc_is_intrinsic (sym, 1, gfc_current_locus))
sym->attr.intrinsic = 1;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6ccbe12..0b6fe4c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2327,7 +2327,7 @@ resolve_function (gfc_expr *expr)
return FAILURE;
}
- if (sym && sym->attr.flavor == FL_VARIABLE)
+ if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
{
gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
return FAILURE;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 4e81b89..7c79ef8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -618,7 +618,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
break;
case FL_VARIABLE:
+ break;
+
case FL_NAMELIST:
+ conf2 (result);
break;
case FL_PROCEDURE:
@@ -672,6 +675,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+ conf2 (result);
if (attr->intent != INTENT_UNKNOWN)
{
@@ -698,6 +702,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf2 (threadprivate);
conf2 (value);
conf2 (is_bind_c);
+ conf2 (result);
break;
default:
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index de62964..e1ff5aa 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1613,8 +1613,8 @@ gfc_sym_type (gfc_symbol * sym)
tree type;
int byref;
- /* Procedure Pointers inside COMMON blocks. */
- if (sym->attr.proc_pointer && sym->attr.in_common)
+ /* Procedure Pointers inside COMMON blocks or as function result. */
+ if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result))
{
/* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
sym->attr.proc_pointer = 0;
@@ -2143,6 +2143,9 @@ gfc_get_function_type (gfc_symbol * sym)
type = gfc_typenode_for_spec (&sym->ts);
sym->ts.kind = gfc_default_real_kind;
}
+ else if (sym->result && sym->result->attr.proc_pointer)
+ /* Procedure pointer return values. */
+ type = gfc_sym_type (sym->result);
else
type = gfc_sym_type (sym);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ad317b7..f64db4d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2008-12-02 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/36704
+ PR fortran/38290
+ * gfortran.dg/entry_7.f90: Modified.
+ * gfortran.dg/proc_ptr_2.f90: Extended.
+ * gfortran.dg/proc_ptr_3.f90: Modified.
+ * gfortran.dg/proc_ptr_11.f90: New.
+ * gfortran.dg/proc_ptr_12.f90: New.
+ * gfortran.dg/result_1.f90: New.
+
2008-12-02 Jakub Jelinek <jakub@redhat.com>
PR middle-end/38343
diff --git a/gcc/testsuite/gfortran.dg/entry_7.f90 b/gcc/testsuite/gfortran.dg/entry_7.f90
index fbe4b8e..5294098 100644
--- a/gcc/testsuite/gfortran.dg/entry_7.f90
+++ b/gcc/testsuite/gfortran.dg/entry_7.f90
@@ -9,7 +9,7 @@
MODULE TT
CONTAINS
FUNCTION K(I) RESULT(J)
- ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" }
+ ENTRY J() ! { dg-error "conflicts with RESULT attribute" }
END FUNCTION K
integer function foo ()
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
new file mode 100644
index 0000000..a5cdbb5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+!
+! PR 38290: Procedure pointer assignment checking.
+!
+! Test case found at http://de.wikibooks.org/wiki/Fortran:_Fortran_2003:_Zeiger
+! Adapted by Janus Weil <janus@gcc.gnu.org>
+
+program bsp
+ implicit none
+
+ abstract interface
+ subroutine up()
+ end subroutine up
+ end interface
+
+ procedure( up ) , pointer :: pptr
+
+ pptr => add ! { dg-error "Interfaces don't match" }
+
+ print *, pptr() ! { dg-error "is not a function" }
+
+ contains
+
+ function add( a, b )
+ integer :: add
+ integer, intent( in ) :: a, b
+ add = a + b
+ end function add
+
+end program bsp
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_12.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_12.f90
new file mode 100644
index 0000000..325703f4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_12.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+procedure(integer),pointer :: p
+p => foo()
+if (p(-1)/=1) call abort
+contains
+ function foo() result(bar)
+ procedure(integer),pointer :: bar
+ bar => iabs
+ end function
+end
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
index d19b81d..6224dc5 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
@@ -6,8 +6,11 @@
PROCEDURE(REAL), POINTER :: ptr
PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" }
+REAL :: x
-ptr => cos(4.0) ! { dg-error "Invalid character" }
+ptr => cos(4.0) ! { dg-error "Invalid procedure pointer assignment" }
+ptr => x ! { dg-error "Invalid procedure pointer assignment" }
+ptr => sin(x) ! { dg-error "Invalid procedure pointer assignment" }
ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" }
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
index 34d4f16..5c4233d 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
@@ -6,14 +6,12 @@
real function e1(x)
real :: x
- print *,'e1!',x
e1 = x * 3.0
end function
subroutine e2(a,b)
real, intent(inout) :: a
real, intent(in) :: b
- print *,'e2!',a,b
a = a + b
end subroutine
@@ -29,7 +27,15 @@ interface
end subroutine sp
end interface
-external :: e1,e2
+external :: e1
+
+interface
+ subroutine e2(a,b)
+ real, intent(inout) :: a
+ real, intent(in) :: b
+ end subroutine e2
+end interface
+
real :: c = 1.2
fp => e1
diff --git a/gcc/testsuite/gfortran.dg/result_1.f90 b/gcc/testsuite/gfortran.dg/result_1.f90
new file mode 100644
index 0000000..162ffaf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/result_1.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+function f() result(r)
+real, parameter :: r = 5.0 ! { dg-error "attribute conflicts" }
+end function
+
+function g() result(s)
+real :: a,b,c
+namelist /s/ a,b,c ! { dg-error "attribute conflicts" }
+end function
+
+function h() result(t)
+type t ! { dg-error "attribute conflicts" }
+end function
generated by cgit v1.1 at 2024-11-02 23:43:53 +0000