mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-21 15:41:09 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/31293 (Implicit character and array returning functions)

Browse Source 
2007-04-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31293
	* symbol.c (gfc_check_function_type): New function.
	* gfortran.h : Add prototype for previous.
	* parse.c (parse_progunit): Call it after parsing specification
	statements.

2007-04-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31293
	* gfortran.dg/interface_12.f90: New test.

From-SVN: r123641
This commit is contained in:
Paul Thomas 2007-04-07 20:13:52 +00:00
parent ca178f85a6
commit e9bd9f7d5d
6 changed files with 140 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2007-04-07 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31293
* symbol.c (gfc_check_function_type): New function.
* gfortran.h : Add prototype for previous.
* parse.c (parse_progunit): Call it after parsing specification
statements.
2007-04-05 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31483

4
gcc/fortran/gfortran.h
View File

@ -483,7 +483,8 @@ typedef struct
/* Variable attributes. */
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, save:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1;
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
implied_index:1;
unsigned data:1, /* Symbol is named in a DATA statement. */
protected:1, /* Symbol has been marked as protected. */
@ -1853,6 +1854,7 @@ void gfc_clear_new_implicit (void);
try gfc_add_new_implicit_range (int, int);
try gfc_merge_new_implicit (gfc_typespec *);
void gfc_set_implicit_none (void);
void gfc_check_function_type (gfc_namespace *);
gfc_typespec *gfc_get_default_type (gfc_symbol *, gfc_namespace *);
try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);

3
gcc/fortran/parse.c
View File

@ -2915,6 +2915,9 @@ parse_progunit (gfc_statement st)
break;
}
if (gfc_current_state () == COMP_FUNCTION)
gfc_check_function_type (gfc_current_ns);
loop:
for (;;)
{

31
gcc/fortran/symbol.c
View File

@ -253,6 +253,37 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
}
/* This function is called from parse.c(parse_progunit) to check the
type of the function is not implicitly typed in the host namespace
and to implicitly type the function result, if necessary. */
void
gfc_check_function_type (gfc_namespace *ns)
{
gfc_symbol *proc = ns->proc_name;
if (!proc->attr.contained || proc->result->attr.implicit_type)
return;
if (proc->result->ts.type == BT_UNKNOWN)
{
if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
== SUCCESS)
{
if (proc->result != proc)
proc->ts = proc->result->ts;
}
else
{
gfc_error ("unable to implicitly type the function result "
"'%s' at %L", proc->result->name,
&proc->result->declared_at);
proc->result->attr.untyped = 1;
}
}
}
/******************** Symbol attribute stuff *********************/
/* This is a generic conflict-checker. We do this to avoid having a

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2007-04-07 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31293
* gfortran.dg/interface_12.f90: New test.
2007-04-07 Bruce Korb <bkorb@gnu.org>
* gcc.dg/format/opt-6.c: New test.

90
gcc/testsuite/gfortran.dg/interface_12.f90 Normal file
View File

@ -0,0 +1,90 @@
! { dg-do run }
! Test the fix for PR31293.
!
! File: interface4.f90
! http://home.comcast.net/%7Ekmbtib/Fortran_stuff/interface4.f90
! Public domain 2004 James Van Buskirk
! Second attempt to actually create function with LEN
! given by specification expression via function name,
! and SIZE given by specification expression via
! result name.
! g95 12/18/04: Error: Circular specification in variable 'r'.
! ISO/IEC 1539-1:1997(E) section 512.5.2.2:
! "If RESULT is specified, the name of the result variable
! of the function is result-name, its characteristics
! (12.2.2) are those of the function result, and..."
! Also from the same section:
! The type and type parameters (if any) of the result of the
! function subprogram may be specified by a type specification
! in the FUNCTION statement or by the name of the result variable
! appearing in a type statement in the declaration part of the
! function subprogram. It shall not be specified both ways."
! Also in section 7.1.6.2:
! "A restricted expression is one in which each operation is
! intrinsic and each primary is
! ...
! (7) A reference to an intrinsic function that is
! ...
! (c) the character inquiry function LEN,
! ...
! and where each primary of the function is
! ...
! (b) a variable whose properties inquired about are not
! (i) dependent on the upper bound of the last
! dimension of an assumed-shape array.
! (ii) defined by an expression that is not a
! restricted expression
! (iii) definable by an ALLOCATE or pointer
! assignment statement."
! So I think there is no problem with the specification of
! the function result attributes; g95 flunks.
! CVF 6.6C3: Error: This name does not have a type, and must
! have an explicit type. [R]
! Clearly R has a type here: the type and type parameters of
! the function result; CVF flunks.
! LF95 5.70f: Type parameters or bounds of variable r may
! not be inquired.
! Again, the type parameters, though not the bounds, of
! variable r may in fact be inquired; LF95 flunks.
module test1
implicit none
contains
character(f (x)) function test2 (x) result(r)
implicit integer (x)
dimension r(modulo (len (r) - 1, 3) + 1)
integer, intent(in) :: x
interface
pure function f (x)
integer, intent(in) :: x
integer f
end function f
end interface
integer i
do i = 1, len (r)
r(:)(i:i) = achar (mod (i, 32) + iachar ('@'))
end do
end function test2
end module test1
program test
use test1
implicit none
character(21) :: chr (3)
chr = "ABCDEFGHIJKLMNOPQRSTU"
if (len (test2 (10)) .ne. 21) call abort ()
if (any (test2 (10) .ne. chr)) call abort ()
end program test
pure function f (x)
integer, intent(in) :: x
integer f
f = 2*x+1
end function f
! { dg-final { cleanup-modules "test1" } }