MODULE SAPPEN (	IDENT = 'V1.2-07'		%TITLE 'XST$APPEND - String Append Function'
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		%BLISS36( ,ENTRY( XST$APPEND ),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 $STR_APPEND function.
!
! ENVIRONMENT:  User mode - multiple host operating/file systems
!
! AUTHOR:  Ward Clark,	CREATION DATE:  27 February 1980
!
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
    XST$APPEND;						! BLISS string copy 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:
!

LITERAL
    db_allocate =					! Allocation increment for a DYNAMIC_BOUNDED string
	%BLISS16( 20 )  %BLISS32( 80 )  %BLISS36( 80 );

!
! PSECT DECLARATIONS:
!

    $XPO_PSECTS						! Declare XPORT PSECT names and attributes

!
! OWN STORAGE:
!

!
! EXTERNAL REFERENCES:
!

GLOBAL ROUTINE XST$APPEND( options, string, target, success_action, failure_action ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine implements the $STR_APPEND function.
!
! FORMAL PARAMETERS:
!
!	options - string processing options
!	string - address of the source string descriptor
!	target - address of the target string descriptor
!	success_action - address of a success action routine
!	failure_action - address of a failure action routine
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! COMPLETION CODES:  (secondary passed to action routine only)
!
!	STR$_NORMAL - string append was successful
!
!	STR$_BAD_SOURCE - invalid source string
!		secondary = failure completion code from $STR_VALIDATE
!	STR$_BAD_TARGET - invalid target string
!		secondary = failure completion code from $STR_VALIDATE
!			    or STR$_NO_SPACE - insufficient space
!	XPO$_FREE_MEM - dynamic memory deallocation error
!		secondary = failure completion code from $XPO_FREE_MEM
!	XPO$_GET_MEM - dynamic memory allocation error
!		secondary = failure completion code from $XPO_GET_MEM
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	options :  $STR_OPTIONS,
	string :  REF $STR_DESCRIPTOR(),
	target :  REF $STR_DESCRIPTOR( CLASS = BOUNDED );

    LOCAL
	string_length;

!
! Initialization
!

    $STR_MAIN_BEGIN( APPEND )				! Beginning of MAIN_BLOCK code block

    $STR_VALIDATE( .string, BAD_SOURCE );		! Validate the source and target string descriptors.
    $STR_VALIDATE( .target, BAD_TARGET );

    string_length = .string[STR$H_LENGTH];		! Save the original string length for potential upcasing.

!
! Select appropriate string append processing depending on the target descriptor class.
!

    SELECTONE .target[STR$B_CLASS] OF
	SET

%TITLE 'XST$APPEND - Append to FIXED or XPORT Temporary String'

!+
!
!	Append source string to FIXED or XPORT Temporary target string'
!
!-

    [ STR$K_CLASS_F,
      STR$K_CLASS_XT ] :

	$STR_QUIT( BAD_TARGET, BAD_CLASS );		! Return error codes to the caller.

%TITLE 'XST$APPEND - Append to a DYNAMIC String'

!+
!
!	Append source string to DYNAMIC target string.
!
!-

    [ STR$K_CLASS_D ] :
	BEGIN
	LOCAL
	    new_string_len,				! Length of resulting string
	    new_target_ptr;				! Address of the new target area

	MACRO
	    round_up( length ) =
		(
		    %BLISS16( length + 3 AND %X'FFFC' )
		    %BLISS32( length + 7 AND %X'FFF8' )
		    %BLISS36( ((length + 4) / 5) * 5 )
		) %;

	new_string_len = .string[STR$H_LENGTH] +	! Calculate the length of the resulting string.
				.target[STR$H_LENGTH];

	IF .new_string_len LEQU				! If the source string will fit in the target area,
		round_up( .target[STR$H_LENGTH] )	!
	THEN						!
	    BEGIN					!
	    CH$MOVE( .string[STR$H_LENGTH],		! move the source string into the target area.
		    .string[STR$A_POINTER],		!
		    CH$PLUS( .target[STR$A_POINTER],	!
			    .target[STR$H_LENGTH] ) );	!
							!
	    target[STR$H_LENGTH] = .new_string_len;	! and set the new target string length.
	    END

	ELSE						! If the source string will not fit in the target area,
	    BEGIN					! a new target area must be allocated.

	    $XPO_IF_NOT( $XPO_GET_MEM(			! Allocate a new target area.
			    CHARACTERS = .new_string_len,
			    RESULT = new_target_ptr,
			    FAILURE = 0 ) )
	    THEN
		$STR_QUIT( (XPO$_GET_MEM), (.$XPO_STATUS) );

	    CH$COPY( .target[STR$H_LENGTH],		! Copy the current target string
			.target[STR$A_POINTER],		! into the new target area
			.string[STR$H_LENGTH],		! and append the source string to it.
			.string[STR$A_POINTER],
			0, .new_string_len,
			.new_target_ptr );

	    $XPO_IF_NOT( $XPO_FREE_MEM(			! Free the old target area.
				    STRING = .target,
				    FAILURE = 0 ))
	    THEN
		$STR_QUIT( (XPO$_FREE_MEM), (.$XPO_STATUS) );

							! Update the target area descriptor:
	    target[STR$H_LENGTH] = .new_string_len;	!	resulting string length
	    target[STR$A_POINTER] = .new_target_ptr;	!	pointer to new target area
	    END;
	END;

%TITLE 'XST$APPEND - Append to a BOUNDED String'

!+
!
!	Append source string to BOUNDED target string.
!
!-

    [ STR$K_CLASS_B ] :

	BEGIN
	IF .string[STR$H_LENGTH] LEQU			! Compare length of source string to the available
			.target[STR$H_MAXLEN] -		! space in the target area.
			    .target[STR$H_PFXLEN] -
				.target[STR$H_LENGTH]
	THEN						! Source length LEQ target space:
	    string_length = .string[STR$H_LENGTH]	!    setup to copy entire source string

	ELSE						! Source length GTR target space:
	    IF .options[STR$V_TRUNCATE]
	    THEN					!    OPTION=TRUNCATE specified:
		string_length = .target[STR$H_MAXLEN] -	!	setup to truncate source string
				.target[STR$H_PFXLEN] -
				.target[STR$H_LENGTH]
	    ELSE					!    Truncation not permitted:
		$STR_QUIT( BAD_TARGET, NO_SPACE );	!	return error codes to the caller

	CH$MOVE( .string_length,			! Copy the source string into the target area.
		.string[STR$A_POINTER],
		CH$PLUS( .target[STR$A_POINTER], .target[STR$H_LENGTH] ) );

							! Update the target descriptor:
	target[STR$H_LENGTH] =				!    string length
		.target[STR$H_LENGTH] + .string_length;
	END;

%TITLE 'XST$APPEND - Append to a DYNAMIC_BOUNDED String'

!+
!
!	Append source string to a DYNAMIC_BOUNDED target string.
!
!-

    [ STR$K_CLASS_DB ] :

	BEGIN
	LOCAL
	    new_string_len,				! Length of resulting string
	    new_target_maxl,				! Maximum length of new target area
	    new_target_ptr;				! Address of the new target area

	new_string_len = .string[STR$H_LENGTH] +	! Calculate the length of the resulting string.
			    .target[STR$H_LENGTH];

	IF .new_string_len LEQU .target[STR$H_MAXLEN] -	! If the source string will fit in the target area,
				.target[STR$H_PFXLEN]	!
	THEN						!
	    BEGIN					!
	    CH$MOVE( .string[STR$H_LENGTH],		! move the source string into the target area.
		    .string[STR$A_POINTER],
		    CH$PLUS( .target[STR$A_POINTER], .target[STR$H_LENGTH] ) );

	    target[STR$H_LENGTH] = .new_string_len;	! Set the new target string length.
	    END

	ELSE						! If the source string will not fit in the target area,
	    BEGIN					! a new target area must be allocated.

	    new_target_maxl = .target[STR$H_MAXLEN];	! Pickup the current target area size.

	    WHILE .new_target_maxl LSS			! Increase the memory size until it is large enough.
		    .new_string_len + .target[STR$H_PFXLEN] DO
		new_target_maxl = .new_target_maxl + db_allocate;

	    $XPO_IF_NOT( $XPO_GET_MEM(			! Allocate a new target area.
			    CHARACTERS = .new_target_maxl,
			    RESULT = new_target_ptr,
			    FAILURE = 0 ) )
	    THEN
		$STR_QUIT( (XPO$_GET_MEM), (.$XPO_STATUS) );

	    CH$COPY(					! Copy the following strings into the target area:
		    .target[STR$H_PFXLEN] +		!    prefix string
			.target[STR$H_LENGTH],		!    current target string
		    CH$PLUS( .target[STR$A_POINTER],	!
			    -.target[STR$H_PFXLEN] ),	!
		    .string[STR$H_LENGTH],		!    source string
		    .string[STR$A_POINTER],
		    0, .new_target_maxl,
		    .new_target_ptr );

	    $XPO_IF_NOT( $XPO_FREE_MEM(			! Free the old target area.
				STRING = .target,
				FAILURE = 0 ))
	    THEN
		$STR_QUIT( (XPO$_FREE_MEM), (.$XPO_STATUS) );

							! Update the target area descriptor:
	    target[STR$H_LENGTH] = .new_string_len;	!	resulting string length
	    target[STR$A_POINTER] = .new_target_ptr;	!	pointer to new target area
	    target[STR$H_MAXLEN] = .new_target_maxl;	!	maximum string length
	    END;
	END;

	TES;

%TITLE 'XST$APPEND - Convert to Upper Case'

!+
!
!	Convert the appended string to upper case if requested.
!
!-

    IF .options[STR$V_UP_CASE]
    THEN
	BEGIN
	LOCAL
	    character,					! A single ASCII character
	    pointer;					! Pointer into target string

	pointer = CH$PLUS( .target[STR$A_POINTER],	! Point to the character preceding the appended string.
			    .target[STR$H_LENGTH] - .string_length - 1 );

	INCR index FROM 1 TO .string_length DO		! Loop through the copied string.
	    BEGIN
	    character = CH$A_RCHAR( pointer );		! Pickup a single ASCII character.

	    IF .character GEQ %C'a' AND			! If it is a lower-case character,
			.character LEQ %C'z'		!
	    THEN					!
		CH$WCHAR( .character - %C' ',		! convert it to upper-case.
					.pointer );
	    END;
	END;

%TITLE 'XST$APPEND - Routine Termination'

!+
!
!	XST$APPEND Routine Termination
!
!-

!
! Setup a normal routine completion code.
!

    $STR_QUIT( NORMAL );

    $STR_MAIN_END;					! End of MAIN_BLOCK code block

!
! Call an appropriate action routine.
!

    $STR_ACTION_RTN( .options, .string, .target );

!
! Free an temporary XPORT string used in this string append.
!

    IF NOT .options[STR$V_NO_FREE_T]			! If this is not an internal XPORT call,
    THEN						!
	$STR_FREE_TEMP( .string );			! free the source string if it is a temporary string.

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

    RETURN .primary_code

    END;
END
ELUDOM