[thirdparty/gcc.git] / libgfortran / io / intrinsics.c

/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH 
   FTELL, TTYNAM and ISATTY intrinsics.
   Copyright (C) 2005-2019 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;
}
Commit	Line	Data
76c0a846	1	/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
76c0a846	2	FTELL, TTYNAM and ISATTY intrinsics.
fbd26352	3	Copyright (C) 2005-2019 Free Software Foundation, Inc.
16de8065	4
ebe7a403	5	This file is part of the GNU Fortran runtime library (libgfortran).
16de8065	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
6bc9506f	10	version 3 of the License, or (at your option) any later version.
16de8065	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
6bc9506f	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
16de8065	25
41f2d5e8	26	#include "io.h"
f65f6629	27	#include "fbuf.h"
f65f6629	28	#include "unix.h"
16de8065	29	#include <string.h>
16de8065	30
a1aa1d30	31
16de8065	32	static const int five = 5;
	33	static const int six = 6;
	34
	35	extern int PREFIX(fgetc) (const int , char , gfc_charlen_type);
	36	export_proto_np(PREFIX(fgetc));
	37
	38	int
25a5ce27	39	PREFIX(fgetc) (const int unit, char c, gfc_charlen_type c_len)
16de8065	40	{
16de8065	41	int ret;
25a5ce27	42	gfc_unit u = find_unit (unit);
16de8065	43
	44	if (u == NULL)
	45	return -1;
	46
7ee4f67a	47	fbuf_reset (u);
	48	if (u->mode == WRITING)
	49	{
	50	sflush (u->s);
	51	u->mode = READING;
	52	}
	53
16de8065	54	memset (c, ' ', c_len);
e2b80761	55	ret = sread (u->s, c, 1);
7b70a698	56	unlock_unit (u);
16de8065	57
65f15010	58	if (ret < 0)
16de8065	59	return ret;
16de8065	60
65f15010	61	if (ret != 1)
16de8065	62	return -1;
	63	else
	64	return 0;
	65	}
	66
	67
	68	#define FGETC_SUB(kind) \
	69	extern void fgetc_i ## kind ## _sub \
	70	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	71	export_proto(fgetc_i ## kind ## _sub); \
	72	void fgetc_i ## kind ## _sub \
25a5ce27	73	(const int unit, char c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
16de8065	74	{ if (st != NULL) \
	75	*st = PREFIX(fgetc) (unit, c, c_len); \
	76	else \
	77	PREFIX(fgetc) (unit, c, c_len); }
	78
	79	FGETC_SUB(1)
	80	FGETC_SUB(2)
	81	FGETC_SUB(4)
	82	FGETC_SUB(8)
	83
	84
	85	extern int PREFIX(fget) (char *, gfc_charlen_type);
	86	export_proto_np(PREFIX(fget));
	87
	88	int
25a5ce27	89	PREFIX(fget) (char *c, gfc_charlen_type c_len)
16de8065	90	{
	91	return PREFIX(fgetc) (&five, c, c_len);
	92	}
	93
	94
	95	#define FGET_SUB(kind) \
	96	extern void fget_i ## kind ## _sub \
	97	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	98	export_proto(fget_i ## kind ## _sub); \
	99	void fget_i ## kind ## _sub \
25a5ce27	100	(char c, GFC_INTEGER_ ## kind st, gfc_charlen_type c_len) \
16de8065	101	{ if (st != NULL) \
	102	*st = PREFIX(fgetc) (&five, c, c_len); \
	103	else \
	104	PREFIX(fgetc) (&five, c, c_len); }
	105
	106	FGET_SUB(1)
	107	FGET_SUB(2)
	108	FGET_SUB(4)
	109	FGET_SUB(8)
	110
	111
	112
	113	extern int PREFIX(fputc) (const int , char , gfc_charlen_type);
	114	export_proto_np(PREFIX(fputc));
	115
	116	int
25a5ce27	117	PREFIX(fputc) (const int unit, char c,
16de8065	118	gfc_charlen_type c_len __attribute__((unused)))
16de8065	119	{
65f15010	120	ssize_t s;
25a5ce27	121	gfc_unit u = find_unit (unit);
16de8065	122
	123	if (u == NULL)
	124	return -1;
	125
7ee4f67a	126	fbuf_reset (u);
	127	if (u->mode == READING)
	128	{
	129	sflush (u->s);
	130	u->mode = WRITING;
	131	}
	132
65f15010	133	s = swrite (u->s, c, 1);
7b70a698	134	unlock_unit (u);
65f15010	135	if (s < 0)
	136	return -1;
	137	return 0;
16de8065	138	}
	139
	140
	141	#define FPUTC_SUB(kind) \
	142	extern void fputc_i ## kind ## _sub \
	143	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	144	export_proto(fputc_i ## kind ## _sub); \
	145	void fputc_i ## kind ## _sub \
25a5ce27	146	(const int unit, char c, GFC_INTEGER_ ## kind *st, gfc_charlen_type c_len) \
16de8065	147	{ if (st != NULL) \
	148	*st = PREFIX(fputc) (unit, c, c_len); \
	149	else \
	150	PREFIX(fputc) (unit, c, c_len); }
	151
	152	FPUTC_SUB(1)
	153	FPUTC_SUB(2)
	154	FPUTC_SUB(4)
	155	FPUTC_SUB(8)
	156
	157
	158	extern int PREFIX(fput) (char *, gfc_charlen_type);
	159	export_proto_np(PREFIX(fput));
	160
	161	int
25a5ce27	162	PREFIX(fput) (char *c, gfc_charlen_type c_len)
16de8065	163	{
	164	return PREFIX(fputc) (&six, c, c_len);
	165	}
	166
	167
	168	#define FPUT_SUB(kind) \
	169	extern void fput_i ## kind ## _sub \
	170	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	171	export_proto(fput_i ## kind ## _sub); \
	172	void fput_i ## kind ## _sub \
25a5ce27	173	(char c, GFC_INTEGER_ ## kind st, gfc_charlen_type c_len) \
16de8065	174	{ if (st != NULL) \
	175	*st = PREFIX(fputc) (&six, c, c_len); \
	176	else \
	177	PREFIX(fputc) (&six, c, c_len); }
	178
	179	FPUT_SUB(1)
	180	FPUT_SUB(2)
	181	FPUT_SUB(4)
	182	FPUT_SUB(8)
	183
76c0a846	184
	185	/* SUBROUTINE FLUSH(UNIT)
	186	INTEGER, INTENT(IN), OPTIONAL :: UNIT */
	187
	188	extern void flush_i4 (GFC_INTEGER_4 *);
	189	export_proto(flush_i4);
	190
	191	void
	192	flush_i4 (GFC_INTEGER_4 *unit)
	193	{
	194	gfc_unit *us;
	195
	196	/* flush all streams */
	197	if (unit == NULL)
	198	flush_all_units ();
	199	else
	200	{
	201	us = find_unit (*unit);
	202	if (us != NULL)
	203	{
65f15010	204	sflush (us->s);
76c0a846	205	unlock_unit (us);
	206	}
	207	}
	208	}
	209
	210
	211	extern void flush_i8 (GFC_INTEGER_8 *);
	212	export_proto(flush_i8);
	213
	214	void
	215	flush_i8 (GFC_INTEGER_8 *unit)
	216	{
	217	gfc_unit *us;
	218
	219	/* flush all streams */
	220	if (unit == NULL)
	221	flush_all_units ();
	222	else
	223	{
	224	us = find_unit (*unit);
	225	if (us != NULL)
	226	{
65f15010	227	sflush (us->s);
76c0a846	228	unlock_unit (us);
	229	}
	230	}
	231	}
	232
7d866870	233	/* FSEEK intrinsic */
	234
	235	extern void fseek_sub (int , GFC_IO_INT , int , int );
	236	export_proto(fseek_sub);
	237
	238	void
25a5ce27	239	fseek_sub (int unit, GFC_IO_INT offset, int whence, int status)
7d866870	240	{
25a5ce27	241	gfc_unit u = find_unit (unit);
65f15010	242	ssize_t result = -1;
7d866870	243
cc65b133	244	if (u != NULL)
7d866870	245	{
65f15010	246	result = sseek(u->s, offset, whence);
7d866870	247
	248	unlock_unit (u);
	249	}
	250
	251	if (status)
65f15010	252	*status = (result < 0 ? -1 : 0);
7d866870	253	}
	254
	255
76c0a846	256
	257	/* FTELL intrinsic */
	258
8c3cef8b	259	static gfc_offset
	260	gf_ftell (int unit)
	261	{
25a5ce27	262	gfc_unit *u = find_unit (unit);
8c3cef8b	263	if (u == NULL)
	264	return -1;
	265	int pos = fbuf_reset (u);
	266	if (pos != 0)
	267	sseek (u->s, pos, SEEK_CUR);
	268	gfc_offset ret = stell (u->s);
	269	unlock_unit (u);
	270	return ret;
	271	}
	272
dd645196	273
84f0fbc6	274	extern GFC_IO_INT PREFIX(ftell) (int *);
76c0a846	275	export_proto_np(PREFIX(ftell));
76c0a846	276
dd645196	277	GFC_IO_INT
25a5ce27	278	PREFIX(ftell) (int *unit)
dd645196	279	{
	280	return gf_ftell (*unit);
	281	}
	282
	283
76c0a846	284	#define FTELL_SUB(kind) \
	285	extern void ftell_i ## kind ## _sub (int , GFC_INTEGER_ ## kind ); \
	286	export_proto(ftell_i ## kind ## _sub); \
	287	void \
25a5ce27	288	ftell_i ## kind ## _sub (int unit, GFC_INTEGER_ ## kind offset) \
76c0a846	289	{ \
8c3cef8b	290	offset = gf_ftell (unit); \
76c0a846	291	}
	292
	293	FTELL_SUB(1)
	294	FTELL_SUB(2)
	295	FTELL_SUB(4)
	296	FTELL_SUB(8)
	297
	298
	299
	300	/* LOGICAL FUNCTION ISATTY(UNIT)
	301	INTEGER, INTENT(IN) :: UNIT */
	302
	303	extern GFC_LOGICAL_4 isatty_l4 (int *);
	304	export_proto(isatty_l4);
	305
	306	GFC_LOGICAL_4
	307	isatty_l4 (int *unit)
	308	{
	309	gfc_unit *u;
	310	GFC_LOGICAL_4 ret = 0;
	311
	312	u = find_unit (*unit);
	313	if (u != NULL)
	314	{
	315	ret = (GFC_LOGICAL_4) stream_isatty (u->s);
	316	unlock_unit (u);
	317	}
	318	return ret;
	319	}
	320
	321
	322	extern GFC_LOGICAL_8 isatty_l8 (int *);
	323	export_proto(isatty_l8);
	324
	325	GFC_LOGICAL_8
	326	isatty_l8 (int *unit)
	327	{
	328	gfc_unit *u;
	329	GFC_LOGICAL_8 ret = 0;
	330
	331	u = find_unit (*unit);
	332	if (u != NULL)
	333	{
	334	ret = (GFC_LOGICAL_8) stream_isatty (u->s);
	335	unlock_unit (u);
	336	}
	337	return ret;
	338	}
	339
	340
	341	/* SUBROUTINE TTYNAM(UNIT,NAME)
	342	INTEGER,SCALAR,INTENT(IN) :: UNIT
	343	CHARACTER,SCALAR,INTENT(OUT) :: NAME */
	344
	345	extern void ttynam_sub (int , char , gfc_charlen_type);
	346	export_proto(ttynam_sub);
	347
	348	void
25a5ce27	349	ttynam_sub (int unit, char name, gfc_charlen_type name_len)
76c0a846	350	{
76c0a846	351	gfc_unit *u;
57f34837	352	int nlen;
57f34837	353	int err = 1;
76c0a846	354
76c0a846	355	u = find_unit (*unit);
	356	if (u != NULL)
	357	{
57f34837	358	err = stream_ttyname (u->s, name, name_len);
57f34837	359	if (err == 0)
76c0a846	360	{
57f34837	361	nlen = strlen (name);
57f34837	362	memset (&name[nlen], ' ', name_len - nlen);
76c0a846	363	}
57f34837	364
76c0a846	365	unlock_unit (u);
76c0a846	366	}
57f34837	367	if (err != 0)
57f34837	368	memset (name, ' ', name_len);
76c0a846	369	}
	370
	371
	372	extern void ttynam (char *, gfc_charlen_type , int);
	373	export_proto(ttynam);
	374
	375	void
25a5ce27	376	ttynam (char *name, gfc_charlen_type name_len, int unit)
76c0a846	377	{
	378	gfc_unit *u;
	379
	380	u = find_unit (unit);
	381	if (u != NULL)
	382	{
25c067ae	383	*name = xmalloc (TTY_NAME_MAX);
57f34837	384	int err = stream_ttyname (u->s, *name, TTY_NAME_MAX);
57f34837	385	if (err == 0)
76c0a846	386	{
76c0a846	387	name_len = strlen (name);
76c0a846	388	unlock_unit (u);
	389	return;
	390	}
57f34837	391	free (*name);
76c0a846	392	unlock_unit (u);
	393	}
	394
	395	*name_len = 0;
	396	*name = NULL;
	397	}