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

Pascal/Delphi Source File | 2020-01-01 | 88KB | 2,734 lines

{>>>> KERMIT.TEXT}
program kermit;
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}
{Adapted to Pascal Microengine by Tim Shimeall, UCI}
{Changes:
- Added device declarations copied from Microengine hardware documentation
- Replaced external assembly language routines with Pascal versions
- Modified debug messages to be label values printed
- Changed format of packetwrite display to show header fields
- Implemented machine-dependent packet timeout
- Added debug packetwrites in recsw
- Added wrap-around debug info region
- Added legality check in showparms
- Removed lf elimination check in echo procedure
- Unitwrite calls replaced by calls to device driving routines
- Most uses of char_int_rec replaced by ord and chr
- Removed queue (no interrupts)
- Used sets for integer ops to getaround Microengine bug
- Changed parser from a unit to a segment procedure to allow swapping
- Split utility procs into separate files for editing and transfer convinience

}
(*$R-*) (* turn range checking off *)
(*$S+*) (* turn swapping on *)
(* $L+*) (* no listing *)

const blksize = 512;
      oport = 8;          (* output port # *)
      (* clearscreen = 12;   charcter which erases screen *)
      bell = 7;           (* ASCII bell *)
      esc = 27;           (* ASCII escape *)
      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 *)
      dle = 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 *)
      eoln_sym = 13;      (* pascal eoln sym *)
      back_space = 8;     (* pascal backspace sym *)

(* MICROENGINE dependent constants *)
      intsize = 15;       (* number of bits in an integer minus 1 *)
      Channel0=-992; {FC20 = serial Port B register}
      Channel1=-1008; {FC10 = serial Port A register}
     (* Elements of the status vector in the "StatCmdRec" declared below*)
      RegEmpty=0;
      DataReceived=1;
      OverError=2;
      FrameError=4;
     (* bits 3,5,6,and 7 are not used, since they rely on specific wiring,
       and seem to be unreliable *)

(* 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;
      prompt_line = 7;
      debug_line = 9;
      debug_max = 12; (* Max lines of debug to show at once *)
  (* 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 *)
                           (* replaced by set version to escape microengine
                              bug *)
                      case boolean of
                          true: (i: integer);
                          false: (b: set of 0..intsize);
                    end; (* record *)

(* MICROENGINE Dependent Types *)
     Port = (Terminal,Modem);
     Statcmdrec = RECORD CASE BOOLEAN OF  (* Only the Status field is used
                                             in this code, but the declaration
                                             is from Western Digital doc. *)
                    TRUE:(Command:INTEGER);
                    FALSE:(Status:PACKED ARRAY [0:7] OF BOOLEAN);
                    END;
    SerialRec = RECORD
                 SerData:INTEGER;
                 StatSynDle:StatCmdRec;
                 Control2:INTEGER;
                 Control1:INTEGER;
                 filler:ARRAY [0..3] OF INTEGER;
                 Switch:StatCmdRec;
                 END;

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

var state: char; (* current state *)
    f: file of char; (* file to be received *)
    oldf: file; (* file to be sent *)
    s: string;
    eol, 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 *)
    debnext:0..7; (* offset for next debug message *)
    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;

(* MICROENGINE Dependent Variable declarations *)
     PortA,PortB:RECORD CASE BOOLEAN OF
                TRUE:(DevAdd:INTEGER);
                FALSE:(Serial:^SerialRec);
                END;
   (* Parser vars *)

    noun, verb, adj: vocab;
    status: statustype;
    vocablist: array[vocab] of string[13];
    filename, line: string;
    newescchar: char;
    expected: set of vocab;

function read_ch(p: port; var ch: char): boolean;
forward;

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

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

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

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

procedure io_error(i: integer);
forward;

procedure debugwrite(s: string);
forward;

procedure debugint(s: string; i: integer);
forward;

procedure writescreen(s: string);
forward;

procedure refresh_screen(numtry, num: integer);
forward;

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

function tochar(ch: char): char;
forward;

function unchar(ch: char): char;
forward;

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

function getfil(filename: string): boolean;
forward;

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

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

procedure spar(var packet: packettype);
forward;

procedure rpar(var packet: packettype);
forward;

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

function getch(var r: char; p: port): boolean;
forward;

function getsoh(p: port): boolean;
forward;

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

procedure read_str(p: port; var s: string);
forward;

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

procedure show_parms;
forward;

