|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 13824 (0x3600)
Types: TextFile
Names: »tslibjob«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »tslibjob«
job hj 6 200 time 11 0 area 12 size 100000 perm disc1 200 3
message ts lib job
( source = copy 25.1
listi = indent source mark lc
listc = cross listi
o errors
message ts lib
pascal80 spacing.1000 codesize.1000 alarmenv source
o c
lookup pass6code
if ok.yes
(
tslib = set 1 disc1
tslib = move pass6code
scope user tslib
)
tsliblst = copy listc errors
scope user tsliblst
pliblookup tslib
convert errors
finis )
\f
prefix timerbook;
procedure timerbook ( (* makes a booking *)
var msg, (* booking and update msg *)
timer_msg: reference; (* module timeout *)
ticks, (* tick counter value *)
object: integer; (* module ident *)
var timeout_sem, (* timeout semaphore *)
answer: semaphore); (* answer sem of msg *)
const
writecontrol= 5; (* function for timeout *)
rwcontrol= 7; (* - - booking *)
op1202= 12*16+2; (* opcode - timeout *)
op1203= 12*16+3; (* - - booking *)
type
updates= record index, count, obj: integer end;
timers= record object: integer end;
begin
timer_msg^.u1:= rwcontrol;
timer_msg^.u3:= msg^.u3;
timer_msg^.u4:= op1202;
msg^.u1:= writecontrol;
(* msg^.u3 must be initialized by yourself *)
msg^.u4:= op1203;
lock msg as buf: updates do with buf do
begin
count:= ticks;
obj:= object
end;
push ( timer_msg, msg);
signal ( msg, timeout_sem );
wait ( msg, answer);
end; (* of timer_book *)
\f
prefix timerupdate;
procedure timerupdate ( (* makes an update *)
var msg: reference; (* update msg *)
ticks: integer; (* tick counter value *)
var timeout_sem, (* timeouts input sem *)
answer: semaphore ); (* answer sem of msg *)
(* updates the tickcounter for the module *)
(* pointed to by buf.index in the msg *)
const
write= 4; (* function for update *)
op1204= #hc4; (* opcode - update *)
type
updates= record index, count, object: integer end;
begin
msg^.u1:= write;
msg^.u4:= op1204;
lock msg as buf: updates do buf.count:= ticks;
signal ( msg, timeout_sem );
wait ( msg, answer);
end; (* of timer_update *)
\f
prefix testopen;
procedure testopen (
var z: zone;
modulename: alfa;
ps: ^semaphore);
type
opbuftype= record
first,
last,
next: integer;
name: alfa;
data: array (1..80) of char;
end (* opbuftype *);
var
opref: reference;
opbuf: opbuftype;
i: integer;
\f
begin
z.opsem:= ps;
while openpool(z.testoutpool) do
begin
alloc (opref, z.testoutpool, z.testoutsem);
opref^.u1:= 2;
lock opref as opbuf: opbuftype do
with opbuf do
begin
first:= 6+alfalength;
next:= 1;
name:= modulename;
end (* with opbuf do *);
return(opref);
end; (* while openpool *)
end (* testopen *);
\f
prefix testout;
(*****************************************************************
*
* function: this procedure is used to produce testoutput to
* the operators console from within a pascal-80
* process.
*
* externals: none
*
* environment: testenv
*
* note: the used zone must be opened by a call of the
* procedure "open".
*
* programmed may 1980 by wib and stb.
*
******************************************************************)
\f
procedure testout(var z:zone; text:alfa; i:integer);
(* the procedure writes the text followed by the value of i
on the operator console.
example:
the call:
_ i:=7;
_ testout(z, "value is ",i);
yields the following output:
_ value is 7
*)
type
opbuftype = record
first, last, next: integer;
name: alfa;
data: array(1..80) of char;
end;
var
opbuf: opbuftype;
opref: reference;
\f
procedure outchar(ch: char);
(* writes ch into the output buffer *)
begin
lock opref as opbuf: opbuftype do
with opbuf do
begin
data(next):= ch;
next:= next + 1;
end;
end (* outchar *);
\f
procedure outinteger(int,positions:integer);
(* writes the integer "int" into opbuf starting at
"outputpoint", which is updated accordingly *)
const
maxpos = 20; (* max number of positions in layout *)
base = 10;
var
digits:array(1..maxpos) of char;
used,i:integer;
negative:boolean;
begin
used:= 1;
(* first we initialise the digits array *)
for i:=1 to maxpos do digits(i):=sp;
i:=maxpos;
negative:= int<0;
repeat
(* now we unpack the digits backwards and put them
into the digits array *)
digits(i):= chr(abs(int mod base) + ord("0"));
int:=int div base;
i:=i-1;
until (i=1) or (int=0);
if negative then
begin
digits(i):="-";
i:=i-1;
end;
used:=maxpos-i;
if int <> 0 then digits(1):= "*";
(* i næste linje skal 20 erstattes af maxpos !!!!!!!!!!!!!!!!!!!!!!!*)
if (not (positions in (. 1 .. 20 .)) )
or (positions < used) then
positions:=used;
for i:=maxpos+1-positions to maxpos do
outchar( digits(i) );
end (* out integer *);
\f
procedure outstring(text: alfa);
(* writes the text into opbuf starting at opbuf.next
which is updated accordingly *)
var
i: integer;
begin
for i:=1 to alfalength do
outchar( text(i) );
end (* out string *);
\f
begin
(**********************************************
*
* m a i n p r o g r a m
*
************************************************)
wait(opref, z.testoutsem);
lock opref as opbuf: opbuftype do
opbuf.next:= 1;
outstring(text);
outinteger(i,4);
outchar(nl);
lock opref as opbuf: opbuftype do
with opbuf do
last:=next+16;
opref^.u2:= 0;
signal(opref, z.opsem^);
wait(opref,z.testoutsem);
return(opref);
end (* test out *);
\f
prefix check5;
function check5(
var msg: reference; (* reference to telegram in question *)
dowhat: what (* what must be generate or check *)
): boolean; (* false if check says fault *)
(********************************************************************
*
* function: the check5 module either inserts a calcula-
* ted checksum into a telegram or controls the tele-
* gram with the aid of the checksum.
*
* externals: none.
*
* parameters: msg is the reference to the telegram to check or to generate
* checkbits in
* dowhat says insert a checksum (=generate) or control the
* telegram of the buffer (=check).
*
* semaphores: none.
*
* version: 1/04
*
* programmed may 1980 by srs
*
********************************************************************)
\f
type
telegram_type = set of 0..15; (* 16 bits *)
(* 0 1 2 3 4 5 6 7 8 9 A B C D E F *
* I---------------I---I-I---------I *
* I data opc l check I *
* I---------------I---I-I---------I *
* *
* *)
var
check_telegram ,
calculated_sum ,
add_to_sum : telegram_type;
bit_c5 ,
bitno : integer;
\f
function getbit( i: integer ): telegram_type;
(* Here we have the checkcode table *)
begin
case i of
0: getbit:= (. 11..15 .); (* 11111 *)
1: getbit:= (. 12..15 .); (* 01111 *)
2: getbit:= (. 11,13,15 .); (* 10101 *)
3: getbit:= (. 13..15 .); (* 00111 *)
4: getbit:= (. 11,12,14,15 .); (* 11011 *)
5: getbit:= (. 12,14,15 .); (* 01011 *)
6: getbit:= (. 11,14,15 .); (* 10011 *)
7: getbit:= (. 11,12,13,15 .); (* 11101 *)
8: getbit:= (. 12,13,15 .); (* 01101 *)
9: getbit:= (. 11,13,14,15 .); (* 10111 *)
10: getbit:= (. 11,12,15 .) (* 11001 *)
end (* case *);
end (* of getbit function *);
\f
function lxor( a, b: telegram_type ): telegram_type;
(************************************************************
* This Exclusive OR function operates on 16-bits at the *
* same time by use of set operations. *
************************************************************)
begin
lxor:= (a+b)-(a*b);
end (* of xor function *);
\f
begin (**************************************
*** ***
*** the body of the check5 module ***
*** ***
**************************************)
calculated_sum:= (. 12,14 .); (* (12,14) corresponds to 01010 *)
lock msg as telegram: telegram_type do
begin
(***************************************************
* the meaning of the next for-statement:
* step through the telegram. for every one bit
* change the checksum with a tabular value belon-
* ging to that bitposition.
***************************************************)
for bitno:=0 to 10 do
if bitno in telegram then
begin
add_to_sum:= getbit( bitno );
calculated_sum:= lxor( calculated_sum, add_to_sum )
end;
(*********** adjust bit_c5 ***********************)
bit_c5 := 0;
for bitno := 11 to 15 do
if bitno in calculated_sum then
bit_c5 := bit_c5 + 1;
if (bit_c5 mod 2) = 0 then
calculated_sum := calculated_sum - (. 15 .)
else
calculated_sum := calculated_sum + (. 15 .);
(****** the generated telegram ******************)
check_telegram := (telegram - (. 11..15 .)) + calculated_sum;
check5:= true;
if dowhat = generate then (* apply the checksum to the telegram *)
telegram := check_telegram
else (* check the telegram *)
begin
add_to_sum:= lxor( telegram, check_telegram );
if add_to_sum = (..) then
check5:= true
else
check5:= false;
end
end (* of lock statement *)
end (* of check5 function *);
\f
prefix count;
(*------------------------- count ---------------------------------*)
procedure count ( var c : integer );
var oldmask : boolean;
function getoflowmask : boolean;
external;
procedure setoflowmask ( m: boolean );
external;
begin
oldmask:= getoflowmask;
setoflowmask ( true); (* now overflow is harmless *)
c:= c + 1;
if c < 0 then c:= 0;
setoflowmask ( oldmask)
end; (* of count *)
\f
<*
prefix swap_address;
(*---------------------- swap_address ---------------------------------*)
procedure swap_address(
var
address1 ,
address2 : alarmnetaddr
);
(*------------------------------------------------------------------------
. function : Swaps the content of two alarm net addresses
.
--------------------------------------------------------------------------*)
var
work_address : alarmnetaddr;
begin
work_address:= address2;
address2:= address1;
address1:= work_address
end; (* procedure swap_address *)
*>
\f
prefix receipt_message;
(*---------------------- receipt_message -------------------------------*)
procedure receipt_message(
var
msg : reference;
var
receiver_sem : !sempointer;
route : byte;
noofby_modif : integer;
result_code : result_range
);
(*-------------------------------------------------------------------------
.
. function : Swaps the addresses of receiver and sender and updates the
. result of the alarmlabel.
. Updates route according to call and adds 1 to the operation
. code, forming a receipt.
. No_of_by is updated with noofby_modif.
. The message is signalled to the receiver semaphore.
.
--------------------------------------------------------------------------*)
var
work_addr : alarmnetaddr;
<*
procedure swap_address( var addr1, addr2: alarmnetaddr );
external;
*>
begin
lock msg as locvar: alarmlabel do
with msg^, locvar do
begin
u3:= route;
if ( u4 < max_byte ) then
u4:= u4 + receipt;
no_of_by:= no_of_by + noofby_modif;
<*
swap_address( rec, send );
*>
work_addr:= rec;
rec:= send;
send:= work_addr;
result:= result_code
end; (* lock msg *)
signal( msg, receiver_sem^ )
end; (* procedure receipt_message *)
\f
prefix reject_message;
(*--------------------- reject_message ---------------------------------*)
procedure reject_message(
var
msg : reference;
var
receiver_sem : !sempointer;
route : byte;
sender_macro : macroaddr;
sender_micro : integer;
result_code : result_range
);
(*-------------------------------------------------------------------------
.
. function : Handles a unrecognizable message. The ( supposed ) original label is
. copied to the data part and a new label, where receiver
. is the original sender and sender the address of the
. incarnation in question, is established.
. The message is released in case of size troubles, otherwise
. it's signalled to the receiver semaphore.
.
--------------------------------------------------------------------------*)
type
garbage_type = array( 0..1 ) of alarmlabel;
begin
with msg^ do
if ( size < ( label_size + 2 ) ) then
release( msg )
else
begin
lock msg as locvar: garbage_type do
begin
locvar( 1 ):= locvar( 0 );
with locvar( 0 ) do
begin
no_of_by:= 2 * label_size + 2;
rec:= send;
send.macro:= sender_macro;
send.micro:= sender_micro;
op_code:= #h12;
result:= result_code
end;
with locvar( 1 ) do
op_code:= u4;
u3:= route;
u4:= #h12
end;
signal( msg, receiver_sem^ )
end
end; (* procedure reject_message *)
\f
.
▶EOF◀