.TITLE	SHRFIL.MAC	88j20a		23-SEP-80/20-Oct-88.
	.ENABL	LC


;	Author:	N. A. Bourgeois, Jr.
;		NAB Software Services, Inc.
;		PO Box 20009
;		Albuquerque, NM 87154


;	The code and information in this software is subject to
;	change without notice and should not be construed as a
;	commitment by NAB Software Services, Inc.  NAB Software
;	Services,Inc. assumes no responsibility for any errors
;	that may appear in this software.
;
;
;				NOTICE
;
;	This software is sponsored by NAB Software Services, Inc.
;	Neither NAB Software Services, Inc., nor any of their
;	employees, nor any of their contractors, subcontractors,
;	or their employees makes any warranty, express or implied,
;	or assumes any legal liability or responsibility for the
;	accuracy, completeness or usefulness of any information,
;	apparatus, product or process disclosed, or represents
;	that its use would not infringe privately owned rights.


;	THIS SOFTWARE WAS ORIGINALLY ISSUED  BY  SANDIA  NATIONAL
;	LABORATORIES,  OPERATED  FOR THE UNITED STATES DEPARTMENT
;	OF ENERGY BY SANDIA CORPORATION.
;
;				NOTICE
;
;	THIS SOFTWARE WAS ORIGINALLY  SPONSORED  BY  THE  UNITED
;	STATES GOVERNMENT.  NEITHER THE UNITED STATES GOVERNMENT
;	NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR  ANY  OF
;	THEIR   EMPLOYEES,   NOR   ANY   OF  THEIR  CONTRACTORS,
;	SUBCONTRACTORS, OR THEIR EMPLOYEES MAKES  ANY  WARRANTY,
;	EXPRESS  OR  IMPLIED,  OR ASSUMES ANY LEGAL LIABILITY OR
;	RESPONSIBILITY  FOR  THE   ACCURACY,   COMPLETENESS   OR
;	USEFULNESS  OF  ANY  INFORMATION,  APPARATUS, PRODUCT OR
;	PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD  NOT
;	INFRINGE PRIVATELY OWNED RIGHTS.
;
;	THIS WORK WAS ORIGINALLY FUNDED BY:
;
;		    HEADQUARTERS, ESD / OCB / STOP 36
;		    HANSCOM AIR FORCE BASE, MA 01731


.SBTTL	EDIT RECORD			23-SEP-80/20-Oct-88.

;23-SEP-80	ORIGINAL CREATION.
;08-OCT-80	REVISED.
;25-MAR-81	CORRECTED ADDRESSING ERROR.
;09-APR-81	CHANGED THE FOLLOWING MODULE AND ROUTINE NAMES; "RCDLOK"
;		 TO "SHRFIL", "DCLRSF" TO "IDCLSF" AND "UNLBLK" TO "IUALBK".
;		 ADDED THE FOLLOWING NEW ROUTINES; "IULSPBK", "ICKWTS" AND
;		 "ISVST".  MADE CODE REENTRANT.
;14-APR-81	"ERRBYT" WAS 53.
;16-JUN-81	CORRECTED COMMENT ON THE ICKWTS ROUTINE.
;26-FEB-82	ADDED IDENTIFICATION CODE.
;06-Jan-84	Maintenance assumed by NAB Software Services, Inc.
;03-Oct-84	Minor revision for V5.1.
;26-Feb-86	Revised for V6.0.  Changed IDCLSF, ICKWTS, IUALBK, IUSPBK,
;		 and LKBLK descriptions and routines.  Added DOIT2 and
;		 DOIT3 subroutines.
;26-Mar-87	Revised for V6.2.  Added NAB Software disclaimer.
;20-Oct-88	Revised DOIT, DOIT1, DOIT2, and DOIT3 routines per information
;		 furnished by K. P. Schneider, Perkin-Elmer Censor, Vaduz,
;		 Lietchenstein.
.PAGE
.SBTTL	DESCRIPTION			23-SEP-80/26-Feb-86.

;THIS MODULE CONTAINS SHARED FILE SUPPORT ROUTINES THAT ARE CALLABLE
;SUBROUTINES.  SOME OF THEM ARE ALSO CALLABLE AS FUNCTIONS.  THIS
;MODULE IS A PART OF THE LIBRARY OF FORTRAN CALLABLE TSX/TSX-PLUS
;EMT ROUTINES.

