C*****************************************************************************
C
C		Common Library Routines Supporting Syslib Test
C			   To be included into TSTLIB
C
C-----------------------------------------------------------------------------
C
C Program	: Common Routines/ Commn.For
C Author	: John Malcolmson
C Date		: June/July 1986
C Language	: Fortran 77
C Notes		: none.
C Revised	: 4-May-89, added new environment functions
C		  9-Aug-89, added new CHECK2 and CHECKX routines
C
C*****************************************************************************

C------------------------------- TestFail ------------------------------------
C
C   Displays a message indicating if the test of a syslib routine succeeded
C	or failed.
C=============================================================================

	Subroutine TestFail( value )

		Integer*4	value

		IF ( value .eq. 0 ) THEN
			Call CenterString( '=== Success ===\' )
		ELSE
			Call CenterString( '*** Failure ***\' )
		END IF
		Call WriteLn
	END

C-------------------------------- RsltFail -----------------------------------
C
C    This is used to display informational messages about a result code that
C	was not expected.
C=============================================================================

	Subroutine RsltFail( value )

		Integer*2	value

		Call WriteString( 'Failed result code on pass \',    0, 0 )
		Call Write2Int( value, 2 )
		Call WriteString( '. -- Expected/Actual =>      \',  0, 0 )

	END

C-------------------------------- IRsltFail ----------------------------------
C
C   This performs the same as RsltFail except this routine also leaves room
C	for an index value to also be printed out.
C=============================================================================

	Subroutine IRsltFail( value )

		Integer*2	value

		Call WriteString( 'Failed result code on pass \', 0, 0 )
		Call Write2Int( value, 2 )
		Call WriteString( '. -- Indx/Expct/Actl =>\',     0, 0 )

	END

C---------------------------------- IMtFail ----------------------------------
C
C   This allows the printing of uniform informational messages.  Leaving
C	room for both an index and expected / actual values.
C=============================================================================

	Subroutine IMtFail( str, value )

		Integer*2	value
		Byte		Str(6)

		Call WriteString( 'Failed \',                     0,  7 )
		Call WriteString( Str, 0, 6 )
		Call WriteString( ' test on pass \',              0, 14 )
		Call Write2Int( value, 2 )
		Call WriteString( '. -- Indx/Expct/Actl =>\',     0, 0 )

	END

C---------------------------------- MtFail -----------------------------------
C
C   This is the same routine as IMtfail except is does not ask for an index
C	value to be supplied.
C=============================================================================

	Subroutine MtFail( str, value )

		Integer*2	value
		Byte		Str(6)

		Call WriteString( 'Failed \',                       0,  7 )
		Call WriteString( Str, 0, 6 )
		Call WriteString( ' test on pass \',                0, 14 )
		Call Write2Int( value, 2 )
		Call WriteString( '. -- Expected/Actual =>      \', 0,  0 )

	END

C---------------------------------- Check2 -----------------------------------
C  Check_for RESULT_EQUAL:
C  This function simplifies the use of MTFAIL by performing a commonly
C  used sequence of checking and displaying operations.
C=============================================================================

	Logical*2 Function Check2( descrp, pass, fword, expect, 
     1				result, status)
c
	byte descrp(1)			! test description
	integer*2 pass			! which pass this is
	byte fword(1)			! short failure string
	integer*2 expect		! expected value
	integer*2 result		! the actual returned value
	integer*4 status		! status-bit double-word
	logical*2 CheckX		! slave function

c  Transform the Check2 call to a CheckX call.

	Check2 = CheckX( descrp, pass, fword, expect, expect, 
     1			result, 'EQ', status)
	Return

	End

C---------------------------------- CheckX -----------------------------------
C  Check RESULT against ACTUAL:
C  This function simplifies the use of MTFAIL by performing a commonly
C  used sequence of checking and displaying operations.
C=============================================================================

	Logical*2 Function CheckX( descrp, pass, fword, expect, tesval,
     1					result, relate, status)
c
	byte descrp(1)			! Test description
	integer*2 pass			! which pass this is
	byte fword(1)			! short failure string
	integer*2 expect		! expected value
	integer*2 tesval		! test value
	integer*2 result		! the actual returned value
	integer*2 relate		! 2-character relationship code
	integer*4 status		! status-bit double-word

	Logical*2 condition		! local reduction of test

	condition = .FALSE.		! default is failure
	if (relate .eq. 'EQ') condition = (result .EQ. tesval)
	if (relate .eq. 'NE') condition = (result .NE. tesval)
	if (relate .eq. 'LT') condition = (result .LT. tesval)
	if (relate .eq. 'GT') condition = (result .GT. tesval)

	IF ( condition ) THEN
		IF (descrp(1) .ne. '\' .and. descrp(1) .ne. 0)
	1		Call Correct( descrp)
	ELSE
		Call MtFail( fword, pass )
		Call Write2Int( expect,  10 )
		Call Write2Int( result, 10 )
		Call WriteLn
		status = status .or. 2**pass
	ENDIF
	CheckX = condition
	Return

	End

C================================= Fallt =====================================
C
C This routine is used to determine faults in lookups and ienters.
C-----------------------------------------------------------------------------

	Subroutine Fallt( res, str )
		Integer*2	res
		Byte		str(40)

		IF (res .lt. 0) THEN
			Call CenterString( str )
			Call WriteLn
		END IF

	END

C=============================================================================

C-------------------------------- REPORT ------------------------------------)
C
C   The Report routine is call by the test controllers to give a complete
C   	accounting of the passes which failed under each syslib call.
C============================================================================)

	Function Report( status, strn, len )

		Integer*4	Report
		Integer*4 	status( len )
		Character*6	strn(   len )
		Integer*4	x, count
		Integer*2	err, i, j, k
		Integer*2	pass( 32 )
		Logical*2	Bitst4
		
		x      = 0
		Report = 0
		DO 5 i = 1, len

			x = x + status( i )

5		Continue

		IF (x .eq. 0) THEN
			Call CenterString( '<--- There were no errors encountered --->\' )
			Call WriteLn
			RETURN
		END IF

		Count = 0

		DO 30 k = 1, len
		
			IF (status(k) .ne. 0) THEN

			        j = 1
				DO 10 i = 1, 31

				    IF (Bitst4(Status(k),i).eq..TRUE.) THEN
					pass(j) = i
				        j       = j + 1
				    END IF

10			    	Continue

				Report = Report + 1
				Call WriteString( strn(k), 0, 6 )
				Call WriteString( ' failed pass(es) : \',0,0)
				DO 20 i = 1, j-1
					Count = Count + 1
					Call Write2Int( pass(i), 3 )
20				Continue
				Call WriteString( '.\', 0, 0 )
				Call WriteLn

			END IF

30		Continue

		Report = Report + ( Count * 1000 )
		Return

	END

C----------------------------------------------------------------------------)

C------------------------------- YnQuery ------------------------------------)
C
C   Prompts for a yes/no answer and returns a boolean reflecting the response
C============================================================================)

	Logical*2 Function YnQuery( text )

		Character*5	inp
		Byte		text(50)
		Integer*2	Slen

		Text(Slen( text ) + 1 ) = "200
		Call GtLin( inp, text )
		
		IF ((inp(1:1) .eq. 'n').or.(inp(1:1) .eq. 'N')) THEN
			YnQuery = .FALSE.
		ELSE
			YnQuery = .TRUE.
		END IF

		RETURN

	END

C----------------------------------------------------------------------------)

C------------------------------- MtQuery ------------------------------------)
C
C   The sames as YnQuery except this works with multi-terminals.        
C============================================================================)

	Logical*2 Function MtQuery( trm, text )

		Byte		text(50), inp(10)
		Integer*2	trm, Slen, i

		Text(Slen(Text)+1) = "200
		Call MtPrnt( trm, Text )
		DO 10 i = 1, 10
			Call Mtin( trm, inp(i))
			IF (inp(i) .eq. 13) Goto 100
10		Continue
100		Call Mtin( trm, inp(10))

		IF ((inp(1) .eq. 'n').or.(inp(1) .eq. 'N')) THEN
			MtQuery = .FALSE.
		ELSE
			MtQuery = .TRUE.
		END IF

		RETURN

	END

C----------------------------------------------------------------------------)

C-------------------------------- ENVIOR ------------------------------------)

C****************************************************************************)
C	This routine returns the following results:
C		0 - SJ monitor running
C		1 - FB monitor running (No XM Support)
C		2 - SJ monitor with XM support
C		3 - XM monitor with full job support
C		4 - Rtem monitor with SJ support
C		5 - Rtem with FB support
C		6 - Rtem with XM/SJ support
C		7 - Rtem with XM support
C****************************************************************************)

	Integer*2 Function Envior

		Envior = 0
 		Envior = Envior + IIAND(Ispy('300'O),1)			! FB
		Envior = Envior + IIAND(Ispy('300'O),2**12)/2**11	! XM
		Envior = Envior + IIAND(Ispy('372'O),2**3)		! RTEM

	END

C----------------------------------- SJ -------------------------------------)
C
C   This logical function returns TRUE if the current monitor is SJ.
C   Otherwise, it returns FALSE.
C
C----------------------------------------------------------------------------)
C
	Logical*2 Function SJ()
	Integer*2 ISPY
C
	SJ = (ISPY("300).and.1) .eq. 0
	Return
C
	End

C----------------------------------- XM -------------------------------------)
C
C   This logical function returns TRUE if the current monitor is XM.
C   Otherwise, it returns FALSE.
C
C----------------------------------------------------------------------------)
C
	Logical*2 Function XM()
	Logical*2 SJ
	Integer*2 ISPY
C
	XM = .Not.SJ() .and. ((ISPY("372).and.2) .ne. 0)
	Return
C
	End

C--------------------------------- SYTASK -----------------------------------)
C
C   This logical function returns TRUE if the current monitor supports system
C   tasks.  Otherwise, it returns FALSE.
C
C----------------------------------------------------------------------------)
C
	Logical*2 Function SYTASK()
	Logical*2 SJ
	Integer*2 ISPY
C
	SYTASK = .NOT.SJ() .and. ((ISPY("372).and."40000) .ne. 0)
	Return
C
	End

C---------------------------------- MTTY ------------------------------------)
C
C   This logical function returns TRUE if the current monitor supports 
C   Multi-terminal requests
C
C----------------------------------------------------------------------------)
C
	Logical*2 Function MTTY()
	Integer*2 ISPY
C
	MTTY = ((ISPY("372).and."20000) .ne. 0)
	Return
C
	End

C--------------------------------- SJTIMR ----------------------------------)
C
C   This logical function returns TRUE if the current monitor is SJ with
C   Timer support.  Otherwise, it returns FALSE.
C
C---------------------------------------------------------------------------)
C
	Logical*2 Function SJTIMR()
	Logical*2 SJ
	Integer*2 ISPY
C
	SJTIMR = SJ() .and. ((ISPY("372).and."2000) .ne. 0)
	Return
C
	End

C----------------------------------- RTEM -----------------------------------)
C
C   This routine returns TRUE if it is being run on RTEM.  Otherwise, it
C   returns .FALSE.
C
C----------------------------------------------------------------------------)

	Logical*2 Function RTEM()
C
	RTEM = ((ISPY("372).and."10) .ne. 0)
	Return
C
	End

C---------------------------------- BitTest ---------------------------------)
C
C   This tests a word for the presence of a specified bit and then returns a
C	boolean indicating the state of the bit.
C============================================================================)

	Logical*2 Function Bitst2( wrd, bt )

		Integer*2	wrd, owr, bt

		owr = IISHFT( wrd, -bt )
		IF (IIAND(owr,1) .eq. 0) THEN
			Bitst2 = .FALSE.
		ELSE
			Bitst2 = .TRUE.
		END IF
	
		Return

	END 

C----------------------------------------------------------------------------)

C---------------------------------- BitTest ---------------------------------)
C
C   Performs a bit test on word pairs.
C============================================================================)

	Logical*2 Function Bitst4( wrd, bt )

		Integer*2	wrd(2), bt
		Logical*2	Bitst2

		IF (bt .gt. 15) THEN
			Bitst4 = Bitst2(wrd(2),bt-16)
		ELSE
			Bitst4 = Bitst2(wrd(1),bt)
		END IF

		Return

	END