PROGRAM modem;
     {Written by Jack M. Wierda  Chicago Illinois
     This program is in the public domain.

     LANGUAGE: UCSD Pascal
     FILES:    MODEM3.PAS -- main program
               MDM3-Z80IO.Z80 -- serial line interface for Z80
               MDM3-8080IO.Z80 -- serial line interface for Intel 8080

     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 Ward's program running under CP/M. One difference is that when sending
files the PASCAL or CP/M transfer mode must be selected. The PASCAL mode
transfers files between two systems running PASCAL, while the CP/M mode is
used when the receiving system is running CP/M. Basically the CP/M mode
provides the linefeeds required to make a PASCAL file compatible with CP/M.
When CP/M files are received they contain linefeeds, these can be deleted
using the editor to make the file compatible with PASCAL. CP/M files may also
contain tabs which the PASCAL editor does not expand.
     External assembly language routines are used to read the status, and read
or write the keyboard and modem ports. These routines are available as
separate files for the 8080 and Z80 processors. The port and flag definitions,
and the timing constant for the one second delay should be changed as required
for your particular hardware.
     The program has been tested with text files only, and may not work
correctly for code or other types of files.
     The PDP-10 mode transfers PASCAL files to a DEC SYSTEM-10 computer.}

CONST
     nul = 0;
     soh = 1;
     ctrlc = 3;
     eot = 4;
     errormax = 5;
     retrymax = 5;
     ctrle = 5;
     ack = 6;
     tab = 9;
     lf = 10;
     cr = 13;
     ctrlq = 17;
     ctrls = 19;
     nak = 21;
     ctrlz = 26;
     space = 32;
     delete = 127;
     lastbyte = 127;
     timeout = 256;
     loopspersec = 1800       {1800 LOOPS PER SECOND AT 4MHZ};
     kbsp = 0           {KEYBOARD STATUS PORT};
     kbdrf = 128        {KEYBOARD DATA READY FLAG};
     kbdp = 1           {KEYBOARD DATA PORT};
     kbmask = 127       {KEYBOARD DATA MASK};
     dchdp = 128        {D. C. HAYES DATA PORT};
     dchmask = 255      {D. C. HAYES DATA MASK};
     dchsp = 129        {D. C. HAYES STATUS PORT};
     {STATUS PORT BIT ASSIGNMENTS}
     rrf     =    1   {RECEIVE REGISTER FULL};
     tre     =    2   {TRANSMIT REGISTER EMPTY};
     perr    =    4   {PARITY ERROR};
     ferr    =    8   {FRAMING ERROR};
     oerr    =    16  {OVERFLOW ERROR};
     cd      =    64  {CARRIER DETECT};
     nri     =    128 {NO RINGING INDICATOR};
     dchcp1 = 129       {D. C. HAYES CONTROL PORT 1};
     {CONTROL PORT 1 BIT ASSIGNMENTS}
     epe     =    1   {EVEN PARITY ENABLE};
     ls1     =    2   {LENGTH SELECT 1};
     ls2     =    4   {LENGTH SELECT 2};
     sbs     =    8   {STOP BIT SELECT};
     pi      =    16  {PARITY INHIBIT};
     dchcp2 = 130       {D. C. HAYES CONTROL PORT 2};
     {CONTROL PORT 2 BIT ASSIGNMENTS}
     brs     =    1   {BIT RATE SELECT};
     txe     =    2   {TRANSMIT ENABLE};
     ms      =    4   {MODE SELECT};
     es      =    8   {ECHO SUPPRESS};
     st      =    16  {SELF TEST};
     rid     =    32  {RING INDICATOR DISABLE};
     oh      =    128 {OFF HOOK};

VAR file1 : text;
   option, hangup, return, mode, baudrate, display, filemode : char;
   sector : ARRAY[0..lastbyte] OF integer;
   dchcw2 : integer;
   ovrn1, ovrn2, showrecv, showtrans : boolean;

FUNCTION stat(port,exr,mask:integer): boolean;
external;

FUNCTION input(port,mask:integer): integer;
external;

PROCEDURE output(port,data:integer);
external;

PROCEDURE sendline(sldata:integer);
BEGIN
 REPEAT
 UNTIL stat(dchsp,tre,tre);
 output(dchdp,sldata);
 IF showtrans
 THEN
   IF (sldata = cr) OR ((sldata >= space) AND (sldata <= delete))
   THEN
     write(chr(sldata))
