Exemple #1
0
/*
 *	_f_inqu - process INQUIRE statement.
 *
 *	Return value
 *		Returns 0 on success, positive error code if an error
 *		is encountered and ERR= or IOSTAT= are unspecified.
 *		This routine aborts on error conditions if no ERR=
 *		or IOSTAT= are specified.
 */
int _f_inqu(
FIOSPTR	css,		/* statement state			*/
unit	*cup,		/* locked unit pointer if INQUIRE by   
			 * unit and unit is connected.		*/
inlist	*a)		/* list of INQUIRE specifiers		*/
{
	int	aifound;	/* Assign info found flag	*/
	int	byfile;		/* INQUIRE by file/unit flag	*/
	int	exists;		/* File exists flag		*/
	int	opened;		/* File opened flag		*/
	int	valunit;	/* Valid unit number flag	*/
	int	errn;
	char	*buf, *fn, *s;
	struct	stat	st;	/* Stat system call packet	*/
	assign_info	ai;	/* Assign information packet	*/
	unit	*p;
	
	p	= cup;
	errn	= 0;

/*
 *	Lock _openlock to ensure that no other task opens or closes units 
 *	during the unit table scan for inquire-by-file processing.  
 */
	OPENLOCK();

	if (a->infile != NULL)		/* if INQUIRE by file */
		byfile	= 1;
	else {				/* else INQUIRE by unit */
		byfile	= 0;
		valunit	= GOOD_UNUM(a->inunit) &&
			  !RSVD_UNUM(a->inunit);	/* Valid Unit Number? */
	}
  
	if ((buf = malloc(MAX(a->infilen + 1, MXUNITSZ + 1))) == NULL) {
		errn	= FENOMEMY;
		if (a->inerr)
			goto out_of_here;
		_ferr(css, errn);
	}
  
	*buf	= '\0';		/* Assume no name */
	opened	= 0;		/* Assume not opened */
	fn	= buf;
  
	if (byfile) {		/* If INQUIRE by file */
  
		_copy_n_trim(a->infile, a->infilen, buf);
  
		if ((aifound = _get_a_options(0, buf, -1, 0, &ai, NULL,
					_LELVL_RETURN)) == -1) {

			errn	= errno;

			if (a->inerr) {
				free(buf);
				goto out_of_here;
			}
			_ferr(css, errn);
		}
  
		if (aifound && ai.a_actfil_flg)		/* If assign alias */
			s	= ai.a_actfil; /* Use -a attribute as file name */
		else
			s	= buf;
  
		exists	= (stat(s, &st) != -1);
  
		if (exists) {

			p	= _get_next_unit(NULL, 1, 1);

			while (p != NULL) {	/* while more open units */
				unum_t	unum;

				unum	= p->uid;

				if (! RSVD_UNUM(unum) &&
				    (p->uinode  == st.st_ino) &&
				    (p->udevice == st.st_dev)) {
					fn	= p->ufnm;
					opened	= 1;
					break;
				}
				p	= _get_next_unit(p, 1, 1);
			}
			/*
 			 * If p is non-null here, it points to a locked unit.
			 * The unit is locked to ensure a consistent set of
			 * INQUIRE'd attributes is returned.
			 */
		}
	}
	else {			/* Else INQUIRE by unit */
		if (valunit) {
			opened	= (cup != NULL);
			if (opened) {		/* If opened, get name */
				p	= cup;
				fn	= p->ufnm;
			}
		}
	}
  
	if (fn == NULL)		/* If no name available, return blanks */
		fn	= "";

	/* EXIST specifier */
  
	if (a->inex != NULL)
		if (byfile)	/* If INQUIRE by file */
			*a->inex	= _btol(exists);
		else		/* INQUIRE by unit    */
			*a->inex	= _btol(valunit); 
 
	/* OPENED specifier */
  
	if (a->inopen != NULL)
		*a->inopen	= _btol(opened);

	/* NAMED specifier */
  
	if (a->innamed != NULL)
		if (byfile)	/* If INQUIRE by file */
			*a->innamed	= _btol(1);		/* .TRUE. */
		else		/* INQUIRE by unit    */
			*a->innamed	= _btol(opened && p->ufnm != NULL);
  
	/* NUMBER specifier */
  
	if (a->innum != NULL) {
		if (opened) {
			if (byfile)	/* If INQUIRE by file */
				*a->innum	= (opened) ? p->uid : -1;
			else		/* INQUIRE by unit    */
				*a->innum	= a->inunit; /* The law of identity */
		}
		else
			*a->innum = -1;
	}
  
	/* RECL specifier */
  
	if (a->inrecl != NULL)
		if (opened) {
			if (p->urecl > 0)	/* If recl was specified */
				*a->inrecl	= p->urecl;
			else	/* Recl not specified (i.e., sequential) */
				*a->inrecl	= (p->ufmt) ? p->urecsize : LONG_MAX;
		}
		else 
			*a->inrecl	= -1;
  
	/* NEXTREC specifier */
  
	if (a->innrec != NULL)
		if (opened && p->useq == 0)	/* If opened & direct access */
			*a->innrec	= p->udalast + 1;
		else
			*a->innrec	= -1;
  
	/* NAME specifier */
  
	if (a->inname != NULL)
		_b_char(fn, a->inname, a->innamlen);
  
	/* ACCESS specifier */

	if (a->inacc != NULL) {
		if (opened)
			s	= (p->useq) ? "SEQUENTIAL" : "DIRECT";
		else
			s	= "UNDEFINED";
		_b_char(s, a->inacc, a->inacclen);
	}
 
	/* SEQUENTIAL specifier */

	if (a->inseq != NULL) {
		if (opened)
			s	= (p->useq) ? "YES" : "NO";
		else
			s	= "UNKNOWN";
		_b_char(s, a->inseq, a->inseqlen);
	}
  
	/* DIRECT specifier */

	if (a->indir != NULL) {
		if (opened)
			s	= (p->useq) ? "NO" : "YES";
		else
			s	= "UNKNOWN";
		_b_char(s, a->indir, a->indirlen);
	}
  
	/* FORM specifier */

	if (a->inform != NULL) {
		if (opened)
			s	= (p->ufmt) ? "FORMATTED" : "UNFORMATTED";
		else
			s	= "UNDEFINED";
		_b_char(s, a->inform, (ftnlen)a->informlen);
	}
  
	/* FORMATTED specifier */

	if (a->infmt != NULL) {
		if (opened)
			s	= (p->ufmt) ? "YES" : "NO";
		else
			s	= "UNKNOWN";
		_b_char(s, a->infmt, a->infmtlen);
	}
  
	/* UNFORMATTED specifier */

	if (a->inunf != NULL) {
		if (opened)
			s	= (p->ufmt) ? "NO" : "YES";
		else
			s	= "UNKNOWN";
		_b_char(s, a->inunf, a->inunflen);
	}
  
	/* BLANK specifier */

	if (a->inblank != NULL) {
		if (opened && p->ufmt)
			s	= (p->ublnk) ? "ZERO" : "NULL";
		else
			s	= "UNDEFINED";
		_b_char(s, a->inblank, a->inblanklen);
	}
  
	/* POSITION specifier */

	if (a->inposit != NULL) {	/* Fortran 90 position control */
		if (opened && p->useq) {
			switch (p->uposition) {
				case OS_REWIND:
					s	= "REWIND";
					break;
				case OS_ASIS:
					s	= "ASIS";
					break;
				case OS_APPEND:
					s	= "APPEND";
					break;
				case 0:
					s	= "UNKNOWN";
					break;
				default:
					_ferr(css, FEINTUNK);
			}
		}
		else
			s	= "UNDEFINED";
		_b_char(s, a->inposit, a->inpositlen);
	}

	/* ACTION specifier */

	if (a->inaction != NULL) { 	/* Fortran 90 action control */
		if (opened) {
			switch (p->uaction) {
				case OS_READWRITE:
					s	= "READWRITE";
					break;
				case OS_READ:
					s	= "READ";
					break;
				case OS_WRITE:
					s	= "WRITE";
					break;
				default:
					_ferr(css, FEINTUNK);
			}
		}
		else	/* for an unconnected file */
			s	= "UNDEFINED";
		_b_char(s, a->inaction, a->inactonlen);
	}

	/* READ specifier */

	if (a->inread != NULL) {	/* Fortran 90 read action control */
		if (opened) {
			if ((p->uaction == OS_READ) ||
			    (p->uaction == OS_READWRITE))
				s	= "YES";
			else
				s	= "NO";
		}
		else
			s	= "UNKNOWN";
		_b_char(s, a->inread, a->inreadlen);
	}

	/* WRITE specifier */

	if (a->inwrite != NULL) {	/* Fortran 90 write action control */
		if (opened) {
			if ((p->uaction == OS_WRITE) ||
			    (p->uaction == OS_READWRITE))
				s	= "YES";
			else
				s	= "NO";
		}
		else
			s	= "UNKNOWN";
		_b_char(s, a->inwrite, a->inwritelen);
	}

	/* READWRITE specifier */

	if (a->inredwrit != NULL) {  /* Fortran 90 read/write action control */
		if (opened) {
			if (p->uaction == OS_READWRITE)
				s	= "YES";
			else
				s	= "NO";
		}
		else
			s	= "UNKNOWN";
		_b_char(s, a->inredwrit, a->inrdwrtlen);
	}

	/* DELIM specifier */

	if (a->indelim != NULL) { /* Fortran 90 delim control */
		if (opened && p->ufmt) {	/* if formatted */
			switch (p->udelim) {
				case OS_NONE:
					s	= "NONE";
					break;
				case OS_QUOTE:
					s	= "QUOTE";
					break;
				case OS_APOSTROPHE:
					s	= "APOSTROPHE";
					break;
				default:
					_ferr(css, FEINTUNK);
			}
		}
		else   /* UNDEFINED for unformatted or unconnected file */
			s	= "UNDEFINED";
		_b_char(s, a->indelim, a->indelimlen);
	}

	/* PAD specifier */

	if (a->inpad != NULL) {  /* Fortran 90 pad control */
		if(opened && p->ufmt) { 	/* if formatted */
			switch (p->upad) {
				case OS_YES:
					s	= "YES";
					break;
				case OS_NO:
					s	= "NO";
					break;
				default:
					_ferr(css, FEINTUNK);
			}
		}
		else /* Fortran 90 missed UNDEFINED if unformatted or unconnected */
			s	= "YES";   /* set to YES instead of UNDEFINED */
		_b_char(s, a->inpad, a->inpadlen);
	}

/*
 *	Unlock the unit if we have a pointer to an open unit.   Note that
 *	$INQ/_INQUIRE never unlocks the unit.
 */
out_of_here:

	OPENUNLOCK();

	if (p != NULL)
		_release_cup(p);	/* unlock the unit */

	free(buf);
	return(errn);
}
Exemple #2
0
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 */

	if (OPEN_UPTR(cup) &&
	    (_fcdtocp(file) == NULL || (cup->ufnm != NULL &&
	     strncmp(cup->ufnm, a.ofile, a.ofilelen) == 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));
}