⟦53005706b⟧

TextFileVerbose

job j 1 time 11 0 perm disc1 1000 10
strsim= set 1 disc1
scope user strsim
(if ok.no
finis)
strsim= algol
begin
<*****************************************************
*
* The purpose with this program is to act as as
*
* streamer simulator. The program makes it possible for
*
* a program to communicate with a TTY using the streamer
*
* interface.
*
* Programmed dec. 1980 by STB and WIB.
*
******************************************************>
\f

 
<******************************************************
*
* declarations
*
********************************************************>
<* constants *>
integer max_stream, max_rec;
max_stream:= 32;
max_rec:= 200;
 
begin
integer char, free, i, no_of_bytes, rec_macro, rec_micro,
_       sender_macro, sender_micro, op_code, hours, min_secs;
integer array 
stream_q (0:max_stream, 0:1),
next_table, buf_addr (1:max_rec),
data (1:20);
boolean finished;
\f

 
procedure empty_eventq;
begin <* moves all messages from the event queue to their
         respective internal queues *>
 
integer result, i, bufferaddr, stream, io, recpt;
integer array mess (0:7);
zone z (1, 1, stderror);
 
repeat
bufferaddr:= 0;
result:= monitor (66 <* test event *>, z, bufferaddr,
                  mess);
if result <> -1 then
begin
recpt:= getmessrec;
if recpt <> 0 then
begin
monitor (20 <* wait message *>, z, bufferaddr, mess);
<* the message is now held in mess *>
testout(<:firstaddress: :>, mess (1));
testout(<:lastaddress: :>, mess (2));
testout(<:bufferaddr: :>,bufferaddr);
stream:= mess (0) extract 12;
io:= if (mess (0) shift (-12)= 3) then 1 else 0;
bufaddr (recpt):= bufferaddr;
 
toq (stream, io, recpt);
end;
end;
 
until (result= -1) or (recpt= 0);
end;
\f

\f

 
integer procedure from_q (stream, io);
integer stream, io;
begin
integer pt;
 
pt:= streamq (stream, io);
if pt <> 0 then
streamq (stream, io):= nexttable (pt);
 
fromq:= pt;
 
end;
\f

 
integer procedure get_mess_rec;
begin <* gets the next free mess rec *>
integer mess_pt;
 
mess_pt:= free;
if free <> 0 then
begin
free:= next_table (free);
nexttable (messpt):= 0;
end;
 
get_mess_rec:= mess_pt;
 
end;
\f

\f

 
procedure init_free;
begin <* initialises the chain of free mess_recs *>
integer i;
 
free:= 1;
for i:= 1 step 1 until maxrec - 1 do
next_table (i):= i+1;
next_table (maxrec):= 0;
next_table (maxrec):= 0;
 
end;
\f

 
procedure list;
begin <* list the nonempty streamq *>
integer st, io;
 
for st:= 0 step 1 until max_stream do
for io:= 0, 1 do
if stream_q (st, io) <> 0 then
write (out, "nl", 1, st, " ", 1,
      (case io+1 of ("o","i")), 1);

end;
\f

  
procedure receive;
begin
integer stream, mess, i, word, no_of_chars, char, ch_no, pt;
integer array data_buf (1:10),
answer (1:9);
zone output (30,1,stderror);
 
integer procedure read_ch;
begin <* gets a character from the zone 'output' *>
 