END;

FUNCTION readline(seconds:integer): integer;

VAR j : integer;
BEGIN
 j := loopspersec * seconds;
 REPEAT
   j := j-1
 UNTIL (stat(dchsp,rrf,rrf)) OR (j = 0);
 IF j = 0
 THEN
   readline := timeout
 ELSE
   BEGIN
     j := input(dchdp,dchmask);
     IF showrecv
     THEN
       IF (j = cr) OR ((j >= space) AND (j <= delete))
       THEN
         write(chr(j));
     readline := j
   END
END;

PROCEDURE sendstr(str:string);

VAR j: integer;
BEGIN
 FOR j := 1 TO length(str) DO
   sendline(ord(str[j]))
END;

FUNCTION uppercase(ch : char) : char;
BEGIN
 IF ch IN ['a'..'z']
 THEN
   uppercase := chr(ord(ch)-space)
 ELSE
   uppercase := ch
END;

PROCEDURE purgeline;

VAR j : integer;
BEGIN
 REPEAT
   j := input(dchdp,dchmask)      {PURGE THE RECEIVE REGISTER};
 UNTIL NOT stat(dchsp,rrf,rrf)
END;

PROCEDURE dchinitialize;
BEGIN
 writeln('Waiting for carrier');
 REPEAT
   BEGIN
     IF option IN ['R','S']
     THEN
       BEGIN
         output(dchcp1,pi+ls2+ls1);
         output(dchcp2,oh+rid+txe+dchcw2)
       END;
     IF option IN ['C','P','T']
     THEN
       BEGIN
         output(dchcp1,ls2+epe);
         output(dchcp2,oh+rid+txe+dchcw2)
       END
   END
 UNTIL (stat(dchsp,cd,cd)) OR (input(kbdp,kbmask) = ctrle);
 purgeline;
 writeln('Carrier detected')
END;

PROCEDURE makesector;

VAR j : integer;
   ch : char;
BEGIN
 j := 0;
 IF ovrn1
 THEN
   BEGIN
     sector[j] := cr;
     j := j+1
   END;
 IF ovrn2
 THEN
   BEGIN
     sector[j] := lf;
     j := j+1
   END;
 ovrn1 := false;
 ovrn2 := false;
 WHILE (NOT eof(file1)) AND (j <= lastbyte) DO
   BEGIN
     WHILE (NOT eoln(file1)) AND (j <= lastbyte) DO
       BEGIN
         read(file1,ch);
         IF ord(ch) <> lf
         THEN
           BEGIN
             sector[j] := ord(ch);
             j := j+1
           END
       END;
     IF eoln(file1)
     THEN
       BEGIN
         readln(file1);
         IF filemode IN ['P']
         THEN
           IF j <= lastbyte
           THEN
             BEGIN
               sector[j] := cr;
               j := j+1
             END
           ELSE
             ovrn1 := true
         ELSE
           BEGIN
             IF j <= (lastbyte-1)
             THEN
               BEGIN
                 sector[j] := cr;
                 sector[j+1] := lf;
                 j := j+2
               END
             ELSE
               IF j = lastbyte
               THEN
                 BEGIN
                   sector[j] := cr;
                   j := j+1;
                   ovrn1 := true
                 END
               ELSE
                 IF j > lastbyte
                 THEN
                   BEGIN
                     ovrn1 := true;
                     ovrn2 := true
                   END
           END
       END
   END;
 CASE filemode OF
   'P' : IF j <= lastbyte
         THEN
           FOR j := j TO lastbyte DO
             sector[j] := space;
   'C' : IF j <= lastbyte
         THEN
           FOR j := j TO lastbyte DO
             sector[j] := ctrlz
 END
END;

PROCEDURE termcomp;

VAR kbdata, dchdata : integer;
   crflag : boolean;
BEGIN
 crflag := false;
 dchinitialize;
 WHILE stat(dchsp,cd,cd) AND (kbdata <> ctrle) DO
   BEGIN
     IF stat(kbsp,kbdrf,kbdrf)
     THEN
       BEGIN
         kbdata := input(kbdp,kbmask);
         IF option IN ['C']
         THEN
           write(chr(kbdata));
         output(dchdp,kbdata)
       END;
     IF stat(dchsp,rrf,rrf)
     THEN
       BEGIN
         dchdata := input(dchdp,dchmask);
         IF option IN ['C']
         THEN
           output(dchdp,dchdata);
         IF dchdata = cr
         THEN
           crflag := true;
         IF (dchdata = lf) AND crflag
         THEN
           crflag := false
         ELSE
           write(chr(dchdata))
       END
   END
