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

/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
   Contributed by Andy Vaught

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, 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, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */


/* Implement the non-IOLENGTH variant of the INQUIRY statement */

#include "config.h"
#include "libgfortran.h"
#include "io.h"


static char undefined[] = "UNDEFINED";


/* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */

static void
inquire_via_unit (gfc_unit * u)
{
  const char *p;

  if (ioparm.exist != NULL)
  {
    if (ioparm.unit >= 0)
      *ioparm.exist = 1;
    else
      *ioparm.exist = 0;
  }

  if (ioparm.opened != NULL)
    *ioparm.opened = (u != NULL);

  if (ioparm.number != NULL)
    *ioparm.number = (u != NULL) ? u->unit_number : -1;

  if (ioparm.named != NULL)
    *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);

  if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
    fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);

  if (ioparm.access != NULL)
    {
      if (u == NULL)
	p = undefined;
      else
	switch (u->flags.access)
	  {
	  case ACCESS_SEQUENTIAL:
	    p = "SEQUENTIAL";
	    break;
	  case ACCESS_DIRECT:
	    p = "DIRECT";
	    break;
	  default:
	    internal_error ("inquire_via_unit(): Bad access");
	  }

      cf_strcpy (ioparm.access, ioparm.access_len, p);
    }

  if (ioparm.sequential != NULL)
    {
      /* disallow an open direct access file to be accessed
         sequentially */
      if (u->flags.access==ACCESS_DIRECT)
        p = "NO";
      else   
        p = (u == NULL) ? inquire_sequential (NULL, 0) :
        inquire_sequential (u->file, u->file_len);

      cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
    }

  if (ioparm.direct != NULL)
    {
      p = (u == NULL) ? inquire_direct (NULL, 0) :
	inquire_direct (u->file, u->file_len);

      cf_strcpy (ioparm.direct, ioparm.direct_len, p);
    }

  if (ioparm.form != NULL)
    {
      if (u == NULL)
	p = undefined;
      else
	switch (u->flags.form)
	  {
	  case FORM_FORMATTED:
	    p = "FORMATTED";
	    break;
	  case FORM_UNFORMATTED:
	    p = "UNFORMATTED";
	    break;
	  default:
	    internal_error ("inquire_via_unit(): Bad form");
	  }

      cf_strcpy (ioparm.form, ioparm.form_len, p);
    }

  if (ioparm.formatted != NULL)
    {
      p = (u == NULL) ? inquire_formatted (NULL, 0) :
	inquire_formatted (u->file, u->file_len);

      cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
    }

  if (ioparm.unformatted != NULL)
    {
      p = (u == NULL) ? inquire_unformatted (NULL, 0) :
	inquire_unformatted (u->file, u->file_len);

      cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
    }

  if (ioparm.recl_out != NULL)
    *ioparm.recl_out = (u != NULL) ? u->recl : 0;

  if (ioparm.nextrec != NULL)
    *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;

  if (ioparm.blank != NULL)
    {
      if (u == NULL)
	p = undefined;
      else
	switch (u->flags.blank)
	  {
	  case BLANK_NULL:
          p = "NULL";
	    break;
	  case BLANK_ZERO:
	    p = "ZERO";
	    break;
	  default:
	    internal_error ("inquire_via_unit(): Bad blank");
	  }

      cf_strcpy (ioparm.blank, ioparm.blank_len, p);
    }

  if (ioparm.position != NULL)
    {
      if (u == NULL || u->flags.access == ACCESS_DIRECT)
        p = undefined;
      else
        switch (u->flags.position)
          {
             case POSITION_REWIND:
               p = "REWIND";
               break;
             case POSITION_APPEND:
               p = "APPEND";
               break;
             case POSITION_ASIS:
               p = "ASIS";
               break;
             default:
               /* if not direct access, it must be
                  either REWIND, APPEND, or ASIS.
                  ASIS seems to be the best default */
               p = "ASIS";
               break;
          }
      cf_strcpy (ioparm.position, ioparm.position_len, p);
    }

  if (ioparm.action != NULL)
    {
      if (u == NULL)
	p = undefined;
      else
	switch (u->flags.action)
	  {
	  case ACTION_READ:
	    p = "READ";
	    break;
	  case ACTION_WRITE:
	    p = "WRITE";
	    break;
	  case ACTION_READWRITE:
	    p = "READWRITE";
	    break;
	  default:
	    internal_error ("inquire_via_unit(): Bad action");
	  }

      cf_strcpy (ioparm.action, ioparm.action_len, p);
    }

  if (ioparm.read != NULL)
    {
      p = (u == NULL) ? inquire_read (NULL, 0) :
	inquire_read (u->file, u->file_len);

      cf_strcpy (ioparm.read, ioparm.read_len, p);
    }

  if (ioparm.write != NULL)
    {
      p = (u == NULL) ? inquire_write (NULL, 0) :
	inquire_write (u->file, u->file_len);

      cf_strcpy (ioparm.write, ioparm.write_len, p);
    }

  if (ioparm.readwrite != NULL)
    {
      p = (u == NULL) ? inquire_readwrite (NULL, 0) :
	inquire_readwrite (u->file, u->file_len);

      cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
    }

  if (ioparm.delim != NULL)
    {
      if (u == NULL || u->flags.form != FORM_FORMATTED)
	p = undefined;
      else
	switch (u->flags.delim)
	  {
	  case DELIM_NONE:
	    p = "NONE";
	    break;
	  case DELIM_QUOTE:
	    p = "QUOTE";
	    break;
	  case DELIM_APOSTROPHE:
	    p = "APOSTROPHE";
	    break;
	  default:
	    internal_error ("inquire_via_unit(): Bad delim");
	  }

      cf_strcpy (ioparm.delim, ioparm.delim_len, p);
    }

  if (ioparm.pad != NULL)
    {
      if (u == NULL || u->flags.form != FORM_FORMATTED)
	p = undefined;
      else
	switch (u->flags.pad)
	  {
	  case PAD_NO:
	    p = "NO";
	    break;
	  case PAD_YES:
	    p = "YES";
	    break;
	  default:
	    internal_error ("inquire_via_unit(): Bad pad");
	  }

      cf_strcpy (ioparm.pad, ioparm.pad_len, p);
    }
}