;DECALARE AN OPEN FILE TO BE SHARED.
;
;CALLING SEQUENCES:
;
;	CALL IDCLSF ( ICHAN ,IACES [ ,IERR ] )
;			OR
;	IERR = IDCLSF ( ICHAN ,IACES )
;
;	WHERE:	IACES	IS ONE OF THE FOLLOWING CODES:
;
;		CODE	PROTECTION	ACCESS
;
;		0	EXCLUSIVE	INPUT
;
;		1	EXCLUSIVE	UPDATE
;
;		2	PROTECTED	INPUT
;
;		3	PROTECTED	UPDATE
;
;		4	SHARED		INPUT
;
;		5	SHARED		UPDATE
;
;		IERR	IS negative or ONE OF THE FOLLOWING:
;
;			0	job does not have RLOCK =privilege.
;
;			1	CHANNEL HAS NOT BEEN OPENED AS A FILE.
;
;			2	TOO MANY CHANNELS OPENED TO SHARED
;				FILES.
;
;			3	TOO MANY SHARED FILES OPENED.
;
;			4	FILE PROTECTION/ACCESS CONFLICT.

;LOCK A BLOCK, WAIT IF ALREADY LOCKED.
;
;CALLING SEQUENCES:
;
;	CALL LKBLKW ( ICHAN ,IBLOCK [ ,IERR ] )
;			OR
;	IERR = LKBLKW ( ICHAN ,IBLOCK )
;
;	WHERE:	IERR	IS negative or ONE OF THE FOLLOWING:
;
;			0	job does not have RLOCK privilege or
;				 system does not include shared file
;				 support.
;
;			1	CHANNEL IS NOT OPEN TO A SHARED FILE.
;
;			2	REQUEST TO LOCK TOO MANY BLOCKS IN
;				FILE.

;LOCK A BLOCK, RETURN IF ALREADY LOCKED.
;
;CALLING SEQUENCES:
;
;	CALL LKBLK ( ICHAN ,IBLOCK [ ,IERR ] )
;			OR
;	IERR = LKBLK ( ICHAN ,IBLOCK )
;
;	WHERE:	IERR	IS negative or ONE OF THE FOLLOWING:
;
;			0	job does not have RLOCK privilege or
;				 system does not include shared file
;				 support.
;
;			1	CHANNEL IS NOT OPENED TO A SHARED
;				FILE.
;
;			2	REQUEST TO LOCK TOO MANY BLOCKS IN
;				FILE.
;
;			3	REQUESTED BLOCK IS LOCKED BY ANOTHER
;				JOB.

;UNLOCK A SPECIFIC BLOCK.
;
;CALLING SEQUENCES:
;
;	CALL IUSPBK ( ICHAN ,IBLOCK [ ,IERR ] )
;			OR
;	IERR = IUSPBK ( ICHAN ,IBLOCK )
;
;	WHERE:	IERR	IS negative or ONE OF THE FOLLOWING:
;
;			0	the job does not have RLOCK privilege
;				or the system does not have shared file
;				support.
;
;			1	CHANNEL IS NOT OPENED TO A SHARED
;				FILE.

;UNLOCK ALL LOCKED BLOCKS.
;
;CALLING SEQUENCES:
;
;	CALL IUALBK ( ICHAN [ ,IERR ] )
;		OR
;	IERR = IUALBK ( ICHAN )
;
;	WHERE:	IERR	IS negative orONE OF THE FOLLOWING:
;
;			0	the job does not have RLOCK privilege.
;
;			1	CHANNEL IS NOT OPENED TO A SHARED
;				FILE.

;CHECK FOR WRITES TO A SHARED FILE.
;
;CALLING SEQUENCES:
;
;	CALL ICKWTS ( ICHAN [ ,IERR ] )
;		OR
;	IERR = ICKWTS ( ICHAN )
;
;	WHERE:	IERR	IS negative or ONE OF THE FOLLOWING:
;
;			0	shared file support not available, or
;				 channel not opened to a shared file,
;				 or no RLOCK privilege.
;
;			2	WRITES HAVE BEEN PERFORMED.

;SAVE THE STATUS OF A SHARED FILE CHANNEL.
;
;CALLING SEQUENCE:
;
;	CALL ISVST ( ICHAN )
.PAGE
.SBTTL	DIRECTIVES			23-SEP-80/20-Oct-88.

	.IDENT	\88j20a\	;TELL LINKER OUR VERSION
	.PSECT	TSXLIB,I
	.GLOBL	TSLBID
	.WORD	TSLBID
	.DSABL	GBL


.SBTTL	ASSIGNMENTS			23-SEP-80/26-Feb-86.

	ERRBYT	= 52		;ERROR CODE LOCATION
	NOERR	= -1		;code for no error
.PAGE
.SBTTL	ENTRY POINTS			23-SEP-80/26-Feb-86.

