|
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: 9856 (0x2680)
Types: TextFile
Names: »RXAA.PAS«
└─⟦692ac107c⟧ Bits:30005923 PolyPascal-80 V3.10 arbejdsdiskette 1
└─⟦this⟧ »RXAA.PAS«
PROGRAM rxaa; (*$I-*)
CONST
callid = 'OZ6OH';
status = 1; (* SIO-PORTENS STATUS-PORT *)
data = 0; (* SIO-PORTENS DATA-PORT *)
rdy = 1; (* RECIEVE RDY-FLAG *)
delfac = 600; (* DELAY FACTOR *)
VAR
abort : boolean;
PROCEDURE rtson;
begin
port(.status.) := $15;
port(.status.) := $6A;
end;
PROCEDURE rtsoff;
begin
port(.status.) := $15;
port(.status.) := $68;
end;
FUNCTION getch : char;
FUNCTION ipa : boolean;
VAR c : char;
BEGIN
IF keypress THEN
BEGIN
read(kbd,c);
abort := (c='Q') or (c='q');
END;
ipa := port(.status.) AND rdy=rdy;
END;
BEGIN; (*getch*)
REPEAT UNTIL ipa OR abort;
IF ipa THEN getch := chr(port(.data.));
END;
CONST
version = '29.8.84.2020';
atx = @0; (* KOMMER FØR LÆNGDEN I TEKST FELTET I HEX-RECORD *)
soh = @1; (* KOMMER FØR NAVNE-HEADER *)
stx = @2; (* KOMMER FØR LÆNGDEN I TEKST FELTET I ASCII-RECORD*)
etx = @3; (* AFSLUTTER TEKSTFELTET *)
eot = @4; (* AFSLUTTER TRANSMISSIONEN *)
syn = @5; (* INDLEDER HVER TRANSMISSION *)
ack = @6; (* INDLEDER RESPONSE *)
nak = @7; (* SENDES HVIS RESPONSE MANGLER *)
dle = @8; (* KOMMER FØR STX ELLER ATX ELLER ETX *)
cr = @13;
LABEL
afslut,exit;
TYPE
rec = ARRAY(.0..127.) OF byte;
rbuf = ARRAY(.0..255.) OF char;
VAR
ackmsg : STRING(.50.);
i_s : STRING(.6.);
dr : STRING(.4.);
ofil : FILE;
rbuffer : ARRAY(.0..7.) OF rbuf;
fbuffer : ARRAY(.0..7.) OF rec;
asci : ARRAY(.0..7.) OF boolean;
i,j,m,t : integer;
flt : STRING(.4.);
sv,ch : char;
mflag,mode : integer;
slut,altok : boolean;
ok,modt : ARRAY(.0..7.) OF boolean;
lgt,sum : ARRAY(.0..7.) OF integer;
filn : STRING(.14.);
max : integer;
PROCEDURE resrts;
VAR n,j : integer;
BEGIN;
FOR n := 0 TO 10 DO FOR j := 0 TO delfac DO BEGIN END;
rtsoff;
END;
PROCEDURE delay(i : integer);
VAR n,j : integer;
BEGIN
write('WAIT');
FOR n := 0 TO i DO FOR j := 0 TO delfac DO BEGIN END;
write(@8,@8,@8,@8);
END;
PROCEDURE setrts;
BEGIN;
rtson;
delay(100);
END;
PROCEDURE getflt;
LABEL exit;
var
i : integer;
BEGIN;
FOR i := 1 TO 4 DO
BEGIN;
flt(.i.) := getch;
IF abort THEN GOTO exit;
END;
flt(.0.) := @4;
exit:
END;
PROCEDURE retnavn;
VAR
ok : boolean;
fil : FILE;
fn : STRING(.14.);
BEGIN;
ok := true;
close(ofil);
REPEAT (* FIND ET FILNAVN SOM IKKE FINDES PÅ DRIVE DR *)
IF filn(.2.) = ':' THEN filn := copy(filn,3,len(filn)-2);
assign (fil,dr+filn);
reset(fil);
ok := iores = 0;
IF ok THEN
BEGIN;
fn := '';
writeln(dr+filn,' FINDES I FORVEJEN,');
writeln;
writeln('TAST <RETURN> FOR OVERSKRIVNING AF GL. FILE - ');
write ('ELLER INDTAST NYT FILE-NAVN:');
readln(fn);
IF len(fn) = 0 THEN
BEGIN
close(fil);
erase(fil);
END ELSE filn := fn;
END;
UNTIL NOT ok; (* FILNAVN OG DRIVE FUNDET *)
assign(ofil,dr+'RXA.$$$');
rename(ofil,filn);
writeln('SLUT PÅ MODTAGELSE AF FILE ',dr+filn);
END;
PROCEDURE getfiln;
VAR
ok : boolean;
BEGIN;
ok := true;
bdos(45,255); (* set error status (only CP/M 3) *)
dr := '';
REPEAT
writeln('VENT! - DISKEN AFPRØVES FOR PLADS M.M.');
assign(ofil,dr+'RXA.$$$');
rewrite(ofil);
IF iores > 0 THEN ok := false ELSE ok := true;
i := 0;
WHILE (ok AND (i < max)) DO
BEGIN
blockwrite(ofil,fbuffer,1);
IF iores > 0 THEN ok := false;
i := succ(i);
END;
IF ok THEN close(ofil);
IF iores > 0 THEN ok := false;
assign(ofil,dr+'RXA.$$$');
IF ok THEN rewrite(ofil);
IF iores > 0 THEN ok := false;
IF NOT ok THEN
BEGIN
writeln('-> DISKPROBLEMER ELLER PLADSPROBLEMER PÅ DISKEN');
writeln('-> SKIFT DISK OG TAST <RETURN> ELLER ANGIV ANDEN DRIVE:');
readln(trm,dr);
END;
UNTIL ok;
writeln('KLAR TIL MODTAGNING AF FILE ',filn,' PÅ ',max:1,' SECTOR(ER).');
bdos(45,0);
END;
PROCEDURE txresponse;
BEGIN
setrts;
FOR i := 0 TO 3 DO write(aux,syn);
write(aux,ack);
writeln(aux,ackmsg);
writeln('OK ');
FOR i := 0 TO 3 DO write(aux,etx);
resrts;
END;
PROCEDURE rxbuf;
LABEL exit;
BEGIN;
slut := false;
mode := 0;
WHILE NOT slut DO
BEGIN;
ch := getch;
IF abort THEN GOTO exit;
CASE mode OF
0 : CASE ch OF
syn : mode := 1;
END;
1 : CASE ch OF
syn : BEGIN END;
dle : mode := 2;
eot : slut := true;
nak : slut := true;
END;
2 : CASE ch OF
syn : BEGIN END;
stx : BEGIN;
getflt;
IF abort THEN GOTO exit;
val(flt,i,j);
write(i:8,'X');
IF j > 0 THEN mode := 1
ELSE
IF i - (i MOD 8) <> m THEN mode := 1
ELSE
BEGIN;
i := i MOD 8;
asci(.i.) := false;
modt(.i.) := true;
mode := 3;
END;
END;
atx : BEGIN;
getflt;
IF abort THEN GOTO exit;
val(flt,i,j);
write(i:8,'A');
IF j > 0 THEN mode := 1
ELSE
IF i - (i MOD 8) <> m THEN mode := 1
ELSE
BEGIN;
i := i MOD 8;
asci(.i.) := true;
modt(.i.) := true;
mode := 3;
END;
END;
soh : BEGIN;
getflt;
IF abort THEN GOTO exit;
val(flt,max,t);
IF t > 0 THEN
BEGIN
mode := 0;
END ELSE
BEGIN
filn := '';
mode := 10;
END;
END;
eot : slut := true;
OTHERWISE mode := 1;
END;
3 : CASE ch OF
syn : BEGIN END;
dle : mode := 4;
eot : slut := true;
OTHERWISE IF j < 256 THEN
BEGIN;
rbuffer(.i.)(.j.) := ch;
j := succ(j);
END ELSE mode := 1;
END;
4 : CASE ch OF
syn : BEGIN END;
etx : BEGIN;
getflt;
IF abort THEN GOTO exit;
val(flt,sum(.i.),t);
IF t > 0 THEN sum(.i.) := 0;
lgt(.i.) := j;
mode := 1;
END;
eot : slut := true;
OTHERWISE mode := 1;
END;
10 : CASE ch OF
dle : BEGIN;
getfiln;
mode := 11;
END;
eot : slut := true;
OTHERWISE
BEGIN;
filn(.0.) := succ(filn(.0.));
filn(.byte(filn(.0.)).) := ch;
END;
END;
11 : CASE ch OF
etx : mode := 1;
syn : mode := 1;
eot : slut := true;
END;
END;
END;
exit:
END;
PROCEDURE convert;
VAR
flt : STRING(.4.);
ss,p,x : integer;
BEGIN;
ok(.i.) := true;
IF asci(.i.) THEN
FOR j := 0 TO 127 DO
BEGIN
x := byte(rbuffer(.i.)(.j.));
IF (x < $09) OR (x > $7F) THEN ok(.i.) := false;
fbuffer(.i.)(.j.) := x;
END ELSE
FOR j := 0 TO 255 DO
IF j MOD 2 = 0 THEN flt := '$'+rbuffer(.i.)(.j.)
ELSE
BEGIN;
flt := flt+rbuffer(.i.)(.j.);
val(flt,x,p);
IF p > 0 THEN ok(.i.) := false ELSE
fbuffer(.i.)(.j SHR 1.) := x;
END;
ss := sum(.i.);
FOR j := 0 TO 127 DO ss := ss - fbuffer(.i.)(.j.);
ss := (ss - m - i) MOD 10000;
IF ss <> 0 THEN ok(.i.) := false;
END;
(* üüü üüü MAIN PROGRAM üüü üüü *)
BEGIN;
write(clrhom);
write ('PROGRAM RXAA - MODTAGER PROGRAM VERSION:');
writeln (rvson,callid,version:13,rvsoff);
writeln ('==========================================================');
writeln ('VENTER PÅ MODT. TAST "Q" FOR AFBRYDELSE.');
abort := false;
m := 0;
REPEAT;
FOR i := 0 TO 7 DO
begin
ok(.i.) := false;
lgt(.i.) := 0;
modt(.i.) := false;
sum(.i.) := 0;
end;
REPEAT;
rxbuf;
IF abort THEN GOTO exit;
altok := true;
mflag := 0;
write(cr,clreol);
ackmsg := '';
FOR i := 0 TO 7 DO
BEGIN;
IF (i+m < max) THEN
BEGIN;
str(i+m,i_s);
IF NOT ok(.i.) THEN IF ((lgt(.i.) = 256) AND (NOT asci(.i.))
OR (lgt(.i.) = 128) AND (asci(.i.)))
THEN convert;
IF NOT modt(.i.) THEN
BEGIN;
altok := false;
mflag := 1;
ackmsg := ackmsg+i_s+' ';
END ELSE
IF NOT (modt(.i.) AND ok(.i.)) THEN
BEGIN;
altok := false;
ackmsg := ackmsg+i_s+' ';
END;
END ELSE mflag := 1;
IF modt(.i.) AND (mflag = 1) THEN altok := false;
END;
IF NOT altok THEN txresponse;
UNTIL altok;
m := m+8;
IF m = max THEN mflag := 1;
FOR i := 0 TO 7 DO IF ok(.i.) THEN blockwrite(ofil,fbuffer(.i.),1);
ackmsg := 'OK';
txresponse;
UNTIL mflag = 1;
retnavn;
GOTO afslut;
exit:
writeln;
writeln(rvson,'AFBRUDT AF OPERATØREN.',rvsoff);
afslut:
(*$I+*)
END.
«eof»