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

/* Implementation of the FGET, FGETC, FPUT, FPUTC, FLUSH 
   FTELL, TTYNAM and ISATTY intrinsics.
   Copyright (C) 2005, 2007 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 2 of the License, 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, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#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;
  size_t s;
  gfc_unit * u = find_unit (*unit);

  if (u == NULL)
    return -1;

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

  if (ret != 0)
    return ret;

  if (s != 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)))
{
  size_t s;
  int ret;
  gfc_unit * u = find_unit (*unit);

  if (u == NULL)
    return -1;

  s = 1;
  ret = swrite (u->s, c, &s);
  unlock_unit (u);
  return ret;
}


#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)
	{
	  flush (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)
	{
	  flush (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);
  try result = FAILURE;

  if (u != NULL && is_seekable(u->s))
    {
      if (*whence == 0)
        result = sseek(u->s, *offset);                       /* SEEK_SET */
      else if (*whence == 1)
        result = sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */
      else if (*whence == 2)
        result = sseek(u->s, file_length(u->s) + *offset);   /* SEEK_END */

      unlock_unit (u);
    }

  if (status)
    *status = (result == FAILURE ? -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) stream_offset (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 = stream_offset (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
	2	FTELL, TTYNAM and ISATTY intrinsics.
	3	Copyright (C) 2005, 2007 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
	10	version 2 of the License, or (at your option) any later version.
	11
	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
	20
	21	Libgfortran is distributed in the hope that it will be useful,
	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	24	GNU General Public License for more details.
	25
	26	You should have received a copy of the GNU General Public
	27	License along with libgfortran; see the file COPYING. If not,
	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	29	Boston, MA 02110-1301, USA. */
	30
36ae8a61	31	#include "io.h"
5d723e54	32
0dce3ca1 FXC	33	#ifdef HAVE_STDLIB_H
	34	#include <stdlib.h>
	35	#endif
	36
5d723e54 FXC	37	#include <string.h>
5d723e54 FXC	38
5d723e54 FXC	39	static const int five = 5;
	40	static const int six = 6;
	41
	42	extern int PREFIX(fgetc) (const int , char , gfc_charlen_type);
	43	export_proto_np(PREFIX(fgetc));
	44
	45	int
	46	PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
	47	{
	48	int ret;
	49	size_t s;
	50	gfc_unit * u = find_unit (*unit);
	51
	52	if (u == NULL)
	53	return -1;
	54
	55	s = 1;
	56	memset (c, ' ', c_len);
	57	ret = sread (u->s, c, &s);
401cd90a	58	unlock_unit (u);
5d723e54 FXC	59
	60	if (ret != 0)
	61	return ret;
	62
	63	if (s != 1)
	64	return -1;
	65	else
	66	return 0;
	67	}
	68
	69
	70	#define FGETC_SUB(kind) \
	71	extern void fgetc_i ## kind ## _sub \
	72	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	73	export_proto(fgetc_i ## kind ## _sub); \
	74	void fgetc_i ## kind ## _sub \
	75	(const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	76	{ if (st != NULL) \
	77	*st = PREFIX(fgetc) (unit, c, c_len); \
	78	else \
	79	PREFIX(fgetc) (unit, c, c_len); }
	80
	81	FGETC_SUB(1)
	82	FGETC_SUB(2)
	83	FGETC_SUB(4)
	84	FGETC_SUB(8)
	85
	86
	87	extern int PREFIX(fget) (char *, gfc_charlen_type);
	88	export_proto_np(PREFIX(fget));
	89
	90	int
	91	PREFIX(fget) (char * c, gfc_charlen_type c_len)
	92	{
	93	return PREFIX(fgetc) (&five, c, c_len);
	94	}
	95
	96
	97	#define FGET_SUB(kind) \
	98	extern void fget_i ## kind ## _sub \
	99	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	100	export_proto(fget_i ## kind ## _sub); \
	101	void fget_i ## kind ## _sub \
	102	(char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	103	{ if (st != NULL) \
	104	*st = PREFIX(fgetc) (&five, c, c_len); \
	105	else \
	106	PREFIX(fgetc) (&five, c, c_len); }
	107
	108	FGET_SUB(1)
	109	FGET_SUB(2)
	110	FGET_SUB(4)
	111	FGET_SUB(8)
	112
	113
	114
	115	extern int PREFIX(fputc) (const int , char , gfc_charlen_type);
	116	export_proto_np(PREFIX(fputc));
	117
	118	int
	119	PREFIX(fputc) (const int * unit, char * c,
	120	gfc_charlen_type c_len __attribute__((unused)))
	121	{
	122	size_t s;
401cd90a	123	int ret;
5d723e54 FXC	124	gfc_unit * u = find_unit (*unit);
	125
	126	if (u == NULL)
	127	return -1;
	128
	129	s = 1;
401cd90a JJ	130	ret = swrite (u->s, c, &s);
	131	unlock_unit (u);
	132	return ret;
5d723e54 FXC	133	}
	134
	135
	136	#define FPUTC_SUB(kind) \
	137	extern void fputc_i ## kind ## _sub \
	138	(const int , char , GFC_INTEGER_ ## kind *, gfc_charlen_type); \
	139	export_proto(fputc_i ## kind ## _sub); \
	140	void fputc_i ## kind ## _sub \
	141	(const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	142	{ if (st != NULL) \
	143	*st = PREFIX(fputc) (unit, c, c_len); \
	144	else \
	145	PREFIX(fputc) (unit, c, c_len); }
	146
	147	FPUTC_SUB(1)
	148	FPUTC_SUB(2)
	149	FPUTC_SUB(4)
	150	FPUTC_SUB(8)
	151
	152
	153	extern int PREFIX(fput) (char *, gfc_charlen_type);
	154	export_proto_np(PREFIX(fput));
	155
	156	int
	157	PREFIX(fput) (char * c, gfc_charlen_type c_len)
	158	{
	159	return PREFIX(fputc) (&six, c, c_len);
	160	}
	161
	162
	163	#define FPUT_SUB(kind) \
	164	extern void fput_i ## kind ## _sub \
	165	(char , GFC_INTEGER_ ## kind , gfc_charlen_type); \
	166	export_proto(fput_i ## kind ## _sub); \
	167	void fput_i ## kind ## _sub \
	168	(char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
	169	{ if (st != NULL) \
	170	*st = PREFIX(fputc) (&six, c, c_len); \
	171	else \
	172	PREFIX(fputc) (&six, c, c_len); }
	173
	174	FPUT_SUB(1)
	175	FPUT_SUB(2)
	176	FPUT_SUB(4)
	177	FPUT_SUB(8)
	178
0dce3ca1 FXC	179
	180	/* SUBROUTINE FLUSH(UNIT)
	181	INTEGER, INTENT(IN), OPTIONAL :: UNIT */
	182
	183	extern void flush_i4 (GFC_INTEGER_4 *);
	184	export_proto(flush_i4);
	185
	186	void
	187	flush_i4 (GFC_INTEGER_4 *unit)
	188	{
	189	gfc_unit *us;
	190
	191	/* flush all streams */
	192	if (unit == NULL)
	193	flush_all_units ();
	194	else
	195	{
	196	us = find_unit (*unit);
	197	if (us != NULL)
	198	{
	199	flush (us->s);
	200	unlock_unit (us);
	201	}
	202	}
	203	}
	204
	205
	206	extern void flush_i8 (GFC_INTEGER_8 *);
	207	export_proto(flush_i8);
	208
	209	void
	210	flush_i8 (GFC_INTEGER_8 *unit)
	211	{
	212	gfc_unit *us;
	213
	214	/* flush all streams */
	215	if (unit == NULL)
	216	flush_all_units ();
	217	else
	218	{
	219	us = find_unit (*unit);
	220	if (us != NULL)
	221	{
	222	flush (us->s);
	223	unlock_unit (us);
	224	}
	225	}
	226	}
	227
dcdc26df DF	228	/* FSEEK intrinsic */
	229
	230	extern void fseek_sub (int , GFC_IO_INT , int , int );
	231	export_proto(fseek_sub);
	232
	233	void
	234	fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
	235	{
	236	gfc_unit * u = find_unit (*unit);
	237	try result = FAILURE;
	238
	239	if (u != NULL && is_seekable(u->s))
	240	{
	241	if (*whence == 0)
	242	result = sseek(u->s, offset); / SEEK_SET */
	243	else if (*whence == 1)
	244	result = sseek(u->s, file_position(u->s) + offset); / SEEK_CUR */
	245	else if (*whence == 2)
	246	result = sseek(u->s, file_length(u->s) + offset); / SEEK_END */
	247
	248	unlock_unit (u);
	249	}
	250
	251	if (status)
	252	*status = (result == FAILURE ? -1 : 0);
	253	}
	254
	255
0dce3ca1 FXC	256
	257	/* FTELL intrinsic */
	258
	259	extern size_t PREFIX(ftell) (int *);
	260	export_proto_np(PREFIX(ftell));
	261
	262	size_t
	263	PREFIX(ftell) (int * unit)
	264	{
	265	gfc_unit * u = find_unit (*unit);
	266	size_t ret;
	267	if (u == NULL)
	268	return ((size_t) -1);
	269	ret = (size_t) stream_offset (u->s);
	270	unlock_unit (u);
	271	return ret;
	272	}
	273
	274	#define FTELL_SUB(kind) \
	275	extern void ftell_i ## kind ## _sub (int , GFC_INTEGER_ ## kind ); \
	276	export_proto(ftell_i ## kind ## _sub); \
	277	void \
	278	ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
	279	{ \
	280	gfc_unit * u = find_unit (*unit); \
	281	if (u == NULL) \
	282	*offset = -1; \
	283	else \
	284	{ \
	285	*offset = stream_offset (u->s); \
	286	unlock_unit (u); \
	287	} \
	288	}
	289
	290	FTELL_SUB(1)
	291	FTELL_SUB(2)
	292	FTELL_SUB(4)
	293	FTELL_SUB(8)
	294
	295
	296
	297	/* LOGICAL FUNCTION ISATTY(UNIT)
	298	INTEGER, INTENT(IN) :: UNIT */
	299
	300	extern GFC_LOGICAL_4 isatty_l4 (int *);
	301	export_proto(isatty_l4);
	302
	303	GFC_LOGICAL_4
	304	isatty_l4 (int *unit)
	305	{
	306	gfc_unit *u;
	307	GFC_LOGICAL_4 ret = 0;
	308
	309	u = find_unit (*unit);
	310	if (u != NULL)
	311	{
	312	ret = (GFC_LOGICAL_4) stream_isatty (u->s);
	313	unlock_unit (u);
	314	}
	315	return ret;
	316	}
	317
	318
	319	extern GFC_LOGICAL_8 isatty_l8 (int *);
320	export_proto(isatty_l8);
321
322	GFC_LOGICAL_8
323	isatty_l8 (int *unit)
324	{
325	gfc_unit *u;
326	GFC_LOGICAL_8 ret = 0;
327
328	u = find_unit (*unit);
329	if (u != NULL)
330	{
331	ret = (GFC_LOGICAL_8) stream_isatty (u->s);
332	unlock_unit (u);
333	}
334	return ret;
335	}
336
337
338	/* SUBROUTINE TTYNAM(UNIT,NAME)
339	INTEGER,SCALAR,INTENT(IN) :: UNIT
340	CHARACTER,SCALAR,INTENT(OUT) :: NAME */
341
342	extern void ttynam_sub (int , char , gfc_charlen_type);
343	export_proto(ttynam_sub);
344
345	void
346	ttynam_sub (int unit, char name, gfc_charlen_type name_len)
347	{
348	gfc_unit *u;
349	char * n;
350	int i;
351
352	memset (name, ' ', name_len);
353	u = find_unit (*unit);
354	if (u != NULL)
355	{
356	n = stream_ttyname (u->s);
357	if (n != NULL)
358	{
359	i = 0;
360	while (*n && i < name_len)
361	name[i++] = *(n++);
362	}
363	unlock_unit (u);
364	}
365	}
366
367
368	extern void ttynam (char *, gfc_charlen_type , int);
369	export_proto(ttynam);
370
371	void
372	ttynam (char ** name, gfc_charlen_type * name_len, int unit)
373	{
374	gfc_unit *u;
375
376	u = find_unit (unit);
377	if (u != NULL)
378	{
379	*name = stream_ttyname (u->s);
380	if (*name != NULL)
381	{
382	name_len = strlen (name);
383	name = strdup (name);
384	unlock_unit (u);
385	return;
386	}
387	unlock_unit (u);
388	}
389
390	*name_len = 0;
391	*name = NULL;
392	}