;DECLARE A FILE TO BE SHARED.
;
IDCLSF::MOV	#125	,R1		;EMT CODE
	JSR	PC	,DOIT3		;MAKE THE DECLARATION
	RTS	PC

;LOCK A BLOCK, WAIT IF ALREADY LOCKED.
;
LKBLKW::MOV	#102	,R1		;EMT CODE
	JSR	PC	,DOIT3		;LOCK THE BLOCK
	RTS	PC

;LOCK A BLOCK, RETURN IF ALREADY LOCKED.
;
LKBLK::	MOV	#103	,R1		;EMT CODE
	JSR	PC	,DOIT3		;TRY TO LOCK THE BLOCK
	RTS	PC

;UNLOCK A SPECIFIC BLOCK.
;
IUSPBK::MOV	#113	,R1		;EMT CODE
	JSR	PC	,DOIT3		;UNLOCK THE BLOCK
	RTS	PC

;UNLOCK ALL LOCKED BLOCKS.
;
IUALBK::MOV	#101	,R1		;EMT CODE
	JSR	PC	,DOIT2		;UNLOCK ALL BLOCKS
	RTS	PC

;CHECK FOR WRITES TO A SHARED FILE.
;
ICKWTS::MOV	#121	,R1		;EMT CODE
	JSR	PC	,DOIT2		;CHECK FOR WRITES
	RTS	PC

;SAVE THE STATUS OF A SHARED FILE CHANNEL.
;
ISVST::	MOV	#122	,R1		;EMT CODE
	JSR	PC	,DOIT1		;SAVE THE STATUS
	RTS	PC
.PAGE
.SBTTL	SUPPORTING SUBROUTINES		23-SEP-80/20-Oct-88.

DOIT:	MOV	@4(R5)	,-(SP)		;PASS ARGUMENT 2
	MOV	@2(R5)	,-(SP)		;PASS ARGUMENT 1 TO LO BYTE
	MOV	SP	,R0		;SET UP THE POINTER
	MOVB	R1	,1(R0)		;HI BYTE = EMT CODE
	EMT	375			;LET TSX DO IT
	CLR	R0			;GET THE
	MOVB	@#ERRBYT,R0		; ERROR CODE
	CMPB	#3	,(R5)		;SUBROUTINE ERROR RETURN?
	BNE	1$			; NO
	MOV	R0	,@6(R5)		; YES
1$:	CMP	(SP)+	,(SP)+		;FIX THE STACK POINTER
	RTS	PC

DOIT1:	MOV	@2(R5)	,-(SP)		;PASS ARGUMENT 1 TO LO BYTE
	MOV	SP	,R0		;SET UP THE POINTER
	MOVB	R1	,1(R0)		;LO BYTE = EMT CODE
	EMT	375			;LET TSX DO IT
	CLR	R0			;GET THE
	MOVB	@#ERRBYT,R0		; ERROR CODE
	CMPB	#2	,(R5)		;SUBROUTINE ERROR RETURN?
	BNE	1$			; NO
	MOV	R0	,@4(R5)		; YES
1$:	TST	(SP)+			;FIX THE STACK POINTER
	RTS	PC

DOIT2:	MOV	@2(R5)	,-(SP)		;pass argument 1 to low byte
	MOV	SP	,R0		;set up the pointer
	MOVB	R1	,1(R0)		;hi byte = EMT code
	MOV	#NOERR	,R1		;code for no error
	EMT	375			;let TSX do it
	BCC	1$			; if no error
	CLR	R1			; if error,
	MOVB	@#ERRBYT,R1		;  get the code
1$:	CMPB	#2	,(R5)		;subroutine error return?
	BNE	2$			; no
	MOV	R1	,@4(R5)		; yes
2$:	MOV	R1	,R0		;function error return
	TST	(SP)+			;fix the stack
	RETURN

DOIT3:	MOV	@4(R5)	,-(SP)		;pass argument two
	MOV	@2(R5)	,-(SP)		;pass argument one to lo byte
	MOV	SP	,R0		;set up the pointer
	MOVB	R1	,1(R0)		;hi byte = EMT code
	MOV	#NOERR	,R1		;code for no error
	EMT	375			;let TSX do it
	BCC	1$			; if no error
	CLR	R1			; if error,
	MOVB	@#ERRBYT,R1		;  get the code
1$:	CMPB	#3	,(R5)		;subroutine error return?
	BNE	2$			; no
	MOV	R1	,@6(R5)		; yes
2$:	MOV	R1	,R0		;function error return
	CMP	(SP)+	,(SP)+		;fix the stack pointer
	RETURN

.SBTTL	END				23-SEP-80/.

	.END