Columbia Kermit/kermit.zip/c/ucapp2.pas

Pascal/Delphi Source File | 2020-01-01 | 186KB | 5,642 lines

(*=== KERMIT.TEXT ===*)
(* >>>>>>>> KERMIT.TEXT ***********************************************)

(*$S+*)
(*$I-*)
(*$R-*)
(*$V-*)

PROGRAM kermit;


USES  kermglob,
      kermacia,
      kermutil,
      kermpack,
      kermsetshw,
      sender,
      receiver,
      helper,
      kerminit,
      parser;

PROCEDURE kermterm(BS_to_DEL, Esc_Char, Xon_Char, Xoff_Char : CHAR;
                   Xoff_W_Time : INTEGER;
                   No_Ffeed,Print, Half_Duplex ,
                   Reject_Cntrl_Char, Emulate : BOOLEAN); FORWARD;




SEGMENT PROCEDURE Connect;

VAR Close_Term, Print : BOOLEAN;
    Ch : CHAR;
    SSC_pass : PACKED ARRAY[0..1] OF CHAR;

PROCEDURE Switch_Printer;
BEGIN
  IF Print_enable THEN
    BEGIN
      WRITE('Screendump is ');
      IF Ch = 'P' THEN BEGIN
                         Print := TRUE;
                         WRITELN('on');
                       END
                  ELSE BEGIN
                         WRITELN(Pr);
                         WRITELN('off');
                         Print := FALSE;
                       END;
    END;
END;


PROCEDURE Show_List;
BEGIN
  WRITELN;
  WRITELN('<?>   Show this list.');
  WRITELN('<S>   Show all current Kermit parameter settings.');
  WRITELN('<C>   Close connection and return to Kermit UCSD command level.');
  Write_Ctl( Esc_Char );
  WRITELN(' Send escape character itself to the remote host.');
  IF ( Acia_implem = A6551 ) OR ( Acia_implem = A6850 )  THEN
    BEGIN
      IF Acia_implem = A6551 THEN
      BEGIN
        WRITE('<Z>   Tell Super Serial Card to pass <^A> to host for ');
                     WRITELN('correct file transfer.');
      END;
      WRITELN('<B>   Send a break signal to the remote host.');
      WRITELN('      Hit any key to turn off break signal.');
    END;
  IF Print_enable THEN
    BEGIN
     WRITELN;
     WRITELN('<P>   Screen output also to printer.');
     WRITELN('<Q>   Turnoff screendump.');
    END;
END;


BEGIN
  Close_Term := FALSE; Print := FALSE; Ch := ' ';
  SSC_pass[0] := CHR(1); SSC_pass[1] := 'Z';
  PAGE( Output );
  WRITE('>Kermterm connecting to host   (type '); Write_Ctl(Esc_Char);
  WRITELN(' <C> to exit)');
  UNITCLEAR( Inport );
  REPEAT
    UNITCLEAR( Keyport );
    Kermterm(BS_to_DEL, Esc_Char, Xon_Char, Xoff_Char, Xoff_W_Time,
             No_Ffeed, Print, Half_Duplex, Reject_Cntrl_Char, Emulate );
    REPEAT
    WRITELN; WRITE('>Kermterm (<?> <B> <C> <P> <Q> <S> <Z>) =>');
    UNITCLEAR( Keyport );
    UNITREAD( Keyport, Ch, 1 ); WRITELN;
    IF Ch IN ['a'..'z'] THEN Ch := CHR( ORD(Ch) - ORD('a') + ORD('A') );
    IF Ch IN ['B','C','P','Q','S','Z','?' ]
      THEN CASE Ch OF
           'B' : Send_Break( Acia_Comm_Reg );
           'C' : Close_Term := TRUE;
       'P','Q' : Switch_Printer;
           'S' : BEGIN Noun := All_Sym; Show_Parms END;
           'Z' : UNITWRITE( Outport, SSC_pass, 2,, 12);
           '?' : Show_List;
           END; (* of then case *)
    UNTIL Ch <> '?';
    IF Ch = Esc_Char THEN UNITWRITE( Outport, Ch, 1,, 12 );
    IF NOT Close_Term THEN WRITELN('Back to host.');
  UNTIL Close_Term;
  WRITELN('Back to Apple Kermit UCSD')
END;


PROCEDURE Kermterm; EXTERNAL;


PROCEDURE closeup;

begin
  check_apple_char( all_sp_char );
  page( output )
end; (* closeup *)


begin (* main kermit program *)
  {$N+}
  {$R kermglob,kermacia,kermutil,kermpack,kermsetshw,parser }
 initialize;
 repeat
   write('Kermit-UCSD> ');
   read_str(line);
   case parse of
     unconfirmed   : writeln('Unconfirmed');
     parm_expected : writeln('Parameter expected');
     ambiguous     : writeln('Ambiguous');
     unrec         : writeln('Unrecognized command');
     fn_expected   : writeln('File name expected');
     pn_expected   : writeln('Volume name expected');
     ch_expected   : writeln('Single character expected');
     num_expected  : writeln('Number > 0 expected');
     null          : case verb of
                       consym   : connect;
             phelpsym, helpsym  : help;
                       recsym   : begin
                                    rec_sw( rec_ok );
                                    write( chr(bell) );
                                    gotoxy( 0, prompt_line - 1 );
                                    if not rec_ok then write('Un');
                                    write( 'succesfull receive' );
                                    close( rec_file, lock );
                                    gotoxy( 0, prompt_line );
                                  end;
                       sendsym  : begin
                                    send_sw( send_ok );
                                    write( chr(bell) );
                                    gotoxy( 0, prompt_line - 1 );
                                    if not send_ok then write('Un');
                                    write('succesfull send');
                                    close( applefile );
                                    gotoxy( 0, prompt_line );
                                  end;
                       setsym   : set_parms;
              dirsym, pdirsym,
           pshowsym, show_sym   : show_parms;
                     end; (* case verb *)
   end; (* case parse *)
 until (verb = exitsym) or (verb = quitsym);
 closeup
end. (* kermit *)

(*=== KERMGLOB.TEXT ===*)
(* >>>> KERMGLOB.TEXT  ************************************************)

(*$S+*)
(*$I-*)
(*$R-*)
(*$V-*)

UNIT kermglob;   INTRINSIC CODE 16   DATA  17;

