+2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
+
+ PR fortran/32797
+ PR fortran/32800
+ * decl.c (verify_bind_c_sym): Use the result symbol for functions
+ with a result clause. Warn if implicitly typed. Verify the type
+ and rank of the SHAPE argument, if given.
+ * resolve.c (gfc_iso_c_sub_interface): Use gfc_procedure_use to
+ check the actual args against the formal, sorting them if
+ necessary.
+ * symbol.c (gen_shape_param): Initialize type of SHAPE param to
+ BT_VOID.
+
2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
PR fortran/32732
int is_in_common, gfc_common_head *com_block)
{
try retval = SUCCESS;
+
+ if (tmp_sym->attr.function && tmp_sym->result != NULL)
+ {
+ tmp_sym = tmp_sym->result;
+ /* Make sure it wasn't an implicitly typed result. */
+ if (tmp_sym->attr.implicit_type)
+ {
+ gfc_warning ("Implicitly declared BIND(C) function '%s' at "
+ "%L may not be C interoperable", tmp_sym->name,
+ &tmp_sym->declared_at);
+ tmp_sym->ts.f90_type = tmp_sym->ts.type;
+ /* Mark it as C interoperable to prevent duplicate warnings. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->attr.is_c_interop = 1;
+ }
+ }
/* Here, we know we have the bind(c) attribute, so if we have
enough type info, then verify that it's a C interop kind.
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
/* default to success; will override if find error */
match m = MATCH_YES;
- gfc_symbol *tmp_sym;
+
+ /* Make sure the actual arguments are in the necessary order (based on the
+ formal args) before resolving. */
+ gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
+
+ /* Give the optional SHAPE formal arg a type now that we've done our
+ initial checking against the actual. */
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ sym->formal->next->next->sym->ts.type = BT_INTEGER;
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
if (c->ext.actual != NULL && c->ext.actual->next != NULL)
{
- /* Make sure we got a third arg. The type/rank of it will
- be checked later if it's there (gfc_procedure_use()). */
- if (c->ext.actual->next->expr->rank != 0 &&
- c->ext.actual->next->next == NULL)
+ /* Make sure we got a third arg if the second arg has non-zero
+ rank. We must also check that the type and rank are
+ correct since we short-circuit this check in
+ gfc_procedure_use() (called above to sort actual args). */
+ if (c->ext.actual->next->expr->rank != 0)
{
- m = MATCH_ERROR;
- gfc_error ("Missing SHAPE parameter for call to %s "
- "at %L", sym->name, &(c->loc));
+ if(c->ext.actual->next->next == NULL
+ || c->ext.actual->next->next->expr == NULL)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Missing SHAPE parameter for call to %s "
+ "at %L", sym->name, &(c->loc));
+ }
+ else if (c->ext.actual->next->next->expr->ts.type
+ != BT_INTEGER
+ || c->ext.actual->next->next->expr->rank != 1)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("SHAPE parameter for call to %s at %L must "
+ "be a rank 1 INTEGER array", sym->name,
+ &(c->loc));
+ }
}
- /* Make sure the param is a POINTER. No need to make sure
- it does not have INTENT(IN) since it is a POINTER. */
- tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
- if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
- {
- gfc_error ("Argument '%s' to '%s' at %L "
- "must have the POINTER attribute",
- tmp_sym->name, sym->name, &(c->loc));
- m = MATCH_ERROR;
- }
}
}
/* set the resolved symbol */
if (m != MATCH_ERROR)
- {
- gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
- c->resolved_sym = new_sym;
- }
+ c->resolved_sym = new_sym;
else
c->resolved_sym = sym;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
- /* Integer array, rank 1, describing the shape of the object. */
- param_sym->ts.type = BT_INTEGER;
+ /* Integer array, rank 1, describing the shape of the object. Make it's
+ type BT_VOID initially so we can accept any type/kind combination of
+ integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
+ of BT_INTEGER type. */
+ param_sym->ts.type = BT_VOID;
+
/* Initialize the kind to default integer. However, it will be overriden
during resolution to match the kind of the SHAPE parameter given as
the actual argument (to allow for any valid integer kind). */
+2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
+
+ PR fortran/32797
+ PR fortran/32800
+ * gfortran.dg/bind_c_usage_8.f03: New test case.
+ * gfortran.dg/c_f_pointer_tests_2.f03: Ditto.
+ * gfortran.dg/c_ptr_tests_5.f03: Updated expected error message.
+
2007-07-23 Richard Sandiford <richard@codesourcery.com>
* gcc.target/mips/branch-cost-1.c: New test.
--- /dev/null
+! { dg-do compile }
+! This should compile, though there is a warning about the type of len
+! (return variable of strlen()) for being implicit.
+! PR fortran/32797
+!
+MODULE ISO_C_UTILITIES
+ USE ISO_C_BINDING
+ implicit none
+ CHARACTER(C_CHAR), DIMENSION(1), SAVE, TARGET, PRIVATE :: dummy_string="?"
+CONTAINS
+ FUNCTION C_F_STRING(CPTR) RESULT(FPTR)
+ use, intrinsic :: iso_c_binding
+ TYPE(C_PTR), INTENT(IN) :: CPTR ! The C address
+ CHARACTER(KIND=C_CHAR), DIMENSION(:), POINTER :: FPTR
+ INTERFACE
+ FUNCTION strlen(string) RESULT(len) BIND(C,NAME="strlen") ! { dg-warning "Implicitly declared" }
+ USE ISO_C_BINDING
+ TYPE(C_PTR), VALUE :: string ! A C pointer
+ END FUNCTION
+ END INTERFACE
+ CALL C_F_POINTER(FPTR=FPTR, CPTR=CPTR, SHAPE=[strlen(CPTR)])
+ END FUNCTION
+END MODULE ISO_C_UTILITIES
+! { dg-final { cleanup-modules "iso_c_utilities" } }
+
--- /dev/null
+! { dg-do compile }
+! This should compile. There was a bug in resolving c_f_pointer that was
+! caused by not sorting the actual args to match the order of the formal args.
+! PR fortran/32800
+!
+FUNCTION C_F_STRING(CPTR) RESULT(FPTR)
+ USE ISO_C_BINDING
+ implicit none
+ TYPE(C_PTR), INTENT(IN) :: CPTR ! The C address
+ CHARACTER(KIND=C_CHAR), DIMENSION(:), POINTER :: FPTR
+ INTERFACE
+ FUNCTION strlen(string) RESULT(len) BIND(C,NAME="strlen")
+ import
+ TYPE(C_PTR), VALUE :: string ! A C pointer
+ integer(c_int) :: len
+ END FUNCTION strlen
+ END INTERFACE
+ CALL C_F_POINTER(FPTR=FPTR, CPTR=CPTR,SHAPE=[strlen(cptr)])
+END FUNCTION C_F_STRING
+
type(c_ptr), value :: c_struct
type(my_f90_type) :: f90_type
- call c_f_pointer(c_struct, f90_type) ! { dg-error "must have the POINTER" }
+ call c_f_pointer(c_struct, f90_type) ! { dg-error "must be a pointer" }
end subroutine sub0
end module c_ptr_tests_5
projects / gcc.git / commitdiff