|
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: 19968 (0x4e00)
Types: TextFile
Names: »catcontracx«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »catcontracx«
└─⟦this⟧ »gi/catcontracx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦baac87bee⟧ »gi«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦baac87bee⟧ »gi«
└─⟦this⟧
; catsort contract * page 1 12 08 80, 10.36 ;
cat_contract = set 1
cat_contract = algol
begin
<*
call :
----
_ cat_contract <basespec> 0/1
<res> = cat_contract <basespec> 0/1
<res> ::= resultfile
_ when no <res> is specified then current out is used.
_ if not present then set on user scope or lover.
<basespec> ::= base.(project//user//login//temp)
_ default is system
_ NOTE only content of contractfiles with catbase containing
_ NOTE the standarbase (i.e loginbase under boss) is dis-
_ NOTE played.
function :
-------- All visible contract entryes is lookup in the catalog
_ and the content of the contractfiles are sorted :
_ 1 after increasing lower base
_ 2 after decreasing upper base
_ 3 after decreasing permanentkey
_ 4 contract_catalog_entries before contententries
_ 5 in aphabetic order
The cat_contract_sort list contain the usual first line
describing the entry and a second line :
for contract files :
_ ; <entries> <texts> <procs> <bins> <nonars>
for contarcted entries
_ ; <contractfilename> <pos>
*>
\f
comment catsort contract * page 2 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
boolean check_base, test;
integer no_of_entries, i, j, length,
_ segm, segm_bytes, new_share, sort_lng;
real array res_name, param(1:2), sort_names(1:6);
long array sort_base, std_base_long(1:2);
integer array std_base, base(1:2), bases(1:8);
integer procedure out_shortclock(ud, cl);
zone ud;
integer cl;
begin
real r;
outshortclock := write(ud, <:d.:>, <<zddddd>,
systime(4, (if cl>0 then cl
else cl + extend 1 shift 24)
/625*1 shift 15+12, r),
<:.:>, <<zddd>, r/100);
end outshortclck;
segm := 3;
segm_bytes := segm * 512;
sort_lng := 48;
new_share := ((segm_bytes // sort_lng) - 1) * sort_lng;
system(11)bases:(i, bases);
std_base(1) := bases(1);
std_base(2) := bases(2);
std_base_long(1) := extend bases(1);
std_base_long(2) := extend bases(2);
res_name(1) :=
res_name(2) := real <::>;
check_base := false;
test := false;
\f
comment catsort contract * page 3 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
i := read_param(param);
if i = -1 then
begin
res_name(1) := param(1);
res_name(2) := param(2);
i := read_param(param);
end;
if i = 2 then
begin
if param(1) = real <:base:> then
begin
if read_param(param) <> 4 then
_ system(9)alarm:(2, <:<10>***base:>);
i := nr_string( j, 4, string param(1), case j of (
_ <:temp:>, <:user:>, <:proj:>, <:syst:>));
if j = 1 then system(9, 2, <:<10>***scope:>);
check_base := j < 5;
if check_base then
begin
sort_base(1) := extend bases(i+i-1);
sort_base(2) := extend bases(i+i);
end;
end
else system(9, 1, <:<10>***scope:>);
end;
\f
comment catsort contract * page 4 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
begin
zone cat(128, 1, std_error),
_ set_base(1, 1, std_error),
_ sort(128*segm, 1, std_error);
integer array tail(1:10);
integer array field cat_w, con_w, sor_w;
long array field name, con_name;
boolean shift_bases;
integer permkey, entries, text, proc, bin, non,
_ c_skift, q;
long b_lo, b_hi;
open(set_base, 0, <::>, 0);
open(cat, 4, <:catalog:>, 0);
if monitor(42)lookup:(cat, i, tail) <> 0 then
_ system(9)alarm:(0, <:<10>*catalog:>);
entries := tail(1);
begin
long array field lf;
long array devi(1:12), scope(1:2);
lf := 0;
for i := 1 step 1 until 6 do
begin
sort_names.lf(i) :=
devi(i+i) := long <::>;
devi(i+i-1) := long(case i of (<:disc5:>,
_ <:disc4:>, <:disc3:>, <:disc2:>,
_ <:disc1:>, <:disc:>));
end;
scope(1) := long <:temp:>;
scope(2) := long <::>;
if set_bsarea(sort_names.lf, devi, scope, entries,
_ 11 shift 12, true) <> 0 then
_ system(9, 0, <:<10>*** set:>);
sort_names(3) := sort_names(1);
sort_names(4) := sort_names(2);
end;
open(sort, 4, string pump(sort_names), 0);
no_of_entries := 0;
length := 0;
cat_w := 476;
sor_w := new_share;
name := 6;
con_name := 38;
\f
comment catsort contract * page 5 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
for q := 15 * entries step -1 until 1 do
begin
zone contr(128, 1, contr_error);
procedure contr_error(z, s, b);
zone z;
integer s, b;
begin
long array field devi_f;
devi_f := 16;
write(out, nl, 2, cat.cat_w.name, cat.cat_w(8),
_ sp, 1, cat.cat_w.devi_f, sp, 1);
out_short_clock(out, cat.cat_w(13));
for j := 14 step 1 until 17 do
if cat.cat_w(j) < 4096 then
_ write(out, cat.cat_w(j)) else
_ write(out, <<d>, sp, 1, cat.cat_w(j) shift (-12),
_ <:.:>, cat.cat_w(j) extract 12);
write(out, nl, 1, sp, 11, <:;:>, cat.cat_w(1) shift (-12),
_ cat.cat_w(1) shift (-3) extract 9, cat.cat_w(1) extract 3,
_ cat.cat_w(2), cat.cat_w(3), nl, 1,
_ <:errorstatus::>);
write_status(out, s);
set_position(out, 0, 0);
if cat.cat_w(1) extract 3 <= 3 then go_to CONT
else go_to CONT1;
end;
if cat_w = 476 then
begin
inrec6(cat, 512);
cat_w := 0;
end
else cat_w := cat_w + 34;
\f
comment catsort contract * page 6 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
b_lo := extend cat.cat_w(2);
b_hi := extend cat.cat_w(3);
if b_lo <> -1 or b_hi <> -1 then
begin
if cat.cat_w(16) shift(-12) = 10 then
begin
if (
_ if check_base
_ then sort_base(1) <= b_lo and
_ sort_base(2) >= b_hi
_ else true)
then
begin
shift_bases := std_base_long(1) < b_lo
_ or std_base_long(2) > b_hi;
if shift_bases then
begin
base(1) := cat.cat_w(2);
base(2) := cat.cat_w(3);
i := monitor(72, set_base, j, base);
end
else
i := 0;
if i = 0 then
begin
entries :=
text :=
proc :=
bin :=
non := 0;
perm_key := (cat.cat_w(1) extract 2) * 2;
open(contr, 4, cat.cat_w.name, (-1 shift 2) -(1 shift 5));
inrec_6(contr, 512);
if shift_bases then monitor(72, set_base, j, std_base);
entries := contr(128) extract 24;
con_w := -34;
c_skift := if contr.con_w(18) shift (-12) = (entries+14)//15
_ then (-12) else (-6);
no_of_entries := no_of_entries + entries + 1;
\f
comment catsort contract * page 7 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
for j := entries step -1 until 1 do
begin
if con_w = 476 then
begin
inrec_6(contr, 512);
con_w := 0;
end
else con_w := con_w + 34;
if contr.con_w(8) <= 0 then non := non + 1 else
if contr.con_w(16) = 0 then text := text + 1 else
if contr.con_w(16) shift (-12) = 4 then proc := proc + 1
else bin := bin + 1;
if sor_w = new_share then
begin
outrec_6(sort, segm_bytes);
length := length + segm;
sor_w := 0;
end
else sor_w := sor_w + sort_lng;
for i := 4 step 1 until 17 do
_ sort.sor_w(i) := contr.con_w(i);
sort.sor_w(1) := perm_key;
sort.sor_w.name(0) := b_lo;
sort.sor_w.con_name(0) := b_hi;
sort.sor_w.con_name(1) := cat.cat_w.name(1);
sort.sor_w.con_name(2) := cat.cat_w.name(2);
sort.sor_w(24) :=
_ contr.con_w(1) shift c_skift;
end;
CONT:
if sor_w = new_share then
begin
outrec_6(sort, segm_bytes);
length := length + segm;
sor_w := 0;
end
else sor_w := sor_w + sort_lng;
for i := 2 step 1 until 17 do
_ sort.sor_w(i) := cat.cat_w(i);
sort.sor_w(1) := permkey + 1;
sort.sor_w.name(0) := b_lo;
sort.sor_w.con_name(0) := b_hi;
sort.sor_w(20) := entries;
sort.sor_w(21) := text;
sort.sor_w(22) := proc;
sort.sor_w(23) := bin;
sort.sor_w(24) := non;
CONT1:
if shift_bases then monitor(72, set_base, 0, base);
close(contr, true);
if shift_bases then monitor(72, set_base, 0, std_base);
\f
comment catsort contract * page 8 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
end
else
begin
if shift_bases then monitor(72, set_base, j, std_base);
if test then
begin
write(out, nl, 1, cat.cat_w.name, b_lo, b_hi, i);
end;
end;
end
else if test then
begin
write(out, nl, 1, cat.cat_w.name, b_lo, b_hi,
_ if check_base then <:checkbase:> else <:notcheckbase:>);
end;
end contract entry ;
end b_lo = b_hi = -1;
end q_step;
close(cat, true);
changerec_6(sort, sor_w);
monitor(42)lookup:(sort, 0, tail);
tail(1) := length;
monitor(44)change_entry:(sort, 0, tail);
close(sort, false);
end;
\f
comment catsort contract * page 9 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
if no_of_entries > 0 then
begin <* catsort *>
boolean sort_ok;
integer array par(1:7), keydesc(1:5, 1:2);
par(1) := segm; <*segs pr inblock *>
par(2) := 1; <* clear inputfile *>
par(3) := segm; <* segs pr outblock *>
par(4) := 1; <* fixed length *>
par(5) := sort_lng; <* length *>
par(6) := 5; <* 5 keys *>
par(7) := 0; <* no comment printed *>
key_desc(1, 1) := +3; <* ascending long *>
key_desc(1, 2) := 6; <* base low *>
key_desc(2, 1) := -3; <* decending long *>
key_desc(2, 2) := 38; <* base high *>
key_desc(3, 1) := -2; <* decending integer *>
key_desc(3, 2) := 2; <* perm_key *>
key_desc(4, 1) := +3; <* increasing long *>
key_desc(4, 2) := 10; <* name(1) *>
key_desc(5, 1) := +3; <* increasing long *>
key_desc(5, 2) := 14; <* name(2) *>
md_sort_proc(par, key_desc, sort_names, 0, no_of_entries,
_ i, j);
if i <> 1 then
begin
long array field nf;
nf := 16;
write(out, nl, 2, <:*** md sort error : :>, nl, 1,
_ case (i-1) of (
_ _ <:not sufficient core. needed core :>,
_ _ <:not sufficient backingstore. needed segm :>,
_ _ <:unknown name of backingstore :>),
_ j, if i = 4 then string pump(sort_names.nf) else <::>, nl, 1);
system(9)alarm:(0, <:<10>**mdsort:>);
end;
end;
\f
comment catsort contract * page 10 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
if no_of_entries > 0 then
begin <* output module *>
procedure print(ud);
zone ud;
begin
zone sort(128*segm, 1, std_error);
long b_lo, b_hi;
integer perm_key, mode, lines, sub_lines, chars,
_ tot_segm, tot_contr, loc_contr, loc_entr;
integer array tail(1:10);
integer array field sor_w;
long array field name, con_name, devi_f;
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;
i := if j > 0 then
_ write(ud, 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(ud, <<d>, 1 shift 11 + mdk shift (-12),
_ <:.:>, mdk extract 12);
chars := (if h_tail(9) = 0 or h_tail(9) = 1 then
_ write(ud, << z>, h_tail(9))
else write(ud, sp, 1, h_tail.name)) + chars + i + 1;
out_char(ud, 32);
out_mode_kind := j <> 1 and j <> 2;
end;
\f
comment catsort contract * page 11 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
procedure write_head(ud);
zone ud;
begin
own integer page;
page := page + 1;
write(ud, nl, 1, ff, 1, nl, 1, <:contract catsort page:>,
_ page, sp, 22);
out_short_clock(ud, short_clock);
write(ud, nl, 2);
lines := 3;
sub_lines := 0;
end;
name := 6;
devi_f := 16;
con_name := 38;
tot_segm :=
tot_contr :=
loc_contr :=
loc_entr := 0;
sub_lines := 0;
sor_w := -sort_lng;
open(sort, 4, sort_names, 0);
monitor(42)lookup:(sort, 0, tail);
tail(1) := ((tail(1) + segm - 1) // segm) * segm;
monitor(44)change_entry:(sort, 0, tail);
in_rec6(sort, segm_bytes);
b_lo := sort.name(0) + 1;
b_hi := sort.con_name(0) - 1;
for i := 1 step 1 until no_of_entries do
begin
if sor_w = new_share then
begin
inrec_6(sort, segm_bytes);
sor_w := 0;
end
else sor_w := sor_w + sort_lng;
if b_lo <> sort.sor_w.name(0) or
_ b_hi <> sort.sor_w.con_name(0) then
begin
perm_key := sort.sor_w(1);
mode := (perm_key mod 2) + 1;
b_lo := sort.sor_w.name(0);
b_hi := sort.sor_w.con_name(0);
if loc_contr > 0 then
write(ud, nl, 1, <:contract<95>files:>, <<__dddd>, loc_contr,
_ nl, 1, <:sub<95>entries :>, loc_entr, nl, 1);
tot_contr := tot_contr + loc_contr;
loc_contr :=
loc_entr := 0;
write_head(ud);
write(ud, sp, 4, <:base::>, b_lo, b_hi, sp, 1,
_ case (perm_key//2+1) of (<:temp:>, <:login:>,
_ _ <:perm:>, <:perm:>), nl, 2,
_ sp, 4, <:contract<95>files::>, nl, 1);
lines := lines + 2;
end;
\f
comment catsort contract * page 12 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
if perm_key <> sort.sor_w(1) then
begin
perm_key := sort.sor_w(1);
mode := (perm_key mod 2) + 1;
case mode of
begin
begin
if lines > 54 then write_head(ud)
else lines := lines + write(ud, nl, 1)+sub_lines;
sub_lines := 0;
write(ud, sp, 4,
_ <:sub<95>entries::>, nl, 1);
lines := lines + 1;
end;
begin
write_head(ud);
write(ud, sp, 4, <:base::>, b_lo, b_hi, sp, 1,
_ case (perm_key//2+1) of (<:temp:>,
_ _ <:login:>, <:perm:>, <:perm:>), nl, 2,
_ sp, 4, <:contract<95>files:>, nl, 1);
lines := lines + 2;
end;
end cases;
end new perm_key;
if sub_lines >= 5 then
begin
lines := lines + sublines;
sub_lines := 0;
if lines > 63 then write_head(ud);
end;
chars := write(ud, true, 12, sort.sor_w.name);
j := 14;
if sort.sor_w(8) >= 0 then
begin
chars := write(ud, <<ddddd>, sort.sor_w(8), sp, 1,
_ true, 6, sort.sor_w.devi_f) + chars;
if sort.sor_w(16) shift (-12) <> 4 and sort.sor_w(16) shift (-12) < 32 then
_ chars := out_shortclock(ud, sort.sor_w(13)) + chars else j := 13;
end
else
if out_mode_kind(sort.sor_w) then
_ chars := out_short_clock(ud, sort.sor_w(13)) + chars
_ else j := 13;
for j := j step 1 until 17 do
chars := (if sort.sor_w(j) < 4096 then
_ write(ud, sp, 1, <<d>, sort.sor_w(j))
else write(ud, sp, 1, <<d>, sort.sor_w(j) shift (-12),
_ <:.:>, sort.sor_w(j) extract 12)) + chars;
\f
comment catsort contract * page 13 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
case mode of
begin
begin
loc_entr := loc_entr + 1;
if chars < 53 then write(ud, sp, 52 - chars)
else sub_lines := write(ud, nl, 1, sp, 52)*0+sub_lines+1;
write(ud, <:; :>, true, 12, sort.sor_w.con_name,
_ <<dddddd>, sort.sor_w(24), nl, 1);
end;
begin
tot_segm := tot_segm + sort.sor_w(8);
loc_contr := loc_contr + 1;
if chars < 53 and sort.sor_w(20) = sort.sor_w(21) then
_ write(ud, sp, 52 - chars, <:;:>, sort.sor_w(20),
_ <: textentries:>, nl, 1)
else
begin
sub_lines := sub_lines + 1;
write(ud, nl, 1, sp, 12, <:;:>);
if sort.sor_w(20) = sort.sor_w(21) then
_ write(ud, sort.sor_w(20), <: textentries:>, nl, 1)
else
begin
for j := 1 step 1 until 5 do
if sort.sor_w(19+j) > 0 then
_ write(ud, sort.sor_w(19+j),
_ case j of(<: entries:>, <: texts:>, <: procs:>,
_ <: bins:>, <: nonar:>), <:,:>);
write(ud, nl, 1);
end;
end;
end;
end mode;
sub_lines := sub_lines + 1;
end;
tot_contr := tot_contr + loc_contr;
no_of_entries := no_of_entries - tot_contr;
write(ud, nl, 1, <:contract<95>files:>, <<__ddddddd>, loc_contr,
_ nl, 1, <:sub<95>entries :>, loc_entr,
_ nl, 3, <:contract<95>files total :>, tot_contr,
_ nl, 1, <:sub<95>entries total :>, no_of_entries,
_ nl, 1, <:contract<95>segments total :>, tot_segm,
_ nl, 1, <:sub<95>entries pr contract<95>file :>,
_ round(no_of_entries / tot_contr),
_ nl, 1, <:segments pr contract<95>file :>,
_ round(tot_segm/tot_contr), nl, 2);
close(sort, true);
monitor(48)remove_entry:(sort, 0, base);
end procedure print;
\f
comment catsort contract * page 14 12 08 80, 10.36
0 1 2 3 4 5 6 7 8 9 ;
if res_name(1) = real <::> then print(out)
else
begin
zone ud(128, 1, std_error);
begin
long array field lf;
long array devi, scope(1:2);
lf := 0;
devi(1) :=
devi(2) :=
scope(2) := long <::>;
scope(1) := long <:user:>;
i := (75 * no_of_entries + 767) // 768;
if set_bsarea(res_name.lf, devi, scope, i,
_ 4, true) <> 0 then system(9, 0, <:<10>*** set:>);
write(out, nl, 2, res_name.lf, <: = set :>, i, sp, 1,
_ devi, <: scope :>, scope, nl, 2);
end;
open(ud, 4, string pump(res_name), 0);
print(ud);
write(ud, em, 3);
close(ud, true);
end;
end
else
write(out, nl, 2, <:++ no contract files on requested base:>, nl, 2);
end;
\f
; catsort contract * page 15 12 08 80, 10.36 ;
if ok.no
mode warning.yes
if warning.yes
(
mode 0.yes
message catcontract not ok
)
if 0.no
(
if 1.yes
scope user cat_contract
if 2.yes
scpe project catcontract
)
lookup catcontract
end
finis
▶EOF◀