procedure uppercase(var s: string); forward;


(*$I WDFORW.TEXT *) (* Forward Declarations for WDPROCS.TEXT *)
(*$I HELP.TEXT*) (* Segment Procedure Help *)
(*$I SENDSW.TEXT*) (* Segment Procedure Sendsw *)
(*$I RECSW.TEXT*) (* Segment Procedure Recsw *)
(*$I PARSE.TEXT*) (* Segment Function Parse *)
(*$I WDPROCS.TEXT*) (* MICROENGINE dependent routines*)
(*$I UTILS.TEXT *) (* General Utility procedures *)
(*$I RSUTILS.TEXT *) (* Utility procedures for send and receive *)

procedure connect;

(* connect to remote host (terminal emulation *)

var ch: char;
    close: boolean;

  procedure read_esc;

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

    begin
      repeat
      until read_ch(terminal,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.'); *)
                  write('C    Close Connection, return to ');
                  writeln('KERMIT-UCSD command level.');
                  writeln('S    Show Status of connection');
                  writeln('?    Print this list');
                  write('^',esc_char,'   send the escape ');
                  writeln('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
              echo(ch);
              while not istbtr do;
              sndbbt(ch);
            end (* if *)
        end (* else if *)
      else                        (* anything else: ignore *)
          write(chr(bell))
    end; (* read_esc *)

  begin (* connect *)
    writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
    close := false;
    repeat
        if read_ch(modem,ch) then        (* if char from host then *)
            echo(ch);                   (* echo it *)

        if read_ch(terminal,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 *)
                    echo(ch);
                while not istbtr do;
                sndbbt(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:
        begin
          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        (* count the 1's *)
                begin
                  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 *)
        end; (* case even *)
      oddpar:
        begin
          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         (* count the 1's *)
                begin
                  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 *)
        end; (* 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 w/parity bit at all *)
              parity_array[ch] := ch;
    end; (* case *)
  end; (* fill_parity_array *)

procedure write_bool(s: string; 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
    if noun in [allsym, debugsym, ibmsym, escsym, filewarnsym, localsym,
                paritysym] then
    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);
            case parity of
                evenpar: write('Even');
                markpar: write('Mark');
                nopar: write('No');
                oddpar: write('Odd');
                spacepar: write('Space');
              end; (* case *)
            writeln(' parity');
          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);
        paritysym: begin
            case parity of
                evenpar: write('Even');
                markpar: write('Mark');
                nopar: write('No');
                oddpar: write('Odd');
            (' parity');
           end; (* paritysym *)
      end (* case *)
      else write(chr(bell));
  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);
        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 *)
      end; (* case *)
  end; (* set_parms *)

procedure initialize;

var ch: char;

  begin
    pad := mypad;
    padchar := chr(mypchar);
    eol := chr(my_eol);
    esc_char := chr(my_esc);
    quote := my_quote;
    ctlset := [chr(1)..chr(31),chr(del),quote];
    half_duplex := false;
    debug := false;
    debnext:=0;
    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;
    init;
  end; (* initialize *)

procedure closeup;

  begin
    finit;
    writeln(chr(esc),'E'{clearscreen});
  end; (* closeup *)

  begin (* kermit *)
    initialize;
    repeat
        write('Kermit-UCSD> ');
        readstr(terminal,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);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* recsym *)
                      sendsym: begin
                          uppercase(filename);
                          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 *)
        unitclear(1); (* clear any trash in input *)
        unitclear(2);
     until (verb = exitsym) or (verb = quitsym);
     closeup
   end. (* kermit *)

{>>>>WDFORW.TEXT}
procedure INIT; forward;
function ISTARR:boolean ; forward;
function ISTBRR:boolean; forward;
function ISTAOR:boolean ; forward;
function ISTBOR:boolean ; forward;
function ISTAFE:boolean ; forward;
function ISTBFE:boolean; forward;
function ISTATR:boolean ; forward;
function ISTBTR :boolean; forward;
function RCVABT:CHAR ; forward;
function RCVBBT:CHAR ; forward;
procedure SNDABT (BT:CHAR); forward;
procedure SNDBBT (BT:CHAR); forward;
procedure FINIT; forward;

{>>>> HELP.TEXT}
segment procedure help;
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}

procedure keypress;

var ch: char;

  begin
    writeln('---------------Press any key to continue---------------');
    repeat
    until readch(terminal,ch);
    writeln(chr(esc),'E'{clearscreen})
  end; (* keypress *)

