Columbia Kermit/kermit.zip/c/ucjlm2.txt

Text File | 2020-01-01 | 115KB | 4,093 lines

(* This file is the concatenated source for Kermit for the Joyce-Loebl Magiscan
   image processor, running UCSD p-System. Before compiling you will need to
   split the file at the clearly marked points, saving each section into a
   TEXT file of the appropriate name *)


**** File DISK.TEXT ************************************************************
(*$S+*)

{ This Unit is based on the SLVDIMS of Joyce Loebl }
{ Created by H Balen 22-Aug-84 }
{ Modified by H Balen 13-May-85 }

Unit DiskUnit;

   Interface


   Uses
      M2Types,M2IpRoot,M2Sys;

   type
     GreyVal = 0..255;
     LType = packed array[0..255] of GreyVal;
     L2Type = packed array[0..255] of char;
     LineType = record
                  case Boolean of
                    True :(i : LType);
                    False:(b : L2Type)
                    end;
     BufferType = record
                   case integer of
                    0 :(i : packed array[0..511] of GreyVal);
                    1 :(b : packed array[0..1] of L2Type);
                    2 :(Im : Image )
                    end;
   var
     Fl : File;

   procedure ImSve( Im : Image;
                     FName : String );
   procedure ImLd( var Im : Image;
                     FName  : String );

Implementation

procedure ImSve;
{ This procedure saves an image, up to eight bits }

var
   Line  : LineType;
   Buffer: BufferType;
   A,B,C,D : Image;
   Blk   : integer;


procedure Deposit( Im : Image );
{ This procedure writes the necessary data to the disk
  in units of 512 bytes,and Images of Half size       }

var
  Blks,RowNum : Integer;
  Row    : PointSet;

  procedure GetLine( LinePs : PointSet;
                     Im     : Image ;
                    var GVal: LType );
  { This procedure gets a 256 byte line from the picture }

  type
     Idynarray = array[1..1]of Integer;

  var
     Mrk : ^Integer;
     Idyn: ^Idynarray;
     i   : integer;

  begin
  { Mark the Heap, and create space }
  mark(Mrk);
  New(Idyn);
  { Sample the image over the pointset and collect data }
  ImSmp(LinePs,Im,Idyn^[0],i);
  { Transfer the sampled data to the array for returning }
  for i := 0 to 255 do
     GVal[i] := Idyn^[i];
  { Clear the heap }
  Release(Mrk)
  end{ GetLine };

begin
{ Define a pointset for sampling purposes }
DefWindow(Row,0,0,256,1);
{ Get the necessary part of the image and save it }
for RowNum := 0 to 255 do
   begin
   { Move pointset to current sample line }
   Row.Origin.Y := RowNum;
   { Sample the current line / collect the Data Values }
   GetLine(Row,Im,Line.i);
   if Odd(RowNum) then
     begin{ Write to the Disk }
     { Copy to buffer }
     Buffer.b[1] := Line.b;
     { Actual write to disk }
     Blks := BlockWrite(Fl,Buffer.i,1)
     end
    else{ Still to fill the Buffer }
      Buffer.b[0] := Line.b
   end
end{ Deposit };

begin{ Save }
{ Open the file }
Rewrite(Fl,FName);
{ Collect the attributes of the image }
Buffer.Im := Im;
{ Put image attributes at the beginning of the file }
Blk := BlockWrite(Fl,Buffer.Im,1);
{ Deal with necessary image size }
case Im.Res of
   Half: Deposit(Im);
   Full: begin
         with Im do
           begin
           { Split the image into 4 Half size images }
           DefImage(A,Origin.X,Origin.Y,Half,LsBit,NoBits);
           DefImage(B,Origin.X+256,Origin.Y,Half,LsBit,NoBits);
           DefImage(C,Origin.X+256,Origin.Y+256,Half,LsBit,NoBits);
           DefImage(D,Origin.X,Origin.Y+256,Half,LsBit,NoBits);
           { Save the image on disk }
           Deposit(A);
           Deposit(B);
           Deposit(C);
           Deposit(D)
           end{ with }
         end
   end{ Case };
{ Close the file }
Close(Fl,Lock)
end{ Save };


procedure ImLd;
{ This procedure ReLoads a previously saved image }

var
   Buffer : BufferType;
   Line   : LineType;
   A,B,C,D: Image;
   L,N,Blk: Integer;
   Error  : Boolean;


procedure ReDraw( var Im : Image );
{ This procedure draws a Half size image on the screen }

var
  RowNum,Blks : integer;
  Row    : PointSet;


  procedure PutRow( LinePs : PointSet;
                   var Im  : Image;
                   var GVal: LType );
  { This procedure gets the current row and draws it }

  type
    Idynarray = array[1..1] of integer;

  var
    Mrk : ^integer;
    Idyn: ^Idynarray;
    i   : integer;

  begin
  { Mark Heap and make room }
  mark(Mrk);
  New(Idyn);
  { Get the current line }
  for i := 0 to 255 do
    Idyn^[i] := GVal[i];
  { Draw the line }
  DrawFn(LinePs,Im,Idyn^[0]);
  { Tidy the Heap }
  release(Mrk)
  end{ PutRow };


begin
{ Define a PointSet for the current line }
DefWindow(Row,0,0,256,1);
{ Draw the Half image to screen }
for RowNum := 0 to 255 do
  begin
  { Move the PointSet to the current Line position }
  Row.Origin.Y := RowNum;
  if Odd(RowNum) then
    begin{ Read the Buffer }
    Line.b := Buffer.b[1];
    { and put on screen }
    PutRow(Row,Im,Line.i)
    end
   else
     begin{ Fill the Buffer from the Disk }
     Blks := BlockRead(Fl,Buffer.i,1);
     { Then read it and put on screen }
     Line.b := Buffer.b[0];
     PutRow(Row,Im,Line.i)
     end
  end
end{ ReDraw };

begin
{ Take care of possible file name fault }
(*$I-*)
Reset(Fl,FName);
Error := IOResult <> 0;
(*$I+*)
{ If we have the correct file then }
if not Error then
  begin{ Get the details of the stored image }
  Blk := BlockRead(Fl,Buffer.Im,1);
  { If the stored image does not match the declared image }
  if (Buffer.Im.Res <> Im.Res) then{ error }
    writeln(' ReLoad : Image Resolution incompatible ')
   else{ Everything ok }
    begin
    { Take care of image size }
    case Im.Res of
     Half: ReDraw(Im);
     Full: begin
           with Im do
            begin
            { Split image into 4 Half size images }
            L := LsBit;N := NoBits;
            DefImage(A,Origin.X,Origin.Y,Half,L,N);
            DefImage(B,Origin.X+256,Origin.Y,Half,L,N);
            DefImage(C,Origin.X+256,Origin.Y+256,Half,L,N);
            DefImage(D,Origin.X,Origin.Y+256,Half,L,N);
            { Get each image and draw it }
            ReDraw(A);
            ReDraw(B);
            ReDraw(C);
            ReDraw(D);
            end{ With };
           end;
     end{ Case }
    end;
   Close(Fl)
   end{ Not Error }
  else{ Error in file name }
    writeln(' ReLoad : Image file open error ')
end{ ReLoad };



end{ Save }.

**** File FILEUNIT.TEXT ********************************************************

(*$S+*)
{ This unit contains the primitives necessary to store
  the incoming data on the disk specified }

Unit FileHandle;

Interface

   Uses
     M2Types,M2IpRoot,M2Sys,
     (*$U Disk.Code*)DiskUnit;


   const
     BufEnd = 512;

   type
     BuffType = packed array[1..BufEnd] of char;
     FStates  = (TxtFile,BinFile,ImgFile,CodeFile); { File States }

   var
     FileBuf    : BuffType;
     BuffPosn   : integer;
     Disk       : String[3];
     TF         : Text;
     F          : File;
     TranState  : FStates;
     EOI        : boolean; { End of Image ! }



   procedure FileInit;

   procedure CloseF(var Name   : string;
                        Save   : boolean );

   function ReadOpenF(var Name     : string ;
                          State    : FStates ): boolean;

   function WriteOpenF(var Name     : string ;
                           State    : FStates ): boolean;

   procedure SaveBuff(var Buff : BuffType;
                      var Posn : integer;
                       NewLine : boolean  );

   procedure ReadBuff(var Buff : BuffType;
                      var Posn : integer );

   procedure LoadIm(var Name : string );



Implementation

var
  Im,TxtIm       : Image;
  Tab            : IOTab;
  Line           : PointSet;
  YPosn          : integer;

(* ---------------------------------------------------- *)

procedure GetLine(var Line   : PointSet;
                      Im     : Image;
                  var Buff   : BuffType );

type
  IdynArray = array[1..1]of Integer;

var
  Mrk     : ^integer;
  Idyn    : ^IdynArray;
  i       : integer;

begin
mark(Mrk);
New(Idyn);
ImSmp(Line,Im,Idyn^[0],i);
for i := 0 to 511 do
  Buff[i+1] := chr(Idyn^[i]);
Release(Mrk)
end{GetLine};

(* ---------------------------------------------------- *)

procedure PutLine(var Line   : PointSet;
                      Im     : image;
                  var Buff   : BuffType );

type
  IdynArray = array[1..1]of Integer;

var
  Mrk     : ^integer;
  Idyn    : ^IdynArray;
  i       : integer;

begin
mark(Mrk);
New(Idyn);
for i := 1 to BufEnd do
  Idyn^[i-1] := ord(Buff[i]);
DrawFn(Line,Im,Idyn^[0]);
Release(Mrk)
end{PutLine};

(* ---------------------------------------------------- *)

procedure InitF;

begin
SysInit;
DefImage(Im,0,512,Full,8,8);
DefImage(TxtIm,0,512,Full,0,1);
DefWindow(Line,0,512,512,1);
LinearIO(Tab,0,255);
Live(Im,Tab,Tab);
Photo;
Display(Im,Tab);
ClearIm(Im);
OvLay(TxtIm,XSat+Yellow);
YPosn := 511;
EOI := TranState <> ImgFile
end{InitF};

(* ---------------------------------------------------- *)

procedure LoadIm;

var
  Ok   : boolean;

begin
if TranState = ImgFile then
  begin
  InitF;
  (*$I-*)
  Reset(F,concat(disk,name));
  Ok := ioresult = 0;
  (*$I+*)
  write(chr(ff));
  if Ok then
    begin
    writeln('LOADING THE IMAGE');
    ImLd(Im,concat(disk,name))
    end
   else
     begin
     writeln('FILE DOES NOT EXIST');
     CursorOn;
     ScrollOn
     end
  end
 else
   writeln('Transfer type is not IMAGE')
