%title 'WFLP'
%sbttl 'READ AND TRANSLATE WP FORMAT FLOPPIES'
MODULE WFLP (MAIN = WFLP,IDENT = '01.00') =
BEGIN

!
!			  Free software BY
!		Project Software & Development, Inc.
!
! This software is furnished for free and may be used and  copied as
! desired. This software or  any  other copies  thereof may be provided
! or otherwise made available to any other person.  No title to and
! ownership of  the  software  is  hereby transferred or allowed. 
!
! The information in this software is subject to change  without  notice
! and  should  not  be  construed  as  a commitment by PROJECT SOFTWARE
! AND DEVELOPMENT, INC.
!
! PROJECT SOFTWARE assumes no responsibility for the use or  reliability  
! of this software on any equipment whatsoever.
!
!	Project Software & Development, Inc.
!	14 Story St.
!	Cambridge, Ma. 02138
!	617-661-1444
!

!++
! FACILITY:
!
! ABSTRACT:
!	READ AND CONVERT WORD PROCESSOR FLOPPIES
!
! ENVIRONMENT:
!	REQUIRES PHYSICAL IO PRIV
!
! AUTHOR:	V. GRAHAM , CREATION DATE: OCT 1981
!
! MODIFIED BY:
!
! 	, : VERSION
! 01	- 
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
	WFLP,
	GETDOC,
	PUTBLK,
	HOME,
	UPCASE : NOVALUE,
	USCRAM,
	DEBLK,
	DISNUM,
	DOCNUM,
	GETBLK,
	CVT_A_X,
	PUT_OUT_REC,
	OPEN_OUT_FILE,
	CLOSE_OUT_FILE;

!
! INCLUDE FILES:
!
LIBRARY
	'SYS$LIBRARY:LIB';
!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

BIND
	CRLF = UPLIT (BYTE(10,13));
!
! OWN STORAGE:
!
OWN
	NULL_LINE : VECTOR[2] INITIAL(2,CRLF),
	O_CHAN : WORD,
	INCHAN : WORD,
	INDEX_HEADER : BYTE INITIAL(0),
	DEBUG_FLAG : BYTE INITIAL(0),
	OUT_FILE_NAME_LEN,


	OUT_FILE_FAB :	$FAB	(FAC=PUT
				,RAT=CR),

	OUT_FILE_RAB :	$RAB	(FAB=OUT_FILE_FAB);
!
! EXTERNAL REFERENCES:
!
EXTERNAL ROUTINE
	LIB$GET_INPUT,
	LIB$PUT_OUTPUT;

ROUTINE WFLP =

!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE
!
! SIDE EFFECTS:
!
!	NONE
!
!--

BEGIN
LITERAL
	MAX_DOC = 200;
LOCAL
	STATUS;

OWN
	OUT_FILE_NAME_ADDR : VECTOR[64,BYTE],
	OUT_FILE_NAME_DESC : VECTOR[2] INITIAL (64,OUT_FILE_NAME_ADDR),
	DOC_NO : VECTOR[4,BYTE],
	DOC_NO_DESC : VECTOR[2,LONG] INITIAL (4,DOC_NO),
	DOC_INDEX,
	IN_LEN,
	INAM_ADDR : VECTOR[32,BYTE],
	INAM : VECTOR[2] INITIAL (32,INAM_ADDR),
	OUTBUF : VECTOR[512,BYTE],
	INBUF :VECTOR[512,BYTE],
	USCRAM_VEC : VECTOR[384,WORD],
	HOME_VEC : VECTOR[384,WORD],
	DOC_HDRVEC : VECTOR[384,WORD],
	BLK_NUM;
	LIB$PUT_OUTPUT($DESCRIPTOR(' '));
	LIB$PUT_OUTPUT($DESCRIPTOR('   WFLP  V1.00'));

	LIB$PUT_OUTPUT($DESCRIPTOR(' '));
	WHILE .IN_LEN EQL 0 DO
	LIB$GET_INPUT(INAM,$DESCRIPTOR('Floppy drive (example DYA1:) : ')
			,IN_LEN);

	INAM[0] = .IN_LEN;

	UPCASE(INAM[0],.INAM[1]);
	LIB$PUT_OUTPUT($DESCRIPTOR(' '));
	LIB$PUT_OUTPUT($DESCRIPTOR('Document # 1 is the floppy index.'));
	LIB$PUT_OUTPUT($DESCRIPTOR(' '));
	LIB$PUT_OUTPUT($DESCRIPTOR('Type E to exit program'));


	IF NOT (STATUS =
	$ASSIGN (CHAN = INCHAN,DEVNAM=INAM))
	THEN SIGNAL (.STATUS);

	IF NOT (STATUS =
	$ASSIGN (CHAN = O_CHAN,DEVNAM=$DESCRIPTOR('TT')))
	THEN SIGNAL(.STATUS);

