Columbia Kermit/kermit.zip/pub/ucsdwdme/kermit.text

Text File | 2020-01-01 | 19KB | 565 lines

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