/*

  Copyright (C) 2000, 2001, Silicon Graphics, Inc.  All Rights Reserved.

   Path64 is free software; you can redistribute it and/or modify it
   under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation version 2.1

   Path64 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 Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



#pragma ident "@(#) libf/fio/rf90.c	92.4	06/18/99 15:49:57"

#include <ctype.h>
#include <errno.h>
#include <liberrno.h>
#include <fortran.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <cray/fmtconv.h>
#include <cray/format.h>
#include <cray/nassert.h>
#ifndef	_ABSOFT
#include <sys/unistd.h>
#endif
#include "fio.h"
#include "fmt.h"
#include "fstats.h"
#include "f90io.h"

/*
 *	_FRF	Called by compiled Fortran programs to process a formatted
 *		or list-directed read statement.  Each statement is
 *		processed by one or more calls to _FRF.
 *
 *	Synopsis
 *
 *		int _FRF(	ControlList	*cilist,
 *				iolist_header	*iolist,
 *				void		*stck);
 *		
 *		Where
 *
 *			cilist	Pointer to the control information list 
 *				information.  This describes the specifiers 
 *				for the current I/O statement.  This cilist
 *				is guaranteed by the compiler to reflect
 *				the original values of control information
 *				list variables for the duration of the I/O
 *				statement (ie through multiple calls).
 *			iolist	Pointer to the I/O list information. 
 *			stck	Pointer to stack space which is passed
 *				to each call to _FRF for a particular 
 *				statement.  This space is used by the
 *				library.
 *
 *	Return value
 *
 *		IO_OKAY, IO_ERR, IO_END, or IO_EOR 
 */
