For the 60th anniversary of Chinese people��s Anti-Japan war victory.

2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/16531
	PR fortran/15966
	PR fortran/18781
	* arith.c (gfc_hollerith2int, gfc_hollerith2real,
	gfc_hollerith2complex, gfc_hollerith2character, gfc_hollerith2logical):
	New functions.
	(eval_intrinsic): Don't evaluate if Hollerith constant arguments exist.
	* arith.h (gfc_hollerith2int, gfc_hollerith2real,
	gfc_hollerith2complex, gfc_hollerith2character, gfc_hollerith2logical):
	Add prototypes.
	* expr.c (free_expr0): Free memery allocated for Hollerith constant.
	(gfc_copy_expr): Allocate and copy string if Expr is from Hollerith.
	(gfc_check_assign): Enable conversion from Hollerith to other.
	* gfortran.h (bt): Add BT_HOLLERITH.
	(gfc_expr): Add from_H flag.
	* intrinsic.c (gfc_type_letter): Return 'h' for BT_HOLLERITH.
	(add_conversions): Add conversions from Hollerith constant to other.
	(do_simplify): Don't simplify if  Hollerith constant arguments exist.
	* io.c (resolve_tag): Enable array in FORMAT tag under GFC_STD_GNU.
	* misc.c (gfc_basetype_name): Return "HOLLERITH" for BT_HOLLERITH.
	(gfc_type_name): Print "HOLLERITH" for BT_HOLLERITH.
	* primary.c (match_hollerith_constant): New function.
	(gfc_match_literal_constant): Add match Hollerith before Integer.
	* simplify.c (gfc_convert_constant): Add conversion from Hollerith
	to other.
	* trans-const.c (gfc_conv_constant_to_tree): Use VIEW_CONVERT_EXPR to
	convert Hollerith constant to tree.
	* trans-io.c (gfc_convert_array_to_string): Get array's address and
	length to set string expr.
	(set_string): Deal with array assigned Hollerith constant and character
	array.
	* gfortran.texi: Document Hollerith constants as extention support.

2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/16531
	PR fortran/15966
	PR fortran/18781
	* gfortran.dg/hollerith.f90: New.
	* gfortran.dg/hollerith2.f90: New.
	* gfortran.dg/hollerith3.f90: New.
	* gfortran.dg/hollerith4.f90: New.
	* gfortran.dg/hollerith_f95.f90: New.
	* gfortran.dg/hollerith_legacy.f90: New.
	* gfortran.dg/g77/cpp4.F: New. Port from g77.

2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/16531
	* io/transfer.c (formatted_transfer): Enable FMT_A on other types to
	support Hollerith constants.

From-SVN: r101688

21 files changed, 863 insertions, 42 deletions

diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index c85366e..4443f33 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -1582,17 +1582,19 @@ eval_intrinsic (gfc_intrinsic_op operator,
   if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
     goto runtime;
 
-  if (op1->expr_type != EXPR_CONSTANT
-      && (op1->expr_type != EXPR_ARRAY
-	  || !gfc_is_constant_expr (op1)
-	  || !gfc_expanded_ac (op1)))
+  if (op1->from_H
+      || (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->expr_type != EXPR_CONSTANT
-      && (op2->expr_type != EXPR_ARRAY
-	  || !gfc_is_constant_expr (op2)
-	  || !gfc_expanded_ac (op2)))
+      && (op2->from_H
+	|| (op2->expr_type != EXPR_CONSTANT
+	  && (op2->expr_type != EXPR_ARRAY
+	    || !gfc_is_constant_expr (op2)
+	    || !gfc_expanded_ac (op2)))))
     goto runtime;
 
   if (unary)
@@ -2214,3 +2216,159 @@ gfc_int2log (gfc_expr *src, int kind)
   return result;
 }
 
