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

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

This file is part of the GNU Fortran 95 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"

#ifdef HAVE_STDLIB_H
#include <stdlib.h>
#endif

#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;

  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;

  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 && is_seekable(u->s))
    {
      result = sseek(u->s, *offset, *whence);

      unlock_unit (u);
    }

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


/* FTELL intrinsic */

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

size_t
PREFIX(ftell) (int * unit)
{
  gfc_unit * u = find_unit (*unit);
  size_t ret;
  if (u == NULL)
    return ((size_t) -1);
  ret = (size_t) stell (u->s);
  unlock_unit (u);
  return ret;
}

#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) \
  { \
    gfc_unit * u = find_unit (*unit); \
    if (u == NULL) \
      *offset = -1; \
    else \
      { \
	*offset = stell (u->s); \
	unlock_unit (u); \
      } \
  }

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;
  char * n;
  int i;

  memset (name, ' ', name_len);
  u = find_unit (*unit);
  if (u != NULL)
    {
      n = stream_ttyname (u->s);
      if (n != NULL)
	{
	  i = 0;
	  while (*n && i < name_len)
	    name[i++] = *(n++);
	}
      unlock_unit (u);
    }
}


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 = stream_ttyname (u->s);
      if (*name != NULL)
	{
	  *name_len = strlen (*name);
	  *name = strdup (*name);
	  unlock_unit (u);
	  return;
	}
      unlock_unit (u);
    }

  *name_len = 0;
  *name = NULL;
}
Commit	Line	Data
0dce3ca1 FXC	1	/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH
0dce3ca1 FXC	2	FTELL, TTYNAM and ISATTY intrinsics.
f9bfed22	3	Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc.
5d723e54 FXC	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	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
748086b7	10	version 3 of the License, or (at your option) any later version.
5d723e54 FXC	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
748086b7 JJ	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/>. */
5d723e54	25
36ae8a61	26	#include "io.h"
5d723e54	27
0dce3ca1 FXC	28	#ifdef HAVE_STDLIB_H
	29	#include <stdlib.h>
	30	#endif
	31