procedure help1;

var ch: char;

begin
if (noun = nullsym) then
begin
writeln('KERMIT is a family of  programs that do reliable file transfer');
write('between computers over TTY lines.  KERMIT can also be ');
writeln('used to make the ');
writeln('microcomputer behave as a terminal for a mainframe.  These are the ');
writeln('commands for theUCSD 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('              system.');
writeln;
write('              To break the connection and "escape" back to the micro,');
writeln;
writeln('              type the escape sequence (CTRL-] C, that is Control ');
writeln('              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
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('                               (default is OFF).');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = escsym) then
begin
writeln('              ESCAPE           To change the escape sequence that ');
writeln('                               lets you return to the PC Kermit from');
write('                               the remote host.');
writeln('  The default is CTRL-] c.');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = filewarnsym) then
begin
writeln('              FILE-WARNING     ON/OFF, default is OFF.  If ON, ');
writeln('                               Kermit will warn you and rename an ');
writeln('                               incoming file so as not to write over');
writeln('                               a file that currently exists with the');
writeln('                               same name');
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('              IBM              ON/OFF, default is OFF.  This flag ');
write('                               should be ON only when ');
writeln('transfering files');
writeln('                               between the micro and an IBM VM/CMS');
writeln('                               system.  It also causes the parity to');
write('                               be set appropriately ');
writeln('(mark) and activates');
writeln('                               local echoing');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = localsym) then
begin
write('              LOCAL-ECHO       ON/OFF, default is OFF.  This sets the');
writeln;
writeln('                               duplex.  It should be ON when using ');
writeln('                               the IBM and OFF for the DEC-20.');
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('              PARITY           EVEN, ODD, MARK, SPACE, or NONE.');
writeln('                               NONE is the default but if the IBM ');
writeln('                               flag is set, parity is set to MARK.  ');
writeln('                               This flag selects the parity for ');
write('                               outgoing and incoming characters during');
writeln;
write('                               CONNECT and file transfer to match the');
writeln;
writeln('                               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.  Options are the same as for SET,');
writeln('              except that a SHOW ALL command has been added.');
end; (* if *)
end; (* help4 *)

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

{>>>> SENDSW.TEXT}

(* Send Section *)
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}

segment 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,filename);
    (*$I+*) (* turn compiler i/o checking back on *)
    io_status := io_result;
    if (iostatus = 0) then
      if (pos('.TEXT',filename) = length(filename) - 4) then
                                          (* is a text file, so *)
          i := blockread(oldf,filebuf,2); (* skip past 2 block header *)
  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);

    if istbrr then ch:=rcvbbt; (* clear modem buffer *)

    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 := state;
            exit(sinit)
          end;
        rpar(recpkt);
        if (eol = chr(0)) then   (* if they didn't spec eol *)
            eol := 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 := state
    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 (state = 'd') do
      begin
        if (numtry > maxtry) then             (* if too many tries, give up *)
            state := '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, which *)
                sdata := state
            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 := state;         (* stay in same state *)
                 exit(sdata);            (* get out of here *)
               end; (* if *)
             if numtry > 1 then          (* if anything in buffer, flush it *)
                 if istbrr then begin
                   ch:=rcvbbt;
                   ch:='Y';
                   end;
             numtry := 0;
             n := n + 1;
             current := b;
             if sizearray[current] = ateof then
                 state := 'z'            (* set state to eof *)
             else
                 state := 'd'            (* else stay in data state *)
           end (* if *)
          else if (ch = 'E') then
            begin
              error(recpkt,len);
              state := 'a'
            end (* if 'E' *)
          else if (ch = chr(0)) then      (* receive failure, so stay in d *)
            begin
            end
          else if (ch <> 'N') then
            state := 'a'                  (* on any other goto abort state *)
      end; (* while *)
    size := sizearray[current];
    packet := packarray[current];
    sdata := state
  end; (* sdata *)

function sfile: char;

(* send file header *)

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

procedure legalize(var fn: string);

(* make sure file name will be legal to other computer *)

var count, i, j, l: integer;

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('A') + ord(s[i]) - ord('a'))
  end; (* uppercase *)

  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;
            delete(fn,j,1);l := l - 1
      end; (* for i *)
    l := length(fn);
    i := pos(':',fn);
    if (i <> 0) then
      begin
        fn := copy(fn,i,l-i);
        l := length(fn)
      end;
    i := 1;
    while (i <= length(fn)) do
        if not(fn[i] in ['a'..'z','A'..'Z','.','0'..'9']) then
            delete(fn,i,1)
        else
            i := i + 1;
    uppercase(fn)
  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 := filename;
    legalize(filename);                (* make filename acceptable to remote *)
    len := length(filename);

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

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

    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 ',filename));

    openfile;
    if io_status <> 0 then
      begin
        writeln(chr(esc),'E'{clear_screen});
        io_error(io_status);
        send_ok := false;
        exit(sendsw)
      end;

    write_screen('Sending');
    state := 's';
    n := 0;       (* set packet # *)
    numtry := 0;
    while true do
        if state in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
          case state of
              'd': state := sdata;
              'f': state := sfile;
              'z': state := seof;
              's': state := sinit;
              'b': state := 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 *)