+/* 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;
+
+  return result;
+}
+
+/* Convert Hollerith to real. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2real (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_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;
+
+  return result;
+}
+
+/* Convert Hollerith to complex. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2complex (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_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;
+
+  return result;
+}
+
+/* Convert Hollerith to character. */
+
+gfc_expr *
+gfc_hollerith2character (gfc_expr * src, int kind)
+{
+  gfc_expr *result;
+
+  result = gfc_copy_expr (src);
+  result->ts.type = BT_CHARACTER;
+  result->ts.kind = kind;
+  result->from_H = 1;
+
+  return result;
+}
+
+/* Convert Hollerith to logical. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_hollerith2logical (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_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;
+
+  return result;
+}
diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h
index ed2fd4e..385fbff 100644
--- a/gcc/fortran/arith.h
+++ b/gcc/fortran/arith.h
@@ -82,6 +82,11 @@ gfc_expr *gfc_complex2complex (gfc_expr *, int);
 gfc_expr *gfc_log2log (gfc_expr *, int);
 gfc_expr *gfc_log2int (gfc_expr *, int);
 gfc_expr *gfc_int2log (gfc_expr *, int);
+gfc_expr *gfc_hollerith2int (gfc_expr *, int);
+gfc_expr *gfc_hollerith2real (gfc_expr *, int);
+gfc_expr *gfc_hollerith2complex (gfc_expr *, int);
+gfc_expr *gfc_hollerith2character (gfc_expr *, int);
+gfc_expr *gfc_hollerith2logical (gfc_expr *, int);
 
 #endif /* GFC_ARITH_H  */
 
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index fe4c746..a3a24b5 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -141,6 +141,12 @@ free_expr0 (gfc_expr * e)
   switch (e->expr_type)
     {
     case EXPR_CONSTANT:
+      if (e->from_H)
+	{
+	  gfc_free (e->value.character.string);
+	  break;
+	}
+
       switch (e->ts.type)
 	{
 	case BT_INTEGER:
@@ -152,6 +158,7 @@ free_expr0 (gfc_expr * e)
 	  break;
 
 	case BT_CHARACTER:
+	case BT_HOLLERITH:
 	  gfc_free (e->value.character.string);
 	  break;
 
@@ -393,6 +400,15 @@ gfc_copy_expr (gfc_expr * p)
       break;
 
     case EXPR_CONSTANT:
+      if (p->from_H)
+	{
+	  s = gfc_getmem (p->value.character.length + 1);
+	  q->value.character.string = s;
+
+	  memcpy (s, p->value.character.string,
+		  p->value.character.length + 1);
+	  break;
+	}
       switch (q->ts.type)
 	{
 	case BT_INTEGER:
@@ -414,6 +430,7 @@ 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;
 
@@ -1813,7 +1830,10 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
 
   if (!conform)
     {
-      if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
+      /* Numeric can be converted to any other numeric. And Hollerith can be
+	 converted to any other type.  */
+      if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
+	  || rvalue->ts.type == BT_HOLLERITH)
 	return SUCCESS;
 
       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 07a3f2c..71b6c19 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -127,7 +127,7 @@ gfc_source_form;
 
 typedef enum
 { BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
-  BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE
+  BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH
 }
 bt;
 
@@ -1077,6 +1077,9 @@ typedef struct gfc_expr
 
   locus where;
 
+  /* True if it is converted from Hollerith constant.  */
+  unsigned int from_H : 1;
+
   union
   {
     int logical;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 05452c2..67d95df 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -79,6 +79,10 @@ gfc_type_letter (bt type)
       c = 'c';
       break;
 
+    case BT_HOLLERITH:
+      c = 'h';
+      break;
+
     default:
       c = 'u';
       break;
@@ -2327,6 +2331,31 @@ add_conversions (void)
 		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
       }
 
+  if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
+    {
+      /* Hollerith-Integer conversions.  */
+      for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
+      /* Hollerith-Real conversions.  */
+      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
+      /* Hollerith-Complex conversions.  */
+      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
+
+      /* Hollerith-Character conversions.  */
+      add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
+		  gfc_default_character_kind, GFC_STD_LEGACY);
+
+      /* Hollerith-Logical conversions.  */
+      for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
+	add_conv (BT_HOLLERITH, gfc_default_character_kind,
+		  BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
+    }
+
   /* Real/Complex - Real/Complex conversions.  */
   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
@@ -2713,6 +2742,16 @@ do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
   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)
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index ef51308..abfeead 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -969,33 +969,63 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
-  if (e->ts.type != tag->type)
+  if (e->ts.type != tag->type && tag != &tag_format)
     {
-      /* Format label can be integer varibale.  */
-      if (tag != &tag_format || e->ts.type != BT_INTEGER)
-        {
-          gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
-		&e->where, gfc_basic_typename (tag->type),
-		gfc_basic_typename (BT_INTEGER));
-          return FAILURE;
-        }
+      gfc_error ("%s tag at %L must be of type %s", tag->name,
+		&e->where, gfc_basic_typename (tag->type));
+      return FAILURE;
     }
 
   if (tag == &tag_format)
     {
-      if (e->rank != 1 && e->rank != 0)
+      /* If e's rank is zero and e is not an element of an array, it should be
+	 of integer or character type.  The integer variable should be
+	 ASSIGNED.  */
+      if (e->symtree == NULL || e->symtree->n.sym->as == NULL
+		|| e->symtree->n.sym->as->rank == 0)
 	{
-	  gfc_error ("FORMAT tag at %L cannot be array of strings",
-		     &e->where);
-	  return FAILURE;
+	  if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
+	    {
+	      gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
+			&e->where, gfc_basic_typename (BT_CHARACTER),
+			gfc_basic_typename (BT_INTEGER));
+	      return FAILURE;
+	    }
+	  else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
+	    {
+	      if (gfc_notify_std (GFC_STD_F95_DEL,
+			"Obsolete: ASSIGNED variable in FORMAT tag at %L",
+			&e->where) == FAILURE)
+		return FAILURE;
+	      if (e->symtree->n.sym->attr.assign != 1)
+		{
+		  gfc_error ("Variable '%s' at %L has not been assigned a "
+			"format label", e->symtree->n.sym->name, &e->where);
+		  return FAILURE;
+		}
+	    }
+	  return SUCCESS;
 	}
-      /* Check assigned label.  */
-      if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER
-		&& e->symtree->n.sym->attr.assign != 1)
+      else
 	{
-	  gfc_error ("Variable '%s' has not been assigned a format label at %L",
-			e->symtree->n.sym->name, &e->where);
-	  return FAILURE;
+	  /* if rank is nonzero, we allow the type to be character under
+	     GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
+	     assigned an Hollerith constant.  */
+	  if (e->ts.type == BT_CHARACTER)
+	    {
+	      if (gfc_notify_std (GFC_STD_GNU,
+			"Extension: Character array in FORMAT tag at %L",
+			&e->where) == FAILURE)
+		return FAILURE;
+	    }
+	  else
+	    {
+	      if (gfc_notify_std (GFC_STD_LEGACY,
+			"Extension: Non-character in FORMAT tag at %L",
+			&e->where) == FAILURE)
+		return FAILURE;
+	    }
+	  return SUCCESS;
 	}
     }
   else
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 2a4301f..dc6a34b 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -159,6 +159,9 @@ gfc_basic_typename (bt type)
     case BT_CHARACTER:
       p = "CHARACTER";
       break;