INTERFACE

  CONST version = 'RUG/PT 1.0';
        cs_file = 'CONSOLE:';
        pr_file = 'PRINTER:';
        setup_file = '*KERMIT.DATA';
        sys_misc_file = '*SYSTEM.MISCINFO';
        blk_size = 512;
        page_size = 1024;
        outport = 8;        (* output port #  remout*)
        inport = 7;         (* input  port #  remin *)
        keyport = 2;
        consol  = 1;
        line_printer = 6;
        bell = 7;           (* ASCII bell *)
        linefeed = 10;      (* ASCII line feed *)
        formfeed = 12;      (* ASCII formfeed *)
        backspace = 8;      (* ASCII backspace *)
        del = 127;          (* ASCII delete char *)
        xdle = 16;          (* ASCII DLE *)
                            (* space compression prefix for p_system *)
        eoline = 13;        (* end of line character  *)
        at_eof = -1;        (* value to return if at eof *)
        def_maxpack = 94;   (* default max packet size I can handle *)
        max_buf = 96;       (* max packetsize(94) + 2 *)

    (* screen control information *)
    (* console line on which to put specified info *)

        title_line = 0;
        status_line = 2;
        packet_line = 3;
        retry_line = 5;
        file_line = 7;
        error_line = 8;
        debug_line = 10;
        pack_line = 13;
        ack_line = 17;
        prompt_line = 23;
    (* position on line to put info *)
        statuspos = 36;
        packet_pos = 19;
        retry_pos = 17;
        file_pos = 11;

(*-------------------------------------------------------------------*)

TYPE packettype = packed array[ 0..maxbuf ] of char;

     parity_type = (nopar, oddpar, evenpar, markpar, spacepar);

     statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
                   unrec, fn_expected, pn_expected, ch_expected, num_expected);

     vocab = (nullsym, allsym, baudsym, consym, debugsym, delsym, dirsym,
              emulatesym, eolnsym, escsym, evensym, exitsym, filewarnsym,
              helpsym, ibmsym, localsym, marksym, maxtrysym, maxpsym, nofeedsym,
              nonesym, oddsym, offsym, onsym, paritysym, pdirsym, phelpsym,
              prefixsym, pshowsym, quitsym, recsym, rejectsym, sendsym,
              setsym, showsym, spacesym, stopbsym, textfsym, timeoutsym,
              wordlensym, xoffsym, xoffwaitsym, xonsym);

     scrcommands = (sc_up, sc_right, sc_clreol, sc_clreos, sc_home,
                    sc_delchar, sc_clrall, sc_clrline, sc_left, sc_down);

     rem_stat_rec = (all_sp_char, stop_flush_break_sp_char, scr_40_sp_char,
                     no_sp_char, mask_msbit_remin, no_mask_msbit_remin);

     cntrl_word_rec = packed record
                         channel    : ( out, inp );
                         purpose    : ( status, control );
                         reserved   :   0..2047  ;
                         special_req: ( none, rw_req );
                         filler     :   0..3 ;
                      end;

     acia_type   =  ( unknown, A6551, A6850, Fut1, Fut2, Fut3 );

(*--------------------------------------------------------------------*)

VAR rec_pkt, packet  : packet_type;

    noun, verb, adj: vocab;

    vocablist: ARRAY[vocab] OF STRING;

    err_string, prefix_vol, newprefix_vol, xfilename, line: STRING;

    newescchar, escchar, bstodel, newxonchar, xonchar, newxoffchar, xoffchar,
    newxeolchar, xeolchar, eolnchar, sohchar, mypchar, padchar, quote,
    currstate, prefix, rlf, ndfs, eraseol, eraseos, home, delchar, clrscreen,
    clrline, backsp, lf, cr, ff, xdle_char, int_key, my_quote : CHAR;

    expected: SET OF vocab;
    ctl_set, ctlq_set : SET OF CHAR;

    my_time, max_try, init_try,  data_bit, stop_bit, baud, newdbit, newstopbit,
    newbaud, xoffwtime, newxoffwait, newtimeout, newmaxtry, vol_num, crpos,
    bufpos, bufend, maxpack,mypad, pad, xtime, errplen, iostatus,
    acia_cntrl_reg, acia_comm_reg, temp, new_maxpack, spsiz, max1_data,
    max2_data : INTEGER;

    def : FILE OF INTEGER;   (* setup file at init  *)
    p, pr : INTERACTIVE; (* printer or console file *)
    untyped_f, apple_file, rec_file : FILE;

    reject_cntrl_char, fwarn, ibm, half_duplex, debug, pr_out,
    text_file, print_enable, no_ffeed,  send_ok, rec_ok, dle_flag, emulate
     : BOOLEAN;

    acia_implem : acia_type;

    new_par, parity : parity_type;

    control_word : cntrl_word_rec;

    no_sfb_char, sfb_char : rem_stat_rec;

    prefixed : ARRAY[scr_commands] OF BOOLEAN;

    filebuf: PACKED ARRAY[1..page_size] OF CHAR;

(*-----------------------------------------------------------------------*)

PROCEDURE Dummy;

IMPLEMENTATION

PROCEDURE dummy;
begin
end;

BEGIN
END. { kermglob }

(*=== KERMACIA.TEXT ===*)
(************* UNIT KERMACIA ********************************************)

(*$S+*)
(*$I-*)
(*$R-*)
(*$V-*)

UNIT KERMACIA;  intrinsic code 18   data 19;


INTERFACE

USES  kermglob;

PROCEDURE send_break ( adr_comm_reg : integer );

PROCEDURE get_acia_parms( var xpar : parity_type;
                          var xdbit, xstopbit, xbaud : integer );

PROCEDURE set_acia_parms(  xpar : parity_type;
                           xdbit, xstopbit, xbaud : integer );

IMPLEMENTATION

{ This unit implements the possibility to change baud rates, parity, number }
{ of databits and stopbits  for outgoing characters and the possibility to  }
{ send a break signal to the remote host.                                   }
{ This unit is dependent on a special unitstatus call, provided by the      }
{ attached driver for remin: ( see file remdriver.text ).                   }
{ The code below is specific for the 6551 acia on a AP2 serial card from IBS}
{ and for the 6850 acia on a CCS model 7710 ASI1 card, that is probably     }
{ similar to the Apple Com Card and the Hayes micromodem card.              }
{ On the CCS card it is not possible to change the baud rate by soft command}
{ nor is it possible to set space parity.                                   }
{ If you have a different serial card then this unit should be adapted to   }
{ the requirements of that card's acia. If you do not know how to or do not }
{ want to rewrite this unit's implementation, then you can set the value of }
{ 'acia_implem' in the kermit.data file to 0 (= unknown). The settable      }
{ parameters   will then equal the default values , but can no longer be    }
{ changed at run time. The procedure send_break will then do nothing.       }

{     acia_cntrl_reg   = -16209;     =$C0AF  Specific for a 6551 acia on a  }
{     acia_comm_reg    = -16210;     =$C0AE  AP2 serial card in slot 2.     }
{     acia_comm_reg    = -16224;     =$C0A0  Specific for CCS 6850  acia.   }
{                                            The 6850 does not have a       }
{                                            control register.              }
{ These 2 adresses are declared in unit kermglob.                           }
{ If your card also has a 6551  acia then these adresses will               }
{ probably be different. They can then be changed in the kermit.data file.  }

TYPE   baud_types      = (B16ext, B50, B75, B110, B135, B150, B300, B600,
                          B1200, B1800, B2400, B3600, B4800, B7200, B9600,
                          B19200);  { 6551 specific }

       dbit_types      = (dbit8, dbit7, dbit6, dbit5 ); { 6551 specific }

       cntrl_6551      = PACKED RECORD
                          baudr  : baud_types;
                          freq   : ( ext, int );
                          wordlen: dbit_types;
                          stpbit : ( one, variable );
                          msb1   : 0..255 ;
                         END;

       comm_6551       = PACKED RECORD
                          dont_change :  0..31 ;
                          set_par     :  BOOLEAN;
                          par_type    : ( p_odd, p_even, p_mark, p_space );
                          msb2        :  0..255 ;
                         END;

       comm_6850       = PACKED RECORD
                          filler1     :  0..3 ;
                          serdata     : ( d7pes2, d7pos2, d7pes1, d7pos1,
                                          d8pns2, d8pns1, d8pes1, d8pos1 );
                { d=databits, p=parity, e=even, o=odd, n=none, s=stopbit }
                          filler2     :  0..7 ;
                          msb3        :  0..255;
                         END;

       stat_rec1      =  RECORD
                          adres1   : INTEGER;
                          content1 : cntrl_6551;
                         END;

       stat_rec2      =  RECORD
                          adres2   : INTEGER;
                          content2 : comm_6551;
                         END;

       stat_rec3      =  RECORD
                          adres3   : INTEGER;
                          content3 : comm_6850;
                         END;

VAR    baud_rate             : ARRAY[ baud_types ] OF INTEGER;
       dbits                 : ARRAY[ dbit_types ] OF INTEGER;
       reg_6551_control      : stat_rec1;
       reg_6551_komm         : stat_rec2;
       reg_6850_comm         : stat_rec3;
       cw_status, cw_control : cntrl_word_rec;




PROCEDURE get_6551_parms ( var xpar:parity_type;
                           var xdbit, xstopbit, xbaud : integer );

BEGIN
  reg_6551_control.adres1 := acia_cntrl_reg;
  reg_6551_komm.adres2    := acia_comm_reg;
  UNITSTATUS( inport, reg_6551_control, cw_status );
  UNITSTATUS( inport, reg_6551_komm,    cw_status );
  WITH reg_6551_komm.content2 DO
    BEGIN
      IF set_par THEN BEGIN
                        CASE par_type OF
                          p_odd    : xpar := odd_par;
                          p_even   : xpar := even_par;
                          p_mark   : xpar := mark_par;
                          p_space  : xpar := space_par;
                        END;
                      END
                 ELSE xpar := no_par;
    END; { with }
  WITH reg_6551_control.content1 DO
    BEGIN
      xbaud  := baud_rate[ baudr ];
      xdbit  := dbits[ wordlen ];
      CASE stpbit OF
        one      : xstopbit := 1;
        variable : BEGIN
                     xstopbit := 2;
                     IF ( xpar <> no_par ) and ( word_len = dbit8 )
                       THEN xstopbit := 1;
                     IF ( xpar =  no_par ) and ( word_len = dbit5 )
                       THEN xstopbit := 15;
                   END;
      END; { case stpbit }
    END; { with }
END; { get_6551_parms }

{ NOTE : xstopbit = 15 actually means 1.5 stopbit }




PROCEDURE get_acia_parms{ var xpar:parity_type;
                          var xdbit,xstopbit,xbaud : integer};

begin
  if acia_implem = A6551 then get_6551_parms( xpar, xdbit, xstopbit, xbaud );
end;  { get_acia_parms }



PROCEDURE set_6551_parms (  xpar:parity_type;
                            xdbit, xstopbit, xbaud : integer );

VAR oldpar : parity_type;
    oldbaud, olddbit, oldstopb : INTEGER;
    i : baud_types;
    j : dbit_types;

BEGIN
   get_6551_parms( oldpar, olddbit, oldstopb, oldbaud );
   WITH reg_6551_komm.content2 DO
     BEGIN
       set_par := TRUE;
       CASE xpar OF
         no_par    : set_par  := FALSE;
         odd_par   : par_type := p_odd;
         even_par  : par_type := p_even;
         mark_par  : par_type := p_mark;
         space_par : par_type := p_space;
       END; { case }
     END; { with }
   UNITSTATUS( inport, reg_6551_komm, cw_control );
   WITH reg_6551_control.content1 DO
     BEGIN
       FOR i := B50 TO B19200 DO IF baud_rate[ i ] = xbaud THEN baudr := i;
       FOR j := dbit8 TO dbit5 DO IF dbits[ j ] = xdbit THEN word_len := j;
       IF xstopbit = 1 THEN stpbit := one
                       ELSE stpbit := variable;
     END; { with  }
   UNITSTATUS( inport, reg_6551_control, cw_control );
END; { set_6551_parms }


PROCEDURE set_6850_parms(  xpar:parity_type; xdbit,xstop : integer);

BEGIN
  WITH reg_6850_comm.content3 DO
    BEGIN
      IF (xdbit=7) and (xpar=evenpar) and (xstop=1) THEN serdata := d7pes1 ELSE
      IF (xdbit=7) and (xpar= oddpar) and (xstop=1) THEN serdata := d7pos1 ELSE
      IF (xdbit=7) and (xpar=evenpar) and (xstop=2) THEN serdata := d7pes2 ELSE
      IF (xdbit=7) and (xpar= oddpar) and (xstop=2) THEN serdata := d7pos2 ELSE
      IF (xdbit=8) and (xpar=markpar) and (xstop=1) THEN serdata := d8pns2 ELSE
      IF (xdbit=8) and (xpar=  nopar) and (xstop=1) THEN serdata := d8pns1 ELSE
      IF (xdbit=8) and (xpar= oddpar) and (xstop=1) THEN serdata := d8pos1 ELSE
      IF (xdbit=8) and (xpar=evenpar) and (xstop=1) THEN serdata := d8pes1 ELSE
      EXIT( set_6850_parms );
    END;  { WITH }
  reg_6850_comm.content3.filler1 := 3;
  reg_6850_comm.content3.filler2 := 0;
  reg_6850_comm.adres3 := acia_comm_reg;
  UNITSTATUS( inport, reg_6850_comm, cw_control );
  { first give an acia master reset }
  reg_6850_comm.content3.filler1 := 1;
  UNITSTATUS( inport, reg_6850_comm, cw_control );
  { set acia command register to desired value }
  parity := xpar;
  stopbit := xstop;
  databit := xdbit;
END;  { set_6850_parms }


PROCEDURE set_acia_parms {  xpar : parity_type;
                            xdbit, xstopbit, xbaud : integer };

begin
  case acia_implem of
    A6551 : set_6551_parms( xpar, xdbit, xstopbit, xbaud );
    A6850 : set_6850_parms( xpar, xdbit, xstopbit );
  end;
end;   { set_acia_parms }



PROCEDURE  send_6551_break ( adr_comm_reg : INTEGER ); EXTERNAL;
PROCEDURE  send_6850_break ( adr_comm_reg : INTEGER ); EXTERNAL;
{ See file asm.acia.text }

PROCEDURE send_break { adr_comm_reg : integer };

{ sends a break signal to the host. Signal is shut off by typing any key. }
{ The command register is restored to the previous value.                 }

begin
  case acia_implem of
    A6551 : send_6551_break( adr_comm_reg );
    A6850 : begin
              send_6850_break( adr_comm_reg );
              set_acia_parms( parity, databit, stopbit, baud );
            end;
  end;
end;   { send_break }



BEGIN
  baud_rate[ B16ext ] :=     0;
  baud_rate[ B50    ] :=    50;
  baud_rate[ B75    ] :=    75;
  baud_rate[ B110   ] :=   110;
  baud_rate[ B135   ] :=   135;
  baud_rate[ B150   ] :=   150;
  baud_rate[ B300   ] :=   300;
  baud_rate[ B600   ] :=   600;
  baud_rate[ B1200  ] :=  1200;
  baud_rate[ B1800  ] :=  1800;
  baud_rate[ B2400  ] :=  2400;
  baud_rate[ B3600  ] :=  3600;
  baud_rate[ B4800  ] :=  4800;
  baud_rate[ B7200  ] :=  7200;
  baud_rate[ B9600  ] :=  9600;
  baud_rate[ B19200 ] := 19200;
  dbits[ dbit8 ] := 8;
  dbits[ dbit7 ] := 7;
  dbits[ dbit6 ] := 6;
  dbits[ dbit5 ] := 5;
  WITH cw_status DO
    BEGIN
      channel      := inp;
      purpose      := status;
      special_req  := rw_req;
      reserved     := 0;
      filler       := 0;
    END;
  cw_control := cw_status;
  cw_control.purpose  :=  control;
  { set serial data for 6850 acia to pascal defaults }
  parity := no_par;
  stopbit := 1;
  databit := 8;
END.

(*=== KERMUTIL.TEXT ===*)
(*>>>>>>>>>>>>>>KERMUTIL>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*)

{$S+}
{$I-}
{$R-}
{$V-}

UNIT kermutil;  INTRINSIC CODE 20;

INTERFACE

   USES  kermglob;

   PROCEDURE upper_case( VAR s : STRING );

   FUNCTION  interrupt( int_key : CHAR ) : BOOLEAN;

   PROCEDURE error(VAR p: packettype; len: INTEGER);

   PROCEDURE io_error(i: INTEGER);

   PROCEDURE debugwrite( s: STRING);

   PROCEDURE packet_write( VAR p : packettype; len : INTEGER );

   PROCEDURE ack_write( ptype: CHAR; len,num: INTEGER; VAR data: packettype);

   PROCEDURE write_bool( s: STRING; b: BOOLEAN);

   PROCEDURE read_str( VAR s : STRING);

   PROCEDURE write_ctl( ch : CHAR);

   FUNCTION  test_printer : BOOLEAN;

   FUNCTION min(x,y: INTEGER): INTEGER;

   FUNCTION tochar(ch: CHAR): CHAR;

   FUNCTION unchar(ch: CHAR): CHAR;

   PROCEDURE screen( scrcmd: scrcommands );

   PROCEDURE writescreen( s: STRING);

   PROCEDURE refresh_screen(numtry, num: INTEGER);

   PROCEDURE check_apple_char( check: rem_stat_rec);

   FUNCTION ctl( ch : CHAR ) : CHAR;

   FUNCTION calc_checksum( VAR packet: packettype; len : INTEGER ) : CHAR;


IMPLEMENTATION

PROCEDURE uppercase {var s: string};

var i: integer;

begin
 for i := 1 to length(s) do
     if s[i] in ['a'..'z'] then
         s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
end; (* uppercase *)



FUNCTION interrupt{ (int_key : char) : boolean };

var buflen : packed array[0..7] of 0..255;
    ch : char;

begin
  interrupt := false;  ch := ' ';
  unitstatus( keyport, buflen[0], control_word );
  if buflen[0] > 0
    then begin
           unitread( keyport, ch, 1,, 12 );
           if ch = int_key then interrupt := true;
         end;
end;   {  interrupt  }



PROCEDURE screen{ scrcmd: scr_commands };

begin
  if prefixed[ scrcmd ] then unitwrite( consol, prefix, 1,,12 );
  case scrcmd of
     sc_up      : unitwrite( consol, rlf      , 1,,12 );
     sc_right   : unitwrite( consol, ndfs     , 1,,12 );
     sc_clreol  : unitwrite( consol, eraseol  , 1,,12 );
     sc_clreos  : unitwrite( consol, eraseos  , 1,,12 );
     sc_home    : unitwrite( consol, home     , 1,,12 );
     sc_delchar : unitwrite( consol, delchar  , 1,,12 );
     sc_clrall  : unitwrite( consol, clrscreen, 1,,12 );
     sc_clrline : unitwrite( consol, clrline  , 1,,12 );
     sc_left    : unitwrite( consol, backsp   , 1,,12 );
     sc_down    : unitwrite( consol, lf       , 1,,12 );
  end; { case }
end; { procedure screen }



PROCEDURE error{ var p: packettype; len: integer };

(* writes error message sent by remote host *)

begin
  gotoxy(0,errorline);
  screen( sc_clreol );
  write('Host error : ');
  unitwrite( consol, p[0], len,, 12 );
  gotoxy(0,promptline);
end; (* error *)



PROCEDURE io_error{ i: integer };

begin
 gotoxy( 0, errorline );
 screen( sc_clreol );
 write('IO_ERROR : ');
 case i of
      0: writeln('No error');
      1: writeln('Bad Block, Parity error (CRC)'); {not used for Apple}
      2: writeln('Bad Unit Number');
      3: writeln('Bad Mode, Illegal operation');
      4: writeln('Undefined hardware error'); {not used for Apple}
      5: writeln('Lost unit, Unit is no longer on-line');
      6: writeln('Lost file, File is no longer in directory');
      7: writeln('Bad Title, Illegal file name');
      8: writeln('No room, insufficient space');
      9: writeln('No unit, No such volume on line');
     10: writeln('No file, No such file on volume');
     11: writeln('Duplicate file');
     12: writeln('Not closed, attempt to open an open file');
     13: writeln('Not open, attempt to close a closed file');
     14: writeln('Bad format, error in reading real or integer');
     15: writeln('Ring buffer overflow');
     16: writeln('Diskette is write protected');
   end; (* case *)
 if i = 64 then writeln('Bad block on diskette');
 gotoxy(0,promptline)
end; (* io_error *)



PROCEDURE debugwrite{  s: string };

(* writes a debugging message *)

var j: integer;

begin
  gotoxy( 0, debug_line );
  screen( sc_clreol );
  write('Debug state is ', s );
end; (* debugwrite *)


PROCEDURE packet_write{  var p:packettype; len: integer };

(* writes a packet to the screen for debugging purposes *)

var i : integer;

begin
  gotoxy( 0, pack_line + 2 ); screen( sc_clreol ); gotoxy( 0, pack_line + 1 );
  screen( sc_clreol );
  unitwrite( consol, p[1], ( len-2 ), , 12 );
end; { packet_write }



PROCEDURE ack_write{ ptype: char; len,num: integer; var data: packettype};

(* writes a ack/nack package to the screen for debugging purposes *)

var i : integer;

begin
  gotoxy( 0, ack_line + 1 );
  screen( sc_clreos );
  writeln('type= ',ptype);
  writeln('num = ',num);
  writeln('len = ',len);
  unitwrite(consol, data[0], len,, 12 );
end;  { ack_write }

PROCEDURE write_bool{ s: string; b: boolean};

(* writes message & 'on' if b, 'off' if not b *)

begin
  write(p, s);
  case b of
      true: writeln(p,'ON');
      false: writeln(p,'OFF');
    end; (* case *)
end; (* write_bool *)



PROCEDURE write_ctl{ ch : char };

begin
  if ord(ch) < 32
   then begin
          if ord(ch) = 27  then write(p,'<ESC>')
                           else write(p,'<^',chr(ord(ch)+64),'> ');
        end
   else begin
          if ord(ch) = 127 then write(p,'<DEL>')
                           else write(p,'<',ch,'>  ');
        end;
end;  { write_ctl }


PROCEDURE read_str{ var s : string };

var i, j, k : integer;
         ch : char;

begin
  i := 0; s := ''; ch := ' ';
  repeat
    unitread( keyport, ch, 1 );
    if ch = backsp
      then begin
             if i > 0
               then begin
                      if s[i] in ctl_set then j := 5 else j := 1;
                      for k := 1 to j do write( ch, ' ', ch );
                      delete( s, i, 1 );
                      i := i - 1;
                    end;
           end
      else begin
             if  ch  <>  cr
               then begin
                      if i < 80
                        then begin
                               if ch in ctl_set then write_ctl( ch )
                                                else write( ch );
                               i := i + 1;
                               s := concat( s, ' ' );
                               s[i] := ch;
                             end
                        else write( chr(bell) );
                    end;
           end;
  until ch = cr;
  writeln;
end;  { read_str }



FUNCTION  test_printer;

{ this function only tests for the presence of a printerinterface card }

begin
  close( pr );
  reset( pr, pr_file );
  test_printer := ( ioresult = 0 );
end;



FUNCTION min{(x,y: integer): integer };

(* returns smaller of two integers *)

begin
 if x < y then min := x else min := y
end; (* min *)



FUNCTION tochar{ (ch: char): char };

(* tochar converts a control character to a printable one by adding space *)

begin
 tochar := chr(ord(ch) + ord(' '))
end; (* tochar *)



FUNCTION unchar{ (ch: char): char };

(* unchar undoes tochar *)

begin
  unchar := chr(ord(ch) - ord(' '))
end; (* unchar *)




PROCEDURE writescreen{  s: string };

(* sets up the screen for receiving or sending files *)

begin
   page(output);
   gotoxy( 11, titleline); write('Kermit UCSD p-System : ', s );
   gotoxy( 50, statusline - 1 );
   write('( type '); write_ctl( int_key );
   write(' to break off )');
   gotoxy(0,packetline);
   write('Number of Packets: ');
   gotoxy(0,retryline);
   write('Number of Tries: ');
   gotoxy(0,fileline);
   write('File Name: ');
   if debug then
     begin
       gotoxy(0,packline);
       write('Outgoing Packet:');
       gotoxy(0,ackline);
       write('Incoming Packet:');
     end;
end; (* writescreen *)



PROCEDURE refresh_screen{ numtry, num: integer };

(* keeps track of packet count on screen *)

begin
   gotoxy(retrypos,retryline);
   write(numtry: 5);
   gotoxy(packetpos,packetline);
   write(num: 5)
end; (* refresh_screen *)


PROCEDURE check_apple_char {  check : rem_stat_rec };

{ this procedure only works with a special implementation of unitstatus }
{ in the attached remin driver. special character checking can be turned}
{ off or on depending on the value of 'check'. also the remin driver can}
{ be instructed to pass 7 or 8 bit characters to pascal.                }

var  control_word : cntrl_word_rec;

begin
  with control_word do
    begin
      channel := inp;  purpose := control;   special_req := none;
      reserved := 0; filler := 0;
    end;
  unitstatus( inport, check, control_word );
end;  { check_apple_char }


FUNCTION ctl{ ( ch : char ) : char }; EXTERNAL;

{ toggles bit 7 of a character: ' controllifies or decontrollifies ' }

FUNCTION calc_checksum{ (var packet:packettype; len:integer):char }; EXTERNAL;

{ calculates one character checksum of a packet }


begin
end. { kermutil }

(*=== KERMPACK.TEXT ===*)
(* >>>> KERMPACK.TEXT  *************************************************)

(*$I-*)
(*$R-*)
(*$S+*)
(*$V-*)

UNIT kermpack;  INTRINSIC CODE 21  ;


INTERFACE

USES  kermglob,
      kermutil;


PROCEDURE spar;

PROCEDURE rpar;

PROCEDURE spack( ptype: CHAR; num, len: INTEGER );

PROCEDURE send_errpack( num : INTEGER );

FUNCTION  rpack(spnum: INTEGER; VAR len, rpnum: INTEGER; VAR data: packettype;
                timeout: INTEGER; soh_char: CHAR ) : CHAR;

FUNCTION  bufill_t : INTEGER;

FUNCTION  bufill_i : INTEGER;

PROCEDURE bufemp_t( len : INTEGER );

PROCEDURE bufemp_i( len : INTEGER );


IMPLEMENTATION


FUNCTION bufill_t (* : integer*);

(* fill a packet with data from a textfile...manages a 2 block buffer *)

var i, j, count: integer;
    ch : char;

begin
  i := 4; (* start at packet[4] for data chars *)
  (* while file has some data & packet has some room we'll keep going *)
  while ((bufpos <= bufend) or (not eof(applefile))) and (i < max1_data) do
    begin
      (* if we need more data from disk then *)
      if (bufpos > bufend) and (not eof(applefile)) then
        begin
          (* read a textpage = 2 blocks *)
          bufend := blockread(applefile,filebuf[1],2) * blksize;
          io_status := ioresult;
          if io_status <> 0 then exit( bufill_t );
          (* and adjust buffer pointer *)
          bufpos := 1
        end; (* if *)
      if (bufpos <= bufend) then          (* if we're within buffer bounds *)
        begin
          ch := filebuf[bufpos];          (* get a character *)
          bufpos := bufpos + 1;           (* increase buffer pointer *)
          if (ch = xdle_char) then        (* if it's space compression char, *)
            begin
              count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
              bufpos := bufpos + 1;       (* read past # *)
              ch := ' ';                  (* and make current char a space *)
            end (* if *)
            else                          (* otherwise, it's just a char *)
              count := 1;                 (* so only 1 copy of it *)
          if (ch in ctlq_set) then        (* if a control char *)
            begin
              if (ch = cr) then           (* if a carriage return *)
                begin
                  packet[i] := quote;     (* put (quoted) CR in packet *)
                  i := i + 1;
                  packet[i] := ctl( cr );
                  i := i + 1;
                  ch := lf;               (* and we'll stick a LF after *)
                end; (* if *)
              packet[i] := quote;         (* put the quote in packet *)
              i := i + 1;
              if ch <> quote then
                      ch := ctl(ch);      (* and un-controllify char *)
            end (* if *)
        end; (* if *)
      j := 1;
      while (j <= count) and (i < max2_data) do
        begin                             (* put all the chars in packet *)
          if ch <> chr(0) then            (* so long as not a NUL *)
            begin
              packet[i] := ch;
              i := i + 1;
            end (* if *)
          else bufpos := bufend +1;       (* if is a NUL so *)
                                          (* skip to end of block *)
                                          (* since rest will be NULs *)
          j := j + 1
        end; (* while *)
    end; (* while *)
  if (i = 4) then                         (* if we're at end of file, *)
      bufill_t := (at_eof)                (* indicate it *)
  else                                    (* else *)
    begin
      if (j <= count) then                (* if didn't all fit in packet *)
        begin
          bufpos := bufpos - 2;           (* put buf pointer at DLE *)
                                          (* and update compress count *)
          filebuf[bufpos + 1] := tochar(chr(count-j+1));
        end; (* if *)
      bufill_t := i                       (* return # of data in packet + 4 *)
    end; (* else *)
end; (* bufill_t *)


FUNCTION bufill_i { : integer };

{ fills packet with data form another type of file than a textfile.  }
{ This will only work if serial wordlength can be set to 8 databits, }
{ no parity and if both sides plus the transport medium do not change}
{ in any way the most significant bit of the byte send.              }

var i : integer;
    ch : char;

begin
  i := 4; ch := ' ';
  while ((bufpos <= bufend) or ( not eof(applefile))) and ( i < spsiz ) do
    begin
      if (bufpos > bufend) and ( not eof(applefile) ) then
        begin
          bufend := blockread( applefile, filebuf[1], 1) * blksize;
          io_status := ioresult;
          if io_status <> 0 then exit( bufill_i );
          bufpos := 1;
        end;
      if (bufpos <= bufend) then
        begin
          ch := filebuf[bufpos];
          bufpos := bufpos + 1;
          if ch in ctlq_set then begin
                                   packet[i] := quote;
                                   i := i + 1;
                                   if ch <> quote then ch := ctl( ch );
                                  end;
          packet[i] := ch;
          i := i + 1;
        end;
    end; { while }
  if i = 4 then bufill_i := at_eof
           else bufill_i := i;
end; { bufill_i }



PROCEDURE bufemp_t { len : integer };

var ch : char;
    i, j : integer;

begin
  i := 0;
  while i < len do
  begin
    if bufpos < ( page_size - 1 )
      then begin
             ch := rec_pkt[i];
             if ch = quote
               then begin
                      i := i + 1;
                      ch := rec_pkt[i];
                      if ch = quote
                        then begin
                               filebuf[bufpos] := ch;
                               bufpos := bufpos + 1;
                             end
                        else begin
                               ch := ctl( ch );
                               if ch in [ cr, ff ] then
                                 begin
                                   if ch = ff then if no_ffeed
                                                   then ch := cr;
                                   filebuf[bufpos]   := ch;
                                   filebuf[bufpos+1] := xdle_char;
                                   filebuf[bufpos+2] := ' ';
                                   crpos := bufpos;
                                   bufpos := bufpos + 3;
                                   dle_flag := true;
                                 end;
                             end;
                    end
               else begin
                      if ( ch = ' ' ) and dle_flag
                        then filebuf[bufpos-1] := succ( filebuf[bufpos-1] )
                        else begin
                               dle_flag := false;
                               filebuf[bufpos] := ch;
                               bufpos := bufpos + 1;
                             end;
                    end;
             i := i + 1;
           end
      else begin
             j := blockwrite( rec_file, filebuf[1], 1 );
             bufpos := bufpos - crpos;
             moveleft( filebuf[crpos], filebuf[1], bufpos );
             fillchar( filebuf[crpos], pagesize + 1 - crpos, chr(0) );
             j := blockwrite( rec_file, filebuf[blk_size + 1], 1 );
             io_status := ioresult;
             if j <> 1 then io_status := 8;
             if io_status <> 0 then exit( bufemp_t );
             bufpos := bufpos + 1;
             crpos := pagesize - 1;
           end;
  end;
end;  { bufemp_t }




PROCEDURE bufemp_i { len : integer };

var ch : char;
    i, j : integer;

begin
  i := 0;
  while i < len do
  begin
    if bufpos <= blk_size
      then begin
             ch := rec_pkt[i];
             if ch = quote
               then begin
                      i := i + 1;
                      ch := rec_pkt[i];
                      if ch <> quote then ch := ctl( ch );
                    end;
             filebuf[bufpos] := ch;
             bufpos := bufpos + 1;
             i := i + 1;
           end
      else begin
             j := blockwrite( rec_file, filebuf[1], 1 );
             bufpos := 1;
             io_status := ioresult;
             if j <> 1 then io_status := 8;
             if io_status <> 0 then exit( bufemp_i );
           end;
  end;
end;  { bufemp_i }





PROCEDURE spar;

(* fills packet with my send-init parameters *)

  begin
    packet[4] := tochar(chr(maxpack));   (* biggest packet i can receive *)
    packet[5] := tochar(chr(mytime));    (* when i want to be timed out *)
    packet[6] := tochar(chr(mypad));     (* how much padding i need *)
    packet[7] := ctl(mypchar);           (* padding char i want *)
    packet[8] := tochar(eoln_char);      (* end of line character i want *)
    packet[9] := myquote;                (* control-quote char i want *)
    packet[10]:= chr(0);                 (* I won't do 8-bit quoting *)
  end; (* spar *)



PROCEDURE rpar;

(* gets their init params *)

begin
  spsiz     := ord(unchar(rec_pkt[0]));         (* max send packet size     *)
  max1_data := spsiz - 2;                       (* calculate maximal        *)
  max2_data := spsiz + 1;                       (* data limits for bufill_t *)
  xtime     := ord(unchar(rec_pkt[1]));         (* when i should time out   *)
  pad       := ord(unchar(rec_pkt[2]));         (* number of pads to send   *)
  padchar   := ctl(rec_pkt[3]);                 (* padding char to send     *)
  xeol_char := unchar(rec_pkt[4]);              (* eol char i must send     *)
  quote     := rec_pkt[5];                      (* incoming data quote char *)
end; (* rpar *)


PROCEDURE spack(*ptype: char; num: integer; len: integer*);

(* send a packet *)

const mtry = 10000;

var j, i, count: integer;
    ch: char;

begin
  if ibm and (currstate <> 's') then           (* if ibm and not SINIT then *)
    begin
      count := 0; ch := ' ';
      repeat                                   (* wait for an xon *)
        repeat
            count := count + 1;
            unitstatus( inport, j, control_word );
        until ( j > 0 ) or ( count > mtry );
        unitread( inport, ch, 1,, 12 );
      until (ch = xon_char) or (count > mtry);
      if count > mtry then exit( spack ); (* if wait too long then get out *)
    end; (* if *)

  if pad > 0 then
    begin
      for i := 1 to pad do
      unitwrite( outport, padchar, 1,, 12 ); (* write out any padding chars *)
    end;
  packet[0] := soh_char;                     (* packet sync character *)
  packet[1] := tochar(chr(len - 1));         (* character count *)
  packet[2] := tochar(chr(num));             (* packet number *)
  packet[3] := ptype;                        (* packet type *)
   (* data chars have already been filled in by by the bufill procedure *)
                                             (* compute final chksum *)
                                             (* len=data chars + 4 *)
  packet[len]   := tochar( calc_checksum( packet, len ) );
  packet[len+1] := xeol_char;
  if debug then packet_write( packet, len+2 );
  unitwrite( outport, packet[0], len+2,, 12 );
end; (* spack *)


PROCEDURE  send_errpack { num : integer };

var len : integer;

begin
  len := length ( err_string );
  moveleft( err_string[1], packet[4], len );
  spack( 'E', num, len+4 );
end;  { send_errpack }


FUNCTION rpack{ (spnum:integer; var len,rpnum:integer; data:packettype;  }
              {  timeout:integer; soh_char:char) : char } ; EXTERNAL;

{ this function listens to the serial input port, detects a kermit }
{ package, decodes it and returns the data part of the packet.     }
{ its function value is the type of the received packet. If there  }
{ was a receive error or the timeout period (1..31 sec) was        }
{ exhausted without receiving a valid packet the function returns  }
{ with '@' as value, with rpnum=spnum and with len = 0.            }


begin
end. { kermpack }
(*=== SENDER.TEXT ===*)
(* >>>> SENDER.TEXT  ***************************************************)

(*$I-*)
(*$R-*)
(*$S+*)
(*$V-*)

UNIT sender;    INTRINSIC CODE 26   ;

INTERFACE

USES  kermglob,
      kermutil,
      kermpack;

PROCEDURE sendsw( VAR send_ok: BOOLEAN );


IMPLEMENTATION


PROCEDURE  sendsw{ var send_ok : boolean };

VAR size, numtry, spnum, rpnum, len : INTEGER;
    ch : CHAR;
    leg_fname : STRING;
    ready : boolean;



FUNCTION  openfile : BOOLEAN;

(* resets file & gets past first 2 blocks in case of textfile *)

var b : integer;

begin
  reset( apple_file,  xfile_name );
  io_status := ioresult;
  if io_status = 0 then
    begin
      if text_file then
        b := blockread( apple_file, filebuf[1], 2 );
        { for a textfile skip past the first two blocks }
        io_status := ioresult;
        bufend := 0;
        bufpos := 1;
    end;
  openfile := ( io_status = 0 );

end; { open_file }


PROCEDURE legalize( var fn : string );

{ make filename acceptable to host }
{ filename is already uppercase and cannot contain a ':' as last char. }

var i, point_pos, len : integer;

begin
  delete( fn, 1, pos( ':', fn ) );   { strip off volumename }
  len := length( fn );
  i := 1; point_pos := 1;
  repeat
    if fn[i] = '.' then point_pos := i; { save last occurrence of '.' }
    if not ( fn[i] in [ '0'..'9', 'A'..'Z' ] )  then fn[i] := 'X';
    { replace every non alphanumeric character with a 'X' }
    i := i + 1;
  until i > len;
  if point_pos > 1 then fn[point_pos] := '.';
  { restore last encountered '.', except when '.' was in first position }
end; { legalize }




FUNCTION sinit: char;

(* send init packet & receive other side's *)

begin
  sinit := 's';    { default state remains 's' }
  if debug then debugwrite('sinit');
  if interrupt(int_key) or (num_try > init_try) then
    begin
      sinit := 'a';
      send_errpack( spnum );
      exit( sinit )
    end;
  num_try := num_try + 1;
  spar;
  refresh_screen( numtry, spnum );
  spack( 'S', spnum, 10 );
  unitclear( inport );            { clear remin buffer }
  ch := rpack( spnum, len, rpnum, recpkt, xtime, soh_char );
  if debug then ack_write(  ch, len, rpnum, recpkt );
  if ch = 'Y' then begin
                     if spnum <> rpnum then exit( sinit );  { stay in 's' }
                     rpar;  { get other side init package }
                     if xeol_char = chr(0) then xeol_char := eoln_char;
                     if quote= chr(0) then quote:= my_quote;
                     if xtime= 0 then xtime:= my_time;
                     if xtime>32 then xtime:= 31;
                     { use my parameters if other side did not specify them }
                     if text_file then ctlq_set := ctl_set + [quote] - [chr(0)]
                                  else
                     ctlq_set := ctl_set + [quote,chr(128)..chr(159),chr(255)];
                     { for image transfer add msbit control chars to set }
                     numtry := 0;
                     spnum := 1;
                     sinit := 'f';  { go to next state }
                   end  { then }
              else if ( ch <> 'N' ) and ( ch <> '@' ) then
                begin
                  sinit := 'a';   { for nack or receive failure stay in 's' }
                                  { for every other state : abort }
                  if ch = 'E' then error( recpkt, len );
                end;  { else }
end; (* sinit *)




FUNCTION sdata: char;

(* send file data *)

begin
  if debug then debug_write( 'sdata' );
  if text_file then size := bufill_t
               else size := bufill_i;
  if io_status <> 0 then begin
                           io_error( io_status );
                           send_errpack( spnum );
                           sdata := 'a';
                           exit( sdata );
                         end;
  while ( currstate = 'd' ) do
    begin
      if interrupt(int_key) or (numtry > maxtry) then
        begin
          sdata := 'a';
          send_errpack( spnum );
          exit( sdata )
        end;
      numtry := numtry + 1;
      refresh_screen( numtry, spnum );
      spack( 'D', spnum, size );
      unitclear( inport );
      ch := rpack( spnum, len, rpnum, recpkt, xtime, soh_char );
      if debug then ack_write( ch, len, rpnum, recpkt );
      if ch = 'N'
        then if ((spnum+1) mod 64 ) <> rpnum
               then ch := '@'   { if a nack and not the right num: stay in 'd'}
               else begin
                      rpnum := (rpnum+63) mod 64;  { if a nack for the next }
                      ch := 'Y';                   { packet: same as ack for}
                    end;   { this packet: indicate an ack. }
      if ch = 'Y'
        then begin
               if spnum = rpnum   { right ack received }
                 then begin
                        if text_file then size := bufill_t
                                     else size := bufill_i;
                        if io_status <> 0
                          then begin
                                 io_error( io_status );
                                 send_errpack( spnum );
                                 sdata := 'a';
                                 exit( sdata );
                               end;
                        if size = at_eof then currstate := 'z';
                        spnum := (spnum+65) mod 64;
                        numtry := 0;
                        { go to next state if data is exhausted, else }
                        { stay in the same state and send next packet }
                      end;
              end
         else if ch <> '@'
                then begin
                       currstate := 'a';
                       if ch = 'E' then error( recpkt, len );
                     end;
    end;  { while }
  sdata := currstate;
end; (* sdata *)




FUNCTION sfile: char;

(* send file header *)

begin
  sfile := 'f';
  if debug then debugwrite('sfile');
  if interrupt(int_key) or ( numtry > maxtry ) then
    begin
      sfile := 'a';
      send_errpack( spnum );
      exit( sfile )
    end;
  numtry := numtry + 1;
  len := length( leg_fname );
  moveleft( leg_fname[1], packet[4], len ); (* move filename into  packet *)
  gotoxy( filepos, fileline );
  write( xfile_name, ' ==> ', leg_fname );
  refresh_screen( numtry, spnum );
  spack( 'F', spnum , len + 4 );          (* send file header packet *)
  unitclear( inport );
  ch := rpack( spnum, len, rpnum, recpkt, xtime, soh_char );
  if debug then ack_write( ch, len, rpnum, recpkt );
  if ch = 'N' then begin
                     if ((spnum + 1 ) mod 64) <> rpnum
                       then exit( sfile )  { a nack for the next packet is an }
                       else begin          { ack for the current packet       }
                              rpnum := (rpnum+63) mod 64; { r = r - 1 }
                              ch := 'Y';
                            end;
                   end;
   if ch = 'Y' then begin
                      if spnum <> rpnum then exit( sfile );  { stay in 'f' }
                      numtry := 0;
                      spnum := ( spnum + 65 ) mod 64; { s = s + 1 }
                      sfile := 'd';  { go to next state }
                    end
                else if ch <> '@' then begin
                                         sfile := 'a';
                                         if ch = 'E' then error( recpkt, len );
                                       end;
               { for rec. failure stay in 'f', other states : abort }
end; (* sfile *)




FUNCTION seof: char;

(* send end of file *)

begin
  seof := 'z';
  if debug then debugwrite('seof');
  if interrupt(int_key) or (numtry > maxtry) then (*if too many tries, give up*)
    begin
      seof := 'a';
      send_errpack( spnum );
      exit(seof)
    end;
  numtry := numtry + 1;
  refresh_screen( numtry, spnum );
  spack( 'Z', spnum, 4 );    (* send end of file packet *)
  unitclear( inport );
  ch := rpack( spnum, len, rpnum, recpkt, xtime, soh_char );
  if debug then ack_write( ch, len, rpnum, recpkt );
  if ch = 'N' then
    if ((spnum+1) mod 64) <> rpnum then exit( seof )
                                   else begin
                                          rpnum := (rpnum+63) mod 64;
                                          ch := 'Y';
                                        end;
  if ch = 'Y'
    then begin
           if spnum <> rpnum then exit( seof )
                             else begin
                                    numtry := 0;
                                    spnum := (spnum+65) mod 64;
                                    seof := 'b';
                                  end;
         end
    else if ch <> '@' then begin
                             seof := 'a';
                             if ch = 'E' then error( recpkt, len );
                           end;
end; (* seof *)



FUNCTION sbreak: char;

(* send break (end of transmission) *)

begin
  sbreak := 'b';
  if debug then debugwrite('sbreak');
  if interrupt(int_key) or (numtry > maxtry) then (*if too many tries, give up*)
    begin
      sbreak := 'a';
      send_errpack( spnum );
      exit(sbreak)
    end;
  numtry := numtry + 1;
  refresh_screen(numtry, spnum);
  spack( 'B', spnum, 4);    (* send end of file packet *)
  unitclear( inport );
  ch := rpack( spnum, len, rpnum, recpkt, xtime, soh_char );
  if debug then ack_write( ch, len, rpnum, recpkt );
  if ch = 'N' then
    if ((spnum+1) mod 64) <> rpnum then exit( sbreak )
                                   else begin
                                          rpnum := (rpnum+63) mod 64;
                                          ch := 'Y';
                                        end;
  if ch = 'Y'
    then begin
           if spnum <> rpnum then exit( sbreak );
           sbreak := 'c';
         end
    else if ch <> '@' then begin
                             sbreak := 'a';
                             if ch = 'E' then error( recpkt, len );
                           end;
end; (* sbreak *)



{   PROCEDURE sendsw   }

(* state table switcher for sending *)

begin (* sendsw *)
  unitclear( inport );
  write_screen('Sending ');
  if text_file and ( pos( '.TEXT', xfile_name ) = 0 )
    then xfile_name := concat( xfile_name, '.TEXT' );
  gotoxy( filepos, fileline ); write( xfile_name );
  if not openfile then
    begin
      io_error(io_status);
      send_ok := false;
      exit(sendsw)
    end;
  leg_fname := xfile_name;
  legalize( leg_fname );
  if not text_file then check_apple_char( no_mask_msbit_remin );
  { for image transfer leave msbit unchanged }
  check_apple_char( sfb_char );
  { restore action of ^S, ^F, ^@ keys during send }
  currstate := 's';
  spnum:= 0;       (* set packet # *)
  numtry := 0;
  ready := false;
  while not ready do
    begin
      if currstate in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
        case currstate of
            'd': currstate := sdata;
            'f': currstate := sfile;
            'z': currstate := seof;
            's': currstate := sinit;
            'b': currstate := sbreak;
            'c': begin
                   send_ok := true;
                   ready := true;
                 end; (* case c *)
            'a': begin
                   send_ok := false;
                   ready := true;
                 end (* case a *)
          end (* case *)
      else (* state not in legal states *)
        begin
          send_ok := false;
          ready := true;
        end (* else *)
    end; { of while }
  check_apple_char( mask_msbit_remin );
  check_apple_char( no_sfb_char );
end; (* sendsw *)


begin
end. { sender }

(*=== RECEIVER.TEXT ===*)
(* >>>> RECEIVER.TEXT  *************************************************)

{$I-}
{$R-}
{$S+}
{$V-}

UNIT receiver;    INTRINSIC CODE 25   ;

INTERFACE

USES  kermglob,
      kermutil,
      kermpack;


PROCEDURE recsw( VAR rec_ok: BOOLEAN );


IMPLEMENTATION


PROCEDURE recsw{ var rec_ok: boolean };

var  oldtry, numtry, spnum, rpnum, len : integer;
     ch : char;
     host_fname : string;
     ready : boolean;



FUNCTION open_file( var fn : string ) : boolean;

var i : integer;

begin
  rewrite( rec_file , concat( prefix_vol, fn ) );
  iostatus := ioresult;
  if iostatus = 0 then
      if text_file then begin
                          fillchar( filebuf[1], page_size, chr(0) );
                          i := blockwrite( rec_file, filebuf[1], 2);
                          iostatus := ioresult;
                          if i <> 2 then io_status := 8;
                        end;
  open_file := ( io_status = 0 );
  bufpos := 1;
  crpos  := page_size - 1;
  dle_flag := false;
end;   { open_file }


FUNCTION close_file : boolean;

var file_end, num_block, i : integer;

begin
  if text_file then begin
                      file_end := page_size;
                      num_block := 2;
                    end
               else begin
                      file_end := blk_size;
                      num_block := 1;
                    end;
  fillchar( filebuf[bufpos], (file_end - bufpos), chr(0) );
  i := blockwrite( rec_file, filebuf[1], num_block );
  iostatus := ioresult;
  if i <> num_block then io_status := 8;
  close_file := ( io_status = 0 );
  close( rec_file, lock );
end;  { close_file }




FUNCTION exist( var fn : string ) : boolean;

begin
  reset( rec_file, concat( prefix_vol, fn ) );
  exist := ( ioresult = 0 );
  close( rec_file )
end; { exist }


PROCEDURE check_name( var fn : string );

var ch : char;
     i : integer;

begin
  i := 1;
  while ( i <= length( fn ) ) and exist( fn ) do
    begin
      ch := 'A';
      while ( ch in [ 'A'..'Z' ] ) and exist( fn ) do
        begin
          fn[ i ] := ch;
          ch := succ( ch );
        end;
      i := i + 1;
    end;
end;  { check_name }


PROCEDURE make_name( var rpkt: packettype; var fn : string; len : integer );

{ change the received filename into a legal apple ucsd filename }

var i : integer;

begin
  host_fname[0] := chr( min( 80, len ) );
  moveleft( rpkt[0], host_fname[1], min( 80, len ) );
  fn := copy( host_fname, 1, min( 15, len ) );
  { take left part of received filename, max 15 long }
  uppercase( fn );
  if  text_file
    then begin
           if ( length(fn) < 5 ) or ( pos('.TEXT',fn) <> length(fn) - 4 )
             then begin
                    if length(fn) > 10 then fn := copy(fn,1,10);
                    fn := concat( fn, '.TEXT' );
                  end;
         end;
  { add .TEXT if the expected file is a textfile }
  for i := 1 to length( fn ) do
    if fn[i] in [ chr(0)..chr(31),':','$',',','=','?','[' ] then fn[i] := 'X';
  { replace apple ucsd incompatible char's in filename with 'X' }
  if fwarn then checkname( fn );
end;  { make_name }




FUNCTION rdata: char;

(* send file data *)


begin
  if debug then debug_write( 'rdata' );
  repeat
    currstate := 'a';
    if interrupt(int_key) or (numtry > maxtry) then
      begin
        rdata := 'a';
        send_errpack( spnum );
        exit( rdata )
      end;
    num_try := num_try + 1;
    unitclear( inport );
    ch := rpack(spnum, len, rpnum, recpkt, xtime, sohchar );{ receive a packet }
    refresh_screen( numtry, spnum );
    if debug then ack_write( ch, len, rpnum, recpkt );
    case ch of
    'D' : { got data packet. if wrong packet number : abort. }
          { if previous packet : ack it again but not more than maxtry times }
          begin
            if spnum = rpnum
              then begin
                     if text_file then bufemp_t( len )
                                  else bufemp_i( len );
                     if io_status <> 0
                       then begin
                              io_error( io_status );
                              send_errpack( spnum );
                            end
                       else begin
                              spack( 'Y', spnum, 4 );
                              numtry := 0;
                              spnum := ( spnum + 65 ) mod 64;
                              currstate := 'd';
                            end;
                   end
              else begin
                     if ( (spnum-1) mod 64 ) = rpnum
                       then begin
                              if oldtry > maxtry then begin
                                                        rdata := 'a';
                                                        exit( rdata );
                                                      end;
                              spack( 'Y', rpnum, 4 );
                              numtry := 0;
                              oldtry := oldtry + 1;
                              currstate := 'd';
                            end;
                   end;
          end;  { case 'D' }
    'F' : { got file header packet again: if it was previous packet }
          { ack it again but not more than maxtry times. any other  }
          { packet number : abort }
          begin
            if ( (spnum-1) mod 64 ) = rpnum
              then begin
                     if oldtry > maxtry then begin
                                               rdata := 'a';
                                               exit( rdata );
                                             end;
                     spack ( 'Y', rpnum, 4 );
                     numtry := 0;
                     oldtry := oldtry + 1;
                     currstate := 'd';
                   end;
          end;  { case 'F' }
    'E' : { error packet received : write it to screen and abort }
          error( recpkt, len );
    '@' : { in case of receive failure send nack and stay in this state }
          begin
            spack( 'N', spnum, 4 );
            currstate := 'd';
          end;
    'Z' : { end-of-file packet received : if it has the right packet number }
          { close the current file and go to rfile state to check whether   }
          { another file haeder packet is coming or an end-of-transmission  }
          { packet. }
          begin
            if spnum = rpnum
              then begin
                     if debug then debugwrite( 'reof' );
                     if not close_file
                       then begin
                              io_error( io_status );
                              send_errpack( spnum );
                            end
                       else begin
                              spack( 'Y', spnum, 4 );
                              spnum := ( spnum + 65 ) mod 64;
                              numtry := 0;
                              oldtry := 0;
                              currstate := 'f';
                            end;
                   end;
          end;  { case 'Z' }
    end;  { case ch }
  until (currstate <> 'd');
  rdata := currstate
end;  { rdata }




FUNCTION rfile: char;

(* receive file header *)

begin (* rfile *)
  currstate := 'a';                 (* set default state for rfile to abort *)
  if debug then debug_write( 'rfile' );
  if interrupt(int_key) or (numtry > maxtry) then
    begin
      rfile := 'a';
      send_errpack( spnum );
      exit( rfile )
    end;
  numtry := numtry + 1;
  unitclear( inport );
  ch := rpack(spnum, len, rpnum, recpkt, xtime, sohchar); (* receive a packet *)
  refresh_screen( numtry, spnum );
  if debug then ack_write( ch, len, rpnum, recpkt );

  case ch of
  'S' : { maybe our ack for packet 0 was lost: send it again, but not more }
        { than maxtry times }
        begin
          if ((spnum-1) mod 64) = rpnum
            then begin
                   if oldtry > maxtry then begin rfile := 'a'; exit(rfile) end;
                   spar;
                   spack( 'Y', rpnum, 10 );
                   numtry := 0;
                   oldtry := oldtry + 1;
                   currstate := 'f';   { stay in same state }
                 end;                  { for any other packet num: abort }
        end;  { case 'S' }
  'Z' : { maybe our ack for the eof packet was lost: ack it again }
        begin
          if ((spnum-1) mod 64) = rpnum
            then begin
                   if oldtry > maxtry then begin rfile := 'a'; exit(rfile) end;
                   spack( 'Y', rpnum, 4 );
                   numtry := 0;
                   oldtry := oldtry + 1;
                   currstate := 'f';     { stay in same state }
                 end;                    { for any other packet num: abort }
        end;  { case 'Z' }
  'B' : { if the right packet num for the eot packet then ack it and go }
        { to the complete state; else abort }
        begin
          if spnum = rpnum
            then begin
                   if debug then debug_write( 'rbreak' );
                   spack( 'Y', spnum, 4 );
                   currstate := 'c';
                 end;                { if not the right num: abort }
        end;  { case 'B' }
  '@' : { in case of receive failure send nack and stay in this state }
        begin
          spack( 'N', spnum, 4 );
          currstate := 'f';
        end;  { case '@' }
  'E' : { error packet received: write it on screen and abort }
        error( recpkt, len );
  'F' : { fileheader packet received which is what we really want: }
        { if not the right packetnumber : abort }
        { if a new file cannot be opened : send error packet to host and abort}
        { if new file is opened : go to receive data state }
        begin
          if spnum = rpnum
            then begin
                   makename( recpkt, xfilename, len );
                   gotoxy( file_pos, file_line );
                   write( host_fname, ' ==> ', concat(prefix_vol, xfilename));
                   if not open_file( xfilename )
                     then begin
                            io_error( io_status );
                            send_errpack( spnum );
                          end
                     else begin
                            spack( 'Y', spnum, 4 );
                            numtry := 0;
                            oldtry := 0;
                            spnum := ( spnum + 65 ) mod 64;
                            currstate := 'd';
                          end;
                 end;
        end; { case 'F' }
  end;  { case ch }
  rfile := currstate;
end; (* rfile *)




FUNCTION rinit: char;

(* receive initialization *)

begin
  rinit := 'r';   { stay in 'r' in case reception failed: ptype = '@'  }
  if debug then debug_write( 'rinit' );
  if interrupt(int_key) or (numtry > init_try) then
    begin
      rinit := 'a';
      send_errpack( spnum );
      exit( rinit )
    end;

  { too many tries : abort. inittry is five times maxtry in case other }
  { side waits before starting to send.                                }

  numtry := numtry + 1;
  unitclear( inport );
  ch := rpack(spnum, len, rpnum, recpkt, mytime, sohchar);(* receive a packet *)
  refresh_screen(num_try, spnum);
  if debug then ack_write( ch, len, rpnum, recpkt );

  if (ch = 'S') then                        (* send init packet *)
    begin
      rpar;                         (* get other side's init data *)
      spar;                         (* fill packet with my init data *)
      numtry := 0;                          (* start a new counter *)
      oldtry := 0;                          (* start oldtry for rfile *)
      spack( 'Y', spnum, 10 );       (* send my init parameters *)
      spnum := (spnum + 65) mod 64;         (* bump packet number *)
      rinit := 'f';                         (* enter file send state *)
    end { if 'S' }
  else if (ch <> '@') then                  (* abort for every other packet *)
         begin                              (* except when rec failed, then *)
           rinit := 'a';
           if ch = 'E' then error( recpkt, len )
         end
         else spack( 'N', spnum, 4);        (* send a NACK packet *)
end; (* rinit *)


{   PROCEDURE RECSW   }

(* state table switcher for receiving packets *)


begin (* recsw *)
  unitclear(inport);
  writescreen('Receiving');
  if not text_file then check_apple_char( no_mask_msbit_remin );
  { for image transfer leave msbit unchanged }
  check_apple_char( sfb_char );
  { restore action of ^S, ^F, ^@ keys during receive }
  ready := false;
  currstate := 'r';            (* initial state is send *)
  spnum := 0;                  (* set packet # *)
  numtry := 0;                 (* no tries yet *)

  while not ready do
    begin
      if currstate in ['d', 'f', 'r', 'c', 'a'] then
        case currstate of
          'd': currstate := rdata;
          'f': currstate := rfile;
          'r': currstate := rinit;
          'c': begin
                 rec_ok := true;
                 ready := true;
               end; (* case c *)
          'a': begin
                 rec_ok := false;
                 ready := true;
               end (* case a *)
        end (* case *)
      else (* state not in legal states *)
      begin
        rec_ok := false;
        ready := true;
      end; (* else *)
    end; { while }
  check_apple_char( mask_msbit_remin );
  check_apple_char( no_sfb_char );
end; (* recsw *)


begin
end. { receiver }

(*=== PARSER.TEXT ===*)
(*>>>>>>>>>>>>PARSER>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*)

(*$S+*)
(*$I-*)
(*$R-*)
(*$V-*)

UNIT parser;   INTRINSIC CODE 23  DATA 24;


INTERFACE

USES  kermglob,
      kermutil;

FUNCTION parse: statustype;


IMPLEMENTATION

VAR first_sym, last_sym : vocab;



PROCEDURE isolate_word ( var line, word : string; var wlen : integer );

var  line_len : integer;

begin
  word := '';  wlen := 0;  linelen := length( line );
  if linelen > 0
    then begin
           delete( line, 1, scan( linelen, <> ' ', line[1] ) );
           linelen := length( line );
           if linelen > 0
             then begin
                    wlen := scan( linelen, = ' ', line[1] );
                    word := copy( line, 1, wlen );
                    delete( line, 1, wlen );
                  end;
         end;
end;  { isolate_word }



FUNCTION get_fn( var line, fn: string; namelen : integer ) : boolean;

{ checks the length of the filename requested for 'send'.              }
{ Or checks the prefix volume name for files to be received.           }

var i, l: integer;

begin
  get_fn := true;
  isolate_word( line, fn, l );
  if (l > namelen) or (l < 1) then get_fn := false
   { max filename length, incl. volumename = 23 }
   { max volumename length, incl. ':' = 8 }
  else begin
         if (fn[l] = ':') and (namelen=23)  then get_fn := false;
         if (fn[l] <> ':') and (namelen=8)  then get_fn := false;
         {  legality of volume and filename will be tested   }
         {  when the file is actually opened. ( see unit "sender" )   }
       end;
end; (* get_fn *)




FUNCTION get_num( var line: string; var n: integer ): boolean;

var
   numstr: string;
   i, numstr_len  : integer;
begin
   get_num := true; n := 0;
   isolate_word( line, numstr, numstr_len );
   if (numstr_len < 6) and (numstr_len > 0) then
     begin
       i := 1;
       numstr := concat( numstr, ' ' );
       while (numstr[i] in ['0'..'9']) do begin
          if n<(maxint div 10) then
             n := n*10 + ord( numstr[i] ) - ord( '0' );
          i := i + 1
       end { while }
     end; { if }
   if n = 0 then get_num := false;
end; { get_num }




FUNCTION nextch(var ch: char): boolean;

var s: string;
    ch_len : integer;

begin
 isolate_word( line, s, ch_len );
 if ch_len <= 1 then begin
                       if ch_len = 1 then ch := s[1]
                                     else ch := cr;
                       nextch := true;
                     end
                else nextch := false;
end; (* nextch *)



FUNCTION get_sym(var word: vocab): statustype;

var i: vocab;
    s: string;
    stat: statustype;
    done: boolean;
    matches, slen : integer;

begin
  isolate_word( line, s, slen );
  if slen = 0 then getsym := ateol
   else
     begin
       stat := null;
       done := false;
       i := first_sym;
       matches := 0;
       repeat
           if (pos(s,vocablist[i]) = 1) and (i in expected) then
             begin
               matches := matches + 1;
               word := i
             end
           else if (s[1] < vocablist[i,1]) then
               done := true;
           if (i = last_sym ) then
               done := true
           else
               i := succ(i)
       until (matches > 1) or done;
       if matches > 1 then
           stat := ambiguous
       else if (matches = 0) then
           stat := unrec;
       getsym := stat
     end (* else *)
end; (* getsym *)





FUNCTION parse(*: statustype*);

type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off,
               get_esc_char, get_show_parm, get_help_show, get_help_parm,
               exitstate, get_baud, get_wordlen, get_stopbit, get_xon_char,
               get_xoff_char, get_xoffwait, get_nofeed, get_timeout, get_maxpak,
               get_eoln_char, get_maxtry, get_prefix, get_dir);

var status: statustype;
    word: vocab;
    state: states;

           procedure case_start;

           begin
             expected := [consym, exitsym, helpsym, phelpsym, quitsym, recsym,
                          sendsym, setsym, showsym, pshowsym, dirsym, pdirsym];
             status := getsym(verb);
             if status = ateol then
               begin
                 parse := null;
                 exit(parse)
               end (* if *)
             else if (status <> unrec) and (status <>  ambiguous) then
                 case verb of
                   consym, recsym, exitsym, quitsym: state := fin;
                   helpsym         : begin
                                       state := get_help_parm;
                                       pr_out:= false
                                     end;
                   phelpsym        : begin
                                       state := get_help_parm;
                                       pr_out:= true
                                     end;
                   dirsym          : begin
                                       state := get_dir;
                                       pr_out := false;
                                     end;
                   pdirsym         : begin
                                       state := get_dir;
                                       pr_out := true;
                                     end;
                   sendsym         : state := getfilename;
                   setsym          : state := get_set_parm;
                   showsym         : begin
                                       state := get_show_parm;
                                       pr_out:= false
                                     end;
                   pshowsym        : begin
                                       state := get_show_parm;
                                       pr_out:= true
                                     end;
                 end (* case *)
           end; (* case_start *)


           procedure case_fin;

           begin
             expected := [];
             status := getsym(verb);
             if status = ateol then
               begin
                 parse := null;
                 exit(parse)
               end (* if status *)
             else
                 status := unconfirmed
           end; (* case_fin *)


           procedure case_getfilename;

           begin
             expected := [];
             if getfn(line,xfilename,23) then
               begin
                 status := null;
                 state := fin
               end (* if *)
             else
                 status := fnexpected
           end; (* case_getfilename *)


           procedure case_gtprefixname;

           begin
             expected := [];
             if getfn(line,newprefix_vol,8) then
               begin
                 status := null;
                 state := fin
               end
             else
                  status := pnexpected
           end;  (* case_gtprefixname *)


           procedure case_getsetparm;

           begin
             expected := [paritysym, localsym, ibmsym, escsym, prefixsym,
                          wordlensym, stopbsym, delsym, debugsym, filewarnsym,
                          baudsym, xonsym, xoffsym, xoffwaitsym, nofeedsym,
                          timeoutsym, eolnsym, maxtrysym, emulatesym, maxpsym,
                          textfsym, rejectsym];
             status := getsym(noun);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <>  ambiguous) then
                 case noun of
                   paritysym:   state := get_parity;
                   prefixsym:   state := get_prefix;
                   escsym:      state := get_esc_char;
                   baudsym:     state := get_baud;
                   wordlensym:  state := get_wordlen;
                   stopbsym:    state := get_stopbit;
                   xonsym:      state := get_xon_char;
                   xoffsym:     state := get_xoff_char;
                   eolnsym:     state := get_eoln_char;
                   xoffwaitsym: state := get_xoffwait;
                   timeoutsym:  state := get_timeout;
                   maxtrysym:   state := get_maxtry;
                   maxpsym:     state := get_maxpak;
                   nofeedsym, filewarnsym, debugsym, delsym, textfsym,
                   ibmsym, localsym, rejectsym, emulatesym:
                                state := get_on_off;
                 end (* case *)
           end; (* case_getsetparm *)


           procedure case_getparity;

           begin
             expected := [marksym, spacesym, nonesym, evensym, oddsym];
             status := getsym(adj);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <> ambiguous) then
                 state := fin
           end; (* case_getparity  *)


           procedure case_getnum( var newnum : integer );

           begin
             expected := [];
             if get_num( line, newnum ) then
               begin
                 status := null; state := fin
               end
             else status := num_expected
           end; (* case_getnum *)


           procedure case_getonoff;

           begin
             expected := [onsym, offsym];
             status := getsym(adj);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <> ambiguous) then
                 state := fin
           end; (* case_ getonoff *)


           procedure case_getchar( var newchar : char );

           begin
             if nextch(newchar) then
                state := fin
             else
                status := ch_expected;
           end; (* case_getchar *)


           procedure case_gtshowparm;

           begin
             expected := [allsym, paritysym, localsym, ibmsym, prefixsym,
                          wordlensym, stopbsym, escsym, delsym, debugsym,
                          filewarnsym, baudsym, xonsym, xoffsym, xoffwaitsym,
                          nofeedsym, timeoutsym, eolnsym, emulatesym, maxpsym,
                          maxtrysym, textfsym, rejectsym];
             status := getsym(noun);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <>  ambiguous) then
                 state := fin
           end; (* case_gtshowparm *)


           procedure case_gethelpshow;

           begin
             expected := [paritysym, localsym, ibmsym, escsym, delsym,
                          wordlensym, stopbsym, debugsym, filewarnsym,
                          baudsym, xonsym, xoffsym, xoffwaitsym, emulatesym,
                          nofeedsym, timeoutsym, eolnsym, prefixsym, maxpsym,
                          maxtrysym, textfsym, rejectsym];
             status := getsym(adj);
             if (status = at_eol) then
               begin
                 status := null;
                 state := fin
               end
             else if (status <> unrec) and (status <>  ambiguous) then
                 state := fin
           end; (* case_gethelpshow *)


           procedure case_gthelpparm;

           begin
             expected := [consym, exitsym, helpsym, phelpsym, quitsym, recsym,
                          sendsym, setsym, showsym, pshowsym, dirsym, pdirsym];
             status := getsym(noun);
             if status = ateol then
               begin
                 parse := null;
                 exit(parse)
               end;
             if (status <> unrec) and (status <>  ambiguous) then
                 case noun of
                   consym, sendsym, recsym,
                   showsym, pshowsym, helpsym,
                   phelpsym, exitsym, quitsym,
                   dirsym, pdirsym            : state := fin;
                   setsym                     : state := get_help_show;
                 end (* case *)
           end; (* case_gthelpparm *)


begin  (*  parse  *)
  state   := start;
  parse   := null;
  noun    := nullsym;
  verb    := nullsym;
  adj     := nullsym;
  uppercase ( line );
  repeat
    case state of
      start         : case_start;
      fin           : case_fin;
      get_filename  : case_getfilename;
      get_prefix    : case_gtprefixname;
      get_set_parm  : case_getsetparm;
      get_parity    : case_getparity;
      get_baud      : case_getnum( newbaud );
      get_wordlen   : case_getnum( newdbit );
      get_stopbit   : case_getnum( newstopbit );
      get_xoffwait  : case_getnum( newxoffwait);
      get_timeout   : case_getnum( newtimeout );
      get_maxtry    : case_getnum( newmaxtry );
      get_maxpak    : case_getnum( newmaxpack );
      get_dir       : case_getnum( vol_num );
      get_on_off    : case_getonoff;
      get_esc_char  : case_getchar( newescchar );
      get_xon_char  : case_getchar( newxonchar );
      get_xoff_char : case_getchar( newxoffchar);
      get_eoln_char : case_getchar( newxeol_char );
      get_show_parm : case_gtshowparm;
      get_help_show : case_gethelpshow;
      get_help_parm : case_gthelpparm;
    end;  { case }
  until (status <> null);
  parse := status
end; (* parse *)


BEGIN  { initialization }
  vocablist[allsym]      := 'ALL';
  vocablist[baudsym]     := 'BAUD';
  vocablist[consym]      := 'CONNECT';
  vocablist[debugsym]    := 'DEBUG';
  vocablist[delsym]      := 'DELKEY';
  vocablist[dirsym]      := 'DIRECTORY';
  vocablist[emulatesym]  := 'EMULATE';
  vocablist[eolnsym]     := 'END-OF-LINE';
  vocablist[escsym]      := 'ESCAPE';
  vocablist[evensym]     := 'EVEN';
  vocablist[exitsym]     := 'EXIT';
  vocablist[filewarnsym] := 'FILE-WARNING';
  vocablist[helpsym]     := 'HELP';
  vocablist[ibmsym]      := 'IBM';
  vocablist[localsym]    := 'LOCAL-ECHO';
  vocablist[marksym]     := 'MARK';
  vocablist[maxpsym]     := 'MAXPACK';
  vocablist[maxtrysym]   := 'MAXTRY';
  vocablist[nofeedsym]   := 'NOFEED';
  vocablist[nonesym]     := 'NONE';
  vocablist[oddsym]      := 'ODD';
  vocablist[offsym]      := 'OFF';
  vocablist[onsym]       := 'ON';
  vocablist[paritysym]   := 'PARITY';
  vocablist[pdirsym]     := 'PDIRECTORY';
  vocablist[phelpsym]    := 'PHELP';
  vocablist[prefixsym]   := 'PREFIX';
  vocablist[pshowsym]    := 'PSHOW';
  vocablist[quitsym]     := 'QUIT';
  vocablist[recsym]      := 'RECEIVE';
  vocablist[rejectsym]   := 'REJECT';
  vocablist[sendsym]     := 'SEND';
  vocablist[setsym]      := 'SET';
  vocablist[showsym]     := 'SHOW';
  vocablist[spacesym]    := 'SPACE';
  vocablist[stopbsym]    := 'STOPBIT';
  vocablist[textfsym]    := 'TEXTFILE';
  vocablist[timeoutsym]  := 'TIMEOUT';
  vocablist[wordlensym]  := 'WORD-LENGTH';
  vocablist[xoffsym]     := 'XOFF-CHAR';
  vocablist[xoffwaitsym] := 'XOFF-WAIT-COUNT';
  vocablist[xonsym]      := 'XON-CHAR';
  first_sym := allsym;
  last_sym  := xonsym;
END. (* end of unit parser *)

(*=== KERMSETSHW.TEXT ===*)

(*$S+*)
(*$I-*)
(*$R-*)
(*$V-*)

UNIT parser;   INTRINSIC CODE 23  DATA 24;


INTERFACE

USES  kermglob,
      kermutil;

FUNCTION parse: statustype;


IMPLEMENTATION

VAR first_sym, last_sym : vocab;



PROCEDURE isolate_word ( var line, word : string; var wlen : integer );

var  line_len : integer;

begin
  word := '';  wlen := 0;  linelen := length( line );
  if linelen > 0
    then begin
           delete( line, 1, scan( linelen, <> ' ', line[1] ) );
           linelen := length( line );
           if linelen > 0
             then begin
                    wlen := scan( linelen, = ' ', line[1] );
                    word := copy( line, 1, wlen );
                    delete( line, 1, wlen );
                  end;
         end;
end;  { isolate_word }



FUNCTION get_fn( var line, fn: string; namelen : integer ) : boolean;

{ checks the length of the filename requested for 'send'.              }
{ Or checks the prefix volume name for files to be received.           }

var i, l: integer;

begin
  get_fn := true;
  isolate_word( line, fn, l );
  if (l > namelen) or (l < 1) then get_fn := false
   { max filename length, incl. volumename = 23 }
   { max volumename length, incl. ':' = 8 }
  else begin
         if (fn[l] = ':') and (namelen=23)  then get_fn := false;
         if (fn[l] <> ':') and (namelen=8)  then get_fn := false;
         {  legality of volume and filename will be tested   }
         {  when the file is actually opened. ( see unit "sender" )   }
       end;
end; (* get_fn *)




FUNCTION get_num( var line: string; var n: integer ): boolean;

var
   numstr: string;
   i, numstr_len  : integer;
begin
   get_num := true; n := 0;
   isolate_word( line, numstr, numstr_len );
   if (numstr_len < 6) and (numstr_len > 0) then
     begin
       i := 1;
       numstr := concat( numstr, ' ' );
       while (numstr[i] in ['0'..'9']) do begin
          if n<(maxint div 10) then
             n := n*10 + ord( numstr[i] ) - ord( '0' );
          i := i + 1
       end { while }
     end; { if }
   if n = 0 then get_num := false;
end; { get_num }




FUNCTION nextch(var ch: char): boolean;

var s: string;
    ch_len : integer;

begin
 isolate_word( line, s, ch_len );
 if ch_len <= 1 then begin
                       if ch_len = 1 then ch := s[1]
                                     else ch := cr;
                       nextch := true;
                     end
                else nextch := false;
end; (* nextch *)



FUNCTION get_sym(var word: vocab): statustype;

var i: vocab;
    s: string;
    stat: statustype;
    done: boolean;
    matches, slen : integer;

begin
  isolate_word( line, s, slen );
  if slen = 0 then getsym := ateol
   else
     begin
       stat := null;
       done := false;
       i := first_sym;
       matches := 0;
       repeat
           if (pos(s,vocablist[i]) = 1) and (i in expected) then
             begin
               matches := matches + 1;
               word := i
             end
           else if (s[1] < vocablist[i,1]) then
               done := true;
           if (i = last_sym ) then
               done := true
           else
               i := succ(i)
       until (matches > 1) or done;
       if matches > 1 then
           stat := ambiguous
       else if (matches = 0) then
           stat := unrec;
       getsym := stat
     end (* else *)
end; (* getsym *)





FUNCTION parse(*: statustype*);

type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off,
               get_esc_char, get_show_parm, get_help_show, get_help_parm,
               exitstate, get_baud, get_wordlen, get_stopbit, get_xon_char,
               get_xoff_char, get_xoffwait, get_nofeed, get_timeout, get_maxpak,
               get_eoln_char, get_maxtry, get_prefix, get_dir);

var status: statustype;
    word: vocab;
    state: states;

           procedure case_start;

           begin
             expected := [consym, exitsym, helpsym, phelpsym, quitsym, recsym,
                          sendsym, setsym, showsym, pshowsym, dirsym, pdirsym];
             status := getsym(verb);
             if status = ateol then
               begin
                 parse := null;
                 exit(parse)
               end (* if *)
             else if (status <> unrec) and (status <>  ambiguous) then
                 case verb of
                   consym, recsym, exitsym, quitsym: state := fin;
                   helpsym         : begin
                                       state := get_help_parm;
                                       pr_out:= false
                                     end;
                   phelpsym        : begin
                                       state := get_help_parm;
                                       pr_out:= true
                                     end;
                   dirsym          : begin
                                       state := get_dir;
                                       pr_out := false;
                                     end;
                   pdirsym         : begin
                                       state := get_dir;
                                       pr_out := true;
                                     end;
                   sendsym         : state := getfilename;
                   setsym          : state := get_set_parm;
                   showsym         : begin
                                       state := get_show_parm;
                                       pr_out:= false
                                     end;
                   pshowsym        : begin
                                       state := get_show_parm;
                                       pr_out:= true
                                     end;
                 end (* case *)
           end; (* case_start *)


           procedure case_fin;

           begin
             expected := [];
             status := getsym(verb);
             if status = ateol then
               begin
                 parse := null;
                 exit(parse)
               end (* if status *)
             else
                 status := unconfirmed
           end; (* case_fin *)


           procedure case_getfilename;

           begin
             expected := [];
             if getfn(line,xfilename,23) then
               begin
                 status := null;
                 state := fin
               end (* if *)
             else
                 status := fnexpected
           end; (* case_getfilename *)


           procedure case_gtprefixname;

           begin
             expected := [];
             if getfn(line,newprefix_vol,8) then
               begin
                 status := null;
                 state := fin
               end
             else
                  status := pnexpected
           end;  (* case_gtprefixname *)


           procedure case_getsetparm;

           begin
             expected := [paritysym, localsym, ibmsym, escsym, prefixsym,
                          wordlensym, stopbsym, delsym, debugsym, filewarnsym,
                          baudsym, xonsym, xoffsym, xoffwaitsym, nofeedsym,
                          timeoutsym, eolnsym, maxtrysym, emulatesym, maxpsym,
                          textfsym, rejectsym];
             status := getsym(noun);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <>  ambiguous) then
                 case noun of
                   paritysym:   state := get_parity;
                   prefixsym:   state := get_prefix;
                   escsym:      state := get_esc_char;
                   baudsym:     state := get_baud;
                   wordlensym:  state := get_wordlen;
                   stopbsym:    state := get_stopbit;
                   xonsym:      state := get_xon_char;
                   xoffsym:     state := get_xoff_char;
                   eolnsym:     state := get_eoln_char;
                   xoffwaitsym: state := get_xoffwait;
                   timeoutsym:  state := get_timeout;
                   maxtrysym:   state := get_maxtry;
                   maxpsym:     state := get_maxpak;
                   nofeedsym, filewarnsym, debugsym, delsym, textfsym,
                   ibmsym, localsym, rejectsym, emulatesym:
                                state := get_on_off;
                 end (* case *)
           end; (* case_getsetparm *)


           procedure case_getparity;

           begin
             expected := [marksym, spacesym, nonesym, evensym, oddsym];
             status := getsym(adj);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <> ambiguous) then
                 state := fin
           end; (* case_getparity  *)


           procedure case_getnum( var newnum : integer );

           begin
             expected := [];
             if get_num( line, newnum ) then
               begin
                 status := null; state := fin
               end
             else status := num_expected
           end; (* case_getnum *)


           procedure case_getonoff;

           begin
             expected := [onsym, offsym];
             status := getsym(adj);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <> ambiguous) then
                 state := fin
           end; (* case_ getonoff *)


           procedure case_getchar( var newchar : char );

           begin
             if nextch(newchar) then
                state := fin
             else
                status := ch_expected;
           end; (* case_getchar *)


           procedure case_gtshowparm;

           begin
             expected := [allsym, paritysym, localsym, ibmsym, prefixsym,
                          wordlensym, stopbsym, escsym, delsym, debugsym,
                          filewarnsym, baudsym, xonsym, xoffsym, xoffwaitsym,
                          nofeedsym, timeoutsym, eolnsym, emulatesym, maxpsym,
                          maxtrysym, textfsym, rejectsym];
             status := getsym(noun);
             if status = ateol then
                 status := parm_expected
             else if (status <> unrec) and (status <>  ambiguous) then
                 state := fin
           end; (* case_gtshowparm *)


           procedure case_gethelpshow;

           begin
             expected := [paritysym, localsym, ibmsym, escsym, delsym,
                          wordlensym, stopbsym, debugsym, filewarnsym,
                          baudsym, xonsym, xoffsym, xoffwaitsym, emulatesym,
                          nofeedsym, timeoutsym, eolnsym, prefixsym, maxpsym,
                          maxtrysym, textfsym, rejectsym];
             status := getsym(adj);
             if (status = at_eol) then
               begin
                 status := null;
                 state := fin
               end
             else if (status <> unrec) and (status <>  ambiguous) then
                 state := fin
           end; (* case_gethelpshow *)


           procedure case_gthelpparm;

           begin
             expected := [consym, exitsym, helpsym, phelpsym, quitsym, recsym,
                          sendsym, setsym, showsym, pshowsym, dirsym, pdirsym];
             status := getsym(noun);
             if status = ateol then
               begin
                 parse := null;
                 exit(parse)
               end;
             if (status <> unrec) and (status <>  ambiguous) then
                 case noun of
                   consym, sendsym, recsym,
                   showsym, pshowsym, helpsym,
                   phelpsym, exitsym, quitsym,
                   dirsym, pdirsym            : state := fin;
                   setsym                     : state := get_help_show;
                 end (* case *)
           end; (* case_gthelpparm *)


begin  (*  parse  *)
  state   := start;
  parse   := null;
  noun    := nullsym;
  verb    := nullsym;
  adj     := nullsym;
  uppercase ( line );
  repeat
    case state of
      start         : case_start;
      fin           : case_fin;
      get_filename  : case_getfilename;
      get_prefix    : case_gtprefixname;
      get_set_parm  : case_getsetparm;
      get_parity    : case_getparity;
      get_baud      : case_getnum( newbaud );
      get_wordlen   : case_getnum( newdbit );
      get_stopbit   : case_getnum( newstopbit );
      get_xoffwait  : case_getnum( newxoffwait);
      get_timeout   : case_getnum( newtimeout );
      get_maxtry    : case_getnum( newmaxtry );
      get_maxpak    : case_getnum( newmaxpack );
      get_dir       : case_getnum( vol_num );
      get_on_off    : case_getonoff;
      get_esc_char  : case_getchar( newescchar );
      get_xon_char  : case_getchar( newxonchar );
      get_xoff_char : case_getchar( newxoffchar);
      get_eoln_char : case_getchar( newxeol_char );
      get_show_parm : case_gtshowparm;
      get_help_show : case_gethelpshow;
      get_help_parm : case_gthelpparm;
    end;  { case }
  until (status <> null);
  parse := status
end; (* parse *)


BEGIN  { initialization }
  vocablist[allsym]      := 'ALL';
  vocablist[baudsym]     := 'BAUD';
  vocablist[consym]      := 'CONNECT';
  vocablist[debugsym]    := 'DEBUG';
  vocablist[delsym]      := 'DELKEY';
  vocablist[dirsym]      := 'DIRECTORY';
  vocablist[emulatesym]  := 'EMULATE';
  vocablist[eolnsym]     := 'END-OF-LINE';
  vocablist[escsym]      := 'ESCAPE';
  vocablist[evensym]     := 'EVEN';
  vocablist[exitsym]     := 'EXIT';
  vocablist[filewarnsym] := 'FILE-WARNING';
  vocablist[helpsym]     := 'HELP';
  vocablist[ibmsym]      := 'IBM';
  vocablist[localsym]    := 'LOCAL-ECHO';
  vocablist[marksym]     := 'MARK';
  vocablist[maxpsym]     := 'MAXPACK';
  vocablist[maxtrysym]   := 'MAXTRY';
  vocablist[nofeedsym]   := 'NOFEED';
  vocablist[nonesym]     := 'NONE';
  vocablist[oddsym]      := 'ODD';
  vocablist[offsym]      := 'OFF';
  vocablist[onsym]       := 'ON';
  vocablist[paritysym]   := 'PARITY';
  vocablist[pdirsym]     := 'PDIRECTORY';
  vocablist[phelpsym]    := 'PHELP';
  vocablist[prefixsym]   := 'PREFIX';
  vocablist[pshowsym]    := 'PSHOW';
  vocablist[quitsym]     := 'QUIT';
  vocablist[recsym]      := 'RECEIVE';
  vocablist[rejectsym]   := 'REJECT';
  vocablist[sendsym]     := 'SEND';
  vocablist[setsym]      := 'SET';
  vocablist[showsym]     := 'SHOW';
  vocablist[spacesym]    := 'SPACE';
  vocablist[stopbsym]    := 'STOPBIT';
  vocablist[textfsym]    := 'TEXTFILE';
  vocablist[timeoutsym]  := 'TIMEOUT';
  vocablist[wordlensym]  := 'WORD-LENGTH';
  vocablist[xoffsym]     := 'XOFF-CHAR';
  vocablist[xoffwaitsym] := 'XOFF-WAIT-COUNT';
  vocablist[xonsym]      := 'XON-CHAR';
  first_sym := allsym;
  last_sym  := xonsym;
END. (* end of unit parser *)
(*=== KERMSETSHW.TEXT ===*)
(* >>>> KERMSETSHW.TEXT ************************************************)

(*$I-*)
(*$R-*)
(*$S+*)
(*$V-*)

UNIT KERMSETSHW;         INTRINSIC CODE   27;

INTERFACE

USES kermglob, kermacia, kermutil;


PROCEDURE  show_parms;

PROCEDURE  set_parms;


IMPLEMENTATION


PROCEDURE show_dir( list_device : integer );

{ lists all the files in the directory from the requested diskunit number  }

var space   : packed array[1..15] of char;
    fil_type ,file_count, file_num : integer;


PROCEDURE list_names ( start, quit : integer );

var   len : integer;

begin
  while (filecount < filenum) and (start < quit) do
    begin
      len := ord( filebuf[start-1] );
      fil_type := ord( filebuf[start-3] );
      if (len > 0) and (len < 16) and (fil_type < 6) then
        begin
          unitwrite( list_device, filebuf[start], len );
          unitwrite( list_device, space[1], 16-len );
          file_count := file_count + 1;
        end;
      start := start + 26;
    end;
end;  { list_names}

begin  { show_dir }
  space := '               ';
  if (volnum=4) or (volnum=5) or ((volnum>8) and (volnum<13))
    then begin
           unitread( vol_num, filebuf[1], page_size, 2 );
           if ioresult <> 0 then begin
                                   writeln('not on line');
                                   writeln;
                                   exit( show_dir );
                                 end;
           writeln(p); write(p,'Volume name is : ');
           unitwrite( list_device, filebuf[8], ord( filebuf[7] ) );
           file_num := ord( filebuf[17] );
           file_count := 0;
           writeln(p); writeln(p);
           list_names(34, pagesize-27);
           if (filecount < filenum) then
             begin
               moveleft( filebuf[pagesize-9], filebuf[1], 10 );
               unitread( vol_num, filebuf[11], page_size - 10, 4 );
               list_names( 8, pagesize-27);
             end;
           writeln(p);
           writeln(p);
         end
    else begin
           writeln('not a disk volume');
           writeln;
         end;
 end;    { show_dir }


PROCEDURE show_p1;

(* shows the various settable parameters *)

var list_device : integer;

begin
  close( p );
  if pr_out and print_enable
    then begin
           reset(p, pr_file);
           list_device := line_printer;
         end
    else begin
           reset(p, cs_file);
           list_device := consol;
         end;
  writeln;
  if (verb = dirsym) or (verb = pdirsym)
    then begin
           show_dir( list_device );
           pr_out := false;
           exit( show_parms )
         end;
  if noun = allsym then
    begin
      page(output);
      writeln(p,'SERIAL PORT SETTINGS');
      writeln(p);
    end;
  if (noun=allsym) or (noun=baudsym) then
    writeln(p,'   BAUD rate is ', baud );
  if (noun=allsym) or (noun=paritysym) then
    begin
      case parity of
        evenpar  : write(p,'   EVEN');
        markpar  : write(p,'   MARK');
        nopar    : write(p,'   NONE');
        oddpar   : write(p,'   ODD');
        spacepar : write(p,'   SPACE');
      end; { case }
      writeln(p,' PARITY');
    end; { if }
  if (noun=allsym) or (noun=wordlensym) then
    writeln(p,'   WORD-LENGTH is ', data_bit ,' bits');
  if (noun=allsym) or (noun=stopbsym) then
    begin
      write(p,'   Number of STOPBITs is ');
      if stopbit = 15 then writeln(p,'1.5') else writeln(p, stopbit );
    end; { if }
  if (noun=allsym) or (noun=localsym) then
    write_bool('   LOCAL-ECHO is ', halfduplex );
end; { show_p1 }


PROCEDURE show_p2;

begin
  if (noun=allsym) then
    begin
      writeln(p);
      writeln(p,'TERMINAL MODE RELATED SETTINGS');
      writeln(p);
    end;
  if (noun=allsym) or (noun=emulatesym) then
    writeln(p,'   EMULATE  is not implemented.' );
  if (noun=allsym) or (noun=escsym) then
    begin
      write(p,'   Terminal ESCAPE key is ');
      write_ctl( esc_char );
      writeln(p);
    end;
  if (noun=allsym) or (noun=rejectsym) then
    write_bool('   REJECT incoming control characters is ', reject_cntrl_char);
  if (noun=allsym) or (noun=delsym) then
    begin
      write(p,'   DELKEY (backspace key code send to host = ');
      write_ctl( bs_to_del ); write(p,' ) is ');
      if bs_to_del = chr(del) then writeln(p,'ON') else writeln(p,'OFF');
    end;
  if (noun=allsym) or (noun=xonsym) then
    begin
      write(p,'   XON-CHAR is ');
      write_ctl( xon_char );
      writeln(p,' ( screendump and ibm = on only )');
    end;
  if (noun=allsym) or (noun=xoffsym) then
    begin
      write(p,'   XOFF-CHAR is ');
      write_ctl( xoff_char );
      writeln(p,' ( screendump only )');
    end;
  if (noun=allsym) or (noun=xoffwaitsym) then
    writeln(p,'   XOFF-WAIT-COUNT is ', xoffwtime ,'   ( screendump only )');
  if (noun=allsym) or (noun=nofeedsym) then
    write_bool('   NOFEED (form-feed during screendump) is ', no_ffeed );
  if (noun=allsym) or (noun=ibmsym) then
    write_bool('   IBM vm/cms settings are ', ibm );
  if (noun=allsym) then
    begin
      if not ( pr_out and print_enable ) then
        begin
          writeln;
          write('>>> PRESS <RETURN> FOR MORE <<<');
          readln;
        end;
      writeln(p);
      writeln(p,'FILE TRANSFER RELATED SETTINGS');
      writeln(p);
    end;
end;  { show_p2 }


PROCEDURE  show_p3;

begin
  if (noun=allsym) or (noun=debugsym) then
    write_bool('   DEBUGging is ', debug );
  if (noun=allsym) or (noun=filewarnsym) then
    write_bool('   FILE-WARNING is ', fwarn );
  if (noun=allsym) or (noun=textfsym) then
    write_bool('   TEXTFILE send & receive is ', text_file );
  if (noun=allsym) or (noun=prefixsym) then
    writeln(p, '   PREFIX volume for received files is ', prefix_vol );
  if (noun=allsym) or (noun=timeoutsym) then
    writeln(p, '   TIMEOUT period specified to host is about ',mytime,' sec');
  if (noun=allsym) or (noun=maxtrysym) then
    begin
    writeln(p,'   MAXTRY ( number of retries before breaking off ) is ',maxtry);
    writeln(p,'          ( Initial retries =  5 * maxtry )');
    end;
  if (noun=allsym) or (noun=eolnsym) then
    begin
      write(p,'   END-OF-LINE character send after each package is ');
      write_ctl( xeol_char );
      writeln(p);
    end;
  if (noun=allsym) or (noun=maxpsym) then
      writeln(p,'   MAXPACK: packetsize (20..', def_maxpack,
                                               ') I can receive is ', maxpack );
  if (noun=allsym) then
    begin
      write(p,'   Kermit packet starts with '); write_ctl( soh_char );
      writeln(p);
      write(p,'   My padding character is '); write_ctl( my_pchar );
      writeln(p);
      writeln(p,'   Number of padding char''s  I need is ', my_pad );
      writeln(p,'   My quote char for control char''s is ', my_quote );
    end;
  writeln(p);
   close( p ); reset( p, cs_file );
end; { show_p3 }


PROCEDURE  show_parms;

begin
  show_p1;
  show_p2;
  show_p3;
  pr_out := false;
end;  { show_parms }



PROCEDURE set_parms;

(* sets the parameters *)

begin
  case noun of
    debugsym   : debug := ( adj = onsym );
    emulatesym : ;
    textfsym   : textfile := ( adj = onsym );
    prefixsym  : prefix_vol := newprefix_vol;
    rejectsym  : reject_cntrl_char := ( adj = onsym );
    nofeedsym  : no_ffeed := ( adj = onsym );
    xonsym     : xonchar := newxonchar;
    xoffsym    : xoffchar := newxoffchar;
    eolnsym    : xeol_char := new_xeol_char;
    escsym     : esc_char := new_esc_char;
    delsym     : case adj of
                   onsym  : bs_to_del := chr(del);
                   offsym : bs_to_del := backsp;
                 end;
    filewarnsym: fwarn := (adj = onsym);
    xoffwaitsym: if newxoffwait < 256 then xoffwtime := newxoffwait;
    maxtrysym  : begin
                   maxtry := newmaxtry;
                   inittry := 5 * maxtry;
                 end;
    maxpsym    : if (new_maxpack <= def_maxpack ) and (new_maxpack >= 20)
                   then maxpack := new_maxpack;
    timeoutsym : if newtimeout < 32  then begin
                                            my_time := newtimeout;
                                            xtime := my_time;
                                          end;
    ibmsym     : case adj of
                   onsym : begin
                             set_acia_parms(markpar,databit,stopbit,baud);
                             get_acia_parms(parity,databit,stopbit,baud);
                             if parity = mark_par
                               then begin
                                      ibm := true;
                                      half_duplex := true;
                                    end;
                           end; (* onsym *)
                   offsym: begin
                             ibm := false;
                             half_duplex := false;
                           end; (* offsym *)
                 end; (* case adj *)
    localsym   : if not ibm then halfduplex := (adj = onsym);
    paritysym  : if not ibm then
                 case adj of
                   evensym: new_par:= evenpar;
                   marksym: new_par:= markpar;
                   nonesym: new_par:= nopar;
                   oddsym:  new_par:= oddpar;
                   spacesym:new_par:= spacepar;
                 end; (* case *)
  end; (* case noun *)
  case noun of
    paritysym  : set_acia_parms( new_par,data_bit, stop_bit, baud );
    baudsym    : set_acia_parms( parity, data_bit, stop_bit, new_baud );
    wordlensym : set_acia_parms( parity, new_dbit, stop_bit, baud );
    stopbsym   : set_acia_parms( parity, data_bit, new_stopbit, baud );
  end; { case }
    get_acia_parms( parity,  data_bit, stop_bit,    baud     );
end; (* set_parms *)

begin
end.     {  kermsetshw }
(*=== KERMINIT.TEXT ===*)
(*>>>>>>>>>>>>KERMINIT>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*)

(*$I-*)
(*$R-*)
(*$S+*)
(*$V-*)

UNIT KERMINIT;      INTRINSIC  CODE  29;

INTERFACE

USES  kermglob,
      kermacia,
      kermutil;

PROCEDURE initialize;


IMPLEMENTATION

PROCEDURE initialize;

{ reads system.miscinfo and the default parameter file kermit.data and }
{ does other necessary initializations }


PROCEDURE  logo;

begin
  page( output );
  gotoxy(17,2);  write('K    E    R    M    I    T');
  gotoxy(21,4);  write('VERSION ', version );
  gotoxy(28,5);  write('for');
  gotoxy(17,6);  write('Apple ][(e) UCSD p-system');
  gotoxy(10,17); write('Adapted from the IBM PC UCSD version by :');
  gotoxy(24,19); write('P. Terpstra');
  gotoxy(20,20); write('University Groningen');
  gotoxy(23,21); write('Nijenborgh 16');
  gotoxy(25,22); write('Groningen');
  gotoxy(22,23); write('The Netherlands');
end;  { logo }


PROCEDURE  check_io ( io_status : integer;  filename : string );

begin
  if io_status <> 0 then
    begin
      io_error( io_status );
      gotoxy( 50, error_line );
      write( filename );
      exit( program );
    end;
end;   {  check_io  }



PROCEDURE get_crt_info;

{ read system.miscinfo to get terminal independent screen operations }

var      byte : 0..255;
         i : integer;

begin
  reset( untyped_f, sys_misc_file );
  check_io( ioresult, sys_misc_file );
  i := blockread( untyped_f, file_buf[1], 1 );
  if i <> 1 then check_io( 64, sys_misc_file );
  close( untyped_f );
  prefix := file_buf[63];        byte := ord( file_buf[73] );
  prefixed[ sc_up      ] := odd( byte );         {cursor up}
  prefixed[ sc_right   ] := odd( byte div   2 ); {cursor right}
  prefixed[ sc_clreol  ] := odd( byte div   4 ); {clear to end of line}
  prefixed[ sc_clreos  ] := odd( byte div   8 ); {clear to end of screen}
  prefixed[ sc_home    ] := odd( byte div  16 ); {cursor home}
  prefixed[ sc_delchar ] := odd( byte div  32 ); {often not implemented}
  prefixed[ sc_clrall  ] := odd( byte div  64 ); {clear whole screen}
  prefixed[ sc_clrline ] := odd( byte div 128 ); {often not implemented}
  prefixed[ sc_left    ] := false; {cursor left:no prefix in sys.miscinfo}
  prefixed[ sc_down    ] := false; {cursor down:no prefix in sys.miscinfo}
  rlf       := file_buf[68]; {reverse line feed: cursor up}
  ndfs      := file_buf[67]; {non destructive space forward: cursor right}
  eraseol   := file_buf[66]; {from cursor: clear to end of line}
  eraseos   := file_buf[65]; {from cursor: clear to end of screen}
  home      := file_buf[64]; {cursor to x=0, y=0}
  delchar   := file_buf[69]; {backspace with deleting: often same as backsp}
  clrscreen := file_buf[72]; {clear whole screen}
  clrline   := file_buf[71]; {clear one whole line: often not possible}
  backsp    := chr( backspace ); {see kermglob: mostly chr(8) }
  lf        := chr( linefeed  ); {see kermglob: mostly chr(10) }
  cr        := chr( eoline );    {see kermglob: mostly chr(13) }
  ff        := chr( formfeed );  {see kermglob: mostly chr(12) }
end;  { procedure get_crt_info }


PROCEDURE read_defaults;

var temp : integer;
    temp_bool : boolean;

begin
  reset( def, setup_file );
  check_io( ioresult, setup_file );
  esc_char        := chr( def^ ); get( def );
  eoln_char       := chr( def^ ); get( def );
  my_quote        := chr( def^ ); get( def );
  my_pchar        := chr( def^ ); get( def );
  my_pad          :=      def^  ; get( def );
  soh_char        := chr( def^ ); get( def );
  int_key         := chr( def^ ); get( def );
  xon_char        := chr( def^ ); get( def );
  xoff_char       := chr( def^ ); get( def );
  xoff_w_time     :=      def^  ; get( def );
  max_pack        :=      def^  ; get( def );
  if (maxpack < 20) or (maxpack > def_maxpack) then  maxpack := def_maxpack;
  max_try         :=      def^  ; get( def );
  my_time         :=      def^  ; get( def );
  if my_time < 1 then my_time := 1 else if my_time > 31 then my_time := 31;
  half_duplex     := odd( def^ ); get( def );
  debug           := odd( def^ ); get( def );
  fwarn           := odd( def^ ); get( def );
  text_file       := odd( def^ ); get( def );
  no_ffeed        := odd( def^ ); get( def );
  rejectcntrlchar := odd( def^ ); get( def );
  temp_bool       := odd( def^ ); get( def );
  if temp_bool then bs_to_del := chr(del) else bs_to_del := backsp;
  temp            :=      def^  ; get( def );
  acia_implem     := unknown;
  if temp = 1 then acia_implem := A6551;
  if temp = 2 then acia_implem := A6850;
  acia_comm_reg   :=      def^  ; get( def );
  acia_cntrl_reg  :=      def^  ; get( def );
  new_baud        :=      def^  ; get( def );
  new_dbit        :=      def^  ; get( def );
  new_stopbit     :=      def^  ; get( def );
  temp            :=      def^  ; get( def );
  new_par := no_par;
  case temp of
    0 : new_par := no_par;
    1 : new_par := odd_par;
    2 : new_par := even_par;
    3 : new_par := mark_par;
    4 : new_par := space_par;
  end;
  temp           :=      def^   ;
  if temp = 80 then begin
                      no_sfb_char := no_sp_char;
                      sfb_char    := stop_flush_break_sp_char;
                    end
               else begin
                      no_sfb_char := scr_40_sp_char;
                      sfb_char    := all_sp_char;
                    end;
  close( def );
end;    {  read_defaults  }


PROCEDURE  other_defaults;

begin
  ibm       :=   false;
  emulate   :=   false;
  pr_out    :=   false;
  xdle_char :=   chr( xdle );
  xeol_char :=   eoln_char;
  quote     :=   my_quote;
  pad       :=   my_pad;
  pad_char  :=   my_pchar;
  xtime     :=   my_time;
  prefix_vol:=   ':';
  init_try  :=   5 * max_try;
  print_enable := test_printer;
  err_string   := 'Error at host';
  reset( p, cs_file );
  ctl_set := [ chr(0)..chr(31), chr(del) ];
  check_apple_char( no_sfb_char );
  check_apple_char( mask_msbit_remin );
  with controlword do
    begin
      channel := inp;
      purpose := status;
      reserved:= 0;
      special_req := none;
      filler  := 0
    end;
  baud := new_baud;
  if (acia_implem=A6551) or (acia_implem=A6850)
    then begin
           set_acia_parms( new_par, new_dbit, new_stopbit, new_baud );
           get_acia_parms( parity, databit, stopbit, baud );
         end
    else begin
           parity  := new_par;
           stopbit := new_stopbit;
           databit := new_dbit;
         end;
end;   {  other_defaults }


begin   {  initialize  }
  logo;
  get_crt_info;
  read_defaults;
  other_defaults;
  writeln;
  writeln;
end;   {  initialize  }


begin
end.   {  kerminit  }
(*=== HELPER.TEXT ===*)
(* >>>> HELPER.TEXT  **************************************************)

(*$I-*)
(*$R-*)
(*$S+*)
(*$V-*)

UNIT helper;      INTRINSIC  CODE 22;


INTERFACE

USES  kermglob,
      kermutil;

PROCEDURE help;

IMPLEMENTATION

PROCEDURE help;


const  scrpr   = 'resp. on screen or on the printer.';
       numpar  = 'Takes a number as parameter.';
       charpar = 'Takes a character as parameter.';
       onoffp  = 'Takes ON / OFF as parameter.';
       conval  = 'Valid only during CONNECT.';
       ftval   = 'Valid only during file transfer.';
       dumpval = 'Valid only in screendump mode.';

Var  i : integer;
     ch : char;


(************  Auxiliary procedures ***********************************)



PROCEDURE wait;

begin
  if not pr_out then
    begin
      ch := ' ';
      gotoxy( 0, 23 );
      write('----------- ');
      write('( Type <spacebar> to continue or '); write_ctl( esc_char );
      write(' to quit help ) ------------');
      read( keyboard, ch );
      if ch = esc_char then begin
                              writeln;
                              writeln;
                              exit( help );
                            end;
      page( output );
    end;
end;


PROCEDURE line;

begin
  for i := 1 to 24 do write(p,'-');
end;


PROCEDURE word1( sym : vocab );

begin
  writeln(p);
  line;
  writeln(p);
  writeln(p, vocablist[sym] );
  line;
  writeln(p);
  writeln(p);
end;


PROCEDURE word2( sym1, sym2 : vocab );

begin
  writeln(p);
  line;
  writeln(p);
  writeln(p, vocablist[sym1], '   ', vocablist[sym2] );
  line;
  writeln(p);
  writeln(p);
end;


PROCEDURE aciaset( sym : vocab );

begin
  write(p,'According to the file ', setup_file, ' this command should ');
  if ( ( aciaimplem=A6850 ) and ( sym=baudsym ) ) or
       ( aciaimplem=unknown ) or ( aciaimplem>A6551 )
   then writeln(p,'not work.')
   else begin
          writeln(p,'work.');
          writeln(p,'Consult your serial card manual for valid settings.');
        end;
end;


(*********** Introduction procedure  ***********************************)


PROCEDURE introkermit;
begin
  writeln(p,'KERMIT is a family of programs that do reliable file transfer');
  writeln(p,'between computers over TTY lines. ( BYTE june & july 1984 )');
  writeln(p,'KERMIT can also be used to make the micro computer behave as a');
  writeln(p,'terminal for a mainframe.');
  writeln(p);
  writeln(p,'These are the commands for the Apple ][(e) UCSD KERMIT ',version);
  writeln(p);
  writeln(p);
end;


(********* These procedures explain the commands except SET ************)


PROCEDURE helpsend;
begin
  word1( sendsym );
  writeln(p,'To send a file to the remote system.');
  writeln(p,'Takes a filename as parameter.');
end;

PROCEDURE helpdir;
begin
  word2( dirsym, pdirsym );
  writeln(p,'Lists the directory of a disk ', scrpr );
  writeln(p, numpar, ' ( 4,5,9..12 )');
end;

PROCEDURE helphelp;
begin
  word2( helpsym, phelpsym );
  writeln(p,'To get an explanation of KERMIT commands ', scrpr );
end;

PROCEDURE helpshow;
begin
  word2( showsym, pshowsym );
  writeln(p,'Shows the values of the parameters that can be modified via');
  writeln(p,'the SET command ', scrpr );
end;

PROCEDURE helpconn;
begin
  word1( consym );
  writeln(p,'To make a virtual terminal connection to a remote system.');
  writeln(p,'To break the connection and escape back to the micro KERMIT');
  write(p,'command level type '); write_ctl( esc_char );
  writeln(p,' immediately followed by <C>.');
  writeln(p,'When the Apple screen starts scrolling host characters may');
  writeln(p,'be lost at > 1200 baud. To prevent this set the host''s');
  writeln(p,'linefeed fill to a count of about 5.');
end;

PROCEDURE helpexit;
begin
  word2( exitsym, quitsym );
  writeln(p,'To return back to the Apple UCSD p-system command level.');
end;

PROCEDURE helprec;
begin
  word1( recsym );
  writeln(p,'To accept a file or group of files from the remote system.');
end;


(***********  The following procedures explain the SET subcommands  ********)


PROCEDURE baudset;
begin
  word2( setsym, baudsym );
  writeln(p,'To set the serial baud rate.');
  writeln(p, numpar );
  aciaset( baudsym );
end;

PROCEDURE parset;
begin
  word2( setsym, paritysym );
  writeln(p,'This selects the parity for outgoing characters to match the');
  writeln(p,'requirements of the host.');
  writeln(p,'Takes as parameters : ', vocablist[nonesym], vocablist[oddsym]:4,
            vocablist[evensym]:5, vocablist[marksym]:5, vocablist[spacesym]:6 );
  writeln(p,'When the IBM flag is set, parity is set to ', vocablist[marksym],
            ' ( if possible ).');
  aciaset( paritysym );
end;

PROCEDURE wordlset;
begin
  word2( setsym, wordlensym );
  writeln(p,'Sets the number of databits for outgoing & incoming characters.');
  writeln(p, numpar );
  aciaset ( wordlensym );
end;

PROCEDURE stopbset;
begin
  word2( setsym, stopbsym );
  writeln(p,'Sets the number of stopbits for outgoing & incoming characters.');
  writeln(p, numpar );
  aciaset( stopbsym );
end;

PROCEDURE debugset;
begin
  word2( setsym, debugsym );
  writeln(p,'Shows packets sent & received during filetransfer when ON.');
  writeln(p, onoffp );
  writeln(p, ftval );
end;

PROCEDURE delset;
begin
  word2( setsym, delsym );
  writeln(p,'Changes the Apple <backspace> key to a <del> key for the host');
  writeln(p,'when set to ON.');
  writeln(p, onoffp );
  writeln(p, conval );
end;

PROCEDURE emulset;
begin
  word2( setsym, emulatesym );
  writeln(p,'Not implemented.');
end;

PROCEDURE eolnset;
begin
  word2( setsym, eolnsym );
  writeln(p,'Sets the "end-of-line" character sent after a KERMIT package.');
  writeln(p, charpar );
  writeln(p, ftval );
end;

PROCEDURE escset;
begin
  word2( setsym, escsym );
  writeln(p,'Sets the escape character preceding the <C>.');
  write(p,'The sequence '); write_ctl( esc_char );
  writeln(p,' <C> returns you to the KERMIT command level.');
  writeln(p, charpar );
  writeln(p, conval );
end;

PROCEDURE filewset;
begin
  word2( setsym, filewarnsym );
  writeln(p,'Changes names of received files to protect already existing');
  writeln(p,'files with similar names.');
  writeln(p, onoffp );
  writeln(p, ftval );
end;

PROCEDURE ibmset;
begin
  word2( setsym, ibmsym );
  writeln(p,'When communicating with an IBM VM/CMS mainframe this flag');
  writeln(p,'should be on.');
  writeln(p,'It also sets ', vocablist[paritysym], ' to ',
             vocablist[marksym], ' and activates ', vocablist[localsym],
             '.');
  writeln(p, onoffp );
end;

PROCEDURE localset;
begin
  word2( setsym, localsym );
  writeln(p,'This sets the duplex : it should be ON for th IBM VM/CMS');
  writeln(p,'and OFF for the CYBER, VAX, DEC-20.');
  writeln(p, onoffp );
end;

PROCEDURE maxtryset;
begin
  word2( setsym, maxtrysym );
  writeln(p,'Maximum number of times KERMIT tries to receive a correct');
  writeln(p,'package before breaking off the file transfer. At the start');
  writeln(p,'of file transfer this number is five times higher to allow');
  writeln(p,'the other side extra time to start file transfer.');
  writeln(p, numpar );
end;

PROCEDURE nofeedset;
begin
  word2( setsym, nofeedsym );
  writeln(p,'Replaces an incoming formfeed character with carriage return.');
  writeln(p, onoffp );
end;

PROCEDURE prefixset;
begin
  word2( setsym, prefixsym );
  writeln(p,'Sets the prefix name of the (disk)volume for incoming files.');
  writeln(p,'Takes a volume name as parameter.');
  writeln(p, ftval );
end;

PROCEDURE rejset;
begin
  word2( setsym, rejectsym );
  writeln(p,'When set control characters coming from the host are not');
  writeln(p,'echoed to the Apple screen or printer except :');
  writeln(p,'backspace, carr. return, formfeed, linefeed, bell.');
  writeln(p, onoffp );
  writeln(p, conval );
end;

PROCEDURE textfset;
begin
  word2( setsym, textfsym );
  writeln(p,' ON : incoming and outgoing files will be treated as UCSD');
  writeln(p,'      textfiles and the 8th bit of each character is masked.');
  writeln(p,'OFF : incoming and outgoing files will be treated as UCSD');
  writeln(p,'      datafiles and the 8th bit of each char. is not masked.');
  writeln(p,'UCSD data & code files can thus be transfered only if both');
  writeln(p,'sides are set to 8-bit word length, no parity and if the 8th');
  writeln(p,'bit is not altered during transmission.');
  writeln(p, ftval );
end;

PROCEDURE timoutset;
begin
  word2( setsym, timeoutsym );
  writeln(p,'Time-out period specified to host in approx. seconds (1..31).');
  writeln(p,'( Note : some host KERMITs do not take this parameter and');
  writeln(p,'         just keep waiting.)');
  writeln(p, numpar );
  writeln(p, ftval );
end;

PROCEDURE maxpackset;
begin
  word2( setsym, maxpsym );
  writeln(p,'Sets this side''s maximum KERMIT package length ( 20..94 ).');
  writeln(p,'Reduce package length on noisy lines.');
  writeln(p, numpar );
  writeln(p, ftval );
end;

PROCEDURE xoffset;
begin
  word2( setsym, xoffsym );
  writeln(p,'A Xoff/Xon protocol is used during ',vocablist[consym],
             ' when a screendump to the printer');
  writeln(p,'is requested.');
  writeln(p,'Set Xoff & Xon  according to the requirements of the host.');
  writeln(p,'( Note : at some hosts the Xon/Xoff char''s should first be');
  writeln(p,'         defined by a terminal definition command. )');
  writeln(p, charpar );
  writeln(p, dumpval );
end;

PROCEDURE xonset;
begin
  word2( setsym, xonsym );
  writeln(p,'See ', vocablist[setsym],vocablist[xoffsym] : 11, '.');
  writeln(p,'( Note : if IBM flag is on this character is also used in the');
  write(  p,'         file-transfer protocol. It should then be set to ');
  write_ctl( chr(17) ); writeln(p,' )');
end;

PROCEDURE xoffwset;
begin
  word2( setsym, xoffwaitsym );
  writeln(p,'If characters are lost during a screendump to the printer then');
  writeln(p,'increase this parameter.');
  writeln(p, numpar, ' (1..255 )');
  writeln(p, conval );
  writeln(p, dumpval );
end;



(*************** This procedure list all SET subcommands  ****************)


PROCEDURE allset;
begin
  page( output );
  word1( setsym );
  writeln(p,'To establish system dependent parameters.');
  writeln(p,'The ', vocablist[ setsym ], ' options are as follows :');
  writeln(p);
  baudset;
  wait;
  debugset;
  delset;
  wait;
  emulset;
  eolnset;
  escset;
  wait;
  filewset;
  ibmset;
  wait;
  localset;
  maxpackset;
  wait;
  maxtryset;
  nofeedset;
  wait;
  parset;
  prefixset;
  wait;
  rejset;
  stopbset;
  wait;
  textfset;
  wait;
  timoutset;
  wordlset;
  wait;
  xoffset;
  xonset;
  wait;
  xoffwset;
end;


(*********** This procedure explains the SET command ********************)


PROCEDURE helpset;

begin
  case adj of
    nullsym       : allset;
    baudsym       : baudset;
    debugsym      : debugset;
    delsym        : delset;
    emulatesym    : emulset;
    eolnsym       : eolnset;
    escsym        : escset;
    filewarnsym   : filewset;
    ibmsym        : ibmset;
    localsym      : localset;
    maxpsym       : maxpackset;
    maxtrysym     : maxtryset;
    nofeedsym     : nofeedset;
    paritysym     : parset;
    prefixsym     : prefixset;
    rejectsym     : rejset;
    stopbsym      : stopbset;
    textfsym      : textfset;
    timeoutsym    : timoutset;
    wordlensym    : wordlset;
    xoffsym       : xoffset;
    xonsym        : xonset;
    xoffwaitsym   : xoffwset;
  end;  { case }
end;   {  helpset }



(**************** This procedure shows all valid HELP commands ************)


PROCEDURE helpall;

begin
  page( output );
  introkermit;
  helpconn;
  wait;
  helpdir;
  helpexit;
  helphelp;
  wait;
  helprec;
  helpsend;
  helpshow;
  wait;
  helpset;
end;


(********************* Finally here starts procedure HELP  ****************)


begin   {  help  }
  close(p);
  if pr_out and print_enable then reset(p, pr_file )
                             else reset(p, cs_file );
  writeln(p);
  case noun of
    nullsym              :  helpall;
    setsym               :  helpset;
    showsym, pshowsym    :  helpshow;
    dirsym , pdirsym     :  helpdir;
    helpsym, phelpsym    :  helphelp;
    exitsym, quitsym     :  helpexit;
    recsym               :  helprec;
    sendsym              :  helpsend;
    consym               :  helpconn;
  end;  {  case  }
  writeln(p);
  pr_out := false;
end;   {  help  }



begin   {  unit  helper  }
end.

(*=== ASM.KERMIT.TEXT ===*)
;-----------------------------------------------------------------------
;-----------------------------------------------------------------------
;
;   This procedure is external to the unit kermpack.
;
;-----------------------------------------------------------------------
;-----------------------------------------------------------------------
;
;FUNCTION rpack(           n  : INTEGER;
;                VAR len, num : INTEGER;
;                VAR    data  : packet_type;
;                    time_out : INTEGER;
;                         soh : CHAR        ) : CHAR;
;------------------------------------------------------------------------
; This function listens to the serial input port, detects a kermit
; package, decodes it, returns the data part of the package, the
; length of the data part and the number of the package. Its function
; value is the packet-type.
; n = the number of the last packet send. It is only used to initialize
; num, otherwise num would be undefined in case of receive failure.
; The function takes the value '@' in case a transmission error is
; detected when decoding the packet or when no valid packet has been
; received during the time_out period.
; time_out can be specified in seconds : this value will be multiplied
; within rpack by 8 to approximate real time. Because only the least
; significant byte of time_out is passed to rpack, the valid range for
; time_out will be 1..31 seconds.
; This function will not work without the system.attach and attach.drivers
; that implement a remin buffer and the remin unitstatus statement.
;
;--------------------------------------------------------------------------
;
           .FUNC RPACK, 6.
;
BIOSAF     .EQU 0FF5C          ; base of bios jump table. Same in V1.1 & V1.2
BIOSRAM    .EQU 0C083          ; switch for extra bios ram.
INTPRAM    .EQU 0C08B          ; switch back to main ram.
RREAD      .EQU BIOSAF+24.     ; bios remote read routine adress.
RSTAT      .EQU BIOSAF+51.     ; bios remote status routine adress.
DUMMY      .EQU 0FFFF          ; dummy adress : will be filled in at runtime
TEMP1      .EQU 00             ; temp zero page adresses.
TEMP2      .EQU 02
;
; get parameters from stack:
;
           PLA                 ; pop return adress.
           STA RETURN
           PLA
           STA RETURN+1
           ;-------------------
           PLA                 ; remove function bias.
           PLA
           PLA
           PLA
           ;-------------------
           PLA                 ; pop soh ( nearly always ^A )
           STA SOH
           PLA                 ; discard msb.
           ;-------------------
           PLA                 ; pop timeout.
           ASL A               ; timeout = timeout * 8
           ASL A               ; to approximate real time.
           ASL A
           STA TIMEOUT
           PLA                 ; discard msb.
           ;-------------------
           PLA                 ; move adress of recpkt to the the right place.
           STA RPADR+1
           PLA
           STA RPADR+2
           ;-------------------
           PLA                 ; move adress of num .
           STA TEMP1
           STA NUMADR+1
           PLA
           STA TEMP1+1
           STA NUMADR+2
           ;-------------------
           PLA                 ; move adress of len .
           STA TEMP2
           STA LENADR+1
           PLA
           STA TEMP2+1
           STA LENADR+2
           ;-------------------
           PLA                 ; pop n
           AND #3F             ; take mod 64
           LDY #00             ; init num to n in case of receive failure.
           STA @TEMP1,Y
           PLA                 ; discard msb of n.
           TYA
           INY
           STA @TEMP1,Y
           ;-------------------
;
; initialization code
;
           LDA #00             ; init len to zero.
           TAY
           STA @TEMP2,Y
           INY
           STA @TEMP2,Y
           STA RESYNCNT        ; set resynchronization count to 0
           STA C1              ; set all timeout counters to 0
           STA C2
           LDA BIOSRAM         ; switch in bios ram
;
; start rpack
;
WAITSOH    JSR GETCHAR2        ; wait for a soh (^A)
           BNE WAITSOH
RESYN      INC RESYNCNT        ; if more than 256 resync's : give up
           BEQ RECFAIL
           ;-------------------
           JSR GETCHAR1        ; get packet length ( len ).
           BEQ RESYN           ; if it was a soh then resync.
           STA CHKSUM          ; init checksum .
           SEC
           SBC #35.            ; len := len - 32 - 3.
           BMI RECFAIL         ; if len < 0 then something is wrong.
           STA LEN             ; save len temporarily.
LENADR     STA DUMMY           ; save len for pascal.
           ;-------------------
           JSR GETCHAR1        ; get packet number ( num ).
           BEQ RESYN           ; if it was a soh then resync.
           PHA                 ; save num
           CLC
           ADC CHKSUM          ; increase chksum
           STA CHKSUM
           PLA                 ; get original num back.
           SEC
           SBC #32.            ; subtract 32.
NUMADR     STA DUMMY           ; save num for pascal.
           ;-------------------
           JSR GETCHAR1        ; get packet type ( function value of rpack )
           BEQ RESYN
           STA PTYPE
           CLC
           ADC CHKSUM          ; increase checksum
           STA CHKSUM
           ;-------------------
           LDY #00             ; get data char's ( recpkt )
FILLPACK   STY LENCNT          ; save y reg.
           CPY LEN             ; if no (more) data expected : skip this loop.
           BEQ GETCHKSUM
           JSR GETCHAR1        ; get data char.
           BEQ RESYN
           LDY LENCNT          ; restore y reg.
RPADR      STA DUMMY,Y         ; fill in recpkt for pascal
           CLC
           ADC CHKSUM          ; increase checksum
           STA CHKSUM
           INY                 ; increase length counter
           BNE FILLPACK        ; branch always to get next data char.
           ;-------------------
GETCHKSUM  JSR GETCHAR1        ; get packet checksum.
           BEQ RESYN
           SEC
           SBC #32.            ; subtract 32.
           STA PCHKSUM
           ;-------------------
           LDA CHKSUM          ; calculate final checksum.
           ROL A
           ROL A
           ROL A
           AND #03
           CLC
           ADC CHKSUM
           AND #3F
           ; equivalent to s = ( s + ( ( s and 192 ) div 64 ) ) and 63
           CMP PCHKSUM         ; compare to received checksum.
           BEQ EXIT            ; if ok then back to pascal.
           ;-------------------
RECFAIL    LDA #40             ; rpack = '@' if a receive failure was
           STA PTYPE           ; detected.
           ;-------------------
EXIT       LDA #00             ; push msb of function value.
           PHA
           LDA PTYPE           ; push lsb of function value.
           PHA
           ;-------------------
           LDA INTPRAM         ; switch back to main ram.
           ;-------------------
           LDA RETURN+1        ; push return adress
           PHA
           LDA RETURN
           PHA
           ;-------------------
           RTS                 ; back to pascal.
;---------------------------------------------------------------------
;
;  subroutines  GETCHAR1 & GETCHAR2
;
GETCHAR1   LDA #00             ; zero timeout counters
           STA C1
           STA C2
           ;-------------------
GETCHAR2   JSR RSTATUS         ; entry point without timeout reset.
           LDA BUFLEN          ; something in remin buffer?
           BNE GET             ; then get it.
           INC C1              ; if not then increase timeout counter
           BNE GETCHAR2        ; and keep testing remin buffer.
           INC C2
           LDA C2
           CMP TIMEOUT         ; if timeout period has expired then
           BNE GETCHAR2        ; indicate a receive failure.
           PLA                 ; remove this routine's return adress
           PLA                 ; from stack and go
           JMP RECFAIL         ; back to pascal.
           ;-------------------
GET        LDX #00             ; x = 0 : read request.
           JSR RREAD           ; read remin buffer. Char in accu.
           CMP SOH             ; main rpack will take action if a ^A is
           RTS                 ; detected.
;---------------------------------------------------------------------
;
;  subroutine  RSTATUS
;
RSTATUS    LDA #00             ; push controlword on stack
           PHA
           LDA #01
           PHA
           ;-------------------
           LDA BUFLENPTR+1     ; push adress of buflen on stack
           PHA
           LDA BUFLENPTR
           PHA
           ;-------------------
           LDX #04             ; x = 4 : status request.
           JSR RSTAT           ; number of char's in reminbuffer
           RTS                 ; can now be found in buflen.
;---------------------------------------------------------------------
;
;  variable space:
;
RETURN     .WORD 00
SOH        .BYTE 00
TIMEOUT    .BYTE 00
RESYNCNT   .BYTE 00
C1         .BYTE 00
C2         .BYTE 00
LEN        .BYTE 00
LENCNT     .BYTE 00
PTYPE      .BYTE 00
CHKSUM     .BYTE 00
PCHKSUM    .BYTE 00
BUFLEN     .WORD 00
BUFLENPTR  .WORD BUFLEN
;--------------------------------------------------------------------------
;--------------------------------------------------------------------------
;
;  These procedures are external to unit kermutil.
;
;--------------------------------------------------------------------------
;--------------------------------------------------------------------------
;
;  FUNCTION calc_checksum( var packet : packettype; len : integer ) : CHAR;
;
;  calculates one character checksum of a packet.
;
;  FUNCTION ctl( ch : char ) : CHAR;
;
;  transforms a control char to a printable char and vice versa.
;
;-----------------------------------------------------------------------
;
          .FUNC CALCCHECKSUM, 2 ; two parameters
RETURN    .EQU 00
PACKETPTR .EQU 02
CHKSUM    .EQU 04
          ;---------------------
          PLA                   ; pop return address
          STA RETURN
          PLA
          STA RETURN+1
          ;---------------------
          PLA                   ; pop .func bias
          PLA
          PLA
          PLA
          ;---------------------
          PLA                   ; save len in y reg.
          TAY
          DEY                   ; len = len - 1
          PLA                   ; discard msb.
          ;---------------------
          PLA                   ; pop address of var packet
          STA PACKETPTR
          PLA
          STA PACKETPTR+1
          ;---------------------
          LDA #00               ; push msb of function result
          PHA
          ;---------------------
SUM       CLC                   ; sum characters except packet[0]
          ADC @PACKETPTR,Y
          DEY
          BNE SUM
          ;--------------------
          STA CHKSUM            ; save this sum temporarily
          ROL A
          ROL A
          ROL A
          AND #03
          CLC
          ADC CHKSUM
          AND #3F
          ;---------------------
          ; equivalent to  s = ( s + ( ( s and 192 ) div 64 ) ) and 63
          PHA                  ; push lsb of function result
          LDA RETURN+1         ; push return and back to pascal
          PHA
          LDA RETURN
          PHA
          RTS
;----------------------------------------------------------------------
;
          .FUNC CTL, 1         ; one parameter
          PLA                  ; save return address in x and y
          TAX
          PLA
          TAY
          ;--------------------
          PLA                  ; pop .func bias
          PLA
          PLA
          PLA
          ;--------------------
          PLA                  ; leave msb function result on stack (=0)
          EOR #40              ; toggle bit 7 of character
          PHA                  ; push lsb funtion result
          ;--------------------
          TYA                  ; push return address
          PHA
          TXA
          PHA
          RTS
;-------------------------------------------------------------------------
;-------------------------------------------------------------------------
;
;  These procedures are external to the unit kermacia.
;
;-------------------------------------------------------------------------
;-------------------------------------------------------------------------
;
;            PROCEDURE   Send_6551_Break ( adr_comm_reg : INTEGER )
;
;  This procedure is external to the unit "kermacia" and is specific for a
;  6551 acia in slot 2.
;  It sends a "break" signal to the the remote host.
;  The signal is switched off by pressing any key.
;  The previous state of the command register is restored.
;-------------------------------------------------------------------------
;
;
          .PROC SEND6551BREAK, 1  ; one parameter : the address of the 6551
                                  ; command register.
COMREG    .EQU 00                 ; zero page pointer.
;---------------------------------
          PLA                 ; pop return adress.
          STA RETURN
          PLA
          STA RETURN+1
          ;-------------------
          PLA                 ; pop 6511 command reg. address.
          STA COMREG
          PLA
          STA COMREG+1
          ;-------------------
          LDY #00
          LDA @COMREG,Y
          PHA                 ; save content of command register.
          ORA #0C             ; turn on break bits 00001100
          STA @COMREG,Y       ; give break signal.
          ;-------------------
KEYBOARD  LDA 0C000           ; test apple keyboard
          BPL KEYBOARD
          STA 0C010           ; clear keyboard strobe
          ;-------------------
          PLA                 ; retrieve content of command register.
          STA @COMREG,Y       ; and restore old situation
          ;-------------------
          LDA RETURN+1        ; push return adress
          PHA
          LDA RETURN
          PHA
          RTS                 ; and back to pascal.
          ;-------------------
RETURN    .WORD 00
;----------------------------------------------------------------------
;
;            PROCEDURE   Send_6850_Break ( adr_comm_reg : INTEGER )
;
;  This procedure is external to the unit "kermacia" and is specific for a
;  6850 acia in slot 2.
;  It sends a "break" signal to the the remote host.
;  The signal is switched off by pressing any key.
;  The previous state of the command register is restored by the procedure
;  set_acia_parms in unit kermacia.
;-------------------------------------------------------------------------
;
;
          .PROC SEND6850BREAK, 1  ; one parameter : the address of the 6850
                                  ; command register.
COMREG    .EQU 00                 ; zero page pointer.
;---------------------------------
          PLA                 ; pop return adress.
          STA RETURN
          PLA
          STA RETURN+1
          ;-------------------
          PLA                 ; pop 6511 command reg. address.
          STA COMREG
          PLA
          STA COMREG+1
          ;-------------------
          LDY #00
          LDA #70             ; set break signal on .
          STA @COMREG,Y
          ;-------------------
KEYBOARD  LDA 0C000           ; test apple keyboard
          BPL KEYBOARD
          STA 0C010           ; clear keyboard strobe
          ;-------------------
          LDA #13             ; give an acia master reset.
          STA @COMREG,Y       ;
          ;-------------------
          LDA RETURN+1        ; push return adress
          PHA
          LDA RETURN
          PHA
          RTS                 ; and back to pascal.
          ;-------------------
RETURN    .WORD 0
;-----------------------------------------------------------------------
          .END
(*=== KERMTERM.TEXT ===*)
;>>>>>>>>>>>>>>>>>>>>>>> KERMTERM.TEXT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


;----------------------------------------------------------------------
;----------------------------------------------------------------------
;
;  This procedure is external to the main kermit program.
;
;----------------------------------------------------------------------
;----------------------------------------------------------------------
; PROCEDURE Kerm_Term( BS_to_DEL, Esc_Char, Xon_Char, Xoff_Char : CHAR;
;                      Xoff_Wait : INTEGER;
;                      No_Ffeed, Print, Half_Duplex, Reject_Cntrl_Char,
;                      Emulate : BOOLEAN );
;----------------------------------------------------------------------
;
; This procedure works only in cooperation with my serial card driver
; BIOS routine, that implements the UCSD  UNITSTATUS procedure and buffers
; serial input for various serial cards. ( see REMDRIVER.TEXT )
; It is written in 6502 code in order to be able to work at high baudrates.
; The baudrate limiting factor on the Apple is the screen scrolling routine.
; If one can set the linefeed fill count in the remote host terminal
; definition to an appropiate value, then this procedure works at 4800 baud.
; With the right Xon and Xoff characters ( most often ^Q and ^S ) and Xoff-
; wait count this procedure will echo on request also to a printer, without
; losing characters. Increase Xoff_wait if characters seem to be lost when
; printing.
; If your keyboard doesn`t have a DEL key and your host requires one for
; delete & backspace, then set BS_to_DEL to CHR(127). During the connection
; your BS key (Asci 8) will be translated to DEL (Asci 127).
; If you do not want incoming control characters other than 'bell', 'bs',
; 'lf', 'ff', 'cr' echoed to to your screen : set 'reject_cntrl_char' to
; true.
;----------------------------------------------------------------------
;
; N.B.  EMULATE is not implemented.
;
;----------------------------------------------------------------------
;
          .PROC KERMTERM,10.  ; 10 parameters, see above.
;
BIOSAF    .EQU 0FF5C        ;base of bios jump table. Same in V1.1 &1.2
CREAD     .EQU BIOSAF+0     ;bios console read routine adres
CWRITE    .EQU BIOSAF+3.    ;bios console write routine adres
PWRITE    .EQU BIOSAF+9.    ;bios printer write routine adres
RREAD     .EQU BIOSAF+24.   ;bios remote read routine adres
RWRITE    .EQU BIOSAF+27.   ;bios remote write routine adres
CSTAT     .EQU BIOSAF+42.   ;bios keyboard status routine adres
RSTAT     .EQU BIOSAF+51.   ;bios remote status routine adres
;
;  The BIOS After Fold jump vector will be patched by SYSTEM.ATTACH .
;  From the above routines only RREAD & RSTAT are actually changed.
;
BIOSRAM   .EQU 0C083        ;switch adress for extra 4k language card part.
                            ;contains UCSD BIOS routines.
INTPRAM   .EQU 0C08B        ;switch adress to get back to normal language
                            ;card part. contains UCSD interpreter.
RPTR      .EQU 0BF18        ;read pointer for circular keyboard buffer.
WPTR      .EQU 0BF19        ;write   "     "     "        "      "
BS        .EQU 08           ;backspace character.
LINEFD    .EQU 0A           ;linefeed     "
FF        .EQU 0C           ;formfeed     "
CR        .EQU 0D           ;return       "
BELL      .EQU 07           ;bell         "
TRUE      .EQU 80           ;used as boolean.
;---------------------------
; GET PARAMETERS FROM STACK
;
          PLA               ; pop return adress.
          STA RETURN
          PLA
          STA RETURN+1
          ;-----------------
          PLA               ; pop emulate boolean.
          BEQ $05
          LDA #TRUE
$05       STA EMULATE
          PLA
          ;----------------
          PLA               ; pop Reject_Cntrl_Char Boolean.
          BEQ $01
          LDA #TRUE
$01       STA REJECT
          PLA
          ;-----------------
          PLA               ; pop Half_Duplex Boolean.
          BEQ $02
          LDA #TRUE
$02       STA HALFDUP
          PLA
          ;-----------------
          PLA               ; pop Printer Boolean.
          BEQ $03
          LDA #TRUE
$03       STA PRINTER
          PLA
          ;-----------------
          PLA               ; pop No_Ffeed Boolean.
          BEQ $04
          LDA #TRUE
$04       STA NOFEED
          PLA
          ;-----------------
          PLA               ; pop Xoff_Wait Integer (1..255).
          STA XOFFWAIT
          PLA
          ;-----------------
          PLA               ; pop Xoff_Char Char.
          STA XOFFCHAR
          PLA
          ;-----------------
          PLA               ; pop Xon_Char Char.
          STA XONCHAR
          PLA
          ;-----------------
          PLA               ; pop ExitChar Char.
          STA EXITCHAR
          PLA
          ;-----------------
          PLA               ; pop BS_to_DEL Char.
          STA BSTODEL
          PLA
;---------------------------
          LDA BIOSRAM       ; switch in BIOS RAM
;---------------------------
START     JSR RSTATUS       ; returns in BUFLEN # char's in remin-buffer.
          LDA BUFLEN
          BEQ READKEY       ; read keyboard if buffer empty.
          ;-----------------
          BIT PRINTER       ; is printer on?
          BPL EMPTYRBUF     ; no : start reading remin buffer.
          ;-----------------
XOFFSEND  LDA XOFFCHAR      ; printer is on:
          JSR RWRITE        ; send xoff char to host and
          LDA XOFFWAIT      ; keep checking remin for a certain time,
          STA COUNT         ; because host may send some more char's
WAIT      JSR RSTATUS       ; before it really gets the xoff.
          DEC COUNT
          BNE WAIT
          ;-----------------
EMPTYRBUF LDX #00           ; X=0 : read request.
          JSR RREAD         ; read a char from remin buffer.
          ;-----------------
          BIT REJECT        ; reject control chars?
          BPL ECHO          ; no: echo to console.
          JSR CHECKCTRL     ; yes: check for allowed control char's.
          ;-----------------
ECHO      PHA               ; save char.
          JSR CWRITE        ; echo char to console.
          PLA               ; restore char in accu.
          ;-----------------
          BIT PRINTER       ; is printer on?
          BPL NOPRINT       ; if not, don't print char.
          ;-----------------
          CMP #FF           ; printer is on. is char a formfeed?
          BNE NOFF
          JSR REPLFF        ; yes: replace it if requested.
NOFF      LDX #01           ; write request.
          JSR PWRITE        ; print char.
          ;-----------------
NOPRINT   DEC BUFLEN        ; keep on reading remin char's until
          BNE EMPTYRBUF     ; reminbuffer is empty.
          ;-----------------
          BIT PRINTER       ; is printer on?
          BPL READKEY       ; no  : check keyboard.
          LDA XONCHAR       ; yes : send xon char to host.
          JSR RWRITE
          ;-----------------
READKEY   LDA RPTR          ; if keyboardbuffer readpointer is
          CMP WPTR          ; equal to writepointer then keyboardbuffer is
          BEQ START         ; empty. loop back to start.
          ;-----------------
          JSR CREAD         ; get a char from keyboardbuffer.
          CMP EXITCHAR      ; is it the escape char?
          BEQ EXIT          ; then exit this procedure.
          ;-----------------
          BIT HALFDUP       ; half_duplex mode ?
          BPL FULLDUP       ; if not , don't echo to screen.
          PHA               ; if half_duplex, save char
          JSR CWRITE        ; echo char to screen.
          PLA               ; restore char to accu
          ;-----------------
FULLDUP   CMP #BS           ; is char a backspace?
          BNE NOBS          ; if not, don't change it.
          LDA BSTODEL       ; if a backspace, translate it to BSTODEL value.
NOBS      JSR RWRITE        ; send keyboard char to remote host
          JMP START         ; start listening to remin again.
          ;-----------------
EXIT      LDA INTPRAM       ; switch BIOS RAM off and interpreter RAM on.
          ;-----------------
          LDA RETURN+1      ; push return adress and back to pascal.
          PHA
          LDA RETURN
          PHA
          ;-----------------
          RTS
;---------------------------------------------------------------------------
;---------------------------------------------------------------------------
;
; SUBROUTINES
;
;---------------------------
;RSTATUS : prepare stack and call reminstatus routine in attached driver.
;
RSTATUS   LDA #00           ; push controlword (=1 : statuscall )
          PHA
          LDA #01
          PHA
          ;-----------------
          LDA BUFLENPTR+1   ; push adres of BUFLEN
          PHA
          LDA BUFLENPTR
          PHA
          ;-----------------
          LDX #04           ; X=4 : statusrequest.
          JSR RSTAT
          RTS
;---------------------------
; CHECKCTRL
;
CHECKCTRL CMP #20           ; is it a control char?
          BCS ECHO1         ; no: echo to console.
          CMP #CR           ; pass to console in any case CR,LF,BS,FF,BELL.
          BEQ ECHO1
          CMP #LINEFD
          BEQ ECHO1
          CMP #BS
          BEQ ECHO1
          CMP #FF
          BEQ ECHO1
          CMP #BELL
          BEQ ECHO1
          PLA
          PLA
          JMP NOPRINT       ; do not echo other control characters.
ECHO1     RTS
;---------------------------
;REPLFF : replaces formfeed with 3 lf's and 1 cr,if requested.
;
REPLFF    BIT NOFEED        ; ff to be elimininated?
          BPL NOCHANGE      ; if not, return.
          LDA #03
          STA COUNT         ; set count to 3
$04       LDA #LINEFD       ; send 3 linefeeds to printer
          LDX #01
          JSR PWRITE
          DEC COUNT
          BNE $04
          LDA #CR           ; replace formfeed with cr.
NOCHANGE  RTS               ; and return.
;---------------------------
;--------------------------------------------------------------------------
;
; VARIABLES
;
;--------------------------------------------------------------------------
RETURN    .WORD 00
BUFLEN    .WORD 00
BUFLENPTR .WORD BUFLEN
COUNT     .BYTE 00
HALFDUP   .BYTE 00
PRINTER   .BYTE 00
NOFEED    .BYTE 00
XOFFWAIT  .BYTE 00
XOFFCHAR  .BYTE 00
XONCHAR   .BYTE 00
EXITCHAR  .BYTE 00
BSTODEL   .BYTE 00
REJECT    .BYTE 00
EMULATE   .BYTE 00
;----------------------------------------------------------------------
          .END
(*=== REMDRIVER.TEXT ===*)
;>>>>>>>>>>>>>>>>>>>>>>> REMDRIVER.TEXT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;
; For an introduction see the file REMDR.DOC.TEXT
;
;----------------------------------------------------------------------
;
; Serial card driver for Kermit-UCSD  RUG/PT V1.0
;
;----------------------------------------------------------------------
;
; LABEL DEFINITIONS
;
SLOT      .EQU 20          ; various slot 2 labels
SLT2MSB   .EQU 0C2
SLOT2ADR  .EQU 0C200
;
                           ; addresses of the offset bytes to calculate :
FSTATUS   .EQU SLOT2ADR+10 ; entry point for a serial firmware card status
FREAD     .EQU SLOT2ADR+0E ;   "     "    "  "   "       "      "   read
;
DUMMY     .EQU 0FFFF       ; dummy address. will be filled in at cold boot.
;
AP2COMM   .EQU 0C08E+SLOT  ; IBS AP2 serial card (6551 acia) command register.
AP2STREG  .EQU 0C08D+SLOT  ;  "   "    "     "     "    "    status     "
AP2IOREG  .EQU 0C08C+SLOT  ;  "   "    "     "     "    "    I/O        "
;
COMSTREG  .EQU 0C08E+SLOT  ; Apple Com Card (6850 acia) status register.
COMIOREG  .EQU 0C08F+SLOT  ;   "    "    "    "    "    I/O      "
;
HAYSTREG  .EQU 0C086+SLOT  ; Hayes Micromodem (6850 acia) status register.
HAYIOREG  .EQU 0C087+SLOT  ;   "       "        "    "    I/O      "
                           ; (Com Card registers may also work.)
SPEAKER   .EQU 0C030
SPCHAR    .EQU 0BF1C       ; system location for special keyboard character
                           ; checking.
SLT2TYP   .EQU 0BF27+2     ; system location with serial card type
                           ; 0 = no card.
                           ; 1 = not recognized by system.
                           ; 3 = Apple Com card
                           ;     California 7710 ASI1 card
                           ;     Hayes Micromodem card?
                           ; 4 = serial card ( IBS AP2 )
                           ; 6 = Firmware card ( Super Serial Card )
;
NUMSERID  .EQU 02-1        ; number(-1) of serial cards this driver checks.
;
ACJVAFOLD .EQU 0E2         ; pointer to attached copy of BIOS jump vector.
JVAFOLD   .EQU 0EE         ; pointer to BIOS jump vector.
;
CONCK     .EQU DUMMY       ; address of BIOS keyboard check routine.
RINIT     .EQU DUMMY       ; address of BIOS Remote Init routine.
INPORTSTAT.EQU DUMMY       ; address of this driver's Remote status routine.
;
STATREC   .EQU 00          ; temp. zero page pointer to status record.
;
;----------------------------------------------------------------------
;
          .PROC REMDRIVER
;
;----------------------------------------------------------------------
          JMP CONCKHDL     ; The first 3 instructions of CONCK will
                           ; be patched by SYSTEM.ATTACH to point here.
;----------------------------------------------------------------------
;
; Calls to REMREAD, REMSTATUS and REMINIT will be handled here :
;
          TXA              ; X=0 : Remote Read request.
          BEQ REMREAD
          CMP #004         ; X=4 : Remote Status request.
          BEQ REMSTATUS
          CMP #002
          BNE ERROR        ; X=2 : Remote Init request.
          ;----------------
          ;
          ; Remote Init routine :
          ;
          LDX REMRPTR      ; Empty remote input buffer.
          STX REMWPTR      ; ( read-pointer = write-pointer )
          LDX #000         ; zero buffer counter.
          STX BUFCOUNT
PATCH3    JMP ONCERINIT    ; if called for the first time ( cold boot ) then
                           ; do the cold boot init routine. This routine
                           ; patches the JMP instruction to NOP,NOP,NOP so
                           ; later init calls (warm boot) will only empty the
                           ; remin buffer.
          RTS
          ;----------------
ERROR     LDX #003         ; for any other request return error code.
          RTS
;----------------------------------------------------------------------
;
; Remote read routine ( reads only the remin buffer ).
;
REMREAD   JSR CONCKHDL     ; check keyboard and remote input port.
          LDX REMRPTR      ; if remin buffer is empty : keep checking remote
          CPX REMWPTR      ; input port until something arrives.
          BEQ REMREAD
          INX              ; read char from remin buffer, bump read-pointer
          STX REMRPTR      ; decrease buffer count and put char in accu.
          DEC BUFCOUNT
          LDA REMBUF,X
READY     LDX #000         ; no error.
          RTS
;----------------------------------------------------------------------
;
; Remote status routine ( implements UNITSTATUS. see KERM.DOC2.TEXT )
;
REMSTATUS JSR CONCKHDL     ; check keyboard and remote input port.
          PLA              ; save return address.
          STA RETURN
          PLA
          STA RETURN+1
          ;------------
          PLA              ; save address of statusrecord on zero page.
          STA STATREC
          PLA
          STA STATREC+1
          ;------------
          PLA              ; save controlword.
          STA CONTROLW
          PLA
          STA CONTROLW+1
          ;------------
          LDA RETURN+1     ; push return address back on stack.
          PHA
          LDA RETURN
          PHA
          ;----------------------------------
REMINSTAT LDX #000         ; zero registers.
          LDY #000
          ;----------------
          ;
          ; Decipher Controlword.
          ;
          LDA CONTROLW     ; if bit 1 = 0 then the purpose is statusrequest.
          AND #002         ; if bit 1 = 1 then the purpose is controlrequest.
                           ; bit 0 (direction) is not checked.
          BNE REMCNTROL
          LDA CONTROLW+1   ; if bit 13 = 0 then a "normal" request.
          AND #020
          BNE PEEK         ; if bit 13 = 1 then a "special" request.
          ;----------------
          ;
          ; Normal Status Request: load in statusrecord ( 2 bytes ) the number
          ; of characters currently in the remin buffer.
          ;
          LDA BUFCOUNT
LOAD      STA @STATREC,Y
          LDA #00
          INY
          STA @STATREC,Y
          RTS
          ;---------------
          ;
          ; Special Status Request: statusrecord first to bytes contain an
          ; address. Return in statusrecord last 2 bytes the value of the
          ; requested location.
          ;
PEEK      LDA @STATREC,Y
          STA ADR1+1
          INY
          LDA @STATREC,Y
          STA ADR1+2
ADR1      LDA DUMMY        ; DUMMY will be changed to the requested address.
          INY
          BNE LOAD         ; value returned is a Pascal Integer!
          ;----------------
          ;
          ; Control Requests :
          ;
REMCNTROL LDA CONTROLW+1   ; if bit 13 = 0 then a normal controlrequest.
          AND #020
          BNE POKE
          ;----------------
          ; Normal Control Request
          ;
          ; first byte of statusrecord contains
          ; 0..3 : store this byte in SPCHAR.
          ; SPCHAR=0 : CONCK checks class 1 and class 2 special chars.
          ; SPCHAR=1 :   "     "    only        class 2    "     "
          ; SPCHAR=2 :   "     "    only        class 1    "     "
          ; SPCHAR=3 :   "     "           no              "     "
          ; ( see KERM.DOC2.TEXT )
          ;
          ; first byte of statusrecord contains
          ; 4  :  7 bit characters in remin buffer.
          ; 5  :  8 bit      "     "    "    "
          ;
          LDA @STATREC,Y
          CMP #004
          BCS BIT78
          STA SPCHAR
          RTS
          ;-----------------
          ;
          ; Special Control Request : statusrecord first 2 bytes contain a
          ; address. Statusrecord third byte contains the value the location
          ; should contain.
          ;
POKE      LDA @STATREC,Y
          STA ADR2+1
          INY
          LDA @STATREC,Y
          STA ADR2+2
          INY
          LDA @STATREC,Y
ADR2      STA DUMMY        ; DUMMY will be filled in at run time.
          RTS
          ;----------------
BIT78     CMP #005         ; set the flag LOCALPAR for the remin input routine.
          BEQ EIGHTBIT     ; default startup setting is seven bit remin chars.
          LDA #000
          BEQ SETLOCPAR
EIGHTBIT  LDA #080
SETLOCPAR STA LOCALPAR
          RTS
;----------------------------------------------------------------------
;
; Calls to the system CONCK routine come here. A call to this
; driver's remin check routine is inserted so that every time the system
; does any I/O call both the keyboard and the remote input port will be checked.
;
CONCKHDL  PHP           ; repeat first 6 instructions of CONCK.
          PHA
          TXA
          PHA
          TYA
          PHA
          JSR REMINCK   ; check the remote input port.
PATCH2    JMP CONCK     ; enter CONCK at start+6 and return from there to
                        ; system. The 2 bytes after the JMP will be filled
                        ; in at first initialization of this driver.
;----------------------------------------------------------------------
;
; REMINCK  : checks remote input port. If it finds a char, it will put it
;            in the remin buffer.
;
REMINCK   JSR INPORTST  ; checks remote inputport. Carry is set when a char
                        ; is waiting. Returns with char in accu.
                        ; The address INPORTST will be filled in at cold boot
                        ; initialization time to point at the correct status
                        ; routine.
          BCC EMPTY
          BIT LOCALPAR  ; depending on LOCALPAR : strip bit 8 of incomimg char.
          BMI NOCHANGE
          AND #07F
NOCHANGE  LDX REMWPTR   ; bump writepointer.
          INX
          CPX REMRPTR   ; if writepointer = readpointer then buffer is full!
          BNE BUFOK
          ;----------
          PHA           ; in case of buffer overflow :
          TXA           ; give a high pitched bell sound.
          PHA
BELL      LDY #060
BELL1     LDX #020
BELL2     DEX
          BNE BELL2
          LDA SPEAKER
          DEY
          BNE BELL1
          LDA #0FF      ; set buffer count to -1.
          STA BUFCOUNT  ; buffer will thus be emptied.
          PLA
          TAX
          PLA
          ;------------
BUFOK     STX REMWPTR   ; save new writepointer.
          INC BUFCOUNT  ; bump buffer count and
          STA REMBUF,X  ; store received char in buffer.
EMPTY     RTS
;-----------------------------------------------------------------------
;
;   Remote status routines for different serial cards.
;   Only one of these is active after cold boot initialization.
;
;   The status routine returns with the received character (if any) in accu
;   and with the carry set if a character was received.
;
;-----------------------------------------------------------------------
;
;   Status routine for an IBS AP2 serial card with a 6551 acia.
;
AP2STAT   LDA AP2COMM
          ORA #008
          STA AP2COMM
          LDA AP2STREG
          CLC
          AND #028
          EOR #008
          BNE NOTHING1
          SEC
          LDA AP2IOREG
NOTHING1  PHA
          LDA AP2COMM
          AND #0F3
          STA AP2COMM
          PLA
          RTS
;----------------------------------------------------------------------
;
;   Status routine for Hayes Micromodem Card with a 6850 acia.
;   ( Identical to Apple Com Card. Can probably be replaced by Com Card routine
;     if Hayes card is also recognized by the Pascal system as an Apple Com
;     card. )
;
HAYESTAT  LDA HAYSTREG
          LSR A
          BCC NOTHING2
          LDA HAYIOREG
NOTHING2  RTS
;-----------------------------------------------------------------------
;
;   Status routine for an Apple Communications Card or California 7710
;   ASI1 card , both with a 6850 acia.
;
COMSTAT   LDA COMSTREG
          LSR A
          BCC NOTHING3
          LDA COMIOREG
NOTHING3  RTS
;-----------------------------------------------------------------------
;
;   Status routine for a "firmware" card like the Apple Super Serial Card.
;   Firmware cards have there own status and read routines in ROM.
;   The final addresses of the status and read routines will be calculated
;   at cold boot initialization and filled in directly here at PATCH4 and
;   PATCH5.
;
FIRMSTAT  LDX #SLT2MSB   ; do the required initialization.
          LDY #SLOT
          STY 06F8
          STA 0CFFF
          LDA SLOT2ADR
          LDA #001
PATCH4    JSR FSTATUS
          BCC NOTHING
          LDX #SLT2MSB
PATCH5    JSR FREAD      ; returns with char in accu.
          SEC
NOTHING   RTS
;------------------------
;
; If you have extended FINDSER to recognize more serial cards then insert
; here the code for the new serial card's status routine.
;
;----------------------------------------------------------------------------
;
;  Local variables
;
RETURN    .WORD 00
LOCALPAR  .BYTE 00
REMRPTR   .BYTE 00
REMWPTR   .BYTE 00
CONTROLW  .WORD 00
BUFCOUNT  .BYTE 00
;
;
;----------------------------------------------------------------------------
;----------------------------------------------------------------------------
;
;          START OF THE REMIN BUFFER AREA
;
;          Contains cold boot initialization code.
;
REMBUF   .BYTE 00
;----------------------------------------------------------------------------
;
PBOTABLE .BYTE 01.,02.,04.,05.,07.,08.,28.,29.,43.,44. ; offset bytes to patch
                                                       ; back the BIOS jump
                                                       ; vector.
AP2STPTR .WORD AP2STAT     ; pointers to the various status routines.
COMSTPTR .WORD COMSTAT
HAYESTPTR.WORD HAYESTAT
FIRMSTPTR.WORD FIRMSTAT
;
OFFSET1  .BYTE 04E,01A     ; offset and identification bytes to recognize
OFFSET2  .BYTE 065,02A     ; different serial cards :
IDBYTE1  .BYTE 04D,09C     ; first row = IBS AP2 serial card.
IDBYTE2  .BYTE 0A3,051     ; second row = Hayes Micromodem card.
;
; Insert more offset and Id-bytes for other serial cards here.
; Adjust NUMSERID correspondingly.
;
;-------------------------
ONCERINIT LDX #009         ; cold boot init jumps here.
PATCHBACK LDA PBOTABLE,X   ; get normal BIOS addresses from the attached copy
          TAY              ; and patch back the BIOS jump vector, except
          LDA @ACJVAFOLD,Y ; remote status, read and init.
          STA @JVAFOLD,Y
          DEX
          BPL PATCHBACK
;--------------------------
          CLC              ; get address of CONCK, add 6 to it and patch
          LDY #055.        ; this code.
          LDA @ACJVAFOLD,Y
          ADC #006
          STA PATCH2+1
          INY
          LDA @ACJVAFOLD,Y
          ADC #000
          STA PATCH2+2
;--------------------------
          LDY #031.        ; get address of Remote INIT and patch this code.
          LDA @ACJVAFOLD,Y
          STA PATCH1+1
          INY
          LDA @ACJVAFOLD,Y
          STA PATCH1+2
;--------------------------
          LDA #0EA         ; patch the instruction JMP ONCERINIT to NOP(3x).
          STA PATCH3       ; ONCERINIT will be done only once.
          STA PATCH3+1
          STA PATCH3+2
;--------------------------
;--------------------------
          LDA SLT2TYP      ; find out which serial card there is in slot 2.
          CMP #003
          BNE NXTTYP2
          LDX COMSTPTR     ; Apple Com Card : save pointer to status routine
          LDY COMSTPTR+1   ; in X and Y registers.
          BNE TORINIT
NXTTYP2   CMP #006
          BNE NXTTYP3
          LDA FSTATUS      ; firmware card : get offset bytes from card's ROM
          STA PATCH4+1     ; and patch the status and read routine entry
          LDA FREAD        ; points in the FIRMSTAT routine.
          STA PATCH5+1
          LDX FIRMSTPTR
          LDY FIRMSTPTR+1
          BNE TORINIT
NXTTYP3   CMP #004
          BNE NOTKNOWN
          JSR FINDSER      ; if it is a serial card try to recognize it.
          BMI NOTKNOWN     ; FINDSER returns with minus flag on if card was
          TYA              ; not recognized. Y = ID number of serial card.
          BEQ AP2SER       ; Y=0 : IBS AP2 card.
HAYSER    CMP #001         ; Y=1 : Hayes micromodem card.
                           ; If Hayes card is already recognized as an Apple
                           ; Com card (I don't know), then this part can be
                           ; deleted.
          BNE NOTKNOWN     ; If FINDSER recognizes more serial cards then
                           ; insert here extra code for other cards.
          LDX HAYESTPTR
          LDY HAYESTPTR+1
          BNE TORINIT
AP2SER    LDX AP2STPTR
          LDY AP2STPTR+1
;--------------------------
TORINIT   STX REMINCK+1    ; Patch INPORTSTAT to point to the adress of status
          STY REMINCK+2    ; routine.
PATCH1    JMP RINIT        ; Initialize once the serial card according to the
                           ; card's normal init routine.
NOTKNOWN  LDX #009         ; If card was not recognized then return to system
          LDY #SLOT        ; with error code 9 ( volume not found ).
          RTS
;-------------------------------------------------------------------------
;
;  Serial card recognition routine.
;
;  Checks two unique bytes in the cards ROM space ( C200-C2FF ).
;
FINDSER   LDY #NUMSERID
FNDNEXT1  LDA OFFSET1,Y
          TAX
          LDA SLOT2ADR,X
          CMP IDBYTE1,Y
          BEQ CONFIRM
FNDNEXT2  DEY
          BPL FNDNEXT1
          RTS
CONFIRM   LDA OFFSET2,Y
          TAX
          LDA SLOT2ADR,X
          CMP IDBYTE2,Y
          BNE FNDNEXT2
CODEND    RTS
;---------------------------------------------------------------------------
          .BLOCK 256.+REMBUF-CODEND,00  ; adjusts buffer if init codelength
                                        ; is changed.
;---------------------------------------------------------------------------
          .END
(*=== REMDR.DOC.TEXT ===*)
;>>>>>>>>>>>>>>>>>>>>>>> REMDR.DOC.TEXT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
;
;
;----------------------------------------------------------------------
;
; Serial card driver for Kermit-UCSD  RUG/PT V1.0
;
;----------------------------------------------------------------------
;
; This program should be assembled and stored in the library ATTACH.DRIVERS
; with the aid of the system program LIBRARY.CODE. It will work only
; when the program SYSTEM.ATTACH and the file ATTACH.DATA are also present
; on the boot disk. For an explanation see also KERM.DOC2.TEXT.
;
; According to ATTACH.DATA the following volumes are attached to this driver :
; ( see KERM.DOC3.TEXT for instructions on how to make ATTACH.DATA )
; REMIN:
; REMOUT:
; CONSOLE:
; KEYBOARD:
; After the cold boot initialization of this driver however the modified BIOS
; jump vector will be patched back to point at the normal BIOS entry points
; except for the Remote Read, Init and Status routines.
; The BIOS routine CONCK ( checks keyboard and maintains type-ahead buffer )
; will still point to the top of this driver. Before sending a call to CONCK
; back to the normal entry point, this driver will make a call to the routine
; REMINCK to check the remote input port and to maintain a circular 256 byte
; Remin buffer. The routine REMREAD reads only from this buffer.
;
; In order to keep this driver short, the cold boot initialization routine,
; is placed in the 256 byte buffer area. It will be replaced by the data
; received at the remote input port.
;
;----------------------------------------------------------------------
;
;                         P. Terpstra
;                         Dept. Biochemistry
;                         University Groningen
;                         Nijenborgh 16
;                         9747 AG Groningen
;                         The Netherlands
;
;----------------------------------------------------------------------
;
; For the source text of REMDRIVER see the file REMDRIVER.TEXT
;
;-----------------------------------------------------------------------
(*=== AP2.TEXT ===*)
27     ;escape char: to escape from CONNECT mode back to the Apple.
13     ;end-of-line char send to host after a kermit package.
35     ;the kermit quote char the Apple uses to prefix control chars.
0      ;the kermit padding char the Apple needs.
0      ;number of padding chars the Apple needs.
1      ;start-of-header (SOH) char the Apple uses to indicate a kermit packet.
5      ;Apple key to manually interrupt the sending/receiving of files: <^E>
17     ;Xon char used during CONNECT when printing the screen.
19     ;Xoff char used during CONNECT when printing the screen.
40     ;number of wait-cycles after sending a Xoff during the screendump.
94     ;max kermit packet length the Apple can handle ( 20..94 ).
5      ;max number of retries before the Apple breaks off sending/receiving.
5      ;number of seconds(1..31) after which the host should resend a packet.
0      ;half-duplex mode. ( 0 = false ).
0      ;debug mode during sending/receiving. ( 0 = false ).
1      ;file-warning for incoming files to avoid name conflicts. ( 0 = false )
1      ;text-file send/rec mode. ( 1 = true )
1      ;no formfeeds during CONNECT when screendump is on. ( 1 = true )
1      ;in CONNECT:no echoing of control chars (exc. cr,lf,ff,bs,bell )(1=true)
0      ;backspace key translated to DEL during CONNECT. ( 1 = true )
1      ;type of acia on serial card.(0 = unknown, 1 = 6551 acia, 2 = 6850 acia )
-16210 ;adress of the acia command register. ( IBS AP2 serial card )
-16209 ;adress of the acia control register. ( IBS AP2 serial card )
300    ;initial baud rate.
8      ;number of databits ( word-length ).
1      ;number of stopbits.
0      ;parity ( 0=nopar; 1=oddpar; 2=evenpar; 3=markpar; 4=spacepar ).
80     ;80= 80-column card in slot 3; 40= normal 40 column screen.
       ;******************* AP2.TEXT ******************************************

(*=== APCOM.TEXT ===*)
27     ;escape char: to escape from CONNECT mode back to the Apple.
13     ;end-of-line char send to host after a kermit package.
35     ;the kermit quote char the Apple uses to prefix control chars.
0      ;the kermit padding char the Apple needs.
0      ;number of padding chars the Apple needs.
1      ;start-of-header (SOH) char the Apple uses to indicate a kermit packet.
5      ;Apple key to manually interrupt the sending/receiving of files: <^E>
17     ;Xon char used during CONNECT when printing the screen.
19     ;Xoff char used during CONNECT when printing the screen.
40     ;number of wait-cycles after sending a Xoff during the screendump.
94     ;max kermit packet length the Apple can handle ( 20..94 ).
5      ;max number of retries before the Apple breaks off sending/receiving.
5      ;number of seconds(1..31) after which the host should resend a packet.
0      ;half-duplex mode. ( 0 = false ).
0      ;debug mode during sending/receiving. ( 0 = false ).
1      ;file-warning for incoming files to avoid name conflicts. ( 0 = false )
1      ;text-file send/rec mode. ( 1 = true )
1      ;no formfeeds during CONNECT when screendump is on. ( 1 = true )
1      ;in CONNECT:no echoing of control chars (exc. cr,lf,ff,bs,bell )(1=true)
0      ;backspace key translated to DEL during CONNECT. ( 1 = true )
2      ;type of acia on serial card.(0 = unknown, 1 = 6551 acia, 2 = 6850 acia )
-16210 ;adress of the acia command register. ( Apple Com Card )
0      ;adress of the acia control register.
300    ;initial baud rate.
8      ;number of databits ( word-length ).
1      ;number of stopbits.
0      ;parity ( 0=nopar; 1=oddpar; 2=evenpar; 3=markpar; 4=spacepar ).
80     ;80= 80-column card in slot 3; 40= normal 40 column screen.
       ;********************* APCOM.TEXT **************************************

(*=== SSC.TEXT ===*)
27     ;escape char: to escape from CONNECT mode back to the Apple.
13     ;end-of-line char send to host after a kermit package.
35     ;the kermit quote char the Apple uses to prefix control chars.
0      ;the kermit padding char the Apple needs.
0      ;number of padding chars the Apple needs.
1      ;start-of-header (SOH) char the Apple uses to indicate a kermit packet.
5      ;Apple key to manually interrupt the sending/receiving of files: <^E>
17     ;Xon char used during CONNECT when printing the screen.
19     ;Xoff char used during CONNECT when printing the screen.
40     ;number of wait-cycles after sending a Xoff during the screendump.
94     ;max kermit packet length the Apple can handle ( 20..94 ).
5      ;max number of retries before the Apple breaks off sending/receiving.
5      ;number of seconds(1..31) after which the host should resend a packet.
0      ;half-duplex mode. ( 0 = false ).
0      ;debug mode during sending/receiving. ( 0 = false ).
1      ;file-warning for incoming files to avoid name conflicts. ( 0 = false )
1      ;text-file send/rec mode. ( 1 = true )
1      ;no formfeeds during CONNECT when screendump is on. ( 1 = true )
1      ;in CONNECT:no echoing of control chars (exc. cr,lf,ff,bs,bell )(1=true)
0      ;backspace key translated to DEL during CONNECT. ( 1 = true )
1      ;type of acia on serial card.(0 = unknown, 1 = 6551 acia, 2 = 6850 acia )
-16214 ;adress of the acia command register. ( Apple Super Serial Card )
-16213 ;adress of the acia control register. ( Apple Super Serial card )
300    ;initial baud rate.
8      ;number of databits ( word-length ).
1      ;number of stopbits.
0      ;parity ( 0=nopar; 1=oddpar; 2=evenpar; 3=markpar; 4=spacepar ).
80     ;80= 80-column card in slot 3; 40= normal 40 column screen.
       ;****************************** SSC.TEXT *******************************

(*=== UNKNOWN.TEXT ===*)
27     ;escape char: to escape from CONNECT mode back to the Apple.
13     ;end-of-line char send to host after a kermit package.
35     ;the kermit quote char the Apple uses to prefix control chars.
0      ;the kermit padding char the Apple needs.
0      ;number of padding chars the Apple needs.
1      ;start-of-header (SOH) char the Apple uses to indicate a kermit packet.
5      ;Apple key to manually interrupt the sending/receiving of files: <^E>
17     ;Xon char used during CONNECT when printing the screen.
19     ;Xoff char used during CONNECT when printing the screen.
40     ;number of wait-cycles after sending a Xoff during the screendump.
94     ;max kermit packet length the Apple can handle ( 20..94 ).
5      ;max number of retries before the Apple breaks off sending/receiving.
5      ;number of seconds(1..31) after which the host should resend a packet.
0      ;half-duplex mode. ( 0 = false ).
0      ;debug mode during sending/receiving. ( 0 = false ).
1      ;file-warning for incoming files to avoid name conflicts. ( 0 = false )
1      ;text-file send/rec mode. ( 1 = true )
1      ;no formfeeds during CONNECT when screendump is on. ( 1 = true )
1      ;in CONNECT:no echoing of control chars (exc. cr,lf,ff,bs,bell )(1=true)
0      ;backspace key translated to DEL during CONNECT. ( 1 = true )
0      ;type of acia on serial card.(0 = unknown, 1 = 6551 acia, 2 = 6850 acia )
0      ;adress of the acia command register.
0      ;adress of the acia control register.
300    ;initial baud rate.
8      ;number of databits ( word-length ).
1      ;number of stopbits.
0      ;parity ( 0=nopar; 1=oddpar; 2=evenpar; 3=markpar; 4=spacepar ).
80     ;80= 80-column card in slot 3; 40= normal 40 column screen.
       ;********************* UNKNOWN.TEXT ************************************

(*=== MAKEDATA.TEXT ===*)
{>>>>>>>>>>>>>>>>>>>>>>>>>> MAKEDATA.TEXT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}


Program  make_kermit_data;

var  setupname, dest_vol : string;
     tf : text;
     df : file of integer;
     infile : array[1..28] of integer;
     i  : integer;


begin
  writeln('name of the kermit setup text file? ');
  readln( setupname );
  writeln('write final kermit.data file to which volume? ');
  readln( dest_vol );
  reset( tf, setupname );
  for i := 1 to 28 do readln( tf, infile[i] );
  close( tf );
  rewrite( df, concat( dest_vol, 'KERMIT.DATA' ) );
  for i := 1 to 28 do
    begin
      df^ := infile[i];
      put( df );
    end;
  close( df, lock );
  writeln('ready');
end.
(*=== ATTACH.UPD.TEXT ===*)
{>>>>>>>>>>>>>>>>>>>> ATTACH.UPD.TEXT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

PROGRAM ATTACHUPD ;

TYPE  SD = RECORD
            DISKINFO : ARRAY[0..15] OF RECORD
                                         CODELENG, CODEADDR : INTEGER
                                       END;
            SEGNAME  : ARRAY[0..15] OF PACKED ARRAY[0..7] OF CHAR;
            SEGKIND  : ARRAY[0..15] OF ( LS, HS, SP, US, SS, UI, LI, DS );
            TEXTADDR : ARRAY[0..15] OF INTEGER;
            SEGINFO  : PACKED ARRAY[0..15] OF PACKED RECORD
                                                       SEGNUM : 0..255;
                                                       MTYPE  : 0..015;
                                                       UNUSED : 0..001;
                                                       VERSION: 0..007
                                                     END;
            INTRINSEG: SET OF 0..31;
            INFO     : PACKED ARRAY[0..219] OF 0..255;
           END;

VAR   SEGDIC : SD;
      FILENAME : STRING;
      F : FILE;
      OPTION,J : INTEGER;



PROCEDURE EXPLAIN;
BEGIN
  WRITELN('This program patches the FORTRAN compiler or SYSTEM.ATTACH (V1.1).');
  WRITELN('They can then be used with the UCSD Pascal Version 1.2.');
  WRITELN('The "Segment Version Numbers" in the SEGMENT-DICTIONARY of');
  WRITELN('these files will be changed to 5.');
  WRITELN('( Operating system reference manual pp. 266-269 )');
  WRITELN;
  WRITELN('Version 1.1 also accepts these patched files.');
  WRITELN;
  WRITELN('I cannot guarantee that this patch will work for all cases!');
  WRITELN('( P. Terpstra, Dept. Biochemistry, Groningen )');
  WRITELN;
  WRITELN('Choose option 1,2,3 or 4');
  WRITELN;
  WRITELN('1) FORTRAN COMPILER ==> Version 1.2');
  WRITELN('2) FORTRAN COMPILER ==> Restore original version bytes.');
  WRITELN;
  WRITELN('3) SYSTEM.ATTACH    ==> Version 1.2');
  WRITELN('4) SYSTEM.ATTACH    ==> Restore original version bytes.');
  WRITELN;
  WRITE('Option ? ');
END;

BEGIN
  EXPLAIN;
  READLN(OPTION);
  IF (OPTION>4) OR (OPTION<1) THEN EXIT(PROGRAM);
  WRITE('File is on which Volume (e.g. #4: )?  ');
  READLN(FILENAME);
  IF (OPTION=1) OR (OPTION=2)
    THEN BEGIN
           (*$I-*)
           RESET(F,CONCAT(FILENAME,'SYSTEM.COMPILER'));
           IF IORESULT<>0 THEN BEGIN WRITELN('Not found');EXIT(PROGRAM) END;
           IF BLOCKREAD(F,SEGDIC,1,0)<>1 THEN BEGIN
                                                WRITELN('IO-Error');
                                                EXIT(PROGRAM)
                                              END;
           (*$I+*)
           IF SEGDIC.SEGNAME[1]<>'FORTRAN:'
             THEN BEGIN
                    WRITELN('This is not the FORTRAN COMPILER!!');
                    EXIT(PROGRAM)
                  END;
           IF OPTION=1
             THEN BEGIN
                    SEGDIC.SEGINFO[1].VERSION := 5;
                    FOR J:= 7 TO 14 DO SEGDIC.SEGINFO[J].VERSION := 5;
                  END
             ELSE BEGIN
                    SEGDIC.SEGINFO[1].VERSION := 1;
                    FOR J:= 7 TO 14 DO SEGDIC.SEGINFO[J].VERSION :=1;
                  END;
             IF BLOCKWRITE(F,SEGDIC,1,0)<>1 THEN BEGIN
                                                   WRITELN('IO-Error');
                                                   EXIT(PROGRAM)
                                                 END
                                            ELSE WRITELN('Ready');
         END;
  IF (OPTION=3) OR (OPTION=4)
    THEN BEGIN
           (*$I-*)
           RESET(F,CONCAT(FILENAME,'SYSTEM.ATTACH'));
           IF IORESULT<>0 THEN BEGIN WRITELN('Not found');EXIT(PROGRAM) END;
           IF BLOCKREAD(F,SEGDIC,1,0)<>1 THEN BEGIN
                                                WRITELN('IO-Error');
                                                EXIT(PROGRAM)
                                              END;
           (*$I+*)
           IF SEGDIC.SEGNAME[1]<>'SYSATCH '
             THEN BEGIN
                    WRITELN('This is not SYSTEM.ATTACH!!');
                    EXIT(PROGRAM)
                  END;
           IF OPTION=3
             THEN BEGIN
                    SEGDIC.SEGINFO[0].VERSION := 5;
                    SEGDIC.SEGINFO[1].VERSION := 5;
                  END
             ELSE BEGIN
                    SEGDIC.SEGINFO[0].VERSION := 0;
                    SEGDIC.SEGINFO[1].VERSION := 2;
                  END;
             IF BLOCKWRITE(F,SEGDIC,1,0)<>1 THEN BEGIN
                                                   WRITELN('IO-Error');
                                                   EXIT(PROGRAM)
                                                 END
                                            ELSE WRITELN('Ready');
         END;
END.
(*=== [End, no more files] ===*)