OSDN Git Service

2008-06-13 Jerry DeLisle <jvdelisle@gcc.gnu.org>
authorjvdelisle <jvdelisle@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 13 Jun 2008 20:28:08 +0000 (20:28 +0000)
committerjvdelisle <jvdelisle@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 13 Jun 2008 20:28:08 +0000 (20:28 +0000)
PR fortran/35863
* libgfortran.h: Change l8_to_l4_offset to big_endian and add endian_off.
* runtime/main.c: Fix error in comment. Change l8_to_l4_offset to
big_endian. (determine_endianness): Add endian_off and set its value
according to big_endian.
* gfortran.map: Add symbol for new _gfortran_transfer_character_wide.
* io/io.h: Add prototype declarations for new functions.
* io/list_read.c (list_formatted_read_scalar): Modify to handle kind=4.
(list_formatted_read): Calculate stride based on kind for character type
and use it when calling list_formatted_read_scalar.
* io/inquire.c (inquire_via_unit): Change l8_to_l4_offset to big_endian.
* io/open.c (st_open): Change l8_to_l4_offset to big_endian.
* io/read.c (read_a_char4): New function to handle formatted read.
* io/write.c: Define GFC_CHAR4(x) to improve readability of code.
(write_a_char4): New function to handle formatted write.
(write_character): Modify to accept the kind parameter and adjust for
endianess of the machine. (list_formatted_write): Calculate the stride
resulting from the kind and adjust the list_formatted_write_scalar call
accordingly. (nml_write_obj): Adjust calls to write_character.
(namelist_write): Likewise.
* io/transfer.c (formatted_transfer_scaler): Rename 'len' argument to
'kind' argument to better describe what it is. Add calls to new
functions for kind == 4. (formatted_transfer): Modify to handle the case
of type character and kind equals 4 to pass in the kind to the transfer
routines. (transfer_character_wide): Add this new function.
(transfer_array): Don't set kind to the character string length. Adjust
strides bases on character kind.
(unformatted_read): Adjust size based on kind for character types.
(unformatted_write): Likewise. (data_transfer_init): Change
l8_to_l4_offset to big_endian.

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

12 files changed:
libgfortran/ChangeLog
libgfortran/gfortran.map
libgfortran/io/fbuf.c
libgfortran/io/inquire.c
libgfortran/io/io.h
libgfortran/io/list_read.c
libgfortran/io/open.c
libgfortran/io/read.c
libgfortran/io/transfer.c
libgfortran/io/write.c
libgfortran/libgfortran.h
libgfortran/runtime/main.c

index 5c931e6..0448967 100644 (file)
@@ -1,3 +1,36 @@
+2008-06-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+       PR fortran/35863
+       * libgfortran.h: Change l8_to_l4_offset to big_endian and add endian_off.
+       * runtime/main.c: Fix error in comment. Change l8_to_l4_offset to
+       big_endian. (determine_endianness): Add endian_off and set its value
+       according to big_endian.
+       * gfortran.map: Add symbol for new _gfortran_transfer_character_wide.
+       * io/io.h: Add prototype declarations for new functions.
+       * io/list_read.c (list_formatted_read_scalar): Modify to handle kind=4.
+       (list_formatted_read): Calculate stride based on kind for character type
+       and use it when calling list_formatted_read_scalar.
+       * io/inquire.c (inquire_via_unit): Change l8_to_l4_offset to big_endian.
+       * io/open.c (st_open): Change l8_to_l4_offset to big_endian.
+       * io/read.c (read_a_char4): New function to handle formatted read.
+       * io/write.c: Define GFC_CHAR4(x) to improve readability of code.
+       (write_a_char4): New function to handle formatted write.
+       (write_character): Modify to accept the kind parameter and adjust for
+       endianess of the machine. (list_formatted_write): Calculate the stride
+       resulting from the kind and adjust the list_formatted_write_scalar call
+       accordingly. (nml_write_obj): Adjust calls to write_character.
+       (namelist_write): Likewise.
+       * io/transfer.c (formatted_transfer_scaler): Rename 'len' argument to
+       'kind' argument to better describe what it is. Add calls to new
+       functions for kind == 4. (formatted_transfer): Modify to handle the case
+       of type character and kind equals 4 to pass in the kind to the transfer
+       routines. (transfer_character_wide): Add this new function.
+       (transfer_array): Don't set kind to the character string length. Adjust
+       strides bases on character kind.
+       (unformatted_read): Adjust size based on kind for character types.
+       (unformatted_write): Likewise. (data_transfer_init): Change
+       l8_to_l4_offset to big_endian. 
+
 2008-06-13  Tobias Burnus  <burnus@net-b.de>
 
        * configure.ac (AM_CFLAGS): Remove -Werror again.
