libgfortran/io/intrinsics.c - gcc - Git at Google

 /* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
    FTELL, TTYNAM and ISATTY intrinsics.
    Copyright (C) 2005-2021 Free Software Foundation, Inc.

 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 3 of the License, or (at your option) any later version.

 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.

 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 "fbuf.h"
 #include "unix.h"
 #include <string.h>


 static const int five = 5;
 static const int six = 6;

 extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
 export_proto_np(PREFIX(fgetc));

 int
 PREFIX(fgetc) (const int *unit, char *c, gfc_charlen_type c_len)
 {
   int ret;
   gfc_unit *u = find_unit (*unit);

   if (u == NULL)
     return -1;

   fbuf_reset (u);
   if (u->mode == WRITING)
     {
       sflush (u->s);
       u->mode = READING;
     }

   memset (c, ' ', c_len);
   ret = sread (u->s, c, 1);
   unlock_unit (u);

   if (ret < 0)
     return ret;

   if (ret != 1)
     return -1;
   else
     return 0;
 }


 #define FGETC_SUB(kind) \
   extern void fgetc_i ## kind ## _sub \
     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
   export_proto(fgetc_i ## kind ## _sub); \
   void fgetc_i ## kind ## _sub \
   (const int *unit, char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
     { if (st != NULL) \
         *st = PREFIX(fgetc) (unit, c, c_len); \
       else \
         PREFIX(fgetc) (unit, c, c_len); }

 FGETC_SUB(1)
 FGETC_SUB(2)
 FGETC_SUB(4)
 FGETC_SUB(8)


 extern int PREFIX(fget) (char *, gfc_charlen_type);
 export_proto_np(PREFIX(fget));

 int
 PREFIX(fget) (char *c, gfc_charlen_type c_len)
 {
   return PREFIX(fgetc) (&five, c, c_len);
 }


 #define FGET_SUB(kind) \
   extern void fget_i ## kind ## _sub \
     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
   export_proto(fget_i ## kind ## _sub); \
   void fget_i ## kind ## _sub \
   (char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
     { if (st != NULL) \
         *st = PREFIX(fgetc) (&five, c, c_len); \
       else \
         PREFIX(fgetc) (&five, c, c_len); }

 FGET_SUB(1)
 FGET_SUB(2)
 FGET_SUB(4)
 FGET_SUB(8)


 extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
 export_proto_np(PREFIX(fputc));

 int
 PREFIX(fputc) (const int *unit, char *c,
 	       gfc_charlen_type c_len __attribute__((unused)))
 {
   ssize_t s;
   gfc_unit *u = find_unit (*unit);

   if (u == NULL)
     return -1;

   fbuf_reset (u);
   if (u->mode == READING)
     {
       sflush (u->s);
       u->mode = WRITING;
     }

   s = swrite (u->s, c, 1);
   unlock_unit (u);
   if (s < 0)
     return -1;
   return 0;
 }


 #define FPUTC_SUB(kind) \
   extern void fputc_i ## kind ## _sub \
     (const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
   export_proto(fputc_i ## kind ## _sub); \
   void fputc_i ## kind ## _sub \
   (const int *unit, char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
     { if (st != NULL) \
         *st = PREFIX(fputc) (unit, c, c_len); \
       else \
         PREFIX(fputc) (unit, c, c_len); }

 FPUTC_SUB(1)
 FPUTC_SUB(2)
 FPUTC_SUB(4)
 FPUTC_SUB(8)


 extern int PREFIX(fput) (char *, gfc_charlen_type);
 export_proto_np(PREFIX(fput));

 int
 PREFIX(fput) (char *c, gfc_charlen_type c_len)
 {
   return PREFIX(fputc) (&six, c, c_len);
 }


 #define FPUT_SUB(kind) \
   extern void fput_i ## kind ## _sub \
     (char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
   export_proto(fput_i ## kind ## _sub); \
   void fput_i ## kind ## _sub \
   (char *c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
     { if (st != NULL) \
         *st = PREFIX(fputc) (&six, c, c_len); \
       else \
         PREFIX(fputc) (&six, c, c_len); }

 FPUT_SUB(1)
 FPUT_SUB(2)
 FPUT_SUB(4)
 FPUT_SUB(8)


 /* SUBROUTINE FLUSH(UNIT)
    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */

 extern void flush_i4 (GFC_INTEGER_4 *);
 export_proto(flush_i4);

 void
 flush_i4 (GFC_INTEGER_4 *unit)
 {
   gfc_unit *us;

   /* flush all streams */
   if (unit == NULL)
     flush_all_units ();
   else
     {
       us = find_unit (*unit);
       if (us != NULL)
 	{
 	  sflush (us->s);
 	  unlock_unit (us);
 	}
     }
 }


 extern void flush_i8 (GFC_INTEGER_8 *);
 export_proto(flush_i8);

 void
 flush_i8 (GFC_INTEGER_8 *unit)
 {
   gfc_unit *us;

   /* flush all streams */
   if (unit == NULL)
     flush_all_units ();
   else
     {
       us = find_unit (*unit);
       if (us != NULL)
 	{
 	  sflush (us->s);
 	  unlock_unit (us);
 	}
     }
 }

 /* FSEEK intrinsic */

 extern void fseek_sub (int *, GFC_IO_INT *, int *, int *);
 export_proto(fseek_sub);

 void
 fseek_sub (int *unit, GFC_IO_INT *offset, int *whence, int *status)
 {
   gfc_unit *u = find_unit (*unit);
   ssize_t result = -1;

   if (u != NULL)
     {
       result = sseek(u->s, *offset, *whence);

       unlock_unit (u);
     }

   if (status)
     *status = (result < 0 ? -1 : 0);
 }


 /* FTELL intrinsic */

 static gfc_offset
 gf_ftell (int unit)
 {
   gfc_unit *u = find_unit (unit);
   if (u == NULL)
     return -1;
   int pos = fbuf_reset (u);
   if (pos != 0)
     sseek (u->s, pos, SEEK_CUR);
   gfc_offset ret = stell (u->s);
   unlock_unit (u);
   return ret;
 }


 extern GFC_IO_INT PREFIX(ftell) (int *);
 export_proto_np(PREFIX(ftell));

 GFC_IO_INT
 PREFIX(ftell) (int *unit)
 {
   return gf_ftell (*unit);
 }


 #define FTELL_SUB(kind) \
   extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
   export_proto(ftell_i ## kind ## _sub); \
   void \
   ftell_i ## kind ## _sub (int *unit, GFC_INTEGER_ ## kind *offset) \
   { \
     *offset = gf_ftell (*unit);			\
   }

 FTELL_SUB(1)
 FTELL_SUB(2)
 FTELL_SUB(4)
 FTELL_SUB(8)


 /* LOGICAL FUNCTION ISATTY(UNIT)
    INTEGER, INTENT(IN) :: UNIT */

 extern GFC_LOGICAL_4 isatty_l4 (int *);
 export_proto(isatty_l4);

 GFC_LOGICAL_4
 isatty_l4 (int *unit)
 {
   gfc_unit *u;
   GFC_LOGICAL_4 ret = 0;

   u = find_unit (*unit);
   if (u != NULL)
     {
       ret = (GFC_LOGICAL_4) stream_isatty (u->s);
       unlock_unit (u);
     }
   return ret;
 }


 extern GFC_LOGICAL_8 isatty_l8 (int *);
 export_proto(isatty_l8);

 GFC_LOGICAL_8
 isatty_l8 (int *unit)
 {
   gfc_unit *u;
   GFC_LOGICAL_8 ret = 0;

   u = find_unit (*unit);
   if (u != NULL)
     {
       ret = (GFC_LOGICAL_8) stream_isatty (u->s);
       unlock_unit (u);
     }
   return ret;
 }


 /* SUBROUTINE TTYNAM(UNIT,NAME)
    INTEGER,SCALAR,INTENT(IN) :: UNIT
    CHARACTER,SCALAR,INTENT(OUT) :: NAME */

 extern void ttynam_sub (int *, char *, gfc_charlen_type);
 export_proto(ttynam_sub);

 void
 ttynam_sub (int *unit, char *name, gfc_charlen_type name_len)
 {
   gfc_unit *u;
   int nlen;
   int err = 1;

   u = find_unit (*unit);
   if (u != NULL)
     {
       err = stream_ttyname (u->s, name, name_len);
       if (err == 0)
 	{
 	  nlen = strlen (name);
 	  memset (&name[nlen], ' ', name_len - nlen);
 	}

       unlock_unit (u);
     }
   if (err != 0)
     memset (name, ' ', name_len);
 }


 extern void ttynam (char **, gfc_charlen_type *, int);
 export_proto(ttynam);

 void
 ttynam (char **name, gfc_charlen_type *name_len, int unit)
 {
   gfc_unit *u;

   u = find_unit (unit);
   if (u != NULL)
     {
       *name = xmalloc (TTY_NAME_MAX);
       int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
       if (err == 0)
 	{
 	  *name_len = strlen (*name);
 	  unlock_unit (u);
 	  return;
 	}
       free (*name);
       unlock_unit (u);
     }

   *name_len = 0;
   *name = NULL;
 }
	/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
	FTELL, TTYNAM and ISATTY intrinsics.
	Copyright (C) 2005-2021 Free Software Foundation, Inc.

	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 3 of the License, or (at your option) any later version.

	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.

	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 "fbuf.h"
	#include "unix.h"
	#include <string.h>


	static const int five = 5;
	static const int six = 6;

	extern int PREFIX(fgetc) (const int , char , gfc_charlen_type);
	export_proto_np(PREFIX(fgetc));

	int
	PREFIX(fgetc) (const int unit, char c, gfc_charlen_type c_len)
	{
	int ret;
	gfc_unit u = find_unit (unit);

	if (u == NULL)
	return -1;

	fbuf_reset (u);
	if (u->mode == WRITING)
	{
	sflush (u->s);
	u->mode = READING;
	}

	memset (c, ' ', c_len);
	ret = sread (u->s, c, 1);
	unlock_unit (u);

	if (ret < 0)
	return ret;

	if (ret != 1)
	return -1;
	else
	return 0;
	}


	#define FGETC_SUB(kind) \
	extern void fgetc_i ## kind ## _sub \
	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	export_proto(fgetc_i ## kind ## _sub); \
	void fgetc_i ## kind ## _sub \
	(const int unit, char c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
	{ if (st != NULL) \
	*st = PREFIX(fgetc) (unit, c, c_len); \
	else \
	PREFIX(fgetc) (unit, c, c_len); }

	FGETC_SUB(1)
	FGETC_SUB(2)
	FGETC_SUB(4)
	FGETC_SUB(8)


	extern int PREFIX(fget) (char *, gfc_charlen_type);
	export_proto_np(PREFIX(fget));

	int
	PREFIX(fget) (char *c, gfc_charlen_type c_len)
	{
	return PREFIX(fgetc) (&five, c, c_len);
	}


	#define FGET_SUB(kind) \
	extern void fget_i ## kind ## _sub \
	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	export_proto(fget_i ## kind ## _sub); \
	void fget_i ## kind ## _sub \
	(char c, GFC_INTEGER_ ## kind st, gfc_charlen_type c_len) \
	{ if (st != NULL) \
	*st = PREFIX(fgetc) (&five, c, c_len); \
	else \
	PREFIX(fgetc) (&five, c, c_len); }

	FGET_SUB(1)
	FGET_SUB(2)
	FGET_SUB(4)
	FGET_SUB(8)



	extern int PREFIX(fputc) (const int , char , gfc_charlen_type);
	export_proto_np(PREFIX(fputc));

	int
	PREFIX(fputc) (const int unit, char c,
	gfc_charlen_type c_len __attribute__((unused)))
	{
	ssize_t s;
	gfc_unit u = find_unit (unit);

	if (u == NULL)
	return -1;

	fbuf_reset (u);
	if (u->mode == READING)
	{
	sflush (u->s);
	u->mode = WRITING;
	}

	s = swrite (u->s, c, 1);
	unlock_unit (u);
	if (s < 0)
	return -1;
	return 0;
	}


	#define FPUTC_SUB(kind) \
	extern void fputc_i ## kind ## _sub \
	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	export_proto(fputc_i ## kind ## _sub); \
	void fputc_i ## kind ## _sub \
	(const int unit, char c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
	{ if (st != NULL) \
	*st = PREFIX(fputc) (unit, c, c_len); \
	else \
	PREFIX(fputc) (unit, c, c_len); }

	FPUTC_SUB(1)
	FPUTC_SUB(2)
	FPUTC_SUB(4)
	FPUTC_SUB(8)


	extern int PREFIX(fput) (char *, gfc_charlen_type);
	export_proto_np(PREFIX(fput));

	int
	PREFIX(fput) (char *c, gfc_charlen_type c_len)
	{
	return PREFIX(fputc) (&six, c, c_len);
	}


	#define FPUT_SUB(kind) \
	extern void fput_i ## kind ## _sub \
	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	export_proto(fput_i ## kind ## _sub); \
	void fput_i ## kind ## _sub \
	(char c, GFC_INTEGER_ ## kind st, gfc_charlen_type c_len) \
	{ if (st != NULL) \
	*st = PREFIX(fputc) (&six, c, c_len); \
	else \
	PREFIX(fputc) (&six, c, c_len); }

	FPUT_SUB(1)
	FPUT_SUB(2)
	FPUT_SUB(4)
	FPUT_SUB(8)


	/* SUBROUTINE FLUSH(UNIT)
	INTEGER, INTENT(IN), OPTIONAL :: UNIT */

	extern void flush_i4 (GFC_INTEGER_4 *);
	export_proto(flush_i4);

	void
	flush_i4 (GFC_INTEGER_4 *unit)
	{
	gfc_unit *us;

	/* flush all streams */
	if (unit == NULL)
	flush_all_units ();
	else
	{
	us = find_unit (*unit);
	if (us != NULL)
	{
	sflush (us->s);
	unlock_unit (us);
	}
	}
	}


	extern void flush_i8 (GFC_INTEGER_8 *);
	export_proto(flush_i8);

	void
	flush_i8 (GFC_INTEGER_8 *unit)
	{
	gfc_unit *us;

	/* flush all streams */
	if (unit == NULL)
	flush_all_units ();
	else
	{
	us = find_unit (*unit);
	if (us != NULL)
	{
	sflush (us->s);
	unlock_unit (us);
	}
	}
	}

	/* FSEEK intrinsic */

	extern void fseek_sub (int , GFC_IO_INT , int , int );
	export_proto(fseek_sub);

	void
	fseek_sub (int unit, GFC_IO_INT offset, int whence, int status)
	{
	gfc_unit u = find_unit (unit);
	ssize_t result = -1;

	if (u != NULL)
	{
	result = sseek(u->s, offset, whence);

	unlock_unit (u);
	}

	if (status)
	*status = (result < 0 ? -1 : 0);
	}



	/* FTELL intrinsic */

	static gfc_offset
	gf_ftell (int unit)
	{
	gfc_unit *u = find_unit (unit);
	if (u == NULL)
	return -1;
	int pos = fbuf_reset (u);
	if (pos != 0)
	sseek (u->s, pos, SEEK_CUR);
	gfc_offset ret = stell (u->s);
	unlock_unit (u);
	return ret;
	}


	extern GFC_IO_INT PREFIX(ftell) (int *);
	export_proto_np(PREFIX(ftell));

	GFC_IO_INT
	PREFIX(ftell) (int *unit)
	{
	return gf_ftell (*unit);
	}


	#define FTELL_SUB(kind) \
	extern void ftell_i ## kind ## _sub (int , GFC_INTEGER_ ## kind ); \
	export_proto(ftell_i ## kind ## _sub); \
	void \
	ftell_i ## kind ## _sub (int unit, GFC_INTEGER_ ## kind offset) \
	{ \
	offset = gf_ftell (unit); \
	}

	FTELL_SUB(1)
	FTELL_SUB(2)
	FTELL_SUB(4)
	FTELL_SUB(8)



	/* LOGICAL FUNCTION ISATTY(UNIT)
	INTEGER, INTENT(IN) :: UNIT */

	extern GFC_LOGICAL_4 isatty_l4 (int *);
	export_proto(isatty_l4);

	GFC_LOGICAL_4
	isatty_l4 (int *unit)
	{
	gfc_unit *u;
	GFC_LOGICAL_4 ret = 0;

	u = find_unit (*unit);
	if (u != NULL)
	{
	ret = (GFC_LOGICAL_4) stream_isatty (u->s);
	unlock_unit (u);
	}
	return ret;
	}


	extern GFC_LOGICAL_8 isatty_l8 (int *);
	export_proto(isatty_l8);

	GFC_LOGICAL_8
	isatty_l8 (int *unit)
	{
	gfc_unit *u;
	GFC_LOGICAL_8 ret = 0;

	u = find_unit (*unit);
	if (u != NULL)
	{
	ret = (GFC_LOGICAL_8) stream_isatty (u->s);
	unlock_unit (u);
	}
	return ret;
	}


	/* SUBROUTINE TTYNAM(UNIT,NAME)
	INTEGER,SCALAR,INTENT(IN) :: UNIT
	CHARACTER,SCALAR,INTENT(OUT) :: NAME */

	extern void ttynam_sub (int , char , gfc_charlen_type);
	export_proto(ttynam_sub);

	void
	ttynam_sub (int unit, char name, gfc_charlen_type name_len)
	{
	gfc_unit *u;
	int nlen;
	int err = 1;

	u = find_unit (*unit);
	if (u != NULL)
	{
	err = stream_ttyname (u->s, name, name_len);
	if (err == 0)
	{
	nlen = strlen (name);
	memset (&name[nlen], ' ', name_len - nlen);
	}

	unlock_unit (u);
	}
	if (err != 0)
	memset (name, ' ', name_len);
	}


	extern void ttynam (char *, gfc_charlen_type , int);
	export_proto(ttynam);

	void
	ttynam (char *name, gfc_charlen_type name_len, int unit)
	{
	gfc_unit *u;

	u = find_unit (unit);
	if (u != NULL)
	{
	*name = xmalloc (TTY_NAME_MAX);
	int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
	if (err == 0)
	{
	name_len = strlen (name);
	unlock_unit (u);
	return;
	}
	free (*name);
	unlock_unit (u);
	}

	*name_len = 0;
	*name = NULL;
	}