⟦abe2b8697⟧

TextFile

job pm 5 600 time 900 area 11 size 90000, 
temp disc 2000 20,
perm disc 100 1
o code
head
claim
mode list.yes
(t1=copy 25.2
i t1)
(t=edit t1
if ok.no
(o c
convert code
finis))
d./-text ****/,d3,
d./:-text ****/
l./-text ****/
s0,f
l1=indent t mark lc
l2=cross l1 bossline.yes
convert l2
clear temp l1
b=set 1 disc
head 1 cpu
(b=pascal80 codelist.yes t
if ok.yes
(head cpu
o c
edit code
if ok.yes
scope user b)
o c
lookup b
convert code
finis)
l b,p-15,l-15,l./end of PASCAL80 compilation/,f
hdlc-text *************************************************\f


process hdlc(var sem:semaphore; reclev:integer);
const
recsize=300;
xmtsize=300;
testmax=31;

type
commandfield=packed record nr:0..7; p:0..1; ns:0..7; i:0..1 end;
framehead   =packed record a: 0..255;  c: commandfield  end;
headbuf     =record first,last,next: integer; fh: framehead end;
headbuf1    =record first,last,next: integer; op: framehead end;
cmdrinf     =packed record cmd,cnt: commandfield; cause: 0..255 end;
pntbuf      =record first,last,next: integer end;
minbuf      =record first,last,next: integer; inf: cmdrinf end;
errortype   = 0..63;
pnttype     =packed record notused:0..8191; p: 0..7 end;
hxtype      =packed record h0,h1,h2,h3: 0..15 end;
dblint      =record h,l: integer end;
modemtype   =packed record f:byte; notused:0..3;
rts,dtr,ci,rate,txe,rxe: 0..1
end;

status      =packed record
         sqd,ffo,ffoi,xmtu,cts,dsr,dcd,ci: boolean;
         error: errortype;
         eom,som: 0..1
       end;

statistics=record
na1,na2,na3: integer;
reci,xmti,skip,retr: dblint;
recrnr,xmtrnr,recrej,xmtrej,timeout,
dsroff,dcdoff,sqdoff,cion: integer;
reccmdr: cmdrinf;
overrun,underrun,recabort: integer
end;

testtype=record
first,last,next: integer;
d:array (0..testmax) of packed record
nt,tt:integer;
at:0..255;
ct:commandfield;
stt:status;
(* extended testoutput ****************
*)
b: 0..4;
r,x: 0..15;
y: 0..2;
m: boolean;
jt: 0..3;
vt,tnt: 0..7;
t0t: 0..127;
snd,sif,ab: boolean;
p0,p1,p2,p3,p4,p5,p6,p7: 0..15;
(**************************************)
end;
end;

flag        =packed array (0..15) of boolean;

const
i0   =commandfield(0,0,0,0);
rr   =commandfield(0,0,0,1);
rnr  =commandfield(0,0,2,1);
rej  =commandfield(0,0,4,1);
ua   =commandfield(3,0,1,1);
dm   =commandfield(0,0,7,1);
sabmp=commandfield(1,1,7,1);
cmdr =commandfield(4,0,3,1);
discp=commandfield(2,1,1,1);

rrframe  =0;
rnrframe =2;
rejframe =4;
iframe   =8;

discframe=2;
sabmframe=1;
uaframe  =3;
cmdrframe=4;
dmframe  =0;
sarmframe=0;

<* address *> dce=1;  dte=3;


causew=1;
causex=3;
causey=4;
causez=8;

message         =7;
timeransw       =1;
recansw         =2;
xmtansw         =3;
conansw         =4;

inputmess       =1;
outputmess      =2;
sensemess       =0;
connectmess     =4;
disconnectmess  =8;
returnallmess   =12;
returnunusedmess=16;
modemmess       =24;
statmess        =28;
statclrmess     =32;
linespeedmess   =36;
eventmess       =40;
testmess        =44;

setfll=12*256;
startrec=16*256+14;
startxmt=17*256+2;
abort=22*256;

<* modemcontrol *>
connectline=modemtype(19,0,0,0,0,0,1,0);

<* xstate *>
xi         =0;
xis        =1;
xua        =2;
xuap       =3;
xspresponse=4;
xspcommand =5;
xdm        =6;
xdmp       =7;
xsabmp     =8;
xcmdr      =9;
xdiscp     =10;

noerror=0;
abst=1;
f=false;
st0=status(f,f,f,f,f,f,f,f,noerror,0,0);
db0=dblint(0,0);
stc0=statistics(0,0,0,db0,db0,db0,db0,
0,0,0,0,0,0,0,0,0,cmdrinf(i0,i0,0),0,0,0);

var
preack,send,sendingiframe,aborting: boolean:=false;
polling,frameok,validinf,ack,poll,auto,nofinalalarm: boolean;
sendok,test,mstate: boolean:=true;
rstate: integer:=10;
bstate,xstate,ystate,t,tn,time,vi,vs:integer:=0;
vr:integer:=-1;
modem: modemtype:=modemtype(19,0,1,1,0,0,0,0);
me:integer:=dce;
you:integer:=dte;
recerr,xmterr: integer:=0;
eventlost: integer:=-1;
xmtlev,k,n2,t1,t2,i,j,l,ovs,ovr,cns,aux:integer;
cnt: integer;
st1,st: status:=status(f,f,f,f,true,true,f,f,noerror,0,0);
stc: statistics:=stc0;
testbit: flag:=flag(16***true);
m,mx,b1,b2,mw,mw1,mc,cmdrbuf,recdev,xmtdev: reference;
op: framehead;
testbuf: testtype;
recshadow,xmtshadow: shadow;
eventqueue,rec,xmt,ique,asem,qs1,testsem,s: semaphore;
headpool: pool 4;
framepool: pool 4 of headbuf;
cmdrpool: pool 1 of minbuf;
priq1: array (-1..8) of semaphore;
priq: array (-1..8) of ^semaphore;
qs,qw: ^semaphore;
cmdrout,cmdrin: cmdrinf;
p: pnttype;
hx: hxtype;

function copychm(var r1,r2: reference): integer; external;
procedure control(w:integer; var dev:reference); external;
procedure controlclr(w:integer; var dev:reference); external;
procedure prepdma(fh,fl:integer; var m,dev: reference); external;
procedure asgnbit=asgnintset(var bit:flag; w:integer); external;
procedure sensefl=sense(var f:flag; w:integer; var dev:reference);
  external;
procedure sensest=sense(var s:status; w:integer; var dev:reference);
  external;
procedure         sense(var c:integer; w:integer; var dev:reference);
  external;
procedure sensept=sense(var p:pnttype; w:integer; var dev:reference);
external;
procedure sensehx=sense(var p:hxtype; w:integer; var dev:reference);
external;
procedure setmodem=control(w:modemtype; var dev:reference); external;
procedure setinterrupt(var ch: reference); external;
function uadd(a,b: integer): integer; external;

