Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MODEM3.ZIP/MODEM3.PAS

Pascal/Delphi Source File | 1989-03-20 | 14.4 KB | 649 lines

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
.