MODULE SFORM (	IDENT = 'X00.04'	%TITLE 'XST$FORMAT - ASCII to ASCII Conversion'
		%BLISS32( ,ADDRESSING_MODE( EXTERNAL=LONG_RELATIVE ) )
		%BLISS36( ,ENTRY( XST$FORMAT ),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_FORMAT 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$FORMAT;						! ASCII to ASCII formatting 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$FORMAT( options, string, length ) =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine implements the $STR_FORMAT string pseudo-function.
!
! FORMAL PARAMETERS:
!
!	options - string options and function code
!	string - address of the source string descriptor
!	length - requested resulting string length
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	None
!
! ROUTINE VALUE:
!
!	address of an XPORT temporary string descriptor
!
! SIDE EFFECTS:
!
!	None
!
!--

    BEGIN

    MAP
	options :  $STR_OPTIONS,
	string :  REF $STR_DESCRIPTOR();

    LOCAL
	format_length,
	temporary :  REF $STR_DESCRIPTOR( CLASS = DYNAMIC ),
	prefix_length;

!
! Initialization
!

    $STR_MAIN_BEGIN( PSEUDO )				! Beginning of MAIN_BLOCK code block

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

    $STR_VALIDATE( .string, BAD_SOURCE );		! Validate the source string descriptor.

!
! Calculate the resulting string length.
!

    IF .length NEQ 0					! If the caller specified a resulting string length,
    THEN						!
	format_length = .length				! use that length.
    ELSE
	format_length = .string[STR$H_LENGTH];		! Otherwise, use the length of the source string.

!
! Allocate a resulting string in dynamic memory.
!

    IF .string[STR$H_LENGTH] LEQ .format_length		! If the caller requested a resulting string length
							! that is large enuf for the source string,
    THEN						!
	BEGIN						!
	$XPO_IF_NOT( $XPO_GET_MEM(			! allocate the string and fill it with blanks.
			    CHARACTERS = .format_length,
			    DESCRIPTOR = .temporary,
			    FILL = %C' ',
			    FAILURE = 0 ) )
	THEN
	    $STR_QUIT( (.$XPO_STATUS) );
	END
    ELSE
	BEGIN
	$XPO_IF_NOT( $XPO_GET_MEM(			! Otherwise, allocate the string and fill it with asterisks.
			    CHARACTERS = .format_length,
			    DESCRIPTOR = .temporary,
			    FILL = %C'*',
			    FAILURE = 0 ) )
	THEN
	    $STR_QUIT( (.$XPO_STATUS) );

	$STR_QUIT( NORMAL );				! Return the asterisks to the caller.
	END;

!
! Calculate the length of the string prefix in the resulting string.
!

    IF .options[STR$V_RIGHT_JUS]
    THEN
        prefix_length = .temporary[STR$H_LENGTH] -	! RIGHT_JUSTIFY :  all of extra space
			.string[STR$H_LENGTH]
    ELSE
        IF .options[STR$V_CENTER]
    	THEN
	    prefix_length =				! CENTER :  half of extra space, rounded down
		( .temporary[STR$H_LENGTH] -
			.string[STR$H_LENGTH] ) / 2
        ELSE
    	    prefix_length = 0;				! LEFT_JUSTIFY :  no prefix

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

    CH$MOVE( .string[STR$H_LENGTH], .string[STR$A_POINTER],
		CH$PLUS( .temporary[STR$A_POINTER], .prefix_length ) );

!
! 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( .temporary[STR$A_POINTER],	! Point to the character preceding the copied string.
				.prefix_length - 1 );

	INCR index FROM 1 TO .string[STR$H_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;

    $STR_QUIT( NORMAL );

    $STR_MAIN_END;					! End of MAIN_BLOCK code block

!
! Free an XPORT temporary string input to this formatting function.
!

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

!
! 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