PR libfortran/64770 Segfault when trying to open existing file with status="new".

[gcc.git] / libgfortran / io / write.c

diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 61b5691d619b2280688c453b7ba7d429d00b4b9e..2149456d3dab28de9e9c3757409a3277bef71285 100644 (file)
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002-2014 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2015 Free Software Foundation, Inc.
    Contributed by Andy Vaught
    Namelist output contributed by Paul Thomas
    F2003 I/O support contributed by Jerry DeLisle
@@ -1312,24 +1312,32 @@ write_integer (st_parameter_dt *dtp, const char *source, int length)
 /* Write a list-directed string.  We have to worry about delimiting
    the strings if the file has been opened in that mode.  */
 
+#define DELIM 1
+#define NODELIM 0
+
 static void
-write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
+write_character (st_parameter_dt *dtp, const char *source, int kind, int length, int mode)
 {
   int i, extra;
   char *p, d;
 
-  switch (dtp->u.p.current_unit->delim_status)
+  if (mode == DELIM)
     {
-    case DELIM_APOSTROPHE:
-      d = '\'';
-      break;
-    case DELIM_QUOTE:
-      d = '"';
-      break;
-    default:
-      d = ' ';
-      break;
+      switch (dtp->u.p.current_unit->delim_status)
+       {
+       case DELIM_APOSTROPHE:
+         d = '\'';
+         break;
+       case DELIM_QUOTE:
+         d = '"';
+         break;
+       default:
+         d = ' ';
+         break;
+       }
     }
+  else
+    d = ' ';
 
   if (kind == 1)
     {
@@ -1551,7 +1559,8 @@ 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->delim_status != DELIM_NONE)
+         (dtp->u.p.current_unit->delim_status != DELIM_NONE
+          && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
       write_separator (dtp);
     }
 
@@ -1564,7 +1573,7 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
       write_logical (dtp, p, kind);
       break;
     case BT_CHARACTER:
-      write_character (dtp, p, kind, size);
+      write_character (dtp, p, kind, size, DELIM);
       break;
     case BT_REAL:
       write_real (dtp, p, kind);
@@ -1628,9 +1637,9 @@ namelist_write_newline (st_parameter_dt *dtp)
   if (!is_internal_unit (dtp))
     {
 #ifdef HAVE_CRLF
-      write_character (dtp, "\r\n", 1, 2);
+      write_character (dtp, "\r\n", 1, 2, NODELIM);
 #else
-      write_character (dtp, "\n", 1, 1);
+      write_character (dtp, "\n", 1, 1, NODELIM);
 #endif
       return;
     }
@@ -1675,7 +1684,7 @@ namelist_write_newline (st_parameter_dt *dtp)
        }
     }
   else
-    write_character (dtp, " ", 1, 1);
+    write_character (dtp, " ", 1, 1, NODELIM);
 }
 
 
@@ -1704,7 +1713,6 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   size_t base_name_len;
   size_t base_var_name_len;
   size_t tot_len;
-  unit_delim tmp_delim;
   
   /* Set the character to be used to separate values
      to a comma or semi-colon.  */
@@ -1718,7 +1726,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   if (obj->type != BT_DERIVED)
     {
       namelist_write_newline (dtp);
-      write_character (dtp, " ", 1, 1);
+      write_character (dtp, " ", 1, 1, NODELIM);
 
       len = 0;
       if (base)
@@ -1728,16 +1736,16 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
          for (dim_i = 0; dim_i < base_name_len; dim_i++)
             {
              cup = toupper ((int) base_name[dim_i]);
-             write_character (dtp, &cup, 1, 1);
+             write_character (dtp, &cup, 1, 1, NODELIM);
             }
        }
       clen = strlen (obj->var_name);
       for (dim_i = len; dim_i < clen; dim_i++)
        {
          cup = toupper ((int) obj->var_name[dim_i]);
-         write_character (dtp, &cup, 1, 1);
+         write_character (dtp, &cup, 1, 1, NODELIM);
        }
-      write_character (dtp, "=", 1, 1);
+      write_character (dtp, "=", 1, 1, NODELIM);
     }
 
   /* Counts the number of data output on a line, including names.  */
@@ -1807,7 +1815,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
          if (rep_ctr > 1)
            {
              snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
-             write_character (dtp, rep_buff, 1, strlen (rep_buff));
+             write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
              dtp->u.p.no_leading_blank = 1;
            }
          num++;
@@ -1827,13 +1835,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
               break;
 
            case BT_CHARACTER:
