This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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 */


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]