!++
!  GET HOME BLOCK
!--
	BLK_NUM = 2;				! HOME BLOCK
	GETBLK(BLK_NUM,INBUF);			! GET IT
	USCRAM(INBUF,HOME_VEC);			! UNSCRAMBLE IT
	HOME(HOME_VEC);				! DISPLAY IT

	BEGIN ! LOCAL LOOP BODY
	    BIND HEADER_BLK_PTR = HOME_VEC[10]:VECTOR[,WORD]; ! PTR TO FIRST DOC HEADER

!++
!  THE DIRECTORY IS DOCUMENT #1
!--
	WHILE 1 DO
	    BEGIN
	    IN_LEN = 0;
	    LIB$PUT_OUTPUT($DESCRIPTOR(' '));
	    WHILE .IN_LEN EQL 0 DO
		LIB$GET_INPUT(DOC_NO_DESC,$DESCRIPTOR('Document # : '), IN_LEN);
	    IF .DOC_NO[0] EQL %C'E' OR .DOC_NO[0] EQL %C'e' THEN EXITLOOP;
	    DOC_NO = CVT_A_X(IN_LEN,DOC_NO);
	    IF .DOC_NO EQL 1 THEN INDEX_HEADER = 1 ELSE INDEX_HEADER = 0;

	    DOC_INDEX = .DOC_NO - 1;

	    IF .DOC_INDEX LSS 0 OR .DOC_INDEX GTR MAX_DOC THEN 
		LIB$PUT_OUTPUT($DESCRIPTOR('Invalid document number'))
	    ELSE
		BEGIN
		OUT_FILE_NAME_LEN = 0;
		LIB$PUT_OUTPUT($DESCRIPTOR(' '));
		LIB$GET_INPUT(OUT_FILE_NAME_DESC
		,$DESCRIPTOR('Output file name (default SYS$OUTPUT): ')
		,OUT_FILE_NAME_LEN);

		IF .OUT_FILE_NAME_LEN NEQ 0 THEN 
		    OPEN_OUT_FILE(OUT_FILE_NAME_LEN,OUT_FILE_NAME_ADDR);

		IF .HEADER_BLK_PTR[.DOC_INDEX] EQL 0 THEN 
		    LIB$PUT_OUTPUT($DESCRIPTOR('Document does not exsit'))
	        ELSE
		    BEGIN
		    GETBLK(HEADER_BLK_PTR[.DOC_INDEX],INBUF);
		    USCRAM(INBUF,DOC_HDRVEC);
		    GETDOC(DOC_HDRVEC);
		    IF .OUT_FILE_NAME_LEN NEQ 0 THEN CLOSE_OUT_FILE();
		    END;
		END; 

	    END; !OF WHILE

	END; ! OF BEGIN LOCAL LOOP BODY

	RETURN 1;
END;			!End of WPFLP

ROUTINE CVT_A_X(DIGITS,ASTR) = 
BEGIN
LOCAL
	J,
	STR,
	TEMP;

	STR = ..ASTR AND %X'0F0F0F';

	IF ..DIGITS GTR 3 THEN RETURN 1000;

	J = 1;
	TEMP = 0;

	DECR I FROM ..DIGITS-1 TO 0 DO
	    BEGIN
	    MAP STR :VECTOR[,BYTE];
	    TEMP = .TEMP+(.J*.STR[.I]);
	    J = .J*10;
	    END;
	RETURN .TEMP;
END;


ROUTINE OPEN_OUT_FILE(NAME_LEN,NAME_ADDR) =
BEGIN
LOCAL
	RMS_STATUS;

	OUT_FILE_FAB[FAB$B_FNS] = ..NAME_LEN;
	OUT_FILE_FAB[FAB$L_FNA] = .NAME_ADDR;

	IF NOT (RMS_STATUS = $CREATE(FAB = OUT_FILE_FAB)) THEN 
		SIGNAL_STOP(.RMS_STATUS);

	IF NOT (RMS_STATUS = $CONNECT(RAB = OUT_FILE_RAB)) THEN 
		SIGNAL_STOP(.RMS_STATUS);
	RETURN 1;
