|
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: 14720 (0x3980)
Types: TextFile
Names: »HDX.PAS«
└─⟦692ac107c⟧ Bits:30005923 PolyPascal-80 V3.10 arbejdsdiskette 1
└─⟦this⟧ »HDX.PAS«
PROGRAM hdx;(*$I-*)
CONST
st = 1;
dt = 0;
rd = 1;
delfac = 500;
VAR
filn : string(.14.);
fil : text;
line : string(.127.);
mode,i : integer;
c : char;
wait,valid,tx,rx,slut : boolean;
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 getresp;
begin
readln;
end;
FUNCTION ipa : boolean;
BEGIN
ipa := port(.st.) AND rd = rd;
END;
PROCEDURE getaux;
VAR ok : boolean;
BEGIN
ok := false;
repeat
REPEAT UNTIL ipa OR keypress;
IF keypress THEN
BEGIN
read(kbd,c);
IF c = ^B then
BEGIN
mode := 3;
ok := true;
writeln(@8,@8,@8,@8,@8,@8,@8,clreol);
END;
IF c = ^X then
begin
mode := 0;
tx := true;
END;
slut := c = ^Z;
ok := tx OR slut;
END ELSE
BEGIN
c := chr(port(.dt.)and 127);
CASE mode of
0 : IF c = ^B THEN mode := 1;
1 : IF c = ^B then
begin
writeln(@8,@8,@8,@8,@8,@8,@8,clreol);
mode := 2;
END;
2 : IF c <> ^B then
begin
mode := 3;
ok := true;
END;
END;
IF mode = 3 then
begin
ok := true;
IF c = ^Z THEN slut := true;
IF c = ^X then
begin
mode := 0;
tx := true;
END;
IF ok THEN IF c = @13 THEN writeln ELSE write(c);
END;
END;
UNTIL ok;
END;
PROCEDURE getcon;
var i : integer;
BEGIN
read(kbd,c);
CASE c OF
^X : rx := true;
^Z : begin
write(aux,c);
slut := true;
end;
^F : BEGIN
write(clrhom,rvson,'Hvilken file skal sendes?',rvsoff);
readln(filn);
assign(fil,filn);
reset(fil);
IF IORES <> 0 THEN WRITELN('ERROR') ELSE
BEGIN
writeln(rvson,'>>>>> START PÅ FIL ',filn,' <<<<<',rvsoff);
writeln(aux,'>>>>> START PÅ FIL ',filn,' <<<<<');
i := 0;
while not (eof(fil) or keypress) do
BEGIN
readln(fil,line);
writeln(line);
writeln(aux,line);
i := succ(i);
if i mod 20 = 0 then getresp;
END;
END;
close(fil);
if keypress then
BEGIN
writeln(rvson,'>>>>> FILTRANSMISSION AFBRUDT <<<<<',RVSOFF);
writeln(aux,'>>>>> FILTRANSMISSION AFBRUDT <<<<<<');
END ELSE
BEGIN
writeln(rvson,'>>>>> SLUT PÅ FIL ',filn,' <<<<<',rvsoff);
writeln(aux,'>>>>> SLUT PÅ FIL ',filn,' <<<<<');
END;
END;
@13 :BEGIN
writeln;
writeln(aux);
END;
OTHERWISE
begin
write(c);
write(aux,c);
END;
END;
END;
PROCEDURE setrts;
BEGIN
writeln;
writeln(rvson,'>>>>> TRANSMITTING <<<<<',rvsoff);
rx := false;
write('WAIT');
port(.st.) := $15;
port(.st.) := $6A;
delay(100);
FOR i := 0 TO 5 DO write(aux,^B);
write(@8,@8,@8,@8,clreol);
END;
PROCEDURE resrts;
BEGIN
FOR i := 0 TO 5 DO write(aux,^X);
writeln;
IF NOT slut THEN write(rvson,'>>>>> RECIEVING <<<<<',rvsoff,' CLOSED');
tx := false;
delay(10);
port(.st.) := $15;
port(.st.) := $68;
mode := 0;
END;
BEGIN; (* MAIN *)
writeln(clrhom,rvson,' COMMUNICATION PROGRAM ');
WRITELN
(' ^X = TX/RX-TOGGEL, ^Z = TERMINATE PROGRAM ',rvsoff);
slut := false;
REPEAT
resrts;
IF NOT slut THEN REPEAT getaux UNTIL tx OR slut;
IF NOT slut then
begin
setrts;
writeln(aux,'OZ6OH VIBESKRAENTEN 9 PHONE 02 977013 2750 BALLERUP ');
REPEAT getcon UNTIL rx OR slut;
END;
UNTIL slut;
resrts;
writeln;
writeln;
writeln(rvson,'>>>>> COMMUNICATION TERMINATED <<<<<',rvsoff);
(*$I+*)
END.
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 = ' 30.8.84.2030';
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=10000;
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 : 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;
BEGIN;
REPEAT
ok := true;
gotoxy(0,2);
write(clreos,'FILENAVN:');
filn := strinp('',10,2,14);
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);
fill := length(ifil);
writeln(', LÆNGDE = ',fill:4);
writeln;
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;
write('TAST "F" FOR FORTSÆTTELSE, "R" FOR REPETETION:');
REPEAT read(kbd,sv) UNTIL sv IN (.'F','R','f','r'.);
writeln(sv);
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,'TXAA - SENDEPROGRAM, VERSION:',callid,version:13);
writeln ('===============================================');
IF len(parm) > 0 THEN
BEGIN
filn := copy(parm,2,len(parm)-1);
assign(ifil,filn);
(*$I-*)
reset(ifil);
IF iores <> 0 THEN getfil ELSE
BEGIN
fill := length(ifil);
writeln('FILENAVN:',filn,', LÆNGDE = ',fill:1,' SECTOR(ER).');
writeln;
END;
END ELSE getfil;
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 writeln(rvson,'PROGRAMMET AFBRUDT AF OPERTØREN.',rvsoff);
END.
«eof»