(*$I-*)
PROGRAM RT2PAS;
CONST
  EMPTY = 512;
  PERM = 1024;
  TENTATIVE = 256;
  ENDMARK = 2048;

TYPE
  DATEWRD = PACKED RECORD
                YEAR:  0..31; (*YEAR-72*)
                DAY:   0..31; (*ALLOCATE*)
                MONTH: 0..31; (*5 BITS EA*)
                JUNK:  0..1   (*INTEGER FILL*)
            END;
  CHARS = PACKED ARRAY [0..2] OF CHAR;
  FILENTRY = RECORD
    STATUSWORD: INTEGER;
    FIRST: INTEGER;
    SECOND: INTEGER;
    EXTENSION: INTEGER;
    LGTH: INTEGER;
    FILLER: INTEGER;
    DATE: DATEWRD
  END;

  XFERTYPE=(RT11EDIT,BINARY,NONE);
  
  DIREC = RECORD CASE BOOLEAN OF
    FALSE: (BUF: PACKED ARRAY [0..1023] OF CHAR);
    TRUE:  (SEGSAVAIL: INTEGER;
	    NEXTSEG: INTEGER;
	    HIGHSEG: INTEGER;
	    FILLER: INTEGER;
	    BEGINSEG: INTEGER;
	    ENTRY: ARRAY [0..71] OF FILENTRY)
  END;

VAR
  I, BLOCK,FILESIZE: INTEGER;
  B:BOOLEAN;
  CH:CHAR;
  OUT: CHARS;
  RT11: DIREC;
  XFEROPTION:XFERTYPE;
  TITLE,WANTED:PACKED ARRAY[0..9] OF CHAR;
  S:STRING;
  INBUF,OUTBUF:PACKED ARRAY[0..1023] OF CHAR;
  FOUT:FILE;
  MONSTR: PACKED ARRAY[1..12] OF STRING;

PROCEDURE DERAD50 (WORD: INTEGER; VAR STORE: CHARS);
VAR
  I: INTEGER;
  NEG: BOOLEAN;
BEGIN
  NEG := WORD < 0;
  IF NEG THEN WORD := WORD + 32767 + 1;
  STORE[2] := CHR (WORD MOD 40);
  IF NEG THEN
    BEGIN
      WORD := WORD DIV 40 + 819;
      IF STORE[2] >= CHR(32) THEN WORD := WORD + 1;
      STORE[2] := CHR( (ORD(STORE[2])+8) MOD 40)
    END
  ELSE
    WORD := WORD DIV 40;
  STORE[1] := CHR (WORD MOD 40);
  STORE[0] := CHR (WORD DIV 40);
  FOR I := 0 TO 2 DO
    BEGIN
      WORD := ORD(STORE[I]);
      IF WORD = 0 THEN WORD := ORD (' ')
      ELSE
        IF WORD <= 26 THEN
	  WORD := WORD + 64
	ELSE
	  IF WORD >= 30 THEN
	    WORD := WORD + 18
	  ELSE (*ERROR-CHANGE TO BLANK*)
	    WORD := ORD (' ');
      STORE[I] := CHR(WORD)
    END
END (*DERAD50*);

PROCEDURE ENRAD (NUMBARS: INTEGER; VAR I: INTEGER);
VAR
  M, N, P, J: INTEGER;
BEGIN
  J := NUMBARS DIV 10;
  I := NUMBARS MOD 10 + 40 * (J MOD 10) + 1600 * (J DIV 10) - 16306
END (*ENRAD*);

PROCEDURE SHOWDIR;
BEGIN
  UNITREAD (5, RT11, 1024, 6);  (*READ BLOCKS 6-7 = RT11 DIRECTORY*)
  WRITELN;
  WRITELN ('  TITLE      SIZE   DATE');
  WRITELN;
  I := 0;
  BLOCK := RT11.BEGINSEG;
  WITH RT11 DO
  WHILE ENTRY[I].STATUSWORD <> ENDMARK DO WITH ENTRY[I] DO
  BEGIN
    IF STATUSWORD = PERM THEN
      BEGIN
        DERAD50 (FIRST, OUT);
        WRITE (OUT);
        DERAD50 (SECOND, OUT);
        WRITE (OUT);
        DERAD50 (EXTENSION, OUT);
        IF OUT <> '   ' THEN WRITE ('.',OUT) ELSE WRITE (' ':4);
        WRITE (LGTH:6);
        IF (DATE.MONTH IN [1..12]) AND (DATE.DAY IN [1..31]) THEN
          WRITE(' ':4,DATE.DAY:2,'-',MONSTR[DATE.MONTH],'-',DATE.YEAR+72:2);
        WRITELN;
      END;
    BLOCK := BLOCK + LGTH;
    I := I + 1
  END;