END;

ROUTINE CLOSE_OUT_FILE =
BEGIN
LOCAL
	RMS_STATUS;

	IF NOT (RMS_STATUS = $CLOSE(FAB = OUT_FILE_FAB)) THEN 
		SIGNAL_STOP(.RMS_STATUS);
	RETURN 1;
END;


ROUTINE GETDOC(DOC_HDR) =
BEGIN
OWN	DOCBUF : VECTOR[512,BYTE],
	OUTVEC : VECTOR[384,WORD];

BIND 	HDR_VEC = .DOC_HDR : VECTOR[,WORD],	! DOCUMENT HEADER
	BLK_CNT = HDR_VEC[5] :WORD,		! # OF BLKS IN DOCUMENT
	FILE_NUM = HDR_VEC[11] : WORD,
	BLK_PTR_LIST = HDR_VEC[%O'55'] : VECTOR[,WORD]; ! LIST OF BLK # IN DOC

	DOCNUM(FILE_NUM,BLK_CNT);
	IF .INDEX_HEADER  AND (.OUT_FILE_NAME_LEN EQL 0) THEN
	    LIB$PUT_OUTPUT(
		$DESCRIPTOR('  Document Ident.              Doc #'));

	INCR I FROM 0 TO .BLK_CNT-1 DO

	    BEGIN
	    IF .BLK_PTR_LIST[.I] NEQ 0 THEN
		BEGIN
		GETBLK(BLK_PTR_LIST[.I],DOCBUF);
		USCRAM(DOCBUF,OUTVEC);
		DEBLK(OUTVEC,DOCBUF);
		PUTBLK(DOCBUF);
		END
	    ELSE EXITLOOP;
	    END;

	PUTBLK(0);	! END OF DOCUMENT - FLUSH THE BUFFER

	RETURN 1;
END;

ROUTINE USCRAM (I_BUF,O_BUF) =
BEGIN
STRUCTURE
	NIB [X;Y] =
		[(Y+1)/2]
		NIB<4*X,4>;
BIND
	WORK_BUF = .I_BUF;	!:VECTOR[,BYTE];
BIND
	OBUF = .O_BUF : VECTOR[,WORD];

	INCR I FROM 0 TO 255 DO
	    OBUF[.I] =.(WORK_BUF+.I+128)<0,8,0>;
!	    (OBUF+(.I*2))<0,8,0> = .(WORK_BUF+.I+128)<0,8,0>;

	INCR I FROM 0 TO 255 DO
	    BEGIN
	    MAP
		WORK_BUF :  NIB;
	    BIND
		TEMP = OBUF[.I] :WORD;

		IF .I THEN
	        TEMP<8,4,0> = .WORK_BUF[.I-1]
		ELSE TEMP<8,4,0> = .WORK_BUF[.I+1];

!	    (OBUF+(.I*2))<8,4,0> = .(WORK_BUF+(.I))<4,4,0>;
!	    (OBUF+.I*2)+1)<8,4,0> = .(WORK_BUF+(.I))<0,4,0>;

	    END;

	RETURN 1;
END;

ROUTINE HOME(BUF) =
BEGIN
OWN
	HOVEC : VECTOR[80,BYTE],
	HOBUF : VECTOR[2] INITIAL (80,HOVEC);
LOCAL
	TEMP;
BIND
	WORK_BUF = .BUF: VECTOR[,WORD];

	IF NOT .DEBUG_FLAG THEN RETURN 1;

	INCR I FROM 0 TO 128 DO
	BEGIN
	TEMP = .WORK_BUF[.I];

	$FAO ($DESCRIPTOR(' HB word !OW !OW !XW')
		,0
		,HOBUF
		,.I
		,.TEMP
		,.TEMP);
	LIB$PUT_OUTPUT(HOBUF);
	END;
	RETURN 1;
END;		