{>>>> RECSW.TEXT}

(* RECEIVE SECTION *)
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}

segment procedure recsw(var rec_ok: boolean);

function rdata: char;

(* send file data *)

var num, len: integer;
    ch: char;

  begin

    repeat
        if numtry > maxtry then
          begin
            debugwrite('too many intial retries in rdata');
            state := 'a';
            exit(rdata)
          end;

        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)
        if debug and (ch<>chr(0)) then packetwrite(recpkt,len);

        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
                    debugwrite('too many data retries in rdata');
                    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 *)
                    debugint('re-acking ',num);
                    spack('Y',num,6,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else begin             (* wrong number *)
                    debugwrite('wrong data sequence no. in rdata');
                    state := 'a'       (* so abort *)
                    end
              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 *)
                if numtry > 1 then
                    if istbrr then     (* clear buffer *)
                      begin
                        ch:=rcvbbt;
                        ch:='D';
                      end;
                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
                debugwrite('too many file head tries in rdata');
                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 *)
                debugint('re-acking file header ',num);
                spack('Y',num,0,packet);
                if istbrr then begin
                  ch:=rcvbbt; (* and empty out buffer *)
                  ch:='F';
                  end;
                numtry := 0;           (* reset try counter *)
                state := state;        (* stay in same state *)
              end (* if *)
            else begin
              debugwrite('file info not previous packet in rdata');
                state := 'a'           (* not previous packet, abort *)
                end
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                debugwrite('wrong eof packet in rdata');
                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 *)
            state := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            state := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then begin (* some other packet type, *)
            state := 'a';                 (* abort *)
            debugwrite('wierd rdata packet');
            end
    until (state <> 'd');
    rdata := state
  end; (* rdata *)

function rfile: char;

(* receive file header *)

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

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

function exist(fn: string): boolean;

(* returns true if file named fn exists *)

var f: file;

  begin
    (*$I-*) (* turn off i/o checking *)
    reset(f,fn);
    exist := (ioresult = 0)
    (*$I+*)
  end; (* exist *)

procedure checkname(var fn: string);

(* 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 *)
    if debug and (ch<>chr(0)) then packetwrite(recpkt,len);
    refresh_screen(numtry,n);

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

        n := n - 1;

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

        n := n - 1;

        if num = (n mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            debugint('re-acking eof ',num);
            spack('Y',num,0,packet);
            numtry := 0;
            rfile := state            (* 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
            debugwrite('wrong seq. of file header');
            rfile := 'a';
            exit(rfile)
          end;

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

        if not getfil(filename) 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
            debugwrite('wrong sequence in break packet');
            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 := state                (* so stay in same state *)
    else begin                        (* some weird state, so abort *)
        rfile := 'a';
        debugwrite('wierd rfile packet');
        end
  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 *)
    if debug and (ch<>chr(0)) then packetwrite(recpkt,len);
    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,7,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 begin
        rinit := 'a';             (* abort *)
        debugwrite('wierd rinit packet');
        end
  end; (* rinit *)

(* state table switcher for receiving packets *)

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

    while true do
        if state in ['d', 'f', 'r', 'c', 'a'] then
          case state of
              'd': state := rdata;
              'f': state := rfile;
              'r': state := 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 *)


{>>>> PARSE.TEXT}

segment function parse: statustype;
(* NOTE: due to procedures at the end of this file, this must be the
LAST segment declared *)

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

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

procedure eatspaces(var s: string);

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: string);

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: string): boolean;

