MODULE SJOIN (	IDENT = 'X00.06'	%TITLE 'XST$JOIN - ASCII String Concatenation'
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		%BLISS36( ,ENTRY( XST$JOIN ), 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 implements the XPORT $STR_CONCAT string pseudo-function.
!
! ENVIRONMENT:  User mode - multiple host operating/file systems
!
! AUTHOR:  Ward Clark,	CREATION DATE:  25 February 1980
!
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
    XST$JOIN :  FORTRAN_FUNC;				! ASCII string concatenation routine

!
! INCLUDE FILES:
!

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

    $XPO_SYS_TEST( $ALL )

!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

!
! PSECT DECLARATIONS:
!

    $XPO_PSECTS						! Declare XPORT PSECT names and attributes

!
! OWN STORAGE:
!

!
! EXTERNAL REFERENCES:
!

GLOBAL ROUTINE XST$JOIN :  FORTRAN_FUNC =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine implements the $STR_CONCAT string pseudo-function.
!
! FORMAL PARAMETERS:
!
!	list of string descriptor addresses
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	address of an XPORT temporary string descriptor
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    BUILTIN
	ACTUALCOUNT,					! Number of routine arguments
	ACTUALPARAMETER;				! Argument fetch function

    LOCAL
	concat_length,
	temporary :  REF $STR_DESCRIPTOR( CLASS = DYNAMIC ),
	result_pointer;

!
! Initialization
!

    $STR_MAIN_BEGIN( PSEUDO )				! Beginning of MAIN_BLOCK code block

    IF ACTUALCOUNT() EQL 1				! If only 1 string was specified,
    THEN						! a temporary string is not needed.
	BEGIN
	temporary = ACTUALPARAMETER( 1 );
	$STR_QUIT( NORMAL );
	END;

    $STR_ALLOC_TEMP( temporary );			! Setup an XPORT temporary string descriptor.

! Validate the number of string descriptor arguments.

    IF ACTUALCOUNT() EQL 0				! Make sure at least one string was specified.
    THEN
	$STR_QUIT( (XPO$_BAD_ARGS) );

!
! Calculate the resulting string length.
!

    concat_length = 0;

    INCR index FROM 1 TO ACTUALCOUNT() DO		! Loop thru the argument list.
	BEGIN
	BIND
	    string = ACTUALPARAMETER( .index ) :  $STR_DESCRIPTOR();

	$STR_VALIDATE( string, BAD_SOURCE );

	IF .string[STR$H_LENGTH] GTRU			! Make sure the resulting string will not be too long.
		%X'FFFF' - .concat_length
	THEN
	    $STR_QUIT( TOO_LONG );

	concat_length = .concat_length + .string[STR$H_LENGTH];
	END;

!
! Allocate a resulting string in dynamic memory.
!

    $XPO_IF_NOT( $XPO_GET_MEM( CHARACTERS = .concat_length,
			    DESCRIPTOR = .temporary,
			    FAILURE = 0 ) )
    THEN
	$STR_QUIT( (.$XPO_STATUS) );

!
! Copy the source strings into the resulting area.
!

    result_pointer = .temporary[STR$A_POINTER];		! Point to the beginning of the result area.

    INCR index FROM 1 TO ACTUALCOUNT() DO		! Copy 1 string at a time into the result area.
	BEGIN
	BIND
	    string = ACTUALPARAMETER( .index ) :  $STR_DESCRIPTOR();

	CH$MOVE( .string[STR$H_LENGTH], .string[STR$A_POINTER], .result_pointer );

	result_pointer = CH$PLUS( .result_pointer, .string[STR$H_LENGTH] );
	END;

    $STR_QUIT( NORMAL );

    $STR_MAIN_END;					! End of MAIN_BLOCK code block

!
! Free any XPORT temporary strings input to this concatenation function.
!

    INCR index FROM 1 TO ACTUALCOUNT() DO		! Free 1 string at a time.
	$STR_FREE_TEMP( ACTUALPARAMETER( .index ) );

!
! Modify the temporary string descriptor in the event of an error.
!

    IF NOT .primary_code				! If the conversion failed,
    THEN						!
	BEGIN						! modify the temporary string descriptor:
	temporary[STR$B_DTYPE] = STR$K_DTYPE_XXX;	!    indicate an erroneous temporary string
	temporary[STR$A_POINTER] = .primary_code;	!    save the error code for $STR_VALIDATE
	END;

!
! Return the address of the temporary string descriptor.
!

    RETURN .temporary

    END;
END
ELUDOM