This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Patch to gfortran PR13433
- From: Victor Leikehman <LEI at il dot ibm dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Sun, 15 Feb 2004 13:40:40 +0200
- Subject: Patch to gfortran PR13433
This patch fixes gfortran/13433 aka "ICE in assumed-length
character function".
(http://gcc.gnu.org/bugzilla/show_bug.cgi?id=13433)
For functions returning CHARACTER, calling conventions
changed to comply with g77.
Follows an example that used to trigger the ICE;
now prints HELLO WORLD as expected.
CHARACTER*11 FUNCTION G()
G = "HELLO"
END
CHARACTER*(*) FUNCTION F()
F = "WORLD"
END
PROGRAM MAIN
CHARACTER*5 F,G
PRINT*, G(), ' ', F()
END
Victor
--
Victor Leikehman
IBM Research Lab in Haifa, Israel
Index: ChangeLogfortran/ChangeLog,v
retrieving revision 1.1.1.2
diff -c -p -r1.1.1.2 ChangeLog
*** ChangeLog 15 Feb 2004 09:30:05 -0000 1.1.1.2
--- ChangeLog 15 Feb 2004 11:09:47 -0000
***************
*** 1,3 ****
--- 1,12 ----
+ 2004-02-15 Victor Leikehman <lei@il.ibm.com>
+
+ PR gfortran/13433
+ * trans-decl.c (gfc_build_function_decl) For functions
+ returning CHARACTER*(*) pass an extra length argument,
+ following g77 calling conventions.
+ * trans-types.c (gfc_get_function_type) Ditto.
+ * trans-expr.c (gfc_conv_function_call) Ditto.
+
2004-02-12 Paul Brook <paul@nowt.org>
* BUGS: Remove.
Index: trans-decl.c
===================================================================
RCS file: /home/lei/cvsroot/fortran/trans-decl.c,v
retrieving revision 1.4
diff -c -p -r1.4 trans-decl.c
*** trans-decl.c 12 Feb 2004 06:40:56 -0000 1.4
--- trans-decl.c 15 Feb 2004 10:52:04 -0000
*************** gfc_build_function_decl (gfc_symbol * sy
*** 1025,1045 ****
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
! if (sym->ts.type == BT_CHARACTER)
{
gfc_allocate_lang_decl (parm);
GFC_DECL_STRING (parm) = 1;
! assert (sym->ts.cl && sym->ts.cl->length
! && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
! GFC_DECL_STRING_LENGTH (parm) =
! gfc_conv_mpz_to_tree (sym->ts.cl->length->value.integer, 4);
!
}
- gfc_finish_decl (parm, NULL_TREE);
-
- arglist = chainon (arglist, parm);
- typelist = TREE_CHAIN (typelist);
}
for (f = sym->formal; f; f = f->next)
--- 1025,1062 ----
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
! gfc_finish_decl (parm, NULL_TREE);
!
! arglist = chainon (arglist, parm);
! typelist = TREE_CHAIN (typelist);
!
! if (sym->ts.type == BT_CHARACTER)
{
gfc_allocate_lang_decl (parm);
GFC_DECL_STRING (parm) = 1;
+
+ /* Length of character result */
+ type = TREE_VALUE (typelist);
+ assert (type == gfc_strlen_type_node);
+ length = build_decl (PARM_DECL, get_identifier (".__result"),
type);
+ arglist = chainon (arglist, length);
+ typelist = TREE_CHAIN (typelist);
+ DECL_CONTEXT (length) = fndecl;
+ DECL_ARG_TYPE (length) = type;
+ TREE_READONLY (length) = 1;
+ gfc_finish_decl (length, NULL_TREE);
! if (sym->ts.cl
! && sym->ts.cl->length
! && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
! {
! length = gfc_conv_mpz_to_tree (
! sym->ts.cl->length->value.integer, 4);
! }
! else
! TREE_USED (length) = 1;
! GFC_DECL_STRING_LENGTH (parm) = length;
}
}
for (f = sym->formal; f; f = f->next)
Index: trans-expr.c
===================================================================
RCS file: /home/lei/cvsroot/fortran/trans-expr.c,v
retrieving revision 1.1.1.1
diff -c -p -r1.1.1.1 trans-expr.c
*** trans-expr.c 4 Feb 2004 11:42:50 -0000 1.1.1.1
--- trans-expr.c 15 Feb 2004 10:54:21 -0000
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1008,1013 ****
--- 1008,1016 ----
var = gfc_conv_string_tmp (se, type, len);
arglist = gfc_chainon_list (arglist, var);
+
+ arglist = gfc_chainon_list (arglist,
+ convert (gfc_strlen_type_node, len));
}
else /* TODO: derived type function return values. */
abort ();
Index: trans-types.c
===================================================================
RCS file: /home/lei/cvsroot/fortran/trans-types.c,v
retrieving revision 1.3
diff -c -p -r1.3 trans-types.c
*** trans-types.c 12 Feb 2004 06:41:08 -0000 1.3
--- trans-types.c 15 Feb 2004 10:55:01 -0000
*************** gfc_get_function_type (gfc_symbol * sym)
*** 1151,1156 ****
--- 1151,1158 ----
if (arg->ts.type == BT_DERIVED || arg->attr.dimension)
type = build_reference_type (type);
typelist = gfc_chainon_list (typelist, type);
+ if (arg->ts.type == BT_CHARACTER)
+ typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
}
/* Build the argument types for the function */