ROUTINE GETBLK(NUM,BUF) = 
BEGIN
! ONE LOG BLK = 3 PHY SECTORS
! SECTORS ARE FROM 1 TO 26
! TRACKS ARE FROM 0 T0 76
! TRACKS 0,74,75,76 ARE UNUSED
! TRACKS 1 TO 73 CONTAIN 632 BLOCKS (0 TO 631) THUS THE BASE = TRACK 1 SECTOR 1
! EACH BLOCK CONTAINS 256 12 BIT WORDS (384 BYTES)
! BLOCK 2 IS THE HOME BLOCK
! 
LITERAL
	SECTOR_OFFSET = 3,		! SECTOR OFFSET FOR INTERLEAVING
	SECTORS_PER_BLK = 3,
	SECTORS_PER_TRACK = 26,
	BASE_TRACK = 1,
	BASE_SECTOR = 1;

BIND
	WORK_BUF = .BUF :VECTOR[,BYTE];
BIND
	SECTOR_ORDER = UPLIT (BYTE
		(0,
		1,4,7,
		10,13,16,
		19,22,25,
		2,5,8,
		11,14,17,
		20,23,26,
		3,6,9,
		12,15,18,
		21,24)) :VECTOR[,BYTE];

OWN

	SECTOR_INDEX : BYTE,
	DISK_ADDR : VECTOR[4,BYTE];
BIND
	BLKNUM = .NUM : WORD,
	SECTOR =DISK_ADDR[0]:BYTE UNSIGNED,
	TRACK = DISK_ADDR[2]:BYTE UNSIGNED;
LOCAL
	STATUS,
	IN_IOSB : VECTOR[4,WORD],
	TEMP;

	TEMP = SECTORS_PER_BLK*.BLKNUM;
	SECTOR_INDEX = (.TEMP MOD SECTORS_PER_TRACK) + BASE_SECTOR;
	SECTOR = .SECTOR_ORDER[.SECTOR_INDEX];
	TRACK = (.TEMP/SECTORS_PER_TRACK) + BASE_TRACK;

	INCR I FROM 0 TO 2 DO
	BEGIN
	DISNUM(BLKNUM,DISK_ADDR);
	IF NOT (STATUS =
	    $QIOW 	(CHAN = .INCHAN
			,FUNC = IO$_READPBLK
			,IOSB = IN_IOSB
			,P1 = WORK_BUF[.I*128]
			,P2 = 128
			,P3 = .DISK_ADDR)) THEN SIGNAL (.STATUS);

	IF .IN_IOSB[0] NEQ SS$_NORMAL THEN SIGNAL (.IN_IOSB[0]);

	    IF .SECTOR EQL 24 THEN	! ALWAYS LAST SECTOR
		BEGIN
		SECTOR =  1;
		TRACK = .TRACK+1;
	   	END
	    ELSE
		BEGIN
		SECTOR = .SECTOR+SECTOR_OFFSET;
		IF .SECTOR GTR SECTORS_PER_TRACK THEN
		    SECTOR = .SECTOR - SECTORS_PER_TRACK;
		END;

	    END;

	RETURN 1;
END;

ROUTINE DISNUM(BLK,ADDR) =
BEGIN
LOCAL
	FAOBUF : VECTOR[80,BYTE],
	FAODES : VECTOR[2];
BIND
	ADDR_W = .ADDR :VECTOR[2,WORD],
	BLK_W = .BLK : WORD;

	IF NOT .DEBUG_FLAG THEN RETURN 1;

	FAODES[0] = 80;
	FAODES[1] = FAOBUF;

	$FAO ($DESCRIPTOR(' Block No. !XW  Track !XW Sector !XW!/')
		,FAODES[0]
		,FAODES
		,.BLK_W
		,.ADDR_W[1]
		,.ADDR_W[0]);
	LIB$PUT_OUTPUT(FAODES);
	RETURN 1;
END;

ROUTINE DOCNUM(NUM,CNT) =
BEGIN
LOCAL
	FAOBUF : VECTOR[80,BYTE],
	FAODES : VECTOR[2];
BIND
	SIZE = .CNT : WORD,
	DOCNUM = .NUM : WORD;

	FAODES[0] = 80;
	FAODES[1] = FAOBUF;

	$FAO ($DESCRIPTOR('!/+***** Document No. !UW Size !UW *******+!/')
		,FAODES[0]
		,FAODES
		,.DOCNUM
		,.SIZE);
	LIB$PUT_OUTPUT(FAODES);
	RETURN 1;
END;


ROUTINE DEBLK(IN_BUF,O_BUF) =
BEGIN
LOCAL
	TEMP;
BIND
	WORK_BUF = .IN_BUF ;	!: VECTOR[,WORD];