function setlength(var m:reference): boolean;
var i: integer;
begin
i:=m^.u2; setlength:=false; pop(mw,m);
for l:=1 to i do begin
while mw^.size=0 do begin
push(mw,mw1); pop(mw,m);
end;
lock mw as d: pntbuf do with d do
if l=j then begin
next:=last+cnt+1; if l=1 then setlength:=next>first else setlength:=true;
end else if l<j then next:=last+1 else next:=first;
end;
push(mw,m);
while not nil(mw1) do begin
pop(mw,mw1); push(mw,m);
end;
end;

procedure setdata(var m:reference);
var fh,fl,i:integer;
begin
i:=0; fl:=4;
pop(mw,m);
repeat
i:=i+1; fh:=4;
while mw^.size=0 do begin
push(mw,mw1); pop(mw,m);
end;
if not nil(m) then if m^.size>0 then fh:=0;
prepdma(fh,fl,mw,recdev);
fl:=14;
until fh>0;
push(mw,m);
while not nil(mw1) do begin
pop(mw,mw1); push(mw,m);
end;
m^.u2:=i;
end;

procedure readframe;
begin
control(startrec,recdev);
prepdma(4,2,m,recdev);
end;

procedure retransmit;
begin
while open(priq(8)^) do begin
wait(mw,priq(8)^); signal(mw,qs^);
end;
qw:=priq(8); priq(8):=qs; qs:=qw;
end;

procedure rejaction;
begin
if vi>0 then begin
vs:=op.c.nr; vi:=0;
if sendingiframe then begin
control(abort,xmtdev); aborting:=true;
end else if open(qs^) then retransmit;
end;
end;

procedure resetaction;
begin ovs:=(vs-vi+8) mod 8; ovr:=vr;
rejaction; vs:=0; vr:=-1; ystate:=0; mstate:=true;
end;

procedure copytest(var m:reference);
begin
lock m as b:testtype do begin
b:=testbuf;
with testbuf do begin next:=first; last:=first end;
with b do if last<testmax then last:=next-1
else if next>testmax then next:=first;
end;
end;

procedure otest(n:integer; a:0..255; c:commandfield);
begin
with testbuf do if next>testmax then
if open(testsem) then begin
wait(mw,testsem); copytest(mw); return(mw);
end else begin last:=testmax; next:=first end;
with testbuf.d(testbuf.next) do begin
nt:=n; at:=a; ct:=c; stt:=st; tt:=time;
(* extended testoutput ************************************************
*)
b:=bstate; r:=rstate; x:=xstate; y:=ystate; m:=mstate; jt:=j;
vt:=vi; tnt:=tn; t0t:=t; snd:=send; sif:=sendingiframe; ab:=aborting;
sensept(p,16*256,recdev); p0:=p.p;
sensept(p,17*256,recdev); p1:=p.p;
sensept(p,18*256,recdev); p2:=p.p;
sensept(p,19*256,recdev); p3:=p.p;
sensept(p,16*256,xmtdev); p4:=p.p;
sensept(p,17*256,xmtdev); p5:=p.p;
sensept(p,18*256,xmtdev); p6:=p.p;
sensept(p,19*256,xmtdev); p7:=p.p;
(***********************************************************************)
end;
with testbuf do next:=next+1;
end;

procedure getresult(var dev:reference);
const
getfl=8*256;  getcnt=24*256;  getadr=0*256;  cntgetpnt=21*256;
var fl:flag;
begin
j:=-1;
repeat
j:=j+1;
sense(cnt,getcnt,dev);
sensest(st,getadr,dev);
if test then if testbit(8) then begin
sensehx(hx,getfl,dev);
otest(7,hx.h1*16+hx.h3,i0);
end;
control(cntgetpnt,dev);
sensefl(fl,getfl,dev);
until (st<>st0) or not fl(13);
while fl(13) do begin
if test then if testbit(8) then begin
sensehx(hx,getfl,dev);
otest(7,hx.h1*16+hx.h3,i0);
end;
control(cntgetpnt,dev);
sensefl(fl,getfl,dev);
end;
end;

procedure event(cause: integer);
begin
if open(eventqueue) then begin
wait(mw,eventqueue);
mw^.u2:=8*cause; mw^.u3:=reclev;
return(mw);
end else if eventlost=-1 then eventlost:=cause else eventlost:=cause+16;
end;

procedure exception(cause: integer);
var r: reference;
begin
trace(cause);
otest(8,cause,discp);
event(15);
repeat
wait(r,sem);
with r^ do
if u2=message then begin
if (u1=testmess) and (u3 mod 2 = 1) then begin
copytest(r); u3:=reclev; u2:=0; return(r);
end else
if (u1=eventmess) and (eventlost<>-1) then begin
signal(r,eventqueue); event(eventlost); eventlost:=-1;
end else begin u2:=3; return(r) end;
end else release(r);
until false;
end;

procedure cmdraction(c,e: integer);
begin
if vr>=0 then resetaction;
t:=1; tn:=0; event(e);
xstate:=xcmdr; rstate:=4; cns:=1;
with cmdrout do begin
cause:=c; cmd:=op.c; cnt.nr:=ovr; cnt.ns:=ovs;
if op.a=you then cnt.p:=1 else cnt.p:=0;
end;
end;
procedure cntmodem;
begin
with stc do begin
if st.sqd and not st1.sqd then sqdoff:=uadd(sqdoff,1);
if st.dsr and not st1.dsr then dsroff:=uadd(dsroff,1);
if st.dcd and not st1.dcd then dcdoff:=uadd(dcdoff,1);
if st.ci  and not st1.ci  then cion:=  uadd(cion  ,1);
st1:=st;
end;
end;

procedure dblcnt(var v: dblint);
begin with v do begin
l:=uadd(l,1); if l=0 then h:=uadd(h,1);
end;
end;

procedure returnque(var q: semaphore; c,lev: integer);
begin
while open(q) do begin
wait(mw,q); mw^.u2:=c; mw^.u3:=lev; return(mw);
end;
end;

procedure returnunused;
begin
for i:=0 to 7 do returnque(priq(i)^,1,xmtlev);
returnque(ique,1,reclev);
returnque(eventqueue,1,reclev);
end;

procedure testaction;
begin
if m^.u3=129 then begin
trace(m^.u4); m^.u3:=reclev; return(m);
end else begin
asgnbit(testbit,m^.u3);
m^.u3:=reclev; m^.u2:=0;
test:=testbit(13);
if testbit(15) then copytest(m);
if testbit(14) then
if testbit(15) then while open(testsem) do begin
return(m); wait(m,testsem); m^.u2:=1;
end else with testbuf do
if last>first then begin
copytest(m); return(m);
end else signal(m,testsem)
else return(m);
end;
end;
\f


process recp(var sem:semaphore);
const
enable=18*256;
startrec=16*256+14;
setfll=12*256;
cntsetpnt=20*256;
var
m,dev:reference;
procedure prepdma(fh,fl:integer; var m,dev:reference); external;
procedure control(w:integer; var dev:reference); external;
procedure controlclr(w:integer; var dev:reference); external;
begin
wait(dev,sem);
channel dev do repeat
wait(m,sem);
case m^.u1 of
0: begin
control(setfll+4,dev); control(cntsetpnt,dev);
control(startrec-14,dev); prepdma(4,2,m,dev);
end;
1: ;
2: control(startrec,dev);
end;
controlclr(enable,dev);
return(m);
until false;
end;

