DataMuseum.dk

top - metrics - download

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

└─⟦2c55ea56f⟧ Bits:30001844 SW-save af projekt 1000, Alarm-system
    └─⟦6b41451d2⟧ 
        └─⟦this⟧ »toperator« 

TextFileVerbose

job bbl 4 600 time 11 0 perm mini 100 1 size 92000
(
platonenv = set bs bblenv
; o operatorout
  head 1 cpu
  pascal80 codesize.12000 spacing.12000 ,
    short.yes,
    stack.260,
    codelist.no,
    debugenvir
; o c
; convert operatorout
  boperator = set 1 mini
  boperator = move pass6code
  if ok.yes
    scope project boperator
  finis
)


process operator(var sem_vector : system_vector);
(************************************************************************)
(*                                                                      *)
(*          operator process                                            *)
(*                                                                      *)
(************************************************************************)

const
level           = 3;

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

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

linelength      = 80;
first_index     = 6 + alfalength;
last_index      = first_index +linelength - 1;
last_name_index = first_index + alfalength + 2;
lf              = 10;
esc             = 27;

default_size    = 0;
priority        = 1;
undef_name      = ' ???????????';  (* first char must differ from '?' *)

type
headtype = record
first, last, next : integer;
inc_name : alfa
end;

nametype = record
head : headtype;
databuf : array(first_index..last_name_index) of char
end;

var
operator_sem    : ^ semaphore;
console_sem     ,
bisem           : semaphore;
messages        : pool 2;
namemessages    : pool 1 of nametype;
stack           ,
driver_msg      ,
name_msg        : reference;
curname         : alfa := undef_name; (* holds current inc-name *)
index           : integer;
console_sh      : shadow;
outqueue        ,
inqueue         : semaphore;
i               : integer;
att_flag        : boolean := false;
printnl         : boolean := true;
repeatinput     : boolean := false;
att_char        : byte;

procedure putinqueue;
var noerror: boolean;
begin
if ownertest(messages,stack) then
begin
att_flag:=true;
att_char := stack^.u3;
signal(stack,console_sem);
end
else
begin
if stack^.size > first_index div 2 then
begin
(* test buffer-pointers *)
lock stack as p : headtype do
with p do
begin
noerror :=
(first_index <= first) and (first <= last) ;
next := first_index
end;
if noerror then
case stack^.u1 of
write:
signal(stack,outqueue);
read:
signal(stack,inqueue);
otherwise
end; (* case *)
end
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 := true;
begin
while more do
begin
sensesem(stack,operator_sem^);
if nil(stack) then
more := false
else
putinqueue
end
end;  (* empty operator_sem *)

procedure init(code : byte);
begin
name_msg^.u1 := code;
lock name_msg as p: headtype do
begin
p.first := first_index;
if code = read then
begin
p.next := first_index;
p.last := last_name_index
end
else
p.last := p.first - 1;
end;
end;

procedure putch(ch : char);
begin
lock name_msg as p : nametype do
begin
p.head.last := p.head.last + 1;
p.databuf(p.head.last) := ch;
end;
end;

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

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;

procedure send_output;
begin
lock stack as p : headtype do 
begin
init(write);
if printnl then
putch(nl);
setname(p.inc_name)
end;
wrap (write);
printnl := driver_msg^.u3 <> lf;
repeatinput := true; (* set flag for eventually to repeat input *)
att_flag    := true; (* to force entry in attention loop in main block *)
att_char    := 0; 
return(stack)
end;

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

function searchname : boolean;
var
found : boolean := false;
begin
signal(driver_msg,inqueue); (* init stop element *)
(* search among pool of inputs *)
wait(stack,inqueue);
while not ownertest(messages,stack) do
begin
if stack^.answer = own.secret_pointer^(deallocatorsem) then
return(stack)
else
      lock stack as candidate : headtype do
if curname = candidate.inc_name then
          found := true;
if nil(driver_msg) and found then
stack :=: driver_msg;
if not nil(stack) then
 signal(stack,inqueue);
wait(stack,inqueue);
end;
searchname := found;
stack :=: driver_msg
end;    (* searchname *);

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



begin

setpriority(1);

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 *)
i := link('console     ',console);
i := create('console     ',console(console_sem,level,level+1),console_sh,default_size);
start(console_sh,priority);

while true do
begin
empty_operatorsem;
if att_flag then
begin
repeat
att_flag := false;
if att_char = esc then
begin
repeatinput := true;
(* read a new inc-name *)
init (write);
if printnl then
putch(nl);
putch ('>');
signal(name_msg,console_sem);
wait(name_msg,bisem);
init (read);
name_msg^.u3 := 0; (* no echo before input *)
signal(name_msg,console_sem);
wait(name_msg,bisem);
get_curname;
if name_msg^.u2 <> ok then
begin
init(write);
putch(nl);
signal(name_msg,console_sem);
wait(name_msg,bisem)
end;
printnl := false;
if curname(1) = '?' then
begin
signal(driver_msg,inqueue); (* init stop element *)
wait(stack,inqueue);
while not ownertest(messages,stack) do
begin
lock stack as p : headtype do
begin
init(write); (* no newline *)
setname(p.inc_name);
end;
signal(stack,inqueue);
wait(stack,inqueue)
end;
stack :=: driver_msg;
att_char := 0;
end;
empty_operatorsem
end
until not att_flag;

if searchname then
begin
if repeatinput then
begin
repeatinput := false;
lock stack as p : headtype do
begin
i := p.last; (* save last for the following input *)
p.last := p.next - 1; (* set last for output of eventually typed input *)
index  := p.last
end;
if index >= first_index then
begin
wrap(write);
printnl := true
end;
lock stack as p : headtype do
begin
p.next := p.last + 1; (* set for continued input *)
p.last := i (* reestablish old last value *)
end
end;
if att_char = 0 then
begin
repeatinput := false;
signal(stack,inqueue)
end
else
begin
if att_char = esc then
att_char := 0;
driver_msg^.u3 := att_char; (* set first echo char *)
wrap(read);
if stack^.u2 = ok then
begin
printnl := false; (* input has been ended with nl *)
return(stack)
end
else
begin
printnl := true;
signal(stack,inqueue)
end
end
end
else
begin
repeatinput := false;
if att_char <> 0 then
begin
init(write); (* no new line *)
putch(bel);
signal(name_msg,console_sem);
wait(name_msg,bisem)
end
end
end
else
begin  (* idle *)
sensesem(stack,outqueue);
if nil(stack) then
begin
wait(stack,operator_sem^);
putinqueue
end
else
send_output
end
end;  (* while *)
end
.     (* operator *)

«eof»