index 60ef853..0671b60 100644 (file)
@@ -1083,6 +1083,7 @@ GFORTRAN_1.1 {
     _gfortran_string_trim_char4;
     _gfortran_string_verify_char4;
     _gfortran_st_wait;
+    _gfortran_transfer_character_wide;
     _gfortran_transpose_char4;
     _gfortran_unpack0_char4;
     _gfortran_unpack1_char4;
index a0d033b..f2b1599 100644 (file)
@@ -157,7 +157,7 @@ fbuf_seek (gfc_unit * u, gfc_offset off)
   /* Moving to the left past the flushed marked would imply moving past
      the left tab limit, which is never allowed. So return error if
      that is attempted.  */
-  if (pos < u->fbuf->flushed)
+  if (pos < (gfc_offset) u->fbuf->flushed)
     return -1;
   u->fbuf->pos = pos;
   return 0;
index 5e0cf3e..9eb63d7 100644 (file)
@@ -268,10 +268,9 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
          case ENCODING_DEFAULT:
            p = "UNKNOWN";
            break;
-         /* TODO: Enable UTF-8 case here when implemented.
          case ENCODING_UTF8:
            p = "UTF-8";
-           break; */
+           break;
          default:
            internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
          }
@@ -497,13 +496,13 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
       else
        switch (u->flags.convert)
          {
-           /*  l8_to_l4_offset is 0 for little-endian, 1 for big-endian.  */
+           /*  big_endian is 0 for little-endian, 1 for big-endian.  */
          case GFC_CONVERT_NATIVE:
-           p = l8_to_l4_offset ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
+           p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
            break;
 
          case GFC_CONVERT_SWAP:
-           p = l8_to_l4_offset ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
+           p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
            break;
 
          default:
index ea75bdb..cb7147d 100644 (file)
@@ -869,6 +869,9 @@ internal_proto(convert_real);
 extern void read_a (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_a);
 
+extern void read_a_char4 (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_a);
+
 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_f);
 
@@ -904,6 +907,9 @@ internal_proto(namelist_write);
 extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_a);
 
+extern void write_a_char4 (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_a_char4);
+
 extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_b);
 
index 1aa8470..c99e3a8 100644 (file)
@@ -1728,7 +1728,8 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
                            int kind, size_t size)
 {
   char c;
-  int m;
+  gfc_char4_t *q;
+  int i, m;
   jmp_buf eof_jump;
 
   dtp->u.p.namelist_mode = 0;
@@ -1831,17 +1832,33 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
 
     case BT_CHARACTER:
       if (dtp->u.p.saved_string)
-       {
+       {
          m = ((int) size < dtp->u.p.saved_used)
              ? (int) size : dtp->u.p.saved_used;
-         memcpy (p, dtp->u.p.saved_string, m);
-       }
+         if (kind == 1)
+           memcpy (p, dtp->u.p.saved_string, m);
+         else
+           {
+             q = (gfc_char4_t *) p;
+             for (i = 0; i < m; i++)
+               q[i] = (unsigned char) dtp->u.p.saved_string[i];
+           }
+       }
       else
        /* Just delimiters encountered, nothing to copy but SPACE.  */
         m = 0;
 
       if (m < (int) size)
-       memset (((char *) p) + m, ' ', size - m);
+       {
+         if (kind == 1)
+           memset (((char *) p) + m, ' ', size - m);
+         else
+           {
+             q = (gfc_char4_t *) p;
+             for (i = m; i < (int) size; i++)
+               q[i] = (unsigned char) ' ';
+           }
+       }
       break;
 
     case BT_NULL:
@@ -1862,6 +1879,8 @@ list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
 {
   size_t elem;
   char *tmp;
+  size_t stride = type == BT_CHARACTER ?
+                 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
 
   tmp = (char *) p;
 
@@ -1869,7 +1888,7 @@ list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
   for (elem = 0; elem < nelems; elem++)
     {
       dtp->u.p.item_count++;
-      list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
+      list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
     }
 }
 
index 84575f7..4a78efa 100644 (file)
@@ -107,7 +107,7 @@ static const st_option decimal_opt[] =
 
 static const st_option encoding_opt[] =
 {
-  /* TODO { "utf-8", ENCODING_UTF8}, */
+  { "utf-8", ENCODING_UTF8},
   { "default", ENCODING_DEFAULT},
   { NULL, 0}
 };
@@ -795,7 +795,7 @@ st_open (st_parameter_open *opp)
        conv = compile_options.convert;
     }
   