process xmtp(var sem:semaphore);
const enable=18*256;
var m,dev:reference;
procedure controlclr(w:integer; var dev:reference); external;
begin
wait(dev,sem);
channel dev do repeat
wait(m,sem);
controlclr(enable,dev);
return(m);
until false
end;

begin
xmtlev:=reclev+1;
qs:=ref(qs1);

j:=create('rec',recp(rec),recshadow,recsize);
if j<>0 then exception(40+j);
start(recshadow,0);
j:=create('xmt',xmtp(xmt),xmtshadow,xmtsize);
if j<>0 then exception(40+j);
start(xmtshadow,0);
j:=reservech(recdev,reclev,-1);
if j<>0 then exception(50+j);
alloc(m,headpool,s);
j:=copychm(m,recdev); signal(m,rec);
j:=reservech(xmtdev,xmtlev,-1);
if j<>0 then exception(50+j);
alloc(m,headpool,s);
j:=copychm(m,xmtdev); signal(m,xmt);

with testbuf do begin first:=0; last:=0; next:=0 end;

setmodem(modem,xmtdev);
control(0,xmtdev);
control(0,recdev);
control(3*256+0,xmtdev);
control(5*256+0,recdev);
control(7*256+0,recdev);

alloc(mc,framepool,sem);
lock mc as h: headbuf do begin
mc^.u2:=conansw; h.first:=6; h.last:=7;
end;

for i:=-1 to 8 do priq(i):=ref(priq1(i));
alloc(m,headpool,s);
signal(m,priq1(-1));

alloc(mx,framepool,sem);
lock mx as h:headbuf do begin
mx^.u2:=xmtansw; h.first:=6; h.last:=7;
end;

alloc(cmdrbuf,cmdrpool,s);
lock cmdrbuf as h: minbuf do begin
h.first:=6; h.last:=7; h.inf.cnt.i:=0;
end;

for l:=1 to 2 do begin
alloc(m,framepool,sem);
lock m as h: headbuf do begin
m^.u1:=0; m^.u2:=recansw; h.first:=6; h.last:=7;
h.fh.a:=85; m^.u3:=l;
end;
if l=1 then begin prepdma(4,2,m,recdev); m^.u1:=1 end;
signal(m,rec);
end;

alloc(m,headpool,sem);
m^.u2:=timeransw; m^.u3:=100; m^.u4:=0;
sendtimer(m);

repeat
wait(m,sem);
case m^.u2 of
message:
begin
if test then if testbit(11) then
otest(((m^.u3+128) mod 256 - 128)* 256+2,m^.u1,rr);
case m^.u1 of
inputmess:
case bstate of
0:
begin
bstate:=1; b1:=:m;
sensesem(m,rec);
if not nil(m) then begin
setdata(b1); readframe;
m^.u1:=1; signal(m,rec);
end;
end;
1:
begin
bstate:=2; b2:=:m;
sensesem(m,rec);
if not nil(m) then begin
bstate:=3; setdata(b2);
m^.u1:=2; signal(m,rec);
end;
end;
2: signal(m,sem);
3,4:
begin
bstate:=4; signal(m,ique)
end;
end;

outputmess:  signal(m,priq(m^.u3)^);

connectmess:
begin
lock m as h:record
first,last,next:integer;
mode: packed record
na1,na2,na3,na4,na5,na6,
finalalarm,auto:boolean;
end;
id,t1,n2,k:integer
end do begin
l:=h.id; k:=h.k; n2:=h.n2; t2:=h.t1; auto:=h.mode.auto;
nofinalalarm:=not h.mode.finalalarm;
end;
m^.u2:=0; m^.u3:=reclev; return(m);
if rstate>2 then begin
if st.dsr or st.cts then begin
rstate:=11; t1:=l+2; t:=t1-1;
if not nil(mc) then begin
modem:=connectline; setmodem(modem,xmtdev);
prepdma(12,0,mc,xmtdev);
control(startxmt+1,xmtdev);
signal(mc,xmt);
time:=0;
end;
end else begin
xstate:=xsabmp; t:=1;
if l>1 then begin
rstate:=7; t1:=l;
end else begin
rstate:=6; t1:=t2;
if l=0 then begin
me:=dte; you:=dce;
end else begin
me:=dce; you:=dte;
end;
end;
end;
end; <* rstate>2 *>
end; <* connectmess *>

disconnectmess:
begin
case rstate of
0,1,2: begin
polling:=nofinalalarm;
resetaction; rstate:=9; xstate:=xdiscp; event(1);
end;
3,4,6: begin rstate:=9; xstate:=xdiscp; end;
5:     rstate:=10;
7,8,11,12: begin rstate:=10; xstate:=xi; end;
9,10:  ;
end;
m^.u2:=0; m^.u3:=reclev; return(m);
t:=1; tn:=0;
end;

testmess: testaction;

eventmess:
begin
signal(m,eventqueue);
if eventlost<>-1 then begin event(eventlost); eventlost:=-1; end;
end;

statmess,statclrmess:
begin
lock m as d: statistics do d:=stc;
if m^.u1=statclrmess then stc:=stc0;
m^.u2:=0; m^.u3:=reclev; return(m);
end;

sensemess:
with st do begin
if rstate<3 then l:=112 else l:=120;
if dsr then l:=l-16;
if dcd then l:=l-32;
if sqd then l:=l-64;
if ci then l:=l+128;
m^.u2:=l; m^.u3:=reclev; return(m);
end;

returnallmess:
begin
control(0,recdev);
sensesem(mw1,rec);
setinterrupt(recdev);
if send then control(abort,xmtdev);
returnunused;
while not nil(b1) do begin
b1^.u2:=1; b1^.u3:=reclev; return(b1); b1:=:b2;
end;
returnque(priq(8)^,9,xmtlev);
returnque(qs^,9,xmtlev);
b1:=:m;
repeat
wait(m,sem);
case m^.u2 of
message:
if m^.u1=testmess then testaction
else begin
m^.u2:=1;
if m^.u1=outputmess then m^.u3:=xmtlev else m^.u3:=reclev;
return(m);
end;

recansw: begin mw:=:mw1; mw1:=:m end;

xmtansw:
begin
if sendingiframe then begin
mx^.u2:=9; mx^.u3:=xmtlev; return(mx);
end;
mx:=:m; send:=false;
end;

timeransw:
begin
if time=9999 then time:=0 else time:=time+1;
m^.u3:=100; m^.u4:=0; sendtimer(m);
end;

conansw: mc:=:m;
otherwise m^.u2:=4; m^.u3:=reclev; return(m);
end;
until not(send or nil(mw));
b1^.u2:=0; b1^.u3:=reclev; return(b1);
mw^.u1:=1; prepdma(4,2,mw,recdev);
signal(mw,rec);
mw1^.u1:=0; signal(mw1,rec);
rstate:=10;
control(0,xmtdev);
sendingiframe:=false; aborting:=false; sendok:=true;
mstate:=true; bstate:=0; xstate:=0; ystate:=0;
t:=0; tn:=0; vi:=0; vs:=0; vr:=-1;
recerr:=0; xmterr:=0; eventlost:=-1;
preack:=false;
end; <* returnallmess *>