END;

PROCEDURE pdp10;

VAR wait10 : boolean;
   dchdata : integer;
   ch : char;
   filename, pdp10file : string;
BEGIN
 showrecv := false;
 showtrans := true;
 wait10 := false;
 write('Filename.Ext ? ');
 readln(filename);
 reset(file1,filename);
 IF option IN ['P']
 THEN
   BEGIN
     write('PDP-10 Filename.Ext ? ');
     readln(pdp10file);
     dchinitialize;
     sendline(cr);
     sendstr('R PIP');
     sendline(cr);
     REPEAT
     UNTIL readline(5) IN [ord('*'),timeout];
     sendstr(pdp10file);
     sendstr('=TTY:');
     sendline(cr)
   END
 ELSE
   BEGIN
     write('UNIX Filename.Ext ? ');
     readln(pdp10file);
     dchinitialize;
     sendline(cr);
     sendstr('cat > ');
     sendstr(pdp10file);
     sendline(cr)
   END;
 WHILE (NOT eof(file1)) AND (stat(dchsp,cd,cd)) DO
   BEGIN
     WHILE NOT eoln(file1) DO
       BEGIN
         IF NOT wait10
         THEN
           BEGIN
             read(file1,ch);
             sendline(ord(ch))
           END;
         IF stat(dchsp,rrf,rrf)
         THEN
           BEGIN
             dchdata := input(dchdp,dchmask);
             IF dchdata = ctrls
             THEN
               wait10 := true;
             IF dchdata = ctrlq
             THEN
               wait10 := false
           END
       END;
     readln(file1);
     sendline(cr)
   END;
 close(file1);
 REPEAT
 UNTIL readline(1)=timeout;
 IF option IN ['P']
 THEN
   BEGIN
     sendline(ctrlz);
     sendline(ctrlc);
   END
 ELSE
   BEGIN
     sendline(eot)
   END;
 termcomp
END;

PROCEDURE sendfile;

VAR j, k, sectornum, counter, checksum : integer;
   filename : string;
BEGIN
 write('Filename.Ext ? ');
 readln(filename);
 reset(file1,filename);
 sectornum := 1;
 dchinitialize;
 ovrn1 := false;
 ovrn2 := false;
 REPEAT
   counter := 0;
   makesector;
   REPEAT
     writeln;
     writeln('Sending sector ', sectornum);
     sendline(soh);
     sendline(sectornum);
     sendline(-sectornum-1);
     checksum := 0;
     FOR j := 0 TO lastbyte DO
       BEGIN
         sendline(sector[j]);
         checksum := (checksum + sector[j]) MOD 256
       END;
     sendline(checksum);
     purgeline;
     counter := counter + 1;
   UNTIL (readline(10) = ack) OR (counter = retrymax);
   sectornum := sectornum + 1
 UNTIL (eof(file1)) OR (counter = retrymax);
 IF counter = retrymax
 THEN
   BEGIN
     writeln;
     writeln('No ACK on sector')
   END
 ELSE
   BEGIN
     counter := 0;
     REPEAT
       sendline(eot);
       counter := counter + 1
     UNTIL (readline(10) = ack) OR (counter = retrymax);
     IF counter = retrymax
     THEN
       BEGIN
         writeln;
         writeln('No ACK on EOT')
       END
     ELSE
       BEGIN
         writeln;
         writeln('Transfer complete')
       END
   END;
 close(file1)
END;

PROCEDURE readfile;

VAR j, firstchar, sectornum,sectorcurrent, sectorcomp, errors,
   checksum : integer;
   errorflag : boolean;
   filename : string;