-  /* We use l8_to_l4_offset, which is 0 on little-endian machines
+  /* We use big_endian, which is 0 on little-endian machines
      and 1 on big-endian machines.  */
   switch (conv)
     {
@@ -804,11 +804,11 @@ st_open (st_parameter_open *opp)
       break;
       
     case GFC_CONVERT_BIG:
-      conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+      conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
       break;
       
     case GFC_CONVERT_LITTLE:
-      conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+      conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
       break;
       
     default:
index a09d663..11a1ac0 100644 (file)
@@ -270,6 +270,43 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
     memset (p + m, ' ', n);
 }
 
+void
+read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
+{
+  char *s;
+  gfc_char4_t *dest;
+  int m, n, wi, status;
+  size_t w;
+
+  wi = f->u.w;
+  if (wi == -1) /* '(A)' edit descriptor  */
+    wi = length;
+
+  w = wi;
+
+  s = gfc_alloca (w);
+
+  /* Read in w bytes, treating comma as not a separator.  */
+  dtp->u.p.sf_read_comma = 0;
+  status = read_block_form (dtp, s, &w);
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+  
+  if (status == FAILURE)
+    return;
+  if (w > (size_t) length)
+     s += (w - length);
+
+  m = ((int) w > length) ? length : (int) w;
+  
+  dest = (gfc_char4_t *) p;
+  
+  for (n = 0; n < m; n++, dest++, s++)
+    *dest = (unsigned char ) *s;
+
+  for (n = 0; n < length - (int) w; n++, dest++)
+    *dest = (unsigned char) ' ';
+}
 
 /* eat_leading_spaces()-- Given a character pointer and a width,
  * ignore the leading spaces.  */
index 36181f6..fd63139 100644 (file)
@@ -54,6 +54,7 @@ Boston, MA 02110-1301, USA.  */
       transfer_integer
       transfer_logical
       transfer_character
+      transfer_character_wide
       transfer_real
       transfer_complex
 
@@ -76,6 +77,9 @@ export_proto(transfer_logical);
 extern void transfer_character (st_parameter_dt *, void *, int);
 export_proto(transfer_character);
 
+extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+export_proto(transfer_character_wide);
+
 extern void transfer_complex (st_parameter_dt *, void *, int);
 export_proto(transfer_complex);
 
