kermit.columbia.edu/kermit.columbia.edu.tar/kermit.columbia.edu/ucsdterak/kermit.text

Text File | 1984-04-10 | 37KB | 1,141 lines

program kermit;

(* $R-*) (* turn range checking off *)
(*$S+*) (* turn swapping on *)
(* $L+*)
(*$U PARSELIB.CODE*)
USES PARSER;

const blksize = 512;
      oport = 8;          (* output port # *)
      clearscreen = 12;   (* charcter which erases screen *)
      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 *)
      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 *)
      rqsize = 5000;      (* input queue size *)
      qsize1 = 5001;      (* qsize + 1 *)
      eoln_sym = 13;      (* pascal eoln sym *)
      back_space = 8;     (* pascal backspace sym *)

(* 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 queue = record (* input queue *)
                 qsize: integer;
                 inp: integer;
                 outp: integer;
                 maxchar: integer;
                 data: packed array[0..rqsize] of char;
               end; (* queue *)
     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 *)

var kq, rq: queue;
    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 *)
    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;

function read_ch(var q: queue; var ch: char): boolean;
forward;

procedure clear_buf(var q: queue);
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_int_rec; var q: queue): boolean;
forward;

function getsoh(var q: queue): boolean;
forward;

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

procedure read_str(var q: queue; var s: string);
forward;

procedure show_parms;
forward;

(*$I HELP.TEXT*)
(*$I SENDSW.TEXT*)
(*$I RECSW.TEXT*)

procedure rcvinit(var q: queue; size: integer);
  external;

procedure rcvfinit;
  external;

procedure kbdinit(var q: queue; size: integer);
  external;

procedure kbdfinit;
  external;

procedure sendbrk;
  external;

procedure read_str(*var q: queue; var s: string*);

(* 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(kq,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 *)

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

(* exclisive 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);
    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);
        write(chr(27),'K');         (* erase to end of line *)
        write(s);
        for i := 1 to 2000 do ;                (* 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(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 *)
    if ch <> chr(lf) then
      begin
        unitwrite(1,ch,1)
      end (* if *)
  end; (* echo *)

procedure clear_buf(*var q: queue*);

(* empties the buffer input buffer *)

  begin
    q.outp := q.inp
  end; (* clear_buf *)

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_int_rec;
    s: string;

  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    (* if character is control quote *)
          begin
            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 = 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.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    (* 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_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-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.ch := filebuf[bufpos];      (* get a character *)
            bufpos := bufpos + 1;         (* increase buffer pointer *)
            if (r.i = dle) 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 - 5) 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                          (* 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 *)
    eol := 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
      begin
        if i = 80 then
          begin
            gotoxy(0,debugline+1);
            write(chr(27),'K');
          end; (* if *)
        write(p[i])
      end; (* for *)
    for i := 1 to 2000 do ;
  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(rq,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
        unitwrite(oport,padchar,1);          (* 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] := eol;

    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);        (* send the packet out *)

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

function read_ch(*var q: queue; var ch: char): boolean*);

(* read a character from an input queue *)

  begin
    with q do
      begin
        if (inp <> outp) then            (* if a char there *)
          begin
            ch := data[outp];              (* get the char *)
            outp := (outp + 1) mod qsize1; (* increment buffer pointer *)
            read_ch := true;               (* and return true *)
          end (* if *)
        else                             (* otherwise *)
            read_ch := false;              (* return false *)
      end (* with *)
  end; (* read_ch *)

function getch(*var r: char_int_rec; var q: queue): 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;
    with q do
      begin
        repeat
            count := count + 1;
        until (inp <> outp) or (count > maxtry);    (* wait for a character *)
        if (count > maxtry) then                    (* if wait too long then *)
            exit(getch);                              (* get out of here *)
        r.ch := data[outp];                         (* get the character *)
        outp := (outp + 1) mod qsize1;              (* increment pointer *)
        r.i := aand(r.i,127);                       (* strip parity from char *)
        getch := (r.ch <> chr(soh));                (* return true if not SOH *)
      end (* with *)
  end; (* getch *)

function getsoh(*var q: queue): boolean*);

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

const maxtry = 10000;

var ch: char;
    count: integer;

  begin
    count := 0;
    get_soh := true;
    with q do
      begin
        repeat
            repeat
                count := count + 1
            until (inp <> outp) or (count > maxtry); (* wait for a character *)
            if (count > maxtry) then
              begin
                get_soh := false;
                exit(get_soh)
              end; (* if *)
            ch := data[outp];                        (* get the character *)
            outp := (outp + 1) mod qsize1;           (* increment pointer *)
            ch := chr(aand(ord(ch),127));            (* strip parity of char *)
        until (ch = chr(SOH))                        (* if not SOH, get more *)
    end (* with q *)
  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;

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

  begin
    count := 0;

    if not getsoh(rq) 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 (* 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,rq) 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,rq) 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,rq) 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,rq) 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,rq) 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 *)

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(kq,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);
              unitwrite(oport,ch,1)
            end (* if *)
        end (* else if *)
      else                        (* anything else: ignore *)
          write(chr(bell))
    end; (* read_esc *)

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

        if read_ch(kq,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);
                unitwrite(oport,ch,1)     (* 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
    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');
                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);
        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;
    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;
    rcvinit(rq,rqsize);
    kbdinit(kq,rqsize);
  end; (* initialize *)

procedure closeup;

  begin
    kbdfinit;
    rcvfinit;
    writeln(chr(clear_screen))
  end; (* closeup *)

  begin (* kermit *)
    initialize;
    repeat
        write('Kermit-UCSD> ');
        readstr(kq,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 *)
     until (verb = exitsym) or (verb = quitsym);
     closeup
   end. (* kermit *)