BIND
	OUT_BUF = .O_BUF : VECTOR[,BYTE];


	INCR I FROM 0 TO 511 BY 2 DO
	    BEGIN
	    OUT_BUF[.I] = .(WORK_BUF+.I)<6,6,0> ;   !FIRST CHAR
	    IF .OUT_BUF[.I] NEQ 0 THEN OUT_BUF[.I] = .OUT_BUF[.I] + %X'1F';
	    OUT_BUF[.I+1] = .(WORK_BUF+.I)<0,6,0> ; !SECOND CHAR
	    IF .OUT_BUF[.I+1] NEQ 0 THEN OUT_BUF[.I+1] = .OUT_BUF[.I+1] + %X'1F';
	    END;

	RETURN 1;
END;


ROUTINE PUTBLK(BUF) = 
BEGIN
OWN
	SAVE_J,
	LAST_CHAR_SPECIAL,
	O_BUF : VECTOR[508,BYTE],
	FLAGS : BITVECTOR[8];		! CHARACTER FLAGS
MACRO
	BOLD_M = 0%,
	UNDS_M = 1%,
	OSTRK_M = 2%,
	JSTFY_M = 3%,
	SUPSCR_M = 4%,
	SUBSCR_M = 5%,
	RULER_M = 6%,
	SHIFT_M = 7%;
BUILTIN
	NULLPARAMETER;

LOCAL 
	I,				! RAW DATA ARRAY INDEX
	J,				! FORMATTED DATA ARRAY INDEX
	STATUS;


