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, fortran] Fix a TRANSFER folding bug, rework Hollerith handling.


:ADDPATCH fortran:

This change is a bugfix to the TRANSFER constant-folding, masquerading as a complete reworking of the way we handle Hollerith constants. :)

The problem, fundamentally, is this: If one takes a strict interpretation of the Fortran standard, the following little program is required to return 42:

  logical, parameter :: A = TRANSFER (4, .true.)
  integer, parameter :: I = TRANSFER (A, 0)
  write(*,*) I

This currently does not work with the constant-folding. The transfer to A determines that 4 is nonzero, and thus A has a logical value of true, and the gfc_expr that is created merely stores that value. Then, the constant-folding to I knows that a value of true is stored as if it has an integer value of 1, and the output is 1.

To fix this, the gfc_expr that we store for A obviously has to include its in-memory representation along with its actual semantic value.

Now, as it happens, we've already got a Fortran functionality that's storing in-memory representations; that's what Hollerith constants do. This patch slightly rearranges how those are handled, so that the in-memory representation is no longer part of the "value" union, and thus a gfc_expr can now have a "value" and an in-memory representation simultaneously. When both of them are set, the TRANSFER intrinsic and gfc_conv_constant_to_tree use the in-memory representation, whereas any other constant-folding (of intrinsics, operators, etc.) use the value.

Once that's done, we can rip out the from_H field in gfc_expr. Its only remaining purpose is to guard against trying to access the value of constants converted from Holleriths, and it's simpler just to give them values using the "interpret" functions from target-memory.

So, that's really just about it, except for cleaning up a few details, and adding a new testcase to demonstrate that this works correctly.

(Unfortunately, the testcase is only currently working with -O0; something weird is happening in the optimizers that I'll need to track down.)

My next project will be folding BOZ-literals into this system, I think; that will be useful to handle how Fortran 2003 does REAL(Z'FFF0') and that kind of mess -- and, coincidentally, give us a very small start on Fortran 2008. :)


------------------------------------------------------------------------------ 2007-05-27 Brooks Moses <brooks.moses@codesourcery.com>

* gfortran.h (gfc_expr): Remove from_H, add "representation"
struct.
* primary.c (match_hollerith_constant): Store the representation of the Hollerith in representation, not in value.character.
* arith.c: Add dependency on target-memory.h.
(eval_intrinsic): Remove check for from_H.
(hollerith2representation): New function.
(gfc_hollerith2int): Determine value of the new constant.
(gfc_hollerith2real): Likewise.
(gfc_hollerith2complex): Likewise.
(gfc_hollerith2logical): Likewise.
(gfc_hollerith2character): Point both representation.string and
value.character.string at the value string.
* data.c (create_character_initializer): For BT_HOLLERITH
rvalues, get the value from the representation rather than
value.character.
* expr.c (free_expr0): Update handling of BT_HOLLERITH values
and values with representation.string.
(gfc_copy_expr): Likewise.
* intrinsic.c (do_simplify): Remove special treatement of
variables resulting from Hollerith constants.
* dump-parse-trees.c (gfc_show_expr): Update handling of
Holleriths.
* trans-const.c (gfc_conv_constant_to_tree): Replace from_H
check with check for representation.string; get Hollerith
representation from representation.string, not value.character.
* trans-expr.c (is_zero_initializer_p): Replace from_H check
with check for representation.string.
* trans-stmt.c (gfc_trans_integer_select): Use
gfc_conv_mpz_to_tree for case values, so as to avoid picking up
the memory representation if the case is given by a transfer
expression.
* target-memory.c (gfc_target_encode_expr): Use the known memory
representation rather than the value, if it exists.
(gfc_target_interpret_expr): Store the memory representation of
the interpreted expression as well as its value.
(interpret_integer): Move to gfc_interpret_integer, make
non-static.
(interpret_float): Move to gfc_interpret_float, make non-static.
(interpret_complex): Move to gfc_interpret_complex, make
non-static.
(interpret_logical): Move to gfc_interpret_logical, make
non-static.
(interpret_character): Move to gfc_interpret_character, make
non-static.
(interpret_derived): Move to gfc_interpret_derived, make
non-static.
* target-memory.h: Add prototypes for newly-exported
gfc_interpret_* functions.