+    case BT_HOLLERITH:
+      p = "HOLLERITH";
+      break;
     case BT_DERIVED:
       p = "DERIVED";
       break;
@@ -207,6 +210,9 @@ gfc_typename (gfc_typespec * ts)
     case BT_CHARACTER:
       sprintf (buffer, "CHARACTER(%d)", ts->kind);
       break;
+    case BT_HOLLERITH:
+      sprintf (buffer, "HOLLERITH");
+      break;
     case BT_DERIVED:
       sprintf (buffer, "TYPE(%s)", ts->derived->name);
       break;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index e14ab92..1f8305b 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -228,6 +228,75 @@ match_integer_constant (gfc_expr ** result, int signflag)
 }
 
 
+/* Match a Hollerith constant.  */
+
+static match
+match_hollerith_constant (gfc_expr ** result)
+{
+  locus old_loc;
+  gfc_expr * e = NULL;
+  const char * msg;
+  char * buffer;
+  unsigned int num;
+  unsigned int i;  
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  if (match_integer_constant (&e, 0) == MATCH_YES
+	&& gfc_match_char ('h') == MATCH_YES)
+    {
+      if (gfc_notify_std (GFC_STD_LEGACY,
+		"Extention: Hollerith constant at %C")
+		== FAILURE)
+	goto cleanup;
+
+      msg = gfc_extract_int (e, &num);
+      if (msg != NULL)
+	{
+	  gfc_error (msg);
+	  goto cleanup;
+	}
+      if (num == 0)
+	{
+	  gfc_error ("Invalid Hollerith constant: %L must contain at least one "
+			"character", &old_loc);
+	  goto cleanup;
+	}
+      if (e->ts.kind != gfc_default_integer_kind)
+	{
+	  gfc_error ("Invalid Hollerith constant: Interger kind at %L "
+		"should be default", &old_loc);
+	  goto cleanup;
+	}
+      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.length = num;
+	  *result = e;
+	  return MATCH_YES;
+	}
+    }
+
+  gfc_free_expr (e);
+  gfc_current_locus = old_loc;
+  return MATCH_NO;
+
+cleanup:
+  gfc_free_expr (e);
+  return MATCH_ERROR;
+}
+
+
 /* Match a binary, octal or hexadecimal constant that can be found in
    a DATA statement.  */
 
