[PATCH, FORTRAN]

[PATCH, FORTRAN]

[Bernd Edlinger]

[-- Attachment #1: Type: text/plain, Size: 462 bytes --]

Hi,

this patch fixes a recently discovered name-clash in gfc_build_class_symbol.

Fortunately it is quite easy to fix: just make sure that the class names of target
classes end with "_t", and target array classes end with "[0-9]t".
This trick makes all names unique again.

I hope it is not too late, and this can still go into 4.9.0.

Boot-Strapped without any regressions on x86_64-unknown-linux-gnu.

Ok for trunk?

Thanks
Bernd.
 		 	   		  

[-- Attachment #2: changelog-class.txt --]
[-- Type: text/plain, Size: 299 bytes --]

gcc:
2014-04-08  Bernd Edlinger  <bernd.edlinger@hotmail.de>

	* fortran/class.c (gfc_build_class_symbol): Append "_t" to target class
	names to make the generated type names unique.

testsuite:
2014-04-08  Bernd Edlinger  <bernd.edlinger@hotmail.de>

	* gfortran.dg/class_nameclash.f90: New test.


[-- Attachment #3: patch-class.diff --]
[-- Type: application/octet-stream, Size: 1794 bytes --]

Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 209173)
+++ gcc/fortran/class.c	(working copy)
@@ -588,13 +588,13 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_a
   else if ((*as) && attr->pointer)
     sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
   else if ((*as))
-    sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
+    sprintf (name, "__class_%s_%d_%dt", tname, rank, (*as)->corank);
   else if (attr->pointer)
     sprintf (name, "__class_%s_p", tname);
   else if (attr->allocatable)
     sprintf (name, "__class_%s_a", tname);
   else
-    sprintf (name, "__class_%s", tname);
+    sprintf (name, "__class_%s_t", tname);
 
   if (ts->u.derived->attr.unlimited_polymorphic)
     {
Index: gcc/testsuite/gfortran.dg/class_nameclash.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_nameclash.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/class_nameclash.f90	(revision 0)
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! try to provoke class name clashes in gfc_build_class_symbol
+!
+module test_module
+
+  implicit none
+
+  type, public :: test_p
+    private
+    class (test_p), pointer :: next => null()
+  end type test_p
+
+  type, public :: test
+!   Error in "call do_it (x)" below:
+!   Type mismatch in argument 'x' at (1); passed CLASS(test_p) to CLASS(test)
+    class (test), pointer :: next => null()
+  end type test
+
+contains
+
+  subroutine do_it (x)
+    class (test_p), target :: x
+
+    x%next => x
+    return
+  end subroutine do_it
+
+end module test_module
+
+use test_module
+
+  implicit none
+  class (test_p), pointer :: x
+
+  allocate (x)
+  call do_it (x)
+  deallocate (x)
+end

FW: [PATCH, FORTRAN] Class Name Clash

[Bernd Edlinger]

[-- Attachment #1: Type: text/plain, Size: 528 bytes --]

Sorry, wrong subject, again...

>
> Hi,
>
> this patch fixes a recently discovered name-clash in gfc_build_class_symbol.
>
> Fortunately it is quite easy to fix: just make sure that the class names of target
> classes end with "_t", and target array classes end with "[0-9]t".
> This trick makes all names unique again.
>
> I hope it is not too late, and this can still go into 4.9.0.
>
> Boot-Strapped without any regressions on x86_64-unknown-linux-gnu.
>
> Ok for trunk?
>
> Thanks
> Bernd.
>
 		 	   		  

[-- Attachment #2: changelog-class.txt --]
[-- Type: text/plain, Size: 299 bytes --]

gcc:
2014-04-08  Bernd Edlinger  <bernd.edlinger@hotmail.de>

	* fortran/class.c (gfc_build_class_symbol): Append "_t" to target class
	names to make the generated type names unique.

testsuite:
2014-04-08  Bernd Edlinger  <bernd.edlinger@hotmail.de>

	* gfortran.dg/class_nameclash.f90: New test.


[-- Attachment #3: patch-class.diff --]
[-- Type: application/octet-stream, Size: 1794 bytes --]

Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 209173)
+++ gcc/fortran/class.c	(working copy)
@@ -588,13 +588,13 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_a
   else if ((*as) && attr->pointer)
     sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank);
   else if ((*as))
-    sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank);
+    sprintf (name, "__class_%s_%d_%dt", tname, rank, (*as)->corank);
   else if (attr->pointer)
     sprintf (name, "__class_%s_p", tname);
   else if (attr->allocatable)
     sprintf (name, "__class_%s_a", tname);
   else
-    sprintf (name, "__class_%s", tname);
+    sprintf (name, "__class_%s_t", tname);
 
   if (ts->u.derived->attr.unlimited_polymorphic)
     {
Index: gcc/testsuite/gfortran.dg/class_nameclash.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_nameclash.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/class_nameclash.f90	(revision 0)
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! try to provoke class name clashes in gfc_build_class_symbol
+!
+module test_module
+
+  implicit none
+
+  type, public :: test_p
+    private
+    class (test_p), pointer :: next => null()
+  end type test_p
+
+  type, public :: test
+!   Error in "call do_it (x)" below:
+!   Type mismatch in argument 'x' at (1); passed CLASS(test_p) to CLASS(test)
+    class (test), pointer :: next => null()
+  end type test
+
+contains
+
+  subroutine do_it (x)
+    class (test_p), target :: x
+
+    x%next => x
+    return
+  end subroutine do_it
+
+end module test_module
+
+use test_module
+
+  implicit none
+  class (test_p), pointer :: x
+
+  allocate (x)
+  call do_it (x)
+  deallocate (x)
+end

[patch, fortran]

[Jerry DeLisle]

[-- Attachment #1: Type: text/plain, Size: 847 bytes --]

This simple patch kindly provided by Marco solves the problem.

Regression tested on x86_64-Linux, Test case provided also.

OK to commit to trunk?

Jerry

2016-07-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	    Marco Restelli <mrestelli@gmail.com>

	PR fortran/62125
	* symbol.c (select_type_insert_tmp): Recursively call self to take care
	of nested select type.

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0ee7dec..c967f25 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2930,7 +2930,11 @@ select_type_insert_tmp (gfc_symtree **st)
   gfc_select_type_stack *stack = select_type_stack;
   for (; stack; stack = stack->prev)
     if ((*st)->n.sym == stack->selector && stack->tmp)
-      *st = stack->tmp;
+      {
+        *st = stack->tmp;
+        select_type_insert_tmp (st);
+        return;
+      }
 }

[-- Attachment #2: pr62125.f90 --]
[-- Type: text/x-fortran, Size: 647 bytes --]

! { dg-do run }
! PR62125  Nested select type not accepted (rejects valid) 
module m
 implicit none
 type, abstract :: t1
  logical :: l
 end type t1
 type, extends(t1), abstract :: t2
  integer :: i
 end type t2
 type, extends(t2) :: t3
  real :: x
 end type t3
contains
 subroutine s(u)
  class(t1), intent(in) :: u
  if(.not.u%l) call abort()
   select type(u); class is(t2)
     if(u%i.ne.2) call abort()
     select type(u); class is(t3)
       if(u%x.ne.3.5) call abort()
     end select
   end select
 end subroutine s
end module m

program p
 use m
 implicit none
 type(t3) :: var = t3( l=.true. , i=2 , x=3.5 )
 call s(var)
end program p

[PATCH, Fortran]

[Alessandro Fanfarillo]

[-- Attachment #1: Type: text/plain, Size: 647 bytes --]

Dear all,

the following code produces a wrong invocation to libcaf for
caf_atomic_op (atomic_add):

program atomic
use iso_fortran_env
implicit none

integer :: me
integer(atomic_int_kind) :: atom[*]
me = this_image()
call atomic_define(atom[1],0)
sync all
call ATOMIC_ADD (atom[1], me)
if(me == 1) call atomic_ref(me,atom[1])
sync all
write(*,*) me

end program

The compiler translates the caf_atomic_op call (related with atomic_add) as:

    integer(kind=4) value.3;

    value.3 = (integer(kind=4)) &me;
    _gfortran_caf_atomic_op (1, caf_token.0, 0, 1, &value.3, 0B, 0B, 1, 4);

The attached patch seems to fix the problem.


Suggestions?

[-- Attachment #2: patch.diff --]
[-- Type: text/plain, Size: 782 bytes --]

Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 215016)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** conv_intrinsic_atomic_op (gfc_code *code
*** 8396,8408 ****
        else
  	image_index = integer_zero_node;
  
-       if (TREE_TYPE (TREE_TYPE (atom)) != TREE_TYPE (TREE_TYPE (value)))
- 	{
- 	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
- 	  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
-           value = gfc_build_addr_expr (NULL_TREE, tmp);
- 	}
- 
        gfc_get_caf_token_offset (&token, &offset, caf_decl, atom, atom_expr);
  
        if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
--- 8396,8401 ----

Re: [PATCH, Fortran]

[Alessandro Fanfarillo]

Thanks, your suggestion fixes the problem.

I just noticed that I missed the subject description; I'll send the
new patch in a different email.

2014-09-08 15:50 GMT-06:00 Tobias Burnus <burnus@net-b.de>:
> Alessandro Fanfarillo wrote:
>
> the following code produces a wrong invocation to libcaf for
> caf_atomic_op (atomic_add):
>
> program atomic
> use iso_fortran_env
> implicit none
>
> integer :: me
> integer(atomic_int_kind) :: atom[*]
> me = this_image()
> call atomic_define(atom[1],0)
> sync all
> call ATOMIC_ADD (atom[1], me)
> if(me == 1) call atomic_ref(me,atom[1])
> sync all
> write(*,*) me
>
> end program
>
> The compiler translates the caf_atomic_op call (related with atomic_add) as:
>
>     integer(kind=4) value.3;
>
>     value.3 = (integer(kind=4)) &me;
>     _gfortran_caf_atomic_op (1, caf_token.0, 0, 1, &value.3, 0B, 0B, 1, 4);
>
> The attached patch seems to fix the problem.
>
>
> But I think it doesn't do the right thing if the kind is different.
>
> Suggestions?
>
>
> I think you want to do something like inserting
>
>   if (POINTER_TYPE_P (TREE_TYPE (value))
>     value = build_fold_indirect_ref_loc (input_location, value);
>
> before the assignment:
>
>  	  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
>
> otherwise you risk that you access invalid memory, e.g. for passing a
> integer(1) variable to an integer(4) atomic. On the other hand, there is
> something wrong with the check – as it shouldn't trigger when both atom and
> value have the same kind. Thus, the modified patch might work, is probably
> not completely clean either.
>
> Tobias
>
> Index: gcc/fortran/trans-intrinsic.c
> ===================================================================
> *** gcc/fortran/trans-intrinsic.c	(revision 215016)
> --- gcc/fortran/trans-intrinsic.c	(working copy)
> *************** conv_intrinsic_atomic_op (gfc_code *code
> *** 8396,8408 ****
>         else
>   	image_index = integer_zero_node;
>
> -       if (TREE_TYPE (TREE_TYPE (atom)) != TREE_TYPE (TREE_TYPE (value)))
> - 	{
> - 	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
> - 	  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
> -           value = gfc_build_addr_expr (NULL_TREE, tmp);
> - 	}
> -
>         gfc_get_caf_token_offset (&token, &offset, caf_decl, atom,
> atom_expr);
>
>         if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
> --- 8396,8401 ----

[patch, fortran]

[Thomas Koenig]

[-- Attachment #1: Type: text/plain, Size: 445 bytes --]

Hello world,

the attached patch extends removing trailing TRIMs in assignments for
cases like a // trim(b).  Regression-tested.  OK for trunk?

	Thomas

2011-05-06  Thomas König  <tkoenig@gcc.gnu.org>

	* frontend-passes.c (optimize_assignment): Follow chains
	of concatenation operators to the end for removing trailing
	TRIMS for assignments.

2011-05-06  Thomas König  <tkoenig@gcc.gnu.org>

	* gfortran.dg/trim_optimize_7.f90:  New test.

[-- Attachment #2: p1.diff --]
[-- Type: text/x-patch, Size: 695 bytes --]

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(Revision 174391)
+++ frontend-passes.c	(Arbeitskopie)
@@ -500,6 +500,14 @@ optimize_assignment (gfc_code * c)
 
   if (lhs->ts.type == BT_CHARACTER)
     {
+      /* Check for a // b // trim(c).  Looping is probably not
+	 necessary because the parser usually generates
+	 (// (// a b ) trim(c) ) , but better safe than sorry.  */
+
+      while (rhs->expr_type == EXPR_OP
+	     && rhs->value.op.op == INTRINSIC_CONCAT)
+	rhs = rhs->value.op.op2;
+
       if (rhs->expr_type == EXPR_FUNCTION &&
 	  rhs->value.function.isym &&
 	  rhs->value.function.isym->id == GFC_ISYM_TRIM)

[-- Attachment #3: trim_optimize_7.f90 --]
[-- Type: text/plain, Size: 628 bytes --]

! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
! Check that trailing trims are also removed from assignment of
! expressions involving concatenations of strings .
program main
  character(2) :: a,b,c
  character(8) :: d
  a = 'a '
  b = 'b '
  c = 'c '
  d = a // b // a // trim(c)   ! This should be optimized away.
  if (d /= 'a b a c ') call abort
  d = a // trim(b) // c // a   ! This shouldn't.
  if (d /= 'a bc a  ') call abort
  d = a // b // a // trim(trim(c)) ! This should also be optimized away.
  if (d /= 'a b a c ') call abort
end
! { dg-final { scan-tree-dump-times "string_len_trim" 1 "original" } }

[Patch, fortran]

[Paul Thomas]

[-- Attachment #1: Type: text/plain, Size: 1295 bytes --]

:ADDPATCH:

This patch consists of five patchlets, all of which are straightforward and
self-explanatory.

Regtested on FC5/Athlon1700 - OK for trunk and 4.1?

Paul

2006-06-24  Paul Thomas  <pault@gcc.gnu.org>
 
	PR fortran/25056
	* interface.c (compare_actual_formal): Signal an error if the formal
	argument is a pure procedure and the actual is not pure.

	PR fortran/27554
	* resolve.c (resolve_actual_arglist): If the type of procedure
	passed as an actual argument is not already declared, see if it is
	an intrinsic.

	PR fortran/25073
	* resolve.c (resolve_select): Use bits 1 and 2 of a new int to
	keep track of  the appearance of constant logical case expressions.
	Signal an error is either value appears more than once.

	PR fortran/20874
	* resolve.c (resolve_fl_procedure): Signal an error if an elemental
	function is not scalar valued.

	PR fortran/20867
	* match.c (recursive_stmt_fcn): Perform implicit typing of variables.


2006-06-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20867
	* gfortran.dg/stfunc_3.f90: New test.

	PR fortran/25056
	* gfortran.dg/impure_actual_1.f90: New test.

	PR fortran/20874
	* gfortran.dg/elemental_result_1.f90: New test.

	PR fortran/25073
	* gfortran.dg/select_7.f90: New test.

	PR fortran/27554
	* intrinsic_actual_1.f: New test.


[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 9540 bytes --]

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 114823)
--- gcc/fortran/interface.c	(working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 1296,1301 ****
--- 1296,1312 ----
  	    }
  	}
  
+       if (f->sym->attr.flavor == FL_PROCEDURE
+ 	    && f->sym->attr.pure
+ 	    && a->expr->ts.type == BT_PROCEDURE
+ 	    && !a->expr->symtree->n.sym->attr.pure)
+ 	{
+ 	  if (where)
+ 	    gfc_error ("Expected a PURE procedure for argument '%s' at %L",
+ 		       f->sym->name, &a->expr->where);
+ 	  return 0;
+ 	}
+ 
        if (f->sym->as
  	  && f->sym->as->type == AS_ASSUMED_SHAPE
  	  && a->expr->expr_type == EXPR_VARIABLE
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 114823)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_actual_arglist (gfc_actual_argli
*** 829,834 ****
--- 829,842 ----
  	  || sym->attr.external)
  	{
  
+ 	  /* If a procedure is not already determined to be something else
+ 	     check if it is intrinsic.  */
+ 	  if (!sym->attr.intrinsic
+ 		&& !(sym->attr.external || sym->attr.use_assoc
+ 		       || sym->attr.if_source == IFSRC_IFBODY)
+ 		&& gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ 	    sym->attr.intrinsic = 1;
+ 
  	  if (sym->attr.proc == PROC_ST_FUNCTION)
  	    {
  	      gfc_error ("Statement function '%s' at %L is not allowed as an "
*************** resolve_select (gfc_code * code)
*** 3615,3620 ****
--- 3623,3629 ----
    gfc_expr *case_expr;
    gfc_case *cp, *default_case, *tail, *head;
    int seen_unreachable;
+   int seen_logical;
    int ncases;
    bt type;
    try t;
*************** resolve_select (gfc_code * code)
*** 3697,3702 ****
--- 3706,3712 ----
    default_case = NULL;
    head = tail = NULL;
    ncases = 0;
+   seen_logical = 0;
  
    for (body = code->block; body; body = body->block)
      {
*************** resolve_select (gfc_code * code)
*** 3749,3754 ****
--- 3759,3777 ----
  	      break;
  	    }
  
+ 	  if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
+ 	    {
+ 	      if (cp->low->value.logical & seen_logical)
+ 		{
+ 		  gfc_error ("constant logical value in CASE statement "
+ 			     "is repeated at %L",
+ 			     &cp->low->where);
+ 		  t = FAILURE;
+ 		  break;
+ 		}
+ 	      seen_logical |= cp->low->value.logical == 0 ? 2 : 1;
+ 	    }
+ 
  	  if (cp->low != NULL && cp->high != NULL
  	      && cp->low != cp->high
  	      && gfc_compare_expr (cp->low, cp->high) > 0)
*************** resolve_fl_procedure (gfc_symbol *sym, i
*** 5177,5182 ****
--- 5200,5215 ----
        return FAILURE;
      }
  
+   /* An elemental function is required to return a scalar 12.7.1  */
+   if (sym->attr.elemental && sym->attr.function && sym->as)
+     {
+       gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
+ 		 "result", sym->name, &sym->declared_at);
+       /* Reset so that the error only occurs once.  */
+       sym->attr.elemental = 0;
+       return FAILURE;
+     }
+ 
    /* 5.1.1.5 of the Standard: A function name declared with an asterisk
       char-len-param shall not be array-valued, pointer-valued, recursive
       or pure.  ....snip... A character value of * may only be used in the
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 114823)
--- gcc/fortran/match.c	(working copy)
*************** cleanup:
*** 2796,2802 ****
  
  /* Check that a statement function is not recursive. This is done by looking
     for the statement function symbol(sym) by looking recursively through its
!    expression(e).  If a reference to sym is found, true is returned.  */
  static bool
  recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
  {
--- 2796,2806 ----
  
  /* Check that a statement function is not recursive. This is done by looking
     for the statement function symbol(sym) by looking recursively through its
!    expression(e).  If a reference to sym is found, true is returned.  
!    12.5.4 requires that any variable of function that is implicitly typed
!    shall have that type confirmed by any subsequent type declaration.  The
!    implicit typing is conveniently done here.  */
! 
  static bool
  recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
  {
*************** recursive_stmt_fcn (gfc_expr *e, gfc_sym
*** 2830,2840 ****
--- 2834,2850 ----
  	    && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
  	return true;
  
+       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ 	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
+ 
        break;
  
      case EXPR_VARIABLE:
        if (e->symtree && sym->name == e->symtree->n.sym->name)
  	return true;
+ 
+       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ 	gfc_set_default_type (e->symtree->n.sym, 0, NULL);
        break;
  
      case EXPR_OP:
Index: gcc/testsuite/gfortran.dg/stfunc_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/stfunc_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/stfunc_3.f90	(revision 0)
***************
*** 0 ****
--- 1,13 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR20867 in which implicit typing was not done within
+ ! statement functions and so was not confirmed or not by subsequent
+ ! type delarations.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+   REAL :: st1
+   st1(I)=I**2
+   REAL :: I ! { dg-error " already has basic type of INTEGER" }
+   END
+ 
+ 
Index: gcc/testsuite/gfortran.dg/impure_actual_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/impure_actual_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/impure_actual_1.f90	(revision 0)
***************
*** 0 ****
--- 1,25 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR25056 in which a non-PURE procedure could be
+ ! passed as the actual argument to a PURE procedure.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+ MODULE M1
+ CONTAINS
+  FUNCTION L()
+   L=1
+  END FUNCTION L
+  PURE FUNCTION J(K)
+    INTERFACE
+      PURE FUNCTION K()
+      END FUNCTION K
+    END INTERFACE
+    J=K()
+  END FUNCTION J
+ END MODULE M1
+ USE M1
+  write(6,*) J(L) ! { dg-error "Expected a PURE procedure for argument" }
+ END
+ 
+ ! { dg-final { cleanup-modules "M1" } }
+ 
Index: gcc/testsuite/gfortran.dg/elemental_result_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/elemental_result_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/elemental_result_1.f90	(revision 0)
***************
*** 0 ****
--- 1,21 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR20874 in which array valued elemental
+ ! functions were permitted.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+ MODULE Test
+ CONTAINS
+   ELEMENTAL FUNCTION LL(I) ! { dg-error "must have a scalar result" }
+     INTEGER, INTENT(IN) :: I
+     INTEGER  :: LL(2)
+   END FUNCTION LL
+ !
+ ! This was already OK.
+ !
+   ELEMENTAL FUNCTION MM(I)
+     INTEGER, INTENT(IN) :: I
+     INTEGER, pointer  :: MM ! { dg-error "conflicts with ELEMENTAL" }
+   END FUNCTION MM
+ END MODULE Test
+ 
Index: gcc/testsuite/gfortran.dg/select_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/select_7.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/select_7.f90	(revision 0)
***************
*** 0 ****
--- 1,13 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR25073 in which overlap in logical case
+ ! expressions was permitted.
+ !
+ ! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+ !
+ LOGICAL :: L
+ SELECT CASE(L)
+ CASE(.true.)
+ CASE(.false.)
+ CASE(.true.) ! { dg-error "value in CASE statement is repeated" }
+ END SELECT
+ END
Index: gcc/testsuite/gfortran.dg/intrinsic_actual_1.f
===================================================================
*** gcc/testsuite/gfortran.dg/intrinsic_actual_1.f	(revision 0)
--- gcc/testsuite/gfortran.dg/intrinsic_actual_1.f	(revision 0)
***************
*** 0 ****
--- 1,49 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR27554, where the actual argument reference
+ ! to abs would not be recognised as being to an intrinsic
+ ! procedure and would produce junk in the assembler.
+ !
+ ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 
+ !
+       subroutine foo (proc, z)
+         external proc
+         real proc, z
+         if ((proc(z) .ne. abs (z)) .and. 
+      &      (proc(z) .ne. alog10 (abs(z)))) call abort ()
+         return
+       end
+ 
+         external cos
+         interface
+           function sin (a)
+             real a, sin
+           end function sin
+         end interface
+ 
+ 
+         intrinsic alog10
+         real x
+         x = 100.
+ ! The reference here would prevent the actual arg from being seen
+ ! as an intrinsic procedure in the call to foo.
+         x = -abs(x)
+         call foo(abs, x)
+ ! The intrinsic function can be locally over-ridden by an interface
+         call foo(sin, x)
+ ! or an external declaration.
+         call foo(cos, x)
+ ! Just make sure with another intrinsic but this time not referenced.
+         call foo(alog10, -x)
+       end
+ 
+       function sin (a)
+         real a, sin
+         sin = -a
+         return
+       end
+ 
+       function cos (a)
+         real a, cos
+         cos = -a
+         return
+       end

[-- Attachment #3: Change.Logs --]
[-- Type: text/plain, Size: 1127 bytes --]

2006-06-24  Paul Thomas  <pault@gcc.gnu.org>
 
	PR fortran/25056
	* interface.c (compare_actual_formal): Signal an error if the formal
	argument is a pure procedure and the actual is not pure.

	PR fortran/27554
	* resolve.c (resolve_actual_arglist): If the type of procedure
	passed as an actual argument is not already declared, see if it is
	an intrinsic.

	PR fortran/25073
	* resolve.c (resolve_select): Use bits 1 and 2 of a new int to
	keep track of  the appearance of constant logical case expressions.
	Signal an error is either value appears more than once.

	PR fortran/20874
	* resolve.c (resolve_fl_procedure): Signal an error if an elemental
	function is not scalar valued.

	PR fortran/20867
	* match.c (recursive_stmt_fcn): Perform implicit typing of variables.


2006-06-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20867
	* gfortran.dg/stfunc_3.f90: New test.

	PR fortran/25056
	* gfortran.dg/impure_actual_1.f90: New test.

	PR fortran/20874
	* gfortran.dg/elemental_result_1.f90: New test.

	PR fortran/25073
	* gfortran.dg/select_7.f90: New test.

	PR fortran/27554
	* intrinsic_actual_1.f: New test.

Re: [Patch, fortran]

[Steve Kargl]

+ 	  if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
+ 	    {
+ 	      if (cp->low->value.logical & seen_logical)

Do you want & or && here?

+ 		{
+ 		  gfc_error ("constant logical value in CASE statement "
+ 			     "is repeated at %L",
+ 			     &cp->low->where);
+ 		  t = FAILURE;
+ 		  break;
+ 		}

Otherwise, the patch is OK.

-- 
Steve

Re: [Patch, fortran]

[Paul Thomas]

Steve Kargl wrote:

> + if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
> + {
> + if (cp->low->value.logical & seen_logical)
>
> Do you want & or && here?

The arithmetic and was intentional. However, I realised in replying to 
you that the first operand is incorrect; the patch only fixes repeated 
.TRUE.!

This is what I will submit:
if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
{
int value;
value = cp->low->value.logical == 0 ? 2 : 1;
if (value & seen_logical)
{
gfc_error ("constant logical value in CASE statement "
"is repeated at %L",
&cp->low->where);
t = FAILURE;
break;
}
seen_logical |= value;
}

>
> Otherwise, the patch is OK.

Many thanks for this and the review of the FORALL patch.

Paul