var i, l: integer;

  begin
    get_fn := true;
    isolate_word(line, fn);
    l := length(fn);
    if (l < 1) then
        get_fn := false
  end; (* get_fn *)

function getch(var ch: char): boolean;

var s: string;

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


function get_sym(var word: vocab): statustype;

var i: vocab;
    s: string;
    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,filename) then
                begin
                  status := null;
                  state := fin
                end (* if *)
              else
                  status := fnexpected
            end; (* case get file name *)
          get_set_parm:
              begin
                expected := [paritysym, localsym, ibmsym, escsym,
                             debugsym, filewarnsym];
                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;
                      escsym: state := getchar;
                      debugsym: state := getonoff;
                      filewarnsym: state := getonoff;
                    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_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 getch(newescchar) then
                 state := fin
              else
                 status := ch_expected;
          get_show_parm:
              begin
                expected := [allsym, paritysym, localsym, ibmsym, escsym,
                             debugsym, filewarnsym];
                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];
                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[consym] :=      'CONNECT';
    vocablist[debugsym] :=    'DEBUG';
    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 *)

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

{>>>>WDPROCS.TEXT}
(* These drivers were adapted from routines written by Tim Shimeall
   for a PCNET implementation, based on information from Western
   Digital.

   On the Microengine, there are two RS232C Serial Ports.  Port A is
   reserved for the system terminal.  Port B is available for all other
   devices which may be desired to hang off a Microengine.  In this code,
   it is assumed that Port B holds the modem.
*)
(* All functions are duplicated on ports A and B for simplicity *)

PROCEDURE Init;
BEGIN (* InitM *)
   PortB.DevAdd:= Channel0;
   PortA.DevAdd:= Channel1;
   WITH PortB.Serial^ DO BEGIN
     {The following two lines set the serial port to the following
      commands:
         Control1:
           1 - Full Duplex Operation
           0 - Break or Transmit NOT transparent
           0 - Send 2 stop bits on Transmitted 8-bit data
           0 - No echo of Recieved data
           0 - Parity checking/generation OFF
           1 - Reciever is enabled (chars in Rec. holding reg.)
           1 - REQUEST TO SEND is enabled if CTS is low
           1 - DTR is ON
          Control2:
           0 - 8 bits
           0 - 8 bits
           0 - Asynchronous character mode
           0 - even parity
           0 - select reciever rate 1
           0 - +
           0   | - Clock select to rate 1 (32X)
           1 - +
       }
     Control1:=135; {87 hex}
     Control2:=1;
     END;
   WITH PortA.Serial^ DO BEGIN
     Control1:=135;
     Control2:=1;
     END;
END; (*InitM*)

(*---------------------UART FLAG CHECKING-------------------------------*)

function ISTARR(*:boolean *);
(* ARR -- IS True Port A Receive Ready?

This checks the UART status bit corresponding to Receive Data
Available. If data is available a true result is returned.*)
BEGIN
  ISTARR:=PortA.Serial^.StatSynDle.status[DataReceived];
END;

function ISTBRR(*:boolean*);
(* BRR -- IS True Port B Receive Ready?*)
BEGIN
  ISTBRR:=PortB.Serial^.StatSynDle.status[DataReceived];
END;

function ISTAOR(*:boolean*);
(* AOR -- IS it True that data OverRun occurred?:0 istor<ditto>

Immediately after RCVBT is called, ISTOR may be called to check for
data overrun. This function isn't necessary, but it helps diagnose
software that is losing data because it is too slow to receive data
before that data starts getting shifted out of the way to make way for
later data that has already started to arrive.
*)
BEGIN
  ISTAOR:=PortA.Serial^.StatSynDle.Status[OverError];
END;

function ISTBOR(*:boolean*);
BEGIN
  ISTBOR:=PortB.Serial^.StatSynDle.Status[OverError];
END;

function ISTAFE(*:boolean *);
(* FE -- IS it True that Framing-Error occurred?:0 istfe<ditto>

Immediately after RCVBT is called, ISTFE may be called to check for
framing error. This function isn't necessary, but it helps diagnose
various errors such as phone-line-noise and wrong-speed-UART. Normally
ISTOR will be called before ISTFE since data overrun is a more serious
error than framing-error and thus pre-empts framing-error. The entire
sequence is thus: ISTRR, RCVBT, ISTOR, ISTFE.
*)
BEGIN
  ISTAFE:=PortA.Serial^.StatSynDle.Status[FrameError];
END;

