⟦ef4584c9f⟧

TextFile

job jg 9 200 time 11 0 perm disc1 1000 10 area 10 size 100000
( message     vagt
 source = copy 25.1
tsvaslst = set 1 disc1
tsvaslst = indent source mark lc
listc = cross tsvaslst
o errors
head 1
message tsvas program
pascal80 spacing.12000 codesize.8192 alarmenv source
o c
lookup pass6code
if ok.yes
( tsvasbin = set 1 disc1
  tsvasbin = move pass6code
  scope user tsvasbin
)
tsvaslst = copy listc errors
scope user tsvaslst
convert errors
finis
)
vagt_env;

(*----------------------------------------------------*)
(*                                                    *)
(*              vagt for demo system                  *)
(*                                                    *)
(*----------------------------------------------------*)
(*

function.
---------
this program acts as the lam_driver for the vc_connector.
( u1 = 8 or u1 = 11 )


requests from other programs.
------------------------------

these must obey the at-protocol.  correct telegrams are printed
on tty in alarm format, and answers are send.


output
------
   alarm       <clock> <text> <oper> <adr> <info>         alarm received.
   ready       <clock>  klar                              connected to ts.
   timeout     *<bel>                                     disconnected.
   empty       <clock>                                    command is send.
   error       <clock> <text>           ??                command rejected.

      <clock> ::= hh.mm.ss
      <text>  ::= name of alarm
      <oper>  ::= ff.nn    opkode of alarm
      <adr>   ::= sending at.     0..255
      <info>  ::= information     0..255


 input
 -----
   <inputline> ::= <command>: <adr> <info> <cr>
   <command>   ::= styr / test / tid: / star / stop / -sta / -sto /
                   vagt / flyt / -fly / modt / -mod /
                   nlat / -nla / nlvc / -nlv /
   <adr>       ::= 0..255       receiving at
   <info>      ::= 0..255       information
                   in tid command: adr = hh and info = mm
          *)
\f


(*------------------------ constants -------------------------------*)

const
version = "vers  3.10 /";
inc_size = 355;

ok = 0;
ille = 4;
p_ack  = 0;            (*  in answers  *)
vc_data= 1;
vc_opr = 2;
status = 3;
d_ack =  4;
t_ack =  5;
vc_nak  = 6;
test_ok = 6;
test_error= 21;
maxtime      =  2;    (*  maxtime*delay1 seconds between poll  *)
pagesize = 44;
ttylength = 80;       (*  line length in tty buffer   *)
last_text_no = 27;    (*  last tekst number   *)
last_com_no = 18;      (*  last command no +1   *)
headn = 4;
no_reads = 1;
no_writes = 3;
delay1       = 10;
delay2       = 10;    (*  1024 m seconds  *)
forever = false;
\f


(*---------------------------- types -------------------------------*)

type
command     = array (1..4) of char;
commands    = array (1..last_com_no) of command;
opcodes     = array (1..last_com_no) of byte;
funktion    = ( poll, data, test_i, opr );
replycode   = 0..7;
replycodes  = array (0..4) of replycode;
errortext   = array (1..3) of alfa;
alarmtext   = record no: byte; tx: alfa  end;
textarray   = array (1..last_text_no) of  alarmtext;
headarray   = array (1..headn) of alfa;
statusarray = array (0..7) of alfa;

createshape = packed record
contr, timer : byte
end;

telegram = packed record          (*  from vccon  *)
inf: byte;
fnc: funktion;
lnr: 0..1;
cbits: 0..31
end;

respons = packed record           (*  to vccon    *)
info: byte;
opko: replycode;
cbits: 0..31
end;

filebuffer = record
first, last, nextfree : integer;
text : array ( 1..ttylength) of char
end;

filezone = record
driver, answer_sem,
free: integer;
cur : reference;
u1val, u2val : byte;
next, top : integer
end;
\f


const
reply = replycodes ( p_ack, vc_data, vc_data, vc_opr, vc_nak);

whatx = errortext ("kommandofejl","atnr fejl   ","info fejl   ");