BEGIN
 write('Filename.Ext ? ');
 readln(filename);
 rewrite(file1,filename);
 sectornum := 0;
 errors := 0;
 dchinitialize;
 sendline(nak);
 sendline(nak);
 REPEAT
   errorflag := false;
     REPEAT
       firstchar := readline(20)
     UNTIL firstchar IN [soh,eot,timeout];
   IF firstchar = timeout
   THEN
     BEGIN
       writeln;
       writeln('SOH error');
     END;
   IF firstchar = soh
   THEN
     BEGIN
       sectorcurrent := readline(1);
       sectorcomp := readline(1);
       IF (sectorcurrent+sectorcomp)=255
       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]) MOD 256
                 END;
               IF checksum=readline(1)
               THEN
                 BEGIN
                   FOR j := 0 TO lastbyte DO
                     write(file1,chr(sector[j]));
                   errors := 0;
                   sectornum := sectorcurrent;
                   IF display <> 'R'
                   THEN
                     BEGIN
                       writeln;
                       writeln('Received sector ',sectorcurrent)
                     END;
                   sendline(ack)
                 END
               ELSE
                 BEGIN
                   writeln;
                   writeln('Checksum error');
                   errorflag := true
                 END
             END
           ELSE
             IF (sectorcurrent=sectornum)
             THEN
               BEGIN
                 REPEAT
                 UNTIL readline(1)=timeout;
                 writeln;
                 writeln('Received duplicate sector ', sectorcurrent);
                 sendline(ack)
               END
             ELSE
               BEGIN
                 writeln;
                 writeln('Synchronization error');
                 errorflag := true
               END
         END
       ELSE
         BEGIN
           writeln;
           writeln('Sector number error');
           errorflag := true
         END
     END;
   IF (errorflag=true)
   THEN
     BEGIN
       errors := errors+1;
       REPEAT
       UNTIL readline(1)=timeout;
       sendline(nak)
     END;
 UNTIL (firstchar IN [eot,timeout]) OR (errors = errormax);
 IF (firstchar = eot) AND (errors < errormax)
 THEN
   BEGIN
     sendline(ack);
     close(file1,lock);
     writeln;
     writeln('Transfer complete')
   END
 ELSE
   BEGIN
     close(file1);
     writeln;
     writeln('Aborting')
   END
END;
BEGIN
 writeln('Modem, 7-July-79');
 REPEAT
   REPEAT
     write('Option : C(omputer), P(DP-10), R(eceive), S(end), T(erminal)');
     write(', U(nix) ? ');
     read(option);
     option := uppercase(option);
     writeln
   UNTIL option IN ['C','P','R','S','T','U'];
   REPEAT
     write('Mode : A(nswer), O(riginate) ? ');
     read(mode);
     mode := uppercase(mode);
     writeln
   UNTIL mode IN ['A','O'];
   IF mode IN ['O']
   THEN
     dchcw2 := ms
   ELSE
     dchcw2 := 0;
   REPEAT
     write('Baud rate : 1(00), 3(00) ? ');
     read(baudrate);
     writeln
   UNTIL baudrate IN ['1','3'];
   IF baudrate='3'
   THEN
     dchcw2 := dchcw2+brs;
   IF option IN ['R','S']
   THEN
     BEGIN
       REPEAT
         write('Display : N(o), R(eceived), T(ransmitted) data ? ');
         read(display);
         display := uppercase(display);
         writeln
       UNTIL display IN ['N','R','T'];
       IF option = 'S'
       THEN
         BEGIN
           REPEAT
             write('File mode : C(pm), P(ascal) ? ');
             read(filemode);
             filemode := uppercase(filemode);
             writeln
           UNTIL filemode IN ['C','P']
         END;
       CASE display OF
         'N': BEGIN
                showrecv := false;
                showtrans := false
              END;
         'R': BEGIN
                showrecv := true;
                showtrans := false
              END;
         'T': BEGIN
                showrecv := false;
                showtrans := true
              END
       END
     END;
   CASE option OF
     'C': termcomp;
     'P': pdp10;
     'R': readfile;
     'S': sendfile;
     'T': termcomp;
     'U': pdp10
   END;
   REPEAT
     writeln;
     write('Hangup : Y(es), N(o) ? ');
     read(hangup);
     hangup := uppercase(hangup);
     writeln
   UNTIL hangup IN ['Y','N'];
   IF hangup IN ['Y']
   THEN
     output(dchcp2,0);
   REPEAT
     writeln;
     write('Return to system : Y(es), N(o) ? ');
     read(return);
     return := uppercase(return);
     writeln
   UNTIL return IN ['Y','N'];
 UNTIL return IN ['Y']
END

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.