home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
LANGUAGS
/
PASCAL
/
MODEM3.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
2000-06-30
|
14KB
|
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
.