MODULE XPMSG (	IDENT = 'X00.24'		%TITLE 'XPO$MESSAGE - XPORT Message Router'
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		%BLISS36( ,ENTRY( XPO$MESSAGE ),OTS='' )
		) =
BEGIN

!
!			  COPYRIGHT (c) 1980 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
! ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
! COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
! AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!

!++
!
! FACILITY:  BLISS Library
!
! ABSTRACT:
!
!	This module is the XPORT message router.
!
! ENVIRONMENT:  User Mode
!
! AUTHOR:  Ward Clark,	CREATION DATE:  12 December 1978
!
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
    XPO$MESSAGE :  FORTRAN_FUNC;			! XPORT message router

!
! INCLUDE FILES:
!

LIBRARY  'XPORT' ;					! Public XPORT control block and macro definitions
LIBRARY  'XPOSYS' ;					! Internal XPORT macro definitions

    $XPO_SYS_TEST( $TOPS10, $TOPS20, $VMS, $11M, $IAS, $RSTS, $RT11 )

%IF $VMS %THEN
REQUIRE  'XVMS' ;					! XPORT-specific VAX/VMS interface definitions
%FI

%IF $11M %THEN
REQUIRE  'XRSX' ;					! XPORT-specific RSX-11 and FCS-11 interface definitions
%FI

%IF $RSTS %THEN
REQUIRE  'XRSTS' ;					! RSTS/E system interface definitions
%FI

%IF $RT11 %THEN
REQUIRE  'XRT11' ;					! RT-11 system interface definitions
%FI

!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

!
! PSECT DECLARATIONS:
!

    $XPO_PSECTS						! Declare XPORT PSECT names and attributes

!
! OWN STORAGE:
!

!
! EXTERNAL REFERENCES:
!

%IF $TOPS10 OR $TOPS20 %THEN
EXTERNAL
    XPO$ERROR_IOB :  $XPO_IOB();			! IOB for standard error message output
%FI

%IF $VMS %THEN
UNDECLARE XPO$_BAD_LOGIC;
EXTERNAL LITERAL
    XPO$_BAD_LOGIC;					! Force autocall of XMSGPTR.OBJ during link.
EXTERNAL ROUTINE
    LIB$SIGNAL : ADDRESSING_MODE(GENERAL);		! VAX/VMS library SIGNAL routine
%ELSE
EXTERNAL ROUTINE
    XPO$XMSG;						! XPORT message retrieval routine
%FI

%IF $11M %THEN
EXTERNAL
    XRSX$TI0_LUN,					! LUN for user's terminal
    XRSX$EVENT_FLAG;					! XPORT event flag number
%FI

GLOBAL ROUTINE XPO$MESSAGE( expl_severity, success_action, failure_action ) :  FORTRAN_FUNC =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine sends a single-line or multiple-line message to
!	the standard XPORT output and error device(s).
!
! FORMAL PARAMETERS:
!
!	expl_severity - explicit message severity code
!	success_action - address of success action routine
!	failure_action - address of failure action routine
!
!	pair(s) of message arguments (code, value)
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! COMPLETION CODES:
!
!	XPO$_NORMAL - message(s) successfully sent
!
!	XPO$_BAD_ARGS - invalid argument list
!	STR$_BAD_SOURCE - invalid message string descriptor
!			( secondary = failure completion code from $STR_VALIDATE )
!	failure completion code from $XPO_PUT (except VAX/VMS)
!	failure completion code from $XPO_GET_MEM (VMS)
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    BUILTIN						! Declare necessary builtin functions:
	ACTUALCOUNT,					!    number of arguments
	ACTUALPARAMETER;				!    single parameter value fetch

    LITERAL
	fixed_numb_args = 3,				! Number of fixed arguments (see above)
	max_message = 132;				! Maximum length of a message.

    LOCAL
	actual_severity;				! message sequence severity code

%IF $VMS %THEN
    LOCAL
	signal_arg_desc :				! SIGNAL argument list descriptor
	    $XPO_DESCRIPTOR( CLASS = DYNAMIC );
%FI

!
! XPORT routine initialization.
!

    $XPO_MAIN_BEGIN( PUT_MSG )				! Define the MAIN_BLOCK code block.

    actual_severity = .expl_severity;			! Assume that the caller provided an explicit severity code.

