|
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: 100608 (0x18900)
Types: TextFile
Names: »disccopy5tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »disccopy5tx «
begin
integer array kind(0:100),alphabet(0:127),zdescr,ia(1:21),shdescr(1:12),
entrybase,ownbase(1:2);
real array ra(0:100),par,auxname,docname,name,toname,fromname,
act_auxname,act_docname,maincatname(1:2);
long array program(1:2);
integer sep,space_name,point_name,space_integer,point_integer,i,j,
type,paramno,firstentryname,no_of_entries,devno,todevno,
fromdevno,scopetype,blocklen,tosegm,fromsegm,number_of_segments,
firstbuffer,topbuffer,topinbuf,curfirstbuf,curtopbuf,
curbufsize,base_lower,base_upper,permkey,start_pos,list,last,
slicelength,slices,segments,entries,bytes,basetype,totalsegments,
chain_addr;
long maximum,topfromsegm,toptosegm;
boolean maincatrem,output,ok,fp_mode,scope,base,
area,morelines, checkread, olddisk;
integer array field iaf;
real array field areaname;
zone zhelp(1,1,stderror),zdisc(5*128,1,ownerror);
\f
procedure result (no, text, name, res, exit);
integer no, res ;
string text ;
real array name ;
boolean exit ;
begin
integer i;
real mon_name, mon_res;
errorbits := 1; <*warning.no, ok.no*>
write (out,
"nl", 1, "*", 3, <: monitor result ::>);
i := 1;
if no < 0 then
<*result from operation sent*>
write (out,
"nl", 1, text, <: : :>, string name (increase (i)),
"nl", 1, "sp", 1, <:result : :>, case res of (
<::>,
<:process not reserver of disc process:>,
<:receiver logical disc or physical disc with logical discs connected:>),
"nl", 1)
else
begin <*monitor procedure result*>
if no = 40 then
begin
mon_name := real <:create entry:>;
mon_res := real ( case res of (
<::>,
<:catalog i/o error,
document not mounted or not ready:>,
<:name conflict:>,
<:claims exceeded:>,
<:cat base outside std base:>,
<:name format of entry or document illegal:>,
<:main catalog not present:> ));
end
\f
else
if no = 54 then
begin
mon_name := real <:create peripheral process:>;
mon_res := real ( case res of (
<:function forbidden in calling process:>,
<:calling process not user,
catalog i/o error:>,
<:name conflict,
not same disc:>,
<:device number does not exist:>,
<:device is reserved by another user:>,
<:name format illegal:>,
<::>));
end else
if no = 90 then
begin
mon_name := real <:permanent entry into aux cat:>;
mon_res := real ( case res of (
<::>,
<:document not ready,
document does not exist,
catalog i/o error:>,
<:name conflict in aux cat,
entry not found:>,
<:entry protected, i.e. outside maxbases,
permkey illegal:>,
<:area used by another process,
entry already permanent in another auxcat:>,
<:name format illegal,
claims exceeded:>,
<:main catalog not present:> ));
end
\f
else
if no = 102 then
begin
mon_name := real <:prepare backing storage:>;
mon_res := real ( case res of (
<:area claims exceeded,
function forbidden in calling process:>,
<:catalog i/o error:>,
<:auxcat name overlap,
auxcat name exists already:>,
<:document device does not exist,
document device is not a bs device,
document device not reserved:>,
<:auxcat size <= 0 or auxcat size too large,
chainhead chain inconsistent,
auxcat chain inconsistent,
illegal kind of chaintable,
permkey of auxcat illegal,
too many slices,
claims exceeded (too few slices for chaintable),
-,- (auxcat too large),
-,- (no room in maincat):>,
<:auxcat name format illegal,
doc name format illegal:>,
<:no chains idle:> ));
end else
if no = 104 then
begin
mon_name := real <:insert entry:>;
mon_res := real ( case res of (
<:function forbidden in calling process:>,
<:catalog i/o error,
document not found,
state of document does not permit the call:>,
<:name overlap,
name exists already:>,
<:calling process not user of the device:>,
<:permkey illegal,
interval illegal,
chain overlap,
chain outside limits:>,
<:name format illegal,
docname format illegal,
claims exceeded:>,
<:main catalog not present:> ));
end
\f
else
if no = 106 then
begin
mon_name := real <:insert backing storage:>;
mon_res := real (case res of (
<:function forbidden in calling process:>,
<:document not found,
state of document does not permit call:>,
<::>,
<:calling process not user of device:>,
<::>,
<:docname format illegal:>,
<::>));
end else
if no = 108 then
begin
mon_name := real <:delete backing storage:>;
mon_res := real (case res of (
<:function forbidden in calling process:>,
<:document not found,
catalog i/o error:>,
<::>,
<:calling process not user of device:>,
<:area processes exist for the document:>,
<:docname format illegal,
main catalog on the document:>,
<::>));
end else
if no = 110 then
begin
mon_name := real <:delete entries:>;
mon_res := real (case res of (
<:function forbidden in calling process:>,
<:document not found,
catalog i/o error,
state of document does not permit call:>,
<:not all entries deleted yet:>,
<:calling process not user of device:>,
<::>,
<:docname format illegal:>,
<::>));
end
\f
else
if no = 120 then
begin
mon_name := real <:create aux entry and area process:>;
mon_res := real (case res of (
<:function forbidden in calling process,
area claims exceeded:>,
<:catalog i/o error,
document not found,
state of document does not permit the call:>,
<:procname overlap,
procname exists already,
entryname overlap (in auxcat),
entryname exists already (in auxcat):>,
<:calling process not user of the device,
claims exceeded:>,
<:key illegal,
interval illegal:>,
<:entry name format illegal,
proc name format illegal,
doc name format illegal:>,
<::> ));
end;
write (out,
"nl", 1, string mon_name,
<: : :>, string name (increase (i)),
"nl", 1, "sp", 1, <:result : :>, string mon_res,
"nl", 1);
end <*monitor procedure result*>;
if not fpmode then
stopzone (out, false);
if exit then
begin
close (zdisc, true);
reset_catbase;
if fp_mode then
goto aftererror
else
goto next_line;
end <*exit*>;
end procedure result;
\f
procedure maybe_device_status (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z a device status mes- *>
<* sage with document name and status bit names the same *>
<* way fp does if the program was to terminate with a give *>
<* up alarm instead of having trapped one. *>
<* *>
<***********************************************************>
begin
integer status, cause, param, bit;
long array text (1:4);
long array field docname;
docname := 8; <*fields possible docname in text*>
status := getalarm (text);
cause := alarmcause extract 24 ;
param := alarmcause shift (-24);
if cause = -11 then
begin <*give up*>
write (z, "nl", 1,
<:device status :>, text.docname);
for bit := 0 step 1 until 23 do
if status shift bit < 0 then
write (z, "nl", 1, case (bit + 1) of (
<:intervention:>,
<:parity error:>,
<:timer:>,
<:data overrun:>,
<:block length error:>,
<:end of document:>,
<:load point:>,
<:tape mark or attention:>,
<:writing enabled:>,
<:mode error:>,
<:read error:>,
<:card rejected or disk error:>,
<:checksum error:>,
<:bit 13:>,
<:bit 14:>,
<:stopped:>,
<:word defect:>,
<:position error:>,
<:process does not exist:>,
<:disconnected:>,
<:unintelligible:>,
<:rejected:>,
<:normal:>,
<:hard error:>));
write (z, "nl", 1);
end;
end rs_alarm;
\f
integer procedure process_description (devno, proc_area);
value devno ;
integer devno ;
integer array proc_area ;
begin
integer i;
system (5, 74, proc_area);
i:= proc_area(1)+devno*2;
if i>=proc_area(2) then writeerror (<:devno outside limits:>);
system(5, i, proc_area);
process_description:= proc_area(1);
system(5,proc_area(1), proc_area);
end process_description;
\f
integer procedure device_number (proc_address);
value proc_address ;
integer proc_address ;
begin
integer array ia (1:2);
integer i, max_device;
system (5, 74, ia);
max_device:= (ia(2)-ia(1))//2;
begin
integer array name_table (0:max_device);
integer array field iff;
iff := -2;
system(5, ia(1), name_table.iff);
for i:= 0 step 1 until max_device do
begin
if proc_address=name_table(i) then
begin
device_number:= i;
i:= max_device;
end;
end;
end;
end device_number;
procedure typetext(text);
string text;
begin
write(out, text); if -,fp_mode then setposition(out,0,0);
end;
procedure typein(number);
integer number;
begin
setposition(in, 0, 0); read(in, number);
end;
\f
procedure alarm(text);
string text;
begin
typetext(text);
typetext(<:<10>:>);
goto after_error;
end;
procedure caterror(z,s,b);
zone z ;
integer s,b ;
if s shift (-18) extract 1 = 1 then b:= 34 else
if s shift (-2) extract 1 = 1 then stderror(z,s,b);
procedure end_of_document(z);
zone z ;
begin
getshare6(z,shdescr,1);
write(out,<:<10>:>,if shdescr(4) shift (-12) = 3 then
<:input from segment : :> else
<:output to segment : :>,<<ddddddd>,shdescr(7),
<: - end of document:>);
typetext(<:<10>:>);
end;
procedure status (z, s, b);
zone z; integer s, b;
begin
integer bit;
integer array zdescr(1:20), shdescr(1:12);
long array field zname;
zname := 2;
getzone6 (z, zdescr);
getshare6 (z, shdescr, 1);
write (out, <:<10>:>, if shdescr(4) shift (-12) = 3 then
<:input from: :> else
<:output to : :>);
write (out, false add 32, 12 - write (out, zdescr.zname));
write (out, <<dddddd>, <: segm::>, shdescr(7),
<: status=:>);
for bit := 0 step 1 until 23 do
write (out, if s shift bit < 0 then <:1:> else <:.:>);
typetext (<:<10>:>);
end procedure status;
\f
procedure ownerror (z, s, b);
zone z; integer s, b;
begin
status (z, s, b);
stderror (z, s, b);
end;
boolean procedure transfer (z, cursegment, topsegment);
zone z; integer cursegment; long topsegment;
begin
integer mode;
long remaining_bytes;
integer logstatus, segments, repcount;
integer array answer(1:8);
repcount := 0;
curfirstbuf := firstbuffer;
curbufsize := curtopbuf - firstbuffer;
remaining_bytes := (topsegment - cursegment) shift 9;
if remaining_bytes < curbufsize then
begin
curbufsize := remaining_bytes;
curtopbuf := curfirstbuf + curbufsize;
end;
next_block:
if curfirstbuf = curtopbuf then
goto exit;
mode := if checkread and
not olddisk and
output then 1 else 0;
<*if checkread and not old disk and output then read after write*>
<*write (out,
"nl", 2, <:*********** mode = :>, mode, <: **************:>);
*>
shdescr (4) := (if output then 5 else 3) shift 12 + mode;
shdescr (5) := curfirstbuf;
shdescr (6) := curfirstbuf + curbufsize - 2;
shdescr (7) := cursegment;
setshare6 (z, shdescr, 1);
monitor (16) send message :( z, 1, shdescr);
logstatus := 1 shift monitor (18) wait answer :( z, 1, answer);
bytes := if logstatus = 2 <* normal answer *> then
answer (2)
else
0;
\f
if logstatus = 2 <* normal answer *> then
logstatus := logstatus + answer (1);
if (logstatus shift(-18) extract 1 = 1 and
logstatus shift(-1) extract 1 = 1 and
curbufsize = 512 and
-,area ) or
logstatus = 1 shift 18 + 1 shift 1 <* end document *>
then curtopbuf:= curfirstbuf + bytes
else
if logstatus <> 1 shift 1 then
begin <* transfer not ok *>
if curbufsize <> 512 then
begin <* repeat same transfer, but with size = 512 bytes *>
bytes := 0;
curbufsize := 512;
end
else
begin <*single segment transfer was not ok*>
repcount := repcount + 1;
if repcount < 6 then
bytes := 0 <*retry*>
else
begin <*give up*>
repcount := 0;
errorbits := 3;
status (z, logstatus, bytes);
bytes := 512; <*simulate transfer of one segment*>
if logstatus extract 6 <> 2 <*normal answer*> and
logstatus extract 6 <> 1 shift 4 <*malfnct, i.e. bus parity*> then
begin <*simulate end of document*>
curtopbuf := firstbuffer;
goto exit;
end <*simulate*>;
end <*give up*>;
end <*single transfer not ok*>;
end
else
begin <*transfer ok*>
repcount := 0;
if curbufsize <> 512 then
curbufsize := curbufsize - bytes;
end <*transfer ok*>;
curfirstbuf := curfirstbuf + bytes;
segments := bytes shift (-9);
cursegment := cursegment + segments;
goto next_block;
exit:
transfer := curtopbuf <> firstbuffer;
end procedure transfer;
\f
procedure copyarea(tosegm, fromsegm, size);
value tosegm, fromsegm, size;
integer tosegm, fromsegm;
long size;
<* this procedure will perform the actual copying*>
begin
if fpmode then
begin
<*the segments involved in copyarea must be transferred*>
<*to core and locked before data buffer is allocated *>
integer oldtrapmode;
oldtrapmode :=trapmode;
trapmode := 1 shift 1; <*stack alarm masked off*>
trap (maybe_stack);
lock (
transfer, getdevorname,
setshare6, 1 ,
monitor , 3 );
maybe_stack:
if alarmcause extract 24 = -1 then
alarm ( <:process too small:> ) else
if alarmcause extract 24 < 0 then
alarm ( <:alarm:> );
trapmode := old_trapmode;
end;
blocklen := system(2 <*free core*>, 0, name)
-1624 <* space for local variables and procedure calls *>;
blocklen := blocklen shift (-9) shift 9;
if blocklen < 512 then alarm (<:process too small:>);
begin
integer i;
integer array todesc, fromdesc(1:20), procdescr (1:1);
zone z(blocklen//4, 1, status);
procedure prepout;
begin
getzone6(z,fromdesc);
setzone6(z,todesc);
output:=true;
end prepout;
procedure prepin;
begin
getzone6(z,todesc);
setzone6(z,fromdesc);
output:=false;
end prepin;
\f
i:=1;
getzone6(z,todesc);
open(z,0,string fromname(increase(i)),-1 shift 2 - 1 shift 8);
<* all except normal answer and stopped *>
if area then
monitor(52,z,0,ia);
monitor(6)initialize:(z,0,ia);
prepout;
i:=1;
open(z,0,string toname(increase(i)),-1 shift 2 - 1 shift 8);
<* all except normal answer and stopped *>
if area then
monitor(52,z,0,ia);
monitor(8)reserve:(z,0,ia);
procdescr (1) := monitor (4, z, 0, procdescr);
if procdescr (1) <> 0 then
begin <*process exists*>
if area then
system (5, procdescr (1) + 10, procdescr); <*main disc*>
system (5, procdescr (1), procdescr); <*procdescr (1) = kind*>
end;
olddisk := procdescr (1) <> 6; <*not exist or kind <> 6*>
prepin;
firstbuffer := fromdesc (19) + 1;
topbuffer := fromdesc (20) * 4 <* buffersize in bytes *>
+ firstbuffer;
getshare6 (z, shdescr, 1);
topfromsegm := size + fromsegm;
toptosegm := size + tosegm;
nextblock:
curtopbuf := topbuffer;
if transfer (z, fromsegm, topfromsegm) then
begin
topinbuf := curtopbuf;
prepout;
transfer (z, tosegm, toptosegm);
prepin;
if topinbuf = curtopbuf then
goto nextblock;
prepout;
end_of_document(z);
prepin;
end;
getshare6(z,shdescr,1);
totalsegments:= shdescr(7) + bytes shift (-9); <* no. of last segment copied *>
close(z,true);
monitor(64)remove process:(z,0,ia);
prepout;
close(z,true);
monitor(64)remove process:(z,0,ia);
prepin;
end;
end copyarea;
\f
boolean procedure getdevorname(getdevice,devno,name,auxname,chain_addr);
boolean getdevice;
integer devno,chain_addr;
real array name,auxname;
begin
integer chainentry, firstdeviceinnametable, device;
integer array coreword(1:1), bspointers(1:3), chainhead(1:17);
real field docname1, docname2, auxcatname1, auxcatname2;
integer field documentnametableaddress;
docname1 := 20; docname2 := docname1 + 4;
documentnametableaddress := docname1 + 6;
auxcatname1:= 10; auxcatname2:= 14;
<* get nametable address of first,top chain *>
system(5, 92, bspointers);
<* get nametable address of first device *>
system(5, 74, coreword);
firstdeviceinnametable := coreword(1);
<* scan all chaintables to find the rigth one *>
for chainentry := bspointers(3) - 2 <* last chaintable *>
step - 2 <* size of nametable entry *>
until bspointers(1) <* first chaintable *>
do
begin
<* get chaintable address *>
system(5, chainentry, coreword);
<* get chainhead from chaintable *>
system(5, coreword(1) - 34, chainhead);
<* compute devicenumber of discdrive *>
device := (chainhead.documentnametableaddress
- firstdeviceinnametable
) // 2;
if chainhead.docname1 shift (-24) extract 24 <> 0 and
(if -, getdevice then
device = devno
else
(name(1) = chainhead.docname1 and
name(2) = chainhead.docname2
)
)
then
goto chaintablefound;
<* this chaintable was not the rigth one *>
end;
<* no chaintables was found good enough *>
getdevorname := true;
goto exit;
chaintablefound:
devno := device;
name(1) := chainhead.docname1;
name(2) := chainhead.docname2;
auxname(1):= chainhead.auxcatname1;
auxname(2):= chainhead.auxcatname2;
chain_addr:= coreword(1);
getdevorname := false;
exit:
end procedure getdevorname;
\f
boolean procedure connect(devno, name);
integer devno;
real array name;
begin
integer repcount;
integer array zdescr(1:20);
real array field zname;
procedure repeatproc(z, s, b);
zone z;
integer s, b;
begin
repcount := repcount + 1;
if repcount < 3 and s = 1 shift 5 then
goto try_once_more;
b := 512;
connect := true;
write (out, <:intervention on :>, <<zdd>, devno);
typetext (<:<10>:>);
end procedure repeatproc;
repcount := 0;
connect := false;
try_once_more:
begin
zone device(128, 1, repeatproc);
zname := 2;
i := 1; open(device, 0, string name(increase(i)), 1 shift 5);
i := monitor(54 <*create peripheral proc*>, device, devno, zdescr);
if i <> 0 then
begin
result(54, <::>, name, i,false);
connect := true;
end
else
begin
inrec6(device, 0); <*try to read a block *>
getzone6(device, zdescr);
name(1) := zdescr.zname(1);
name(2) := zdescr.zname(2);
end;
end;
end procedure connect;
\f
boolean procedure kitoff(docname);
real array docname;
begin
integer array tail (1:10);
long array field dname;
integer i,k;
zone z (512,1,stderror);
long array progname(1:2);
dname := 2; <*fields docname in tail*>
kitoff := false; <*assume succes in removal*>
for i := 1 step 1 until 4 do
ia(17+i) := docname.iaf(i);
k:=monitor(108)delete bs:(z,0,ia);
if k=5 <* area processes exists for same document *> then
begin <*remove area process*>
<*maybe remove program area proc*>
system (2, 0, progname);
open (z, 4, progname, 0);
tail.dname (1) := tail.dname (2) := long <::>;
if monitor (42) lookup tail :(z, i, tail) = 0 and
tail.dname (1) = long docname (1) and
tail.dname (2) = long docname (2) then
begin <*lock all program segments and remove proc*>
if fp_mode then
lockall;
close (z, true);
typetext (<:notice : disc with program file is removed<10>:>);
end else
close (z, false);
<*maybe remove fp area process*>
open (z, 4, <:fp:>, 0);
tail.dname (1) := tail.dname (2) := long <::>;
if monitor (42) lookup tail :(z, i, tail) = 0 and
tail.dname (1) = long docname (1) and
tail.dname (2) = long docname (2) then
begin
close (z, true);
typetext (<:notice : disc with fp prog file is removed<10>:>);
end_action := 1; <*end prog condition := finis*>
end else
close (z, false);
k := monitor (108) delete bs :(z, 0, ia);
end <*remove area processes*>;
if k=6 <* maincat on same document*> then
begin
maincatrem := 0 = monitor(114)remove main catalog:(z,0,ia);
if maincatrem then
typetext (<:notice : disc with main catalog is removed<10>:>);
k:=monitor(108)delete bs:(z,0,ia);
end;
\f
if k<>0 and k<>2 then
begin
kitoff := true;
result(108, <::>, docname, k,true);
end
else
begin
for k:=monitor(110)delete entries:(z,0,ia) while k=3 do;
if k<>0 and k<>7 then
begin
kitoff := true;
result(110, <::>, docname, k,true);
end;
end;
end procedure kitoff;
\f
procedure list_entry(entry,k);
integer k ;
real array entry ;
begin
boolean sp;
long array field entryname;
sp:= false add 32;
entryname:= 6;
outchar(out,10);
write(out,sp,18-write(out,entry.entryname));
if entry.iaf(8) >= 0
then write(out,<<dddddd>,entry.iaf(8))
else write(out,sp,6);
write(out,<<-ddddddd>,sp,5,entry.iaf(2),sp,5,entry.iaf(3));
if k <> 0
then write(out,<: - not ok:>, "nl", 1, <:result = :>,
case k of (
<:function forbidden in calling process:>,
<:catalog i/o error, document not found, state illegal:>,
<:name overlap/exists already:>,
<:calling process not user of the device:>,
<:permkey/interval illegal, chain overlap/outside limits:>,
<:name/docname format illegal, claims exceeded:>,
<:main catalog not present:> ),
"nl", 1);
if -,fp_mode then setposition(out,0,0);
end listentry;
\f
procedure kiton(devno,docname,list,insert_entry_incl,wrkname);
boolean insert__entry_incl,wrkname;
integer devno,list;
real array docname;
begin
long array field auxcat,document;
zone zcat(128,1,ownerror);
integer k,i,catsize, first_slice_chain, last_slice_doc, no_of_slices, chain_length;
integer array shdescr (1:12);
long array field laf;
boolean head_listed;
document:= 16; auxcat:= 6;
laf:=6;
docname(1) := 0;
if connect(devno, docname) then
goto if fp_mode then aftererror else nextline;
i := 1; open (zdisc, 6, string docname (increase (i)), 0);
<*read chain*>
inrec6(zdisc,34);
first_slice_chain := zdisc.iaf (15) extract 12;
last__slice_doc := zdisc.iaf (15) shift (-12) extract 12;
no_of_slices := last_slice_doc - first_slice_chain + 1;
chain_length := ((34 + no_of_slices + 511) // 512) * 512;
setposition (zdisc, 0, 0);
getshare6 (zdisc, shdescr, 1);
shdescr (3) := shdescr (2) + chain_length - 1; <*last sh := first sh + ...*>
setshare6 (zdisc, shdescr, 1);
inrec6 (zdisc, chainlength); <*just the necessary no of segments*>
if -,wrkname then
begin <* create ph. proc. with correct documentname *>
getzone6(zdisc,ia);
for i:= 2 step 1 until 5 do
docname.iaf(i-1):= ia(i):= zdisc.iaf(i+7);
setzone6(zdisc,ia);
monitor(54)create ph proc:(zdisc,devno,ia);
end
else
begin <* insert wrkname for document and auxcat in chainhead *>
for i:= 1 step 1 until 4 do
begin <* save actual names before insertion of wrknames *>
act_auxname.iaf(i):= zdisc.iaf(i+3); <* save auxname *>
act_docname.iaf(i) := zdisc.iaf(i+8); <* save docname *>
end;
monitor(68)generate wrkname:(zcat,0,ia);
getzone6(zcat,ia);
for i:= 1 step 1 until 4 do
begin
zdisc.iaf(i+8):= docname.iaf(i); <* document *>
zdisc.iaf(i+3):= ia(i+1); <* auxcat *>
end;
close(zcat,false);
end;
slicelength:= zdisc.iaf(14);
monitor(8)reserve:(zdisc,i,ia);
k := monitor(102)prepare bs:(zdisc,i,ia);
if k <> 0 then
result(102, <::>, docname, k, true);
if maincatrem then
begin <* connect maincat if possible *>
i:= 1;
open(zcat,4,string zdisc.laf(increase(i)),0);
close(zcat,true); <* remove area process for auxcat *>
maincatname(1):= real<:catal:> add 111;
maincatname(2):= real<:g:>;
maincatrem:= monitor(112)connect maincat:(zdisc,0,maincatname.iaf) <> 0;
write (out,
"nl", 1, <:main catalog :>,
if maincatrem then <:not :> else <: :>, <:reconnected:>);
typetext (<:<10>:>);
end;
if insert_entry_incl then
begin <* insert entries in maincatalog *>
head_listed := false;
i:=1;
open(zcat,4,string zdisc.laf(increase(i)),0);
catsize:=zdisc.iaf(8)*15;
for i:=1 step 1 until catsize do
begin
inrec6(zcat,34);
<*if entry used then insert entry*>
if zcat.iaf(1)<>-1 then
begin
k:= monitor(104)insert entry:(zdisc,0,zcat.iaf);
if not head_listed and
(list = 2
or list = 3 and
(extend zcat.iaf (2) > extend (-8388607)
or extend zcat.iaf (3) < extend 8388605)
or list = 4 and
k > 0 and
k <> 3
or list = 5 and
k = 3) then
begin
write(out,<:<10>*kiton, :>,case list of
(<::>,
<:entries inserted::>,
<:non system entries inserted::>,
<:errors during insertion::>,
<:entries not inserted due to name overlap::>),
<:<10><10>:>,
<:entry name size :>,
<:lower base upper base:>, "nl", 1);
head_listed := true;
end;
case list of
begin
; <* list.no *>
list_entry(zcat,k) ; <* list.yes *>
if extend zcat.iaf(2) > extend (-8388607) or
extend zcat.iaf(3) < extend 8388605
then list_entry(zcat,k) ; <* list.nonsys *>
if k <> 0 and k <> 3
then list_entry(zcat,k) ; <* list.error *>
if k = 3 then list_entry(zcat,0) ; <* list.warning *>
end;
end;
end;
close(zcat,true);
if -,wrkname then close(zdisc,true);
open (zcat, 4, <:fp:>, 0);
if monitor (52) create area proc :(zcat, 1, ia) = 0 then
endaction := 0; <*fp area proc intact*>
close (zcat, false);
end;
end procedure kiton;
\f
procedure lockall;
lock (0, progsize - 1); <*lock all upper part of prog in core*>
\f
boolean procedure next_param(arr,no,type,optional);
value optional ;
boolean optional ;
integer no,type ;
array arr ;
begin comment this procedure returns call-parameter number
'no' in array 'arr'. type-checking is performed
as follows:
type = 1: space-name is demanded
type = 2: point-name is demanded
type = 3: space-integer is demanded
type = 4: point-integer is demanded
type = 5: point-integer or point-name is demanded
'optional' indicates whether the next parameter is
optional or not.
the procedure operates in fp-mode or in
conversational mode. ;
procedure conv_error(number,i,type,delim);
value number,i,type,delim ;
integer number,i,type,delim ;
begin <* error-messages in conversational mode *>
write(out,<:<10>illegal parameter no. :>,no,
<:,must be :>,case type of (<:<sp><name>:>,
<:.<name>:>,<:<sp><integer>:>,
<:.<integer>:>,<:.<integer> or .<name>:>),
<: read: :>);
if delim = 0
then write(out,<:<integer>:>)
else outchar(out,delim);
if kind(i) = 6 <* text *>
then write(out,string ra(increase(i)))
else
if kind(i) = 2 <* legal number *>
then write(out,round ra(i))
else write(out,<: illegal number :>);
write(out,<:<10>:>);
if -,fp_mode then setposition(out,0,0);
goto next_line;
end conv_error;
boolean ok,continue;
real array op_name(1:2);
integer sep,action,number,delim,separator;
if optional then
begin
op_name(1):= arr(1);
op_name(2):= arr(2);
end;
continue:= true;
if fp_mode then
begin <* fp_mode *>
sep:= system(4,no,arr);
if sep <> 0 then
begin
if optional then
begin
if sep = (case type of (space_name,point_name,space_integer,
point_integer)) then
begin
if op_name(1) <> arr(1) or
op_name(2) <> arr(2) then
begin
i:= 1;
write(out,<:<10>illegal parameter no. :>,no,
<:,must be: :>,string op_name(increase(i)));
i:= 1;
write(out,<: read: :>,string arr(increase(i)));
goto endprogram;
end;
end
else
continue:= false;
end optional;
if continue then
begin
case type of
begin
ok:= sep = space_name;
ok:= sep = point_name;
ok:= sep = space_integer;
ok:= sep = point_integer;
begin
type:= if sep = point_name then 2 else 4; <* return-value *>
ok:= sep = point_name or sep = point_integer;
end;
end;
if -,ok then
begin
separator:= 5;
for i:= 1 step 1 until 4 do
if sep = ( case i of (space_name,point_name,space_integer,
point_integer)) then separator:= i ;
write(out,<:<10>***:>,program,<:: illegal fpparameter no. :>,
no,<:,must be :>,case type of (<:<sp><name>:>,
<:.<name>:>,<:<sp><integer>:>,<:.<integer>:>),
<: read::>,case separator of (<:<sp>:>,<:.:>,
<:<sp>:>,<:.:>,<::>));
if separator < 3 <* name *> then
begin
i:= 1;
write(out,string arr(increase(i)));
end
else
write(out,round arr(1));
goto endprogram;
end -, ok;
end;
end;
next_param:= if optional
then continue and sep <> 0
else sep <> 0;
end
else
begin <* conversational mode *>
delim:= 0;
number:= -1;
<* search item *>
for i:= 0,i + 1 while kind(i) <> 8 and number < no do
begin
action:= case ((kind(i)-1)*8 + kind(i+1)) of
<* kind(i+1) *>
( 3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
<* kind(i) *> 3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
3 , 3 , 3 , 3 , 3 , 3 , 3 , 3 ,
3 , 3 , 3 , 3 , 3 , 2 , 2 , 2 ,
1 , 1 , 3 , 3 , 3 , 1 , 2 , 2 ) ;
case action of
begin
number:= number + 1; <* text or integer found *>
; <* skip *>
begin <* error *>
write(out,<:<10>action-table in error:>);
goto endprogram;
end;
end;
end for-loop;
if number = no then
begin <* now 'i' points at the first element of the
item in array 'ra' . get the item and check it . *>
if optional then
begin
if round ra(i-1) = (case type of (32,46,32,46)) then
begin
if op_name(1) <> ra(i) then
begin
j:= 1;
write(out,<:<10>illegal parameter no. :>,no,
<:,must be: :>,string op_name(increase(j)),
<: read: :>,string ra(increase(i)),<:<10>:>);
if -,fp_mode then setposition(out,0,0);
goto next_line;
end;
end
else
continue:= false;
end optional;
if continue then
begin
if kind(i-1) = 7 then delim:= round ra(i-1);
case type of
begin
<* space-name *> if delim <> 32 or kind(i) <> 6
then conv_error(number,i,1,delim);
<* point-name *> if delim <> 46 or kind(i) <> 6
then converror(number,i,2,delim);
<* space-int. *> if delim <> 32 or kind(i) <> 2
then conv_error(number,i,3,delim);
<* point-int. *> if delim <> 46 or kind(i) <> 2
then conv_error(number,i,4,delim);
<* point-int. or
point-name *> begin
if delim=46 and kind(i)=6 then type:= 2 else
if delim=46 and kind(i)=2 then type:= 4 else
conv_error(number,i,5,delim);
end;
end case;
<* return item in 'arr' *>
if type < 3 then
begin <* text *>
arr(1):= ra(i);
arr(2):= if kind(i+1) <> 6 then real <::> else
ra(i+1) shift(-8) shift 8; <* max 11 chars *>
end
else
arr(1):= ra(i);
end;
end;
next_param:= if optional
then continue and number = no <* optional param. present *>
else number = no;
end conversational mode;
if continue then no:= no + 1;
end next_param;
\f
procedure dump_actual_names(devno);
integer devno ;
begin <* dumps actual names of auxcat and document in chainhead. *>
zone zdisc (128, 1, ownerror);
docname(1):= 0;
connect(devno,docname); <* create ph. proc with wrkname *>
i:= 1; open(zdisc,6,string docname(increase(i)),0);
swoprec6(zdisc,34); <* get chainhead *>
for i:= 1 step 1 until 4 do
begin
zdisc.iaf(i+3):= act_auxname.iaf(i); <* reestablish auxname *>
zdisc.iaf(i+8):= act_docname.iaf(i); <* reestablish docname *>
end;
close(zdisc,true);
monitor(64)remove process:(zdisc,0,ia);
end;
\f
integer procedure convert_to_number(arr);
array arr ;
begin
integer i;
convert_to_number:= 13;
for i:= 1 step 1 until 12 do
begin
if arr(1) = ( case i of ( real<:discc:> add 'o',
real<:kitna:> add 'm',
real<:kiton:> ,
real<:kitof:> add 'f',
real<:packo:> add 'n',
real<:packo:> add 'f',
real<:kitla:> add 'b',
real<:end:> ,
real<:save:> ,
real<:load:> ,
real<:bin:> ,
real<:typei:> add 'n' )) and
arr(2) = ( case i of ( real<:py:> ,
real<:e:> ,
real<::> ,
real<::> ,
real<::> ,
real<:f:> ,
real<:el:> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ,
real<::> ))
then convert_to_number:= i;
end;
end convert_to_number;
\f
procedure outtable(alphabet,length);
value length ;
integer length ;
integer array alphabet ;
begin
zone alpha(25,1,blockproc);
integer class,char,i;
procedure blockproc(z,s,b);
zone z ;
integer s,b ;
if (s shift (-5)) extract 1 <> 1 then stderror(z,s,b) else b:= 25*4;
if length < 0 or length > 127 then length:= 127;
open(alpha,0,<::>,1 shift 5);
for i:= 0 step 1 until length do write(alpha,false add i,1);
write(alpha,false add 10,1);
setposition(alpha,0,0);
for i:= 0 step 1 until length do
begin
class:= readchar(alpha,char);
if char <> i then
begin
class:= 0;
repeatchar(alpha);
end;
alphabet(i):= class shift 12 + i;
end;
end outtable;
integer procedure convert_param(arr);
array arr ;
begin
integer i;
convert_param:= 7;
for i:= 1 step 1 until 6 do
if arr (1) = ( case i of (
real<:from:> ,
real<:to:> ,
real<:scope:> ,
real<:base:> ,
real<:list:> ,
real<:check:> add 'r' )) then
convert_param := i;
end;
\f
procedure write_error(cause);
string cause ;
begin
write (out, "nl", 1);
if fp_mode then
write (out, <:***:>, program, <:, :>);
write (out, cause, "nl", 1);
if fp_mode
then goto after_error
else
begin
setposition(out,0,0);
goto next_line;
end;
end;
procedure check_scope;
begin
for i:= 1 step 1 until 3 do
if par(1) = (case i of ( real<:syste:> add 109,
real<:proje:> add 99 ,
real<:user:> )) and
par(2) = (case i of ( real<::> ,
real<:t:> ,
real<::> ))
then scopetype:= i;
if scopetype = 0
then writeerror(<:scope must be 'system','project' or 'user':>);
end;
\f
boolean procedure entry_ok(entry,names,entry_found);
real array entry,names ;
boolean array entry_found ;
begin <* this procedure checks a catalogentry according to
the call-parameters. *>
integer i;
boolean ok;
real array entryname(1:2);
<* check base *>
entrybase(1):= entry.iaf(2);
entrybase(2):= entry.iaf(3);
if base
then ok:= extend entrybase(1) >= extend base_lower and
extend entrybase(2) <= extend base_upper and
entry.iaf(1) extract 3 >= 2 <* min auxcat permkey *>
else ok:= extend entrybase(1) = extend base_lower and
extend entrybase(2) = extend base_upper and
entry.iaf(1) extract 3 = 3; <* permkey *>
if ok then
begin
<* check if entryname match with entrynames in call - if any *>
if firstentryname > 0 then
begin
for i:= 1 step 1 until 4 do
entryname.iaf(i):= entry.iaf(i+3); <* get entryname *>
ok:= false;
for i:= 1,i+1 while i <= no_of_entries and -,ok do
if entryname(1) = names(i,1) and
entryname(2) = names(i,2) then
ok:= entry_found(i):= true;
end;
end;
entry_ok:= ok;
end entry_ok;
\f
procedure initbases;
begin
integer array iarr(1:8);
system(11)catalog bases:(i,iarr);
ownbase(1):= iarr(1);
ownbase(2):= iarr(2);
if -,base then
begin
base_lower:= (case scopetype of (-8388607,iarr(7),iarr(5)));
base_upper:= (case scopetype of (8388605 ,iarr(8),iarr(6)));
end;
end;
\f
procedure set_catbase (base);
integer array base ;
<***********************************************************>
<* *>
<* The procedure changes the catalog base of own process *>
<* to the base given. *>
<* If the result becomes 4 : new base illegal, it is sup- *>
<* posed that the new base is outside the max base of the *>
<* process and the procedure will set cat base to max base.*>
<* *>
<* Call : set_catbase (entry); *>
<* *>
<* base (call value, integer array). The new base *>
<* in base (1:2). *>
<* *>
<***********************************************************>
begin
own
boolean called_before;
integer i;
integer array own_bases (1:8);
integer result;
integer array field max;
zone z (1, 1, stderror);
if -,called_before then
begin
called_before := true;
reset_catbase; <*init reset catbase*>
end;
open (z, 0, <::>, 0); <*own process*>
close (z, true);
for i := 1, 2 do own_bases (i) := base (i);
<*to avoid fielding in call of system*>
result := monitor (72, z, 0, own_bases);
if result = 4 then
begin <*outside max*>
max := 12; <*fields max base in own_bases (7:8)*>
system (11 )bases:( 0, own_bases);
set_catbase (own_bases.max);
end <*outside max*> else
if result <> 0 then
system (9, result, <:<10>cat base:>);
end set_catbase;
\f
procedure reset_catbase;
<***********************************************************>
<* *>
<* The procedure resets the catbase of own process *>
<* to the original catbase before the first change *>
<* of catbase by a call of set_catbase. *>
<* *>
<***********************************************************>
begin
own
boolean called_before;
own
integer catbase_lower, catbase_upper;
if -,called_before then
begin <*save catbase and init branch*>
called_before := true;
catbase_lower := ownbase (1);
catbase_upper := ownbase (2);
reset_catbase;
end else
begin <*set catbase*>
integer array catbase (1:2);
catbase (1) := catbase_lower;
catbase (2) := catbase_upper;
set_catbase (catbase);
end <*set catbase*>;
end reset_catbase;
\f
procedure read_base_params;
begin
integer array iarr(1:8);
integer type;
type:= 5; <* name or integer *>
if next_param(par,paramno,type,false) then
begin
if type = 4 <* returnvalue - integer *> then
begin
base_lower:= round par(1);
if next_param(par,paramno,4,false)
then base_upper:= round par(1)
else writeerror(<:upper base is missing:>);
if base_upper < base_lower then
writeerror(<:'upper-base' is less than 'lower-base':>);
end
else
begin <* returnvalue - text *>
basetype:= if par(1) = real<:syste:> add 109 then 1 else
if par(1) = real<:proje:> add 99 and
par(2) = real<:t:> then 2 else
if par(1) = real<:user:> then 3 else 0;
if basetype = 0 then
writeerror(<:'base' must be 'system','project' or 'user':>)
else
begin
system(11)process bases:(i,iarr);
base_lower:= (case basetype of (-8388607,iarr(7),iarr(5)) );
base_upper:= (case basetype of (8388605 ,iarr(8),iarr(6)) );
end;
end
end
else
writeerror(<:'base-params' are incomplete:>);
end read_base_params;
\f
procedure call_save(displ);
value displ ;
integer displ ;
begin
zone zcat(128,1,caterror);
integer k,i,first_slice;
integer array core,chain_start(1:1);
long array entryname(1:2);
real array from_docname(1:2);
boolean anywhere,listing,found,head;
area:= found:= true;
base:= scope:= head:= listing:= checkread:= false;
basetype:= firstentryname:= scopetype:= segments:= slices:= entries:= 0;
no_of_entries:= 1;
paramno:= 1+displ;
docname(1):= docname(2):= 0;
todevno:= -1;
while next_param(par,paramno,1,false) do
begin
case convert_param(par) of
begin
begin <* from *>
if next_param(par,paramno,2,false) then
begin
from_docname(1):= docname(1):= par(1);
from_docname(2):= docname(2):= par(2);
end
else
write_error(<:no document-name :>);
end;
begin <* to *>
if next_param(par,paramno,4,false)
then todevno:= round par(1)
else write_error(<:no device-number:>);
end;
begin <* scope *>
scope:= true;
if todevno < 0 then
writeerror(<:to.<devno> must be specified before scope:>);
if next_param(par,paramno,2,false)
then check_scope
else writeerror(<:'scope'-parameters are incomplete:>);
end;
begin <* base *>
base:= true;
if todevno < 0 then
writeerror(<:to.<devno> must be specified before base:>);
read_base_params;
end;
begin <* list *>
if next_param(par,paramno,2,false) then
begin
if par(1) <> real<:no:> and
par(1) <> real<:yes:>
then writeerror(<:listoption must be 'yes' or 'no':>)
else listing:= par(1) = real<:yes:>;
end
else
writeerror(<:no listoption:>);
end;
begin <* checkread *>
set_checkread;
end;
begin <* entrynames *>
if todevno < 0 then
writeerror(<:to.<devno> must be specified before entrynames:>)
else
begin
firstentryname:= paramno-1;
no_of_entries:= 1;
while next_param(par,paramno,1,false) do no_of_entries:= no_of_entries+1;
end
end entrynames;
end case;
end while-loop;
begin
real array names(1:no_of_entries,1:2);
boolean array entry_found(1:no_of_entries);
if todevno < 0 then
writeerror(<:to.<devno> must be specified :>);
if firstentryname > 0 then
begin
paramno:= firstentryname;
for i:= 1 step 1 until no_of_entries do
begin
next_param(par,paramno,1,false);
names(i,1):= par(1);
names(i,2):= par(2);
entry_found(i):= false;
end;
end;
if -,base and -,scope then scopetype:= 1; <* default scope.system *>
anywhere:= docname(1) = 0;
if -,anywhere then
begin
if get_dev_or_name(true,devno,docname,auxname,chain_addr)
then writeerror(<:source disc does not exist:>);
end;
kiton(todevno,docname,1,true,true); <* include to-device *>
for i:= 1 step 1 until 4 do ia(17+i):= docname.iaf(i);
initbases;
i:= 1;
if listing then write(out,<:<12><10>entries saved on :>,
string act_docname(increase(i)),<::<10><10>:>,
<:entryname :>,
<:size lower-base upper-base:>);
i:= 1;
open(zcat,4,if anywhere then <:catalog:> else string auxname(increase(i)),1 shift 18);
comment scan catalog ( auxiliary or maincat );
for i:= inrec6(zcat,34) while i > 0 do
begin <* check entry *>
if zcat.iaf(1) <> -1 <* used catalog entry *> then
begin
fromname(1):= zcat.areaname(1);
fromname(2):= zcat.areaname(2);
if entry_ok(zcat,names,entry_found) then
begin <* entry ok - try to save it *>
zone z(1,1,stderror);
set_catbase (entry_base);
i:= 1;
open(z,0,string fromname(increase(i)),0);
monitor(76)head and tail:(z,0,ia);
close(z,false);
reset_catbase;
if -,anywhere then
begin <* the entry is checked to be ok so far - check if *>
<* correct document *>
first_slice:= ia(1) shift (-12) extract 12;
if first_slice >= 2048 <* non area entry *> then
begin <* compute chain table address *>
system(5,92,core);
system(5,core(1) + (first_slice - 2048),chain_start);
found:= chain_start(1) = chain_addr;
end
else
found:= from_docname.iaf(1) = ia(9) and
from_docname.iaf(2) = ia(10) and
from_docname.iaf(3) = ia(11) and
from_docname.iaf(4) = ia(12);
end;
if found then
begin
open(z,0,<::>,0);
set_catbase (entry_base);
k:= monitor(120)create aux entry:(z,0,ia);
reset_catbase;
if k <> 0 then
begin
if k = 3 <* nameoverlap *> then
begin
i:= 1;
write(out,<:<10>entry already exists in auxcat ::>,
string fromname(increase(i)) );
if -,fp_mode then setposition(out,0,0) else
errorbits := 1 shift 1; <*warning.yes ok.yes*>
end
else
begin
close (zcat, true);
kitoff (docname);
dump_actual_names (to_devno);
result(120, <::>, fromname,k,true);
end;
end
else
begin
entries:= entries+1;
if listing then list_entry(zcat,0);
set_catbase (entry_base);
if ia(8) > 0 <* area describing entry *> then
begin
close(z,false);
getzone(z,zdescr);
for i:= 2 step 1 until 5 do toname.iaf(i-1):=zdescr(i);
copyarea(0,0,maximum);
segments := segments + ia (8); <*size*>
slices := slices + (ia (8) - 1) // slicelength + 1;
end
else
begin <* remove area process *>
close(z,true);
monitor(64)remove process:(z,0,ia);
end;
reset_catbase;
end;
end;
end;
end;
end while_loop;
close(zdisc,true);
close(zcat,true);
kitoff(docname);
dump_actual_names(todevno);
if entries > 0 then
begin
write(out,<:<10><10>:>,<<dddd>,entries,<: entries, :>,
<<dddddddd>,segments,<: segments<10>:>,<<dddd>,
slices,<: slices *:>,slicelength,<: =:>,<<ddddd>,
slices*slicelength,<: segments<10><10>:>);
if -,fp_mode then setposition(out,0,0);
end;
if firstentryname > 0 then
begin <* check if all entries are saved *>
for i:= 1 step 1 until no_of_entries do
if -,entry_found(i) then
begin
if -,head then
begin
write(out,<:<10>***entries not found :<10>:>);
errorbits := 1 shift 1; <*warning.yes, ok.yes*>
head:= true;
j:= 0;
end;
entryname(1):= long names(i,1);
entryname(2):= long names(i,2);
j:= j + write(out,false add 32,2,entryname);
if j > 65 then begin j:= 0; typetext(<:<10>:>) end;
end;
typetext(<:<10>:>);
end;
end;
end call_save;
\f
procedure call_load(displ);
value displ ;
integer displ ;
begin
integer array tail(1:10),core,chain_start(1:1);
long array entryname(1:2);
real array wrkname,name,fromkitname,old_docname(1:2);
integer i,k,pos1,pos2,first_slice,act_chain_addr;
boolean listing,head,ok;
zone zwrk,z(1,1,stderror),zcat(128,1,caterror);
basetype:= scopetype:= segments:= slices:= entries:= 0;
area:= true;
base:= scope:= head:= listing:= checkread:= false;
firstentryname:= 0;
no_of_entries:= 1;
paramno:= 1+displ;
docname(1):= docname(2):= 0;
fromdevno:= -1;
while next_param(par,paramno,1,false) do
begin
case convert_param(par) of
begin
begin <* from *>
if next_param(par,paramno,4,false)
then fromdevno:= round par(1)
else writeerror(<:no 'from'-devicenumber:>);
end;
begin <* to *>
if next_param(par,paramno,2,false) then
begin
docname(1):= par(1);
docname(2):= par(2);
end
else
writeerror(<:no 'to'-documentname:>);
end;
begin <* scope *>
scope:= true;
if docname(1) = 0 then
writeerror(<:to.<docname> must be specified before scope:>)
else
if fromdevno < 0 then
writeerror(<:from.<devno> must be specified before scope:>)
else
begin
if next_param(par,paramno,2,false)
then check_scope
else writeerror(<:'scope'_parameters are incomplete:>);
end;
end;
begin <* base *>
base:= true;
if docname(1) = 0 then
writeerror(<:to.<docname> must be specified before base :>)
else
if fromdevno < 0 then
writeerror(<:from.<devno> must be specified before base :>)
else
read_base_params;
end;
begin <* list *>
if next_param(par,paramno,2,false) then
begin
if par(1) <> real<:no:> and
par(1) <> real<:yes:>
then writeerror(<:listoption must be 'yes' or 'no':>)
else listing:= par(1) = real<:yes:>;
end
else
writeerror(<:no listoption :>);
end;
begin <* checkread *>
set_checkread;
end;
begin <* entrynames *>
if docname(1) = 0 then
writeerror(<:to.<docname> must be specified before entrynames:>)
else
if fromdevno < 0 then
writeerror(<:from.<devno> must be specified before entrynames:>)
else
begin
firstentryname:= paramno-1;
no_of_entries:= 1;
while next_param(par,paramno,1,false) do
no_of_entries:= no_of_entries+1;
end
end entrynames;
end case;
end while-loop;
begin
real array names(1:no_of_entries,1:2);
boolean array entry_found(1:no_of_entries);
for i:= 1 step 1 until no_of_entries do entry_found(i):= false;
if docname(1) = 0 or fromdevno < 0 then
writeerror(<:from.<devno> and to.<docname> must be specified:>);
if firstentryname > 0 then
begin
paramno:= firstentryname;
for i:= 1 step 1 until no_of_entries do
begin
next_param(par,paramno,1,false);
names(i,1):= par(1);
names(i,2):= par(2);
end;
end;
if -,base and -,scope then scopetype:= 1; <* default scope.system *>
if get_dev_or_name(true,devno,docname,auxname,act_chain_addr) then
writeerror(<:object disc not included in bs-system:>);
initbases;
kiton(fromdevno,fromkitname,1,false,true); <* entries are not inserted *>
<* get name of auxcat *>
get_dev_or_name(true,fromdevno,fromkitname,auxname,chain_addr);
i:= 1;
if listing then write(out,<:<12><10>entries loaded to :>,
string docname(increase(i)),<::<10><10>:>,
<:entryname :>,
<:size lower-base upper-base:>);
i:= 1;
open(zcat,4,string auxname(increase(i)),1 shift 18);
comment scan auxiliary catalog;
inrec_entry:
for i:= inrec6(zcat,34) while i > 0 do
begin
if zcat.iaf(1) <> -1 then
begin
if entry_ok(zcat,names,entry_found) then
begin <* entry ok - load it *>
toname(1):= zcat.areaname(1);
toname(2):= zcat.areaname(2);
set_catbase (entry_base);
monitor(68)generate wrkname:(zwrk,0,entrybase);
getzone(zwrk,zdescr);
for j:= 2 step 1 until 5 do
begin <* insert wrknames *>
old_docname.iaf(j-1):= zcat.iaf(j+7);
zcat.areaname.iaf(j-1):= fromname.iaf(j-1):= zdescr(j);
zcat.iaf(j+7):= fromkitname.iaf(j-1);
end;
<* insert entry with workname *>
k:= monitor(104)insert entry:(zdisc,0,zcat.iaf);
reset_catbase;
if k <> 0 then
begin
if k = 6 <* claims exceeded *> then
begin <* remove entries inserted with wrknames *>
getposition(zcat,pos1,pos2);
close(zcat,true);
close(zdisc,true);
kitoff(fromkitname);
kiton(fromdevno,fromkitname,1,false,true);
get_dev_or_name(true,fromdevno,fromkitname,auxname,chain_addr);
j:= 1; open(zcat,4,string auxname(increase(j)),1 shift 18);
setposition(zcat,pos1,pos2);
goto inrec_entry;
end
else
begin
close (zcat, true);
kitoff (from_kitname);
result(104, <::>, toname,k,true);
end;
end;
for j:= 1 step 1 until 10 do tail(j):= zcat.iaf(j+7);
j:= 1;
open(z,0,string toname(increase(j)),0);
set_catbase (entry_base);
if monitor(76)head and tail:(z,0,ia) = 0 and
extend ia(2) = extend entrybase(1) and
extend ia(3) = extend entrybase(2) then
begin <* entry included - change it if correct document *>
reset_catbase;
first_slice:= ia(1) shift (-12) extract 12;
if first_slice >= 2048 <* non area entry *> then
begin <* compute chain table address *>
system(5,92,core);
system(5,core(1) + (first_slice-2048),chain_start);
ok:= chain_start(1) = act_chain_addr;
if ok then
for j:= 1 step 1 until 4 do
tail(j+1):= old_docname.iaf(j); <* insert correct document *>
end
else
ok:= ia(9) = docname.iaf(1) and
ia(10) = docname.iaf(2) and
ia(11) = docname.iaf(3) and
ia(12) = docname.iaf(4);
if ok then
begin
set_catbase (entry_base);
monitor (44) change entry :(z, 0, tail);
reset_catbase;
end else
begin
close (z, false);
j:= 1;
write(out,<:<10>entry already included from another document : :>,
string toname(increase(j)) );
if -,fp_mode then setposition(out,0,0) else
errorbits := 1 shift 1; <*warning.yes, ok.yes*>
goto inrec_entry;
end;
end
else
begin <* entry does not exist - create on document specified *>
reset_catbase;
for j:= 1 step 1 until 4 do
tail(j+1):= if zcat.iaf(8) < 0 then old_docname.iaf(j)
else docname.iaf(j);
set_catbase (entry_base);
j:= monitor(40)create entry:(z,0,tail);
reset_catbase;
if j <> 0 then
begin
close (zcat, true);
kitoff (from_kitname);
result(40, <::>, toname,j,true);
end;
set_catbase (entry_base);
j:= monitor(90)perm into auxcat:(z,3,docname.iaf);
reset_catbase;
if j <> 0 then
begin
close (zcat, true);
kitoff (from_kitname);
result(90, <::>, toname,j,true);
end;
end;
if listing then
begin
for j:= 1 step 1 until 4 do
zcat.areaname.iaf(j):= toname.iaf(j);
listentry(zcat,0);
end;
set_catbase (entry_base);
if zcat.iaf(8) > 0 <* area describing entry *> then
begin
copyarea(0,0,maximum);
segments := segments + zcat.iaf (8);
end;
entries := entries + 1;
close(z,true);
reset_catbase;
end;
end;
end while_loop;
close(zdisc,true);
close (zcat,true);
kitoff(fromkitname);
if entries > 0 then
begin
write(out,<:<10><10>:>,<<dddd>,entries,<: entries, :>,
<<dddddddd>,segments,<: segments<10>:>);
if -,fp_mode then setposition(out,0,0);
end;
if firstentryname > 0 then
begin <* check if all entries are loaded *>
for i:= 1 step 1 until no_of_entries do
if -,entry_found(i) then
begin
if -,head then
begin
write(out,<:<10>***entries not found:<10>:>);
errorbits := 1 shift 1; <*warning.yes, ok.yes*>
head:= true;
j:= 0;
end;
entryname(1):= long names(i,1);
entryname(2):= long names(i,2);
j:= j + write(out,false add 32,2,entryname);
if j > 65 then begin j:= 0; typetext(<:<10>:>) end;
end;
typetext(<:<10>:>);
end;
end;
end call_load;
\f
procedure call_bin(displ);
value displ ;
integer displ ;
begin
boolean all,all_from,all_to;
integer no_of_devices,physical_disc__addr,i, maincatdev, mainautodev;
integer array core(1:2), main (1:1), proc (1:30);
real array main_name, mainautoname (1:2);
long array field laf;
all_from:= all_to:= all:= area:= checkread:= false;
todevno:= fromdevno:= -1;
laf := 0;
paramno:= displ + 1;
if -,next_param(par,paramno,1,false) then
begin <* no parameters - copy specified parts of discpacks *>
call_spec;
goto if fp_mode then endprogram else nextline;
end
else paramno:= paramno-1;
while next_param(par,paramno,1,false) do
begin
case convert_param(par) of
begin
begin <* from *>
next_param(par,paramno,4,false);
fromdevno:= round par(1);
par(1):= real<:all:>;
par(2):= real<::>;
<* all-param is optional *>
if next_param(par,paramno,2,true) then all:= all_from:= true;
end;
begin <* to *>
next_param(par,paramno,4,false);
todevno:= round par(1);
par(1):= real <:all:>; <* all-param is optional *>
par(2):= real<::>;
if next_param(par,paramno,2,true) then all:= all_to:= true;
end;;;;
begin <* checkread *>
set_checkread;
end;
begin
i:= 1;
write(out,<:illegal parameter : :>,string par(increase(i)));
if fp_mode
then goto after_error
else
begin
setposition(out,0,0);
goto nextline;
end;
end;
end case;
end while-loop;
if todevno < 0 or fromdevno < 0
then writeerror(<:to.<devno> and from.<devno> must be specified:>);
system (5) move core :( 98, core); <*chaintable maincatdev*>
system (5) move core :(core (1) - 10, core); <*name table address *>
system (5) move core :(core (1) , core); <*proc descr address *>
system (5) move core :(core (1) + 2, main_name); <*proc name *>
system (5) move core :(core (1) + 10, main ); <*main process *>
maincatdev := device_number (core (1)); <*device number*>
system(5)move core area:(74,core);
no_of_devices:= (core(2) - core(1))//2 ;
begin
integer array device_addr(0:no_of_devices - 1);
boolean array remember (0 : no_of_devices - 1);
boolean error, maincatdev_wr_enabled;
integer array field iff;
iff := -2;
for i := 0 step 1 until no_of_devices - 1 do
begin
remember (i) := false;
j := process_description (i, proc);
if (proc ( 1) = 62
or proc ( 1) = 6) and
proc ( 6) = main (1) and
proc (15) = 0 <*first segment*> then
begin <*autoload disc on same physical as maincat disc*>
main_auto_dev := i;
system (5) move core :(j + 2, main_auto_name);
end;
end;
error := maincatdev_wr_enabled := false;
<*decide whether or not to be copied from or to physical disc *>
system(5)move core area:(core(1),device_addr.iff);
<*get physical source disc*>
physical_disc_addr := deviceaddr (fromdevno);
system (5) move core :(deviceaddr (fromdevno), ia);
if ia (1) = 6 then
system (5) move core :(ia (6), main); <*get main*>
if ia (1) = 62 <*disc not ida*> and
ia (6) = 0 <*no main *>
or ia (1) = 6 <*disc ida*> and
main (1) = 20 <*main is ida*> then
begin <*from device is itself a physical disc*>
physical_disc_addr := device_addr (fromdevno);
all := all_from := true;
end else
if ia (1) = 62 <*disc not ida*> and
ia (6) > 0 <*has a main *>
or ia (1) = 6 <*disc ida*> and
main (1) = 6 <*main is ida*> then
physical_disc_addr := ia (6); <*main*>
if all_from then
begin <*get dev no of physical disc*>
for devno := 0 step 1 until no_of_devices - 1 do
if device_addr (devno) = physical_disc_addr then
begin
from_devno := devno;
devno := noofdevices;
end;
system (5) move core :(physical_disc_addr, ia);
if ia (1) = 6 then
begin <*ida, pack it off*>
trap (on_again);
packoff (fromdevno, false) <*no power down*>
end else
begin <*not ida*>
for devno := 0 step 1 until no_of_devices - 1 do
begin <*kitoff logical discs on the physical*>
system (5) move core :(deviceaddr (devno), ia);
if (ia (1) = 62 <*disc not ida*>
or ia (1) = 6 <*disc ida*>) and
ia (6) = physical_disc_addr then
begin
if -,getdevorname (false, devno, docname, auxname,
chainaddr) then
begin
if -,kitoff ( docname) then
begin
write (out,
"nl", 1, true, 12, docname.laf, <: dismounted from :>,
<<ddd>, devno);
typetext (<:<10>:>);
trap (on_again);
remember (devno) := true;
end;
end;
end;
end <*kitoff*>;
end <*not ida*>;
end <*get device number of physical source disc*>;
<*get physical object disc*>
system (5) move core :(deviceaddr (todevno), ia);
if ia (1) = 6 then
system (5) move core :(ia (6), main);
if ia (1) = 62 <*disc not ida*> and
ia (6) = 0 <*has no main*>
or ia (1) = 6 <*disc ida*> and
main (1) = 20 <*main is ida*> then
begin <*to device is itselt a physical disc*>
physical_disc_addr := device_addr (todevno);
all := all_to := true;
end else
if ia (1) = 62 <*disc not ida*> and
ia (6) > 0 <*has a main *>
or ia (1) = 6 <*disc ida*> and
main (1) = 6 <*has a main *> then
physical_disc_addr := ia (6);
if all_to then
begin <*get device no of physical disc*>
for devno := 0 step 1 until no_of_devices - 1 do
if deviceaddr (devno) = physical_disc_addr then
begin todevno := devno; devno := noofdevices; end;
end <*get*>;
if all then
begin
write(out,<:<10>source disc: :>,fromdevno,
<:<10>object disc: :>,todevno,<:<10>:>);
if -,fp_mode then setposition(out,0,0);
end;
toname (1) := 0;
if connect (todevno, toname) then
type_text (<:<10>object disc not connected<10>:>)
else
begin <*todev connected*>
if -,get_dev_or_name (false, fromdevno, docname, auxname, chainaddr) then
begin
if -,kitoff (docname) then
begin
write (out,
"nl", 1, true, 12, docname.laf, <: dismounted from :>,
<<ddd>, fromdevno);
typetext (<:<10>:>);
trap (on_again);
remember (fromdevno) := true;
end;
end;
fromname (1) := 0;
if connect (fromdevno, fromname) then
type_text (<:<10>source disc not connected<10>:>)
else
begin <*fromdev connected*>
copyarea (0, 0, maximum);
write (out,
"nl", 1, <:copying terminated:>,
"nl", 1, <:number of segments copied : :>,
<<ddddddd>, totalsegments);
typetext (<:<10>:>);
end <*fromdev connected*>;
end <*todev connected*>;
on_again:
trap (0);
<*check if disc with maincat is wr enabled*>
maincatdev_wr_enabled :=
if mainautoname (1) shift (-24) extract 24 = 0 then
-,connect (mainautodev, mainautoname)
else
true;
if maincatdev_wr_enabled then
begin <*connectable*>
zone z (128, 1, check_malfnc);
procedure check_malfnc (z, s, b);
zone z ;
integer s, b ;
begin
if s extract 1 = 1 then
stderror (z, s, b)
else
begin
maincatdev_wr_enabled := false;
b := 512;
s := 0;
end;
end check_malfnc;
laf := 0;
open (z, 6, main_auto_name.laf, 60); <*dummy answer*>
monitor (8) reserve :(z, 1, core);
maincatdev_wr_enabled := true;
inrec_6 (z, 512);
setposition (z, 0, 0);
outrec6 (z, 512);
close (z, true); <*release process*>
end <*connectable*>;
if -,maincatdev_wr_enabled then
write (out,
"nl", 1,
<:notice : disc with main catalog disconnected or write protected:>)
else
if all_from then
begin <*if ida then packon again*>
system (5) move core :(device_addr (from_devno), ia);
if ia (1) = 6 <*ida disc*> then
pack_on (from_devno, false, 5); <*no power up, list.warning*>
end;
if remember (maincatdev) or main_cat_rem then
begin <*write enabled and dismounted*>
kiton (maincatdev, docname, 4 <*list error*>, true <*insert bs*>,
false <*wrk name*>);
for i := 1 step 1 until 4 do
ia (17 + i) := docname.iaf (i);
i := monitor (106) insert bs :(out, 0, ia);
if i <> 0 then
result (106, <::>, docname, i, false);
remember (maincatdev) := false;
write (out,
"nl", 1, true, 12, docname.laf,
if i <> 0 then <: not:> else <::>,
<: mounted on :>, <<ddd>, maincatdev);
end <*write enabled and dismounted*>;
typetext (<:<10>:>);
if maincatdev_wr_enabled then
begin <*kit on discs previously kitted of*>
for devno := 0 step 1 until no_of_devices - 1 do
if remember (devno) then
begin
kiton (devno, docname, 4 <*list error*>, true <*insert entries*>,
false <*wrk name*>);
for i := 1 step 1 until 4 do
ia (17 + i) := docname.iaf (i);
i := monitor (106) insert bs :(out, 0, ia);
if i <> 0 then
result (106, <::>, docname, i, false);
remember (devno) := false;
write (out,
"nl", 1, true, 12, docname.laf,
if i <> 0 then <: not:> else <::>, <: mounted on :>, <<ddd>, devno);
typetext (<:<10>:>);
end;
end <*kit on discs previously kitted off*>;
if error then
goto if fpmode then aftererror else nextline;
end;
end call_bin;
\f
procedure call_kiton;
begin
integer list,k;
long array field laf;
zone z(1,1,stderror);
list:= 5; <*list.warning as default*>
laf := 0;
paramno:= 1;
if next_param(par,paramno,1,false) then
begin
if par(1) = real <:devno:> then
begin
if next_param(par,paramno,4,false)
then devno:= round par(1)
else writeerror(<:device-number is missing:>);
end
else
writeerror(<:first parameter must be devno.<devno> :>);
end
else
writeerror(<:no parameters:>);
if next_param(par,paramno,1,false) then
begin
if par(1) = real<:list:> then
begin
if next_param(par,paramno,2,false) then
begin
if par(1) = real<:no:> then else
if par(1) = real<:yes:> then list:= 2 else
if par(1) = real<:nonsy:> add 115 then list:= 3 else
if par(1) = real<:error:> then list:= 4 else
if par(1) = real<:warni:> add 110 and
par(2) = real<:g:> then list:= 5 else
writeerror(<:illegal list-option :>);
end
else
writeerror(<:listoption is missing:>);
end
else
begin
i:= 1;
write(out,<:unknown parameter : :>,string par(increase(i)));
if fp_mode
then goto after_error
else
begin
setposition(out,0,0);
goto next_line;
end;
end;
end;
kiton(devno,fromname,list,true,false);
for i:= 1 step 1 until 4 do ia(17+i):= fromname.iaf(i);
k:= monitor(106)insert bs:(z,0,ia);
if k <> 0 then result(106, <::>, fromname,k, false);
write(out,"nl", 2, true, 12, fromname.laf,
if k <> 0 then <: not:> else <::>, <: mounted on :>,<<ddd>,devno,<:<10>:>);
if -,fp_mode then setposition(out,0,0);
end call_kiton;
\f
procedure call_kitoff;
begin
long array field laf;
laf := 0;
paramno:= 1;
if next_param(par,paramno,1,false) then
begin
if par(1) = real<:devno:> then
begin
if next_param(par,paramno,4,false)
then devno:= round par(1)
else writeerror(<:device-number is missing:>);
end
else
writeerror(<:first parameter must be devno.<devno>:>);
end
else
writeerror(<:no parameters:>);
if -,get_dev_or_name(false,devno,docname,auxname,chain_addr) then
begin
if -,kitoff (docname) then
begin
write (out,
"nl", 1, true, 12, docname.laf, <: dismounted from :>,
<<ddd>, devno);
typetext (<:<10>:>);
end;
end;
end call_kitoff;
\f
procedure mount_disc;
begin
integer list;
list:= 5; <*list.warning as default*>
paramno:= 1;
if next_param(par,paramno,1,false) then
begin
if par(1) = real <:devno:> then
begin
if next_param(par,paramno,4,false)
then devno:= round par(1)
else writeerror(<:device-number is missing:>);
end
else
writeerror(<:first parameter must be devno.<devno> :>);
end
else
writeerror(<:no parameters:>);
if next_param(par,paramno,1,false) then
begin
if par(1) = real<:list:> then
begin
if next_param(par,paramno,2,false) then
begin
if par(1) = real<:no:> then else
if par(1) = real<:yes:> then list:= 2 else
if par(1) = real<:nonsy:> add 115 then list:= 3 else
if par(1) = real<:error:> then list:= 4 else
if par(1) = real<:warni:> add 110 and
par(2) = real<:g:> then list:= 5 else
writeerror(<:illegal list-option :>);
end
else
writeerror(<:listoption is missing:>);
end
else
begin
i:= 1;
write(out,<:unknown parameter : :>,string par(increase(i)));
if fp_mode
then goto after_error
else
begin
setposition(out,0,0);
goto next_line;
end;
end;
end;
pack_on (devno, true, list); <*power up*>
end procedure mount_disc;
procedure pack_on (devno, power_up, list);
value devno ;
integer devno, list ;
boolean power_up ;
begin
integer k, disc_count, disc_descr_size, disc;
integer first_segment, segments, type, log_devno;
integer array field log_entry;
long array field laf;
integer field count_f;
integer array field iaf;
real array field raf;
real array za (1:128);
zone z(128,1,stderror);
laf := 0;
process_description (devno, ia);
if ia(1)<>6 then
begin
writeerror (<:not connected or not ida disc:>);
end;
raf:= 2; iaf:= 0;
tofrom (docname, ia.raf, 8);
if ia(8) shift (-12) <> 0 then
write_error (<:not physical disc:>);
if docname.iaf(1) = 0 then
begin
if connect (devno, docname) then
begin
if fp_mode then goto after_error
else goto next_line;
end;
end;
open (z, 0, docname, 0);
if power_up then
begin
monitor (8, z, i, ia);
getshare6 (z, shdescr, 1);
for i:= 4 step 1 until 7 do shdescr(i):= 0;
shdescr(4):= 10 shift 12 + 0; <* power up spindle *>
setshare6 (z, shdescr, 1);
i:= 1;
monitor (16, z, i, ia); <* send message *>
i :=
monitor (18, z, i, shdescr); <* wait answer *>
monitor (10, z, 0, ia);
if i<>1 then result(-1, <:power up spindle:>, docname, i, true);
end;
setposition (z, 0, 0);
inrec6 (z, 512);
tofrom (za, z, 512);
close (z, false);
process_description (devno, ia);
system (5, ia(6), ia);
tofrom (docname, ia.raf, 8);
open (z, 0, docname, 0);
count_f := 2; <* files in autoload description *>
count_f := (za.count_f*4) + 4; <* logical disc files *>
disc_descr_size := za.count_f shift (-12) extract 12;
disc_count := za.count_f extract 12;
log_entry:= count_f;
for disc:= 1 step 1 until disc_count do
begin comment linkup logical discs;
first_segment:= za.log_entry(1);
segments:= za.log_entry(2);
type:= za.log_entry(3) shift (-12);
log_devno:= za.log_entry(3) extract 12;
getshare6 (z, shdescr, 1);
shdescr(4):= 16 shift 12 + (type extract 1); <* link logical disc *>
shdescr(5):= log_devno;
shdescr(6):= devno;
shdescr(7):= first_segment;
shdescr(8):= segments;
setshare6 (z, shdescr, 1);
i:= 1;
monitor(16, z, i, ia);
i:= monitor(18, z, i, ia);
if i<>1 then
begin
write (out, <:<10>linkup logical disc, devno=:>, << dd>, log_devno,
<:, on device=:>, devno,
<:, result=:>, i);
if fp_mode then goto after_error else
begin
setposition (out, 0, 0);
goto next_line;
end;
end;
log_devno:= ia(2);
if type shift (-1) = 1 then
begin comment catalog on disc;
kiton(log_devno,fromname,list,true,false);
for i:= 1 step 1 until 4 do ia(17+i):= fromname.iaf(i);
k:= monitor(106)insert bs:(z,0,ia);
if k <> 0 then result(106, <::>, fromname,k, false);
write (out,
"nl", 2, true, 12, fromname.laf,
if k <> 0 then <: not:> else <::>, <: mounted on :>, <<ddd>, logdevno);
typetext (<:<10>:>);
end else
begin comment disc has no katalog;
real array docname (1:2);
docname(1):= real<::>;
if connect (log_devno, docname) then
begin
if fp_mode then goto after_error else
begin
setposition (out, 0, 0);
goto next_line;
end;
end;
write (out,
"nl", 1, true, 12, docname.laf, <: mounted on :>, <<ddd>, logdevno);
typetext (<: - no auxcat -<10>:>);
if -, fp_mode then setposition (out, 0, 0);
end;
log_entry:= log_entry + disc_descr_size;
end;
close (z, false);
if -,fp_mode then setposition(out,0,0);
end pack_on;
\f
procedure remove_disc;
begin
paramno:= 1;
if next_param(par,paramno,1,false) then
begin
if par(1) = real<:devno:> then
begin
if next_param(par,paramno,4,false)
then devno:= round par(1)
else writeerror(<:device-number is missing:>);
end
else
writeerror(<:first parameter must be devno.<devno>:>);
end
else
writeerror(<:no parameters:>);
pack_off (devno, true); <*power down*>
end procedure remove_disc;
procedure pack_off (devno, power_down);
value devno ;
integer devno ;
boolean power_down ;
begin
integer log_devno, next_logical, log_disc;
long array field laf;
integer array field iaf;
real array field raf;
zone z (1, 1, stderror);
laf := 0;
next_logical:= process_description (devno, ia)+22;
if ia(1)<>6 then write_error (<:not connected or not ida disc:>);
if ia(8) shift (-12)<>0 then write_error (<:not physical disc:>);
system (5, ia(6), ia);
raf:= 2;iaf:= 0;
tofrom (docname, ia.raf, 8);
open (z, 0, docname, 0);
system (5, next_logical, ia);
log_disc:= ia(1);
close (z, false);
while log_disc > 0 do
begin
system (5, log_disc, ia);
tofrom (docname, ia.raf, 8);
log_devno:= device_number (log_disc);
if ia(8) shift (-13) extract 11 = 1 then
begin
if -,kitoff (docname) then
begin
write (out,
"nl", 1, true, 12, docname.laf, <: dismounted from :>,
<<ddd>, logdevno);
typetext (<:<10>:>);
end;
end;
getshare6 (z, shdescr, 1);
for i:= 4 step 1 until 8 do shdescr(i):= 0;
shdescr(4):= 18 shift 12 + 0; <* unlink logical disc *>
shdescr(5):= log_devno;
setshare6 (z, shdescr, 1);
i:=1;
monitor (16, z, i, shdescr);
i:= monitor (18, z, i, ia);
if i<>1 then
begin
result (-1, <:unlink logical disc:>, docname, i, false);
end;
system (5, next_logical, ia);
log_disc:= ia(1);
end;
process_description (devno, ia);
tofrom (docname, ia.raf, 8);
if docname.iaf(1)=0 then connect (devno, docname);
if power_down then
begin
open (z, 0, docname, 0);
close (z, false);
monitor (8, z, i, ia);
getshare6 (z, shdescr, 1);
for i:= 4 step 1 until 5 do shdescr(i):= 0;
shdescr(4):= 12 shift 12 + 0; <* power down spindle *>
setshare6 (z, shdescr, 1);
i:= 1;
monitor (16, z, i, ia);
i:= monitor (18, z, i, ia);
if i<>1 then result (-1, <:power down spindle:>, docname, i, false);
monitor (10, z, 1, ia);
end <*power down*>;
end pack_off;
\f
procedure call_kitlabel;
begin
integer field devno,catsize,slicelength,size,catfirst,catlast,
lastslice,i,segm;
boolean field slicerel;
integer kind;
integer array ia(1:1);
long array name,auxname(1:2);
zone disc(128,1,stderror);
procedure discerror(z,s,b);
zone z; integer s,b;
begin
own boolean aftererror;
if aftererror then stderror(z,s,b);
aftererror:= true;
goto again;
end;
paramno:= 1;
if next_param(par,paramno,3,false) then
begin
devno:= round par(1); <* devicenumber *>
if next_param(par,paramno,1,false) then
begin
name(1):= long par(1);
name(2):= long par(2) shift (-8) shift 8; <* max 11 chars *>
end
else
writeerror(<:no documentname:>);
if next_param(par,paramno,1,false) then
begin
auxname(1):= long par(1);
auxname(2):= long par(2) shift (-8) shift 8 ; <* max 11 chars *>
end
else
writeerror(<:no auxcat-name:>);
end
else
writeerror(<:no device-number:>);
next_param(par,paramno,1,false);
if par(1) = real<:slow:> then kind:= 1 else
if par(1) = real<:fast:> then kind:= 0 else
writeerror(<:kind must be 'slow' or 'fast':>);
for i:= 1 step 1 until 3 do
begin
if next_param(par,paramno,3,false) then
begin
case i of
begin
catsize:= round par(1);
slicelength:= round par(1);
size:= round par(1);
end;
end
else
case i of
begin
writeerror(<:catsize-param is missing:>);
writeerror(<:slicelength-param is missing:>);
writeerror(<:size-param is missing:>);
end;
end for-loop;
again:
<* compute first, last slice of aux cat *>
catfirst := (( 34 <* size of chainhead *>
+ size <* size of chaintable *>
+ 511) // 512 <* counted in segments *>
+ slicelength - 1 <* round up *>
) // slicelength;
catlast := catfirst + (catsize - 1) // slicelength;
<* compute last slicenumber of disc *>
lastslice:= size - 1;
open(disc, 0, <::>, 0);
<* create peripheral process, wrk-name *>
monitor(54, disc, devno, ia);
<* reserve process *>
monitor(8 , disc, 0 , ia);
<* prepare chainhead *>
outrec6(disc, 34);
for i := 2 step 2 until 34 do
disc.i := case i shift (-1) of
(catfirst shift 12 +kind shift 3 + 3<*1st catslice,kind*8+key*>
, -8388607 <* lower catalog interval *>
, 8388606 <* upper catalog interval *>
, auxname.iaf(1) <* auxcat name *>
, auxname.iaf(2)
, auxname.iaf(3)
, auxname.iaf(4)
, catsize <* size of auxcat *>
, name.iaf(1) <* document name *>
, name.iaf(2)
, name.iaf(3)
, name.iaf(4)
, 0 <* not used *>
, slicelength
, lastslice shift 12 + 0 <* last slice of disc,
first of chain*>
, (-1) shift 12 + 0 <* auxcat, zero *>
, 0 <* zero, zero *>
);
<* initialize chain for chaintable + auxcat *>
outrec6(disc, outrec6(disc, 0));
for slicerel := 1 step 1 until catlast do
disc.slicerel := false add 1;
disc.slicerel := false;
<* clear space between cahintable and catalog *>
outrec6(disc, 0); <* change buffer *>
getposition(disc, 0, segm);
for segm := segm step 1 until catfirst * slicelength - 1 do
outrec6(disc, 512);
<* write empty auxcat *>
setposition(disc, 0, catfirst * slicelength);
for segm := 1 step 1 until catsize do
begin
outrec6(disc, 512);
for i := 2 step 2 until 510 do
disc.i := -1; <* unused catalog entries *>
disc.i := 0; <* entry count *>
end;
<* terminate last block and release disc *>
close(disc, true);
goto if fp_mode then endprogram else nextline;
end call_kitlabel;
\f
procedure call_kitname;
begin <* rename document and auxiliary catalog *>
paramno := 1;
if next_param(par,paramno,3,false) then
devno:= round par(1)
else writeerror(<: devicenumber is missing :>);
if next_param(par,paramno,1,false) then
begin
actdocname(1):= par(1);
actdocname(2):= par(2);
end
else writeerror(<:documentname is missing:>);
if next_param(par,paramno,1,false) then
begin
actauxname(1):= par(1);
actauxname(2):= par(2);
end
else writeerror(<:auxcatname is missing:>);
if -,get_dev_or_name(false,devno,docname,auxname,chain_addr) then kitoff(docname);
dump_actual_names(devno);
end call_name;
\f
procedure call_spec;
begin <* used for copying specified parts of devices *>
typetext(<:to device: :>); typein(todevno);
typetext(<:start segment: :>); typein(tosegm);
typetext(<:from device: :>); typein(fromdevno);
typetext(<:start segment: :>); typein(fromsegm);
typetext(<:number of segments: :>); typein(number_of_segments);
if -,get_dev_or_name(false,todevno,toname,auxname,chain_addr) then kitoff(toname);
if -,get_dev_or_name(false,fromdevno,fromname,auxname,chain_addr) then kitoff(fromname);
toname(1):= 0; connect(todevno,toname);
fromname(1):= 0; connect(fromdevno,fromname);
copyarea(tosegm,fromsegm,extend number_of_segments);
write(out,<:<10>copying terminated<10>:>,
<:number of segments copied: :>,<<ddddddd>,
totalsegments-(if shdescr(4) shift (-12) = 3 <* input *>
then fromsegm else tosegm) );
typetext(<:<10>:>);
end;
procedure set_checkread;
begin
if next_param (par, paramno, 2, false) then
begin
if par (1) = real <:yes:>
or par (1) = real <:no:> then
checkread := par (1) = real <:yes:>
else
write_error (<:checkread option must be 'yes' or 'no':>)
end else
write_error (<:checkread.yes or checkread.no:>);
end set_checkread;
\f
<* m a i n p r o g r a m *>
open(zhelp,0,<::>,0);
trapmode:= 0; <* write all alarms *>
trap(after_error);
maximum:= 10 000 000;
maincat_rem:= false;
area:= false;
areaname:= 6;
ok:= false;
iaf:= 0;
permkey:= 3;
scopetype:= 0;
scope:= base:= false;
space_name:= 4 shift 12 + 10;
point_name:= 8 shift 12 + 10;
space_integer:= 4 shift 12 + 4;
point_integer:= 8 shift 12 + 4;
fp_mode:= true;
checkread := false;
kind(0):= 7; <* delimiter *>
ra(0):= 32 ; <* space *>
base := true;
init_bases;
base := false;
reset_catbase; <*to initialize reset catbase*>
<* decide name of program *>
system(4,0,par);
tofrom(program,par,8);
case convert_to_number(par) of
begin
begin <* disccopy *>
paramno:= 1;
next_param(par,paramno,1,false);
<* decide action *>
type:= convert_to_number(par);
if type < 9 then type:= 13;
case type-8 of
begin
call_save(1);
call_load(1);
call_bin(1) ;
begin <* enter conversational mode *>
fp_mode:= false;
lockall;
<* modify standardalphabet *>
outtable(alphabet,127);
for i:= 39,43,46 do alphabet(i):= 7 shift 12 + i;
intable(alphabet);
tableindex:= 0;
nextline: morelines:= true;
start_pos:= 1;
while morelines do
begin <* read lines of command *>
setposition(in,0,0);
i:= readall(in,ra,kind,start_pos);
if i < 0 then
begin <* array bounds exceeded *>
write(out,<:<10>command too long - last line skipped<10>:>);
if -,fp_mode then setposition(out,0,0);
kind(start_pos):= 8; <* terminates inf. in 'ra' and 'kind'*>
morelines:= false;
end
else
begin <* check if current line terminates command *>
for i:= 0,i+1 while round ra(i) = 32 do;
if kind(i) = 8 then goto nextline; <* skip if no command *>
for i:= startpos,i+1 while kind(i) <> 8 do;
last:= i;
ra(last):= 32;
kind(last):= 7;
for i:= i,i-1 while kind(i) = 7 and round ra(i) = 32 do;
if (kind(i) = 7 and round ra(i) = 44) <* comma *> then
begin
ra(i):= ra(i+1):= 32; <* space *>
kind(i):= kind(i+1):= 7;
startpos:= i+1;
end
else
begin
morelines:= false;
kind(last):= 8;
end;
end;
end while_loop;
<* start execution of command *>
paramno:= 0;
next_param(par,paramno,1,false);
case convert_to_number(par) of
begin
<* disccopy ignored *> ;
call_kitname;
call_kiton;
call_kitoff;
mount_disc;
remove_disc;
call_kitlabel;
goto endprogram; <* end *>
call_save(0);
call_load(0);
call_bin(0);
<* typein ignored *> ;
begin <* unknown command *>
i:= 1;
write(out,<:<10>illegal command : :>,
string par(increase(i)),<:<10>:>);
if -,fp_mode then setposition(out,0,0);
end;
end case;
close(zdisc,true);
goto nextline;
end conv_mode;
begin <* unknown fpparameter *>
i:= 1;
write(out,<:<10>***disccopy: unknown fpparameter : :>,
string par(increase(i)));
goto endprogram;
end;
end case;
end disccopy;
call_kitname;
call_kiton;
call_kitoff;
mount_disc;
remove_disc;
call_kitlabel;
<*8*>;
<*9*>;
<*10*>;
<*11*>;
<*12*>;
write(out,<:<10>unknown program name: :>,program);
end case;
goto end_program;
after_error: errorbits:= 3; <*warning.yes, ok.no*>
may_be_device_status (out);
endprogram:
end;
▶EOF◀