------------------------------------------------------------------------------
2007-05-27  Brooks Moses  <brooks.moses@codesourcery.com>

* gfortran.dg/transfer_simplify_3.f90: New test.

------------------------------------------------------------------------------

Regression-tested on powerpc-apple-darwin8.9.0. Ok for trunk?

- Brooks
Index: intrinsic.c
===================================================================
--- intrinsic.c	(revision 125106)
+++ intrinsic.c	(working copy)
@@ -3065,16 +3065,6 @@ do_simplify (gfc_intrinsic_sym *specific
   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
   gfc_actual_arglist *arg;
 
-  /* Check the arguments if there are Hollerith constants. We deal with
-     them at run-time.  */
-  for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
-    {
-      if (arg->expr && arg->expr->from_H)
-	{
-	  result = NULL;
-	  goto finish;
-	}
-    }
   /* Max and min require special handling due to the variable number
      of args.  */
   if (specific->simplify.f1 == gfc_simplify_min)
Index: trans-expr.c
===================================================================
--- trans-expr.c	(revision 125106)
+++ trans-expr.c	(working copy)
@@ -3567,8 +3567,9 @@ is_zero_initializer_p (gfc_expr * expr)
 {
   if (expr->expr_type != EXPR_CONSTANT)
     return false;
-  /* We ignore Hollerith constants for the time being.  */
-  if (expr->from_H)
+
+  /* We ignore constants with prescribed memory representations for now.  */
+  if (expr->representation.string)
     return false;
 
   switch (expr->ts.type)
Index: dump-parse-tree.c
===================================================================
--- dump-parse-tree.c	(revision 125106)
+++ dump-parse-tree.c	(working copy)
@@ -340,16 +340,6 @@ gfc_show_expr (gfc_expr *p)
       break;
 
     case EXPR_CONSTANT:
-      if (p->from_H || p->ts.type == BT_HOLLERITH)
-	{
-	  gfc_status ("%dH", p->value.character.length);
-	  c = p->value.character.string;
-	  for (i = 0; i < p->value.character.length; i++, c++)
-	    {
-	      gfc_status_char (*c);
-	    }
-	  break;
-	}
       switch (p->ts.type)
 	{
 	case BT_INTEGER:
@@ -405,11 +395,33 @@ gfc_show_expr (gfc_expr *p)
 	  gfc_status (")");
 	  break;
 
+	case BT_HOLLERITH:
+	  gfc_status ("%dH", p->representation.length);
+	  c = p->representation.string;
+	  for (i = 0; i < p->representation.length; i++, c++)
+	    {
+	      gfc_status_char (*c);
+	    }
+	  break;
+
 	default:
 	  gfc_status ("???");
 	  break;
 	}
 
+      if (p->representation.string)
+	{
+	  gfc_status (" {");
+	  c = p->representation.string;
+	  for (i = 0; i < p->representation.length; i++, c++)
+	    {
+	      gfc_status ("%.2x", (unsigned int) *c);
+	      if (i < p->representation.length - 1)
+		gfc_status_char (',');
+	    }
+	  gfc_status_char ('}');
+	}
+
       break;
 
     case EXPR_VARIABLE:
Index: gfortran.h
===================================================================
--- gfortran.h	(revision 125106)
+++ gfortran.h	(working copy)
@@ -1290,17 +1290,28 @@ typedef struct gfc_expr
 
   locus where;
 
-  /* True if it is converted from Hollerith constant.  */
-  unsigned int from_H : 1;
   /* True if the expression is a call to a function that returns an array,
      and if we have decided not to allocate temporary data for that array.  */
   unsigned int inline_noncopying_intrinsic : 1;
-  /* Used to quickly find a given constructor by it's offset.  */
+
+  /* Used to quickly find a given constructor by its offset.  */
   splay_tree con_by_offset;
 
+  /* If an expression comes from a Hollerith constant or compile-time
+     evaluation of a transfer statement, it may have a prescribed target-
+     memory representation, and these cannot always be backformed from
+     the value.  */
+  struct
+  {
+    int length;
+    char *string;
+  }
+  representation;
+
   union
   {
     int logical;
+
     mpz_t integer;
 
     mpfr_t real;
Index: data.c
===================================================================
--- data.c	(revision 125106)
+++ data.c	(working copy)
@@ -154,7 +154,7 @@ create_character_intializer (gfc_expr *i
   int len;
   int start;
   int end;
-  char *dest;
+  char *dest, *rvalue_string;
 	    
   gfc_extract_int (ts->cl->length, &len);
 
@@ -207,7 +207,17 @@ create_character_intializer (gfc_expr *i
     }
 
   /* Copy the initial value.  */
-  len = rvalue->value.character.length;
+  if (rvalue->ts.type == BT_HOLLERITH)
+    {
+      len = rvalue->representation.length;
+      rvalue_string = rvalue->representation.string;
+    }
+  else
+    {
+      len = rvalue->value.character.length;
+      rvalue_string = rvalue->value.character.string;
+    }
+
   if (len > end - start)
     {
       len = end - start;
@@ -215,14 +225,17 @@ create_character_intializer (gfc_expr *i
 		       "at %L", &rvalue->where);
     }
 
-  memcpy (&dest[start], rvalue->value.character.string, len);
+  memcpy (&dest[start], rvalue_string, len);
 
   /* Pad with spaces.  Substrings will already be blanked.  */
   if (len < end - start && ref == NULL)
     memset (&dest[start + len], ' ', end - (start + len));
 
   if (rvalue->ts.type == BT_HOLLERITH)
-    init->from_H = 1;
+    {
+      init->representation.length = init->value.character.length;
+      init->representation.string = init->value.character.string;
+    }
 
   return init;
 }
Index: trans-const.c
===================================================================
--- trans-const.c	(revision 125106)
+++ trans-const.c	(working copy)
@@ -209,45 +209,45 @@ gfc_conv_constant_to_tree (gfc_expr * ex
 {
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 
-  /* If it is converted from Hollerith constant, we build string constant
-     and VIEW_CONVERT to its type.  */
+  /* If it is has a prescribed memory representation, we build a string
+     constant and VIEW_CONVERT to its type.  */
  
   switch (expr->ts.type)
     {
     case BT_INTEGER:
-      if (expr->from_H)
+      if (expr->representation.string)
 	return build1 (VIEW_CONVERT_EXPR,
 			gfc_get_int_type (expr->ts.kind),
-			gfc_build_string_const (expr->value.character.length,
-				expr->value.character.string));
+			gfc_build_string_const (expr->representation.length,
+				expr->representation.string));
       else
 	return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 
     case BT_REAL:
-      if (expr->from_H)
+      if (expr->representation.string)
 	return build1 (VIEW_CONVERT_EXPR,
 			gfc_get_real_type (expr->ts.kind),
-			gfc_build_string_const (expr->value.character.length,
-				expr->value.character.string));
+			gfc_build_string_const (expr->representation.length,
+				expr->representation.string));
       else
 	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 
     case BT_LOGICAL:
-      if (expr->from_H)
+      if (expr->representation.string)
 	return build1 (VIEW_CONVERT_EXPR,
 			gfc_get_logical_type (expr->ts.kind),
-			gfc_build_string_const (expr->value.character.length,
-				expr->value.character.string));
+			gfc_build_string_const (expr->representation.length,
+				expr->representation.string));
       else
 	return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 			    expr->value.logical);
 
     case BT_COMPLEX:
-      if (expr->from_H)
+      if (expr->representation.string)
 	return build1 (VIEW_CONVERT_EXPR,
 			gfc_get_complex_type (expr->ts.kind),
-			gfc_build_string_const (expr->value.character.length,
-				expr->value.character.string));
+			gfc_build_string_const (expr->representation.length,
+				expr->representation.string));
       else
 	{
 	  tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
@@ -260,10 +260,13 @@ gfc_conv_constant_to_tree (gfc_expr * ex
 	}
 
     case BT_CHARACTER:
-    case BT_HOLLERITH:
       return gfc_build_string_const (expr->value.character.length,
 				     expr->value.character.string);
 
+    case BT_HOLLERITH:
+      return gfc_build_string_const (expr->representation.length,
+				     expr->representation.string);
+
     default:
       fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
 		   gfc_typename (&expr->ts));
Index: trans-stmt.c
===================================================================
--- trans-stmt.c	(revision 125106)
+++ trans-stmt.c	(working copy)
@@ -1139,7 +1139,8 @@ gfc_trans_integer_select (gfc_code * cod
 
 	  if (cp->low)
 	    {
-	      low = gfc_conv_constant_to_tree (cp->low);
+	      low = gfc_conv_mpz_to_tree (cp->low->value.integer,
+					  cp->low->ts.kind);
 
 	      /* If there's only a lower bound, set the high bound to the
 		 maximum value of the case expression.  */
@@ -1169,7 +1170,8 @@ gfc_trans_integer_select (gfc_code * cod
 		  || (cp->low
 		      && mpz_cmp (cp->low->value.integer,
 				  cp->high->value.integer) != 0))
-		high = gfc_conv_constant_to_tree (cp->high);
+		high = gfc_conv_mpz_to_tree (cp->high->value.integer,
+					     cp->high->ts.kind);
 
 	      /* Unbounded case.  */
 	      if (!cp->low)
Index: expr.c
===================================================================
--- expr.c	(revision 125106)
+++ expr.c	(working copy)
@@ -140,12 +140,7 @@ free_expr0 (gfc_expr *e)
   switch (e->expr_type)
     {
     case EXPR_CONSTANT:
-      if (e->from_H)
-	{
-	  gfc_free (e->value.character.string);
-	  break;
-	}
-
+      /* Free any parts of the value that need freeing.  */
       switch (e->ts.type)
 	{
 	case BT_INTEGER:
@@ -157,7 +152,6 @@ free_expr0 (gfc_expr *e)
 	  break;
 
 	case BT_CHARACTER:
-	case BT_HOLLERITH:
 	  gfc_free (e->value.character.string);
 	  break;
 
@@ -170,6 +164,11 @@ free_expr0 (gfc_expr *e)
 	  break;
 	}
 
+      /* Free the representation, except in character constants where it
+	 is the same as value.character.string and thus already freed.  */
+      if (e->representation.string && e->ts.type != BT_CHARACTER)
+	gfc_free (e->representation.string);
+
       break;
 
     case EXPR_OP:
@@ -413,14 +412,16 @@ gfc_copy_expr (gfc_expr *p)
       break;
 
     case EXPR_CONSTANT:
-      if (p->from_H)
+      /* Copy target representation, if it exists.  */
+      if (p->representation.string)
 	{
-	  s = gfc_getmem (p->value.character.length + 1);
-	  q->value.character.string = s;
+	  s = gfc_getmem (p->representation.length + 1);
+	  q->representation.string = s;
 
-	  memcpy (s, p->value.character.string, p->value.character.length + 1);
-	  break;
+	  memcpy (s, p->representation.string, p->representation.length + 1);
 	}
+
+      /* Copy the values of any pointer components of p->value.  */
       switch (q->ts.type)
 	{
 	case BT_INTEGER:
@@ -442,13 +443,18 @@ gfc_copy_expr (gfc_expr *p)
 	  break;
 
 	case BT_CHARACTER:
-	case BT_HOLLERITH:
-	  s = gfc_getmem (p->value.character.length + 1);
-	  q->value.character.string = s;
+	  if (p->representation.string)
+	    q->value.character.string = q->representation.string;
+	  else
+	    {
+	      s = gfc_getmem (p->value.character.length + 1);
+	      q->value.character.string = s;
 
-	  memcpy (s, p->value.character.string, p->value.character.length + 1);
+	      memcpy (s, p->value.character.string, p->value.character.length + 1);
+	    }
 	  break;
 
+	case BT_HOLLERITH:
 	case BT_LOGICAL:
 	case BT_DERIVED:
 	  break;		/* Already done */
Index: target-memory.c
===================================================================
--- target-memory.c	(revision 125106)
+++ target-memory.c	(working copy)
@@ -220,6 +220,15 @@ gfc_target_encode_expr (gfc_expr *source
   gcc_assert (source->expr_type == EXPR_CONSTANT
 	      || source->expr_type == EXPR_STRUCTURE);
 
+  /* If we already have a target-memory representation, we use that rather 
+     than recreating one.  */
+  if (source->representation.string)
+    {
+      memcpy (buffer, source->representation.string,
+	      source->representation.length);
+      return source->representation.length;
+    }
+
   switch (source->ts.type)
     {
     case BT_INTEGER:
@@ -289,8 +298,8 @@ interpret_array (unsigned char *buffer, 
 }
 
 
-static int
-interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
+int
+gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 		   mpz_t integer)
 {
   mpz_init (integer);
@@ -301,8 +310,8 @@ interpret_integer (int kind, unsigned ch
 }
 
 
-static int
-interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
+int
+gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 		 mpfr_t real)
 {
   mpfr_init (real);
@@ -314,19 +323,19 @@ interpret_float (int kind, unsigned char
 }
 
 
-static int
-interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
+int
+gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 		   mpfr_t real, mpfr_t imaginary)
 {
   int size;
-  size = interpret_float (kind, &buffer[0], buffer_size, real);
-  size += interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
+  size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
+  size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
   return size;
 }
 
 
-static int
-interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
+int
+gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 		   int *logical)
 {
   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
@@ -337,8 +346,8 @@ interpret_logical (int kind, unsigned ch
 }
 
 
-static int
-interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+int
+gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 {
   if (result->ts.cl && result->ts.cl->length)
     result->value.character.length =
@@ -355,8 +364,8 @@ interpret_character (unsigned char *buff
 }
 
 
-static int
-interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+int
+gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 {
   gfc_component *cmp;
   gfc_constructor *head = NULL, *tail = NULL;
@@ -428,24 +437,55 @@ gfc_target_interpret_expr (unsigned char
   switch (result->ts.type)
     {
     case BT_INTEGER:
-      return interpret_integer (result->ts.kind, buffer, buffer_size,
-				result->value.integer);
+      result->representation.length = 
+        gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
+			       result->value.integer);
+      break;
+
     case BT_REAL:
-      return interpret_float (result->ts.kind, buffer, buffer_size,
-			      result->value.real);
+      result->representation.length = 
+        gfc_interpret_float (result->ts.kind, buffer, buffer_size,
+    			     result->value.real);
+      break;
+
     case BT_COMPLEX:
-      return interpret_complex (result->ts.kind, buffer, buffer_size,
-				result->value.complex.r,
-				result->value.complex.i);
+      result->representation.length = 
+        gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
+			       result->value.complex.r,
+			       result->value.complex.i);
+      break;
+
     case BT_LOGICAL:
-      return interpret_logical (result->ts.kind, buffer, buffer_size,
-				&result->value.logical);
+      result->representation.length = 
+        gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
+			       &result->value.logical);
+      break;
+
     case BT_CHARACTER:
-      return interpret_character (buffer, buffer_size, result);
+      result->representation.length = 
+        gfc_interpret_character (buffer, buffer_size, result);
+      break;
+
     case BT_DERIVED:
-      return interpret_derived (buffer, buffer_size, result);
+      result->representation.length = 
+        gfc_interpret_derived (buffer, buffer_size, result);
+      break;
+
     default:
       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
+      break;
+    }
+
+  if (result->ts.type == BT_CHARACTER)
+    result->representation.string = result->value.character.string;
+  else
+    {
+      result->representation.string =
+        gfc_getmem (result->representation.length + 1);
+      memcpy (result->representation.string, buffer,
+	      result->representation.length);
+      result->representation.string[result->representation.length] = '\0';
     }
-  return 0;
+
+  return result->representation.length;
 }
Index: target-memory.h
===================================================================
--- target-memory.h	(revision 125106)
+++ target-memory.h	(working copy)
@@ -32,6 +32,13 @@ size_t gfc_target_expr_size (gfc_expr *)
 int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
 
 /* Read a target buffer into a constant expression.  */
+
+int gfc_interpret_integer (int, unsigned char *, size_t, mpz_t);
+int gfc_interpret_float (int, unsigned char *, size_t, mpfr_t);
+int gfc_interpret_complex (int, unsigned char *, size_t, mpfr_t, mpfr_t);
+int gfc_interpret_logical (int, unsigned char *, size_t, int *);
+int gfc_interpret_character (unsigned char *, size_t, gfc_expr *);
+int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
 int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *);
 
 #endif /* GFC_TARGET_MEMORY_H  */
Index: arith.c
===================================================================
--- arith.c	(revision 125106)
+++ arith.c	(working copy)
@@ -30,6 +30,7 @@ Software Foundation, 51 Franklin Street,
 #include "flags.h"
 #include "gfortran.h"
 #include "arith.h"
+#include "target-memory.h"
 
 /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
    It's easily implemented with a few calls though.  */
@@ -1613,17 +1614,15 @@ eval_intrinsic (gfc_intrinsic_op operato
   if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
     goto runtime;
 
-  if (op1->from_H
-      || (op1->expr_type != EXPR_CONSTANT
-	  && (op1->expr_type != EXPR_ARRAY
-	      || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))))
+  if (op1->expr_type != EXPR_CONSTANT
+      && (op1->expr_type != EXPR_ARRAY
+	  || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
     goto runtime;
 
   if (op2 != NULL
-      && (op2->from_H
-	  || (op2->expr_type != EXPR_CONSTANT
-	      && (op2->expr_type != EXPR_ARRAY
-		  || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))))
+      && op2->expr_type != EXPR_CONSTANT
+	 && (op2->expr_type != EXPR_ARRAY
+	     || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
     goto runtime;
 
   if (unary)
@@ -2307,37 +2306,52 @@ gfc_int2log (gfc_expr *src, int kind)
 }
 
 
+/* Helper function to set the representation in a Hollerith conversion.  
+   This assumes that the ts.type and ts.kind of the result have already
+   been set.  */
+
+static void
+hollerith2representation (gfc_expr *result, gfc_expr *src)
+{
+  int src_len, result_len;
+
+  src_len = src->representation.length;
+  result_len = gfc_target_expr_size (result);
+
+  if (src_len > result_len)
+    {
+      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+		   &src->where, gfc_typename(&result->ts));
+    }
+
+  result->representation.string = gfc_getmem (result_len + 1);
+  memcpy (result->representation.string, src->representation.string,
+	MIN (result_len, src_len));
+
+  if (src_len < result_len)
+    memset (&result->representation.string[src_len], ' ', result_len - src_len);
+
+  result->representation.string[result_len] = '\0'; /* For debugger  */
+  result->representation.length = result_len;
+}
+
+
 /* Convert Hollerith to integer. The constant will be padded or truncated.  */
 
 gfc_expr *
 gfc_hollerith2int (gfc_expr *src, int kind)
 {
   gfc_expr *result;
-  int len;
-
-  len = src->value.character.length;
 
   result = gfc_get_expr ();
   result->expr_type = EXPR_CONSTANT;
   result->ts.type = BT_INTEGER;
   result->ts.kind = kind;
   result->where = src->where;
-  result->from_H = 1;
-
-  if (len > kind)
-    {
-      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
-		   &src->where, gfc_typename(&result->ts));
-    }
-  result->value.character.string = gfc_getmem (kind + 1);
-  memcpy (result->value.character.string, src->value.character.string,
-	MIN (kind, len));
-
-  if (len < kind)
-    memset (&result->value.character.string[len], ' ', kind - len);
 
-  result->value.character.string[kind] = '\0'; /* For debugger  */
-  result->value.character.length = kind;
+  hollerith2representation (result, src);
+  gfc_interpret_integer(kind, (unsigned char *) result->representation.string,
+			result->representation.length, result->value.integer);
 
   return result;
 }
@@ -2358,22 +2372,10 @@ gfc_hollerith2real (gfc_expr *src, int k
   result->ts.type = BT_REAL;
   result->ts.kind = kind;
   result->where = src->where;
-  result->from_H = 1;
 
-  if (len > kind)
-    {
-      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
-		   &src->where, gfc_typename(&result->ts));
-    }
-  result->value.character.string = gfc_getmem (kind + 1);
-  memcpy (result->value.character.string, src->value.character.string,
-	MIN (kind, len));
-
-  if (len < kind)
-    memset (&result->value.character.string[len], ' ', kind - len);
-
-  result->value.character.string[kind] = '\0'; /* For debugger.  */
-  result->value.character.length = kind;
+  hollerith2representation (result, src);
+  gfc_interpret_float(kind, (unsigned char *) result->representation.string,
+		      result->representation.length, result->value.real);
 
   return result;
 }
@@ -2394,24 +2396,11 @@ gfc_hollerith2complex (gfc_expr *src, in
   result->ts.type = BT_COMPLEX;
   result->ts.kind = kind;
   result->where = src->where;
-  result->from_H = 1;
-
-  kind = kind * 2;
-
-  if (len > kind)
-    {
-      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
-		   &src->where, gfc_typename(&result->ts));
-    }
-  result->value.character.string = gfc_getmem (kind + 1);
-  memcpy (result->value.character.string, src->value.character.string,
-	  MIN (kind, len));
 
-  if (len < kind)
-    memset (&result->value.character.string[len], ' ', kind - len);
-
-  result->value.character.string[kind] = '\0'; /* For debugger  */
-  result->value.character.length = kind;
+  hollerith2representation (result, src);
+  gfc_interpret_complex(kind, (unsigned char *) result->representation.string,
+			result->representation.length, result->value.complex.r,
+			result->value.complex.i);
 
   return result;
 }
@@ -2427,7 +2416,9 @@ gfc_hollerith2character (gfc_expr *src, 
   result = gfc_copy_expr (src);
   result->ts.type = BT_CHARACTER;
   result->ts.kind = kind;
-  result->from_H = 1;
+
+  result->value.character.string = result->representation.string;
+  result->value.character.length = result->representation.length;
 
   return result;
 }
@@ -2448,22 +2439,10 @@ gfc_hollerith2logical (gfc_expr *src, in
   result->ts.type = BT_LOGICAL;
   result->ts.kind = kind;
   result->where = src->where;
-  result->from_H = 1;
-
-  if (len > kind)
-    {
-      gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
-		   &src->where, gfc_typename(&result->ts));
-    }
-  result->value.character.string = gfc_getmem (kind + 1);
-  memcpy (result->value.character.string, src->value.character.string,
-	MIN (kind, len));
-
-  if (len < kind)
-    memset (&result->value.character.string[len], ' ', kind - len);
 
-  result->value.character.string[kind] = '\0'; /* For debugger  */
-  result->value.character.length = kind;
+  hollerith2representation (result, src);
+  gfc_interpret_logical(kind, (unsigned char *) result->representation.string,
+			result->representation.length, &result->value.logical);
 
   return result;
 }
Index: primary.c
===================================================================
--- primary.c	(revision 125106)
+++ primary.c	(working copy)
@@ -236,7 +236,6 @@ match_hollerith_constant (gfc_expr **res
   locus old_loc;
   gfc_expr *e = NULL;
   const char *msg;
-  char *buffer;
   int num;
   int i;  
 
@@ -270,18 +269,18 @@ match_hollerith_constant (gfc_expr **res
 	}
       else
 	{
-	  buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
-	  for (i = 0; i < num; i++)
-	    {
-	      buffer[i] = gfc_next_char_literal (1);
-	    }
 	  gfc_free_expr (e);
 	  e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
 				   &gfc_current_locus);
-	  e->value.character.string = gfc_getmem (num + 1);
-	  memcpy (e->value.character.string, buffer, num);
-	  e->value.character.string[num] = '\0';
-	  e->value.character.length = num;
+
+	  e->representation.string = gfc_getmem (num + 1);
+	  for (i = 0; i < num; i++)
+	    {
+	      e->representation.string[i] = gfc_next_char_literal (1);
+	    }
+	  e->representation.string[num] = '\0';
+	  e->representation.length = num;
+
 	  *result = e;
 	  return MATCH_YES;
 	}
! { dg-do run }
! { dg-options "-O0" }
! Tests that the in-memory representation of a transferred variable
! propagates properly.
!
  implicit none

  integer, parameter :: ip1 = 42
  logical, parameter :: ap1 = transfer(ip1, .true.)
  integer, parameter :: ip2 = transfer(ap1, 0)

  logical :: a
  integer :: i
  
  i = transfer(transfer(ip1, .true.), 0)
  if (i .ne. ip1) call abort ()

  i = transfer(ap1, 0)
  if (i .ne. ip1) call abort ()
  
  a = transfer(ip1, .true.)
  i = transfer(a, 0)
  if (i .ne. ip1) call abort ()

  i = ip1
  a = transfer(i, .true.)
  i = transfer(a, 0)
  if (i .ne. ip1) call abort ()

end

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