|
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 - download
Length: 43776 (0xab00)
Types: Rc489k_TapeFile, TextFile
└─⟦aa55fa693⟧ Bits:30007479 SW8110/1 TAS/SOS/PRIMO Rel 2.3
└─⟦this⟧
(head 1
bcheckparam=algol message.no
if ok.yes
(c=message checkparam compiled ok
checkparam=move bcheckparam
c=lookup checkparam
)
if ok.no
c=message checkparam error in compilation
)
external integer procedure checkparam
(paramno, keywordno, keywordlist, elements, elementtype, print);
value
paramno, print ;
real array
keywordlist, elements ;
integer array
elementtype ;
integer
paramno, keywordno ;
boolean print ;
message: *** checkparam version 1.00 ***;
comment: *** ***;
message: *** eli, 78.07.13 ***;
comment:
this procedure may be used to check the right hand side parameterlist
of a programcall.
the procedure assumes, that the parameterlist consists of a number
of parameter(groups) separated by spaces (<sp> in fp-notation).
each parameter consists of one or more elements, separated
(if more than one) by periods.
the first (and maybe only) element and is assumed
to be a keyword. the array <keywordlist> is assumed
to be declared as
real array keywordlist(1:no_of_keywords, 1:3)
the keywords allowed must be described in keywordlist(i, 1) and
keywordlist(i,2). if keywordlist(i,1)= null they will be assumed
to match any keyword in the parameter. unused entries in
keywordlist should have keywordlist(i,1) set to a
value which can not possible occur (0.0 shift 48 add -1 shift 24
add -1).
keywordlist(i,3) must contain a specification of the types
(text or integer) allowed for the elements in the parameter. each
specification contains 3 bits as follows:
000 no element allowed
001 text element must be present
010 integer element must be present
011 text or integer element may be present
100 not used bitpattern
101 text element may be present
110 integer element may be present
111 text or integer element may be present
note, that the optional elements should, to make sense,
appear as the last elements in the parameter.
the specifications must be packed in keywordlist(i,3) in the
following way:
keywordlist(i,3):= 0.0 shift 48
add <specs0> shift 3
add <specs1> shift 3
add <specs2> shift 3
...
add <specsn>
<specs0> is the specification for the keyword.
<specs1> is the specification for the first element
following the keyword, <specs2> the specifications of the
next element etc.
the arrays elements and elementtype must be declared as
real array elements(0:max_elements, 1:2)
integer array elementtype(0:max_elements)
where <max_elements> is the maximum number (in excess to the
keyword) of elements that is allowed by the specifications in
array keywordlist. note, that the packing of the specifications
limits this number to at most 15.
the keyword is stored in elements(0,1) and elements(0,2). the elements
following are stored in elements(i,1) and elements(i,2), i=1, 2, ...
the type of the keyword and the elements is signalled in elementtype
in the following way:
elementtype(i)= 0 no element present
= 1 text type element
= 2 integer type element
if checkparam returns with ok-indication, each element is of a
type allowed in the specifications in keywordlist(i, 3).
when called, checkparam will check the parameter specified
by <paramno>. <paramno> must contain the number (as defined
for the procedure system(4, ...) in the algol-manual)
of the keyword in the parameter. the separator
preceeding this element should be a space. if checkparam is
used to check all the parameters the first call of checkparam
will have <paramno>= 1 (no left side parameter) or <paramno>= 2
(left side present).
upon return, the success of the parametercheck is indicated through
the value of checkparam:
checkparam= 0 no more parameters
> 0 parameter ok. keyword and elements are stored as
described above. <keyword_no> contains the value
of the first index in keywordlist where the
keyword was found.
the value of checkparam indicates the number of
elements (including the keyword).
< 0 error in parameter. the contents of <keyword_no>
elements and elementtype are undefined.
the absolute value of checkparam indicates the
number of elements.
note, that when checkparam<>0, <paramno> may be adjusted to point
to the next parameter by the statement:
j:= checkparam(paramno, ...)
paramno:= paramno+ abs j
if j<0 then ...
when an error is detected, checkparam may print an errormessage
on current output. the errormessage has the following format:
***<progname> param: <parameter>
where <progname> if the programname found in the fp-parameters and
<parameter> is the illegal parameter.
the errormessage will only be printed if <errorprint> is true.
;
\f
begin
integer i, j, p, maxelems, maxkeywords;
real array arr(1:2);
real r, null;
null:= 0.0 shift 48;
i:= system(3, max_keywords, keywordlist);
maxkeywords:= (maxkeywords-i+1)//3;
system(3, i, elementtype);
for i:= i step (-1) until 1 do elementtype(i):= 0;
comment: start scan of parameter;
j:= system(4, paramno, arr);
if j=0 then
begin comment: parameterlist empty);
checkparam:= 0;
goto return;
end;
comment: search for keyword;
i:= 1;
while keywordlist(i,1)<>null and
(keywordlist(i,1)<>arr(1) or
keywordlist(i,2)<>arr(2)) do
begin
i:= i+1;
if i>maxkeywords then goto paramerror;
end;
comment: i holds the keywordnumber;
keywordno:= i;
r:= keywordlist(keywordno, 3);
comment: find maximum number of elements allowed;
maxelems:= -1;
while r<>null do
begin
maxelems:= maxelems+1;
r:= r shift (-3);
end;
comment: copy elements description into array elementtype;
r:= keywordlist(keywordno, 3);
for i:= maxelems step (-1) until 0 do
begin
elementtype(i):= r extract 3;
r:= r shift (-3);
end;
comment: now scan the elements in the parameter. check the type
and store the element and the elementtype;
i:= 0;
for j:= system(4,paramno+i,arr) while (i=0) or (j shift (-12)=8) do
begin
if j extract 12=10 then
begin comment: texttype element;
if elementtype(i) extract 1=0 then goto paramerror;
elementtype(i):= 1;
end else
begin comment: integertype element;
if elementtype(i) shift (-1) extract 1=0 then goto paramerror;
elementtype(i):= 2;
end;
elements(i,1):= arr(1);
elements(i,2):= arr(2);
i:= i+1;
end;
comment: if any element-specifications are left unused, they
should contain the optional-bit;
checkparam:= i;
for i:= i step 1 until maxelems do
begin
if elementtype(i) shift (-2) extract 1=0 then goto paramerror;
elementtype(i):= 0;
end;
comment: parameter ok;
goto return;
paramerror:
if print then
begin comment: find programname in parameterlist;
if system(4, 1, arr) shift (-12)<>6 then
system(4, 0, arr);
i:= 1;
write(out, <:***:>, string arr(increase(i)), <: param: :>);
end;
comment: find actual number of elements in erroneous parameter
and print elements if specified;
p:= 0;
for j:= system(4, paramno+p, arr) while (p=0) or
(j shift (-12)=8) do
begin
if print then
begin
if p<>0 then write(out, <:.:>);
if j extract 12=10 then
begin
i:= 1;
write(out, string arr(increase(i)));
end else
write(out, <<d>, arr(1));
end;
p:= p+1;
end;
if print then write(out, <:<10>:>);
comment: p contains number of elements;
checkparam:= -p;
return:
end;
end
\f
(head 1
bfilexfer=algol connect.no message.no
if ok.yes
(c=message filexfer compiled ok
filexfer=move bfilexfer
c=lookup filexfer
)
if ok.no
c=message filexfer error in compilation
)
begin message: *** filexfer version: 1.01 ***;
comment: *** ***;
message: *** eli, 79.04.01 ***;
comment: program constants and generation parameters;
integer max_queue_specs, no_of_queue_specs, first_tkrit,
mes_lgt, ans_lgt, def_transport_code, wait_code,
release_code;
integer field treply, tno, intfi, tsenderror, treceiveerror;
integer array field tkrit;
real array field tsend, treceiv, tname, tuser, queue, group;
boolean any_errors, verify, wait, release;
real progname, null;
comment: program generation parameters;
max_queue_specs:= 1;
comment: program constants;
first_tkrit:= 58;
treply:= intfi:= 2;
tno:= 4;
tname:= 4;
tuser:= 16;
tsend:= 40;
treceiv:= 50;
group:= 2;
queue:= 10;
tkrit:= first_tkrit;
tsenderror:= 16;
treceiveerror:= 20;
progname:= real <:***filexfer :>;
any_errors:= false;
def_transport_code:= 2;
wait_code:= 6;
release_code:= 8;
mes_lgt:= 30+9*max_queue_specs;
ans_lgt:= 26;
null:= 0.0 shift 48;
verify:= false;
wait:= false;
release:= true;
begin comment: declaration of workspace;
integer array mess(1:mes_lgt), answer(1:ans_lgt);
integer i, j;
real array resultentry(1:2);
procedure entry(id);
value id ;
integer id ;
begin
zone z(1,1,stderror);
integer array tail(1:10);
i:= 1;
open(z, 0, string resultentry(increase(i)), 0);
for i:= 2 step 1 until 10 do tail(i):= 0;
tail(1):= 1 shift 23;
tail(7):= id;
j:= monitor(40, z, i, tail);
if j<>0 then
begin comment: entry already exists or other creation error;
i:= 1;
write(out, string progname, <:create :>,
string resultentry(increase(i)));
if j=3 then
write(out, <: entry already exists:>) else
if j=4 then
write(out, <: claims exceeded:>) else
if j=5 then
write(out, <: catalog base illegal:>) else
write(out, <: result: :>, j);
write(out, <:<10>:>);
any_errors:= true;
goto end_program;
end;
if id=0 then
monitor(48, z, i, tail);
end procedure entry;
comment: initialization;
no_of_queue_specs:= 0;
for i:= 1 step 1 until mes_lgt do mess(i):= -1;
for i:= 1 step 1 until ans_lgt do answer(i):= -1;
begin comment: scan and check of parameterlist;
real array keywordlist(1:7, 1:3), elements(0:2, 1:2),
arr(1:2);
integer array elementtype(0:2);
integer text, int, keywordno, param, i, j, p, iparam, oparam;
procedure error(paramno, text);
integer paramno;
string text;
begin comment: prints an error mess on current output.
if paramno=0 only the text is printed.
otherwise the text followed by <:param:> is
printed and the parameter specified by paramno
is printed until a parameter preceeded by <sp>
is met.
if paramno=0 the program terminates;
write(out, string progname, text);
if paramno=0 then
begin
write(out, <:<10>:>);
goto end_program;
end;
write(out, if real text=real <::> then <:param: :>
else <:: :>);
p:= paramno;
for j:= system(4,paramno,arr) while j shift(-12)=8 or
p=paramno do
begin
i:= 1;
if j shift (-12)=8 then write(out, <:.:>);
if j extract 12=4 then write(out, <<d>, arr(1))
else write(out, string arr(increase(i)));
paramno:= paramno+1;
end;
write(out, <:<10>:>);
any_errors:= true;
goto scan_params;
end;
text:= 1;
int:= 2;
keywordlist(1,1):= real <:verif:> add 121;
keywordlist(1,2):= null;
keywordlist(1,3):= null add text shift 3 add text;
keywordlist(2,1):= real <:name:>;
keywordlist(2,2):= null;
keywordlist(2,3):= null add text shift 3 add text;
keywordlist(3,1):= real <:queue:>;
keywordlist(3,2):= null;
keywordlist(3,3):= null add text shift 3 add text shift 3 add text;
keywordlist(4,1):= real <:relea:> add 115;
keywordlist(4,2):= real <:e:>;
keywordlist(4,3):= null add text shift 3 add text;
keywordlist(5,1):= real <:user:>;
keywordlist(5,2):= null;
keywordlist(5,3):= null add text shift 3 add text;
keywordlist(6,1):= real <:wait:>;
keywordlist(6,2):= null;
keywordlist(6,3):= null add text shift 3 add text;
keywordlist(7,1):= keywordlist(7,2):= null;
keywordlist(7,3):= null add text;
comment: check left side;
resultentry(1):= null;
param:= iparam:= 1;
oparam:= 2;
if system(4,1,arr) shift (-12)=6 then
begin comment: left side present;
param:= iparam:= 2;
oparam:= 3;
system(4,0,resultentry);
end;
scan_params:
for j:= checkparam(param, keywordno, keywordlist,
elements, elementtype, false) while j<>0 do
begin comment: keywordno holds the keywordnumber;
if j<0 then error(param, <::>);
case keywordno of
begin
begin <* 1: verify*>
if elements(1,1)=real <:yes:> then verify:= true else
if elements(1,1)=real <:no:> then verify:= false else
error(param, <::>);
end;
begin <* 2: name*>
if mess.tname.intfi<>-1 then
error(param, <:transport name double defined:>);
mess.tname(1):= elements(1,1);
mess.tname(2):= elements(1,2);
end;
begin <* 3: queue*>
if no_of_queue_specs=max_queue_specs then
error(param, <:no room for queue specification:>);
no_of_queue_specs:= no_of_queue_specs+1;
mess.tkrit(1):= 0;
mess.tkrit.group(1):= elements(1,1);
mess.tkrit.group(2):= elements(1,2);
mess.tkrit.queue(1):= elements(2,1);
mess.tkrit.queue(2):= elements(2,2);
tkrit:= tkrit+18;
end;
begin <* 4: release*>
if elements(1,1)= real <:yes:> then release:= true else
if elements(1,1)= real <:no:> then release:= false else
error(param, <::>);
end;
begin <* 5: user*>
if mess.tuser.intfi<>-1 then
error(param,<:user name double defined:>);
mess.tuser(1):= elements(1,1);
mess.tuser(2):= elements(1,2);
end;
begin <* 6: wait*>
if elements(1,1)= real <:yes:> then wait:= true else
if elements(1,1)= real <:no:> then wait:= false else
error(param, <::>);
end;
begin <* 7: area- or devicename*>
if param=iparam then
begin comment: sendername;
mess.tsend(1):= elements(0,1);
mess.tsend(2):= elements(0,2);
end else
if param=oparam then
begin comment: receivername;
mess.treceiv(1):= elements(0,1);
mess.treceiv(2):= elements(0,2);
end else
error(param, <::>);
end;
end case;
param:= param+j;
end for while;
if any_errors then goto end_program;
comment: end of parameterscan.
check that at least sender- and receiver name has
been specified;
if mess.tsend.intfi=-1 then error(0, <:sender name missing:>);
if mess.treceiv.intfi=-1 then error(0, <:receiver name missing:>);
if mess.tname.intfi=-1 then
begin comment use null-name;
mess.tname(1):= mess.tname(2):= null;
end;
if mess.tuser.intfi=-1 then
begin comment get process name;
long array arr(1:2);
system(6,i,arr);
tofrom(mess.tuser,arr,8);
end;
if resultentry(1)<>null then entry(0);
end parameter block;
comment: send transport definition mess to primo;
i:= transfer(def_transport_code, mess, mes_lgt, answer, ans_lgt);
comment: check result;
if i<>0 then
begin comment: error in communication with primo or in parameters
to <transfer>. the latter should not possible
could occur;
any_errors:= true;
write(out, string progname, <:primo communication error: :>);
if i>1 and i<7 then
write(out, case i-1 of (<:rejected:>,
<:unintelligible:>,
<:malfunction:>,
<:primo does not exist:>,
<:mess buffer claim exceeded:>),
<:<10>:>)
else
write(out, <:unexpected result: :>, i, <:<10>:>);
end else
begin comment: error returned in answer from primo itself;
i:= answer.treply;
if i<>0 then
begin comment: transport definition error;
any_errors:= true;
write(out, string progname, <:primo reply error: :>);
if i=3 then
write(out, <:missing resources:>)
else
if i=5 or i=6 then
begin comment: error in sender/receiver device specification;
if i=5 then
begin
write(out, <:sender :>);
j:= answer.tsenderror;
end else
begin
write(out, <:receiver :>);
j:= answer.treceiveerror;
end;
if j=1 then write(out, <:entry troubles:>)
else
if j=2 then write(out, <:device troubles:>)
else
write(out, <:errorcode :>, j);
end else
write(out, <:unexpected reply code: :>, i);
write(out, <:<10>:>);
end else
begin comment: transport defined. if the verify.yes
parameter has been specified, the identi-
fication of the transport shall be output;
if verify then
write(out, <:transport identification: :>,
answer.tno, <:<10>:>);
if resultentry(1)<>null then entry(answer.tno);
if wait then
begin comment: send wait operation;
mess.tno:= answer.tno;
transfer(wait_code,mess,9,answer,ans_lgt);
end;
if release then
begin comment: send release operation;
mess.tno:= answer.tno;
transfer(release_code,mess,7,answer,7);
end;
end;
end_program:
if any_errors then errorbits:= 1 shift 0;
trapmode:= 1 shift 10;
end;
end
end
\f
(head 1
bfileenq=algol connect.no fp.yes message.no
if ok.yes warning.no
(c=message fileenq compiled ok
fileenq=move bfileenq
c=lookup fileenq
)
if ok.no
c=message fileenq error in compilation
)
begin message: *** fileenq version: 1.01 ***;
comment: *** ***;
message: *** eli, 79.04.01 ***;
comment: program constants;
integer field treply, tno, tsubno, tsubstate, tsubcause,
tsubstatus, tsenderror, treceiveerror;
real array field tname, tident;
long field tsubpos;
real progname;
integer mes_lgt, ans_lgt, wait_and_get_state_code,
get_state_code, release_code, kill_code;
treply:= 2;
tno:= 4;
tname:= 4;
tident:= 16;
tsubno:= 40;
tsubstate:= 42;
tsubpos:= 46;
tsubcause:= 50;
tsubstatus:= 52;
progname:= real <:***fileenq :>;
release_code:= 8;
kill_code:= 10;
wait_and_get_state_code:= 6;
get_state_code:= 4;
mes_lgt:= 9;
ans_lgt:= 26;
begin comment: declaration of workspace;
integer array mess(1:mes_lgt), answer(1:ans_lgt);
real array entry_name(1:2);
integer i, j, state, code, release, kill;
boolean wait, details, any_errors;
real null;
comment: initialization;
release:= kill:= 0;
any_errors:= wait:= details:= false;
for i:= 1 step 1 until mes_lgt do mess(i):= -1;
for i:= 1 step 1 until ans_lgt do answer(i):= -1;
entry_name(1):= null:= 0.0 shift 48;
begin comment: scan and check of parameterlist;
real array keywordlist(1:5, 1:3), elements(0:1, 1:2),
arr(1:2);
integer array elementtype(0:1);
integer text, int, keywordno, param, i, j, p, iparam, oparam;
procedure error(paramno, text);
integer paramno;
string text;
begin comment: prints an error mess on current output.
if paramno=0 only the text is printed.
otherwise the text followed by <:param:> is
printed and the parameter specified by paramno
is printed until a parameter preceeded by <sp>
is met.
if paramno=0 the program terminates;
write(out, string progname, text);
if paramno=0 then
begin
write(out, <:<10>:>);
goto end_program;
end;
write(out, if real text=real <::> then <:param: :>
else <:: :>);
p:= paramno;
for j:= system(4,paramno,arr) while j shift(-12)=8 or
p=paramno do
begin
i:= 1;
if j shift (-12)=8 then write(out, <:.:>);
if j extract 12=4 then write(out, <<d>, arr(1))
else write(out, string arr(increase(i)));
paramno:= paramno+1;
end;
write(out, <:<10>:>);
any_errors:= true;
goto scan_params;
end;
text:= 1;
int:= 2;
keywordlist(1,1):= real <:wait:>;
keywordlist(1,2):= null;
keywordlist(1,3):= null add text shift 3 add text;
keywordlist(2,1):= real <:relea:> add 115;
keywordlist(2,2):= real <:e:>;
keywordlist(2,3):= null add text shift 3 add text;
keywordlist(3,1):= real <:detai:> add 108;
keywordlist(3,2):= real <:s:>;
keywordlist(3,3):= null add text shift 3 add text;
keywordlist(4,1):= real <:kill:>;
keywordlist(4,2):= null;
keywordlist(4,3):= null add text shift 3 add text;
keywordlist(5,1):= keywordlist(5,2):= null;
keywordlist(5,3):= null add (text add int);
comment: check left side;
if system(4,1,arr) shift (-12)=6 then
error(0, <:call:>);
param:= 1;
scan_params:
for j:= checkparam(param, keywordno, keywordlist,
elements, elementtype, false) while j<>0 do
begin comment: keywordno holds the keywordnumber;
if j<0 then error(param, <::>);
case keywordno of
begin
begin <* 1: wait*>
if elements(1,1)= real <:yes:> then wait:= true else
if elements(1,1)= real <:no:> then wait:= false else
error(param, <::>);
end;
begin <* 2: release*>
if elements(1,1)= real <:yes:> then release:= +1 else
if elements(1,1)= real <:no:> then release:= -1 else
error(param, <::>);
end;
begin <* 3: details*>
if elements(1,1)= real <:yes:> then details:= true else
if elements(1,1)= real <:no:> then details:= false else
error(param, <::>);
end;
begin <* 4: kill*>
if elements(1,1)=real <:yes:> then kill:= +1 else
if elements(1,1)=real <:no:> then kill:= -1 else
error(param,<::>);
end;
begin <* 5: identification*>
if elementtype(0)=int then
mess.tno:= elements(0,1)
else
begin comment: lookup entry name;
zone z(1,1,stderror);
integer array tail(1:10);
integer i,j;
entry_name(1):= elements(0,1);
entry_name(2):= elements(0,2);
i:= 1;
open(z,0,string entry_name(increase(i)),0);
j:= monitor(42,z,i,tail);
if j<>0 then
begin
i:= 1;
write(out, string progname, <:lookup :>,
string entry_name(increase(i)));
if j=3 then
write(out, <: entry does not exist<10>:>) else
write(out, <:result: :>, j, <:<10>:>);
any_errors:= true;
goto end_program;
end;
mess.tno:= tail(7);
end;
end;
end case;
param:= param+j;
end for while;
if any_errors then goto end_program;
comment: end of parameterscan;
end parameter block;
comment: send mess to primo;
code:= if wait then wait_and_get_state_code else get_state_code;
i:= transfer(code, mess, mes_lgt, answer, ans_lgt);
comment: check result;
if i<>0 then
begin comment: error in communication with primo or in parameters
to <transfer>. the latter should not possible
could occur;
any_errors:= true;
write(out, string progname, <:primo communication error: :>);
if i>1 and i<7 then
write(out, case i-1 of (<:rejected:>,
<:unintelligible:>,
<:malfunction:>,
<:primo does not exist:>,
<:mess buffer claim exceeded:>),
<:<10>:>)
else
write(out, <:unexpected result: :>, i, <:<10>:>);
end else
begin
i:= answer.treply;
if i<>0 then
begin comment: reply error;
any_errors:= true;
write(out, string progname, <:primo reply error: :>);
if i=2 then
write(out, <:transport unknown:>)
else
if i=3 then
write(out, <:missing resources:>)
else
if i=5 or i=6 then
begin comment: error in sender/receiver device specification;
if i=5 then
begin
write(out, <:sender :>);
j:= answer.tsenderror;
end else
begin
write(out, <:receiver :>);
j:= answer.treceiveerror;
end;
if j=1 then write(out, <:entry troubles:>)
else
if j=2 then write(out, <:device troubles:>)
else
write(out, <:errorcode :>, j);
end else
write(out, <:unexpected reply code: :>, i);
write(out, <:<10>:>);
end else
begin comment: state received;
if details then
begin comment: print transport name;
i:= 1;
write(out, <:transport name: :>,
string answer.tname(increase(i)), <:<10>:>);
end;
write(out, <: state: :>);
state:= answer.tsubstate;
if state>1 and state<9 then
write(out, case state-1 of
(<:waiting:>,
<:executing:>,
<:held:>,
<:completed:>,
<:aborted :>,
<:killed by operator:>,
<:killed by application:>))
else
write(out, state);
if state=6 then
begin comment: output abort-cause;
i:= answer.tsubcause;
if i=1 or i=2 or i=3 then
write(out, <:caused by :>,
if i=1 then <:sender:> else
if i=2 then <:receiver:> else <:opearator:>,
<: device:>)
else
write(out, <:cause=:>, i);
end;
write(out, <:<10>:>);
if details and (state=6) then
begin comment: output device status;
boolean first;
first:= true;
write(out, <: status: :>);
i:= answer.tsubstatus;
j:= 23;
while i<>0 do
begin
if i<0 then
begin
write(out, false add 32, if first then 0 else 16,
case j+1 of
(<:hard error:>,
<:normal answer:>,
<:rejected:>,
<:unintelligible:>,
<:disconnected:>,
<:process does not exist:>,
<:position error:>,
<:word defect:>,
<:stopped:>,
<:bit 14:>,
<:bit 13:>,
<:checksum error:>,
<:card reject:>,
<:read error:>,
<:mode error:>,
<:writing enabled:>,
<:tapemark or attention:>,
<:load point:>,
<:end document:>,
<:block length error:>,
<:data overrun:>,
<:timer:>,
<:parity error:>,
<:intervention:>
),
<:<10>:>);
first:= false;
end;
i:= i shift 1;
j:= j-1;
end while;
end;
if details and answer.tsubpos>=0 then
begin
write(out,<: char position::>,answer.tsubpos,<:<10>:>);
end;
if release>0 or (release=0 and state=5) then
begin comment: release transport and remove entry;
if entry_name(1)<>null then
begin
zone z(1,1,stderror);
integer array tail(1:10);
integer i;
i:= 1;
open(z,0,string entry_name(increase(i)),0);
monitor(48,z,i,tail);
end;
transfer(release_code,mess,7,answer,7);
end;
if kill>0 then
begin
transfer(kill_code,mess,7,answer,7);
end;
end state;
end;
end_program:
if any_errors then errorbits:= 1 shift 0;
trapmode:= 1 shift 10;
end;
end
\f
(savetrans=algol message.no connect.no
if ok.yes
(c=message savetrans translated ok
)
if ok.no
(c=message savetrans not ok
)
)
begin
<*********************************************************************
* *
* *
* Savetrans: *
* A utility program which restarts all unfinished transports *
* sent to primo in case of a system break down. *
* *
* *
* Operating procedure: *
* savespool=move primospool ; do this before primo is started *
* ; now start primo using an s command *
* savetrans savespool ; restart the transports from the old *
* ; primospool area, possible errors will be printed on current *
* ; output *
* *
* *
*********************************************************************>
message
***************************
**** ****
**** kc nov. 13. 1980 ****
**** savetrans ****
**** ****
***************************;
\f
<***************************************************************
* *
* format of a transport description in the spoolarea of primo: *
* *
* +-----------+ *
* + 0 ! ! transport name *
* + 2 ! ! *
* + 4 ! ! *
* + 6 ! ! *
* + 8 ! ! user name *
* +10 ! ! *
* +12 ! ! *
* +14 ! ! *
* +16 ! ! sender name *
* +18 ! ! *
* +20 ! ! *
* +22 ! ! *
* +24 ! ! receiver name *
* +26 ! ! *
* +28 ! ! *
* +30 ! ! *
* +32 ! ! bs area name *
* +34 ! ! *
* +36 ! ! *
* +38 ! ! *
* +40 ! ! mode shift 12+kind of device *
* +42 ! ! lower cat base of sending process *
* +44 ! ! upper cat base of sending process *
* +46 ! ! bs start position halfword (long) *
* +48 ! ! *
* +50 ! ! queue group name (e.g. paper) *
* +52 ! ! *
* +54 ! ! *
* +56 ! ! *
* +58 ! ! queue name (e.g. a4upright) *
* +60 ! ! *
* +62 ! ! *
* +64 ! ! *
* +66 ! ! coroutine description address *
* +68 ! ! transport state *
* +70 ! ! cause (if state is aborted or held) *
* +72 ! ! device status *
* +74 ! ! character position (long) *
* +76 ! ! *
* +78 ! ! buffer address of wait and get state *
* +80 ! ! removetime (>8388605 meens waiting) *
* +-----------+ *
* *
***************************************************************>
\f
zone output,transport(128,1,stderror),catbase(1,1,stderror);
real array inname,outname(1:2);
integer array ia(1:20),carr(1:39),rarr(1:11),base(1:2),savedbase(1:2);
integer i;
boolean list,outp;
<* transfer description *>
long array field tname,
uname,
sname,
rname,
gname,
qname;
<* transport description *>
long array field tr_name,
tr_user,
tr_sname,
tr_rname,
tr_bsname;
boolean field tr_mode,
tr_kind;
integer field tr_baselow,
tr_baseup,
tr_bsstartptr;
long array field tr_qgroup,
tr_qname;
integer field tr_couru,
tr_state,
tr_cause,
tr_status,
tr_charposition,
tr_waitmess,
tr_removetime;
\f
boolean procedure getrec(z,n);
value n; zone z; integer n;
begin
integer i;
getrec:=true;
i:=inrec6(z,0);
if i>=n then
inrec6(z,n)
else
begin
inrec6(z,i);
i:=inrec6(z,0);
if i>=n then
inrec6(z,n)
else
getrec:=false
end
end;
procedure error(s,i,a);
value i;
string s; integer i; array a;
begin
integer sep,kind;
write(out,<:***savetrans :>,s);
if i<>0 then
begin
write(out,<:: :>);
sep:=i shift (-13)-1;
kind:=i extract 12;
outchar(out,case sep of (32, 61, 46));
i:=1;
if kind=10 then write(out,string a(increase(i)))
else write(out,<<d>,entier a(1))
end;
write(out,<:<10>:>);
outp:=false;
goto stop
end;
\f
procedure initfields;
begin
<* transfer description *>
tname:=4;
uname:=16;
sname:=40;
rname:=50;
gname:=60;
qname:=68;
<* transport description *>
tr_name:=0;
tr_user:=8;
tr_sname:=16;
tr_rname:=24;
tr_bsname:=32;
tr_mode:=41;
tr_kind:=42;
tr_baselow:=44;
tr_baseup:=46;
tr_bsstartptr:=50;
tr_qgroup:=50;
tr_qname:=58;
tr_couru:=68;
tr_state:=70;
tr_cause:=72;
tr_status:=74;
tr_charposition:=78;
tr_waitmess:=80;
tr_removetime:=82
end;
\f
procedure connect_output;
begin
integer array bases(1:8),ia(1:17);
integer i;
open(output,4,outname,0);
system(11)bases:(0,bases);
i:=monitor(76)lookup head and tail:(output,0,ia);
if i=0 then
begin
if extend ia(2)<extend bases(7) or
extend ia(3)>extend bases(8) then i:=1
end;
if i<>0 then
begin
ia(1):=ia(2):=1;
for i:=3 step 1 until 10 do ia(i):=0;
ia(6):=systime(7)short clock:(0,0.0);
if monitor(40)create entry:(output,0,ia)<>0 then
error(<:create output area not possible:>,
4 shift 12 add 10,outname)
end
else
begin
monitor(42)lookup entry:(output,0,ia);
ia(6):=systime(7)short clock:(0,0.0);
monitor(44)change entry:(output,0,ia)
end;
if monitor(52)create area process:(output,0,ia)<>0 then
error(<:connect output not possible:>,
4 shift 12 add 10,outname)
end;
\f
procedure write_transport(z);
zone z;
begin
long l1,l2;
l1:=extend 0 add transport.tr_baselow;
l2:=extend 0 add transport.tr_baseup;
write(z,<:<10>base abs:>,<<_d>,l1,l2,<: ;:>,
<<_-d>,l1 extract 24,l2 extract 24);
write(z,<:<10>filexfer :>,transport.tr_sname,
<: :>,transport.tr_rname);
if transport.tr_user(1)<>0 then
write(z,<: user.:>,transport.tr_user);
if transport.tr_name(1)<>0 then
write(z,<: name.:>,transport.tr_name);
if transport.tr_qgroup(1)<>0 then
write(z,<: queue.:>,transport.tr_qgroup,
<:.:>,transport.tr_qname);
write(z,<:<10>:>)
end;
\f
procedure show_error(z,i);
value i; zone z; integer i;
begin
write(z,<:***savetrans :>,case i of(
if rarr(1)=3 then <:missing resources in primo:>
else if rarr(1)=5 then <:sender troubles:>
else <:receiver troubles:>,
<:rejected:>,
<:unintelligible:>,
<:primo malfunction:>,
<:primo does not exist:>,
<:buffer claim exceeded:>,
<:illegal action ???:>,
<:illegal cleng or rleng ???:>,
<:criterion type illegal:>,
<:set catalog base, illegal bases:>),
<:<10>:>);
if i>=2 and i<=8 then
begin
write(z,<:***savetrans fatal error<10>:>);
goto stop
end
end;
\f
procedure start_transport(z);
zone z;
begin
for i:=7, 8, 13 step 1 until 20, 25, 30, 39 do
carr(i):=-1;
for i:=1, 2 do
begin
carr.tname(i):=transport.tr_name(i);
carr.uname(i):=transport.tr_user(i);
carr.sname(i):=transport.tr_sname(i);
carr.rname(i):=transport.tr_rname(i);
carr.gname(i):=transport.tr_qgroup(i);
carr.qname(i):=transport.tr_qname(i)
end;
if transport.tr_qgroup(1)<>0 then
carr(30):=0;
base(1):=transport.tr_baselow;
base(2):=transport.tr_baseup;
i:=monitor(72)set catalog base:(catbase,0,base);
if i<>0 then i:=10;
if i=0 then i:=transfer(2)define transport:(carr,39,rarr,11);
if i=0 and rarr(1)<>0 then i:=1;
if i<>0 then
begin
if -, list then write_transport(z);
show_error(z,i)
end
else
begin
for i:=3 step 1 until 7 do rarr(i):=-1;
transfer(8)release transport:(rarr,7,carr,16)
end
end; <* start transport *>
\f
procedure read_params;
begin
real array param(1:2);
integer i,j;
list:=false;
j:=1;
i:=system(4,1,param);
if i shift (-12)=6 then <* left hand side *>
begin
j:=2;
outp:=true;
system(4,0,param);
outname(1):=param(1);
outname(2):=param(2)
end else
outp:=false;
i:=system(4,j,param);
if i<>4 shift 12 add 10 <* <sp><text> *> then
error(if i=0 then <:no input file:> else <:param:>,i,param);
inname(1):=param(1);
inname(2):=param(2);
j:=j+1;
i:=system(4,j,param);
if i<>0 then
begin
if i<>4 shift 12 add 10 <* <sp><text> *> then
error(<:param:>,i,param);
if param(1)<>real <:list:> then
error(<:illegal parameter name:>,i,param);
i:=system(4,j+1,param);
if i<>8 shift 12 add 10 <* .<text> *> then
error(<:param:>,i,param);
list:=param(1)=real <:yes:>
end
end; <* read params *>
\f
procedure do_it(z);
zone z;
while getrec(transport,82) do
if transport.tr_removetime>8388605 then <* not executed *>
begin
if list then write_transport(z);
start_transport(z)
end;
<* begin of main program *>
init_fields;
read_params;
open(catbase,0,<::>,0); <* for set catalog base *>
close(catbase,true);
<* save catalog bases of users process *>
system(11)bases:(0,ia);
savedbase(1):=ia(1);
savedbase(2):=ia(2);
if outp then connect_output;
open(transport,4,inname,0);
if monitor(52)create area process:(transport,0,ia)<>0 then
error(<:connect input not possible:>,4 shift 12 add 10,inname);
if outp then do_it(output) else do_it(out);
stop:
if outp then
begin
outchar(output,25);
close(output,false);
getzone6(output,ia);
i:=ia(9);
monitor(42)lookup entry:(output,0,ia);
ia(1):=i;
monitor(44)change entry:(output,0,ia)
end;
close(transport,true);
<* restore catalog base of users process *>
monitor(72)set catalog base:(catbase,0,savedbase);
trapmode:=-1
end
; end of file
end ; utility end
▶EOF◀