function ISTBFE(*:boolean*);
BEGIN
  ISTBFE:=PortB.Serial^.StatSynDle.Status[FrameError];
END;

function ISTATR(*:boolean *);
(* TR -- IS it True that Transmit is Ready?:0 isttr<used in FDX&SDWBT>

ISTTR is analagous to ISTRR, it tells whether it's safe to transmit
(rather than to receive) a byte of data. Internally it tells whether
the previous byte has cleared the device so that the buffer is empty
to accept another byte. In the device descripion it's usually called
Transmit Buffer Empty. For instantaneous devices such as memory-mapped
CRTs, this function will always return TRUE. For most other devices
such as UARTs and ACIAs (connected directly to terminals, or to
modems), ISTTR will return TRUE initially, then return FALSE as soon
as a byte is sent to the device, and then return TRUE when actual
transmission is done. For double-buffered devices it may only go FALSE
only after two characters are sent to it, one of which is actually en
route and the other of which is merely occupying the extra buffer.
*)
BEGIN
  ISTATR:=PortA.Serial^.StatSynDle.Status[RegEmpty];
END;

function ISTBTR(*:boolean*);
BEGIN
  ISTBTR:=PortB.Serial^.StatSynDle.Status[RegEmpty];
END;

(*------------------Primitive character sending and receiving---------------*)

function RCVABT(*:CHAR*) ;
(* ReCeiVe ByTe of data from device:0 rcvbt<used in FDX and RCWBT>

This is the function that is called after ISTRR returns true, to
actually fetch the waiting data from the UART or ACIA into the
computer, freeing the device to accept the next byte of data. These
two functions, testing for data ready and actually fetching the data,
are kept separate for two reasons: (1) they are separate hardware
functions in most existing devices, ISTRR being a read of the status
port with testing for a bit and RCVBT being a read of the data
port, and (2) often they must be separate in the software, such as
when it's necessary to verify both that data is available and there's
a place to put it before fetching the data, such as in a terminal emulator.

Note that calling RCVBT any time other than after getting a true
result from ISTRR is invalid, yielding random garbage such as part of
an incoming byte shifted. Note also that RCVBT fetches all 8 bits of
the incoming byte of data, returning an 8-bit number with each bit in
its normal position, for example the first-arrived bit is the 1 bit,
then the 2 bit, etc., with the "parity" bit which is the last-arrived
appearing simply as an 8th bit (hexadecimal value 80). No checking of
parity is allowed, nor is stripping off of the parity bit. When only 7
bits are desired, a higher-level function will strip off the parity bit.*)
BEGIN
  RCVABT:=CHR(PortA.Serial^.SerData);
END;

function RCVBBT(*:CHAR*);
BEGIN
  RCVBBT:=CHR(PortB.Serial^.SerData);
END;

procedure SNDABT(* (BT:CHAR)*);
(* SeND ByTe of data:0 sndbt<used in FDX&SDWBT>

After getting back a TRUE result from isttr, this function SNDBT is
used to actually send the byte of data from the CPU to the device, so
as to effect sending it out the I/O port (modem or local CRT). Note
that any attempt to call SNDBT without first getting TRUE from isttr
can result in clobbering previous data that is still in transit from
the UART or ACIA bit by bit, causing both that previous byte and this
new byte to be lost/garbaged. *)
BEGIN (* SNDABT*)
  PortA.Serial^.SerData:=ORD(BT);
END(*SNDABT*);

procedure SNDBBT(* (BT:CHAR)*);
(* SeND ByTe of data:0 sndbt<used in FDX&SDWBT>

After getting back a TRUE result from isttr, this function SNDBT is
used to actually send the byte of data from the CPU to the device, so
as to effect sending it out the I/O port (modem or local CRT). Note
that any attempt to call SNDBT without first getting TRUE from isttr
can result in clobbering previous data that is still in transit from
the UART or ACIA bit by bit, causing both that previous byte and this
new byte to be lost/garbaged. *)
BEGIN (* SNDBBT*)
  PortB.Serial^.SerData:=ORD(BT);
END(*SNDBBT*);

procedure finit;
BEGIN
  PortB.Serial^.Control1:=0; {Turn off DTR, which causes modem to hang up}
END;


{>>>>UTILS.TEXT}
function ready(p:port):boolean;
begin
  ready:= ((p=terminal) and istarr) or ((p=modem) and istbrr);
end;

