/*
 * Copyright (C) 2007 PathScale, LLC.  All Rights Reserved.
 */

/*
 * Copyright 2003, 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
 */

/*

  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/opn.c	92.3	06/23/99 16:08:16"

#include <errno.h>
#include <fortran.h>
#include <liberrno.h>
#include <string.h>
#include <stdarg.h>
#include <cray/nassert.h>
#ifdef KEY /* Bug 4260 */
#  include <cray/assign.h>
#endif /* KEY Bug 4260 */
#include "fmt.h"
#include "fio.h"
#include "f90io.h"

#define OPNERR(n) { \
	errn	= n;	\
	goto opn_done;	\
}

#define SETSPEC(_specifier, _default_value, _error_code, _nval, _spec_list) \
 \
	if (_fcdtocp(_specifier) == NULL) \
		a.o##_specifier	= _default_value; \
	else if (! findmatch(_specifier, (int*) &a.o##_specifier, _nval \
			     _spec_list)) \
		OPNERR(_error_code)

#undef S
#define S(_spec) , #_spec, OS_##_spec

/*
 *	PASSED_ARG(x) is nonzero if argument x was passed.
 */

#define ARGS_11		(4 + 7*sizeof(_fcd)/sizeof(long))
#define ARGS_12		(4 + 8*sizeof(_fcd)/sizeof(long))
#define ARGS_13		(4 + 9*sizeof(_fcd)/sizeof(long))
#define ARGS_16		(7 + 9*sizeof(_fcd)/sizeof(long))
#if _UNICOS
#define PASSED_ARG(x)	(_numargs() >= x)
#else
#define PASSED_ARG(x)	(1)
#endif


static int	findmatch(_fcd fortstring, int *result, int nval, ...);

/*
 *	$OPN - Fortran-77 runtime open routine.  Processes an OPEN statement.
 */

#ifdef	_UNICOS
#pragma _CRI duplicate __OPN as $OPN
#endif

