|
DataMuseum.dkPresents historical artifacts from the history of: RC3500 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC3500 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 20736 (0x5100)
Types: TextFileVerbose
Names: »ww«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system
└─⟦72244f0ef⟧
└─⟦this⟧ »ww«
job jg 8 200 time 6 0 area 10 size 100000
(source= copy 25.1
festrlst=set 1 disc1
festrlst= indent source mark lc
listc= cross festrlst
o errors
head 1
message festr program
pascal80 spacing.3000 codesize.3000 evaenv alarmenv feaosenv source
o c
lookup pass6code
if ok.yes
(festrbin= set 1 disc1
festrbin= move pass6code
scope user festrbin
)
festrlst= copy listc errors
scope user festrlst
convert errors
finis
)
process streamer(
var input_sem, xmitter, receiver : ! ts_pointer;
retrans_max : integer;
op : sempointer);
const
output_buffers = 2;
input_buffers = 2;
own_data_size = 8; (* bytes *)
sense_com = 0;
write_data = 2;
write_read_data= 3;
regret_input = 4;
input = 5;
output = 6; <* output = input + 1 is demanded *>
tell_next_notice=8;
read_stream = 9;
write_stream =10;
regret_output =12;
const
chain_in = 8;
chain_out = 8;
restart_notices= 1;
noticed_output = 2;
received_input = 3;
ready_request = 4;
free_in = 5;
free_out = 6;
chain_max = 6 + chain_in + chain_out;
type
chain_rec = record
next, prev, c_stream, c_func : byte;
ref : reference;
end;
chain_mem = array(1..chain_max) of chain_rec;
var
chain : chain_mem;
const
request = 0;
notice = 0;
master_out = 1;
no_stream = 0;
max_stream =63;
stream_size =max_stream + 1;
master_block = 256 div stream_size - 1;
master_size = 2;
buffer_size = stream_size div master_size;
ok_result = 0;
rejected = 1;
soft_error = 2;
(* *) blocklength_error = 64;
hard_error = 3;
un_intelligible= 4;
master = 5;
overload = 6;
max_integer = 32767;
type
data_buffer = record
first, last, next : integer;
end;
own_data = record
first, last, next : integer;
d : array(1..own_data_size div 2) of integer;
end;
var
header, sense_device, desc_header, message : reference;
waiting_output,
out_desc_sem,
pending_input, in_desc_sem : semaphore;
output_stopped, input_stopped: boolean;
notices_received: packed array(0..max_stream) of byte ;
xmit_pool : pool output_buffers + output_buffers;
sense_pool : pool input_buffers + output_buffers;
receive_pool : pool input_buffers + buffer_size;
message_pool : pool input_buffers of own_data;
operation, result, status, stream , result_modif,
output_block_no, input_block_no : integer;
procedure move_element(from, into : integer);
var fn, fp, tn : integer;
begin
with chain(into) do
begin
tn := next; next := from;
end;
with chain(from) do
begin
fn := next; fp := prev;
next := tn ; prev := into;
end;
chain(fp).next := fn ;
chain(fn).prev := fp ;
chain(tn).prev := from;
end (* procedure move chain-element *) ;
function search_sem(var s: semaphore): integer;
var stream, stop : byte;
begin
with message^ do
begin
stop := u1; stream := u3;
end;
search_sem := 0;
repeat
signal(message, s);
wait(message, s);
with message^ do
if u1 <> stop then
if u3 div stream_size <> master_block then
if u3 mod stream_size = stream then search_sem := 1;
until stop = message^.u1;
end (* procedure to find a specific stream request on a semaphore *) ;
function search_chain(start, stream, func_code : integer; no_regret:boolean) : integer;
var last, s, f : byte;
begin
search_chain := 0;
last := start;
start := chain(start).next;
while start <> last do
with chain(start) do
begin
if nil(ref) then
begin
s := c_stream; f := c_func;
if no_regret then f := sense_com;
end else
with ref^ do
begin
s := u3; f := u1;
end;
if (s = stream) and (f = func_code) then
begin
search_chain := start;
start := last ;
end else
begin
start := next ;
end;
end;
end (* procedure search chain for stream-number *) ;
procedure decode_message(var operation, result : integer);
var user_result, block_no : integer;
label comp_result;
begin
pop(header, message);
with header^ do
begin
result := u2 mod 8;
result_modif := u2 - result;
if u1 = write_read_data then
begin
user_result := ok_result;
operation := u4 mod master_size + input;
comp_result:
case result of
ok_result, soft_error:
begin
block_no := u3 div stream_size;
if block_no = master_block then
begin
result := master;
end else
if block_no <> u4 div stream_size then
begin
result := master;
end;
end;
▶18◀ hard_error: ;
rejected : ;
otherwise begin
user_result := un_intelligible;
result := result - un_intelligible;
goto comp_result;
end;
end;
end else
begin
operation := u1;
user_result:= u2;
push(header, message);
end;
end;
if not nil(message) then
begin
message^.u2 := user_result;
end;
end (* decode the received message *) ;
procedure next_notice(var stream : integer);
var r : reference;
ptr : integer;
begin
with chain(restart_notices) do
if prev <> restart_notices then
begin
stream := chain(next).ref^.u3;
move_element(next, chain(noticed_output).prev);
end else
with chain(free_out) do
if prev = free_out then
begin
stream := no_stream;
end else
begin
sensesem(r, waiting_output);
if nil(r) then
begin
stream := no_stream;
end else
begin
stream := r^.u3;
ptr := search_chain(noticed_output, stream, write_stream, false);
if ptr = 0 then ptr := next else
if not nil(chain(ptr).ref) then ptr := next;
chain(ptr).ref :=: r;
if ptr = next then
move_element(next, chain(noticed_output).prev) else
stream := no_stream;
end;
end;
end (* procedure to find the next notice *) ;
procedure return_output(result : integer);
begin
if not nil(message) then
begin
with message^ do u2 := u2 + result;
return(message);
end;
end (* procedure to return output-data to the user *) ;
procedure xqt_request;
var stream, ptr : integer;
begin
stream := header^.u3 mod stream_size;
if stream <> no_stream then
begin
ptr := search_chain(noticed_output, stream, write_stream, false);
message :=: chain(ptr).ref ;
move_element(ptr, free_out);
end;
end (* procedure to find the requested data *) ;
procedure xmit(operation, status : integer);
var block_no, stream, buffers : integer;
begin
if operation = notice then
begin
block_no := output_block_no mod 3;
buffers := 0;
next_notice(stream);
end else
begin
stream := output_buffers*master_size + status;
block_no:= master_block;
buffers := output_buffers;
alloc(sense_device, sense_pool, input_sem.w^);
sense_device^.u1 := sense_com;
signal(sense_device, xmitter.s^);
end;
desc_header^.u3 := block_no*stream_size + stream;
with header^ do
begin
u1 := write_read_data;
u3 := desc_header^.u3;
u4 := block_no*stream_size + buffers*master_size + 1;
end;
signal(desc_header, out_desc_sem);
push(header, message);
signal(message, xmitter.s^);
if output_block_no = max_integer then output_block_no := -1;
output_block_no := output_block_no + 1;
end (* procedure to send a new data-buffer to the transmitter *) ;
procedure restart_xmitter(receiver_buffers : integer);
var ptr : integer;
begin
ptr := restart_notices;
with chain(noticed_output) do
while noticed_output <> prev do
begin
move_element(next, ptr);
ptr := chain(ptr).next ;
end;
output_stopped := false;
output_block_no := 0;
for ptr := 1 to output_buffers do
begin
alloc(desc_header, xmit_pool, out_desc_sem);
alloc(header, xmit_pool , input_sem.w^);
xmit(notice, 0);
end;
end (* restart of the transmitter *) ;
function master_match(var received, xmitted : integer): boolean;
begin
master_match := false;
with desc_header^ do
if u3 div stream_size = master_block then
begin
master_match := true;
xmitted := u3 mod master_size;
if received = master then
received := header^.u3 mod master_size else
received := -1;
end;
end (* procedure to test if a master-out is answered with master-in *) ;
procedure return_input(result : integer);
begin
if not nil(message) then
begin
lock message as d:data_buffer do with d do
if next - first <= 1 then
begin
next := first;
if result = ok_result then result := rejected;
end;
with message^ do u2 := u2 + result;
return(message);
end;
end (* procedure to return input buffers to the user *) ;
procedure xqt_notice;
var stream, ptr, notice_no : integer;
begin
stream := header^.u3 mod stream_size;
if stream <> no_stream then
begin
notice_no := notices_received(stream);
if notice_no = 0 then
begin
ptr := search_chain(received_input, stream, read_stream, false);
if ptr = 0 then
begin
notice_no := 1;
ptr := search_chain(received_input, stream, tell_next_notice, false);
if ptr <> 0 then
begin
message :=: chain(ptr).ref;
message^.u2 := ok_result;
return(message);
move_element(ptr, free_in);
end;
end else
begin
move_element(ptr, chain(ready_request).prev);
end;
end else
begin
notice_no := notice_no + 1;
end;
notices_received(stream) := notice_no;
end;
end (* procedure to execute a notice *) ;
procedure place_input(el:integer; var in_ref: reference);
var stream, n : integer;
begin
stream := in_ref^.u3;
n := notices_received(stream);
if n > 0 then
begin
if in_ref^.u1 = tell_next_notice then
begin
n := 0;
end else
begin
notices_received(stream) := n -1;
n := ready_request;
end;
end else
begin
n := received_input;
end;
if n > 0 then
begin
chain(el).ref :=: in_ref;
move_element(el, chain(n).prev);
end else
begin
in_ref^.u2 := ok_result;
return(in_ref);
end;
end (* procedure to place incoming input-request *) ;
procedure next_request(var stream : integer);
begin
with chain(ready_request) do
if prev = ready_request then
begin
stream := no_stream;
end else
begin
message :=: chain(next).ref;
stream := message^.u3;
move_element(next, free_in);
end;
end (* procedure to find the next request *) ;
procedure send_input;
begin
wait(message, pending_input);
pop(desc_header, message);
signal(desc_header, in_desc_sem);
lock header as buf:own_data do
with buf do
begin
first := 6;
if nil(message) then last := own_data_size else last := 0;
last := first + last - 1;
next := first;
end;
push(header, message);
signal(message, receiver.s^);
input_block_no := (input_block_no + 1) mod 3;
end (* procedure to send the next input message *) ;
procedure receive(operation, status : integer);
var block_no, stream, buffers, expected_block : integer;
begin
if operation = request then
begin
buffers := 0;
block_no := input_block_no;
expected_block := (block_no+1)mod 3;
next_request(stream);
end else
begin
alloc(sense_device, sense_pool, input_sem.w^);
sense_device^.u1 := sense_com;
signal(sense_device, receiver.s^);
buffers := input_buffers;
stream := input_buffers*master_size + status;
block_no:= master_block;
expected_block := master_block;
end;
desc_header^.u3 := block_no*stream_size + stream;
with header^ do
begin
u1 := write_read_data;
u3 := desc_header^.u3;
u4 := expected_block*stream_size + buffers*master_size;
end;
push(desc_header, message);
signal(message, pending_input);
send_input;
end (* procedure to send the next receive-operation *) ;
procedure restart_receiver(buffering : integer);
var ptr : integer;
begin
ptr := received_input;
with chain(ready_request) do
while ready_request <> prev do
begin
move_element(next, ptr);
ptr := chain(ptr).next;
end;
for ptr := 0 to max_stream do
notices_received(ptr) := 0;
for ptr := 1 to buffering-1 do
begin
alloc(message, receive_pool, pending_input);
with message^ do
begin
u1 := 0; u2 := 0;
u3 := no_stream ;
end;
return(message);
end;
ptr := 1;
if not nil(desc_header) then
begin
with desc_header^ do
begin
u1 := 0; u2 := 0; u3 := no_stream;
end;
signal(desc_header, pending_input);
with header^ do
begin
u3 := (master_block*stream_size + input_buffers*master_size);
u4 := 0;
end;
send_input;
ptr := 2;
end;
input_block_no := 0; input_stopped := false;
for ptr := ptr to input_buffers do
begin
alloc(desc_header, receive_pool, in_desc_sem);
alloc(header, message_pool, input_sem.w^);
receive(request, 0);
end;
end (* procedure to restart the receiver *) ;
procedure test_master(trans_mitter : boolean; answer : integer);
var sent, count : integer;
begin
if master_match(answer, sent) then
begin
if answer = 0 then
begin
sent := (header^.u3 mod stream_size) div master_size;
if trans_mitter then
begin
release(header); release(desc_header);
restart_xmitter(sent);
end else
begin
restart_receiver(sent);
end;
end else
begin
if trans_mitter then count := -1 else count := 0;
if answer <> sent then
begin
sent := master_size;
count:= -1;
end;
sent := sent + count;
if trans_mitter then xmit(master_out, sent) else receive(master_out, sent);
end;
end else
begin
release(desc_header);
sent := (header^.u4 mod stream_size) div master_size;
if sent = 0 then
begin
release(header);
end else
begin
sent := sent*master_size + master_size - 1;
header^.u3 := master_block*stream_size + sent;
if trans_mitter then signal(header, xmitter.s^) else
if open(pending_input) then send_input else
signal(header, receiver.s^);
end;
end;
end (* procedure to master-clear the transmitter *) ;
procedure link_chain(head, start, stop : integer);
var i : integer;
begin
with chain(head) do
begin
next := start; prev := stop;
end;
for i := start to stop do
with chain(i) do
begin
next := i + 1;
prev := i - 1;
if i = start then prev := head;
if i = stop then next := head;
end;
end (* procedure to initialize a chain *);
begin
for input_block_no := 1 to chain_max do
with chain(input_block_no) do
begin
next := input_block_no; prev := next;
end;
link_chain(free_in, 7, 6 + chain_in);
link_chain(free_out, 7 + chain_in, chain_max);
restart_xmitter(1);
restart_receiver(1);
while true do
begin
wait(message, input_sem.w^);
decode_message(operation, result);
case operation of
sense_com,
write_data:
release(message);
regret_output:
begin
status := search_sem(out_desc_sem);
if status = 0 then
begin
status := search_chain(restart_notices, message^.u3, write_stream, true);
if status <> 0 then move_element(status, free_in) else
begin
status := search_chain(noticed_output, message^.u3, write_stream, true);
if status <> 0 then
with chain(status), ref^ do
begin
c_func := u1; c_stream := u3;
end;
end;
if status <> 0 then sense_device :=: chain(status).ref else
begin
status := search_sem(waiting_output);
if status <> 0 then
begin
stream := message^.u3;
repeat
if not nil(message) then signal(message, waiting_output);
wait(message, waiting_output);
operation := message^.u1;
if (message^.u3=stream) and (nil(sense_device)) then
sense_device :=: message;
until operation = regret_output;
end;
end;
if status <> 0 then status := ok_result else status := un_intelligible;
end else status := rejected;
message^.u2 := status;
push(message, sense_device);
return(sense_device);
end;
regret_input:
begin
status := search_sem(in_desc_sem);
if status = 0 then status := search_sem(pending_input);
if status = 0 then
begin
status := search_chain(ready_request, message^.u3, read_stream, false);
if status = 0 then
status := search_chain(received_input, message^.u3, read_stream, false);
if status = 0 then
begin
status := un_intelligible;
end else
begin
sense_device :=: chain(status).ref;
move_element(status, free_in);
status := ok_result;
end;
end else
begin
status := rejected;
end;
message^.u2 := status;
push(message, sense_device);
return(sense_device);
end;
write_stream:
signal(message, waiting_output);
read_stream, tell_next_notice:
with chain(free_in) do
if free_in = prev then
begin
with chain(received_input) do
if prev <> received_input then place_input(next, message);
message^.u2 := ok_result;
return_input(overload);
end else
begin
place_input(next, message);
end;
output:
begin
wait(desc_header, out_desc_sem);
if output_stopped then
begin
return_output(master);
test_master(true, result);
end else
begin
return_output(result + result_modif);
case result of
ok_result, soft_error:
begin
xqt_request;
operation := notice;
end;
otherwise
begin
output_stopped := true;
operation := master_out;
status := master_size - 1;
end;
end;
xmit(operation, status);
end;
end;
input:
begin
wait(desc_header, in_desc_sem);
if input_stopped then
begin
return_input(master);
test_master(false, result);
end else
begin
return_input(result+result_modif);
case result of
ok_result, soft_error:
begin
xqt_notice;
operation := request;
end;
otherwise
begin
input_stopped := true;
operation := master_out;
status := master_size - 1;
end;
end;
receive(operation, status);
end;
end;
otherwise
begin
message^.u2 := un_intelligible;
return(message);
end;
end;
end;
end.
«eof»