DataMuseum.dk

top - metrics - download

    Length: 8448 (0x2100)
    Types: TextFile
    Names: »toperator«

└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
    └─⟦72244f0ef⟧ 
        └─⟦this⟧ »toperator« 

TextFile

process operator(name : alfa; sem_vector : system_vector);
(************************************************************************)
(*                                                                      *)
(*          operator process                                            *)
(*                                                                      *)
(************************************************************************)

const
version = '800626 10.00';
level = 3;
pu = 0;

(* functions *)
read = 1;
write = 2;
error_write = write + 4;
attention = read + 4;

(* results *)
not_processed = 1;
ok = 0;
timeout = 2;
perm_error = 3;
illegal_message = 4;
(* attention = 5 *)

linelength = 80;
first_index = 6 + alfalength;
last_index = first_index +linelength - 1;
esc = 27;

size = 512;
priority = -8;
undef_name = alfa (alfalength *** '?');

type
buffertype = record
first, last, next : integer;
inc_name : alfa;
databuf : array(first_index..last_index) of char
end;

var
<*mask : boolean := false; (* to be removed *) *>
operator_sem : ^ semaphore;
console_sem : semaphore;
bisem : semaphore;
messages : pool 2;
namemessages : pool 1 of buffertype;
stack : reference;
driver_msg : reference;
name_msg : reference;
curname         : alfa := undef_name; (* holds current inc-name *)
cur_inputname   : alfa := undef_name;
errorcode : integer;
console_sh : shadow;
outqueue : semaphore;
inqueue : semaphore;
read_name : boolean;
searchsem : semaphore;
i : integer;
att_flag: boolean := false;
att_char: byte;

<*
procedure print(text:alfa;nbr:integer);
begin
if mask then
begin
printtext('operator:   ');
printtext(text); printnumber(nbr,4); printnl
end
end; (* print *)
*>


procedure putinqueue;
var noerror: boolean;
begin
if stack^.size <= last_index div 2 then
begin
if ( stack^.size = 0 ) and ( stack^.u1 = attention ) then
begin (* assume until further: attention. if not the msg will be kept *)
att_flag:=true;
att_char := stack^.u4; (* may be: esc or cr *)
signal(stack,console_sem);
end
end
else
begin
(* test buffer-pointers *)
lock stack as p: buffertype do
with p do
noerror :=
(first_index <= first) and (first <= last) and (last <= last_index);
if noerror then
case stack^.u1 of
write,error_write:
begin
signal(stack,outqueue);
end;
read:
begin
signal(stack,inqueue)
end;
otherwise
end; (* case *)
end; (* test on size *)
if not nil (stack) then
begin
stack^.u2 := illegal_message;
return(stack)
end
end;    (* put in queue *)


procedure empty_operatorsem;
var 
more : boolean;
begin
more:=true;
while more do
begin
sensesem(stack,operator_sem^);
if nil(stack) then
more := false
else
putinqueue;
end
end;  (* empty operator_sem *)

procedure init (var msg: reference; code: byte);
begin
msg^.u1 := code;
lock msg as p: buffertype do
begin
p.first := first_index;
if code = read then
p.last := last_index
else
p.last := p.first - 1;
end;
end;

procedure putch (var msg: reference; ch: char);
begin
lock msg as p: buffertype do
begin
p.last := p.last + 1;
p.databuf (p.last) := ch;
end;
end;

procedure setname (newname: alfa);
var i : integer;
begin
if newname <> curname then
begin
curname := newname;
init (name_msg, write);
putch (name_msg, nl);
putch (name_msg, '>');
for i := 1 to alfalength do
if curname(i) <> sp then
putch (name_msg, curname(i))
else
i := alfalength;
putch (name_msg, nl);
signal (name_msg, console_sem);
wait (name_msg, bisem); 
end;
end;

procedure outtext(index : integer);
forward;

procedure wrap (func: byte);
(* sends 'stack' to console, with given function-code *)
begin
driver_msg^.u1 := func;
push (driver_msg, stack);
signal (stack, console_sem);
wait (stack, bisem);
pop (driver_msg, stack);
stack^.u2 := driver_msg^.u2;
end;

function empty_outqueue : boolean;
begin
empty_outqueue := false;
sensesem(stack,outqueue);
if nil(stack) then
empty_outqueue := true
else
begin
lock stack as p: buffertype do setname(p.inc_name);
case stack^.u1 of
write: (* operator console text output *)
begin
wrap (write);
return(stack)
end;
error_write: (* operator console error message *)
begin
wrap (write);
outtext (stack^.u4);
return(stack)
end;
end; (* case *)
end; (* if not nil *)
end;

