{$C-} {no user interrupts}
{$U-}
{$K-} {no stack checking - program works}
program Modem;

{ Written by Jack M. Wierda  Chicago Illinois
  Modified by Steve Freeman

      LANGUAGE: TURBO Pascal
      This program is in the public domain.

      This program is basically a re-write in PASCAL of Ward Christensen's
Modem Program which was distributed in CP/M User's Group Volume 25. Identical
and compatible options are provided to allow this program to work directly
with XMODEM running under CP/M. }

const
      Version = '12-Nov-84';
      FredsPhone = '7-5038';
      SignOnLine = 'ACGM10,RLIP,PSSWD';
      MaxPhoneNums = 26;
      COMport = 1;

      NUL   =   00;   SOH   = #$01;   EOT   = #$04;   ACK   = #$06;
      TAB   =   09;   LF    = #$0A;   CR    = #$0D;   NAK   = #$15;
      Space = ' ';    DELete = $7F;

      lastbyte = 127;
      timeout  = 256;
      errormax = 5;
      retrymax = 5;
      loopspersec = 6500;
      Intseg: integer = 0; {filled with interrupt segment address}

type maxstr = string[255];
     PhoneEntry = string[32];
     PhoneStr = string[20];
     BytePointer = ^byte;

var  COMbase: integer; {this will point to the Communications base}
     WorkFile: file;
     PhoneFile: text;
     PhoneList: array[1..MaxPhoneNums] of PhoneEntry;
     option, hangup, return, mode, baudrate : char;
     sector : array[0..lastbyte] of byte;
     base, N_Phones: integer;

     { interrupt vectors and pointers to them }
     newvec, oldvec: BytePointer;
     INT3: BytePointer absolute $0000:$002C; {for COM2:}
     INT4: BytePointer absolute $0000:$0030; {for COM1:}
     rcvbuf: array[0..127] of byte;
     inptr, outptr: integer;
     datardy: boolean;
{.pa}
  type hexstr = string[4];
  function hex(num: integer): hexstr;
    var i, j: integer;
        h: string[16];
        str: hexstr;
    begin
      str := '0000';   h := '0123456789ABCDEF';   j := num;
      for i:=4 downto 1
        do begin
             str[i] := h[(j and 15)+1];
             j := j shr 4;
           end;
      hex := str;
    end;
{.cp10}
  function GetYN: char;
    var c: char;
    begin
      repeat
          read(kbd,c);
          c := upcase(c);
        until c in ['Y','N'];
      writeln(c);
      GetYN := c
    end;
{.cp4}
  procedure SetDTR;
    begin
      port[base+4] := $09; {DTR on and INT enabled}
    end;
{.cp4}
  procedure HangUpPhone; {hang up by terminating the line}
    begin
      port[base+4] := 0;
    end;
{.cp7}
  function status: integer;
    var st: integer;
    begin
      st := port[base+5];
      st := st shl 8 + port[base+6];
      status := st;
    end;
{.cp6}
  procedure send(ch: char);
    var s: byte;
    begin
      repeat s := port[base+5] and $20 until (s=$20);
      port[base] := ord(ch);
    end;
{.cp6}
  function get_rcv_char: char;
    begin
      get_rcv_char := chr(rcvbuf[outptr]);
      outptr := (outptr + 1) and $7F;
      if inptr=outptr then datardy := false;
    end;
{.cp5}
  function receive: char;
    begin
      repeat until datardy;
      receive := get_rcv_char;
    end;
{.cp9}
  function ReadLine(seconds:integer): integer;
    var j : integer;
    begin
      j := loopspersec * seconds;
      repeat  j := j-1  until datardy or (j = 0);
      if j = 0
        then readline := timeout
        else readline := ord(get_rcv_char);
    end;
{.cp8}
  procedure PurgeLine;   {purge the receive register}
    var c: char;
    begin
      repeat
          if datardy then c := get_rcv_char;
          delay(35);   { 300 baud time period for received char }
        until not(datardy)
    end;
{.cp42}
  procedure Set_RS232_Vector;

    procedure Int_Handler;
    { This routine buffers all incoming received data }
      begin
        inline($50/$52/$57/$1E/                     {save registers}
        $2E/             {CS:}
        $8E/$1E/Intseg/  {MOV   DS,[Intseg]}        {get data segment pointer}
        $BA/$FD/$03/     {MOV   DX,$3FD}            {is character ready?}
        $EC/             {IN    AL,DX}
        $24/$01/         {AND   AL,01}
        $74/$19/         {JZ    here}               { no, skip entry}
        $BA/$F8/$03/     {MOV   DX,$3F8}            { yes, get pointer}
        $A1/inptr/       {MOV   AX,[inptr]}         {get index to buffer}
        $97/             {XCHG  DI,AX}
        $EC/             {IN    AL,DX}              {get data from receiver}
        $88/$85/rcvbuf/  {MOV   [DI+rcvbuf],AL}     {put data into buffer}
        $97/             {XCHG  DI,AX}              {increment pointer}
        $40/             {INC   AX}
        $24/$7F/         {AND   AL,$7F}
        $A3/inptr/       {MOV   [inptr],AX}
        $B8/$01/$00/     {MOV   AX,1}               {show data is ready}
        $A2/datardy/     {MOV   [datardy],AX}
                   {here}
        $B0/$64/         {MOV   AL,64}              {EOI, level 4 on 8259}
        $E6/$20/         {OUT   20,AL}
        $1F/$5F/$5A/$58/$CF);                       {restore and return}
      end;

    begin
      Intseg := Dseg;
      COMbase := $0400 + 2 * (COMport - 1);
      oldvec := INT4;
      newvec := ptr(cseg,ofs(Int_Handler)+7+5);
      INT4 := newvec;
      inline($BA/$3F8/         {MOV  DX,BASE}
             $EC/$EC/$EC/$EC/  {IN   AL,DX}
             $BA/$3FD/$EC/     {MOV  DX,BASE+5 ! IN  AL,DX}
             $BA/$3FE/$EC);    {MOV  DX,BASE+6 ! IN  AL,DX}
      datardy := false;   inptr := 0;   outptr := inptr;
      inline($E4/$21/$24/$EF/$E6/$21); {turn off IRQ mask bit - enabled}
    end;
{.cp16}
  procedure Setup(md, brc: char);
    var al: integer;
    begin
      base := memw[0:COMbase];
      port[base+3] := $83;         {access baud rate divisor and sets
                                    8 data, no parity, 1 stop}
      if md='O' then mode:=' ' else mode:='R';
      baudrate := brc;
      if baudrate='1'
        then portw[base] := $0060     {1200 baud}
        else portw[base] := $0180;    { 300 baud}
      port[base+3] := $03;         {set access for xmt/rcv}
      port[base+1] := $01;         {enable receiver interrupts}
      SetDTR;                      {put station on-line}
      return := 'N';
    end;
{.cp16}
  procedure Initialize;
    var mode, baudrate: char;
    begin
      repeat
          write('Mode : A(nswer), O(riginate) ? ');
          read(kbd,mode);   mode := upcase(mode);
        until mode in ['A','O'];
      writeln(mode);
      repeat
          write('Baud rate : 3(00), 1(200) ? ');
          read(kbd,baudrate);
        until baudrate in ['1','3'];
      writeln(baudrate);
      Setup(mode,baudrate);
    end;
{.cp19}
  procedure terminal;
    var s, t: byte;
        c: char;
    begin {$I-}  {no I/O checking here}
      writeln('Use ctrl-E to exit terminal mode.');
      repeat
          s := port[base+5];   {get status}
          if datardy
            then begin
                   t := ord(get_rcv_char);   t := t and $7F;
                   if t<>$7F then write(chr(t));
                 end;
            if keypressed and ((s and $20) = $20)
              then begin
                     read(kbd,c);
                     port[base] := ord(c);
                   end;
        until (c = ^E);
    end; {$I+}
{.cp5}
  procedure sendtext(str: maxstr);
    var i: integer;
    begin
      for i:=1 to length(str) do send(str[i]);
    end;
{.cp20}
  function Dial(PhoneNumber: PhoneStr): char;
    var c, kc: char;
        t: integer;
    begin
      HangUpPhone;  write(cr,lf,'Dialing: ',PhoneNumber);
      delay(250);   SetDTR;   delay(250);   sendtext(cr);   delay(1000);
      sendtext('AT '+mode+'M1V0DT'+PhoneNumber+cr);   delay(2000);
      c := receive;   c := chr(0);   repeat  c := get_rcv_char  until (c=cr);
      write(', Waiting for carrier ...');
      t := 60 * loopspersec;
      repeat
          t := t - 1;
          if datardy then c := get_rcv_char;
          if keypressed then read(kbd,kc);
        until (c in ['0'..'5']) or (t=0) or (kc=^E);
      if c='1'
        then writeln(' connected.')
        else if (t=0) or (kc=^E) then c := '9';
      Dial := c
    end;
{.cp15}
  procedure SignOn;
    var i: integer;
        c: char;
    begin
      write('Signing on ... ');
      delay(2000);
      for i:=1 to 7
        do begin
             send('8');
             delay(333);
           end;
      sendtext('('+cr);
      delay(2500);   sendtext(SignOnLine+cr);
      writeln('all set !');
    end;
{.pa}
  procedure SendFile;
    var j, sectornum, counter, checksum : integer;
        filename : string[20];
        c: char;

    procedure SendIt;
      begin
        sectornum := 1;
        repeat
            counter := 0;
            blockread(WorkFile,sector,1);
            repeat
                write(cr,'Sending sector ', sectornum);
                send(SOH);   send(chr(sectornum));   send(chr(-sectornum-1));
                checksum := 0;
                for j:=0 to lastbyte
                  do begin
                       send(chr(sector[j]));
                       checksum := (checksum + sector[j]) mod 256
                     end;
                send(chr(checksum));
                purgeline;
                counter := counter + 1;
              until (readline(10) = ord(ack)) or (counter = retrymax);
            sectornum := sectornum + 1
          until (eof(WorkFile)) or (counter = retrymax);
        if counter = retrymax
          then writeln(cr,lf,'No ACK on sector')
          else begin
                 counter := 0;
                 repeat
                     send(EOT);
                     counter := counter + 1
                   until (readline(10)=ord(ack)) or (counter=retrymax);
                 if counter = retrymax
                   then writeln(cr,lf,'No ACK on EOT')
                   else writeln(cr,lf,'Transfer complete');
               end;
      end;

  begin
      write('Filename.Ext ? ');   readln(filename);
      if length(filename)>0
        then begin
               assign(WorkFile,filename);
               reset(WorkFile);
               SendIt;
               close(WorkFile)
             end;
  end;
{.pa}
procedure readfile;
  var j, firstchar, sectornum,sectorcurrent, sectorcomp, errors,
      checksum : integer;
      errorflag : boolean;
      filename : string[20];

  procedure ReceiveIt;
    begin
      sectornum := 0;   errors := 0;
      send(nak);   send(nak);  { send ready characters }
      repeat
          errorflag := false;
          repeat
              firstchar := readline(20)
            until firstchar in [ord(SOH),ord(EOT),timeout];
          if firstchar = timeout then writeln(cr,lf,'Error - No starting SOH');
          if firstchar = ord(SOH)
            then begin
                   sectorcurrent := readline(1);      {real sector number}
                   sectorcomp := readline(1);         {+ inverse of above}
                   if (sectorcurrent+sectorcomp)=255  {<-- becomes this #}
                     then begin
                            if (sectorcurrent=sectornum+1)
                              then begin
                                     checksum := 0;
                                     for j := 0 to lastbyte
                                       do begin
                                            sector[j] := readline(1);
                                            checksum := (checksum+sector[j]) and $00FF
                                          end;
                                     if checksum=readline(1)
                                       then begin
                                              blockwrite(WorkFile,sector,1);
                                              errors := 0;
                                              sectornum := sectorcurrent;
                                              write(cr,'Received sector ',sectorcurrent);
                                              send(ack)
                                            end
                                       else begin
                                              writeln(cr,lf,'Checksum error');
                                              errorflag := true
                                            end
                                   end
                              else if (sectorcurrent=sectornum)
                                     then begin
                                            repeat until readline(1)=timeout;
                                            writeln(cr,lf,'Received duplicate sector ', sectorcurrent);
                                            send(ack)
                                          end
                                     else begin
                                            writeln(cr,lf,'Synchronization error');
                                            errorflag := true
                                          end
                          end
                     else begin
                            writeln(cr,lf,'Sector number error');
                            errorflag := true
                          end
                 end;
          if errorflag then begin
                              errors := errors+1;
                              repeat until readline(1)=timeout;
                              send(nak)
                            end;
        until (firstchar in [ord(EOT),timeout]) or (errors = errormax);
      if (firstchar=ord(EOT)) and (errors<errormax)
        then begin
               send(ack);
               writeln(cr,lf,'Transfer complete')
             end
        else writeln(cr,lf,'Aborting');
    end;

  begin
    write('Filename.Ext ? ');   readln(filename);
    if length(filename)>0
      then begin
             assign(WorkFile,filename);
             rewrite(WorkFile);
             ReceiveIt;
             close(WorkFile);
           end;
  end;
{.cp17}
  function ReadPhoneList: integer;
    var index: integer;
    begin
      assign(PhoneFile,'MODEM.PHN');
      index := 0;
      {$I-}  reset(PhoneFile);  {$I+}
      if IOresult=0
        then begin
               while (not eof(PhoneFile)) and (index<26)
                 do begin
                      index := index + 1;
                      readln(PhoneFile,PhoneList[index]);
                    end;
               close(PhoneFile);
             end;
      ReadPhoneList := index;
    end;
{.cp41}
  procedure Call;
    var rc: char;
        selection, i, j, k: integer;
        PhoneNo: PhoneStr;
    begin
      if N_Phones>0
        then begin
               clrscr;   writeln;
               for i:=1 to N_Phones
                 do begin
                      if (i mod 2)=0
                        then write('      ')
                        else writeln;
                      write(chr(i+64),' - ',PhoneList[i]);
                    end;
               writeln;   writeln;   write('Enter selection letter: ');
               repeat
                   repeat until keypressed;
                   read(kbd,rc);   rc := upcase(rc);
                   selection := ord(rc) - ord('@');
                 until (selection in [1..N_Phones]);
               writeln(rc);
               mode     := PhoneList[selection][31];
               baudrate := PhoneList[selection][32];
               Setup(mode,baudrate);
               j := 30;   PhoneNo := '';
               while PhoneList[selection][j]<>'.' do j:=j-1;
               for k:=j+1 to 30 do PhoneNo := PhoneNo + PhoneList[selection][k];
               rc := Dial(PhoneNo);
             end
        else rc := Dial(FredsPhone);
      if rc='1'
        then begin
               if N_Phones=0
                 then SignOn
                 else if selection=1 then Signon;
               terminal;
             end
        else HangUpPhone;
    end;
{.cp22}
  procedure GetOption;
    begin
      clrscr;
      writeln('Modem, ',Version);
      gotoxy(7,4);   writeln('Options:');
      writeln;
      writeln('  R - receive a file');
      writeln('  S - send a file');
      writeln('  T - terminal mode');
      writeln;
      writeln('  C - place a call');
      writeln('  H - hang up the phone');
      writeln('  O - option configuration');
      writeln('  X - exit to system');
      writeln;   write('which ? ');
      repeat
          read(kbd,option);
          option := upcase(option);
        until option IN ['O','C','R','S','T','H','X'];
      writeln(option);
    end;
{.cp16}
begin {Modem}
  Set_RS232_Vector;
  N_Phones := ReadPhoneList;
  Setup('O','1');   { default of Originate/1200 baud }
  repeat
      GetOption;
      case option of
        'T': Terminal;
        'R': ReadFile;
        'S': SendFile;
        'O': Initialize;
        'C': Call;
        'H': HangUpPhone;
        'X': return := 'Y';
      end;
    until return='Y';
  inline($E4/$21/$0C/$10/$E6/$21); {turn on IRQ mask bit - disabled}
(*  INT4 := oldvec;  {restore the old RS232 vector} *)
end.