|
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: 37632 (0x9300)
Types: TextFile
Names: »tgicontract«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tgicontract«
; contract and pack * page 1 20 06 80, 14.19;
contract = set 1
contract = algol connect.no survey.yes
begin
<*
pack/unpack/offpack/listpack (<name>)0/8388607
all programs uses a contractfile on user scope with the name
_ pack<initials>
where <initials> is the users initials in usercat.
the program contract may be used on the same file.
function
********
pack the <name> list is contracted on pack<initials>,
_ and the file is initialized on disc2, if not found.
_ The init call as in contract is not needed.
unpack the <name> list is contracted from pack<initials>
offpack the <name> list is deleted from pack<initials>
listpack the content of pack<initials> is listed
exsample of pack<initials>
**************************
the user logs in as : ke 1 3002
the pack<initials> is then : packke
*>
\f
<* contract and pack * page 2 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 *>
<*
call of program :
contract <prog>.<file>(.<bs>)0/1 <params> 0/1
<prog> ::= init/on/clear/list/all/from/temp/set/proc/text
function of program :
init : The contractfile <file> is initiated on
_ (if <bs> specified then <bs> else main) bs_device.
_ no further <params> are allowed.
_ The <file> may not exist in the catalog.
on : The contractfile <file> is extended by the entries
_ specified in <params> and if <bs> is specified then
_ moved to that bs_device.
_ if an entry from <params> exists in <file>_catalog
_ then is the <file>_catalog entry replaced.
_ no activity take place when claims are exceeded.
_ any kind of entry may be contracted.
_ in case of break_actions the old file is still present
_ or in worst case the updated file as a wrk_name.
clear : The entries in <params> is removed from the contract-
_ file <file> catalog.
_ when the catalog becommes enpty the <file> is removed.
list : The contractfile <file> catalog is listed in short form.
all : The contractfile <file> catalog is listed format as
_ lookup.
from : The entries in <params> are contracted from contractfile
_ <file> and set on the original backing storage on login
_ scope. If the claims on the original bs is exceeded then
_ is the entry set on main bs.
_ If claims are exceeded no entry is set.
temp : As from but with temp scope.
set : The entries in <params> are set on main bs with temp
_ scope as a refer to the contractfile <file> :
_ <param> = set bs <file> <date> <file_no> <segm> . . .
_ Warning procedures may not be set and any procedure named
_ ******* in <params> is considered unknown.
proc : All procedures in the contractfile <file> catalog is
_ contracted as called by temp. No <params> used.
text : All textfiles in the contractfile <file> catalog is con-
_ tracted as called by set. No <params> used.
*>
\f
<* contract and pack * page 3 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 *>
<*
contractfile organization :
+++++++++++++++++++++++++
<file> == <catalog> <content>
<catalog> == <c_segm> 1:((entries+14)//15)
<c_segm> == <head and tail> 1:15, <entries>
<head and tail> length 34 bytes :
_ integer content
_ 1 (content position) shift 18 ,max pos = 262145
_ (head_and_tail(1) extract 3)
_ 2 base low
_ 3 base high
_ 4:7 entryname
_ 8 length or modekind
_ 9:12 document name
_ 13:17 last of tail
<entries> == total entries in contractfile
<content> == (<entry>)
_ 1 : (no of entries where head_and_tail(8) > 0)
<entry content> == (<segment>) head_and_tail(1) shift (-6) :
_ head_and_tail(8)-1+head_and_tail(1) shift (-6)
*>
\f
<* contract and pack * page 4 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 *>
integer i, t, twb, yc, prog_nr, max_pos,
_ b_skift, c_skift;
boolean init, on, from, list, all, clear, temp, set,
_ text, proc, ok_no;
real array devi, iofpar, myst(1:2);
integer array headm(1:17), tail(1:20);
integer array field word;
long array field lng_f;
zone zm(128, 1, std_error);
procedure stop(s);
__________________
string s;
system(9, 0*write(out, <:<10>***:>, s), <:<10>contract:>);
procedure stap(a, s);
_____________________
array a; string s;
begin
long array field lafl;
lafl := 0;
system(9, 0*write(out, <:<10>*** :>,
(a.lafl), s), <:<10>contract:>);
end;
boolean procedure mess(a, s, warning);
______________________________________
array a; string s; boolean warning;
begin
long array field lafl;
lafl := 0;
write(out, true, 12, (a.lafl), s, "nl", 1);
if warning then
begin
set_fpmode(0, true);
ok_no := true;
end;
mess := false;
end;
<*
; read_param_tx * page 1 27 09 77, 11.35;
; read_param
; ************
if listing.yes
char 10 12 10
read_param=set 1
read_param=algol
external*> integer procedure read_param
_______________________________________
_ (a);
array a;
comment
the procedure reads the parameters in the FP command
activating the program.
read_param: kind of item stored in a
_ -1 <text>= (at first call and after wrap around)
_ 0 end_of_parameter_list
_ 1 <s><integer>
_ 2 <s><text>
_ 3 .<integer>
_ 4 .<text>
a: (return value, real array, length >=2).
an integer is floated into the first element of a, a text item
is assigned into a(1:2).
the parameter list is scanned by means of system(4, q, a).
at the end_of_parameter_list reading continues with the first
first parameter again. the program name is always skipped;
begin
own integer q;
integer i;
q := q + 1;
i := system(4, q, a);
if q<>1 or i <> (6 shift 12) + 10 then
begin comment not first nor = sign;
if i <> 0 then
read_param := (if i shift(-12)=8 then 2 else 0)
_ +(if i extract 12=10 then 2 else 1)
else
read_param := q := 0;
end not first nor =sign
else
begin comment first and = sign;
system(4, 0, a);
read_param := -1;
end first and = sign;
end read_param;
procedure outshortclock(shortclock);
_____________________________________
integer shortclock;
begin real r;
write(out, <:d.:>, <<zddddd>,
systime(4, (if shortclock>0 then shortclock
else shortclock + extend 1 shift 24)
/625*1 shift 15+12, r),
<:.:>, <<zddd>, r/100)
end outshortclck;
integer procedure shortclock;
shortclock:=systime(6,0,0.0);
\f
comment contract and pack * page 5 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
procedure mess_create(name, i, warning);
________________________________________
value i, warning;
array name;
integer i;
boolean warning;
begin
write(out, <:*** create trouble : :>,
_ case i of ( <:catalog function forbidden:>,
_ <:catalog i/o error:>, <:entry exists:>,
_ <:catalog full:>, <:contigous area not available:>,
_ <:name format illegal:>), "nl", 1);
mess(name, <: create trouble:>, warning);
end;
integer procedure blocksizeproc(zio, zwork, pos);
______________________________________________________
zone zio, zwork; integer pos;
begin comment transfers zio to zwork, computes size;
integer t, i, size;
set_position(zwork, 0, pos);
size := 0;
repeat
size := size + 1;
out_rec6(zwork, 512);
i := read_string(zio, zwork, 1);
until i >= 0;
if i > 0 or size > 1 then
begin
if i = 0 then
begin
i := 1;
zwork(i) := real <::>;
end;
if zwork(i) = real <::> then
_ zwork(i) := real <:<25><25><25>:>
else
begin
t := 0;
while (zwork(i) shift t) extract 8 = 0 do t := t - 8;
zwork(i) := real(long zwork(i)
_ + long<:<25><25><25>:> shift (-48-t));
end;
pos := pos + size
end
else
size := -1;
blocksizeproc := size;
end blocksizeproc;
\f
comment contract and pack * page 6 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
procedure allsort(a, ix, n);
____________________________
value n;
long array a;
integer array ix;
integer n;
begin
integer i, j, k, m;
long array field f1, f2;
for i := 1 step i until n do m := i + i -1;
for m := m//2 while m <> 0 do
begin
k := n - m;
for j := 1 step 1 until k do
begin
for i := j step -m until 1 do
begin
f1 := ix(i);
f2 := ix(i+m);
if
( if a.f2(1) < a.f1(1) then true else
_ if a.f2(1) > a.f1(1) then false else
_ if a.f2(2) < a.f1(2) then true else
_ if a.f2(2) > a.f1(2) then false else
_ ( a.f2(3) > a.f1(3) )
) then
begin
ix( i ) := f2;
ix(i+m) := f1;
end
else
i := 1;
end;
end;
end;
end alsort;
\f
comment contract and pack * page 7 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
integer procedure find_bs(devi_name, tail, antal);
__________________________________________________
value antal;
long array devi_name;
integer array tail;
integer antal;
begin
long array field df, tf;
find_bs := 0;
antal := antal * 8;
t_f := 2;
for d_f := 0 step 8 until antal do
if devi_name.d_f(1) = tail.tf(1) and
_ devi_name.d_f(2) = tail.tf(2) then
begin
find_bs := df // 8;
df := antal;
end;
end find_bs;
integer procedure movesizeproc(zio, zwork, pos, segm);
______________________________________________________
value segm;
zone zio, zwork;
integer pos, segm;
begin
integer i;
set_position(zwork, 0, pos);
for i := segm step -1 until 1 do
begin
inrec6(zio, 512);
outrec6(zwork, 512);
tofrom(zwork, zio, 512);
end;
pos := pos + segm;
movesizeproc := segm;
end movesizeproc;
\f
comment contract and pack * page 8 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
boolean procedure out_mode_kind(h_tail);
________________________________________
integer array h_tail;
begin
integer i, j, mdk;
long array field name;
name := 16;
j := -1;
mdk := h_tail(8) extract 23;
for i := 1 step 1 until 21 do
if case i of ( 0, 4, 8, 10, 2 shift 12 + 10, 4 shift 12 + 10,
_ 6 shift 12 + 10, 12, 2 shift 12 + 12, 4 shift 12 + 12,
_ 6 shift 12 + 12, 8 shift 12 + 12, 14, 16, 8 shift 12 + 16,
_ 10 shift 12 + 16, 18, 2 shift 12 + 18, 4 shift 12 + 18,
_ 6 shift 12 + 18, 20) = mdk then
begin
j := i;
i := 21;
end;
if j > 0 then
_ write(out, case j of (<:ip:>, <:bs:>, <:tw:>, <:tro:>,
_ <:tre:>, <:trn:>, <:trf:>, <:tpo:>, <:tpe:>, <:tpn:>,
_ <:tpf:>, <:tpt:>, <:lp:>, <:crb:>, <:crd:>, <:crc:>,
_ <:mto:>, <:mte:>, <:nrz:>, <:nrze:>, <:pl:>))
else
write(out, <<d>, 1 shift 11 + mdk shift (-12),
_ <:.:>, mdk extract 12);
if h_tail(9) = 0 or h_tail(9) = 1 then
_ write(out, << z>, h_tail(9))
else write(out, "sp", 1, h_tail.name);
out_char(out, 32);
out_mode_kind := j <> 1 and j <> 2;
end;
\f
comment contract and pack * page 9 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
b_skift :=
c_skift := 6;
max_pos := (1 shift (24-b_skift)) - 1;
ok_no := false;
lng_f :=
word := 0;
yc := readparam(iofpar);
if yc = -1 then
_ stop(<:param error +lefthand:>);
prog_nr := prog_entry(i, 5, case i of (
<*1*> <:contract:>,
<*2*> <:pack:>,
<*3*> <:unpack:>,
<*4*> <:listpack:>,
<*5*> <:offpack:>));
if prognr <> 1 then
begin
system(6)own_process:(i)name:(iofpar);
for i := 1 step 1 until 2 do
for t := -40 step 8 until 0 do
if iof_par(i) shift t extract 8 < 97 then
begin
iofpar(i) := (iofpar(i) shift (t-8)) shift (8-t);
if i = 1 then iofpar(2) := real <::>;
i := 2;
t := 0;
end;
myst(1) := real<:pack:> add ((iofpar(1) shift (-32)) extract 16);
myst(2) := (iofpar(1) shift 16) add
_ (((iofpar(2) shift (-40)) shift 8) extract 16);
init :=
on :=
proc :=
temp :=
text :=
set :=
from :=
list :=
all :=
clear := false;
end
else
if readparam(myst) <> 4 then
_ stop(<:param error -contractfile:>);
\f
comment contract and pack * page 10 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
case prog_nr of
begin
begin <*contract*>
init := real <:init:> = iofpar(1);
on := real <:on:> = iofpar(1);
proc := real <:proc:> = iofpar(1);
temp := real <:temp:> = iofpar(1) or proc;
text := real <:text:> = iofpar(1);
set := real <:set:> = iofpar(1) or text;
from := real <:from:> = iofpar(1);
list := real <:list:> = iofpar(1);
all := real <:all:> = iofpar(1);
clear := real <:clear:> = iofpar(1);
end;
begin <*pack*>
open(zm, 4, myst, 0);
i := monitor(76, zm, 0, headm);
close(zm, false);
twb := 0;
init := i <> 0;
on := true;
end;
<*unpack*>
from := true;
<*listpack*>
list := true;
<*offpack*>
clear := true;
end prog_nr case;
if -, init and -, on and -, from and -, list and -, all
and -, clear and -, temp and -, set then
stap(iofpar, <: param error not contract prog call:>);
open(zm, 4, myst, 0);
i := monitor(76, zm, 0, headm);
if i = 0 and init then
stap(myst, <: exist allready:>);
if -, init and i > 0 then
stap(myst, <:-contractfile does not exist:>);
if -, init and headm(16) shift(-12) <> 10 then
stap(myst, <:-contractfile not initiated:>);
if -, init then
begin
inrec_6(zm, 512);
twb := zm.word(256);
if twb > 0 and zm.word(1) shift (-12) = (twb+14)//15 then
_ c_skift := 12;
end;
\f
comment contract and pack * page 11 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
repeat
<* to include on after init of pack *>
if list or all then
begin
integer array bases( 1 : 8 );
long array field wolng_f, lj;
integer array field fld;
fld := -34;
lj := 6;
wolng_f := 16;
system(11)bases:(i, bases);
i := write(out, "nl", 1, headm.lj);
write(out, "sp", 15-i);
outshortclock(headm(13));
write(out, "nl", 1, <<dddd>, <:entries =:>, "sp", 7, twb, "nl", 1,
<:size =:>, "sp", 7, headm(8), "nl", 1);
for t := 1 step 1 until twb do
begin
if fld = 476 <* = 15 * 34 - 34 *> then
begin
fld := 0;
inrec_6(zm, 512);
end
else fld := fld + 34;
i := write(out, "nl", 1, zm.fld.lj);
if list then
begin
write(out, "sp", 15-i);
if zm.fld(8) >= 0 then
begin
i := zm.fld(16) shift (-12);
if i <> 4 and i < 32 then outshortclock(zm.fld(13))
_ else write(out, <:procedure:>);
end
else
begin
write(out, <:= set :>);
out_mode_kind(zm.fld);
end;
end
else
begin <* all *>
\f
comment contract and pack * page 12 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
write(out, "sp", 12 - i, <:= set :>);
i := 14;
if zm.fld(8) >= 0 then
begin
write(out, <<dddd>, zm.fld(8), "sp", 1, zm.fld.wolng_f, "sp", 2);
if zm.fld(16) shift (-12) <> 4 and zm.fld(16) shift (-12) < 32
then outshortclock(zm.fld(13)) else i := 13;
end
else
if out_mode_kind(zm.fld) then
_ out_shortclock(zm.fld(13)) else i := 13;
for i := i step 1 until 17 do
if zm.fld(i) < 4096 then
_ write(out, "sp", 1, <<d>, zm.fld(i))
else write(out, "sp", 1, <<d>, zm.fld(i) shift(-12),
_ <:.:>, zm.fld(i) extract 12);
write(out, false add 59<* ; *>, 1, "sp", 1);
i := if zm.fld(1) extract 3 > 3 then 6
else
case zm.fld(1) extract 3 + 1 of
(
<* key 0, maybe temp *>
_ if extend zm.fld(2) = extend bases(3)
_ and extend zm.fld(3) = extend bases(4)
_ then 1 else 6,
<* key 1 : undefined *> 6,
<* key 2, maybe login *>
_ if extend zm.fld(2) = extend bases(3)
_ and extend zm.fld(3) = extend bases(4)
_ then 2 else 6,
<* key 3, user, project or system *>
_ if extend zm.fld(2) = extend bases(5)
_ and extend zm.fld(3) = extend bases(6) then 3
_ else
_ if extend zm.fld(2) = extend bases(7)
_ and extend zm.fld(3) = extend bases(8) then 4
_ else
_ if extend zm.fld(2) <= extend bases(7)
_ and extend zm.fld(3) >= extend bases(8) then 5
_ else 6
);
write(out, case i of(
_ <:temp:>, <:login:>, <:user:>,
_ <:project:>, <:system:>, <:***:>),
_ "nl", 1, "sp", 14, false add 59, 1, "sp", 4,
_ zm.fld(1) shift(-c_skift), <: bases:>,
_ zm.fld(2), zm.fld(3));
end;
end;
write(out, "nl", 1);
if twb = 0 then write(out, <:storage file empty<10>:>);
end <* list or all *>
else
\f
<* contract and pack * page 13 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 *>
if init then
begin
real array field name;
for t := 1 step 1 until 10 do tail(t) := 0;
name := 2;
if prog_nr = 1 then
begin
i := read_param(devi);
t := if i = 0 then 0 else -1;
if i > 0 then i := read_param(iofpar);
if i <> 0 then stap(iofpar, <: + param :>);
end
else
begin
devi(1) := real <:disc2:>;
devi(2) := real <::>;
t := -1;
end;
if -, claim_proc(0, t, devi.lngf, t, t, t) then
_ stap(devi, <: unknown bs<95>device :>);
tail(1) := 1;
tail.name(1) := devi(1);
tail.name(2) := devi(2);
tail(6) := short_clock;
tail(9) := 10 shift 12;
if monitor(40)create_entry:(zm, 0, tail) > 0 then
_ stop(<: contractfile not created:>);
if monitor(50) permanent entry:(zm, 3, tail)<>0 then
stop(<: no permanent resources:>);
system(11)bases:(i, tail);
tail(1) := tail(5);
tail(2) := tail(6);
if monitor(74)set entry base:(zm, 0, tail) <> 0 then
write(out, "nl", 1, <: base:>, tail(1), tail(2));
out_rec_6(zm, 512);
zm(1) := real <::>;
name := 4;
to_from(zm.name, zm, 508);
if prog_nr = 2 then
begin
set_position(zm, 0, 0);
in_rec6(zm, 512);
monitor(76)lookup_head_and_tail:( zm, 0, headm);
end;
init := init shift 1;
end <* init *>
else
\f
<* contract and pack * page 14 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 *>
begin
if prognr = 1 then yc := read_param(devi);
if yc = 4 then t := 0
else
begin
devi(1) :=
devi(2) := real <::>;
t := 1;
end;
if yc > 0 or text or proc then
begin
i := t;
while readparam(iofpar) <> 0 do i := i + 1;
for t := (if prog_nr = 1 then 3 else 1) - t
_ step -1 until 1 do
_ read_param(iofpar);
t := (if text or proc then twb else i) + twb; <* max entries *>
if from or temp or set then
begin
system(5, 92, tail);
i := (tail(3) - tail(1)) // 2 - 1;
<* bs_devices inclusive zero : 0 *>
yc := 4 * 4;
end
else
begin
i := 0;
yc := 3 * 4 + 2;
end;
\f
comment contract and pack * page 15 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
begin
boolean exist;
integer j, bs_devices, tot_entries, twob;
integer array ix(1:t), headio(1:20),
_ bs_entr, bs_segm, bs_length(0:i);
long array scope(1:2), devinames(1:2*i+2),
_ y(1 : (yc * t) // 4 + 1);
integer array field fld;
long array field lj, ix_f, devi_f;
real array field rf;
zone zio(128, 1, std_error);
procedure read_text_or_proc;
____________________________
begin
for t := 1 step 1 until twb do
begin
if fld = 476 <* = 15 * 34 - 34 *> then
begin
in_rec6(zm, 512);
fld := 0;
end
else fld := fld + 34;
j := zm.fld(16) shift (-12);
if (
_ if text then j = 0 and zm.fld(8) > 0
_ else j = 4 or j >= 32) then
begin
y.ix_f(1) := zm.fld.lj(1);
y.ix_f(2) := zm.fld.lj(2);
y.ix_f(3) := -1;
scope(1) := 0;
j := lookup_proc(scope, y.ixf, tail);
y.ix_f(4) := if j <> 0 or
_ ( scope(1) <> long <:login:> and
_ scope(1) <> long <:temp:>)
_ then -1
_ else if tail(1) <= 0 then 0
_ else (extend(tail(1)) shift 24
_ add find_bs(devinames, tail, bs_devices));
ix_f := ix_f + yc;
end;
end;
fld := -34;
setposition(zm, 0, 0);
inrec_6(zm, 512);
end read_text or proc;
\f
comment contract and pack * page 16 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
bs_devices := i;
fld := -34;
tot_entries :=
rf :=
ix_f := 0;
lj := 6;
exist := true;
if -, clear and -, on then
begin
devi_f := -8;
t := if from then 2 else 0;
for i := 0 step 1 until bs_devices do
begin
devi_f := devi_f + 8;
claim_proc(t, i, devi_names.devi_f, bs_entr(i),
_ bs_segm(i), bs_length(i));
end;
end;
if text or proc then read_text_or_proc
else
while readparam(iofpar) <> 0 do
begin comment readpar_to_p_long-1;
if on then
begin
open(zio, 4, iofpar.lngf, 0);
if monitor(76, zio, 0, headio) <> 0 then
exist := mess(iofpar, <: file does not exist :>, false)
else
y.ix_f.word(7) := if headio(8) > 0 then headio(8) else 0;
close(zio, true);
end
else
if clear then y.ix_f.word(7) := 0
else
begin
scope(1) := 0;
i := lookup_proc(scope, iofpar.lng_f, tail);
y.ix_f(4):= if i <> 0 or
_ (scope(1) <> long<:login:> and
_ scope(1) <> long<:temp:>)
_ then -1
_ else if tail(1) <= 0 then 0
_ else (extend(tail(1)) shift 24
_ add find_bs(devi_names, tail, bs_devices));
end;
if exist then
begin
y.ix_f(1) := iofpar.lng_f(1);
y.ix_f(2) := iofpar.lng_f(2);
y.ix_f(3) := -1;
ix_f := ix_f + yc;
end
else exist := true;
end readpar_to_p_long-1;
tot_entries := ix_f // yc;
\f
comment contract and pack * page 17 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
if totentries > 0 then
begin
i := 0;
devi_f := 14;
twob := tot_entries + twb;
for t := totentries + 1 step 1 until twob do
begin comment read_zm_to twb_long-2;
if fld = 476 <* = 15 * 34 - 34 *> then
begin
inrec_6(zm, 512);
i := i + 1;
fld := 0;
end
else fld := fld + 34;
if
( if -, set then true
_ else zm.fld(16) shift (-12) <> 4 and
_ zm.fld(16) shift (-12) < 32 ) then
begin
y.ix_f(1) := zm.fld.lj(1);
y.ix_f(2) := zm.fld.lj(2);
y.ix_f(3) := extend(i) shift 24 + fld;
y.ix_f(4) := if zm.fld(8) > 0 then
_ (extend( zm.fld(8) ) shift 24 +
_ (if from then find_bs(devinames,
_ zm.devif.fld, bs_devices) else 0))
_ else 0;
ix_f := ix_f + yc;
end;
end read_zm_to_twb_long-2;
tot_entries :=
twob := ix_f // yc;
for t := 1 step 1 until tot_entries do ix(t) := (t-1) * yc;
allsort(y, ix, totentries);
if on or (clear and twb > 0) then
begin
integer first_segment, max_lng;
integer array alpha(0:255);
integer array field seac_f;
real array field rf;
zone seac_zn, zwork(128, 1, stderror);
max_lng :=
seac_f := 0;
for t := 0 step 1 until 127 do
_ alpha(t) := 6 shift 12 add t;
alpha(0) := alpha(127) := 0;
alpha(25) := 8 shift 12 add 25;
intable(alpha);
\f
comment contract and pack * page 18 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
lj := ix(1);
for i := 2 step 1 until tot_entries do
begin
ix_f := lj;
lj := ix(i);
if y.lj(1) = y.ix_f(1) and y.lj(2) = y.ix_f(2) then
begin
twob := twob - 1;
if y.ix_f(3) < 0 then write(out, true, 11, y.ix_f,
_ <: doublet in param : skipped:>, "nl", 1)
else
if on then max_lng := max_lng + y.lj.word(7);
y.lj.word(7) := 0;
if clear then
begin
y.lj(3) := -6;
if y.ix_f(3) >= 0 then twob := twob - 1;
end;
y.ix_f(3) := -7;
end
else
max_lng := max_lng + y.ix_f.word(7);
end;
max_lng := max_lng + y.lj.word(7);
if clear then
for ix_f := (tot_entries-1) * yc step -yc until 0 do
if y.ix_f(3) = -1 then
begin
twob := twob - 1;
y.ix_f(3) := -7;
mess(y.ix_f.rf, <: not in textstorage:>, true);
end;
\f
comment contract and pack * page 19 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
firstsegment := (twob + 14) // 15;
if first_segment > 0 then
begin comment build_up_workstore;
open(zwork, 4, <::>, 0);
tail(1) := 1;
for t := 2 step 1 until 10 do tail(t) := headm(7+t);
lj := 2;
if devi(1) <> real <::> then
begin
tail.lj(1) := long devi(1);
tail.lj(2) := long devi(2);
end;
ixf := 0;
i := -1;
if -, claim_proc(3, i, tail.lj, bs_entr(0), bs_segm(0), j)
then system(9, 0 * write(out, "nl", 1, <:unknown bs :>,
_ tail.lj, "nl", 1, <:***:>), <:contract:>);
if bs_segm(0) - max_lng - first_segment < 0
_ or bs_entr(0) < 1 then
begin
write(out, "nl", 1, <:***claims exceeded on :>,
_ tail.lj, "nl", 1, <:available:>,
_ <: entries, needed segm ::>, bs_entr(0),
_ max_lng+first_segment-bs_segm(0));
stop(<::>);
end;
if monitor(40)create_entry:(zwork, 0, tail) > 0 then
_ stop(<:workstore not created:>);
getzone(zwork, headio);
write(out, "nl", 2, <:tempfile = :>, headio.lj, "nl", 1);
open(seac_zn, 4, headio.lj, 0);
outrec_6(seac_zn, 512);
lj := 6;
\f
comment contract and pack * page 20 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
for i := 1 step 1 until totentries do
if firstsegment <= maxpos then
begin comment y_one_to_z;
ix_f := ix(i);
if y.ix_f(3) > -6 then
begin
if y.ix_f(3) < 0 then
begin
open(zio, 4, y.ix_f, 0);
if monitor(76, zio, 0, headio) = 0 then
begin comment parentrihead;
for t := 2 step 1 until 17 do
_ seac_zn.seac_f(t) := headio(t);
if headio(8) > 0 then
begin
seac_zn.seac_f(1) :=
first_segment shift (b_skift)
_ + headio(1) extract b_skift;
seac_zn.seac_f(8) := if headio(16) shift (-12) = 0
_ then blocksizeproc(zio, zwork, firstsegment)
_ else movesizeproc(zio, zwork, firstsegment,
_ headio(8));
if seaczn.seac_f(8) < 0 then
_ stap(y.ix_f.rf, <: no text : empty :>);
end
else <* catalog entry *>
seac_zn.seac_f(1) := ((i-1)//15) shift b_skift
_ + headio(1) extract b_skift;
seac_f := seac_f + 34;
end
else stap(y.ix_f.rf, <: could not be contracted:>);
close(zio, true);
end
else
begin comment zm_entry;
fld := y.ix_f.word(6);
setposition(zm, 0, y.ix_f.word(5));
inrec_6(zm, 512);
j := zm.fld(8);
seac_zn.seac_f(1) := (if j > 0 then
_ firstsegment else ((i-1)//15))
_ shift b_skift
_ + zm.fld(1) extract b_skift;
for t := 2 step 1 until 17 do
_ seac_zn.seac_f(t) := zm.fld(t);
seac_f := seac_f + 34;
setposition(zm, 0, zm.fld(1) shift (-c_skift));
if j > 0 then movesizeproc(zm, zwork, firstsegment, j);
end zm_entry;
end ulig_minus_seks_syv;
if seac_f = 510 then
begin comment seac_to_catalog;
seac_zn.seac_f(1) := twob;
outrec_6(seac_zn, 512);
seac_f := 0;
end seac_to_catalog;
end y_one_to_z
else
stap(myst, <: file is full max 262145 segm :>);
\f
comment contract and pack * page 21 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
if seac_f > 0 then
begin
while seac_f < 510 do
begin
seac_f := seac_f + 2;
seac_zn.seac_f(0) := 0;
end;
seac_zn.seac_f(1) := twob;
end
else changerec_6(seac_zn, 0);
close(seac_zn, false);
tail(1) := firstsegment;
tail(6) := short_clock;
monitor(44)change entry:(zwork, i, tail);
tail(1) := headm(2);
tail(2) := headm(3);
i := monitor(50)permanent entry:(zwork, 3, tail) ;
if i <> 0 then
begin
write(out, case i of (
<:dummy:>,
<:catalog i/o error, doc. not mounted or doc. not ready:>,
<:entry not found, name conflict - in aux catalog:>,
<:entry protected, i e base of entry name not con-
tained in max base of calling process- key illegal:>,
<:dummy:>,
<:name format illegal -- claims exeeded:>,
<:catalog inconsistent:> ));
stop(<:troubles with monitor 50 ---claims? :>);
end;
if monitor(74)set entry base:(zwork, 0, tail) <> 0 then
begin
monitor(48)remove entry:(zwork, 0, tail);
stop(<:workstorebase not allowed:>);
end;
end <* build up workstore *>
else
mess(myst, <: file empty : removed:>, false);
close(zm, true);
monitor(48)remove entry:(zm, 0, headm);
if firstsegment > 0 then
begin
close(zwork, false);
monitor(46)rename entry:(zwork, 0, myst.word);
end;
end <* on or (clear and twb > 0) *>
else
if clear then
_ write(out, <:empty storagefile:>, "nl", 1)
else
\f
<* contract and pack * page 22 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 *>
<* from or temp or set *>
begin
lj := ix(1);
if y.lj(3) < 0 then y.lj(3) := -7;
for i := 2 step 1 until tot_entries do
begin
ix_f := lj;
lj := ix(i);
if y.ix_f(1) = y.lj(1) and y.ix_f(2) = y.lj(2) then
begin
if y.ix_f(3) >= 0 then <* ixf is a zm_entry *>
begin <* lj is a wanted entry *>
if y.lj(4) > -1 then
begin
t := y.lj.word(8);
bs_entr(t) := bs_entr(t) + 1;
bs_segm(t) := bs_segm(t) + ((y.lj.word(7) - 1)
_ // bs_length(t) + 1) * bs_length(t);
end;
t := y.ix_f.word(8);
if bs_entr(t) > 0 and
_ bs_segm(t) > y.ixf.word(7) then
begin
bs_entr(t) := bs_entr(t) - 1;
if -, set then
_ bs_segm(t) := bs_segm(t) - ((y.ixf.word(7) - 1)
_ // bs_length(t) + 1) * bs_length(t);
end
else
begin
y.ix_f.word(8) := 0;
bs_entr(0) := bs_entr(0) - 1;
if -, set then
_ bs_segm(0) := bs_segm(0) - ((y.ixf.word(7) - 1)
_ // bs_length(0) + 1) * bs_length(0);
end;
end
else
write(out, true, 11, y.ixf,
_ <: doublet in param : skipped:>, "nl", 1);
end <* equality *>
else
begin
if y.ixf(3) >= 0 then y.ixf(3) := -2; <* zm_entry not wanted *>
if y.lj(3) = -1 then y.lj(3) := -7; <* wanted but unknown *>
end;
end;
if y.lj(3) > 0 then y.lj(3) := -2;
\f
comment contract and pack * page 23 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
if bs_entr(0) < 0 or bs_segm(0) < 0 then
begin
write(out, "nl", 1, <:***claims wanted on disc: entries, segm ::>,
_ -bs_entr(0), -bs_segm(0));
stop(<:claims exceeded:>);
end;
for j := 1 step 1 until tot_entries do
begin
ixf := ix(j);
if y.ixf(3) >= 0 then
begin
setposition(zm, 0, y.ixf.word(5));
inrec6(zm, 512);
fld := y.ixf.word(6);
for i := 1 step 1 until 10 do tail(i) := zm.fld(i+7);
if (temp or (from and y.ixf.word(8) = 0))
_ and tail(1) > 0 then
begin
lj := 2;
tail.lj(1) := long <:disc:>;
tail.lj(2) := 0;
end;
if set then
begin
lj := 2;
tail.lj(1) := headm.lj(2);
tail.lj(2) := headm.lj(3);
tail(8) := zm.fld(1) shift (-c_skift);
tail(1) := 1 shift 23 add 4;
end;
open(zio, 4, y.ixf, 0);
j := j + 1;
lj := ix(j);
if y.lj(4) > -1 then
monitor(48)remove_entry:(zio, 0, tail);
i := monitor(40, zio, 0, tail);
if i <> 0 then
mess_create(y.ixf.rf, i, true);
\f
comment contract and pack * page 24 20 06 80, 14.19
0 1 2 3 4 5 6 7 8 9 ;
if (-, set) and zm.fld(8) > 0 then
begin
set_position(zm, 0, zm.fld(1) shift (-c_skift));
movesizeproc(zm, zio, 0, tail(1));
close(zio, true);
<*change entry*>
monitor(44, zio, i, tail);
end
else close(zio, true);
if from then
begin
if monitor(50)permanent entry:(zio, 2, tail)<>0 then
_ mess(y.ixf.rf, <:no login resources:>, true);
end;
end
else
if y.ixf(3) = -7 then
begin
write(out, "nl", if ok_no then 0 else 1, true, 12, y.ixf,
<: not in contractfile catalog:>, "nl", 1);
set_fpmode(0, true);
ok_no := true;
end ;
end stp tot_entries;
end <* from or temp or set *>;
end <* totentries > 0 *>
else write(out, <:contractfile was not changed:>, "nl", 1);
end <* declare block *>;
end
else ok_no := write(out, <:missing parameters:>, "nl", 1) > 0;
init := false; <* to stop repeat loop when program = pack *>
end <* on or clear or from or temp or set or text or proc *>;
<* last of : repeat init on pack *>
until -, (init shift (-1)) or prog_nr <> 2;
close(zm, true);
trap_mode := 1 shift 10;
if ok_no then
system(9, 0*write(out, "nl", 2, <:*** warning :>), <:contract:>);
end;
\f
; contract and pack * page 25 20 06 80, 14.19;
;
if warning.yes
(mode 0.yes
message contract not ok
lookup contract)
if 0.no
(
pack = entry bs contract contract contract,
_ contract contract contract
unpack = assign pack
listpack = assign pack
offpack = assign pack
if 1.yes
(scope user,
contract,
pack,
unpack,
listpack,
offpack)
if 2.yes
(scope project,
contract,
pack,
unpack,
listpack,
offpack)
lookup,
contract,
pack,
unpack,
listpack,
offpack
)
end
finis
▶EOF◀