/* inquire_via_filename()-- Inquiry via filename.  This subroutine is
 * only used if the filename is *not* connected to a unit number. */

static void
inquire_via_filename (void)
{
  const char *p;

  if (ioparm.exist != NULL)
    *ioparm.exist = file_exists ();

  if (ioparm.opened != NULL)
    *ioparm.opened = 0;

  if (ioparm.number != NULL)
    *ioparm.number = -1;

  if (ioparm.named != NULL)
    *ioparm.named = 1;

  if (ioparm.name != NULL)
    fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);

  if (ioparm.access != NULL)
    cf_strcpy (ioparm.access, ioparm.access_len, undefined);

  if (ioparm.sequential != NULL)
    {
      p = inquire_sequential (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
    }

  if (ioparm.direct != NULL)
    {
      p = inquire_direct (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.direct, ioparm.direct_len, p);
    }

  if (ioparm.form != NULL)
    cf_strcpy (ioparm.form, ioparm.form_len, undefined);

  if (ioparm.formatted != NULL)
    {
      p = inquire_formatted (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
    }

  if (ioparm.unformatted != NULL)
    {
      p = inquire_unformatted (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
    }

  if (ioparm.recl_out != NULL)
    *ioparm.recl_out = 0;

  if (ioparm.nextrec != NULL)
    *ioparm.nextrec = 0;

  if (ioparm.blank != NULL)
    cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);

  if (ioparm.position != NULL)
    cf_strcpy (ioparm.position, ioparm.position_len, undefined);

  if (ioparm.access != NULL)
    cf_strcpy (ioparm.access, ioparm.access_len, undefined);

  if (ioparm.read != NULL)
    {
      p = inquire_read (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.read, ioparm.read_len, p);
    }

  if (ioparm.write != NULL)
    {
      p = inquire_write (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.write, ioparm.write_len, p);
    }

  if (ioparm.readwrite != NULL)
    {
      p = inquire_read (ioparm.file, ioparm.file_len);
      cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
    }

  if (ioparm.delim != NULL)
    cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);

  if (ioparm.pad != NULL)
    cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);

}


/* Library entry point for the INQUIRE statement (non-IOLENGTH
   form).  */