-             tmp_delim = dtp->u.p.current_unit->delim_status;
-             if (dtp->u.p.nml_delim == '"')
-               dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
-             if (dtp->u.p.nml_delim == '\'')
-               dtp->u.p.current_unit->delim_status = DELIM_APOSTROPHE;
-             write_character (dtp, p, 1, obj->string_length);
-               dtp->u.p.current_unit->delim_status = tmp_delim;
+             if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+               write_character (dtp, p, 4, obj->string_length, DELIM);
+             else
+               write_character (dtp, p, 1, obj->string_length, DELIM);
               break;
 
            case BT_REAL:
@@ -1862,7 +1867,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
              base_var_name_len = base ? strlen (base->var_name) : 0;
              ext_name_len = base_name_len + base_var_name_len 
                + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
-             ext_name = (char*)xmalloc (ext_name_len);
+             ext_name = xmalloc (ext_name_len);
 
              memcpy (ext_name, base_name, base_name_len);
              clen = strlen (obj->var_name + base_var_name_len);
@@ -1891,7 +1896,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
              /* Now obj_name.  */
 
              obj_name_len = strlen (obj->var_name) + 1;
-             obj_name = xmalloc (obj_name_len+1);
+             obj_name = xmalloc (obj_name_len + 1);
              memcpy (obj_name, obj->var_name, obj_name_len-1);
              memcpy (obj_name + obj_name_len-1, "%", 2);
 
@@ -1921,12 +1926,20 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
             to column 2. Reset the repeat counter.  */
 
          dtp->u.p.no_leading_blank = 0;
-         write_character (dtp, &semi_comma, 1, 1);
+         if (obj->type == BT_CHARACTER)
+           {
+             if (dtp->u.p.nml_delim != '\0')
+               write_character (dtp, &semi_comma, 1, 1, NODELIM);
+           }
+         else
+           write_character (dtp, &semi_comma, 1, 1, NODELIM);
          if (num > 5)
            {
              num = 0;
+             if (dtp->u.p.nml_delim == '\0')
+               write_character (dtp, &semi_comma, 1, 1, NODELIM);
              namelist_write_newline (dtp);
-             write_character (dtp, " ", 1, 1);
+             write_character (dtp, " ", 1, 1, NODELIM);
            }
          rep_ctr = 1;
        }
@@ -1935,17 +1948,17 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 
 obj_loop:
 
-    nml_carry = 1;
-    for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
-      {
-       obj->ls[dim_i].idx += nml_carry ;
-       nml_carry = 0;
-       if (obj->ls[dim_i].idx  > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
-         {
-           obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
-           nml_carry = 1;
-         }
-       }
+      nml_carry = 1;
+      for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
+       {
+         obj->ls[dim_i].idx += nml_carry ;
+         nml_carry = 0;
+         if (obj->ls[dim_i].idx  > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
+           {
+             obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
+             nml_carry = 1;
+           }
+        }
     }
 
   /* Return a pointer beyond the furthest object accessed.  */
@@ -1967,23 +1980,28 @@ namelist_write (st_parameter_dt *dtp)
   index_type dummy_offset = 0;
   char c;
   char * dummy_name = NULL;
-  unit_delim tmp_delim = DELIM_UNSPECIFIED;
 
   /* Set the delimiter for namelist output.  */
-  tmp_delim = dtp->u.p.current_unit->delim_status;
-
-  dtp->u.p.nml_delim = tmp_delim == DELIM_APOSTROPHE ? '\'' : '"';
-
-  /* Temporarily disable namelist delimters.  */
-  dtp->u.p.current_unit->delim_status = DELIM_NONE;
+  switch (dtp->u.p.current_unit->delim_status)
+    {
+      case DELIM_APOSTROPHE:
+        dtp->u.p.nml_delim = '\'';
+       break;
+      case DELIM_QUOTE:
+      case DELIM_UNSPECIFIED:
+       dtp->u.p.nml_delim = '"';
+       break;
+      default:
+       dtp->u.p.nml_delim = '\0';
+    }
 
-  write_character (dtp, "&", 1, 1);
+  write_character (dtp, "&", 1, 1, NODELIM);
 
   /* Write namelist name in upper case - f95 std.  */
   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
     {
       c = toupper ((int) dtp->namelist_name[i]);
-      write_character (dtp, &c, 1 ,1);
+      write_character (dtp, &c, 1 ,1, NODELIM);
     }
 
   if (dtp->u.p.ionml != NULL)
@@ -1997,9 +2015,7 @@ namelist_write (st_parameter_dt *dtp)
     }
 
   namelist_write_newline (dtp);
-  write_character (dtp, " /", 1, 2);
-  /* Restore the original delimiter.  */
-  dtp->u.p.current_unit->delim_status = tmp_delim;
+  write_character (dtp, " /", 1, 2, NODELIM);
 }
 
 #undef NML_DIGITS