returnunusedmess:
begin
returnunused;
m^.u2:=0; m^.u3:=reclev; return(m);
end;

\f


otherwise m^.u2:=4; return(m);
end;
end; <* message *>

recansw:
begin
getresult(recdev);
frameok:=st.error=noerror; ack:=false; validinf:=false;
if frameok then begin
lock m as h:headbuf do begin op:=h.fh; h.fh.a:=85 end;
if (op.c.i=0) and (op.a=me) and (op.c.ns=vr) and not st.ffo then begin
ack:=setlength(b1); validinf:=true; vr:=(vr+1) mod 8;
end;
end;
if ack then begin
b1^.u2:=0; b1^.u3:=reclev; return(b1); b1:=:b2;
dblcnt(stc.reci);
case bstate of
1: begin bstate:=0; m^.u1:=0; end;
2: begin setdata(b1); readframe; m^.u1:=1; bstate:=1 end;
3: begin prepdma(4,2,m,recdev); m^.u1:=1; bstate:=1 end;
4: begin
wait(b2,ique); if passive(ique) then bstate:=3;
m^.u1:=2; prepdma(4,2,m,recdev); setdata(b2);
end;
end;
end else begin
<* not valid iframe *>
if op.c.ns=3 then if (op.c.i=1) and not st.ffo and frameok then
<* cmdrframe *>
lock b1 as d:minbuf do cmdrin:=d.inf
else cmdrin.cnt.i:=1;

case bstate of
0: m^.u1:=0;
1: begin setdata(b1); readframe; m^.u1:=1 end;
2: begin setdata(b1); readframe; setdata(b2); m^.u1:=2; bstate:=3 end;
3,4: begin b1:=:b2; prepdma(4,2,m,recdev); setdata(b2); m^.u1:=2 end;
end;
end;
aux:=m^.u3;
signal(m,rec);
if st<>st1 then cntmodem;

if test then if testbit(12) then otest(aux*256,op.a,op.c);

if frameok then begin
if((op.a=me) or (op.a=you)) then begin
<* the frameheader is processed *>
if op.c.i=0 then cns:=iframe else cns:=op.c.ns;
if cns mod 2 =0 then begin
<* iframe or sframe *>
if rstate<3 then begin
<* connected state *>
i:=(vs-op.c.nr+8) mod 8;
ack:=i<vi;
while i<vi do begin
vi:=vi-1;
if open(qs^) then begin
wait(mw,qs^); mw^.u2:=0; mw^.u3:=xmtlev; return(mw);
end else preack:=true;
end;
poll:=op.c.p=1;
if i=vi then begin
if tn>0 then begin
if poll then begin
tn:=0; t:=1; rejaction;
if xstate=xspcommand then xstate:=xi;
end;
end else if ack then t:=1;
end else if vi>=0 then cmdraction(causez,10);
if poll then
if (op.a=you) then begin
if not polling then begin
if vr>=0 then resetaction;
xstate:=xsabmp; rstate:=6; cns:=1; t:=1; tn:=0; event(8);
end;
end else begin
xstate:=xspresponse; rstate:=0;
end
else if ack then polling:=nofinalalarm;

case cns of
iframe:
if validinf then begin
rstate:=0; if xstate<=xuap then xstate:=xis;
end else if op.a=me then if not st.ffo then begin
if xstate<=xuap then if rstate=1 then xstate:=xi
else xstate:=xis;
rstate:=1;
end else if j>0 then cmdraction(causey,9);
rrframe:
begin
if rstate=2 then begin rstate:=0; xstate:=xi; tn:=0 end;
ystate:=0;
end;
rnrframe:
begin
if rstate=2 then begin rstate:=0; xstate:=xi; tn:=0 end;
ystate:=1; if vi>1 then rejaction;
stc.recrnr:=uadd(stc.recrnr,1);
end;
rejframe:
begin
if rstate=2 then begin rstate:=0; xstate:=xi; tn:=0 end;
stc.recrej:=uadd(stc.recrej,1); ystate:=0; rejaction;
end;
1: ;
otherwise cmdraction(causew,7);
end;
end else <* disconnected state *>
if rstate<11 then begin
if op.c.p=1 then if rstate=4 then xstate:=xcmdr else begin
xstate:=xdmp; if rstate=6 then rstate:=3;
end;
end;
end else begin
<* uframe *>
if rstate<2 then resetaction;
polling:=nofinalalarm;
if rstate<11 then
if op.a=me then case op.c.nr of
discframe:
begin
if rstate<3 then xstate:=xua else xstate:=xdm;
if op.c.p=1 then xstate:=xstate+1;
if rstate<9 then begin
if rstate<>5 then event(2);
if rstate>6 then t1:=t2; rstate:=5;
end else rstate:=10;
t:=0;
end;
sabmframe:
begin
case rstate of
2,6,7:      begin rstate:=2; xstate:=xua; vr:=0; event(0) end;
0,1,3,4,5,8:begin rstate:=0; xstate:=xua; vr:=0; event(0) end;
9,10:       begin rstate:=10; xstate:=xdm; end;
end;
if op.c.p=1 then xstate:=xstate+1;
tn:=0; t:=0;
end;
sarmframe:
case rstate of
7,8,10: ;
9: if xstate=xi then if op.c.p=1 then xstate:=xdmp else xstate:=xdm;
otherwise cmdraction(causew,7);
end;
otherwise if rstate<3 then cmdraction(causew,7);
end else begin
<* op.a=you *>
case op.c.nr of
dmframe:
begin
if rstate<3 then event(5);
case rstate of
0,1,2,3,4: begin rstate:=6; xstate:=xsabmp; t:=1 end;
5,8,10:    ;
6,7:       if op.c.p=1 then begin rstate:=5; t1:=t2; t:=0 end;
9:         if op.c.p=1 then begin rstate:=10; t:=0 end;
end;
end;
uaframe:
case rstate of
0,1:    begin rstate:=6; xstate:=xsabmp; t:=1; event(4) end;
2:      if op.c.p=1 then begin
rstate:=0; xstate:=xi; vr:=0; t:=0;
end else begin
rstate:=6; xstate:=xsabmp; t:=1; event(4);
end;
3:      begin xstate:=xdm; t:=1 end;
4:      if op.c.p=1 then begin xstate:=xcmdr; t:=1 end;
5,8,10: ;
6,7:
if op.c.p=1 then begin
rstate:=0; xstate:=xi; vr:=0; t1:=t2; t:=0; event(0);
end;
9:      if op.c.p=1 then begin rstate:=10; t:=0 end;
end;
cmdrframe:
begin
if test then begin
otest(5,cmdrin.cause,cmdrin.cnt);
otest(6,cmdrin.cause,cmdrin.cmd);
end;
event(6);
case rstate of
7,8:  ;
9,10: begin rstate:=10; xstate:=xdm; t:=0 end;
otherwise rstate:=6; xstate:=xsabmp; t:=1;
end;
end;
sabmframe:
if rstate=8 then begin
rstate:=2; if op.c.p=1 then xstate:=xuap else xstate:=xua;
i:=me; me:=you; you:=i; vr:=0; t1:=t2; t:=0;
end;
otherwise if rstate<3 then cmdraction(causew,7);
end;
tn:=0;
end
else xstate:=xi;
end; <* uframe *>
end;
recerr:=0;
end else begin
if recerr=n2 then begin
recerr:=0; event(13);
end else recerr:=recerr+1;
with stc do begin
if st.ffo then overrun:=uadd(overrun,1);
if (st.error and abst)<>0 then recabort:=uadd(abort,1);
dblcnt(skip);
end;
end;
end; <* recansw *>

