|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 33024 (0x8100)
Types: TextFileVerbose
Names: »tslapjob«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »tslapjob«
job oer 9 200 time 11 0 size 100000 area 10
( message lam driver
source = copy 25.1
tslaplst=set 1 disc1
tslaplst = indent source mark lc
listc = cross tslaplst
o tslaperr
pascal80 codesize.8000 spacing.100 evaenv alarmenv source;
o c
lookup pass6code
if ok.yes
( tslapbin = set 1 disc1
tslapbin= move pass6code
scope user tslapbin
)
tslaplst = copy listc tslaperr
scope user tslaplst
finis output.no
)
\f
process lam(
opsem: sempointer;
pu: integer;
level:integer;
var mainsem: !ts_pointer
);
(*********************************************************
* *
* lam-driver *
* programmed by oer *
**********************************************************)
(*-------------------------------------------------------
. terms
.
. port refers to a port on the physical lam
. channel refers to a channel in the lamdriver
. where there are two channels for each port
. i e one for output and one for input
.
.--------------------------------------------------------*)
const
version = "vers 4.02 /";
max_port_no=15;
max_channel_no= 2*max_port_no+1;
(*--- values used when creating high level lam-driver ---*)
mask = 0;
store = 200;
(*--- number of lambuffers, one is used as channelmessage ---*)
no_of_lambufs = 32;
normal_time = 7;
no_time = 1;
forever = false;
(* controlebits to lam *)
requesttosend = 7*32;
readytoread = 5*32;
(* statuswords from lam *)
write_read_ok = 40;
overrun=41;
parity=44;
overrun_and_parity=45;
readytosend = 24;
(* alc-functions *)
alc_write = write_it;
alc_read = read_it;
write_alc_read = write_read_it;
create_alc_ch = create_it_ch;
op_codes = (. 5, 19, 20, 21, 28, 29 .);
\f
(*--- channelkinds ---*)
not_created = 0;
at_write_channel = 1;
at_write_wait = 2;
at_read_channel = 3;
at_read_wait = 4;
alc_write_channel = 5;
alc_read_channel = 6;
tty_write_channel = 7;
tty_read_channel = 8;
echo_nl_on_channel = 9;
tty_wait_cr = 10;
tty_wait_nl = 11;
tty_wait_input = 12;
(*--- delays used on at-channels ---*)
rts_delay_u3 = 10;
rts_delay_u4 = 3;
rtr_delay_u3 = 9;
rtr_delay_u4 = 3;
(*--- byte-compatible values for special characters ---*)
stx = 2;
etx = 3;
bs = 8;
nl = 10;
cr = 13;
cs = 19; (* crtl + small s *)
esc = 27;
sp = 32;
del = 127;
command = 28;
\f
(* result codes *)
(* specified in u2 overwriting portno *)
(* other resultcodes are given in alarmenv *)
transient_error = transi_err;
persistent_error = persi_err;
illegal_function = ill_func;
write_error = 2*8 + transient_error;
write_read_mixed = create_done;
buffer_too_small = illegal_function;
go_on_read = 6▶07◀;
(*-------------------
results modified for
transient errors
2*8 +2 = write-error
3*8 +2 = parity or overrun
4*8 +2 = checksum error
5*8 +2 = read bbl too big
6*8 +2 = etx missing
---------------------*)
(****************************************
*
* params that should be used in create channel
*
* +0 odd parity
* 1 stop element
* 5 databits/char
* 110 bps
* +1 no parity
* +2 even parity
* +3 no parity
* +4 2 stop elements
* +8 6 databits
* +16 7 databits
* +24 8 databits
* +32 300 bps
* +64 600 bps
* +96 1200 bps
*
****************************************)
\f
type
(* no of input+output devices on one lam-driver *)
channelset = 0..max_channel_no;
portset = 0..max_port_no;
(* format of a buffer send to/from a vcit *)
drvbuffer
= record
first, last, next : integer;
end;
(* format of a buffer send to/from a vcat or at *)
atbuffer
= array(0..1) of byte;
(* one word to write in writeword *)
lamword
= packed record
data : byte;
std : 0..7;
port_and_bit15 : channelset;
end;
(* one description for each device *)
channelrecord
= record
request:reference; (* current message *)
channel_kind : 0..15;
old_result : byte;
interruptable : boolean;
reading_tty : boolean;
checksum: integer;
timeout,
next,
top: integer;
status : integer;
end;
\f
var
(* ref for channelmsg *)
channelmessage,ref: reference;
(* shadow for lam at high level *)
driver: shadow;
lamsem : semaphore;
(*--- pools ---*)
delaypool : pool 16;
timerpool: pool 1;
(* buffers for handling interrupts *)
lampool: pool no_of_lambufs;
(* devicenumber *)
channel_no: integer;
(* zone used by testopen and testout *)
z: zone;
(* all devicedescriptors in one array *)
channel_descriptor: array(channelset) of channelrecord;
queue : array(channelset) of semaphore;
(* timeoutperiode and controlword for each device *)
time,controle_byte: array(portset)of byte;
i,j,k : integer;
test_b : boolean;
tst : integer := 0;
\f
(*************** externals ***********************************)
function copychm(var x,y: reference): integer; external;
(* makes a copy of a channelmessage *)
procedure testopen(var x:zone; y:alfa; z:^semaphore); external;
(* opens testmode *)
procedure testout(var x:zone; y:alfa; z:integer); external;
(* writes text for test *)
procedure control( x: integer; var y: reference); external;
(* writes one controlword *)
procedure outword( x: lamword; var y: reference); external;
(* writes one word *)
procedure sense(var x:integer; y:integer; var z:reference); external;
(*************** procedures ***********************************)
procedure stop_actual_request
( result: byte; channel_no: channelset );
forward;
\f
procedure start_rts_delay(channel_no : integer);
(*********************************************
* rts-delay *
**********************************************)
var ref:reference;
begin
alloc(ref, delaypool, mainsem.s^);
ref^.u3 := rts_delay_u3;
ref^.u4 := rts_delay_u4;
ref^.u1 := channel_no*2;
(*q if test_b then
testout( z, "rts-delay ", ref^.u1); q*)
sendtimer(ref);
end;
procedure start_rtr_delay(channel_no : integer);
(*********************************************
* rtr-delay *
**********************************************)
var ref:reference;
begin
alloc(ref, delaypool, mainsem.s^);
ref^.u3:=rtr_delay_u3;
ref^.u4:=rtr_delay_u4;
ref^.u1 :=channel_no*2+1;
(*q if test_b then
testout( z, "rtr-delay ", ref^.u1); q*)
sendtimer(ref);
end;
\f
procedure createchannel( w_kind, r_kind: 0..15 );
(***********************************************
* createchannel *
************************************************)
var i: integer;
begin
i:=ref^.u2;
channel_descriptor(i*2).channel_kind:=w_kind;
channel_descriptor(i*2+1).channel_kind:=r_kind;
channel_descriptor(i*2).status := write_read_ok;
channel_descriptor(i*2+1).status := write_read_ok;
lock ref as buf:atbuffer do
begin
controle_byte(i):=buf(0) mod 128;
time(i):=buf(1);
end;
ref^.u2:=ok_result;
return(ref);
(*q if test_b then
begin
testout( z, "chn created ", i);
testout( z, "controlebyte", controle_byte(i));
end; q*)
end;
\f
(*******************************************************
* start_next_request *
* initializes next, top, and timeout in *
* channeldescriptor(channel_no) *
* and channel if it is used for output *
* *
* called when - not finished with write/read *
* - more requests after stop_actual_request
* - timeout on write *
* - no requests when a new userbuffer *
* is comming *
********************************************************)
procedure start_next_request( channel_no:channelset);
var c : integer;
begin
with channel_descriptor(channel_no) do
begin
timeout:= time(channel_no div 2);
(*q if test_b then
begin
testout( z,"sta-nxt-req ", channel_no);
testout( z,"chn-kind ",channel_kind);
end; q*)
if channel_kind = at_write_channel then
begin
(* set up for output *)
c:=controle_byte(channel_no div 2)*256+requesttosend+channel_no;
control(c,channelmessage);
(*q if test_b then
testout(z,"rts-init ",c); q*)
start_rts_delay(channel_no);
channel_kind := at_write_wait;
end
\f
else
begin
if channel_kind = tty_read_channel then
channel_descriptor(channel_no-1).reading_tty:=true;
interruptable:=true;
end;
if request^.u1 > write_alc_read then
begin
lock request as buf: drvbuffer do
begin
next:= buf.next;
top:= buf.last+1;
end;
end
else
if request^.u1 <= write_read_at then
begin
next := 0;
top := 2;
end
else
begin (* alc mode *)
if request^.u3 >= command then
lock request as buf : drvbuffer do
begin
buf.next := buf.first;
end;
top := 1;
if channel_kind = alc_read_channel then
timeout := timeout * 10;
end;
end;
end;
\f
(*******************************************************
* stop_actual_request
*
* sends answer back to user
* if we shall go on read the request is send to *
* queue at channel_no+1 *
********************************************************)
procedure stop_actual_request
( result:byte; channel_no:channelset);
var c : integer;
begin
with channel_descriptor(channel_no) do
case channel_kind of
at_write_channel:
begin
start_rtr_delay(channel_no);
channel_kind := at_read_wait;
old_result := result;
end;
at_read_wait:
begin
c:=controle_byte(channel_no div 2)*256+readytoread+channel_no;
control(c,channelmessage);
channel_kind := at_write_channel;
result:= old_result;
(*q if test_b then
testout( z,"rtr-answer ", c); q*)
end
otherwise;
end;
\f
if channel_descriptor(channel_no).channel_kind <> at_read_wait then
begin
if result = go_on_read then
begin
(*q if test_b then
testout( z,"go on read ", channel_no); q*)
while not nil( channel_descriptor(channel_no+1).request) do
with channel_descriptor(channel_no+1) do
begin
request^.u2:=write_read_mixed;
return(request);
sensesem( request, queue(channel_no+1));
end;
channel_descriptor(channel_no+1).request:=:channel_descriptor(channel_no).request;
start_next_request(channel_no+1);
end
else
begin
with channel_descriptor( channel_no) do
if (( channel_kind=alc_read_channel) or (channel_kind=alc_write_channel)) then
begin
<*t
if result <> 0 then
begin
if channel_kind=alc_read_channel then
testout(z,"ui-r ", result)
else
testout(z,"uo-r ", result);
testout(z,"opc ", request^.u3);
end;
t*>
request^.u4 := status mod 256;
end;
channel_descriptor(channel_no).request^.u2:=result;
(*q if test_b then
testout( z, "returning ", channel_no); q*)
return(channel_descriptor(channel_no).request);
end;
\f
with channel_descriptor(channel_no) do
begin
timeout:=0;
sensesem(request,queue(channel_no));
if channel_kind = tty_read_channel then
begin
if nil(channel_descriptor(channel_no-1).request) then
begin (* no writes are waiting *)
if nil(request) then
channel_descriptor(channel_no-1).reading_tty := false
else
start_next_request( channel_no)
end
else
begin (* writes are waiting *)
channel_descriptor(channel_no-1).reading_tty:=false;
start_next_request(channel_no-1);
end
end
else
if channel_kind = tty_write_channel then
begin
if nil( request) then
begin (* no more writes look for reads *)
if not nil(channel_descriptor(channel_no+1).request) then
start_next_request(channel_no+1)
end
else
start_next_request(channel_no);
end
else
if nil(request) then interruptable:=false
else start_next_request(channel_no);
end;
end;
end;
\f
function packed_word ( databits: byte; channel_no: channelset): lamword;
(********************************************************
* makes a word ready for outword *
*********************************************************)
var w: lamword;
begin
w.data:= databits;
w.std := 0;
w.port_and_bit15:=channel_no;
packed_word:= w
end;
\f
procedure set_lam_control( channel_no : channelset);
var c : integer;
begin
channel_no := channel_no - channel_no mod 2;
c := controle_byte( channel_no div 2) *256 + channel_no;
if channel_descriptor(channel_no).channel_kind = at_write_channel then
c := c+readytoread
else
c:= c+ requesttosend;
control( c, channelmessage);
end;
\f
procedure start_new_channel(channel_no: channelset);
(********************************************************
* start_new_channel *
* called when - channel is created *
* - persistent status error *
* - timeout on write or write/read *
*********************************************************)
begin
set_lam_control( channel_no);
channel_descriptor(channel_no).status:= write_read_ok;
with channel_descriptor(channel_no) do
while not nil(request) do
stop_actual_request
(create_done, channel_no);
channel_no:= channel_no+1;
with channel_descriptor(channel_no) do
while not nil(request) do
stop_actual_request
(create_done, channel_no);
end;
\f
function ready_to_send( channel_no:channelset):boolean;
(********************************************************
* ready-to-send *
*********************************************************)
begin
with channel_descriptor(channel_no) do
begin
sense( status, channel_no, channelmessage);
if status mod 32 div 8 = 3 then
ready_to_send := true
else
ready_to_send:=false
end;
end;
\f
procedure handle_ok_lam_int(data_byte: byte; channel_no: channelset);
(********************************************************
* handle_ok_lam_int *
* handles the buffer pointed to by request *
* *
* if it is a writebuffer the byte pointed to by next *
* is output *
* *
* if it is a readbuffer the data_byte is put into *
* the buffer at the byte pointed to by next *
* *
*********************************************************)
begin
(*q if test_b then
testout(z, "hndl-o-l-int", channel_no); q*)
with channel_descriptor(channel_no) do
case channel_kind of
\f
at_write_channel :
if next >= top then
begin
(*q if test_b then
testout( z, "next = top ", 0); q*)
if request^.u1 = write_read_at then
stop_actual_request
( go_on_read, channel_no)
else stop_actual_request
( ok_result, channel_no);
end
else
begin
<*rif ready_to_send(channel_no) then
r*>
lock request as buf:atbuffer do
begin
(*q if test_b then
begin
testout( z, "at-w-next ", next);
testout( z, "at-w-ch ", buf(next));
end; q*)
outword( packed_word( buf(next), channel_no), channelmessage);
next:=next+1;
end
<*r
else
stop_actual_request
( write_error, channel_no)
r*>
end;
\f
at_read_channel :
begin
lock request as buf:atbuffer do
buf(next):=data_byte;
(*q if test_b then
begin
testout( z, "at-r-next ", next);
testout( z,"at-r-ch ", data_byte);
end; q*)
next:=next+1;
if next >= top then
stop_actual_request
( ok_result, channel_no);
end;
\f
alc_read_channel :
begin
(* top controls position i format *)
case top of
1 : (* stx should be read *)
if data_byte = stx then top:= 2;
2 : (* opcode should be read *)
begin
old_result := data_byte;
checksum := 0;
if (data_byte in op_codes) then
if data_byte < command then top:= 5 else top:= 3
else top:= 1; (* illegal opk *)
end;
3 : (* bbl should be read *)
begin
next:= data_byte; (* points to etx *)
top:= 4;
(*qtestout(z,"reci-bbl ", data_byte);q*)
end;
4:
begin (* info is read *)
i := request^.size;
lock request as buf : record
first, last, next : integer;
info : array (6..i-1+i) of byte;
end do
begin
buf.info(buf.next) := data_byte;
buf.next := buf.next +1;
next:= next-1;
if next < 0 then top:= 5 else
if buf.next > buf.last then (* buffer too small *)
top:= 1
end;
if top = 1 then
stop_actual_request ( 5*8+transient_error, channel_no);
end;
\f
5: (*--- etx should be read *)
begin
if data_byte <> etx then
begin (* start again *)
if request^.u3 >= command then
lock request as buf : drvbuffer do
begin
buf.next := buf.first;
end;
top := 1;
end else
top:= 6;
end;
6:
(* chs should be read *)
if data_byte <> checksum then
begin
stop_actual_request
( 4*8 + transient_error, channel_no);
end else
begin
request^.u3 := old_result;
stop_actual_request
( ok_result, channel_no);
(*qtestout(z,"release-ui ", 0);q*)
end;
end; (* case *)
checksum := (checksum + data_byte) mod 256;
end;
\f
alc_write_channel :
begin
<*r
if ready_to_send ( channel_no) then
r*>
begin
case top of
1 : (* stx is send *)
begin
data_byte := stx;
top:= 2;
end;
2 : (* opcode is send *)
begin
data_byte := request^.u3;
checksum:= 0;
if data_byte < command then top:= 5 else top:= 3
end;
3 : (* bbl is send *)
lock request as buf : drvbuffer do
begin (* bbl *)
data_byte := buf.last - buf.first;
top:= 4;
(*qtestout(z,"send-bbl ", data_byte);q*)
end;
4: (* send info *)
begin
i:= request^.size;
lock request as buf : record
first, last, next : integer;
info : array (6..i-1+i) of byte;
end do
begin
data_byte := buf.info( buf.next);
buf.next := buf.next +1;
if buf.next > buf.last then top:= 5;
(*qtestout(z,"send-info ", buf.info(buf.next));q*)
end;
end;
\f
5: (* send etx *)
begin
data_byte := etx;
top:= 6;
(*qtestout(z,"send-etx ", checksum);q*)
end;
6:
(* chs is send *)
begin
data_byte := checksum;
top:= 7;
(*qtestout(z,"send-chs ", etx);q*)
end;
7: (* user buffer is released *)
begin
stop_actual_request
( ok_result, channel_no);
(*qtestout(z,"release uo ",next);q*)
end;
end; (* case *)
<*r
else
stop_actual_request
(write_error, channel_no);
r*>
outword( packed_word( data_byte, channel_no), channelmessage);
checksum := (checksum + data_byte) mod 256;
end;
end;
\f
tty_read_channel :
begin
(*q if test_b then
begin
testout( z,"tty-r-next ", next);
testout( z,"tty-r-ch ", data_byte);
end; q*)
case data_byte of
esc :
begin
with channel_descriptor( channel_no-1) do
if not reading_tty then
begin
timeout:=0;
channel_kind:=tty_wait_cr;
lock request as buf:drvbuffer do
if next > 1 then
buf.next:=next-1
else
buf.next:=next;
end
else
channel_kind := tty_wait_nl;
outword( packed_word( cr, channel_no), channelmessage);
start_next_request( channel_no);
(*ttestout(z,"esc ",timeout);t*)
end;
cs :
with channel_descriptor(channel_no-1) do
if not reading_tty then
begin
while not nil(request) do
begin
request^.u2:=create_done;
return(request);
sensesem(request,queue(channel_no-1))
end;
timeout:=0;
if not nil(channel_descriptor(channel_no).request) then
start_next_request(channel_no);
end
else (* reading tty *)
begin
with channel_descriptor( channel_no) do
begin
i:= request^.size;
lock request as buf : record
first, last, next : integer;
text : array (1..i-6+i) of byte;
end do
begin
if next > (i-6+i) then next := (i-6+i);
buf.text(next):=cs;
next:=next+1;
if next>=top then
buf.next:=next;
end;
if next>=top then
stop_actual_request
( ok_result, channel_no);
end;
outword(packed_word(cr,channel_no), channelmessage);
(*ttestout(z,"cs ",timeout);t*)
channel_kind:=echo_nl_on_channel;
end;
del,bs :
if channel_descriptor(channel_no-1).reading_tty then
lock request as buf:drvbuffer do
if next > buf.first then (* erase *)
begin
next:=next-1;
outword( packed_word( bs, channel_no), channelmessage);
end;
cr: (* return works as line-end *)
if channel_descriptor(channel_no-1).reading_tty then
begin
i := request^.size;
lock request as buf : record
first, last, next : integer;
text : array (1..i-6+i) of byte;
end do
begin
channel_descriptor(channel_no-1).channel_kind:=echo_nl_on_channel;
buf.text(next):=data_byte;
if next<top-1 then
begin
buf.text(next+1):=nl;
buf.next:=next+2
end
else
buf.next:=next+1;
outword( packed_word( cr, channel_no), channelmessage);
(*ttestout(z,"cr ",timeout);t*)
end
end
\f
otherwise (* packed_word character *)
if channel_descriptor(channel_no-1).reading_tty then
begin
i := request^.size;
lock request as buf : record
first, last, next : integer;
text : array (1..i-6+i) of byte;
end do
begin
(* index error has been seen here, next=81 *)
if next > (i-6+i) then next := (i-6+i);
buf.text(next):=data_byte;
next:=next+1;
if next >= top then
buf.next:=next;
end;
if next>=top then
stop_actual_request
( ok_result, channel_no);
outword( packed_word( data_byte, channel_no), channelmessage);
end
end;
if channel_descriptor(channel_no-1).reading_tty then
if timeout<normal_time then
timeout:=normal_time;
end; (* case read_tty *)
\f
tty_write_channel :
if not reading_tty then
<*r
if ready_to_send(channel_no) then
r*>
begin
i:= request^.size;
lock request as buf : record
first, last, next : integer;
text : array (1..i-6+i) of byte;
end do
begin
(*q if test_b then
begin
testout( z, "tty-w-next ", next);
testout( z, "tty-w-ch ", buf.text(next));
end; q*)
outword ( packed_word( buf.text(next), channel_no), channelmessage);
next:= next+1;
if next>= top then (* terminate *)
buf.next:= next;
end;
if next>=top then
if request^.u1 = write_read_tty then
stop_actual_request
( go_on_read, channel_no)
else
stop_actual_request
( ok_result, channel_no)
end;
<*r
else
stop_actual_request
( write_error, channel_no);
r*>
\f
echo_nl_on_channel :
begin
(*ttestout(z,"nl ",timeout);t*)
outword( packed_word( nl, channel_no), channelmessage);
if reading_tty then
stop_actual_request( ok_result, channel_no+1);
channel_kind:=tty_write_channel;
end;
tty_wait_cr :
begin
outword(packed_word(cr,channel_no),channelmessage);
channel_kind:=tty_wait_nl;
(*ttestout(z,"esc cr ",timeout);t*)
end;
tty_wait_nl :
begin
outword(packed_word(nl,channel_no),channelmessage);
channel_kind:=tty_wait_input;
(*ttestout(z,"esc nl ",timeout);t*)
end;
tty_wait_input :
begin
end;
otherwise
begin
end
end;
end;
\f
(***********************************************************
* *
* high level lam-driver *
* *
* converts an interrupt to a signal to the level-0-driver *
* *
* handles input only *
************************************************************)
process highlevellamdriver( var lamsem: semaphore);
const
readytosend= 24;
startscanner = -1;
interrupt_ok=40;
no_input=255;
type
dataword
= packed record
data:byte;
unused:0..3;
error:boolean;
port_and_bit15: 0..31;
end;
var
channelmessage,ref: reference;
indata: dataword;
status: integer;
procedure controlclr(x:integer; var y:reference); external;
(* writes controle and clears interrupt *)
procedure inword( var x: dataword; var y: reference); external;
(* reads one word *)
procedure sense( var x:integer; y:integer; var z:reference); external;
(* gets status *)
\f
begin
wait(channelmessage,lamsem);
(* wait for a channelmessage to arrive *)
channel channelmessage do
while true do
begin
controlclr(startscanner,channelmessage);
(* write control and clear interrupt *)
inword(indata,channelmessage);
(* read one word of input *)
wait(ref,lamsem);
(* wait for inputbuffer at lamsem *)
with indata,ref^ do
begin
u2:=interrupt_ok;
if (port_and_bit15 mod 2) = 0 then
(* it is an outputinterrupt *)
u3:=no_input
else
if error then
begin
sense(status, port_and_bit15, channelmessage);
u2 := abs( status) mod 64;
end
else
u3:=data;
u4:=port_and_bit15;
(*******************************
* +1 overrun
* +2 framing error
* status = 0 +4 parity error
* +8 data set ready
* +16 ready for sending
* +32 data carrier detector
********************************)
end;
return(ref);
end
end;
\f
(********************************************************
* initialization *
*********************************************************)
begin
testopen(z, own.incname, opsem);
testout( z, version, al_env_version);
(* create and start high level lamdriver *)
if create( "highlevellam", highlevellamdriver(lamsem), driver, store ) = 0
then start(driver,hl_lam_pri)
(*q else
if test_b then
testout(z,"create error",0) q*) ;
(* first buffer from lampool is used as a copy of channelmess *)
(*q if test_b then
testout(z, "lam-h start ", 0); q*)
alloc(ref,lampool,mainsem.s^);
if (reservech(channelmessage, level,mask) + copychm(ref,channelmessage) <> 1) and test_b then
(*q testout(z,"res.ch error",reservech(channelmessage, level,mask)) q*) ;
(* if reservation of channel went well, send copy of channelmess to lamdriver *)
signal(ref,lamsem);
(* get one timeoutbuffer *)
alloc(ref,timerpool,mainsem.s^);
(* delay is set to u3*2**u4 = 1 sec *)
ref^.u1 := 6;
ref^.u3:=250; ref^.u4:=2;
(* send to systemtimer *)
sendtimer(ref);
\f
(* get rest of inputbuffers and send them to lamdriver *)
for channel_no:=2 to no_of_lambufs do
begin
alloc(ref, lampool, mainsem.s^);
ref^.u1 := 6;
signal(ref,lamsem);
end;
(* all devicedescriptors are initialized *)
for channel_no:=0 to max_channel_no do
with channel_descriptor( channel_no) do
begin
timeout := 0;
channel_kind := not_created;
interruptable := false;
reading_tty := false;
end;
\f
(********************************************************
* level-0-lam *
* *
* sends output directly to the channel *
* handles inputbuffers from highlevel lamdriver *
* *
*********************************************************)
repeat (* main loop *)
(* wait for buffer on inputsemaphore *)
wait(ref,mainsem.w^);
\f
if ownertest(lampool,ref) then
begin
(*q if test_b then
testout( z, "interrupt on", ref^.u4); q*)
with channel_descriptor(ref^.u4) do
if interruptable then
if (not nil(request)) or (channel_kind>=echo_nl_on_channel) then
begin
status := ref^.u2;
if status = write_read_ok then
handle_ok_lam_int(ref^.u3, ref^.u4)
else
begin
stop_actual_request
(3*8 + transient_error,ref^.u4);
set_lam_control( ref^.u4);
<*
end
otherwise
begin
stop_actual_request
(persistent_error, ref^.u4);
status := ref^.u2;
start_new_channel(ref^.u4);
(*q if test_b then
testout(z,"hwstatus= 8.",((ref^.u2 div 8)*10+(ref^.u2 mod 8))*100+ref^.u4); q*)
*>
end;
end;
signal(ref,lamsem);
end
\f
else
(* it is a timeoutbuffer from systemtimer *)
if ownertest(timerpool,ref) then
begin
ref^.u3:=250; ref^.u4:=2;
sendtimer(ref);
for channel_no:=0 to 31 do with channel_descriptor(channel_no) do
if timeout>0 then
begin
timeout:=timeout-1;
if timeout=0 then
if channel_kind = tty_read_channel then
if not nil(channel_descriptor(channel_no-1).request) then
begin
channel_descriptor(channel_no-1).reading_tty := false;
start_next_request(channel_no-1);
lock request as buf:drvbuffer do
begin
if channel_descriptor(channel_no).next>buf.first then
outword( packed_word( 60, channel_no), channelmessage)
else
outword( packed_word(del, channel_no), channelmessage);
end
end
else
stop_actual_request
( timeout_err, channel_no)
else
begin
stop_actual_request
( timeout_err, channel_no);
if channel_no mod 2 = 0 then start_new_channel ( channel_no)
end;
end;
end
\f
else
(* it is a delaybuffer from systemtimer *)
if ownertest( delaypool, ref) then
begin
channel_no:=ref^.u1 div 2;
with channel_descriptor(channel_no) do
begin
case (ref^.u1 mod 2) of
0:
begin
(*q if test_b then
testout( z, "end-rts-dlay", channel_no); q*)
channel_kind:=at_write_channel;
interruptable := true;
handle_ok_lam_int( 0,channel_no);
end;
1:
begin
(*q if test_b then
testout( z, "end-rtr-dlay", channel_no); q*)
if request^.u1 = write_at then stop_actual_request
( ok_result, channel_no)
else stop_actual_request
( go_on_read, channel_no);
end;
otherwise (*q testout( z, "timer fault ", channel_no) q*);
end;
release(ref);
end
end
else
if ref^.u3 = dummy_route then return ( ref)
\f
else
(* it is a userbuffer *)
begin
(* devicenumber is equal to portno *2 *)
channel_no:=ref^.u2 * 2;
(* if command is pure read the devicenumber is uneven *)
if ref^.u1 mod 4 = 1 then channel_no:=channel_no+1;
case ref^.u1 of
create_at_ch:
begin
createchannel(at_write_channel, at_read_channel);
start_new_channel(channel_no);
end;
create_alc_ch:
begin
createchannel(alc_write_channel, alc_read_channel);
start_new_channel(channel_no);
end;
create_tty_ch:
begin
createchannel(tty_write_channel, tty_read_channel);
channel_descriptor(channel_no).interruptable:=true;
channel_descriptor(channel_no+1).interruptable:=true;
start_new_channel(channel_no);
end;
\f
read_at, write_at, write_read_at :
with channel_descriptor(channel_no) do
if (channel_kind<at_write_channel) or (channel_kind > at_read_wait) then
begin
ref^.u2 := illegal_function;
return( ref)
end
else
if not nil(request) then signal(ref,queue(channel_no))
else
begin
request:=:ref;
start_next_request(channel_no);
end;
\f
alc_read, alc_write, write_alc_read :
begin
if ref^.u3 >= command then
begin
lock ref as buf : drvbuffer do
begin
i := buf.first;
j := buf.last;
end;
k:= ref^.size;
if (i<6) or (j<i) or (j > (k-1+k)) then
begin
(*q if test_b then
testout( z,"buffer small", ref^.size); q*)
ref^.u2:=buffer_too_small;
return( ref);
end;
end;
if not nil( ref) then
with channel_descriptor(channel_no) do
if (channel_kind<alc_write_channel) or (channel_kind>alc_read_channel) then
begin
ref^.u2:=illegal_function;
return( ref);
end
else
begin
if not nil(request) then signal( ref, queue(channel_no))
else
begin
request :=: ref;
start_next_request(channel_no);
if channel_kind=alc_write_channel then handle_ok_lam_int(0,channel_no);
end;
end
end;
\f
read_tty:
with channel_descriptor(channel_no) do
if channel_kind < tty_write_channel then
begin
ref^.u2:=illegal_function;
return(ref);
end
else
begin
lock ref as buf : drvbuffer do
begin
i:= buf.first;
j:= buf.last;
end;
if (j<i)
or (i<1)
or (j-i >= 2*ref^.size-6) then
begin
ref^.u2 := illegal_function;
return( ref);
end;
if not nil( ref) then
if not nil ( request) then signal ( ref, queue(channel_no))
else
begin (* start now *)
request :=: ref;
(* look if write_tty is going on *)
if nil(channel_descriptor(channel_no-1).request) then
start_next_request(channel_no)
end;
end;
\f
write_tty,write_read_tty :
with channel_descriptor(channel_no) do
if channel_kind<tty_write_channel then
begin
ref^.u2:=illegal_function;
return(ref);
end
else
begin
lock ref as buf : drvbuffer do
begin
i := buf.first;
j := buf.last;
buf.next:=buf.first;
end;
if (j<i)
or (i<1)
or (j-i >= 2*ref^.size-6) then
begin
ref^.u2 := illegal_function;
return( ref);
end;
if not nil( ref) then
if not nil (request) then
signal ( ref, queue(channel_no))
else
begin
request :=: ref;
(* look if read_tty is going on *)
if channel_kind <> tty_wait_input then
if reading_tty then
with channel_descriptor(channel_no+1) do
lock request as buf:drvbuffer do
begin
if next>buf.first then
timeout:=normal_time
else
timeout:=no_time
end
else
begin
start_next_request(channel_no);
if not nil( request) then
handle_ok_lam_int ( 0, channel_no);
end;
end;
end
\f
otherwise
begin
(*q if test_b then
testout ( z, "unknown ", ref^.u1); q*)
ref^.u2:=illegal_function;
return(ref);
end
end;
end (* user request *)
until forever
end. (* lam driver *)
«eof»