5d723e54 FXC	32	#include <string.h>
5d723e54 FXC	33
5d723e54 FXC	34	static const int five = 5;
	35	static const int six = 6;
	36
	37	extern int PREFIX(fgetc) (const int , char , gfc_charlen_type);
	38	export_proto_np(PREFIX(fgetc));
	39
	40	int
	41	PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
	42	{
	43	int ret;
5d723e54 FXC	44	gfc_unit * u = find_unit (*unit);
	45
	46	if (u == NULL)
	47	return -1;
	48
5d723e54	49	memset (c, ' ', c_len);
f9bfed22	50	ret = sread (u->s, c, 1);
401cd90a	51	unlock_unit (u);
5d723e54	52
7812c78c	53	if (ret < 0)
5d723e54 FXC	54	return ret;
5d723e54 FXC	55
7812c78c	56	if (ret != 1)
5d723e54 FXC	57	return -1;
	58	else
	59	return 0;
	60	}
	61
	62
	63	#define FGETC_SUB(kind) \
	64	extern void fgetc_i ## kind ## _sub \
	65	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	66	export_proto(fgetc_i ## kind ## _sub); \
	67	void fgetc_i ## kind ## _sub \
	68	(const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	69	{ if (st != NULL) \
	70	*st = PREFIX(fgetc) (unit, c, c_len); \
	71	else \
	72	PREFIX(fgetc) (unit, c, c_len); }
	73
	74	FGETC_SUB(1)
	75	FGETC_SUB(2)
	76	FGETC_SUB(4)
	77	FGETC_SUB(8)
	78
	79
	80	extern int PREFIX(fget) (char *, gfc_charlen_type);
	81	export_proto_np(PREFIX(fget));
	82
	83	int
	84	PREFIX(fget) (char * c, gfc_charlen_type c_len)
	85	{
	86	return PREFIX(fgetc) (&five, c, c_len);
	87	}
	88
	89
	90	#define FGET_SUB(kind) \
	91	extern void fget_i ## kind ## _sub \
	92	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	93	export_proto(fget_i ## kind ## _sub); \
	94	void fget_i ## kind ## _sub \
	95	(char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	96	{ if (st != NULL) \
	97	*st = PREFIX(fgetc) (&five, c, c_len); \
	98	else \
	99	PREFIX(fgetc) (&five, c, c_len); }
	100
	101	FGET_SUB(1)
	102	FGET_SUB(2)
	103	FGET_SUB(4)
	104	FGET_SUB(8)
	105
	106
	107
	108	extern int PREFIX(fputc) (const int , char , gfc_charlen_type);
	109	export_proto_np(PREFIX(fputc));
	110
	111	int
	112	PREFIX(fputc) (const int * unit, char * c,
	113	gfc_charlen_type c_len __attribute__((unused)))
	114	{
7812c78c	115	ssize_t s;
5d723e54 FXC	116	gfc_unit * u = find_unit (*unit);
	117
	118	if (u == NULL)
	119	return -1;
	120
7812c78c	121	s = swrite (u->s, c, 1);
401cd90a	122	unlock_unit (u);
7812c78c JD	123	if (s < 0)
	124	return -1;
	125	return 0;
5d723e54 FXC	126	}
	127
	128
	129	#define FPUTC_SUB(kind) \
	130	extern void fputc_i ## kind ## _sub \
	131	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	132	export_proto(fputc_i ## kind ## _sub); \
	133	void fputc_i ## kind ## _sub \
	134	(const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	135	{ if (st != NULL) \
	136	*st = PREFIX(fputc) (unit, c, c_len); \
	137	else \
	138	PREFIX(fputc) (unit, c, c_len); }
	139
	140	FPUTC_SUB(1)
	141	FPUTC_SUB(2)
	142	FPUTC_SUB(4)
	143	FPUTC_SUB(8)
	144
	145
	146	extern int PREFIX(fput) (char *, gfc_charlen_type);
	147	export_proto_np(PREFIX(fput));
	148
	149	int
	150	PREFIX(fput) (char * c, gfc_charlen_type c_len)
	151	{
	152	return PREFIX(fputc) (&six, c, c_len);
	153	}
	154
	155
	156	#define FPUT_SUB(kind) \
	157	extern void fput_i ## kind ## _sub \
	158	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	159	export_proto(fput_i ## kind ## _sub); \
	160	void fput_i ## kind ## _sub \
	161	(char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	162	{ if (st != NULL) \
	163	*st = PREFIX(fputc) (&six, c, c_len); \
	164	else \
	165	PREFIX(fputc) (&six, c, c_len); }
	166
	167	FPUT_SUB(1)
	168	FPUT_SUB(2)
	169	FPUT_SUB(4)
	170	FPUT_SUB(8)
	171
0dce3ca1 FXC	172
	173	/* SUBROUTINE FLUSH(UNIT)
	174	INTEGER, INTENT(IN), OPTIONAL :: UNIT */
	175
	176	extern void flush_i4 (GFC_INTEGER_4 *);
	177	export_proto(flush_i4);
	178
	179	void
	180	flush_i4 (GFC_INTEGER_4 *unit)
	181	{
	182	gfc_unit *us;
	183
	184	/* flush all streams */
	185	if (unit == NULL)
	186	flush_all_units ();
	187	else
	188	{
	189	us = find_unit (*unit);
	190	if (us != NULL)
	191	{
7812c78c	192	sflush (us->s);
0dce3ca1 FXC	193	unlock_unit (us);
	194	}
	195	}
	196	}
	197
	198
	199	extern void flush_i8 (GFC_INTEGER_8 *);
	200	export_proto(flush_i8);
	201
	202	void
	203	flush_i8 (GFC_INTEGER_8 *unit)
	204	{
	205	gfc_unit *us;
	206
	207	/* flush all streams */
	208	if (unit == NULL)
	209	flush_all_units ();
	210	else
	211	{
	212	us = find_unit (*unit);
	213	if (us != NULL)
	214	{
7812c78c	215	sflush (us->s);
0dce3ca1 FXC	216	unlock_unit (us);
	217	}
	218	}
	219	}
	220
dcdc26df DF	221	/* FSEEK intrinsic */
	222
	223	extern void fseek_sub (int , GFC_IO_INT , int , int );
	224	export_proto(fseek_sub);
	225
	226	void
	227	fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
	228	{
	229	gfc_unit * u = find_unit (*unit);
7812c78c	230	ssize_t result = -1;
dcdc26df DF	231
	232	if (u != NULL && is_seekable(u->s))
	233	{
7812c78c	234	result = sseek(u->s, offset, whence);
dcdc26df DF	235
	236	unlock_unit (u);
	237	}
	238
	239	if (status)
7812c78c	240	*status = (result < 0 ? -1 : 0);
dcdc26df DF	241	}
	242
	243
0dce3ca1 FXC	244
	245	/* FTELL intrinsic */
	246
	247	extern size_t PREFIX(ftell) (int *);
	248	export_proto_np(PREFIX(ftell));
	249
	250	size_t
	251	PREFIX(ftell) (int * unit)
	252	{
	253	gfc_unit * u = find_unit (*unit);
	254	size_t ret;
	255	if (u == NULL)
	256	return ((size_t) -1);
7812c78c	257	ret = (size_t) stell (u->s);
0dce3ca1 FXC	258	unlock_unit (u);
	259	return ret;
	260	}
	261
	262	#define FTELL_SUB(kind) \
	263	extern void ftell_i ## kind ## _sub (int , GFC_INTEGER_ ## kind ); \
	264	export_proto(ftell_i ## kind ## _sub); \
	265	void \
	266	ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
	267	{ \
	268	gfc_unit * u = find_unit (*unit); \
	269	if (u == NULL) \
	270	*offset = -1; \
	271	else \
	272	{ \
7812c78c	273	*offset = stell (u->s); \
0dce3ca1 FXC	274	unlock_unit (u); \
	275	} \
	276	}
	277
	278	FTELL_SUB(1)
	279	FTELL_SUB(2)
	280	FTELL_SUB(4)
	281	FTELL_SUB(8)
	282
	283
	284
	285	/* LOGICAL FUNCTION ISATTY(UNIT)
	286	INTEGER, INTENT(IN) :: UNIT */
	287
	288	extern GFC_LOGICAL_4 isatty_l4 (int *);
	289	export_proto(isatty_l4);
	290
	291	GFC_LOGICAL_4
	292	isatty_l4 (int *unit)
	293	{
	294	gfc_unit *u;
	295	GFC_LOGICAL_4 ret = 0;
	296
	297	u = find_unit (*unit);
	298	if (u != NULL)
	299	{
	300	ret = (GFC_LOGICAL_4) stream_isatty (u->s);
	301	unlock_unit (u);
	302	}
	303	return ret;
	304	}
	305
	306
	307	extern GFC_LOGICAL_8 isatty_l8 (int *);
	308	export_proto(isatty_l8);
	309
	310	GFC_LOGICAL_8
	311	isatty_l8 (int *unit)
	312	{
	313	gfc_unit *u;
	314	GFC_LOGICAL_8 ret = 0;
	315
	316	u = find_unit (*unit);
	317	if (u != NULL)
	318	{
	319	ret = (GFC_LOGICAL_8) stream_isatty (u->s);
	320	unlock_unit (u);
	321	}
	322	return ret;
	323	}
	324
	325
	326	/* SUBROUTINE TTYNAM(UNIT,NAME)
	327	INTEGER,SCALAR,INTENT(IN) :: UNIT
	328	CHARACTER,SCALAR,INTENT(OUT) :: NAME */
	329
	330	extern void ttynam_sub (int , char , gfc_charlen_type);
	331	export_proto(ttynam_sub);
	332
	333	void
	334	ttynam_sub (int unit, char name, gfc_charlen_type name_len)
	335	{
	336	gfc_unit *u;
	337	char * n;
338	int i;
339
340	memset (name, ' ', name_len);
341	u = find_unit (*unit);
342	if (u != NULL)
343	{
344	n = stream_ttyname (u->s);
345	if (n != NULL)
346	{
347	i = 0;
348	while (*n && i < name_len)
349	name[i++] = *(n++);
350	}
351	unlock_unit (u);
352	}
353	}
354
355
356	extern void ttynam (char *, gfc_charlen_type , int);
357	export_proto(ttynam);
358
359	void
360	ttynam (char ** name, gfc_charlen_type * name_len, int unit)
361	{
362	gfc_unit *u;
363
364	u = find_unit (unit);
365	if (u != NULL)
366	{
367	*name = stream_ttyname (u->s);
368	if (*name != NULL)
369	{
370	name_len = strlen (name);
371	name = strdup (name);
372	unlock_unit (u);
373	return;
374	}
375	unlock_unit (u);
376	}
377
378	*name_len = 0;
379	*name = NULL;
380	}