Upload

Digital Research

CONTRIBUTIONS/z80em86/support/modem.pas

@@ -0,0 +1,451 @@
+(*************************************************************************)
+(*                                                                       *)
+(*     SIMPLE MODEM v1.00  (c) Copyright  S.J.Kay  18th April 1995       *)
+(*          Using the Ward Christensen file transfer protocol            *)
+(*                                                                       *)
+(*                Uses CP/M 3.0 AUXIN and AUXOUT routines                *)
+(*                                                                       *)
+(*************************************************************************)
+
+type
+   registers = record
+                  case boolean of
+                     true  : (AL, AH, BL, BH, CL, CH, DL, DH : byte);
+                     false : (AX,     BX,     CX,     DX,
+                              BP, SI, DI, DS, ES, FLAGS      : integer)
+               end;
+
+
+const
+   PthNme = '';
+   ENDBUF = $1FFF;        { must be a multiple of 128 -1 }
+
+   SOH    = $01;          { Start Of Header }
+   EOT    = $04;          { End Of Transmission }
+   ACK    = $06;          { Acknowledge }
+   NAK    = $15;          { Negative Acknowledge }
+   CAN    = $18;          { Cancel }
+
+
+var
+   R      : registers;
+   F      : file;
+   ExtCde : byte;
+   Check  : byte;
+   BufPos : integer;
+   Abort  : boolean;
+   TmeOut : boolean;
+   FleOpn : boolean;
+   Buffer : array [$0000..ENDBUF] of byte;
+
+
+procedure ProcZ80 (Fn, Ax : byte; BCx, DEx, HLx : integer);
+begin
+   inline
+      (
+       $3A/Fn/          { ld      a,(Fn)     }
+       $32/* + 17/      { ld      (FNCNMB),a }
+       $3A/Ax/          { ld      a,(Ax)     }
+       $ED/$4B/BCx/     { ld      bc,(BCx)   }
+       $ED/$5B/DEx/     { ld      de,(DEx)   }
+       $2A/HLx/         { ld      hl,(HLx)   }
+       $D3/$FF          { out     (FNCNMB),a }
+      )
+end;
+
+
+procedure Intr (Int : byte; var R : registers);
+begin
+   ProcZ80($A1, Int, $AA55, $55AA, addr(R))
+end;
+
+
+function SerialOutputStatus : byte;
+begin
+   SerialOutputStatus := bios(18)     { test if AUXOUT is ready }
+end;
+
+function SerialInputStatus : byte;
+begin
+   SerialInputStatus := bios(17)     { test if AUXIN has a character }
+end;
+
+procedure SerialOutput (x : byte);
+begin
+   bios(5, x);
+end;
+
+function SerialInput : byte;
+begin
+   SerialInput := bios(6);
+end;
+
+
+function TickCount : integer;
+begin
+   R.AH := $00;
+   intr($1A, R);
+   TickCount := R.DX
+end;
+
+
+procedure TestAbort;
+var
+   Key : char;
+begin
+   while keypressed do
+      begin
+         read(kbd, Key);
+         if (Key = ^[) or (Key = ^X) then
+            begin
+               Abort := true;
+               ExtCde := 1
+            end
+      end
+end;
+
+
+procedure WriteByte (BytVal : byte; TckVal : integer);
+var
+   BytOut : boolean;
+   T      : integer;
+begin
+   TmeOut := false;
+   if SerialOutputStatus <> 0 then
+      SerialOutput(BytVal)
+   else
+      begin
+         BytOut := false;
+         T := TickCount;
+         repeat
+            if SerialOutputStatus <> 0 then
+               begin
+                  SerialOutput(BytVal);
+                  BytOut := true
+               end
+            else
+               begin
+                  TmeOut := (TickCount - T) >= TckVal;
+                  if keypressed then
+                     TestAbort
+               end
+         until BytOut or TmeOut or Abort
+      end
+end;
+
+
+function ReadByte (TckVal : integer) : byte;
+var
+   BytInp : boolean;
+   T      : integer;
+begin
+   TmeOut := false;
+   if SerialInputStatus <> 0 then
+      ReadByte := SerialInput
+   else
+      begin
+         BytInp := false;
+         T := TickCount;
+         repeat
+            if SerialInputStatus <> 0 then
+               begin
+                  ReadByte := SerialInput;
+                  BytInp := true
+               end
+            else
+               begin
+                  ReadByte := $FF;
+                  TmeOut := (TickCount - T) >= TckVal;
+                  if keypressed then
+                     TestAbort
+               end
+         until BytInp or TmeOut or Abort
+      end
+end;
+
+
+procedure Purge;
+var
+   Dummy : byte;
+begin
+   repeat
+      Dummy := ReadByte(19)                              { 1 sec time out }
+   until TmeOut or Abort
+end;
+
+
+procedure SendCancel;
+var
+   Dummy : byte;
+begin
+   repeat
+      Abort := false;
+      Dummy := ReadByte(19)                              { 1 sec time out }
+   until TmeOut;
+   WriteByte(CAN, 91)                                    { 5 sec time out }
+end;
+
+
+procedure StartNAK;
+var
+   BytVal, Retry : byte;
+begin
+   Retry := 15;
+   repeat
+      Purge;                                       { 1 sec min time taken }
+      if not Abort then
+         begin
+            WriteByte(NAK, 1820);                      { 100 sec time out }
+            if TmeOut then
+               begin
+                  Abort := true;
+                  ExtCde := 2
+               end;
+            if not Abort then
+               begin
+                  BytVal := ReadByte(56);    { 3 sec time out waiting ACK }
+                  if Tmeout then
+                     Retry := Retry - 1;
+                  if Retry = 0 then
+                     begin
+                        Abort := true;
+                        ExtCde := 3
+                     end
+               end
+         end
+   until (BytVal = ACK) or Abort
+end;
+
+
+procedure BlockNAK;
+begin
+   Purge;
+   if not Abort then
+      begin
+         WriteByte(NAK, 1820);                         { 100 sec time out }
+         if TmeOut then
+            begin
+               Abort := true;
+               ExtCde := 4
+            end
+      end
+end;
+
+
+procedure BlockACK;
+begin
+   if not Abort then
+      begin
+         WriteByte(ACK, 1820);                         { 100 sec time out }
+         if TmeOut then
+            begin
+               Abort := true;
+               ExtCde := 5
+            end
+      end
+end;
+
+
+procedure OpenFile;
+var
+   i      : integer;
+   FleNme : string[12];
+begin
+   BufPos := 0;
+   FleNme := '';
+   i := 0;
+   while (i < 12) and (Buffer[i] <> 0) do
+      begin
+         FleNme := FleNme + chr(Buffer[i]);
+         i := i + 1
+      end;
+   gotoxy(42, 17);
+   write(FleNme, '':12);
+   assign(F, PthNme + FleNme);
+   rewrite(F);
+   FleOpn := true
+end;
+
+
+procedure FlushBuffer;
+begin
+   blockwrite(F, Buffer, BufPos div 128);
+   BufPos := 0
+end;
+
+
+procedure CloseFile;
+begin
+   if FleOpn then
+      begin
+         FlushBuffer;
+         close(F);
+         FleOpn := false
+      end
+end;
+
+
+function ReadBlockByte (TckVal : integer) : byte;
+var
+   BytVal : byte;
+begin
+   BytVal := ReadByte(TckVal);
+   Check := Check + BytVal;
+   ReadBlockByte := BytVal
+end;
+
+
+function CheckHeader : boolean;
+var
+   BytVal : byte;
+begin
+   BytVal := ReadBlockByte(182);
+   if (BytVal = EOT) and (not TmeOut) and (not Abort) then
+      begin
+         CloseFile;
+         WriteByte(ACK, 1820);
+         if TmeOut then
+            Abort := true;
+         if not Abort then
+            WriteByte(ACK, 1820);
+         if TmeOut then
+            Abort := true;
+         if Abort then
+            ExtCde := 6
+      end;
+   CheckHeader := BytVal = EOT
+end;
+
+
+procedure ReadBlocks;
+var
+   Finish                         : boolean;
+   i, SveBuf                      : integer;
+   GetBlk, BlkNmb, BlkCpl, ChkSum : byte;
+   BytVal                         : byte;
+begin
+   BufPos := 0;
+   GetBlk := 0;
+   FleOpn := false;
+   repeat
+      i := 0;
+      Check := 0;
+      SveBuf := BufPos;
+      Finish := CheckHeader;
+      if not Finish then
+         begin
+            if (not TmeOut) and (not Abort) then
+               BlkNmb := ReadBlockByte(19);
+            if (not TmeOut) and (not Abort) then
+               BlkCpl := ReadBlockByte(19);
+            while (not TmeOut) and (not Abort) and (i < 128) do
+               begin
+                  BytVal := ReadBlockByte(19);
+                  Buffer[BufPos] := BytVal;
+                  BufPos := BufPos + 1;
+                  i := i + 1
+               end;
+            if (not TmeOut) and (not Abort) then
+               ChkSum := ReadByte(19);
+            if (not TmeOut) and (not Abort) then
+               if ChkSum = Check then
+                  begin
+                     if not FleOpn and (BlkNmb = 0) then
+                        begin
+                           OpenFile;
+                           gotoxy(43, 18);
+                           write(BlkNmb, '': 2);
+                           BlockACK
+                        end;
+                     if BlkNmb = GetBlk then
+                        begin
+                           gotoxy(43, 18);
+                           write(BlkNmb, '': 2);
+                           GetBlk := GetBlk + 1;
+                           if BufPos > ENDBUF then
+                              FlushBuffer;
+                           BlockACK
+                        end
+                     else
+                        begin
+                           BufPos := SveBuf;
+                           if BlkNmb = (GetBlk - 1) then
+                              BlockACK
+                           else
+                              begin
+                                 Abort := true;
+                                 ExtCde := 7
+                              end
+                        end
+                  end;
+            if TmeOut or (Check <> ChkSum) then
+               begin
+                  BlockNAK;
+                  BufPos := SveBuf
+               end
+         end
+   until Abort or Finish
+end;
+
+
+procedure Receive;
+var
+   Retry, Finish : boolean;
+   BytVal        : byte;
+begin
+   Abort := false;
+   Finish := false;
+   ExtCde := 0;
+   repeat
+      StartNAK;                             { send NAK, then wait for ACK }
+      if not Abort then
+         begin
+            Retry := true;
+            while Retry and not Abort do
+               begin
+                  BytVal := ReadByte(19); { 1st letter of filename or EOT }
+                  Retry := TmeOut;
+                  if not Retry then
+                     Finish := BytVal = EOT
+                  else
+                     BlockNAK
+               end;
+            if (not Finish) and (not Abort) then
+               ReadBlocks
+         end
+   until Finish or Abort;
+   if Abort then
+      SendCancel;
+   gotoxy(1, 23);
+   case ExtCde of
+      1 : writeln('User cancelled by pressing abort key');
+      2 : writeln('Unable to send initial NAK to sender');
+      3 : writeln('No ACK response for initial NAK sent');
+      4 : writeln('Unable to send NAK for bad block');
+      5 : writeln('Unable to send ACK for block received');
+      6 : writeln('Unable to send ACK for file end (EOT)');
+      7 : writeln('Fatal loss of sync receiving blocks')
+   end
+end;
+
+
+begin
+   clrscr;
+   writeln('             MODEM v1.00  (c) S.J.Kay  1st April 1995');
+   writeln;
+   writeln('         Uses the Ward Christensen file transfer protocol');
+   writeln('                    with file name support.');
+   writeln;
+   writeln('         NOTE: Files will be written to the default drive.');
+   writeln;
+   writeln('    Uses AUXIN and AUXOUT devices, set device for correct values');
+   writeln('                    before using this program');
+   writeln;
+   writeln('          To abort press the ESC or ^X keys at any time');
+   writeln;
+   gotoxy(31, 17);
+   write(  'Receiving:');
+   gotoxy(31, 18);
+   write(  '    Block: #');
+   Receive
+end.