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

Pascal/Delphi Source File | 2020-01-01 | 82KB | 2,639 lines

>>>> HELPER.TEXT
unit helper;
interface

   procedure help;

implementation

uses {$U kermglob.code} kermglob;

procedure keypress;

var ch: char;

  begin
    writeln('---------------Press any key to continue---------------');
    read( keyboard, ch );
    page(output); {SP}
  end; (* keypress *)

procedure help1;

  var ch: char;

  begin { help1 }
    if (noun = nullsym) then begin
      writeln('KERMIT is a family of  programs that do reliable file transfer');
      writeln('between computers over TTY lines.',
              '  KERMIT can also be used to make the ');
      writeln('microcomputer behave as a terminal',
              ' for a mainframe.  These are the ');
      writeln('commands for the UCSD p-system version, KERMIT-UCSD:');
      writeln
    end; (* if *)

    if (noun = nullsym) or (noun = consym) then begin
      writeln('  CONNECT     To make a "virutual terminal" connection to a remote');
      writeln(' ':14, 'system.');
      writeln;
      writeln(' ':14, 'To break the connection and "escape" back to the micro,');
      writeln(' ':14, 'type the escape sequence (CTRL-] C, that is Control ');
      writeln(' ':14, 'rightbracket followed immediately by the letter C.)');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = exitsym) then begin
      writeln('  EXIT        To return back to main command level of the p-system.');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = helpsym) then begin
      writeln('  HELP        To get a list of KERMIT commands.');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = quitsym) then begin
      writeln('  QUIT        Same as EXIT.');
      writeln;
    end; (* if *)

    if (noun = nullsym) or (noun = recsym) then begin
      writeln('  RECEIVE     To accept a file from the remote system.');
      writeln;
    end; (* if *)
  end; (* help1 *)

procedure help2;

var ch: char;

  begin { help2 }
    if (noun = nullsym) or (noun = sendsym) then begin
      writeln('  SEND        To send a file or group of files to the remote system.');
      writeln;
    end; (* if *)

    if (noun = nullsym) then
        keypress;
    if (noun = nullsym) or (noun = setsym) then begin
      writeln('  SET         To establish system-dependent parameters.  The ');
      writeln('              SET options are as follows: ');
      writeln;
      if (adj = nullsym) or (adj = debugsym) then begin
        writeln('              DEBUG            To set debug mode ON or OFF ');
        writeln(' ':31, '(default is OFF).');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = escsym) then begin
        writeln(' ':14, 'ESCAPE           To change the escape sequence that ');
        writeln(' ':31, 'lets you return to the PC Kermit from');
        writeln(' ':31, 'the remote host.  The default is CTRL-] c.');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = filewarnsym) then begin
        writeln(' ':14, 'FILE-WARNING     ON/OFF, default is OFF.  If ON, ');
        writeln(' ':31, 'Kermit will warn you and rename an ');
        writeln(' ':31, 'incoming file so as not to write over');
        writeln(' ':31, 'a file that currently exists with the');
        writeln(' ':31, 'same name');
        writeln;
      end; (* if *)
      if (adj = nullsym) or (adj = baudsym) then begin
        writeln(' ':14, 'BAUD             To set the serial baud rate.' );
        writeln(' ':31, 'Choices are: 110/300/1200/2400/4800/9600.' );
        writeln(' ':31, 'The default is 1200.');
        writeln
      end; (* if *)
      if (adj = nullsym) then
        keypress;
    end; (* if *)
  end; (* help2 *)

procedure help3;

  begin
    if (noun = nullsym) or (noun = setsym) then begin
      if (adj = nullsym) or (adj = ibmsym) then begin
        writeln(' ':14, 'IBM              ON/OFF, default is OFF.  This flag ');
        writeln(' ':31, 'should be ON only when transfering files');
        writeln(' ':31, 'between the micro and an IBM VM/CMS');
        writeln(' ':31, 'system.  It also causes the parity to');
        writeln(' ':31, 'be set appropriately (mark) and activates');
        writeln(' ':31, 'local echoing');
        writeln;
      end; (* if *)

      if (adj = nullsym) or (adj = localsym) then begin
        writeln(' ':14, 'LOCAL-ECHO       ON/OFF, default is OFF.  This sets the');
        writeln(' ':31, 'duplex.  It should be ON when using ');
        writeln(' ':31, 'the IBM and OFF for the DEC-20.');
        writeln;
      end; (* if *)

      if (adj = nullsym) or (adj = emulatesym) then begin
        writeln(' ':14, 'EMULATE          ON/OFF, default is OFF.  This sets the');
        writeln(' ':31, 'DataMedia 1520A terminal emulation on or off.');
        writeln;
      end; (* if *)
    end; (* if *)
  end; (* help3 *)

procedure help4;

  begin
    if (noun = setsym) or (noun = nullsym) then begin
      if (adj = nullsym) or (adj = paritysym) then begin
        writeln(' ':14, 'PARITY           EVEN, ODD, MARK, SPACE, or NONE.');
        writeln(' ':31, 'NONE is the default but if the IBM ');
        writeln(' ':31, 'flag is set, parity is set to MARK.  ');
        writeln(' ':31, 'This flag selects the parity for ');
        writeln(' ':31, 'outgoing and incoming characters during');
        writeln(' ':31, 'CONNECT and file transfer to match the');
        writeln(' ':31, 'requirements of the host.');
        writeln;
      end; (* if *)
    end; (* if *)
    if (noun = nullsym) or (noun = showsym) then begin
      writeln('  SHOW        To see the values of parameters that can be modified');
      writeln('              via the SET command.');
    end; (* if *)
  end; (* help4 *)

procedure help;
begin
  help1;
  help2;
  help3;
  help4
end; (* help *)

end. { unit helper }

>>>> KERMGLOB.TEXT
unit kermglob;

interface

   const blksize = 512;
         oport = 8;          (* output port # *)
         inport = 7;
         keyport = 2;
         bell = 7;           (* ASCII bell *)
         maxpack = 93;       (* maximum packet size minus 1 *)
         soh = 1;            (* start of header *)
         sp = 32;            (* ASCII space *)
         cr = 13;            (* ASCII CR *)
         lf = 10;            (* ASCII line feed *)
         xdle = 16;           (* ASCII DLE (space compression prefix for psystem) *)
         del = 127;          (* delete *)
         my_esc = 29;        (* default esc char for connect (^]) *)
         maxtry = 5;         (* number of times to retry sending packet *)
         my_quote = '#';     (* quote character I'll use *)
         my_pad = 0;         (* number of padding chars I need *)
         my_pchar = 0;       (* padding character I need *)
         my_eol = 13;        (* end of line character i need *)
         my_time = 5;        (* seconds after which I should be timed out *)
         maxtim = 20;        (* maximum timeout interval *)
         mintim = 2;         (* minimum time out interval *)
         at_eof = -1;        (* value to return if at eof *)
         rqsize = 5000;      (* input queue size *)
         qsize1 = 5001;      (* qsize + 1 *)
         eoln_sym = 13;      (* pascal eoln sym *)
         back_space = 8;     (* pascal backspace sym *)
         defaultbaud = 1200; (* default baud rate *)

   (* screen control information *)
     (* console line on which to put specified info *)
         title_line = 1;
         statusline = 2;
         packet_line = 3;
         retry_line = 4;
         file_line = 5;
         error_line = 6;
         debug_line = 7;
         prompt_line = 8;
     (* position on line to put info *)
         statuspos = 70;
         packet_pos = 19;
         retry_pos = 17;
         file_pos = 11;

   type packettype = packed array[0..maxpack] of char;
        parity_type = (evenpar, oddpar, markpar, spacepar, nopar);

        char_int_rec = record (* allows character to be treated as integer... *)
                              (* is system dependent *)
                         case boolean of
                             true: (i: integer);
                             false: (ch: char)
                       end; (* record *)

        int_bool_rec = record (* allows integer to be treated as boolean... *)
                              (* used for numeric and, or, xor...system dependent *)
                         case boolean of
                             true: (i: integer);
                             false: (b: boolean)
                       end; (* record *)

        string255 = string[255];


        statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
                      unrec, fn_expected, ch_expected, num_expected);
        vocab = (nullsym, allsym, baudsym, consym, debugsym, emulatesym,
                 escsym, evensym, exitsym, filewarnsym,helpsym, ibmsym,
                 localsym, marksym, nonesym, oddsym, offsym, onsym, paritysym,
                 quitsym, recsym, sendsym, setsym, showsym, spacesym);

        scrcommands = (sc_up, sc_right, sc_clreol, sc_clreos, sc_home,
                       sc_escape, sc_left, sc_clrall, scr_clrline);

    var noun, verb, adj: vocab;
        status: statustype;
        vocablist: array[vocab] of string255;
        xfilename, line: string255;
        newescchar: char;
        expected: set of vocab;
        newbaud: integer;

        currstate: char; (* current state *)
        f: file of char; (* file to be received *)
        oldf: file; (* file to be sent *)
        s: string255;
        xeol, quote, esc_char: char;
        fwarn, ibm, half_duplex, debug: boolean;
        i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
        recpkt, packet: packettype;
        padchar, ch: char;
        debf: text; (* file for debug output *)
        parity: parity_type;
        xon: char;
        filebuf: packed array[1..1024] of char;
        bufpos, bufend: integer;
        parity_array: packed array[char] of char;
        ctlset: set of char;
        rec_ok, send_ok: boolean;
        baud: integer;
        emulating: boolean;