@@ -730,35 +734,43 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 
 static void
 unformatted_read (st_parameter_dt *dtp, bt type,
-                 void *dest, int kind __attribute__((unused)),
-                 size_t size, size_t nelems)
+                 void *dest, int kind, size_t size, size_t nelems)
 {
   size_t i, sz;
 
-  /* Currently, character implies size=1.  */
   if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE
-      || size == 1 || type == BT_CHARACTER)
+      || size == 1)
     {
       sz = size * nelems;
+      if (type == BT_CHARACTER)
+       sz *= GFC_SIZE_OF_CHAR_KIND(kind);
       read_block_direct (dtp, dest, &sz);
     }
   else
     {
       char buffer[16];
       char *p;
-      
+
+      p = dest;
+
+      /* Handle wide chracters.  */
+      if (type == BT_CHARACTER && kind != 1)
+       {
+         nelems *= size;
+         size = kind;
+       }
+
       /* Break up complex into its constituent reals.  */
       if (type == BT_COMPLEX)
        {
          nelems *= 2;
          size /= 2;
        }
-      p = dest;
       
       /* By now, all complex variables have been split into their
         constituent reals.  */
       
-      for (i=0; i<nelems; i++)
+      for (i = 0; i < nelems; i++)
        {
          read_block_direct (dtp, buffer, &size);
          reverse_memcpy (p, buffer, size);
@@ -775,20 +787,30 @@ unformatted_read (st_parameter_dt *dtp, bt type,
 
 static void
 unformatted_write (st_parameter_dt *dtp, bt type,
-                  void *source, int kind __attribute__((unused)),
-                  size_t size, size_t nelems)
+                  void *source, int kind, size_t size, size_t nelems)
 {
   if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE ||
-      size == 1 || type == BT_CHARACTER)
+      size == 1)
     {
-      size *= nelems;
-      write_buf (dtp, source, size);
+      size_t stride = type == BT_CHARACTER ?
+                 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+
+      write_buf (dtp, source, stride * nelems);
     }
   else
     {
       char buffer[16];
       char *p;
       size_t i;
+
+      p = source;
+
+      /* Handle wide chracters.  */
+      if (type == BT_CHARACTER && kind != 1)
+       {
+         nelems *= size;
+         size = kind;
+       }
   
       /* Break up complex into its constituent reals.  */
       if (type == BT_COMPLEX)
@@ -797,16 +819,13 @@ unformatted_write (st_parameter_dt *dtp, bt type,
          size /= 2;
        }      
 
-      p = source;
-
       /* By now, all complex variables have been split into their
         constituent reals.  */
 
-
-      for (i=0; i<nelems; i++)
+      for (i = 0; i < nelems; i++)
        {
          reverse_memcpy(buffer, p, size);
-         p+= size;
+         p += size;
          write_buf (dtp, buffer, size);
        }
     }
@@ -904,7 +923,7 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
    of the next element, then comes back here to process it.  */
 
 static void
-formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
+formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
                           size_t size)
 {
   char scratch[SCRATCH_SIZE];
@@ -1004,9 +1023,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_decimal (dtp, f, p, len);
+           read_decimal (dtp, f, p, kind);
          else
-           write_i (dtp, f, p, len);
+           write_i (dtp, f, p, kind);
 
          break;
 
@@ -1019,9 +1038,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_radix (dtp, f, p, len, 2);
+           read_radix (dtp, f, p, kind, 2);
          else
-           write_b (dtp, f, p, len);
+           write_b (dtp, f, p, kind);
 
          break;
 
@@ -1034,9 +1053,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_radix (dtp, f, p, len, 8);
+           read_radix (dtp, f, p, kind, 8);
          else
-           write_o (dtp, f, p, len);
+           write_o (dtp, f, p, kind);
 
          break;
 
@@ -1049,9 +1068,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_radix (dtp, f, p, len, 16);
+           read_radix (dtp, f, p, kind, 16);
          else
-           write_z (dtp, f, p, len);
+           write_z (dtp, f, p, kind);
 
          break;
 
@@ -1059,11 +1078,23 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
          if (n == 0)
            goto need_data;
 
+         /* It is possible to have FMT_A with something not BT_CHARACTER such
+            as when writing out hollerith strings, so check both type
+            and kind before calling wide character routines.  */
          if (dtp->u.p.mode == READING)
-           read_a (dtp, f, p, len);
+           {
+             if (type == BT_CHARACTER && kind == 4)
+               read_a_char4 (dtp, f, p, size);
+             else
+               read_a (dtp, f, p, size);
+           }
          else
-           write_a (dtp, f, p, len);
-
+           {
+             if (type == BT_CHARACTER && kind == 4)
+               write_a_char4 (dtp, f, p, size);
+             else
+               write_a (dtp, f, p, size);
+           }
          break;
 
        case FMT_L:
@@ -1071,9 +1102,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            goto need_data;
 
          if (dtp->u.p.mode == READING)
-           read_l (dtp, f, p, len);
+           read_l (dtp, f, p, kind);
          else
-           write_l (dtp, f, p, len);
+           write_l (dtp, f, p, kind);
 
          break;
 
@@ -1084,9 +1115,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_f (dtp, f, p, len);
+           read_f (dtp, f, p, kind);
          else
-           write_d (dtp, f, p, len);
+           write_d (dtp, f, p, kind);
 
          break;
 
@@ -1097,9 +1128,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_f (dtp, f, p, len);
+           read_f (dtp, f, p, kind);
          else
-           write_e (dtp, f, p, len);
+           write_e (dtp, f, p, kind);
          break;
 
        case FMT_EN:
@@ -1109,9 +1140,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_f (dtp, f, p, len);
+           read_f (dtp, f, p, kind);
          else
-           write_en (dtp, f, p, len);
+           write_en (dtp, f, p, kind);
 
          break;
 
@@ -1122,9 +1153,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_f (dtp, f, p, len);
+           read_f (dtp, f, p, kind);
          else
-           write_es (dtp, f, p, len);
+           write_es (dtp, f, p, kind);
 
          break;
 
@@ -1135,9 +1166,9 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            return;
 
          if (dtp->u.p.mode == READING)
-           read_f (dtp, f, p, len);
+           read_f (dtp, f, p, kind);
          else
-           write_f (dtp, f, p, len);
+           write_f (dtp, f, p, kind);
 
          break;
 
@@ -1148,16 +1179,19 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            switch (type)
              {
              case BT_INTEGER:
-               read_decimal (dtp, f, p, len);
+               read_decimal (dtp, f, p, kind);
                break;
              case BT_LOGICAL:
-               read_l (dtp, f, p, len);
+               read_l (dtp, f, p, kind);
                break;
              case BT_CHARACTER:
-               read_a (dtp, f, p, len);
+               if (kind == 4)
+                 read_a_char4 (dtp, f, p, size);
+               else
+                 read_a (dtp, f, p, size);
                break;
              case BT_REAL:
-               read_f (dtp, f, p, len);
+               read_f (dtp, f, p, kind);
                break;
              default:
                goto bad_type;
@@ -1166,19 +1200,22 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
            switch (type)
              {
              case BT_INTEGER:
-               write_i (dtp, f, p, len);
+               write_i (dtp, f, p, kind);
                break;
              case BT_LOGICAL:
-               write_l (dtp, f, p, len);
+               write_l (dtp, f, p, kind);      
                break;
              case BT_CHARACTER:
-               write_a (dtp, f, p, len);
+               if (kind == 4)
+                 write_a_char4 (dtp, f, p, size);
+               else
+                 write_a (dtp, f, p, size);
                break;
              case BT_REAL:
                if (f->u.real.w == 0)
-                 write_real (dtp, p, len);
+                 write_real (dtp, p, kind);
                else
-                 write_d (dtp, f, p, len);
+                 write_d (dtp, f, p, kind);
                break;
              default:
              bad_type:
@@ -1407,12 +1444,13 @@ formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
   char *tmp;
 
   tmp = (char *) p;
-
+  size_t stride = type == BT_CHARACTER ?
+                 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
   /* Big loop over all the elements.  */
   for (elem = 0; elem < nelems; elem++)
     {
       dtp->u.p.item_count++;
-      formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
+      formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
     }
 }
 
@@ -1465,10 +1503,26 @@ transfer_character (st_parameter_dt *dtp, void *p, int len)
   if (len == 0 && p == NULL)
     p = empty_string;
 
-  /* Currently we support only 1 byte chars, and the library is a bit
-     confused of character kind vs. length, so we kludge it by setting
-     kind = length.  */
-  dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
+  /* Set kind here to 1.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+}
+
+void
+transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+{
+  static char *empty_string[0];
+
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  /* Strings of zero length can have p == NULL, which confuses the
+     transfer routines into thinking we need more data elements.  To avoid
+     this, we give them a nice pointer.  */
+  if (len == 0 && p == NULL)
+    p = empty_string;
+
+  /* Here we pass the actual kind value.  */
+  dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
 }
 
 
@@ -1522,13 +1576,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
       break;
     case GFC_DTYPE_CHARACTER:
       iotype = BT_CHARACTER;
-      /* FIXME: Currently dtype contains the charlen, which is
-        clobbered if charlen > 2**24. That's why we use a separate
-        argument for the charlen. However, if we want to support
-        non-8-bit charsets we need to fix dtype to contain
-        sizeof(chartype) and fix the code below.  */
       size = charlen;
-      kind = charlen;
       break;
     case GFC_DTYPE_DERIVED:
       internal_error (&dtp->common,
@@ -1542,7 +1590,9 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
   for (n = 0; n < rank; n++)
     {
       count[n] = 0;
-      stride[n] = desc->dim[n].stride;
+      stride[n] = iotype == BT_CHARACTER ?
+                 desc->dim[n].stride * GFC_SIZE_OF_CHAR_KIND(kind) :
+                 desc->dim[n].stride;
       extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
 
       /* If the extent of even one dimension is zero, then the entire
@@ -1815,7 +1865,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
      if (conv == GFC_CONVERT_NONE)
        conv = compile_options.convert;
 
-     /* We use l8_to_l4_offset, which is 0 on little-endian machines
+     /* We use big_endian, which is 0 on little-endian machines
        and 1 on big-endian machines.  */
      switch (conv)
        {
@@ -1824,11 +1874,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
         break;
         
        case GFC_CONVERT_BIG:
-        conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+        conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
         break;
       
        case GFC_CONVERT_LITTLE:
-        conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+        conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
         break;
         
        default:
index 6135d60..ed50e0d 100644 (file)
@@ -124,6 +124,108 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 #endif
 }
 
+
+/* The primary difference between write_a_char4 and write_a is that we have to
+   deal with writing from the first byte of the 4-byte character and take care
+   of endianess.  This currently implements encoding="default" which means we
+   write the lowest significant byte. If the 3 most significant bytes are
+   not representable emit a '?'.  TODO: Implement encoding="UTF-8"
+   which will process all 4 bytes and translate to the encoded output.  */
+
+void
+write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+  int wlen;
+  char *p;
+  gfc_char4_t *q;
+
+  wlen = f->u.string.length < 0
+        || (f->format == FMT_G && f->u.string.length == 0)
+        ? len : f->u.string.length;
+
+  q = (gfc_char4_t *) source;
+#ifdef HAVE_CRLF
+  /* If this is formatted STREAM IO convert any embedded line feed characters
+     to CR_LF on systems that use that sequence for newlines.  See F2003
+     Standard sections 10.6.3 and 9.9 for further information.  */
+  if (is_stream_io (dtp))
+    {
+      const char crlf[] = "\r\n";
+      int i, j, bytes;
+      gfc_char4_t *qq;
+      bytes = 0;
+
+      /* Write out any padding if needed.  */
+      if (len < wlen)
+       {
+         p = write_block (dtp, wlen - len);
+         if (p == NULL)
+           return;
+         memset (p, ' ', wlen - len);
+       }
+
+      /* Scan the source string looking for '\n' and convert it if found.  */
+      qq = (gfc_char4_t *) source;
+      for (i = 0; i < wlen; i++)
+       {
+         if (qq[i] == '\n')
+           {
+             /* Write out the previously scanned characters in the string.  */
+             if (bytes > 0)
+               {
+                 p = write_block (dtp, bytes);
+                 if (p == NULL)
+                   return;
+                 for (j = 0; j < bytes; j++)
+                   p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+                 bytes = 0;
+               }
+
+             /* Write out the CR_LF sequence.  */ 
+             p = write_block (dtp, 2);
+              if (p == NULL)
+                return;
+             memcpy (p, crlf, 2);
+           }
+         else
+           bytes++;
+       }
+
+      /*  Write out any remaining bytes if no LF was found.  */
+      if (bytes > 0)
+       {
+         p = write_block (dtp, bytes);
+         if (p == NULL)
+           return;
+         for (j = 0; j < bytes; j++)
+           p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+       }
+    }
+  else
+    {
+#endif
+      int j;
+      p = write_block (dtp, wlen);
+      if (p == NULL)
+       return;
+
+      if (wlen < len)
+       {
+         for (j = 0; j < wlen; j++)
+           p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+       }
+      else
+       {
+         memset (p, ' ', wlen - len);
+         for (j = wlen - len; j < wlen; j++)
+           p[j] = q[j] > 255 ? '?' : (unsigned char) q[j];
+       }
+#ifdef HAVE_CRLF
+    }
+#endif
+}
+
+
 static GFC_INTEGER_LARGEST
 extract_int (const void *p, int len)
 {
@@ -639,10 +741,12 @@ write_integer (st_parameter_dt *dtp, const char *source, int length)
    the strings if the file has been opened in that mode.  */
 
 static void
-write_character (st_parameter_dt *dtp, const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 {
   int i, extra;
   char *p, d;
+  gfc_char4_t *q;
+
 
   switch (dtp->u.p.delim_status)
     {
@@ -657,35 +761,77 @@ write_character (st_parameter_dt *dtp, const char *source, int length)
       break;
     }
 
-  if (d == ' ')
-    extra = 0;
-  else
+  if (kind == 1)
     {
-      extra = 2;
+      if (d == ' ')
+       extra = 0;
+      else
+       {
+         extra = 2;
 
-      for (i = 0; i < length; i++)
-       if (source[i] == d)
-         extra++;
-    }
+           for (i = 0; i < length; i++)
+             if (source[i] == d)
+               extra++;
+       }
 
-  p = write_block (dtp, length + extra);
-  if (p == NULL)
-    return;
+      p = write_block (dtp, length + extra);
+      if (p == NULL)
+       return;
+
+      if (d == ' ')
+       memcpy (p, source, length);
+      else
+       {
+         *p++ = d;
 
-  if (d == ' ')
-    memcpy (p, source, length);
+         for (i = 0; i < length; i++)
+            {
+              *p++ = source[i];
+              if (source[i] == d)
+               *p++ = d;
+           }
+
+         *p = d;
+       }
+    }
   else
     {
-      *p++ = d;
-
-      for (i = 0; i < length; i++)
+      /* We have to scan the source string looking for delimiters to determine
+        how large the write block needs to be.  */
+      if (d == ' ')
+       extra = 0;
+      else
        {
-         *p++ = source[i];
-         if (source[i] == d)
-           *p++ = d;
+         extra = 2;
+
+         q = (gfc_char4_t *) source;
+         for (i = 0; i < length; i++, q++)
+           if (*q == (gfc_char4_t) d)
+             extra++;
        }
 
-      *p = d;
+      p = write_block (dtp, length + extra);
+      if (p == NULL)
+       return;
+
+      if (d == ' ')
+       {
+         q = (gfc_char4_t *) source;
+         for (i = 0; i < length; i++, q++)
+           p[i] = *q > 255 ? '?' : (unsigned char) *q;
+       }
+      else
+       {
+         *p++ = d;
+         q = (gfc_char4_t *) source;
+         for (i = 0; i < length; i++, q++)
+           {
+             *p++ = *q > 255 ? '?' : (unsigned char) *q;
+             if (*q == (gfc_char4_t) d)
+               *p++ = d;
+           }
+         *p = d;
+       }
     }
 }
 
@@ -796,7 +942,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);
+      write_character (dtp, p, kind, size);
       break;
     case BT_REAL:
       write_real (dtp, p, kind);
@@ -818,6 +964,8 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
 {
   size_t elem;
   char *tmp;
+  size_t stride = type == BT_CHARACTER ?
+                 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
 
   tmp = (char *) p;
 
@@ -825,7 +973,7 @@ list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
   for (elem = 0; elem < nelems; elem++)
     {
       dtp->u.p.item_count++;
-      list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
+      list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
     }
 }
 
@@ -889,9 +1037,9 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   if (obj->type != GFC_DTYPE_DERIVED)
     {
 #ifdef HAVE_CRLF
-      write_character (dtp, "\r\n ", 3);
+      write_character (dtp, "\r\n ", 1, 3);
 #else
-      write_character (dtp, "\n ", 2);
+      write_character (dtp, "\n ", 1, 2);
 #endif
       len = 0;
       if (base)
@@ -900,15 +1048,15 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
          for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
             {
              cup = toupper (base_name[dim_i]);
-             write_character (dtp, &cup, 1);
+             write_character (dtp, &cup, 1, 1);
             }
        }
       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
        {
          cup = toupper (obj->var_name[dim_i]);
-         write_character (dtp, &cup, 1);
+         write_character (dtp, &cup, 1, 1);
        }
-      write_character (dtp, "=", 1);
+      write_character (dtp, "=", 1, 1);
     }
 
   /* Counts the number of data output on a line, including names.  */
@@ -978,7 +1126,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
          if (rep_ctr > 1)
            {
              sprintf(rep_buff, " %d*", rep_ctr);
-             write_character (dtp, rep_buff, strlen (rep_buff));
+             write_character (dtp, rep_buff, 1, strlen (rep_buff));
              dtp->u.p.no_leading_blank = 1;
            }
          num++;
@@ -1003,7 +1151,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
                dtp->u.p.delim_status = DELIM_QUOTE;
              if (dtp->u.p.nml_delim == '\'')
                dtp->u.p.delim_status = DELIM_APOSTROPHE;
-             write_character (dtp, p, obj->string_length);
+             write_character (dtp, p, 1, obj->string_length);
              dtp->u.p.delim_status = tmp_delim;
               break;
 
@@ -1093,14 +1241,14 @@ 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);
+         write_character (dtp, &semi_comma, 1, 1);
          if (num > 5)
            {
              num = 0;
 #ifdef HAVE_CRLF
-             write_character (dtp, "\r\n ", 3);
+             write_character (dtp, "\r\n ", 1, 3);
 #else
-             write_character (dtp, "\n ", 2);
+             write_character (dtp, "\n ", 1, 2);
 #endif
            }
          rep_ctr = 1;
