[gfortran] String intrinsics

[Paul Brook <paul at nowt dot org>]

The attached patch implements the TRIM and REPEAT intrinsic functions. It 
also fixes the LEN intrinsic.

Applied to tree-ssa branch.

Paul

2003-10-11  Huang Chun  <jiwang@mail.edu.cn>

	* check.c (gfc_check_repeat): Check arguments are scalar.
	(gfc_check_trim): New function.
	* intrinsic.h (gfc_check_trim): Add prototype.
	* intrinsic.c (add_functions): Use it.
	* trans.h (gfor_fndecl_string_trim, gfor_fndecl_string_repeat):
	Decalare.
	* trans-decl.c: Ditto.
	(gfc_build_intrinsic_fucntion_decls): Set them.
	* trans-intrinsic.c (gfc_conv_intrinsic_len): Handle result vars.
	(gfc_conv_intrinsic_trim): New function.
	(gfc_conv_intrinsic_repeat): New function.
	(gfc_conv_intrinsic_function): Use them.
libgfortran
	* intrinsics/string_intrinsics.c (string_trim): New function.
	(string_repeat): New function.
testsuite
	* gfortran.fortran-torture/execute/intrinsic_len.f90: New test.
	* gfortran.fortran-torture/execute/intrinsic_trim.f90: New test.

