PR fortran/25829 28655

2008-04-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/25829 28655
	* io/open.c (edit_modes): Set flags.async. (new_unit) Set flags.async
	and flags.status. (st_open): Initialize flags.async.
	* io/list_read.c (read_charactor): Use delim_status instead of
	flags.delim.
	* io/read.c (read_x): Use pad_status instead of flags.pad.
	* io/inquire.c (inquire_via_unit): Add new checks.
	(inquire_via_filename): Likewise.
	* io/io.h (st_parameter_inquire): Add new flags.
	(st_parameter_dt): Likewise.
	* io/unit.c (get_internal_unit): Set flags.async. (init_units): Set
	flags.async.
	* io/transfer.c: Add delim and pad option arrays. (read_sf): Use
	pad_status instead of flags.pad. (read_block): Likewise.
	(data_transfer_init): Set flags.async and add checks.
	* io/write.c (write_character): Use delim_status.
	(list_formatted_write_scalar): Likewise. (nml_write_obj): Likewise.
	(namelist_write): Likewise.

From-SVN: r133988

libgfortran/ChangeLog

@@ -1,3 +1,24 @@
+2008-04-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/25829 28655
+	* io/open.c (edit_modes): Set flags.async. (new_unit) Set flags.async
+	and flags.status. (st_open): Initialize flags.async.
+	* io/list_read.c (read_charactor): Use delim_status instead of
+	flags.delim.
+	* io/read.c (read_x): Use pad_status instead of flags.pad.
+	* io/inquire.c (inquire_via_unit): Add new checks.
+	(inquire_via_filename): Likewise.
+	* io/io.h (st_parameter_inquire): Add new flags.
+	(st_parameter_dt): Likewise.
+	* io/unit.c (get_internal_unit): Set flags.async. (init_units): Set
+	flags.async.
+	* io/transfer.c: Add delim and pad option arrays. (read_sf): Use
+	pad_status instead of flags.pad. (read_block): Likewise.
+	(data_transfer_init): Set flags.async and add checks.
+	* io/write.c (write_character): Use delim_status.
+	(list_formatted_write_scalar): Likewise. (nml_write_obj): Likewise.
+	(namelist_write): Likewise.
+
 2008-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/25829 28655

libgfortran/io/inquire.c