procedure outtext(index : integer);
const
textlength = 30;
max =33;
type
errortext = array(1..textlength) of char;
tabletype = array(0..max) of errortext;
const
table=tabletype("unknown name                  ",
"signal: reference = nil       ",
"odd operand when even expected",
"****f: illegal field (lst<fst)",
"stv*f: field overflow         ",
"iocda/ioib*: nil message ptr  ",
"iocda: not channel message    ",
"iocda: not own pu             ",
"ioibx: not data message       ",
"ioibx: size too small         ",
"ioibx: top <= first           ",
"arithmetic overflow           ",
"index exception               ",
"undefined instruction code    ",
"odd addr. or lengths in sets  ",
"setad truncation error        ",
"stack overflow                ",
"intrs: illegal value          ",
"break: shadow = nil           ",
"push: identical arguments     ",
"pool: no core                 ",
"link: process already linked  ",
"pop: first param <> nil       ",
"pop: second param = nil       ",
"push: first param = nil       ",
"push: first param not emty    ",
"remove: shadow = nil          ",
"start: shadow = nil           ",
"stop: shadow = nil            ",
"unlink: process in use        ",
"subrange type outside limits  ",
"illegal switch in case constr.",
"upper limit in call of succ   ",
"lower limit in call of pred   ");
   
var
i,j:integer;
begin
if (index >= 0) and (index <= max) then
begin
init (name_msg, write);
j := textlength;
while table (index, j) = sp do j := j-1; (* find last significant char *)
for i := 1 to j do
putch (name_msg, table(index, i));
putch (name_msg, nl);
signal(name_msg,console_sem);
wait(name_msg,bisem);
end;
end;

procedure get_curname (var msg: reference);
var
i, length: integer;
begin
  lock msg as key : buffertype do
   begin
length := key.next - key.first;
if length <> 0 then
begin
if length > alfalength then length := alfalength;
for i := 1 to length do
key.inc_name(i) := key.databuf(first_index-1+i);
for i := length + 1 to alfalength do
key.inc_name(i) := sp;
cur_inputname := key.inc_name;
end
else
cur_inputname := curname;
curname := cur_inputname;
end; (* lock *)
end; (* procedure get-curname *)

function searchname : boolean;
var
more : boolean := true;
help : reference;
begin
searchname := false;

(* search among pool of inputs *)
    while more do
    begin
      sensesem(stack,inqueue);
      if nil(stack) then
      more := false
      else
      lock stack as candidate : buffertype do
begin
        if curname = candidate.inc_name then
        begin
          searchname := true;
          more := false;
        end;
end;
        if more then
              signal(stack,searchsem)
    end;      (* while more *)
  more := true;
  while more do
  begin
    sensesem( help , searchsem );
    if nil(help) then
    more := false
    else
    signal(help,inqueue)
  end
end;    (* searchname *);

process console(var consolesem : semaphore; pu,inputlevel,outputlevel : integer);
external;



begin
platoninit; (* to be removed after test*)
operator_sem := sem_vector(operatorsem);

alloc(driver_msg,messages,operator_sem^);
driver_msg^.u1 := attention;
signal(driver_msg,console_sem);

alloc(driver_msg,messages,bisem);
alloc(name_msg,namemessages,bisem);
name_msg^.u2 := ok;

(* create console driver incarnation *)
link('console     ',console);
i := create(console(console_sem,pu,level,level+1),console_sh,size,pu);
start(console_sh,priority);

while true do
begin
empty_operatorsem;
if att_flag then
begin
att_flag := false;
if att_char = esc then
begin
(* read a new inc-name *)
init (name_msg, write);
putch (name_msg, nl);
putch (name_msg, '>');
signal(name_msg,console_sem);
wait(name_msg,bisem);
if name_msg^.u2 = ok then
begin
init (name_msg, read);
signal(name_msg,console_sem);
wait(name_msg,bisem);
if name_msg^.u2 = ok then
get_curname (name_msg);
end;
end
else (* att-char <> esc *)
setname (cur_inputname);

case name_msg^.u2 of
ok:
begin
empty_operatorsem;
if searchname then
begin
wrap (stack^.u1);
if stack^.u2 = attention then
putinqueue
else
return(stack)
end
else
outtext(0);
end;  (* ok *)
attention: ;
timeout: ;
end;   (* case *)
end
else
if empty_outqueue then
begin  (* idle *)
wait(stack,operator_sem^);
putinqueue;
end
end;  (* while *)
end
.     (* operator *)

▶EOF◀