!
! Validate the routine argument list.
!

							! The argument list is invalid if one or more
							! of the following conditions exist:
    IF ACTUALCOUNT() LSS fixed_numb_args+2 OR		!    less than minimum number of arguments
	NOT ACTUALCOUNT() OR				!    there are an even number of arguments
	.expl_severity GTR XPO$_FATAL			!    the severity value is too large
    THEN
	$XPO_QUIT( BAD_ARGS );				! Return an error code if the argument list is bad.

!+
!
!	System-specific message processing follows.
!
!-

%TITLE 'VAX/VMS Message Processing'
%IF $VMS %THEN

!+
!
!	VAX/VMS Message Processing
!
!-

    BEGIN

    LITERAL
	args_per_line = 3,				! Maximum number of SIGNAL arguments per single message
	xpo$_text = SHR$_TEXT + XPO$K_VMS_CODE^16;	! ASCII string message code

    BUILTIN
	CALLG;						! CALLG needed for out-of-line argument list

!
! Allocate and initialize a SIGNAL argument list (vector) in dynamic memory.
!

    $STR_DESC_INIT( DESCRIPTOR = signal_arg_desc,	! Initialize the argument list descriptor.
		    CLASS = DYNAMIC );

    $XPO_IF_NOT( $XPO_GET_MEM(				! Allocate and initialize dynamic memory for the argument list.
			FULLWORDS = 1 + args_per_line * ( ( ACTUALCOUNT()-3 ) / 2 ),
			DESCRIPTOR = signal_arg_desc,
			FILL = 0,
			FAILURE = 0 ) )
    THEN
	$XPO_QUIT( (.$XPO_STATUS) );

    BEGIN
    BIND signal_argument =				! Declare the allocated argument list
	    .signal_arg_desc[XPO$A_ADDRESS] :  VECTOR;

!
! Process the messages one at a time.
!

    INCR argument_index					! Loop until all message arguments have been processed.
	FROM fixed_numb_args+1 TO ACTUALCOUNT() BY 2 DO
	BEGIN

!
! Select appropriate argument processing.
!

	CASE ACTUALPARAMETER(.argument_index)		! Use the argument code to select appropriate setup.
	    FROM XPO$K_PUT_COD
		TO XPO$K_PUT_STR OF
	    SET

	    [ XPO$K_PUT_STR ] :				! STRING= argument setup
		BEGIN
		IF .actual_severity EQL XPO$_NO_SEV
		THEN
		    actual_severity = XPO$_ERROR;

		$STR_VALIDATE(				! Validate the caller's string descriptor.
			ACTUALPARAMETER( .argument_index + 1 ),
			BAD_SOURCE );

								! Add arguments to the end of the argument list:
		signal_argument[ .signal_argument[0] + 1 ] =	!    XPORT general message code
			xpo$_text + .actual_severity;		!
		signal_argument[ .signal_argument[0] + 2 ] = 1;	!    number of FAO arguments
		signal_argument[ .signal_argument[0] + 3 ] =	!    address of caller's string descriptor
			ACTUALPARAMETER( .argument_index + 1 );

		signal_argument[0] =			! Increment the argument list length.
			.signal_argument[0] + 3;
		END;

	    [ XPO$K_PUT_COD ] :				! CODE= argument setup
		BEGIN
		LOCAL message_code;
		message_code = ACTUALPARAMETER(.argument_index+1);

		IF .message_code NEQ 0
		THEN
		    BEGIN
		    IF .signal_argument[0] EQL 0	! Setup severity of initial message.
		    THEN
			IF .actual_severity EQL XPO$_NO_SEV
			THEN
			    actual_severity = .message_code<0,3>
			ELSE
			    message_code<0,3> = .actual_severity;

								! Add arguments to the end of the argument list:
		    signal_argument[.signal_argument[0]+1] =	!    caller's message code
				.message_code;			!	followed by a zero FAO count

		    signal_argument[0] =		! Increment the argument list length.
			.signal_argument[0] + 2;
		    END;
		END;

	    [ OUTRANGE ] :				! Invalid argument code
		$XPO_QUIT( BAD_ARGS );

	    TES;

	END;						! End of argument processing loop