extern void st_inquire (void);
export_proto(st_inquire);

void
st_inquire (void)
{
  gfc_unit *u;

  library_start ();

  if (ioparm.file == NULL)
    inquire_via_unit (find_unit (ioparm.unit));
  else
    {
      u = find_file ();
      if (u == NULL)
	inquire_via_filename ();
      else
	inquire_via_unit (u);
    }

  library_end ();
}
Commit	Line	Data
4ee9c684	1	/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
	2	Contributed by Andy Vaught
	3
	4	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	5
	6	Libgfortran is free software; you can redistribute it and/or modify
	7	it under the terms of the GNU General Public License as published by
	8	the Free Software Foundation; either version 2, or (at your option)
	9	any later version.
	10
b417ea8c	11	In addition to the permissions in the GNU General Public License, the
	12	Free Software Foundation gives you unlimited permission to link the
	13	compiled version of this file into combinations with other programs,
	14	and to distribute those combinations without any restriction coming
	15	from the use of this file. (The General Public License restrictions
	16	do apply in other respects; for example, they cover modification of
	17	the file, and distribution when not linked into a combine
	18	executable.)
	19
4ee9c684	20	Libgfortran is distributed in the hope that it will be useful,
	21	but WITHOUT ANY WARRANTY; without even the implied warranty of
	22	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	23	GNU General Public License for more details.
	24
	25	You should have received a copy of the GNU General Public License
	26	along with Libgfortran; see the file COPYING. If not, write to
	27	the Free Software Foundation, 59 Temple Place - Suite 330,
	28	Boston, MA 02111-1307, USA. */
	29
	30
	31	/* Implement the non-IOLENGTH variant of the INQUIRY statement */
	32
	33	#include "config.h"
	34	#include "libgfortran.h"
	35	#include "io.h"
	36
	37
	38	static char undefined[] = "UNDEFINED";
	39
	40
	41	/* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
	42
	43	static void
f02dd226	44	inquire_via_unit (gfc_unit * u)
4ee9c684	45	{
	46	const char *p;
	47
	48	if (ioparm.exist != NULL)
78e910ee	49	{
	50	if (ioparm.unit >= 0)
	51	*ioparm.exist = 1;
	52	else
	53	*ioparm.exist = 0;
	54	}
4ee9c684	55
	56	if (ioparm.opened != NULL)
	57	*ioparm.opened = (u != NULL);
	58
	59	if (ioparm.number != NULL)
	60	*ioparm.number = (u != NULL) ? u->unit_number : -1;
	61
	62	if (ioparm.named != NULL)
	63	*ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
	64
	65	if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
	66	fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
	67
	68	if (ioparm.access != NULL)
	69	{
	70	if (u == NULL)
	71	p = undefined;
	72	else
	73	switch (u->flags.access)
	74	{
	75	case ACCESS_SEQUENTIAL:
	76	p = "SEQUENTIAL";
	77	break;
	78	case ACCESS_DIRECT:
	79	p = "DIRECT";
	80	break;
	81	default:
	82	internal_error ("inquire_via_unit(): Bad access");
	83	}
	84
	85	cf_strcpy (ioparm.access, ioparm.access_len, p);
	86	}
	87
	88	if (ioparm.sequential != NULL)
	89	{
b0ef000d	90	/* disallow an open direct access file to be accessed
	91	sequentially */
	92	if (u->flags.access==ACCESS_DIRECT)
	93	p = "NO";
	94	else
	95	p = (u == NULL) ? inquire_sequential (NULL, 0) :
	96	inquire_sequential (u->file, u->file_len);