@@ -1159,6 +1228,10 @@ gfc_match_literal_constant (gfc_expr ** result, int signflag)
   if (m != MATCH_NO)
     return m;
 
+  m = match_hollerith_constant (result);
+  if (m != MATCH_NO)
+    return m;
+
   m = match_integer_constant (result, signflag);
   if (m != MATCH_NO)
     return m;
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 5df7a4c..72d03ea 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3774,6 +3774,34 @@ gfc_convert_constant (gfc_expr * e, bt type, int kind)
 	}
       break;
 
+    case BT_HOLLERITH:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_hollerith2int;
+	  break;
+
+	case BT_REAL:
+	  f = gfc_hollerith2real;
+	  break;
+
+	case BT_COMPLEX:
+	  f = gfc_hollerith2complex;
+	  break;
+
+	case BT_CHARACTER:
+	  f = gfc_hollerith2character;
+	  break;
+
+	case BT_LOGICAL:
+	  f = gfc_hollerith2logical;
+	  break;
+
+	default:
+	  goto oops;
+	}
+      break;
+
     default:
     oops:
       gfc_internal_error ("gfc_convert_constant(): Unexpected type");
diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 121740c..ae7c271 100644
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -274,30 +274,58 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
 {
   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 
+  /* If it is converted from Hollerith constant, we build string constant
+     and VIEW_CONVERT to its type.  */
+ 
   switch (expr->ts.type)
     {
     case BT_INTEGER:
-      return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
+      if (expr->from_H)
+	return build1 (VIEW_CONVERT_EXPR,
+			gfc_get_int_type (expr->ts.kind),
+			gfc_build_string_const (expr->value.character.length,
+				expr->value.character.string));
+      else
+	return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 
     case BT_REAL:
-      return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
+      if (expr->from_H)
+	return build1 (VIEW_CONVERT_EXPR,
+			gfc_get_real_type (expr->ts.kind),
+			gfc_build_string_const (expr->value.character.length,
+				expr->value.character.string));
+      else
+	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
 
     case BT_LOGICAL:
-      return build_int_cst (gfc_get_logical_type (expr->ts.kind),
+      if (expr->from_H)
+	return build1 (VIEW_CONVERT_EXPR,
+			gfc_get_logical_type (expr->ts.kind),
+			gfc_build_string_const (expr->value.character.length,
+				expr->value.character.string));
+      else
+	return build_int_cst (gfc_get_logical_type (expr->ts.kind),
 			    expr->value.logical);
 
     case BT_COMPLEX:
-      {
-	tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
+      if (expr->from_H)
+	return build1 (VIEW_CONVERT_EXPR,
+			gfc_get_complex_type (expr->ts.kind),
+			gfc_build_string_const (expr->value.character.length,
+				expr->value.character.string));
+      else
+	{
+	  tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
 					  expr->ts.kind);
-	tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
+	  tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
 					  expr->ts.kind);
 
-	return build_complex (gfc_typenode_for_spec (&expr->ts),
-			      real, imag);
-      }
+	  return build_complex (gfc_typenode_for_spec (&expr->ts),
+				real, imag);
+	}
 
     case BT_CHARACTER:
+    case BT_HOLLERITH:
       return gfc_build_string_const (expr->value.character.length,
 				     expr->value.character.string);
 
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 6680449..4b6caa6 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -364,6 +364,68 @@ set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
   gfc_add_modify_expr (block, tmp, se.expr);
 }
 