@@ -43,6 +43,7 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
 {
   const char *p;
   GFC_INTEGER_4 cf = iqp->common.flags;
+  GFC_INTEGER_4 cf2 = iqp->flags2;
 
   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
     {
@@ -213,7 +214,7 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
 
   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
     {
-      if (u == NULL)
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
 	p = undefined;
       else
 	switch (u->flags.blank)
@@ -231,6 +232,148 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
       cf_strcpy (iqp->blank, iqp->blank_len, p);
     }
 
+  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.pad)
+	  {
+	  case PAD_YES:
+	    p = "YES";
+	    break;
+	  case PAD_NO:
+	    p = "NO";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
+	  }
+
+      cf_strcpy (iqp->pad, iqp->pad_len, p);
+    }
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+    *iqp->pending = 0;
+  
+  if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
+    *iqp->id = 0;
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.encoding)
+	  {
+	  case ENCODING_DEFAULT:
+	    p = "UNKNOWN";
+	    break;
+	  /* TODO: Enable UTF-8 case here when implemented.
+	  case ENCODING_UTF8:
+	    p = "UTF-8";
+	    break; */
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
+	  }
+
+      cf_strcpy (iqp->encoding, iqp->encoding_len, p);
+    }
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.decimal)
+	  {
+	  case DECIMAL_POINT:
+	    p = "POINT";
+	    break;
+	  case DECIMAL_COMMA:
+	    p = "COMMA";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
+	  }
+
+      cf_strcpy (iqp->decimal, iqp->decimal_len, p);
+    }
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.async)
+	  {
+	  case ASYNC_YES:
+	    p = "YES";
+	    break;
+	  case ASYNC_NO:
+	    p = "NO";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+	  }
+
+      cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
+    }
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.sign)
+	  {
+	  case SIGN_PROCDEFINED:
+	    p = "PROCESSOR_DEFINED";
+	    break;
+	  case SIGN_SUPPRESS:
+	    p = "SUPPRESS";
+	    break;
+	  case SIGN_PLUS:
+	    p = "PLUS";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
+	  }
+
+      cf_strcpy (iqp->sign, iqp->sign_len, p);
+    }
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.round)
+	  {
+	  case ROUND_UP:
+	    p = "UP";
+	    break;
+	  case ROUND_DOWN:
+	    p = "DOWN";
+	    break;
+	  case ROUND_ZERO:
+	    p = "ZERO";
+	    break;
+	  case ROUND_NEAREST:
+	    p = "NEAREST";
+	    break;
+	  case ROUND_COMPATIBLE:
+	    p = "COMPATIBLE";
+	    break;
+	  case ROUND_PROCDEFINED:
+	    p = "PROCESSOR_DEFINED";
+	    break;
+	  default:
+	    internal_error (&iqp->common, "inquire_via_unit(): Bad round");
+	  }
+
+      cf_strcpy (iqp->round, iqp->round_len, p);
+    }
+
   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
     {
       if (u == NULL || u->flags.access == ACCESS_DIRECT)
@@ -380,6 +523,7 @@ inquire_via_filename (st_parameter_inquire *iqp)
 {
   const char *p;
   GFC_INTEGER_4 cf = iqp->common.flags;
+  GFC_INTEGER_4 cf2 = iqp->flags2;
 
   if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
     *iqp->exist = file_exists (iqp->file, iqp->file_len);
@@ -435,6 +579,18 @@ inquire_via_filename (st_parameter_inquire *iqp)
   if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
     cf_strcpy (iqp->blank, iqp->blank_len, undefined);
 
+  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+    cf_strcpy (iqp->pad, iqp->pad_len, undefined);
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
+    cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
+  
+  if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
+    cf_strcpy (iqp->delim, iqp->delim_len, undefined);
+
+  if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
+    cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
+
   if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
     cf_strcpy (iqp->position, iqp->position_len, undefined);
 
@@ -459,11 +615,14 @@ inquire_via_filename (st_parameter_inquire *iqp)
       cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
     }
 
-  if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+  if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
     cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 
-  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+  if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
     cf_strcpy (iqp->pad, iqp->pad_len, undefined);
+  
+  if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
+    cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
 }
 
 

libgfortran/io/io.h

@@ -235,7 +235,7 @@ typedef enum
 unit_mode;
 
 typedef enum
-{ ASYNC_YES, ASYNC_NO, AYSYNC_UNSPECIFIED }
+{ ASYNC_YES, ASYNC_NO, ASYNC_UNSPECIFIED }
 unit_async;
 
 #define CHARACTER1(name) \
@@ -342,13 +342,13 @@ typedef struct
   CHARACTER1 (convert);
   GFC_INTEGER_4 flags2;
   CHARACTER1 (asynchronous);
-  CHARACTER1 (decimal);
+  CHARACTER2 (decimal);
   CHARACTER1 (encoding);
-  CHARACTER1 (pending);
+  CHARACTER2 (pending);
   CHARACTER1 (round);
-  CHARACTER1 (sign);
+  CHARACTER2 (sign);
   GFC_INTEGER_4 *size;
-  GFC_IO_INT id;
+  GFC_INTEGER_4 *id;
 }
 st_parameter_inquire;
 
@@ -409,6 +409,7 @@ typedef struct st_parameter_dt
 	  int item_count;
 	  unit_mode mode;
 	  unit_blank blank_status;
+          unit_pad pad_status;
 	  enum { SIGN_S, SIGN_SS, SIGN_SP } sign_status;
 	  int scale_factor;
 	  int max_pos; /* Maximum righthand column written to.  */
@@ -423,6 +424,7 @@ typedef struct st_parameter_dt
 	  int sf_seen_eor;
 	  unit_advance advance_status;
 	  unit_decimal decimal_status;
+          unit_delim delim_status;
 
 	  unsigned reversion_flag : 1; /* Format reversion has occurred.  */
 	  unsigned first_item : 1;

libgfortran/io/list_read.c