#ifdef _CRAYMPP
__OPN(
_f_int	*unitn,
_f_int	*iostat,
int	*errf,
...
)
#else
int __OPN(
_f_int	*unitn,
_f_int	*iostat,
int	*errf,
_fcd	file,
_fcd	status,
_fcd	access,
_fcd	form,
_f_int	*recl,
_fcd	blank,
_fcd	position,
_fcd	action_arg,
_fcd	delim_arg,
_fcd	pad_arg,
int	unused1,	/* for a future CFT77 open specifier */
int	unused2,	/* for a future CFT77 open specifier */
int	isf90_arg)	/* =1 iff Fortran-90 OPEN */
#endif
{
	olist		a;		/* OPEN specifier list		*/
	long		fstrlen;	/* Length of Fortran string	*/
	int		errn;		/* IOSTAT error number		*/
	int		error;		/* Error flag			*/
	unum_t		unum;		/* Fortran unit number		*/
	_fcd		action;
	_fcd		delim;
	_fcd		pad;
	int		isf90;
	unit		*cup;		/* Pointer to unit table entry	*/
	enum form_spec	formdef;
	struct fiostate	cfs;

#ifdef _CRAYMPP
	va_list args;
	_fcd	file;
	_fcd	status;
	_fcd	access;
	_fcd	form;
	_f_int	*recl;
	_fcd	blank;
	_fcd	position;
	int	unused1;	/* for a future CFT77 open specifier */
	int	unused2;	/* for a future CFT77 open specifier */
	int	isf90_arg;	/* =1 iff Fortran-90 OPEN */
#endif

/*
 *	The ACTION, DELIM, and PAD specifiers are supported by CFT77
 *	release 5.0 and later on CX/CEA systems, and by CFT77 release 6.0 and
 *	later on CRAY-2 systems.
 */
	action	= _cptofcd(NULL, 0);
	delim	= _cptofcd(NULL, 0);
	pad	= _cptofcd(NULL, 0);
#ifdef _CRAYMPP
	va_start(args,errf);
	file	= va_arg(args, _fcd);
	status	= va_arg(args, _fcd);
	access	= va_arg(args, _fcd);
	form	= va_arg(args, _fcd);
	recl	= va_arg(args, _f_int *);
	blank	= va_arg(args, _fcd);
	position = va_arg(args, _fcd);
	
#endif
	if (PASSED_ARG(ARGS_11)) {
#ifdef _CRAYMPP
		action	= va_arg(args, _fcd);
#else
		action	= action_arg;
#endif
	}
	if (PASSED_ARG(ARGS_12)) {
#ifdef _CRAYMPP
		delim	= va_arg(args, _fcd);
#else
		delim	= delim_arg;
#endif
	}
	if (PASSED_ARG(ARGS_13)) {
#ifdef _CRAYMPP
		pad	= va_arg(args, _fcd);
#else
		pad	= pad_arg;
#endif
	}
/*
 *	The isf90 argument is not passed from CFT77.
 */
	isf90	= 0;

	if (PASSED_ARG(ARGS_16)) {
#ifdef _CRAYMPP
		unused1	= va_arg(args, int);
		unused2	= va_arg(args, int);
		isf90	= va_arg(args, int);
#else
		isf90	= isf90_arg;
#endif
	}
#ifdef _CRAYMPP
	va_end(args);
#endif
	errn	= 0;

	OPENLOCK();		/* prevent other OPENs or CLOSEs right now */

#ifdef KEY /* Bug 4260 */
	/* Before we open the first file in the course of execution, we must
	 * set byte-swapping based on __io_byteswap_value defined by Fortran
	 * main in response to command-line options like -byteswapio */
        __io_byteswap();
#endif /* KEY Bug 4260 */

	unum	= *unitn;	/* UNIT= is required by compiler */
	a.ounit	= unum;

	STMT_BEGIN(unum, 0, T_OPEN, NULL, &cfs, cup);	/* lock unit if open */

	if (!GOOD_UNUM(unum) || RSVD_UNUM(unum))
		OPNERR(FEIVUNTO);

	a.oerr	= (errf || iostat) ? 1 : 0;	/* Catch errs if ERR | IOSTAT */

/*
 *	Process FILE= and RECL= specifiers.
 */
	if (_fcdtocp(file) != NULL) {
	       	a.ofile		= _fcdtocp(file);
		a.ofilelen	= _fcdlen (file);
	}
	else {
		a.ofile		= NULL;
		a.ofilelen	= 0;
	}

	if (recl != NULL)
		a.orecl	= *recl;
	else
		a.orecl	= 0;	/* 0 means unspecified */

/*
 *	Process remaining specifiers.
 *
 *	Specifier		Default			Error Code
 * 	Value List
 */

	SETSPEC(status,		OS_UNKNOWN,		FEOPSTAT,	5,
	S(OLD) S(NEW) S(SCRATCH) S(UNKNOWN) S(REPLACE));

#if	!defined(__mips) && !defined(_LITTLE_ENDIAN)
	SETSPEC(access,		OS_SEQUENTIAL,		FEOPACCS,	2,
	S(DIRECT) S(SEQUENTIAL));
	SETSPEC(position,	OS_ASIS,		FEOPPOSN,	3,
	S(APPEND) S(ASIS) S(REWIND));
#else	/* not __mips and not little endian */
	SETSPEC(access,		OS_SEQUENTIAL,		FEOPACCS,	4,
	S(DIRECT) S(SEQUENTIAL) S(KEYED) S(APPEND));
	if ((_fcdtocp(access) != NULL) && (a.oaccess == OS_OAPPEND)) {
		if (_fcdtocp(position) != NULL) {
			OPNERR(FEOPACCS);	/* Invalid ACCESS */
		}
#ifdef KEY /* Bug 86 */
                /* The Fortran 90 standard does not place a constraint
		 * on the value of 'access=', so there's no need to
		 * issue an error message in normal or -ansi mode (and
		 * "isf90" seems always to be set anyway).  */
#else
		else if (isf90) {
			OPNERR(FEOPACCS);	/* Invalid ACCESS */
		}
#endif /* KEY */
		else {
			a.oposition	= OS_APPEND;
			a.oaccess	= OS_SEQUENTIAL;
		}
	}
	else {
	/* use POSITION= if ACCESS='APPEND' is not provided */
	SETSPEC(position,	OS_ASIS,		FEOPPOSN,	3,
	S(APPEND) S(ASIS) S(REWIND));
	}
#endif	/* not __mips and not little endian */

        formdef	= (a.oaccess == OS_SEQUENTIAL) ? OS_FORMATTED : OS_UNFORMATTED;

	SETSPEC(form,		formdef,		FEOPFORM,	4,
	S(UNFORMATTED) S(FORMATTED) S(BINARY) S(SYSTEM));

	SETSPEC(blank,		OS_NULL,		FEOPBLNK,	2,
	S(ZERO) S(NULL));

	SETSPEC(action,		OS_ACTION_UNSPECIFIED,	FEOPACTB,	3,
	S(READ) S(WRITE) S(READWRITE));

	SETSPEC(delim,		OS_NONE,		FEOPDLMB,	3,
	S(APOSTROPHE) S(QUOTE) S(NONE));

	SETSPEC(pad,		OS_YES,			FEOPPADB,	2,
	S(YES) S(NO));

/*
 *	Diagnose errors.
 */

	if (recl != NULL && a.orecl <= 0)
		OPNERR(FEOPRECL);		/* Invalid RECL */

	if (recl == NULL && a.oaccess == OS_DIRECT)
		OPNERR(FEOPRCRQ);		/* RECL required for direct */

	if (_fcdtocp(blank) != NULL && (a.oform == OS_UNFORMATTED ||
	   a.oform == OS_BINARY || a.oform == OS_SYSTEM))
		OPNERR(FEOPBKIV);		/* BLANK= invalid if unform. */
 
	if (_fcdtocp(delim) != NULL && (a.oform == OS_UNFORMATTED ||
	   a.oform == OS_BINARY || a.oform == OS_SYSTEM))
		OPNERR(FEOPDLMI);		/* DELIM invalid if unform. */

	if (_fcdtocp(pad) != NULL && (a.oform == OS_UNFORMATTED ||
	   a.oform == OS_BINARY || a.oform == OS_SYSTEM))
		OPNERR(FEOPPDIV);		/* PAD= invalid if unformatted*/

	if (_fcdtocp(position) != NULL && a.oaccess == OS_DIRECT)
		OPNERR(FEOPPSIV);		/* POSITION invalid on direct */

/*
 *	Done with OPEN specifiers.
 */
	if (OPEN_UPTR(cup) && cup->ufs == FS_AUX)
		OPNERR(FEOPAUXT);	/* Unit is opened by AQ/MS/DR/WA IO */

	/* Bug COMPILER-8764 */
	char *null_terminated = alloca(a.ofilelen + 1);
	_copy_n_trim(a.ofile, a.ofilelen, null_terminated);
	if (OPEN_UPTR(cup) &&
	    (_fcdtocp(file) == NULL || (cup->ufnm != NULL &&
	     strcmp(cup->ufnm, null_terminated) == 0))) {
		/*
		 * A re-open of the same file occurs when the FILE= specifier
		 * is present and matches the name with which the file was
		 * originally opened, or if the FILE= specifier is absent
		 * (these are re-opens of the same file by definition).
		 *
		 * In this case, only a subset of the OPEN specifiers
		 * (the BLANK=, PAD=, and DELIM= specifiers) may be provided
	 	 * with values which are different from those currently in 
		 * effect.   Any new value passed with the BLANK=, PAD=, or
		 * DELIM= specifier will go into effect.
	 	 *
		 * An attempt to change the other OPEN specifers is an error.
		 */

		if (_fcdtocp(status) != NULL && a.ostatus != cup->uostatus) {
			if (a.ostatus == OS_NEW && cup->uostatus == OS_OLD) {
				OPNERR(FEOPNNEW); /* STATUS=NEW became OLD */
			}
			else
				OPNERR(FEOPCBNK); /* Can't change STATUS */
		}

		if (_fcdtocp(access) != NULL &&
		    ((a.oaccess == OS_SEQUENTIAL && cup->useq == 0 ) ||
		     (a.oaccess == OS_DIRECT     && cup->useq == 1)   ))
			OPNERR(FEOPCBNK);	/* Can't change ACCESS */

		if (_fcdtocp(form) != NULL &&
		    ((a.oform == OS_FORMATTED   && cup->ufmt == 0) ||
		     (a.oform == OS_UNFORMATTED && cup->ufmt == 1)   ))
			OPNERR(FEOPCBNK);	/* Can't change FORM */

		if (recl != NULL && a.orecl != cup->urecl)
			OPNERR(FEOPCBNK);	/* Can't change RECL */
			
		if (_fcdtocp(position) != NULL && a.oposition != cup->uposition)
			OPNERR(FEOPCBNK);	/* Can't change POSITION */

		if (_fcdtocp(action) != NULL && a.oaction != cup->uaction)
			OPNERR(FEOPCBNK);	/* Can't change ACTION */

		/*
		 * Place into effect any new BLANK=, DELIM=, or PAD= specifier
		 * provided on the OPEN statement.
		 */

		if (_fcdtocp(blank) != NULL)
			cup->ublnk	= (a.oblank == OS_ZERO);

		if (_fcdtocp(delim) != NULL)
			cup->udelim	= a.odelim;	

		if (_fcdtocp(pad)   != NULL)
			cup->upad	= a.opad;	
	}
	else {

		/*
		 * Open the unit.  If the unit is currently connected, it
		 * will be closed and then reopened for the new file.  
		 */

/* KEY: we do want this check */
#if	(!defined(__mips) && !defined(_LITTLE_ENDIAN)) || defined(KEY)
		/*
		 * SGI's F77 and old F90 allowed open with status=NEW,
		 * OLD, or REPLACE without FILE specifier, so we continue
		 * to allow it on MIPS systems.
		 */
		if (a.ostatus == OS_REPLACE && a.ofile == NULL)
			OPNERR(FEOPFNRQ); /* FILE= required for 'REPLACE' */

		if (a.ostatus == OS_OLD && a.ofile == NULL)
			OPNERR(FEOPFNRQ); /* FILE= required for 'OLD' */

		if (a.ostatus == OS_NEW && a.ofile == NULL)
			OPNERR(FEOPFNRQ); /* FILE= required for 'NEW' */
#endif
#ifdef	_CRAYMPP
		/*
		 * This check should be added for CX/CEA someday.
 		 */
		if (a.ostatus == OS_SCRATCH && a.ofile != NULL)
			OPNERR(FEOPFNIV); /* FILE= should not be specified */
#endif


		/*
 		 * We assume that _f_open does not change cfs.f_cu if
 		 * the unit was already open.
		 */
		errn	= _f_open(&cfs, &cup, &a, isf90);
	}

/*
 *	Process results
 */
opn_done:
	error	= (errn != 0) ? IO_ERR : IO_OKAY;

	if (iostat != NULL)
		*iostat	= errn;
	else
		if (error != IO_OKAY && errf == 0)
			if (errn == FEIVUNTO)
				_ferr(&cfs, errn, unum);
			else
				_ferr(&cfs, errn);

	STMT_END(cup, T_OPEN, NULL, NULL);	/* unlock unit */

	OPENUNLOCK();

	return(CFT77_RETVAL(error));
}