+/* Given an array expr, find its address and length to get a string. If the
+   array is full, the string's address is the address of array's first element
+   and the length is the size of the whole array. If it is an element, the
+   string's address is the element's address and the length is the rest size of
+   the array.
+*/
+
+static void
+gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
+{
+  tree tmp;
+  tree array;
+  tree type;
+  tree size;
+  int rank;
+  gfc_symbol *sym;
+
+  sym = e->symtree->n.sym;
+  rank = sym->as->rank - 1;
+
+  if (e->ref->u.ar.type == AR_FULL)
+    {
+      se->expr = gfc_get_symbol_decl (sym);
+      se->expr = gfc_conv_array_data (se->expr);
+    }
+  else
+    {
+      gfc_conv_expr (se, e);
+    }
+
+  array = sym->backend_decl;
+  type = TREE_TYPE (array);
+
+  if (GFC_ARRAY_TYPE_P (type))
+    size = GFC_TYPE_ARRAY_SIZE (type);
+  else
+    {
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+      size = gfc_conv_array_stride (array, rank);
+      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+		gfc_conv_array_ubound (array, rank),
+		gfc_conv_array_lbound (array, rank));
+      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
+		gfc_index_one_node);
+      size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);      
+    }
+
+  gcc_assert (size);
+
+  /* If it is an element, we need the its address and size of the rest.  */
+  if (e->ref->u.ar.type == AR_ELEMENT)
+    {
+      size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+		TREE_OPERAND (se->expr, 1));
+      se->expr = gfc_build_addr_expr (NULL, se->expr);
+    }
+
+  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+
+  se->string_length = fold_convert (gfc_charlen_type_node, size);
+}
 
 /* Generate code to store a string and its length into the
    ioparm structure.  */
@@ -400,7 +462,15 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
     }
   else
     {
-      gfc_conv_expr (&se, e);
+      /* General character.  */
+      if (e->ts.type == BT_CHARACTER && e->rank == 0)
+	gfc_conv_expr (&se, e);
+      /* Array assigned Hollerith constant or character array.  */
+      else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
+	gfc_convert_array_to_string (&se, e);
+      else
+	gcc_unreachable ();
+
       gfc_conv_string_parameter (&se);
       gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
       gfc_add_modify_expr (&se.pre, len, se.string_length);
@@ -408,7 +478,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 
   gfc_add_block_to_block (block, &se.pre);
   gfc_add_block_to_block (postblock, &se.post);
-
 }
 
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d8efcde..57e7e08 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,16 @@
+2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/16531
+	PR fortran/15966
+	PR fortran/18781
+	* gfortran.dg/hollerith.f90: New.
+	* gfortran.dg/hollerith2.f90: New.
+	* gfortran.dg/hollerith3.f90: New.
+	* gfortran.dg/hollerith4.f90: New.
+	* gfortran.dg/hollerith_f95.f90: New.
+	* gfortran.dg/hollerith_legacy.f90: New.
+	* gfortran.dg/g77/cpp4.F: New. Port from g77.
+
 2005-07-07  Ziemowit Laski  <zlaski@apple.com>
 
 	PR objc/22274