implementation


end. { kermglob }

>>>> KERMIT.TEXT
program kermit;

(* $R-*) (* turn range checking off *)
(* $L+*)

USES {$u kermglob.code} kermglob,
     {$U kermutil.code} kermutil,
     (* {$U kermpack.code} kermpack, *)
     {$U parser.code}   parser,
     {$U helper.code}   helper,
     {$U sender.code}   sender,
     {$U receiver.code} receiver;

{
  Modifications by SP, 25 Oct 1983: adapt to IBM Version IV.1
  Delete keyboard and serial buffering: provided by system already.

  Additional mods by SP, 18 Mar 1984: make all strings 255 chars long

  13 May 84: Incorporate screen control through syscom record entries
             for portability
}


procedure showparms;
forward;


procedure connect;

(* connect to remote host and transceive *)

var ch: char;
    close: boolean;

  procedure read_esc;

  (* read character after esc char and interpret it *)

    begin
      repeat
      until read_ch(keyport,ch);       (* wait until they've typed something in *)
      if (ch in ['a'..'z']) then  (* uppercase it *)
          ch := chr(ord(ch) - ord('a') + ord('A'));
      if ch in ['B','C','S','?'] then
          case ch of
              'B': sendbrk;       (* B: send a break to the IBM *)
              'C': close := true; (* C: end connection *)
              'S': begin          (* S: show status *)
                      noun := allsym;
                      showparms
                   end; (* S *)
              '?': begin          (* ?: show options *)
                  writeln('B    Send a BREAK signal.');
                  writeln('C    Close Connection, return to KERMIT-UCSD command level.');
                  writeln('Q    Query Status of connection');
                  writeln('F    Send Control-F character to remote host.' );
                  writeln('S    Send Control-S character to remote host.' );
                  writeln('?    Print this list');
                  writeln('^',esc_char,'   send the escape character itself to the');
                  writeln('     remote host.')
                end; (* ? *)
            end (* case *)
      else if ch = esc_char then  (* ESC-char: send it out *)
        begin
          if half_duplex then
            begin
              write(ch); { changed from echo() by SP }
              write_ch(oport,ch)
            end (* if *)
        end (* else if *)
      else                        (* anything else: ignore *)
          write(chr(bell))
    end; (* read_esc *)

  begin (* connect *)
    clear_buf(keyport);                    (* empty keyboard buffer *)
    clear_buf(inport);                    (* empty remote input buffer *)
    writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
    close := false;
    repeat
        if read_ch(inport,ch) then        (* if char from host then *)
            echo(ch);                   (* echo it *)

        if read_ch(keyport,ch) then        (* if char from keyboard then *)
            if ch <> esc_char then      (* if not ESC-char then *)
              begin
                if half_duplex then       (* echo it if half-duplex *)
                    write(ch); { changed from echo() by sp }
                write_ch(oport,ch)     (* send it out the port *)
              end (* if *)
            else (* ch = esc_char *)    (* else is ESC-char so *)
              read_esc;                   (* interpret next char *)
    until close;                      (* if still connected, get more *)
    writeln('Disconnected')
  end; (* connect *)


procedure fill_parity_array;

(* parity value table for even parity...not(entry) = odd parity *)

const min = 0;
      max = 126;

var i, shifter, counter: integer;
    minch, maxch, ch: char;
    r: char_int_rec;

begin
   minch := chr(min);
   maxch := chr(max);
   case parity of
      evenpar: for ch := minch to maxch do begin
                  r.ch := ch;               (* put char into variant record *)
                  shifter := aand(r.i,255); (* mask off parity bit *)
                  counter := 0;
                  for i := 1 to 7 do begin       (* count the 1's *)
                     if odd(shifter) then
                        counter := counter + 1;
                     shifter := shifter div 2
                  end; (* for i *)
                  if odd(counter) then       (* stick a 1 on if necessary *)
                     parity_array[ch] := chr(aor(ord(ch),128))
                  else
                     parity_array[ch] := chr(aand(ord(ch),127))
               end; (* for ch *) (* case even *)
      oddpar:  for ch := minch to maxch do begin
                  r.ch := ch;                (* put char into variant record *)
                  shifter := aand(r.i,255);  (* mask off parity bit *)
                  counter := 0;
                  for i := 1 to 7 do begin        (* count the 1's *)
                     if odd(shifter) then
                         counter := counter + 1;
                     shifter := shifter div 2
                  end; (* for i *)
                  if odd(counter) then        (* stick a 1 on if necessary *)
                     parity_array[ch] := chr(aand(ord(ch),127))
                  else
                     parity_array[ch] := chr(aor(ord(ch),128))
               end; (* for ch *) (* case odd *)
      markpar:
          for ch := minch to maxch do     (* stick a 1 on all chars *)
              parity_array[ch] := chr(aor(ord(ch),128));
      spacepar:
          for ch := minch to maxch do     (* mask off parity on all chars *)
              parity_array[ch] := chr(aand(ord(ch),127));
      nopar:
          for ch := minch to maxch do     (* don't mess with parity bit at all *)
              parity_array[ch] := ch;
    end; (* case *)
  end; (* fill_parity_array *)


{$I setshow.text}


procedure initialize;

var ch: char;

  begin
    pad := mypad;
    padchar := chr(mypchar);
    xeol := chr(my_eol);
    esc_char := chr(my_esc);
    quote := my_quote;
    ctlset := [chr(1)..chr(31),chr(del),quote];
    half_duplex := false;
    debug := false;
    emulating := false;
    fwarn := false;
    spsiz := max_pack;
    rpsiz := max_pack;
    n := 0;
    parity := nopar;
    initvocab;
    fill_parity_array;
    ibm := false;
    xon := chr(17);
    bufpos := 1;
    bufend := 0;

    baud := defaultbaud;
    setup_comm
  end; (* initialize *)


procedure closeup;

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


  begin (* main kermit program *)
    initialize;
    repeat
        write('Kermit-UCSD> ');
        readstr(keyport,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');
            ch_expected: writeln('Single character expected');
            null: case verb of
                      consym: connect;
                      helpsym: help;
                      recsym: begin
                          recsw(rec_ok);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if rec_ok then
                              writeln('successful receive')
                          else
                              writeln('unsuccessful receive');
                          (*$I-*) (* set i/o checking off *)
                          close(oldf);        { why??? }
                          if not rec_ok then
                             close(f);  { added by SP }
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* recsym *)
                      sendsym: begin
                          uppercase(xfilename);
                          sendsw(send_ok);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if send_ok then
                              writeln('successful send')
                          else
                              writeln('unsuccessful send');
                          (*$I-*) (* set i/o checking off *)
                          close(oldf);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* sendsym *)
                      setsym: set_parms;
                      show_sym: show_parms;
                  end; (* case verb *)
        end; (* case parse *)
     until (verb = exitsym) or (verb = quitsym);
     closeup
   end. (* kermit *)
>>>> KERMPACK.TEXT
unit kermpack;

interface

   uses {$U kermglob.code} kermglob;


   procedure spar(var packet: packettype);

   procedure rpar(var packet: packettype);

   procedure spack(ptype: char; num:integer; len: integer; data: packettype);

   function rpack(var len, num: integer; var data: packettype): char;

   procedure bufemp(buffer: packettype; var f: text; len: integer);

   function bufill(var buffer: packettype): integer;


implementation

uses {$U kermutil.code} kermutil;


procedure bufemp(*buffer: packettype; var f: text; len: integer*);

(* empties a packet into a file *)
{ Note: this strips out ALL linefeed characters! }

var i,ls: integer;
    r: char_int_rec;
    s: string255;

begin
   s := copy('',0,0);
   ls := 0;
   i := 0;
   while i < len do begin
      r.ch := buffer[i];          (* get a character *)
      if (r.ch = myquote) then begin   (* if character is control quote *)
         i := i + 1;               (* skip over quote and *)
         r.ch := buffer[i];        (* get quoted character *)
         if (aand(r.i,127) <> ord(myquote)) then
            r.ch := ctl(r.ch);    (* controllify it *)
      end; (* if *)
      if (r.i = lf) then { skip linefeeds SP }
         i := i + 1
      else if (r.i = cr) then begin     (* else if a carriage return then *)
         i := i + 1;
         {  i := i + 3;  }         (* skip over that and line feed *)
         (*$I-*)                   (* turn i/o checking off *)
         writeln(f,s);             (* and write out line to file *)
         s := copy('',0,0);        (* empty the string var *)
         ls := 0;
         if (io_result <> 0) then begin (* if io_error *)
            io_error(ioresult);     (* tell them and *)
            currstate := 'a';           (* abort *)
         end (* if *)
      end
      (*$I+*)                      (* turn i/o checking back on *)
      else begin                   (* else, is a regular char, so *)
         r.i := aand(r.i,127);     (* mask off parity bit *)
         s := concat(s,' ');       (* and add character to out string *)
         ls := ls + 1;
         s[ls] := r.ch;
         i := i + 1                (* increase buffer pointer *)
      end; (* else *)
   end; (* while *)              (* and get another char *)
   (*$I-*)                     (* turn i/o checking off *)
   write(f,s);                 (* and write out line to file *)
   if (io_result <> 0) then begin   (* if io_error *)
      io_error(ioresult);       (* tell them and *)
      currstate := 'a';             (* abort *)
   end (* if *)
   (*$I+*)                      (* turn i/o checking back on *)
end; (* bufemp *)


function bufill(*var buffer: packettype): integer*);

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

var i, j, k, t7, count: integer;
    r: char_int_rec;

  begin
    i := 0;
    (* while file has some data & packet has some room we'll keep going *)
    while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-12) do
      begin
        (* if we need more data from disk then *)
        if (bufpos > bufend) and (not eof(oldf)) then
          begin
            (* read a couple of blocks *)
            bufend := blockread(oldf,filebuf[1],2) * blksize;
            (* and adjust buffer pointer *)
            bufpos := 1
          end; (* if *)
        if (bufpos <= bufend) then     (* if we're within buffer bounds *)
          begin
            r.ch := filebuf[bufpos];      (* get a character *)
            bufpos := bufpos + 1;         (* increase buffer pointer *)
            if (r.i = xdle) then           (* if it's space compression char, *)
              begin
                count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
                bufpos := bufpos + 1;       (* read past # *)
                r.ch := ' ';                (* and make current char a space *)
              end (* else if *)
            else                           (* otherwise, it's just a char *)
                count := 1;                (* so only 1 copy of it *)
            if (r.ch in ctlset) then     (* if a control char *)
              begin
                if (r.i = cr) then         (* if a carriage return *)
                  begin
                    buffer[i] := quote;      (* put (quoted) CR in buffer *)
                    i := i + 1;
                    buffer[i] := ctl(chr(cr));
                    i := i + 1;
                    r.i := lf;                (* and we'll stick a LF after *)
                  end; (* if *)
                if r.i <> 0 then           (* if not a NUL then *)
                  begin
                    buffer[i] := quote;      (* put the quote in buffer *)
                    i := i + 1;
                    if r.ch <> quote then
                        r.ch := ctl(r.ch);   (* and un-controllify char *)
                  end (* if *)
              end; (* if *)
          end; (* if *)
        j := 1;
        while (j <= count) and (i <= spsiz - 8) do
          begin                           (* put all the chars in buffer *)
            if (r.i <> 0) then            (* so long as not a NUL *)
              begin
                buffer[i] := r.ch;
                i := i + 1;
              end (* if *)
            else                          (* if is a NUL so *)
                if (bufpos > blksize) then  (* skip to end of block *)
                    bufpos := bufend + 1    (* since rest will be NULs *)
                else
                    bufpos := blksize + 1;
            j := j + 1
          end; (* while *)
      end; (* while *)
    if (i = 0) then                         (* if we're at end of file, *)
        bufill := (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 := i                           (* return # of chars in packet *)
      end; (* else *)
  end; (* bufill *)


procedure spar(*var packet: packettype*);

(* fills data array with my send-init parameters *)

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

procedure rpar(*var packet: packettype*);

(* gets their init params *)

  begin
    spsiz := ord(unchar(packet[0]));     (* max send packet size *)
    timint := ord(unchar(packet[1]));    (* when i should time out *)
    pad := ord(unchar(packet[2]));       (* number of pads to send *)
    padchar := ctl(packet[3]);           (* padding char to send *)
    xeol := unchar(packet[4]);            (* eol char i must send *)
    quote := packet[5];                  (* incoming data quote char *)
  end; (* rpar *)

procedure packetwrite(p: packettype; len: integer);

(* writes out all of a packet for debugging purposes *)

var i: integer;

  begin
    gotoxy(0,debugline);
    for i := 0 to len+3 do
        write(p[i])
  end; (* packetwrite *)

procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);

(* send a packet *)

const maxtry = 10000;

var bufp, i, count: integer;
    chksum: char;
    buffer: packettype;
    ch: char;

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

    bufp := 0;
    for i := 1 to pad do
        write_ch(oport,padchar);          (* write out any padding chars *)
    buffer[bufp] := chr(soh);                (* packet sync character *)
    bufp := bufp + 1;
    chksum := tochar(chr(len + 3));          (* init chksum *)
    buffer[bufp] := tochar(chr(len + 3));    (* character count *)
    bufp := bufp + 1;
    chksum := chr(ord(chksum) + ord(tochar(chr(num))));
    buffer[bufp] := tochar(chr(num));
    bufp := bufp + 1;
    chksum := chr(ord(chksum) + ord(ptype));
    buffer[bufp] := ptype;                   (* packet type *)
    bufp := bufp + 1;

    for i := 0 to len - 1 do                 (* loop through data chars *)
      begin
        buffer[bufp] := data[i];             (* store char *)
        bufp := bufp + 1;
        chksum := chr(ord(chksum) + ord(data[i]))
      end; (* for i *)
                                             (* compute final chksum *)
    chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
    buffer[bufp] := tochar(chksum);
    bufp := bufp + 1;
    buffer[bufp] := xeol;

    if (parity <> nopar) then
        for i := 0 to bufp do                 (* set correct parity on buffer *)
            buffer[i] := parity_array[buffer[i]];

    {unitwrite(oport,buffer[0],bufp+1,,12);}       (* send the packet out *)

    for i := 0 to bufp do
       write_ch(oport, buffer[i]);

    if debug then
        packetwrite(buffer,len);
  end; (* spack *)

(*$G+*) (* turn on goto option...need it for next routine *)

function rpack(*var len, num: integer; var data: packettype): char*);

(* read a packet *)

label 1; (* used to emulate C's CONTINUE statement *)

const maxtry = 10000;

var count, i, ichksum: integer;
    chksum, ptype: char;
    r: char_int_rec;

  begin
    count := 0;

    if not getsoh and (currstate<>'r') then (*if don't get synch char then *)
      begin
        rpack := 'N';                        (* treat as a NAK *)
        num := n mod 64;
        exit(rpack)                          (* and get out of here *)
      end;

  1: count := count + 1;
     if (count>maxtry)and(currstate<>'r') then (* if we've tried too many times *)
        begin                               (* and aren't waiting for init *)
          rpack := 'N';                      (* treat as NAK *)
          exit(rpack)                        (* and get out of here *)
        end; (* if *)

    if not getch(r) then                (* get a char and *)
            goto 1;                        (* resynch if soh *)

    ichksum := r.i;                        (* start checksum *)
    len := ord(unchar(r.ch)) - 3;          (* character count *)

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + r.i;
    num := ord(unchar(r.ch));              (* packet number *)

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + r.i;
    ptype := r.ch;                         (* packet type *)

    for i := 0 to len-1 do                 (* get any data *)
      begin
        if not getch(r) then            (* get a char and *)
            goto 1;                        (* resynch if soh *)
        ichksum := ichksum + r.i;
        data[i] := r.ch;
      end; (* for i *)
    data[len] := chr(0);                   (* mark end of data *)

    if not getch(r) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)

                                           (* compute final checksum *)
    chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));

    if (chksum <> unchar(r.ch)) then       (* if checksum bad *)
        rpack := chr(0)                      (* return 'false' indicator *)
    else                                   (* else *)
        rpack := ptype;                      (* return packet type *)

    if debug then
      begin
        gotoxy(0,debugline);
        write(len,num,ptype);
        for i := 1 to 1000 do
            ;
      end; (* if *)
  end; (* rpack *)

(*$G-*) (* turn off goto option...don't need it anymore *)


end. { kermpack }


>>>> KERMUTIL.TEXT
unit kermutil;

{ Change log:

        13 May 84: Use KERNEL's syscom record for screen control -sp-
}

interface

   uses {$U kermglob.code} kermglob;


   function read_ch(unitno: integer; var ch: char): boolean;

   procedure read_str(unitno:integer; var s: string255);

   procedure echo(ch: char);

   procedure clear_buf(unitno:integer);

   function aand(x,y: integer): integer;

   function aor(x,y: integer): integer;

   function xor(x,y: integer): integer;

   procedure uppercase(var s: string255);

   procedure error(p: packettype; len: integer);

   procedure io_error(i: integer);

   procedure debugwrite(s: string255);

   procedure debugint(s: string255; i: integer);

   function min(x,y: integer): integer;

   function tochar(ch: char): char;

   function unchar(ch: char): char;

   function ctl(ch: char): char;

   function getch(var r: char_int_rec): boolean;

   function getsoh: boolean;

   function getfil(filename: string255): boolean;

   procedure send_brk;

   procedure setup_comm;

   procedure write_ch(unitno: integer; ch: char );

   procedure screen( scrcmd: scrcommands );

   procedure writescreen(s: string255);

   procedure refresh_screen(numtry, num: integer);


implementation

uses {$U remunit.code} remunit,  {SP, 1/14/84}
     {$U kernel.code} kernel;


procedure uppercase(*var s: string255*);

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 *)


{ screen -- perform screen operations }
procedure screen{( scrcmd: scrcommands )};
begin
   { for portability, peek in at syscom vector to get control chars }
   with syscom^ do begin
      if crtctrl.prefixed[ord(scrcmd)] then
         write( crtinfo.prefix );

      with crtctrl do
         case scrcmd of
            sc_up:       write( rlf );
            sc_right:    write( ndfs );
            sc_clreol:   write( eraseeol );
            sc_clreos:   write( eraseeos );
            sc_home:     write( home );
            sc_escape:   write( escape );
            sc_left:     write( backspace );
            sc_clrall:   write( clearscreen );
            scr_clrline: write( clearline )
         end
   end
end; { screen }


function read_ch(*unitno:integer; var ch: char): boolean*);

(* read a character from an input queue *)
var
   ready: boolean;

  begin
    if unitno=keyport then
       ready := cr_kbstat
    else if unitno=inport then
       ready := cr_remstat
    else
       ready := false;
    if ready then            (* if a char there *)
       if unitno=keyport then begin
          ch := ' ';
          unitread( keyport, ch, 1,, 12 )
       end
       else
          ch := cr_getrem;
    read_ch := ready
  end; (* read_ch *)

procedure write_ch(*unitno: integer; ch: char*);
begin
   if unitno=oport then
      cr_putrem( ch )
end;


procedure read_str(*unitno:integer; var s: string255*);

(* acts like readln(s) but takes input from input queue *)

var i: integer;

  begin
    i := 0;
    s := copy('',0,0);
    repeat
      repeat                              (* get a character *)
      until read_ch(unitno,ch);
      if (ord(ch) = backspace) then       (* if it's a backspace then *)
        begin
          if (i > 0) then                   (* if not at beginning of line *)
            begin
              write(ch);                      (* go back a space on screen *)
              write(' ');                     (* erase char on screen *)
              write(ch);                      (* go back a space again *)
              i := i - 1;                     (* adjust string counter *)
              s := copy(s,1,i)                (* adjust string *)
            end (* if *)
        end (* if *)
      else if (ord(ch) <> eoln_sym) then  (* otherwise if not at eoln  then *)
        begin
          write(ch);                        (* echo char on screen *)
          i := i + 1;                       (* inc string counter *)
          s := concat(s,' ');
          s[i] := ch;                       (* put char in string *)
        end; (* if *)
    until (ord(ch) = eoln_sym);           (* if not eoln, get another char *)
    s := copy(s,1,i);                     (* correct string length *)
    writeln                               (* write a line on the screen *)
  end; (* read_str *)


procedure clear_buf(*unitno:integer*);
{ modified by SP }
begin
   if unitno=keyport then
      unitclear( unitno )
end;


procedure send_brk;
begin
   cr_break
end;


procedure setup_comm;
{ SP, 14 Jan 84 }
var
   result: cr_baud_result;
begin
   cr_setcommunications(false,
                        false,
                        baud,
                        8,
                        1,
                        cr_orig,
                        'IBM PC',
                        result );
end;


function aand(*x,y: integer): integer*);

(* arithmetic and--takes 2 integers and ands them, yeilding an integer *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put the two numbers in variant record *)
    yrec.i := y;
    temp.b := xrec.b and yrec.b;  (* use as booleans to 'and' them *)
    aand := temp.i                (* return integer result *)
  end; (* aand *)


function aor(*x,y: integer): integer*);

(* arithmetic or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
    temp.b := xrec.b or yrec.b;   (* use as booleans to 'or' them *)
    aor := temp.i                 (* return integer result *)
  end; (* aor *)

function xor(*x,y: integer): integer*);

(* exclusive or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
                                  (* use as booleans to 'xor' them *)
    temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.b));
    xor := temp.i                 (* return integer result *)
  end; (* xor *)

procedure error(*p: packettype; len: integer*);

(* writes error message sent by remote host *)

var i: integer;

  begin
    gotoxy(0,errorline);
    for i := 0 to len-1 do
        write(p[i]);
    gotoxy(0,promptline);
  end; (* error *)

procedure io_error(*i: integer*);

  begin
    gotoxy( 0, errorline );
    screen( sc_clreol );
    case i of
        0: writeln('No error');
        1: writeln('Bad Block, Parity error (CRC)');
        2: writeln('Bad Unit Number');
        3: writeln('Bad Mode, Illegal operation');
        4: writeln('Undefined hardware error');
        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')
      end; (* case *)
    gotoxy(0,promptline)
  end; (* io_error *)

procedure debugwrite(*s: string255*);

(* writes a debugging message *)
var i: integer;

  begin
    if debug then
      begin
        gotoxy(0,debugline);
        screen( sc_clreol );
        write(s);
        for i := 1 to 2000 do ;                (* write debugging message *)
      end (* if debug *)
  end; (* debugwrite *)

procedure debugint(*s: string255; i: integer*);

(* write a debugging message and an integer *)

  begin
    if debug then
      begin
        debugwrite(s);
        write(i)
      end (* if debug *)
  end; (* debugint *)

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 *)

function ctl(*ch: char): char*);

(* ctl toggles control bit: ^A becomes A, A becomes ^A *)

  begin
    ctl := chr(xor(ord(ch),64))
  end; (* ctl *)

procedure echo(*ch: char*);

(* echos a character on the screen *)
const
   maxtry = 30000;

var count, cursorx, cursory:integer;
{ The DataMedia emulation is by John Socha. }
begin
   ch := chr(aand(ord(ch),127)); (* mask off parity bit *)

   if emulating and (ord(ch) in [30,25,28,31,29,11]) then
      case ord(ch) of
         { Datamedia 1520 emulation }
         { rs }30: begin
                      { allow timeout while waiting for coordinates
                        so computer doesn't freeze }
                      count := 0;
                      repeat
                         count := count + 1
                      until read_ch( inport, ch ) or (count>maxtry);
                      if count<=maxtry then begin
                         cursorx:=ord(ch)-32;
                         count := 0;
                         repeat
                            count := count + 1
                         until read_ch( inport, ch ) or (count>maxtry);
                         if count<=maxtry then begin
                            cursory:=ord(ch)-32;
                            gotoxy(cursorx,cursory)
                         end
                      end
                   end;
         { em }25: screen( sc_home );
         { fs }28: screen( sc_right );
         { us }31: screen( sc_up );
         { gs }29: screen( sc_clreol );
         { vt }11: screen( sc_clreos )
      end
    else
       unitwrite(1,ch,1,,12)  { the 12 eliminates DLE & CR expansion }
  end; (* echo *)


function getch(*var r: char_int_rec): boolean*);

(* gets a character, strips parity, returns true if it got a char which *)
(* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *)

const maxtry = 10000;

var count: integer;

  begin
    count := 0;
    getch := false;
    repeat
        count := count + 1;
    until (read_ch(inport,r.ch)) or (count>maxtry);  (* wait for a character *)
    if (count > maxtry) then                    (* if wait too long then *)
        exit(getch);                              (* get out of here *)
    r.i := aand(r.i,127);                       (* strip parity from char *)
    getch := (r.ch <> chr(soh));                (* return true if not SOH *)
  end; (* getch *)


function getsoh(*: boolean*);

(* reads characters until it finds an SOH; returns false if has to read more *)
(* than maxtry chars *)
{ modified by SP }

const maxtry = 10000;

var ch: char;
    count: integer;

  begin
    count := 0;
    getsoh := true;
    repeat
      repeat
        count := count + 1
      until (read_ch(inport,ch)) or (count > maxtry); (* wait for a character *)
      if (count > maxtry) then
        begin
            getsoh := false;
            exit(getsoh)
          end; (* if *)
        ch := chr(aand(ord(ch),127));            (* strip parity of char *)
    until (ch = chr(SOH))                        (* if not SOH, get more *)
  end; (* getsoh *)


function getfil(*filename: string255): boolean*);

(* opens a file for writing *)

  begin
    (*$I-*) (* turn i/o checking off *)
    rewrite(f,filename);
    (*$I-*) (* turn i/o checking on *)
    getfil := (ioresult = 0)
  end; (* getfil *)


procedure writescreen(*s: string255*);

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

begin
   page(output);
   gotoxy(0,titleline);
   write('            Kermit UCSD p-system, Version ', version );
   gotoxy(statuspos,statusline);
   write(s);
   gotoxy(0,packetline);
   write('Number of Packets: ');
   gotoxy(0,retryline);
   write('Number of Tries: ');
   gotoxy(0,fileline);
   write('File Name: ');
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 *)


begin { body of unit kermutil }
   { initialization code }
   syscom^.crtinfo.flush := chr(255);  { effectively turning flush off }
   syscom^.crtinfo.stop := chr(254);   { effectively turning stop off }

   ***;  { <-- would you believe that this is Pascal? }

   { termination code }
   syscom^.crtinfo.flush := chr(6);  { turn flush back on }
   syscom^.crtinfo.stop := chr(19)   { effectively turning stop off }

end. { kermutil }

>>>> PARSER.TEXT
(*$S+*)
unit parser;

INTERFACE

uses {$U kermglob.code} kermglob;


   function parse: statustype;

   procedure initvocab;


IMPLEMENTATION

uses
   {$U kermutil.code} kermutil;


procedure eatspaces(var s: string255);

var done: boolean;
    i: integer;

  begin
    done := (length(s) = 0);
    while not done do
      begin
        if s[1] = ' ' then
          begin
            i := length(s) - 1;
            s := copy(s,2,i);
            done := length(s) = 0
          end (* if *)
        else
            done := true
      end (* while *)
  end; (* eatspaces *)

procedure isolate_word(var line, s: string255);

var i: integer;
    done: boolean;

  begin
    done := false;
    i := 1;
    s := copy(' ',0,0);
    while (i <= length(line)) and not done do
      begin
        if line[i] = ' ' then
            done := true
        else
            s := concat(s,copy(line,i,1));
        i := i + 1;
      end; (* while *)
    line := copy(line,i,length(line)-i+1);
  end; (* isolate_word *)

function get_fn(var line, fn: string255): boolean;

var i, l: integer;

  begin
    get_fn := true;
    isolate_word(line, fn);
    l := length(fn);
(* Watch out, the set below had an ASCII null (0) in quotes as its 5th *)
(* member, between '_' and '/'.  The null character has been deleted to *)
(* allow tape and network distribution of this program. *)
    if (l > 15) or (l < 1) then
        get_fn := false
    else
        for i := 1 to l do
            if not (fn[i] in ['0'..'9','A'..'Z', '-', '_', '', '/', '.']) then
                get_fn := false
  end; (* get_fn *)

function get_num( var line: string255; var n: integer ): boolean;

var
   numstr: string255;
   i, l: integer;
begin
   get_num := true;
   isolate_word( line, numstr );
   l := length(numstr);
   if (l>5) or (l<1) then begin
      n := 0;
      get_num := false
   end
   else begin
      n := 0; 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
   end
end; { get_num }

function nextch(var ch: char): boolean;

var s: string255;

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

function parse(*: statustype*);

type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off,
               get_char, get_show_parm, get_help_show, get_help_parm,
               exitstate, get_baud);

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

function get_sym(var word: vocab): statustype;

var i: vocab;
    s: string255;
    stat: statustype;
    done: boolean;
    matches: integer;

  begin
    eat_spaces(line);
    if length(line) = 0 then
        getsym := ateol
    else
      begin
        stat := null;
        done := false;
        isolate_word(line,s);
        i := allsym;
        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 = spacesym) 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 *)

  begin
    state := start;
    parse := null;
    noun := nullsym;
    verb := nullsym;
    adj := nullsym;
    uppercase(line);
    repeat
        case state of
          start:
              begin
                expected := [consym, exitsym, helpsym, quitsym, recsym, sendsym,
                             setsym, showsym];
                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: state := fin;
                      exitsym, quitsym: state := fin;
                      helpsym: state := get_help_parm;
                      recsym: state := fin;
                      sendsym: state := getfilename;
                      setsym: state := get_set_parm;
                      showsym: state := get_show_parm;
                    end (* case *)
              end; (* case start *)
          fin:
              begin
                expected := [];
                status := getsym(verb);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end (* if status *)
                else
                    status := unconfirmed
              end; (* case fin *)
          getfilename:
            begin
              expected := [];
              if getfn(line,xfilename) then
                begin
                  status := null;
                  state := fin
                end (* if *)
              else
                  status := fnexpected
            end; (* case get file name *)
          get_set_parm:
              begin
                expected := [paritysym, localsym, ibmsym, emulatesym, escsym,
                             debugsym, filewarnsym, baudsym];
                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;
                      localsym: state := get_on_off;
                      ibmsym: state := get_on_off;
                      emulatesym: state := get_on_off;
                      escsym: state := getchar;
                      debugsym: state := get_on_off;
                      filewarnsym: state := get_on_off;
                      baudsym: state := get_baud
                    end (* case *)
            end; (* case get_set_parm *)
          get_parity:
              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 get_parity  *)
          get_baud:
             begin
               expected := [];
               if get_num( line, newbaud ) then begin
                  status := null; state := fin
               end
               else begin
                  newbaud := 0;
                  status := parm_expected
               end
             end; (* case get_baud *)
          get_on_off:
              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; (* get_on_off *)
          get_char:
              if nextch(newescchar) then
                 state := fin
              else
                 status := ch_expected;
          get_show_parm:
              begin
                expected := [allsym, paritysym, localsym, ibmsym, escsym,
                             debugsym, filewarnsym, baudsym];
                status := getsym(noun);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <>  ambiguous) then
                    state := fin
              end; (* case get_show_parm *)
          get_help_show:
              begin
                expected := [paritysym, localsym, ibmsym, escsym,
                           debugsym, filewarnsym, baudsym, emulatesym];
                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 get_help_show *)
          get_help_parm:
              begin
                expected := [consym, exitsym, helpsym, quitsym, recsym,
                             sendsym, setsym, showsym];
                status := getsym(noun);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end;
                if (status <> unrec) and (status <>  ambiguous) then
                    case noun of
                      consym: state := fin;
                      sendsym: state := fin;
                      recsym: state := fin;
                      setsym: state := get_help_show;
                      showsym: state := fin;
                      helpsym: state := fin;
                      exitsym, quitsym: state := fin;
                    end (* case *)
              end; (* case get_help_show *)
        end (* case *)
    until (status <> null);
    parse := status
  end; (* parse *)

