re PR libfortran/78549 (Very slow formatted internal file output)
[gcc.git] / libgfortran / io / unit.c
index a54061d2f84cb070671689060a68d3d508ae943f..e62f9b839d4a35eff4e251459082807a8ff8bff5 100644 (file)
@@ -1,35 +1,34 @@
-/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2017 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   F2003 I/O support contributed by Jerry DeLisle
 
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
 
 Libgfortran is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
 any later version.
 
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file.  (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
 Libgfortran is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.
 
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING.  If not, write to
-the Free Software Foundation, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA.  */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
 
 #include "io.h"
-#include <stdlib.h>
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
 #include <string.h>
+#include <assert.h>
 
 
 /* IO locking rules:
@@ -69,9 +68,31 @@ Boston, MA 02110-1301, USA.  */
    on it.  unlock_unit or close_unit must be always called only with the
    private lock held.  */
 
-/* Subroutines related to units */
 
 
+/* Table of allocated newunit values.  A simple solution would be to
+   map OS file descriptors (fd's) to unit numbers, e.g. with newunit =
+   -fd - 2, however that doesn't work since Fortran allows an existing
+   unit number to be reassociated with a new file. Thus the simple
+   approach may lead to a situation where we'd try to assign a
+   (negative) unit number which already exists. Hence we must keep
+   track of allocated newunit values ourselves. This is the purpose of
+   the newunits array. The indices map to newunit values as newunit =
+   -index + NEWUNIT_FIRST. E.g. newunits[0] having the value true
+   means that a unit with number NEWUNIT_FIRST exists. Similar to
+   POSIX file descriptors, we always allocate the lowest (in absolute
+   value) available unit number.
+ */
+static bool *newunits;
+static int newunit_size; /* Total number of elements in the newunits array.  */
+/* Low water indicator for the newunits array. Below the LWI all the
+   units are allocated, above and equal to the LWI there may be both
+   allocated and free units. */
+static int newunit_lwi;
+
+/* Unit numbers assigned with NEWUNIT start from here.  */
+#define NEWUNIT_START -10
+
 #define CACHE_SIZE 3
 static gfc_unit *unit_cache[CACHE_SIZE];
 gfc_offset max_offset;
@@ -88,12 +109,32 @@ static char stdin_name[] = "stdin";
 static char stdout_name[] = "stdout";
 static char stderr_name[] = "stderr";
 
+
+#ifdef HAVE_NEWLOCALE
+locale_t c_locale;
+#else
+/* If we don't have POSIX 2008 per-thread locales, we need to use the
+   traditional setlocale().  To prevent multiple concurrent threads
+   doing formatted I/O from messing up the locale, we need to store a
+   global old_locale, and a counter keeping track of how many threads
+   are currently doing formatted I/O.  The first thread saves the old
+   locale, and the last one restores it.  */
+char *old_locale;
+int old_locale_ctr;
+#ifdef __GTHREAD_MUTEX_INIT
+__gthread_mutex_t old_locale_lock = __GTHREAD_MUTEX_INIT;
+#else
+__gthread_mutex_t old_locale_lock;
+#endif
+#endif
+
+
 /* This implementation is based on Stefan Nilsson's article in the
* July 1997 Doctor Dobb's Journal, "Treaps in Java". */
  July 1997 Doctor Dobb's Journal, "Treaps in Java". */
 
 /* pseudo_random()-- Simple linear congruential pseudorandom number
* generator.  The period of this generator is 44071, which is plenty
* for our purposes.  */
  generator.  The period of this generator is 44071, which is plenty
  for our purposes.  */
 
 static int
 pseudo_random (void)
@@ -108,7 +149,7 @@ pseudo_random (void)
 /* rotate_left()-- Rotate the treap left */
 
 static gfc_unit *
-rotate_left (gfc_unit * t)
+rotate_left (gfc_unit *t)
 {
   gfc_unit *temp;
 
@@ -123,7 +164,7 @@ rotate_left (gfc_unit * t)
 /* rotate_right()-- Rotate the treap right */
 
 static gfc_unit *
-rotate_right (gfc_unit * t)
+rotate_right (gfc_unit *t)
 {
   gfc_unit *temp;
 
@@ -135,7 +176,6 @@ rotate_right (gfc_unit * t)
 }
 
 
-
 static int
 compare (int a, int b)
 {
@@ -186,8 +226,7 @@ insert (gfc_unit *new, gfc_unit *t)
 static gfc_unit *
 insert_unit (int n)
 {
-  gfc_unit *u = get_mem (sizeof (gfc_unit));
-  memset (u, '\0', sizeof (gfc_unit));
+  gfc_unit *u = xcalloc (1, sizeof (gfc_unit));
   u->unit_number = n;
 #ifdef __GTHREAD_MUTEX_INIT
   {
@@ -207,15 +246,15 @@ insert_unit (int n)
 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
 
 static void
-destroy_unit_mutex (gfc_unit * u)
+destroy_unit_mutex (gfc_unit *u)
 {
   __gthread_mutex_destroy (&u->lock);
-  free_mem (u);
+  free (u);
 }
 
 
 static gfc_unit *
-delete_root (gfc_unit * t)
+delete_root (gfc_unit *t)
 {
   gfc_unit *temp;
 
@@ -240,12 +279,12 @@ delete_root (gfc_unit * t)
 
 
 /* delete_treap()-- Delete an element from a tree.  The 'old' value
* does not necessarily have to point to the element to be deleted, it
* must just point to a treap structure with the key to be deleted.
* Returns the new root node of the tree. */
  does not necessarily have to point to the element to be deleted, it
  must just point to a treap structure with the key to be deleted.
  Returns the new root node of the tree. */
 
 static gfc_unit *
-delete_treap (gfc_unit * old, gfc_unit * t)
+delete_treap (gfc_unit *old, gfc_unit *t)
 {
   int c;
 
@@ -268,18 +307,18 @@ delete_treap (gfc_unit * old, gfc_unit * t)
 /* delete_unit()-- Delete a unit from a tree */
 
 static void
-delete_unit (gfc_unit * old)
+delete_unit (gfc_unit *old)
 {
   unit_root = delete_treap (old, unit_root);
 }
 
 
-/* get_external_unit()-- Given an integer, return a pointer to the unit
* structure.  Returns NULL if the unit does not exist,
* otherwise returns a locked unit. */
+/* get_gfc_unit()-- Given an integer, return a pointer to the unit
  structure.  Returns NULL if the unit does not exist,
  otherwise returns a locked unit. */
 
 static gfc_unit *
-get_external_unit (int n, int do_create)
+get_gfc_unit (int n, int do_create)
 {
   gfc_unit *p;
   int c, created = 0;
@@ -328,7 +367,7 @@ retry:
     }
 
 found:
-  if (p != NULL)
+  if (p != NULL && (p->child_dtio == 0))
     {
       /* Fast path.  */
       if (! __gthread_mutex_trylock (&p->lock))
@@ -341,9 +380,10 @@ found:
       inc_waiting_locked (p);
     }
 
+
   __gthread_mutex_unlock (&unit_lock);
 
-  if (p != NULL)
+  if (p != NULL && (p->child_dtio == 0))
     {
       __gthread_mutex_lock (&p->lock);
       if (p->closed)
@@ -364,49 +404,73 @@ found:
 gfc_unit *
 find_unit (int n)
 {
-  return get_external_unit (n, 0);
+  return get_gfc_unit (n, 0);
 }
 
 
 gfc_unit *
 find_or_create_unit (int n)
 {
-  return get_external_unit (n, 1);
+  return get_gfc_unit (n, 1);
 }
 
 
-gfc_unit *
-get_internal_unit (st_parameter_dt *dtp)
+/* Helper function to check rank, stride, format string, and namelist.
+   This is used for optimization. You can't trim out blanks or shorten
+   the string if trailing spaces are significant.  */
+static bool
+is_trim_ok (st_parameter_dt *dtp)
 {
-  gfc_unit * iunit;
-  gfc_offset start_record = 0;
-
-  /* Allocate memory for a unit structure.  */
-
-  iunit = get_mem (sizeof (gfc_unit));
-  if (iunit == NULL)
+  /* Check rank and stride.  */
+  if (dtp->internal_unit_desc)
+    return false;
+  /* Format strings can not have 'BZ' or '/'.  */
+  if (dtp->common.flags & IOPARM_DT_HAS_FORMAT)
     {
-      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
-      return NULL;
+      char *p = dtp->format;
+      off_t i;
+      if (dtp->common.flags & IOPARM_DT_HAS_BLANK)
+       return false;
+      for (i = 0; i < dtp->format_len; i++)
+       {
+         if (p[i] == '/') return false;
+         if (p[i] == 'b' || p[i] == 'B')
+           if (p[i+1] == 'z' || p[i+1] == 'Z')
+             return false;
+       }
     }
+  if (dtp->u.p.ionml) /* A namelist.  */
+    return false;
+  return true;
+}
 
-  memset (iunit, '\0', sizeof (gfc_unit));
-#ifdef __GTHREAD_MUTEX_INIT
-  {
-    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
-    iunit->lock = tmp;
-  }
-#else
-  __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
-#endif
-  __gthread_mutex_lock (&iunit->lock);
 
+gfc_unit *
+set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind)
+{
+  gfc_offset start_record = 0;
+
+  iunit->unit_number = dtp->common.unit;
   iunit->recl = dtp->internal_unit_len;
-  
-  /* For internal units we set the unit number to -1.
-     Otherwise internal units can be mistaken for a pre-connected unit or
-     some other file I/O unit.  */
-  iunit->unit_number = -1;
+  iunit->internal_unit = dtp->internal_unit;
+  iunit->internal_unit_len = dtp->internal_unit_len;
+  iunit->internal_unit_kind = kind;
+
+  /* As an optimization, adjust the unit record length to not
+     include trailing blanks. This will not work under certain conditions
+     where trailing blanks have significance.  */
+  if (dtp->u.p.mode == READING && is_trim_ok (dtp))
+    {
+      int len;
+      if (kind == 1)
+         len = string_len_trim (iunit->internal_unit_len,
+                                                  iunit->internal_unit);
+      else
+         len = string_len_trim_char4 (iunit->internal_unit_len,
+                             (const gfc_char4_t*) iunit->internal_unit);
+      iunit->internal_unit_len = len;
+      iunit->recl = iunit->internal_unit_len;
+    }
 
   /* Set up the looping specification from the array descriptor, if any.  */
 
@@ -414,92 +478,98 @@ get_internal_unit (st_parameter_dt *dtp)
     {
       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
       iunit->ls = (array_loop_spec *)
-       get_mem (iunit->rank * sizeof (array_loop_spec));
-      dtp->internal_unit_len *=
+       xmallocarray (iunit->rank, sizeof (array_loop_spec));
+      iunit->internal_unit_len *=
        init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 
       start_record *= iunit->recl;
     }
 
   /* Set initial values for unit parameters.  */
+  if (kind == 4)
+    iunit->s = open_internal4 (iunit->internal_unit - start_record,
+                                iunit->internal_unit_len, -start_record);
+  else
+    iunit->s = open_internal (iunit->internal_unit - start_record,
+                             iunit->internal_unit_len, -start_record);
 
-  iunit->s = open_internal (dtp->internal_unit - start_record,
-                           dtp->internal_unit_len, -start_record);
   iunit->bytes_left = iunit->recl;
   iunit->last_record=0;
   iunit->maxrec=0;
   iunit->current_record=0;
   iunit->read_bad = 0;
+  iunit->endfile = NO_ENDFILE;
 
   /* Set flags for the internal unit.  */
 
   iunit->flags.access = ACCESS_SEQUENTIAL;
   iunit->flags.action = ACTION_READWRITE;
+  iunit->flags.blank = BLANK_NULL;
   iunit->flags.form = FORM_FORMATTED;
   iunit->flags.pad = PAD_YES;
   iunit->flags.status = STATUS_UNSPECIFIED;
-  iunit->endfile = NO_ENDFILE;
+  iunit->flags.sign = SIGN_UNSPECIFIED;
+  iunit->flags.decimal = DECIMAL_POINT;
+  iunit->flags.delim = DELIM_UNSPECIFIED;
+  iunit->flags.encoding = ENCODING_DEFAULT;
+  iunit->flags.async = ASYNC_NO;
+  iunit->flags.round = ROUND_UNSPECIFIED;
 
   /* Initialize the data transfer parameters.  */
 
   dtp->u.p.advance_status = ADVANCE_YES;
-  dtp->u.p.blank_status = BLANK_UNSPECIFIED;
   dtp->u.p.seen_dollar = 0;
   dtp->u.p.skips = 0;
   dtp->u.p.pending_spaces = 0;
   dtp->u.p.max_pos = 0;
   dtp->u.p.at_eof = 0;
-
-  /* This flag tells us the unit is assigned to internal I/O.  */
-  
-  dtp->u.p.unit_is_internal = 1;
-
   return iunit;
 }
 
 
-/* free_internal_unit()-- Free memory allocated for internal units if any.  */
-void
-free_internal_unit (st_parameter_dt *dtp)
-{
-  if (!is_internal_unit (dtp))
-    return;
-
-  if (dtp->u.p.current_unit != NULL)
-    {
-      if (dtp->u.p.current_unit->ls != NULL)
-       free_mem (dtp->u.p.current_unit->ls);
-  
-      if (dtp->u.p.current_unit->s)
-       free_mem (dtp->u.p.current_unit->s);
-  
-      destroy_unit_mutex (dtp->u.p.current_unit);
-    }
-}
-      
-
-
 /* get_unit()-- Returns the unit structure associated with the integer
* unit or the internal file. */
  unit or the internal file.  */
 
 gfc_unit *
 get_unit (st_parameter_dt *dtp, int do_create)
 {
+  gfc_unit *unit;
 
   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
-    return get_internal_unit(dtp);
-
-  /* Has to be an external unit */
+    {
+      int kind;
+      if (dtp->common.unit == GFC_INTERNAL_UNIT)
+        kind = 1;
+      else if (dtp->common.unit == GFC_INTERNAL_UNIT4)
+        kind = 4;
+      else
+       internal_error (&dtp->common, "get_unit(): Bad internal unit KIND");
+
+      dtp->u.p.unit_is_internal = 1;
+      dtp->common.unit = newunit_alloc ();
+      unit = get_gfc_unit (dtp->common.unit, do_create);
+      set_internal_unit (dtp, unit, kind);
+      fbuf_init (unit, 128);
+      return unit;
+    }
 
+  /* Has to be an external unit.  */
   dtp->u.p.unit_is_internal = 0;
+  dtp->internal_unit = NULL;
   dtp->internal_unit_desc = NULL;
 
-  return get_external_unit (dtp->common.unit, do_create);
+  /* For an external unit with unit number < 0 creating it on the fly
+     is not allowed, such units must be created with
+     OPEN(NEWUNIT=...).  */
+  if (dtp->common.unit < 0)
+    return get_gfc_unit (dtp->common.unit, 0);
+
+  return get_gfc_unit (dtp->common.unit, do_create);
 }
 
 
 /*************************/
-/* Initialize everything */
+/* Initialize everything */
 
 void
 init_units (void)
@@ -507,6 +577,14 @@ init_units (void)
   gfc_unit *u;
   unsigned int i;
 
+#ifdef HAVE_NEWLOCALE
+  c_locale = newlocale (0, "C", 0);
+#else
+#ifndef __GTHREAD_MUTEX_INIT
+  __GTHREAD_MUTEX_INIT_FUNCTION (&old_locale_lock);
+#endif
+#endif
+
 #ifndef __GTHREAD_MUTEX_INIT
   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 #endif
@@ -524,14 +602,22 @@ init_units (void)
       u->flags.blank = BLANK_NULL;
       u->flags.pad = PAD_YES;
       u->flags.position = POSITION_ASIS;
+      u->flags.sign = SIGN_UNSPECIFIED;
+      u->flags.decimal = DECIMAL_POINT;
+      u->flags.delim = DELIM_UNSPECIFIED;
+      u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_UNSPECIFIED;
+      u->flags.share = SHARE_UNSPECIFIED;
+      u->flags.cc = CC_LIST;
 
       u->recl = options.default_recl;
       u->endfile = NO_ENDFILE;
 
-      u->file_len = strlen (stdin_name);
-      u->file = get_mem (u->file_len);
-      memmove (u->file, stdin_name, u->file_len);
-    
+      u->filename = strdup (stdin_name);
+
+      fbuf_init (u, 0);
+
       __gthread_mutex_unlock (&u->lock);
     }
 
@@ -547,13 +633,21 @@ init_units (void)
       u->flags.status = STATUS_OLD;
       u->flags.blank = BLANK_NULL;
       u->flags.position = POSITION_ASIS;
+      u->flags.sign = SIGN_UNSPECIFIED;
+      u->flags.decimal = DECIMAL_POINT;
+      u->flags.delim = DELIM_UNSPECIFIED;
+      u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_UNSPECIFIED;
+      u->flags.share = SHARE_UNSPECIFIED;
+      u->flags.cc = CC_LIST;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
-    
-      u->file_len = strlen (stdout_name);
-      u->file = get_mem (u->file_len);
-      memmove (u->file, stdout_name, u->file_len);
+
+      u->filename = strdup (stdout_name);
+
+      fbuf_init (u, 0);
 
       __gthread_mutex_unlock (&u->lock);
     }
@@ -570,22 +664,28 @@ init_units (void)
       u->flags.status = STATUS_OLD;
       u->flags.blank = BLANK_NULL;
       u->flags.position = POSITION_ASIS;
+      u->flags.sign = SIGN_UNSPECIFIED;
+      u->flags.decimal = DECIMAL_POINT;
+      u->flags.encoding = ENCODING_DEFAULT;
+      u->flags.async = ASYNC_NO;
+      u->flags.round = ROUND_UNSPECIFIED;
+      u->flags.share = SHARE_UNSPECIFIED;
+      u->flags.cc = CC_LIST;
 
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
 
-      u->file_len = strlen (stderr_name);
-      u->file = get_mem (u->file_len);
-      memmove (u->file, stderr_name, u->file_len);
+      u->filename = strdup (stderr_name);
+
+      fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
+                              any kind of exotic formatting to stderr.  */
 
       __gthread_mutex_unlock (&u->lock);
     }
 
   /* Calculate the maximum file offset in a portable manner.
-   * max will be the largest signed number for the type gfc_offset.
-   *
-   * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
-
+     max will be the largest signed number for the type gfc_offset.
+     set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
   max_offset = 0;
   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
     max_offset = max_offset + ((gfc_offset) 1 << i);
@@ -602,7 +702,7 @@ close_unit_1 (gfc_unit *u, int locked)
   if (u->previous_nonadvancing_write)
     finish_last_advance_record (u);
 
-  rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+  rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
 
   u->closed = 1;
   if (!locked)
@@ -614,10 +714,14 @@ close_unit_1 (gfc_unit *u, int locked)
 
   delete_unit (u);
 
-  if (u->file)
-    free_mem (u->file);
-  u->file = NULL;
-  u->file_len = 0;
+  free (u->filename);
+  u->filename = NULL;
+
+  free_format_hash_table (u);
+  fbuf_destroy (u);
+
+  if (u->unit_number <= NEWUNIT_START)
+    newunit_free (u->unit_number);
 
   if (!locked)
     __gthread_mutex_unlock (&u->lock);
@@ -641,8 +745,8 @@ unlock_unit (gfc_unit *u)
 }
 
 /* close_unit()-- Close a unit.  The stream is closed, and any memory
* associated with the stream is freed.  Returns nonzero on I/O error.
* Should be called with the u->lock locked. */
  associated with the stream is freed.  Returns nonzero on I/O error.
  Should be called with the u->lock locked. */
 
 int
 close_unit (gfc_unit *u)
@@ -652,11 +756,11 @@ close_unit (gfc_unit *u)
 
 
 /* close_units()-- Delete units on completion.  We just keep deleting
* the root of the treap until there is nothing left.
* Not sure what to do with locking here.  Some other thread might be
* holding some unit's lock and perhaps hold it indefinitely
* (e.g. waiting for input from some pipe) and close_units shouldn't
* delay the program too much.  */
  the root of the treap until there is nothing left.
  Not sure what to do with locking here.  Some other thread might be
  holding some unit's lock and perhaps hold it indefinitely
  (e.g. waiting for input from some pipe) and close_units shouldn't
  delay the program too much.  */
 
 void
 close_units (void)
@@ -665,20 +769,46 @@ close_units (void)
   while (unit_root != NULL)
     close_unit_1 (unit_root, 1);
   __gthread_mutex_unlock (&unit_lock);
+
+  free (newunits);
+
+#ifdef HAVE_FREELOCALE
+  freelocale (c_locale);
+#endif
 }
 
 
-/* update_position()-- Update the flags position for later use by inquire.  */
+/* High level interface to truncate a file, i.e. flush format buffers,
+   and generate an error or set some flags.  Just like POSIX
+   ftruncate, returns 0 on success, -1 on failure.  */
 
-void
-update_position (gfc_unit *u)
+int
+unit_truncate (gfc_unit *u, gfc_offset pos, st_parameter_common *common)
 {
-  if (file_position (u->s) == 0)
-    u->flags.position = POSITION_REWIND;
-  else if (file_length (u->s) == file_position (u->s))
-    u->flags.position = POSITION_APPEND;
+  int ret;
+
+  /* Make sure format buffer is flushed.  */
+  if (u->flags.form == FORM_FORMATTED)
+    {
+      if (u->mode == READING)
+       pos += fbuf_reset (u);
+      else
+       fbuf_flush (u, u->mode);
+    }
+
+  /* struncate() should flush the stream buffer if necessary, so don't
+     bother calling sflush() here.  */
+  ret = struncate (u->s, pos);
+
+  if (ret != 0)
+    generate_error (common, LIBERROR_OS, NULL);
   else
-    u->flags.position = POSITION_ASIS;
+    {
+      u->endfile = AT_ENDFILE;
+      u->flags.position = POSITION_APPEND;
+    }
+
+  return ret;
 }
 
 
@@ -689,7 +819,6 @@ update_position (gfc_unit *u)
 char *
 filename_from_unit (int n)
 {
-  char *filename;
   gfc_unit *u;
   int c;
 
@@ -707,12 +836,8 @@ filename_from_unit (int n)
     }
 
   /* Get the filename.  */
-  if (u != NULL)
-    {
-      filename = (char *) get_mem (u->file_len + 1);
-      unpack_filename (filename, u->file, u->file_len);
-      return filename;
-    }
+  if (u != NULL && u->filename != NULL)
+    return strdup (u->filename);
   else
     return (char *) NULL;
 }
@@ -720,24 +845,77 @@ filename_from_unit (int n)
 void
 finish_last_advance_record (gfc_unit *u)
 {
-  char *p;
 
   if (u->saved_pos > 0)
-    p = salloc_w (u->s, &u->saved_pos);
+    fbuf_seek (u, u->saved_pos, SEEK_CUR);
 
   if (!(u->unit_number == options.stdout_unit
        || u->unit_number == options.stderr_unit))
     {
-      size_t len;
-
-      const char crlf[] = "\r\n";
 #ifdef HAVE_CRLF
-      len = 2;
+      const int len = 2;
 #else
-      len = 1;
+      const int len = 1;
 #endif
-      if (swrite (u->s, &crlf[2-len], &len) != 0)
+      char *p = fbuf_alloc (u, len);
+      if (!p)
        os_error ("Completing record after ADVANCE_NO failed");
+#ifdef HAVE_CRLF
+      *(p++) = '\r';
+#endif
+      *p = '\n';
     }
+
+  fbuf_flush (u, u->mode);
 }
 
+
+/* Assign a negative number for NEWUNIT in OPEN statements or for
+   internal units.  */
+int
+newunit_alloc (void)
+{
+  __gthread_mutex_lock (&unit_lock);
+  if (!newunits)
+    {
+      newunits = xcalloc (16, 1);
+      newunit_size = 16;
+    }
+
+  /* Search for the next available newunit.  */
+  for (int ii = newunit_lwi; ii < newunit_size; ii++)
+    {
+      if (!newunits[ii])
+        {
+          newunits[ii] = true;
+          newunit_lwi = ii + 1;
+         __gthread_mutex_unlock (&unit_lock);
+          return -ii + NEWUNIT_START;
+        }
+    }
+
+  /* Search failed, bump size of array and allocate the first
+     available unit.  */
+  int old_size = newunit_size;
+  newunit_size *= 2;
+  newunits = xrealloc (newunits, newunit_size);
+  memset (newunits + old_size, 0, old_size);
+  newunits[old_size] = true;
+  newunit_lwi = old_size + 1;
+    __gthread_mutex_unlock (&unit_lock);
+  return -old_size + NEWUNIT_START;
+}
+
+
+/* Free a previously allocated newunit= unit number.  unit_lock must
+   be held when calling.  */
+
+void
+newunit_free (int unit)
+{
+  int ind = -unit + NEWUNIT_START;
+  assert(ind >= 0 && ind < newunit_size);
+  newunits[ind] = false;
+  if (ind < newunit_lwi)
+    newunit_lwi = ind;
+}