unix.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

  /* retry for write-only access */
  rwflag = O_WRONLY;
  fd = open (path, rwflag | crflag, mode);
  if (fd >=0)
    {
      flags->action = ACTION_WRITE;
      return fd;               /* success */
    }
  return fd;                   /* failure */
}


/* open_external()-- Open an external file, unix specific version.
 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
 * Returns NULL on operating system error. */

stream *
open_external (st_parameter_open *opp, unit_flags *flags)
{
  int fd, prot;

  if (flags->status == STATUS_SCRATCH)
    {
      fd = tempfile (opp);
      if (flags->action == ACTION_UNSPECIFIED)
        flags->action = ACTION_READWRITE;

#if HAVE_UNLINK_OPEN_FILE
      /* We can unlink scratch files now and it will go away when closed. */
      if (fd >= 0)
	unlink (opp->file);
#endif
    }
  else
    {
      /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
       * if it succeeds */
      fd = regular_file (opp, flags);
    }

  if (fd < 0)
    return NULL;
  fd = fix_fd (fd);

  switch (flags->action)
    {
    case ACTION_READ:
      prot = PROT_READ;
      break;

    case ACTION_WRITE:
      prot = PROT_WRITE;
      break;

    case ACTION_READWRITE:
      prot = PROT_READ | PROT_WRITE;
      break;

    default:
      internal_error (&opp->common, "open_external(): Bad action");
    }

  return fd_to_stream (fd, prot);
}


/* input_stream()-- Return a stream pointer to the default input stream.
 * Called on initialization. */

stream *
input_stream (void)
{
  return fd_to_stream (STDIN_FILENO, PROT_READ);
}


/* output_stream()-- Return a stream pointer to the default output stream.
 * Called on initialization. */

stream *
output_stream (void)
{
  return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
}


/* error_stream()-- Return a stream pointer to the default error stream.
 * Called on initialization. */

stream *
error_stream (void)
{
  return fd_to_stream (STDERR_FILENO, PROT_WRITE);
}

/* init_error_stream()-- Return a pointer to the error stream.  This
 * subroutine is called when the stream is needed, rather than at
 * initialization.  We want to work even if memory has been seriously
 * corrupted. */

stream *
init_error_stream (unix_stream *error)
{
  memset (error, '\0', sizeof (*error));

  error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;

  error->st.alloc_w_at = (void *) fd_alloc_w_at;
  error->st.sfree = (void *) fd_sfree;

  error->unbuffered = 1;
  error->buffer = error->small_buffer;

  return (stream *) error;
}


/* compare_file_filename()-- Given an open stream and a fortran string
 * that is a filename, figure out if the file is the same as the
 * filename. */

int
compare_file_filename (gfc_unit *u, const char *name, int len)
{
  char path[PATH_MAX + 1];
  struct stat st1;
#ifdef HAVE_WORKING_STAT
  struct stat st2;
#endif

  if (unpack_filename (path, name, len))
    return 0;			/* Can't be the same */

  /* If the filename doesn't exist, then there is no match with the
   * existing file. */

  if (stat (path, &st1) < 0)
    return 0;

#ifdef HAVE_WORKING_STAT
  fstat (((unix_stream *) (u->s))->fd, &st2);
  return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
#else
  if (len != u->file_len)
    return 0;
  return (memcmp(path, u->file, len) == 0);
#endif
}


#ifdef HAVE_WORKING_STAT
# define FIND_FILE0_DECL struct stat *st
# define FIND_FILE0_ARGS st
#else
# define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
# define FIND_FILE0_ARGS file, file_len
#endif

/* find_file0()-- Recursive work function for find_file() */