procedure initvocab;

var i: integer;

  begin
    vocablist[allsym] := 'ALL';
    vocablist[baudsym] := 'BAUD';
    vocablist[consym] := 'CONNECT';
    vocablist[debugsym] := 'DEBUG';
    vocablist[emulatesym] := 'EMULATE';
    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[nonesym] := 'NONE';
    vocablist[oddsym] := 'ODD';
    vocablist[offsym] := 'OFF';
    vocablist[onsym] := 'ON';
    vocablist[paritysym] := 'PARITY';
    vocablist[quitsym] := 'QUIT';
    vocablist[recsym] := 'RECEIVE';
    vocablist[sendsym] := 'SEND';
    vocablist[setsym] := 'SET';
    vocablist[showsym] := 'SHOW';
    vocablist[spacesym] := 'SPACE';
  end; (* initvocab *)

  end. (* end of unit *)
>>>> RECEIVER.TEXT
unit receiver;

interface

   procedure recsw(var rec_ok: boolean);


implementation

uses
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack;


procedure recsw{(var rec_ok: boolean)};

function rdata: char;

(* send file data *)

var num, len: integer;
    ch: char;
    i: integer;

  begin

    repeat
        if numtry > maxtry then
          begin
            currstate := 'a';
            exit(rdata)
          end;

        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)

        refresh_screen(numtry,n);

        if (ch = 'D') then             (* got data packet *)
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                n := n - 1;

                if (num = (n mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,6,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    currstate := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                bufemp(recpkt,f,len);  (* write data to file *)
                spack('Y',(n mod 64),0,packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data send state *)
              end (* else *)
          end (* if 'D' *)
        else if (ch = 'F') then        (* file header *)
          begin
            if (oldtry > maxtry) then
              begin
                rdata := 'a';          (* too many tries, abort *)
                exit(rdata)
              end; (* if *)

            n := n - 1;

            if (num = (n mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                spack('Y',num,0,packet);
                numtry := 0;           (* reset try counter *)
                currstate := currstate;        (* stay in same state *)
              end (* if *)
            else
                currstate := 'a'           (* not previous packet, abort *)
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                rdata := 'a';
                exit(rdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            close(f,lock);             (* close up the file *)
            n :=  n + 1;               (* bump packet counter *)
            currstate := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            currstate := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then    (* some other packet type, *)
            currstate := 'a'               (* abort *)
    until (currstate <> 'd');
    rdata := currstate
  end; (* rdata *)

function rfile: char;

(* receive file header *)

var num, len: integer;
    ch: char;
    oldfn: string255;
    i: integer;

procedure makename(recpkt: packettype; var fn: string255; l: integer);

function exist(fn: string255): boolean;

(* returns true if file named fn exists *)

var f: file;
    isthere: boolean;
  begin
    (*$I-*) (* turn off i/o checking *)
    reset(f,fn);
    isthere := (ioresult = 0);
    if isthere then    { added by SP }
       close( f );
    (*$I+*)
    exist := isthere
  end; (* exist *)

procedure checkname(var fn: string255);

(* if file fn exists, makes a new name which doesn't *)
(* does this by changing letters in file name until it *)
(* finds some combination which doesn't exitst *)

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; (* while *)
        i := i + 1
      end; (* while *)
    end; (* checkname *)

  begin (* makename *)
    fn := copy('               ',1,15);    (* stretch length *)
    moveleft(recpkt[0],fn[1],l);           (* get filename from packet *)
    oldfn := copy(fn, 1,l);                (* save fn sent to show user *)
    fn := copy(fn,1,min(15,l));            (* set length of filename *)
                                           (* and make sure <= 15 *)
    uppercase(fn);
    if pos('.TEXT',fn) <> length(fn)-4 then
      begin
        if length(fn) > 10 then
            fn := copy(fn,1,10);           (* can only be 15 long in all *)
        fn := concat(fn,'.TEXT');          (* and we'll add .TEXT *)
      end; (* if *)
    if fwarn then                          (* if file warning is on *)
        checkname(fn);                       (* must check that name unique *)
  end; (* makename *)

  begin (* rfile *)
    if debug then
        debugwrite('rfile');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        rfile := 'a';
        exit(rfile)
      end;
    numtry := numtry + 1;

    ch := rpack(len,num,recpkt);      (* receive a packet *)

    refresh_screen(numtry,n);

    if ch = 'S' then                  (* send init, maybe our ACK lost *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        n := n - 1;

        if num = (n mod 64) then      (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spar(packet);             (* with our send init params *)
            spack('Y',num,6,packet);
            numtry := 0;              (* reset try counter *)
            rfile := currstate;           (* stay in same state *)
          end (* if *)
        else                          (* not previous packet, abort *)
          currstate := 'a'
      end (* if 'S' *)
    else if (ch = 'Z') then           (* end of file *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        n := n - 1;

        if num = (n mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spack('Y',num,0,packet);
            numtry := 0;
            rfile := currstate            (* stay in same state *)
          end (* if *)
        else
            rfile := 'a'              (* no, abort *)
      end (* else if *)
    else if (ch = 'F') then           (* file header *)
      begin                           (* which is what we really want *)
        if (num <> (n mod 64)) then   (* if wrong packet, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end;

        makename(recpkt,xfilename,len); (* get filename, make unique if filew *)
        gotoxy(filepos,fileline);
        write(oldfn,' ==> ',xfilename);

        if not getfil(xfilename) then  (* try to open new file *)
          begin
            ioerror(ioresult);        (* if unsuccessful, tell them *)
            rfile := 'a';             (* and abort *)
            exit(rfile)
          end; (* if *)

        spack('Y',n mod 64,0,packet); (* ACK file header *)
        oldtry := numtry;             (* reset try counters *)
        numtry := 0;
        n := n + 1;                   (* bump packet number *)
        rfile := 'd';                 (* switch to data state *)
      end (* else if *)
    else if ch = 'B' then             (* break transmission *)
      begin
        if (num <> (n mod 64)) then            (* wrong packet, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end;
        spack('Y',n mod 64,0,packet); (* say ok *)
        rfile := 'c'                  (* go to complete state *)
      end (* else if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        rfile := 'a'
      end
    else if (ch = chr(0)) then        (* returned false *)
        rfile := currstate                (* so stay in same state *)
    else                              (* some weird state, so abort *)
        rfile := 'a'
  end; (* rfile *)

function rinit: char;

(* receive initialization *)

var num, len: integer;  (* packet number and length *)
    ch: char;

  begin
    if debug then
        debugwrite('rinit');

    numtry := numtry + 1;

    ch := rpack(len,num,recpkt); (* receive a packet *)
    refresh_screen(num_try,n);

    if (ch = 'S') then           (* send init packet *)
      begin
        rpar(recpkt);            (* get other side's init data *)
        spar(packet);            (* fill packet with my init data *)
        ctl_set := [chr(1)..chr(31),chr(del),quote];
        spack('Y',n mod 64,6,packet); (* ACK with my params *)
        oldtry := numtry;        (* save old try count *)
        numtry := 0;             (* start a new counter *)
        n := n + 1;              (* bump packet number *)
        rinit := 'f';            (* enter file send state *)
      end (* if 'S' *)
    else if (ch = 'E') then
      begin
        rinit := 'a';
        error(recpkt,len)
      end (* if 'E' *)
    else if (ch = chr(0)) then
        rinit := 'r'             (* stay in same state *)
    else
        rinit := 'a'             (* abort *)
  end; (* rinit *)

(* state table switcher for receiving packets *)

  begin (* recswok *)
    writescreen('Receiving');
    currstate := 'r';            (* initial state is send *)
    n := 0;                  (* set packet # *)
    numtry := 0;             (* no tries yet *)

    while true do
        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;
                     exit(recsw)
                   end; (* case c *)
              'a': begin
                     rec_ok := false;
                     exit(recsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            rec_ok := false;
            exit(recsw)
          end (* else *)
  end; (* recsw *)

  end. { receiver }

>>>> SENDER.TEXT
unit sender;

interface

   procedure sendsw(var send_ok: boolean);


implementation

uses
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack;


procedure sendsw{(var send_ok: boolean)};

var io_status: integer;

procedure openfile;

(* resets file & gets past first 2 blocks *)

  begin
    (*$I-*) (* turn off compiler i/o checking temporarily *)
    reset(oldf,xfilename);
    (*$I+*) (* turn compiler i/o checking back on *)
    io_status := io_result;
    if (iostatus = 0) then
      if (pos('.TEXT',xfilename) = length(xfilename) - 4) then
        begin                             (* is a text file, so *)
          i := blockread(oldf,filebuf,1); (* skip past 2 block header *)
          i := blockread(oldf,filebuf,1);
        end; (* if *)
  end; (* openfile *)

function sinit: char;

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

var num, len, i: integer;  (* packet number and length *)
    ch: char;

  begin
    if debug then
        debugwrite('sinit');

    if numtry > maxtry then
      begin
        sinit := 'a';
        exit(sinit)
      end;

    num_try := num_try + 1;
    spar(packet);

    clear_buf(inport);

    refresh_screen(numtry,n);

    spack('S',n mod 64,6,packet);

    ch := rpack(len,num,recpkt);

    if (ch = 'N') then
      begin
        sinit := 's';
        exit(sinit)
      end (* if 'N' *)
    else if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then       (* not the right ack *)
          begin
            sinit := currstate;
            exit(sinit)
          end;
        rpar(recpkt);
        if (xeol = chr(0)) then   (* if they didn't spec eol *)
            xeol := chr(my_eol);    (* use mine *)
        if (quote = chr(0)) then (* if they didn't spec quote *)
            quote := my_quote;     (* use mine *)
        ctl_set := [chr(1)..chr(31),chr(del),quote];
        numtry := 0;
        n := n + 1;              (* increase packet number *)
        sinit := 'f';
        exit(sinit)
      end (* else if 'Y' *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sinit := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then
        sinit := currstate
    else if (ch <> 'N') then
        sinit := 'a'
  end; (* sinit *)

function sdata: char;

(* send file data *)

var num, len: integer;
    ch: char;
    packarray: array[false..true] of packettype;
    sizearray: array[false..true] of integer;
    current: boolean;
    b: boolean;

function other(b: boolean): boolean;

(* complements a boolean which is used as array index *)

  begin
    if b then
        other := false
    else
        other := true
  end; (* other *)

  begin
    current := true;
    packarray[current] := packet;
    sizearray[current] := size;
    while (currstate = 'd') do
      begin
        if (numtry > maxtry) then             (* if too many tries, give up *)
            currstate := 'a';

        b := other(current);
        numtry := numtry + 1;

                                          (* send a data packet *)
        spack('D',n mod 64,sizearray[current],packarray[current]);

        refresh_screen(numtry,n);
                                          (* set up next packet *)
        sizearray[b] := bufill(packarray[b]);

        ch := rpack(len,num,recpkt);      (* receive a packet *)
        if ch = 'N' then                  (* NAK, so just stay in this state *)
            if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
                sdata := currstate
            else                          (* is just like ACK for this packet *)
              begin
                if num > 0 then
                    num := (num - 1)      (* in which case, decrement num *)
                else
                    num := 63;
                ch := 'Y';                (* and indicate an ACK *)
              end; (* else *)

        if (ch = 'Y') then
           begin
             if ((n mod 64) <> num) then (* if wrong ACK *)
               begin
                 sdata := currstate;         (* stay in same state *)
                 exit(sdata);            (* get out of here *)
               end; (* if *)
             numtry := 0;
             n := n + 1;
             current := b;
             if sizearray[current] = ateof then
                 currstate := 'z'            (* set state to eof *)
             else
                 currstate := 'd'            (* else stay in data state *)
           end (* if *)
          else if (ch = 'E') then
            begin
              error(recpkt,len);
              currstate := 'a'
            end (* if 'E' *)
          else if (ch = chr(0)) then      (* receive failure, so stay in d *)
            begin
            end
          else if (ch <> 'N') then
            currstate := 'a'                  (* on anything else goto abort state *)
      end; (* while *)
    size := sizearray[current];
    packet := packarray[current];
    sdata := currstate
  end; (* sdata *)

function sfile: char;

(* send file header *)

var num, len, i: integer;
    ch: char;
    fn: packettype;
    oldfn: string255;

procedure legalize(var fn: string255);

(* make sure we send only 1 '.' in filename *)

var count, i, j, l: integer;

  begin
    count := 0;
    l := length(fn);
    for i := 1 to l do                                  (* count '.'s in fn *)
        if fn[i] = '.' then
            count := count + 1;
    for i := 1 to count-1 do                            (* remove all but 1 *)
      begin
        j := 1;
        while (j < l) and (fn[j] <> '.') do
            j := j + 1;                                 (* by finding it *)
        fn := concat(copy(fn,1,j-1),copy(fn,j+1,l-j));  (* and copying around it *)
        l := l - 1
      end (* for i *)
  end; (* legalize *)

  begin
    if debug then
        debugwrite('sfile');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        sfile := 'a';
        exit(sfile)
      end;
    numtry := numtry + 1;

    oldfn := xfilename;
    legalize(xfilename);                (* make filename acceptable to remote *)
    len := length(xfilename);

    moveleft(xfilename[1],fn[0],len);   (* move filename into a packettype *)

    gotoxy(filepos,fileline);
    write(oldfn,' ==> ',xfilename);

    refresh_screen(numtry,n);

    spack('F',n mod 64,len,fn);               (* send file header packet *)

    size := bufill(packet);            (* get first data from file *)
                                       (* while waiting for response *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
            exit(sfile)                (* is just like ACK for this packet *)
        else
          begin
            if (num > 0) then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then  (* if wrong ACK, stay in F state *)
            exit(sfile);
        numtry := 0;
        n := n + 1;
        sfile := 'd';
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sfile := 'a'
      end (* if 'E' *)
    else if (ch <> chr(0)) and (ch <> 'N') then (* don't recognize it *)
        sfile := 'a'
  end; (* sfile *)

function seof: char;

(* send end of file *)

var num, len: integer;
    ch: char;

  begin
    if debug then
        debugwrite('seof');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        seof := 'a';
        exit(seof)
      end;
    numtry := numtry + 1;

    refresh_screen(numtry,n);

    spack('Z',(n mod 64),0,packet);    (* send end of file packet *)

    if debug then
        debugwrite('seof1');

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
            exit(seof)                 (* is just like ACK for this packet *)
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if debug then
            debugwrite('seof2');
        if ((n mod 64) <> num) then     (* if wrong ACK, stay in F state *)
            exit(seof);
        numtry := 0;
        n := n + 1;
        if debug then
            debugwrite(concat('closing ',s));
        close(oldf);
        seof := 'b'
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        seof := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
      begin
      end
    else if (ch <> 'N') then           (* other error, just abort *)
        seof := 'a'
  end; (* seof *)

function sbreak: char;

var num, len: integer;
    ch: char;

(* send break (end of transmission) *)

  begin
    if debug then
        debugwrite('sbreak');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        sbreak := 'a';
        exit(sbreak)
      end;
    numtry := numtry + 1;

    refresh_screen(numtry,n);

    spack('B',(n mod 64),0,packet);    (* send end of file packet *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
            exit(sbreak)               (* is just like ACK for this packet *)
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then    (* if wrong ACK, stay in B state *)
            exit(sbreak);
        numtry := 0;
        n := n + 1;
        sbreak := 'c'                  (* else, switch state to complete *)
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sbreak := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
      begin
      end
    else if (ch <> 'N') then           (* other error, just abort *)
        sbreak := 'a'
  end; (* sbreak *)

(* state table switcher for sending *)

  begin (* sendsw *)

    if debug then
        debugwrite(concat('Opening ',xfilename));

    openfile;
    if io_status <> 0 then
      begin
        io_error(io_status);
        send_ok := false;
        exit(sendsw)
      end;

    write_screen('Sending');
    currstate := 's';
    n := 0;       (* set packet # *)
    numtry := 0;
    while true do
        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;
                     exit(sendsw)
                   end; (* case c *)
              'a': begin
                     send_ok := false;
                     exit(sendsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            send_ok := false;
            exit(sendsw)
          end (* else *)
  end; (* sendsw *)

  end. { sender }

>>>> SETSHOW.TEXT
procedure write_bool(s: string255; b: boolean);

(* writes message & 'on' if b, 'off' if not b *)
  begin
    write(s);
    case b of
        true: writeln('on');
        false: writeln('off');
      end; (* case *)
  end; (* write_bool *)

procedure show_parms;

(* shows the various settable parameters *)

begin
   case noun of
      allsym: begin
                 write_bool('Debugging is ',debug);
                 writeln('Escape character is ^',ctl(esc_char));
                 write_bool('File warning is ',fwarn);
                 write_bool('IBM is ',ibm);
                 write_bool('Local echo is ',halfduplex);
                 write_bool('Emulate DataMedia is ', emulating );
                 case parity of
                    evenpar: write('Even');
                    markpar: write('Mark');
                    nopar: write('No');
                    oddpar: write('Odd');
                    spacepar: write('Space');
                 end; (* case *)
                 writeln(' parity');
                 writeln( 'Baud rate is ', baud:5 );
              end; (* allsym *)

      debugsym:    write_bool('Debugging is ',debug);

      escsym:      writeln('Escape character is ^',ctl(esc_char));

      filewarnsym: write_bool('File warning is ',fwarn);

      ibmsym:      write_bool('IBM is ',ibm);

      localsym:    write_bool('Local echo is ',halfduplex);

      emulatesym:  write_bool('Emulate DataMedia is ', emulating );

      baudsym:     writeln( 'Baud rate is ', baud:5 );

      paritysym:   begin
                      case parity of
                         evenpar: write('Even');
                         markpar: write('Mark');
                         nopar: write('No');
                         oddpar: write('Odd');
                         spacepar: write('Space');
                      end; (* case *)
                      writeln(' parity');
                      end; (* paritysym *)
                   end; (* case *)
end; (* show_sym *)


procedure set_parms;

(* sets the parameters *)

  begin
    case noun of
        debugsym: case adj of
                      onsym: begin
                          debug := true;
                          (*$I-*)
                          rewrite(debf,'CONSOLE:')
                          (*I+*)
                        end; (* onsym *)
                      offsym: debug := false
                    end; (* case adj *)
        escsym: escchar := newescchar;
        filewarnsym: fwarn := (adj = onsym);
        ibmsym: case adj of
                    onsym: begin
                        ibm := true;
                        parity := markpar;
                        half_duplex := true;
                        fillparityarray
                      end; (* onsym *)
                    offsym: begin
                        ibm := false;
                        parity := nopar;
                        half_duplex := false;
                        fillparityarray
                      end; (* onsym *)
                  end; (* case adj *)
        localsym: halfduplex := (adj = onsym);
        emulatesym: emulating := (adj = onsym);
        paritysym: begin
              case adj of
                  evensym: parity := evenpar;
                  marksym: parity := markpar;
                  nonesym: parity := nopar;
                  oddsym: parity := oddpar;
                  spacesym: parity := spacepar;
                end; (* case *)
              fill_parity_array;
             end; (* paritysym *)
        baudsym: begin
            if newbaud=110 then
               baud := 110
            else if newbaud=300 then
               baud := 300
            else if newbaud=1200 then
               baud := 1200
            else if newbaud=2400 then
               baud := 2400
            else if newbaud=4800 then
               baud := 4800
            else if newbaud=9600 then
               baud := 9600;
            setup_comm
         end { baudsym }
      end; (* case *)
  end; (* set_parms *)