2008-12-02 Jakub Jelinek <jakub@redhat.com>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-const.c

diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 8d5f8a8..4db3512 100644 (file)
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -33,6 +33,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans.h"
 #include "trans-const.h"
 #include "trans-types.h"
+#include "target-memory.h"
 
 tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
 
@@ -66,6 +67,8 @@ gfc_build_const (tree type, tree intval)
   return val;
 }
 
+/* Build a string constant with C char type.  */
+
 tree
 gfc_build_string_const (int length, const char *s)
 {
@@ -81,15 +84,53 @@ gfc_build_string_const (int length, const char *s)
   return str;
 }
 
+
+/* Build a string constant with a type given by its kind; take care of
+   non-default character kinds.  */
+
+tree
+gfc_build_wide_string_const (int kind, int length, const gfc_char_t *string)
+{
+  int i;
+  tree str, len;
+  size_t size;
+  char *s;
+
+  i = gfc_validate_kind (BT_CHARACTER, kind, false);
+  size = length * gfc_character_kinds[i].bit_size / 8;
+
+  s = XCNEWVAR (char, size);
+  gfc_encode_character (kind, length, string, (unsigned char *) s, size);
+
+  str = build_string (size, s);
+  gfc_free (s);
+
+  len = build_int_cst (NULL_TREE, length);
+  TREE_TYPE (str) =
+    build_array_type (gfc_get_char_type (kind),
+                     build_range_type (gfc_charlen_type_node,
+                                       integer_one_node, len));
+  return str;
+}
+
+
 /* Build a Fortran character constant from a zero-terminated string.
-   Since this is mainly used for error messages, the string will get
-   translated.  */
+   There a two version of this function, one that translates the string
+   and one that doesn't.  */
+tree
+gfc_build_cstring_const (const char *string)
+{
+  return gfc_build_string_const (strlen (string) + 1, string);
+}
+
 tree
-gfc_build_cstring_const (const char *msgid)
+gfc_build_localized_cstring_const (const char *msgid)
 {
-  return gfc_build_string_const (strlen (msgid) + 1, _(msgid));
+  const char *localized = _(msgid);
+  return gfc_build_string_const (strlen (localized) + 1, localized);
 }
 
+
 /* Return a string constant with the given length.  Used for static
    initializers.  The constant will be padded or truncated to match 
    length.  */
@@ -97,13 +138,14 @@ gfc_build_cstring_const (const char *msgid)
 tree
 gfc_conv_string_init (tree length, gfc_expr * expr)
 {
-  char *s;
+  gfc_char_t *s;
   HOST_WIDE_INT len;
   int slen;
   tree str;
+  bool free_s = false;
 
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
-  gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+  gcc_assert (expr->ts.type == BT_CHARACTER);
   gcc_assert (INTEGER_CST_P (length));
   gcc_assert (TREE_INT_CST_HIGH (length) == 0);
 
@@ -112,14 +154,18 @@ gfc_conv_string_init (tree length, gfc_expr * expr)
 
   if (len > slen)
     {
-      s = gfc_getmem (len);
-      memcpy (s, expr->value.character.string, slen);
-      memset (&s[slen], ' ', len - slen);
-      str = gfc_build_string_const (len, s);
-      gfc_free (s);
+      s = gfc_get_wide_string (len);
+      memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
+      gfc_wide_memset (&s[slen], ' ', len - slen);
+      free_s = true;
     }
   else
-    str = gfc_build_string_const (len, expr->value.character.string);
+    s = expr->value.character.string;
+
+  str = gfc_build_wide_string_const (expr->ts.kind, len, s);
+
+  if (free_s)
+    gfc_free (s);
 
   return str;
 }
@@ -206,6 +252,8 @@ gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
 tree
 gfc_conv_constant_to_tree (gfc_expr * expr)
 {
+  tree res;
+
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 
   /* If it is has a prescribed memory representation, we build a string
@@ -233,13 +281,19 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
 
     case BT_LOGICAL:
       if (expr->representation.string)
-       return fold_build1 (VIEW_CONVERT_EXPR,
-                           gfc_get_logical_type (expr->ts.kind),
-                           gfc_build_string_const (expr->representation.length,
-                                                   expr->representation.string));
+       {
+         tree tmp = fold_build1 (VIEW_CONVERT_EXPR,
+                                 gfc_get_int_type (expr->ts.kind),
+                                 gfc_build_string_const (expr->representation.length,
+                                                         expr->representation.string));
+         if (!integer_zerop (tmp) && !integer_onep (tmp))
+           gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
+                        " has undefined result at %L", &expr->where);
+         return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
+       }
       else
        return build_int_cst (gfc_get_logical_type (expr->ts.kind),
-                           expr->value.logical);
+                             expr->value.logical);
 
     case BT_COMPLEX:
       if (expr->representation.string)
@@ -259,8 +313,10 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
        }
 
     case BT_CHARACTER:
-      return gfc_build_string_const (expr->value.character.length,
-                                    expr->value.character.string);
+      res = gfc_build_wide_string_const (expr->ts.kind,
+                                        expr->value.character.length,
+                                        expr->value.character.string);
+      return res;
 
     case BT_HOLLERITH:
       return gfc_build_string_const (expr->representation.length,