end{LoadIm};

(* ---------------------------------------------------- *)

procedure EmptyBuff(var FileBuffer : BuffType;
                    var Posn       : integer );
{ This procedure Empties the buffer }

var
  i   : integer;

begin
for i := 1 to BufEnd do
  FileBuffer[i] := chr(0); { set all to nulls }
Posn := 1 { set the position at the begining }
end{EmptyBuff};

(* ---------------------------------------------------- *)

procedure FileInit;
{ This procedure initialises the unit,
  the disk is set up in the main program }

begin
EmptyBuff(FileBuf,BuffPosn);
TranState := TxtFile;
EOI := TranState <> ImgFile
end{fInit};

(* ---------------------------------------------------- *)

procedure CloseF;
{ This procedure closes the file, neatly. }

var
  Blk,i  : integer;
  s      : string;
  Key    : char;

begin
if Save then
  begin { we wish to save the file }
  case TranState of
    TxtFile          : begin
                       s := copy('',0,0);
                       if (BuffPosn <= BufEnd) and (BuffPosn > 1) then
                         begin
                         for i := 1 to pred(BuffPosn) do
                          begin
                          s := concat(s,' ');
                          s[Length(s)] := FileBuf[i]
                          end;
                         write(TF,s);
                         end;
                       Close(TF,Lock)
                       end;
    ImgFile          : begin
                       if (BuffPosn > 1) and (YPosn >= 0) then
                         begin
                         Line.Origin.Y := YPosn;
                         PutLine(Line,Im,FileBuf)
                         end;
                       EOI := True;
                       write('DO YOU WISH TO SAVE THE IMAGE ? ');
                       repeat
                         read(KeyBoard,Key)
                       until Key in ['Y','y','N','n'];
                       if Key in ['Y','y'] then
                         ImSve(Im,concat(disk,name))
                       end;
    CodeFile,BinFile : begin
                       if BuffPosn > 1 then
                         Blk := BlockWrite(F,FileBuf,1);
                       Close(F,Lock);
                       end
    end{case};
  EmptyBuff(FileBuf,BuffPosn)
  end
 else
   begin { This makes sure the file will be closed }
   close(TF);
   close(F)
   end;
CursorOn;
ScrollON
end{CloseF};

(* ---------------------------------------------------- *)

function ReadOpenF;
{ This procedure opens the file for reading }

var
  OK  : boolean;
  Blk : integer;

begin
EmptyBuff(FileBuf,BuffPosn);
EOI := TranState <> ImgFile;
if TranState <> ImgFile then
  begin
  (*$I-*)
  reset(F,concat(disk,name));
  OK := ioresult = 0;
  (*$I+*)
  if (State = TxtFile) then
    begin
    Blk := BlockRead(F,FileBuf,1);
    Blk := BlockRead(F,FileBuf,1)
    end
  end
 else
   begin{ this is an image file }
   OK := True;
   end;
ReadOpenF := OK
end{OpenF};

(* ---------------------------------------------------- *)

function WriteOpenF;
{ This procedure opens the file for writing }

var
  OK  : boolean;
  Blk : integer;

begin
EmptyBuff(FileBuf,BuffPosn);
(*$I-*)
if TranState <> TxtFile then
  begin
  if TranState = ImgFile then
    begin
    write(chr(ff));
    InitF;
    ClearIm(Im);
    OK := True
    end
   else
     begin
     rewrite(F,concat(disk,name));
     OK := ioresult = 0
     end
  end
 else
   begin
   ReWrite(TF,concat(disk,name));
   OK := ioresult = 0
   end;
(*$I+*)
WriteOpenF := OK
end{OpenF};

(* ---------------------------------------------------- *)

procedure SaveBuff;
{ This procedure empties the buffer into the current file }

var
  Blk,i : integer;
  s     : string;

begin
{ If it is a text file then }
if TranState = TxtFile then
  begin{ Insert a string ! }
  s := copy('',0,0);
  for i := 1 to pred(Posn) do
    begin
    s := concat(s,' ');
    s[Length(s)] := Buff[i]
    end;
  if NewLine then
    begin
    if Length(s) = 0 then
      writeln(TF)
     else
       writeln(TF,s)
    end
   else
     write(TF,s);
  EmptyBuff(Buff,Posn)
  end
 else{ insert the buffer as it is when full }
   if Posn > BufEnd then
     begin
     if TranState = ImgFile then
       begin
       if YPosn >= 0 then
         begin
         Line.Origin.Y := YPosn;
         PutLine(Line,Im,Buff);
         YPosn := YPosn -1
         end
        else
          EOI := True;
       EmptyBuff(Buff,Posn)
       end
      else
        begin
        Blk := BlockWrite(F,Buff,1);
        EmptyBuff(Buff,Posn)
        end
     end
end{SaveBuff};

(* ---------------------------------------------------- *)

procedure ReadBuff;
{ This procedure fills the buffer from the file when
  necessary }

var
  Blk    : integer;

begin
if ((Posn <= 1) or (Posn > BufEnd)) and (not EOF(F)) and (TranState <> ImgFile) then
  begin
  Blk := BlockRead(F,Buff,1);
  Posn := 1
  end
 else
   if ((Posn <=1) or (Posn > BufEnd)) and (TranState = ImgFile) then
     begin
     if YPosn >= 0 then
       begin
       Posn := 1;
       Line.Origin.Y := YPosn;
       GetLine(Line,Im,Buff);
       YPosn := YPosn - 1
       end
      else
        EOI := True;
     end
end{ReadBuff};

(* ---------------------------------------------------- *)

end{FileHandle}.

**** File BINUTILS.TEXT ********************************************************

{ This contains the routines for eight bit quoting }

(* ---------------------------------------------------- *)

procedure Bbufemp(* var buffer : pakettype;
                      Len    : integer  *);
{ procedure to empty the buffe into a file }

var
  r      : char;
  i      : integer;

begin
i := 0;

while i < Len do { while not at the end of packet do }
  begin
  r := buffer[i];
  if (r = myquote) then { if myquote the a control char ? }
    begin{get quoted character}
    i := i + 1;
    r := buffer[i];
    if (aand(ord(r),127) <> ord(myquote)) and
       (aand(ord(r),127) <> ord(mybquote)) then
      r := ctl(r) { controlify the character }
    end
   else
     if (r = myBquote) then { if mybquote then eight bit should be set }
       begin{get the binary character}
       i := i + 1;
       r := buffer[i];
       if (aand(ord(r),127) = ord(myquote)) then { is a control char }
         begin
         i := i + 1;
         r := buffer[i];
         if (aand(ord(r),127) <> ord(myquote)) and
            (aand(ord(r),127) <> ord(mybquote)) then
           r := ctl(chr(aand(ord(r),127)));
         end;
       r := chr(aand(ord(r),127) + 128) { add in eight bit }
       end
      else
        begin{get the normal character}
        r := chr(aand(ord(r),127))
        end;
  i := i + 1;
  FileBuf[BuffPosn] := r; { put in the file buffer }
  BuffPosn := BuffPosn + 1;
  if BuffPosn > BufEnd then { if file buffer full then save it }
    SaveBuff(FileBuf,BuffPosn,False)
  end{while}

end{Bbufemp};

(* ---------------------------------------------------- *)

function Bbufill(*var buffer: packettype): integer*);
{ This fills a packet from the file }

var i,j,k : integer;
    r     : char;
    OK    : boolean;

begin
OK := ((not eof(f)) and (TranState <> ImgFile)) or
      ((not EOI) and (TranState = ImgFile));

