[F-E, patch] patch for proc decls, bug fix.
Paul Thomas
paulthomas2@wanadoo.fr
Sat Jun 9 07:45:00 GMT 2007
Christopher,
Let's not go too quickly here:) - you obviously included something that
I did not and that was the C-binding for procedures. Did you get as far
as procedure pointers and their assignment? It is obvious that we have
taken different tilts at this and that they should be combined by
someone; I have cc'd Janus so that he marks your reverse patch. Maybe
you can help him with the combination?
In my opinion, it is a very good idea to separate out the introduction
of procedures. I am eager though that your contribution does not get
lost and that you get some of the credit.
Paul
> hi all,
>
> the attached patch is for the following:
> - removes the initial work i had done for proc decl stmts
> - fixes a bug with c_loc that was listed on the wiki
> - my patch from yesterday
>
> with the attached patch applied, the wiki can be updated to remove the
> bug listed for c_loc, and the bugs listed for the procedure
> declaration statements (procedure pointer snippets) since that code
> has been removed.
>
> bootstrapped and regtested on x86 with no new failures.
>
> ChangeLog entry:
> 2007-06-08 Christopher D. Rickett <crickett@lanl.gov>
> * symbol.c (check_conflict, gfc_copy_attr): Remove references to
> in_proc_decl attribute.
> (copy_formal_args): Removed because no longer necessary without
> procedure declaration code.
> * decl.c (verify_proc_decl_attrs, match_proc_decl,
> gfc_match_proc_decl_stmt): Removed code to match and verify
> procedure declarations.
> * gfortran.h: Removed in_proc_decl attribute from
> symbol_attribute. Removed prototype for copy_formal_args.
> * resolve.c (is_scalar_expr_ptr): Fixed bug with strings of length
> one as arguments to c_loc.
> * match.h: Removed prototype for gfc_match_proc_decl_stmt.
> * parse.c (decode_statement): Removed match for
> gfc_match_proc_decl_stmt.
> * gfortran.dg/c_loc_tests_6.f03: New test case for c_loc with
> character argument of length one.
> * gfortran.dg/c_loc_tests_8.f03: New test case for c_loc with
> character argument of length greater than one.
> * gfortran.dg/test_proc_stmt.f90: Remove test case.
> * gfortran.dg/proc_stmt_main.c: Remove driver for
> test_proc_stmt.f90.
> ------------------------------------------------------------------------
>
> Index: gcc/testsuite/gfortran.dg/test_proc_stmt.f90
> ===================================================================
> --- gcc/testsuite/gfortran.dg/test_proc_stmt.f90 (revision 125577)
> +++ gcc/testsuite/gfortran.dg/test_proc_stmt.f90 (working copy)
> @@ -1,103 +0,0 @@
> -! { dg-do run }
> -! { dg-additional-sources proc_stmt_main.c }
> -module testProcStmt
> - interface
> - subroutine copy() bind(c)
> - end subroutine copy
> -
> - subroutine copy2()
> - end subroutine copy2
> -
> - subroutine foo(x,y) bind(c)
> - use, intrinsic :: iso_c_binding
> - real(c_double) :: x
> - real(c_double) :: y
> - end subroutine foo
> -
> - subroutine foo2(x,y) bind(c)
> - use, intrinsic :: iso_c_binding
> - real(c_double), value :: x
> - real(c_double), value :: y
> - end subroutine foo2
> - end interface
> -
> -contains
> - subroutine testProcDecls() bind(c, name="testProcDecls")
> - use, intrinsic :: iso_c_binding
> -! this next line should work, and does as of 04.12.06
> -! procedure(copy), bind(c, name="myCopy") :: myCopy
> -! this line should also work. the binding label (since not given) is
> -! the name of the sym in all lowercase. the bind(c) is inherited from
> -! the interface defn of copy(). this is dependent on the mycopy/myCopy
> -! routine in the file procDecls.f90, because the binding label.
> -! this one works with the defn of myCopy that has no explicit label.
> -! the above proc decl of myCopy works with the explicitly labeled one.
> -! --Rickett, 04.12.06
> - procedure(copy) :: myCopy
> - ! this line should work. both are bind(c) with same "signature".
> - procedure(copy), bind(c) :: myCopy2
> - ! this next one is by default bind(c), since foo is bind(c)
> - procedure(foo) :: myFoo
> - ! this is bind(c) also, with by-value params
> - procedure(foo2) :: myFoo2
> - real(c_double) :: myX
> - real(c_double) :: myY
> -
> - call myCopy()
> -
> - call myCopy2()
> -
> - myX = 1.1d0
> - myY = 1.2d0
> - ! does not use myX and myY
> - call myFoo(myX, myY)
> - ! does not change myX and myY, because pass-by-value
> - call myFoo2(myX, myY)
> - if(myX .ne. 1.1d0) then
> - call abort()
> - endif
> - if(myY .ne. 1.2d0) then
> - call abort()
> - endif
> - end subroutine testProcDecls
> -end module testProcStmt
> -
> -subroutine myCopy() bind(c)
> - use, intrinsic :: iso_c_binding
> - interface
> - subroutine copy() bind(c)
> - end subroutine copy
> - end interface
> -
> - ! copy() is a C routine
> - call copy()
> -end subroutine myCopy
> -
> -subroutine myCopy2() bind(c)
> - use, intrinsic :: iso_c_binding
> - interface
> - subroutine copy() bind(c)
> - end subroutine copy
> - end interface
> -
> - ! copy() is a C routine
> - call copy()
> -end subroutine myCopy2
> -
> -subroutine myFoo(x, y) bind(c)
> - use, intrinsic :: iso_c_binding
> - real(c_double) :: x
> - real(c_double) :: y
> -
> -end subroutine myFoo
> -
> -subroutine myFoo2(x, y) bind(c)
> - use, intrinsic :: iso_c_binding
> - real(c_double), value :: x
> - real(c_double), value :: y
> -
> - ! x coming in is 1.1d0
> - x = x + 0.1d0
> - ! y coming in is 1.2d0
> - y = y + 0.1d0
> -end subroutine myFoo2
> Index: gcc/testsuite/gfortran.dg/c_loc_tests_6.f03
> ===================================================================
> --- gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 (revision 0)
> +++ gcc/testsuite/gfortran.dg/c_loc_tests_6.f03 (revision 0)
> @@ -0,0 +1,13 @@
> +! { dg-do compile }
> +! Verifies that the c_loc scalar pointer tests recognize the string of length
> +! one as being allowable for the parameter to c_loc.
> +module x
> +use iso_c_binding
> +contains
> +SUBROUTINE glutInit_f03()
> + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
> + CHARACTER(C_CHAR), DIMENSION(10), TARGET :: empty_string=C_NULL_CHAR
> + argv(1)=C_LOC(empty_string)
> +END SUBROUTINE
> +end module x
> +! { dg-final { cleanup-modules "x" } }
> Index: gcc/testsuite/gfortran.dg/c_loc_tests_8.f03
> ===================================================================
> --- gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 (revision 0)
> +++ gcc/testsuite/gfortran.dg/c_loc_tests_8.f03 (revision 0)
> @@ -0,0 +1,13 @@
> +! { dg-do compile }
> +! Verifies that the c_loc scalar pointer tests recognize the string of length
> +! greater than one as not being allowable for the parameter to c_loc.
> +module x
> +use iso_c_binding
> +contains
> +SUBROUTINE glutInit_f03()
> + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
> + character(kind=c_char, len=5), target :: string="hello"
> + argv(1)=C_LOC(string) ! { dg-error "must have a length of 1" }
> +END SUBROUTINE
> +end module x
> +
> Index: gcc/testsuite/gfortran.dg/bind_c_dts_3.f03
> ===================================================================
> --- gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 (revision 125577)
> +++ gcc/testsuite/gfortran.dg/bind_c_dts_3.f03 (working copy)
> @@ -3,6 +3,10 @@ module bind_c_dts_3
> use, intrinsic :: iso_c_binding
> implicit none
>
> +TYPE, bind(c) :: t
> + integer(c_int) :: i
> +end type t
> +
> type :: my_c_type_0 ! { dg-error "must have the BIND attribute" }
> integer(c_int) :: i
> end type my_c_type_0
> @@ -13,6 +17,14 @@ type, bind(c) :: my_c_type_1 ! { dg-erro
> integer(c_int), pointer :: j ! { dg-error "cannot have the POINTER" }
> end type my_c_type_1
>
> +type, bind(c) :: t2 ! { dg-error "BIND.C. derived type" }
> + type (t2), pointer :: next ! { dg-error "cannot have the POINTER" }
> +end type t2
> +
> +type, bind(c):: t3 ! { dg-error "BIND.C. derived type" }
> + type(t), allocatable :: c(:) ! { dg-error "cannot have the ALLOCATABLE" }
> +end type t3
> +
> contains
> subroutine sub0(my_type, expected_value) bind(c) ! { dg-error "is not C interoperable" }
> type(my_c_type_1) :: my_type
> Index: gcc/testsuite/gfortran.dg/proc_stmt_main.c
> ===================================================================
> --- gcc/testsuite/gfortran.dg/proc_stmt_main.c (revision 125577)
> +++ gcc/testsuite/gfortran.dg/proc_stmt_main.c (working copy)
> @@ -1,17 +0,0 @@
> -/* f90 routines */
> -void testProcDecls(void);
> -
> -/* c routines */
> -void copy(void);
> -
> -int main(int argc, char **argv)
> -{
> - testProcDecls();
> -
> - return 0;
> -}/* end main() */
> -
> -void copy(void)
> -{
> - return;
> -}/* end copy() */
> Index: gcc/fortran/trans-expr.c
> ===================================================================
> --- gcc/fortran/trans-expr.c (revision 125577)
> +++ gcc/fortran/trans-expr.c (working copy)
> @@ -2755,9 +2755,9 @@ gfc_conv_initializer (gfc_expr * expr, g
> return NULL_TREE;
>
> if (expr != NULL && expr->ts.type == BT_DERIVED
> - && expr->ts.is_iso_c && expr->ts.derived)
> - if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
> - || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
> + && expr->ts.is_iso_c && expr->ts.derived
> + && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
> + || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
> expr = gfc_int_expr (0);
>
> if (array)
> @@ -3159,8 +3159,8 @@ gfc_conv_expr (gfc_se * se, gfc_expr * e
> if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
> || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
> {
> - /* Try simply setting expr_type to EXPR_NULL, which should result
> - in null_pointer_node being used below. */
> + /* Set expr_type to EXPR_NULL, which will result in
> + null_pointer_node being used below. */
> expr->expr_type = EXPR_NULL;
> }
> else
> Index: gcc/fortran/symbol.c
> ===================================================================
> --- gcc/fortran/symbol.c (revision 125577)
> +++ gcc/fortran/symbol.c (working copy)
> @@ -27,6 +27,7 @@ Software Foundation, 51 Franklin Street,
> #include "gfortran.h"
> #include "parse.h"
>
> +
> /* Strings for all symbol attributes. We use these for dumping the
> parse tree, in error messages, and also when reading and writing
> modules. */
> @@ -397,8 +398,6 @@ check_conflict (symbol_attribute *attr,
> conf (dummy, save);
> conf (dummy, threadprivate);
> conf (pointer, target);
> - if (attr->in_proc_decl != 1)
> - conf (pointer, external);
> conf (pointer, intrinsic);
> conf (pointer, elemental);
> conf (allocatable, elemental);
> @@ -1523,8 +1522,6 @@ gfc_copy_attr (symbol_attribute *dest, s
> dest->is_c_interop = 1;
> if (src->is_iso_c)
> dest->is_iso_c = 1;
> - if (src->in_proc_decl)
> - dest->in_proc_decl = 1;
>
> return SUCCESS;
>
> @@ -3006,6 +3003,11 @@ verify_bind_c_derived_type (gfc_symbol *
> gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
> "unexpectedly NULL");
>
> + /* If we've already looked at this derived symbol, do not look at it again
> + so we don't repeat warnings/errors. */
> + if (derived_sym->ts.is_c_interop)
> + return SUCCESS;
> +
> /* The derived type must have the BIND attribute to be interoperable
> J3/04-007, Section 15.2.3. */
> if (derived_sym->attr.is_bind_c != 1)
> @@ -3035,10 +3037,34 @@ verify_bind_c_derived_type (gfc_symbol *
> each is a C interoperable type. */
> do
> {
> - /* BIND(C) derived types can't have derived types in them unless
> - they're c_ptr or c_funptr. J3/04-007, Section 15.2.3, C1502. */
> + /* The components cannot be pointers (fortran sense).
> + J3/04-007, Section 15.2.3, C1505. */
> + if (curr_comp->pointer != 0)
> + {
> + gfc_error ("Component '%s' at %L cannot have the "
> + "POINTER attribute because it is a member "
> + "of the BIND(C) derived type '%s' at %L",
> + curr_comp->name, &(curr_comp->loc),
> + derived_sym->name, &(derived_sym->declared_at));
> + retval = FAILURE;
> + }
> +
> + /* The components cannot be allocatable.
> + J3/04-007, Section 15.2.3, C1505. */
> + if (curr_comp->allocatable != 0)
> + {
> + gfc_error ("Component '%s' at %L cannot have the "
> + "ALLOCATABLE attribute because it is a member "
> + "of the BIND(C) derived type '%s' at %L",
> + curr_comp->name, &(curr_comp->loc),
> + derived_sym->name, &(derived_sym->declared_at));
> + retval = FAILURE;
> + }
> +
> + /* BIND(C) derived types must have interoperable components. */
> if (curr_comp->ts.type == BT_DERIVED
> - && curr_comp->ts.derived->ts.is_iso_c != 1)
> + && curr_comp->ts.derived->ts.is_iso_c != 1
> + && curr_comp->ts.derived != derived_sym)
> {
> /* This should be allowed; the draft says a derived-type can not
> have type parameters if it is has the BIND attribute. Type
> @@ -3080,30 +3106,6 @@ verify_bind_c_derived_type (gfc_symbol *
> curr_comp->name, derived_sym->name,
> &(curr_comp->loc));
> }
> -
> - /* The components can not be pointers (fortran sense).
> - J3/04-007, Section 15.2.3, C1505. */
> - if (curr_comp->pointer != 0)
> - {
> - gfc_error ("Component '%s' at %L cannot have the "
> - "POINTER attribute because it is a member "
> - "of the BIND(C) derived type '%s' at %L",
> - curr_comp->name, &(curr_comp->loc),
> - derived_sym->name, &(derived_sym->declared_at));
> - retval = FAILURE;
> - }
> -
> - /* The components can not be allocatable.
> - J3/04-007, Section 15.2.3, C1505. */
> - if (curr_comp->allocatable != 0)
> - {
> - gfc_error ("Component '%s' at %L cannot have the "
> - "ALLOCATABLE attribute because it is a member "
> - "of the BIND(C) derived type '%s' at %L",
> - curr_comp->name, &(curr_comp->loc),
> - derived_sym->name, &(derived_sym->declared_at));
> - retval = FAILURE;
> - }
> }
>
> curr_comp = curr_comp->next;
> @@ -3808,72 +3810,3 @@ get_iso_c_sym (gfc_symbol *old_sym, char
> return new_symtree->n.sym;
> }
>
> -
> -/* Copy the formal args from an existing symbol, src, into a new
> - symbol, dest. New formal args are created, and the description of
> - each arg is set according to the existing ones. This function is
> - used when creating procedure declaration variables from a procedure
> - declaration statement (see match_proc_decl()) to create the formal
> - args based on the args of a given named interface. */
> -
> -void
> -copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
> -{
> - gfc_formal_arglist *head = NULL;
> - gfc_formal_arglist *tail = NULL;
> - gfc_formal_arglist *formal_arg = NULL;
> - gfc_formal_arglist *curr_arg = NULL;
> - gfc_formal_arglist *formal_prev = NULL;
> - gfc_namespace *parent_ns = NULL;
> -
> - /* Save current namespace so we can change it for formal args. */
> - parent_ns = gfc_current_ns;
> -
> - /* Create a new namespace, which will be the formal ns (namespace
> - of the formal args). */
> - gfc_current_ns = gfc_get_namespace (parent_ns, 0);
> - gfc_current_ns->proc_name = dest;
> -
> - curr_arg = src->formal;
> - formal_prev = NULL;
> - while (curr_arg != NULL)
> - {
> - /* Allocate a new struct for the formal arg. */
> - formal_arg = gfc_get_formal_arglist ();
> -
> - /* Create symbol for the arg. */
> - gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
> -
> - /* May need to copy more info for the symbol. */
> - formal_arg->sym->attr = curr_arg->sym->attr;
> - formal_arg->sym->ts = curr_arg->sym->ts;
> -
> - /* If this isn't the first arg, set up the next ptr. For the
> - last arg built, the formal_arg->next will never get set to
> - anything other than NULL. */
> - formal_arg->next = NULL;
> - if (formal_prev != NULL)
> - formal_prev->next = formal_arg;
> - formal_prev = formal_arg;
> -
> - /* Add arg to list of formal args. */
> - add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
> -
> - /* Will reuse for any additional arg(s). */
> - formal_arg = NULL;
> -
> - /* Go to the next arg, if any. */
> - curr_arg = curr_arg->next;
> - }
> -
> - /* Add the interface to the symbol. */
> - add_proc_interface (dest, IFSRC_DECL, head);
> -
> - /* Store the formal namespace information. */
> - if (dest->formal != NULL)
> - /* The current ns should be that for the dest proc. */
> - dest->formal_ns = gfc_current_ns;
> -
> - /* Restore the current namespace to what it was on entry. */
> - gfc_current_ns = parent_ns;
> -}
> Index: gcc/fortran/decl.c
> ===================================================================
> --- gcc/fortran/decl.c (revision 125577)
> +++ gcc/fortran/decl.c (working copy)
> @@ -3131,204 +3131,6 @@ get_bind_c_idents (void)
> }
>
>
> -/* Verifies that if a variable in a procedure declaration statement is
> - BIND(C) then the procedure represented by the named interface in
> - the statement also is. If the user specifies the procedure in the
> - declaration as BIND(C) but the provided named interface is not to a
> - BIND(C) routine, then it is an error. The error will be reported
> - here. */
> -
> -static try
> -verify_proc_decl_attrs (gfc_symbol *proc_sym, gfc_symbol *int_sym)
> -{
> - /* The only case where these would not be equal would be if the
> - proc_sym is bind(c) but the interface one is not. This is because
> - the proc_sym inherits properties from the interface. So, the only
> - error would arise if the interface proc was not bind(c), but the
> - user explicitly makes the proc decl sym bind(c). */
> - if (proc_sym->attr.is_bind_c != int_sym->attr.is_bind_c)
> - {
> - gfc_error ("Procedure '%s' at %C can not be bind(c) because "
> - "procedure '%s' at %L is not bind(c)", proc_sym->name,
> - int_sym->name, &int_sym->declared_at);
> - return FAILURE;
> - }
> -
> - /* If we get here, no errors reported. */
> - return SUCCESS;
> -}
> -
> -
> -/* Match a procedure declaration statement, creating symbols for the
> - given variables. Currently, this function expects a named
> - interface to be given to describe the formal args and return type
> - of the variables, though the draft does not require this. This is
> - a very initial start to the function (read: very little completed).
> - Some error checking is done to make sure a named interface is given
> - and is complete enough, there aren't attribute conflicts (for the
> - attributes tested -- incomplete), the binding labels can be set
> - correctly, etc. The errors are reported here, and passed back to
> - the calling function. Returns MATCH_ERROR if an error was
> - encountered; MATCH_YES if the procedure declaration statement was
> - valid (based on what can be handled so far). If the initial test
> - for the keyword 'procedure' failed, the return status of that
> - matching routine is returned. */
> -
> -static match
> -match_proc_decl (void)
> -{
> - match proc_decl = MATCH_NO;
> - char int_name[GFC_MAX_SYMBOL_LEN + 1];
> - char proc_name[GFC_MAX_SYMBOL_LEN + 1];
> - gfc_symtree *int_symtree = NULL;
> - gfc_symbol *new_proc_sym = NULL;
> - int is_sub = 0;
> - int num_idents = 0;
> - int i = 0;
> - char *src_attr;
> - char *dest_attr;
> -
> - proc_decl = gfc_match (" procedure ");
> -
> - /* TODO: much more work to do here, such as matching attributes,
> - interface name, etc. */
> -
> - if (proc_decl != MATCH_YES)
> - return proc_decl;
> -
> - /* Get the optional procedure interface now. The parens seem required
> - (looking at the grammar), but the interface is not. */
> - proc_decl = gfc_match_char ('(');
> - /* Get the optional name. if this fails, it's ok as long as
> - nothing is between the parens. */
> - gfc_match_name (int_name);
> - if (proc_decl == MATCH_ERROR || gfc_match_char (')') != MATCH_YES)
> - {
> - gfc_error ("Syntax error in procedure declaration statement at %C");
> - return MATCH_ERROR;
> - }
> -
> - /* Get the symbol for the procedure that defines the interface
> - of the declared proc(s). Don't check for nonzero return, because
> - if the procedure used as an interface is ambiguous, it should have
> - been caught elsewhere. */
> - gfc_find_sym_tree (int_name, gfc_current_ns, 1, &int_symtree);
> - if (int_symtree == NULL)
> - {
> - gfc_error ("Procedure '%s' used in procedure declaration statement"
> - " at %C has not been defined", int_name);
> - return MATCH_ERROR;
> - }
> -
> - /* Store whether it's a function or subroutine, though we may not know if
> - it is either. */
> - is_sub = int_symtree->n.sym->attr.subroutine;
> - /* Make sure the symbol we have is for a sub or func, for now. */
> - if (is_sub != 1 && int_symtree->n.sym->attr.function != 1)
> - {
> - gfc_error ("Symbol '%s' at %C must be either a subroutine or "
> - "function", int_name);
> - return MATCH_ERROR;
> - }
> -
> - /* If the interface is BIND(C), we could inherit that attribute without
> - specifying it in the procedure declaration. This could prevent the
> - gfc_match_bind_c from being called, so we need to clear the
> - has_name_equals flag ourselves. */
> - /* TODO: what happens if the interface we're using in the procedure
> - declaration has a NAME= specifier that is not NAME=""? */
> - if (int_symtree->n.sym->attr.is_bind_c)
> - has_name_equals = 0;
> -
> - /* Try and match attributes. We will match any attr here, and
> - report conflicts as we find them.
> - TODO: make sure all conflicts are caught. */
> - /* This will say we're declaring the sym from a proc decl stmt, so
> - we can catch conflicts. */
> - match_attr_spec ();
> - current_attr.in_proc_decl = 1;
> -
> - gfc_match (" :: ");
> -
> - /* Get the proc decl list. */
> - do
> - {
> - /* Initialize to NULL. Will reuse the pointer for all proc(s). */
> - new_proc_sym = NULL;
> - /* Initialized to 0. */
> - num_idents++;
> -
> - if (gfc_match_name (proc_name) != MATCH_YES)
> - return MATCH_ERROR;
> -
> - /* Create the symbol for the procedure of this name. */
> - if (get_proc_name (proc_name, &new_proc_sym, false))
> - /* A nonzero return value means error, but the message should
> - have been handled by the get_proc_name, so just return. */
> - return MATCH_ERROR;
> -
> - /* Copy the attr and typespecs. These are an or of what the
> - user lists, and what is defined for the interface proc. */
> - new_proc_sym->attr = int_symtree->n.sym->attr;
> - new_proc_sym->ts = int_symtree->n.sym->ts;
> - src_attr = (char *) (&(current_attr));
> - dest_attr = (char *) (&(new_proc_sym->attr));
> - for (i = 0; i < (int) sizeof (new_proc_sym->attr); i++)
> - {
> - *dest_attr = (*dest_attr) | (*src_attr);
> - dest_attr++;
> - src_attr++;
> - }
> -
> - /* Or necessary current_ts info with ts from interface proc. */
> - new_proc_sym->ts.is_c_interop |= current_ts.is_c_interop;
> - new_proc_sym->ts.f90_type |= current_ts.f90_type;
> -
> - /* All procedure decls refer to external procedures (this may
> - not be right to do if it's a proc pointer.). */
> - new_proc_sym->attr.external = 1;
> - /* We have the symbol for the new procedure, so set up the
> - properties such as formal args, sub/func flag, etc. */
> - if (is_sub == 1)
> - gfc_add_subroutine (&(new_proc_sym->attr), proc_name,
> - &gfc_current_locus);
> - else
> - gfc_add_function (&(new_proc_sym->attr), proc_name,
> - &gfc_current_locus);
> -
> - /* If the binding label has been set in the sym, that means the
> - sym was made before now, so leave the binding label alone.
> - If it's not set yet, and the sym is bind(c), set it to the sym name
> - in all lowercase letters for now. */
> - if (set_binding_label (new_proc_sym->binding_label, new_proc_sym->name,
> - num_idents) != SUCCESS)
> - return MATCH_ERROR;
> -
> - /* Copy the formal arg list (params are: (dest, src)). */
> - copy_formal_args (new_proc_sym, int_symtree->n.sym);
> -
> - /* Verify the proc decl attributes with the interface's attrs. */
> - if (verify_proc_decl_attrs (new_proc_sym, int_symtree->n.sym)
> - != SUCCESS)
> - /* Error messages will have already been printed. */
> - return MATCH_ERROR;
> - } while (gfc_match_char (',') == MATCH_YES);
> -
> - /* Make sure we match the eos now. */
> - if (gfc_match_eos () != MATCH_YES)
> - return MATCH_ERROR;
> -
> - /* Now that we know we successfully matched a proc decl, make
> - sure the user didn't specify a standard that doesn't allow them. */
> - if (gfc_notify_std (GFC_STD_F2003,
> - "Fortran 2003: procedure declaration "
> - "statement at %C") == FAILURE)
> - return MATCH_ERROR;
> -
> - return proc_decl;
> -}
> -
> -
> /* Try and match a BIND(C) attribute specification statement. */
>
> match
> @@ -3366,29 +3168,6 @@ gfc_match_bind_c_stmt (void)
> }
>
>
> -/* Try to match a PROCEDURE declaration statement.
> - TODO: Handling of procedure declarations is nowhere near complete! */
> -
> -match
> -gfc_match_proc_decl_stmt (void)
> -{
> - match found_match = MATCH_NO;
> - gfc_typespec *ts;
> -
> - ts = ¤t_ts;
> -
> - /* This may not be necessary. */
> - gfc_clear_ts (ts);
> - /* Clear the temporary binding label holder. */
> - curr_binding_label[0] = '\0';
> -
> - /* Look for procedure decl stmt. */
> - found_match = match_proc_decl ();
> -
> - return found_match;
> -}
> -
> -
> /* Match a data declaration statement. */
>
> match
> Index: gcc/fortran/gfortran.h
> ===================================================================
> --- gcc/fortran/gfortran.h (revision 125577)
> +++ gcc/fortran/gfortran.h (working copy)
> @@ -641,7 +641,6 @@ typedef struct
> is created from a decl being processed. */
> unsigned is_c_interop:1; /* It's c interoperable. */
> unsigned is_iso_c:1; /* Symbol is from iso_c_binding. */
> - unsigned in_proc_decl:1; /* Symbol is from a proc decl stmt. */
>
> /* Function/subroutine attributes */
> unsigned sequence:1, elemental:1, pure:1, recursive:1;
> @@ -2120,7 +2119,6 @@ try verify_bind_c_derived_type (gfc_symb
> try verify_com_block_vars_c_interop (gfc_common_head *);
> void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, char *);
> gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, char *, int);
> -void copy_formal_args (gfc_symbol *, gfc_symbol *);
> int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **);
> int gfc_get_ha_symbol (const char *, gfc_symbol **);
> int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
> Index: gcc/fortran/resolve.c
> ===================================================================
> --- gcc/fortran/resolve.c (revision 125577)
> +++ gcc/fortran/resolve.c (working copy)
> @@ -1588,6 +1588,18 @@ is_scalar_expr_ptr (gfc_expr *expr)
> && ref->u.ar.as->upper[0] != NULL
> && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
> {
> + /* If we have a character string, we need to check if
> + its length is one. */
> + if (expr->ts.type == BT_CHARACTER)
> + {
> + if (expr->ts.cl == NULL
> + || expr->ts.cl->length == NULL
> + || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
> + != 0)
> + retval = FAILURE;
> + }
> + else
> + {
> /* We have constant lower and upper bounds. If the
> difference between is 1, it can be considered a
> scalar. */
> @@ -1598,6 +1610,7 @@ is_scalar_expr_ptr (gfc_expr *expr)
> if (end - start + 1 != 1)
> retval = FAILURE;
> }
> + }
> else
> retval = FAILURE;
> }
> Index: gcc/fortran/match.h
> ===================================================================
> --- gcc/fortran/match.h (revision 125577)
> +++ gcc/fortran/match.h (working copy)
> @@ -173,7 +173,6 @@ try set_verify_bind_c_sym (gfc_symbol *,
> try set_verify_bind_c_com_block (gfc_common_head *, int);
> try get_bind_c_idents (void);
> match gfc_match_bind_c_stmt (void);
> -match gfc_match_proc_decl_stmt (void);
> match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
> match gfc_match_bind_c (gfc_symbol *);
> match gfc_get_type_attr_spec (symbol_attribute *);
> Index: gcc/fortran/parse.c
> ===================================================================
> --- gcc/fortran/parse.c (revision 125577)
> +++ gcc/fortran/parse.c (working copy)
> @@ -261,7 +261,6 @@ decode_statement (void)
> if (gfc_match_public (&st) == MATCH_YES)
> return st;
> match ("protected", gfc_match_protected, ST_ATTR_DECL);
> - match (NULL, gfc_match_proc_decl_stmt, ST_ATTR_DECL);
> break;
>
> case 'r':
>
More information about the Fortran
mailing list