PROGRAM kermit;                                         {$NO GLOBALS}
{
Copyright (C) 1986, Trustees of Columbia University in the City of New
York.  Permission is granted to any individual or institution to copy
or use this program except for explicitly commercial purposes, provided
this copyright notice is retained.

The Kermit file transfer protocol was developed at Columbia University.
It is named after Kermit the Frog, star of the television series THE
MUPPET SHOW; the name is used by permission of Henson Associates, Inc.
"Kermit" is also Celtic for "free".  KERMIT is available for many
systems for only a nominal fee from Columbia and from various user
group organizations, such as DECUS and SHARE.

Author: Paul W. Madaus
        Johnson Controls, Inc.
        507 E. Michigan St.
        Milwaukee, WI  53201
        (414) 274-4528

  THIS VERSION OF KERMIT SOURCE WAS ORIGINALLY DESIGNED TO RUN ON THE
  SPERRY(UNIVAC) 1100.  I HAVE CHOSEN TO CONVERT AND IMPLEMENT THIS
  VERSION OF KERMIT ONTO THE TI-990 DX10 SYSTEMS.  THE CONVERSION OF
  SYSTEM SPECIFIC PROCEDURES WAS STRAIGHTFORWARD, THE BASIC PROTOCOL
  OF THE UNIVAC VERSION WAS WRITTEN IN STANDARD PASCAL, AND OF ALL THE
  VERSIONS TESTED FOR CONVERSION, THE UNIVAC VERSION PRODUCED AN
  ACCEPTABLE AMOUNT OF ERRORS UPON INITIAL DX10 COMPILATION(not a
  deciding factor - but very influential).  BEFORE CONTINUING FURTHER,
  I WISH TO CREDIT THE ORIGINAL UNIVAC VERSION(2.0) OF THIS PROGRAM TO:

                     Edgar Butt         (last known address)
                     Computer Science Center
                     University of Maryland
                     College Park, Maryland 20742
                     Phone (301) 454-2946

  MY METHOD OF RE-DESIGN WILL CONSIST OF REMOVAL OR CONVERSION OF
  ALL UNIVAC SYSTEM DEPENDENT SOFTWARE, ADDITION OF A COMMAND
  PARSING MECHANISM, ADDITION OF INTERACTIVE COMMAND CONTROL,
  ADDITION OF SEVERAL NEW KERMIT COMMANDS, ADDITION OF SIMPLE TTY TYPE
  TERMINAL EMULATION VIA CONNECT CMD, ADDITION OF REMOTE AS WELL AS
  LOCAL KERMIT EXECUTION, AND ADDITION OF A PASCAL XOR FUNTION FOR
  7th AND 8th BIT SETTING AND RESETTING.  THIS PROGRAM MAKES USE OF
  TI PASCAL EXTENSIONS BUT DOES NOT INCLUDE ANY NON-TI PASCAL
  STRUCTURES.  PROGRAM WAS COMPILED AND LINKED AT DX10 REL. 3.7.0 AND
  DX10 PASCAL REL. 1.8.0.  THE TI PASCAL CONFIGURATION PROCESS WAS
  NOT USED ONLY FOR GREATER SIMPLICITY AND EASIER PORTABILITY.
  < more comments to follow in documentation... >
}