@@ -1164,13 +1312,13 @@ namelist_write (st_parameter_dt *dtp)
   /* Temporarily disable namelist delimters.  */
   dtp->u.p.delim_status = DELIM_NONE;
 
-  write_character (dtp, "&", 1);
+  write_character (dtp, "&", 1, 1);
 
   /* Write namelist name in upper case - f95 std.  */
   for (i = 0 ;i < dtp->namelist_name_len ;i++ )
     {
       c = toupper (dtp->namelist_name[i]);
-      write_character (dtp, &c ,1);
+      write_character (dtp, &c, 1 ,1);
     }
 
   if (dtp->u.p.ionml != NULL)
@@ -1184,9 +1332,9 @@ namelist_write (st_parameter_dt *dtp)
     }
 
 #ifdef HAVE_CRLF
-  write_character (dtp, "  /\r\n", 5);
+  write_character (dtp, "  /\r\n", 1, 5);
 #else
-  write_character (dtp, "  /\n", 4);
+  write_character (dtp, "  /\n", 1, 4);
 #endif
 
   /* Restore the original delimiter.  */
index 6ff9f4f..8c0f1b4 100644 (file)
@@ -272,13 +272,12 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
    simply equal to the kind parameter itself.  */
 #define GFC_SIZE_OF_CHAR_KIND(kind) (kind)
 