int
_FRF(ControlListType *cilist, iolist_header *iolist, void *stck)
{
	register int	errf;		/* ERR processing flag	*/
	register int 	errn;		/* Error number		*/
	register int	iost;		/* I/O statement type	*/
	register int	retval;		/* _FRF return value	*/
	register recn_t	errarg;		/* Extra _ferr argument	*/
	register unum_t	unum;		/* Unit number		*/
	unit		*cup;		/* Unit table pointer	*/
	FIOSPTR		css;		/* I/O statement state	*/

/*
 *	Assertions 
 */
	/* Validate that the size of *stck is large enough */
	assert ( cilist->stksize >= sizeof(struct fiostate)/sizeof(long) );

	/* The compiler disallows ADVANCE='YES' w/ SIZE= */
	assert ( ! (cilist->advcode == CI_ADVYES && cilist->size_spec != NULL));

	/* The compiler disallows ADVANCE='YES' w/ EOR= */
	assert ( ! (cilist->advcode == CI_ADVYES && cilist->eorflag));

	/* The compiler disallows ADVANCE= w/ internal files */
	assert( ! (cilist->advcode != CI_ADVYES && cilist->internal != 0));

	/* The compiler disallows ADVANCE= w/ list-directed */
	assert( ! (cilist->advcode != CI_ADVYES && cilist->fmt == CI_LISTDIR));

	css	= stck;
	errn	= 0;
	errarg	= 0;
	retval	= IO_OKAY;

	if (iolist->iolfirst == 0) {
		cup	= css->f_cu;
		goto data_transfer;
	}

/*******************************************************************************
 *
 *	Statement Initialization Section
 *
 ******************************************************************************/

	/* Establish error processing options */

	errf	= (cilist->errflag || cilist->iostatflg);

	if (cilist->fmt == CI_LISTDIR) 
		iost	= T_RLIST;
	else if (cilist->dflag)
		iost	= T_RDF;
	else
		iost	= T_RSF;

	/* Zero the SIZE= value before any errors are encountered */

	if (iost & TF_FMT)
		css->u.fmt.u.fe.charcnt	= 0;

	css->u.fmt.freefmtbuf	= 0;
	css->u.fmt.freepfmt	= 0;
	css->u.fmt.tempicp	= NULL;

	/* Check if we're doing internal I/O or external I/O */

	if (cilist->internal) {		/* If internal I/O */
		STMT_BEGIN(-1, 1, iost, NULL, css, cup);
		cup->uft90	= 1;	/* set F90 mode for internal file */
#ifndef	__mips
		cup->ufcompat	= 2;	/* set CF90 on internal file */
		cup->ufunilist	= 0;
		cup->ufcomsep	= 0;
		cup->ufcomplen	= 0;
		cup->ufrptcnt	= 0;
#elif	defined(_LITTLE_ENDIAN)
		cup->ufcompat	= 0;	/* set no f90 on internal file */
		cup->ufunilist	= 0;
		cup->ufcomsep	= 0;
		cup->ufcomplen	= 0;
		cup->ufrptcnt	= 0;
#else
		cup->ufcompat	= 4;	/* set IRIXF90 on internal file */
		cup->ufunilist	= 0;
		cup->ufcomsep	= 0;
		cup->ufcomplen	= 0;
		cup->ufrptcnt	= 0;
#endif
	}
	else {				/* Else external I/O */
		if (cilist->uflag == CI_UNITASTERK)
			unum	= STDIN_U;
		else
			unum	= *cilist->unit.wa;

		STMT_BEGIN(unum, 0, iost, NULL, css, cup);

		if (cup == NULL) {	/* If not connected */
			int	stat;

			cup	= _imp_open(	css,
						(cilist->dflag ? DIR : SEQ),
						FMT,
						unum,
						errf,
						&stat);

			/*
			 * If the open failed, cup is NULL and stat contains 
			 * the error number.
			 */
			if (cup == NULL) {
				errn	= stat;
				goto handle_exception;
			}
		}
	}

	/* All paths which lead here have set cup to a non-null value */

	assert (cup != NULL);

	/* Copy the user's error processing options into the unit table */

	cup->uflag	= (cilist->errflag		?  _UERRF : 0) |
			  (cilist->endflag		?  _UENDF : 0) |
			  (cilist->eorflag		?  _UEORF : 0) |
			  (cilist->iostat_spec != NULL	? _UIOSTF : 0);

	/* Initialize fields in the Fortran statement state structure */

	css->u.fmt.icp		= NULL;
	css->u.fmt.blank0	= cup->ublnk;
	css->u.fmt.lcomma	= 0;
	css->u.fmt.slash	= 0;
#ifdef	_CRAYMPP
	css->f_shrdput		= 0;
#endif

	/* Process the format and related specifiers */

	if (cilist->fmt != CI_LISTDIR) {	/* If formatted input */
		register int	stat;

		css->u.fmt.u.fe.fmtbuf	= NULL;
		css->u.fmt.u.fe.fmtnum	= 0;
		css->u.fmt.u.fe.fmtcol	= 0;
		css->u.fmt.u.fe.scale	= 0;

		errn	= setup_format(css, cup, cilist);

		if (errn > 0)
			goto handle_exception;

		/* Handle ADVANCE specifier */

		stat	= _is_nonadv(cilist);

		if (stat < 0)
			errn	= FEADVSPC;	/* Invalid ADVANCE specifier */

		if (cilist->advcode == CI_ADVVAR && stat == 0) {
			if (cilist->size_spec != NULL)
				errn	= FEADVSIZ; /* ADVANCE='YES' w/SIZE= */

			if (cilist->eorflag)
				errn	= FEADVEOR; /* ADVANCE='YES' w/EOR= */
		}

		if (errn != 0)
			goto handle_exception;

		css->u.fmt.nonadv	= stat;
	}
	else					/* Else list-directed input */
		css->u.fmt.nonadv	= 0;

	/* Set processing functions */

	if (cilist->dflag) {

		if (!cup->ok_rd_dir_fmt)
			errn	= _get_mismatch_error(errf, iost, cup, css);
		else {
			register recn_t	recn;	/* Record number */

			recn	= (recn_t) *cilist->rec_spec;
			errarg	= recn;
			errn	= _unit_seek(cup, recn, iost);
		}

		css->u.fmt.endrec	= _dr_endrec;
	}
	else {

		if (!cup->ok_rd_seq_fmt) {
			errn	= _get_mismatch_error(errf, iost, cup, css);
			goto handle_exception;
		}

		if (cilist->internal) {

			css->u.fmt.endrec	= _ir_endrec;

			if (cilist->uflag == CI_UNITCHAR) {
				css->u.fmt.iiae	= 1;
				css->u.fmt.icp	= _fcdtocp(cilist->unit.fcd);
				css->u.fmt.icl	= _fcdlen (cilist->unit.fcd);
			}
			else {
				DopeVectorType *dv = cilist->unit.dv;
				void	*newar;
				int	nocontig = 0;
				long	extent = 0;
				long	nbytes = 0;

				css->u.fmt.icp	= _fcdtocp(dv->base_addr.charptr);
				css->u.fmt.icl	= _fcdlen (dv->base_addr.charptr);

				newar	= (void *) NULL;

				if (dv->p_or_a && (dv->assoc == 0))
					errn	= FEUNOTAL; /* Not allocated/associated */
				else	/* Check for contiguous array */
					errn	= _cntig_chk(dv, &newar, &nocontig,
							&extent, &nbytes);

				if (errn != 0)
					goto handle_exception;

				/* Number of elements in array */

				css->u.fmt.iiae	= extent;

				if (nocontig) {
					css->u.fmt.icp		= newar;
					css->u.fmt.tempicp	= newar;
				}
			}

			/*
			 * If the size of the internal record is greater
			 * than the existing line buffer, then realloc()
			 * another one; else just decrease urecsize.
			 */
 
			if (css->u.fmt.icl > cup->urecsize) {
 
				cup->ulinebuf	= (long *) realloc(cup->ulinebuf,
							sizeof(long) *
							(css->u.fmt.icl + 1));

				if (cup->ulinebuf == NULL)
					errn	= FENOMEMY;	/* No memory */
			}

			cup->urecsize	= css->u.fmt.icl;
		}
		else {			/* external sequential formatted I/O */

			if (cup->uend != BEFORE_ENDFILE && !cup->umultfil) /* If after endfile */
				errn	= FERDENDR;	/* Read after endfile */
	
			if (cup->uwrt)	/* If writing */
				errn	= FERDAFWR;	/* Read after write */

			css->u.fmt.endrec	= _sr_endrec;

		}
	}

	if (errn != 0)
		goto handle_exception;

	if (cup->pnonadv == 0) {	/* If previous ADVANCE='YES' */
		errn	= (*css->u.fmt.endrec)(css, cup, 1); /* Read a record */

		if (errn != 0)
			goto handle_exception;
	}
	else			/* else previous ADVANCE='NO' */
		css->u.fmt.leftablim	= cup->ulineptr; /* Set left tab limit */

	cup->pnonadv	= css->u.fmt.nonadv;	/* Remember previous ADVANCE */
	cup->uwrt	= 0;			/* Set read status */

/*******************************************************************************
 *
 *	Data Transfer Section
 *
 ******************************************************************************/
data_transfer:

	errn	= _xfer_iolist(css, cup, iolist, (cilist->fmt == CI_LISTDIR) ?
				_ld_read : _rdfmt);

	if (errn != 0)
		goto handle_exception;

	if (! iolist->iollast )
		return (IO_OKAY);

/******************************************************************************
 *
 *	Statement Finalization Section
 *
 ******************************************************************************/
finalization:

#ifdef	_CRAYMPP
	if (css->f_shrdput) {
		css->f_shrdput	= 0;
		_remote_write_barrier();
	}
#endif
	/* If formatted I/O and no error/EOF/EOR, complete processing */

	if (cilist->fmt != CI_LISTDIR) {	/* If formatted */

		if (errn == 0)	/* Complete format */
			errn	= _rdfmt(css, cup, (void *) NULL, &__tip_null,
					0);

		/* If we allocated memory for a variable format, free it */

		if (css->u.fmt.freepfmt && css->u.fmt.u.fe.pfmt != NULL)
			free(css->u.fmt.u.fe.pfmt);

		/* If we allocated memory for a noncontiguous format,
		 * free it.
		 */

		if (css->u.fmt.freefmtbuf && css->u.fmt.u.fe.fmtbuf != NULL)
			free(css->u.fmt.u.fe.fmtbuf);
	}

	/*
	 * If we allocated memory for an internal file, move the output
	 * file from the temporary array to the noncontiguous array and
	 * free the temporary array.
	 */

	if (cilist->internal && css->u.fmt.tempicp != NULL) {
		(void) _unpack_arry (css->u.fmt.tempicp,
					cilist->unit.dv);
		free(css->u.fmt.tempicp);
	}

out_a_here:

	/* Set IOSTAT variable to 0 if no error, >0 error code otherwise */

	if (cilist->iostat_spec != NULL)
		*cilist->iostat_spec	= errn;

	/* Store character count in the SIZE= variable */

	if (cilist->size_spec != NULL)
		*cilist->size_spec	= css->u.fmt.u.fe.charcnt;

	STMT_END(cup, TF_READ, NULL, css);	/* Unlock unit */

	/* Return proper status */

	return (retval);

/*
 *	We put the error handling stuff here to reduce its impact when
 *	no errors are generated.  If we jump here, errn is set to a nonzero
 *	error, eor, or endfile status code.
 */
handle_exception:
	if (errn < 0) {	/* If EOF/EOR type error */

		/* No current record if EOF or EOR */

		if (cup != NULL) 
			cup->pnonadv	= 0;

		if (errn == FEEORCND)
			retval	= IO_EOR;
		else
			retval	= IO_END;
	}
	else 
		retval	= IO_ERR;

	if (retval == IO_ERR && ! cilist->errflag && ! cilist->iostatflg)
		_ferr(css, errn, errarg);

	if (retval == IO_EOR && ! cilist->eorflag && ! cilist->iostatflg)
		_ferr(css, errn, errarg);

	if (retval == IO_END && ! cilist->endflag && ! cilist->iostatflg)
		_ferr(css, errn, errarg);

	if (cup == NULL)
		goto out_a_here;

	goto finalization;
}