!
! Use VAX/VMS SIGNAL to send the final message sequence to the user.
!

    CALLG( signal_argument, LIB$SIGNAL );

    primary_code = XPO$_NORMAL;				! Signalling always succeeds.

    END;						! End of "BIND" code block
    END;						! End of VAX/VMS code block

!
! Free the dynamic memory used by the signal argument list.
!

    $XPO_MAIN_END;					! Terminate MAIN_BLOCK.

    $XPO_FREE_MEM( BINARY_DATA = signal_arg_desc,
		    FAILURE = 0 );

!+
!
!	End of VAX/VMS Message Processing
!
!-

%FI

%TITLE 'Non-VMS Message Processing'
%IF NOT $VMS %THEN

!+
!
!	Non-VMS Message Processing
!
!-

    BEGIN

%IF $RSTS %THEN
    LITERAL
    	numb_of_chars = 2;				! number of characters to be appended to the end of the buffer
%FI

%IF $RT11 %THEN
    LITERAL
    	numb_of_chars = 1;				! number of characters to be appended to the end of the buffer
%FI

        LOCAL
	message_buffer :				! message buffer
	    VECTOR[CH$ALLOCATION(max_message)],
	message_text :  REF $STR_DESCRIPTOR(),		! address of message text descriptor
	xport_text :  $STR_DESCRIPTOR(),		! space for XPO$XMSG to build a string descriptor
	total_message :					! total message descriptor
		$STR_DESCRIPTOR( CLASS = BOUNDED );

    $STR_DESC_INIT( DESCRIPTOR = total_message,		! Initialize the total message descriptor.
		CLASS = BOUNDED,
		STRING = ( max_message, CH$PTR(message_buffer) ) );

!
! Open the user message file IOB if this is the first message.
!

%IF $TOPS10 OR $TOPS20 %THEN
    IF NOT .XPO$ERROR_IOB[IOB$V_OPEN]			! If the error message IOB has not been opened,
    THEN						!
	IF NOT $XPO_OPEN( IOB = XPO$ERROR_IOB,		! open the error message file for output.
			FILE_SPEC = $XPO_ERROR,
			OPTIONS = OUTPUT,
			FAILURE = 0 )
	THEN
	    $XPO_QUIT( (.XPO$ERROR_IOB[IOB$G_COMP_CODE]) );
%FI

%IF $11M %THEN
    ALUN$S( .XRSX$TI0_LUN,				! Assign the user terminal LUN.
	    %EXACTSTRING( 2, 0, $XPO_INPUT ),
	    0 );
%FI

!
! Process the messages one at a time.
!

    INCR argument_index					! Loop until all messages have been sent.
	FROM fixed_numb_args+1 TO ACTUALCOUNT() BY 2 DO
	BEGIN

!
! Select appropriate argument processing.
!

	CASE ACTUALPARAMETER(.argument_index)		! Use the argument code to select appropriate setup.
	    FROM XPO$K_PUT_COD
		TO XPO$K_PUT_STR OF
	    SET

	    [ XPO$K_PUT_STR ] :				! STRING= argument setup
		BEGIN
		IF .actual_severity EQL XPO$_NO_SEV
		THEN
		    actual_severity = XPO$_ERROR;

		$STR_VALIDATE(				! Validate the caller's string descriptor.
			ACTUALPARAMETER( .argument_index + 1 ),
			BAD_SOURCE );

		message_text = ACTUALPARAMETER( .argument_index + 1 );
		END;

	    [ XPO$K_PUT_COD ] :				! CODE= argument setup
		IF ACTUALPARAMETER(.argument_index+1) EQL 0
		THEN
		    message_text = 0
		ELSE
		    BEGIN
		    IF .actual_severity EQL XPO$_NO_SEV
		    THEN
			actual_severity = ACTUALPARAMETER(.argument_index+1) AND 7;

		    XPO$XMSG( ACTUALPARAMETER(.argument_index+1), xport_text );
		    message_text = xport_text;
		    END;

	    [ OUTRANGE ] :				! Invalid argument code
		$XPO_QUIT( BAD_ARGS );

	    TES;