-
 /* This will be 0 on little-endian machines and one on big-endian machines.  */
-extern int l8_to_l4_offset;
-internal_proto(l8_to_l4_offset);
+extern int big_endian;
+internal_proto(big_endian);
 
 #define GFOR_POINTER_TO_L1(p, kind) \
-  (l8_to_l4_offset * (kind - 1) + (GFC_LOGICAL_1 *)(p))
+  (big_endian * (kind - 1) + (GFC_LOGICAL_1 *)(p))
 
 #define GFC_INTEGER_1_HUGE \
   (GFC_INTEGER_1)((((GFC_UINTEGER_1)1) << 7) - 1)
index 8632f15..71b481a 100644 (file)
@@ -45,10 +45,9 @@ stupid_function_name_for_static_linking (void)
   return;
 }
 
-/* This is the offset (in bytes) required to cast from logical(8)* to
-   logical(4)*. and still get the same result.  Will be 0 for little-endian
-   machines and 4 for big-endian machines.  */
-int l8_to_l4_offset = 0;
+/* This will be 0 for little-endian
+   machines and 1 for big-endian machines.  */
+int big_endian = 0;
 
 
 /* Figure out endianness for this machine.  */
@@ -64,9 +63,9 @@ determine_endianness (void)
 
   u.l8 = 1;
   if (u.l4[0])
-    l8_to_l4_offset = 0;
+    big_endian = 0;
   else if (u.l4[1])
-    l8_to_l4_offset = 1;
+    big_endian = 1;
   else
     runtime_error ("Unable to determine machine endianness");
 }