|
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: 23040 (0x5a00)
Types: TextFile
Names: »theadm «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »theadm «
external
\f
procedure head_m(filename, file_no, chains, rec_descr, no_of_keys,
size_m);
value file_no, no_of_keys;
integer file_no, no_of_keys;
string filename;
integer array chains, rec_descr, size_m;
begin
comment
filename : the name of the backing store file in which the mas-
terfile head is generated. The size should be great
enough to hold at least 47 +11*no_of_keys +3* no_of
_associated_chains doublewords in an integral num-
ber of segments.
file_no : the users logical file_no.
chains : holds the specification of all chaingroups in the
system. Must be declared (1:no_of_chains*4). A chain-
group occupies 4 words: file_no for motherfile, file_
no for daughterfile, chaintype, and compressed_key_
size, which is a return value from this procedure.
rec_descr : see procedure head_file_i.
no_of_keys : the number of keywords.
size_m : an array of 4 words holding the last 4 parameters of
procedure head_file_i.
The procedure uses internally the procedure head_file_i described
in RCSL 55-D99 to set up the head of an indexed sequential file.
This head is extended to hold the special quantities needed for
for a cf_masterfile head, such as runnumbers, chaintables, the
code piece split_key, simple constants, and addresses.
The head is generated in the local zone z_head, which is connec-
ted to the document filename.
Note: head_file_i is made local to this procedure, but the only
difference from the official external edition is that the variable
savekey (an address in the zone buffer) is made global and its
content is changed to fit the cf_system.
;
comment outer block, check parameters, calculate no. of associated
chains;
integer former, first, chainpartsize, low, up, i, reclengthtype,
reclengthpos, i_buf, m_buf, z_buf;
procedure alarm(int, text);
value int;
integer int;
string text;
comment
the procedure prints an alarm headline, and calls
system(9...;
begin
write(out, <:<10><10>***headm alarm:<10>:>);
system(9, int, text);
end alarm;
former:= first:= chainpartsize:= i:= 0;
low:= system(3, up, chains);
if low <> 1 or up mod 4 <> 0 or up > 8191 then goto diagnos1;
for i:= 1 step 4 until up do
begin if chains(i +1) = file_no or chains(i +2) < 0 or
chains(i +2) > 1 then goto diagnos1;
if chains(i) = file_no then
begin chainpartsize:= chainpartsize +2;
if former <> 0 then chains(former):= i +3 else first:= i +3;
former:= i +3;
end;
end;
if former <> 0 then chains(former):= 0;
reclengthtype:= rec_descr(no_of_keys +1, 1)*6;
reclengthpos:= if reclengthtype = 0 then 0 else
rec_descr(no_of_keys +1, 2);
comment head_file_i will take care of further checks;
i_buf:= 35 +no_of_keys*10;
m_buf:= 12 +no_of_keys* 1 +3*chainpartsize//2;
z_buf:= (i_buf +m_buf +127)//128*128;
begin zone z_head(z_buf, 1, stderror);
integer savekey, k, first_mother_chain, next, split_key_code,
comp_rel, lengthtype, recrel, min_rec_size, max_rec_size,
cf_buf_ref, save_head_size;
integer blw1x2, rlw1x2, dlw1x2, hsw1x3, rsw1x3, dsw1x3, jlx3,
jlrelindir,
b7, b1, b3, b4, b5, b6, b8, b9, b10, b11, b14, b15, b16, b19,
b12, b21, w1, x2, x3;
real r;
integer array tail(1:10);
procedure storeword(word) in z at byte :(p);
value word, p; integer word, p;
begin integer elementno;
elementno:= p//4 +1;
z_head(elementno):=
if p mod 4 < 2 then
0.0 shift 24 add word shift 24 add(z_head(elementno)
extract 24) else z_head(elementno) shift (-24)
shift 24 add word;
end;
procedure system(i, int, text);
integer i, int;
string text;
comment
this procedure will trap the system(9... calls from
head_fle_i;
alarm(int, text);
\f
procedure head_file_i (z, keyfield, n, maxreclength, maxbucks, segsperbuck,
segsperblock);
value n, maxreclength, maxbucks, segsperbuck, segsperblock;
integer n, maxreclength, maxbucks, segsperbuck, segsperblock;
integer array keyfield;
zone z;
begin
comment
z : the name of the zone in which the file head is generated,
only one share is needed, but it should be able to hold
at least 10*n+30 elements as one record in an integral
number of segments.
keyfield : a two-dimensional array holding information about
types and relative locations of the keywords and,
if needed, the length in a record.
n : number of keywords.
maxreclength: maximum length, in reals, of records which will be stored
in the file.
if only constant length records are used then maxreclength
is this constant length.
maxbucks : maximum number of buckets to be provided for in the
buckettable.
segsperbuck : number of segments in one bucket.
on disk normally segsperbuck = 40.
segsperblock: number of segments in one block.
the procedure will generate the head of an indexed sequential file
and output it, by means of outrec, to the file opened in z.
the head consists of codepieces, which will be used by the record
handling procedures whenever they refer to keys or recordlengths,
a list of entry points to these codepieces and other parameters
describing the file.
the head is a whole number of segments which is followed by the buckhead
on a separate segment. the buckhead is also initialized and output in this
procedure.
;
\f
integer blw0, rlw0, dlw1, bsw0, wsw0, ssw1, fsw1, blw1, rlw1, hsw1, rsw1,
dsw1, sew00, snw00, ndw12, jlret, cfw12, jlw2x2, lsw12, jlx3,
w1, w2, x2, x3, relmark,
i, k, i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12,
minrecsize, maxrecsize, reckeysize, keypartsize, bucktablesize,
segsize, doubleintegers, lengthtype, recrel, <* savekey, *> savebase,
segsinhead, segsinsharebucks, segsinshareblocks, blocksperbuck,
blocksperbuck1, bytesperblock, word, isqrelease, monres;
real time;
long sum;
integer array recaddr, saveaddr(1:n+1), typeoperation(1:16), ia(1:10);
integer procedure typeop (base, i); value base, i; integer base, i;
typeop:= typeoperation (base + abs keyfield(i,1));
procedure storeword (word) in z at byte :(p);
value word, p; integer word, p;
begin
integer field element;
element:= p +2;
z.element:= word;
end storeword;
procedure compile (instr); value instr; integer instr;
begin
storeword(
if false add (instr shift (-15)) then
instr - instr extract 12 + (instr-k) extract 12
else instr) in z at byteaddress :(k);
k := k+2;
end compile;
<*start:*>
<*initialize constants:*>
isqrelease:= 12;
w1 := 1 shift 16; w2 := 2 shift 16; x2 := 2 shift 12; x3 := 3 shift 12;
relmark := 1 shift 15;
blw0 := 2 shift 18; rlw0 := 20 shift 18;
dlw1 :=54 shift 18+w1; bsw0 := 17 shift 18;
wsw0 := 8 shift 18; ssw1 := 57 shift 18 + w1;
fsw1 :=49 shift 18 + w1; blw1 := 2 shift 18 + w1;
rlw1 :=20 shift 18 + w1; hsw1 := 26 shift 18 + w1;
rsw1 :=23 shift 18 + w1; dsw1 := 55 shift 18 + w1;
sew00:=42 shift 18; snw00:= 43 shift 18;
ndw12:=35 shift 18 +w1 + 2; cfw12:= 53 shift 18 + w1 + 2;
jlret:=13 shift 18 + relmark; jlx3:= 13 shift 18 + x3;
jlw2x2:=13 shift 18 + w2 + x2 ; lsw12:= 38 shift 18 + w1 + 2;
for i := 1 step 1 until 16 do
typeoperation(i) := case i of
(blw0, rlw0, dlw1, dlw1,
bsw0, wsw0, ssw1, fsw1,
blw1, rlw1, dlw1, dlw1,
hsw1, rsw1, dsw1, dsw1);
<* savekey:= 2; *> i10:= 18; i11:= 4; i12:= 4;
savebase:= savekey+relmark - 1; segsize:= 512;
i0:= 0; i1:= i0+14; i2:= i1+20; i3:= i2+26; i4:= i3+i10;
i5:= i4+i10; i6:= i5+i10+2; i7:= i6+30; i8:= i7+30;
bucktablesize:= i8 -i7;
minrecsize:= maxrecsize:= maxreclength*4;
test_reasonable:
if maxrecsize < 1 or maxrecsize > 10000 or
segsperbuck < 2 or segsperbuck > 1000 or
segsperblock < 1 or segsperblock > 50 or
maxbucks > 10000 then system(9, 0, <:<10>head i p:>);
\f
<*compute addresses:*>
k := reckeysize := doubleintegers := 0;
for i := 1 step 1 until n do
begin
lengthtype := abs keyfield(i,1);
if lengthtype = 3 then
begin lengthtype :=4 ; doubleintegers := doubleintegers + 1; end;
if lengthtype < 1 or lengthtype > 4 then goto keyfielderror;
recrel:= keyfield(i,2); k:= k+lengthtype;
if recrel < lengthtype or recrel >maxrecsize then
goto keyfielderror;
if recrel > reckeysize then reckeysize:= recrel;
if lengthtype > 1 then
begin if recrel mod 2 <> 0 then goto keyfielderror;
k:= k mod 2 + k;
end;
recaddr (i) := recrel + x3; saveaddr (i) := k + savebase
end;
k := keypartsize := k mod 2 + k; reckeysize:= reckeysize mod 2 + reckeysize;
lengthtype := keyfield (n + 1,1);
if lengthtype <> 0 then
variable_length_records:
begin
if lengthtype < 1 or lengthtype > 4 then goto keyfielderror;
recrel:= keyfield(n+1,2);
if recrel < lengthtype or recrel > maxrecsize or
(lengthtype > 1 and recrel mod 2 <> 0) then
goto keyfielderror;
minrecsize := if recrel > reckeysize then recrel else reckeysize;
if lengthtype > 2 then k := k + 2;
recaddr (n + 1) := recrel + x3;
k:= k + 2;
saveaddr (n + 1) := k + savebase;
end;
k:= k+savekey;
i0:= i:= k + 24*n + 8*doubleintegers + (keypartsize+2)//4 * 4 +
(if lengthtype = 0 then 6 else 14);
if i > 2044 then
keyfielderror: system(9, i, <:<10>recdescr:>);
i1:= i1+i0; i2:= i2+i0; i3:= i3+i0; i4:= i4+i0; i5:= i5+i0;
i6:= i6+i0; i7:= i7+i0; i8:=i8+i0;
segsinhead:= (i7-1)//segsize + 1;
outrec6(z, segsinhead*segsize);
storeword (i0+1) at:(0); comment zonebufrefrel;
jlret := jlret + i0 - 2;
\f
generate_codepieces:
compare1 :
;comment compares savekey with the reckey given by x3 = recbase,
exits with: w0 < 0 for savekey < reckey
w0 = 0 for savekey = reckey
w0 > 0 for savekey > reckey
the code generated for each keyfield is of the form:
< form difference in w0 >
se w0 0
jl. return
where se w0 0 is omitted for the last keyfield and
< form difference in w0 > depends on keyfield type as follows:
keyfield type value code
12 - bit integer:
ascending order 1 bl. w0 saveaddr
bs w0 recaddr
descending order -1 bl w0 recaddr
bs. w0 saveaddr
24 - bit integer:
ascending order 2 rl. w0 saveaddr
ws w0 recaddr
descending order -2 rl w0 recaddr
ws. w0 saveaddr
48 - bit integer:
ascending order 3 dl. w1 saveaddr
ss w1 recaddr
sn w0 0
nd w1 2
descending order -3 dl w1 recaddr
ss. w1 saveaddr
sn w0 0
nd w1 2
48 - bit real:
ascending order 4 dl. w1 saveaddr
fs w1 recaddr
descending order -4 dl w1 recaddr
fs. w1 saveaddr
total size in bytes:
n *8 + number of 48 - bit integer fields * 4 - 2;
\f
storeword (k) at:(i0 + 0); comment relative entry point for compare1;
for i := 1 step 1 until n do
begin
compile (typeop(0 , i) +
(if keyfield (i , 1) < 0 then recaddr (i) else saveaddr (i)));
compile (typeop(4 , i) +
(if keyfield (i , 1) < 0 then saveaddr (i) else recaddr (i)));
if abs keyfield (i , 1) = 3 then
begin compile(snw00); compile (ndw12); end;
if i < n then
compile (sew00);
compile(jlret);
end;
savethekey:
;comment moves the reckey given by x3 = recbase to savekey, field by field
according to type:
12 - bit integer 24 - bit integer 48 - bit integer or real
bl w1 recaddr rl w1 recaddr dl w1 recaddr
bs. w1 saveaddr rs. w1 saveaddr ds. w1 saveaddr
terminated by: jl. return.
total size in bytes: n * 4 + 2;
storeword (k) at :(i0 + 4); comment relative entry point for savethekey;
for i := 1 step 1 until n do
begin
compile (typeop(8 , i) + recaddr (i));
compile (typeop(12 , i) + saveaddr (i));
end;
compile (jlret);
restorehead:
;comment moves savelength and savekey to the record given by x3 = recbase,
field by field according to type, with no code for savelength if fixed length
records ( lengthtype = 0 ).
total size in bytes :
( if lengthtype = 0 then 0 else 4 ) + 4 * n + 2;
storeword (k) at:(i0 + 6); comment relative entry point for restorehead;
if lengthtype <> 0 then
begin
compile (typeop (8 , n + 1) + saveaddr (n + 1));
compile (typeop (12 , n + 1) + recaddr (n + 1));
end;
for i := 1 step 1 until n do
begin
compile (typeop (8 , i) + saveaddr (i));
compile (typeop (12 , i) + recaddr (i));
end;
compile (jlret);
\f
copykey:
;comment
copies the savekey to the entry given by x3 = entry by
dl-ds instructions.
terminated by: jl. return.
total size in bytes: (keypartsize+2)//4 * 4 + 2;
storeword (k) at :(i0 + 8); comment relative entry point for copykey;
for i := 1 step 1 until keypartsize // 4 do
begin
compile (dlw1 + 4 * i + savebase);
compile (dsw1 + 4 * i + x3);
end;
if keypartsize mod 4 > 0 then
begin
compile (rlw1 + keypartsize + savebase);
compile (rsw1 + keypartsize + x3);
end;
compile (jlret);
compare2:
;comment compares savekey with the keypart of the entry given
in x3. instructions as in compare1 but other addresses.
terminated by: jl. return.
total size in bytes: 8*n + 4*doubleintegers - 2;
storeword (k) at :(i0 +2); comment relative entry point for compare2;
for i := 1 step 1 until n do
begin
compile (typeop (0 , i) + saveaddr (i) +
(if keyfield (i , 1) < 0 then x3 - savebase else 0 ));
compile (typeop (4 , i) + saveaddr (i) +
(if keyfield (i , 1) < 0 then 0 else x3 - savebase ));
if abs keyfield (i , 1) = 3 then
begin
compile (snw00);
compile (ndw12);
end;
if i < n then compile (sew00);
compile(jlret);
end;
\f
getsize:
;comment
if fixed recordlength is specified, indicated by lengthtype=0, then
getsize simply returns with w1 = maxrecsize otherwise the length field
of the record is moved to savelength, the value converted to number
of bytes and returned in w1.
totalsize in bytes:
if lengthtype = 0 then 2 else 6;
storeword (k) at :(i0 + 10); comment relative entry point for getsize;
if lengthtype <> 0 then
begin
compile (typeop (8 , n + 1) + recaddr (n +1));
compile ( typeop (12 , n + 1) + saveaddr (n +1));
compile (if lengthtype = 4 then cfw12 else lsw12);
end
else
compile (rlw1 + i2+16+relmark);
comment as the next instruction is the common returnjump we need no
jl return here;
storeword (k) at :(i0 + 12); comment relative entry point for compare3;
compile (jlw2x2); comment returnjump in zonebufref - 2;
sizecomputations:
bucktablesize:= maxbucks*(keypartsize+i11)+bucktablesize;
segsinsharebucks:= (bucktablesize-1)//segsize + 1;
blocksperbuck:= segsperbuck*segsize//(segsperblock*segsize+
keypartsize+i12);
segsinshareblocks:= (blocksperbuck*(keypartsize+i12)-1)//segsize + 1;
blocksperbuck1:= (segsperbuck - segsinhead - segsinsharebucks -
segsinshareblocks) // segsperblock;
bytesperblock:= if lengthtype = 0 then
segsperblock*segsize//maxrecsize*maxrecsize
else segsperblock*segsize - maxrecsize + 4;
if segsperblock*segsize < 2*maxrecsize then system(9, 1, <:<10>head i p:>);
if blocksperbuck1 < 1 then system(9, 2, <:<10>head i p:>);\f
<*store file parameters:*>
k:= i1;
for word:=
10 shift 12 + 40, <*i1*>
60,
5 shift 12 + 5,
0,
0,
500,
0,
0,
0,
0,
0, <*i2*>
segsperbuck,
segsinhead*segsize-i7,
0,
0,
0,
blocksperbuck1*(keypartsize+i12),
bucktablesize,
maxrecsize,
minrecsize-1,
blocksperbuck1 shift 12 add blocksperbuck,
bytesperblock,
isqrelease,
0, <*i3*>
i11-1+i8-i7,
keypartsize+i11,
0,
0,
0,
0,
0,
i11 shift 12 add segsinsharebucks,
segsinshareblocks*segsize, <*i4*>
i12-1,
keypartsize+i12,
0,
round sqrt(blocksperbuck)*(keypartsize+i12),
0,
blocksperbuck*(keypartsize+i12),
0,
i12 shift 12 add segsinshareblocks,
segsperblock*segsize, <*i5*>
-1,
0,
0,
0,
0,
segsperblock * segsize,
0,
segsperbuck shift 12 add segsperblock,
0,
jlx3, <*i6*>
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0,
0
do begin storeword (word) at:(k); k:= k+2 end;
\f
if k mod 4 <> 0 then
storeword(0,k);
<*checksum:*>
sum:= long <:isq:> shift(-24);
for i:= 1 step 1 until (i7+3)//4 do
sum:= sum + (-(z(i)extract 24)) + (-(z(i) shift (-24) extract 24));
storeword(sum extract 24) at:(i2);
bucktablehead:
outrec6(z, i8 -i7);
k:= 0;
for word:= 0, 0, 0, 0, segsinhead, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 do
begin storeword(word) at:(k); k:= k+2 end;
setposition(z, 0, 0);
end head_file_i;
\f
comment initialize slang names and instructions;
w1:= 1 shift 16; x2:= 2 shift 12; x3:= 3 shift 12;
blw1x2:= 2 shift 18 +w1 +x2;
rlw1x2:= 20 shift 18 +w1 +x2;
dlw1x2:= 54 shift 18 +w1 +x2;
hsw1x3:= 26 shift 18 +w1 +x3;
rsw1x3:= 23 shift 18 +w1 +x3;
dsw1x3:= 55 shift 18 +w1 +x3;
jlrelindir:= 13 shift 18 +3 shift 14;
jlx3:= 13 shift 18 +x3;
first_mother_chain:= k:= 6;
store_word(-1)at:(k-2);
comment initialize dbtable address;
comment initialize chaintabels;
next:= first; i:= 0;
for i:= i +2 while next <> 0 do
begin storeword(-1) at:(k);
storeword(-1) at:(k +2);
storeword(i) at:(k +4);
storeword((next shift (-2)) shift 12 +i) at:(k +6);
k:= k +8; next:= chains(next);
end;
storeword(0) at:(k);
k:= k +2; comment return_address;
storeword(0) at:(k);
comment
calculate max_rec_size and chain_part_size:
both max_rec_size (size_m(1)) and chain_part_size
are rounded up to a multiplum of 4 to suit file-i
except in the special case of fixed record length
and max_rec_size + chain_part_size being a multiplum
of 4;
max_rec_size:= (size_m(1) + 1)//2 * 2;
if rec_length_type <> 0 or
(max_rec_size + chain_part_size) mod 4 <> 0 then
begin
max_rec_size:= (max_rec_size + 3)//4 * 4;
chain_part_size:= (chain_part_size + 3)//4 * 4;
end rounding;
comment generate split_key_code;
split_key_code:= k:= k +2;
min_rec_size:= 0;
comp_rel:= 0;
for i:= 1 step 1 until no_of_keys do
begin lengthtype:= abs rec_descr(i, 1);
if lengthtype < 1 or lengthtype > 4 then goto diagnos2;
recrel:= rec_descr(i, 2);
if recrel < lengthtype or recrel > size_m(1) then
goto diagnos2;
if min_rec_size < recrel then
min_rec_size:= recrel;
comp_rel:= comprel +lengthtype;
if lengthtype > 1 then
begin if recrel mod 2 <> 0 then goto diagnos2;
comp_rel:= comp_rel mod 2 +comp_rel;
end;
storeword( case lengthtype of
(blw1x2, rlw1x2, dlw1x2, dlw1x2) +comprel)
at:(k);
storeword( case lengthtype of
(hsw1x3, rsw1x3, dsw1x3, dsw1x3) +recrel)
at:(k +2);
k:= k +4;
end;
if min_rec_size < reclengthpos then min_rec_size:= reclengthpos;
storeword(jlrelindir +((-no_of_keys*4 -2) extract 12)) at:(k);
save_head_size:= comp_rel +comp_rel mod 2;
next:= first; i:= 0;
for i:= i +2 while next <> 0 do
begin former:= chains(next);
chains(next):= save_head_size;
next:= former;
end;
k:= k +2;
storeword(split_key_code -(k+6)) at:(k);
k:= k +2; storeword(reclengthtype) at:(k);
k:= k +2; storeword(reclengthpos) at:(k);
cf_buf_ref:= k +2;
storeword(cf_buf_ref -(-1)) at:(-1 +3);
comment store in the area common for _m and _l;
b1:= 0; b3:= b1 +2 +2; b4:= b3 +4 +2; b5:= b4 +2 +2;
b6:= b5 +2; b8:= b6 +2; b9:= b8 +2;
b14:= b9 +2; b15:= b14 +2; b16:= b15 +2;b19:= b16 +2;
for k:= b1, b1 +2, b3, b3 +2, b3 +4, b4, b4 +2, b5, b6, b8,
b9, b14, b15, b16, b19 do
storeword( case(k +2)//2 of (
jlx3,
0, 0, 0, 0, 0, 0, 0, 0, 0,
chainpartsize,
save_head_size,
file_no shift 4 +0,
first_mother_chain -cf_buf_ref,
0)
) at:(cf_buf_ref +k
);
comment store after common area;
b12:= b19 +2; b21:= b12 +2;
storeword(min_rec_size) at:(cf_buf_ref +b12);
savekey:= cf_buf_ref +b21;
comment
reset to zero 4 * noofkeys bytes of the first part of
the file_i head, in order to have unused bytes in the
keypart equal to zero;
for k:= save_key step 2 until save_key + 4*noofkeys do
store_word(0) at:(k);
open(z_head, 4, filename, 0);
comment
lookup the file before possible extension during outrec;
tail(1):= 0;
monitor(42, z_head, 0, tail); <* lookup *>
head_file_i(z_head, rec_descr, no_of_keys, (max_rec_size
+ chainpartsize)//4, size_m(2), size_m(3),
size_m(4));
comment
change the length of the file to a multiplum of segsperbuck;
k:= size_m(3); <* segsperbuck *>
i:= tail(1) // k * k;
tail(1):= if i < k then k else i;
for i:= 2 step 1 until 10 do tail(i):= 0;
tail(6):= systime(7, 0, r); <* shortclock *>
tail(9):= 22 shift 12 add 1; <* cf master *>
monitor(44, z_head, 0, tail); <* change entry *>
close(z_head, true);
result_cf:= 1;
goto ok;
diagnos2: alarm(i, <:<10>recdescr:>);
end;
diagnos1: alarm((i+3)//4, <:<10>chains p:>);
ok:
end head_m;
end
▶EOF◀