PROGRAM RERUN(input,output,f);

         (*---- Rishiyur Nikhil, 5-Feb-81 ----*)
	 (*     Computer Science Department   *)
	 (*     University of Pennsylvania    *)

   (* link with
            OPENFILE ,
            RERCHARIO ,
            FILESTAT
   *)

 const LPMAX = 13200;

 TYPE alfa = packed array [1..10] of char;
      line = packed array[1..80] of char;
      descr  = PACKED RECORD    (* Line descriptor *)
                 length:  integer;
                 pointer: ^line   end;
      word = 0..65535;
      byte = 0..255;
      descriptor = packed record      (* command line descriptor *)
                      dlen  : word;
                      dtype : byte;
                      dclass: byte;
                      dptr  : ^line    end;

 VAR f:text;
     I,
     TTY,
     CURPAGE,STARTPAGE: integer;

     EOF1, QUIT, NOPAUSE, IMPLICIT_CRLF, OWE_LF, NoFormFeeds: boolean;

     NULL,
     CTRL_D,CTRL_U,
     BACK_SP, BEEP, CR,LF,FF,CEOF,ESC: char;

     LASTPAGE: packed array [1..LPMAX] of char;  LPI: integer;

     TRANS_SIZE : array [0..127] of integer;
     TRANS_TABLE: array [0..127] of alfa;

     Terminal_type_prompt,
     Type_Q_for_help_prompt,
     Control_char_prompt,
     Translated_to_prompt,
     Type_anything_to_continue_prompt : line;

 %include 'RERCHARIO.INC'
 %include 'OPENFILE.INC'

 Procedure lib$get_foreign(var get_line: descriptor); extern;

Procedure NEWLINE;
 begin
   Putchar(CR, TTY);
   Putchar(LF, TTY)
 end;

Procedure Putalfa(a:alfa; N, TTY:integer);
 var l:line; i:integer;
 begin
   for i := 1 to N do l[i] := a[i];
   Putline(l,n, TTY)
 end;

Function LCtoUC(C:char):char;
 begin
   if ('a' <= C) and (C <= 'z') then
     LCtoUC := chr(ord(C) - ord('a') + ord('A'))
   else
     LCtoUC := C
 end;

 (* ----------- routines to send chars to tty ------------- *)

 Procedure FLUSH(var d:descr);
   begin
    if d.length > 0 then
      putline(d.pointer^, d.length, TTY);
    d.length := 0
   end;

 Procedure EMITC1(c:char; var d:descr);
  begin
    if d.length = 80 then flush(d);
    d.length := d.length + 1;
    d.pointer^[d.length] := c
  end;

 Procedure EMITC(c:char; var d:descr);
  var I,J:integer;
  begin
    J := ord(c);
    for I := 1 to TRANS_SIZE[J] do  EMITC1(TRANS_TABLE[J,I], d)
  end;

 (* ----------- routines for last page ------------ *)

Procedure SAVEC(C:char);
 begin
   if LPI < LPMAX then begin
     LPI := LPI + 1;
     LASTPAGE[LPI] := C  end
 end;