/*
 *	_OPEN - Fortran-90 runtime open routine.  Processes an OPEN statement.
 */
int
_OPEN(struct open_spec_list *o)
{
/*
 *	Pass value of 1 in argument #16 to indicate that this is a Fortran-90
 *	OPEN.
 */
	assert ( o->version == 0 );

	return( __OPN(o->unit, o->iostat, (int*)o->err, o->file, o->status,
		     o->access, o->form, o->recl, o->blank, o->position,
		     o->action, o->delim, o->pad,
#ifdef KEY
		     0, 0,
#else
		     (int)NULL, (int)NULL,
#endif /* KEY */
		     1) );
}


#if 0	/* ifdef it out.   Remove it when we're really sure it's not needed. */
/*
 *	_OPN - Obsolete Fortran-90 runtime open routine.  Processes an OPEN 
 *	statement.
 */

int
_OPN(
_f_int	*unitn,
_f_int	*iostat,
int	*errf,
_fcd	file,
_fcd	status,
_fcd	access,
_fcd	form,
_f_int	*recl,
_fcd	blank,
_fcd	position,
_fcd	action_arg,
_fcd	delim_arg,
_fcd	pad_arg)
{
/*
 *	Pass value of 1 in argument #16 to indicate that this is a Fortran-90
 *	OPEN.
 */
	return( __OPN(unitn, iostat, errf, file, status, access, form, recl, \
		     blank, position, action_arg, delim_arg, pad_arg,
		     NULL, NULL, 1) );
}
#endif /* 0 */