xmtansw:
begin
getresult(xmtdev);
if test then if testbit(12) then
lock m as h:headbuf do otest(1,h.fh.a,h.fh.c);
if st<>st1 then cntmodem;
if aborting then begin
signal(mx,qs^);
retransmit; aborting:=false; sendingiframe:=false;
end else begin
if (st.error=noerror) and not st.xmtu then begin
if sendingiframe then begin
send:=setlength(mx); sendingiframe:=false;
if preack then begin
mx^.u2:=0; mx^.u3:=xmtlev; return(mx); preack:=false;
end else signal(mx,qs^);
end else if nil(cmdrbuf) then cmdrbuf:=:mx;
xmterr:=0;
end else begin
if xmterr=n2 then begin
xmterr:=0; event(14);
end else xmterr:=xmterr+1;
sendok:=false;
with stc do begin
if st.xmtu then underrun:=uadd(underrun,1);
dblcnt(retr);
end;
end;
end;
mx:=:m;
send:=false;
end; <* xmtansw *>

timeransw:
begin
if time=9999 then time:=0 else time:=time+1;
if t>0 then if t>=t1 then begin
case rstate of
0,1:
if (tn>0) or (vi>0) then begin
if tn<=n2 then begin
xstate:=xspcommand; ystate:=2; tn:=tn+1; polling:=true;
stc.timeout:=uadd(stc.timeout,1);
end else begin
resetaction;
event(11);
xstate:=xsabmp; rstate:=6;
end;
t:=1;
end else t:=0;
2,3,6:
begin
if tn<n2 then begin
rstate:=6; xstate:=xsabmp; t:=1; tn:=tn+1;
end else begin
if auto then event(11) else begin
rstate:=10; event(12);
end;
tn:=0;
end;
end;
4:
begin
t:=1;
if tn<n2 then begin
xstate:=xcmdr; tn:=tn+1;
end else begin
event(11);
tn:=0; rstate:=6; xstate:=xsabmp;
end;
end;
5,10: t:=0;
7:    begin rstate:=8; t:=1; end;
8:    begin rstate:=7; xstate:=xsabmp; t:=1 end;
9:    if tn<n2 then begin
xstate:=xdiscp; t:=1; tn:=tn+1;
end else begin
rstate:=10; event(12);
end;
11: begin event(14); t:=0 end;
12: begin
prepdma(12,0,mc,xmtdev);
control(startxmt+1,xmtdev);
signal(mc,xmt);
t:=t1-1; rstate:=11;
end;
end;
end else t:=t+1;
m^.u3:=100; m^.u4:=0; sendtimer(m);
end; <* timeransw *>

conansw:
begin
mc:=:m;
if rstate=11 then begin
getresult(xmtdev);
if st.dsr or st.cts then rstate:=12 else
begin <* modem ready *>
modem.rxe:=1; setmodem(modem,xmtdev);
xstate:=xsabmp; t:=1; time:=0;
if t1>3 then begin
rstate:=7; t1:=t1-2;
end else begin
rstate:=6;
if t1=2 then begin
me:=dte; you:=dce;
end else begin
me:=dce; you:=dte;
end;
t1:=t2;
end;
end; <* modem ready *>
end; <* rstate=11 *>
end; <* conansw *>

otherwise if test then otest(4,m^.u2,rr); m^.u2:=4; return(m);
end;

if not send then begin
lock mx as h:headbuf1 do with h do begin
<* xmt idle *>
send:=true;
if sendok then begin
case xstate of
xi, xis:
if rstate<3 then begin
if (rstate<>1) and ((bstate=0)=mstate) then begin
if mstate then op.c:=rnr else op.c:=rr;
mstate:=not mstate;
end else if (rstate=1) and (xstate=xis) then op.c:=rej else
if (ystate<2) and (vi<k) then begin
i:=8; while passive(priq(i)^) do i:=i-1;
if i>-1 then begin
wait(m,priq(i)^);
op.c:=i0; op.c.ns:=vs; sendingiframe:=true;
vs:=(vs+1) mod 8; vi:=vi+1; if vi=1 then t:=1;
if ystate=1 then ystate:=2;
end else if xstate=xis then
if mstate then op.c:=rr else op.c:=rnr
else send:=false;
end else if xstate=xis then
if mstate then op.c:=rr else op.c:=rnr
else send:=false;
if send then with stc do begin
if op.c=rnr then xmtrnr:=uadd(xmtrnr,1);
if op.c=rej then xmtrej:=uadd(xmtrej,1);
if op.c.i=0 then dblcnt(xmti);
op.c.nr:=vr; op.a:=you;
end;
end else send:=false;
xua,xuap:
begin op.a:=me; op.c:=ua; if xstate=xuap then op.c.p:=1 end;
xspresponse,xspcommand:
begin
if xstate=xspresponse then op.a:=me else op.a:=you;
if rstate=1 then begin
op.c:=rej; stc.xmtrej:=uadd(stc.xmtrej,1);
end else begin
mstate:=bstate<>0;
if mstate then op.c:=rr else begin
op.c:=rnr; stc.xmtrnr:=uadd(stc.xmtrnr,1);
end;
end;
op.c.p:=1; op.c.nr:=vr;
end;
xdm,xdmp:
begin op.c:=dm; op.a:=me; if xstate=xdmp then op.c.p:=1 end;
xsabmp: begin op.c:=sabmp; op.a:=you end;
xcmdr: begin
op.c:=cmdr; op.a:=me; 
lock cmdrbuf as b: minbuf do b.inf:=cmdrout;
m:=:cmdrbuf;
end;
xdiscp: begin op.c:=discp; op.a:=you end;
end;
xstate:=xi;
end else sendok:=true;
if test then if testbit(10) then if send then otest(3,op.a,op.c);
end;
if send then begin
if nil(m) then prepdma(14,0,mx,xmtdev) else begin
prepdma(2,0,mx,xmtdev);
l:=0;
pop(mw,m);
repeat
while mw^.size=0 do begin push(mw,mw1); pop(mw,m) end;
if nil(m) then l:=12 else if m^.size=0 then l:=12;
prepdma(l,6,mw,xmtdev);
until l=12;
push(mw,m);
while not nil(mw1) do begin
pop(mw,mw1); push(mw,m);
end;
end;
control(setfll,xmtdev);
control(startxmt,xmtdev);
signal(mx,xmt); m:=:mx;
end;
end;
until false;
end
.
prepdma-text *********************************************\f


