* [patch, fortran]
@ 2011-06-05 21:00 Thomas Koenig
2011-06-06 19:25 ` [patch, fortran] Some more TRIM optimizations Thomas Koenig
0 siblings, 1 reply; 12+ messages in thread
From: Thomas Koenig @ 2011-06-05 21:00 UTC (permalink / raw)
To: fortran, gcc-patches
[-- 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" } }
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [patch, fortran] Some more TRIM optimizations
2011-06-05 21:00 [patch, fortran] Thomas Koenig
@ 2011-06-06 19:25 ` Thomas Koenig
2011-06-10 17:27 ` Thomas Koenig
0 siblings, 1 reply; 12+ messages in thread
From: Thomas Koenig @ 2011-06-06 19:25 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 617 bytes --]
I wrote:
> Hello world,
>
> the attached patch extends removing trailing TRIMs in assignments for
> cases like a // trim(b). Regression-tested. OK for trunk?
>
> Thomas
This time with the test case corrected (cleanup of the *.original file)
and a more meaningful Subject line.
OK?
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: 676 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" } }
! { dg-final { cleanup-tree-dump "original" } }
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [patch, fortran] Some more TRIM optimizations
2011-06-06 19:25 ` [patch, fortran] Some more TRIM optimizations Thomas Koenig
@ 2011-06-10 17:27 ` Thomas Koenig
2011-06-10 17:52 ` jerry DeLisle
0 siblings, 1 reply; 12+ messages in thread
From: Thomas Koenig @ 2011-06-10 17:27 UTC (permalink / raw)
To: fortran, gcc-patches
I wrote:
>
>> Hello world,
>>
>> the attached patch extends removing trailing TRIMs in assignments for
>> cases like a // trim(b). Regression-tested. OK for trunk?
>>
>> Thomas
>
> This time with the test case corrected (cleanup of the *.original file)
> and a more meaningful Subject line.
>
> OK?
Ping ** 0.5714
Full patch can be found at
http://gcc.gnu.org/ml/fortran/2011-06/msg00053.html
Thomas
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [patch, fortran] Some more TRIM optimizations
2011-06-10 17:27 ` Thomas Koenig
@ 2011-06-10 17:52 ` jerry DeLisle
2011-06-11 10:06 ` Thomas Koenig
0 siblings, 1 reply; 12+ messages in thread
From: jerry DeLisle @ 2011-06-10 17:52 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches
On 06/10/2011 10:08 AM, Thomas Koenig wrote:
> I wrote:
>
>>
>>> Hello world,
>>>
>>> the attached patch extends removing trailing TRIMs in assignments for
>>> cases like a // trim(b). Regression-tested. OK for trunk?
>>>
>>> Thomas
>>
>> This time with the test case corrected (cleanup of the *.original file)
>> and a more meaningful Subject line.
>>
>> OK?
>
> Ping ** 0.5714
>
> Full patch can be found at
>
> http://gcc.gnu.org/ml/fortran/2011-06/msg00053.html
OK and thanks for patch.
Jerry
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [patch, fortran] Some more TRIM optimizations
2011-06-10 17:52 ` jerry DeLisle
@ 2011-06-11 10:06 ` Thomas Koenig
0 siblings, 0 replies; 12+ messages in thread
From: Thomas Koenig @ 2011-06-11 10:06 UTC (permalink / raw)
To: jerry DeLisle; +Cc: fortran, gcc-patches
Hi Jerry,
>
>> Ping ** 0.5714
>>
>> Full patch can be found at
>>
>> http://gcc.gnu.org/ml/fortran/2011-06/msg00053.html
>
> OK and thanks for patch.
Sending fortran/ChangeLog
Sending fortran/frontend-passes.c
Sending testsuite/ChangeLog
Adding testsuite/gfortran.dg/trim_optimize_7.f90
Transmitting file data ....
Committed revision 174944.
Thanks for the review!
Thomas
^ permalink raw reply [flat|nested] 12+ messages in thread
* [patch, fortran]
@ 2016-07-14 17:47 Jerry DeLisle
0 siblings, 0 replies; 12+ messages in thread
From: Jerry DeLisle @ 2016-07-14 17:47 UTC (permalink / raw)
To: gfortran; +Cc: gcc patches
[-- 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
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [PATCH, Fortran]
[not found] ` <540E2489.2030403@net-b.de>
@ 2014-09-08 22:13 ` Alessandro Fanfarillo
0 siblings, 0 replies; 12+ messages in thread
From: Alessandro Fanfarillo @ 2014-09-08 22:13 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, gfortran
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 ----
^ permalink raw reply [flat|nested] 12+ messages in thread
* [PATCH, Fortran]
@ 2014-09-08 21:23 Alessandro Fanfarillo
[not found] ` <540E2489.2030403@net-b.de>
0 siblings, 1 reply; 12+ messages in thread
From: Alessandro Fanfarillo @ 2014-09-08 21:23 UTC (permalink / raw)
To: gcc-patches, gfortran
[-- 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 ----
^ permalink raw reply [flat|nested] 12+ messages in thread
* [PATCH, FORTRAN]
@ 2014-04-08 12:04 Bernd Edlinger
0 siblings, 0 replies; 12+ messages in thread
From: Bernd Edlinger @ 2014-04-08 12:04 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
[-- 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
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [Patch, fortran]
2006-06-24 15:35 ` Steve Kargl
@ 2006-06-25 7:09 ` Paul Thomas
0 siblings, 0 replies; 12+ messages in thread
From: Paul Thomas @ 2006-06-25 7:09 UTC (permalink / raw)
To: Steve Kargl; +Cc: 'fortran@gcc.gnu.org', patch
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
^ permalink raw reply [flat|nested] 12+ messages in thread
* Re: [Patch, fortran]
2006-06-23 17:16 [Patch, fortran] Paul Thomas
@ 2006-06-24 15:35 ` Steve Kargl
2006-06-25 7:09 ` Paul Thomas
0 siblings, 1 reply; 12+ messages in thread
From: Steve Kargl @ 2006-06-24 15:35 UTC (permalink / raw)
To: Paul Thomas; +Cc: 'fortran@gcc.gnu.org', patch
+ 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
^ permalink raw reply [flat|nested] 12+ messages in thread
* [Patch, fortran]
@ 2006-06-23 17:16 Paul Thomas
2006-06-24 15:35 ` Steve Kargl
0 siblings, 1 reply; 12+ messages in thread
From: Paul Thomas @ 2006-06-23 17:16 UTC (permalink / raw)
To: 'fortran@gcc.gnu.org', patch
[-- 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.
^ permalink raw reply [flat|nested] 12+ messages in thread
end of thread, other threads:[~2016-07-14 17:47 UTC | newest]
Thread overview: 12+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-06-05 21:00 [patch, fortran] Thomas Koenig
2011-06-06 19:25 ` [patch, fortran] Some more TRIM optimizations Thomas Koenig
2011-06-10 17:27 ` Thomas Koenig
2011-06-10 17:52 ` jerry DeLisle
2011-06-11 10:06 ` Thomas Koenig
-- strict thread matches above, loose matches on Subject: below --
2016-07-14 17:47 [patch, fortran] Jerry DeLisle
2014-09-08 21:23 [PATCH, Fortran] Alessandro Fanfarillo
[not found] ` <540E2489.2030403@net-b.de>
2014-09-08 22:13 ` Alessandro Fanfarillo
2014-04-08 12:04 [PATCH, FORTRAN] Bernd Edlinger
2006-06-23 17:16 [Patch, fortran] Paul Thomas
2006-06-24 15:35 ` Steve Kargl
2006-06-25 7:09 ` Paul Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).