|
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: 93000 (0x16b48)
Types: TextFile
Notes: flxfile
Names: »s28101:1.tcatupdate main «, »tcatupdate main «
└─⟦2c579b2cd⟧ Bits:30004129/s28101.imd SW8101/2 BOSS v.2 rel. 2.0
└─⟦4fb120d20⟧
└─⟦this⟧ »s28101:1.tcatupdate main «
(boptions = set 100 1
boptions = slang lister.no
scope user boptions
print boptions words,
.2 integer 0.2)
s. a20 w.
81 12 09, 58 ;0,2 versionid:
a0 ;4 top of devicelist
a1 ;6 number of devices
a2 ;8 max no of private kits in a project
a3 ;10 no of free logical backing storage devices
p. <:options:> ; include options (with devicelist) on segment
; define values:
a0 = e24 + e17 ; top of device list:= first std tape station
; + length of devicelist;
a1 = e17 - e26 ; no of devices:= devlist length - std stations;
a2 = i30 ; max no of private kits:= option value;
c. i27, a3 = i29 - 2 z.; drum present: free bsdevs:= all - 2;
c.-i27, a3 = i29 - 1 z.; no drum: free bsdevs:= all - 1;
e. ; end options
e. ; end slang segment
\f
(catupdate = set 100 1
catupdate = algol spill.yes list.no xref.no
scope user catupdate
)
begin
<* bbj 9 9 76 catupdate ...1... *>
comment this program is intended to create and update
the usercat, nescessary for the boss2-operating-system.
there are several comments throughout the program, in
order to facilitate the understanding of the text, but
for certain of the actions, the reader is kindly
requested to confer with the actual boss2-program-text.
(this is especially recommended for reading the option-
actions (because they are - more or less - directly translated
from slang into algol6).)
apart from this, i have used long variable-names, instead
of having comments...;
\f
<* bbj 9 9 76 description of catalog catupdate ...2... *>
<*
bbj 15-1-76
The usercatalog in Boss
The usercatalog is built as an hierarchical structure of subcatalogs with
each subcatalog consisting of records of varying length. These records
describe all the information available in the catalog.
The catalog is placed on the system disc with the name USERCAT and is re-
served by the operating system BOSS. The catalog is terminated by a re-
cord of type 0 and with a project number 2**23-1 (described later).
The first segment(s) is (are) used as an index to gain faster access to
the catalog.
The first word of the index table is the maximum number of permanent ca-
talog entries which are promised to the projects in the usercatalog (in
negative representation). If there exist more than one index segment the
next word will contain -1. The number of words with -1 is the number of
index segments -1. The following words contain the number of the project
with the highest number on that segment. The address of the segment is
the number of the index word (absolute segment addressing).
The following figure illustrates how the indextable and the catalog en-
tries work
Usercat
! !
!------------------------------! --
0 ! - no. of catalog entries ! !
!------------------------------! !
2 ! -1 ! !
!------------------------------! !
segment 1 4 ! (project number) 0 ! !
!------------------------------! !
6 ! do 0 ! !
!------------------------------! !
8 ! do 1 ! !
!------------------------------! !
! ! !
---------! . ! > index table
segment 2 ! . ! !
! . ! !
!------------------------------! !
! 2**23-1 ! !
!------------------------------! !
! 2**23-1 ! !
---------!------------------------------!---!
! !
segment 3 ! !
!------------------------------!
! inf. about project 0 !
---------!------------------------------!
! !
! !
segment 4 !------------------------------!
! inf. about project 0 !
---------!------------------------------!
! !
! !
segment 5 !------------------------------!
! inf. about project 1 !
---------!------------------------------!
! !
! !
Each record describes a piece of information for a project or a user. The
records have the common feature that the two first bytes describe the
type and the length of the record.
Type 0 and type 2 are special records. Type 0 describes the projects and
type 2 the users within the projects. All common information and resour-
ces are gathered under a type 0 record and all information for each user
is gathered under a type 2 record.
All information about projects and users are necessary in the catalog,
all other types of records are optional.
The following is a list of all the record types and for each type the
meaning of each byte (word) of the record.
Many of the records are concerned with different claims (for instance
disc or drum) with both a standard value and a maximum value, therefore
the record types can assume two values an even integer if standard va-
lues are used and an odd integer if maximum values are used. If only one
of the two types can be used the record is marked with a *.
More information about the catalog can be found in ref1 ch4 p2-3, ref2
ch1 p1-3 and ref3 ch7.
\f
bbj 9 9 76 records in the catalog catupdate ...3...
Record-types in the catalog
* type 0 project
- 0 - 0, 12
- 2 - project number
- 4 - max-interval
- 8 - rest entries, rest slices on disc
- 10 - total entries, total slices on disc
* type 2 user
- 0 - 2, 16
- 2 - user name (8 bytes)
- 10 - user interval start
- 12 - standard interval length
- 14 - number of user indices
* type 4
- 0 - 4, 6
- 2 - standard value of priority
- 4 - minimum value of late
* type 6 private disc kits
- 0 - 6, 12
- 2 - device name
- 10 - rest entries, rest slices
- 12 - total entries, total slices
type 8
- 0 - 8 , 6
- 2 - first word with device bits
- 4 - second word - - -
type 10 accounts (ref1, ch2, p2)
- 0 - 10, 4
- 2 - number of account buffers
type 12 area processes (ref1, ch2, p2)
- 0 - 12, 4
- 2 - area claim
type 14 mess. buffer (ref1, ch2, p3)
- 0 - 14, 4
- 2 - buffer claim
type 16 convert operations (ref1, ch2, p3)
- 0 - 16, 4
- 2 - cbuf claim
\f
bbj 9 9 76 records in the catalog catupdate ...4...
type 18 internal processes (ref1, ch2, p3)
- 0 - 18, 4
- 2 - internal claim
type 20 keys (ref1, ch2, p4)
- 0 - 20, 4
- 2 - number of protection keys
type 22 mounts (ref1, ch2, p5)
- 0 - 22, 4
- 2 - number of mounts
type 24 output (ref1, ch2, p6)
- 0 - 24, 4
- 2 - number of output characters
type 26 size (ref1, ch2, p7)
- 0 - 26, 4
- 2 - number of bytes in core store
type 28 stations (ref1, ch2, p7)
- 0 - 28, 4
- 2 - number of standard tape stations
type 30 tapes (ref1, ch2, p4)
- 0 - 30, 4
- 2 - number of papertapes to be loaded
type 32 time (ref1, ch2, p8)
- 0 - 32, 4
- 2 - net run time
* type 34 user with userpool
- 0 - 34, 10
- 2 - user max interval
- 6 - rest entries, rest slices
- 8 - total entries, total slices
* type 36 drum, key 1
- 0 - 36, 4
- 2 - entries, slices
* type 38 disc, key 1
- 0 - 38, 4
- 2 - entries, slices
\f
bbj 9 9 76 records in the catalog catupdate ...5...
* type 40 disc, key 3
- 0 - 40, 4
- 2 - entries, slices
* type 42 output identification
- 0 - 42 , variable length
- 2 - user name and address
* type 44 drum, key 3
- 0 - 44, 6
- 2 - rest entries, rest slices
- 4 - total entries, total slices
* type 46 drum, key 3
- 0 - 46, 4
- 2 - user entries, slices
* type 48 special device, key 3
- 0 - 48, 12
- 2 - device name
- 10 - user entries, slices
* type 50 max turn around time (ref1, ch2, p4)
- 0 - 50, 4
- 2 - maximum wait
type 52 information for accountjob
- 0 - 52, 16
- 2 -
project identification in textform
- 14 -
* type 54 program
- 0 - 54, 4
- 2 - name of program to be loaded
type 56 available suspend buffers (ref1, ch2, p7)
- 0 - 56, 4
- 2 - suspendings
type 58 online
- 0 - 58, 4
- 2 - conversational jobs allowed (0) / not allowed (1)
type 60 corelock (ref1, ch2, p3)
- 0 - 60, 4
- 2 - corelock time
\f
bbj 9 9 76 records in the catalog catupdate ...6...
type 62 degree of information (ref1, ch2, p5)
- 0 - 62, 4
- 2 - minimal yes (1) / no (0)
type 64 priority
- 0 - 64, 4
- 2 - start priority factor
type 66 deliberate waiting (ref1, ch2, p8)
- 0 - 66, 4
- 2 - maximum wait time
type 68 catalog preservation (ref1, ch2, p6)
- 0 - 68, 4
- 2 - preserve yes (1) / no (0)
type 70 terminal user rights (privileges)
- 0 - 70, 4
- 2 - privilege-bits
type 72 link
- 0 - 72,4
- 2 - no. of simultaneous used links
References
(1) Boss 2 Users Manual
(2) Monitor 3
(3) Boss 2 Installation and Maintenance
*>
\f
<* bbj 9 9 76 declarations catupdate ...7... *>
real array transname, vartransname, newcatname (1:2);
integer max_devicenumber, max_option, max_record_type,
worksize,
std_usercat_index, max_no_of_disckits,
intervaltable_size, varlength, maxlength,
no_of_trans, no_of_vartrans, no_of_privkits,
no_of_priv_discdrives;
boolean nooldcat, leftside, updatetest;
comment definitions of standard-values ... may be changed;
max_devicenumber := 47; comment length of devicelist;
max_option := 26; comment length of option-table;
max_record_type := 72;
worksize := 8; comment size of workareas;
std_usercat_index:= 2; comment no of index segments in usercat;
max_no_of_disckits:=50; comment length of kittable;
intervaltable_size := 200;
comment i.e. max number of projects + greatest no of users in
single project;
varlength := 512//2;
comment maxlength of username - 10 (in bytes...);
updatetest := true;
comment testoutput is selected by the edit-command:
g b/comment iiff updatetest/if updatetest/
;
begin
integer print, no_of_devices;
integer array devicenumber(1:max_devicenumber);
long array devicename(1:5);
begin
integer projno, updateinf, usercatsegm,
state, neutralstate, projectstate, userstate,
linetype, inlinetype, linelength, freeparam, rectypelgth, typeofrec,valueofpar,
paramno, number_of_params,
first_paramno,
first_free_proj, last,
permanent_disc;
long username1, username2, name,
deviceword, maxdeviceword;
boolean nosource, list, userpool,
device, maxdevice, project;
integer field i, j, if2, if4, if12, basis, int1, int2, int3, int4,
int5, int6, int7;
long field lg6, lg10, long1, long2, lastoption, nameptr;
boolean field p1;
integer array p(0:10), line, kind(1:(varlength-10)//2), alphabettable(0:5*128-1),
option(1:5*max_option+2);
real array fpparam, fpparam1(1:2);
integer array field rec;
zone in, trans, vartrans(128, 1, stderror);
\f
<* bbj 9 9 76 help procedures catupdate ...8... *>
procedure output(z, length);
zone z; integer length;
comment the procedure initializes the next transaction-
record, with project-number, username and recordtype
and -length, and information whether creation, changing
or deleting.
furthermore the two special cases are handled:
l. only checking of transactions (i.e. no leftside
in program call)
2. the transactions are allready sorted and may
be used directly to form a new usercat.
;
begin
no_of_trans:= no_of_trans + 1;
outrec6(z, length);
z.if2:= projno;
z.lg6:= username1;
z.lg10:= username2;
z.if12:= rectypelgth shift 4 add (if inlinetype<-1 then 0 else updateinf);
z.basis:= rectypelgth;
end;
procedure move_username(z, length);
value length; zone z; integer length;
comment the procedure moves the first parameter on the
input line (i.e. the username) to the zone;
begin
j:= p(0) * 2; comment start of text;
last := p(1) * 2; comment last of text;
rectypelgth := rectypelgth + last - j + 2;
output(z,length);
i:= int1 - 2;
for i:= i+2 while j <> last do
begin comment move...;
z.i := line.j;
j := j+2;
end;
end move_username;
procedure checkparam(min, max, number, type);
integer min, max, number, type;
comment the procedure checks, that the number_of_params
is within the limits min,max (incl.) and that all
parameters are of legal type. (notice the jensen-device...).
if any inconsistency is found the alarm-procedure
is called;
if number_of_params < min or number_of_params > max then
alarm(<:number of params:>)
else
for number := 0 step 1 until number_of_params-1 do
if type shift (-kind(p(number))) extract 1 = 0 then
alarm(<:illegal type:>);
comment notice: if the actual type contains ..1 shift m..
it means, that an actual parameter with kind=m is
legal...;
procedure alarm(text);
string text;
begin
write(out, <:***:>, text, <:<10>:>);
goto alarmprint;
end;
\f
<* bbj 9 9 76 proc parameter error catupdate ...9... *>
procedure parameter_error;
comment if any parameter error is found in the fp-command, this procedure
is called. it writes the faulty parameters on current
output, and returns to ...next_source... with paramno
pointing at the next parameter;
begin
write(out, <: <10>***parameter error: :>);
for i:= system(4, paramno, fpparam),
system(4, paramno, fpparam) while i shift (-12) = 8 do
begin
write(out, if i shift (-12) = 8 then <:.:> else <: :>);
j := 1;
if i extract 12 = 10 then
write(out, string fpparam(increase(j)))
else
write(out, <<d>, fpparam(1));
paramno := paramno + 1;
end;
write(out, <:<10>:>);
goto next_source;
end parameter_error;
procedure testvalues(rectype,val1);
value rectype,val1; integer rectype,val1;
<* the routine checks the parametervalues for byte/word
overflow/underflow where it is possible
*>
begin integer i,j;
j:=rectype//2;
if j>max_record_type then
begin write(out,<:<10>case out of range in testvalues<10>:>); goto exittest;
end;
i := case j of
(3,3,3,3,1,1,1,1,1,1,
1,2,2,1,1,2,3,3,3,3,
3,3,3,3,2,3,3,1,3,2,
3,1,2,3,3,1
);
<* i-value :
1- the parameter must be within a byte
2- - - - - - a word
3- no check
*>
case i of
begin
<*1*> if (val1<0) or (val1>=4095) then
write(out,<: ***value should not exceed a byte:>);
<*2*> if (val1<0) or (val1>=8388607) then
write(out,<: ***value should not exceed a word:>);
<*3 - nothing *> ;
end case i;
exittest:
end proc testvalues;
\f
<* bbj 9 9 76 initialization catupdate ...10... *>
comment initialization of fields in transaction-records;
if2 := 2; if4 := 4; lg6 := 6; lg10 := 10; if12 := 12;
comment standard values of program options;
nooldcat:= false;
list := false;
nosource := true;
print := 0; comment no listing of usercatalog;
comment initialize state-values;
neutralstate := 1 - (-1) * 3; comment (=1-(smallest type)*3);
projectstate := 1 + neutralstate;
userstate := 1 + projectstate;
state := neutralstate;
comment initialize the primitive interval-routine, in case
of newcat-mode;
first_free_proj := 1 shift 23 + 2;
usercatsegm := std_usercat_index; comment number of indexsegments;
comment initialize the charactertable for reading of username;
for i := 0 step 1 until 5*128-1 do alphabettable(i) := 0;
for i := 33 step 1 until 125 do
alphabettable(i) := 1 shift 12 + 128; comment shift-chars;
for i := 12, 25, 59 do
alphabettable(i) := 1 shift 12 + 256; comment shift back;
for i := 32 step 1 until 125 do
alphabettable(i+128) := 6 shift 12 + i; comment normal chars;
alphabettable(10) := 6 shift 12 + 10;
for i := 10+128, 12+128, 25+128, 59+128 do
alphabettable(i) := 1 shift 12 + 0; comment shift chars;
alphabettable(95) := 6 shift 12 + 32; comment underline is space;
comment initialize the charactertable for reading of normal lines;
for i := 97 step 1 until 125 do
alphabettable(i+256) := 6 shift 12 + i; comment letters;
for i := 9, 14 step 1 until 94,
96, 126 do
alphabettable(i+256) := 7 shift 12 + i; comment delimiters;
for i := 9, 32 step 1 until 125 do
alphabettable(i+384) :=
alphabettable(i+512) := 7 shift 12 + i;
for i := 48 step 1 until 57 do
alphabettable(i+256) := 2 shift 12 + i; comment digits;
for i := 43, 45 do
alphabettable(i+256) := 3 shift 12 + i; comment sign;
for i := 10, 12, 25 do
alphabettable(i+256) := 8 shift 12 + i; comment terminators;
alphabettable(40+256) := 1 shift 12 + 384; comment shift-char;
alphabettable(59+256) := 1 shift 12 + 512; comment shift-char;
for i := 10, 12, 25 do
alphabettable(i+384) :=
alphabettable(i+512) := 1 shift 12 + 256; comment shift back;
alphabettable(41+384) := 1 shift 12 + 256; comment shift back;
for i := 0 step 128 until 512 do
alphabettable(26+i) := 7 shift 12 + 38; comment sub char;
intable(alphabettable); tableindex := 256;
\f
<* bbj 9 9 76 initialization of optiontable catupdate ...11... *>
comment initialization of the option table:
each entry contains:
1. option name
2. action number
3. legal parametertypes for this option (3 bytes)
(notice: 1 shift m means that parameters, whose
readall-kind (-value) is m, are legal)
4. recordtype in usercat
5. recordlength in usercat
;
begin
integer type_2, type_6, type_8, type_2_6, type_2_8;
boolean field byte;
procedure pack(optionname, actionno, partype1,
partype2, partype3, rectype, reclength);
string optionname;
integer actionno, partype1, partype2, partype3,
rectype, reclength;
begin comment the procedure packs the parameters
in the next free elements of the option table;
option.lastoption := long optionname;
byte := lastoption;
for i := actionno, partype1, partype2, partype3,
rectype, reclength do
begin
byte := byte + 1;
option.byte := false add i;
end;
lastoption := lastoption + 10;
end pack;
type_2 := 1 shift 2; comment integer parameter;
type_6 := 1 shift 6; comment text parameter;
type_8 := 1 shift 8; comment end of line;
type_2_6 := type_2 + type_6; comment integer or text parameter;
type_2_8 := type_2 + type_8; comment integer param or end of line;
lastoption := 4;
pack(<:acco:>, 1, type_2, type_8, type_8, 10, 4);
pack(<:area:>, 1, type_2, type_8, type_8, 12, 4);
pack(<:buf:> , 1, type_2, type_8, type_8, 14, 4);
pack(<:cbuf:>, 1, type_2, type_8, type_8, 16, 4);
pack(<:core:>, 1, type_2, type_8, type_8, 60, 4);
pack(<:devi:>, 2, type_2_6, type_8, type_8, 8,6);
pack(<:inte:>, 1, type_2, type_8, type_8, 18, 4);
pack(<:key:> , 1, type_2, type_8, type_8, 20, 4);
pack(<:late:>, 3, type_2, type_2_8, type_8,50,4);
pack(<:mini:>, 9, type_6, type_8, type_8, 62, 4);
pack(<:moun:>, 1, type_2, type_8, type_8, 22, 4);
pack(<:onli:>, 9, type_6, type_8, type_8, 58, 4);
pack(<:outp:>, 1, type_2, type_8, type_8, 24, 4);
pack(<:perm:>, 7, type_6, type_2, type_2, 40, 4);
pack(<:pres:>, 9, type_6, type_8, type_8, 68, 4);
pack(<:prio:>, 1, type_2, type_8, type_8, 64, 4);
pack(<:priv:>, 4, type_2, type_8, type_8, 70, 4);
pack(<:prog:>, 5, type_6, type_8, type_8, 54,10);
pack(<:link:>, 1, type_2, type_8, type_8, 72, 4);
pack(<:size:>, 1, type_2, type_8, type_8, 26, 4);
pack(<:stat:>, 1, type_2, type_8, type_8, 28, 4);
pack(<:susp:>, 1, type_2, type_8, type_8, 56, 4);
pack(<:tape:>, 1, type_2, type_8, type_8, 30, 4);
pack(<:temp:>, 8, type_6, type_2, type_2_8,36,4);
pack(<:time:>, 6, type_2, type_2_8, type_2_8, 32, 4);
pack(<:wait:>, 1, type_2, type_8, type_8, 66, 4);
comment now lastoption points at a place just after the
the option names;
end initialize option table;
\f
<* bbj 9 9 76 initialization catupdate ...12... *>
comment initialize the tables of system devices,
to be used by the action ..device..;
for i := 1 step 1 until 5 do
devicename(i) := long (case i of
(<: :>, <:prin:>, <:card:>, <:punc:>, <:plot:>));
open(trans, 4, <:boptions:>, 0);
inrec6(trans, 4);
write(out, <:<12><10>; catupdate version:>, trans.if2, trans.if4, <:<10><10>:>);
inrec6(trans, 508);
no_of_devices := trans.if4;
p1 := trans.if2-4; comment top of devicelist...;
rec:= 0;
no_of_privkits:= trans.rec(3);
no_of_priv_discdrives:= trans.rec(4);
for i:=1 step 1 until no_of_devices do
begin
devicenumber(i) := trans.p1 extract 11 - trans.p1 shift(-11) extract 1 shift 11;
p1 := p1 - 1;
end;
close(trans, true);
comment initialize the transaction-zone and update
the newcat-option...;
for i:= 3 step 1 until 10 do line(i):= 0;
open(trans, 4, <::>, 0);
line(1) := worksize;
line(2) := 1; comment pref. disc;
monitor(40) create entry:(trans, 0, line);
open(vartrans, 4, <::>, 0);
line(1):= line(2):= 1;
monitor(40) create entry:(vartrans, 0, line);
getzone6(trans, line);
for i:= 1, 2 do
transname(i):= real<::> add line(i*2) shift 24 add line(i*2+1);
getzone6(vartrans, line);
for i:= 1,2 do
vartransname(i):= real<::> add line(i*2) shift 24 add line(i*2+1);
\f
<* bbj 9 9 76 fp-command catupdate ...13... *>
<* examination of the fp-command *>
<* ----------------------------- *>
comment examine the parameter list:
1. if there is a leftside parameter, the transaction
zone is connected to the specified area
(and the option ..leftside.. is set to true)
2. if the first parameter group is cat.yes the
transactions are not merged with the old usercat
(and the option ..newcat.. is set to true)
;
paramno := 1; comment point at a possible programname;
i := system(4, paramno, fpparam); comment get parameter 1 ;
leftside := false;
if i = 6 shift 12 + 10 <* = followed by a name *> then
begin
leftside:= true;
system(4, 0, newcatname); <*leftside := newcatname *>
paramno:= paramno + 1;
i:= system(4, paramno, fpparam); <* fpparam := catupdate *>
end;
first_paramno := paramno + 1;
comment now paramno is the number of the first real parameter,
and fpparam contains the parameter, while i contains the
parameterhead...;
comment test if the first parameter group is cat.yes...;
if if i = 4 shift 12 + 10 <* . followed by a name *> then fpparam(1) = real <:cat:> else false then
begin comment the parameter group may be cat.yes ;
if system(4, paramno + 1, fpparam) = 8 shift 12 + 10
and fpparam(1) = real <:yes:>
and system(4, paramno + 2, fpparam) shift (-12) <> 8 then
begin
paramno := paramno + 2;
nooldcat:= true;
end cat.yes;
end first parameter = <:cat:>;
comment initialize fields in transaction records;
basis := 14;
int1 := 2 + basis;
int2 := 4 + basis; long1 := int2;
int3 := 6 + basis;
int4 := 8 + basis; long2 := int4;
int5 := 10+ basis;
int6 := 12+ basis;
int7 := 14+ basis;
maxlength := int7; comment last byte of longest record;
maxlength := ((maxlength + 3) // 4) * 4; comment must be a
multiple of 4 bytes;
no_of_trans:= no_of_vartrans:= 0;
\f
<* bbj 9 9 76 fp-command catupdate ...14... *>
comment initialize the input zone, and update the list-option...;
next_source: ; comment
*************** ;
comment paramno is the number of the next fpparameter;
i := system(4, paramno, fpparam); comment get the parameter;
if i = 0 then
begin comment the list is empty;
if nosource then
print := 1 shift 3; comment print all catalog...;
linetype := -1; comment simulate a finis-record;
goto select;
end;
if i <> 4 shift 12 + 10 <* space followed by name *> then parameter_error;
i := system(4, paramno + 1, fpparam1); comment examine the following
parameter...;
if i shift (-12) = 8 then
begin comment parameter group ... must be list.on or list.off;
if i = 8 shift 12 + 10 <* . and name follows *>
and fpparam(1) = real <:list:>
and system(4, paramno + 2, fpparam) shift (-12) <> 8 then
begin
list := fpparam1(1) = real <:on:>;
paramno := paramno + 2;
goto next_source;
end list.on or list.off
else
parameter_error;
end parameter group;
comment the parameter is the name of the next source;
paramno := paramno + 1;
nosource := false;
if paramno = first_paramno then
system(9, 0, <:<10>***call :>);
close(in, true);
i := 1; open(in, 4, string fpparam(increase(i)), 0);
comment examine if it is something else than a backing store area;
i := monitor(42, in, 1, line); comment lookup entry;
if i = 0 and line(1) < 0 then
begin comment it is a filedescriptor...;
close(in, true); comment i.e. regret the open...;
i := 2;
open(in, line(1) extract 23, string (real <::> add
line(increase(i)) shift 24 add line(increase(i))), 0);
end;
comment position the input, according to the catalog entry...;
if line(1) > 0 or line(1) extract 12 = 4 or line(1) extract 12 = 18 then
setposition(in, line(7), line(8));
comment ... only in case of backing store area or mag.tape...;
goto first_line;
<* end fp-command *>
<* -------------- *>
\f
<* bbj 9 9 76 input catupdate ...15... *>
print_line: ; comment
*************** ;
if list then
begin
alarmprint: ; comment
*************** ;
write(out, <<d>, inlinetype);
for i := 1 step 1 until (abs linelength)-1 do
case kind(i) of
begin
comment kind 1; write(out, <:***number out of range:>);
comment kind 2; write(out, <<d>, line(i));
comment kind 3,4,5; ;;;
comment kind 6;
begin
write(out, string (real <::> add
line(increase(i)) shift 24 add
line(increase(i))));
i := i-1;
end;
comment kind 7; write(out, false add line(i), 1);
end case kind;
write(out, <:<10>:>);
if inlinetype = 5 then testvalues(typeofrec,valueofpar);
end print line;
comment reading of input ;
comment ---------------- ;
tableindex := 256; comment select std alfabet;
for i := readchar(in, i) while i <> 8 do ;
comment skip any possible line-rest;
first_line: ; comment
*************** ;
if list then
begin comment copy input until sign, digits or endline;
for i:=readchar(in, j) while i<>3 and i<>2 and j<>25 do
write(out, false add j, 1);
repeatchar(in);
end;
if read(in, inlinetype) = 0 then goto next_source;
repeatchar(in);
linetype := inlinetype;
if inlinetype = -1 then goto select; comment finis-record;
linetype := abs linetype;
if linetype = 3 or linetype=12 then tableindex := 0; <* name and add or accounting *>
comment this special alfabet skips the preceding
spaces on a line, and terminates reading when
a semicolon or end_medium char occurs;
linelength := readall(in, line, kind, 1);
repeatchar(in);
freeparam := linelength + 1;
if linetype > 12 or inlinetype < -1 then alarm(<:illegal linetype:>);
if linelength < 0 then alarm(<:line too long:>);
if linetype = 0 then goto select; comment end-record;
if linetype <> 3 and linetype <> 12 and linelength < 3 and linelength <> 0 then
alarm(<:too few parameters on line:>);
comment check the type of the line;
\f
<* bbj 9 9 76 search kind catupdate ...16... *>
comment search the kind-array and find the start of the parameters ;
i := 1;
number_of_params := -1;
comment i is the element in ...kind... to be checked, while
number_of_params is the corresponding parameter number in
the line (notice: parameters are counted from 0...);
for number_of_params := number_of_params + 1 while kind(i) <> 8 do
begin
if number_of_params > 6 then alarm(<:too many parameters:>);
if (1 shift 1 + 1 shift 2 + 1 shift 6) shift (-kind(i))
extract 1 = 0 then
number_of_params := number_of_params - 1
else
p(number_of_params) := i;
comment if the kind of the element is not integer or text
then skip the element, else indicate the start of the
current parameter in the array ..p..
in this way p(J) is the start index of parameter j of
the current line;
for i:= i+1 while kind(i) = kind(i-1) do ;
comment skip the following elements with the same kind;
end;
p(number_of_params) := i; comment the end_of_line element;
select: ; comment
*************** ;
comment dependent of the type of the line, rectypelgth is
initialized with the standard value. (each input line normally
produces one record in the usercat). some of the special
action may however set another rectypelgth;
comment: linetype is in the range from -1 to 12 (both incl.)
-1 0 1 2 3 4 5 6 7 8 9 10 11 12 ;
rectypelgth := case linetype+2 of
(-1, -1, 0, 2, 42, 6, -1, -1, 4, 44, 34, 0, 2, 52)
shift 12 add (case linetype+2 of
(-1, -1, 12, 16, 0, 16, 0, 0, 6, 6, 0, 12, 16, 0) );
comment ... notice that the rectypelgth of linetype 0 is explicitly
used at ...initsort... ;
comment select the corresponding action, depending on line type
and state;
goto case linetype*3 + state of
(initsort , termproj , termuser ,
print_line, termproj , termuser ,
linetype1 , termproj , termuser ,
linetype2 , termproj , termuser ,
illegal , linetype3 , linetype3,
illegal , linetype4 , linetype4,
illegal , linetype5 , linetype5,
illegal , linetype6 , linetype6,
illegal , linetype7 , linetype7,
illegal , linetype8 , linetype8,
illegal , illegal , linetype9,
linetype10, termproj , termuser ,
linetype11, termproj , termuser ,
illegal , linetype12, linetype12);
\f
<* bbj 9 9 76 linetypes catupdate ...17... *>
linetype1: ; comment create project
*************** **************** ;
checkparam(4, 5, 0, 1 shift 2); comment 4 or 5 integer parameters;
if number_of_params = 4 and line(p(1)) = 0 then
alarm(<:number of params:>);
comment convert project width into primitive project
interval...;
p(5) := increase(freeparam);
line(p(5)) := first_free_proj + line(p(4)) - 1;
p(4) := increase(freeparam);
line(p(4)) := first_free_proj;
comment now: p(4) points at lower proj-interval,
p(5) points at upper proj-interval;
goto initproj;
linetype2: ; comment create user
*************** ************* ;
checkparam(3, 5, i, if i=0 then 1 shift 6 else 1 shift 2);
comment 3, 4 or 5 parameters, first is name, rest are integers;
comment initialize standard values;
if number_of_params = 3 then
begin comment insert std job-interval-width;
p(3) := increase(freeparam);
line(p(3)) := 1;
end;
if number_of_params < 5 then
begin comment insert std number of sim. jobs;
p(4) := increase(freeparam);
line(p(4)) := 10;
end;
comment compute primitive user interval;
p(5) := increase(freeparam);
line(p(5)) := first_free_proj;
comment now: p(3) points at job-interval-width.
p(4) points at number of simult. jobs,
p(5) points at lower user interval;
goto inituser;
linetype3: ; comment username record
*************** ***************** ;
checkparam(1, 1, i, 1 shift 6);
comment exactly one text parameter;
comment: the record is copied to a
special file, vartrans, in order to facilitate the
sorting of the transactions (because the sorting then
may concentrate on fixlength records...);
no_of_trans:= no_of_trans - 1;
no_of_vartrans:= no_of_vartrans + 1;
move_username(vartrans, varlength);
goto print_line;
\f
<* bbj 9 9 76 linetypes catupdate ...18... *>
linetype4: ; comment resources on special disc-kits
*************** ******************************** ;
checkparam(4, 4, i, if i=0 then 1 shift 6 else 1 shift 2);
comment 4 parameters, the first is text, the rest integers;
if -, project then userpool:= true;
nameptr := p(0) * 2 + 2; comment point at kit-name;
if line.nameptr = long <:disc:> or
line.nameptr = long <:drum:> then
alarm(<:illegal devicename:>);
output(trans, maxlength);
trans.long1 := line.nameptr;
nameptr := nameptr + 4;
trans.long2 := if kind(p(0)+2) <> 6 then extend 0
else line.nameptr;
trans.int5 :=
trans.int6 := line(p(2)) shift 12 add line(p(1));
trans.int7 := line(p(3));
goto print_line;
linetype5: ; comment standard values for options
*************** ***************************** ;
linetype6: ; comment maximum values for options
*************** **************************** ;
checkparam(2, 4, i, if i=0 then 1 shift 6 else -1);
comment 2 to 4 parameters, the first is text,
the rest may be anything;
nameptr := p(0) * 2 + 2; comment point at option name;
name := line.nameptr shift (-16) shift 16;
comment extract the first four letters...;
option.lastoption := name; comment insert last in table...;
comment scan the option table to find the proper option...;
nameptr := -6;
for nameptr := nameptr + 10 while option.nameptr <> name do ;
if nameptr = lastoption then
alarm(<:option unknown:>);
p1 := nameptr + 2; comment point at first parameter type...;
for i := 1 step 1 until 3 do
begin comment check the parameters in the option line...;
if kind(p(i)) = 8 then
begin
p(i+1) := p(i) + 1;
kind(p(i+1)) := 8;
end
else
if -, option.p1 shift (-kind(p(i))) then
alarm(<:parameter kind:>);
p1 := p1 + 1;
end;
i:= nameptr+5; <*point at recordtype*>
typeofrec:= option.i shift (-12);
i := nameptr + 6; comment point at rectypelgth element;
rectypelgth := option.i;
if linetype = 6 then
rectypelgth := 1 shift 12 + rectypelgth;
comment maximum-value-records have an odd recordtype...;
p1 := nameptr + 1; comment point at action-number byte;
goto case option.p1 extract 12 of
(action1, action2, action3, action4, action5,
action6, action7, action8, action9);
\f
<* bbj 9 9 76 linetypes catupdate ...19... *>
linetype7: ; comment jobpriority and respite
*************** ************************* ;
<* used by older versions, does not exist in newer versions *>
checkparam(2, 2, 0, 1 shift 2);
comment 2 integer parameters;
output(trans, maxlength);
trans.int1 := line(p(0)); comment jobpriority;
trans.int2 := (line(p(1)) * (extend 10000)) shift (-13);; comment respite;
goto print_line;
linetype8: ; comment permanent drum
*************** **************** ;
checkparam(2, 2, 0, 1 shift 2);
comment 2 integer parameters;
output(trans, maxlength);
trans.int1 :=
trans.int2 := line(p(1)) shift 12 add line(p(0));
goto print_line;
linetype9: ; comment userpool
*************** ********** ;
checkparam(2, 2, 0, 1 shift 2);
comment 2 integer parameters;
permanent_disc :=
permanent_disc + line(p(1)) shift 12 add line(p(0));
userpool := true;
goto print_line;
linetype10: ; comment abs create proj
*************** ***************** ;
checkparam(6, 6, 0, 1 shift 2);
comment 6 integer parameters;
goto initproj;
\f
<* bbj 9 9 76 linetypes catupdate ...20... *>
linetype11: ; comment abs create user
*************** ***************** ;
checkparam(6, 6, i, if i=0 then 1 shift 6 else 1 shift 2);
comment 6 parameters, the first is text, the rest
are integers;
goto inituser;
linetype12: ; comment project id (account inf.)
*************** *************************** ;
checkparam(1, 1, 0, 1 shift 6);
comment 1 text parameter;
for i := p(1), i+1 while p(0)+7 > i do line(i) := 0;
p(1) := p(0) + 7;
comment extend the text into 21 chars...;
move_username(trans, maxlength);
goto print_line;
initproj: ; comment
*************** ;
<* the parameter pointed at by p(1) is :
0 - new project or user
1 - change - - -
2 - delete - - -
*>
projno := line(p(0));
if projno < 1 or projno > 999999 then
alarm(<:illegal projno:>);
if line(p(1)) < 0 or line(p(1)) > 2 then
alarm(<:illegal update identification:>);
updateinf := (if line(p(1)) = 2 then 0 else line(p(1)) + 1) shift 1
add (if linetype=1 then 1 else 0);
if updateinf = 1 then alarm(<:illegal update information:>);
project := true;
username1 := username2 := 0;
output(trans, maxlength);
maxdeviceword := -1; comment no devices allowed;
deviceword := 0; comment no devices requested;
maxdevice :=
device := false;
trans.int1 := projno;
trans.int2 := line(p(4)); comment lower proj interv.;
trans.int3 := line(p(5)); comment upper proj interv.;
trans.int4 :=
trans.int5 := line(p(3)) shift 12 add line(p(2));
state := if updateinf = 0 then neutralstate else projectstate;
goto print_line;
\f
<* bbj 9 9 76 linetypes catupdate ...21... *>
inituser: ; comment
*************** ;
projno := line(p(1));
if line(p(2)) < 0 or line(p(2)) > 2 then
alarm(<:illegal update identification:>);
updateinf := (if line(p(2)) = 2 then 0 else line(p(2)) + 1) shift 1
add (if linetype=2 then 1 else 0);
if updateinf = 1 then alarm(<:illegal update information:>);
project := false;
nameptr := p(0) * 2 + 2; comment point at username...;
username1 := line.nameptr;
nameptr := nameptr + 4;
username2 := if kind(p(0) + 2) <> 6 then extend 0
else line.nameptr shift (-24) shift 24;
comment if the username is shorter than 7 characters,
the name is extended with null-chars, otherwise
the name allways is cut down to at most 9 chars;
output(trans, maxlength);
maxdeviceword := -1; comment no devices allowed;
deviceword := 0; comment no devices requested;
maxdevice :=
device := false;
userpool := false;
permanent_disc:= 0;
trans.long1:= username1;
trans.long2:= username2;
trans.int5 := line(p(5)); comment user interval start;
trans.int6 := line(p(3)); comment job-interval-width;
trans.int7 := line(p(4)); comment number of simult. jobs;
state := if updateinf = 0 then neutralstate else userstate;
goto print_line;
\f
<* bbj 9 9 76 linetypes catupdate ...22... *>
termuser: ; comment
*************** ;
if userpool then
begin comment output the max-interval record;
rectypelgth := 34 shift 12 add 10;
output(trans, maxlength);
trans.int3 :=
trans.int4 := permanent_disc;
end;
termproj: ; comment
*************** ;
if device then
begin comment output the device record;
rectypelgth := 8 shift 12 add 6;
output(trans, maxlength);
trans.long1 := deviceword;
end;
if maxdevice then
begin comment output the max-device record;
rectypelgth := 9 shift 12 add 6;
output(trans, maxlength);
trans.long1 := maxdeviceword;
end;
state := neutralstate;
goto select;
illegal: ; comment
*************** ;
alarm(<:out of sequence:>);
\f
<* bbj 9 9 76 special actions catupdate ...23... *>
comment the following contains the different
special actions to be taken with the different
options, called by linetype 5 and linetype 6...
notice: some of the action require a certain linetype
***************************************************** ;
action1: ; comment
*************** ;
comment joboptions which consist of <keyword> <int parameter> ;
comment acco, area, buf, cbuf, core, inte, key, outp,
moun, wait, size, stat, susp, tape, prio, link;
output(trans, maxlength);
valueofpar:=trans.int1 := line(p(1));
goto print_line;
action2: ; comment
*************** ;
comment devi;
if kind(p(1)) = 6 then
begin comment text parameter;
nameptr := p(1) * 2 + 2; comment point at device name;
name := line.nameptr shift (-16) shift 16;
comment extract the first four letters of device name;
for i := 2 step 1 until 5 do
if devicename(i) = name and devicenumber(i) > 0 then
goto device_found;
if name = long <:no:> then
begin
i := 50; comment devicebit out of range...;
if linetype = 5 then deviceword := 0
else maxdeviceword := -1;
end
else
alarm(<:device unknown:>);
end
else
begin comment integer parameter;
for i := no_of_devices step -1 until 4 do
if line(p(1)) = devicenumber(i) then
goto device_found;
alarm(<:device unknown:>);
end;
device_found:
if linetype = 5 then
begin
if deviceword shift (-47+i) extract 1 = 0 then
deviceword := deviceword + (extend 1) shift (47-i);
device := true;
end
else
begin
if maxdeviceword shift (-47+i) extract 1 = 1 then
maxdeviceword := maxdeviceword - (extend 1) shift (47-i);
maxdevice := true;
end;
goto print_line;
\f
<* bbj 9 9 76 special actions catupdate ...24... *>
action3: ; comment
*************** ;
comment late;
output(trans, maxlength);
valueofpar:=trans.int1 := extend 0
+ ((line(p(1)) * 60
+ (if kind(p(2))=2 then line(p(2)) else 0))
* (extend 600000))
shift (-13);
goto print_line;
action4: ; comment
*************** ;
comment priv;
if linetype <> 5 then
alarm(<:max value not allowed:>);
output(trans, maxlength);
i:=line(p(1));
if i>9 or i<=0 then alarm(<:privilege illegal:>);
trans.int1:=case i of (4081, 4080, 4064, 4032, 3968, 3840, 3584, 3072, 2048);
goto print_line;
action5: ; comment
*************** ;
comment prog;
if linetype <> 5 then
alarm(<:max value not allowed:>);
output(trans, maxlength);
nameptr := p(1) * 2 + 2; comment point at programname;
trans.long1 := line.nameptr;
nameptr := nameptr + 4;
trans.long2 := if kind(p(1) + 2) = 6 then line.nameptr shift (-8) shift 8
else extend 0;
goto print_line;
action6: ; comment
*************** ;
comment time;
output(trans, maxlength);
j := 0; comment compute time from up to three params;
for i := 1 step 1 until 3 do
if kind(p(i)) <> 2 then i := 3
else j := j * 60 + line(p(i));
valueofpar:=trans.int1 := ((extend 10000) * j) shift (-13);
goto print_line;
\f
<* bbj 9 9 76 special actions catupdate ...25... *>
action7: ; comment
*************** ;
comment perm;
if linetype <> 5 then
alarm(<:max value not allowed:>);
nameptr := p(1) * 2 + 2; comment point at device name;
name := line.nameptr;
if name = long <:drum:> then rectypelgth := 46 shift 12 add 4
else if name <> long <:disc:> then goto special;
output(trans, maxlength);
trans.int1 := line(p(3)) shift 12 + line(p(2));
goto print_line;
special:
rectypelgth := 48 shift 12 add 12;
output(trans, maxlength);
trans.long1 := line.nameptr;
nameptr := nameptr + 4;
trans.long2 := if kind(p(1) + 2) <> 6 then extend 0
else line.nameptr shift (-8) shift 8;
trans.int5 := line(p(3)) shift 12 + line(p(2));
goto print_line;
action8: ; comment
*************** ;
comment temp;
if linetype <> 5 then
alarm(<:max value not allowed:>);
nameptr := p(1) * 2 + 2; comment point at devicename;
name := line.nameptr;
if name = long <:disc:> then rectypelgth := 38 shift 12 add 4
else if name <> long <:drum:> then
alarm(<:temp not allowed on specified device:>);
output(trans, maxlength);
trans.int1 := line(p(2)) + (if kind(p(3)) = 2 then line(p(3)) shift 12
else 0);
goto print_line;
action9: ; comment
*************** ;
comment onli , pres or mini;
nameptr := p(1) * 2 + 2; comment point at answer;
name := line.nameptr;
if name = long <:no:> then i := 0
else if name = long <:yes:> then i := 1
else alarm(<:illegal parameter:>);
output(trans, maxlength);
trans.int1 := i;
goto print_line;
\f
<* bbj 9 9 76 end of input catupdate ...26... *>
initsort: ; comment
**************** ;
comment now all input has been processed, and has been
changed into transaction records;
rectypelgth := 0 shift 12 add 12; comment produce a end-catalog-record;
projno := (-1) shift (-1);
username1 := username2 := 0;
updateinf := 0;
output(trans, maxlength);
output(vartrans, varlength);
no_of_trans := no_of_trans - 1; comment compensate the counting;
no_of_vartrans := no_of_vartrans + 1;
close(in, true);
close(trans, true);
close(vartrans, true);
end; <* end of input *>
\f
<* bbj 9 9 76 sorting of records catupdate ...27... *>
begin comment sorting block;
procedure discsort(filnavn,læ,antalindiv,segmprblok,ngl,levls);
value segmprblok; string filnavn;
integer læ,antalindiv,segmprblok,levls;
integer array ngl;
begin integer fysisksubbloklængde, fysiskbloklængde, b;
integer array ia(1:20); array ra(1:2);
fysisksubbloklængde := 512 * segmprblok;
b:= (system(2,b,ra)-8*512)//(2*fysisksubbloklængde);
fysiskbloklængde := b * fysisksubbloklængde;
segmprblok := b * segmprblok;
comment iiff updatest then write(out, <:<10>antalindiv = :>, antalindiv);
begin integer diff, fa, indivlæ2, logiskbloklængde,
logisksubbloklængde, nedbasis, nedplads, nedslut, opbasis,
opplads, opslut, slut2, start2, subblokstart, transporter;
long array field m, ned, op; integer array nuvblok(0:1);
zone z(fysiskbloklængde//2,1,blproc);
long array mid, nøgle(1:levls);
long r;
long field i;
integer j, levels, level; integer field indivlæ;
procedure blproc(z,s,b); zone z; integer s, b;
if s extract 19 < 1 shift 18 or ia(4)<>5 shift 12 then
stderror(z,s,b);
procedure io(plads,operation); integer plads, operation;
begin b:=nuvblok(plads)*segmprblok;
if b>=0 then
begin ia(4):= operation shift 12;
ia(7):= b;
ia(5):= b:= fa + plads*fysiskbloklængde;
ia(6):= b + fysiskbloklængde - 2;
setshare(z,ia,1);
monitor(16,z,1,ia); check(z);
end
end io;
\f
<* bbj 9 9 76 quicksort catupdate ...28... *>
procedure quicksort(start,slut,enblok); value start, slut, enblok;
integer start, slut; boolean enblok;
begin
for m:=(start+slut)//indivlæ2*indivlæ while start<slut-indivlæ2 do
begin op:= start-opbasis; ned:= slut-nedbasis;
if enblok then m:=m-opbasis else
begin transporter:=0;
transport(m,0,opplads,nedplads);
nedslut:=ned; opslut:=op;
end;
for level:= 1 step 1 until levels do
mid(level):= z.m(nøgle(level));
søgned: ned:= ned-indivlæ; if ned < nedslut then
begin transport(ned,nedbasis,nedplads,opplads);
nedslut:= subblokstart;
end;
for level:= 1 step 1 until levels do
if z.ned(nøgle(level)) > mid(level) then goto søgned else
if z.ned(nøgle(level)) < mid(level) then level:= levels;
søgop: op:= op+indivlæ; if op >= opslut then
begin transport(op,opbasis,opplads,nedplads);
opslut:= subblokstart + logisksubbloklængde;
if transporter=3 then enblok:= nedslut=subblokstart;
end;
for level:= 1 step 1 until levels do
if z.op(nøgle(level)) < mid(level) then goto søgop else
if z.op(nøgle(level)) > mid(level) then level:= levels;
if op+opbasis < ned+nedbasis then
begin for i:=4 step 4 until indivlæ do
begin r:=z.op.i; z.op.i:=z.ned.i; z.ned.i:=r end;
if indivlæ extract 2 = 2 then
begin j:=z.op.indivlæ; z.op.indivlæ:=z.ned.indivlæ; z.ned.indivlæ:=j end;
goto søgned;
end;
slut2:= op+opbasis; start2:= start; start:= ned+nedbasis;
if slut-start < slut2-start2 then
begin i:=slut; slut:=slut2; slut2:=i;
i:=start; start:=start2; start2:=i;
end;
if start2<slut2-indivlæ2 then quicksort(start2,slut2,enblok);
end for m;
end quicksort;
\f
\f
<* bbj 9 9 76 transport catupdate ...29... *>
procedure transport(fysisk,basis,plads,andenplads);
integer fysisk, basis, plads, andenplads;
begin integer logisk, blok, blokrel, subbloknr, blokbasis;
logisk:= fysisk+basis;
blok:= logisk//logiskbloklængde; blokrel:= logisk mod logiskbloklængde;
if blok = nuvblok(0) then plads := 0 else
if blok = nuvblok(1) then plads := 1 else
begin plads := 1-andenplads; io(plads,5);
nuvblok(plads):= blok; io(plads,3);
end;
subbloknr := blokrel//logisksubbloklængde;
blokbasis := plads * fysiskbloklængde;
fysisk := blokrel + subbloknr * diff + blokbasis;
subblokstart := subbloknr * fysisksubbloklængde + blokbasis;
basis := logisk - fysisk;
transporter := transporter + 1;
end transport;
open(z,4,filnavn,1 shift 18); close(z,false);
getzone(z,ia); fa:=ia(19)+1; getshare(z,ia,1);
indivlæ:= læ;
indivlæ2:= 2*indivlæ;
levels:= levls;
for level:= 1 step 1 until levels do
nøgle(level):= ngl(level);
diff:= fysisksubbloklængde mod indivlæ;
logisksubbloklængde := fysisksubbloklængde - diff;
logiskbloklængde := b * logisksubbloklængde;
nuvblok(0) := nuvblok(1) := -1;
opbasis:= nedbasis:= nedplads:= 0;
quicksort(-indivlæ, indivlæ*antalindiv, false);
io(0,5); io(1,5);
end zone blok;
end disksort;
integer array keyfield(1:6); integer i;
for i:= 1 step 1 until 6 do keyfield(i):= case i of(1,2,3,4,5,6);
i:= 1; discsort(string transname(increase(i)), maxlength, no_of_trans, 1, keyfield, 6);
i:= 1; discsort(string vartransname(increase(i)), varlength, no_of_vartrans, 1, keyfield, 3);
end sorting block;
\f
\f
<* bbj 9 9 76 declarations catupdate ...30... *>
begin
integer projlower, projupper, lowerint, upperint,
minimum, maximum,
nextnew, nextold,
level, copytype,
firstsegm, projsegm, projrel,
projstart, userstart, nil;
long tproj, tuser1, tuser2, ttype,
cproj, cuser1, cuser2, ctype, ckit1, ckit2,
width, catno, transno;
boolean absint, warning, delete, nodelete, create, after_delete,
firsttime, bool, record_in_inbuf,
newproj, firstproj, projlist, userlist;
integer field proj, cupper, clower, cstart, cwidth, cjobs,
maxlower, maxupper,
ptr, oldptr, firstfree, i, j, if2, if12, basis;
long field kitname1, kitname2, username1, username2,
lg6, lg10;
integer array xinf(1:2),
intervals(1:3*intervaltable_size),
special_action(0:max_record_type//2);
long array comp(1:2,1:4);
boolean array change(0:max_record_type//2);
integer array field old, new, rec, cat, upper, lower;
zone trans, vartrans, oldcat, newcat(128, 1, stderror);
\f
<* bbj 9 9 76 proc initialize catupdate ...31... *>
procedure initialize(start, project, lowint, upint);
value project, lowint, upint;
integer start, lowint, upint;
boolean project;
comment the procedure initializes the intervaltable, and
returns the start-address of the list in ..start..;
begin
integer lowerint, upperint, segm;
integer field minptr, stepptr, searchptr;
comment iiff updatest then write(out, <:<10>initialize :>, if project then <:proj:> else <:user:>, lowint, upint);
if firstfree > intervaltable_size then
interval_alarm;
start := oldptr := firstfree;
firstfree := firstfree + 6;
comment initialize list-head, containing top- and base-interval
of the ..owner.. of the list (i.e. the surrounding
interval to be obeyed);
intervals.lower.oldptr := upint + 1;
intervals.upper.oldptr := lowint - 1;
intervals.oldptr := nil;
comment notice the funny exchange of lower- and upper...;
if newproj or firstproj then goto exit;
comment i.e. there are no proper records in oldcat;
comment the oldcat is searched, extracting the information
concerning the intervals of all projects (or all
users belonging to the current project);
getposition(oldcat, 0, segm);
setposition(oldcat, 0, if project then firstsegm else projsegm);
cat := if project then 0 else projrel;
\f
<* bbj 9 9 76 proc initialize catupdate ...32... *>
next_block:
inrec6(oldcat, 512);
for i := oldcat.cat.if2 extract 12 + cat while oldcat.cat.if2 <> 0 do
begin
if oldcat.cat.if2 < 2 shift 12 then
begin
comment project record;
if -, project or oldcat.cat.proj = maximum then
goto updated;
if firstfree > intervaltable_size then
interval_alarm;
intervals.lower.firstfree := lowerint := oldcat.cat.clower;
intervals.upper.firstfree := oldcat.cat.cupper;
if lowerint <> minimum then
firstfree := firstfree + 6;
comment maintenance-project and account-project are
not included in interval-list;
end proj-record
else
if if project then false else oldcat.cat.if2 < 4 shift 12 then
begin
comment user-record (skipped if only extracting projects...);
if firstfree > intervaltable_size then
interval_alarm;
intervals.lower.firstfree := lowerint := oldcat.cat.cstart;
intervals.upper.firstfree :=
oldcat.cat.cwidth * oldcat.cat.cjobs + lowerint - 1;
if lowerint <> minimum then
firstfree := firstfree + 6;
end user-record;
cat := i; comment increase to next record...;
end;
cat := 0;
goto next_block;
\f
<* bbj 9 9 76 proc initialize catupdate ...33... *>
updated:;
comment restore the oldcat-zone...;
setposition(oldcat, 0, segm);
inrec6(oldcat, 512);
comment the intervals must be sorted:
primary: lower interval ascending,
sec.ary: upper interval descending;
for stepptr := start+6 step 6 until firstfree-6 do
begin
minptr := stepptr; comment point at current winner;
lowerint := intervals.lower.minptr;
for searchptr := stepptr+6 step 6 until firstfree-6 do
if if extend intervals.lower.searchptr < lowerint then true else
intervals.lower.searchptr = lowerint and
extend intervals.upper.searchptr < intervals.upper.minptr then
begin
minptr := searchptr;
lowerint := intervals.lower.minptr;
end;
comment exchange the challenger and the winner;
intervals.lower.minptr := intervals.lower.stepptr;
intervals.lower.stepptr:= lowerint;
upperint := intervals.upper.minptr;
intervals.upper.minptr := intervals.upper.stepptr;
intervals.upper.stepptr:= upperint;
comment insert in list of intervals;
intervals.oldptr := oldptr := stepptr;
intervals.stepptr := nil;
end sorting;
exit:
end initialize_procedure;
\f
<* bbj 9 9 76 proc getinterval catupdate ...34... *>
procedure get_interval(start, lowint, upint);
value start;
integer start, lowint, upint;
comment the procedure searches the interval-list, starting
at start, until a hole with the width upint-lowint+1
is found. special actions are made with abs-intervals;
begin
long oldupper, maxupper, low;
width := extend upint - lowint + 1;
ptr := start;
maxupper := intervals.upper.ptr;
comment iiff updatest then
write(out, <:<10>get interval :>, start, lowint, upint,
intervals.upper.ptr, intervals.lower.ptr);
if absint then
begin
if extend lowint <= intervals.upper.ptr or
extend upint >= intervals.lower.ptr then
update_alarm(<:illegal abs interval:>);
end;
rep:
oldptr := ptr;
oldupper := intervals.upper.oldptr;
ptr := intervals.oldptr;
if oldupper > maxupper then maxupper := oldupper;
if ptr <> nil then
begin
low := intervals.lower.ptr;
if absint then
begin
comment search until low has passed lowint...;
if low < lowint then goto rep;
comment if low has not yet passed upint then overlap...;
if low <= upint then
begin
warning := true;
update_alarm(<:overlapping intervals:>);
end;
comment search until the sorting demands are fulfilled...;
if low = lowint and
intervals.upper.ptr > upint then goto rep;
end
else
begin
comment search until a hole is found big enough...;
if low - oldupper <= width then goto rep;
end
end ptr <> nil
else
ptr := start; comment notice: lower.start is top of legal interv.;
\f
<* bbj 9 9 76 proc getinterval catupdate ...35... *>
comment now oldptr points at element just before, while
intervals.lower.ptr contains the start of the next interval
(used to chech ..no room..);
if absint then
oldupper := lowint - 1
else
if intervals.lower.ptr - oldupper <= width then
update_alarm(<:no room:>);
if firstfree > intervaltable_size then
interval_alarm;
intervals.lower.firstfree := lowint := oldupper + 1;
intervals.upper.firstfree := upint := oldupper + width;
if maxupper >= lowint then
begin
warning := true;
update_alarm(<:overlapping intervals:>);
end;
intervals.firstfree := intervals.oldptr;
intervals.oldptr := firstfree;
firstfree := firstfree + 6;
end get_interval...;
\f
<* bbj 9 9 76 proc output catupdate ...36... *>
procedure output(from, iaf);
zone from;
integer array field iaf;
begin
integer length;
length := from.iaf.if2 extract 12;
comment iiff updatest then write(out, <:<10>output :>, from.iaf.if2 shift (-12), length, nextnew);
if nextnew+length > 510 then
begin
if leftside then outrec6(newcat, 512);
nextnew := 0;
end;
new := nextnew;
nextnew := nextnew + length; comment point at next record;
for i := 2 step 2 until length do
newcat.new.i := from.iaf.i;
newcat.new.i := 0;
comment insert a dummy zero (in case of block-change...);
end output_procedure;
procedure interval_alarm;
begin
write(out, <:***the catupdate program must be corrected and
recompiled, with a greater intervaltable_size<10>:>);
system(9, intervaltable_size//6, <:<10>size :>);
end;
procedure update_alarm(text);
string text;
begin
write(out, <:projno= :>, <<dddddd>, tproj, <: user= :>);
i := 1;
write(out, false add 32,
13 - write(out, string( case increase(i) of (tuser1, tuser2))),
<:*** :>,text,<: ***:>, <:<10><10> ; :>);
if ttype=42 then printrec(vartrans.rec, tproj)
else printrec(trans.rec , tproj);
write(out, <:<10><10>:>);
if warning then warning := false else
goto next_trans;
end;
\f
<* bbj 9 9 76 proc printrec catupdate ...37... *>
procedure printrec(record, projno);
integer array record;
long projno;
comment the procedure prints the current record in such a way,
that it later may be used again as input for the program...;
begin
integer i, typ, type, length;
long longwork;
boolean newline;
procedure slices(n); integer n;
write(out, <<d>, record(n) shift 12 // 4096, <:,:>, record(n) // 4096);
procedure claim(n); integer n;
begin
write(out, <: (slices, entries=) :>);
slices(n);
end;
procedure restclaim(n); integer n;
begin
write(out, <: (restclaim= :>);
slices(n);
write(out, <:):>);
end;
procedure temp_or_perm(device, n); string device; integer n;
begin
write(out, <: 5 :>, if type < 40 then <:temp :> else <:perm :>, device);
claim(n);
end;
long procedure name;
name := case increase(i) of (record.username1, record.username2);
long procedure longtext;
longtext := long <::> add (if i < length then record(increase(i)+1) else 0) shift 24
add (if i < length then record(increase(i)+1) else 0);
procedure standard(text); string text;
write(out, <<ddd>, typ, <: :>, text, << d>, record(2));
\f
<* bbj 9 9 76 proc printrec catupdate ...38... *>
type := record(1) shift (-12);
length := record(1) extract 12;
typ := if type extract 1 = 0 then 5 else 6;
i := 1; comment used in printing text a.o.;
case type shift (-1) + 1 of
begin
comment type=0, project-record;
begin
write(out, <: 10 (new projno =):>, <<dddddd>, projno, <: 0:>);
claim(6);
restclaim(5);
write(out, <: (interval=):>, record.clower, record.cupper);
end;
comment type=2, user-record;
write(out, <: 11 (new user =) :>, string name,
<: (projno =):>, projno, <: 0 (width,jobs,start =):>,
record.cwidth, record.cjobs, record.cstart);
comment type=4, priority and respite;
write(out, <: 7 (priority, respite =):>, record(2),
(extend record(3)) shift 13 // 10000);
comment type=6, claims on private kits;
begin
write(out, <: 4 (private kit =) :>, string name);
claim(7);
restclaim(6);
write(out, <: (slicelength =):>, if length = 14 then 8 else record(8));
end;
comment type=8/9 , device-mask record;
begin
longwork := record.username1;
if type extract 1 = 1 then longwork := -1 - longwork;
comment ones-complement...;
if longwork = 0 then
write(out, <<ddd>, typ, <: device no:>)
else
begin
newline := false;
for i := 2 step 1 until 5 do
if longwork shift (-47+i) extract 1 = 1 then
begin write(out, newline, 1);
newline := false add 10;
write(out, <<ddd>, typ, <: device :>, string devicename(i));
end;
for i := 6 step 1 until no_of_devices do
if longwork shift (-47+i) extract 1 = 1 then
begin write(out, newline, 1);
newline := false add 10;
write(out, <<ddd>, typ, <: device :>, devicenumber(i));
end;
end;
end;
\f
<* bbj 9 9 76 print rec types catupdate ...39... *>
comment type=10/11;
standard(<:acco:>);
comment type=12/13;
standard(<:area:>);
comment type=14/15;
standard(<:buf:>);
comment type=16/17;
standard(<:cbuf:>);
comment type=18/19;
standard(<:inte:>);
comment type=20/21;
standard(<:key:>);
comment type=22/23;
standard(<:moun:>);
comment type=24/25;
write(out, <<ddd>, typ, <: outp:>, << d>, record(2), <: (slices):>);
comment type=26/27;
standard(<:size:>);
comment type=28/29;
standard(<:stat:>);
comment type=30/31;
standard(<:tape:>);
comment type=32/33;
begin
write(out, <<ddd>, typ, <: time:>);
longwork := (extend record(2)) shift 13 // 10000;
if longwork >= 3600 then write(out, longwork // 3600);
if longwork >= 60 then write(out, longwork mod 3600 // 60);
write(out, longwork mod 60);
end;
comment type=34;
begin
write(out, <: 9 (userpool):>);
claim(5);
restclaim(4);
end;
comment type=36, temp drum;
temp_or_perm(<:drum:>, 2);
comment type=38, temp disc;
temp_or_perm(<:disc:>, 2);
comment type=40, perm disc;
temp_or_perm(<:disc:>, 2);
comment type=42, username and address;
write(out, <: 3 :>, string longtext);
\f
<* bbj 9 9 76 print rec types catupdate ...40... *>
comment type=44, permanent resources on drum;
begin
write(out, <: 8 (permanent drum):>);
claim(3);
restclaim(2);
end;
comment type=46, perm drum;
temp_or_perm(<:drum:>, 2);
comment type=48, perm <private kit>;
temp_or_perm(string name, 6);
comment type=50/51 the latest finishing time for the job;
begin
longwork := (extend record(2)) shift 13 // 600000;
write(out,<<ddd>, typ, <: late:>, longwork // 60, longwork mod 60);
end;
comment type=52, project id;
write(out, <: 12 :>, string longtext);
comment type=54;
write(out, <: 5 program= :>, string name);
comment type=56;
standard(<:susp:>);
comment type=58/59;
write(out, <<ddd>, typ, <: onli:>, if record(2) = 0 then <: no:> else <: yes:>);
comment type=60/61;
standard(<:core:>);
comment type=62/63;
write(out,<<ddd>, typ, <: mini:>, if record(2) = 0 then <: no:> else <: yes:>);
comment type=64/65;
standard(<:prio:>);
comment type=66/67;
standard(<:wait:>);
comment type=68/69;
write(out, <<ddd>, typ, <: pres:>, if record(2) = 0 then <: no:> else <: yes:>);
\f
<* bbj 9 9 76 print rec types catupdate ...41... *>
comment type=70;
begin
write(out,<<ddd>, typ,<: priv:>);
longwork:=record(2);
if longwork extract 1=1 then i:=1 else
begin
longwork:=longwork shift (-3);
i:=2;
for longwork:=longwork shift (-1) while longwork extract 1=0 do
i:=i+1;
end;
write(out,i,<: (bit pattern: :>);
longwork:=record(2);
write(out,<< d>, longwork shift (-11) extract 1,
longwork shift (-10) extract 1,
longwork shift (-9) extract 1,
longwork shift (-8) extract 1,
longwork shift (-7) extract 1,
longwork shift (-6) extract 1,
longwork shift (-5) extract 1,
longwork shift (-4) extract 1,
longwork shift (-3) extract 1,
longwork shift (-2) extract 1,
longwork shift (-1) extract 1,
longwork extract 1,<:):>);
end;
comment type=72 link ;
standard(<:link:>);
end case type...;
write(out, <:;:>);
end procedure printrec;
\f
<* bbj 9 9 76 initialization catupdate ...42... *>
comment initialize field-variables;
comment project record (type = 0);
proj := 4;
clower := 6;
cupper := 8;
comment user record (type = 2);
username1 := 6;
username2 := 10;
cstart := 12;
cwidth := 14;
cjobs := 16;
comment special bs-device record (type = 6);
kitname1 := 6;
kitname2 := 10;
comment userpool record(type = 34);
maxlower := 4;
maxupper := 6;
comment sorting fields in transactions;
if2 := 2; comment projectnumber of transaction, rectype of usercat;
lg6 := 6; comment username1 of transactions;
lg10 := 10; comment username2 of transactions;
if12 := 12; comment contains updateinf...;
basis := 14; comment recordtype and -length of transactions;
rec := basis-if2;
comment interval-list;
intervaltable_size := intervaltable_size * 6;
userstart := firstfree := 2;
upper := 2;
lower := upper + 2;
warning := false;
comment std-variables;
maximum := (-1) shift (-1);
minimum := 1 shift 23 + 1;
nil := -1;
comment initialize update-tables;
for i := 0 step 2 until max_record_type do
begin
change(i//2) := false add
(if i=0 then (1 + 1 shift 4 + 1 shift 5) else
if i=2 then 1 else
if i=6 then (1 + 1 shift 5 + 1 shift 6) else
if i=34 then (1 + 1 shift 3 + 1 shift 4) else
if i=44 then (1 + 1 shift 1 + 1 shift 2) else
if i=46 then (1 + 1 shift 1 ) else
if i=48 then (1 + 1 shift 5 ) else
0 );
comment this means, that in f.ex. the record of type 6,
updating is made by increasing the contents of
word 5 (i.e. 1 shift 5) and word 6 in the usercat-
record by the corresponding words in the trans-
action-record. ***** only bs claims *****
(the bit 1 shift 0 indicates whether the record is
to be updated or simply exchanged by a new record);
special_action(i//2) :=
if i=0 then 1 else
if i=2 then 2 else
if i=6 or i=48 then 3 else
if i=34 then 4 else
5 ;
end initialize update-tables;
\f
<* bbj 9 9 76 mix catalogs catupdate ...43... *>
if nooldcat then <* the parameter cat.yes is set *>
begin comment no old usercat present, simulate end-record;
oldcat.if2 := 0 shift 12 + 12; comment rectype of proj-record;
oldcat.proj := maximum; comment projno of end-record;
cproj := maximum;
cuser1 := cuser2 := ctype := 0;
firstsegm := std_usercat_index;
old := 0;
record_in_inbuf := true;
end
else
begin
open(oldcat, 4, <:usercat:>, 0);
firstsegm := 0;
for i:= inrec6(oldcat, 2), inrec6(oldcat, 2) while oldcat.if2 < 0 do
firstsegm := firstsegm + 1;
setposition(oldcat, 0, firstsegm);
cproj := -1;
nextold := 0;
inrec6(oldcat, 512);
record_in_inbuf := false;
end;
i := 1; open(trans, 4, string(transname(increase(i))), 0);
i := 1; open(vartrans, 4, string(vartransname(increase(i))), 0);
nextnew := 512;
if leftside then
begin
i := 1; open(newcat, 4, string(newcatname(increase(i))), 0);
setposition(newcat, 0, std_usercat_index);
end;
projlist := false; comment the interval-list of projs is not created yet;
firstproj := true;
firsttime := true;
ttype := 0 ; comment serves to initialize the trans-zones...;
\f
<* bbj 9 9 76 mix catalogs catupdate ...44... *>
next_trans: ; comment
*************** ;
comment select the next transaction from either the
trans-zone or the vartrans-zone. initialize the merging
variables;
if first_time or ttype=42 then
begin
first_time := false;
inrec6(vartrans, varlength);
comp(1,1) := vartrans.if2; comment project number;
comp(1,2) := vartrans.lg6; comment username...;
comp(1,3) := vartrans.lg10;
xinf(1) := vartrans.if12 extract 4; comment updateinf;
comp(1,4) := vartrans.basis shift (-12); comment recordtype;
end;
if ttype <> 42 then
begin
inrec6(trans, maxlength);
comp(2,1) := trans.if2; comment project number;
comp(2,2) := trans.lg6; comment username...;
comp(2,3) := trans.lg10;
xinf(2) := trans.if12 extract 4; comment updateinf;
comp(2,4) := trans.basis shift (-12); comment recordtype;
end;
i := 1; comment suppose vartrans wins...;
for level := 1 step 1 until 4 do
if comp(1,level) < comp(2,level) then goto winner else
if comp(1,level) > comp(2,level) then level := 5;
i := 2; comment vartrans lost the competition...;
winner: ; comment
******;
tproj := comp(i,1); comment project number;
tuser1:= comp(i,2); comment username...;
tuser2:= comp(i,3); comment .... ;
ttype := comp(i,4); comment recordtype;
absint:= xinf(i) extract 1 = 0;
delete:= xinf(i) shift (-1) = 0;
create:= xinf(i) shift (-1) = 1;
nodelete := true;
after_delete := false;
comment no deleting is in progress...;
comment iiff updatest then write(out, case i of (<:<10>var:>, <:<10>tr :>), tproj, ttype, xinf(i));
\f
<* bbj 9 9 76 mix catalogs catupdate ...45... *>
compare_start: ; comment
*************** ;
level := 1; comment start the comparison at project-level;
compare: ; comment
*************** ;
comment proceed the comparison at the current level...;
catno := case level of (cproj, cuser1, cuser2, ctype, ckit1, ckit2); <* current record-variables *>
transno := case level of (tproj, tuser1, tuser2, ttype,
trans.rec.kitname1, trans.rec.kitname2); <* record from trans or vartrans *>
copytype := case level of (2, 4, 4, 1000, 1000, 1000);
comment iiff updatest then write(out, <:<10>cat:>, level, catno, transno);
if catno < transno then
begin
comment the current record is completely updated.
copy the usercat, until a record with recordtype
less than ..copytype.. is met;
copy:
if nodelete and record_in_inbuf then output(oldcat, old);
if nextnew < 512 and print > 0 then
begin comment print the current record...;
if nodelete then
begin
printrec(newcat.new, cproj);
if print extract 1 = 1 then write(out, <: --- updated ---:>);
end
else
begin
printrec(oldcat.old, cproj);
write(out, <: --- deleted ---:>);
end;
write(out, <:<10>:>);
print := print shift (-1) shift 1;
comment remove the update-bit;
end;
for old := nextold while oldcat.old.if2 = 0 do
begin
nextold := 0;
inrec6(oldcat, 512);
end;
nextold := oldcat.old.if2 extract 12 + old;
comment step nextold up pointing at next record...;
ctype := oldcat.old.if2 shift (-12);
record_in_inbuf := true;
if ctype >= copytype then goto copy;
comment the present record is to be seperatly considered;
\f
<* bbj 9 9 76 mix catalogs catupdate ...46... *>
if ctype < (case level of ( 0, 2, 2, 4, 4, 4)) then
goto possibly_new_record;
comment this means, that the next project-record or
next user-record is met (i.e. a sort of
end-situation has come up...);
case level of
begin
level1: begin comment projectno was not ok, try this one;
cproj := oldcat.old.proj;
cuser1 := cuser2 := ctype := 0;
firstproj := false;
comment initialize interval-procedures...;
getposition(oldcat, 0, projsegm);
projrel := nextold;
firstfree := userstart;
projlower := oldcat.old.clower;
projupper := oldcat.old.cupper;
newproj := userlist := false;
end level1;
level2: begin comment project ok, user not ok, try this user;
cuser1 := oldcat.old.username1;
cuser2 := oldcat.old.username2;
lowerint := oldcat.old.cstart;
upperint := oldcat.old.cwidth * oldcat.old.cjobs + lowerint - 1;
end;
level3: begin comment second part of username not ok, try this user;
level := 2;
goto level2;
end;
level4: begin comment project and user ok, recordtype not ok.
try this record;
end;
level5: begin comment first part of kitname in record concerning
private kit is not ok, try this record;
level := 4;
end;
level6: begin comment second part of kitname not ok, try this record;
level := 4;
end;
end level_case;
goto compare; comment i.e. test with the current level...;
end catno<transno;
if catno = transno then
begin
comment proceed the comparison in all levels...;
level := level + 1;
if level <= 4 then goto compare;
comment at this point projectnumber, username and recordtype is ok;
\f
<* bbj 9 9 76 mix catalogs catupdate ...47... *>
case special_action(ctype//2) of
begin
acti1: begin comment ctype = 0... project-record;
if cproj = maximum then
begin
output(oldcat, old); comment end-record...;
goto finisupdate;
end;
goto testcreate;
end;
acti2: begin comment ctype = 2... user-record;
testcreate: if create then update_alarm(<:existing:>);
if delete then
begin
if cuser1 = 0 then
begin comment delete project until next proj-record;
comment check proper interval...;
if trans.rec.clower <> projlower or
trans.rec.cupper <> projupper then
update_alarm(<:delete wrong interval:>);
tproj := tproj + 1; comment to skip rest of project;
end
else
begin comment delete user...;
comment check proper interval...;
if lowerint <> trans.rec.cstart or
upperint <> trans.rec.cwidth * trans.rec.cjobs
+ lowerint - 1 then
update_alarm(<:delete wrong interval:>);
tuser2 := tuser2 + 1; comment to skip rest of user...;
end;
comment the project (or user) is not removed from the internal list;
start_delete:
after_delete := true; comment i.e. remember the forgery...;
nodelete := false; comment i.e. skip rest of proj or user;
delete := false;
print := print shift (-1) shift 1 add 1;
goto compare_start;
end delete-action;
if after_delete then
stop_delete:
begin comment forget about the simulated transaction...;
nodelete := true;
ttype := ttype - 1; comment in case of deleting username-record...;
goto next_trans;
end;
end action 2, delete user or project;
\f
<* bbj 9 9 76 mix catalogs catupdate ...48... *>
acti3: begin comment special bs-devices, ctype = 6 or ctype = 48;
comment proceed the comparison to check the devicename...;
if record_in_inbuf then
begin
ckit1 := oldcat.old.kitname1;
ckit2 := oldcat.old.kitname2;
end
else
begin
ckit1 := newcat.new.kitname1;
ckit2 := newcat.new.kitname2;
end;
if level < 7 then goto compare;
if delete then
begin
trans.rec.kitname2 := trans.rec.kitname2 + 1;
goto start_delete;
end;
end action 3;
acti4: begin comment ctype = 34, userpool record;
if delete then update_alarm(<:delete not allowed:>);
end;
acti5: begin comment other records, no action to be done...;
if delete then
begin comment skip record...;
ttype := ttype + 1;
goto start_delete;
end;
end;
end special_action_case;
comment at this point the proper record is found
update it...;
\f
<* bbj 9 9 76 mix catalogs catupdate ...49... *>
bool := change(ctype//2);
if bool then
begin comment the variable bool contains information about
which elements in the record to update;
if record_in_inbuf then output(oldcat, old);
for i := -1 step -1 until -11 do
if bool shift i then
begin
j:=newcat.new(1-i) + trans.rec(1-i);
if j<0 or j shift 12 < 0 then
begin comment claims would get negative;
warning:=true;
update_alarm(<:illegal claims:>);
end
else newcat.new(1-i):=j;
end;
end
else
begin comment forget about the old version of the record...;
if -, record_in_inbuf then nextnew := new;
new_record:
if ttype = 42 then output(vartrans, rec)
else output(trans , rec);
end;
ctype := ttype;
record_in_inbuf := false;
print := print shift (-1) shift 1 add 1;
comment indicate the updating;
goto next_trans;
end catno = transno;
\f
<* bbj 9 9 76 mix catalogs catupdate ...50... *>
comment catno > transno;
possibly_new_record:
nextold := old; comment regret input, i.e. repeat next time...;
record_in_inbuf := false;
if afterdelete then goto stop_delete;
case special_action(ttype//2) of
begin
act1: begin comment ttype = 0, new project;
if -, create then update_alarm(<:project unknown:>);
firstfree := userstart;
if -, projlist then
initialize(projstart, true, minimum+2, maximum-2);
projlist := true;
userlist := false; newproj := true;
comment the intervals of the project must be inserted in
the interval-list (except the maintenance-proj and
the account-project);
if trans.rec.clower <> minimum then
get_interval(projstart, trans.rec.clower, trans.rec.cupper);
userstart := firstfree;
projlower := trans.rec.clower;
projupper := trans.rec.cupper;
cproj := tproj;
cuser1 := cuser2 := ctype := 0;
end action 1;
act2: begin comment ttype = 2, new user;
if level = 1 then
update_alarm(<:project unknown:>);
if -, create then update_alarm(<:user unknown:>);
if -, userlist then
initialize(userstart, false, projlower, projupper);
userlist := true;
comment the intervals of the user must be inserted in the
interval list;
lowerint:= trans.rec.cstart;
upperint := trans.rec.cwidth * trans.rec.cjobs
+ lowerint - 1;
get_interval(userstart, lowerint, upperint);
trans.rec.cstart := lowerint;
cuser1 := tuser1;
cuser2 := tuser2;
end action 2;
act3: begin comment special bs-devices, ttype = 6;
goto act5;
end;
act4: begin comment userpool record, ttype = 34;
if level < 4 then goto act5;
trans.rec.maxlower:= lowerint;
trans.rec.maxupper:= upperint;
end;
act5: begin comment other records;
if level < 4 then update_alarm(<:out of sequence:>);
end;
end special-action_case with new record...;
if delete then updatealarm(<:record unknown:>);
bool:=change(ttype//2);
if bool then
for i:=-1 step -1 until -11 do
if bool shift i then
begin
if trans.rec(1-i)<0 or trans.rec(1-i) shift 12 < 0 then
update_alarm(<:illegal claims:>);
end;
goto new_record;
finis_update: ; comment
****************;
if print shift(-3) extract 1=1 then
write(out,<:-1 ; end of catalog<10>:>);
close(vartrans, true); monitor(48) remove entry:(vartrans, 0, xinf);
close(trans, true); monitor(48) remove entry:(trans, 0, xinf);
close(oldcat, true);
close(newcat, false);
end update_block;
end device-number block;
\f
<* bbj 9 9 76 index segment catupdate ...51... *>
if leftside then
begin comment update the index segments...;
zone index(128, 1, stderror),
newcat(128, 1, stderror);
integer array entr, slicelength(1:max_no_of_disckits), tail(1:10);
long array kittable(2:2*max_no_of_disckits+1);
integer array field new;
integer field if2, proj, slicelgth, disc_entr, priv_entr, userdisc_entr, drum_entr;
long field kit1, kit2, user1, user2;
integer i, j, projno, type, entries, max, maxindex, no_of_disckits, kitcount;
long name1, name2;
procedure warn(text);
string text;
begin
integer i;
write(out, <:projno= :>, <<dddddd>, projno, <: user= :>);
i := 1;
write(out, false add 32,
13 - write(out, string (case increase(i) of (name1, name2))),
text, <:<10>:>);
end;
i := 1; open(index , 4, string newcatname(increase(i)), 0);
i := 1; open(newcat, 4, string newcatname(increase(i)), 0);
setposition(newcat, 0, std_usercat_index);
if2 := 2;
proj := 4;
disc_entr := 12;
priv_entr := 14;
userdisc_entr := 10;
drum_entr := 6;
kit1 := 6;
kit2 := 10;
slicelgth:= 16;
user1 := 6;
user2 := 10;
projno := -1;
for i := 1 step 1 until std_usercat_index do
begin
outrec6(index, 2);
index.if2 := projno;
end;
comment scan the new usercat and count the maximum-number
of pre-promissed entries;
entries := 0;
no_of_disckits := 0;
next_block:
inrec6(newcat, 512);
index.if2 := projno;
new := 0;
outrec6(index, 2);
\f
<* bbj 9 9 76 count entries catupdate ...52... *>
next_record:
type := newcat.new.if2 shift (-12);
if type < 2 then
begin comment project-record or end-of-segment;
if newcat.new.if2 = 0 then goto next_block;
projno := newcat.new.proj;
if projno = (-1) shift (-1) then goto finished;
entries := newcat.new.disc_entr shift (-12) + entries;
kitcount := 0;
name1 := name2 := long <::>;
end
else
if type < 4 then
begin comment user-record;
kitcount := 0;
name1 := newcat.new.user1;
name2 := newcat.new.user2;
end
else
if type = 6 then
begin comment private disckit, search kitname in kittable;
for i := 2 step 2 until no_of_disckits do
if if newcat.new.kit1 <> kittable(i) then false
else newcat.new.kit2 = kittable(i+1) then goto found;
comment kitname was not in kittable, include it now...;
if i > 2* max_no_of_disckits then
begin
warn(<::>);
system(9, i//2, <:<10>disckits:>);
end;
no_of_disckits := i;
kittable(i) := newcat.new.kit1;
kittable(i+1) := newcat.new.kit2;
slicelength(i//2) := newcat.new.slicelgth;
entr(i//2) := 0;
found:
kitcount := kitcount + 1;
if kitcount = no_of_privkits + 1 then
warn(<:too many privkits:>);
entr(i//2) := entr(i//2) + newcat.new.priv_entr shift (-12);
if slicelength(i//2) <> newcat.new.slicelgth then
warn(<:different slice-length on same kit:>);
slicelength(i//2) := newcat.new.slicelgth;
end type=6
else
if type = 34 then
begin comment userpool-record;
entries := newcat.new.userdisc_entr shift (-12) + entries;
end
else
if type = 44 then
begin comment permanent drum-record;
entries := newcat.new.drum_entr shift (-12) + entries;
end;
new := newcat.new.if2 extract 12 + new;
goto next_record;
\f
<* bbj 9 9 76 private kits catupdate ...53... *>
finished:
getposition(index, 0, new);
if new >= std_usercat_index then
write(out, <:<10>***std_usercat_index too small***<10>:>);
index.if2 := projno;
for i := 1 step 1 until no_of_priv_discdrives do
begin
max := 0;
maxindex := 1;
for j := no_of_disckits//2 step -1 until 1 do
if entr(j) > max then
begin
max := entr(j);
maxindex := j;
end;
entries := entries + max;
entr(maxindex) := 0; comment i.e. clear in the kittable...;
end;
setposition(index, 0, 0);
swoprec6(index, 2);
index.if2 := - entries;
<* cut length of newcat to segments actually used,
and set shortclock in tail *>
monitor(42 <* lookup entry *>, newcat, 0, tail);
getposition(newcat, 0, i);
tail(1):= i + 1; <* segments used *>
tail(6):= systime(7, 0, 0.0); <* shortclock *>
monitor(44 <* change entry *>, newcat, 0, tail);
close(index, true);
close(newcat,true);
end index-update block;
end
▶EOF◀