diff --git a/gcc/testsuite/gfortran.dg/g77/cpp4.F b/gcc/testsuite/gfortran.dg/g77/cpp4.F
new file mode 100644
index 0000000..0dd5c99
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/g77/cpp4.F
@@ -0,0 +1,12 @@
+      ! { dg-do run }
+C The preprocessor must not mangle Hollerith constants
+C which contain apostrophes.
+      integer i
+      character*4 j
+      data i /4hbla'/
+      write (j, '(4a)') i
+      if (j .ne. "bla'") call abort
+      end
+
+      ! { dg-warning "Hollerith constant" "const" { target *-*-* } 6 }
+      ! { dg-warning "Conversion" "conversion" { target *-*-* } 6 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith.f90 b/gcc/testsuite/gfortran.dg/hollerith.f90
new file mode 100644
index 0000000..e273cee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith.f90
@@ -0,0 +1,108 @@
+! { dg-do run }
+! PR15966, PR18781 & PR16531
+implicit none
+complex*16 x(2) 
+complex*8 a(2,2)
+character*4 z
+character z1(4)
+character*4 z2(2,2)
+character*80 line
+integer*4 i
+logical*4 l
+real*4 r
+character*8 c
+
+data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/
+data a /8H(i3),abc, 0, 4H(i4), 8H    (i9)/
+data z/4h(i5)/
+data z1/1h(,1hi,1h6,1h)/
+data z2/4h(i7),'xxxx','xxxx','xxxx'/
+
+z2 (1,2) = 4h(i8)
+i = 4hHell
+l = 4Ho wo
+r = 4Hrld! 
+write (line, '(3A4)') i, l, r
+if (line .ne. 'Hello world!') call abort
+i = 2Hab
+r = 2Hab
+l = 2Hab
+c = 2Hab
+write (line, '(3A4, 8A)') i, l, r, c
+if (line .ne. 'ab  ab  ab  ab      ') call abort
+
+write(line, '(4A8, "!")' ) x
+if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') call abort
+
+write (line, a) 3
+if (line .ne. '  3') call abort
+write (line, a (1,2)) 4
+if (line .ne. '   4') call abort
+write (line, z) 5
+if (line .ne. '    5') call abort
+write (line, z1) 6
+if (line .ne. '     6') call abort
+write (line, z2) 7
+if (line .ne. '      7') call abort
+write (line, z2 (1,2)) 8
+if (line .ne. '       8') call abort
+write (line, '(16A)') z2
+if (line .ne. '(i7)xxxx(i8)xxxx') call abort
+call test (8h   hello)
+end
+
+subroutine test (h)
+integer*8 h
+character*80 line
+
+write (line, '(8a)') h
+if (line .ne. '   hello') call abort
+end subroutine
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 15 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 15 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 16 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 16 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 17 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 18 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 21 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 21 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 22 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 22 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 23 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 23 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 24 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 24 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 27 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 27 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 28 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 28 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 29 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 29 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 30 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 30 }
+
+! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 37 }
+
+! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 39 }
+
+! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 43 }
+
+! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 45 }
+
+! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 47 }
+
+! { dg-warning "Hollerith constant" "" { target *-*-* } 51 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith2.f90 b/gcc/testsuite/gfortran.dg/hollerith2.f90
new file mode 100644
index 0000000..773b79b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith2.f90
@@ -0,0 +1,26 @@
+       ! { dg-do run }
+       ! Program to test Hollerith constant.
+       Program test
+       implicit none
+       integer* 4 i,j
+       real r, x, y
+       parameter (i = 4h1234)
+       parameter (r = 4hdead)
+       parameter (y = 4*r)
+       parameter (j = selected_real_kind (i))
+       x = 4H1234 
+       x = sin(r)
+       x = x * r
+       x = x / r
+       x = x + r
+       x = x - r
+       end
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 7 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 7 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 8 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 8 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 11 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 11 }
+
diff --git a/gcc/testsuite/gfortran.dg/hollerith3.f90 b/gcc/testsuite/gfortran.dg/hollerith3.f90
new file mode 100644
index 0000000..b283f5f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith3.f90
@@ -0,0 +1,9 @@
+       ! { dg-do compile }
+       ! { dg-options "-w" }
+       ! Program to test invalid Hollerith constant.
+       Program test
+       implicit none
+       integer i
+       i = 0H ! { dg-error "at least one character" }
+       i = 4_8H1234 ! { dg-error "should be default" }
+       end
diff --git a/gcc/testsuite/gfortran.dg/hollerith4.f90 b/gcc/testsuite/gfortran.dg/hollerith4.f90
new file mode 100644
index 0000000..b890185
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith4.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! Test Hollerith constant assigned to allocatable array
+
+integer, allocatable :: c (:,:)
+character (len = 20) ch
+allocate (c(1,2))
+
+c(1,1) = 4H(A4)
+c(1,2) = 4H(A5)
+
+write (ch, "(2A4)") c
+if (ch .ne. "(A4)(A5)") call abort()
+write (ch, c) 'Hello'
+if (ch .ne. "Hell") call abort()
+write (ch, c (1,2)) 'Hello'
+if (ch .ne. "Hello") call abort()
+end
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 8 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 8 }
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 9 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 9 }
+
+! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 13 }
+
+! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 15 }
+
+
diff --git a/gcc/testsuite/gfortran.dg/hollerith_f95.f90 b/gcc/testsuite/gfortran.dg/hollerith_f95.f90
new file mode 100644
index 0000000..c7e4d58
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith_f95.f90
@@ -0,0 +1,100 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+! PR15966, PR18781 & PR16531
+implicit none
+complex*16 x(2) 
+complex*8 a(2,2)
+character*4 z
+character z1(4)
+character*4 z2(2,2)
+character*80 line
+integer*4 i
+logical*4 l
+real*4 r
+character*8 c
+
+data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/
+data a /8H(i3),abc, 0, 4H(i4), 8H    (i9)/
+data z/4h(i5)/
+data z1/1h(,1hi,1h6,1h)/
+data z2/4h(i7),'xxxx','xxxx','xxxx'/
+
+z2 (1,2) = 4h(i8)
+i = 4hHell
+l = 4Ho wo
+r = 4Hrld! 
+write (line, '(3A4)') i, l, r
+if (line .ne. 'Hello world!') call abort
+i = 2Hab
+r = 2Hab
+l = 2Hab
+c = 2Hab
+write (line, '(3A4, 8A)') i, l, r, c
+if (line .ne. 'ab  ab  ab  ab      ') call abort
+
+write(line, '(4A8, "!")' ) x
+if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') call abort
+
+write (line, a) 3
+if (line .ne. '  3') call abort
+write (line, a (1,2)) 4
+if (line .ne. '   4') call abort
+write (line, z) 5
+if (line .ne. '    5') call abort
+write (line, z1) 6
+if (line .ne. '     6') call abort
+write (line, z2) 7
+if (line .ne. '      7') call abort
+write (line, z2 (1,2)) 8
+if (line .ne. '       8') call abort
+write (line, '(16A)') z2
+if (line .ne. '(i7)xxxx(i8)xxxx') call abort
+call test (8h   hello)
+end
+
+subroutine test (h)
+integer*8 h
+character*80 line
+
+write (line, '(8a)') h
+if (line .ne. '   hello') call abort
+end subroutine
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 16 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 17 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 18 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 19 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 20 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 22 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 23 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 24 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 25 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 28 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 29 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 30 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 31 }
+
+! { dg-error "Hollerith constant" "const" { target *-*-* } 52 }
+
+! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 38 }
+
+! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 40 }
+
+! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 44 }
+
+! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 46 }
+
+! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 48 }
+
diff --git a/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 b/gcc/testsuite/gfortran.dg/hollerith_legacy.f90
new file mode 100644
index 0000000..561430c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith_legacy.f90
@@ -0,0 +1,61 @@
+! { dg-do compile }
+! { dg-options "-std=legacy" }
+! PR15966, PR18781 & PR16531
+implicit none
+complex*16 x(2) 
+complex*8 a(2,2)
+character*4 z
+character z1(4)
+character*4 z2(2,2)
+character*80 line
+integer*4 i
+logical*4 l
+real*4 r
+character*8 c
+
+data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/
+data a /8H(i3),abc, 0, 4H(i4), 8H    (i9)/
+data z/4h(i5)/
+data z1/1h(,1hi,1h6,1h)/
+data z2/4h(i7),'xxxx','xxxx','xxxx'/
+
+z2 (1,2) = 4h(i8)
+i = 4hHell
+l = 4Ho wo
+r = 4Hrld! 
+write (line, '(3A4)') i, l, r
+if (line .ne. 'Hello world!') call abort
+i = 2Hab
+r = 2Hab
+l = 2Hab
+c = 2Hab
+write (line, '(3A4, 8A)') i, l, r, c
+if (line .ne. 'ab  ab  ab  ab      ') call abort
+
+write(line, '(4A8, "!")' ) x
+if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') call abort
+
+write (line, a) 3
+if (line .ne. '  3') call abort
+write (line, a (1,2)) 4
+if (line .ne. '   4') call abort
+write (line, z) 5
+if (line .ne. '    5') call abort
+write (line, z1) 6
+if (line .ne. '     6') call abort
+write (line, z2) 7
+if (line .ne. '      7') call abort
+write (line, z2 (1,2)) 8
+if (line .ne. '       8') call abort
+write (line, '(16A)') z2
+if (line .ne. '(i7)xxxx(i8)xxxx') call abort
+call test (8h   hello)
+end
+
+subroutine test (h)
+integer*8 h
+character*80 line
+
+write (line, '(8a)') h
+if (line .ne. '   hello') call abort
+end subroutine
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 42b78ee..242bd3c 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,9 @@
+2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>
+
+	PR fortran/16531
+	* io/transfer.c (formatted_transfer): Enable FMT_A on other types to
+	support Hollerith constants.
+
 2005-07-01  Andreas Jaeger  <aj@suse.de>
 
 	* intrinsics/unpack_generic.c: Remove const from parameter.
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 6a4a15e..bcba218 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -524,8 +524,6 @@ formatted_transfer (bt type, void *p, int len)
 	case FMT_A:
 	  if (n == 0)
 	    goto need_data;
-	  if (require_type (BT_CHARACTER, type, f))
-	    return;
 
 	  if (g.mode == READING)
 	    read_a (f, p, len);