BIND
	RAW_BUF = .BUF+4 : VECTOR[,BYTE]; ! SKIP FIRST 4 BYTES

	IF NULLPARAMETER(1) THEN 	! FLUSH OPERATION
	    BEGIN
	    IF .SAVE_J NEQ 0 THEN
	        PUT_OUT_REC(SAVE_J,O_BUF);
	    SAVE_J = 0;
	    RETURN 1;
	    END;

	I = 0;
	J = .SAVE_J;

	IF .DEBUG_FLAG THEN
	IF NOT (STATUS =
	$QIOW 	(CHAN = .O_CHAN
		,FUNC = IO$_WRITELBLK
		,P1 = RAW_BUF
		,P2 = 508)) THEN SIGNAL (.STATUS);

	WHILE (.RAW_BUF[.I] NEQ 0) AND (.I LEQ 507) DO
	    BEGIN
	    IF .RAW_BUF[.I] EQL %C'[' THEN FLAGS[SHIFT_M] = 1
		ELSE IF .RAW_BUF[.I] EQL %C']' THEN FLAGS[SHIFT_M] = 0
		  ELSE IF .RAW_BUF[.I] EQL %C'^' AND (.I EQL 507) THEN 
			LAST_CHAR_SPECIAL = 1
		    ELSE IF .RAW_BUF[.I] EQL %C'^' OR .LAST_CHAR_SPECIAL THEN
			BEGIN	! SPECIAL CHAR
			IF NOT .LAST_CHAR_SPECIAL THEN I = .I+1
			    ELSE LAST_CHAR_SPECIAL = 0;
			SELECTONE .RAW_BUF[.I] OF
			SET
			[0]:		LAST_CHAR_SPECIAL = 1;
			[%C'!']:	FLAGS[BOLD_M] = 1;
			[%C'"']:	FLAGS[BOLD_M] = 0;
			[%C'#']:	FLAGS[UNDS_M] = 1;
			[%C'$']:	FLAGS[UNDS_M] = 0;

			[%C'%']:	BEGIN	! CHANGE TAB TO SPACE
					O_BUF[.J] = %C' ';
					J = .J+1;
					END;

			[%C'&']:	FLAGS[OSTRK_M] = 1;
			[%C'''']:	FLAGS[OSTRK_M] = 0;
			
			[%C'(']:	FLAGS[JSTFY_M] = 1;
			[%C')']:	FLAGS[JSTFY_M] = 0;

			[%C'*']:	BEGIN	! END OF LINE
					PUT_OUT_REC(J,O_BUF);
					J = 0;
					!O_BUF[.J] = 10;
					!O_BUF[.J+1] = 13;
					!J = .J+2;
					END;

			[%C'+']:	BEGIN
					O_BUF[.J] = 12;
					J = .J+1;
					END;

			[%C',']:	FLAGS[SUPSCR_M] = 1;
			[%C'-']:	FLAGS[SUPSCR_M] = 0;
			[%C'.']:	FLAGS[SUBSCR_M] = 1;
			[%C'/']:	FLAGS[SUBSCR_M] = 0;
!!!!!			[%C'0']:

			[%C'1']:	BEGIN
					O_BUF[.J] = %C'[';
					J = .J+1;
					END;

			[%C'2']:	BEGIN
					O_BUF[.J] = %C'\';
					J = .J+1;
					END;

			[%C'3']:	BEGIN
					O_BUF[.J] = %C']';
					J = .J+1;
					END;

			[%C'4']:	BEGIN
					O_BUF[.J] = %C'^';
					J = .J+1;
					END;
			[%C'5']:	BEGIN
					O_BUF[.J] = %C'_';
					J = .J+1;
					END;
!!!! LINE MODIFY	[%C'6']:

			[%C'7']:	!START RULER
					BEGIN
					DO	! UNTIL END RULER
					  BEGIN
					  I = .I+1;
					  IF .RAW_BUF[.I] EQL %C'[' THEN 
						FLAGS[SHIFT_M] = 1;
					  END
					UNTIL .RAW_BUF[.I] EQL %C'^';
					I = .I+1;
					END;

					!ONLY IF RULER SPANS BLOCKS
			[%C'8']:	I = .I+1;	! END RULER

			TES;

			END

			    ELSE	! NOT A SPECIAL CHARACTER
				BEGIN
				O_BUF[.J] = .RAW_BUF[.I];
				IF NOT .FLAGS[SHIFT_M] THEN
				    IF (.O_BUF[.J] GTR 64) AND (.O_BUF[.J] LSS 91) THEN
				        O_BUF[.J] = .O_BUF[.J] + 32;  !LOWER CASE
				J = .J+1;
				END;

		I = .I+1;

	    END; ! OF WHILE 1

	IF .J NEQ 0 THEN SAVE_J = .J ELSE SAVE_J = 0;


	RETURN 1;
END;

ROUTINE PUT_OUT_REC(LEN,ADDR) = 
BEGIN

	IF .OUT_FILE_NAME_LEN NEQ 0 THEN
	    BEGIN
	    LOCAL
		RMS_STATUS;

		OUT_FILE_RAB[RAB$W_RSZ] = ..LEN;
		OUT_FILE_RAB[RAB$L_RBF] = .ADDR;
	
		IF NOT (RMS_STATUS = $PUT(RAB = OUT_FILE_RAB)) THEN 
			SIGNAL_STOP(.RMS_STATUS);
	    END
	ELSE
	    BEGIN
	    LOCAL
		BUF_DES: VECTOR[2];

		IF .INDEX_HEADER THEN
		    BEGIN
		    LOCAL J,
			  LSTR : VECTOR[64,BYTE];
		    CH$FILL(%C'.',64,LSTR);
		    BUF_DES[0] = ..LEN-5;
		    BUF_DES[1] = .ADDR+3;
			BEGIN !LOCAL BLOCK
			BIND STR = .BUF_DES[1] : VECTOR[,BYTE];
			J=0;
			INCR I FROM 0 TO .BUF_DES[0] -1 DO
			    BEGIN
			    IF  .STR[.I] EQL %C'>' THEN  LSTR[.J] = %C' '
			    ELSE IF .STR[.I] EQL %C'<'  THEN	J = 31
			    ELSE LSTR[.J] = .STR[.I];
			    J = .J+1;
			    END;
			BUF_DES[0] = .J;
			BUF_DES[1] = LSTR;
			END; !LOCAL BLOCK
		    END
		ELSE
		    BEGIN
		    BUF_DES[0] = ..LEN;
		    BUF_DES[1] = .ADDR;
		    END;

		LIB$PUT_OUTPUT(BUF_DES);
	    END;

	
	RETURN 1;
END;


%SBTTL 'UPCASE'
ROUTINE UPCASE (STRLEN,STRADDR) : NOVALUE =

BEGIN
	CH$TRANSLATE(
	    CH$TRANSTABLE(
	    0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,
	    25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,
	    47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,
	    69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,
	    91,92,93,94,95,96, 65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
	    81,82,83,84,85,86,87,88,89,90, 123,124,125,126,127),
	    .STRLEN,CH$PTR(.STRADDR),
	    %C' ',
	    .STRLEN,CH$PTR(.STRADDR));
END;

END				!End of module
ELUDOM