static gfc_unit *
find_file0 (gfc_unit *u, FIND_FILE0_DECL)
{
  gfc_unit *v;

  if (u == NULL)
    return NULL;

#ifdef HAVE_WORKING_STAT
  if (u->s != NULL
      && fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
      st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
    return u;
#else
  if (compare_string (u->file_len, u->file, file_len, file) == 0)
    return u;
#endif

  v = find_file0 (u->left, FIND_FILE0_ARGS);
  if (v != NULL)
    return v;

  v = find_file0 (u->right, FIND_FILE0_ARGS);
  if (v != NULL)
    return v;

  return NULL;
}


/* find_file()-- Take the current filename and see if there is a unit
 * that has the file already open.  Returns a pointer to the unit if so. */

gfc_unit *
find_file (const char *file, gfc_charlen_type file_len)
{
  char path[PATH_MAX + 1];
  struct stat st[2];
  gfc_unit *u;

  if (unpack_filename (path, file, file_len))
    return NULL;

  if (stat (path, &st[0]) < 0)
    return NULL;

  __gthread_mutex_lock (&unit_lock);
retry:
  u = find_file0 (unit_root, FIND_FILE0_ARGS);
  if (u != NULL)
    {
      /* Fast path.  */
      if (! __gthread_mutex_trylock (&u->lock))
	{
	  /* assert (u->closed == 0); */
	  __gthread_mutex_unlock (&unit_lock);
	  return u;
	}

      inc_waiting_locked (u);
    }
  __gthread_mutex_unlock (&unit_lock);
  if (u != NULL)
    {
      __gthread_mutex_lock (&u->lock);
      if (u->closed)
	{
	  __gthread_mutex_lock (&unit_lock);
	  __gthread_mutex_unlock (&u->lock);
	  if (predec_waiting_locked (u) == 0)
	    free_mem (u);
	  goto retry;
	}

      dec_waiting_unlocked (u);
    }
  return u;
}

static gfc_unit *
flush_all_units_1 (gfc_unit *u, int min_unit)
{
  while (u != NULL)
    {
      if (u->unit_number > min_unit)
	{
	  gfc_unit *r = flush_all_units_1 (u->left, min_unit);
	  if (r != NULL)
	    return r;
	}
      if (u->unit_number >= min_unit)
	{
	  if (__gthread_mutex_trylock (&u->lock))
	    return u;
	  if (u->s)
	    flush (u->s);
	  __gthread_mutex_unlock (&u->lock);
	}
      u = u->right;
    }
  return NULL;
}

void
flush_all_units (void)
{
  gfc_unit *u;
  int min_unit = 0;

  __gthread_mutex_lock (&unit_lock);
  do
    {
      u = flush_all_units_1 (unit_root, min_unit);
      if (u != NULL)
	inc_waiting_locked (u);
      __gthread_mutex_unlock (&unit_lock);
      if (u == NULL)
	return;

      __gthread_mutex_lock (&u->lock);

      min_unit = u->unit_number + 1;

      if (u->closed == 0)
	{
	  flush (u->s);
	  __gthread_mutex_lock (&unit_lock);
	  __gthread_mutex_unlock (&u->lock);
	  (void) predec_waiting_locked (u);
	}
      else
	{
	  __gthread_mutex_lock (&unit_lock);
	  __gthread_mutex_unlock (&u->lock);
	  if (predec_waiting_locked (u) == 0)
	    free_mem (u);
	}
    }
  while (1);
}


/* stream_at_bof()-- Returns nonzero if the stream is at the beginning
 * of the file. */

int
stream_at_bof (stream * s)
{
  unix_stream *us;

  if (!is_seekable (s))
    return 0;

  us = (unix_stream *) s;

  return us->logical_offset == 0;
}


/* stream_at_eof()-- Returns nonzero if the stream is at the end
 * of the file. */

int
stream_at_eof (stream * s)
{
  unix_stream *us;

  if (!is_seekable (s))
    return 0;

  us = (unix_stream *) s;

  return us->logical_offset == us->dirty_offset;
}


/* delete_file()-- Given a unit structure, delete the file associated
 * with the unit.  Returns nonzero if something went wrong. */

int
delete_file (gfc_unit * u)
{
  char path[PATH_MAX + 1];

  if (unpack_filename (path, u->file, u->file_len))
    {				/* Shouldn't be possible */
      errno = ENOENT;
      return 1;
    }

  return unlink (path);
}


/* file_exists()-- Returns nonzero if the current filename exists on
 * the system */

int
file_exists (const char *file, gfc_charlen_type file_len)
{
  char path[PATH_MAX + 1];
  struct stat statbuf;

  if (unpack_filename (path, file, file_len))
    return 0;

  if (stat (path, &statbuf) < 0)
    return 0;

  return 1;
}



static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";

/* inquire_sequential()-- Given a fortran string, determine if the
 * file is suitable for sequential access.  Returns a C-style
 * string. */

const char *
inquire_sequential (const char *string, int len)
{
  char path[PATH_MAX + 1];
  struct stat statbuf;

  if (string == NULL ||
      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
    return unknown;

  if (S_ISREG (statbuf.st_mode) ||
      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
    return yes;

  if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
    return no;

  return unknown;
}


/* inquire_direct()-- Given a fortran string, determine if the file is
 * suitable for direct access.  Returns a C-style string. */

const char *
inquire_direct (const char *string, int len)
{
  char path[PATH_MAX + 1];
  struct stat statbuf;

  if (string == NULL ||
      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
    return unknown;

  if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
    return yes;

  if (S_ISDIR (statbuf.st_mode) ||
      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
    return no;

  return unknown;
}


/* inquire_formatted()-- Given a fortran string, determine if the file
 * is suitable for formatted form.  Returns a C-style string. */

const char *
inquire_formatted (const char *string, int len)
{
  char path[PATH_MAX + 1];
  struct stat statbuf;

  if (string == NULL ||
      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
    return unknown;

  if (S_ISREG (statbuf.st_mode) ||
      S_ISBLK (statbuf.st_mode) ||
      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
    return yes;

  if (S_ISDIR (statbuf.st_mode))
    return no;

  return unknown;
}


/* inquire_unformatted()-- Given a fortran string, determine if the file
 * is suitable for unformatted form.  Returns a C-style string. */

const char *
inquire_unformatted (const char *string, int len)
{
  return inquire_formatted (string, len);
}


/* inquire_access()-- Given a fortran string, determine if the file is
 * suitable for access. */

static const char *
inquire_access (const char *string, int len, int mode)
{
  char path[PATH_MAX + 1];

  if (string == NULL || unpack_filename (path, string, len) ||
      access (path, mode) < 0)
    return no;

  return yes;
}


/* inquire_read()-- Given a fortran string, determine if the file is
 * suitable for READ access. */

const char *
inquire_read (const char *string, int len)
{
  return inquire_access (string, len, R_OK);
}


/* inquire_write()-- Given a fortran string, determine if the file is
 * suitable for READ access. */

const char *
inquire_write (const char *string, int len)
{
  return inquire_access (string, len, W_OK);
}


/* inquire_readwrite()-- Given a fortran string, determine if the file is
 * suitable for read and write access. */

const char *
inquire_readwrite (const char *string, int len)
{
  return inquire_access (string, len, R_OK | W_OK);
}


/* file_length()-- Return the file length in bytes, -1 if unknown */

gfc_offset
file_length (stream * s)
{
  return ((unix_stream *) s)->file_length;
}


/* file_position()-- Return the current position of the file */

gfc_offset
file_position (stream * s)
{
  return ((unix_stream *) s)->logical_offset;
}


/* is_seekable()-- Return nonzero if the stream is seekable, zero if
 * it is not */

int
is_seekable (stream * s)
{
  /* By convention, if file_length == -1, the file is not
     seekable.  */
  return ((unix_stream *) s)->file_length!=-1;
}

try
flush (stream *s)
{
  return fd_flush( (unix_stream *) s);
}

int
stream_isatty (stream *s)
{
  return isatty (((unix_stream *) s)->fd);
}

char *
stream_ttyname (stream *s)
{
#ifdef HAVE_TTYNAME
  return ttyname (((unix_stream *) s)->fd);
#else
  return NULL;
#endif
}

gfc_offset
stream_offset (stream *s)
{
  return (((unix_stream *) s)->logical_offset);
}


/* How files are stored:  This is an operating-system specific issue,
   and therefore belongs here.  There are three cases to consider.

   Direct Access:
      Records are written as block of bytes corresponding to the record
      length of the file.  This goes for both formatted and unformatted
      records.  Positioning is done explicitly for each data transfer,
      so positioning is not much of an issue.

   Sequential Formatted:
      Records are separated by newline characters.  The newline character
      is prohibited from appearing in a string.  If it does, this will be
      messed up on the next read.  End of file is also the end of a record.

   Sequential Unformatted:
      In this case, we are merely copying bytes to and from main storage,
      yet we need to keep track of varying record lengths.  We adopt
      the solution used by f2c.  Each record contains a pair of length
      markers:

        Length of record n in bytes
        Data of record n
        Length of record n in bytes

        Length of record n+1 in bytes
        Data of record n+1
        Length of record n+1 in bytes

     The length is stored at the end of a record to allow backspacing to the
     previous record.  Between data transfer statements, the file pointer
     is left pointing to the first length of the current record.

     ENDFILE records are never explicitly stored.

*/