WRITELN;
END (*SHOWDIR*);

PROCEDURE LOCATEFILE;
VAR I,J:INTEGER;
BEGIN
  UNITREAD (5, RT11, 1024, 6);  (*READ BLOCKS 6-7 = RT11 DIRECTORY*)
  I:=0;
  B:=FALSE;
  BLOCK:=RT11.BEGINSEG;
  WITH RT11 DO
    WHILE (ENTRY[I].STATUSWORD<>ENDMARK) AND (NOT B) DO
      WITH ENTRY[I] DO
        BEGIN
          IF STATUSWORD=PERM THEN
            BEGIN
              DERAD50(FIRST,OUT);
              MOVERIGHT(OUT[0],TITLE[0],3);
              DERAD50(SECOND,OUT);
              MOVERIGHT(OUT[0],TITLE[3],3);
              DERAD50(EXTENSION,OUT);
              IF OUT='   ' THEN
                FOR J:=6 TO 9 DO TITLE[J]:=' '
              ELSE
                BEGIN
                  TITLE[6]:='.';
                  MOVERIGHT(OUT[0],TITLE[7],3);
                END;
            END;
          B:=(WANTED=TITLE);
          IF NOT B THEN
            BEGIN
              BLOCK:=BLOCK+LGTH;
              I:=I+1;
            END;
        END (*WHILE*);
    IF B THEN FILESIZE:=RT11.ENTRY[I].LGTH
    ELSE BEGIN WRITELN('?FIL NOT FND?'); BLOCK:=-1 END;
END (*LOCATEFILE*);

FUNCTION GETWANTED:BOOLEAN;
VAR I,J:INTEGER;
BEGIN
  WRITE('Enter source file title: ');
  GETWANTED:=FALSE;
  WANTED:='          '; (*OVERLAY ONTO A BED OF SPACES*)
  READLN(S);
  IF LENGTH(S)>0 THEN
    BEGIN
      I:=POS('.',S);
      IF I<>-1 THEN                        (*FORCE TITLE SANS EXTENSION*)
        FOR J:=I TO 6 DO INSERT(' ',S,I);  (*INTO FIRST 6 POSITIONS *)
      IF LENGTH(S)<=10 THEN (*IF LENGTH IS REASONABLE*)
        MOVERIGHT(S[1],WANTED[0],LENGTH(S));
      GETWANTED:=TRUE; (*IF LENGTH NOT RESONABLE, LOOKUP BLANK TITLE*)
    END;
END (*GETWANTED*);

PROCEDURE GETTGT;
BEGIN
  REPEAT
    WRITE('Enter target file title: ');
    READLN(S);
    B:=FALSE;
    IF LENGTH(S)>0 THEN
    BEGIN
      OPENNEW(FOUT,S);
      IF IORESULT=0 THEN B:=TRUE ELSE WRITELN('?ILL FILE DESC?');
    END;
  UNTIL B;
END; (*GETTGT*)

FUNCTION GETMODE:BOOLEAN;
BEGIN
  WRITE('Transfer Mode: B)inary or T)ext ? ');
  READLN(S); CH:=CHR(0); IF LENGTH(S)>0 THEN CH:=S[1];
  XFEROPTION:=NONE;
  IF CH IN ['B','b'] THEN XFEROPTION:=BINARY;
  IF CH IN ['T','t'] THEN XFEROPTION:=RT11EDIT;
  GETMODE:=XFEROPTION<>NONE;
END; (*GETMODE*)
      
PROCEDURE PUTPAGE(VAR POUT:INTEGER);
VAR I:INTEGER;
  CH:CHAR;
BEGIN
  I:=BLOCKWRITE(FOUT,OUTBUF,2);
  POUT:=0;
  FILLCHAR(OUTBUF,1024,CHR(0));
END (*PUTPAGE*);