@@ -943,8 +943,8 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
     default:
       if (dtp->u.p.namelist_mode)
 	{
-	  if (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
+	  if (dtp->u.p.delim_status == DELIM_APOSTROPHE
-	      || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE
+	      || dtp->u.p.delim_status == DELIM_QUOTE
 	      || c == '&' || c == '$' || c == '/')
 	    {
 	      unget_char (dtp, c);

libgfortran/io/open.c

@@ -254,6 +254,8 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 	u->flags.decimal = flags->decimal;
       if (flags->encoding != ENCODING_UNSPECIFIED)
 	u->flags.encoding = flags->encoding;
+      if (flags->async != ASYNC_UNSPECIFIED)
+	u->flags.async = flags->async;
       if (flags->round != ROUND_UNSPECIFIED)
 	u->flags.round = flags->round;
       if (flags->sign != SIGN_UNSPECIFIED)
@@ -317,6 +319,13 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
     flags->form = (flags->access == ACCESS_SEQUENTIAL)
       ? FORM_FORMATTED : FORM_UNFORMATTED;
 
+  if (flags->async == ASYNC_UNSPECIFIED)
+    flags->async = ASYNC_NO;
+
+  if (flags->status == STATUS_UNSPECIFIED)
+    flags->status = STATUS_UNKNOWN;
+
+  /* Checks.  */
 
   if (flags->delim == DELIM_UNSPECIFIED)
     flags->delim = DELIM_NONE;
@@ -424,12 +433,6 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
    if (flags->position == POSITION_UNSPECIFIED)
      flags->position = POSITION_ASIS;
 
-
-  if (flags->status == STATUS_UNSPECIFIED)
-    flags->status = STATUS_UNKNOWN;
-
-  /* Checks.  */
-
   if (flags->access == ACCESS_DIRECT
       && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
     {
@@ -739,6 +742,10 @@ st_open (st_parameter_open *opp)
     find_option (&opp->common, opp->encoding, opp->encoding_len,
 		 encoding_opt, "Bad ENCODING parameter in OPEN statement");
 
+  flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
+    find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
+		 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
+
   flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
     find_option (&opp->common, opp->round, opp->round_len,
 		 round_opt, "Bad ROUND parameter in OPEN statement");

libgfortran/io/read.c

@@ -854,7 +854,7 @@ read_x (st_parameter_dt *dtp, int n)
 {
   if (!is_stream_io (dtp))
     {
-      if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
+      if ((dtp->u.p.pad_status == PAD_NO || is_internal_unit (dtp))
 	  && dtp->u.p.current_unit->bytes_left < n)
 	n = dtp->u.p.current_unit->bytes_left;
 

libgfortran/io/transfer.c

@@ -114,6 +114,19 @@ static const st_option blank_opt[] = {
   {NULL, 0}
 };
 
+static const st_option delim_opt[] = {
+  {"apostrophe", DELIM_APOSTROPHE},
+  {"quote", DELIM_QUOTE},
+  {"none", DELIM_NONE},
+  {NULL, 0}
+};
+
+static const st_option pad_opt[] = {
+  {"yes", PAD_YES},
+  {"no", PAD_NO},
+  {NULL, 0}
+};
+
 typedef enum
 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
   FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -242,7 +255,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
 	  /* Without padding, terminate the I/O statement without assigning
 	     the value.  With padding, the value still needs to be assigned,
 	     so we can just continue with a short read.  */
-	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+	  if (dtp->u.p.pad_status == PAD_NO)
 	    {
 	      if (no_error)
 		break;
@@ -320,7 +333,7 @@ read_block (st_parameter_dt *dtp, int *length)
           dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
 	  else
 	    {
-	      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+	      if (dtp->u.p.pad_status == PAD_NO)
 		{
 		  /* Not enough data left.  */
 		  generate_error (&dtp->common, LIBERROR_EOR, NULL);
@@ -358,7 +371,7 @@ read_block (st_parameter_dt *dtp, int *length)
 
   if (nread != *length)
     {				/* Short read, this shouldn't happen.  */
-      if (dtp->u.p.current_unit->flags.pad == PAD_YES)
+      if (dtp->u.p.pad_status == PAD_YES)
 	*length = nread;
       else
 	{
@@ -1802,6 +1815,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
      u_flags.pad = PAD_UNSPECIFIED;
      u_flags.decimal = DECIMAL_UNSPECIFIED;
      u_flags.encoding = ENCODING_UNSPECIFIED;
+     u_flags.async = ASYNC_UNSPECIFIED;
      u_flags.round = ROUND_UNSPECIFIED;
      u_flags.sign = SIGN_UNSPECIFIED;
      u_flags.status = STATUS_UNKNOWN;
@@ -2021,6 +2035,23 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
     dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
   
+  /* Check the delim mode.  */
+  dtp->u.p.delim_status
+    = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
+      find_option (&dtp->common, dtp->delim, dtp->delim_len, delim_opt,
+		   "Bad DELIM parameter in data transfer statement");
+  
+  if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
+    dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
+
+  /* Check the pad mode.  */
+  dtp->u.p.pad_status
+    = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
+      find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
+		   "Bad PAD parameter in data transfer statement");
+  
+  if (dtp->u.p.pad_status == PAD_UNSPECIFIED)
+    dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
  
   /* Sanity checks on the record number.  */
   if ((cf & IOPARM_DT_HAS_REC) != 0)

libgfortran/io/unit.c

@@ -443,6 +443,7 @@ get_internal_unit (st_parameter_dt *dtp)
   iunit->flags.sign = SIGN_SUPPRESS;
   iunit->flags.decimal = DECIMAL_POINT;
   iunit->flags.encoding = ENCODING_DEFAULT;
+  iunit->flags.async = ASYNC_NO;
 
   /* Initialize the data transfer parameters.  */
 
@@ -531,6 +532,7 @@ init_units (void)
       u->flags.sign = SIGN_SUPPRESS;
       u->flags.decimal = DECIMAL_POINT;
       u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
      
       u->recl = options.default_recl;
       u->endfile = NO_ENDFILE;
@@ -557,6 +559,7 @@ init_units (void)
       u->flags.sign = SIGN_SUPPRESS;
       u->flags.decimal = DECIMAL_POINT;
       u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
@@ -583,6 +586,7 @@ init_units (void)
       u->flags.sign = SIGN_SUPPRESS;
       u->flags.decimal = DECIMAL_POINT;
       u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;

libgfortran/io/write.c

@@ -640,7 +640,7 @@ write_character (st_parameter_dt *dtp, const char *source, int length)
   int i, extra;
   char *p, d;
 
-  switch (dtp->u.p.current_unit->flags.delim)
+  switch (dtp->u.p.delim_status)
     {
     case DELIM_APOSTROPHE:
       d = '\'';
@@ -779,7 +779,7 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
   else
     {
       if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
-	  dtp->u.p.current_unit->flags.delim != DELIM_NONE)
+	  dtp->u.p.delim_status != DELIM_NONE)
 	write_separator (dtp);
     }
 
@@ -994,13 +994,13 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
               break;
 
 	    case GFC_DTYPE_CHARACTER:
-	      tmp_delim = dtp->u.p.current_unit->flags.delim;
+	      tmp_delim = dtp->u.p.delim_status;
 	      if (dtp->u.p.nml_delim == '"')
-		dtp->u.p.current_unit->flags.delim = DELIM_QUOTE;
+		dtp->u.p.delim_status = DELIM_QUOTE;
 	      if (dtp->u.p.nml_delim == '\'')
-		dtp->u.p.current_unit->flags.delim = DELIM_APOSTROPHE;
+		dtp->u.p.delim_status = DELIM_APOSTROPHE;
 	      write_character (dtp, p, obj->string_length);
-	      dtp->u.p.current_unit->flags.delim = tmp_delim;
+	      dtp->u.p.delim_status = tmp_delim;
               break;
 
 	    case GFC_DTYPE_REAL:
@@ -1141,7 +1141,7 @@ namelist_write (st_parameter_dt *dtp)
 
   /* Set the delimiter for namelist output.  */
 
-  tmp_delim = dtp->u.p.current_unit->flags.delim;
+  tmp_delim = dtp->u.p.delim_status;
   switch (tmp_delim)
     {
     case (DELIM_QUOTE):
@@ -1158,7 +1158,7 @@ namelist_write (st_parameter_dt *dtp)
     }
 
   /* Temporarily disable namelist delimters.  */
-  dtp->u.p.current_unit->flags.delim = DELIM_NONE;
+  dtp->u.p.delim_status = DELIM_NONE;
 
   write_character (dtp, "&", 1);
 
@@ -1186,7 +1186,7 @@ namelist_write (st_parameter_dt *dtp)
 #endif
 
   /* Restore the original delimiter.  */
-  dtp->u.p.current_unit->flags.delim = tmp_delim;
+  dtp->u.p.delim_status = tmp_delim;
 }
 
 #undef NML_DIGITS