|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 23040 (0x5a00)
Types: TextFile
Names: »hlvlam1«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »hlvlam1«
process lamdriver(var lamsem: semaphore;
lamlevel: integer);
(*
x.21 lam-driver and scanner for centernet.
vers: 810408 hlv
*)
const
revision= 100;
scanner_size= 200; (* size in bytes of scanner process, *)
(* to be optimized later *)
init_linespec=
line_status_type(?,
0, (* 110 bps *)
3, (* 8 bits *)
true, (* 2 stop bits *)
3, (* no parity *)
true,false,false,
true,true,true,
false,false);
(* special characters *)
brk= -1; (* conversion value for rec. break *)
sub= 26; (* conversion value for pty errors *)
xon= 17;
xoff=19;
(* internal error codes *)
init1= 100; (* lamlevel not reservable *)
init2= init1+1; (* copychm error *)
init3= init2+1; (* create scanner troubles *)
internal1= 110; (* xsem = nill and xmode = output_finis *)
internal2= 111; (* xsem = nill and xmode = output or output_finis
and output timeout *)
\f
var
(* message pools *)
scanpool: pool scanpoolsize;
timerpool: pool 1;
(* line descriptors *)
line: linearraytype;
lineref: array (firstline..lastline) of linereftype;
lam, r, rw: reference;
scansem: semaphore; (* scanner event pool *)
scansh: shadow;
curline: integer;
lamout: lamouttype;
lamcontrol: line_status_type;
lamin: lamintype;
lam_stat: lamstattype;
datain: cycinputtype;
spec_index,
convchar: integer;
i, (* local work of any kind *)
cmode, (* conversion mode *)
c, (* conversion lineno *)
s: integer; (* local var for dyn. array dimension *)
\f
process scanner(var eventsem: semaphore;
var line: linearraytype);
(*
scanner process
executes on lam interrupt level and simulates intelligent dma.
*)
const
chlost= stat_ovrun+stat_err;
startscanner= -1;
var
lamin: lamintype;
lamout: lamouttype;
lam_stat: lamstattype;
i,l: integer;
r,lam: reference;
schedule: boolean;
\f
begin (* scanner main program *)
(* get channel message from main driver *)
wait(lam,eventsem);
channel lam do
repeat (* scanner main loop: flying high forever *)
schedule:= false;
(* wait for work to do *)
controlclr(startscanner,lam);
inword(lamin,lam);
if lamin.line <= lastline then
with line(lamin.line) do
begin
if lamin.input then
begin
sense(lam_stat,lamin,lam);
if (rmode <> idle) and
(cycfirst = cyclast)
then schedule:= true;
i:= (cyclast+1) mod cyctop;
if i <> cycfirst then
with cycbuf(i) do
begin (* deposit data in input buffer *)
char:= lamin.char;
stat:= lam_stat.stat;
cyclast:= i;
end (* depose value *)
else
begin (* input buffer overflow *)
rstat:= rstat or chlost;
schedule:= true;
end; (* input buffer overflow *)
end (* input *)
\f
else (* output *)
case xmode of
xidle,output_finis: ; (* no action *)
output: begin (* output next char *)
sensesem(r,xsem);
if not nil(r) then
begin
i:= r^.size;
lock r as ob: packed record
first, last, next: integer;
buf: array (6..i-1+i) of byte;
end do
with ob do
begin
lamout.line:= lamin.line;
lamout.char:= buf(next);
outword(lamout,lam);
next:= next + 1;
xtimer:= xtimer1;
if next > last then xmode:= output_last;
end; (* lock *)
signal(r,xsem);
end; (* not nill(r) *)
end; (* output *)
\f
output_last:
begin
schedule:= true;
xtimer:= 0;
xmode:= output_finis;
end; (* output_last *)
xecho: begin (* echo finished *)
schedule:= true;
xtimer:= 0;
xmode:= xidle;
end; (* xecho *)
end; (* case xmode *)
if schedule then
begin (* schedule main driver *)
sensesem(r,eventsem);
if not nil(r) then
begin
r^.u3:= lamin.line;
return(r);
end;
end;
end; (* with line *)
until doom;
end; (* scanner process *)
\f
procedure error(code: integer);
(*
fatal error termination routine.
outputs errormessage and terminates with zero division *)
begin
trace(code); (* output error *)
code:= 0;
code:= code div code; (* send my regards to broadway *)
end; (* error *)
procedure outecho(char: byte);
(* outputs char on curline as echo *)
begin
with line(curline) do
begin
lamout.char:= char;
lamout.line:= curline;
xmode:= xecho;
xtimer:= xtimer1;
outword(lamout,lam);
end; (* with *)
end; (* outecho *)
\f
procedure next_spec_echo;
(* outputs next special echo char. *)
begin
with line(curline) do
begin
lock lineref(spec_echo_line).convbuf as
spec_echo: array (-14..spec_echo_next) of byte
do outecho(spec_echo(spec_echo_next));
spec_echo_next:= spec_echo_next + 1;
echo_count:= echo_count - 1;
end; (* with *)
end; (* next_spec_echo *)
procedure retbuf(var r: reference; stat: integer);
(* returns r with u2 set to stat *)
begin
r^.u2:= stat;
return(r);
end;
procedure retall(var sem: semaphore);
(* returns all buffers at sem with u2= stat_notproc *)
begin
while open(sem) do
begin
wait(rw,sem);
retbuf(rw,stat_notproc);
end;
end; (* retall *)
\f
procedure retrbuf(var r: reference; stat: integer);
(* returns r with u2 = stat *)
begin
with line(curline) do
begin
if (rstat and stat_xoff) <> 0 then
begin
if xmode = xidle then
begin
if (r^.u1 and fatt) <> 0 then rmode:= att_echo
else rmode:= input_echo;
outecho(xoff);
end
else rstat:= rstat or stat_echoerr;
rstat:= rstat xor stat_xoff;
end
else
begin
retbuf(r,stat or rstat);
rmode:= idle;
rtimer:= 0;
rstat:= 0;
end;
end; (* with *)
end; (* retrbuf *)
procedure retxbuf(var r: reference; stat: integer);
(* as retrbuf except that line.xmit is idled *)
begin
with line(curline) do
begin
retbuf(r,stat);
xmode:= xidle;
xtimer:= 0;
end; (* with *)
end; (* retxbuf *)
\f
procedure setrbuf;
(* select next rec. buffer *)
begin
with line(curline) do
with lineref(curline) do
if nil(rcurbuf) then
begin
if open(rsem) then
begin
wait(rcurbuf,rsem);
rmode:= input;
rtimer:= rtimer1;
end
else
if open(rattsem) then
begin
wait(rcurbuf,rattsem);
rmode:= att;
end;
if not nil(rcurbuf) then
begin
lock rcurbuf as b: bufhead
do b.next:= b.first;
if (rcurbuf^.u1 and fcont) = 0 then
begin (* not input continued *)
cycfirst:= cyclast;
rstat:= 0;
end (* not input continued *)
\f
else
begin (* input continued *)
sensesem(rw,scansem);
if not nil(rw) then
begin
rw^.u3:= curline;
return(rw);
end; (* not nill *)
end; (* input continued *)
if (rcurbuf^.u1 and fxon) <> 0 then
begin
rstat:= rstat or stat_xoff;
rmode:= succ(rmode);
outecho(xon);
end;
end; (* not nill(rcurbuf) *)
end; (* with *)
end; (* setrbuf *)
\f
procedure setcontrol;
(* outputs modem control from line.linestatus *)
begin
lamcontrol:= line(curline).linestatus;
with lamcontrol do
begin
if pty_mode = 1 then pty_mode:= 2;
not_mr:= true;
dcd:= (curline and 8) <> 0;
rfs:= (curline and 4) <> 0;
dsr:= (curline and 2) <> 0;
b14:= (curline and 1) <> 0;
scan:= false;
end;
control(lamcontrol,lam);
end; (* setcontrol *)
\f
procedure sensemodem;
(* updates incomming modem signals *)
begin
lamin.line:= curline;
sense(lam_stat,lamin,lam);
with line(curline) do
begin
if (lam_stat.stat and ls_dcd) = 0 then linestatus.dcd:= false;
if (lam_stat.stat and ls_rfs) = 0 then linestatus.rfs:= false;
if (lam_stat.stat and ls_dsr) = 0 then linestatus.dsr:= false;
end;
end; (* sensemodem *)
procedure returnmodem(var r: reference);
(* returns r with linestatus *)
begin
lock r as b: record
f, l, n: integer;
s: line_status_type;
end
do b.s:= line(curline).linestatus;
retbuf(r,stat_ok);
with line(curline).linestatus do
begin
dcd:= true;
rfs:= true;
dsr:= true;
end;
end; (* returnmodem *)
\f
procedure setxbuf;
(* selects next output message and starts output.
xmode must be idle, when called *)
begin
with line(curline) do
begin
sensesem(r,xsemqueue);
if not nil(r) then
begin (* start output *)
s:= r^.size;
lock r as ob: packed record
first, last, next: integer;
buf: array (6..s-1+s) of byte;
end
do
with ob do
begin
lamout.line:= curline;
lamout.char:= buf(first);
next:= first + 1;
xtimer:= xtimer1;
if next > last then xmode:= output_last
else xmode:= output;
end; (* lock *)
(* start scanner output *)
signal(r,xsem);
outword(lamout,lam);
end; (* not nill (r) *)
end; (* with *)
end; (* setxbuf *)
\f
begin (* lam main program *)
(* initialization *)
(* reserve and reproduce lam channel *)
if reservech(lam,lamlevel,lammask) <> 0 then error(init1);
alloc(r,scanpool,scansem);
if copychm(r,lam) <> 0 then error(init2);
signal(r,scansem);
(* init scanner event pool *)
while openpool(scanpool) do
begin
alloc(r,scanpool,lamsem);
signal(r,scansem);
end;
(* init timer for 1 sec ticks *)
alloc(r,timerpool,lamsem);
r^.u3:= timeru3;
r^.u4:= timeru4;
sendtimer(r);
(* master reset the lam *)
lamcontrol.not_mr:= false;
control(lamcontrol,lam);
\f
(* init line descriptors *)
for curline:= firstline to lastline do
with line(curline) do
begin
rmode:= idle;
rtimer:= 0; rtimer1:= 0; rtimer2:= 0;
linestatus:= init_linespec;
cycfirst:= 0; cyclast:= 0;
convmode:= -2;
rstat:= 0;
xmode:= xidle;
setcontrol;
end; (* linedescriptor init loop *)
(* start scanner process *)
if create("lamscanner",scanner(scansem,line), scansh,scanner_size) <> 0
then error(init3);
start(scansh,0);
\f
(* lam main loop and main waiting point *)
repeat
wait(r,lamsem);
if ownertest(scanpool,r) then
begin (* event from scanner *)
curline:= r^.u3;
signal(r,scansem);
with line(curline) do
with lineref(curline) do
begin
if ((rmode = input_echo) or (rmode = att_echo)) and
(xmode = xidle) then
begin (* echo char finished *)
if echo_count <> 0 then next_spec_echo
else
begin
if open(xsemqueue) then setxbuf;
if (res.class and termination) <> 0 then
begin (* last event for this message *)
retrbuf(rcurbuf,rstat);
setrbuf;
end
else rmode:= pred(rmode);
end; (* not special echo *)
end; (* echo char finished *)
\f
(* pick chars from the cyclic input buffer *)
while ((rmode = input) or (rmode = att)) and
(cycfirst <> cyclast) do
begin
rtimer:= rtimer2;
cycfirst:= (cycfirst + 1) mod cyctop;
datain:= cycbuf(cycfirst);
(* preconvert special characters ( break and pty-err) *)
convchar:= datain.char;
if (datain.stat and ls_error) <> 0 then
begin
if ((datain.stat and ls_stop) <> 0) and
(datain.char = 0)
then convchar:= brk
else
if ((datain.stat and (ls_pty or ls_stop)) <> 0) and
(linestatus.pty_mode <> 1) then
begin
convchar:= sub;
rstat:= rstat or stat_pty;
end;
if (datain.stat and ls_ovrun) <> 0 then
rstat:= rstat or (stat_ovrun or stat_err);
end; (* datain.stat and ls_error *)
(* update modem status *)
if ((datain.stat and ls_dcd) = 0) then linestatus.dcd:= false;
if ((datain.stat and ls_rfs) = 0) then linestatus.rfs:= false;
if ((datain.stat and ls_dsr) = 0) then linestatus.dsr:= false;
\f
(* convchar now contains a legal char or break *)
(* conversion *)
cmode:= convmode;
case cmode of
-1: c:= curline; (* own conversion *)
-2: ; (* no conversion *)
firstline..lastline:
begin (* borrow conversion *)
c:= cmode;
cmode:= line(c).convmode;
end;
otherwise cmode:= -2;
end; (* case cmode *)
\f
if cmode = -1 then
begin (* do conversion *)
s:= lineref(c).convbuf^.size;
lock lineref(c).convbuf as
conv: record
?,?,?,?: integer;
tab: array (-1..s-6) of convinteger;
end do
begin
res:= conv.tab(convchar);
if (res.class and normal_conv) = 0 then
begin (* special conversion *)
spec_index:= (res.class * 256) + res.char;
res:= conv.tab(spec_index);
res.class:= res.class and #b01111111; (* normal_conv=0 *)
spec_echo_line:= c;
spec_echo_next:= spec_index+spec_index;
echo_count:= (conv.tab(spec_index+1).class * 256) +
conv.tab(spec_index+1).char;
if echo_count = 0 then res.class:= res.class or noecho;
end; (* special conversion *)
end; (* lock conv.tab *)
end (* cmode = -1 *)
else
begin (* no conversion *)
if convchar = brk then
begin
res.char:= sub;
rstat:= rstat or stat_pty;
end
else res.char:= convchar;
res.class:= normal_conv;
end; (* no conversion *)
\f
(* decode conversion classes *)
if (rstat and stat_ovrun) <> 0
then res.class:= res.class or termination;
if (res.class and attention) <> 0 then
begin
(* stop input (later) *)
rstat:= rstat or stat_att;
res.class:= res.class or termination;
(* stop output (now), if active *)
sensesem(r,xsem);
if not nil(r) then
begin
retxbuf(r,stat_att);
setxbuf;
end; (* stop output *)
end; (* attention *)
\f
(* buffer actions *)
if (rmode = input) or ((res.class and attention) <> 0) then
begin
if (res.class and erase_all) <> 0 then
lock rcurbuf as b: bufhead do b.next:= b.first;
if (res.class and erase_last) <> 0 then
lock rcurbuf as b: bufhead do
if b.next <> b.first then b.next:= b.next - 1
else res.class:= res.class or noecho;
if ((res.class and blind) = 0) and
((rmode = input) or ((res.class and attention) <> 0)) then
begin (* deliver value *)
s:= rcurbuf^.size;
lock rcurbuf as
b: packed record
first, last, next: integer;
buf: array (6..s-1+s) of byte;
end
do with b do
begin
buf(next):= res.char;
next:= next + 1;
if next > last then res.class:= res.class or termination;
end; (* lock *)
if (res.class and mark) <> 0
then rstat:= rstat or stat_mark;
end; (* deliver value *)
\f
if ((res.class and noecho) = 0) and
((rcurbuf^.u1 and fecho) <> 0) then
begin (* start echo *)
if xmode <> xidle then rstat:= rstat or stat_echoerr
else
begin (* reserve echo line *)
rmode:= succ(rmode);
xmode:= xecho;
if (res.class and normal_conv) <> 0 then
begin (* one char normal echo *)
echo_count:= 0;
outecho(res.char);
end
else next_spec_echo;
end; (* reserve echo line *)
end (* start echo *)
else
if (res.class and termination) <> 0 then
begin
retrbuf(rcurbuf,rstat);
setrbuf;
end; (* termination *)
end; (* buffer actions *)
end; (* while input ready *)
\f
(* output_finis action *)
if xmode = output_finis then
begin
sensesem(r,xsem);
if nil(r) then error(internal1)
else
begin
retxbuf(r,stat_ok);
setxbuf;
end; (* not nil(r) *)
end; (* output_finis action *)
end; (* with *)
end (* scanner event *)
else
\f
(* timer action *)
if ownertest(timerpool,r) then
begin (* timer tick *)
r^.u3:= timeru3;
r^.u4:= timeru4;
sendtimer(r);
for curline:= firstline to lastline do
with line(curline) do
with lineref(curline) do
begin
if rtimer <> 0 then
begin (* input timer active*)
rtimer:= rtimer - 1;
if (rtimer = 0) and ((rmode = input) or (rmode = input_echo)) then
begin (* input timeout *)
retrbuf(rcurbuf,stat_err + stat_timeout);
setrbuf;
end; (* input timeout *)
end; (* input timer active *)
\f
if xtimer <> 0 then
begin (* output timer active *)
xtimer:= xtimer - 1;
if xtimer = 0 then
case xmode of
xidle: ; (* no action *)
output, output_last, output_finis:
begin (* output timeout *)
xmode:= xidle;
sensesem(r,xsem);
if nil(r) then error(internal2);
retxbuf(r,stat_err+stat_timeout);
setxbuf;
end; (* output, output_finis *)
xecho: begin (* echo error *)
rstat:= rstat or stat_echoerr;
(* simulate echo finish *)
xmode:= xidle;
sensesem(r,scansem);
if not nil(r) then
begin
r^.u3:= curline;
return(r);
end;
end; (* xecho *)
end; (* case xmode *)
end; (* output timer active *)
end; (* for all lines *)
end (* timer tick *)
else
\f
(* not event and not timer => real message *)
begin
curline:= r^.u3;
if (curline < firstline) or (curline > lastline) then
begin
r^.u2:= stat_ill;
return(r);
end
else
with line(curline) do
with lineref(curline) do
case r^.u1 of
0: begin (* sense modem *)
sensemodem;
returnmodem(r);
end; (* sense modem *)
\f
4: begin (* line control *)
lock r as b: record
f,l,n: integer;
ns, ac: line_status_type;
end
do with b do with linestatus do
begin
if ac.line_speed <> 0 then line_speed:= ns.line_speed;
if ac.data_size <> 0 then data_size:= ns.data_size;
if ac.stop_bits then stop_bits:= ns.stop_bits;
if ac.pty_mode <> 0 then pty_mode:= ns.pty_mode;
if ac.rts then rts:= ns.rts;
if ac.dtr then dtr:= ns.dtr;
end; (* lock *)
(* set lam parameters *)
setcontrol;
sensemodem;
returnmodem(r);
end; (* line control *)
\f
8: begin (* set conversion *)
lock r as conv: record
f,l,n,mode: integer;
end
do cmode:= conv.mode;
convmode:= cmode;
echo_count:= 0; (* stop special echo *)
case cmode of
-2: begin (* clear conversion *)
push(r,convbuf);
r :=: convbuf;
end; (* clear conversion *)
-1: (* set conversion table *)
r :=: convbuf;
firstline..lastline: (* set conversion link *)
r :=: convbuf;
otherwise begin (* illegal conv_control *)
convmode:= -2;
retbuf(r,stat_ill);
end; (* illegal *)
end; (* case cmode *)
if not nil(r) then retbuf(r,stat_ok);
end; (* set conversion *)
\f
12: begin (* set timers *)
lock r as b: record
f,l,n: integer;
it1, it2, ot1: integer;
end
do with b do
begin
rtimer1:= it1;
rtimer2:= it2;
xtimer1:= ot1;
end; (* lock *)
retbuf(r,stat_ok);
end; (* set timers *)
16: begin (* reset, return all buffers *)
if not nil(rcurbuf) then
begin
if (rstat and stat_xoff) <> 0 then
begin
outecho(xoff);
rstat:= rstat xor stat_xoff;
end;
retrbuf(rcurbuf,stat_notproc);
end; (* not nil(rcurbuf *)
rmode:= idle;
xmode:= xidle;
echo_count:= 0;
rtimer:= 0;
xtimer:= 0;
retall(rsem);
retall(rattsem);
retall(xsem);
retall(xsemqueue);
retbuf(r,stat_ok);
end; (* reset *)
\f
(* tramsput messages *)
1,3,5,7,17,19,21,23:
begin (* input *)
signal(r,rsem);
if nil(rcurbuf) then setrbuf
else
begin (* if att then suspend *)
if (rcurbuf^.u1 and fatt) <> 0 then
begin
signal(rcurbuf,rattsem);
setrbuf;
end; (* suspend attention buffer *)
end; (* not nil(rcurbuf) *)
end; (* input *)
9,11,13,15,25,27,29,31:
begin (* attention *)
signal(r,rattsem);
if nil(rcurbuf) then setrbuf;
end; (* attention *)
2: begin (* output *)
signal(r,xsemqueue);
if not open(xsem) then setxbuf;
end;
otherwise retbuf(r,stat_ill);
end; (* with case function *)
end; (* real message *)
until doom;
end (* lam driver, farvel og tak *)
.
▶EOF◀