diff -uprxCVS clean/tree-ssa/gcc/fortran/check.c gcc/gcc/fortran/check.c
--- clean/tree-ssa/gcc/fortran/check.c	2003-09-14 18:08:25.000000000 +0100
+++ gcc/gcc/fortran/check.c	2003-10-11 22:42:44.000000000 +0100
@@ -1352,9 +1352,15 @@ gfc_check_repeat (gfc_expr * x, gfc_expr
   if (type_check (x, 0, BT_CHARACTER) == FAILURE)
     return FAILURE;
 
+  if (scalar_check (x, 0) == FAILURE)
+    return FAILURE;
+
   if (type_check (y, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
 
+  if (scalar_check (y, 1) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -1667,6 +1673,19 @@ gfc_check_verify (gfc_expr * x, gfc_expr
 }
 
 
+try
+gfc_check_trim (gfc_expr * x)
+{
+  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
+    return FAILURE;
+
+  if (scalar_check (x, 0) == FAILURE)
+    return FAILURE;
+
+   return SUCCESS;
+}
+
+
 /* Common check function for the half a dozen intrinsics that have a
    single real argument.  */
 
diff -uprxCVS clean/tree-ssa/gcc/fortran/intrinsic.c gcc/gcc/fortran/intrinsic.c
--- clean/tree-ssa/gcc/fortran/intrinsic.c	2003-10-11 20:18:36.000000000 +0100
+++ gcc/gcc/fortran/intrinsic.c	2003-10-11 22:36:49.000000000 +0100
@@ -1552,7 +1552,7 @@ add_functions (void)
   make_generic ("transpose", GFC_ISYM_TRANSPOSE);
 
   add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc,
-	     NULL, gfc_simplify_trim, gfc_resolve_trim,
+	     gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
 	     stg, BT_CHARACTER, dc, 0);
 
   make_generic ("trim", GFC_ISYM_TRIM);
diff -uprxCVS clean/tree-ssa/gcc/fortran/intrinsic.h gcc/gcc/fortran/intrinsic.h
--- clean/tree-ssa/gcc/fortran/intrinsic.h	2003-10-11 20:18:36.000000000 +0100
+++ gcc/gcc/fortran/intrinsic.h	2003-10-11 23:11:58.000000000 +0100
@@ -90,6 +90,7 @@ try gfc_check_spread (gfc_expr *, gfc_ex
 try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_transpose (gfc_expr *);
+try gfc_check_trim (gfc_expr *);
 try gfc_check_ubound (gfc_expr *, gfc_expr *);
 try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *);
diff -uprxCVS clean/tree-ssa/gcc/fortran/trans-decl.c gcc/gcc/fortran/trans-decl.c
--- clean/tree-ssa/gcc/fortran/trans-decl.c	2003-10-11 20:18:36.000000000 +0100
+++ gcc/gcc/fortran/trans-decl.c	2003-10-11 22:36:49.000000000 +0100
@@ -116,6 +116,8 @@ tree gfor_fndecl_string_len_trim;
 tree gfor_fndecl_string_index;
 tree gfor_fndecl_string_scan;
 tree gfor_fndecl_string_verify;
+tree gfor_fndecl_string_trim;
+tree gfor_fndecl_string_repeat;
 tree gfor_fndecl_adjustl;
 tree gfor_fndecl_adjustr;
 
@@ -1286,6 +1288,24 @@ gfc_build_intrinsic_function_decls (void
                                      gfc_strlen_type_node, pchar_type_node,
                                      gfc_logical4_type_node);
 
+  gfor_fndecl_string_trim = 
+    gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
+                                     void_type_node,
+                                     4,
+                                     build_pointer_type (gfc_strlen_type_node),
+                                     ppvoid_type_node,
+                                     gfc_strlen_type_node,
+                                     pchar_type_node);
+
+  gfor_fndecl_string_repeat =
+    gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
+                                     void_type_node,
+                                     4,
+                                     pchar_type_node,
+                                     gfc_strlen_type_node,
+                                     pchar_type_node,
+                                     gfc_int4_type_node);
+
   gfor_fndecl_adjustl =
     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
 				     void_type_node,
diff -uprxCVS clean/tree-ssa/gcc/fortran/trans-intrinsic.c gcc/gcc/fortran/trans-intrinsic.c
--- clean/tree-ssa/gcc/fortran/trans-intrinsic.c	2003-10-11 21:59:38.000000000 +0100
+++ gcc/gcc/fortran/trans-intrinsic.c	2003-10-11 22:43:33.000000000 +0100
@@ -1773,6 +1773,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc
   tree len;
   tree type;
   tree decl;
+  gfc_symbol *sym;
   gfc_se argse;
   gfc_expr *arg;
 
@@ -1784,7 +1785,14 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc
   switch (arg->expr_type)
     {
     case EXPR_VARIABLE:
-      decl = gfc_get_symbol_decl (arg->symtree->n.sym);
+      sym = arg->symtree->n.sym;
+      decl = gfc_get_symbol_decl (sym);
+      if (decl == current_function_decl && sym->attr.function
+            && (sym->result == sym))
+        {
+          decl = gfc_get_fake_result_decl (sym);
+        }
+
       assert (GFC_DECL_STRING (decl));
       len = GFC_DECL_STRING_LENGTH (decl);
       assert (len);
@@ -2965,6 +2973,79 @@ gfc_conv_intrinsic_sr_kind (gfc_se * se,
 }
 
 
+/* Generate code for TRIM (A) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
+{
+  tree var;
+  tree len;
+  tree addr;
+  tree tmp;
+  tree arglist;
+  tree type;
+  tree cond;
+
+  arglist = NULL_TREE;
+
+  type = build_pointer_type (gfc_character1_type_node);
+  var = gfc_create_var (type, "pstr");
+  addr = build1 (ADDR_EXPR, ppvoid_type_node, var);
+  len = gfc_create_var (gfc_int4_type_node, "len");
+
+  tmp = gfc_conv_intrinsic_function_args (se, expr);
+  arglist = gfc_chainon_list (arglist, build1 (ADDR_EXPR, 
+	build_pointer_type(TREE_TYPE(len)), len));
+  arglist = gfc_chainon_list (arglist, addr);
+  arglist = chainon (arglist, tmp);
+  
+  tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
+  arglist = gfc_chainon_list (NULL_TREE, addr);
+  tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
+  tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
+/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
+
+static void
+gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
+{
+  tree tmp;
+  tree len;
+  tree args;
+  tree arglist;
+  tree ncopies;
+  tree var;
+  tree type;
+
+  args = gfc_conv_intrinsic_function_args (se, expr);
+  len = TREE_VALUE (args);
+  tmp = gfc_advance_chain (args, 2);
+  ncopies = TREE_VALUE (tmp);
+  len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies));
+  type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+  var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
+
+  arglist = NULL_TREE;
+  arglist = gfc_chainon_list (arglist, var);
+  arglist = chainon (arglist, args);
+  tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
 /* Generate code for an intrinsic function.  Some map directly to library
    calls, others get special handling.  In some cases the name of the function
    used depends on the type specifiers.  */
@@ -2998,9 +3079,15 @@ gfc_conv_intrinsic_function (gfc_se * se
       abort ();
 
     case GFC_ISYM_CSHIFT:
+      gfc_todo_error ("Intrinsic %s", expr->value.function.name);
+
     case GFC_ISYM_REPEAT:
+      gfc_conv_intrinsic_repeat (se, expr);
+      break;
+
     case GFC_ISYM_TRIM:
-      gfc_todo_error ("Intrinsic %s", expr->value.function.name);
+      gfc_conv_intrinsic_trim (se, expr);
+      break;
 
     case GFC_ISYM_SI_KIND:
       gfc_conv_intrinsic_si_kind (se, expr);
diff -uprxCVS clean/tree-ssa/gcc/fortran/trans.h gcc/gcc/fortran/trans.h
--- clean/tree-ssa/gcc/fortran/trans.h	2003-09-21 15:30:23.000000000 +0100
+++ gcc/gcc/fortran/trans.h	2003-10-11 22:36:49.000000000 +0100
@@ -447,6 +447,8 @@ extern GTY(()) tree gfor_fndecl_string_l
 extern GTY(()) tree gfor_fndecl_string_index;
 extern GTY(()) tree gfor_fndecl_string_scan;
 extern GTY(()) tree gfor_fndecl_string_verify;
+extern GTY(()) tree gfor_fndecl_string_trim;
+extern GTY(()) tree gfor_fndecl_string_repeat;
 extern GTY(()) tree gfor_fndecl_adjustl;
 extern GTY(()) tree gfor_fndecl_adjustr;
 
diff -uprxCVS clean/tree-ssa/libgfortran/intrinsics/string_intrinsics.c gcc/libgfortran/intrinsics/string_intrinsics.c
--- clean/tree-ssa/libgfortran/intrinsics/string_intrinsics.c	2003-09-19 20:04:42.000000000 +0100
+++ gcc/libgfortran/intrinsics/string_intrinsics.c	2003-10-11 23:55:09.000000000 +0100
@@ -64,6 +64,11 @@ GFC_INTEGER_4 string_scan (GFC_INTEGER_4
 GFC_INTEGER_4 string_verify (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
                              const char *, GFC_LOGICAL_4);
 
+#define string_trim prefix(string_trim)
+void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *);
+
+#define string_repeat prefix(string_repeat)
+void string_repeat (char *, GFC_INTEGER_4, const char *, GFC_INTEGER_4);
 
 /* The two areas may overlap so we use memmove.  */
 
@@ -160,6 +165,32 @@ concat_string (GFC_INTEGER_4 destlen, ch
 }
 
 
+/* Return string with all trailing blanks removed.  */
+
+void
+string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen, const char * src)
+{
+  int i;
+
+  /* Determine length of result string.  */
+  for (i = slen - 1; i >= 0; i--)
+    {
+      if (src[i] != ' ')
+        break;
+    }
+  *len = i + 1;
+
+  if (*len > 0)
+    {
+      /* Allocate space for result string.  */
+      internal_malloc (dest, *len);
+
+      /* copy string if necessary.  */
+      memmove (*dest, src, *len);
+    }
+}
+
+
 /* The length of a string not including trailing blanks.  */
 
 GFC_INTEGER_4
@@ -337,3 +368,27 @@ string_verify (GFC_INTEGER_4 slen, const
 
   return 0;
 }
+
+
+/* Concatenate several copies of a string.  */
+
+void
+string_repeat (char * dest, GFC_INTEGER_4 slen, 
+               const char * src, GFC_INTEGER_4 ncopies)
+{
+  int i;
+
+  /* See if ncopies is valid.  */
+  if (ncopies < 0)
+    {
+      /* The error is already reported.  */
+      runtime_error ("Augument NCOPIES is negative.");
+    }
+
+  /* Copy characters.  */
+  for (i = 0; i < ncopies; i++) 
+    {
+      memmove (dest + (i * slen), src, slen);
+    }
+}
+

Attachment: intrinsic_trim.f90
Description: Text document

Attachment: intrinsic_len.f90
Description: Text document