!
! Setup the message prefix.
!

	IF .message_text NEQ 0				! Bypass CODE=0 message argument.
	THEN
	    BEGIN
	    IF .argument_index EQL 4			! If this is the first message of a sequence,
	    THEN					! select an appropriate message prefix
		IF .actual_severity GEQ XPO$_ERROR	! based on the severity of the 1st message.
		THEN
		    $STR_COPY( STRING = '? ', TARGET = total_message, FAILURE = 0 )
		ELSE
		    $STR_COPY( STRING = '% ', TARGET = total_message, FAILURE = 0 )

	    ELSE					! Otherwise, use a hyphen and spaces.
		$STR_COPY( STRING = '-     ', TARGET = total_message, FAILURE = 0 );

%IF $RSTS OR $RT11 %THEN
!
! Specific control characters must appear at the end of the buffer.
!

    	    IF .total_message[STR$H_MAXLEN] -			! If there is no room in the buffer for the control characters, 
    			.total_message[STR$H_LENGTH] LSS	!
    		.message_text[STR$H_LENGTH] + numb_of_chars	!
    	    THEN						!
    		message_text[STR$H_LENGTH]=			! change the length of the message to allow for these characters.
    		    .total_message[STR$H_MAXLEN] - 
    			.total_message[STR$H_LENGTH] - numb_of_chars;
%FI

!
! Add the actual message text to the buffer.
!

	    $STR_APPEND( STRING = .message_text, TARGET = total_message, OPTION = TRUNCATE, FAILURE = 0 );

!
! Send a single message to the user.
!

%IF $TOPS10 OR $TOPS20 %THEN
	    primary_code =				! Send a single message to the user.
		$XPO_PUT( IOB = XPO$ERROR_IOB,
			STRING = total_message,
			FAILURE = 0 );
%FI

%IF $11M %THEN
	    BEGIN
	    LOCAL status :  $QIO_STATUS;

	    QIOW$S( IO$WVB, .XRSX$TI0_LUN,		! Send the message to the user's terminal.
			.XRSX$EVENT_FLAG,,
			status,,
			< .total_message[STR$A_POINTER],
			    .total_message[STR$H_LENGTH],
			    %O'040' > );

	    primary_code = XPO$_NORMAL;
	    END;
%FI

%IF $RSTS %THEN
    	    $STR_APPEND( STRING = %STRING( %CHAR(cr), %CHAR(lf) ),
    			 TARGET = total_message, FAILURE = 0 );

    	    $XRSTS_INI_FIRQB;				! Initialize the FIRQB.
    	    $XRSTS_INI_XRB;				! Initialize the XRB.
    							! Setup the XRB:
    	    $XRSTS_XRB[XRLEN] =				!    length of output buffer
    			 .total_message[STR$H_LENGTH];	!
    	    $XRSTS_XRB[XRBC] =				!    number of bytes to be written
    			 .total_message[STR$H_LENGTH];	!
    	    $XRSTS_XRB[XRLOC] =				!    starting address of buffer
    			.total_message[STR$A_POINTER];	!
    	    $XRSTS_XRB[XRCI] = 0;			!    channel number times 2 (user's terminal is always 0)

    	    $WRITE;					! Output the message to the user's terminal.

    	    primary_code = XPO$_NORMAL;
%FI

%IF $RT11 %THEN
    	    $STR_APPEND( STRING = %CHAR(null),		! Append a null to the message to automatically get a crlf.
    			 TARGET = total_message, FAILURE = 0 );

    	    $PRINT( .total_message[STR$A_POINTER] );	! Send the message to the user's terminal.

    	    primary_code = XPO$_NORMAL;
%FI

	    END;

	END;						! End of message processing loop
    END;						! End of Non-VMS code block

    $XPO_MAIN_END;					! Terminate MAIN_BLOCK.

!+
!
!	End of Non-VMS message processing
!
!-

%FI

%TITLE 'XPO$MESSAGE Routine Termination'

!+
!
!	XPO$MESSAGE Routine Termination
!
!-

!
! Call an appropriate action routine.
!

    $XPO_ACTION_RTN( actual_severity );			! Call a success or failure action routine.

!
! Terminate program execution on fatal errors.
!

    IF .actual_severity EQL XPO$_FATAL			! If the message severity is FATAL,
    THEN						!
	$XPO_TERMINATE();				! terminate program execution.

!
! Return the final completion code to the caller.
!

    RETURN .primary_code				! Return to the caller.

    END;
END
ELUDOM