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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101688 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 73 insertions, 0 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index e14ab925e85..1f8305bf7b4 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;