read_ch:= output ((ch_no+5)//6) shift (8*((ch_no-1) mod 6 - 5)) extract 8;
ch_no:= ch_no + 1;
end read_ch;
 
 
read (in, stream);
pt:= stream_q (stream, 0);
if stream_q (stream, 0)= 0
then <* queue empty *>
write (out, <:no output:>, "nl", 1)
else
begin
answer (1):= 0;
answer (9):= 1;
i:= monitor (70 <* copy core area *>, output,
             buf_addr (pt), answer);
testout (<:copy core area: :>, i);
no_of_chars:= answer (3);
ch_no:= 1;
 
testout (<:bufferaddr: :>, bufaddr(pt));
testout (<:noofchars : :>, no_of_chars);
for i:= 1 step 1 until no_of_chars do
begin
char:= read_ch;
write (out, "<", 1, <<ddd>, char, ">", 1);
end;
 
monitor (22 <* send answer *>, output,
         buf_addr (pt), answer);
pt:= from_q (stream, 0);
release_messrec (pt);
 
end;
end;
\f

 
procedure release_mess_rec (messpt);
value mess_pt;
integer mess_pt;
 
begin
next_table (mess_pt):= free;
free:= mess_pt;
end;
\f


procedure set;
begin <* set attributes *>
integer char, char2, group, no, i;
 
readchar (in, char2);
 
if char2= 'o' then
begin <* set opcode *>
read (in, group);
read (in, no);
opcode:= (group shift 4 + no) extract 8;
end

else if char2= 'd' then
begin <* set data *>
integer char3, datapoint;
 
readchar (in, char3);
read (in, datapoint);
 
if char3= 'a' then
begin <* read alfanumeric *>
repeat
readchar (in, char);
data (datapoint):= char;
datapoint:= datapoint + 1;
until char= 'nl';
end read alfanumeric
else
 
begin <* read numeric *>
repeat
read (in, no);
if no >= 0 then
begin
data(datapoint):= no extract 8;
datapoint:= datapoint + 1;
end
until no < 0;
end read numeric;
 
if datapoint+15 > noofbytes then
noofbytes:= datapoint+15;
 
end <* set data *>
end set;
\f


procedure testout (text, int);
value int;
integer int;
string text;
 
begin <* writes testoutput *>
write (out, text, "sp", 2, int, "nl", 1);
setposition (out,0,0);
end;
\f

 
procedure to_q (stream, io, mess_pt);
integer stream, io, mess_pt;
 
begin
integer pt, last_pt;
 
lastpt:= 0;
pt:= stream_q (stream, io);
while pt <> 0 do
begin <* scan the queue *>
lastpt:= pt;
pt:= next_table (pt);
end;
 
if lastpt= 0 then
<* queue is empty *>
stream_q (stream, io) := mess_pt
else
next_table (lastpt):= messpt;
next_table (mess_pt):= 0;

end;
\f

 
procedure transmit;
begin
integer stream, format, i, pt, dwpt, datapt;
real result;
integer array messbuf (1:2),
answer (1:9),
z_descr (1:20);
zone input (20,1,stderror);
 
read (in, stream);
read (in, format);
if stream_q (stream, 1)= 0
then write (out, <:no buffer available:>)
else
begin
case format of
begin
<* 1: *> 
begin
<* transmit a message preceeded by a correct alarm_label *>

input(1):=real( (extend no_of_bytes shift 32)
_         + (extend rec_macro shift 16)
_         + rec_micro);

input(2):=real( (extend sender_macro shift 32)
_         + (extend sender_micro shift 16)
_         + (op_code shift 8) );

input(3):=real( (extend hours shift 32)
_         + (extend min_secs shift 16)
_         + (data(1) shift 8 + data(2)));

datapt:= 3;
 
for dwpt:= 4 step 1 until 6 do
begin
for i:= datapt step 1 until datapt+5 do
result:= result shift 8 add (extend data(i));
datapt:= datapt + 6;
input (dwpt):= result;
end for;
end;
end case;
 
pt:= stream_q (stream, 1);
answer (9):= 1;
getzone6 (input, z_descr);
z_descr(15):= z_descr(14)+20;
setzone6 (input, z_descr);
i:= monitor (70 <* copy core area *>, input,
             buf_addr( pt), answer);
if i<>0 then
testout (<:copy core error :>, i);
answer(1):= 0;
i:= monitor (22 <* send answer *>, input,
             buf_addr( pt), answer);
if i<>1 then
testout (<:send answer error :>, i);
pt:= from_q (stream, 1);
release_mess_rec (pt);
no_of_bytes:= 16;

end;
end;
<*****************  initialisation  *****************>
 
for i:= 0 step 1 until max_stream do
stream_q (i,0):= stream_q (i,1):= 0;
initfree;
finished:= false;
char:= 0;
 
<* init label and data *>
no_of_bytes:= 16;
rec_macro:= 10;
rec_micro:= 11;
sender_macro:= 0;
sender_micro:= 1;
op_code:= 0;
hours:= 13;
minsecs:= 1415;
 
for i:= 1 step 1 until 20 do
data (i):= 0;
 
<* create pseudo-process *>
begin
integer array dummy (1:1);
integer array old_base(1:8),new_base(1:2);
zone str,z (1,1,stderror);

<* first we get the old catalog bases *>
system(11,0,oldbase);

open(z,0,<::>,0);
newbase(1):=oldbase(7);
newbase(2):=oldbase(8);

monitor(72 <* set cat base *>,z,0,newbase);

open (str, 0, <:streamer:>, 0);
i:= monitor (80 <* create pseudo-process *>, str,
             0, dummy);
close (str, true);

<* now restore the old cat base *>
monitor(72 <* set cat base *>,z,0,oldbase);

end;
\f

 
<********************  main loop  **********************>
 
write (out, <:stream simulator:>, "nl", 1);
 
repeat
if char <> 'nl' then
write (out, "nl", 1, <:command: :>);
setposition (out,0,0);
readchar (in, char);
empty_eventq;
 
if char= 'e' then finished:= true else
if char= 'l' then list else
if char= 'nl' then else
if char= 'r' then receive else
if char= 's' then set else
if char= 't' then transmit else
write  (out, <:unknown command:>);
setposition (out,0,0);
 
until finished;
 
end;
end
 
if warning.yes
(message warning errors in compilation
finis)
message compilation ok
finis
«eof»
DataMuseum.dk

RC3500

⟦53005706b⟧ TextFileVerbose

Derivation

TextFileVerbose
