|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 10496 (0x2900)
Types: TextFile
Names: »TXAB.PAS«
└─⟦692ac107c⟧ Bits:30005923 PolyPascal-80 V3.10 arbejdsdiskette 1
└─⟦this⟧ »TXAB.PAS«
PROGRAM txaa;
CONST
callid = 'OZ6OH';
sio = true;
status = 1; (* SIO-PORTENS STATUS-PORT *)
data = 0; (* SIO-PORTENS DATA-PORT *)
rdy = 1; (* RECIEVE RDY-FLAG *)
delfac = 600; (* DELAY FACTOR *)
PROCEDURE rtson;
begin
port(.status.) := $15;
port(.status.) := $6A;
end;
PROCEDURE rtsoff;
begin
port(.status.) := $15;
port(.status.) := $68;
end;
CONST
version = ' 10/04/85 -2235';
atx = @0;
soh = @1;
stx = @2;
etx = @3;
eot = @4;
syn = @5;
ack = @6;
nak = @7;
dle = @8;
LABEL exit;
TYPE
hexstr = STRING(.4.);
rec = ARRAY(.0..127.) OF byte;
str14 = STRING(.14.);
str30 = STRING(.30.);
str50 = STRING(.50.);
str80 = STRING(.80.);
VAR
ss,abort : boolean;
s,ssav : str80;
parm : str50 AT $80;
ch : byte;
filn : str14;
ifil : FILE;
fill,i,j,m,t,sum : integer;
buffer : ARRAY(.0..7.) OF rec;
FUNCTION hex(tal,cif : integer) : hexstr;
CONST
hexcif : ARRAY(.0..15.) OF char = '0123456789ABCDEF';
VAR
h : hexstr;
c : integer;
BEGIN
h(.0.) := chr(cif);
FOR c := cif DOWNTO 1 DO
BEGIN
h(.c.) := hexcif(.tal AND 15.);
tal := tal SHR 4;
END;
hex := h;
END;
FUNCTION ascii(rc : rec) : boolean;
VAR
i : integer;
BEGIN
ascii := true;
FOR i := 0 TO 127 DO
IF (rc(.i.) > 127) OR (rc(.i.) < 9) THEN ascii := false;
END;
FUNCTION ipa : boolean;
VAR c : char;
BEGIN
ipa := port(.status.) AND rdy = rdy;
IF keypress THEN
BEGIN
read(kbd,c);
CASE c OF
'Q','q' : abort := true;
'R','r' : BEGIN
ss := true;
ssav := '';
END;
'F','f' : BEGIN
ss := true;
ssav := 'OK';
END;
OTHERWISE BEGIN
ss := true;
write(c);
readln(ssav);
ssav := c + ssav;
END;
END;
END;
END;
PROCEDURE delay(i : integer);
VAR n,j : integer;
BEGIN
FOR n := 0 TO i DO FOR j := 0 TO delfac DO BEGIN END;
END;
PROCEDURE resrts;
VAR n,j : integer;
BEGIN;
delay(10);
IF sio THEN
BEGIN
port(.status.) := $15;
port(.status.) := $68;
END;
END;
PROCEDURE setrts;
BEGIN;
write('WAIT');
IF sio THEN
BEGIN
port(.status.) := $15;
port(.status.) := $6A;
END;
delay(100);
write(@8,@8,@8,@8);
END;
PROCEDURE txnak;
BEGIN
setrts;
FOR i := 0 TO 5 DO write(aux,syn);
FOR i := 0 TO 5 DO write(aux,nak);
resrts;
END;
FUNCTION getch : char;
VAR
c : char;
timer : integer;
timout : boolean;
BEGIN;
(*$I-*)
IF sio THEN
BEGIN
REPEAT
timer := 0;
REPEAT
timer := succ(timer);
timout := timer=15000;
UNTIL ipa OR abort OR ss OR timout;
IF timout THEN
BEGIN
writeln('>>>TIMEOUT<<<');
txnak;
END;
UNTIL ipa OR abort OR ss;
IF ipa THEN getch := chr(port(.data.));
END ELSE
BEGIN
read(aux,c);
getch := c;
END;
END;
PROCEDURE getflt;
LABEL exit;
VAR
i : integer;
BEGIN;
i := 1;
REPEAT
s(.i.) := getch;
IF ss OR abort THEN GOTO exit;
i := i+1;
UNTIL (s(.i-1.) IN (.@0..@10,@13.));
s(.0.) := chr(i-2);
exit:
END;
PROCEDURE getresponse;
LABEL exit;
VAR
st : STRING(.4.);
c : char;
BEGIN
ss := false;
abort := false;
REPEAT c := getch UNTIL (c = syn) OR abort OR ss;
IF ss OR abort THEN GOTO exit;
REPEAT c := getch UNTIL (c = ack) OR abort OR ss;
IF ss OR abort THEN GOTO exit;
getflt;
IF ss OR abort THEN GOTO exit;
REPEAT c := getch UNTIL (c = etx) OR abort OR ss;
exit:
IF ss THEN IF ssav = '' THEN
FOR i := 0 TO 7 DO
BEGIN
IF i+m < fill THEN
BEGIN
str(i+m,st);
s := s + st + ' ';
END;
END ELSE s := ssav;
END;
FUNCTION strinp(s : str30;x,y,l : integer) : str30;
CONST
dots = '..............................';
VAR
p : integer;
ch : char;
PROCEDURE dyt; BEGIN write(@7); END;
BEGIN
gotoxy(x,y);
write(s,copy(dots,1,l-len(s)));
p := 0;
REPEAT
gotoxy(x+p,y);
read(kbd,ch);
CASE ch OF
@$7f,@8
: BEGIN
IF p = 0 THEN dyt ELSE
BEGIN
s := copy(s,1,p-1)+copy(s,p+1,l);
write(@8,copy(s,p,l),'.');
p := p-1;
END;
END;
^L : BEGIN
p := 0;
s := '';
gotoxy(x,y);
write(copy(dots,1,l));
END;
^S : IF (p > 0) THEN p :=p-1 ELSE dyt;
^D : IF (p < len(s)) THEN p := p+1 ELSE dyt;
^A : p := 0;
^F : p := len(s);
^G : IF (p = l) OR (p = len(s)) THEN dyt ELSE
BEGIN
s := copy(s,1,p)+copy(s,p+2,l);
write(copy(s,p+1,l),'.');
END;
' '..'ü'
: BEGIN
IF len(s) = l THEN dyt ELSE
BEGIN;
IF p = 0 THEN s := ch+copy(s,1,l-1)
ELSE s := copy(s,1,p)+ch+copy(s,p+1,l-1);
p := p+1;
write(copy(s,p,l));
END;
END;
END;
UNTIL (ord(ch)=13);
gotoxy(x+len(s),y);
write('':l - len(s));
gotoxy(x+len(s),y);
strinp:=s;
END;
PROCEDURE getfil;
VAR
ok : boolean;
LABEL exit;
BEGIN;
REPEAT
ok := true;
gotoxy(0,2);
write(clreos,'FILENAVN:');
filn := strinp('',10,2,14);
if len(filn) = 0 THEN GOTO exit;
assign (ifil,filn);
(*$I-*)
reset (ifil);
IF iores <> 0 THEN ok := false;
IF NOT ok THEN writeln(@7);
UNTIL ok;
IF filn(.2.) = ':' THEN filn := copy(filn,3,len(filn)-2);
exit:
END;
PROCEDURE presat(sum : integer);
BEGIN;
IF sum < 1000 THEN write(aux,'0');
IF sum < 100 THEN write(aux,'0');
IF sum < 10 THEN write(aux,'0');
write(aux,sum);
END;
PROCEDURE txbuf(i : integer);
VAR
as : boolean;
BEGIN
as := ascii(buffer(.i.));
write(i+m:5);
IF as THEN write('A') ELSE write('X');
FOR j := 0 TO 4 DO write(aux,syn);
write(aux,dle);
IF as THEN write(aux,atx) ELSE write(aux,stx);
sum := i+m;
presat(sum);
IF as THEN
FOR j := 0 TO 127 DO
BEGIN
write(aux,chr(buffer(.i.)(.j.)));
sum := (sum+buffer(.i.)(.j.)) MOD 10000;
END ELSE
FOR j := 0 TO 127 DO
BEGIN;
write(aux,hex(buffer(.i.)(.j.),2));
sum := (sum+buffer(.i.)(.j.)) MOD 10000;
END;
write(aux,dle);
write(aux,etx);
presat(sum);
END;
PROCEDURE txhdr;
VAR sv : char;
BEGIN;
REPEAT
setrts;
sv := ' ';
FOR j := 0 TO 4 DO write(aux,syn);
write(aux,dle);
write(aux,soh);
sum := length(ifil);
presat(sum);
write(aux,filn);
write(aux,dle);
write(aux,etx);
resrts;
getresponse; sv := 'F'
UNTIL (sv = 'F') OR (sv = 'f');
END;
FUNCTION num(c : char) : boolean;
BEGIN;
IF (c < '0') OR (c > '9') THEN num := false ELSE num := true;
END;
PROCEDURE retrans;
LABEL exit;
VAR
t : ARRAY(.0..7.) OF integer;
ok : boolean;
i,j,g : integer;
FUNCTION nxtrng : boolean;
VAR A : BOOLEAN;
BEGIN
A := TRUE;
FOR I := 0 TO 7 DO
IF M+I+8 < FILL THEN A := A AND (T(.I.)=I+M+8);
NXTRNG := A and (m+8<fill);
END;
BEGIN; (* RETRANS *)
REPEAT
REPEAT
FOR i := 0 TO 7 DO t(.i.) := 0;
ok := true;
g := 0;
writeln;
s := '';
getresponse;
IF abort THEN GOTO exit;
IF s = 'OK' THEN writeln('ALT OK') ELSE
BEGIN
writeln('RETRANSMITTER ',s) ;
IF fill-m < 8 THEN i := fill-m-1 ELSE i := 7;
i := 1;
WHILE (len(s) > 0) AND (NOT num(s(.1.))) DO
BEGIN (* SUPPRESS LEADING BLANKS AND TEST FOR INVALID CH *)
IF s(.1.) <> ' ' THEN ok := false;
s := copy(s,2,len(s)-1);
END;
WHILE (len(s) > 0) AND (NOT num(s(.len(s).))) DO
BEGIN (* SUPPRESS TRAILING BLANKS AND TEST FOR INVALID CH *)
IF s(.len(s).) <> ' ' THEN ok := false;
s := copy(s,1,len(s)-1);
END;
WHILE i <= len(s) DO
BEGIN;
WHILE ((NOT num(s(.i.))) AND (i <= len(s))) DO
BEGIN (* TEST FOR VALID SPACES *)
IF s(.i.) <> ' ' THEN ok := false;
i := succ(i);
END;
WHILE (num(s(.i.)) AND (i <= len(s))) DO
BEGIN
t(.g.) := t(.g.)*10+ord(s(.i.))-$30;
i := succ(i);
END;
g := succ(g);
END;
(* TEST FOR VALID NUMBERS *)
FOR i := 0 TO g-1 DO IF I+M < FILL THEN
IF ((t(.i.) < m) OR (t(.i.) > m+7))
THEN ok := false;
IF NXTRNG THEN
BEGIN
OK := TRUE;
s := 'OK';
G := 0;
END;
IF NOT ok THEN txnak;
END;
UNTIL ok;
IF g > 0 THEN
BEGIN;
setrts;
IF g > 0 THEN FOR g := 0 TO g-1 DO txbuf(t(.g.) MOD 8);
FOR j := 0 TO 5 DO write(aux,eot);
resrts;
END;
UNTIL s = 'OK';
exit:
END;
PROCEDURE nextblok;
BEGIN;
i := 0;
WHILE (NOT eof(ifil)) AND (i < 8) DO
BEGIN
blockread(ifil,buffer(.i.),1);
i := succ(i);
END;
writeln('=>',fill-m:4,' SECTOR(ER) RESTERER.');
setrts;
FOR i := 0 TO i-1 DO txbuf(i);
FOR j := 0 TO 5 DO write(aux,eot);
resrts;
retrans;
m := m+8;
END;
(* === *)
BEGIN;
resrts;
writeln(clrhom,rvson,'TXAB - SENDEPROGRAM, VERSION:',callid,version:13);
writeln ('===============================================',rvsoff);
IF len(parm) > 0 THEN
BEGIN
filn := copy(parm,2,len(parm)-1);
assign(ifil,filn);
(*$I-*)
reset(ifil);
IF iores <> 0 THEN getfil;
END ELSE getfil;
IF LEN(filn) = 0 THEN GOTO exit;
fill := length(ifil);
writeln('FILENAVN:',filn,', LÆNGDE = ',fill:1,' SECTOR(ER).');
writeln;
m := 0;
write('TAST <RETURN> FOR HEADER-BLOCK:');
readln;
txhdr;
WHILE NOT eof(ifil) DO
BEGIN
nextblok;
IF abort THEN GOTO exit;
END;
writeln('SLUT PÅ FILE ',filn);
exit:
IF abort THEN
BEGIN
writeln;
writeln(rvson,'PROGRAMMET AFBRUDT AF OPERTØREN.',rvsoff);
end;
END.
«eof»