i := 0;
(* while file has some data & packet has some room we'll keep going *)
while ((buffposn <= bufend) or OK) and (i < spsiz-8) do
  begin
  ReadBuff(FileBuf,BuffPosn);(* while *)
  if (buffposn <= bufend) then     (* if we're within buffer bounds *)
    begin
    r := filebuf[buffposn];      (* get a character *)
    buffposn := buffposn + 1;         (* increase buffer pointer *)
    if ord(r) > 127 then
      begin{we have the eight bit set }
      buffer[i] := bquote;
      i := i + 1;
      r := chr(aand(ord(r),127));{ convert to 7 bit }
      if (r in ctlset) then
        begin
        buffer[i] := quote;
        i := i + 1;
        if (r <> quote) and (r <> bquote) then
          r := ctl(r);
        end
      end
     else
       if (r in ctlset) then     (* if a control char *)
         begin
         buffer[i] := quote;      (* put the quote in buffer *)
         i := i + 1;
         if (r <> quote) and (r <> bquote) then
             r := ctl(r);   (* and un-controllify char *)
         end;
    buffer[i] := r; { update the buffer }
    i := i + 1;
    end;
  OK := ((not eof(f)) and (TranState <> ImgFile)) or
        ((not EOI) and (TranState = ImgFile));
  end{while};
if (i = 0) then                         (* if we're at end of file, *)
  Bbufill := (at_eof)                    (* indicate it *)
 else                                    (* else *)
   Bbufill := i                           (* return # of chars in packet *)
end; (* Bbufill *)

(* ---------------------------------------------------- *)

**** File HANDLE.TEXT **********************************************************

.TITL   HANDLER

.PROC   GETBUF < FUNCTION GETBUF( SOH, EOP, TIMEOUT : INTEGER;
                                  VAR S        : STRING ):BOOLEAN; >

;-----------------------------------------------------------;
;                                                           ;
; written by H Balen    March 1986                          ;
;                                                           ;
; This is a microcode routine to receive a packet for the   ;
; Magiscans KERMIT program.                                 ;
;                                                           ;
; SOH = 'my_soh' start of packet                            ;
; EOP = 'my_eop' end of the packet                          ;
; TIMEOUT = number of loops before giving up                ;
; S = the buffer in which to store the data                 ;
;                                                           ;
;                                                           ;
;-----------------------------------------------------------;


.REG EOP
.REG SOH
.REG STRPTR
.REG INDPSN
.REG WPSN
.REG CBYTE
.REG VALUE
.REG WRDPTR
.REG TCOUNT
.REG TIMOUT

GETBUF: NOP                     :JSR DUMP2      ; Zero the count
        ZER TCOUNT              :JSR ACPOP      ; and the posn
        MOV AC,STRPTR           :JSR ACPOP      ; Set the string and word pointers
        MOV AC,TIMOUT           :JSR ACPOP      ; get wait
        MOV AC,EOP              :JSR ACPOP      ; get special characters
        MOV AC,SOH

LAB1:   ZER INDPSN
        MOV STRPTR,AC
        MOV AC,WRDPTR

LOOP:   INC TCOUNT                              ; check the time out
        MOV TIMOUT,AC
        SUB AC,COUNT,#
        MOV %0004,AC            :JMP LEAVE ZR
        SUB AC,C16,RMSK                         ; check the status register
        MOV C255,AC             :JSR STATSET
        AND IO(RS),C1,AC
        NOP                     :JMP LOOP NZ

        MOV %0038,IOA                           ; read the port
        MOV IO,AC
        AND AC,%7F,AC

        SUB AC,SOH,#                            ; check the special chars
        SUB AC,EOP,#            :JMP LAB1 ZR
        MOV AC,CBYTE            :JMP PEND ZR

        NOP                     :JSR STORUP     ; store the byte
        NOP                     :JMP LOOP       ; continue to loop

PEND:   MOV STRPTR,MAF                          ; routine to leave the microcode procedure
        MOV MM,AC                               ; store the length of the string
        AND AC,%FF00,AC
        MOV AC,VALUE
        MOV INDPSN,AC
        AND AC,%00FF,AC
        OR  AC,VALUE,AC
        MOV AC,MM
        MOV C1,AC
FEND:   NOP                     :JSR ACPUSH
        NOP                     :JMP ENDIPC
LEAVE:  ZER AC                  :JMP FEND

STORUP: INC INDPSN                              ; find the index
        MOV INDPSN,AC
        MOV WRDPTR,MAF
        AND AC,C1,#                             ; if the index is odd then store in high byte of word
        MOV MM,AC               :JMP ODD NZ
        AND AC,%FF00,AC                         ; else store in the low byte
        MOV AC,VALUE
        MOV CBYTE,AC
        AND AC,%00FF,AC
        OR  AC,VALUE,AC
        MOV AC,MM               :RET

ODD:    AND AC,%00FF,AC                         ; store in high byte
        MOV AC,VALUE
        MOV CBYTE,AC
        AND AC(8L),%FF00,AC
        OR  AC,VALUE,AC
        MOV AC,MM
        INC WRDPTR              :RET

**** File HELP.TEXT ************************************************************

segment procedure help;
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}
{ Adapted for the Magiscan 2 by H Balen, Lancaster U }

procedure keypress;

var
  ch: char;

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

procedure help1;

var ch: char;

begin
write(chr(ff));
if (noun = nullsym) then
  begin
  writeln('KERMIT is a family of  programs that do reliable file transfer');
  writeln('between computers over TTY lines.  KERMIT can also be used to ');
  writeln('make the microcomputer behave as a terminal for a mainframe.  ');
  writeln('These are the commands for theUCSD p-system version, ');
  writeln('KERMIT-UCSD:');
  writeln
  end; (* if *)
if (noun = nullsym) or (noun = consym) then
  begin
  writeln('  CONNECT     To make a "virutual terminal" connection to ');
  writeln('              a remote system. To break the connection and');
  writeln('              "escape" back to the micro, type the escape ');
  writeln('              sequence (CTRL-] C, that is Control rightbracket');
  writeln('              followed immediately by the letter C.)');
  writeln;
  end; (* if *)
if (noun = nullsym) or (noun = exitsym) then
  begin
  writeln('  EXIT        To return back to main command level of the');
  writeln('              p-system.');
  writeln;
  end; (* if *)
if (noun = nullsym) or (noun = helpsym) then
  begin
  writeln('  HELP        To get a list of KERMIT commands.');
  writeln;
  end; (* if *)
if (noun = nullsym) or (noun = quitsym) then
  begin
  writeln('  QUIT        Same as EXIT.');
  writeln;
  end; (* if *)
if (noun = nullsym) or (noun = recsym) then
  begin
  writeln('  RECEIVE     To accept a file from the remote system.');
  writeln;
  end; (* if *)
end; (* help1 *)

procedure help2;

var
  ch  : char;

begin
if (noun = nullsym) or (noun = loadsym) then
  begin
  writeln('  LOAD        To load an image from the current disk.');
  writeln;
  end; (* if *)
if (noun = nullsym) or (noun = sendsym) then
  begin
  writeln('  SEND        To send a file or group of files to the remote');
  writeln('              system.');
  writeln;
  end; (* if *)
if (noun = nullsym) then
    keypress;
end{help2};

procedure help3;

var ch: char;

begin
if (noun = nullsym) or (noun = setsym) then
  begin
  writeln('  SET         To establish system-dependent parameters.  The ');
  writeln('              SET options are as follows: ');
  writeln;
  if (adj = nullsym) or (adj = baudsym) then
    begin
    writeln('              BAUD             75 to 9600, default is 1200. ');
    writeln('                               This sets the baud rate for the');
    writeln('                               system, should be done before');
    writeln('                               a conect, and is a mutiple of');
    writeln('                               75 by a power of two.');
    writeln;
    end;{if}
  if (adj = nullsym) or (adj = debugsym) then
    begin
    writeln('              DEBUG            To set debug mode ON or OFF ');
    writeln('                               (default is OFF).');
    writeln;
    end; (* if *)
  if (adj = nullsym) or (adj = dirsym) then
    begin
    writeln('              DISK             4/5/9/10, default is 5. This');
    writeln('                               sets the drive to be one of');
    writeln('                               the volumes/disks in existance');
    writeln('                               on the M2.');
    writeln;
    end;{if}
  if (adj = nullsym) then
      keypress;
  end; (* if *)
end; (* help3 *)

procedure help4;

begin
if (noun = nullsym) or (noun = setsym) then
  begin
  if (adj = nullsym) or (adj = escsym) then
    begin
    writeln('              ESCAPE           To change the escape sequence');
    writeln('                               that lets you return to the ');
    writeln('                               PC Kermit from the remote host.');
    writeln('                               The default is CTRL-] c.');
    writeln;
    end; (* if *)
  if (adj = nullsym) or (adj = filewarnsym) then
    begin
    writeln('              FILE-WARNING     ON/OFF, default is OFF.  If');
    writeln('                               ON, Kermit will warn you and');
    writeln('                               rename an incoming file so as');
    writeln('                               not to write over a file that');
    writeln('                               currently exists with the');
    writeln('                               same name');
    writeln;
    end; (* if *)
  end; (* if *)
end; (* help4 *)

procedure help5;

begin
if (noun = setsym) or (noun = nullsym) then
  begin
  if (adj = nullsym) or (adj = ibmsym) then
    begin
    writeln('              IBM              ON/OFF, default is OFF.  This');
    writeln('                               flag should be ON only when ');
    writeln('                               transfering files between the');
    writeln('                               micro and an IBM VM/CMS system.');
    writeln('                               It also causes the parity to be');
    writeln('                               set appropriately (mark) and ');
    writeln('                               activates local echoing');
    writeln;
    end; (* if *)
  if (adj = nullsym) then
      keypress;
  if (adj = nullsym) or (adj = localsym) then
    begin
    writeln('              LOCAL-ECHO       ON/OFF, default is OFF. This');
    writeln('                               sets the duplex.  It should be');
    writeln('                               ON when using the IBM and OFF ');
    writeln('                               for the DEC-20.');
    writeln;
    end; (* if *)
  end; (* if *)
end; (* help5 *)

procedure Help6;

begin
if (noun = setsym) or (noun = nullsym) then
  begin
  if (adj = nullsym) or (adj = paritysym) then
    begin
    writeln('              PARITY           EVEN, ODD, MARK, SPACE, ');
    writeln('                               or NONE. NONE is the default');
    writeln('                               but if the IBM flag is set, ');
    writeln('                               parity is set to MARK. This ');
    writeln('                               flag selects the parity for ');
    writeln('                               outgoing and incoming ');
    writeln('                               characters during CONNECT and');
    writeln('                               file transfer to match the');
    writeln('                               requirements of the host.');
    writeln;
    end; (* if *)
  if (noun = paritysym) then
    KeyPress
  end{if};
if (noun = transym) or (noun = nullsym) then
  begin
  writeln('  TRANSFER    To set the type of transfer, the types can ');
  writeln('              be TEXT, CODE, DATA, IMAGE. The format of the ');
  writeln('              command is TRANSFER TYPE <type>          ');
  writeln;
  if (noun = transym) then
    KeyPress;
  end; (* if *)
end{help6};

procedure Help7;

begin
if (noun = nullsym) or (noun = showsym) then
  begin
  writeln('  SHOW        To see the values of parameters that can be');
  writeln('              modified via the SET command.  Options are the');
  writeln('              same as for SET,  except that a SHOW ALL ');
  writeln('              command has been added.');
  KeyPress;
  end; (* if *)
end{Help7};

begin
help1;
help2;
help3;
help4;
help5;
help6;
help7
end; (* help *)

**** File KERMIT.TEXT **********************************************************

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

{Adapted to Joyce Loebl's Magiscan 2 Image processing computer,
 by Henry Balen, Lancaster University }
{Changes:
- added ability for the parser to recognize digits,
  this enabled a Baudrate command to be implemented
- added a command to set a work disk, set disk #.
- The IO subroutines were put into an unit RS232 and
  changed to suit the Magiscan.
- put the parser back into an unit since the Magiscan has 128K
  available.
- modified the constants for the screen because the Magiscan only
  has 64 columns.
- Added a unit SysUnit to enable the user to interogate the
  current work disk and delete files if so wishes.
- Added a unit FileHandle which gives routines for accessing
  files for reading and writing, the old version of this didn't
  close a file if there was an unsuccessful receive/send this
  is now fixed.
- Modified the Buffer empty and fill routines to use these.
- Added the ability to do eight bit prefixing and the necessary
  routines for this.
- Have added a new command called TRANSFER ( do a TRANSFER
  TYPE <type> ), which enables transfers of image,data,code and
  text 'types'.
- There is also image LOAD routine implemented, this allows
  the images to be loaded from disk and transfered to the Host
  straight from image memory.
}
{ Futher changes by H Balen, now of Joyce Loebl, March 1986 }
{
- The receive packet routine has been put in the magiscan's
  microcode, data can now be succesfully received and transmitted
  at 9600 baud (except images ! max =4800 ), though the screen
  cannot scroll fast enough for incoming characters greater
  than 1200.
- Two new options have been included - they are the MUX delay
  which tells the Magiscan how many cycles the wait when
  sending characters, and the option of using the winchester
  on #9.
}

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

Uses
  M2Types,M2IpRoot,M2Sys,
  (*$U DISK.CODE*)DiskUnit,
  (*$U RS232.Code*)RS232,
  (*$U SysUnit.Code*)SysUnit,
  (*$U ParUnit.Code*)ParseUnit,
  (*$U FileUnit.Code*)FileHandle,
  (*$U HANDLE.CODE*)HANDLER; { the microcode }

const blksize = 512;
      oport = 8;          (* output port # *)
      (* clearscreen = 12;   charcter which erases screen *)
      { bell = 7; }           (* ASCII bell *)
      esc = 27;           (* ASCII escape *)
      maxpack = 93;       (* maximum packet size minus 1 *)
      soh = 1;            (* start of header *)
      sp = 32;            (* ASCII space *)
      cr = 13;            (* ASCII CR *)
      lf = 10;            (* ASCII line feed *)
      dle = 16;           (* ASCII DLE (space compression prefix for psystem) *)
      del = 127;          (* delete *)
      my_esc = 29;        (* default esc char for connect (^]) *)
      maxtry = 5;         (* number of times to retry sending packet *)
      my_quote = '#';     (* quote character I'll use *)
      my_bquote = '&';    { binary quate character I'll use }
      my_pad = 0;         (* number of padding chars I need *)
      my_pchar = 0;       (* padding character I need *)
      my_eol = 13;        (* end of line character i need *)
      my_time = 5;        (* seconds after which I should be timed out *)
      maxtim = 20;        (* maximum timeout interval *)
      mintim = 2;         (* minimum time out interval *)
      at_eof = -1;        (* value to return if at eof *)
      eoln_sym = 13;      (* pascal eoln sym *)
      back_space = 8;     (* pascal backspace sym *)


(* screen control information *)
  (* console line on which to put specified info *)
      title_line = 1;
      statusline = 2;
      packet_line = 3;
      retry_line = 4;
      file_line = 5;
      error_line = 6;
      prompt_line = 7;
      debug_line = 9;
      debug_max = 12; (* Max lines of debug to show at once *)
  (* position on line to put info *)
      statuspos = 54;
      packet_pos = 19;
      retry_pos = 17;
      file_pos = 11;

      Intsize = 15;

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

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

     int_bool_rec = record (* allows integer to be treated as boolean... *)
                           (* used for numeric AND,OR,XOR...system dependent *)
                           (* replaced by set version to escape microengine
                              bug *)
                      case boolean of
                          true: (i: integer);
                          false: (b: set of 0..intsize);
                    end; (* record *)

     Port = (Terminal,Modem);


var state: char; (* current state *)
    s: string;
    eol, bquote, quote, esc_char: char;
    fwarn, ibm, half_duplex, debug: boolean;
    delay, i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
    recpkt, packet: packettype;
    padchar, ch: char;
    debf: text; (* file for debug output *)
    debnext:0..7; (* offset for next debug message *)
    parity: parity_type;
    xon: char;
    vol, Baud: integer;
    parity_array: packed array[char] of char;
    ctlset: set of char;
    rec_ok, send_ok: boolean;


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

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

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

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

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

procedure ino_error(i: integer);
forward;

procedure debugwrite(s: string);
forward;

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

procedure writescreen(s: string);
forward;

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

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

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

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

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

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

procedure Bbufemp(buffer: packettype; len: integer);
forward;

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

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

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

procedure spar(var packet: packettype);
forward;

procedure rpar(var packet: packettype);
forward;

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

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

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

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

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

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

procedure show_parms;
forward;


(*$I HELP.TEXT*) (* Segment Procedure Help *)
(*$I SENDSW.TEXT*) (* Segment Procedure Sendsw *)
(*$I RECSW.TEXT*) (* Segment Procedure Recsw *)
(*$I UTILS.TEXT *) (* General Utility procedures *)
(*$I BINUTILS.TEXT*) { Routines for Binary transfer }
(*$I RSUTILS.TEXT *) (* Utility procedures for send and receive *)

procedure connect;

(* connect to remote host (terminal emulation *)

var ch: char;
    close: boolean;

  procedure read_esc;

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

    begin
      repeat
      until read_ch(terminal,ch);       (* wait until they've typed something in
 *)
      if (ch in ['a'..'z']) then  (* uppercase it *)
          ch := chr(ord(ch) - ord('a') + ord('A'));
      if ch in [{'B',}'C','S','D','?'] then
          begin
          writeln;
          case ch of
              (*'B': sendbrk;        B: send a break to the IBM *)
              'C': close := true; (* C: end connection *)
              'S': begin          (* S: show status *)
                   noun := allsym;
                   showparms
                   end; (* S *)
              'D':begin
                  vol := ord(disk[2]) - ord('0');
                  if vol in [9,10] then
                    writeln('Cannot DIR a Winchester')
                   else
                     PrintNames(vol,value)
                  end; (* D *)
              '?': begin          (* ?: show options *)
                  (* writeln('B    Send a BREAK signal.'); *)
                  writeln('C    Close Connection, return to ');
                  writeln('     KERMIT-UCSD command level.');
                  writeln('S    Show Status of connection');
                  writeln('D    displays the current directory');
                  writeln('?    Print this list');
                  write('^',ctl(esc_char),'   send the escape ');
                  writeln('character itself to the');
                  writeln('     remote host.');
                end; (* ? *)
            end (* case *)
           end
      else if ch = esc_char then  (* ESC-char: send it out *)
        begin
          if half_duplex then
            begin
              echo(ch);
              while not istbtr do;
              sndbbt(ch);
            end (* if *)
        end (* else if *)
      else                        (* anything else: ignore *)
          write(chr(bell))
    end; (* read_esc *)

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

        if read_ch(terminal,ch) then        (* if char from keyboard then *)
            if ch <> esc_char then      (* if not ESC-char then *)
              begin
                if half_duplex then       (* echo it if half-duplex *)
                    echo(ch);
                while not istbtr do;
                sndbbt(ch)               (* send it out the port *)
              end (* if *)
            else (* ch = esc_char *)    (* else is ESC-char so *)
              read_esc;                   (* interpret next char *)
    until close;                      (* if still connected, get more *)
    writeln('Disconnected')
  end; (* connect *)

procedure fill_parity_array;

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

const min = 0;
      max = 126;

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

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

procedure write_bool(s: string; b: boolean);

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

procedure writeTrans;
{ writes the transfer state }

begin
write('Transfer Type : ');
case TranState of
  CodeFile : writeln('BINARY');
  ImgFile : writeln('IMAGE');
  TxtFile : writeln('TEXT');
"BinFile : writeln('DATA')
  end
end{writeTrans};

procedure show_parms;

(* shows the various settable parameters *)

  begin
    writeln;
    if noun in [allsym, debugsym, ibmsym, escsym, filewarnsym,
                muxsym, transym, disksym, localsym, baudsym, paritysym] then
    case noun of
        allsym:
          begin
            write_bool('Debugging is ',debug);
            writeln('Escape character is ^',ctl(esc_char));
            write_bool('File warning is ',fwarn);
            write_bool('IBM is ',ibm);
            write_bool('Local echo is ',halfduplex);
            case parity of
                evenpar: write('Even');
                markpar: write('Mark');
                nopar: write('No');
                oddpar: write('Odd');
                spacepar: write('Space');
              end; (* case *)
            writeln(' parity');
            writeln('Baudrate is ',Baud);
            writeln('Drive is ',disk);
            writeln('MUX is ',MUXDelay);
            writetrans
          end; (* allsym *)
        debugsym: write_bool('Debugging is ',debug);
        escsym: writeln('Escape character is ^',ctl(esc_char));
        filewarnsym: write_bool('File warning is ',fwarn);
        ibmsym: write_bool('IBM is ',ibm);
        localsym: write_bool('Local echo is ',halfduplex);
        baudsym : writeln('Baudrate is ',Baud);
        disksym : writeln('Drive is ',disk);
        transym : writetrans;
        muxsym : writeln('MUX is ',MUXDelay);
        paritysym: begin
            case parity of
                evenpar: write('Even');
                markpar: write('Mark');
                nopar: write('No');
                oddpar: write('Odd');
                end;
            writeln(' parity');
           end; (* paritysym *)
        typesym : writetrans
      end (* case *)
      else write(chr(bell));
  end; (* show_sym *)

procedure set_parms;

(* sets the parameters *)

  begin
    case noun of
        debugsym: case adj of
                      onsym: begin
                          debug := true;
                          (*$I-*)
                          rewrite(debf,'CONSOLE:')
                          (*I+*)
                        end; (* onsym *)
                      offsym: debug := false
                    end; (* case adj *)
        escsym: escchar := newescchar;
        filewarnsym: fwarn := (adj = onsym);
        ibmsym: case adj of
                    onsym: begin
                          ibm := true;
                          parity := markpar;
                          half_duplex := true;
                          fillparityarray
                          end; (* onsym *)
                    offsym: begin
                            ibm := false;
                            parity := nopar;
                            half_duplex := false;
                            fillparityarray
                            end; (* onsym *)
                  end; (* case adj *)
        localsym: halfduplex := (adj = onsym);
        paritysym: begin
                   case adj of
                       evensym: parity := evenpar;
                       marksym: parity := markpar;
                       nonesym: parity := nopar;
                       oddsym: parity := oddpar;
                       spacesym: parity := spacepar;
                     end; (* case *)
                   fill_parity_array;
                  end; (* paritysym *)
        MUXsym  : begin
                  MUXDelay := value
                  end (* baudsym *);
        baudsym : begin
                  Baud := value;
                  BaudRate(Baud)
                  end (* baudsym *);
        disksym : begin
                  if value in [4,5,9] then
                    begin
                    disk := ' ';
                    disk[1] := chr(ord('0')+value);
                    disk := concat('#',disk);
                    disk := concat(disk,':')
                    end
                   else
                     writeln('Drive does not exist ')
                  end (* disksym *)

      end; (* case *)
  end; (* set_parms *)

procedure initialize;

var ch: char;

  begin
    pad := mypad;
    padchar := chr(mypchar);
    eol := chr(my_eol);
    esc_char := chr(my_esc);

    quote := my_quote;
    bquote := my_bquote;
    ctlset := [chr(1)..chr(31),chr(del),quote,bquote];
    TranState := TxtFile;
    TimInt := My_Time;

    half_duplex := false;
    debug := false;
    debnext:=0;
    fwarn := false;
    spsiz := max_pack;
    rpsiz := max_pack;
    n := 0;
    parity := nopar;
    initvocab;
    fill_parity_array;
    ibm := false;
    xon := chr(17);
    {bufpos := 1;}
    initM;
    Baud := 1200;

    FileInit;
    value := 0;
    disk  := '#5:'
  end; (* initialize *)

procedure closeup;

  begin
    writeln(chr(ff){clearscreen});
  end; (* closeup *)

  begin (* kermit *)
    initialize;
    { Load in the microcode }
    OVLYLOAD('HANDLE');

    repeat
        write('Kermit-UCSD> ');
        readstr(terminal,line);
        case parse of
            unconfirmed: writeln('Unconfirmed');
            parm_expected: writeln('Parameter expected');
            ambiguous: writeln('Ambiguous');
            unrec: writeln('Unrecognized command');
            fn_expected: writeln('File name expected');
            ch_expected: writeln('Single character expected');
            null: case verb of
                      consym: connect;
                      helpsym: help;
                      Loadsym: begin
                               uppercase(filename);
                               LoadIm(filename)
                               end;
                      recsym: begin
                              recsw(rec_ok);
                              gotoxy(0,debugline);
                              write(chr(bell));
                              if rec_ok then
                                  writeln('successful receive')
                              else
                                  writeln('unsuccessful receive');
                              gotoxy(0,promptline);
                              end; (* recsym *)
                      sendsym: begin
                               uppercase(filename);
                               sendsw(send_ok);
                               gotoxy(0,debugline);
                               write(chr(bell));
                               if send_ok then
                                   writeln('successful send')
                               else
                                   writeln('unsuccessful send');
                               (*$I-*) (* set i/o checking off *)
                               closeF(filename,False);
                               (*$I+*) (* set i/o checking back on *)
                               gotoxy(0,promptline);
                               end; (* sendsym *)
                      delsym: begin
                              uppercase(filename);
                              vol := ord(disk[2]) - ord('0');
                              Delfile(filename,vol)
                              end; (* delsym *)
                      setsym: set_parms;
                     transym: begin
                              if noun = Typesym then
                                case adj of
                                  binsym   : TranState := CodeFile;
                                  datasym  : TranState := BinFile;
                                  textsym  : TranState := TxtFile;
                                  imagesym : TranState := ImgFile;
                                  end
                                else
                                  write(Bell)
                              end;
                      show_sym: show_parms;
                      dirsym : begin
                               vol := ord(disk[2]) - ord('0');
                               if vol in [9,10] then
                                 writeln('Cannot DIR a Winchester')
                                else
                                  PrintNames(vol,value)
                               end (* dirsym *)
                  end; (* case verb *)
        end; (* case parse *)
        { unitclear(1); }(* clear any trash in input *)
        { unitclear(2); } (* Don't clear the screen ! *)
     until (verb = exitsym) or (verb = quitsym);
     closeup
   end.(* kermit *)

**** File PARUNIT.TEXT *********************************************************

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

Unit ParseUnit;

{ This is a unit because the magiscan does have enough memory
  to hold it without swapping }

Interface

Uses
  M2Types,M2IpRoot,M2Sys;


  (* Parser Types *)

  type
    statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
                  unrec, fn_expected, ch_expected);

    vocab = (nullsym, zerosym, onesym, twosym, threesym, foursym,
             fivesym, sixsym, sevensym, eightsym, ninesym,
             allsym, baudsym, binsym, consym, datasym,
             debugsym, delsym, dirsym, disksym, escsym, evensym,
             exitsym, filewarnsym, helpsym, ibmsym, imagesym, loadsym, localsym,
             marksym, muxsym, nonesym, oddsym, offsym, onsym, paritysym,
             quitsym, recsym, sendsym, setsym, showsym,
             spacesym, textsym, transym, typesym );

  (* Parser vars *)
  var
    noun, verb, adj     : vocab;
    status              : statustype;
    vocablist           : array[vocab] of string[13];
    value               : integer;
    filename, line      : string;
    newescchar          : char;
    expected            : set of vocab;

  procedure uppercase(var s: string);

  procedure initvocab;

  function parse: statustype;


Implementation


(* ---------------------------------------------------- *)

procedure uppercase;

var
  i: integer;

begin
for i := 1 to length(s) do
  if s[i] in ['a'..'z'] then
    s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
end; (* uppercase *)

(* ---------------------------------------------------- *)

function parse;

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

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

  procedure eatspaces(var s: string);

  var done: boolean;
      i: integer;

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

  procedure isolate_word(var line, s: string);

  var i: integer;
      done: boolean;

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

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

  var i, l: integer;

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

  function getch(var ch: char): boolean;

  var s: string;

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


  function get_sym(var word: vocab): statustype;

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

    begin
      eat_spaces(line);
      if length(line) = 0 then
          getsym := ateol
      else
        begin
          stat := null;
          done := false;
          isolate_word(line,s);
          i := allsym;
          matches := 0;
          repeat
             if (pos(s,vocablist[i]) = 1) and (i in expected) then
                begin
                  matches := matches + 1;
                  word := i
                end
              else if (s[1] < vocablist[i,1]) then
                  done := true;
              if (i = typesym) then
                  done := true
              else
                  i := succ(i)
          until (matches > 1) or done;
          if matches > 1 then
              stat := ambiguous
          else if (matches = 0) then
              stat := unrec;
          getsym := stat
        end (* else *)
    end; (* getsym *)

  function get_val(var value : integer): statustype;

  var i: vocab;
      s: string;
      stat: statustype;
      gotval,done: boolean;

      function NewVal(Value  : integer;
                      S      : vocab  ) : integer;

      begin
      case S of
        zerosym  : NewVal := Value * 10 + 0;
        onesym   : NewVal := Value * 10 + 1;
        twosym   : NewVal := Value * 10 + 2;
        threesym : NewVal := Value * 10 + 3;
        foursym  : NewVal := Value * 10 + 4;
        fivesym  : NewVal := Value * 10 + 5;
        sixsym   : NewVal := Value * 10 + 6;
        sevensym : NewVal := Value * 10 + 7;
        eightsym : NewVal := Value * 10 + 8;
        ninesym  : NewVal := Value * 10 + 9
        end{case}
      end{NewVal};

      function NextDigit : boolean;

      var
        i   : integer;

      begin
      if length(s) <= 1 then
        NextDigit := False
       else
         begin
         i := length(s) - 1;
         s := copy(s,2,i);
         NextDigit := True
         end
      end{NextDigit};


    begin
      eat_spaces(line);
      if length(line) = 0 then
        getval := ateol
      else
        begin
          stat := null;
          done := false;
          isolate_word(line,s);
          value := 0;
          repeat

            GotVal := False;
            for i := zerosym to ninesym do
              if (s[1] = vocablist[i][1]) then
                begin
                Value := NewVal(value,i);
                GotVal := True
                end;
            if not GotVal then
              begin
              stat := unrec;
              done := True
              end
             else
               done := not NextDigit

          until done;
          getval := stat
        end (* else *)
    end; (* getval *)

begin
state := start;
parse := null;
noun := nullsym;
verb := nullsym;
adj := nullsym;
uppercase(line);
repeat
   case state of
     start:
         begin
           expected := [consym, exitsym, helpsym, quitsym,
                        recsym, delsym, dirsym, sendsym,
                        setsym, showsym, transym, loadsym];
         status := getsym(verb);
         if status = ateol then
           begin
             parse := null;
             exit(parse)
           end (* if *)
         else
           if (status <> unrec) and (status <>  ambiguous) then
             case verb of
                  dirsym, consym: state := fin;
                  exitsym, quitsym: state := fin;
                  helpsym: state := get_help_parm;
                  recsym: state := fin;
                  loadsym, delsym, sendsym: state := getfilename;
                  setsym: state := get_set_parm;
                  showsym: state := get_show_parm;
                  transym: state := get_trans;
                end (* case *);
          end; (* case start *)
      fin:
          begin
            expected := [];
            status := getsym(verb);
            if status = ateol then
              begin
                parse := null;
                exit(parse)
              end (* if status *)
            else
                status := unconfirmed
          end; (* case fin *)
      getfilename:
        begin
          expected := [];
          if getfn(line,filename) then
            begin
              status := null;
              state := fin
            end (* if *)
          else
              status := fnexpected
        end; (* case get file name *)
      get_trans:
          begin
          expected := [typesym];
            status := getsym(noun);
            if status = ateol then
                status := parm_expected
            else if (status <> unrec) and (status <>  ambiguous) then
                case noun of
                  typesym: state := get_type;
                end (* case *)
        end; (* case get_set_parm *)
      get_set_parm:
          begin
          expected := [paritysym, localsym, ibmsym, escsym, muxsym,
                      disksym, debugsym, filewarnsym, baudsym];
            status := getsym(noun);
            if status = ateol then
                status := parm_expected
            else if (status <> unrec) and (status <>  ambiguous) then
                case noun of
                  paritysym: state := get_parity;
                  localsym: state := get_on_off;
                  ibmsym: state := get_on_off;
                  escsym: state := getchar;
                  debugsym: state := getonoff;
                  filewarnsym: state := getonoff;
                  muxsym, baudsym : state := getvalue;
                  disksym : state := getvalue;
                  transym : state := get_on_off;
                end (* case *)
        end; (* case get_set_parm *)
      get_type:
          begin
            expected := [binsym, datasym, imagesym, textsym];
            status := getsym(adj);
            if status = ateol then
                status := parm_expected
            else if (status <> unrec) and (status <> ambiguous) then
                state := fin
          end; (* case get_parity  *)
      get_parity:
          begin
            expected := [marksym, spacesym, nonesym, evensym, oddsym];
            status := getsym(adj);
            if status = ateol then
                status := parm_expected
            else if (status <> unrec) and (status <> ambiguous) then
                state := fin
          end; (* case get_parity  *)
      get_value:
             begin
               expected := [zerosym, onesym, twosym,
                            threesym, foursym, fivesym,
                            sixsym, sevensym, eightsym,
                            ninesym];
               status := getval(value);
               if status = ateol then
                   status := parm_expected
                else
                 if (status <> unrec) and (status <> ambiguous) then
                   state := fin
             end; (* get_speed *)
      get_on_off:
          begin
            expected := [onsym, offsym];
            status := getsym(adj);
            if status = ateol then
                status := parm_expected
            else if (status <> unrec) and (status <> ambiguous) then
                state := fin
          end; (* get_on_off *)
      get_char:
          if getch(newescchar) then
             state := fin
          else
             status := ch_expected;
      get_show_parm:
          begin
          expected := [allsym, paritysym, localsym, ibmsym, escsym,
                       muxsym, transym, disksym, baudsym, debugsym, filewarnsym];
            status := getsym(noun);
            if status = ateol then
                status := parm_expected
            else if (status <> unrec) and (status <>  ambiguous) then
                state := fin
          end; (* case get_show_parm *)
      get_help_show:
          begin
            expected := [paritysym, localsym, ibmsym, escsym,
                        debugsym, filewarnsym];
            status := getsym(adj);
            if (status = at_eol) then
              begin
                status := null;
                state := fin
              end
            else if (status <> unrec) and (status <>  ambiguous) then
                state := fin
          end; (* case get_help_show *)
      get_help_parm:
          begin
            expected := [consym, delsym, exitsym, helpsym,
                        quitsym, recsym, dirsym, transym, sendsym,
                        setsym, showsym];
            status := getsym(noun);
            if status = ateol then
              begin
                parse := null;
                exit(parse)
              end;
            if (status <> unrec) and (status <>  ambiguous) then
                case noun of
                  consym: state := fin;
                  sendsym: state := fin;
                  recsym: state := fin;
                  setsym: state := get_help_show;
                  showsym: state := fin;
                  helpsym: state := fin;
                  exitsym, quitsym: state := fin;
                end (* case *)
          end; (* case get_help_show *)
    end (* case *)
until (status <> null);
parse := status
end; (* parse *)

(* ---------------------------------------------------- *)

procedure initvocab;

var i: integer;

  begin
    vocablist[zerosym] :=     '0';
    vocablist[onesym] :=      '1';
    vocablist[twosym] :=      '2';
    vocablist[threesym] :=    '3';
    vocablist[foursym] :=     '4';
    vocablist[fivesym] :=     '5';
    vocablist[sixsym] :=      '6';
    vocablist[sevensym] :=    '7';
    vocablist[eightsym] :=    '8';
    vocablist[ninesym] :=     '9';
    vocablist[allsym] :=      'ALL';
    vocablist[baudsym] :=     'BAUDRATE';
    vocablist[binsym] :=      'BINARY';
    vocablist[consym] :=      'CONNECT';
    vocablist[datasym] :=     'DATA';
    vocablist[debugsym] :=    'DEBUG';
    vocablist[delsym] :=      'DELETE';
    vocablist[dirsym] :=      'DIRECTORY';
    vocablist[disksym] :=     'DISK';
    vocablist[escsym] :=      'ESCAPE';
    vocablist[evensym] :=     'EVEN';
    vocablist[exitsym] :=     'EXIT';
    vocablist[filewarnsym] := 'FILE-WARNING';
    vocablist[helpsym] :=     'HELP';
    vocablist[ibmsym] :=      'IBM';
    vocablist[imagesym] :=    'IMAGE';
    vocablist[loadsym] :=     'LOAD';
    vocablist[localsym] :=    'LOCAL-ECHO';
    vocablist[marksym] :=     'MARK';
    vocablist[muxsym] :=      'MUX';
    vocablist[nonesym] :=     'NONE';
    vocablist[oddsym] :=      'ODD';
    vocablist[offsym] :=      'OFF';
    vocablist[onsym] :=       'ON';
    vocablist[paritysym] :=   'PARITY';
    vocablist[quitsym] :=     'QUIT';
    vocablist[recsym] :=      'RECEIVE';
    vocablist[sendsym] :=     'SEND';
    vocablist[setsym] :=      'SET';
    vocablist[showsym] :=     'SHOW';
    vocablist[spacesym] :=    'SPACE';
    vocablist[transym] :=     'TRANSFER';
    vocablist[textsym] :=     'TEXT';
    vocablist[typesym] :=     'TYPE';
  end; (* initvocab *)



(* ---------------------------------------------------- *)



end{Parse}.

**** File RECSW.TEXT ***********************************************************

(* RECEIVE SECTION *)
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}
{Modified for the Magiscan 2 by H Balen, Lancaster U }

segment procedure recsw(var rec_ok: boolean);

function rdata: char;

(* send file data *)

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

  begin

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

        num_try := num_try + 1;

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

        refresh_screen(numtry,n);

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

                n := n - 1;

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

            n := n - 1;

            if (num = (n mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                debugint('re-acking file header ',num);
                spack('Y',num,0,packet);
                if istbrr then begin
                  ch:=rcvbbt; (* and empty out buffer *)
                  ch:='F';
                  end;
                numtry := 0;           (* reset try counter *)
                state := state;        (* stay in same state *)
              end (* if *)
            else begin
              debugwrite('file info not previous packet in rdata');
                state := 'a'           (* not previous packet, abort *)
                end
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                debugwrite('wrong eof packet in rdata');
                rdata := 'a';
                exit(rdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            { CloseF(filename,True); }
            n :=  n + 1;               (* bump packet counter *)
            state := 'b';              (* go to break state *)
            oldtry := numtry;
            numtry := 0;
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            state := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then begin (* some other packet type, *)
            state := 'a';                 (* abort *)
            debugwrite('wierd rdata packet');
            end
    until (state <> 'd');
    rdata := state
  end; (* rdata *)

function rfile: char;

(* receive file header *)

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

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

function exist(fn: string): boolean;

(* returns true if file named fn exists *)

var f: file;
    OK : boolean;

  begin
    (*$I-*) (* turn off i/o checking *)
    reset(f,concat(disk,fn));
    OK := (ioresult = 0);
    if OK then
      close(f);
    Exist := OK
    (*$I+*)
  end; (* exist *)

procedure checkname(var fn: string);

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

var ch: char;
    i: integer;

  begin
    i := 1;
    while (i <= length(fn)) and exist(fn) do
      begin
        ch := 'A';
        while (ch in ['A'..'Z']) and exist(fn) do
          begin
            fn[i] := ch;
            ch := succ(ch);
          end; (* while *)
        i := i + 1
      end; (* while *)
    end; (* checkname *)

  begin (* makename *)
    fn := copy('               ',1,15);    (* stretch length *)
    moveleft(recpkt[0],fn[1],l);           (* get filename from packet *)
    oldfn := copy(fn, 1,l);                (* save fn sent to show user *)
    fn := copy(fn,1,min(15,l));            (* set length of filename *)
                                           (* and make sure <= 15 *)
    uppercase(fn);
    {
    if length(fn) > 10 then
      fn := copy(fn,1,10);           (* can only be 15 long in all *)
    }
    if TranState = TxtFile then
      begin
      if pos('.TEXT',fn) <> (length(fn)-4) then
        begin
        if length(fn) > 10 then
          fn := copy(fn,1,10);           (* can only be 15 long in all *)
        fn := concat(fn,'.TEXT');          (* and we'll add .TEXT *)
        end; (* if *)
      end
     else
       if TranState = CodeFile then
         begin{ Same as above except this is a code file }
         if pos('.CODE',fn) <> (length(fn)-4) then
           begin
           if length(fn) > 10 then
             fn := copy(fn,1,10);
           fn := concat(fn,'.CODE')
           end
         end
        else
          begin { Same as last two but this is a data file }
          if pos('.DATA',fn) <> (length(fn)-4) then
            begin
            if length(fn) > 10 then
              fn := copy(fn,1,10);
            fn := concat(fn,'.DATA')
            end;
          end;
    if fwarn then                          (* if file warning is on *)
        checkname(fn);                       (* must check that name unique *)
  end; (* makename *)

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

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

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

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

        n := n - 1;

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

        n := n - 1;

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

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

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

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

function rbreak: char;

(* receive file header *)

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

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

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

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

    if (ch = 'Z') then
      begin{ is previous eof packet }

      n := n -1;
      if (num = (n mod 64)) then (* previous packet again *)
        begin                (* so re-ACK it *)
          debugint('re-acking ',num);
          spack('Y',num,6,packet);
          numtry := 0;       (* reset try counter *)
                             (* stay in same state *)
        end (* if *)
      else begin             (* wrong number *)
          debugwrite('wrong data sequence no. in rbreak');
          state := 'a'       (* so abort *)
          end
      end
   else
    if ch = 'B' then             (* break transmission *)
      begin
        if (num <> (n mod 64)) then            (* wrong packet, abort *)
          begin
            debugwrite('wrong sequence in break packet');
            rbreak := 'a';
            exit(rbreak)
          end;
        spack('Y',n mod 64,0,packet); (* say ok *)
        rbreak := 'c'                  (* go to complete state *)
      end (* else if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        rbreak := 'a'
      end
    else if (ch = chr(0)) then        (* returned false *)
        rbreak := state                (* so stay in same state *)
    else begin                        (* some weird state, so abort *)
        rbreak := 'a';
        debugwrite('wierd break packet');
        end
  end; (* rbreak *)

function rinit: char;

(* receive initialization *)

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

  begin
    if debug then
        debugwrite('rinit');

    numtry := numtry + 1;

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

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

(* state table switcher for receiving packets *)

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

    while true do
        if state in ['d', 'f', 'r', 'c', 'a', 'b'] then
          case state of
              'd': state := rdata;
              'f': state := rfile;
              'r': state := rinit;
              'b': state := rbreak;
              'c': begin
                     rec_ok := true;
                     CloseF(filename,true);
                     exit(recsw)
                   end; (* case c *)
              'a': begin
                     rec_ok := false;
                     CloseF(filename,false);
                     exit(recsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            rec_ok := false;
            CloseF(filename,False);
            exit(recsw)
          end (* else *)
  end; (* recsw *)

**** File RS232.TEXT ***********************************************************

(*$S+*)

{ This unit contains the subroutines necessary for
  accessing/using the RS232 interface of the Magiscan }

Unit RS232;

{ Written by H Balen 1-Aug-85 }
{ Modified by H Balen 23-Sep-85 }

Interface


Uses
  M2Types,M2IpRoot,M2Sys;

var
  MuxDelay    : integer;

  procedure InitM;

  function ISTATR : boolean;

  function ISTBRR : boolean;

  function ISTBOR : boolean;

  function ISTBFE : boolean;

  function ISTBTR : boolean;

  procedure SNDBBT( BT : char );

  procedure SNDABT( BT : char );

  function RCVBBT : Char;



Implementation

{ All the routines below have the same function as those
  in the text file WDPROCS for the UCM version of kermit }

const
  RxBit   = 4;
  TxBit   = 5;
  Uart    = 56;
  Control = 57;
  Status  = 57;

  { RS232 dependant constants for the status registar }
  OverError = 4;
  FrameError = 5;

type
  RegByte = record
               case Boolean of
                 True : ( Value : integer );

(* ---------------------------------------------------- *)

function ISTBOR;
{  Is it true that data OverRun occurred ?,}

var
  Byte : RegByte;

begin
Byte.Value := IORead(Status);
ISTBOR := Byte.B[OverError]
end{ISTBOR};

(* ---------------------------------------------------- *)

function ISTBFE;
{ Is it true that Framing-Error occured? }

var
  Byte  : RegByte;

begin
Byte.Value := IORead(Status);
ISTBFE := Byte.B[FrameError]
end{ISTBFE};

(* ---------------------------------------------------- *)

function ISTBTR;
{ Is it true that transmit is ready ? }

begin
ISTBTR := not IOStatus(TxBit)
end{ISTBR};

(* ---------------------------------------------------- *)

procedure InitM;
{ This initialises the RS232 port }

begin
IOWrite(64,Control); { Internal Reset }
IOWrite(78,Control); { Set the mode }
IOWrite(55,Control); { Error Reset }
BaudRate(1200);
MuxDelay := 0;
end{RSInit};

(* ---------------------------------------------------- *)

procedure SNDBBT;
{ After getting back a TRUE result from isttr, this function
  SNDBBT is used to actually send the byte of data from the
  CPU to the device. Note that any attempt to call SNDBBT before
  getting TRUE from isttr can result in clobering the previous
  data }

var
  i   : integer;

begin
for i := 0 to (10 * MuxDelay) do;
{[UnitWrite(8,i,1);}
IOWrite(ord(BT),Uart);
end{SendToUART};

(* ---------------------------------------------------- *)

procedure SNDABT;
{ Same as the SNDBBT except this is for the keyboard }

const
  Ret  = 13;
  LF   = 10;

begin
if ord(BT) <> Ret then
  if ord(BT) = LF then{ If we have a LF then }
    write(chr(Ret)) { send a CR instead }
   else
     write(BT) { else send the character itself }
end{SNABT};

(* ---------------------------------------------------- *)

function RCVBBT;

var
  Ch    : char;

begin
RCVBBT := chr( IORead(Uart) )
{UnitRead(7,Ch,1);
RCVBBT := Ch}
end{RxUART};

(* ---------------------------------------------------- *)

end{RS232}.

**** File RSUTILS.TEXT *********************************************************

(*$S+*)

{ This unit contains the subroutines necessary for
  accessing/using the RS232 interface of the Magiscan }

Unit RS232;

{ Written by H Balen 1-Aug-85 }
{ Modified by H Balen 23-Sep-85 }

Interface


Uses
  M2Types,M2IpRoot,M2Sys;

var
  MuxDelay    : integer;

  procedure InitM;

  function ISTATR : boolean;

  function ISTBRR : boolean;

  function ISTBOR : boolean;

  function ISTBFE : boolean;

  function ISTBTR : boolean;

  procedure SNDBBT( BT : char );

  procedure SNDABT( BT : char );

  function RCVBBT : Char;



Implementation

{ All the routines below have the same function as those
  in the text file WDPROCS for the UCM version of kermit }

const
  RxBit   = 4;
  TxBit   = 5;
  Uart    = 56;
  Control = 57;
  Status  = 57;

  { RS232 dependant constants for the status registar }
  OverError = 4;
  FrameError = 5;

type
  RegByte = record
               case Boolean of
                 True : ( Value : integer );

(* ---------------------------------------------------- *)

function ISTBOR;
{  Is it true that data OverRun occurred ?,}

var
  Byte : RegByte;

begin
Byte.Value := IORead(Status);
ISTBOR := Byte.B[OverError]
end{ISTBOR};

(* ---------------------------------------------------- *)

function ISTBFE;
{ Is it true that Framing-Error occured? }

var
  Byte  : RegByte;

begin
Byte.Value := IORead(Status);
ISTBFE := Byte.B[FrameError]
end{ISTBFE};

(* ---------------------------------------------------- *)

function ISTBTR;
{ Is it true that transmit is ready ? }

begin
ISTBTR := not IOStatus(TxBit)
end{ISTBR};

(* ---------------------------------------------------- *)

procedure InitM;
{ This initialises the RS232 port }

begin
IOWrite(64,Control); { Internal Reset }
IOWrite(78,Control); { Set the mode }
IOWrite(55,Control); { Error Reset }
BaudRate(1200);
MuxDelay := 0;
end{RSInit};

(* ---------------------------------------------------- *)

procedure SNDBBT;
{ After getting back a TRUE result from isttr, this function
  SNDBBT is used to actually send the byte of data from the
  CPU to the device. Note that any attempt to call SNDBBT before
  getting TRUE from isttr can result in clobering the previous
  data }

var
  i   : integer;

begin
for i := 0 to (10 * MuxDelay) do;
{[UnitWrite(8,i,1);}
IOWrite(ord(BT),Uart);
end{SendToUART};

(* ---------------------------------------------------- *)

procedure SNDABT;
{ Same as the SNDBBT except this is for the keyboard }

const
  Ret  = 13;
  LF   = 10;

begin
if ord(BT) <> Ret then
  if ord(BT) = LF then{ If we have a LF then }
    write(chr(Ret)) { send a CR instead }
   else
     write(BT) { else send the character itself }
end{SNABT};

(* ---------------------------------------------------- *)

function RCVBBT;

var
  Ch    : char;

begin
RCVBBT := chr( IORead(Uart) )
{UnitRead(7,Ch,1);
RCVBBT := Ch}
end{RxUART};

(* ---------------------------------------------------- *)

end{RS232}.

**** File SENDSW.TEXT **********************************************************

(* Send Section *)
{UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U}
{ adapted by H Balen for the Magiscan 2, Lancaster U }

segment procedure sendsw(var send_ok: boolean);

var io_status: integer;

procedure openfile;

(* resets file & gets past first 2 blocks *)
var
  OK   : boolean;

  begin
  OK := ReadOpenF(filename,TranState);
  io_status := io_result;
  end; (* openfile *)

function sinit: char;

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

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

  begin
    if debug then
        debugwrite('sinit');

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

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

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

    refresh_screen(numtry,n);

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

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

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

function sdata: char;

(* send file data *)

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

function other(b: boolean): boolean;

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

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

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

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

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

        ch := rpack(len,num,recpkt);      (* receive a packet *)
                                          (* set up next packet *)
        if TranState = TxtFile then
          sizearray[b] := bufill(packarray[b])
         else
           sizearray[b] := Bbufill(packarray[b]);

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

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

  begin
    for i := 1 to length(s) do
        if s[i] in ['a'..'z'] then
            s[i] := chr(ord('A') + ord(s[i]) - ord('a'))
  end; (* uppercase *)

  begin
    count := 0;
    l := length(fn);
    for i := 1 to l do                                  (* count '.'s in fn *)
        if fn[i] = '.' then
            count := count + 1;
    for i := 1 to count-1 do                            (* remove all but 1 *)
      begin
        j := 1;
        while (j < l) and (fn[j] <> '.') do
            j := j + 1;
            delete(fn,j,1);l := l - 1
      end; (* for i *)
    l := length(fn);
    i := pos(':',fn);
    if (i <> 0) then
      begin
        fn := copy(fn,i,l-i);
        l := length(fn)
      end;
    i := 1;
    while (i <= length(fn)) do
        if not(fn[i] in ['a'..'z','A'..'Z','.','0'..'9']) then
            delete(fn,i,1)
        else
            i := i + 1;
    uppercase(fn)
  end; (* legalize *)

  begin
    if debug then
        debugwrite('sfile');

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

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

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

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

    refresh_screen(numtry,n);

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

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

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

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then  (* if wrong ACK, stay in F state *)
            begin
            sfile := 'f';
            exit(sfile)
            end;
        if TranState = TxtFile then
          size := bufill(packet)     (* get first data from file *)
         else
           size := Bbufill(packet);
        numtry := 0;
        n := n + 1;
        sfile := 'd';
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sfile := 'a'
      end (* if 'E' *)
    else if (ch <> chr(0)) and (ch <> 'N') then (* don't recognize it *)
        sfile := 'a'
  end; (* sfile *)

function seof: char;

(* send end of file *)

var num, len: integer;
    ch: char;

  begin
    if debug then
        debugwrite('seof');

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

    refresh_screen(numtry,n);

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

    if debug then
        debugwrite('seof1');

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

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

function sbreak: char;

var num, len: integer;
    ch: char;

(* send break (end of transmission) *)

  begin
    if debug then
        debugwrite('sbreak');

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

    refresh_screen(numtry,n);

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

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

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

(* state table switcher for sending *)

  begin (* sendsw *)

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

    openfile;
    if io_status <> 0 then
      begin
        writeln(chr(ff){clear_screen});
        ino_error(io_status);
        send_ok := false;
        exit(sendsw)
      end;

    write_screen('Sending');
    state := 's';
    n := 0;       (* set packet # *)
    numtry := 0;
    while true do
        if state in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
          case state of
              'd': state := sdata;
              'f': state := sfile;
              'z': state := seof;
              's': state := sinit;
              'b': state := sbreak;
              'c': begin
                     send_ok := true;
                     exit(sendsw)
                   end; (* case c *)
              'a': begin
                     send_ok := false;
                     exit(sendsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            send_ok := false;
            CloseF(filename,send_ok);
            exit(sendsw)
          end (* else *)
  end; (* sendsw *)

**** File SYSUNIT.TEXT *********************************************************

(*$S+*)

{ This unit allows the users to access the directory information
  held on each disk }
Unit SysUnit;


  Interface


  Uses
     M2Types,M2IpRoot,M2Sys;

  type
    FileType = String[15];
    Volume = 4..12;

  var
    D      : File;


  procedure DelFile( G  : FileType;
                     Vol : Volume );

  procedure PrintNames( Vol   : Volume;
                       var NbrOfFiles : integer );


Implementation

{ These are the declerations that we don't really want the
  user to see, as they may do silly things }

   const
     FirstBlk = 8;
     LastBlk  = 839;

   type
     FileArray = Packed array[0..77] of FileType;

     Daterec = packed record
                  Month  : 0..12;
                  Day    : 0..31;
                  Year   : 0..100
                  end;

     FileKind = (UnTyped,XDsk,Code,Text,Info,Data,Graf,Foto,
                 SecureDir);

     DirEntry = Packed Record
                   DFirstBlk  : integer;
                   DLastBlk   : integer;
                   case DFKind : FileKind of

                      SecureDir,UnTyped : (Filler1 : 0..2048;
                                           Dvid    : String[7];
                                           DevoBlk : integer;
                                           DNumFiles: 0..77;
                                           DLoadTime: integer;
                                           DLastBoot: DateRec );

                      XDsk,Code,Text,Info,Data,Graf,Foto :
                                        (Filler  : 0..1024;
                                         Status  : Boolean;
                                         Dtid    : String[15];
                                         DLastByte: 1..512;
                                         DAccess : DateRec )
                      end;

     Directory = array[0..77] of DirEntry;


(* ---------------------------------------------------- *)

function IsFile(Name  : FileType;
                Vol   : Volume ) : Boolean;
{ This checks if the file, name, exists on the disk, vol }

var
  G  : String;
  i  : integer;

begin
if (Not ( Vol in [4,5,11,12] )) or (Length(Name) < 1) then
  begin
  IsFile := False;
  Exit(IsFile)
  end;

case Vol of
   4  : G := Concat('#4:',Name);
   5  : G := Concat('#5:',Name);
   11 : G := Concat('#11:',Name);
   12 : G := Concat('#12:',Name);
   end;

(*$I-*)
Reset(D,g);
i := IOResult;
if i = 0 then Close(D,lock);
(*$I+*)
IsFile := i = 0
end{IsFile};

(* ---------------------------------------------------- *)

procedure DelFile;
{ This procedure deletes a file from disk }

var
  i,j,NbrOfFiles  : Integer;
  DD              : Directory;
  Dummy           : DirEntry;
  Found           : Boolean;
  Key             : char;

begin

{ Tell the user what we are doing }
write('#',vol,':',G,' =====> ');
{ Check that the name is valid and exists }
if (Not (Vol in [4,5,11,12])) or (Length(G)<1)
    or Not (IsFile(G,Vol)) then
  begin
  writeln('Does not exist');
  Exit(DelFile);
  end;

{ Inform that it has been deleted ! }
writeln('Deleted');
{ Ask if the user wishes to update the directory,
  this will do the actual delete ! }
write('Update Directory (Y/N) ?');
repeat
  read(keyboard,Key)
until Key in ['Y','y','N','n'];
writeln(Key);

{ If we do update the directory then we have to delete }
if Key in ['Y','y'] then
  begin
  { Get the directory info }
  UnitRead(Vol,DD,SizeOf(DD),4);
  NbrOfFiles := DD[0].DNumFiles;

  i := 0;
  Found := False;

  { Find the file }
  while not Found do
    begin
    with DD[i] do
      if (Not (DFKind in [SecureDir,UnTyped])) and
        (DTid = G) then
       Found := True
       else
         i := i + 1;
    if i > NbrOfFiles then Exit(DelFile)
    end;

  { delete from the directory info }
  Dummy := DD[i];
  For j:= i To pred(NbrOfFiles) do
    DD[j] := DD[j+1];
  DD[NbrOfFiles] := Dummy;
  DD[0].DNumFiles := NbrOfFiles -1;

  { Update the actual directory on the disk }
  UnitWrite(Vol,DD,SizeOf(DD),4)
  end;

end{DelFile};

(* ---------------------------------------------------- *)

procedure PrintNames;
{ This procedure displays a directory on the screen for
  the user to view }

const
  StrtPos  = 20;
  FinisPos = 26;
  DatePos  = 32;
  TyPos    = 42;

var
  i,k  : integer;
  DD   : Directory;

  (* -------------------------------------------------- *)

  procedure PrintDAcc(var DAccess  : DateRec );

  begin
  GotoXY(DatePos,k);
  with DAccess do
    begin
    write(Day,'-');
    case Month of
      1  : write('Jan');
      2  : write('Feb');
      3  : write('Mar');
      4  : write('Apr');
      5  : write('May');
      6  : write('Jun');
      7  : write('Jul');
      8  : write('Aug');
      9  : write('Sep');
      10 : write('Oct');
      11 : write('Nov');
      12 : write('Dec')
      end{case};
    write('-',Year)
    end{with};
  end{PrintDAcc};

  (* -------------------------------------------------- *)

  procedure PrintTy( DFKind  : FileKind );

  begin
  GotoXY(TyPos,k);
  case DFKind of
     SecureDir : write(' SecureDir ');
     UnTyped   : write(' UnTyped   ');
     XDsk      : write(' XDsk      ');
     Code      : write(' Code      ');
     Text      : write(' Text      ');
     Info      : write(' Info      ');
     Data      : write(' Data      ');
     Graf      : write(' Graf      ');
     Foto      : write(' Foto      ');
     end;
  end{PrintTy};

  (* -------------------------------------------------- *)

begin
{ Get the directory information }
UnitRead(Vol,DD,SizeOf(DD),4);
NbrOfFiles := DD[0].DNumFiles;

{ write which disk ths info is from }
writeln(chr(ff),'DIRECTORY OF #',Vol,':');

k := 1;

{ Take care of the first entry }
with DD[1] do
  begin
  if DFirstBlk > FirstBlk then
    begin
    write('<UNUSED>');
    GotoXY(StrtPos,k); write(FirstBlk);
    GotoXY(FinisPos,k);write(pred(DFirstBlk));
    k := k + 1;
    writeln
    end
  end;

{ For each entry display on the screen }
for i := 1 to NbrOfFiles do
  with DD[i] do
    begin
    write(Dtid);
    GotoXY(StrtPos,k); write(DFirstBlk);
    GotoXY(FinisPos,k);write(DLastBlk);
    PrintDAcc(DAccess);
    PrintTy(DFKind);
    writeln; k := succ(k);
    if i < NbrofFiles then
      if (DLastBlk < DD[succ(i)].DFirstBlk) then
        begin
        write('<UNUSED>');
        GotoXY(StrtPos,k); write(DLastBlk);
        GotoXY(FinisPos,k);write(pred(DD[succ(i)].DFirstBlk));
        k := k + 1;
        writeln
        end;
    { if we have reached the bottom of the screen and still
      have more to do... wrap around }
    if (k mod 31) = 0 then
      begin
      Pause;
      writeln(chr(ff),' DIRECTORY CONTD');
      k := 1
      end;
    end;

{ Take care of the last entry, if blank etc }
with DD[NbrOfFiles] do
  begin
  if DlastBlk < LastBlk then
    begin
    write('<UNUSED>');
    GotoXY(StrtPos,k); write(succ(DLastBlk));
    GotoXY(FinisPos,k);write(LastBlk);
    k := k + 1;
    writeln
    end
  end


end{PrintNames};

(* ---------------------------------------------------- *)

end{SysUnit}.

**** File UTILS.TXT ************************************************************

function ready(p:port):boolean;
begin
  ready:= ((p=terminal) and (not IoStatus(2))) or ((p=modem) and istbrr);
end;

function pget(p:port):char;
begin
  if p=terminal then pget := chr( aand(IORead(80),127) ) { get from the keyboard }
  else pget :=rcvbbt;
end;

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

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

var i: integer;

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

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

(* read a character from an input port *)

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

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

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

const maxtry = 10000;

var count: integer;

  begin
    count := 0;
    getch := false;
    repeat
        count := count + 1;
    until ready(p) or (count > maxtry);         (* wait for a character *)
    if (count > maxtry) then                    (* if wait too long then *)
        begin
        getch := false; { act as if SOH ! }
        exit(getch)                             (* get out of here *)
        end;
    r:=pget(p);                                 (* get the character *)
    r := chr(aand(ord(r),127));                 (* strip parity from char *)
    getch := (r <> chr(soh));                   (* return true if not SOH *)
  end; (* getch *)


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

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

var xrec, yrec, temp: int_bool_rec;

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

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

(* arithmetic or *)

var xrec, yrec, temp: int_bool_rec;

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

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

(* exclisive or *)

var xrec, yrec, temp: int_bool_rec;

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

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

(* writes error message sent by remote host *)

var i: integer;

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

procedure ino_error(*i: integer*);

  begin
    gotoxy(0,errorline);
    writeln;         (* erase to end of line *)
    gotoxy(0,errorline);
    case i of
        0: writeln('No error');
        1: writeln('Bad Block, Parity error (CRC)');
        2: writeln('Bad Unit Number');
        3: writeln('Bad Mode, Illegal operation');
        4: writeln('Undefined hardware error');
        5: writeln('Lost unit, Unit is no longer on-line');
        6: writeln('Lost file, File is no longer in directory');
        7: writeln('Bad Title, Illegal file name');
        8: writeln('No room, insufficient space');
        9: writeln('No unit, No such volume on line');
        10: writeln('No file, No such file on volume');
        11: writeln('Duplicate file');
        12: writeln('Not closed, attempt to open an open file');
        13: writeln('Not open, attempt to close a closed file');
        14: writeln('Bad format, error in reading real or integer');
        15: writeln('Ring buffer overflow')
      end; (* case *)
    gotoxy(0,promptline)
  end; (* ino_error *)

procedure debugwrite(*s: string*);

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

  begin
    if debug then
      begin
        gotoxy(0,debugline+debnext);
        writeln;
        gotoxy(0,debugline+debnext);
        debnext:=(debnext+1) mod debug_max;
        write(s);                   (* write debugging message *)
      end (* if debug *)
  end; (* debugwrite *)

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

(* write a debugging message and an integer *)

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

procedure writescreen(*s: string*);

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

  begin
    write(chr(ff){clearscreen});
    gotoxy(0,titleline);
    write('                        Kermit UCSD p-system');
    gotoxy(statuspos,statusline);
    write(s);
    gotoxy(0,packetline);
    write('Number of Packets: ');
    gotoxy(0,retryline);
    write('Number of Tries: ');
    gotoxy(0,fileline);
    write('File Name: ');
  end; (* writescreen *)

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

(* keeps track of packet count on screen *)

  begin
    gotoxy(retrypos,retryline);
    write(numtry: 5);
    gotoxy(packetpos,packetline);
    write(num: 5)
  end; (* refresh_screen *)

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

(* returns smaller of two integers *)

  begin
    if x < y then
        min := x
    else
        min := y
  end; (* min *)

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

(* tochar converts a control character to a printable one by adding space *)

  begin
    tochar := chr(ord(ch) + ord(' '))
  end; (* tochar *)

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

(* unchar undoes tochar *)

  begin
    unchar := chr(ord(ch) - ord(' '))
  end; (* unchar *)

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

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

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

procedure echo(ch: char);

(* echos a character on the screen *)

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

**** End of concatenated source files ******************************************