Procedure DUMPLASTPAGE(var d:descr);
 var I: integer;
 begin
   d.length := 0;
   for I := 1 to LPI do EMITC(LASTPAGE[I],d);
   Flush(d)
 end;

 Procedure CLEARLASTPAGE;
  begin
    LPI := 0
  end;

 (* ---------- routines to interact with user during pauses -------- *)

 Procedure DEFAULT_TRANSLATION(MODE:integer);
  var I:integer;
  begin
    if MODE=0 then begin
      for I := 0 to 31 do TRANS_SIZE[I] := 0;
      TRANS_SIZE[0] := 1;
      TRANS_TABLE[0,1] := chr(0);   {null}
      TRANS_SIZE[8] := 1;
      TRANS_TABLE[8,1] := chr(8);   {backspace}
      TRANS_SIZE[10] := 1;
      TRANS_TABLE[10,1] := chr(10);   {linefeed}
      TRANS_SIZE[13] := 1;
      TRANS_TABLE[13,1] := chr(13)  end   {carriage return}
    else
      for I := 0 to 31 do begin
        TRANS_SIZE[I] := 1;
        TRANS_TABLE[I,1] := chr(I)  end;

    for I := 32 to 127 do begin
      TRANS_SIZE[I] := 1;
      TRANS_TABLE[I,1] := chr(I)  end
  end;

 Procedure QUME_TRANSLATION;
  begin
    DEFAULT_TRANSLATION(1);
    TRANS_SIZE[4] := 2;
    TRANS_TABLE[4,1] := ESC;
    TRANS_TABLE[4,2] := 'D';
    TRANS_SIZE[21] := 2;
    TRANS_TABLE[21,1] := ESC;
    TRANS_TABLE[21,2] := 'U';
  end;

 Procedure HELP_TRANSLATION;
  begin
    PutChar('?',TTY);
    NEWLINE;
    writeln('Translation of control-chars. Terminal types :');
    writeln('q : Qume- ^U to <ESC>U for half scroll forward,');
    writeln('          ^D to <ESC>D for half scroll back.');
    writeln('s : Special -prompt mode for specifying other translations.');
    writeln('0 : pass only <NULL>, <CR>, <LF> and <Backspace>');
    writeln('1 : pass all control chars untranslated');
    NEWLINE
  end;

 Procedure SPECIAL_TRANSLATION;
  var C,DELIMC:char; DONE:boolean; I,J:integer;
    Procedure HELP;
     begin
       writeln('Specify each control char to be translated, and');
       writeln('  char. sequence it should be translated to.');
       writeln('Max. sequence length is 10 chars.');
       writeln('Delimit sequence on both sides by any char not in the sequence.');
       writeln('e.g.');
       writeln('  "Control char ? ^D Translated to /<ESC>d/"');
       writeln('Type any non-control char to finish');
       NEWLINE
     end;

     Procedure ECHO_CHAR(C:char; FULLWIDTH: boolean);
      begin
        if C=NULL then begin
          Putalfa('<NULL>    ',6, TTY);
          if FULLWIDTH then Putalfa('          ',3, TTY)  end
        else if C=BACK_SP then
          Putalfa('<BACK_SP> ',9, TTY)
        else if C=CR then begin
          Putalfa('<CR>      ',4, TTY);
          if FULLWIDTH then Putalfa('          ',5, TTY)  end
        else if C=LF then begin
          Putalfa('<LF>      ',4, TTY);
          if FULLWIDTH then Putalfa('          ',5, TTY)  end
        else if C=FF then begin
          Putalfa('<FF>      ',4, TTY);
          if FULLWIDTH then Putalfa('          ',5, TTY)  end
        else if C=ESC then begin
          Putalfa('<ESC>     ',5, TTY);
          if FULLWIDTH then Putalfa('          ',4, TTY)  end
        else if C < ' ' then begin
          Putalfa('<^        ',2, TTY);
          Putchar(chr(ord(C)+64), TTY);
          Putchar('>', TTY);
          if FULLWIDTH then Putalfa('          ',5, TTY)  end
        else
          Putchar(C, TTY)
      end; {echo_char}
  begin
    HELP;
    repeat
      DONE := false;
      putline(Control_char_prompt,15,TTY);
      C := getchar(TTY);
      if C < ' ' then begin
        I := ord(C);
        ECHO_CHAR(C, true);
        PutLine(Translated_to_prompt,17,TTY);
        DELIMC := getchar(TTY);
        ECHO_CHAR(DELIMC,false);
        J := 0;
        if DELIMC=NULL then C := BEEP
        else C := NULL;
        while C <> DELIMC do begin
          C := getchar(TTY);
          if C=DELIMC then begin
            ECHO_CHAR(C, false);
            NEWLINE            end
          else begin
            J := J + 1;
            if J > 10 then Putchar(BEEP, TTY)
            else begin
              ECHO_CHAR(C, false);
              TRANS_SIZE[I] := J;
              TRANS_TABLE[I,J] := C  end  end  end  end
       else if C = '?' then begin
         Putchar('?', TTY);
         NEWLINE;
         HELP               end
       else begin
         Putalfa('DONE      ',4, TTY);
         NEWLINE;
         DONE := true  end
     until DONE
  end; {SPECIAL_TRANSLATION}

 Procedure SET_TRANSLATION;
  var I: integer; C:char; DONE: boolean;
  begin
    repeat
      DONE := true;
      PutLine(TERMINAL_TYPE_PROMPT,16, TTY);
      C := getchar(TTY);
      C := LCtoUC(C);
      case C of
        '?' : begin
                HELP_TRANSLATION;
                DONE := false    end;
        'Q' : begin
                Putalfa('Qume      ',4, TTY);
                NEWLINE;
                QUME_TRANSLATION              end;
        'S' : begin
                Putalfa('Special   ',7, TTY);
                NEWLINE;
                SPECIAL_TRANSLATION             end;
        '0' : begin
                Putchar('0', TTY);
                NEWLINE;
                DEFAULT_TRANSLATION(0)  end;
        '1' : begin
                Putchar('1', TTY);
                NEWLINE;
                DEFAULT_TRANSLATION(1)  end;
        otherwise begin
                putchar(BEEP,TTY);
                NEWLINE;
                Putline(Type_Q_for_help_prompt,15, TTY);
                NEWLINE;
                DONE := false  end
      end {case}
    until DONE;
  end;

 Function GETNUM(DEFAULT:integer): integer;
  var ACC: integer; C: char;
  begin
    C := getchar(TTY);
    while (C = ' ') do C := getchar(TTY);
    if (C=ESC) or (C=CR) then GETNUM := DEFAULT
    else
      if (C<'0') or ('9'<C) then GETNUM := -1
      else begin
        ACC := ord(C) - 48;
        C := getchar(TTY);
        while ('0'<=C) and (C<='9') do begin
          ACC := ACC*10 + ord(C) - 48;
          C := getchar(TTY) end;
        GETNUM := ACC  end
  end;

 Procedure SHOW_HELP;
  begin
    writeln('Commands are :');
    writeln('  <CR>,<ESC> : continue (next page)');
    writeln('  q,e        : Quit, Exit');
    writeln('  j <number> : Jump forward to page <number>');
    writeln('  s <number> : Skip <number> pages ');
    writeln('  g          : Go (don''t pause between pages)');
    writeln('  a          : last page Again (max. 13200 chars)');
    writeln('  f          : Form-feed after each page');
    writeln('  n          : No form-feed after each page');
    writeln('  t          : set Translation of control chars');
    writeln('  ?          : this text (help)');
    writeln;
    writeln(' Next page is - ',CURPAGE);
    writeln
  end;

 Procedure SHOW_END_OF_PAGE;
  var I: integer;
  begin
    if NoFormFeeds then begin
      for I := 1 to 67 do write('-');
      if EOF1 then writeln(' end of file')
      else writeln(' end of page');
      NEWLINE                        end
    else
      putchar(FF,TTY)
  end;

 Procedure PAUSE(var d:descr);
  var c:char; N: integer; DONE:boolean;
  begin
   DONE := false;
   while not(DONE or QUIT or NOPAUSE) do begin
     putchar(BEEP,TTY);
     c := getchar(TTY);
     if (c=CR) or (C=ESC) then DONE := true
     else begin
       c := LCtoUC(c);
       case C of
         '?' : begin
                 SHOW_HELP;
                 PutLine(Type_anything_to_continue_prompt,26, TTY);
                 c := getchar(TTY);
                 SHOW_END_OF_PAGE  end;
         'Q','E' : QUIT := true;
         'S' : begin
                 N := GETNUM(1);
                 if N >= 0 then begin
                   STARTPAGE := CURPAGE + N;
                   DONE := true                end  end;
         'J' : begin
                 N := GETNUM(0);
                 if N >= CURPAGE then begin
                   STARTPAGE := N;
                   DONE := true           end end;
         'G' : NOPAUSE := true;
         'A' : begin
                 DUMPLASTPAGE(d);
                 SHOW_END_OF_PAGE         end;
         'F' : NoFormFeeds := false;
         'N' : NoFormFeeds := true;
         'T' : begin
                 SET_TRANSLATION;
                 SHOW_END_OF_PAGE   end
       end {case}
     end {else begin}
   end {while}
  end;

 (* ----------- routines to read single chars from file -------- *)

  Function NEXTC(var f:text): char;
   begin
     if IMPLICIT_CRLF then
       if OWE_LF then begin
         NEXTC := LF;
         OWE_LF := false  end
       else
         if eof(f) then NEXTC := CEOF
         else
           if eoln(f) then begin
             NEXTC := CR;
             OWE_LF := true;
             get(f)        end
           else begin
             NEXTC := f^;
             get(f)  end
     else begin
       while eoln(f) and not(eof(f)) do get(f);
       if eof(f) then NEXTC := CEOF
       else begin
         NEXTC := f^;
         get(f)  end  end
   end;

 Procedure PROCESS_NAME(var s:line);
  var I,FIRST,LAST,N,DOTPOS,SEMICPOS: integer;
        (* remove leading spaces, make ".MEM" as default extension *)
  begin
        (* find position of first non-blank *)
     FIRST := 81;
     I := 1;
     while (I < FIRST) do
       if s[i] <> ' ' then FIRST := I
       else I := I + 1;
     if FIRST <= 80 then begin
         (* find position of last non-blank *)
       LAST := FIRST;
       I := 80;
       while LAST < I do
         if s[i] <> ' ' then LAST := I
         else i := i - 1;
          (* shift left over leading blanks, locate "." and ";" *)
       N := LAST-FIRST+1;
       DOTPOS := N+1;
       SEMICPOS := N+1;
       for I := FIRST to LAST do begin
         s[I-FIRST+1] := s[I];
         if s[I-FIRST+1] = '.' then DOTPOS := I-FIRST+1;
         if s[I-FIRST+1] = ';' then SEMICPOS := I-FIRST+1  end;
           (* if no dot, put in ".MEM" at end *)
       if DOTPOS > N then begin
             (* move everything to right of semic right by 4 *)
         for I := (N+4) downto (SEMICPOS+4) do
           if I <= 80 then s[I] := s[I-4];
         if ( SEMICPOS   <=80) then s[SEMICPOS]   := '.';
         if ((SEMICPOS+1)<=80) then s[SEMICPOS+1] := 'M';
         if ((SEMICPOS+2)<=80) then s[SEMICPOS+2] := 'E';
         if ((SEMICPOS+3)<=80) then s[SEMICPOS+3] := 'M';
         SEMICPOS := SEMICPOS + 4;
         N := N + 4                                   end;

         (* pad to right with blanks *)
       for I := (N+1) to 80 do s[I] := ' '  end
  end;

 Procedure SETUPFILE(var f: text);
   const class_d = 2; dtype_d = 14;
   var I,J,RETCODE: integer; com_lin_descr: descriptor;
   begin
       (* initialise command-line descriptor *)
     with com_lin_descr do begin
       dlen := 0;
       dtype := dtype_d;
       dclass := class_d;
       dptr := nil   end;

       (* get command line *)
     lib$get_foreign(com_lin_descr);
     if com_lin_descr.dlen < 1 then begin
       new(com_lin_descr.dptr);
       write('Filename ? : ');
       if not eof(input) then read(com_lin_descr.dptr^)
       else
         QUIT := true   end
     else
       for I := (com_lin_descr.dlen + 1) to 80 do
         com_lin_descr.dptr^[i] := ' ';
     PROCESS_NAME(com_lin_descr.dptr^);
     if not QUIT then begin
       RETCODE := openforread(com_lin_descr.dptr^,f);
       case RETCODE of
         1 : IMPLICIT_CRLF := true;
         2 : IMPLICIT_CRLF := false;
         3 : begin
               J := 0;
               for I := 1 to 80 do
                 if com_lin_descr.dptr^[i] <> ' ' then J := I;
               write('?File not found : "');
               for I := 1 to J do write(com_lin_descr.dptr^[i]);
               writeln('"');
               QUIT := true       end;
         otherwise begin
               write('?system error - illegal RETCODE from FILESTAT : ');
               writeln(RETCODE);
               QUIT := true      end  end   end
 end;

 (* -------- main body -------------------------------------*)

  Procedure MAIN;
  VAR i,p:integer; d: descr; c:char;
  begin
    new(d.pointer); d.length := 0;
    setupfile(f);
    if not(QUIT) then begin
      initchario(TTY);
      CLEARLASTPAGE;
      STARTPAGE := 1;
      CURPAGE := 1;
      NoFormFeeds := false;
      QUIT := false;
      NOPAUSE := false;
      pause(d);
      OWE_LF := false;
      EOF1 := false;
      c := NEXTC(f);
      while not(QUIT) and not(EOF1) do
        if C=CEOF then begin
          flush(d);
          EOF1 := true;
          SHOW_END_OF_PAGE  end
        else begin
          if c = FF then begin
            CURPAGE := CURPAGE + 1;
            flush(d);
            if (CURPAGE > STARTPAGE) then begin
              SHOW_END_OF_PAGE;
              pause(d);
              clearlastpage               end  end
          else
            if CURPAGE >= STARTPAGE then begin
              EMITC(c,d);
              SAVEC(c)                   end;
          c := NEXTC(f)  end;
      flush(d);
      pause(d)  end
  end;

begin
    NULL := chr(0);
    CTRL_D := chr(4); CTRL_U := chr(21);
    BACK_SP := chr(8);
    FF := chr(12); CR := chr(13); LF := chr(10);
    BEEP := chr(7); ESC := chr(27); CEOF := chr(26);

    DEFAULT_TRANSLATION(1);

    Terminal_type_prompt := 'Terminal type ?                                                                 ';
    Type_Q_for_help_prompt := 'Type ? for help                                                                 ';
    Control_char_prompt := 'Control char ?                                                                  ';
    Translated_to_prompt := ' Translated to ?                                                                ';
    Type_anything_to_continue_prompt := 'Type anything to continue                                                       ';

    MAIN
end.