prefix prepdma;
procedure prepdma(fh,fl:integer; var msg,dev:reference);
const
setmsel=14*256;
setflh =13*256;
setfll =12*256;
setcnth=11*256;
setcntl=10*256;
setadrh= 9*256;
setadrl= 8*256;
cntsetpnt=20*256;

type inftype=record
top,cnt:integer;
b0,b1,b2,b3:byte;
end;

wrd=record h,l:byte end;

procedure getbufparam(var inf:inftype; first,last:integer; var m:reference);
external;
procedure control(w:integer; var dev:reference); external;
procedure asgn=asgnintset(var w:wrd; w1:integer); external;

var inf:inftype;  w: wrd;

begin
lock msg as m:record
first,last,next:integer;
end do begin
getbufparam(inf,m.first,m.last,msg);
control(setmsel+inf.b1,dev);
control(setflh+fh,dev);
asgn(w,-inf.cnt);
control(setcnth+w.h,dev);
control(setcntl+w.l,dev);
control(setadrh+inf.b2,dev);
control(setadrl+inf.b3,dev);
control(setfll+fl,dev);
control(cntsetpnt,dev);
end;
end
.
test-text ******************************************************\f


process s(var syst:system_vector);
const
hdlcsize=2000;
datasize=4000;
pri=0;
datapri=-1;
levelq=24;
levelr=26;

testmax=127;
maxevent=10;
opoolsize=10;

process hdlcdata(var op,sem1,sem2:semaphore; reclev1,reclev2:integer);
const
maxans=28;
maxnesting=5;

<****************************************************************>
<*                      hdlcdata                                *>
<*                                                              *>

type
iline=record
first,last,next:integer;
name:alfa;
line:array (18..98) of char;
end;

dbuf=record
first,last,next,no:integer;
txti:char;
inf:array (9..133) of char;
end;

ansbuf=record
f1,f2,f3,f4:byte;
f5:integer;
f6:char;
end;

tx2=array(1..2) of char;
tx5=array(1..5) of char;
ciftype=array('0'..'9') of byte;

oelem= record
t1:char;
t2:tx5;
t3:tx2;
t4,t5:tx5;
t6: char;
end;

oline=record
first,last,next:integer;
name:alfa;
inf:array(1..4) of oelem;
e1,e2,e3,e4,e5: char;
end;

const
cif=ciftype(0,1,2,3,4,5,6,7,8,9);
spelem=oelem(' ','     ','  ','     ','     ',',');

var
r,m,comi,como: reference;
asem,qs,opa:semaphore;
c1,c:char:=nl;
v,i,j,xmtlev1,xmtlev2:integer;
l: integer:=0;
cnt: integer:=0;
dpool:pool 26 of dbuf;
tab: array (18..98) of integer;
s: array('n'..'r') of ^semaphore;
sl: array(8..127) of char;
err,esc: boolean;
ans: array(1..maxans) of ansbuf;
ipool:pool 2 of iline;
opool:pool 1 of oline;
data: array('a'..'z') of dbuf;
x: integer:=0;
a: array(1..maxnesting) of integer;

procedure out5(var t:tx5; v:integer);
var i:integer;
begin
for i:=5 downto 1 do if v>0 then begin
t(i):=chr(v mod 10 + 48);  v:=v div 10;
end else if i=5 then t(i):='0' else t(i):=sp;
end;

procedure listq;
var i,l: integer;
begin
l:=1;
while l<j do begin
i:=1;  wait(como,opa);
lock como as d:oline do
repeat
if l<j then with d.inf(i) do
begin
with ans(l) do begin
t1:=sl(f3); out5(t2,f5);
t3(2):=f6;
out5(t4,f4); out5(t5,f2);
end;
l:=l+1;
end else d.inf(i):=spelem;
i:=i+1;
until i>4;
como^.u2:=7; signal(como,op);
end;
j:=1;
end;

begin
trace(0);
for i:=1 to 2 do begin
alloc(r,ipool,asem);
r^.u1:=1; r^.u4:=0;
lock r as d:iline do with d do begin
first:=18; last:=97;
name:='data'
end;
r:=:comi;
end;

alloc(como,opool,opa);
como^.u1:=2;
lock como as d:oline do with d do begin
first:=18; last:=first+76;
name:='data';
for i:=1 to 4 do d.inf(i):=spelem;
e1:=nl;
end;
return(como);

cnt:=0;  j:=1;
xmtlev1:=reclev1+1;
xmtlev2:=reclev2+1;

for i:=8 to 127 do sl(i):='n';
sl(xmtlev1):='o';
sl(xmtlev2):='p';
sl(reclev1):='q';
sl(reclev2):='r';

s('n'):=ref(asem);
s('o'):=ref(sem1);
s('p'):=ref(sem2);
s('q'):=ref(sem1);
s('r'):=ref(sem2);

for c:='a' to 'z' do with data(c) do begin
first:=6; last:=first+20;
txti:=c; inf:='  buffer'; inf(10):=c;
end;

r^.u2:=7; signal(r,op); wait(r,asem);
repeat
esc:=false; err:=false;  if cnt>9999 then cnt:=0;
comi^.u2:=7; signal(comi,op);
r:=:comi;
lock comi as lbuf:iline do with lbuf do begin
if comi^.u2<>0 then next:=first;
i:=first; x:=0;
line(next):=nl;
repeat
c:=line(i); if nil(m) then alloc(m,dpool,asem);
with m^ do begin
u2:=7; u4:=i;
case c of
'o','p':
begin
lock m as d:dbuf do begin
u1:=2; u3:=cif(line(i+1));
d:=data(line(i+2));
tab(i):=cnt;  d.no:=cnt;  i:=i+2;  cnt:=cnt+1;
end;
signal(m,qs);
end;
'q','r':
begin
lock m as d:dbuf do d:=data('z');
u1:=1; signal(m,qs);
end;
'w','x',nl:
begin
while open(qs) do begin
wait(r,qs); signal(r,s(line(r^.u4))^);
end;
if c=nl then begin
c:=c1;
end else begin
c1:=c; l:=cif(line(i+1));
end;
repeat
wait(r,asem);
if r^.u4=0 then esc:=true else
with r^ do with ans(j) do begin
f1:=u1; f2:=u2; f3:=u3; f4:=u4;
if u1=1 then begin
lock r as d:dbuf do with d do begin
f5:=no; f6:=txti;
end;
if c='x' then begin u2:=7; signal(r,s(sl(u3))^) end 
else release(r);
end else begin
f5:=tab(u4); f6:='*'; release(r);
end;
l:=l-1; j:=j+1;
if j>maxans then listq;
end;
until (l=0) or esc;
i:=i+1;
end;
'l': listq;
'(': begin
if x<maxnesting then x:=x+1 else for v:=2 to maxnesting do a(v-1):=a(v);
a(x):=i;
end;
')': if x>0 then begin
if (line(i+1)>'1') and (line(i+1)<='9') then begin
line(i+1):=pred(line(i+1));  i:=a(x);
end else begin
if line(i+1)='1' then i:=i+1;
x:=x-1;
end;
end else if (line(i+1)>'0') and (line(i+1)<='9') then i:=i+1;
'c','d':
with data(line(i+1)) do begin
if c='d' then last:=8;
c:=line(i+2); i:=i+3;
while (line(i)<>c) and (line(i-1)<>nl) do begin
last:=last+1; inf(last):=line(i); i:=i+1;
end;
if line(i-1)=nl then i:=i-1;
end;
sp: ;
otherwise
repeat if not nil(m) then release(m); sensesem(m,qs) until passive(qs);
comi^.u1:=2; line:='error in datacommand'; line(last):=nl;
err:=true;
end;
end;
if c<>nl then i:=i+1;
until esc or err;
listq;
end;
if err then begin
comi^.u2:=7; signal(comi,op); wait(comi,asem); wait(r,asem);
if r^.u1=1 then comi^.u1:=1 else begin r^.u1:=1; r:=:comi end;
end;
until false;
end;

