MODULE HTRAN
	(LANGUAGE (BLISS32),
	IDENT = 'X0002') =
BEGIN
!
! modification history:
!	13-jul-1981 wsk	if logical name ends with a colon, remove it
! IDENT 2
! 	25-may-1982 wsk support for concealed devices
!
LIBRARY	'SYS$LIBRARY:STARLET';
MACRO
	MAK_PSECT(FILE) = 
PSECT
	GLOBAL = %NAME('$',FILE,'A$')
	(READ,WRITE,EXECUTE,NOSHARE,PIC,CONCATENATE,
	LOCAL,ALIGN(2),ADDRESSING_MODE(WORD_RELATIVE));

PSECT
	OWN = %NAME('$',FILE,'B$')
	(READ,WRITE,NOEXECUTE,NOSHARE,PIC,CONCATENATE,
	LOCAL,ALIGN(2),ADDRESSING_MODE(WORD_RELATIVE));

PSECT
	PLIT = %NAME('$',FILE,'C$')
	(READ,EXECUTE,SHARE,PIC,CONCATENATE,
	LOCAL,ALIGN(2),ADDRESSING_MODE(WORD_RELATIVE));
PSECT
	CODE = %NAME('$',FILE,'D$')
	(READ,NOWRITE,EXECUTE,SHARE,PIC,CONCATENATE,
	LOCAL,ALIGN(2),ADDRESSING_MODE(WORD_RELATIVE));
%;
MAK_PSECT (HTRAN);


MACRO
	RETURN_ON_ERROR (CALL) =
		BEGIN
		    LOCAL STS;
		    IF NOT (STS = CALL) THEN RETURN .STS;
		END%;
MACRO
	DESC(STRING)=
		UPLIT(%CHARCOUNT(STRING),UPLIT BYTE(STRING))%;
MACRO
	FNM(NAM)=
		FNA=UPLIT(%STRING(NAM)),
		FNS=%CHARCOUNT(NAM)%;
LITERAL
	ESC = %X'1B',
	LOGNAM_SIZ = 64;

GLOBAL ROUTINE TRAN_LOG (LOG_NAME_DESC,TRAN_NAME_DESC,CONCEALED_NAME) =
!
! this is a routine to translate logical names
! inputs:
!	descriptor describing the logical name
!	descriptor describing the space allocated for the translated name
!	descriptor describing the space allocated for the completely translated
!			name...this is an optional parameter
!	the name will be translated and the result passed back
!		the translated name in tran_name_desc will honor concealed dev.
!		the translated name in concealed_name will divulge that info
! status: 
!	result of the translation
!
BEGIN
	OWN
		ORIGINAL_LEN,
		ORIGINAL_BUFFER : VECTOR [500,BYTE],
		SAVE_LEN,
		SAVE_BUFFER : VECTOR [500,BYTE];
	LOCAL
		TMP,
		COLON_FLAG,
		HAD_COLON_FLAG,
		FLAG,
		L_NAME_DESC : VECTOR [2,LONG],
		FINAL_STATUS,
		STATUS;
BIND
	TRANS_NAME = .TRAN_NAME_DESC : VECTOR [2,LONG],
	BUFFER = .TRANS_NAME[1] : VECTOR [500,BYTE],
	LOG_NAME = .LOG_NAME_DESC : VECTOR[2,LONG];
BUILTIN ACTUALCOUNT;
  L_NAME_DESC[0] = .LOG_NAME[0];
  L_NAME_DESC[1] = .LOG_NAME[1];
  CH$FILL (0,.SAVE_LEN,SAVE_BUFFER);
  CH$MOVE (.LOG_NAME[0],.LOG_NAME[1],ORIGINAL_BUFFER);
  ORIGINAL_LEN = .LOG_NAME[0];
  HAD_COLON_FLAG = 0;
  !
  !
  ! get translation 
  !
  FLAG = 1;
  DO
    BEGIN
        TMP = .L_NAME_DESC[1] + .L_NAME_DESC<0,16> - 1;
        COLON_FLAG = 0;
        IF .(.TMP)<0,8> EQL %C':' THEN COLON_FLAG = 1;
	STATUS = $TRNLOG (LOGNAM=L_NAME_DESC,
			  RSLLEN=L_NAME_DESC,
			  RSLBUF = TRANS_NAME);
	IF .FLAG EQL 1 THEN FINAL_STATUS = .STATUS;
	FLAG = .FLAG + 1;
	L_NAME_DESC[1] = .TRANS_NAME[1];
 	IF (.BUFFER[0] EQLU ESC) AND (.BUFFER[1] EQLU 0) THEN
	BEGIN
		L_NAME_DESC[0] = .L_NAME_DESC[0] - 4;
		L_NAME_DESC[1] = .L_NAME_DESC[1] + 4;
	END;
	IF .BUFFER[0] NEQ %C'_' AND .BUFFER[1] NEQ %C'_' THEN
		(CH$MOVE (.L_NAME_DESC[0],.L_NAME_DESC[1],SAVE_BUFFER);
		SAVE_LEN = .L_NAME_DESC[0]);
	IF .COLON_FLAG AND .STATUS EQLU SS$_NOTRAN THEN
	BEGIN
		L_NAME_DESC[0] = .L_NAME_DESC[0] - 1;
		STATUS = 1;
		COLON_FLAG = 0;
		HAD_COLON_FLAG = 1;
	END;
    END
  UNTIL NOT .STATUS OR (.STATUS EQLU SS$_NOTRAN) OR (.BUFFER[0] EQL %C'_');
  TRANS_NAME[0] = .L_NAME_DESC[0];
  IF .HAD_COLON_FLAG EQL 1 AND .STATUS EQLU SS$_NOTRAN THEN
  BEGIN
	TMP = .TRANS_NAME<0,16> + .TRANS_NAME[1];
	IF .(.TMP)<0,8> EQL %C':' THEN TRANS_NAME[0] = .TRANS_NAME[0] + 1;
  END;
  IF ACTUALCOUNT() EQL 3 THEN
  BEGIN
     BIND 
	CONCEAL = .CONCEALED_NAME  : VECTOR [2,LONG];
	CH$MOVE (.TRANS_NAME[0],.TRANS_NAME[1],.CONCEAL[1]);
	CONCEAL[0] = .TRANS_NAME[0];
  END;
  IF .BUFFER[0] EQL %C'_' AND .BUFFER[1] EQL %C'_' THEN
  BEGIN

	IF .SAVE_BUFFER[0] NEQ 0 THEN
		(CH$MOVE (.SAVE_LEN,SAVE_BUFFER,.TRANS_NAME[1]);
		TRANS_NAME[0] = .SAVE_LEN)
	ELSE
	      BEGIN
		CH$MOVE (.ORIGINAL_LEN,ORIGINAL_BUFFER,.TRANS_NAME[1]);
		TRANS_NAME[0] = .LOG_NAME[0];
		TMP = .TRANS_NAME<0,16> + .TRANS_NAME[1] - 1;
		IF .(.TMP)<0,8> NEQ  %C':' THEN
		BEGIN
			TRANS_NAME[0] = .TRANS_NAME[0] + 1;
			TMP = .TMP + 1;
			(.TMP)<0,8> = %C':';			
		END;
		FINAL_STATUS = SS$_NOTRAN;
	      END;
  END;		
RETURN .FINAL_STATUS;
END; ! end of routine htran
END
ELUDOM