PROCEDURE TRANSLATE;
CONST
  LF=10;
  CR=13;
  DLE=16;
VAR
  I,BLKNUM,PIN,POUT,BLANKCNT:INTEGER;
  INCH:CHAR;
  NEWLINETOG:BOOLEAN;

BEGIN
  FILLCHAR(INBUF,512,CHR(0));
  FILLCHAR(OUTBUF,1024,CHR(0));
  I:=BLOCKWRITE(FOUT,OUTBUF,2,0); (*2 blocks of nuls to start*)
  BLANKCNT:=0;
  POUT:=0;
  NEWLINETOG:=FALSE;
  FOR BLKNUM:=1 TO FILESIZE DO
    BEGIN
      UNITREAD(5,INBUF,512,BLOCK);
      BLOCK:=BLOCK+1;
      PIN:=0;
      WHILE PIN<=511 DO
        BEGIN
          INCH:=INBUF[PIN];
          IF NOT (ORD(INCH) IN [0,LF]) THEN
            BEGIN
              WRITE(INCH);
              IF INCH=CHR(CR) THEN
                BEGIN
                  OUTBUF[POUT]:=CHR(CR);
                  POUT:=POUT+1;
                  NEWLINETOG:=TRUE;
                  BLANKCNT:=0;
                  IF POUT>940 THEN PUTPAGE(POUT);
                END
              ELSE
                IF NEWLINETOG THEN
                  BEGIN
                    IF INCH=' ' THEN
                      BLANKCNT:=BLANKCNT+1
                    ELSE
                      BEGIN
                        OUTBUF[POUT]:=CHR(DLE);
                        OUTBUF[POUT+1]:=CHR(ORD(' ')+BLANKCNT);
                        NEWLINETOG:=FALSE;
                        OUTBUF[POUT+2]:=INCH;
                        POUT:=POUT+3;
                      END;
                  END (*NEWLINETOG*)
                ELSE
                  BEGIN
                    OUTBUF[POUT]:=INCH;
                    POUT:=POUT+1;
                  END;
          END (*IF INBUF...*);
          PIN:=PIN+1;
        END (*WHILE*);
    END (*FOR*);
  PUTPAGE(POUT);
END (*TRANSLATE*);

PROCEDURE XBINARY;
VAR I,BLKNUM:INTEGER;
BEGIN
  FOR BLKNUM:=1 TO FILESIZE DO
    BEGIN
      UNITREAD(5,INBUF,512,BLOCK);
      BLOCK:=BLOCK+1;
      I:=BLOCKWRITE(FOUT,INBUF,1);
      IF I<>1 THEN
        BEGIN
          WRITELN;
          WRITE('OUTPUT ERROR, program terminated', CHR(7(*BEL*)));
          EXIT(PROGRAM);
        END;
    END;
END (*XBINARY*);

BEGIN (*MAIN*)
  MONSTR[1]:='Jan'; MONSTR[2]:='Feb'; MONSTR[3]:='Mar'; 
  MONSTR[4]:='Apr'; MONSTR[5]:='May'; MONSTR[6]:='Jun'; 
  MONSTR[7]:='Jul'; MONSTR[8]:='Aug'; MONSTR[9]:='Sep'; 
  MONSTR[10]:='Oct'; MONSTR[11]:='Nov'; MONSTR[12]:='Dec'; 
  WRITELN('RT2PAS      RT-11 TO PASCAL FILE TRANSFER UTILITY       V01-01');
  WRITELN('RT-11 structured disk is assumed to be in QX1 drive (Unit 5)');
  REPEAT
    REPEAT
      WRITE('Display the directory? (y/n)');
      READLN(S); PAGE(OUTPUT);
      IF LENGTH(S)>0 THEN IF S[1] IN ['Y','y'] THEN SHOWDIR;
      IF GETWANTED THEN LOCATEFILE ELSE BLOCK:=-1;
    UNTIL BLOCK>=0;
    CLOSE(FOUT); (*COVERS RECALL TO GETTGT*)
    GETTGT;
  UNTIL GETMODE;
  CASE XFEROPTION OF
    RT11EDIT: TRANSLATE;
    BINARY:XBINARY;
  END (*CASE*);
  CLOSE(FOUT,LOCK);
  WRITELN('*** FILE TRANSFER DONE ***');
END.