⟦b0c00adc3⟧

TextFileVerbose

job oer 9 200 time 11 0 size 100000 area 10
( mode list.yes
source = copy 25.1
o c
tsoererr = set 1 disc1
tsoerlst=set 1 disc1
if ok.yes
(message lam116 compile
o tsoererr
pascal80 codesize.8000 spacing.12 evaenv alarmenv source;
o c
lookup pass6code
if ok.yes
( tsoerbin=set 1 disc1
tsoerbin= move pass6code
scope user tsoerbin
message lam116 ok
)
liste=indent source lc mark
lst=cross liste
tsoerlst = copy lst tsoererr
scope user tsoerlst
scope user tsoererr
message lam116 liste
)
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  3.16 /";

max_port_no=15;
max_channel_no= 2*max_port_no+1;

(*---  values used when creating high level lam-driver ---*)
mask = 0;
      prio  = 2;
      store = 200;
(*--- number of lambuffers, one is used as channelmessage ---*)
no_of_lambufs = 32;


long_time = 10;
normal_time = 7;
short_time = 4;
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 = 5;

rtr_delay_u3 = 13;
rtr_delay_u4 = 5;


(*---  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;
read_checksum : integer;
tst : integer := 0;
dummy_byte : byte := 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
if request^.u3 >= command then
lock request as buf : drvbuffer do
begin
buf.next := buf.first;
top := buf.last -buf.first + 6;
end
else
top := 4;
next := 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( channe{_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);

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(var 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
if next < top then
case next of

1 :
begin
if data_byte <> stx then
next := 0;
checksum := 0;
end;


2 : (* stx should be read *)

if data_byte <> stx then
next := 0;

3 : (* opcode should be read *)
begin
old_result := data_byte;
if not (data_byte in op_codes) then
next := 0
else
if data_byte < command then
top := 4;
end;

4 : (* bbl should be read *)
begin


if top < data_byte + 6 then
begin  (* read bbl too big *)
stop_actual_request
( 5*8 + transient_error, channel_no);
(*qtestout(z,"reci-bbl    ", data_byte);q*)
end
else
begin
top := data_byte + 6;  (* top points at etx *)

(*qtestout(z,"reci-bbl    ", data_byte);q*)
end


end;

otherwise

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;
end;

(*qtestout(z,"reci-info   ", data_byte);q*)


end
end (* case *)
\f


else
if next = top then
(*---  etx should be read *)

begin
if data_byte <> etx then
begin (* start again *)
next := 0;
if request^.u3 >= command then
lock request as buf : drvbuffer do
begin
buf.next := buf.first;
top := buf.last - buf.first +6;
end
else
top := 4;
end;

end

else
begin (* next >= top + 1 *)
       (* 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;
next := next +1;
checksum := (checksum + data_byte) mod 256;
end;
\f


alc_write_channel :
begin

<*r
if ready_to_send ( channel_no) then
r*>
begin

if next < top then

case next of

1 :
begin
data_byte := stx;
checksum := 0;
end;

2 : (* stx is send *)

data_byte := stx;

3 : (* opcode is send *)
begin
data_byte := request^.u3;
end;

4 : (* bbl is send *)

lock request as buf : drvbuffer do
begin  (* bbl *)
data_byte := buf.last - buf.first;
(*qtestout(z,"send-bbl    ", data_byte);q*)
end;
otherwise

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;
(*qtestout(z,"send-info   ", buf.info(buf.next));q*)
end;
end
end (* case *)
\f


else
if next = top then
begin
data_byte := etx;
(*qtestout(z,"send-etx    ", checksum);q*)
end

else
if next = top + 1 then

(* chs is send *)

begin
data_byte := checksum;
(*qtestout(z,"send-chs    ", etx);q*)

end
else
(*  next >= top + 2 *)
(*  user buffer is released *)

begin
stop_actual_request
( ok_result, channel_no);

(*qtestout(z,"release uo  ",next);q*)
end;

end;
<*r
else
stop_actual_request
(write_error, channel_no);
r*>
outword( packed_word( data_byte, channel_no), channelmessage);
checksum := (checksum + data_byte) mod 256;
next := next + 1;
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
begin
lock request as buf:drvbuffer do
if next > buf.first then       (*  erase  *)
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
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 := 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,prio)
(*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 request^.u1=read_tty 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( dummy_byte,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;

if (j < i )
or (j-i >= (2*ref^.size -6)) 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(dummy_byte,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:

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 ( dummy_byte, 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»
DataMuseum.dk

RC3500

⟦b0c00adc3⟧ TextFileVerbose

Derivation

TextFileVerbose