empty = "          > ";
klar  = "klar        ";
head = headarray (
"  klokken   ","tekst       "," opkode  atn","r  info     "); 

tekst = textarray(
alarmtext ( #h01, "log fra aVC "),
alarmtext ( #h10, "returneret  "),
alarmtext ( #h12, "afvisning!!!"),
alarmtext ( #h20, "knudeudfald "),
alarmtext ( #h21, "knuderetabl."),
alarmtext ( #h28, "AT udfald   "),
alarmtext ( #h29, "AT retabl.  "),
alarmtext ( #h30, "au-alarm    "),
alarmtext ( #h31, "liniealarm  "),
alarmtext ( #h32, "statusalarm "),
alarmtext ( #h41, "styr udført "),
alarmtext ( #h42, "styr afvist "),
alarmtext ( #h50, "flytning?   "),
alarmtext ( #h53, "flytning ok "),
alarmtext ( #h54, "returnering?"),
alarmtext ( #h57, "vagt retur  "),
alarmtext ( #h62, "AT er ok    "),
alarmtext ( #h64, "start AT?   "),
alarmtext ( #h65, "stop AT?    "),
alarmtext ( #h66, "nedlæg AT? "),
alarmtext ( #h72, "nedlæg VC?  "),
alarmtext ( #h85, "test udført "),
alarmtext ( #h86, "test afvist "),
alarmtext ( #h98, "meddelelse  "),
alarmtext ( #hf0, "AT ukendt   "),
alarmtext ( #hf1, "VC ukendt   "),
alarmtext ( #hff, "ukendt alarm") );
\f


statustxt = statusarray(
": afmelding ",
": timeout   ",
": hs fejl   ",
": au fejl   ",
": serif fejl",
": genstart  ",
": batteri ud",
": batteri   ");

menu = commands
 ("styr","test","tid:","star",
  "stop","-sta","-sto",
"vagt","flyt","-fly","modt","-mod",
"nlat","-nla","nlvc","-nlv","medd",
  "    ");

opkode = opcodes
 ( #h40, #h84, #hc4, #h01,
   #h02, #h03, #h04,
#h15, #h16, #h17, #h18, #h19,
#h05, #h06, #h07, #h08, #h20,
0 );
.
\f


process atvagtsim(
op_sem : sempointer;
var
sem    : !ts_pointer_vector  (* ts semaphores *)
);


type
descriptor_ix = 1..vc_l;

var
inc_name  : alfa;
desc_ix   : descriptor_ix := 1;
no_of_inc : 0..vc_l       := 0;
result    : result_range  := accepted;

ch_desc   : array( descriptor_ix ) of
record
chann  : byte;
main   : integer;
shad   : shadow
end;

msg       : reference;
opzone    : zone;
\f


process vagt_sim( op_sem: sempointer;
var
sem: !ts_pointer_vector;
main, vagt_int1, vagt_int2, vagt_int3, vagt_int4, lam_sem_no: !integer );


var
l, vl : 0..1;            (*  løbenumre   *)
lamstate,
oldstate,
austate,
databits : byte:= 0;
func: funktion;
lastanswer,
answer: respons := respons ( 0, 0, 10 );
sample,
newdata,
timeout,
h         : integer := 0;
dummy,
line_ready : boolean := false;
letter,                          (*  message from keyboard  *)
note : array (0..4) of byte;     (*  message from vccon     *)
msg: reference;

writepool: pool no_writes of filebuffer;
readpool : pool no_reads of filebuffer;
timerpool : pool 1;

opzone : zone;

portno: byte;          (*  lam channel  *)
linecount : integer:= 0;

tty : filezone := filezone ( ?, ?, ?, ?, 18, 1, 1, ttylength );
kb  : filezone := filezone ( ?, ?, ?, ?, 17, 1, 1, ttylength );

clockpool : pool 1 of ts_time;    (*  to get time   *)
clock_msg : reference;
\f


procedure open_file ( var f: filezone;  driv, answ, vacant: integer; 
 bufs : integer; var reso : pool 1; v1, v2: byte );
begin
with f do
begin
driver:= driv;
answer_sem:= answ;
free:= vacant;
u1val:= v1;
u2val:= v2;
while bufs > 0 do
begin
alloc ( cur, reso, sem(answer_sem).s^);
cur^.u1:= u1val;
cur^.u2:= 0;
signal ( cur, sem(free).s^ );
bufs:= bufs-1
end;
end
end;



procedure outblock ( var f: filezone);
begin
with f do
begin
(*q testout ( opzone, "outblock    ", next-1 ); q*)
lock cur as buf: filebuffer do
begin
buf.first:= 1;
buf.last:= next-1;
end;
cur^.u1:= u1val;
cur^.u2:= u2val;
signal ( cur, sem(driver).s^)
end
end;
\f


procedure file_error ( var f: filezone);
begin
lamstate:= f.cur^.u2;
if (lamstate<>0) and (lamstate<>5) then
austate:= lamstate;
end;



procedure outchar ( var f: filezone;  character: char );
begin
with f do
begin
if nil ( cur ) then 
begin
wait ( cur, sem(answer_sem).w^);
lamstate:= 0;
if cur^.u2 <> ok then file_error ( f) else austate:= 0;
next:= 1
end;
lock cur as buf: filebuffer do buf.text(next):= character;
next:= next+1;
if next > top then outblock ( f);
end;
end;



procedure print_head ( j: integer);
forward;

procedure outnewline ( var f: filezone );
begin
if linecount > pagesize then print_head ( 14);
outchar ( f, nl);
outchar ( f, cr);
linecount := linecount + 1;
end;
\f



procedure outinteger ( var f: filezone; bin: integer );
begin
end;



procedure outalfa ( var f: filezone; text: alfa);
var   i: integer;
begin
for i:= 1 to alfalength do outchar ( f, text(i));
end;


procedure outfill ( var f: filezone; filler: char;  rep: integer );
begin
while rep > 0 do
begin
outchar ( f, filler);
rep:= rep-1
end;
end;

procedure inblock ( var f: filezone;  var res: reference );
(*  called when res is an read_answer   *)
begin
with f do
begin
if not nil ( cur) then signal ( cur, sem(free).s^);
cur :=: res;
lamstate:= 0;
if cur^.u2 <> ok then file_error ( f) else austate:= 0;
next:= 1
end;
end;

function readchar ( var f: filezone): char;
begin
with f do
lock cur as buf: filebuffer do  with buf do
if next < nextfree then
begin
readchar:= text(next);   next:= next+1
end else readchar:= cr
end;
\f


function readinteger ( var f: filezone): integer;
const
digits = (. "0".."9" .);
var
t: char;
i, v: integer:= 0;
begin
with f do
begin
repeat
t:= readchar ( f)
until ( t in digits ) or (t = cr );
if t = cr then readinteger := -1  else
begin
while t in digits do
if i = 4 then    (* only 4 digits allowed *)
t:= cr
else
begin
i:= i + 1;
v:= 10*v+ord(t)-ord("0");
t:= readchar ( f)
end;
readinteger:= v
end
end
end;
\f


function gettime : ts_time;
begin
signal ( clock_msg, sem(timeout_sem_no).s^ );
wait   ( clock_msg, sem(vagt_int2).w^ );
lock     clock_msg as buf: ts_time do
gettime:= buf;
end;



procedure puttime ( hh, mm : integer );
(*  set time in timeout module    *)
begin
clock_msg^.u1:= 5;      (*  writecontrol  *)
lock clock_msg as buf: record h,m: integer end  do
begin
buf.h:= hh;
buf.m:= 100*mm
end;
signal ( clock_msg, sem(timeout_sem_no).s^ );
wait ( clock_msg, sem(vagt_int2).w^ );
clock_msg^.u1:= 2
end;


procedure bindec ( bin: integer; var digits: alfa);
(*  binary to decimal conversion,  at least 2 digits    *)
const
blank = "            ";
var
sign : char := " ";
pos: integer:= alfalength;    (*  index in digits  *)
negative : boolean;

begin
digits:= blank;
negative:= bin<0;
bin:= abs( bin);
repeat
digits(pos):= chr(bin mod 10 + ord("0"));
bin:= bin div 10;
pos:= pos-1
until (bin=0) and (pos<=12-2);
if negative then digits(pos):= "-";
end;
\f


procedure print_num ( bin: integer; leng: integer);
var   i: integer;
 number: alfa;
begin
bindec ( bin, number);
for i:= alfalength+1-leng to alfalength do outchar ( tty, number(i));
end;


procedure print_time;
forward;

procedure printbell;        (*  called at poll timeout    *)
begin
if line_ready then
begin
outnewline ( tty);
print_time;
outalfa ( tty, "vagt stoppet");
outchar ( tty, sp)
end;
outchar ( tty, "*");
outchar ( tty, bel);
outblock ( tty);
timeout:= maxtime;
line_ready:= false
end;

procedure print_head ( j: integer);
var   i : integer;
begin
outfill ( tty, nl, j);
outchar ( tty, cr);
for i:= 1 to headn do outalfa ( tty, head(i));
outchar ( tty, nl);
outchar ( tty, cr);
outblock ( tty);
linecount:= 9
end;
\f


procedure print_time;
var   time: ts_time;
begin
time:= gettime;
outfill ( tty, sp, 2);
print_num ( time(0), 2);
outchar ( tty, ".");
print_num ( time(1) div 100, 2);
outchar ( tty, ".");
print_num ( time(1) mod 100, 2);
outfill ( tty, sp, 2);
end;

procedure print_alfa ( text: alfa );         (*  print clock and alfa  *)
begin
print_time;
outalfa ( tty, text);
outnewline ( tty);
outalfa ( tty, empty);
outblock ( tty);
end;
\f


procedure print_alarm;
var   i, n: integer;
begin
outnewline ( tty);
print_time;
if ( note(1)=#h64 ) and ( note(3)=stop_code ) then note(1):= #h65;
(*  search text  *)
i:= 0;
repeat
i:= i+1;
until (tekst(i).no=note(1)) or (i=last_text_no);

(*  the next cannot be done by a real vagt     *)

outalfa ( tty, tekst(i).tx);
outfill ( tty, sp, 2);
print_num ( note(1) div 16, 2);
outchar ( tty, ".");
print_num ( note(1) mod 16, 2);
case note(1) of
#h72 : (* nothing *)
otherwise
begin
outfill ( tty, sp, 2);
print_num ( note(2), 3);
end;
end;
case note(1) of
#h62,#h64,#h65,#h66,#h72 : (* nothing *)
otherwise
begin
outfill ( tty, sp, 3);
print_num ( note(3), 3);
end;
end;
outblock ( tty);

if note(1) = #h32 then     (* statusalarm *)
begin
n := note(3);
if n = 0 then
begin
outnewline ( tty);
outfill ( tty, sp, 12);
outalfa ( tty, statustxt(0));
outblock ( tty)
end
else
for i := 7 downto 1 do
begin
if (n mod 2) = 1 then
begin
outnewline ( tty);
outfill ( tty, sp, 12);
outalfa ( tty, statustxt(i));
outblock ( tty)
end;
n := n div 2
end;
end;
outnewline ( tty);
outalfa ( tty, empty);
outblock ( tty);
sample:= 0;
end;

\f


procedure print_text_val ( text: alfa; val: integer );
begin
print_num ( val, 3);
outalfa ( tty, text );
outnewline ( tty);
end;

procedure send_read ( var f: filezone);
begin
with f do
begin
if open ( sem(free).w^) then wait ( cur, sem(free).w^);
if not nil(cur) then
begin
lock cur as buf: filebuffer do 
begin
buf.first:= 1;
buf.last:= top-1;
buf.nextfree:= 1
end;
cur^.u1:= u1val;
cur^.u2:= u2val;
signal ( cur, sem(driver).s^);
end
end
end;
\f


procedure read_command ( var newdata: integer);
var
error, i : integer;
com: command;

begin
newdata:= 0;
for i:= 1 to 4 do com(i):= readchar( kb);
error:= 0;
linecount := linecount + 1;
if com(1) <> cr then
begin
i:= 0;
repeat
i:=i+1
until (menu(i)=com) or (i=last_com_no);
if i < last_com_no then letter(3):= opkode(i)
else error:= 1;

if error=0 then
begin
if (letter(3)=7) or (letter(3)=8) then
i:= 0
else
i:= readinteger ( kb);
if (i<0) or (255<i) then error:= 2 else
begin
letter(2):= i;
                       (*  make default letter(1)    *)
case letter(3) of
1,2,
5,7,
21,22,
 24:   letter(1):= 0;
3,4,
6,8,
23,25 : letter(1):= 1
otherwise
begin
i:= readinteger ( kb);
if (i<0) or (255<i) then error:= 3 else
letter(1):= i;
end
end
end;
end;
signal ( kb.cur, sem(kb.free).s^);

if error > 0 then
begin
print_alfa ( whatx(error));
send_read ( kb)
end
else
if letter(3) = #hc4 then   (*  set time  *)
begin
puttime ( letter(2), letter(1));
end  else
newdata:= 3;
end;

if (newdata = 0) and (error = 0) then
begin
outnewline ( tty);
outalfa ( tty, empty);
outblock( tty);
send_read ( kb)
end;
end;

\f



(*----------------------- main program ----------------------------*)

begin

testopen ( opzone, own.incname, op_sem);
testout ( opzone, own.incname, al_env_version);


(*       wait for lam reservation        *)

vl := 1;
timeout:= 40;
h:= ille;
repeat
wait ( msg, sem( main).w^ );
if msg^.u1 = create_at_ch then        (*  start at lam channel  *)
begin
portno:= msg^.u2;
alloc ( clock_msg, clockpool, sem(vagt_int2).s^ );
clock_msg^.u1:= create_tty_ch;
clock_msg^.u2:= portno;
clock_msg^.u3:= 33;        (*  <> 0  *)
lock clock_msg as buf: createshape do
begin
buf.contr:= 2+4+16+32;     (*  even 7bit 2stop 300 bps   *)
buf.timer:= 60;
end;
signal ( clock_msg, sem(lam_sem_no).s^ );
wait ( clock_msg, sem(vagt_int2).w^ );
msg^.u2:= clock_msg^.u2;
return ( msg);
h:= ok;
end  else
begin
msg^.u2:= ille;   return( msg)
end
until h = ok;
\f


open_file (  kb, lam_sem_no,  main, vagt_int4, no_reads, readpool, 17, portno);
open_file ( tty, lam_sem_no, vagt_int1, vagt_int3, no_writes, writepool, 18, portno);

with tty do
while open ( sem(free).w^) do
begin
wait ( msg, sem(free).w^ );
signal ( msg, sem(answer_sem).s^ )
end;

clock_msg^.u1:= 2;     (*  read  *)

alloc ( msg, timerpool, sem( main ).s^ );
msg^.u1:= read_write;        msg^.u2:= 0;
msg^.u3:= delay1;   msg^.u4:= delay2;
sendtimer ( msg);
outchar( tty, cr);
outalfa( tty, "/ vagt      ");
outalfa( tty, version);
print_head ( 2);
\f



(*----------------------- main loop ---------------------------*)

repeat

wait ( msg, sem( main ).w^ );

if ownertest ( readpool, msg) then      (*  read terminated   *)
begin
(*q testout ( opzone, "keyboard    ", msg^.u2 ); q*)
inblock ( kb, msg);
if lamstate <> 0 then
send_read ( kb )
else
read_command ( newdata);
end  else

if ownertest ( timerpool, msg) then      (*  from timer        *)
begin
msg^.u1:= 6;        msg^.u2:= 0;
msg^.u3:= delay1;   msg^.u4:= delay2;
sendtimer ( msg);
if timeout > 0 then
begin
timeout:= timeout-1;
if timeout = 0 then  printbell    (*  no poll in maxtime*delay1 sec  *)
end
end  else

if msg^.u3 = dummy_route then  return ( msg)
else

if msg^.u1 = 11 then                      (*  from vccon       *)
begin
lock msg as buf: telegram do  with buf do
begin
databits:= inf;
func    := fnc;
l       := lnr
end;
\f



(*------------------- at protocol answer ----------------------------*)

if not line_ready then vl:= l;   (* all l accepted *)
if l <> vl then
begin
testout ( opzone, "l <> vl     ", vl);
answer:= lastanswer
end
else
begin
vl:= 1-vl;
with answer do
if austate <> oldstate then      (*  status  *)
begin
info:= austate;
opko:= status;
oldstate:= austate
end  else
case func of

poll:  begin
timeout:= maxtime;
if not line_ready then
begin
outnewline ( tty);
print_alfa ( klar );
end;
line_ready:= true;
if newdata = 0 then info:= 0  else
info:= letter(newdata);
opko:= reply(newdata);
if newdata > 0 then
begin
newdata:= newdata-1;
if newdata = 0 then     (*  message send    *)
begin
outalfa ( tty, empty);
outblock ( tty)
end;
end;
if newdata = 0 then send_read ( kb);
end;   (*  poll  *)

data:  begin
timeout:= maxtime;
if sample > 0 then
begin
sample:= sample+1;
note(sample):= databits
end;
if sample = 3 then print_alarm;
info:= databits;
opko:= d_ack
end;

opr:  begin
timeout:= maxtime;
sample:= 1;
note(1):= databits;
info:= databits;
opko:= t_ack
end;

test_i:  begin
timeout:= maxtime;
if austate = 0 then info:= test_ok else info:= test_error;
opko:= t_ack
end
end (* of case on func *)
end;   (*  l=vl  *)

lastanswer:= answer;
letter(0):= answer.info;
msg^.u2 := ok;

lock msg as buf : respons do
buf:= answer;
dummy:= check5 ( msg, generate);

return ( msg)
end   (*  from vccon   *)   else

begin
testout ( opzone, "illegal msg ", msg^.u1 );
msg^.u2:= ille;   return ( msg)
end

until forever 

end; (* process vagt_sim *)
\f


function find_ch( ch: byte; var desc_ix: descriptor_ix ): boolean;

begin
desc_ix:= 1;

while ( desc_ix < vc_l ) and ( ch <> ch_desc( desc_ix ).chann ) do
desc_ix:= desc_ix + 1;

find_ch:= ( ch = ch_desc( desc_ix ).chann )
end; (* function find_ch *)
\f



begin (* process vagt *)
testopen( opzone, own.incname, op_sem );
testout( opzone, version, al_env_version );

for desc_ix:= 1 to vc_l do
with ch_desc( desc_ix ) do
chann:= 255;

repeat (* forever *)

wait( msg, sem( vas_sem_no ).w^ );

with msg^ do
begin
if ( u1 = create_at_ch ) then
begin
if find_ch( u2, desc_ix ) then
begin

testout( opzone, "reuse chann ", u2 );
u2:= 0;
return( msg )

end
else
begin
if ( no_of_inc = vc_l ) then
begin
testout( opzone, "vagt_sim >  ", vc_l );
release( msg )  (* <<<<<<<<<<<<<<<<<<<<<<<< OBS! *)
end
else
begin
no_of_inc:= no_of_inc + 1;
with ch_desc( no_of_inc ) do
begin
chann:= u2;
main:= vagt_int + ( no_of_inc - 1 ) * 5;
inc_name:= "vagt ch     ";
inc_name( 9 ):= chr( u2 div 10 + ord( "0" ) );
inc_name( 10 ):= chr( u2 mod 10 + ord( "0" ) );

result:= create( inc_name, vagt_sim( op_sem, sem, main,
main + 1, main + 2, main + 3, main + 4, lam_sem_no ),
shad, inc_size );

if result = 0 then
begin
start( shad, vc_sim_pri );
signal( msg, sem( main ).s^ )
end
else
testout( opzone, "create error", result )
;
end
end
end
end
else
begin
if find_ch( u2, desc_ix ) then
signal( msg, sem( ch_desc( desc_ix ).main ).s^ )
else
testout( opzone, "channel     ", u2 )
end
end (* with msg^ *)

until forever

end. (* process vagt *)
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦ef4584c9f⟧ TextFile

Derivation

TextFile