function pget(p:port):char;
begin
  if p=terminal then pget:=rcvabt
  else pget:=rcvbbt;
end;

procedure read_str(*var p: port; var s: string*);

(* acts like readln(s) but takes input from specified port *)

var i: integer;

  begin
    i := 0;
    s := copy('',0,0);
    repeat
      repeat                              (* get a character *)
      until ready(p);
      ch:=pget(p);
      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 *)

function read_ch(*p: port; var ch: char): boolean*);

(* read a character from an input port *)

  begin
        if ready(p) then            (* if a char there *)
          begin
            ch := pget(p);      (* get the char *)
            read_ch := true;               (* and return true *)
          end (* if *)
        else                             (* otherwise *)
            read_ch := false;              (* return false *)
  end; (* read_ch *)

function getch(*var r: char; p: port): 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 ready(p) or (count > maxtry);         (* wait for a character *)
    if (count > maxtry) then                    (* if wait too long then *)
        exit(getch);                            (* get out of here *)
    r:=pget(p);                                 (* get the character *)
    r := chr(aand(ord(r),127));                 (* strip parity from char *)
    getch := (r <> chr(soh));                   (* return true if not SOH *)
  end; (* getch *)


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 * yrec.b;  (* use as sets 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 + yrec.b;   (* use as sets to 'or' them *)
    aor := temp.i                 (* return integer result *)
  end; (* aor *)

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

(* exclisive or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
                                  (* use as sets to 'xor' them *)
    temp.b := (xrec.b - yrec.b) + (yrec.b - xrec.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);
    write(chr(27),'K');         (* erase to end of line *)
    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: string*);

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

  begin
    if debug then
      begin
        gotoxy(0,debugline+debnext);
        debnext:=(debnext+1) mod debug_max;
        write(chr(27),'K');         (* erase to end of line *)
        write(s);                   (* write debugging message *)
      end (* if debug *)
  end; (* debugwrite *)

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

(* write a debugging message and an integer *)

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

procedure writescreen(*s: string*);

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

  begin
    write(chr(esc),'E'{clearscreen});
    gotoxy(0,titleline);
    write('                        Kermit UCSD p-system');
    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 *)

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

  begin
    ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
    repeat until istatr;
    sndabt(ch)
  end; (* echo *)

{>>>>RSUTILS.TEXT}
function getfil(*filename: string): 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 bufemp(*buffer: packettype; var f: text; len: integer*);

(* empties a packet into a file *)

