diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 389f8faa09e..253caa2b8d1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2008-09-30 Janus Weil + + PR fortran/36592 + * symbol.c (check_conflict): If a symbol in a COMMON block is a + procedure, it must be a procedure pointer. + (gfc_add_in_common): Symbols in COMMON blocks may be variables or + procedure pointers. + * trans-types.c (gfc_sym_type): Make procedure pointers in COMMON + blocks work. + 2008-09-25 Jerry DeLisle proc_pointer) + conf2 (in_common); + switch (attr->proc) { case PROC_ST_FUNCTION: - conf2 (in_common); conf2 (dummy); break; @@ -649,7 +651,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case PROC_DUMMY: conf2 (result); - conf2 (in_common); conf2 (threadprivate); break; @@ -1133,13 +1134,7 @@ gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) /* Duplicate attribute already checked for. */ attr->in_common = 1; - if (check_conflict (attr, name, where) == FAILURE) - return FAILURE; - - if (attr->flavor == FL_VARIABLE) - return SUCCESS; - - return gfc_add_flavor (attr, FL_VARIABLE, name, where); + return check_conflict (attr, name, where); } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 8178ae39f05..c3d2a918040 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1627,6 +1627,16 @@ gfc_sym_type (gfc_symbol * sym) tree type; int byref; + /* Procedure Pointers inside COMMON blocks. */ + if (sym->attr.proc_pointer && sym->attr.in_common) + { + /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ + sym->attr.proc_pointer = 0; + type = build_pointer_type (gfc_get_function_type (sym)); + sym->attr.proc_pointer = 1; + return type; + } + if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) return void_type_node; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 28086b33dbd..02eb3b3cd82 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-09-30 Janus Weil + + PR fortran/36592 + * gfortran.dg/proc_ptr_common_1.f90: New. + * gfortran.dg/proc_ptr_common_2.f90: New. + 2008-09-30 Paolo Bonzini * g++.dg/warn/if-empty-1.C: Copy from gcc.dg/if-empty-1.c. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 new file mode 100644 index 00000000000..0cfdec03d5a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_common_1.f90 @@ -0,0 +1,30 @@ +! { dg-do run } + +! PR fortran/36592 +! +! Procedure Pointers inside COMMON blocks. +! +! Contributed by Janus Weil . + +subroutine one() + implicit none + common /com/ p1,p2,a,b + procedure(real), pointer :: p1,p2 + integer :: a,b + if (a/=5 .or. b/=-9 .or. p1(0.0)/=1.0 .or. p2(0.0)/=0.0) call abort() +end subroutine one + +program main + implicit none + integer :: x,y + intrinsic sin,cos + procedure(real), pointer :: func1 + external func2 + pointer func2 + common /com/ func1,func2,x,y + x = 5 + y = -9 + func1 => cos + func2 => sin + call one() +end program main diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90 new file mode 100644 index 00000000000..f401c3a15c3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_common_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + +! PR fortran/36592 +! +! Procedure Pointers inside COMMON blocks. +! +! Contributed by Tobias Burnus . + +abstract interface + subroutine foo() bind(C) + end subroutine foo +end interface + +procedure(foo), pointer, bind(C) :: proc +common /com/ proc,r + +common s +call s() ! { dg-error "PROCEDURE attribute conflicts with COMMON attribute" } + +end