<*                                                      *>
<*                      end hdlcdata                    *>
<********************************************************>
\f


<*process s(var syst: system_vector);*>

type
contype=record
xxx1,xxx2,xxx3:integer;
auto: boolean;
inf: array (2..5) of integer;
end;

telem=packed record
aux,kind: byte;
t:integer;
a:byte;
nr:0..7;
p:bit;
ns:0..7;
i:bit;
s:packed array(0..3) of 0..15;
(* extended testoutput *********************************************
*)
b         : 0..4;
r,x       : 0..15;
y         : 0..2;
m         : bit;
jt        : 0..3;
vt,tnt    : 0..7;
t0t       : 0..127;
snd,sif,ab: bit;
p0,p1,p2,p3,p4,p5,p6,p7: 0..15;
(********************************************************************)
end;

testtype=record
first,last,next:integer;
d:array (0..testmax) of telem;
end;

txt=array (18..98) of char;
digtype=array (0..15) of char;
ciftype=array ('0'..'9') of byte;

cline=record
f,l,n:integer;
name:alfa;
d:txt;
end;

modetype=packed record
t6,t5,t4,t3,t2,t1: bit;
func:0..3;
end;

modetab=array ('q'..'r') of modetype;

const
dig=digtype('0','1','2','3','4','5','6','7','8','9','A','B','C','D',
'E','F');
bool=digtype('.','I',14***'E');
cif=ciftype(0,1,2,3,4,5,6,7,8,9);
testoff=modetype(0,0,0,0,0,0,0);
teston=modetype(1,1,1,1,1,1,0);
head=modetype(1,0,0,0,0,0,0);

var
mode,state: modetab:=modetab(2***teston);
ln:array (8..127) of char;
c,c1,c2: char;
m,r,con,out:reference;
lc,v,i,n:integer:=0;
nc: integer:=10;
etop,ecnt: array('q'..'r') of integer;
era,oque,cona,opool,a,outa:semaphore;
sem:array('q'..'r') of semaphore;
op:^semaphore;
cpool:pool 3 of cline;
conpool:pool 1 of contype;
opool1:pool opoolsize of testtype;
hpool: pool maxevent;
hdlcq,hdlcr,data: shadow;
b,err,finis,empty: boolean:=false;
print: boolean :=true;
levq: integer:=levelq;
levr: integer:=levelr;
w: modetype;

procedure setmode=stvsb0(var r:byte; var s:modetype); external;
process hdlc(var sem:semaphore; reclev:integer); external;

procedure outi(var d:txt; var l:integer; t,n:integer);
var i:integer;
begin
for i:=n downto 1 do
if t>0 then begin d(l+i):=dig(t mod 10); t:=t div 10; end
else if i=n then d(l+n):='0' ;
l:=l+n;
end;

procedure testo(e:telem);
begin
wait(out,outa);
lock out as line:cline do with line do with e do begin
d:='  ';
l:=f-1; outi(d,l,t,4);
d(l+2):=c; d(l+3):=dig(kind);
case kind of
0:l:=f+24; 1:l:=f+18; 2:l:=f+6; 3:l:=f+12; otherwise l:=f+7 end;
case kind of
0,1,3,6: begin
outi(d,l,a,3);
d(l+2):=dig(nr); d(l+3):=dig(p); d(l+4):=dig(ns); d(l+5):=dig(i);
end;
2,4,8: outi(d,l,a,3);
5: if i=0 then begin
d(l+5):=dig(nr); d(l+6):=dig(p); d(l+7):=dig(ns);
end else d(l+5):='?';
7: begin d(l+5):=dig(a div 16); d(l+6):=dig(a mod 16) end;
end;
l:=f+34;
for v:=0 to 3 do d(l+v):=dig(s(v));
(* extended testoutput ***********************************************
*)
l:=l+4; outi(d,l,aux,3);
d(l+2):=dig(b); l:=l+3; outi(d,l,r,2); outi(d,l,x,3);
d(l+2):=dig(y); d(l+3):=bool(m); d(l+4):=dig(jt); d(l+5):=dig(vt);
d(l+7):=dig(tnt); l:=l+8; outi(d,l,t0t,3);
d(l+2):=bool(snd); d(l+3):=bool(sif); d(l+4):=bool(ab);
d(l+6):=dig(p0); d(l+7):=dig(p1); d(l+8):=dig(p2); d(l+9):=dig(p3);
d(l+11):=dig(p4); d(l+12):=dig(p5); d(l+13):=dig(p6); d(l+14):=dig(p7);
l:=l+11;
(***********************************************************************)
l:=l+4; d(l):=nl;
end;
signal(out,op^);
end;

procedure list;
begin
if open(oque) or not nil(r) then
repeat
if nil(r) then begin
wait(r,oque); wait(out,outa);
lock out as line: cline do with line do begin
d:=
' time            send   xmt   rec status    b  r  x ymji n   t sia';
d(f):=nl; l:=f+67; d(l):=nl;
end;
signal(out,op^);
lc:=lc-1;
end;
if lc>0 then begin
c:=ln(r^.u3);
lock r as td:testtype do with td do begin
i:=r^.u4;
if i>=next then begin
while (lc>0) and (i<=last) do begin
if i=next then begin
wait(out,outa);
lock out as line: cline do with line do begin
d:='           mod     testoutputlines lost';
d(f+5):=c; l:=f+6; outi(d,l,next,3);
l:=f+14; outi(d,l,testmax+1,3); l:=f+39; d(l):=nl;
end;
signal(out,op^);
lc:=lc-1;
end;
testo(d(i));  i:=i+1; lc:=lc-1;
end;
if i>last then i:=first;
end;
while (lc>0) and (i<next) do begin
testo(d(i));  i:=i+1; lc:=lc-1;
end;
r^.u4:=i; empty:=(i=next);
end;
if empty then signal(r,opool);
end;
until (lc<=0) or (passive(oque) and nil(r));
end;

<***********************************************************>
<*               hdlctest                                  *>
<*               initialize                                *>

begin
op:=syst(operatorsem);
i:=link('hdlc',hdlc);  if i<>0 then exception(40+i);