var i,ls: integer;
    r: char;
    s: string;

  begin
    s := copy('',0,0);
    ls := 0;
    i := 0;
    while i < len do
      begin
        r := buffer[i];          (* get a character *)
        if (r = myquote) then    (* if character is control quote *)
          begin
            i := i + 1;               (* skip over quote and *)
            r := buffer[i];        (* get quoted character *)
            if (aand(ord(r),127) <> ord(myquote)) then
                r := ctl(r);       (* controllify it *)
          end; (* if *)
        if (ord(r) = cr) then          (* else if a carriage return then *)
          begin
            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  (* if io_error *)
              begin
                io_error(ioresult);     (* tell them and *)
                state := 'a';           (* abort *)
              end (* if *)
          end
      (*$I+*)                      (* turn i/o checking back on *)
      else                        (* else, is a regular char, so *)
          begin
            r:= chr(aand(ord(r),127));     (* mask off parity bit *)
            s := concat(s,' ');       (* and add character to out string *)
            ls := ls + 1;
            s[ls] := r;
            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    (* if io_error *)
        begin
          io_error(ioresult);       (* tell them and *)
          state := '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;

  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-9) 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 := filebuf[bufpos];      (* get a character *)
            bufpos := bufpos + 1;         (* increase buffer pointer *)
            if (ord(r) = dle) then           (* if it's space compression char, *)
              begin
                count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
                bufpos := bufpos + 1;       (* read past # *)
                r := ' ';                (* 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 in ctlset) then     (* if a control char *)
              begin
                if (ord(r) = 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 := chr(lf);            (* and we'll stick a LF after *)
                  end; (* if *)
                if r <> chr(0) then          (* if not a NUL then *)
                  begin
                    buffer[i] := quote;      (* put the quote in buffer *)
                    i := i + 1;
                    if r <> quote then
                        r := ctl(r);   (* and un-controllify char *)
                  end (* if *)
              end; (* if *)
          end; (* if *)
        j := 1;
        while (j <= count) and (i <= spsiz - 5) do
          begin                           (* put all the chars in buffer *)
            if (ord(r) <> 0) then            (* so long as not a NUL *)
              begin
                buffer[i] := r;
                i := i + 1;
              end (* if *)
            else                          (* 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 *)
var s:string;
  begin
    s:='rpar:spsize:## timint:## pad:## padchar:### eol:### quote:###';
    spsiz := ord(unchar(packet[0]));     (* max send packet size *)
    s[13]:=chr(ord('0')+(spsiz div 10));
    s[14]:=chr(ord('0')+(spsiz mod 10));
    timint := ord(unchar(packet[1]));    (* when i should time out *)
    s[23]:=chr(ord('0')+(timint div 10));
    s[24]:=chr(ord('0')+(timint mod 10));
    pad := ord(unchar(packet[2]));       (* number of pads to send *)
    s[30]:=chr(ord('0')+(pad div 10));
    s[31]:=chr(ord('0')+(pad mod 10));
    padchar := ctl(packet[3]);           (* padding char to send *)
    s[41]:=chr(ord('0')+(ord(padchar) div 100));
    s[42]:=chr(ord('0')+((ord(padchar) mod 100) div 10));
    s[43]:=chr(ord('0')+(ord(padchar) mod 10));
    eol := unchar(packet[4]);            (* eol char i must send *)
    s[49]:=chr(ord('0')+(ord(eol) div 100));
    s[50]:=chr(ord('0')+((ord(eol) mod 100) div 10));
    s[51]:=chr(ord('0')+(ord(eol) mod 10));
    quote := packet[5];                  (* incoming data quote char *)
    s[59]:=chr(ord('0')+(ord(quote) div 100));
    s[60]:=chr(ord('0')+((ord(quote) mod 100) div 10));
    s[61]:=chr(ord('0')+(ord(quote) mod 10));
    debugwrite(s);
  end; (* rpar *)

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

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

var i: integer;
    s: string;
  begin
    s:='length:## Sequence:## Type: #';
    if p[0]=chr(soh) then s:=concat('SOH ',s);
    s[8]:=chr(ord('0')+(ord(p[1]) div 10));
    s[9]:=chr(ord('0')+(ord(p[1]) mod 10));
    s[20]:=chr(ord('0')+(ord(p[2]) div 10));
    s[21]:=chr(ord('0')+(ord(p[2]) mod 10));
    s[length(s)]:=p[3];
    debugwrite(s);
    gotoxy(0,debugline+debnext);
    debnext:=(debnext+1) mod debug_max;
    for i := 4 to len+3 do
      begin
        if i = 84 then
          begin
            gotoxy(0,debugline+debnext);
            debnext:=(debnext+1) mod debug_max;
            write(chr(27),'K');
          end; (* if *)
        write(p[i])
      end; (* for *)
  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 (state <> 's') then           (* if ibm and not SINIT then *)
      begin
        count := 0;
        repeat                                 (* wait for an xon *)
            repeat
                count := count + 1
            until (readch(modem,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 begin
        while not istbtr do ;
        sndbbt(padchar);                     (* write out any padding chars *)
        end;
    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] := eol;

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

    for i:=0 to bufp do begin
      while not istbtr do;
      sndbbt(buffer[i]);    (* send the packet out *)
      end;

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

function getsoh(*p: port): boolean*);

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

const maxtry = 10000; (* allows about 1 second of trying *)

var ch: char;
    seconds,count: integer;

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

(*$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; (* allows for about 1 second of checking *)

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

  begin
    count := 0;
    seconds := 0;

    if not getsoh(modem) and (state<>'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(state<>'r') then (* end of one second *)
        if seconds<timint then begin       (* and aren't waiting for init *)
          count:=0;
          seconds:=seconds+1;
        end
        else begin                       (* if we've tried too many times *)
          rpack := 'N';                      (* treat as NAK *)
          exit(rpack)                        (* and get out of here *)
        end; (* if *)

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

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

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

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

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

    if not getch(r,modem) 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)) then       (* if checksum bad *)
        rpack := chr(0)                      (* return 'false' indicator *)
    else                                   (* else *)
        rpack := ptype;                      (* return packet type *)

    if debug then
      begin
        gotoxy(0,debugline+debnext);
        debnext:= (debnext+1) mod debug_max;
        write('rpack: len:',len,' num:',num,' ptype:',ptype);
      end; (* if *)
  end; (* rpack *)

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