4ee9c684	97
	98	cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
	99	}
	100
	101	if (ioparm.direct != NULL)
	102	{
	103	p = (u == NULL) ? inquire_direct (NULL, 0) :
	104	inquire_direct (u->file, u->file_len);
	105
	106	cf_strcpy (ioparm.direct, ioparm.direct_len, p);
	107	}
	108
	109	if (ioparm.form != NULL)
	110	{
	111	if (u == NULL)
	112	p = undefined;
	113	else
	114	switch (u->flags.form)
	115	{
	116	case FORM_FORMATTED:
	117	p = "FORMATTED";
	118	break;
	119	case FORM_UNFORMATTED:
	120	p = "UNFORMATTED";
	121	break;
	122	default:
	123	internal_error ("inquire_via_unit(): Bad form");
	124	}
	125
	126	cf_strcpy (ioparm.form, ioparm.form_len, p);
	127	}
	128
	129	if (ioparm.formatted != NULL)
	130	{
	131	p = (u == NULL) ? inquire_formatted (NULL, 0) :
	132	inquire_formatted (u->file, u->file_len);
	133
	134	cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
	135	}
	136
	137	if (ioparm.unformatted != NULL)
	138	{
	139	p = (u == NULL) ? inquire_unformatted (NULL, 0) :
	140	inquire_unformatted (u->file, u->file_len);
	141
	142	cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
	143	}
	144
	145	if (ioparm.recl_out != NULL)
	146	*ioparm.recl_out = (u != NULL) ? u->recl : 0;
	147
	148	if (ioparm.nextrec != NULL)
	149	*ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
	150
	151	if (ioparm.blank != NULL)
	152	{
	153	if (u == NULL)
	154	p = undefined;
	155	else
	156	switch (u->flags.blank)
	157	{
	158	case BLANK_NULL:
	159	p = "NULL";
	160	break;
161	case BLANK_ZERO:
162	p = "ZERO";
163	break;
164	default:
165	internal_error ("inquire_via_unit(): Bad blank");
166	}
167
168	cf_strcpy (ioparm.blank, ioparm.blank_len, p);
169	}
170
171	if (ioparm.position != NULL)
172	{
173	if (u == NULL \|\| u->flags.access == ACCESS_DIRECT)
b3b0377b	174	p = undefined;
4ee9c684	175	else
b3b0377b	176	switch (u->flags.position)
	177	{
	178	case POSITION_REWIND:
	179	p = "REWIND";
	180	break;
	181	case POSITION_APPEND:
	182	p = "APPEND";
	183	break;
	184	case POSITION_ASIS:
	185	p = "ASIS";
	186	break;
	187	default:
	188	/* if not direct access, it must be
	189	either REWIND, APPEND, or ASIS.
	190	ASIS seems to be the best default */
	191	p = "ASIS";
	192	break;
	193	}
	194	cf_strcpy (ioparm.position, ioparm.position_len, p);
4ee9c684	195	}
	196
	197	if (ioparm.action != NULL)
	198	{
	199	if (u == NULL)
	200	p = undefined;
	201	else
	202	switch (u->flags.action)
	203	{
	204	case ACTION_READ:
	205	p = "READ";
	206	break;
	207	case ACTION_WRITE:
	208	p = "WRITE";
	209	break;
	210	case ACTION_READWRITE:
	211	p = "READWRITE";
	212	break;
	213	default:
	214	internal_error ("inquire_via_unit(): Bad action");
	215	}
	216
	217	cf_strcpy (ioparm.action, ioparm.action_len, p);
	218	}
	219
	220	if (ioparm.read != NULL)
	221	{
	222	p = (u == NULL) ? inquire_read (NULL, 0) :
	223	inquire_read (u->file, u->file_len);
	224
	225	cf_strcpy (ioparm.read, ioparm.read_len, p);
	226	}
	227
	228	if (ioparm.write != NULL)
	229	{
	230	p = (u == NULL) ? inquire_write (NULL, 0) :
	231	inquire_write (u->file, u->file_len);
	232
	233	cf_strcpy (ioparm.write, ioparm.write_len, p);
	234	}
	235
	236	if (ioparm.readwrite != NULL)
	237	{
	238	p = (u == NULL) ? inquire_readwrite (NULL, 0) :
	239	inquire_readwrite (u->file, u->file_len);
	240
	241	cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
	242	}
	243
	244	if (ioparm.delim != NULL)
	245	{
	246	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	247	p = undefined;
	248	else
	249	switch (u->flags.delim)
	250	{
	251	case DELIM_NONE:
	252	p = "NONE";
	253	break;
	254	case DELIM_QUOTE:
	255	p = "QUOTE";
	256	break;
	257	case DELIM_APOSTROPHE:
	258	p = "APOSTROPHE";
259	break;
260	default:
261	internal_error ("inquire_via_unit(): Bad delim");
262	}
263
05876242	264	cf_strcpy (ioparm.delim, ioparm.delim_len, p);
4ee9c684	265	}
	266
	267	if (ioparm.pad != NULL)
	268	{
	269	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	270	p = undefined;
	271	else
	272	switch (u->flags.pad)
	273	{
	274	case PAD_NO:
	275	p = "NO";
	276	break;
	277	case PAD_YES:
	278	p = "YES";
	279	break;
	280	default:
	281	internal_error ("inquire_via_unit(): Bad pad");
	282	}
	283
	284	cf_strcpy (ioparm.pad, ioparm.pad_len, p);
	285	}
	286	}
	287
	288
	289	/* inquire_via_filename()-- Inquiry via filename. This subroutine is
	290	* only used if the filename is not connected to a unit number. */
	291
	292	static void
	293	inquire_via_filename (void)
	294	{
	295	const char *p;
	296
	297	if (ioparm.exist != NULL)
	298	*ioparm.exist = file_exists ();
	299
	300	if (ioparm.opened != NULL)
	301	*ioparm.opened = 0;
	302
	303	if (ioparm.number != NULL)
	304	*ioparm.number = -1;
	305
	306	if (ioparm.named != NULL)
	307	*ioparm.named = 1;
	308
	309	if (ioparm.name != NULL)
	310	fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
	311
	312	if (ioparm.access != NULL)
	313	cf_strcpy (ioparm.access, ioparm.access_len, undefined);
	314
	315	if (ioparm.sequential != NULL)
	316	{
	317	p = inquire_sequential (ioparm.file, ioparm.file_len);
	318	cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
	319	}
	320
	321	if (ioparm.direct != NULL)
	322	{
	323	p = inquire_direct (ioparm.file, ioparm.file_len);
	324	cf_strcpy (ioparm.direct, ioparm.direct_len, p);
	325	}
	326
	327	if (ioparm.form != NULL)
	328	cf_strcpy (ioparm.form, ioparm.form_len, undefined);
329
330	if (ioparm.formatted != NULL)
331	{
332	p = inquire_formatted (ioparm.file, ioparm.file_len);
333	cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
334	}
335
336	if (ioparm.unformatted != NULL)
337	{
338	p = inquire_unformatted (ioparm.file, ioparm.file_len);
339	cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
340	}
341
342	if (ioparm.recl_out != NULL)
343	*ioparm.recl_out = 0;
344
345	if (ioparm.nextrec != NULL)
346	*ioparm.nextrec = 0;
347
348	if (ioparm.blank != NULL)
349	cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
350
351	if (ioparm.position != NULL)
352	cf_strcpy (ioparm.position, ioparm.position_len, undefined);
353
354	if (ioparm.access != NULL)
355	cf_strcpy (ioparm.access, ioparm.access_len, undefined);
356
357	if (ioparm.read != NULL)
358	{
359	p = inquire_read (ioparm.file, ioparm.file_len);
360	cf_strcpy (ioparm.read, ioparm.read_len, p);
361	}
362
363	if (ioparm.write != NULL)
364	{
365	p = inquire_write (ioparm.file, ioparm.file_len);
366	cf_strcpy (ioparm.write, ioparm.write_len, p);
367	}
368
369	if (ioparm.readwrite != NULL)
370	{
371	p = inquire_read (ioparm.file, ioparm.file_len);
372	cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
373	}
374
375	if (ioparm.delim != NULL)
376	cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
377
378	if (ioparm.pad != NULL)
379	cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
380
381	}
382
383
6799e2f8	384	/* Library entry point for the INQUIRE statement (non-IOLENGTH
6799e2f8	385	form). */
4ee9c684	386
7b6cb5bd	387	extern void st_inquire (void);
	388	export_proto(st_inquire);
	389
4ee9c684	390	void
	391	st_inquire (void)
	392	{
f02dd226	393	gfc_unit *u;
4ee9c684	394
	395	library_start ();
	396
	397	if (ioparm.file == NULL)
	398	inquire_via_unit (find_unit (ioparm.unit));
	399	else
	400	{
	401	u = find_file ();
	402	if (u == NULL)
	403	inquire_via_filename ();
	404	else
	405	inquire_via_unit (u);
	406	}
	407
	408	library_end ();
	409	}