alloc(m,cpool,a);
lock m as h:cline do begin
m^.u1:=1; h.f:=18; h.l:=97; h.name:='test';
end;
signal(m,op^);

alloc(m,cpool,outa);
lock m as h:cline do begin
m^.u1:=2; h.f:=18; h.l:=18; h.name:='test';
end;
return(m);

alloc(m,cpool,era);
lock m as h:cline do begin
m^.u1:=2; h.f:=18; h.l:=34; h.name:='test'; h.d:='***command error';
h.d(34):=nl;
end;
return(m);

etop('q'):=0; etop('r'):=0;

repeat
repeat
wait(out,outa);
lock out as line: cline do with line do begin
d:='levelq=   ; levelr=';
l:=f+6;  outi(d,l,levq,3);
l:=f+18; outi(d,l,levr,3);
l:=l+1; d(l):=nl;
end;
signal(out,op^);

repeat
wait(m,a); if (m^.u1<>1) or (m^.u2=7) then release(m);
until not nil(m);
b:=true;
with m^ do if (u2=0) and (u1=1) then
lock m as l: cline do with l do begin
d(n):=nl;
repeat
c:=d(f); v:=0; f:=f+1;
if c<>nl then begin
b:=false;
while (d(f)>='0') and (d(f)<='9') do
if v<13 then begin
v:=v*10+cif(d(f)); f:=f+1;
end else c:=nl;
end;
if v<128 then case c of
'q': levq:=v;
'r': levr:=v;
otherwise
end;
until c=nl;
f:=18;
end;
signal(m,op^);
until b;

trace(0);

if openpool(conpool) then alloc(con,conpool,cona);

while openpool(opool1) do begin
alloc(m,opool1,a); m^.u1:=44;  signal(m,opool);
end;

ln(levq):='q'; ln(levq+1):='q';
ln(levr):='r'; ln(levr+1):='r';

i:=create('hdlcq',hdlc(sem('q'),levq),hdlcq,hdlcsize);
if i<>0 then exception(50+i);

i:=create('hdlcr',hdlc(sem('r'),levr),hdlcr,hdlcsize);
if i<>0 then exception(50+i);

start(hdlcq,pri); start(hdlcr,pri);

i:=create('data',hdlcdata(a,sem('q'),sem('r'),levq,levr),data,datasize);
if i<>0 then exception(50+i);
start(data,datapri);

ecnt('q'):=0; ecnt('r'):=0;

repeat
if print then
while (lc<=0) and passive(a) do begin lc:=nc; list end;
wait(m,a);
if m^.u2=7 then signal(m,op^) else
if m^.u1=1 then begin <* console command *>
if m^.u2=0 then begin
lock m as l:cline do with l do begin
d(n):=nl;
case d(f) of
't','m': begin <* set testmode *>
c1:=d(f+1);
if (c1='q') or (c1='r') then begin
i:=f+2; c2:=c1;
end else begin
i:=f+1; c1:='q'; c2:='r';
end;
if (d(i)<'0') or (d(i)>'3') then err:=true
else with w do begin
w:=testoff; func:=cif(d(i));
if d(f)='m' then begin
b:=false;
repeat
i:=i+1;
case d(i) of
'1','e':      ; '2','a': t2:=1; '3','m': t3:=1;
'4','s': t4:=1; '5'    : t5:=1; '6','f': t6:=1;
otherwise b:=true;
end;
if not b then t1:=1;
until b;
for c:=c1 to c2 do mode(c):=w;
end else for c:=c1 to c2 do mode(c).func:=func;
end;
end;
'h': mode:=modetab(2***head);
'l','p': begin <* list testoutput *>
print:=d(f)='p'; i:=f+1; lc:=0;
while (d(i)>='0') and (d(i)<='9') do begin
lc:=lc*10+cif(d(i)); i:=i+1;
if lc>3000 then d(i):=nl;
end;
if lc>3000 then err:=true else
if print then begin if lc>0 then nc:=lc end;
list;
end;
'a','c': begin <* connect *>
c:=d(f+1);  f:=f+2;
lock con as b:contype do with b do begin
if d(f-2)='c' then auto:=false else auto:=true;
for i:=2 to 5 do begin
while ((d(f)<'0') or (d(f)>'9')) and (d(f)<>nl) do f:=f+1;
inf(i):=0;
while (d(f)>='0') and (d(f)<='9') do
if inf(i)>3000 then c:='a' else begin
inf(i):=inf(i)*10+cif(d(f));  f:=f+1;
end;
end;
end;
con^.u1:=4;  con^.u2:=7;
if (c='q') or (c='r') then begin
signal(con,sem(c));
wait(con,cona);
end else err:=true;
end;
'd': begin <* disconnect *>
con^.u1:=8;  con^.u2:=7;
if (d(f+1)='q') or (d(f+1)='r') then begin
signal(con,sem(d(f+1)));
wait(con,cona);
end else err:=true;
end;
'e': begin
c:=d(f+1);
if ((c='q') or (c='r')) and (d(f+2)>='0') and (d(f+2)<='9') then begin
etop(c):=cif(d(f+2));
while openpool(hpool) and (etop(c)>ecnt(c)) do begin
alloc(out,hpool,a);
out^.u1:=40; out^.u2:=7; signal(out,sem(c));
ecnt(c):=ecnt(c)+1;
end;
end else err:=true;
end;
'f': finis:=(d(f+1)='i') and (d(f+2)='n');
nl : ;
otherwise
err:=true;
end;
f:=18;
end;
end;
signal(m,op^)
end else with m^ do
if u1=40 then begin <* event answer *>
if u2 mod 8=0 then begin
wait(out,outa);
lock out as line: cline do with line do begin
c:=ln(u3); d:='event'; l:=f+8; d(f+6):=c; outi(d,l,m^.u2 div 8,2);
l:=l+1; d(l):=nl;
end;
signal(out,op^);
if m^.u2>=8 then mode(c).func:=1;
if m^.u2=15 then etop(c):=0;
if etop(c)<ecnt(c) then begin ecnt(c):=ecnt(c)-1; release(m) end else 
begin u2:=7; signal(m,sem(c)) end;
end else release(m);
end else begin <* testoutput answ *>
if (u2=0) and (u4 <> 0) then begin
if (u4=2) and print then mode(ln(u3)).func:=2;
lock m as td:testtype do u4:=td.next;
signal(m,oque);
if print then begin lc:=nc; list end;
end else signal(m,opool);
end;
if err then begin
err:=false; wait(m,era); signal(m,op^);
end else
for c:='q' to 'r' do if mode(c)<>state(c) then
if open(opool) then begin
wait(m,opool);
setmode(m^.u3,mode(c)); m^.u4:=mode(c).func;  m^.u2:=7;
signal(m,sem(c));
mode(c).func:=0;  state(c):=mode(c);
end;
until finis;
stop(hdlcq); stop(hdlcr); stop(data);
remove(hdlcq); remove(hdlcr); remove(data);
finis:=false;
until false;
end
.
end-of-text *******************************************************
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦abe2b8697⟧ TextFile

Derivation

TextFile
