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

/* Copyright (C) 2002, 2003, 2005, 2007, 2009 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 3, 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/>.  */


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

#include "io.h"


static const char undefined[] = "UNDEFINED";


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

static void
inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
{
  const char *p;
  GFC_INTEGER_4 cf = iqp->common.flags;

  if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
    {
      *iqp->exist = (iqp->common.unit >= 0
		     && iqp->common.unit <= GFC_INTEGER_4_HUGE);

      if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0)
	{
	  if (!(*iqp->exist))
	    *iqp->common.iostat = LIBERROR_BAD_UNIT;
	  *iqp->exist = *iqp->exist
			&& (*iqp->common.iostat != LIBERROR_BAD_UNIT);
	}
    }

  if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
    *iqp->opened = (u != NULL);

  if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
    *iqp->number = (u != NULL) ? u->unit_number : -1;

  if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
    *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);

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

  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
    {
      if (u == NULL)
	p = undefined;
      else
	switch (u->flags.access)
	  {
	  case ACCESS_SEQUENTIAL:
	    p = "SEQUENTIAL";
	    break;
	  case ACCESS_DIRECT:
	    p = "DIRECT";
	    break;
	  case ACCESS_STREAM:
	    p = "STREAM";
	    break;
	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad access");
	  }

      cf_strcpy (iqp->access, iqp->access_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
    {
      if (u == NULL)
	p = inquire_sequential (NULL, 0);
      else
	switch (u->flags.access)
	  {
	  case ACCESS_DIRECT:
	  case ACCESS_STREAM:
	    p = "NO";
	    break;
	  case ACCESS_SEQUENTIAL:
	    p = "YES";
	    break;
	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad access");
	  }

      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
    {
      if (u == NULL)
	p = inquire_direct (NULL, 0);
      else
	switch (u->flags.access)
	  {
	  case ACCESS_SEQUENTIAL:
	  case ACCESS_STREAM:
	    p = "NO";
	    break;
	  case ACCESS_DIRECT:
	    p = "YES";
	    break;
	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad access");
	  }

      cf_strcpy (iqp->direct, iqp->direct_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
    {
      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 (&iqp->common, "inquire_via_unit(): Bad form");
	  }

      cf_strcpy (iqp->form, iqp->form_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
    {
      if (u == NULL)
	p = inquire_formatted (NULL, 0);
      else
	switch (u->flags.form)
	  {
	  case FORM_FORMATTED:
	    p = "YES";
	    break;
	  case FORM_UNFORMATTED:
	    p = "NO";
	    break;
	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad form");
	  }

      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
    {
      if (u == NULL)
	p = inquire_unformatted (NULL, 0);
      else
	switch (u->flags.form)
	  {
	  case FORM_FORMATTED:
	    p = "NO";
	    break;
	  case FORM_UNFORMATTED:
	    p = "YES";
	    break;
	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad form");
	  }

      cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
    *iqp->recl_out = (u != NULL) ? u->recl : 0;

  if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
    *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;

  if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
    {
      /* This only makes sense in the context of DIRECT access.  */
      if (u != NULL && u->flags.access == ACCESS_DIRECT)
	*iqp->nextrec = u->last_record + 1;
      else
	*iqp->nextrec = 0;
    }

  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
    {
      if (u == NULL || u->flags.form != FORM_FORMATTED)
	p = undefined;
      else
	switch (u->flags.blank)
	  {
	  case BLANK_NULL:
	    p = "NULL";
	    break;
	  case BLANK_ZERO:
	    p = "ZERO";
	    break;
	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
	  }

      cf_strcpy (iqp->blank, iqp->blank_len, p);
    }

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

      cf_strcpy (iqp->pad, iqp->pad_len, p);
    }

  if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
    {
      GFC_INTEGER_4 cf2 = iqp->flags2;

      if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
	*iqp->pending = 0;
  
      if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
        *iqp->id = 0;

      if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
	{
	  if (u == NULL || u->flags.form != FORM_FORMATTED)
	    p = undefined;
          else
	    switch (u->flags.encoding)
	      {
	      case ENCODING_DEFAULT:
		p = "UNKNOWN";
		break;
	      case ENCODING_UTF8:
		p = "UTF-8";
		break;
	      default:
		internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
	      }

	  cf_strcpy (iqp->encoding, iqp->encoding_len, p);
	}

      if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
	{
	  if (u == NULL || u->flags.form != FORM_FORMATTED)
	    p = undefined;
	  else
	    switch (u->flags.decimal)
	      {
	      case DECIMAL_POINT:
		p = "POINT";
		break;
	      case DECIMAL_COMMA:
		p = "COMMA";
		break;
	      default:
		internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
	      }

	  cf_strcpy (iqp->decimal, iqp->decimal_len, p);
	}

      if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
	{
	  if (u == NULL)
	    p = undefined;
	  else
	    switch (u->flags.async)
	    {
	      case ASYNC_YES:
		p = "YES";
		break;
	      case ASYNC_NO:
		p = "NO";
		break;
	      default:
		internal_error (&iqp->common, "inquire_via_unit(): Bad async");
	    }

	  cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
	}

      if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
	{
	  if (u == NULL)
	    p = undefined;
	  else
	    switch (u->flags.sign)
	    {
	      case SIGN_PROCDEFINED:
		p = "PROCESSOR_DEFINED";
		break;
	      case SIGN_SUPPRESS:
		p = "SUPPRESS";
		break;
	      case SIGN_PLUS:
		p = "PLUS";
		break;
	      default:
		internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
	    }

	  cf_strcpy (iqp->sign, iqp->sign_len, p);
	}

      if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
	{
	  if (u == NULL)
	    p = undefined;
	  else
	    switch (u->flags.round)
	    {
	      case ROUND_UP:
		p = "UP";
		break;
	      case ROUND_DOWN:
		p = "DOWN";
		break;
	      case ROUND_ZERO:
		p = "ZERO";
		break;
	      case ROUND_NEAREST:
		p = "NEAREST";
		break;
	      case ROUND_COMPATIBLE:
		p = "COMPATIBLE";
		break;
	      case ROUND_PROCDEFINED:
		p = "PROCESSOR_DEFINED";
		break;
	      default:
		internal_error (&iqp->common, "inquire_via_unit(): Bad round");
	    }

	  cf_strcpy (iqp->round, iqp->round_len, p);
	}
    }

  if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
    {
      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 (iqp->position, iqp->position_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
    {
      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 (&iqp->common, "inquire_via_unit(): Bad action");
	  }

      cf_strcpy (iqp->action, iqp->action_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
    {
      p = (u == NULL) ? inquire_read (NULL, 0) :
	inquire_read (u->file, u->file_len);

      cf_strcpy (iqp->read, iqp->read_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
    {
      p = (u == NULL) ? inquire_write (NULL, 0) :
	inquire_write (u->file, u->file_len);

      cf_strcpy (iqp->write, iqp->write_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
    {
      p = (u == NULL) ? inquire_readwrite (NULL, 0) :
	inquire_readwrite (u->file, u->file_len);

      cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
    {
      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 (&iqp->common, "inquire_via_unit(): Bad delim");
	  }

      cf_strcpy (iqp->delim, iqp->delim_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
    {
      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 (&iqp->common, "inquire_via_unit(): Bad pad");
	  }

      cf_strcpy (iqp->pad, iqp->pad_len, p);
    }
 
  if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
    {
      if (u == NULL)
	p = undefined;
      else
	switch (u->flags.convert)
	  {
	    /*  big_endian is 0 for little-endian, 1 for big-endian.  */
	  case GFC_CONVERT_NATIVE:
	    p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
	    break;

	  case GFC_CONVERT_SWAP:
	    p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
	    break;

	  default:
	    internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
	  }

      cf_strcpy (iqp->convert, iqp->convert_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 (st_parameter_inquire *iqp)
{
  const char *p;
  GFC_INTEGER_4 cf = iqp->common.flags;

  if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
    *iqp->exist = file_exists (iqp->file, iqp->file_len);

  if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
    *iqp->opened = 0;

  if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
    *iqp->number = -1;

  if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
    *iqp->named = 1;

  if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
    fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);

  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
    cf_strcpy (iqp->access, iqp->access_len, undefined);

  if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
    {
      p = "UNKNOWN";
      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
    {
      p = "UNKNOWN";
      cf_strcpy (iqp->direct, iqp->direct_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
    cf_strcpy (iqp->form, iqp->form_len, undefined);

  if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
    {
      p = "UNKNOWN";
      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
    {
      p = "UNKNOWN";
      cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
    *iqp->recl_out = 0;

  if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
    *iqp->nextrec = 0;

  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
    cf_strcpy (iqp->blank, iqp->blank_len, undefined);

  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
    cf_strcpy (iqp->pad, iqp->pad_len, undefined);

  if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
    {
      GFC_INTEGER_4 cf2 = iqp->flags2;

      if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
	cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
  
      if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
	cf_strcpy (iqp->delim, iqp->delim_len, undefined);

      if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
	cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);

      if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
	cf_strcpy (iqp->delim, iqp->delim_len, undefined);

      if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
	cf_strcpy (iqp->pad, iqp->pad_len, undefined);
  
      if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
	cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
    }

  if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
    cf_strcpy (iqp->position, iqp->position_len, undefined);

  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
    cf_strcpy (iqp->access, iqp->access_len, undefined);

  if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
    {
      p = inquire_read (iqp->file, iqp->file_len);
      cf_strcpy (iqp->read, iqp->read_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
    {
      p = inquire_write (iqp->file, iqp->file_len);
      cf_strcpy (iqp->write, iqp->write_len, p);
    }

  if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
    {
      p = inquire_read (iqp->file, iqp->file_len);
      cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
    }
}


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

extern void st_inquire (st_parameter_inquire *);
export_proto(st_inquire);

void
st_inquire (st_parameter_inquire *iqp)
{
  gfc_unit *u;

  library_start (&iqp->common);

  if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
    {
      u = find_unit (iqp->common.unit);
      inquire_via_unit (iqp, u);
    }
  else
    {
      u = find_file (iqp->file, iqp->file_len);
      if (u == NULL)
	inquire_via_filename (iqp);
      else
	inquire_via_unit (iqp, u);
    }
  if (u != NULL)
    unlock_unit (u);

  library_end ();
}
Commit	Line	Data
6bc9506f	1	/* Copyright (C) 2002, 2003, 2005, 2007, 2009 Free Software Foundation, Inc.
4ee9c684	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
6bc9506f	8	the Free Software Foundation; either version 3, or (at your option)
4ee9c684	9	any later version.
	10
	11	Libgfortran is distributed in the hope that it will be useful,
	12	but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	GNU General Public License for more details.
	15
6bc9506f	16	Under Section 7 of GPL version 3, you are granted additional
	17	permissions described in the GCC Runtime Library Exception, version
	18	3.1, as published by the Free Software Foundation.
	19
	20	You should have received a copy of the GNU General Public License and
	21	a copy of the GCC Runtime Library Exception along with this program;
	22	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	23	<http://www.gnu.org/licenses/>. */
4ee9c684	24
	25
	26	/* Implement the non-IOLENGTH variant of the INQUIRY statement */
	27
4ee9c684	28	#include "io.h"
	29
	30
fb35179a	31	static const char undefined[] = "UNDEFINED";
4ee9c684	32
	33
	34	/* inquire_via_unit()-- Inquiry via unit number. The unit might not exist. */
	35
	36	static void
60c514ba	37	inquire_via_unit (st_parameter_inquire iqp, gfc_unit u)
4ee9c684	38	{
4ee9c684	39	const char *p;
60c514ba	40	GFC_INTEGER_4 cf = iqp->common.flags;
4ee9c684	41
60c514ba	42	if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
6550bb3d	43	{
	44	*iqp->exist = (iqp->common.unit >= 0
	45	&& iqp->common.unit <= GFC_INTEGER_4_HUGE);
	46
	47	if ((cf & IOPARM_INQUIRE_HAS_FILE) == 0)
	48	{
	49	if (!(*iqp->exist))
	50	*iqp->common.iostat = LIBERROR_BAD_UNIT;
	51	iqp->exist = iqp->exist
	52	&& (*iqp->common.iostat != LIBERROR_BAD_UNIT);
	53	}
	54	}
4ee9c684	55
60c514ba	56	if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
60c514ba	57	*iqp->opened = (u != NULL);
4ee9c684	58
60c514ba	59	if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
60c514ba	60	*iqp->number = (u != NULL) ? u->unit_number : -1;
4ee9c684	61
60c514ba	62	if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
60c514ba	63	*iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
4ee9c684	64
60c514ba	65	if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
	66	&& u != NULL && u->flags.status != STATUS_SCRATCH)
	67	fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
4ee9c684	68
60c514ba	69	if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
4ee9c684	70	{
	71	if (u == NULL)
	72	p = undefined;
	73	else
	74	switch (u->flags.access)
	75	{
	76	case ACCESS_SEQUENTIAL:
	77	p = "SEQUENTIAL";
	78	break;
	79	case ACCESS_DIRECT:
	80	p = "DIRECT";
	81	break;
4d8ee55b	82	case ACCESS_STREAM:
	83	p = "STREAM";
	84	break;
4ee9c684	85	default:
60c514ba	86	internal_error (&iqp->common, "inquire_via_unit(): Bad access");
4ee9c684	87	}
4ee9c684	88
60c514ba	89	cf_strcpy (iqp->access, iqp->access_len, p);
4ee9c684	90	}
4ee9c684	91
60c514ba	92	if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
4ee9c684	93	{
214b69f2	94	if (u == NULL)
	95	p = inquire_sequential (NULL, 0);
	96	else
2e1fa727	97	switch (u->flags.access)
	98	{
	99	case ACCESS_DIRECT:
	100	case ACCESS_STREAM:
	101	p = "NO";
	102	break;
	103	case ACCESS_SEQUENTIAL:
	104	p = "YES";
	105	break;
	106	default:
	107	internal_error (&iqp->common, "inquire_via_unit(): Bad access");
	108	}
4ee9c684	109
60c514ba	110	cf_strcpy (iqp->sequential, iqp->sequential_len, p);
4ee9c684	111	}
4ee9c684	112
60c514ba	113	if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
4ee9c684	114	{
2e1fa727	115	if (u == NULL)
	116	p = inquire_direct (NULL, 0);
	117	else
	118	switch (u->flags.access)
	119	{
	120	case ACCESS_SEQUENTIAL:
	121	case ACCESS_STREAM:
	122	p = "NO";
	123	break;
	124	case ACCESS_DIRECT:
	125	p = "YES";
	126	break;
	127	default:
	128	internal_error (&iqp->common, "inquire_via_unit(): Bad access");
	129	}
4ee9c684	130
60c514ba	131	cf_strcpy (iqp->direct, iqp->direct_len, p);
4ee9c684	132	}
4ee9c684	133
60c514ba	134	if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
4ee9c684	135	{
	136	if (u == NULL)
	137	p = undefined;
	138	else
	139	switch (u->flags.form)
	140	{
	141	case FORM_FORMATTED:
	142	p = "FORMATTED";
	143	break;
	144	case FORM_UNFORMATTED:
	145	p = "UNFORMATTED";
	146	break;
	147	default:
60c514ba	148	internal_error (&iqp->common, "inquire_via_unit(): Bad form");
4ee9c684	149	}
4ee9c684	150
60c514ba	151	cf_strcpy (iqp->form, iqp->form_len, p);
4ee9c684	152	}
4ee9c684	153
60c514ba	154	if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
4ee9c684	155	{
2e1fa727	156	if (u == NULL)
	157	p = inquire_formatted (NULL, 0);
	158	else
	159	switch (u->flags.form)
	160	{
	161	case FORM_FORMATTED:
	162	p = "YES";
	163	break;
	164	case FORM_UNFORMATTED:
	165	p = "NO";
	166	break;
	167	default:
	168	internal_error (&iqp->common, "inquire_via_unit(): Bad form");
	169	}
4ee9c684	170
60c514ba	171	cf_strcpy (iqp->formatted, iqp->formatted_len, p);
4ee9c684	172	}
4ee9c684	173
60c514ba	174	if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
4ee9c684	175	{
2e1fa727	176	if (u == NULL)
	177	p = inquire_unformatted (NULL, 0);
	178	else
	179	switch (u->flags.form)
	180	{
	181	case FORM_FORMATTED:
	182	p = "NO";
	183	break;
	184	case FORM_UNFORMATTED:
	185	p = "YES";
	186	break;
	187	default:
	188	internal_error (&iqp->common, "inquire_via_unit(): Bad form");
	189	}
4ee9c684	190
60c514ba	191	cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
4ee9c684	192	}
4ee9c684	193
60c514ba	194	if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
60c514ba	195	*iqp->recl_out = (u != NULL) ? u->recl : 0;
4ee9c684	196
4d8ee55b	197	if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0)
3c43c91f	198	*iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0;
4d8ee55b	199
60c514ba	200	if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
f4bfed80	201	{
	202	/* This only makes sense in the context of DIRECT access. */
	203	if (u != NULL && u->flags.access == ACCESS_DIRECT)
	204	*iqp->nextrec = u->last_record + 1;
	205	else
	206	*iqp->nextrec = 0;
	207	}
4ee9c684	208
60c514ba	209	if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
4ee9c684	210	{
8e327405	211	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
4ee9c684	212	p = undefined;
	213	else
	214	switch (u->flags.blank)
	215	{
	216	case BLANK_NULL:
60c514ba	217	p = "NULL";
4ee9c684	218	break;
	219	case BLANK_ZERO:
	220	p = "ZERO";
	221	break;
	222	default:
60c514ba	223	internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
4ee9c684	224	}
4ee9c684	225
60c514ba	226	cf_strcpy (iqp->blank, iqp->blank_len, p);
4ee9c684	227	}
4ee9c684	228
8e327405	229	if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
	230	{
	231	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	232	p = undefined;
	233	else
	234	switch (u->flags.pad)
	235	{
	236	case PAD_YES:
	237	p = "YES";
	238	break;
	239	case PAD_NO:
	240	p = "NO";
	241	break;
	242	default:
	243	internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
	244	}
	245
	246	cf_strcpy (iqp->pad, iqp->pad_len, p);
	247	}
	248
0d72fa67	249	if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
8e327405	250	{
b5d015e3	251	GFC_INTEGER_4 cf2 = iqp->flags2;
b5d015e3	252
0d72fa67	253	if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
	254	*iqp->pending = 0;
	255
	256	if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
	257	*iqp->id = 0;
8e327405	258
0d72fa67	259	if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
	260	{
	261	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	262	p = undefined;
	263	else
	264	switch (u->flags.encoding)
	265	{
	266	case ENCODING_DEFAULT:
	267	p = "UNKNOWN";
	268	break;
	269	case ENCODING_UTF8:
	270	p = "UTF-8";
	271	break;
	272	default:
	273	internal_error (&iqp->common, "inquire_via_unit(): Bad encoding");
	274	}
	275
	276	cf_strcpy (iqp->encoding, iqp->encoding_len, p);
	277	}
8e327405	278
0d72fa67	279	if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
	280	{
	281	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	282	p = undefined;
	283	else
	284	switch (u->flags.decimal)
	285	{
	286	case DECIMAL_POINT:
	287	p = "POINT";
	288	break;
	289	case DECIMAL_COMMA:
	290	p = "COMMA";
	291	break;
	292	default:
	293	internal_error (&iqp->common, "inquire_via_unit(): Bad comma");
	294	}
	295
	296	cf_strcpy (iqp->decimal, iqp->decimal_len, p);
	297	}
8e327405	298
0d72fa67	299	if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0)
	300	{
	301	if (u == NULL)
	302	p = undefined;
	303	else
	304	switch (u->flags.async)
	305	{
	306	case ASYNC_YES:
	307	p = "YES";
	308	break;
	309	case ASYNC_NO:
	310	p = "NO";
	311	break;
	312	default:
	313	internal_error (&iqp->common, "inquire_via_unit(): Bad async");
	314	}
	315
	316	cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
	317	}
8e327405	318
0d72fa67	319	if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
	320	{
	321	if (u == NULL)
	322	p = undefined;
	323	else
	324	switch (u->flags.sign)
	325	{
	326	case SIGN_PROCDEFINED:
	327	p = "PROCESSOR_DEFINED";
	328	break;
	329	case SIGN_SUPPRESS:
	330	p = "SUPPRESS";
	331	break;
	332	case SIGN_PLUS:
	333	p = "PLUS";
	334	break;
	335	default:
	336	internal_error (&iqp->common, "inquire_via_unit(): Bad sign");
	337	}
	338
	339	cf_strcpy (iqp->sign, iqp->sign_len, p);
	340	}
8e327405	341
0d72fa67	342	if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0)
	343	{
	344	if (u == NULL)
	345	p = undefined;
	346	else
	347	switch (u->flags.round)
	348	{
	349	case ROUND_UP:
	350	p = "UP";
	351	break;
	352	case ROUND_DOWN:
	353	p = "DOWN";
	354	break;
	355	case ROUND_ZERO:
	356	p = "ZERO";
	357	break;
	358	case ROUND_NEAREST:
	359	p = "NEAREST";
	360	break;
	361	case ROUND_COMPATIBLE:
	362	p = "COMPATIBLE";
	363	break;
	364	case ROUND_PROCDEFINED:
	365	p = "PROCESSOR_DEFINED";
	366	break;
	367	default:
	368	internal_error (&iqp->common, "inquire_via_unit(): Bad round");
	369	}
	370
	371	cf_strcpy (iqp->round, iqp->round_len, p);
	372	}
8e327405	373	}
8e327405	374
60c514ba	375	if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
4ee9c684	376	{
4ee9c684	377	if (u == NULL \|\| u->flags.access == ACCESS_DIRECT)
b3b0377b	378	p = undefined;
4ee9c684	379	else
b3b0377b	380	switch (u->flags.position)
	381	{
	382	case POSITION_REWIND:
	383	p = "REWIND";
	384	break;
	385	case POSITION_APPEND:
	386	p = "APPEND";
	387	break;
	388	case POSITION_ASIS:
	389	p = "ASIS";
	390	break;
	391	default:
	392	/* if not direct access, it must be
	393	either REWIND, APPEND, or ASIS.
	394	ASIS seems to be the best default */
	395	p = "ASIS";
	396	break;
	397	}
60c514ba	398	cf_strcpy (iqp->position, iqp->position_len, p);
4ee9c684	399	}
4ee9c684	400
60c514ba	401	if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
4ee9c684	402	{
	403	if (u == NULL)
	404	p = undefined;
	405	else
	406	switch (u->flags.action)
	407	{
	408	case ACTION_READ:
	409	p = "READ";
	410	break;
	411	case ACTION_WRITE:
	412	p = "WRITE";
	413	break;
	414	case ACTION_READWRITE:
	415	p = "READWRITE";
	416	break;
	417	default:
60c514ba	418	internal_error (&iqp->common, "inquire_via_unit(): Bad action");
4ee9c684	419	}
4ee9c684	420
60c514ba	421	cf_strcpy (iqp->action, iqp->action_len, p);
4ee9c684	422	}
4ee9c684	423
60c514ba	424	if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
4ee9c684	425	{
	426	p = (u == NULL) ? inquire_read (NULL, 0) :
	427	inquire_read (u->file, u->file_len);
	428
60c514ba	429	cf_strcpy (iqp->read, iqp->read_len, p);
4ee9c684	430	}
4ee9c684	431
60c514ba	432	if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
4ee9c684	433	{
	434	p = (u == NULL) ? inquire_write (NULL, 0) :
	435	inquire_write (u->file, u->file_len);
	436
60c514ba	437	cf_strcpy (iqp->write, iqp->write_len, p);
4ee9c684	438	}
4ee9c684	439
60c514ba	440	if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
4ee9c684	441	{
	442	p = (u == NULL) ? inquire_readwrite (NULL, 0) :
	443	inquire_readwrite (u->file, u->file_len);
	444
60c514ba	445	cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
4ee9c684	446	}
4ee9c684	447
60c514ba	448	if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
4ee9c684	449	{
	450	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	451	p = undefined;
	452	else
	453	switch (u->flags.delim)
	454	{
	455	case DELIM_NONE:
	456	p = "NONE";
	457	break;
	458	case DELIM_QUOTE:
	459	p = "QUOTE";
	460	break;
	461	case DELIM_APOSTROPHE:
	462	p = "APOSTROPHE";
	463	break;
	464	default:
60c514ba	465	internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
4ee9c684	466	}
4ee9c684	467
60c514ba	468	cf_strcpy (iqp->delim, iqp->delim_len, p);
4ee9c684	469	}
4ee9c684	470
60c514ba	471	if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
4ee9c684	472	{
	473	if (u == NULL \|\| u->flags.form != FORM_FORMATTED)
	474	p = undefined;
	475	else
	476	switch (u->flags.pad)
	477	{
	478	case PAD_NO:
	479	p = "NO";
	480	break;
	481	case PAD_YES:
	482	p = "YES";
	483	break;
	484	default:
60c514ba	485	internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
4ee9c684	486	}
4ee9c684	487
60c514ba	488	cf_strcpy (iqp->pad, iqp->pad_len, p);
4ee9c684	489	}
9e94d29f	490
	491	if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0)
	492	{
	493	if (u == NULL)
	494	p = undefined;
	495	else
	496	switch (u->flags.convert)
	497	{
1316e8f0	498	/* big_endian is 0 for little-endian, 1 for big-endian. */
18f0b7df	499	case GFC_CONVERT_NATIVE:
1316e8f0	500	p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN";
9e94d29f	501	break;
9e94d29f	502
18f0b7df	503	case GFC_CONVERT_SWAP:
1316e8f0	504	p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN";
9e94d29f	505	break;
	506
	507	default:
	508	internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
	509	}
	510
	511	cf_strcpy (iqp->convert, iqp->convert_len, p);
	512	}
4ee9c684	513	}
	514
	515
	516	/* inquire_via_filename()-- Inquiry via filename. This subroutine is
	517	* only used if the filename is not connected to a unit number. */
	518
	519	static void
60c514ba	520	inquire_via_filename (st_parameter_inquire *iqp)
4ee9c684	521	{
4ee9c684	522	const char *p;
60c514ba	523	GFC_INTEGER_4 cf = iqp->common.flags;
4ee9c684	524
60c514ba	525	if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
60c514ba	526	*iqp->exist = file_exists (iqp->file, iqp->file_len);
4ee9c684	527
60c514ba	528	if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
60c514ba	529	*iqp->opened = 0;
4ee9c684	530
60c514ba	531	if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
60c514ba	532	*iqp->number = -1;
4ee9c684	533
60c514ba	534	if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
60c514ba	535	*iqp->named = 1;
4ee9c684	536
60c514ba	537	if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
60c514ba	538	fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
4ee9c684	539
60c514ba	540	if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
60c514ba	541	cf_strcpy (iqp->access, iqp->access_len, undefined);
4ee9c684	542
60c514ba	543	if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
4ee9c684	544	{
2e1fa727	545	p = "UNKNOWN";
60c514ba	546	cf_strcpy (iqp->sequential, iqp->sequential_len, p);
4ee9c684	547	}
4ee9c684	548
60c514ba	549	if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
4ee9c684	550	{
2e1fa727	551	p = "UNKNOWN";
60c514ba	552	cf_strcpy (iqp->direct, iqp->direct_len, p);
4ee9c684	553	}
4ee9c684	554
60c514ba	555	if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
60c514ba	556	cf_strcpy (iqp->form, iqp->form_len, undefined);
4ee9c684	557
60c514ba	558	if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
4ee9c684	559	{
2e1fa727	560	p = "UNKNOWN";
60c514ba	561	cf_strcpy (iqp->formatted, iqp->formatted_len, p);
4ee9c684	562	}
4ee9c684	563
60c514ba	564	if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
4ee9c684	565	{
2e1fa727	566	p = "UNKNOWN";
60c514ba	567	cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
4ee9c684	568	}
4ee9c684	569
60c514ba	570	if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
60c514ba	571	*iqp->recl_out = 0;
4ee9c684	572
60c514ba	573	if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
60c514ba	574	*iqp->nextrec = 0;
4ee9c684	575
60c514ba	576	if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
60c514ba	577	cf_strcpy (iqp->blank, iqp->blank_len, undefined);
4ee9c684	578
8e327405	579	if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
	580	cf_strcpy (iqp->pad, iqp->pad_len, undefined);
	581
0d72fa67	582	if (cf & IOPARM_INQUIRE_HAS_FLAGS2)
0d72fa67	583	{
b5d015e3	584	GFC_INTEGER_4 cf2 = iqp->flags2;
b5d015e3	585
0d72fa67	586	if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
0d72fa67	587	cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
8e327405	588
0d72fa67	589	if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
	590	cf_strcpy (iqp->delim, iqp->delim_len, undefined);
	591
	592	if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0)
	593	cf_strcpy (iqp->decimal, iqp->decimal_len, undefined);
8e327405	594
0d72fa67	595	if ((cf2 & IOPARM_INQUIRE_HAS_DELIM) != 0)
	596	cf_strcpy (iqp->delim, iqp->delim_len, undefined);
	597
	598	if ((cf2 & IOPARM_INQUIRE_HAS_PAD) != 0)
	599	cf_strcpy (iqp->pad, iqp->pad_len, undefined);
	600
	601	if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
	602	cf_strcpy (iqp->encoding, iqp->encoding_len, undefined);
	603	}
8e327405	604
60c514ba	605	if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
60c514ba	606	cf_strcpy (iqp->position, iqp->position_len, undefined);
4ee9c684	607
60c514ba	608	if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
60c514ba	609	cf_strcpy (iqp->access, iqp->access_len, undefined);
4ee9c684	610
60c514ba	611	if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
4ee9c684	612	{
60c514ba	613	p = inquire_read (iqp->file, iqp->file_len);
60c514ba	614	cf_strcpy (iqp->read, iqp->read_len, p);
4ee9c684	615	}
4ee9c684	616
60c514ba	617	if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
4ee9c684	618	{
60c514ba	619	p = inquire_write (iqp->file, iqp->file_len);
60c514ba	620	cf_strcpy (iqp->write, iqp->write_len, p);
4ee9c684	621	}
4ee9c684	622
60c514ba	623	if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
4ee9c684	624	{
60c514ba	625	p = inquire_read (iqp->file, iqp->file_len);
60c514ba	626	cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
4ee9c684	627	}
4ee9c684	628	}
	629
	630
6799e2f8	631	/* Library entry point for the INQUIRE statement (non-IOLENGTH
6799e2f8	632	form). */
4ee9c684	633
60c514ba	634	extern void st_inquire (st_parameter_inquire *);
7b6cb5bd	635	export_proto(st_inquire);
7b6cb5bd	636
4ee9c684	637	void
60c514ba	638	st_inquire (st_parameter_inquire *iqp)
4ee9c684	639	{
f02dd226	640	gfc_unit *u;
4ee9c684	641
60c514ba	642	library_start (&iqp->common);
4ee9c684	643
60c514ba	644	if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
	645	{
	646	u = find_unit (iqp->common.unit);
	647	inquire_via_unit (iqp, u);
	648	}
4ee9c684	649	else
4ee9c684	650	{
60c514ba	651	u = find_file (iqp->file, iqp->file_len);
4ee9c684	652	if (u == NULL)
60c514ba	653	inquire_via_filename (iqp);
4ee9c684	654	else
60c514ba	655	inquire_via_unit (iqp, u);
4ee9c684	656	}
60c514ba	657	if (u != NULL)
60c514ba	658	unlock_unit (u);
4ee9c684	659
	660	library_end ();
	661	}