CONST

               { NEXT TWO CONSTANTS USED IN CONNECT FOR XOFF TUNING }
  xoff_threshold=800; { NO. OF CHARS TO RECEIVE BEFORE SENDING XOFF }
    buf_threshold=1000;    { GUARD TO AVOID OVERFILLING CHAR BUFFER }

    maxtry = 5;
    maxbuf = 200;
    maxflen=50;                          { MAXIMUM FILE NAME LENGTH }
    maxwrt = 132;

    ascnul = 0;
    ascsoh = 1;
    ascbs = 8;
    asclf = 10;
    asccr = 13;
    ascsp = 32;                                                   { }
    ascns = 35;                                                   {#}
    ascamp = 38;                                                  {&}
    ascast = 42;                                                  {*}
    ascper = 46;                                                  {.}
    ascb = 66;                                                    {B}
    ascc = 67;                                                    {C}
    ascd = 68;                                                    {D}
    asce = 69;                                                    {E}
    ascf = 70;                                                    {F}
    ascg = 71;                                                    {G}
    asch = 72;                                                    {H}
    asci = 73;                                                    {I}
    ascl = 76;                                                    {L}
    ascn = 78;                                                    {N}
    asco = 79;                                                    {O}
    ascr = 82;                                                    {R}
    ascs = 83;                                                    {S}
    asct = 84;                                                    {T}
    ascx = 88;                                                    {X}
    ascy = 89;                                                    {Y}
    ascz = 90;                                                    {Z}

    asctil = 126;                                                 {~}
    ascdel = 127;                                            {rubout}

    mark = ascsoh;
    crlf='#0D#0A';

                                          { DX10 SVC I/O SUBOPCODES }
      asslun = #91;                 { ASSIGN LUNO SVC I/O SUBOPCODE }
    opnrwd = #03;                   { OPEN REWIND SVC I/O SUBOPCODE }
    readas = #09;                    { READ ASCII SVC I/O SUBOPCODE }
    writas = #0B;                   { WRITE ASCII SVC I/O SUBOPCODE }
    moddev= #15;                    { MODIFY DEVICE CHARACTERISTICS }
    rfc=#05;                            { READ FILE CHARACTERISTICS }
    genluno=#04;                           { GENERATE LUNO FLAG SET }
    lunass=#80;             { LUNO ASSIGNED BIT FOR PDT STATUS WORD }

    ret_sys_info=#3F;                      { RETURN SYSTEM INFO SVC }
    pdt_memory=1;                           { RETURN PDT STRUCTURES }

TYPE

  ascval = 0..255;                                         { A BYTE }

                  { WE'LL NEED STATIC LENGTH STRING BUFFERS ON DX10 }
  char2=PACKED ARRAY[1..2]OF char;
  char4=PACKED ARRAY[1..4]OF char;
  char12=PACKED ARRAY[1..12]OF char;
  char40=PACKED ARRAY[1..40]OF char;
  char80=PACKED ARRAY[1..80]OF char;
  flen=PACKED ARRAY[1..maxflen]OF char;
  scistring=PACKED ARRAY[0..10]OF char;

  byte6=PACKED ARRAY[1..6]OF ascval;          { FILLERS AND OFFSETS }
  byte12=PACKED ARRAY[1..12]OF ascval;
  byte16=PACKED ARRAY[1..16]OF ascval;
  byte18=PACKED ARRAY[1..18]OF ascval;
  byte28=PACKED ARRAY[1..28]OF ascval;
  byte60=PACKED ARRAY[1..60]OF ascval;

  kermitstates = (kcommand,
    fininit,
    byeinit,
    getinit,
    wexit,
    kexit,
    cexit,                                       { EXIT TO CMD MODE }
    sinitiate,
    sheader,
    sdata,
    sbreak,
    rcv,
    rinitiate,
    rheader,
    rdata);
  filestatus = (closed, open, endfile);

  ablk=PACKED RECORD                            { ABORT I/O CALLBLK }
    op,lun:ascval
    END;

  wblk=PACKED RECORD                                 { WAIT I/O SVC }
    op,err:ascval;
    addr:integer
    END;

  w1blk=PACKED RECORD                 { WAIT ANY I/O COMPLETION SVC }
    op:ascval;
    fil1,fil2,fil3:ascval                            { ZERO FILLERS }
    END;

  eflags = SET OF                                      { EDIT FLAGS }
  (pass,etx,esc,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14,r15);

  pblk=PACKED RECORD                             { PASSTHRU CALLBLK }
    resv1:integer;
    eflg:eflags;
    resv2:integer
    END;

  rfcblk=PACKED RECORD              { FOR READ FILE CHARACTERISTICS }
    fil1,fil2,fil3:integer;
    filesize:longint
    END;

  ascbuf = RECORD
    ln: integer;
    ch: PACKED ARRAY[1..maxbuf] OF
      ascval
    END;

  sbits = SET of 0..35;
  btype=ARRAY[1..16] OF integer;               { FOR DISPLAY-ACCEPT }

  suflags= SET OF                                       { SVC FLAGS }
  (bsy,err,eofil,evnt,f1,f2,f3,f4,qret,rep,f5,f6,f7,opn,ext,blnk);

  exflags=SET OF                        { EXTENDED CALL BLOCK FLAGS }
    (fstrt,inten,blink,graph,asci8,tedit,beep,right,curpos,filchr,
      noinit,trmchr,noecho,chrval,flderr,wbeep);

  svcblk = PACKED RECORD                            { SVC CALLBLOCK }
    svc,                                               { SVC OPCODE }
      stat,                                           { STATUS CODE }
      subop,                                    { SVC I/O SUBOPCODE }
      lun:ascval;                                            { LUNO }
    flags:suflags;                          { SYSTEM AND USER FLAGS }
    buf:integer;                              { DATA BUFFER ADDRESS }
    lrl:integer;                            { LOGICAL RECORD LENGTH }
    cc:integer;                                   { CHARACTER COUNT }
    fil1:integer;                                        { NOT USED }
        { EXTENDED CALL BLOCK BEGINS HERE - RESERVED FOR FUTURE USE }
    xblk:exflags;                                        { NOT USED }
    filorflg:ascval;                { FILL CHAR OR ASSIGN LUNO FLAG }
    event:ascval;                                      { EVENT BYTE }
    crow:ascval;                            { CURSOR POSITION - ROW }
    ccol:ascval;                            { CURSOR POSITION - COL }
    frow:ascval;                                { FIELD START - ROW }
    fcol:ascval;                                { FIELD START - COL }
    devaddr:integer;               { DEVICE POINTER FOR ASSIGN LUNO }
    fil2,fil3:integer                                    { NOT USED }
    END;

  svcptr=@svcblk;                      { SVC POINTER TYPE FOR SCB$A }

  waitblk = PACKED RECORD              { WAIT FOR I/O SVC CALLBLOCK }
    opcode:ascval;                                     { SVC OPCODE }
    stat:ascval;                                            { ERROR }
    svcaddr:integer                   { ACTUAL SVC I/O ADDRESS (+2) }
    END;

  bytebits=SET OF                  { 16 BITS TO A WORD - FOR XORING }
  (b15,b14,b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,b2,b1,b0);

  svccbt = PACKED RECORD  { SVC BLOCK FOR RETURN SYSTEM INFORMATION }
    opcode,                                                { OPCODE }
      error,                                               { STATUS }
      data_type,                    { TYPE OF STRUCTURE TO RETRIEVE }
      flags:ascval;                                         { FLAGS }
    index,                                       { STRUCTURE NUMBER }
      read_addr,                            { OFFSET INTO STRUCTURE }
      buff_len,                                  { READ BUFFER SIZE }
      ret_len,                           { NUMBER OF BYTES RETURNED }
      bufaddr,                                { READ BUFFER ADDRESS }
      reserved:integer
    END;
                                                                   {}
  pdtrec=PACKED RECORD
     { BASED ON CURRENT PDT STRUCTURE - NOT AT ALL LIKELY TO CHANGE }
    addr:integer;
    fil0:byte6;                                            { FILLER }
    bsy:ascval;                                { CONTAINS BUSY BITS }
    fil1:ascval;                               { OTHER HALF OF BYTE }
    fil2:byte18;                                           { FILLER }
    tiline:ascval;           { NEED UPPER PORTION OF TILINE ADDRESS }
    fil3:ascval;                                           { FILLER }
    fil4:byte12;                                           { FILLER }
    devnam:char4;                                     { DEVICE NAME }
    fil5:byte60;                                           { FILLER }
    addr2:integer;                 { SHOULD BE SAME THIS PDT'S ADDR }
    fil6:byte28;                                           { FILLER }
    vdtsc1:bytebits;                        { PORT INITIALIZED WORD }
    fil7:byte16;                                           { FILLER }
    init:bytebits;                          { PORT INITIALIZED WORD }
    fil8:byte60                                            { FILLER }
    END;

  buf=PACKED ARRAY[1..1024]OF char;            { ADJUST IF YOU WISH }

VAR

                                         { I HOPE I USE ALL THESE!! }
  iniflg: boolean;              {Set true after first initialization}
  server: boolean;
  state: kermitstates;
  filbuf,wrtbuf,redbuf,sndbuf,rcvbuf,cmdbuf: ascbuf;
  redix: integer;
  rfile,wfile,lfile: text;                    { DX10 TEXT FILE TYPES}
  wbfile:FILE OF char80;                        { BINARY WRITE FILE }
  rbfile:FILE OF char80;                         { BINARY READ FILE }
  bbuf:char80;                                 { BINARY DATA BUFFER }
  bptr:integer;                              { CURRENT BBUF POINTER }
  fname,rfname,lname,ioname,namebuf,tname:flen;   { DX10 FILE PATHS }
  fnlen,rfnlen,iolen,lnlen,tlen:integer;
  rstatus, wstatus,lstatus: filestatus;
  seq,rcvseq: integer;
  rlen: integer;
  stype,rcvtyp: ascval;
  numtry: integer;
  numcserr: integer;
  ineoln: boolean;
  sndonly: boolean;
  sndlog, rcvlog, wrtlog, redlog: boolean;
  creol: boolean;
  lfeol: boolean;
  crlfeol: boolean;
  gotcr: boolean;

  locbsiz: ascval;
  loctout: ascval;
  locnpad: ascval;
  locpad: ascval;
  loceol: ascval;
  locquo: ascval;
  optqu8: ascval;
  locqu8: ascval;
  locrep: ascval;

  rembsiz: ascval;
  remdsiz: ascval;
              {Maximum number of data characters to send (remBsiz-3)}
  remtout: ascval;
  remnpad: ascval;
  rempad: ascval;
  remeol: ascval;
  remquo: ascval;
  remqu8: ascval;
  remrep: ascval;

  oval:boolean;                               { IOTERM SETTING SAVE }
  blk:btype;                      { FOR DISPLAY-ACCEPT CLEARSCREENS }
  lun:integer;                                    { FOR INITSCREENS }
  eolflg:boolean;          { DX10 RECORDS DO NOT CONTAIN CRs OR LFs }
  pcbuf,tcbuf:char2;                                    { CHAR BUFS }
  ts:svcblk;                           { TERMINAL SVC I/O CALLBLOCK }
  ps:svcblk;                               { PORT SVC I/O CALLBLOCK }
  sp:svcptr;                          { SVCBLK POINTER FOR MISC I/O }
  s:svcblk;
  rs:rfcblk;                     { READ FILE CHARACTERISTICS BUFFER }
  recsred:integer;                 { NUMBER OF RECORDS READ IN FILE }
  percent:real;                    { PERCENT OF FILE SENT TO REMOTE }
  a:ablk;                                       { ABORT I/O CALLBLK }
  w:wblk;                                        { WAIT I/O CALLBLK }
  w1:w1blk;                                  { WAIT ANY I/O CALLBLK }
  p:pblk;                            { EDIT FLAG BLOCK FOR PASSTHRU }
  bsbuf:char40;                    { BIG USER MESSAGE STRING BUFFER }
  ssbuf:char12;       { SMALL STRING BUFFER - MAINLY FOR THE PROMPT }
  cond:boolean;                                 { CONNECTED BOOLEAN }
  pktsnt:integer;                 { A RUNNING COUNT OF PACKETS SENT }
  headok:boolean;                         { HEADER PACKET SENT FLAG }
  sending:boolean;                                 { SENDING A FILE }
  receiving:boolean;                             { RECEIVING A FILE }
  local:boolean;                         { MODE WE ARE OPERATING IN }
  syn,val:scistring;                          { FOR SYNONYM SETTING }
  perr:integer;                                  { GET PARM ERR BUF }
  isc:boolean;                       { ISC TYPE TERMINAL - OPTIONAL }
  binary:boolean;                           { BINARY TYPE FILE FLAG }
  reof:boolean;                    { READ FILE EOF ENCOUNTERED FLAG }

                                     { FORWARD REFERENCE PROCEDURES }

PROCEDURE error(msg:char40);forward;   { 40 CHARACTER ERROR MESSAGE }

                                    { TI PASCAL EXTERNAL PROCEDURES }
 { THESE FIRST TWO PROCEDURES DEPEND ON THE EXISTENCE OF TIFORMS ON }
      { YOUR DX10 SYSTEM AND ARE OPTIONAL SINCE THEY ONLY CLEAR THE }
         { SCREEN UPON KERMIT INITIALIZATION.  YOU MAY REMOVE THEM. }
PROCEDURE initscreen(VAR block:btype;
  unit : integer );external;                              { TIFORMS }

PROCEDURE clearscreen( VAR block : btype);external;       { TIFORMS }

PROCEDURE delay(l:longint);external;            { DELAY L millisecs }

PROCEDURE p$parm(num:integer;         { GET PARMS FROM CALLING PROC }
  VAR str:PACKED ARRAY[1..?]OF char;VAR err:integer);external;

PROCEDURE store$syn(VAR syn,value:scistring);external;

PROCEDURE set$acnm(locvar,locfil:integer);external;
                                            { SET PASCAL FILE NAMES }
PROCEDURE setpdt(w1addr,w2addr:integer);external;     { NOT TI PROC }
   { ASSEMBLY - SET PORT INIT BITS FOR 2 WORDS IN PDT IF OPEN FAILS }
PROCEDURE svc$(call_blk_addr:integer);external;       { PROCESS SVC }

FUNCTION scb$a(fileloc:integer):svcptr;external;
                                      { GET TI FILE CHARACTERISTICS }
{ ***************************************************************** }

PROCEDURE passt(VAR s:svcblk;onoff:boolean);
     { SET OR RESET THE PASSTHRU MODE - DEVICE MUST ALREADY BE OPEN }
BEGIN                                                       { PASST }
                                       { SET TERMINAL PASSTHRU MODE }
  IF onoff THEN
    p.eflg:=[pass]                              { SET PASSTHRU FLAG }
  ELSE
    p.eflg:=[];                               { RESET PASSTHRU FLAG }
  p.resv1:=0;
  p.resv2:=0;
  s.flags:=[];                                { WAIT FOR COMPLETION }
  s.subop:=moddev;                    { SET MODIFY DEVICE SUBOPCODE }
  s.buf:=location(p);
  s.cc:=6;
  svc$(location(s))                             { SET PASSTHRU MODE }
END;                                                        { PASST }

PROCEDURE abort(VAR s:svcblk);
BEGIN
  IF bsy IN s.flags THEN
    BEGIN
      a.op:=15;                         { SET ONCE ABORT I/O OPCODE }
      a.lun:=s.lun;
      svc$(location(a));
      w.op:=1;                           { SET ONCE WAIT I/O OPCODE }
      w.err:=0;                { NOW WAIT FOR THIS ABORT COMPLETION }
      w.addr:=location(s)+2;
      svc$(location(w))
    END
END;

PROCEDURE chktrm(devname:char4);

VAR
  sys_info : svccbt;                             { USED TO GET PDTs }
  pdt_addr :integer;                             { PDT ADDRESS SAVE }
  pdt:pdtrec;                               { GENERAL PDT STRUCTURE }
  vdtaddr,iniaddr:integer; { ADDRESS BUFFERS THE TWO PDT INIT WORDS }

BEGIN                                                      { CHKTRM }

  vdtaddr:=-1;                        { NOT A VALID PDT ADDRESS YET }
  iniaddr:=-1;                        { NOT A VALID PDT ADDRESS YET }
  IF devname[1]='S' AND devname[2]='T' THEN
    WITH sys_info DO                       { SEARCH FOR DEVICES PDT }
      BEGIN
        opcode:=ret_sys_info;
        error:=0;
        data_type:=pdt_memory;            { RETRIEVE PDT STRUCTURES }
        flags:=0;
        index:=0;                  { START AT BEGINNING OF PDT LIST }
        read_addr:=0;                             { OFFSET INTO PDT }
        buff_len:=size(pdt);                  { SIZE OF READ BUFFER }
        ret_len:=0;                   { ACTUAL NUMBER OF BYTES READ }
        bufaddr:=location(pdt);
        reserved:=0;
        REPEAT
          index:=succ(index);                  { GET NEXT PDT ENTRY }
          pdt_addr:=pdt.addr;                 { POINTER TO NEXT PDT }
          svc$(location(sys_info));                  { GET NEXT PDT }
          IF pdt.devnam=devname AND error=0 THEN
            BEGIN                                { FOUND THE DEVICE }
              IF index=1 THEN   { IF FIRST PDT ON LIST THEN WE HAVE }
                pdt_addr:=pdt.addr2;   { TO GET ITS ADDR WITHIN PDT }
              IF (pdt.bsy=0 OR pdt.bsy=lunass) AND
{ ONLY ALLOW LUNO ASSISNED BIT SET IN PDT STATUS WORD i.e. not busy }
                  pdt.tiline>= #F8 AND
    { MAKE SURE STATION COMING OFF CI403 BOARD --> TILINE TYPE ADDR }
                  NOT (b2 IN pdt.vdtsc1 AND    { SEE IF ONE OR BOTH }
                  b2 IN pdt.init) THEN   { WORDS NEEDS MODIFICATION }
{ ALL THE ABOVE CONDITIONS MUST BE SATISFIED FOR THIS FINAL ATTEMPT }
{ TO OPEN A 931 PORT TO EVEN BE ATTEMPTED.  ADDRESSES OF WORDS WILL }
   { BE SET THAT NEED BIT MODIFICATION, ELSE ADDRESSES REMAIN AT -1 }
                BEGIN
                  IF NOT b2 IN pdt.vdtsc1 THEN       { NEED BIT SET }
                    vdtaddr:=pdt_addr+location(pdt.vdtsc1)-location(
                        pdt
                        );  { SO SET ADDRESS OF WORD TO BE MODIFIED }
                  IF NOT b2 IN pdt.init THEN   { SAME FOR THIS WORD }
                    iniaddr:=pdt_addr+location(pdt.init)-location(pdt
                        );
                  setpdt(vdtaddr,iniaddr)
                                         { SET APPROPRIATE PDT BITS }
                END
            END
        UNTIL pdt.addr=0 OR pdt.devnam=devname OR error<>0
      END
END;                                                       { CHKTRM }

PROCEDURE initio(dev:integer;VAR s:svcblk);

VAR
  devnam:char4;                               { DEVICE NAME TO OPEN }

BEGIN                                                      { INITIO }
  IF s.stat=0 THEN                     { CHECK FOR ANY PREVIOUS ERR }
    WITH s DO
      BEGIN
        svc:=0;                                           { SVC I/O }
        subop:=asslun;                      { ASSIGN LUNO OPERATION }
        lun:=0;                         { SYSTEM WILL PICK THE LUNO }
        flags:=[];                         { USE EXTENDED CALLBLOCK }
        buf:=0;                                             { CLEAR }
        lrl:=0;                                             { CLEAR }
        cc:=0;                                              { CLEAR }
        fil1:=0;                                            { CLEAR }
        xblk:=[];                                           { CLEAR }
        filorflg:=genluno;         { SYSTEM TO GENERATE LUNO NUMBER }
        event :=0;                                          { CLEAR }
        crow :=0;                                           { CLEAR }
        ccol :=0;                                           { CLEAR }
        frow :=0;                                           { CLEAR }
        fcol :=0;                                           { CLEAR }
        devaddr:=dev;                         { DEVICE NAME POINTER }
        fil2:=0;                                            { CLEAR }
        fil3:=0;                                            { CLEAR }
        svc$(location(s));                        { PERFORM THE SVC }
        IF stat=0 THEN                   { LUNO ASSIGNMENT COMPLETE }
          BEGIN                               { OPEN DEVICE FOR I/O }
            filorflg :=0;                                   { CLEAR }
            devaddr:=0;                                     { CLEAR }
            subop:=opnrwd;   { SET OPEN REWIND OPERATION FOR DEVICE }
            flags:=[qret];      { QUICK RETURN SO WE CAN CHECK OPEN }
            svc$(location(s));                    { OPEN THE DEVICE }
            delay(500);           { ALLOW OPEN OF DEVICE TO PROCEED }
            IF bsy IN flags THEN
              BEGIN                         { OPEN NOT COMPLETE YET }
                delay(3000);                       { WAIT SOME MORE }
                IF bsy IN flags THEN
                  BEGIN
                    abort(s);
                            { ABORT AND CHECK PORT'S PDT INIT WORDS }
                    stat:=0;
                    IF dev=location(ioname) THEN
                      BEGIN           { PDT MAY NEED INITIALIZATION }
                        FOR i:=1 TO 4 DO
                          devnam[i]:=ioname[(i+1)];
                        chktrm(devnam)
                     { CHECK AND POSSIBLY MODIFY PDT PORT INIT BITS }
                      END;
                    svc$(location(s));       { TRY ONE MORE ATTEMPT }
                    delay(2000);
                    IF bsy IN flags THEN
                      stat:= #FF   { COULDN'T OPEN DEVICE SET ERROR }
                  END
              END;
            flags:=[];                                { RESET FLAGS }
            IF stat=0 AND dev=location(ioname) THEN
              passt(s,true);     { SET PASSTHRU MODE ON REMOTE PORT }
            lrl:=1                                 { FOR MOST READS }
          END
      END
END;                                                       { INITIO }

          { IN SOME PROCEDURES I CALL SVC$ DIRECTLY FOR QUICKER I/O }
PROCEDURE readdev(VAR rs:svcblk;wait:boolean;bufloc:integer);
BEGIN
  rs.subop:=readas;
  rs.buf:=bufloc;
  IF wait THEN                                { WAIT I/O COMPLETION }
    rs.flags:=rs.flags-[qret]
  ELSE
    rs.flags:=rs.flags+[qret];
  svc$(location(rs))                                  { DO THE READ }
END;

PROCEDURE writdev(VAR rs:svcblk;wait:boolean;
  numchars:integer;bufloc:integer);
BEGIN
  rs.subop:=writas;
  rs.buf:=bufloc;
  rs.cc:=numchars;
  IF wait THEN                                { WAIT I/O COMPLETION }
    rs.flags:=rs.flags-[qret]
  ELSE
    rs.flags:=rs.flags+[qret];
  svc$(location(rs))                                 { DO THE WRITE }
END;

FUNCTION devbsy(ds:svcblk):boolean;
BEGIN
  devbsy:=bsy IN ds.flags                      { DEVICE DOING I/O ? }
END;

                                                       {$NO WARNINGS}
FUNCTION bxor(i:integer;b:ascval):ascval;              { XOR 128/64 }

VAR
  a:bytebits;                             { BIT MANIPULATION NEEDED }

BEGIN                                                        { BXOR }
  a:= b::bytebits;              { TYPE CONVERT FOR BIT MANIPULATION }
  IF i = 64 THEN
    BEGIN                                                  { XOR 64 }
      IF ( b6 IN a ) THEN
        a:=a - [b6]                                   { RESET BIT 6 }
      ELSE
        a:=a+ [b6]                                      { SET BIT 6 }
    END;                                                   { XOR 64 }
  IF i = 128 THEN
    BEGIN                                                 { XOR 128 }
      IF ( b7 IN a ) THEN
        a:=a- [b7]                                    { RESET BIT 7 }
      ELSE
        a:=a+[b7]                                       { SET BIT 7 }
    END;                                                  { XOR 128 }
                              { NO OTHER XORS DONE IN THIS PROTOCOL }
  b:=a::ascval;                    { TYPE CONVERT FOR COMPATABILITY }
  bxor:=b                                   { RETURN FUNCTION VALUE }
END;                                                         { BXOR }
                                                          {$WARNINGS}
FUNCTION makechar (i: integer): ascval;

BEGIN
  makechar:=ascsp+i
END;

FUNCTION unchar (a: ascval): integer;

BEGIN
  unchar:=a-ascsp
END;

FUNCTION tog64(a: ascval): ascval;

BEGIN
  tog64:=bxor(64,a)                                {System dependent}
END;

FUNCTION tog128(a: ascval): ascval;

BEGIN
  tog128:=bxor(128,a)                              {System dependent}
END;

FUNCTION checksum (sum: integer): ascval;

BEGIN                        { SINGLE CHARACTER ARITHMETIC CHECKSUM }
  checksum := (((sum MOD 256) DIV 64) + sum) MOD 64
END;

PROCEDURE logopn;                     { OPEN LOG FILE - IF DEMANDED }

BEGIN
  set$acnm(location(lfile),location(lname));
                                             { SET PASCAL FILE NAME }
  rewrite(lfile);                       { OPEN LOG FILE FOR WRITING }
  lstatus:=open;                                   { ASSUME SUCCESS }
  write(lfile,'DX10 KERMIT-990  --- LOGFILE');
  writeln(lfile);
  bsbuf:='LOGGING REQUESTED TO:                   ';
  writdev(ts,true,22,location(bsbuf));
  FOR i:=1 TO ord(lname[1]) DO
    BEGIN
      tcbuf[1]:=lname[(i+1)];
      writdev(ts,true,1,location(tcbuf))
    END;
  tcbuf:='#0D#0A';
  writdev(ts,true,2,location(tcbuf))
END;

PROCEDURE logcls;

BEGIN
  IF lstatus=open THEN
    close(lfile)                               { CLOSE THE LOG FILE }
END;

                                         { Buffer routines - FOLLOW }

PROCEDURE bufinit(VAR buf:ascbuf);

BEGIN
  buf.ln:=0
END;

PROCEDURE putbuf(VAR buf: ascbuf; a:ascval);

BEGIN
  IF NOT (buf.ln<maxbuf) THEN
                     { I THINK THE CAUSE OF THIS ERROR NEEDS FIXING }
    BEGIN            { THIS CONDITION SHOULD BE AVOIDED - FIX LATER }
      error('SIZE OF ASCII BUFFER EXCEEDED           ')
    END
  ELSE
    BEGIN
      buf.ln:=buf.ln+1;
      buf.ch[buf.ln]:=a
    END
END;

PROCEDURE lintobuf(l: flen; len: integer; VAR buf: ascbuf);

BEGIN
  bufinit(buf);
  FOR i:=2 TO (len+1) DO
    putbuf(buf,ord(l[i]))
END;

PROCEDURE buftolin(buf: ascbuf; VAR l:flen; VAR len: integer);

VAR a:ascval;

BEGIN
  len:=buf.ln;
  IF len>maxflen THEN len:=maxflen;
  FOR i:=1 TO len DO
    BEGIN
      a:=buf.ch[i];
      IF a>127 THEN a:=a-127;
      l[(i+1)]:=chr(a)
    END;
  l[1]:=chr(len)                                 { NEED FILE LENGTH }
END;

                     { Process parameters to and from remote Kermit }

PROCEDURE putpar;
VAR temp: ascval;

BEGIN
  bufinit(filbuf);
  putbuf(filbuf,makechar(locbsiz));
  putbuf(filbuf,makechar(loctout));
  putbuf(filbuf,makechar(locnpad));
  putbuf(filbuf,tog64(locpad));
  putbuf(filbuf,makechar(loceol));
  putbuf(filbuf,locquo);
  temp:=ascsp;                        { SO FAR NO EIGHT BIT QUOTING }
  IF locqu8<>0 THEN temp:=locqu8;
  putbuf(filbuf,temp);
  putbuf(filbuf,ascsp);    {Only know how do to 1 character checksum}
  temp:=ascsp;
  IF locrep<>0 THEN temp:=locrep;
  putbuf(filbuf,temp)
END;

PROCEDURE getpar;

BEGIN
  IF rcvbuf.ln > 0 THEN rembsiz:=unchar(rcvbuf.ch[1]);
  IF rcvbuf.ln > 1 THEN remtout:=unchar(rcvbuf.ch[2]);
  IF rcvbuf.ln > 2 THEN remnpad:=unchar(rcvbuf.ch[3]);
  IF rcvbuf.ln > 3 THEN rempad:=tog64(rcvbuf.ch[4]);
  IF rcvbuf.ln > 4 THEN remeol:=unchar(rcvbuf.ch[5]);
  IF rcvbuf.ln > 5 THEN remquo:=rcvbuf.ch[6];
  IF rcvbuf.ln > 6 THEN remqu8:=rcvbuf.ch[7];
    { DONT GET CHCKSUM - WE ARE ONLY SET UP FOR SINGLE CHAR CHCKSUM }
  IF rcvbuf.ln > 8 THEN remrep:=rcvbuf.ch[9];

" remdsiz:=rembsiz-3;
  remdsiz:=rembsiz-6;      { SEND LESS DATA - EXCEEDING REMOTE BUFS }
  IF state=rinitiate THEN         {Our parameters have not been sent}
    BEGIN
      IF locqu8=0 THEN remqu8:=0;      { WE DONT WANT 8-BIT QUOTING }
      IF ((32<remqu8) AND (remqu8<63)) OR ((95<remqu8) AND (remqu8<
          127))
          AND (remqu8<>remquo) THEN
        BEGIN
          locqu8:=ascy
                      {Remote Kermit specified 8-bit quote character}
        END
      ELSE
        IF remqu8=ascy THEN
          BEGIN
            locqu8:=ascamp;
            IF (locqu8=remquo) OR (locqu8=remrep) THEN locqu8:=asctil;
            IF (locqu8=remquo) OR (locqu8=remrep) THEN locqu8:=ascns;
            remqu8:=locqu8
          END
        ELSE
          BEGIN
            locqu8:=0;                       {Don't do 8-bit quoting}
            remqu8:=0
          END;
      IF ((32<remrep) AND (remrep<63)) OR ((95<remrep) AND (remrep<
          127))
          AND (remrep<>remquo) AND (remrep<>remqu8) AND (locrep<>0)
          THEN
        BEGIN
          locrep:=remrep                  {Agree to do repeat counts}
        END
      ELSE
        BEGIN
          remrep:=0;
          locrep:=0
        END
    END
  ELSE                        {Our parameters have already been sent}
    BEGIN
      IF (remqu8<>ascy) AND (remqu8<>locqu8) THEN
        BEGIN
          locqu8:=0                          {Don't do 8-bit quoting}
        END;
      IF remrep<>locrep THEN
        locrep:=0                            {Don't do repeat counts}
    END
END;

PROCEDURE rcvpkt;

{ rcvtyp = 0 - no soh encountered
           1 - soh encountered, but packet incomplete
           2 - Checksum error
            Other - ASCII value of packet type from good packet

   rcvseq = -1 - Not a valid packet
            0...63 - Sequence number from valid packet

   rcvbuf.ln - number of ascii values input since last SOH

   rcvbuf.ch - array of ascii values input                        }

VAR
  c:PACKED ARRAY[1..2]OF char;
  av,rt: ascval;
  rst,rsq,cs:integer;
  cct:integer;
  dlay:integer;                                   { A DELAY COUNTER }
  dtim:longint;                              { VARIABLE DELAY TIMES }

BEGIN
  cct:=0;
  IF rcvlog THEN write(lfile,'RCV <');
  rcvtyp:=0;
  rcvseq:=-1;                                 { NO VALID PACKET YET }
  rst:=0;
  ineoln:=false;
  bufinit(rcvbuf);
{ FOR OPTIMAL SPEED WE WILL AVOID THE PROCEDURE CALL TO READ A CHAR }
  ps.subop:=readas;
  ps.buf:=location(c);
  ps.flags:=ps.flags+[qret];
  svc$(location(ps));                              { QUEUE THE READ }
  WHILE NOT ineoln AND cct<230 DO
                { UNTIL END OF PACKET OR UNTIL NO SOH LIMIT REACHED }
    BEGIN
      dlay:=0;                                { CLEAR DELAY COUNTER }
      dtim:=0;                                   { NO INITIAL DELAY }
                   { THIS WHILE LOOP MAY BE FINE TUNED IF NECESSARY }
      WHILE (bsy IN ps.flags) AND dtim<=200 DO
        BEGIN
          delay(dtim);            { VARIABLE DELAY BEGINS WITH ZERO }
          dlay:=succ(dlay);                { INCREMENT TIME COUNTER }
              { THIS DELAY MECHANISM MAY NEED FINE(or GROSS) TUNING }
          IF( (dlay MOD 10) = 0) THEN
            dtim:=dtim+50                   { WAIT LONGER NEXT TIME }
        END;
      IF bsy IN ps.flags THEN
          { READ CHARACTER COULD NOT COMPLETE IN ABOUT FIVE SECONDS }
        ineoln:=true              { SO LEAVE --> RESEND LAST PACKET }
      ELSE                                         { WE READ A CHAR }
        BEGIN
          IF rcvlog THEN
            BEGIN
              IF ps.stat<>0 THEN
                write(lfile,'^^ERR IN PORT READ: ',ps.stat hex,' ^^')
              ELSE
                write(lfile,c[1])
            END;
          cct:=succ(cct);
          av:=ord(c[1]);
                      { WE HAVE THE CHAR - SO REQUEUE THE NEXT READ }
          svc$(location(ps));
                       { QUEUE NEXT READ WHILE PROCESSING LAST CHAR }
          IF av=mark THEN rst:=1;
          CASE rst OF

            0:                    {Mark character never encountered.}
              BEGIN
                putbuf(rcvbuf,av);
              END;

            1:                                      {Mark character.}
              BEGIN
                rcvtyp:=1;
                rcvseq:=-1;
                cct:=0;                           { CLEAR PACKET OK }
                bufinit(rcvbuf);
                rst:=2
              END;

            2:                                {Length of the packet.}
              BEGIN
                cs:=av;                         {Initialize checksum}
                rlen:=unchar(av)-3;
                rst:=3
              END;

            3:                                       {Packet number.}
              BEGIN
                cs:=cs+av;
                rsq:=unchar(av);
                rst:=4
              END;

            4:                                         {Packet type.}
              BEGIN
                cs:=cs+av;
                rt:=av;                    {remember the packet type}
                rst:=5;
                IF rlen=0 THEN
                  rst:=6
              END;

            5:                                        {Data portion.}
              BEGIN
                cs:=cs+av;
                putbuf(rcvbuf,av);
                IF rcvbuf.ln = rlen THEN
                  rst:=6
              END;

            6:                                            {Checksum.}
              BEGIN
                IF checksum(cs)=unchar(av) THEN
                  BEGIN
                    rcvtyp:=rt;
                    rcvseq:=rsq;
                    ineoln:=true        {Ignore the rest of the line}
         { CARRIAGE CONTROL CHAR WILL BE READ FROM NEXT QUEUED READ }
                  END
                ELSE
                  BEGIN
                    numcserr:=numcserr+1;
                    rst:=0;                   {Look for another mark}
                    rcvtyp:=2;              {Indicate checksum error}
                    ineoln:=true                   { RETURN ERR NOW }
                  END
              END
            END                                              { CASE }
        END                          { ELSE - NOT BSY --> CHAR READ }
    END;
  IF rcvlog THEN
    writeln(lfile,'>');
  IF cct>=230 THEN
 { AFTER RECEIVING 230 UNSUCCESSFUL CHARACTERS - IT'S TIME TO RESET }
    error('#0D#0A230 CHARS AND STILL NO VALID PACKET.#0D#0A');
  IF bsy IN ps.flags THEN
    abort(ps)                            { CLEAN UP BEFORE WE LEAVE }
END;                                                       { RCVPKT }

                                { Build and send packets PROCEDURES }

PROCEDURE makepacket(ptype: ascval; seq, len: integer);

VAR c: ascval;
  cs: integer;

BEGIN
  bufinit(sndbuf);
  FOR i:=1 TO remnpad DO         { ADD PAD CHARS IF ANY TO BE ADDED }
    putbuf(sndbuf,rempad);
  putbuf(sndbuf,mark);                                 { SOH MARKER }
  c:=makechar(len+3);
  cs:=c;                                        {Initialize checksum}
  putbuf(sndbuf,c);                              { LENGTH OF PACKET }
  c:=makechar(seq);
  cs:=cs+c;
  putbuf(sndbuf,c);                             { PACKET SEQ NUMBER }
  c:=ptype;
  cs:=cs+c;
  putbuf(sndbuf,c);                                   { PACKET TYPE }
  FOR i:=1 TO len DO
    BEGIN
      c:=filbuf.ch[i];
      cs:=cs+c;
      putbuf(sndbuf,c)                            { ADD PACKET DATA }
    END;
  c:=makechar(checksum(cs));
  putbuf(sndbuf,c);                        { ADD CHECKSUM TO PACKET }
  IF (remeol<>asccr) AND (remeol<>asclf) THEN
    putbuf(sndbuf,remeol)             { EOL MARKER AT END OF PACKET }
END;

PROCEDURE sndpkt;

VAR                           { NEED CONTIGUOUS PACKED DATA FOR SVC }
  tbuf:PACKED ARRAY[1..maxbuf]OF ascval;
  ens:integer;                      { ENCODE PROCEDURE ERROR BUFFER }

BEGIN
  IF sndlog THEN write(lfile,'SND <');
  FOR i:=1 TO sndbuf.ln DO
    BEGIN
      tbuf[i]:=sndbuf.ch[i];                    { PACK DATA FOR SVC }
      IF sndlog THEN                                       { LOG IT }
        write(lfile,chr(sndbuf.ch[i]))
    END;
  tbuf[sndbuf.ln+1]:= #0D;                          { SEND EOL CHAR }
  IF sndlog THEN
    write(lfile,'#0D');                                    { LOG IT }
  writdev(ps,true,(sndbuf.ln+1),location(tbuf)); {WRITE(send) PACKET}
  IF ps.stat<>0 AND sndlog THEN
    write(lfile,'  ERR IN SNDPKT: ',ps.stat hex,'  ');
  IF local THEN
    BEGIN                           { DISPLAY SEND OR RECEIVE STATS }
      IF sending THEN
        BEGIN
                                                       {$NO WARNINGS}
          percent:=recsred/rs.filesize*100;
                                      { PERCENT OF FILE SENT SO FAR }
                                                          {$WARNINGS}
          ssbuf:='     %     #0D';             { DISPLAY % TEMPLATE }
          IF state=sbreak THEN             { DONE SENDING THIS FILE }
            BEGIN
              sending :=false;                  { BREAK OUT OF HERE }
              ssbuf:='100.0%  OK#0D#0A'
            END
          ELSE
            encode(ssbuf,1,ens,percent:5:1);
                                          { PLACE PERCENT IN STRING }
          writdev(ts,true,12,location(ssbuf))
                                         { DISPLAY PERCENT COMPLETE }
        END
      ELSE
        IF receiving THEN
          BEGIN
            pktsnt:=succ(pktsnt);
            ssbuf:='<=#0D#0A        ';
            IF rcvtyp=ascb THEN          { DONE RECEIVING THIS FILE }
              BEGIN
                receiving:=false;
                ssbuf:='  COMPLETE#0D#0A';
                writdev(ts,true,12,location(ssbuf))
              END
            ELSE
              BEGIN
                IF pktsnt>=36 THEN       { NEW LINE FOR NEAT FORMAT }
                  BEGIN
                    writdev(ts,true,4,location(ssbuf));
                    pktsnt:=0
                  END
                ELSE
                  writdev(ts,true,2,location(ssbuf))
              END
          END
    END;
  IF sndlog THEN
    writeln(lfile,'>')
END;

                                           { File output PROCEDURES }

PROCEDURE wrtrec;

VAR
  c:char;

BEGIN
  IF wrtlog THEN write(lfile,'WRT [');
  FOR i:=1 TO wrtbuf.ln DO
    BEGIN
      c:=chr(wrtbuf.ch[i]);               { ASCII VALUE MAY BE >127 }
      IF NOT binary THEN
        write(wfile,c)                             { TEXT CHARACTER }
      ELSE
        BEGIN
          bptr:=succ(bptr);           { ADVANCE BINARY CHAR BUF PTR }
          IF bptr>size(bbuf) THEN            { BUF FULL -> WRITE IT }
            BEGIN
              write(wbfile,bbuf); { WRITE BUF INCLUDING TRAIL BLNKS }
              bptr:=1                               { RESET BUF PTR }
            END;
          bbuf[bptr]:=c                            { STORE OUR CHAR }
        END;
      IF wrtlog THEN
        write(lfile,c)
    END;
  IF NOT binary THEN
    writeln(wfile);
  IF wrtlog THEN writeln(lfile,']');
  bufinit(wrtbuf)
END;

PROCEDURE wrtcls;                                  {System dependent}

BEGIN
  IF wstatus=open THEN
    BEGIN
      IF wrtbuf.ln>0 THEN wrtrec;
      IF binary THEN          { TAKE CARE OF REMAINING BINARY CHARS }
        BEGIN
          FOR i:=(bptr+1) TO (size(bbuf)) DO
            bbuf[i]:=' ';               { BLANK FILL REST OF RECORD }
          write(wbfile,bbuf);            { WRITE LAST BINARY RECORD }
          close(wbfile)
        END
      ELSE
        close(wfile)                 { CLOSE THE FILE BEING WRITTEN }
    END;
  wstatus:=closed
END;

PROCEDURE wrtopn;
VAR
  wstat: boolean;

BEGIN
  wrtcls;
  IF binary THEN
    BEGIN                      { OPEN SPECIAL FILE FOR BINARY CHARS }
    { ACTUALLY WE USE FILE OF CHAR80 TO AVOID TRAIL BLNK TRUNCATION }
      set$acnm(location(wbfile),location(fname));
                                                  { SET PASCAL NAME }
      ioterm(wbfile,oval,false);         { TURN OFF I/O TERM ON ERR }
      rewrite(wbfile);              { I HOPE THEY WANT A CLEAR FILE }
      wstat:= status(wbfile)=0;              { CHECK FOR OPEN ERROR }
      ioterm(wbfile,oval,true)       { TURN BACK ON I/O TERM ON ERR }
    END
  ELSE
    BEGIN               { OPEN NORMAL TEXT FILE FOR NON-BINARY DATA }
      set$acnm(location(wfile),location(fname));
                                                  { SET PASCAL NAME }
      ioterm(wfile,oval,false);          { TURN OFF I/O TERM ON ERR }
      rewrite(wfile);               { I HOPE THEY WANT A CLEAR FILE }
      wstat:= status(wfile)=0;               { CHECK FOR OPEN ERROR }
      ioterm(wfile,oval,true)        { TURN BACK ON I/O TERM ON ERR }
    END;
  IF wstat THEN wstatus:=open;
  bufinit(wrtbuf)
END;

PROCEDURE wrtasc(a:ascval);

BEGIN
  IF wrtbuf.ln >=maxwrt THEN wrtrec;
  putbuf(wrtbuf,a)
END;

PROCEDURE putrec(buf: ascbuf);
                              { Process data portion of data packet }
VAR
  i,repcnt:integer;
  a:ascval;
  qflag: boolean;

BEGIN
  i:=1;
  WHILE i<= buf.ln DO
    BEGIN
      a:=buf.ch[i];
      i:=succ(i);
      repcnt:=1;
      IF a=remrep THEN
        BEGIN                            { REPEAT CHAR SYMBOL FOUND }
          repcnt:=unchar(buf.ch[i]);             { GET REPEAT COUNT }
          i:=succ(i);
          a:=buf.ch[i];                            { CHAR TO REPEAT }
          i:=succ(i)
        END;
      qflag:= a=remqu8;                               { 8th BIT SET }
      IF qflag THEN
        BEGIN                                      { THEN HANDLE IT }
          a:=buf.ch[i];
          i:=succ(i)
        END;
      IF a=remquo THEN
        BEGIN                                         { 7th BIT SET }
          a:=buf.ch[i];
          i:=succ(i);
          IF (a<>remquo) AND (a<>remqu8) AND (a<>remrep) THEN
            a:=tog64(a)
        END;
      IF qflag THEN
        a:=tog128(a);
      FOR j:=1 TO repcnt DO
        BEGIN                                  { WRITE DATA TO FILE }
          IF a=asclf THEN
            BEGIN
              IF lfeol OR gotcr THEN
                BEGIN
                  wrtrec;
                  gotcr:=false
                END
              ELSE
                BEGIN
                  wrtasc(a)
                END
            END
          ELSE
            BEGIN
              IF gotcr THEN
                BEGIN
                  wrtasc(asccr);
                  gotcr:=false
                END;
              IF a=asccr THEN
                BEGIN
                  IF creol THEN
                    BEGIN
                      wrtrec
                    END
                  ELSE
                    IF crlfeol THEN
                      BEGIN
                        gotcr:=true
                      END
                    ELSE
                      BEGIN
                        wrtasc(a)
                      END
                END
              ELSE
                BEGIN
                  wrtasc(a)
                END
            END
        END
    END
END;

PROCEDURE redrec;                                      { File input }

VAR c: char;
  a: ascval;

BEGIN
  bufinit(redbuf);
  IF redix >= 0 AND NOT binary THEN
    readln(rfile);                        { GET TEXT RECORD TO TASK }
  IF binary THEN
    BEGIN
      IF eof(rbfile) THEN
        reof:=true
      ELSE
        read(rbfile,bbuf)                     { READ 80 CHAR RECORD }
    END;
  redix:=0;
  IF NOT binary THEN
    reof:= eof(rfile);
  IF NOT reof THEN                     { NOT EOF ON FILETYPE IN USE }
    BEGIN                    { BINARY TYPE OR TEXT TYPE NOT EOF YET }
      IF redlog THEN write(lfile,'RED [');
      IF NOT binary THEN
        WHILE NOT eoln(rfile) DO
          BEGIN                               { PROCESS TEXT RECORD }
            read(rfile,c);
            IF redlog THEN write(lfile,c);
            a:=ord(c);
            putbuf(redbuf,a)
          END
      ELSE
        FOR i:=1 TO size(bbuf) DO
          BEGIN
            IF redlog THEN write(lfile,bbuf[i]);
            a:=ord(bbuf[i]);
            putbuf(redbuf,a)
          END;
      recsred:=succ(recsred);              { NUMBER OF RECORDS READ }
      IF redlog THEN writeln(lfile,']');
      IF creol OR crlfeol THEN putbuf(redbuf,asccr);
      IF lfeol OR crlfeol THEN
        putbuf(redbuf,asclf)
    END
END;

PROCEDURE redopn;                                  {System dependent}

VAR
  rstat: boolean;

BEGIN
  rstatus:=closed;
  IF NOT binary THEN
    BEGIN
      set$acnm(location(rfile),location(fname));  { SET PASCAL NAME }
      ioterm(rfile,oval,false);          { TURN OFF I/O TERM ON ERR }
      reset(rfile);                         { OPEN FILE FOR READING }
      rstat:= status(rfile)=0;               { CHECK FOR OPEN ERROR }
      ioterm(rfile,oval,true)        { TURN BACK ON I/O TERM ON ERR }
    END
  ELSE                                           { BINARY FILE TYPE }
    BEGIN
      set$acnm(location(rbfile),location(fname)); { SET PASCAL NAME }
      ioterm(rbfile,oval,false);         { TURN OFF I/O TERM ON ERR }
      reset(rbfile);                        { OPEN FILE FOR READING }
      rstat:= status(rbfile)=0;              { CHECK FOR OPEN ERROR }
      ioterm(rbfile,oval,true)       { TURN BACK ON I/O TERM ON ERR }
    END;
  IF rstat THEN
    BEGIN
      rstatus:=open;
      IF NOT binary THEN
        sp:=scb$a(location(rfile))   { GET CALLBLOCK OF FILE OPENED }
      ELSE                                                 { BINARY }
        sp:=scb$a(location(rbfile)); { GET CALLBLOCK OF FILE OPENED }
      s.svc:=0;                  { SET UP READ FILE CHARACTERISTICS }
      s.subop:=rfc;                                     { SUBOPCODE }
      s.buf:=location(rs);                 { CHARACTERISTICS BUFFER }
      s.lrl:=size(rs);
      s.lun:=sp@.lun;                                 { LUNO NUMBER }
      svc$(location(s));                          { PERFORM THE SVC }
      IF lstatus = open THEN
        BEGIN                     { RECORD SVC STATUS AND FILE SIZE }
          writeln(lfile,'THE SVC RFC STATUS: ',s.stat hex);
          writeln(lfile,'FILE SIZE IS: ',rs.filesize);
        END;
  { RS.FILESIZE IS THE NO. OF RECORDS IN FILE USED FOR DISPLAYING % }
      IF rs.filesize=0 THEN rs.filesize:=100;
      recsred:=0
    END;
  reof:=false;                             { NO EOF ENCOUNTERED YET }
  redix:= -1;
  redbuf.ln:= -1
END;

PROCEDURE redcls;

BEGIN
  IF rstatus=open THEN                        { SEE IF FILE IS OPEN }
    BEGIN
      IF NOT binary THEN
        close(rfile)                               { CLOSE THE FILE }
      ELSE
        close(rbfile)
    END;
  rstatus:=closed
END;

PROCEDURE getrec;               { Build data portion of data packet }

VAR a: ascval;
  exit: boolean;
  prevln,previx,tix: integer;

BEGIN
  bufinit(filbuf);
        { WE MUST IMPLEMENT SPECIAL EOF HANDLING FOR FILE OF CHAR80 }
  IF (NOT binary AND eof(rfile)) OR (binary AND reof) THEN
    BEGIN
      rstatus:=endfile
    END
  ELSE
    BEGIN
      exit:=false;
      REPEAT
        IF redix >= redbuf.ln THEN
          BEGIN
            redrec;
            IF (NOT binary AND eof(rfile)) OR (binary AND reof) THEN
              BEGIN
                exit:=true;
                IF filbuf.ln=0 THEN
                  rstatus:=endfile
              END
          END;
        IF redix < redbuf.ln THEN
          BEGIN
            prevln:=filbuf.ln;
            previx:=redix;
            redix:=redix+1;
            a:=redbuf.ch[redix];
            IF locrep<>0 THEN
              BEGIN
                tix:=redix+1;
                WHILE (a=redbuf.ch[tix]) AND (tix<=redbuf.ln) DO
                  tix:=tix+1;
                tix:=tix-redix;         {tix is now the repeat count}
                IF tix>3 THEN
                  BEGIN
                    IF tix>94 THEN tix:=94;
                    putbuf(filbuf,locrep);
                    putbuf(filbuf,makechar(tix));
                    redix:=redix-1+tix
                  END
              END;
            IF (a>127) THEN
              BEGIN
                IF locqu8<>0 THEN putbuf(filbuf,locqu8);
                a:=tog128(a)
              END;
            IF (a<32) OR (a=ascdel) THEN
              BEGIN
                putbuf(filbuf,locquo);
                a:=tog64(a)
              END;
            IF (a=locquo) OR (a=locqu8) OR (a=locrep) THEN
              BEGIN
                putbuf(filbuf,locquo)
              END;
            putbuf(filbuf,a);
            IF filbuf.ln >= remdsiz THEN
              BEGIN
                exit:=true;
                IF filbuf.ln>remdsiz THEN
                  BEGIN
               {Character expansion caused buffer length to be
                exceeded.  Back up.}
                  filbuf.ln:=prevln;
                    redix:=previx
                  END
              END
          END
      UNTIL exit
    END
END;

PROCEDURE gencmd(r:ascbuf);

BEGIN                                                      { GENCMD }
  IF r.ch[1]=ascl THEN                     { EXIT KERMIT AND LOGOFF }
    BEGIN
      sndpkt;                                            { SEND ACK }
      ssbuf:='$QUIT       ';     { SCI SYNONYM FOR LOGOFF UPON EXIT }
      FOR i:=1 TO 5 DO
        syn[i]:=ssbuf[i];
      syn[0]:='#05';                               { SET SYN LENGTH }
      ssbuf:='YES         ';                     { VALUE OF SYNONYM }
      FOR i:=1 TO 3 DO
        val[i]:=ssbuf[i];                                 { MOVE IT }
      val[0]:='#03';                                       { LENGTH }
      store$syn(syn,val);           { SET $QUIT SYN IN CALLING PROC }
      server:=false;                                  { EXIT SERVER }
      state:=kexit                                    { EXIT KERMIT }
    END
  ELSE
    IF r.ch[1]=ascf THEN                         { JUST EXIT KERMIT }
      BEGIN
        sndpkt;                                          { SEND ACK }
        server:=false;                                { EXIT SERVER }
        state:=kexit                                  { EXIT KERMIT }
      END
    ELSE
      error('UNSUPPORTED GENERIC COMMAND.            ')
END;                                                       { GENCMD }

PROCEDURE sendinitiate;                               { Send states }

BEGIN
  IF fnlen>0 THEN
    BEGIN
      redopn;
      IF rstatus=open THEN
        BEGIN
          putpar;                        {Put parameters into buffer}
          makepacket(ascs,seq,filbuf.ln);
                                    {Make packet with our parameters}
          numtry:=0;
          state:=sheader
        END
      ELSE
        error('ERROR OPENING READ FILE                 ')
    END
  ELSE
    error('NO READ FILE SPECIFIED                  ')
END;

PROCEDURE sendheader;

VAR
  wrkbuf:flen;             { WORKING BUFFER FOR FILENAME EXTRACTION }
  cptr:integer;                               { A TEMP CHAR POINTER }

BEGIN
  IF rcvtyp=ascy THEN
    BEGIN
      headok:=true;
      IF NOT sndonly THEN getpar;
                              {Get parameters from ACK of 'S' packet}
      IF rfnlen>0 THEN
        BEGIN          { USER SPECIFIED REMOTE FILENAME - USE AS IS }
          lintobuf(rfname,rfnlen,filbuf)     {Send remote file name.}
        END
      ELSE
        BEGIN                      { USE LOCAL FILE NAME FOR REMOTE }

{ WE MUST STRIP ANY UNUSUAL CHARS AND/OR DIRECTORY NAMES FROM LOCAL
  PATH TO BUILD A REMOTE FILENAME.  KERMIT DOES ALLOW THE USE OF A
  DOT WITHIN A FILENAME, BUT SINCE DX10 DOESN'T AND DX10 IS THE
  ORIGINATING SYSTEM, WE WILL ONLY ALLOW UPPERCASE CHARS AND DIGITS
  WITHIN A FILENAME.  IF THE USER WANTS ANYTHING ELSE - THEN USE THE
  REMOTE FILE OPTION ON SEND COMMAND -  THAT'S WHAT IT'S THERE FOR. }

          FOR k:=1 TO maxflen DO
            wrkbuf[k]:=' ';        { CLEAR FILE NAME WORKING BUFFER }
          cptr:=fnlen+1;                 { POINT TO END OF FILENAME }
          WHILE cptr>2 AND fname[cptr]<>'.' DO
            BEGIN              { EXTRACT LOCAL FILE NAME FOR REMOTE }
              IF fname[cptr]<>'$' AND fname[cptr]<>'_' THEN
                wrkbuf[cptr]:=fname[cptr]
              ELSE { WE'LL REPLACE ANY ILLEGAL CHARS WITH 0 - SORRY }
                wrkbuf[cptr]:='0';
              cptr:=pred(cptr)
            END;         { GOT A FILE NAME - NOW PUT IN RIGHT PLACE }
          rfnlen:=2;                { NOW KEEP TRACK OF LENGTH ALSO }
          FOR k:=1 TO maxflen DO
            IF wrkbuf[k]<>' ' THEN
              BEGIN         { EXTRACT GOOD NAME FROM WORKING BUFFER }
                rfname[rfnlen]:=wrkbuf[k];       { GRAB A GOOD CHAR }
                rfnlen:=succ(rfnlen)
              END;
          rfnlen:=rfnlen-2;           { ADJUST FOR TRUE NAME LENGTH }
          rfname[1]:=chr(rfnlen);
          lintobuf(rfname,rfnlen,filbuf)  { SEND ADJUSTED FILE NAME }
        END;
      numtry:=0;
      seq:=(seq+1) MOD 64;
      makepacket(ascf,seq,filbuf.ln);
      state:=sdata
    END
END;

PROCEDURE senddata;

BEGIN
  IF rcvtyp=ascy THEN
    BEGIN
      IF headok THEN          { LAST PACKET - FILE HEADER WAS ACKed }
        BEGIN
          sending:=true;                       { START SENDING FILE }
          headok:=false;                        { RESET HEADER FLAG }
          bsbuf:= 'SENDING FILE:                           ';
          writdev(ts,true,15,location(bsbuf));
          FOR k:=1 TO fnlen DO
            bsbuf[k]:=fname[k+1];
          writdev(ts,true,fnlen,location(bsbuf));
          ssbuf:=' ==>        ';
          writdev(ts,true,5,location(ssbuf));
          FOR k:=1 TO rfnlen DO
            bsbuf[k]:=rfname[k+1];
          writdev(ts,true,rfnlen,location(bsbuf));
          tcbuf:=crlf;
          writdev(ts,true,2,location(tcbuf))
        END;
      getrec;
      numtry:=0;
      seq:=(seq+1) MOD 64;
      IF rstatus = open THEN
        makepacket(ascd,seq,filbuf.ln)
      ELSE
        BEGIN
          makepacket(ascz,seq,0);
          state:=sbreak;
          fnlen:=0
        END
    END
END;

PROCEDURE sendbreak;

BEGIN
  IF rcvtyp=ascy THEN
    BEGIN
      numtry:=0;
      seq:=(seq+1) MOD 64;
      makepacket(ascb,seq,0)
    END;
  state:=wexit
END;

                                        { Receive states PROCEDURES }

PROCEDURE rcvinitiate;

BEGIN
  IF rcvtyp=ascs THEN
    BEGIN
      getpar;                            {Get parameters from packet}
      putpar;                            {Put parameters into buffer}
      makepacket(ascy,seq,filbuf.ln);
                                {Make ACK packet with our parameters}
      seq:=rcvseq;
      numtry:=0;
      seq:=(seq+1) MOD 64;
      state:=rheader
    END
END;

PROCEDURE rcvheader;

BEGIN
  IF rcvtyp=ascf THEN
    BEGIN
      IF fnlen=0 THEN
        BEGIN                                { USE REMOTE FILE NAME }
          buftolin(rcvbuf,fname,fnlen);
        END;
      IF fnlen>0 THEN
        BEGIN                  { GOT A FILE TO RECEIVE TO - OPEN IT }
          wrtopn;
          IF wstatus=open THEN
            BEGIN
              makepacket(ascy,seq,0);
              numtry:=0;
              seq:=(seq+1) MOD 64;
              headok:=true;
              state:=rdata
            END
          ELSE
            error('ERROR OPENING WRITE FILE                ')
        END
      ELSE
        error('NO OUTPUT FILE SPECIFIED                ')
    END
  ELSE
    IF rcvtyp=ascb THEN
      BEGIN
        makepacket(ascy,seq,0);
        sndpkt;
        state:=cexit
      END
    ELSE
      IF rcvtyp=ascg THEN
        BEGIN
          makepacket(ascy,seq,0);                     { ACKNOWLEDGE }
          numtry:=0;
          gencmd(rcvbuf)               { PROCESS GENERIC KERMIT CMD }
        END
      ELSE
        error('WRONG PACKET RECEIVING FILE HEADER      ')
END;

PROCEDURE receivedata;

BEGIN
  IF rcvtyp=ascd THEN
    BEGIN
      IF headok THEN          { LAST PACKET - FILE HEADER WAS ACKed }
        BEGIN
          receiving:=true;                   { START RECEIVING FILE }
          headok:=false;                        { RESET HEADER FLAG }
          bsbuf:= 'RECEIVING FILE:                         ';
          writdev(ts,true,17,location(bsbuf));
          FOR k:=1 TO rfnlen DO
            bsbuf[k]:=rfname[k+1];
          writdev(ts,true,rfnlen,location(bsbuf));
          ssbuf:=' ==>        ';
          writdev(ts,true,5,location(ssbuf));
          FOR k:=1 TO fnlen DO
            bsbuf[k]:=fname[k+1];
          writdev(ts,true,fnlen,location(bsbuf));
          tcbuf:=crlf;
          writdev(ts,true,2,location(tcbuf))
        END;
      putrec(rcvbuf);
      makepacket(ascy,seq,0);
      numtry:=0;
      seq:=(seq+1) MOD 64
    END
  ELSE
    IF rcvtyp=ascz THEN             { RECEIVED EOF INDICATOR PACKET }
      BEGIN
        wrtcls;
        fnlen:=0;
        makepacket(ascy,seq,0);
        numtry:=0;
        seq:=(seq+1) MOD 64;
        state:=rheader
      END
    ELSE
      error('UNEXPECTED PACKET RECEIVING DATA        ')
END;

PROCEDURE get;                                { PREPARE AN R PACKET }

BEGIN
  IF rcvtyp=ascy THEN
    BEGIN                    { I PACKET ACKed - CONTINUE NEXT STATE }
      lintobuf(rfname,rfnlen,filbuf);       { SEND FILE NAME TO GET }
      numtry:=0;
      makepacket(ascr,seq,filbuf.ln);
      state:=rinitiate
    END
END;

PROCEDURE iinitiate;

BEGIN
  putpar;                                {Put parameters into buffer}
  makepacket(asci,seq,filbuf.ln);         { MAKE I PARAMETER PACKET }
  numtry:=0
END;

PROCEDURE finish;              { SHUT DOWN REMOTE SERVER AND KERMIT }

BEGIN
  bufinit(filbuf);
  putbuf(filbuf,ascf);
  makepacket(ascg,seq,filbuf.ln);   {Make packet with our parameters}
  numtry:=0;
  state:=wexit
END;

PROCEDURE bye;           { SHUT DOWN REMOTE SERVER, KERMIT & LOGOFF }

BEGIN
  bufinit(filbuf);
  putbuf(filbuf,ascl);
  makepacket(ascg,seq,filbuf.ln);   {Make packet with our parameters}
  numtry:=0;
  state:=wexit
END;

PROCEDURE connect;                              { CONNECT TO REMOTE }

      { THE PROCEDURE CONNECT IS A SIMPLE TTY TYPE EMULATOR USED TO }
  { CONNECT REMOTE SYSTEMS OR MODEMS.  FULL DUPLEX I/O IS EMULATED. }
  { I/O IS ACCOMPLISHED VIA SVC CALLS.  CALLS TO PROCEDURES TO PER- }
  { FORM READS AND WRITES HAVE BEEN REMOVED FOR GREATER SPEED -     }
  { ESPECIALLY NEEDED FOR CHARACTER INPUT.  A WAIT ON ANY I/O       }
  { CALL IS MADE WHEN NOTHING IS GOING ON - TO AVOID SPINNING.      }
  { IF WE GET AN INPUT BUFFER OVERFLOW(I.E. THE CHARACTERS ARE COM- }
  { ING IN FASTER THAN WE CAN HANDLE THEM),THEN WE WILL DYNAMICALLY }
  { ADJUST OUR XOFF THRESHOLD(I.E. NUMBER OF CHARACTERS TO RECEIVE  }
  { AT ONE TIME BEFORE SENDING AN XOFF) TO ADAPT TO THE SYSTEM.     }



VAR
  escseq:boolean;                         { ESCAPE FROM REMOTE HOST }
  xbuf:char2;                              { XON - XOFF CHAR BUFFER }
  fq,bq:integer;                                    { CHAR POINTERS }
  xoff:boolean;                              { XOFF-XON IN PROGRESS }
  wrt:boolean;                  { WRITE TO TERMINAL IS TAKING PLACE }
  b:boolean;                                { DOUBLE BUFFER POINTER }
  bufp:ARRAY[boolean]OF buf;        { REMOTE CONNECT DOUBLE BUFFERS }
  justread:char;                            { FOR ECHO CHAR CONTROL }
  ti:integer;                            { GET CHAR LOOP CONTROLLER }
  dummy:char2;                       { JUNK TO SATISFY A WRITE NEED }
  adjustxoff:integer; { CURRENT NO. OF CHARS TO RECEIVE BEFORE XOFF }
  inesc:integer;                              { CHEAP EMULATOR FLAG }
  seqnum:integer;   { HOW MANY ESQ SEQ. CHARS TO THROW AWAY FOR ISC }
  twochar:boolean;                               { DOUBLE CHAR FLAG }

BEGIN
  seqnum:=0;
  inesc:=0;                          { NO VALID CHARACTER TO OUTPUT }
  twochar:=false;                  { NO 2 CHAR SEQUENCE TO SEND YET }
  adjustxoff:=xoff_threshold;                   { SET INITIAL VALUE }
  bq:=0;
  fq:=0;
  w1.op:= #36;          { SET WAIT ON ANY I/O COMPLETION SVC OPCODE }
  w1.fil1:=0;                             { CLEAR REST OF CALLBLOCK }
  w1.fil2:=0;
  w1.fil3:=0;
  dummy:='#08#08';
  xbuf:='#13#11';                    { XOFF AND XON FOR I/O CONTROL }
  xoff:=false;
  wrt:=false;
  b:=true;
  escseq:=false;
  ti:=0;
  ps.subop:=readas;                          { READ ASCII SUBOPCODE }
  ps.flags:=[qret];                              { QUICK RETURN I/O }
  ps.buf:=location(pcbuf);                             { SET BUFFER }
  ps.lrl:=1;                              { READ A SINGLE CHARACTER }
  svc$(location(ps));                       { PERFORM I/O OPERATION }
  ts.subop:=readas;                          { READ ASCII SUBOPCODE }
  ts.flags:=[qret];                              { QUICK RETURN I/O }
  ts.buf:=location(tcbuf);                             { SET BUFFER }
  ts.lrl:=1;                              { READ A SINGLE CHARACTER }
  svc$(location(ts));                       { PERFORM I/O OPERATION }

                                        { UNTIL ESCAPE SEQ IS TYPED }
  WHILE NOT escseq AND ts.stat=0 AND
      (ps.stat=0 OR (ps.stat>=#50 AND ps.stat<=#52)) DO
    BEGIN                       { PARITY,FRAME,OVERFLOW - NON-FATAL }

      IF ps.stat>=#50 AND ps.stat<=#52 THEN
        BEGIN   { NOT FATAL - i.e. HOPEFULLY THINGS WILL GET BETTER }
          IF ps.stat=#52 THEN
            BEGIN                                  { OVERFLOW ERROR }
              IF lstatus=open THEN
                BEGIN
                  writeln(lfile,'PORT FULL BUFFER ERROR');
                  writeln(lfile,'CHARS BUFFED SO FAR: ',fq)
                END;
   { ATTEMPT TO ADJUST XOFF THRESHOLD FOR CURRENT SYSTEM CONDITIONS }
   { BUT KEEP ABOVE MINIMUM TO AVOID XOFFING EVERY LINE OR TWO.     }
      { ADJUSTING XOFF THRESHOLD IS EXPERIMENTAL AND MAY BE REMOVED }
              IF fq>200 AND fq<adjustxoff THEN
                adjustxoff:=fq
            END
          ELSE
            IF ps.stat=#51 THEN
              BEGIN
                IF lstatus=open THEN
                  writeln(lfile,'PORT FRAMING ERROR')
              END
            ELSE                              { JUST A PARITY ERROR }
              BEGIN
                IF lstatus=open THEN
                  writeln(lfile,'PARITY ERROR ON PORT.')
              END;
          ps.stat:=0;                               { CLEAR THE ERR }
          svc$(location(ps))                         { REQUEUE READ }
        END;

      IF NOT bsy IN ps.flags AND ps.stat=0 THEN
        BEGIN                 { GOT A CHAR FROM REMOTE SYSTEM/MODEM }
          ti:=0;                   { RESET GET CHAR LOOP CONTROLLER }
          WHILE ti<800 AND ps.stat=0 DO
      { HOW LONG YOU WANT TO STAY IN HERE DEPENDS ON AVOVE CONSTANT }
            BEGIN
            { STAY HERE FOR AWHILE IN CASE MORE CHARS ARE COMING IN }
              IF NOT bsy IN ps.flags THEN
                BEGIN                               { READ FINISHED }
                  fq:=succ(fq);    { NUMBER OF CHARS READ IN SO FAR }
 (******************************************************************)
                  IF isc THEN    { A VERY QUICK 931 TO TTY EMULATOR }
 { THE OBJECTIVE HERE IS TO ATTEMPT TO INHIBIT THE ESCAPE SEQUENCES }
{ THAT GET SENT TO A TI VDT931 TERMINAL, THUS EMULATING A TTY MODE. }
{ IF AN ESCAPE SEQUENCE ARRIVES, THEN THE ESCAPE SEQUENCE WILL BE   }
{ THROWN AWAY.  THE NUMBER OF CHARACTERS TOSSED WILL DEPEND ON THE  }
{ TYPE OF SEQUENCE.  MOST ARE SINGLE CHARACTER SEQUENCES.           }
                    CASE inesc OF               { OUR PRESENT STATE }
                      0:
                        IF pcbuf[1] <> '#1B' THEN
                          bufp[b,fq]:=pcbuf[1]
                        ELSE
                          BEGIN
                            inesc:=1;
                            fq:=pred(fq)   { THROW AWAY ESCAPE CHAR }
                          END;
                      1:
                        BEGIN
                          inesc:=2;          { ASSUME >2 SEQ LENGTH }
{ DEPENDING ON THE ESQ SEQ IDENTIFIER, NUMBER OF CHARS TO TOSS IS SET }
                          CASE pcbuf[1] OF
                            'V': seqnum:=1;
                            'Y':
                              BEGIN
                          { DO A CRLF ON A CURSOR POSITION SEQUENCE }
                                seqnum:=2;
                                bufp[b,fq]:='#0A';
                                fq:=succ(fq);
                                bufp[b,fq]:='#0D';
                                fq:=succ(fq)
                              END;
                            '4': seqnum:=1;
                            '@': seqnum:=2;
                            '>': seqnum:=2;
                            'j':seqnum:=2;
                            'x': seqnum:=4;
                            '?': seqnum:=3;
                            'k':
                              seqnum:=2
                            OTHERWISE
                               { JUST TOSS THIS ONE i.e. 2 CHAR SEQ }
                              inesc:=0
                                  { AND RETURN TO NORMAL CHAR STATE }
                            END;
                          fq:=pred(fq)              { TOSS THE CHAR }
                        END;
                      2:
                        BEGIN
                          seqnum:=pred(seqnum);
                            { SET NUMBER OF CHARS REMAINING TO TOSS }
                          fq:=pred(fq);             { TOSS THIS ONE }
                          IF seqnum=0 THEN       { ALL DONE TOSSING }
                            inesc:=0 { RETURN TO NORMAL INPUT STATE }
                        END
                      END
                  ELSE
 (******************************************************************)
                    bufp[b,fq]:=pcbuf[1];  { SAVE CHAR - DOUBLE BUF }
                  IF fq>adjustxoff THEN
                    BEGIN                    { READ BUF ALMOST FULL }
                      ps.subop:=writas;     { WRITE ASCII SUBOPCODE }
                      ps.flags:=[];
                      ps.buf:=location(xbuf);       { POINT TO XOFF }
                      ps.cc:=1;               { CHARACTERS TO WRITE }
                      svc$(location(ps));               { SEND XOFF }
                      ps.subop:=readas;      { READ ASCII SUBOPCODE }
                      ps.flags:=[qret];          { QUICK RETURN I/O }
                      ps.buf:=location(pcbuf);         { SET BUFFER }
                      ps.lrl:=1;          { READ A SINGLE CHARACTER }
                      IF ps.stat=0 THEN
                        svc$(location(ps));     { NOW EMPTY PDT BUF }
                      WHILE fq<buf_threshold AND ps.stat=0 AND NOT
                          xoff DO
                        BEGIN       { EMPTY PDT BUFFER OF ALL CHARS }
                          IF NOT bsy IN ps.flags THEN
                            BEGIN
                              fq:=succ(fq);
                              bufp[b,fq]:=pcbuf[1];
                              IF fq<buf_threshold THEN
                                svc$(location(ps))
                              ELSE
                                xoff:=true
                              { ONLY IF USER HAS "LARGE" PDT BUFFER }
                            END
                          ELSE
                            BEGIN
                              delay(100);
                              xoff:=bsy IN ps.flags          { DONE }
                            END
                        END;
                      IF lstatus = open THEN
                        BEGIN
                          writeln(lfile,'FQ SURPASSED ADJUST IS:',fq);
                          IF xoff THEN
                            writeln(lfile,'XOFF WAS JUST SET')
                        END
                    END
                  ELSE
                    svc$(location(ps));          { CONTINUE READING }
                  ti:=0              { RESET ITERATION LOOP CONTROL }
                END
              ELSE
                ti:=succ(ti)
            END
        END
      ELSE                              { EITHER DEVBSY(PS) OR XOFF }
        BEGIN
          IF fq>0 AND NOT wrt AND bsy IN ts.flags AND
              (bsy IN ps.flags OR xoff) THEN
            BEGIN
              IF fq>80 THEN
                BEGIN      { LIMITED TO 80 CHAR WRITE WITH PASSTHRU }
                  bq:=fq-80;
                  fq:=80
                END;
              abort(ts);
              ts.subop:=writas;             { WRITE ASCII SUBOPCODE }
              ts.flags:=[qret];                  { QUICK RETURN I/O }
              ts.cc:=fq;                      { CHARACTERS TO WRITE }
              ts.buf:=location(bufp[b]);         { SET WRITE BUFFER }
              IF isc THEN              { SPECIAL CHARACTER HANDLING }
                BEGIN
                  IF fq=1 AND bufp[b,1]=justread THEN
                        { THIS IS WHERE WE CAN SUPPRESS ECHO ON ISC }
                    ts.buf:=location(dummy)  { OR NON-PASSTHRU TERM }
                  ELSE              { ONLY UPPERCASE ON ISC ALLOWED }
                    FOR i:=1 TO (bq+fq) DO        { L.C. --> U.CASE }
                      IF bufp[b,i]>='a' AND bufp[b,i]<='z' THEN
                        bufp[b,i]:=chr(ord(bufp[b,i])-32)
                END;
              svc$(location(ts));           { PERFORM I/O OPERATION }
              wrt:=true;
              b:=NOT b;                   { ENABLE DOUBLE BUFFERING }
              fq:=0
            END
          ELSE
            IF NOT(wrt OR bsy IN ts.flags OR ts.stat<>0)AND
                (bsy IN ps.flags OR xoff) THEN
              BEGIN                 { READ A CHAR FROM THE TERMINAL }
                IF ts.cc=1 THEN
                  BEGIN
                    justread:=tcbuf[1];
                                    { SAVE LAST CHAR READ FROM TERM }
                    IF tcbuf[1]='#40' OR tcbuf[1]='#5E' OR
                        tcbuf[1]='#25' THEN
                      BEGIN                    { SPECIAL CHARACTERS }
                        tcbuf[2]:=tcbuf[1];
                                 { SAVE POSSIBLE SPECIAL START CHAR }
                        svc$(location(ts));
                                         { TRY FOR SPECIAL SEQUENCE }
                        delay(200);   { ALLOW DELAY FOR REST OF SEQ }
                        IF NOT bsy IN ts.flags AND ts.stat=0 THEN
                          BEGIN                  { GOT ANOTHER CHAR }
                            IF tcbuf='#40#40' THEN
                              escseq:=true                { GET OUT }
                            ELSE
{ IF ON ISC(NO-PASSTHRU TERM) THE FOLLOWING KEY SEQUENCES ARE NEEDED }
      { IN ORDER TO SEND SPECIAL CONTROL KEYS TO TI REMOTE 931 PORT }
                              IF tcbuf='#5E#5E' THEN
                                BEGIN
                                  twochar:=true;  { A TWO CHAR SEND }
                                  tcbuf:='#1B#68'         { CMD KEY }
                                END
                              ELSE
                                IF tcbuf='#25#25' THEN
                                  BEGIN
                                    twochar:=true;
                                                  { A TWO CHAR SEND }
                                    tcbuf:='#1B#67' { BLNK ORGE KEY }
                                  END
                                ELSE
                                  IF tcbuf='#5E#40' THEN
                                    tcbuf[1]:='#1B'       { ESQ KEY }
                                  ELSE
                                    IF tcbuf='#25#40' THEN
                                      tcbuf[1]:='#11'    { SEND XON }
                          END
                      END
                  END
                ELSE
                  IF isc THEN               { ONLY FOR ISC TERMINAL }
                    BEGIN
                      tcbuf:=crlf;        { HEURISTIC-PROBABLY A CR }
                      ts.subop:=writas;
                      ts.flags:=[];
                      ts.cc:=1;
                      ts.buf:=location(tcbuf)+1;
                      svc$(location(ts))          { WRITE LF TO ISC }
                    END;
                IF NOT escseq AND NOT xoff AND ts.stat=0 THEN
                  BEGIN
                    abort(ps);
                    ps.subop:=writas;       { WRITE ASCII SUBOPCODE }
                    ps.flags:=[];
                    IF isc AND twochar THEN
                      BEGIN
                        twochar:=false;                     { RESET }
                        ps.cc:=2                    { WRITE 2 CHARS }
                      END
                    ELSE
                      ps.cc:=1;               { CHARACTERS TO WRITE }
                    ps.buf:=location(tcbuf);           { SET BUFFER }
                    svc$(location(ps));     { PERFORM I/O OPERATION }
                    IF ps.stat=0 THEN
                      BEGIN                   { CONTINUE - NO ERROR }
                        ps.subop:=readas;    { READ ASCII SUBOPCODE }
                        ps.flags:=[qret];        { QUICK RETURN I/O }
                        ps.buf:=location(pcbuf);       { SET BUFFER }
                        ps.lrl:=1;        { READ A SINGLE CHARACTER }
                        svc$(location(ps)); { PERFORM I/O OPERATION }
                        IF NOT bsy IN ts.flags AND ts.stat=0 THEN
                          BEGIN
                               { READ POSSIBLY QUEUED ALREADY ABOVE }
                            ts.subop:=readas;
                                             { READ ASCII SUBOPCODE }
                            ts.lrl:=1;         { READ A SINGLE CHAR }
                            ts.flags:=[qret];    { QUICK RETURN I/O }
                            ts.buf:=location(tcbuf);   { SET BUFFER }
                            svc$(location(ts))
                                            { PERFORM I/O OPERATION }
                          END
                      END
                  END
              END
            ELSE
              IF wrt AND NOT bsy IN ts.flags AND ts.stat=0 AND
                  (bsy IN ps.flags OR xoff) THEN
                BEGIN
                  IF bq>0 THEN
                    BEGIN
                      ts.subop:=writas;     { WRITE ASCII SUBOPCODE }
                      ts.flags:=[qret];          { QUICK RETURN I/O }
                      ts.buf:=ts.buf+80;               { SET BUFFER }
                      IF bq>80 THEN
                        BEGIN
                          ts.cc:=80;
                          bq:=bq-80
                        END
                      ELSE
                        BEGIN
                          ts.cc:=bq;
                          bq:=0
                        END;
                      svc$(location(ts))
                    END
                  ELSE
                    BEGIN
                      wrt:=false;
                      ts.subop:=readas;      { READ ASCII SUBOPCODE }
                      ts.flags:=[qret];          { QUICK RETURN I/O }
                      ts.buf:=location(tcbuf);         { SET BUFFER }
                      svc$(location(ts));   { PERFORM I/O OPERATION }
                      IF xoff THEN
                        BEGIN
                          IF lstatus=open THEN
                            writeln(lfile,'XOFF BEING RESET');
                          xoff:=false;
                          pcbuf[1]:=xbuf[2];
                          IF bsy IN ps.flags THEN
                            abort(ps);
                          ps.subop:=writas; { WRITE ASCII SUBOPCODE }
                          ps.flags:=[];
                          ps.buf:=location(pcbuf);     { SET BUFFER }
                          ps.cc:=1;           { CHARACTERS TO WRITE }
                          svc$(location(ps));
                                            { PERFORM I/O OPERATION }
                          IF ps.stat=0 THEN
                            ps.subop:=readas;
                                             { READ ASCII SUBOPCODE }
                          ps.flags:=[qret];      { QUICK RETURN I/O }
                          ps.lrl:=1;      { READ A SINGLE CHARACTER }
                          svc$(location(ps))
                                            { PERFORM I/O OPERATION }
                        END
                    END
                END
        END;
      IF bsy IN ps.flags AND bsy IN ts.flags AND
          bq=0 AND fq=0 AND NOT wrt AND NOT xoff THEN
                                                 { NOTHING GOING ON }
        svc$(location(w1))    { DONT SPIN - WAIT ANY I/O COMPLETION }
    END;

  IF ts.stat<>0 AND lstatus=open THEN
    BEGIN
      writeln(lfile,'A TERMINAL SVC ERROR.');
      writeln(lfile,'THE SVC ERROR IS: ',ts.stat hex);
      writeln(lfile,'BYE')
    END;
  IF ps.stat<>0 AND lstatus=open THEN
    BEGIN
      writeln(lfile,'A REMOTE PORT SVC ERROR.');
      writeln(lfile,'THE SVC ERROR IS: ',ps.stat hex);
      writeln(lfile,'BYE')
    END
END;                                                      { CONNECT }

PROCEDURE help;

BEGIN                                                        { HELP }
  tcbuf:=crlf;
  writdev(ts,true,2,location(tcbuf));
  bsbuf:='THE FOLLOWING COMMANDS ARE SUPPORTED.#0D#0A ';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='PLEASE USE UPPERCASE FOR ALL COMMANDS.#0D#0A';
  writdev(ts,true,40,location(bsbuf));
  writdev(ts,true,2,location(tcbuf));
  bsbuf:='LOG <OPTIONAL FILENAME>               #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='CONNECT - CONNECT TO REMOTE SYSTEM.   #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='SEND <LOCAL FILE> <OPTIONAL REM FILE> #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='RECEIVE <DX10 RECEIVE FILE NAME>      #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='FINISH - SHUT DOWN REMOTE KERMIT.     #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='BYE - SHUT DOWN AND LOG OFF REMOTE.   #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='TEST - SEND ONLY TEST MODE.           #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='EXIT - LEAVE KERMIT.                  #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='SERVER - PLACE KERMIT IN SERVER MODE. #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='BINARY - SEND/RECEIVE BINARY FILE.    #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='TEXT - SEND/RECEIVE TEXT FILE(DEFAULT)#0D#0A';
  writdev(ts,true,40,location(bsbuf));
  bsbuf:='GET <REMOTE FILE NAME> <LOCAL FILE>   #0D#0A';
  writdev(ts,true,40,location(bsbuf));
  writdev(ts,true,2,location(tcbuf));
  writdev(ts,true,2,location(tcbuf))
END;                                                         { HELP }

PROCEDURE error;          { Error processing - Process fatal errors }
VAR l:integer;

BEGIN                                                       { ERROR }
  l:=size(msg);
  IF l>maxbuf-6 THEN l:=maxbuf-6;
  bufinit(filbuf);
  FOR i:=1 TO 3 DO putbuf(filbuf,ascsp);
                                    {Make message readable in packet}
  FOR i:=1 TO l DO putbuf(filbuf,ord(msg[i]));
  FOR i:=1 TO 3 DO putbuf(filbuf,ascsp);
                                    {Make message readable in packet}
  makepacket(asce,seq,filbuf.ln);
  sndpkt;
  state:=cexit;                    { THEN EXIT BACK TO COMMAND MODE }
  IF local AND NOT server THEN           { OUT ERROR TO CONSOLE TOO }
    BEGIN
      ssbuf:='#0D#0A#0D#0A        ';
      writdev(ts,true,4,location(ssbuf));
      writdev(ts,true,40,location(msg));
      writdev(ts,true,4,location(ssbuf))
    END
END;                                                        { ERROR }

PROCEDURE kermcommand;

BEGIN                                                 { KERMCOMMAND }
  IF lstatus=open AND server THEN
    writeln(lfile,'IN SERVER MODE');
  REPEAT
    rcvpkt;                                          { GET A PACKET }
    IF rcvseq>-1 THEN                       { LEGAL PACKET RECEIVED }
      BEGIN
        IF rcvtyp=asci AND server THEN { RECEIVED INIT PARMS PACKET }
          BEGIN
            getpar;                      {Get parameters from packet}
            putpar;                      {Put parameters into buffer}
            seq:=rcvseq;
            makepacket(ascy,seq,filbuf.ln);
                                {Make ACK packet with our parameters}
            sndpkt                                { AND SEND IT OFF }
          END
        ELSE
          IF rcvtyp=ascs THEN
            BEGIN                       { RECEIVED SEND-INIT PACKET }
              state:=rinitiate
            END
          ELSE
            IF rcvtyp=ascr AND server THEN
              BEGIN                 { RECEIVE A FILE REQUEST PACKET }
                IF fnlen=0 THEN
                  BEGIN
                    buftolin(rcvbuf,fname,fnlen)
                  END;
                state:=sinitiate
              END
            ELSE
              IF rcvtyp=ascg AND server THEN
                BEGIN
                  makepacket(ascy,seq,0);             { ACKNOWLEDGE }
                  numtry:=0;
                  gencmd(rcvbuf)   { PROCESS GENERIC KERMIT COMMAND }
                END
              ELSE
                error('UNEXPECTED PACKET TYPE                  ')
      END
    ELSE
      IF rcvseq=-1 THEN
        BEGIN
          makepacket(ascn,seq,0);
          sndpkt                                { SEND PERIODIC NAK }
        END
      ELSE
        IF rcvseq=-2 THEN
          BEGIN
            state:=cexit;
            server:=false
          END
  UNTIL state<>kcommand
END;

PROCEDURE kerminitialize;                    { Initialization state }
VAR lstat: boolean;

BEGIN
  state:=kcommand;
  numtry:=0;
  seq:=0;
  fnlen:=0;                               {Indicate no file name yet}
  rfnlen:=0;                              { NO REMOTE FILE NAME YET }
  pktsnt:=0;                               { NUMBER OF PACKETS SENT }
  sending:=false;
  receiving:=false;                      { NOT RECEIVING A FILE YET }

  locbsiz:=78;
  loctout:=12;
  locnpad:=0;
  locpad:=0;
  loceol:=asccr;
  locquo:=ascns;
                 {  locqu8 will be set after options are processed. }
  locrep:=asctil;         {Initialize to 0 to turn off repeat counts}

  rembsiz:=78;
                                              { remdsiz:=rembsiz-3; }
  remdsiz:=rembsiz-6;        { MAKE SMALLER - EXCEEDING REMOTE BUFS }
  remtout:=12;
  remnpad:=0;
  rempad:=0;
  remeol:=asccr;
  remqu8:=0;
  remrep:=0;
  headok:=false;                             { NO HEADER PACKET YET }
  bptr:=0;                      { NO DATA IN BINARY DATA BUFFER YET }

  bufinit(sndbuf);

  {The following should only be done on the first call to initialize}
  IF iniflg=false THEN
    BEGIN
      sndonly:=false;
      sndlog:=false;
      rcvlog:=false;
      wrtlog:=false;
      redlog:=false;
      lnlen:=0;                                   { LOG FILE LENGTH }
      crlfeol:=true;
      creol:=false;
      lfeol:=false;
      rstatus:=closed;
      wstatus:=closed;
      lstatus:=closed;
      eolflg:=false;                  { NO CR OR LF ENCOUNTERED YET }
      server:=false;                      { SET ONLY IN SERVER MODE }
      cond:=false;
      optqu8:=0;                      { ASSUME NO EIGHT-BIT QUOTING }
      binary:=false                 { DEFAUTLT NON-BINARY TYPE DATA }
    END;
  locqu8:=optqu8;  { EIGHT BIT QUOTING DONE ONLY WITH BINARY OPTION }
  iniflg:=true
END;

PROCEDURE getstr(VAR wp,strlen:integer;VAR str:flen;cnt:boolean);
(******************************************************************
* ATTEMPT TO GET A THE NEXT STRING WITHIN THIS BUFFER OF STRINGS
*
*   WP - CURRENT CHAR POINTER WITHIN THE BUFFER
*   STRLEN - LENGTH OF THE STRING RETURNED - 0 IF NONE OR PAST END.
*   STR - THE ACTUAL STRING
*   CNT - IF TRUE PUT THE COUNT AT FRONT OF STRING - NEEDED FOR
*         FILE NAMES.
********************************************************************)

BEGIN                                                      { GETSTR }
  strlen:=0;                        { CLEAR --> NO VALID STRING YET }
  WHILE cmdbuf.ch[wp]<>ascsp AND wp <=cmdbuf.ln DO
    wp:=succ(wp);                          { SKIP PAST CHARS IF ANY }
  WHILE cmdbuf.ch[wp]=ascsp AND wp <=cmdbuf.ln DO
    wp:=succ(wp);         { SKIP PAST BLANKS BETWEEN STRINGS IF ANY }
  WHILE cmdbuf.ch[wp]<>ascsp AND wp<=cmdbuf.ln DO
    BEGIN                  { SAVE THE STRING WE ARE NOW POINTING TO }
      strlen:=succ(strlen);                 { SAVE LENGTH OF STRING }
      str[strlen]:=chr(cmdbuf.ch[wp]);                { MOVE A CHAR }
      wp:=succ(wp)                            { BUMP BUFFER POINTER }
    END;
  IF strlen > 0 THEN                              { STRING IS VALID }
    BEGIN
      IF cnt THEN                   { WE NEED STRING COUNT AT FRONT }
        BEGIN
          FOR i:= (strlen+1) DOWNTO 2 DO
            str[i]:=str[(i-1)];         { SHIFT STRING ONE TO RIGHT }
          str[1]:=chr(strlen)
                             { PUT STRING LENGTH AT FRONT OF STRING }
        END
    END
END;                                                       { GETSTR }

PROCEDURE prscmd(VAR parseok:boolean);     { PARSE A KERMIT COMMAND }

VAR
  sp:integer;                            { A STRING(cmdbuf) POINTER }

BEGIN
  sp:=1;                     { POINT TO THE BEGINNING OF THE CMDBUF }
                     (******************** SEND ********************)
  IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascn)
      THEN
    BEGIN                                  { THIS IS A SEND COMMAND }
      getstr(sp,fnlen,fname,true);
                                   { GET FILE NAME TO SEND - IF ANY }
      IF fnlen = 0 THEN
        BEGIN
                      { SEND FILE NAME NOT IN CMD BUF - PROMPT USER }
          bsbuf:='FILE NAME SPECIFICATIONS WERE NOT ENTERE';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='D - TRY AGAIN PLEASE.#0D#0A                 ';
          writdev(ts,true,23,location(bsbuf))
        END
      ELSE
        BEGIN
          parseok:=true;             { CMD ENTERED SYNTACTICALLY OK }
          state:=sinitiate;                   { SET SEND INIT STATE }
          getstr(sp,rfnlen,rfname,true)
                                   { CHK FOR REMOTE FILENAME IN CMD }
                                   { A REMOTE FILE NAME IS OPTIONAL }
        END
    END;

                     (****************** RECEIVE *******************)
  IF (cmdbuf.ch[1]=ascr AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascc)
      THEN
    BEGIN                               { THIS IS A RECEIVE COMMAND }
      getstr(sp,fnlen,fname,true);
                           { GET LOCAL FILENAME TO STORE FILE UNDER }
      IF fnlen = 0 THEN
        BEGIN
          { REQUIRED RECEIVE FILE NAME NOT IN CMD BUF - PROMPT USER }
          bsbuf:='FILE NAME SPECIFICATIONS WERE NOT ENTERE';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='D - TRY AGAIN PLEASE.#0D#0A                 ';
          writdev(ts,true,23,location(bsbuf))
        END
      ELSE
        BEGIN
          state:=rcv;                               { SET RCV STATE }
          parseok:=true              { CMD ENTERED SYNTACTICALLY OK }
        END
    END;

                      (******************** GET ********************)
  IF (cmdbuf.ch[1]=ascg AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=asct)
      THEN                                  { THIS IS A GET COMMAND }
    BEGIN            { EXTRACT FROM COMMAND LINE REMOTE FILE TO GET }
      getstr(sp,rfnlen,rfname,true);
      IF rfnlen = 0 THEN
        BEGIN
            { REMOTE FILE NAME TO GET NOT IN CMD LINE - PROMPT USER }
          bsbuf:='A REMOTE FILE NAME TO GET MUST BE ENTERE';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='D - TRY AGAIN PLEASE.#0D#0A                 ';
          writdev(ts,true,23,location(bsbuf))
        END
      ELSE
        BEGIN
          getstr(sp,fnlen,fname,true);
                                 { LOCAL FILE NAME TO WRITE FILE TO }
          IF fnlen=0 THEN
            BEGIN
          { LOCAL FILE NAME TO WRITE REMOTE FILE TO NOT IN CMD LINE }
              bsbuf:='A LOCAL DX10 FILE NAME MUST BE ENTERED -';
              writdev(ts,true,40,location(bsbuf));
              bsbuf:=
                  ' TRY AGAIN PLEASE.#0D#0A                    ';
              writdev(ts,true,20,location(bsbuf))
            END
          ELSE
            BEGIN
              parseok:=true;         { CMD ENTERED SYNTACTICALLY OK }
              iinitiate;                    { MAKE INITIAL I PACKET }
              state:=getinit                { PREPARE R PACKET NEXT }
            END
        END
    END;

                     (********************* LOG ********************)
  IF (cmdbuf.ch[1]=ascl AND cmdbuf.ch[2]=asco AND cmdbuf.ch[3]=ascg)
      THEN
    BEGIN                                             { SET LOGGING }
      IF lstatus <> open THEN                    { NOT ALREADY OPEN }
        BEGIN
          getstr(sp,lnlen,lname,true); { GET USER LOG FILE - IF ANY }
          IF lnlen = 0 THEN                  { USE DEFAULT LOG FILE }
            p$parm(5,lname,perr);   { GET DEFAULT LOG FILE PATHNAME }
          sndlog:=true;
          rcvlog:=true;
          wrtlog:=true;
          redlog:=true;
          logopn;
          parseok:=true              { LOG COMMAND ACCEPTED CORRECT }
        END
      ELSE
        BEGIN
          bsbuf:='LOG FILE ALREADY OPEN - NO NEED TO SET L';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='OGGING AGAIN.#0D#0A                         ';
          writdev(ts,true,15,location(bsbuf))
        END
    END;

                     (******************** TEST ********************)
  IF (cmdbuf.ch[1]=asct AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascs)
      THEN
    BEGIN                                   { SEND ONLY FOR TESTING }
      sndonly:=true;
      parseok:=true;                { TEST COMMAND ACCEPTED CORRECT }
      bsbuf:='TEST MODE->NO PACKETS WILL BE RECEIVED#0D#0A';
      writdev(ts,true,40,location(bsbuf))
    END;

                   (******************** SERVER ********************)
  IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascr)
      THEN
    BEGIN                                   { SEND ONLY FOR TESTING }
      server:=true;
      bsbuf:='#0D#0AKERMIT SERVER RUNNING ON DX10 HOST,#0D#0AP';
      writdev(ts,true,40,location(bsbuf));
      bsbuf:='LEASE TYPE YOUR ESC SEQUENCE TO RETURN#0D#0A';
      writdev(ts,true,40,location(bsbuf));
      bsbuf:='TO YOUR LOCAL MACHINE.  SHUT DOWN#0D#0ASERVE';
      writdev(ts,true,40,location(bsbuf));
      bsbuf:='R BY TYPING THE BYE OR FINISH COMMAND #0D#0A';
      writdev(ts,true,40,location(bsbuf));
      bsbuf:='ON YOUR LOCAL MACHINE....             #0D#0A';
      writdev(ts,true,40,location(bsbuf));
      parseok:=true;                          { SERVER CMD ACCEPTED }
      makepacket(ascn,seq,0);           { SEND INITIAL NAK TO LOCAL }
      sndpkt                                   { GET THINGS ROLLING }
    END;

                  (******************** CONNECT ********************)
  IF (cmdbuf.ch[1]=ascc AND cmdbuf.ch[2]=asco AND cmdbuf.ch[3]=ascn)
      THEN
    BEGIN                                         { CONNECT COMMAND }
      IF local THEN           { CONNECT ONLY IN LOCAL MODE - PLEASE }
        BEGIN
          bsbuf:='#0D#0ACONNECTING THRU                       ';
          writdev(ts,true,18,location(bsbuf));
          FOR k:=1 TO ord(ioname[1]) DO
            bsbuf[k]:=ioname[k+1];
          writdev(ts,true,(ord(ioname[1])),location(bsbuf));
          bsbuf:=', SPEED 1200#0D#0ATO ESCAPE AND RETURN TO YO';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='UR LOCAL  #0D#0ASYSTEM - TYPE TWO "AT SIGN" ';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:=' @  #0D#0ACHARACTERS IN QUICK SEQUENCE.   #0D#0A';
          writdev(ts,true,40,location(bsbuf));
          IF NOT isc THEN
            passt(ts,true)
                      { SET PASSTHRU MODE WHILE CONNECTED TO REMOTE }
          ELSE             { DISPLAY SPECIAL CHAR SEQUENCES FOR ISC }
            BEGIN
              tcbuf:=crlf;
              writdev(ts,true,2,location(tcbuf));
              writdev(ts,true,2,location(tcbuf));
              bsbuf:='TYPE THE FOLLOWING IN FAST SEQUENCE : #0D#0A';
              writdev(ts,true,40,location(bsbuf));
              bsbuf:='^ ^ (TWO UP ARROWS) FOR CMD KEY.      #0D#0A';
              writdev(ts,true,40,location(bsbuf));
              bsbuf:='% % (TWO PERCENTS) FOR BLNK ORNGE KEY.#0D#0A';
              writdev(ts,true,40,location(bsbuf));
              bsbuf:='@ ^ ( AT SIGN AND UP ARROW) FOR ESQ.  #0D#0A';
              writdev(ts,true,40,location(bsbuf));
              bsbuf:='@ % ( AT SIGN AND PERCENT) FOR DC1.   #0D#0A';
              writdev(ts,true,40,location(bsbuf));
              writdev(ts,true,2,location(tcbuf))
            END;
          IF ts.stat=0 THEN
            connect;                 { GO ATTEMPT CONNECT TO REMOTE }
          bsbuf:='#0A#0DKERMIT IS BACK TO LOCAL SYSTEM.     #0D#0A';
          writdev(ts,true,40,location(bsbuf));
          IF ts.stat<>0 THEN
            BEGIN         { CONSOLE TERMINAL I/O ERR DURING CONNECT }
              bsbuf:='CONSOLE TERMINAL ERROR DURING CONNECT.#0D#0A';
              writdev(ts,true,40,location(bsbuf))
            END;
          IF ps.stat<>0 THEN
            BEGIN            { REMOTE PORT I/O ERROR DURING CONNECT }
              bsbuf:='REMOTE PORT I/O ERROR DURING CONNECT. #0D#0A';
              writdev(ts,true,40,location(bsbuf))
            END;
          IF NOT isc THEN                       { TURN OFF PASSTHRU }
            BEGIN                  { SO WE CAN DO CMD CONTROL AGAIN }
              IF bsy IN ts.flags THEN         { ABORT ANY I/O FIRST }
                abort(ts);          { OR PASSTHRU WON'T BE AFFECTED }
              passt(ts,false)                    { THEN TURN IT OFF }
            END;
          parseok:=true   { ONLY ERR ON THIS COMMAND IS MISSPELLING }
        END
      ELSE
        BEGIN
          bsbuf:='#0D#0AYOU HAVE ALREADY CONNECTED TO A REMOTE';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='#0D#0ASYSTEM.  USE YOUR ESCAPE SEQUENCE IF Y';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='OU #0D#0AWISH TO RETURN TO YOUR LOCAL SYSTEM';
          writdev(ts,true,40,location(bsbuf));
          bsbuf:='.#0D#0A                                     ';
          writdev(ts,true,3,location(bsbuf))
        END
    END;

                   (******************** FINISH ********************)
  IF (cmdbuf.ch[1]=ascf AND cmdbuf.ch[2]=asci AND cmdbuf.ch[3]=ascn)
      THEN
    BEGIN                           { USER TYPED THE FINISH COMMAND }
      parseok:=true;                 { CMD ENTERED SYNTACTICALLY OK }
      iinitiate;                 { MAKE REQUIRED PRECEDING I PACKET }
      state:=fininit
    END;

                      (******************** BYE ********************)
  IF (cmdbuf.ch[1]=ascb AND cmdbuf.ch[2]=ascy AND cmdbuf.ch[3]=asce)
      THEN
    BEGIN                              { USER TYPED THE BYE COMMAND }
      parseok:=true;                 { CMD ENTERED SYNTACTICALLY OK }
      iinitiate;                 { MAKE REQUIRED PRECEDING I PACKET }
      state:=byeinit
    END;

                      (******************** SET-RESERVED FOR FUTURE*)
  IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=asct)
      THEN
    BEGIN                                  { SET A KERMIT PARAMETER }
      sp:=4;                                      { WE GOT PAST SET }
      WHILE cmdbuf.ch[sp]=ascsp AND sp<30 DO
        sp:=succ(sp);                                 { SKIP SPACES }
      parseok:=true;
      bsbuf:='SET COMMAND RESERVED FOR FUTURE USE.  #0D#0A';
   { YOU COULD PROBABLY IMPLEMENT SET BAUD , SET PARITY, ETC. HERE. }
      writdev(ts,true,40,location(bsbuf))
    END;

                     (******************** HELP ********************)
  IF (cmdbuf.ch[1]=asch AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascl)
      THEN
    BEGIN                                         { USER WANTS HELP }
      help;                                          { SO HELP USER }
      state:=cexit;
      parseok:=true                             { COMMAND PARSED OK }
    END;

                   (******************** BINARY ********************)
  IF (cmdbuf.ch[1]=ascb AND cmdbuf.ch[2]=asci AND cmdbuf.ch[3]=ascn)
      THEN
    BEGIN                                    { SET BINARY FILE TYPE }
      optqu8:=ascamp;              { EIGHT-BIT QUOTING WILL BE DONE }
      crlfeol:=false;            { NO CARRIAGE CON. IN BINARY FILES }
      binary:=true;                    { BINARY TYPE FILE TRANSFERS }
      bsbuf:='BINARY FILE - 8 BIT QUOTING TURNED ON.#0D#0A';
      writdev(ts,true,40,location(bsbuf));
      state:=cexit;
      parseok:=true                             { COMMAND PARSED OK }
    END;

                   (********************** TEXT ********************)
  IF (cmdbuf.ch[1]=asct AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascx)
      THEN
    BEGIN                                      { SET TEXT FILE TYPE }
      optqu8:=0;                { NO EIGHT-BIT QUOTING WILL BE DONE }
      crlfeol:=true;                      { SET CARRIAGE CONTROL ON }
      binary:=false;                          { NO BINARY FILE TYPE }
      bsbuf:='TEXT FILE TYPE TRANSFER TURNED ON.    #0D#0A';
      writdev(ts,true,40,location(bsbuf));
      state:=cexit;
      parseok:=true                             { COMMAND PARSED OK }
    END;

                    (********************* EXIT ********************)
  IF (cmdbuf.ch[1]=asce AND cmdbuf.ch[2]=ascx AND cmdbuf.ch[3]=asci)
      THEN
    BEGIN                                   { SET PROPER EXIT FLAGS }
      server:=false;
      state:=kexit;
      parseok:=true                 { EXIT COMMAND ACCEPTED CORRECT }
    END;

END;

PROCEDURE getcmd;                { INTERACTIVELY GET A USER COMMAND }

VAR
  validcmd:boolean;

BEGIN                                                      { GETCMD }
  validcmd:=false;
  tcbuf:=crlf;
  writdev(ts,true,2,location(tcbuf));
  WHILE NOT validcmd DO
    BEGIN
      ssbuf:='KERMIT-990> ';    { USER PROMPT- MODIFIABLE IN FUTURE }
      writdev(ts,true,12,location(ssbuf));
      bufinit(cmdbuf);                   { CLEAR THE COMMAND BUFFER }
      IF local THEN
        BEGIN
          ts.lrl:=size(cmdbuf.ch);           { SIZE OF BUF FOR READ }
          readdev(ts,true,location(cmdbuf.ch));
          cmdbuf.ln:=ts.cc;           { GET ACTUAL SIZE OF CMD READ }
          ssbuf:='#0D#0A          ';         { JUST CRLF FOR OTHERS }
          writdev(ts,true,2,location(ssbuf))
        END
      ELSE    { PORT IS IN PASSTHRU MODE SO READ ONE CHAR AT A TIME }
        BEGIN
          ineoln:=false;                       { NOT END OF CMD YET }
          WHILE NOT ineoln DO                { CMD ENDS WITH RETURN }
            BEGIN
              readdev(ts,true,location(tcbuf));        { GET A CHAR }
              IF tcbuf[1]='#0D' THEN
                BEGIN
                  tcbuf:=crlf;       { ECHO PROPER CARRIAGE CONTROL }
                  writdev(ts,true,2,location(tcbuf));
                  ineoln:=true               { ACCEPT AND PARSE CMD }
                END
              ELSE
                IF tcbuf[1]='#08' THEN
                  BEGIN
                    IF cmdbuf.ln>=1 THEN              { BS IS LEGAL }
                      BEGIN
                        ssbuf:='#08 #08         ';
                                          { THIS IS A BS? - ALMOST! }
                        writdev(ts,true,3,location(ssbuf));
                        cmdbuf.ch[cmdbuf.ln]:=ascsp;
                                        { BLANK POSITION IN CMD BUF }
                        cmdbuf.ln:=pred(cmdbuf.ln)
                      END
                  END
                ELSE
                  BEGIN
                    writdev(ts,true,1,location(tcbuf)); { ECHO CHAR }
                    cmdbuf.ch[(cmdbuf.ln+1)]:=ord(tcbuf[1]);
                                                        { SAVE CHAR }
                    IF cmdbuf.ch[1] <> ascsp THEN
                                               { IGNORE LEAD SPACES }
                      cmdbuf.ln:=succ(cmdbuf.ln)   { INC CHAR COUNT }
                  END
            END
        END;
      IF cmdbuf.ln >1 THEN            { WE HAVE ACTUAL CMD TO PARSE }
        BEGIN
          prscmd(validcmd);                     { PARSE THE COMMAND }
          IF NOT validcmd THEN   { PARSE FAILURE --> CMD SYNTAX ERR }
            BEGIN
              bsbuf:='INCORRECT OR NON-SUPPORTED COMMAND:     ';
              writdev(ts,true,38,location(bsbuf));
              FOR i:=1 TO cmdbuf.ln DO
                BEGIN
                  tcbuf[1]:=chr(cmdbuf.ch[i]);
                  writdev(ts,true,1,location(tcbuf))
                                                  { DISPLAY BAD CMD }
                END;
              tcbuf:='#0D#0A';
              writdev(ts,true,2,location(tcbuf))
            END
        END
    END
END;                                                       { GETCMD }

{ ************************* Main block **************************** }

BEGIN                                                      { KERMIT }
         { LET'S TAKE CARE OF SOME STANDARD FILE I/O INITIALIZATION }
  p$parm(6,ioname,perr);            { GET MY STATUS LOCAL OR REMOTE }
  local:=ioname[2]='L';
  p$parm(7,ioname,perr);           { CHECK FOR SPECIAL ISC TERMINAL }
  isc:=ioname[2]='I' AND local;
  IF local AND NOT isc THEN                { THIS BLOCK IS OPTIONAL }
    BEGIN                  { DONT TRY TO CLEAR SOME REMOTE TERMINAL }
      initscreen(blk,lun);       { ENABLE DISPLAY-ACCEPT FOR CLEARS }
      clearscreen(blk)                           { CLEAR THE SCREEN }
    END;
  p$parm(3,ioname,perr);                     { GET REMOTE PORT NAME }
  p$parm(4,tname,perr);                          { MY TERMINAL NAME }
  initio(location(tname),ts);               { OPEN CONSOLE TERMINAL }
  initio(location(ioname),ps);  { OPEN REMOTE PORT AND SET PASSTHRU }
  IF ps.stat=0 AND ts.stat=0 THEN             { PORTS READY FOR I/O }
    BEGIN                                { NORMAL KERMIT PROCESSING }
      ssbuf:='#0D#0A#0D#0A        ';
      writdev(ts,true,2,location(bsbuf));
      bsbuf:='WELCOME TO DX10 KERMIT-990 - RELEASE 1.0';
      writdev(ts,true,40,location(bsbuf));
      bsbuf:= '#0D#0A                                      ';
      writdev(ts,true,2,location(bsbuf));
      bsbuf:='TYPE HELP TO VIEW THE KERMIT COMMANDS.#0D#0A';
      writdev(ts,true,40,location(bsbuf));
      iniflg:=false;                      { FOR ONCE ONLY VAR INITS }
      state:=kcommand;
      WHILE server OR state<>kexit DO
        BEGIN
          kerminitialize;
                    { KCOMMAND MAY BE A GOOD CHOICE FOR SERVER MODE }
          WHILE NOT server AND state=kcommand DO
            getcmd;
          IF state=rcv THEN state:=kcommand;
                                  { FALL BACK TO CMD MODE AFTER RCV }
          IF state=kcommand THEN kermcommand;
          IF state=sinitiate THEN sendinitiate;
          IF state=rinitiate THEN rcvinitiate;
          WHILE state<>cexit AND state<>kexit DO
            BEGIN                            { PACKET SENDING STATE }
              REPEAT
                sndpkt;
                numtry:=numtry+1;
                IF sndonly THEN
                  BEGIN
                    rcvseq:=seq;
                    rcvtyp:=ascy;
                    rcvbuf.ln:=0
                  END
                ELSE
                  BEGIN
                    rcvpkt
                  END;
                IF rcvtyp=ascn THEN
                  BEGIN                              { RECEIVED NAK }
                    rcvseq:=(rcvseq-1) MOD 64;
                    rcvtyp:=ascy
                  END
              UNTIL (rcvseq=seq) OR (numtry>=maxtry) OR (state=
                  kexit) OR (state = cexit);
              IF (rcvseq<>seq) AND (state<>kexit) THEN
                error('DIDNT RECEIVE EXPECTED PACKET           ')
              ELSE
                IF rcvtyp=asce THEN      {Just received error packet}
                  BEGIN
                    state:=wexit
                  END
                ELSE
                  BEGIN
                    CASE state OF
                      getinit:get;
                      sheader :sendheader;
                      sdata :senddata;
                      sbreak :sendbreak;
                      rinitiate:rcvinitiate;
                      rheader :rcvheader;
                      rdata :receivedata;
                      wexit:state:=cexit;      { ALLOWS LAST SNDPKT }
                      fininit:finish;         { BUILD FINISH PACKET }
                      byeinit:bye;               { BUILD BYE PACKET }
                      kexit :;
                      cexit:
                      END
                  END
            END;
          wrtcls
        END;
      logcls;                              { CLOSE LOG FILE IF OPEN }
      bsbuf:='KERMIT END.#0D#0AHAVE A HOPPY HAPPY DAY!!!#0D#0A';
      writdev(ts,true,40,location(bsbuf))
    END
  ELSE
    IF ts.stat=0 THEN           { TERMINAL OK TO OUTPUT PORT ERR TO }
      BEGIN
        bsbuf:='KERMIT PORT OPEN FAILED - TRY AGAIN.#0D#0A#0D#0A';
        writdev(ts,true,40,location(bsbuf))
      END
END.                                                       { KERMIT }