/*
 *	findmatch - does a case-insensitive match of Fortran string fortstring 
 *	with a list of possible values.  The integer code of the matched 
 *	value is returned in *result.
 *
 *	Return value is 1 if a match was made, and 0 otherwise.
 */
static int 
findmatch(_fcd fortstring, int *result, int nval, ...)
{
	va_list ap;
	char	*fstring;       /* Pointer to Fortran string    */
	long	fstrlen;        /* Length of Fortran string     */
	int	_string_cmp();	/* String compare routine in libu */
	char	*next_string;
	int	next_value;
	int	ret, i;

	va_start(ap, nval);

	fstring	= _fcdtocp(fortstring);
	fstrlen	= _fcdlen (fortstring);

	ret	= 0;		/* assume match not found */

	for (i = 0; i < nval; i++) {
		next_string	= va_arg(ap, char *);
		next_value	= va_arg(ap, int);
		if (_string_cmp(next_string, fstring, fstrlen)) {
			*result	= next_value;
			ret	= 1;
			break;
		}
	}

	va_end(ap);

	return(ret);
}

#if	defined(__mips) || defined(_LITTLE_ENDIAN)
/*
 *	_OPEN - IRIX f77 -craylibs runtime open routine.
 *	 Processes an OPEN statement.
 */
int
_OPENF77(struct open_spec_list *o)
{
/*
 *	Pass value of 0 in argument #16 to indicate that this
 *	is a Fortran-77 IRIX OPEN.
 */
	assert ( o->version == 0 );

	return( __OPN(o->unit, o->iostat, (int*)o->err, o->file, o->status,
		     o->access, o->form, o->recl, o->blank, o->position,
		     o->action, o->delim, o->pad,
#ifdef KEY
		     0, 0, 0
#else
		     (int)NULL, (int)NULL, (int)NULL
#endif /* KEY */
		     ));
}
#endif	/* mips  or little endian */
