|
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: 328704 (0x50400)
Types: TextFile
Names: »load52tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »load52tx «
begin
\f
<* sw8010/2, load pageheads page ... 1...
1985.02.21 *>
\f
<* sw8010/2, load declarations first level page ... 3...
1984.04.30 *>
message decl first level page 1;
boolean repeat_param ;
integer item_count ,
zone_level ,
max_no_of_vol ,
no_of_discs ;
integer array discs (1:4),
fp_table (0:127);
real array outfile ,
progname ,
chainname (1:2);
\f
<* sw8010/2, load parameter scanning page ... 4...
1981.11.13 *>
message prepare_paramscan page 1;
procedure prepare_param_scan (item_no);
value item_no ;
integer item_no ;
<***********************************************************>
<* *>
<* The procedure prepares a sequential scan of the fp pa- *>
<* rameters in the fp command stack and command files re- *>
<* ferenced in the parameter list by a parameter : *>
<* in.<name> *>
<* The scan is supposed to be carried out by the procedu- *>
<* re scan_param. *>
<* The scan is prepared to start in the fp item number *>
<* item_no. *>
<* The scan is implemented by means of the global variab- *>
<* les : *>
<* zone_level, item_count and repeat_param *>
<* where zone_level is the zone stack level and item_count *>
<* is the number of the item in the fp command stack to be *>
<* taken next. *>
<* A stack zone level of zero means no current input zone *>
<* has been stacked, i. e. the next item should be taken *>
<* in the fp commend stack, a zone stack level of n means *>
<* that current input zone has been stacked n times as a *>
<* result of a in.<name> parameter. *>
<* If level > 0, item_count is the item in the fp command *>
<* stack following the in.<name> parameter causing the *>
<* first zone stack level. *>
<* *>
<* Call: prepare_param_scan (item_no); *>
<* *>
<* item_no (call value, integer). The item number in the *>
<* fp command stack where the parameter scan car- *>
<* ried out by scan_param or repeat_param will be *>
<* started. *>
<* *>
<* Function : *>
<* Current input zone is unsatacked until zone_level eq- *>
<* uals one, item_no is assigned to the global item_count *>
<* and the global boolean repeat_param is set false. *>
<* *>
<***********************************************************>
begin
while zone_level > 0 do
unstack_current_input (zone_level);
item_count := item_no;
repeat_param := false;
end prepare_param_scan;
\f
<* sw8010/2, load parameter scanning page ... 5...
1981.11.13 *>
message scan param page 1;
integer
procedure scan_param ( item );
real array item ;
<***********************************************************>
<* *>
<* The procedure either returns the parameter which was la-*>
<* test returned or it returns the next parameter governed *>
<* by the global boolean repeat_param. *>
<* The parameter is coded as an item as for system (4,..) *>
<* and is taken either from fp command stack or from cur- *>
<* rent input zone. *>
<* *>
<* Call: scan_param ( item ); *>
<* *>
<* scan_param (return value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (return value, array). An item is returned *>
<* in item (1:2) as for system (4, ...). *>
<* *>
<* Function : *>
<* If repeat_param is false, the procedure calls next_item *>
<* and at the same time it stores the item in own variab- *>
<* les. *>
<* If repeat_param is true, the procedure returns the item *>
<* stored in the own variables and switches repeat_param *>
<* back to false. *>
<* *>
<***********************************************************>
begin
own
integer old_seplength;
own
real old_param1, old_param2;
if repeat_param then
begin <*the item is repeated*>
scan_param := old_seplength;
item (1) := old_param1 ;
item (2) := old_param2 ;
repeat_param := false;
end else
begin <*take next item*>
old_seplength := next_item (item);
old_param1 := item (1) ;
old_param2 := item (2) ;
scan_param := old_seplength ;
end;
end scan_param;
\f
<* sw8010/2, load parameter scanning page ... 6...
1982.12.21 *>
message next item page 1;
integer
procedure next_item (item);
real array item ;
<***********************************************************>
<* *>
<* The procedure returns the next item, either from the fp *>
<* command stack or from current input zone. The item is *>
<* coded as for system (4, ...). *>
<* *>
<* Call : next_item (item); *>
<* *>
<* next_item (return value, integer). Separator shift 12 *>
<* + length as for system (4, ...). *>
<* item (return value, array). An item is returned *>
<* in item (1:2) as for system (4, ...). *>
<* in item (1:2) as for system (4, ...). *>
<* *>
<* Function : *>
<* If the item taken, either from fp command stack by sys- *>
<* tem (4, ...) or from current input zone by system_four, *>
<* is <s>in.<name>, the current input zone is stacked and *>
<* curr input zone is connected to the file named <name>. *>
<* The level count in zone_level is increased by one and *>
<* the next item is taken from current input zone. *>
<* If the item taken is not <s>in, it is returned and if *>
<* it came from fp command stack, the item counter in the *>
<* global item_count is increased by one. *>
<* If the item is <s>in, but the name is neither 'scope' *>
<* nor 'docname', the parameter <s>in is returned and the *>
<* next parameter is saved in owns for later delivery. *>
<* *>
<***********************************************************>
\f
<* sw8010/2, load parameter scanning page ... 7...
1981.11.13 *>
message next item page 2;
begin
own
integer own_seplength;
own
real own_item_1, own_item_2;
own
boolean own_repeat;
integer seplength, old_seplength,
space_txt, point_txt, result;
real array old_item (1:2);
space_txt := 4 shift 12 + 10;
point_txt := 8 shift 12 + 10;
if own_repeat then
begin <*deliver owns*>
next_item := own_seplength;
item (1) := own_item_1 ;
item (2) := own_item_2 ;
own_repeat:= false ;
end <*deliver owns*> else
begin <*read new*>
seplength := if zone_level = 0 then
system (4, increase (item_count), item) else
systemfour ( item) ;
if item (1) <> real <:in:>
or seplength <> space_txt then
next_item := sep_length <*item ready*>
else
begin <* <s>in *>
old_seplength := seplength;
old_item (1) := item (1) ;
old_item (2) := item (2) ;
seplength := if zone_level = 0 then
system (4, increase (item_count), item) else
system_four ( item) ;
if seplength = seplength and
( item (1) = real <:scope:>
or item (1) = real <:docna:> add 'm' and
item (2) = real <:e:> )
or seplength <> point_txt then
begin <* <s>in not followed by .<filename>, store new, del. old*>
own_seplength := seplength ;
own_item_1 := item (1) ;
own_item_2 := item (2) ;
next_item := old_seplength;
item (1) := old_item (1) ;
item (2) := old_item (2) ;
own_repeat := true ;
<*end*> <* <s>in not followed by .<filename> *> <*else*>
\f
<* sw8010/2, load parameter scanning page ... 8...
1982.12.21 *>
message next item page 3;
end <* <s>in not followed by .<filename> *> else
begin <* <s>in followed by .<filename>, connect and read new *>
result := stack_current_input (zonelevel, item);
if result <> 0 then
begin <*connect not ok*>
write_alarm (out, <:warning infile param connect impossible:>);
write (out, <: in:>);
write_param (out, seplength, item);
write (out, <: :>, case result of (
<:no resources:>, <:malfunction:>, <:not user, non exist:>,
<:convention error:>, <:not allowed:>, <:name format error:>));
errorbits := 2; <*warning.yes, ok.yes*>
end <*connect not ok*>;
next_item := next_item (item);
end <* <s>in followed by .<filename> *>;
end <* <s>in *>;
end <*read new*>;
end next_item;
\f
<* sw8010/2, load parameter scanning page ... 9...
1982.12.21 *>
message param alarm page 1;
procedure param_alarm (z, text);
zone z ;
string text ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the text : *>
<* <10>***_<prog name>__:> *>
<* followed by a text and the entire parameter list, star- *>
<* ting with current parameter and emptying the parameter *>
<* list, ending up in fp command stack with current input *>
<* zone completely unstacked. *>
<* After emptying the parameter list, the fp mode bits are *>
<* set : warning.yes ok.no. *>
<* *>
<* Call : param_error (z, text); *>
<* *>
<* z (call and return value, zone). The name of the *>
<* document. Determines further the document, the *>
<* buffering and the position of the document. *>
<* text (call value, string). The text to be written. *>
<* *>
<***********************************************************>
begin
integer start_pos;
start_pos :=
write_alarm (z, text);
write_param_list (z, start_pos, 80);
errorbits := 3; <*warning.yes, alarm.yes*>
end param_alarm;
\f
<* sw8010/2, load parameter scanning page ... 10...
1981.11.13*>
message param warning page 1;
procedure param_warning (z, text);
zone z ;
string text ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the text : *>
<* <:<10>*** <prog name> :> *>
<* followed by the text given in text and the current pa- *>
<* rameter. *>
<* At return, the fp mode bits are : warning.yes, ok.yes *>
<* *>
<* Call : param_warning (z, text); *>
<* *>
<* z (call and return value, zone).The name of the *>
<* document. Determines further the document, the *>
<* buffering and the position of the document. *>
<* text (call value, string). The text to be written. *>
<* *>
<***********************************************************>
begin
integer seplength;
real array item (1:2);
repeat_param := true; <*repeat current parameter*>
seplength := scan_param (item);
write_alarm (z, text);
write_param (z, seplength, item);
errorbits := 2; <*warning.yes, alarm.no*>
end param_warning;
\f
<* sw8010/2, load parameter scanning page ... 11...
1982.12.28 *>
message write alarm page 1;
integer
procedure write_alarm (z, text);
zone z ;
string text ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the text : *>
<* <:<10>_<program name>__<text>__ *>
<* and returns the number of characters written. *>
<* *>
<* call : write_alarm (z, text); *>
<* *>
<* write_alarm (return value, integer). The number of *>
<* characters written. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* text (call value, string). The text to be *>
<* written after the program name. *>
<* *>
<**********************************************************>
begin
long array field laf;
laf := 0;
outchar (out, 'nl');
write_alarm :=
write (z, <:*** :>, prog_name.laf, <: :>, text, <: :>);
end write_alarm;
\f
<* sw8010/2, load parameter scanning page ... 12...
1982.12.21 *>
message write param list page 1;
procedure write_param_list (z, start_pos, positions);
value start_pos, positions ;
zone z ;
integer start_pos, positions ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the entire parameter *>
<* list, starting with the parameter last obtained by a *>
<* call of scan_param and emptying the parameter list, en- *>
<* ding up in fp command stack with current input zone *>
<* completely unstacked. *>
<* *>
<* Call : write_param_list (z, start_pos, positions); *>
<* *>
<* z (call and return value, zone). The name of *>
<* the document. Determines further the docu- *>
<* ment, the buffering and the position of the *>
<* document. *>
<* start_pos (call value, integer). The procedure supposes *>
<* that start_pos characters have been written *>
<* on the zone z since the last 'nl' character. *>
<* If an item extends over the positions charac- *>
<* ters, the next item of the form <s>name will *>
<* be preceeded by a comma, a new line and *>
<* start_pos spaces. *>
<* positions (call value, integer). See above. *>
<* *>
<***********************************************************>
begin
integer seplength, spaceint, spacetxt, chars;
real array item (1:2);
space_int := 4 shift 12 + 4;
space_txt := 4 shift 12 + 10;
chars := start_pos ;
repeat_param := true; <*repeat current parameter*>
for seplength := scan_param (item) while seplength <> 0 do
chars :=
(if chars > positions then
write (z, ",", 1, "nl", 1,"sp", start_pos)
else
chars) +
write_param (z, seplength, item);
write (z, <:<10>:>);
end write_param_list;
\f
<* sw8011/1, save parameter scanning page ... 14...
1984.04.25 *>
message skip param list page 1;
procedure skip_param_list;
<***********************************************************>
<* *>
<* The procedure skips the entire parameter *>
<* list, starting with the parameter last obtained by a *>
<* call of scan_param and emptying the parameter list, en- *>
<* ding up in fp command stack with current input zone *>
<* completely unstacked. *>
<* *>
<* Call : skip_param_list; *>
<* *>
<* *>
<***********************************************************>
begin
integer seplength;
real array item (1:2);
for seplength := scan_param (item) while seplength <> 0 do;
end skip_param_list;
\f
<* sw8011/1, save parameter scanning page ... 14...
1981.11.13 *>
message write param page 1;
integer
procedure write_param (z, seplength, item);
value seplength ;
zone z ;
integer seplength ;
real array item ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the parameter coded *>
<* as an item as for system (4, ...), and returns the num- *>
<* ber of characters written. *>
<* *>
<* Call : write_param (z, seplength, item); *>
<* *>
<* write_param (return parameter, integer). The number *>
<* of characters written. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* seplength (call value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (call value, array). An item in item(1:2) *>
<* as for system (4, ...). *>
<* *>
<***********************************************************>
begin
integer separator, length, chars;
long array field laf;
laf := 0; <*fields array to long array*>
separator := seplength shift (-12) extract 12; <*2, 4, 6, or 8*>
length := seplength extract 12; <*4 or 10 *>
write_param :=
if seplength = 0 then
write (z, "nl", 1)
else
write (z, case (separator//2+1) of ("(", "nul", "sp", "=", "."), 1) +
(if length = 4 then
write (z, <<d>, round (item(1)))
else
if length = 10 then
write (z, item.laf)
else
0);
end write_param;
\f
<* sw8010/2, load parameter scanning page ... 14..
1981.11.13 *>
message write char page 1;
integer
procedure write_char (z, char);
value char ;
zone z ;
integer char ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the character with *>
<* the iso-value char as a graphical and returns the num- *>
<* ber of characters written. *>
<* *>
<* Call : write_char (z, char); *>
<* *>
<* write_char (return value, integer). The number of *>
<* characters written. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* char (call value, integer).The character with *>
<* iso-value char is written as a graphical. *>
<* *>
<***********************************************************>
begin
write_char := if char <= 'sp' then
write (z, <<d>, "<", 1, char, ">", 1) else
write (z, false add char, 1 ) ;
end write_char;
\f
<* sw8010/2, load parameter scanning page ... 15...
1981.11.13*>
message system four page 1;
integer
procedure system_four (item);
array item ;
<***********************************************************>
<* *>
<* The procedure reads from current input zone an item in *>
<* the sense defined by system (4, ...) and returns it. *>
<* *>
<* Call : system_four (item); *>
<* *>
<* system_four (return value, integer). Separator <12 + *>
<* length as for system (4, ...). *>
<* item return value, array). An item is retur- *>
<* ned in item (1:2) as for system (4, ..). *>
<* *>
<* Function : *>
<* The procedure reads, character by character, from cur- *>
<* rent input zone using the special fp input table defi- *>
<* ned by : *>
<* - small letters , class = 6, in name *>
<* - digits , -"- = 2, in number *>
<* - = (equal) , -"- 7, separator *>
<* - sp (space) , -"- 5, -"- *>
<* - . (point) , -"- 4, -"- *>
<* - , (comma) , -"- 3, -"- *>
<* - ; (semicolon) , -"- 3, -"- *>
<* - * (asterisk) , -"- 3, -"- *>
<* - nl (new line) , -"- 5, -"- *>
<* - ff (form feed) , -"- 5, -"- *>
<* - em (end medium), -"- 8, terminator *>
<* - bs (back space), -"- 9, illegal *>
<* - cr (carret) , -"- 9, -"- *>
<* - other graphics , -"- 9, -"- *>
<* - capitals , -"- 9, -"- *>
<* - all others , -"- 0, blind *>
<* This alphabet differs from the specila fp input alpha- *>
<* bet for characters ';', '*', 'nl' and 'ff', the effect *>
<* being that 'nl' is equivalent to 'sp'. *>
<* *>
<* From the character read, an item is build up using the *>
<* following state/action table : *>
\f
<* sw8010/2, load parameter scanning page ... 16...
1981.11.13 *>
message system four page 2;
<* State/action table : *>
<* *>
<* ________________________________________________ *>
<* character : !il-! ! ; ! ! nl! ! ! ! *>
<* !le-!di-! , ! . ! ff!let! = !em ! *>
<* !gal!git! * ! ! sp!ter! ! ! *>
<* ! ! ! ! ! ! ! ! ! *>
<* ! ! ! ! ! ! ! ! ! *>
<* states : ! 9 ! 2 ! 3 ! 4 ! 5 ! 6 ! 7 ! 8 ! *>
<* _______________!___!___!___!___!___!___!___!___! *>
<* ! ! ! ! ! ! ! ! ! *>
<* 1 not used ! ! ! ! ! ! ! ! ! *>
<* 2 after equal !7/l!6/i!2/g!7/l!2/f!5/h!7/l!7/l! *>
<* 3 after space !7/l!6/i!3/g!4/c!3/f!5/h!2/a!3/e! *>
<* 4 after point !7/l!6/i!4/g!7/l!4/f!5/h!7/l!7/l! *>
<* 5 in text !7/l!5/h!8/j!8/j!8/j!5/h!8/j!8/j! *>
<* 6 in number !7/l!6/i!8/k!8/k!8/k!7/l!8/k!8/k! *>
<* 7 after illegal!7/l!7/l!3/m!7/l!3/m!7/l!3/m!3/m! *>
<* 8 after item ! ! ! ! ! ! ! ! ! *>
<* ________________________________________________ *>
<* *>
<* Actions : *>
<* *>
<* a : separator := equal; *>
<* b : -"- := space; *>
<* c : -"- := point; *>
<* e : unstack current input; *>
<* f : empty; *>
<* g : skip until nl or em *>
<* h : pack char; *>
<* i : pack digit; *>
<* j : finish name; repeatchar; *>
<* k : finish number; repeatchar; *>
<* l : syntax error; *>
<* m : finish syntax error (empty curr input stack chain)*>
\f
<* sw8010/2, load parameter scanning page ... 17...
1982.12.21 *>
message system four page 3;
<* The possible separators to be met in current input zone *>
<* are : *>
<* *>
<* 4 : space *>
<* 6 : equal *>
<* 8 : point *>
<* *>
<* and the possible lengths are : *>
<* *>
<* 4 : integer *>
<* 10 : name *>
<* *>
<* When one of class 3 is met, the characters up to *>
<* but not including nl or em are skipped . *>
<* When one of class 8 is met, the procedure per- *>
<* forms an unstack current input zone and reads again. If *>
<* however, the current input zone is unstacked to level 0 *>
<* the item is taken from fp command stack by a call of *>
<* system (4, ...), in which case any item returned by *>
<* system (4, ...) may be returned by system_four. *>
<* If class 9 character is met, the character and the *>
<* following characters up to a following space, comma, = *>
<* any any terminator, are listed on current output zone *>
<* as syntax errors. *>
<* The same goes for a character creating a syntax error : *>
<* ==, .=, .., =., =<terminator>, .<terminator> and letter *>
<* in number. *>
<* When the last character has been listed, current input *>
<* stack chain is emptied and listed on current output and *>
<* the next item is taken from fp command stack. *>
<* *>
<***********************************************************>
begin
integer class , char , separator , length,
fp_item , space , equal ,
point , int , txt , number,
digits , chars , after_equal, after_space,
after_point, in_txt , in_number , after_illegal,
after_item , state ;
integer array digit (1:8), zdescr (1:20);
long array name (1:2) ;
own
boolean fp_table_initialized;
\f
<* sw8010/2, load parameter scanning page ... 18...
1981.11.13 *>
message system four page 4;
procedure pack_char (state, name, chars, char);
value char ;
long array name ;
integer state, chars, char ;
<*********************************************************>
<* *>
<* The procedure packs a given character into the tail *>
<* of a given long array where a given number of charac- *>
<* ters allready are packed, and returns the increased *>
<* number of characters. *>
<* If allready eleven characters are packed, the proce- *>
<* dure gives a syntax alarm, listing the characters *>
<* packed and returns the state 'after illegal'. *>
<* *>
<* Call : pack_char (state, name, chars, char); *>
<* *>
<* state (call and return value, integer). If all- *>
<* ready eleven characters are packed, the *>
<* state 'after illegal' is returned, else un- *>
<* changed. *>
<* name (call and return value, long array). The *>
<* character with the iso-value char is packed *>
<* in the tail of the long array name (1:2), *>
<* where allready chars characters are packed. *>
<* If allready eleven characters are packed, a *>
<* null character is packed after the last one.*>
<* chars (call and return value, integer). Num- *>
<* ber of characters allready packed, at re- *>
<* turn increased by one, unless allready ele- *>
<* ven characters are packed, in which case *>
<* chars = 11 is returned. *>
<* char (call value, integer). The character with *>
<* the iso-value char is packed after the last *>
<* one packed in the tail of name (1) or *>
<* name (2), depending on the number of charac-*>
<* ters allready packed. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load parameter scanning page ... 19...
1981.11.13 *>
message system four page 5;
begin
integer i, index, char_no, pos;
if chars = 0 then name (2) := 0; <*zerofill second element*>
chars := chars + 1;
index := (chars - 1)//6 + 1;
name (index) := name (index) shift 8 add char;
if chars = 12 then
begin <*name overflow*>
for i := 1 step 1 until 12 do
begin
index := (i-1) // 6 + 1;
char_no := (i-1) mod 6 + 1;
pos := (char_no-6) * 8;
syntax (state, name (index) shift pos extract 8);
state := after_illegal;
end;
end;
end pack_char;
\f
<* sw8010/2, load parameter scanning page ... 20...
1981.11.13 *>
message system four page 6;
procedure finish_name (name, chars);
value chars ;
long array name ;
integer chars ;
<*********************************************************>
<* *>
<* The procedure finishes the name in name (1:2) where *>
<* chars caracters are packed by pack_char. *>
<* *>
<* Call : finish_name (name, chars); *>
<* *>
<* name (call and return value, long array). A num- *>
<* ber of characters are packed in name (1) and *>
<* maybe name (2). The element in which the *>
<* last character is packed is shifted the pro- *>
<* per number of positions to the left. *>
<* chars (call value, integer). The number of charac- *>
<* ters packed in name. *>
<* *>
<*********************************************************>
begin
integer index, char_no, pos;
index := (chars-1) // 6 + 1;
char_no := (chars-1) mod 6 + 1;
pos := (6-char_no) * 8 ;
name (index) := name (index) shift pos;
end finish_name;
\f
<* sw8010/2, load parameter scanning page ... 21...
1981.11.13 *>
message system four page 7;
procedure pack_digit (state, number, digits, char);
value char ;
integer array number ;
integer state, digits, char ;
<*********************************************************>
<* *>
<* The procedure packs a digit given as an iso-character *>
<* into a given integer arrayu where a given number of *>
<* digits allready are packed, and returns the increased *>
<* number of digits. *>
<* If allready six digits are packed or the number com- *>
<* posed of the digits allready packed and the given di- *>
<* git will exceed the positive integer range, the pro- *>
<* cedure gives a syntax alarm, listing the characters *>
<* packed and returns the state 'after illegal'. *>
<* *>
<* Call : pack_digit (state, number, digits, char); *>
<* *>
<* state (call and return value, integer). If an il- *>
<* legal number will be the result, the state *>
<* 'after illegal' is returned, else unchanged. *>
<* number (call and return value, integer arry). The *>
<* character will be packed as a digit in num- *>
<* ber (chars + 1). *>
<* digits (call and return value, integer). The number *>
<* of digits allready packed, at return invrea- *>
<* sed by one. *>
<* char (call value, integer). The character with *>
<* the iso value char is packed as a digit. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load parameter scanning page ... 22...
1981.11.13 *>
message system four page 8;
begin
integer i, n, digit;
n := 0;
digit := char - 48;
for i := 1 step 1 until digits do n := n * 10 + number (i);
if digits = 7
or (digit > 7 and n >= 638860 ) then
begin <* overflow in number or integer exception at finish*>
for i := 1 step 1 until digits do
begin
syntax (state, 48 + number (i) );
state := after_illegal;
end;
syntax (state, char);
end else
begin <* ok *>
digits := digits + 1;
number (digits) := digit;
end;
end pack_digit;
\f
<* sw8010/2, load parameter scanning page ... 23...
1981.11.13 *>
message system four page 9;
integer
procedure finish_number (digit, digits);
value digits ;
integer array digit ;
integer digits ;
<*********************************************************>
<* *>
<* The procedure finishes the number packed as digits in *>
<* digit (1:digits) by pack_digit, and returns the re- *>
<* sulting integer. *>
<* *>
<* Call : finish_number (digit, digits); *>
<* *>
<* finish_number (return value, integer). The number *>
<* packed as digits in digit (1:digits). *>
<* digit (call value, integer array). See abo- *>
<* ve. *>
<* digits (call value, integer). See above. *>
<* *>
<*********************************************************>
begin
integer n, i;
n := 0;
for i := 1 step 1 until digits do n := n * 10 + digit (i);
finish_number := n;
end finish_number;
\f
<* sw8010/2, load parameter scanning page ... 24...
1981.11.13 *>
message system four page 10;
procedure syntax ( state, char);
value state, char ;
integer state, char ;
<*********************************************************>
<* *>
<* The procedure writes on current output zone an alarm *>
<* by means of the procedure write_alarm, provided the *>
<* value of state <> 7 (after illegal). In any case, the *>
<* character with the iso-value char is written by means *>
<* of the procedure write_char. *>
<* *>
<* Call : syntax (state, char); *>
<* *>
<* state (call value, integer). If state<> 7 (after *>
<* illegal) a syntax alarm is written first. *>
<* char (call value, integer). In any case the cha- *>
<* racter with the iso-value char is written by *>
<* means of the procedure write_char. *>
<* *>
<*********************************************************>
begin
if state <> 7 <*after illegal*> then
write_alarm (out, <:syntax:>);
write_char (out, char);
end procedure syntax;
\f
<* sw8010/2, load parameter scanning page ... 25...
1981.11.13 *>
message system four page 11;
procedure finish_syntax;
<*********************************************************>
<* *>
<* The procedure finishes the syntax alarm given by the *>
<* procedure syntax by writing the current input stack *>
<* zone chain on current output while unstacking until *>
<* zone level zero. *>
<* Before return the fp mode bits are set : *>
<* warning.yes, ok.no *>
<* *>
<*********************************************************>
begin
integer field kind;
long array parent_name (1:2);
long array field name;
kind := name := 2; <*fields the process name and mode kind*>
system (8, 0, parent_name);
getzone6 (in, zdescr );
write (out, <:<10> *read from :>);
if zdescr.kind extract 12 = 8 <*tw*>
or zdescr.kind extract 12 = 0 <*ip*> and
zdescr.name (1) = parent_name (1) and
zdescr.name (2) = parent_name (2) then
write (out, <:primary input:>)
else
write (out, zdescr.name );
while zone_level > 0 do
begin <*empty current input zone stack chain*>
unstack_current_input (zone_level);
getzone6 (in, zdescr);
write (out, <:<10> *selected from :>);
if zdescr.kind extract 12 = 8 <*tw*>
or zdescr.kind extract 12 = 0 <*ip*> and
zdescr.name (1) = parent_name (1) and
zdescr.name (2) = parent_name (2) then
write (out, <:primary input:>)
else
write (out, zdescr.name );
end <*empty current input zone stack chain*>;
write_alarm (out, <:reinitialized:>); <*warning.yes, ok.yes*>
end finish_syntax;
\f
<* sw8010/2, load parameter scanning page ... 26...
1981.11.13 *>
message system four page 12;
<*******************************************************>
<* *>
<* sepa- length: state: variable: val:*>
<* rator: *>
chars :=
digits := 0;
after_equal := 2;
after_space := state := 3;
space := int := after_point := separator := 4;
in_txt := 5;
equal := in_number := 6;
after_illegal := 7;
point := after_item := 8;
txt := fp_item := 10;
<* *>
<*******************************************************>
if -,fp_table_initialized then
fp_table_initialized := init_fp_table (fp_table);
intable (fp_table); <*special fp input table*>
repeat <*until state = after_item*>
class := if zone_level > 0 then
readchar (in, char)
else
fp_item;
case class of
begin
; <*class = 1, shift characters, not used*>
\f
<* sw8010/2, load parameter scanning page ... 27...
1981.11.13 *>
message system four page 13;
begin <*class = 2, digit*>
case state of
begin
; <*not used*>
begin <*after equal*>
pack_digit (state, digit, digits, char);
state := in_number;
end;
begin <*after space*>
pack_digit (state, digit, digits, char);
state := in_number;
end;
begin <*after point*>
pack_digit (state, digit, digits, char);
state := in_number;
end;
pack_char (state, name , chars , char); <*in text*>
pack_digit (state, digit, digits, char); <*in number*>
syntax (state, char); <*after illegal*>
end case state;
end <*class = 2*>;
begin <*class = 3, ,;: skip until 'nl' or 'em' equals 'sp'*>
case state of
begin
; <*not used*>
skip_until_nl; <*after equal*>
skip_until_nl; <*after space*>
skip_until_nl; <*after point*>
begin <*in text*>
repeatchar (in);
finish_name (name, chars);
length := txt;
state := after_item;
end;
begin <*in number*>
repeatchar (in); <*repeat 'nl'*>
number := finish_number (digit, digits);
length := int;
state := after_item;
end;
begin <*after illegal*>
state := after_space;
finish_syntax; <*empty current stack chain*>
end;
end case state;
end <*class = 3*>;
\f
<* sw8010/2, load parameter scanning page ... 28...
1981.11.13 *>
message system four page 14;
begin <*class = 4, '.'*>
case state of
begin
; <*not used*>
begin <*after equal*>
syntax (state, char);
state := after_illegal;
end;
begin <*after space*>
separator := point;
state := after_point;
end;
begin <*after point*>
syntax (state, char);
state := after_illegal;
end;
begin <*in text*>
repeatchar (in);
finish_name (name, chars);
length := txt;
state := after_item;
end;
begin <*in number*>
repeatchar (in);
number := finish_number (digit, digits);
length := int;
state := after_item;
end;
syntax (state, char); <*after illegal*>
end case state;
end <*class = 4*>;
\f
<* sw8010/2, load parameter scanning page ... 29...
1981.11.13 *>
message system four page 15;
begin <*class = 5, 'nl' and 'ff'*>
case state of
begin
; <*not used*>
; <*after equal*>
; <*after space*>
; <*after point*>
begin <*in text*>
repeatchar (in);
finish_name (name, chars);
length := txt;
state := after_item;
end;
begin <*in number*>
repeatchar (in);
number := finish_number (digit, digits);
length := int;
state := after_item;
end;
begin <*after illegal*>
state := after_space;
finish_syntax; <*empty current input stack chain*>
end;
end case state;
end <*class = 5*>;
begin <*class = 6, letter*>
case state of
begin
; <*not used*>
begin <*after equal*>
state := in_txt;
pack_char (state, name, chars, char);
end;
begin <*after space*>
state := in_txt;
pack_char (state, name, chars, char);
end;
begin <*after point*>
state := in_txt;
pack_char (state, name, chars, char);
end;
begin <*in text*>
state := in_txt;
pack_char (state, name, chars, char);
end;
begin <*in number*>
syntax (state, char);
state := after_illegal;
end;
begin <*after illegal*>
syntax (state, char);
state := after_illegal;
end;
end case state;
end <*class = 6*>;
\f
<* sw8010/2, load parameter scanning page ... 30...
1981.11.13 *>
message system four page 16;
begin <*class = 7, '='*>
case state of
begin
; <*not used*>
syntax (state, char); <*after equal*>
begin <*after space*>
separator := equal;
state := after_equal;
end;
syntax (state, char); <*after point*>
begin <*in text*>
repeatchar (in);
finish_name (name, chars);
length := txt;
state := after_item;
end;
begin <*in number*>
repeatchar (in);
number := finish_number (digit, digits);
length := int;
state := after_item;
end;
begin <*after illegal*>
state := after_space;
finish_syntax; <*empty current input stack zone chain*>
end;
end case state;
end <*class = 7*>;
begin <*class = 8, 'em'*>
case state of
begin
; <*not used*>
syntax (state, char) ; <*after equal*>
unstack_current_input (zone_level); <*after space*>
syntax (state, char) ; <*after point*>
begin <*in text*>
repeatchar (in);
finish_name (name, chars);
length := txt;
state := after_item;
end;
begin <*in number*>
repeatchar (in);
number := finish_number (digit, digits);
length := int;
state := after_item;
end;
begin <*after illegal*>
state := after_space;
finish_syntax; <*empty current input stack zone chain*>
end;
end case state;
end <*class = 8*>;
\f
<* sw8010/2, load parameter scanning page ... 31...
1981.11.13 *>
message system four page 17;
begin <*class = 9, illegal*>
syntax (state, char);
state := after_illegal;
end;
<*class = 10, current input zone has been unstacked to level 0*>
state := after_item;
end case class;
until state = after_item;
if class = fp_item then
<*item comes from fp command stack*>
system_four :=
system (4, increase (item_count), item)
else
begin <*the item came from current input*>
system_four := separator shift 12 + length;
if length = int then
item (1) := number <*number*>
else
begin
item (1) := real name (1);
item (2) := real name (2);
end;
end <*the item came from current input*>;
intable (0); <*return to normal input table*>
end system_four;
\f
<* sw8010/2, load parameter scanning page ... 32...
1982.12.21 *>
message init fp table page 1;
boolean
procedure init_fp_table (table);
integer array table ;
<***********************************************************>
<* *>
<* Initialization of special fp input table used by the *>
<* procedure system_four. *>
<* *>
<* Call : init_fp_table (table); *>
<* *>
<* init_fp_table (return value, boolean). True. *>
<* table (call value, integer array). The special *>
<* fp alphabet is assigned to table (0:127).*>
<* *>
<***********************************************************>
begin
integer i;
isotable (table);
<*class = 0, blind*>
for i := 0 step 1 until 7,
9, 11,
14 step 1 until 24,
26 step 1 until 31,
95, 127 do
table (i) := 0 shift 12 + i;
<*class = 2, digits*>
<*unchanged*>
<*class = 3, ','*>
for i := ',', ';', '*' do
table (i) := 3 shift 12 + i;
<*class = 4, '.' '/'*>
table ('.') := table ('/') := 4 shift 12 + '.';
<*class = 5, 'nl', 'ff' and 'sp'*>
for i := 'nl', 'ff', 'sp' do
table (i) := 5 shift 12 + i;
<*class = 6, letters*>
<*unchanged*>
<*class = 7, '='*>
table ('=') := 7 shift 12 + '=';
<*class = 8, 'em'*>
for i := 'em' do
table (i) := 8 shift 12 + i;
<*class = 9, illegal*>
for i := 8, 13,
33 step 1 until 39,
40, 41, 43, 45, 58, 60, 62, 63,
64 step 1 until 94,
96,126 do
table (i) := 9 shift 12 + i;
init_fp_table := true;
end init_fp_table;
\f
<* sw8010/2, load parameter scanning page ... 33...
1981.11.13 *>
message skip until nl page 1;
procedure skip_until_nl;
<*********************************************************>
<* *>
<* The procedure reads from current input zone and skips *>
<* all characters up to and including the next 'nl' or *>
<* 'em' character. *>
<* *>
<*********************************************************>
begin
integer char;
repeat
readchar (in, char);
until char = 'nl' or char = 'em' ;
end skip_until_nl;
\f
<* sw8010/2, load parameter scanning page ... 34...
1981.11.13*>
message stack current in put page 1;
integer
procedure stack_current_input (zone_level, file_name);
integer zone_level ;
real array file_name ;
<***********************************************************>
<* *>
<* The procedure stacks the current input zone and con- *>
<* nexts the zone to the file named file_name, increasing *>
<* the zone level counter zone_level by one, and returns *>
<* zero. *>
<* If the zone cannot be connected to the file, the zone *>
<* is unstaked again and the procedure returns value > 1 *>
<* with zone_level unchanged. *>
<* *>
<* Call : stack_current_input (zone_level, file_name); *>
<* *>
<* stack_current_input (return value, integer). The re- *>
<* sult of the connection. *>
<* zone_level (call and return value, integer). *>
<* At call the actual zone_level, at *>
<* return increased by one if connec- *>
<* tion was ok, unchanged if not. *>
<* file_name (call value, array). After stack *>
<* current input zone, the zone is *>
<* connected to the file whose name *>
<* is given in file_name (1:2). *>
<* *>
<***********************************************************>
begin
integer result;
integer array zdescr (1:20), sdescr (1:12);
fp_proc (29, 0, in, 0); <*stack c i*>
fp_proc (27, result, in, file_name); <*connect *>
if result <> 0 then
fp_proc (30, 0, in, 0) <*unstack *>
else
begin <*connect ok*>
get__zone6 (in, zdescr);
get_share6 (in, sdescr, zdescr (17)); <*used share*>
zdescr (13) := 0; <*positioned after open *>
zdescr (14) := sdescr (5) - 1; <*record base := first addr - 1*>
zdescr (15) := sdescr (6) ; <*last half := last addr *>
setzone6 (in, zdescr);
zone_level := zone_level + 1;
end <*connect ok*>;
stack_current_input := result;
end stack_current_input;
\f
<* sw8010/2, load parameter scanning page ... 35...
1981.11.13*>
message unstack current input page 1;
procedure unstack_current_input (zone_level);
integer zone_level ;
<*********************************************************>
<* *>
<* The procedure terminates the current input zone by a *>
<* call of h79 : terminate_zone and unstacks current in- *>
<* put zone. At return the parameter zone_level is de- *>
<* creased by one. *>
<* *>
<* Call : unstack_current_input (zone_level); *>
<* *>
<* zone_level (call and return value, integer). At *>
<* call the current zone stack level, at *>
<* return decreased by one. *>
<* *>
<*********************************************************>
begin
fp_proc (79, 0 <*w0*>, in <*w1*>, 0 <*w2*>); <*terminate zone*>
fp_proc (30, 0 <*w0*>, in <*w1*>, 0 <*w2*>); <*unstack zone*>
zone_level := zone_level - 1;
end unstack_current_input;
\f
<* sw8010/2, load parameter scanning page ... 36...
1988.09.08 *>
message stack current output page 1;
integer
procedure stack_current_output (file_name);
array file_name ;
<***********************************************************>
<* *>
<* The procedure stacks the current output zone, establi- *>
<* shing a stack zone chain in the global long array *>
<* chain_name, connects the zone to the file file_name and *>
<* returns zero. *>
<* If the zone cannot be connected to the file, the proce- *>
<* dure returns a value > 0 with the zone unstacked again. *>
<* *>
<* Call : stack_current_output (file_name); *>
<* *>
<* stack_current_output (return value, integer). The re- *>
<* sult of the connection. *>
<* file_name (call value, real array). After *>
<* stacking the zone is connected to *>
<* the file whose name is in *>
<* file_name (1:2). *>
<* *>
<***********************************************************>
begin
integer result;
result := 1 shift 2; <*1<2 <=> 1 segment, temporary*>
fp_proc (29, 0, out, chain_name); <*stack c o*>
fp_proc (28, result, out, file__name); <*connect *>
if result <> 0 then
fp_proc (30, 0, out, chain_name); <*unstack *>
stack_current_output := result;
end stack_current_output;
\f
<* sw8010/2, load parameter scanning page ... 37...
1981.12.07 *>
message unstack current output page 1;
procedure unstack_current_output;
<***********************************************************>
<* *>
<* The procedure unstacks the current output file from the *>
<* stack zone chain given in the global long array chain_ *>
<* name after having closed it up with an 'em' character *>
<* or a 'nl' character and termonated it. *>
<* *>
<***********************************************************>
begin
integer char;
integer array zdescr (1:20);
getzone6 (out, zdescr);
char :=
if zdescr (1) extract 12 = 4 <*bs*>
or zdescr (1) extract 12 = 18 <*mt*> then 'em' else 'nl';
fp_proc (34, 0, out, char); <*close up *>
fp_proc (79, 0, out, 0); <*terminate*>
fp_proc (30, 0, out, chain_name); <*unstack *>
end unstack_current_output;
\f
<* sw8010/2, load parameter scanning page ... 38...
1988.09.08 *>
message connect output page 1;
integer
procedure connect__output (z, kind, name, size, giveup);
value size, giveup ;
zone z ;
long array name ;
integer kind, size, giveup ;
<***********************************************************>
<* *>
<* The procedure connects the zone z to a file with a name *>
<* given after having initialized the zone with kind and a *>
<* giveup mask given. *>
<* The connection takes place by the fp procedure connect *>
<* output, i. e. a backing storage area of one slice is *>
<* created if necessary. *>
<* *>
<* Call : connect_output (z, kind, name, giveup); *>
<* *>
<* connect_output (return value, integer). The result of *>
<* fp connect output. *>
<* z (call value, zone). Determines the zone *>
<* to be connected. *>
<* kind (call value, integer). As for the proce- *>
<* dure close. *>
<* name (call and return value, long array). The *>
<* name of the file is in name (1:2). If *>
<* name (1) = long <::> a generated name is *>
<* used and returned in name (1:2). *>
<* giveup (call value, integer). As for close. *>
<* *>
<***********************************************************>
begin
integer i, result;
integer array dummyia (1:1), zdescr (1:20);
long array field laf;
open (z, kind, name, giveup);
if name (1) = long <::> then
begin
monitor (68) generate name :(z, 1, dummyia);
getzone6 (z, zdescr);
laf := 2;
for i := 1, 2 do
name (i) := zdescr.laf (i);
end;
result := size shift 2; <*at least one slice, temporary*>
fpproc (28, result, z, name);
connect_output := result;
end connect_output;
\f
<* sw8010/2, load parameter scanning page ... 39...
1984.04.25 *>
message connect_alarm page 1;
procedure connect_alarm (z, name, result);
value result ;
zone z ;
long array name ;
integer result ;
<***********************************************************>
<* *>
<* The procedure writes a connect alarm on the zone z and *>
<* skips the parameter list provided the result code is *>
<* positive and less then 7. *>
<* *>
<* Call : connect_alarm (z, name, result); *>
<* *>
<* z (call value, zone). Determines the document, *>
<* position of the document, ... where to write *>
<* alarm. *>
<* name (call value, long array). The name of the docu- *>
<* ment used in the connection. *>
<* result (call value, integer). The result code of the *>
<* connection (fp connect output). *>
<* *>
<***********************************************************>
begin
integer start_pos;
if result> 0 and result < 7 then
begin
startpos :=
write_alarm (z, <:connect:>);
write (z, name,
"nl", 1, "sp", startpos, case result of (
<:no resources:>, <:malfunction:>, <:not user, not exist:>,
<:convention error:>, <:not allowed:>, <:name format error:>));
skip_param_list;
end;
end connect_alarm;
\f
<* sw8010/2, load parameter scanning page ... 40...
1984.05.01 *>
message disconnect output page 1;
integer
procedure disconnect_output (z, release);
zone z ;
boolean release ;
<***********************************************************>
<* *>
<* The procedure stops all transfers in the zone z and dis-*>
<* connects the zone from the document in the sense that *>
<* the zone is closed and the document is cut down to last *>
<* block output if it is a backing storage area. *>
<* *>
<* Call : disconnect_output (z, release); *>
<* *>
<* disconnect_ *>
<* output (return value, integer). If the document is bs *>
<* the size is returned else zero is returned. *>
<* z (call value, zone). Determines the zone and *>
<* the document to be disconnected. *>
<* If the zone kind is bs, the document is cut to *>
<* contain the last block output. *>
<* release (call value, boolean). Release code as for *>
<* close with the same meaning. *>
<* *>
<***********************************************************>
begin
integer array zdescr (1:20), tail (1:10);
close (z, false); <*dont remove process*>
getzone6 (z, zdescr);
if zdescr (1) extract 12 = 4 then
begin <*bs*>
monitor (42) lookup entry tail :(z, 1, tail);
tail (1) := zdescr (9); <*segment count*>
monitor (44) change entry tail :(z, 1, tail); <*ignore results*>
disconnect_output := tail (1);
end else
disconnect_output := 0;
close (z, release);
end disconnect output;
\f
<* sw8010/2, load parameter scanning page ... 41...
1984.05.21 *>
message maybe device status page 1;
procedure maybe_device_status (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z a device status mes- *>
<* sage with document name and status bit names the same *>
<* way fp does if the program was to terminate with a give *>
<* up alarm instead of having trapped one. *>
<* *>
<***********************************************************>
begin
integer status, cause, param, bit;
long array text (1:4);
long array field docname;
own boolean called_before;
docname := 8; <*fields possible docname in text*>
status := getalarm (text);
cause := alarmcause extract 24 ;
param := alarmcause shift (-24);
if cause = -11 and -, called_before then
begin <*give up*>
called_before := true;
write (z, "nl", 1,
<:***device status :>, text.docname);
for bit := 0 step 1 until 21 do
if status shift bit < 0 then
write (z, "nl", 1, case (bit + 1) of (
<:intervention:>,
<:parity error:>,
<:timer:>,
<:data overrun:>,
<:block length error:>,
<:end of document:>,
<:load point:>,
<:tape mark or attention:>,
<:writing enabled:>,
<:mode error:>,
<:read error:>,
<:card rejected or disk error:>,
<:checksum error:>,
<:bit 13:>,
<:bit 14:>,
<:stopped:>,
<:word defect:>,
<:position error:>,
<:process does not exist:>,
<:disconnected:>,
<:unintelligible:>,
<:rejected:>,
<:normal:>,
<:hard error:>));
write (z, "nl", 1);
end;
end rs_alarm;
\f
<* sw8010/2, load decl. for parameters/discs page ... 38...
1988.11.17 *>
message decl. second level page 1;
<*init of disc_name table*>
system (5 )move core:( 92, discs);
<*discs (1) = first drum in nametable *>
<*discs (2) = first disc in nametable *>
<*disc2 (3) = first unused in nametable *>
<*discs (4) = chain addr of maincat disc*>
no_of_discs := (discs(3) - discs (1)) // 2;
max_no_of_vol := 32; <*max number of volumes in tapeparam*>
begin
<*block for parameter and disc variables and procedures*>
<*for parameter identification, interpretation and ca- *>
<*talog scanning *>
boolean list_entries , <*special param *>
list_only_name , <*special param *>
load ,
survey ,
check_tape ,
connect ,
reserve , <*not used*>
test ,
savecatfile_connected ,
reading_savecat ,
inc_dump ,
tape_param_ok ;
boolean array end_of_doc ,
parity ,
expell_zone (1:3),
release , <*mount param *>
mount_param_spec (1:2); <*mount param *>
\f
<* sw8010/2, load decl. for parameters/discs page ... 39...
1985.02.08 *>
message decl. second level page 2;
real r ;
integer action , <*param action *>
point_int ,
point_txt ,
space_int ,
space_txt ,
seplength ,
old_length ,
start_volume ,
copy_count ,
no_of_copies ,
no_of_shares ,
entry_spec_count ,
buflength ,
load_state ,
before_load_spec ,
after_modifier ,
after_disc_spec ,
after_entry_spec ,
after_error ,
no_of_entry_specs ,
any_scope ,
all ,
perm ,
sistem ,
owen ,
project ,
user ,
login ,
temp ,
result ,
no_of_unknown_discs ,
maincat_disc ,
progbase_lower ,
progbase_upper ,
buf__claim ,
area_claim ,
bufs_needed ,
areas_needed ,
segm ,
segments ,
savecat_size ,
savecat_reclength ,
savecat_recstart ,
baselevel ,
basetime ,
dumplevel ,
dumptime ,
entries_in_partcat ,
entries_in_savecat ,
entries_stored ,
entries_loaded ,
segs_loaded ,
total_entry_count ,
total_segm__count ,
version_id ,
release_id ,
sync_blocklength ,
aux_synclength ,
speedlimit ,
monrelease ,
dummy ,
i ,
j ,
k ;
\f
<* sw8010/2, load decl. for parameters/discs page ... 39...
1984.12.04 *>
message decl. second level page 2;
integer array dummyia ,
claim (1:1),
savecat_base ,
device_no ,
mode_kind ,
vol_count ,
no_of_vol (1:2),
file__no ,
block_no (1: 3),
dumpbases (1: 8),
zdescr (1:20),
slice_length ,
entry_count ,
slice_count ,
name_table (1:no_of_discs);
long array cat__base ,
std__base ,
user_base ,
max__base ,
sys__base ,
partcat_name ,
savecat_name ,
loadcat_name ,
disc_spec_name (1:2),
dump_label ,
from_to_discname (1:2 ,
1:2),
para_name ,
tape_name (1:2 ,
1:2 * max_no_of_vol),
incl_auxcat_name ,
incl_disc_name (1:no_of_discs ,
1:2 );
long array field current_tape ,
label_name ,
disc ,
laf ;
real array item ,
old_item ,
proc_name (1:2);
real array field raf1 ,
raf2 ;
zone z_partcat ,
z_loadcat ,
z_savecat (128, 1, stderror);
\f
<* sw8010/2, load entry procedures page ... xx...
1984.07.10*>
message connect savecat file page 1;
boolean
procedure connect_savecatfile (z, name, base, size, shortclock);
value size, shortclock ;
zone z ;
long array name ;
integer array base ;
integer size, shortclock ;
<***********************************************************>
<* *>
<* The procedure connects to a backing storage area of *>
<* given name, base, size and shortclock. *>
<* *>
<* Call : connect_savecatfile (z, name, base, size, short);*>
<* *>
<* connect_savecatfile *>
<* ( return value, boolean). True if the *>
<* proper entry is looked up, an area pro- *>
<* cess is created and connected, false o- *>
<* therwise. *>
<* z (call and return value, zone). The zone *>
<* to be connected. At call the zone state *>
<* must be 4, after declaration. At return *>
<* it is 0, after open. *>
<* name (call value, long array). The given na- *>
<* me in name (1:2). *>
<* base (call value, integer array). The entry *>
<* base of the given name is contained in *>
<* base (1:2). *>
<* size (call value, integer). The size of the *>
<* file given. *>
<* shortclock (call value, integer). The given short- *>
<* clock. *>
<* *>
<***********************************************************>
begin
integer result;
boolean connected;
integer array entry (1:17), dummy (1:1);
\f
<* sw8010/2, load entry procedures page ... xx...
1984.11.07 *>
message connect savecat file page 2;
connected := false; <*default*>
set_catbase (base);
open (z, 4, name, 0);
result := monitor (76) lookup head and tail :(z, 1, entry);
reset_catbase;
if result = 0 and
entry ( 1) extract 3 = 3 and
entry ( 2) = base (1) and
entry ( 3) = base (2) and
entry ( 8) = size and
entry (13) = shortclock then
begin <*entry exists*>
set_catbase (base);
if monitor (52) create area process :(z, 1, dummy) = 0 then
begin <*process created*>
inrec6 (z, 0); <*est. name table address*>
setposition (z, 0, 0);
connected := true;
end <*process created*>;
reset_catbase;
end <*entry exists*>;
if -, connected then
close (z, true);
connect_savecatfile := connected;
if test then
write (out,
"nl", 2, <:connect savecatfile ::>,
"nl", 1, <:connected = :>, if connected then <: yes:> else <: no:>,
"nl", 1, <:entry (1) = :>, entry (1) extract 3,
"nl", 1, <:entry (2) = :>, entry (2), <: base (1) = :>, base (1),
"nl", 1, <:entry (3) = :>, entry (3), <: base (2) = :>, base (2),
"nl", 1, <:entry (8) = :>, entry (8), <: size = :>, size,
"nl", 1, <:entry (13)= :>, entry (13), <: shortcl = :>, shortclock);
end connect_savecatfile;
\f
<* sw8010/2, load entry procedures page ... xx...
1984.09.17 *>
message connect wrk or exist page 1;
integer
procedure connect_wrk_or_existing (z, entry, discname, existing);
zone z ;
integer array entry ;
long array discname ;
boolean existing ;
<*********************************************************>
<* *>
<* If the parameter existing is true, the procedure tri- *>
<* es to look up the entry given (name and base). If it *>
<* exists, the procedure tries to change its tail to the *>
<* one specified, except for the document name of an a- *>
<* rea entry (disc name) which remains unchanged. If the *>
<* entry is an area entry, the procedure connects the *>
<* zone z to it. *>
<* If any of the steps above fail or the parameter exis- *>
<* ting is false, the procedure tries to create an entry *>
<* with a wrk name but with bases, permanent key, tail *>
<* and discname as specified. *>
<* If any of these steps fail, the procedure removes the *>
<* possibly created entry again and writes a proper a- *>
<* larm message on current output zone. *>
<* *>
<* Call : connect_wrk_or_existing (z, entry, discname, *>
<* existing); *>
<* *>
<* connect_wrk_ (return value, integer). Either zero or *>
<* the result from the monitor procedure *>
<* which failed. *>
<* z ( call and return value, zone). The zo- *>
<* no to be connected. *>
<* entry (call value, integer array). An area *>
<* entry head and tail in entry (1:17). *>
<* Entry (1) shift (-12) = 0 means no area *>
<* after all. *>
<* discname ( call value, long array). If the proce-*>
<* dure should create an wrk area entry, *>
<* name of the disc where to place it is *>
<* contained in discname (1:2). The first *>
<* word of discname (1) may be zero or one *>
<* with the usual meaning. *>
<* existing (call value, boolean). If existing is *>
<* true, the procedure first tries to con- *>
<* nect to a possibly existing area entry *>
<* with the same name and bases as given *>
<* in entry. *>
<* *>
<*********************************************************>
begin
integer result, key, no;
integer array headtail (1:17), entry_tail (1:10), entry_base (1:2),
diskname (1:8), zdescr (1:20), dummyia (1: 1);
long array wrk_name (1:2);
integer field size;
integer array field iaf, base, tail;
long array field name, z_name, docname;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.11.25 *>
message connect wrk or exist page 2;
z_name := 2; <*fields docname in zone descr*>
iaf := 0;
base := 2;
name := 6;
tail := 14;
size := 16;
docname := 2; <*fields docname in an entry tail*>
tofrom (entry_tail, entry.tail, 20); <*move entry tail into int array*>
tofrom (entry_base, entry.base, 4); <* - - base - - - *>
tofrom (diskname , discname , 8); <* - discname - - - *>
result := 1;
if existing then
begin <*if the entry exists, change its tail and connect if area*>
open (z, 4, entry.name, 0);
set_catbase (entry.base);
result := monitor (76) head and tail :(z, 1, headtail);
if result = 0 then
result :=
if headtail .base (1) = entry .base (1) and
headtail .base (2) = entry .base (2) and <*bases*>
headtail (1) extract 3 = entry (1) extract 3 and <*permkey*>
(headtail .size >= 0 and <*areas*>
entry .size >= 0
or headtail .size < 0 and <*descr*>
entry .size < 0) then
0
else
1;
if result = 0 then
begin <*existing discname wins*>
if entry.size >= 0 then
tofrom (entry_tail.docname, head_tail.tail.docname, 8);
result := monitor (44) change entry :(z, 1, entry_tail);
tofrom (entry , head_tail, 14); <*head returned in entry*>
tofrom (entry.tail, entrytail, 20); <*tail returned in entry*>
end;
reset_catbase;
end <*if the area entry exists connect to it*>;
\f
<* sw8010.1, save entry procedures page ... xx...
1984.11.08 *>
message connect wrk or exist page 3;
if result > 0 then
begin <*could not or should not connect to existing, create wrk and conn*>
close (z, true); <*remove process*>
wrk_name (1) := long <::>;
open (z, 4, wrk_name, 0);
result := monitor (40) create entry :(z, 1, entry_tail);
getzone6 (z, zdescr);
tofrom (wrk_name, zdescr.z_name, 8);
if test then
begin
write (out,
"nl", 2, <:connect wrk or existing ::>,
"nl", 1, <:entry name = :>, wrkname,
"nl", 1, <:entry tail = :>,
entrytail (1) shift (-12), <:.:>, entrytail (1) extract 12,
"sp", 1, true, 12, entrytail.docname,
"sp", 1, true, 8, entry (6), entry (7), entry (8), entry (9), entry (10));
end;
if result > 0 then
monitor_alarm (out, 40, wrk_name, result)
else
begin <*permanent*>
key := entry (1) extract 3;
no :=
if entry.size >= 0
or discname (1) shift (-24) = 0
or discname (1) shift (-24) = 1 then
50 <*permanent entry, area or no specific disc*>
else
90; <*permanent in aux cat, non area entry and specific disc*>
result := monitor (no) permanent :(z, key, diskname);
\f
<* sw8010/2, load entry procedures page ... xx...
1984.11.09 *>
message connect wrk or exist page 4;
monitor (76) head and tail :(z, 1, head_tail); <*actual head tail*>
entry (1) := head_tail (1); <*first slice, namekey, permkey returned*>
tofrom (entry.tail, headtail.tail, 20); <*tail returned*>
if test then
begin integer array zdescr (1:20); long array field zname;
zname := 2;
getzone6 (z, zdescr);
write (out,
"nl", 2, <:connect wrk or existing ::>,
"nl", 1, <:permanent entry, no = :>, no,
"nl", 1, <: name = :>, zdescr.zname,
"nl", 1, <: key = :>, key,
"nl", 1, <: disc = :>, discname,
"nl", 1, <: result = :>, result);
listentry (out, false, entry, 0, 0, 0, 0);
end;
if result > 0 then
monitor_alarm (out, no, discname, result)
else
begin <*set entry base*>
result := monitor (74) set entry base :(z, 1, entry_base);
if result > 0 then
monitor_alarm (out, 74, wrk_name, result);
end <*set entry base*>;
end <*permanent*>;
if result > 0 then
begin
monitor (48) remove entry :(z, 1, dummyia);
result := 9; <*ignored in skip entry*>
end;
end <*could or should not connect to existing, create wrk and connect*>;
if result = 0 and entry.size > 0 then
begin <*create area process*>
set_catbase (entry_base);
result :=monitor (52) create area process :(z, 1, dummyia);
if result = 0 then
result := monitor (8) reserve process :(z, 1, dummyia) shift 12;
if result = 0 then
begin <*connect*>
inrec6 (z, 0); <*est. name table address*>
setposition (z, 0, 0);
end <*connect*>;
if result = 0 then
begin <*check bases*>
system (5) move core :(monitor (4, z, 1, dummyia) - 4, entry_base);
if entry_base (1) <> entry.base (1)
or entry_base (2) <> entry.base (2) then
result := 8; <*covered by a better entry*>
end <*check bases*>;
reset_catbase;
end <*create area process*>;
connect_wrk_or_existing := result;
end connect_wrk_or_existing;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.02.04*>
message rename wrk page 1;
integer
procedure rename_wrk (z, entry, discno);
zone z ;
integer array entry ;
integer discno ;
<*********************************************************>
<* *>
<* The procedure tries to rename the entry given. If it *>
<* cannot be renamed because of name overlap, it tries *>
<* to remove the entry in the way and rename again. If *>
<* the procedure fails to rename the entry, it is re- *>
<* moved instead, and a proper message is displayed on *>
<* current out. *>
<* If the procedure succeeds, the number of the disc a- *>
<* mong included discs which holds the new entry is re- *>
<* turned. *>
<* *>
<* Call : rename_wrk (z, entry); *>
<* *>
<* z (call value, zone). The zone is supposed to *>
<* contain the old entry name. *>
<* entry (call value, integer array). The entry is sup- *>
<* posed to be contained in entry (1:17). *>
<* discno (return value, integer). If the procedure re- *>
<* turns ok (= 0), the number of the disc holding *>
<* the new entry is returned in discno, else the *>
<* value is returned unchanged. *>
<* *>
<*********************************************************>
begin
integer result, key, first_slice, permkey, min_auxcat_permkey,
twice_chain_no, i, j;
integer array headtail (1:17), first_bs, chain_addr, dummyia (1:1),
entry_name (1:4);
long array bs_name (1:2);
integer field size;
integer array field base, tail;
long array field name, doc, disc;
zone zhelp (1, 1, stderror);
base := 2; <*fields entry base*>
name := 6; <* - - name*>
tail := 14; <* - - tail*>
size := 16; <* - - size*>
doc := 16; <* - - docname*>
min_auxcat_permkey := 2;
tofrom (entry_name, entry.name, 8); <*move entry name into int array*>
\f
<* sw8010/2, load entry procedures page ... xx...
1988.02.04 *>
message rename wrk page 2;
set_catbase (entry.base);
result := monitor (46) rename entry :(z, 1, entry_name);
if test then
begin integer array zdescr (1:20);
long array field zname;
zname := 2;
getzone6 (z, zdescr);
write (out,
"nl", 1, <:rename wrk ::>,
"nl", 1, <:old name = :>, zdescr.zname,
"nl", 1, <:new name = :>, entry.name ,
"nl", 1, <:ent base = :>, entry.base (1), entry.base (2),
"nl", 1, <:result = :>, result);
end;
if result = 0 then
begin <*reopen zone z*>
close (z, true);
open (z, 0, entry_name, 0);
end;
if (result = 0 <*renamed *>
or result = 3) and <*name overlap*>
entry.size >= 0 then
begin <*check whether or not to cut area*>
integer result1;
result1 := monitor (76) head and tail :(z, 1, headtail);
if test then
begin
integer array zdescr (1:20);
integer array field zname;
zname := 2;
getzone6 (z, zdescr);
write (out,
"nl", 1, <:lookup head and tail : :>, zdescr.zname,
"nl", 1, <:result : :>, result1 );
end;
if result1 = 0 and
entry.size <> headtail.size then
begin <*cut area*>
result1 := monitor (44) change entry :(z, 1, entry.tail);
if test then
begin
integer array zdescr (1:20);
integer array field zname;
zname := 2;
getzone6 (z, zdescr);
write (out,
"nl", 1, <:change entry : :>, zdescr.zname,
"nl", 1, <:entry.size : :>, entry.size ,
"nl", 1, <:result : :>, result1);
end;
if result1 > 0 then
begin <*could not be changed*>
reset_catbase;
monitor_alarm (out, 44, entry.name, result1);
end;
end <*cut area*>;
end <*check whether ...*>;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.02.04*>
message rename wrk page 1a;
if result > 0 and result <> 3 then
begin <*could not be renamed, remove entry and alarm*>
monitor (48) remove entry :(z, 1, dummyia);
reset_catbase;
monitor_alarm (out, 46, entry.name, result);
end else
begin <*renamed or not found.name overlap*>
if result = 3 then
begin <*not found.name overlap*>
if monitor (76) head and tail :(z, 1, headtail) > 0
or headtail.base (1) <> entry.base (1)
or headtail.base (2) <> entry.base (2) then
monitor_alarm (out, 46, entry.name, result) <*not found*>
else
if entry.size <> headtail.size then
write (out,
"nl", 1, "*", 3, "sp", 1, true, 12, headtail.name, <:not renamed:>)
else
begin <*name equivalence*>
open (zhelp, 0, entry_name, 0);
close (zhelp, true );
result := monitor (48) remove entry :(zhelp, 1, dummyia);
if test then
begin integer array zdescr (1:20); long array field zname;
zname := 2;
getzone6 (zhelp, zdescr);
write (out,
"nl", 1, <:remove entry ::>,
"nl", 1, <:name = :>, zdescr.zname,
"nl", 1, <:result = :>, result);
end;
if result > 0 then
begin <*old entry could not be removed*>
monitor (48) remove entry :(z, 1, dummyia);
reset_catbase;
monitor_alarm (out, 48, entry.name, result);
end else
begin <*old entry is removed*>
result := monitor (46) rename entry :(z, 1, entry_name);
if result > 0 then
begin <*could not be renamed, remove wrk and alarm*>
monitor (48) remove entry :(z, 1, dummyia);
reset_catbase;
monitor_alarm (out, 46, entry.name, result);
end;
end <*old entry removed*>;
end <*name equivalence*>;
end <*not found.name overlap*>;
\f
<* sw8010/2, load entry procedures page ... xx...
1984.08.28 ▶1c◀*>
message rename wrk page 3;
if result = 0 then
begin <*renamed, find the name of the disc holding the entry*>
if entry.size >= 0 then <*area entry, docname = discname*>
begin <*area entry, discname = docname*>
for i := 1, 2 do
bs_name (i) := entry.doc (i);
end else
begin <*non-area entry, find disc*>
first_slice := entry (1) shift (-12) extract 12;
perm__key := entry (1) extract 3;
if perm_key < min_auxcat_permkey then
system (5 )move core:( 98, chain_addr) <*disc with maincat*>
else
begin <*permanented into auxcat*>
twice_chain_no := first_slice extract 10;
system (5 )move core:( 92, first_bs); <*first drum/disc*>
system (5 )move core:( first_bs (1) + twice_chain_no,
chain_addr);
end;
system (5 )move core:( chain_addr (1) - 18, bs_name);
end <*non-area*>;
j := 0;
for i := 1 step 1 until no_of_discs do
begin <*search the name of the disc in discname table*>
disc := 8 * i; <*fields name of discno i in discname*>
if incl_discname.disc (1) = bs_name (1) and
incl_discname.disc (2) = bs_name (2) then
begin j := i; i := no_of_discs; end;
end <*search*>;
discno := j; <*0 means disc not found or not specified*>
if test then
write (out,
"nl", 2, <:rename wrk ::>,
"nl", 1, <:disc name found = :>, bsname,
"nl", 1, <:disc no returned = :>, discno);
end <*find disc holding the entry*>;
end <*renamed or ...*>;
reset_catbase;
close (z, true); <*remove process*>
rename_wrk := result;
end rename_wrk;
\f
<* sw8010/2, load entry procedures page ... xx...
1984.11.09 *>
message monitor alarm page 1;
procedure monitor_alarm (z, entry, name, result);
value result ;
zone z ;
long array name ;
integer entry, result ;
<***********************************************************>
<* *>
<* The procedure writes a monitor alarm on the zone z *>
<* provided the result code is *>
<* positive and less than 8, else the call is blind. *>
<* *>
<* Call : monitor alarm (z, entry, name, result); *>
<* *>
<* z (call value, zone). Determines the document, *>
<* position of the document, ... where to write *>
<* alarm. *>
<* entry (call value, integer). Number of a monitor en- *>
<* try. (40, 50 or 90 , 74, 44, 46, 48) *>
<* name (call value, long array). The name of the en- *>
<* try used in the monitor call. *>
<* result (call value, integer). The result code of the *>
<* monitor call. *>
<* *>
<***********************************************************>
begin
integer start_pos;
if result> 0 and result < 8 then
begin
entry :=
if entry = 40 then 1 else
if entry = 50 then 2 else
if entry = 90 then 3 else
if entry = 74 then 4 else
if entry = 44 then 5 else
if entry = 46 then 6 else 7;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.02.04 *>
message monitor alarm page 2;
startpos :=
write_alarm (z, case entry of (
<:create entry:> ,
<:permanent entry:>,
<:permanent entry in auxcat:>,
<:set entry base:> ,
<:change entry:> ,
<:rename entry:> ,
<:remove entry:> ));
write (z, name, "sp", 1, case (result + 1) of (
<:result 0:>,
<:result 1:>,
<:catalog i/o error/document not ready:>,
<:name conflict/not found:>,
case entry of (<:claims exceeded:>,
<:entry protected/key illegal:>,
<:entry protected/key illegal:>,
<:entry protected/base illegal:>,
<:entry protected:>,
<:entry protected:>,
<:entry protected:>),
case entry of (<:catbase outside std base:>,
<:reserved by another:>,
<:used by another/already in another aux catalog:>,
<:used by another:>,
<:used by another:>,
<:used by another:>,
<:used by another:>),
case entry of (<:name format illegal:>,
<:claims exceeded:>,
<:claims exceeded:>,
<:name format illegal:>,
<:new size illegal/claims exceeded:>,
<:name format illegal:>,
<:name format illegal:>),
<:maincat not present:>));
errorbits := 2; <*warning.yes, ok.yes*>
end;
end monitor alarm;
\f
<* sw8010/2, load entry procedures page ... xx...
1984.07.10*>
message terminate alarm page 1;
procedure terminate_alarm (z, text, name, val, text1, val1);
value val, val1 ;
zone z ;
string text, text1 ;
long array name ;
integer val, val1 ;
<***********************************************************>
<* *>
<* The procedure terminates with an invisible runtime alarm*>
<* after having written an alarm message on the zone z. *>
<* *>
<* Call: terminate_alarm (z, text, name, val, text1, val1);*>
<* *>
<* z (call and return value, zone). The document, the *>
<* buffering and the position of the document where *>
<* to write the alarm message. *>
<* text (call value, string). *>
<* text1 *>
<* name (call value, long array). *>
<* val (call value, integer). All values which are writ- *>
<* val1 ten on the zone z. *>
<* *>
<***********************************************************>
begin
write_alarm (z, text);
write (z, "nl", 1, "sp", 4,
true, 12, name, <: :>, val, text1, val1);
trapmode := 1 shift 13; <*ignore output of trap alarm*>
trap (1); <*alarm*>
end terminate_alarm;
\f
<* sw8010/2, load entry procedures page ... xx...
1988.01.28*>
message continue warning page 1;
procedure continue_warning (z, text, name, val, text1, val1);
value val, val1 ;
zone z ;
string text, text1 ;
long array name ;
integer val, val1 ;
<***********************************************************>
<* *>
<* The procedure continues after having written an warning *>
<* message on the zone z. The fp mode bits are set *>
<* warning.yes ok.yes *>
<* *>
<* Call: continuewarning (z, text, name, val, text1, val1);*>
<* *>
<* z (call and return value, zone). The document, the *>
<* buffering and the position of the document where *>
<* to write the alarm message. *>
<* text (call value, string). *>
<* text1 *>
<* name (call value, long array). *>
<* val (call value, integer). All values which are writ- *>
<* val1 ten on the zone z. *>
<* *>
<***********************************************************>
begin
write_alarm (z, text);
write (z, "nl", 1, "sp", 4,
true, 12, name, <: :>, val, text1, val1);
errorbits := 2; <*warning.yes, ok.yes*>
end continue_warning;
\f
<* sw8010/2, load parameter interpretation page ... 40...
1988.08.21*>
message mount param page 1;
integer
procedure mount_param (seplength, item);
value seplength ;
integer seplength ;
real array item ;
<***************************************************************>
<* *>
<* The procedure returns the kind of the item given. *>
<* *>
<* Call : mount_param (seplength, item); *>
<* *>
<* mount_param (return value, integer). The kind of the *>
<* item : *>
<* 0 seplength<> <s> or ., item not below *>
<* 1 seplength = <s> or ., item = mountspec *>
<* 2 -"- , -"- release *>
<* 3 -"- , -"- mt62, mtlh, mto *>
<* 4 -"- , -"- mte *>
<* 5 -"- , -"- mt16, mtll, nrz *>
<* 6 -"- , -"- nrze *>
<* 7 -"- , -"- mt32 *>
<* 8 -"- , -"- mt08 *>
<* 9 -"- , -"- mthh *>
<* 10 -"- , -"- mthl *>
<* seplength (call value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (call value, array). An item in *>
<* item (1:2) as for system (4, ...). *>
<* *>
<***************************************************************>
\f
<* sw8010/2, load parameter interpretation page ... 41...
1988.08.21 *>
message mount param page 2;
begin
integer i, j, space_txt, point_txt;
space_txt := 4 shift 12 + 10;
point_txt := 8 shift 12 + 10;
j := 0;
for i := 1 step 1 until
(if seplength <> space_txt and
seplength <> point_txt then 0 else 10) do
if item (1) = real ( case i of (
<:mount:> add 's',
<:relea:> add 's',
<:mt62:> ,
<::> ,
<:mt16:> ,
<::> ,
<:mt32:> ,
<:mt08:> ,
<::> ,
<::> ) ) and
item (2) = real ( case i of (
<:pec:> ,
<:e:> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) )
or item (1) = real ( case i of (
<::> ,
<::> ,
<:mtlh:> ,
<::> ,
<:mtll:> ,
<::> ,
<::> ,
<::> ,
<:mthh:> ,
<:mthl:> ) ) and
item (2) = real ( case i of (
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) )
or item (1) = real ( case i of (
<::> ,
<::> ,
<:mto:> ,
<:mte:> ,
<:nrz:> ,
<:nrze:> ,
<::> ,
<::> ,
<::> ,
<::> ) ) and
item (2) = real ( case i of (
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) ) then
begin j := i; i := 10; end;
mount_param := j;
end mount_param;
\f
<* sw8010/2, load parameter interpretation page ... 41...
1984.07.10 *>
message special param page 1;
integer
procedure special_param (seplength, item);
value seplength ;
integer seplength ;
array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, may-*>
<* be using one look ahead. *>
<* *>
<* Call : special_param (seplength, item); *>
<* *>
<* special_param (return value, integer). The kind of *>
<* the item : *>
<* 0 not <s><name>, <s><name> unknown *>
<* or <s><name> one or below but the *>
<* next item is an entry specifier. *>
<* 1 <s><name> and name = copy *>
<* 2 <s><name> and name = level *>
<* 3 <s><name> and name = list *>
<* 4 <s><name> and name = test *>
<* 5 <s><mame> and name = load *>
<* 6 <s><name> and name = survey *>
<* 7 <s><name> and name = check *>
<* 8 <s><name> and name = connect *>
<* seplength (call value, integer). Separator < 12 *>
<* + length as for system (4, ...). *>
<* item (call value, array). An item in *>
<* item (1:2) as for system (4, ...). *>
<* *>
<* The procedure may read the next item which however *>
<* will be re-read by the next call of scan param. *>
<* *>
<*********************************************************>
\f
<*sw8010/2, load parameter interpretation page ... 42...
1985.02.06 *>
message special param page 2;
begin
integer i, j, space_txt, point_int,
next_seplength, entry_spec_val;
real array next_item (1:2);
space_txt := 4 shift 12 + 10;
point_int := 8 shift 12 + 4;
j := 0;
for i := 1 step 1 until (if seplength <> space_txt then 0 else 11) do
if item (1) = real ( case i of (
<:vol:> ,
<:copy:> ,
<:segm:> ,
<:level:>,
<:list:> ,
<:test:> ,
<:load:> ,
<:surve:> add 'y',
<:check:>,
<:conne:> add 'c',
<:reser:> add 'v' )) and
item (2) = real ( case i of (
<::>,
<::>,
<::>,
<::>,
<::>,
<::>,
<::>,
<::>,
<::>,
<:t:>,
<:e:> )) then
begin j := i; i := 11; end;
if j > 0 then
begin <*<s><name> known, look ahead*>
next_seplength := scan_param (next_item);
repeat_param := true;
entry_spec_val :=
entry_specifier (next_seplength, next_item, false <*no further look ahead*>);
if j <= 4 <*integer*> and next_seplength <> point_int <*not .<int>*>
or j > 4 <*name *> and entry_spec_val < 3 <*not .<name> or entry*> then
j := 0; <*entry name*>
end <*<s><name> known, look ahead*>;
special_param := j;
end special_param;
\f
<*sw8010/2, load parameter interpretation page ... 43...
1981.12.09 *>
message file no tape name page 1;
integer
procedure file_no_tape_name (name, tape_name, modekind);
real array name ;
long array tape_name ;
integer modekind ;
<*********************************************************>
<* *>
<* The procedure looks up a name in the catalog to see *>
<* whether it is a file descriptor describing a magnetic *>
<* tape. *>
<* If it is not, the name is returned as tapename and *>
<* file number zero is returned as procedure value. *>
<* if it is, the document name of the entry is returned *>
<* as tapename, the modekind in modekind and the file *>
<* number as procedure value. *>
<* *>
<* Call : file_no_tape_name (name, tapename, modekind);*>
<* *>
<* file_no_tape_name (return value, integer). If the *>
<* name is found in the catalog and *>
<* kind is mt (18), the file number *>
<* of the entry, else zero. *>
<* name (call value, real array). The name *>
<* to be looked up in the catalog in *>
<* name (1:2). *>
<* tape_name (return value, long aray). If the *>
<* name is found in the catalog and *>
<* kind is mt (18), tapename (1:2) *>
<* will contain the document bame of *>
<* the entry, else it contains the *>
<* name given. *>
<* modekind (return value, integer). If the *>
<* name is found in the catalog and *>
<* kind is mt, the modekind of the *>
<* entry is returned here, else un- *>
<* changed. *>
<* *>
<*********************************************************>
begin
integer i;
integer array entry (1:10);
integer field kind, file;
long array field docname;
zone z (1, 1, stderror);
kind := docname := 2; <*fields modekind and docname in an entry*>
file := 14; <*fields file number in an entry*>
entry.kind := 0; <*default*>
open (z, 0, name, 0); <*name in zone*>
close (z, true );
if monitor (42) lookup entry :(z, 1, entry) <> 0
or entry.kind extract 12 <> 18 then
begin <*not in catalog or not describing a magnetic tape*>
for i := 1, 2 do tape_name (i) := long name (i);
file_no_tape_name := 0 ;
<*modekind unchanged*>
end else
begin <*magtape file descriptor*>
for i := 1, 2 do tape_name (i) := entry.docname (i);
file_no_tape_name := entry.file ;
modekind := entry.kind ;
end;
end file_no_tape_name;
\f
<* sw8010/2, load parameter interpretation page ... 44...
1981.12.09 *>
message entry specifier page 1;
integer
procedure entry_specifier (seplength, item, look_ahead);
value seplength ;
integer seplength ;
array item ;
boolean look_ahead ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, de- *>
<* cided with one look ahead if so specified. *>
<* *>
<* Call : entry_specifier (seplength, item, look_ahead); *>
<* *>
<* entry_ *>
<* specifier (return value, integer). The kind of the *>
<* item given : *>
<* 0 not .<name> *>
<* 1 .<name> and name = scope *>
<* 2 .<name> and name = docname *>
<* 3 .<name> and name none of above de- *>
<* cided witn no look ahead, *>
<* or one look ahead reveals *>
<* the next item to be one of *>
<* above. *>
<* seplength (call value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (call value, array). An item as for sys- *>
<* tem (4, ...). *>
<* look_ahead (call value, boolean). If true, the kind *>
<* of the item is decided with one look a- *>
<* head, else without. *>
<* *>
<* In case of one look ahead, the procedure reads the *>
<* next item, which will be re-read at next call of *>
<* scan_param. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load parameter interpretation page ... 45...
1982.03.23 *>
message entry specifier page 2;
begin
integer i, j, point_txt, next_seplength;
real array next_item (1:2);
point_txt := 8 shift 12 + 10;
j := 0;
for i := 1 step 1 until (if seplength <> point_txt then 0 else 2) do
if item (1) = real (case i of (
<:scope:>, <:docna:> add 'm' )) and
item (2) = real (case i of (
<::> , <:e:> )) then
begin j := i; i := 3; end;
if seplength = point_txt and j = 0 then
j := 3 <*.<name>, unknown, no look ahead*>
else
if seplength = point_txt and look_ahead then
begin <*known, look ahead*>
next_seplength := scan_param (next_item);
repeat_param := true;
if entry_specifier (next_seplength, next_item, -,look_ahead) < 3 then
j := 3; <*entry name*>
end <*known, look ahead*>;
entry_specifier := j;
end entry_specifier;
\f
<* sw8010/2, load parameter interpretation page ... 46...
1981.12.09 *>
message load specifier page 1;
integer
procedure load_specifier (seplength, item);
value seplength ;
integer seplength ;
array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, de- *>
<* cided with one look ahead. *>
<* *>
<* Call : load_specifier (seplength, item); *>
<* *>
<* load_specifier (return value, integer). The kind : *>
<* 0 not <s><name> *>
<* 1 <s><name>, name = changedisc (kit) *>
<* 2 <s><name>, name = newscope *>
<* 3 <s><name>, name = disc (or kit) *>
<* 4 <s><name>, name not above or next *>
<* is .scope, .docname or *>
<* not .<name> *>
<* seplength (call value, integer). Separator < 12 *>
<* + length as for system (4, ...). *>
<* item (call value, array). An item as for *>
<* system (4, ...). *>
<* The procedure reads next param, which will be re-read *>
<* at next call of scan_param. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load parameter interpretation page ... 47...
1982.03.24 *>
message load specifier page 2;
begin
integer i, j, space_txt, next_seplength;
real array next_item (1:2);
space_txt := 4 shift 12 + 10;
j := 0;
for i := 1 step 1 until (if seplength <> space_txt then 0 else 3) do
if item (1) = real ( case i of (
<:chang:> add 'e', <:newsc:> add 'o', <:disc:> )) and
item (2) = real ( case i of (
<:disc:> , <:pe:> , <::> ))
or item (1) = real ( case i of (
<:chang:> add 'e', <:newsc:> add 'o', <:kit:> )) and
item (2) = real ( case i of (
<:kit:> , <:pe:> , <::> )) then
begin j := i; i := 3; end;
if seplength = space_txt and j = 0 then
j := 4 <*<s><name>, unknown, no look ahead*>
else
if seplength = space_txt then
begin <*name known, look ahead*>
next_seplength := scan_param (next_item);
repeat_param := true;
if entry_specifier (next_seplength, next_item, false <*no look ahead*>) < 3 then
j := 4; <*entry name*>
end <*look ahead*>;
<*curr param is <s><name> but no load spec keyword or *>
<*next param is .scope, .docname or anything but .<name>*>
load_specifier := j;
end load_specifier;
\f
<* sw8010/2, load parameter interpretation page ... 48...
1982.12.28 *>
message list specifiers page 1;
procedure list_specifiers (z, pos, n, no, spec, discname, name, scope, doc);
value pos, n, no ;
zone z ;
integer pos, n, no ;
boolean array spec ;
integer array scope ;
long array discname, name, doc ;
<*********************************************************>
<* *>
<* The procedure lists on the document connected to z *>
<* the values of the specifiers given. *>
<* *>
<* Call : list_specifiers (z, pos, n, no, spec, discname,*>
<* name, scope, doc_name);*>
<* *>
<* z (call and return value). The name, buffe- *>
<* ring and position of the document. *>
<* pos (call value, integer). The number of posi- *>
<* tions defining the left margin. *>
<* n (call value, integer). The number of load *>
<* specifiers in the call. *>
<* no (call value, integer). The max number of *>
<* different discs specified in call. *>
<* spec (call value, integer). The value of spec (i)*>
<* is true if disc number i is specified. *>
<* discname (call value, long array). Element (i,1) and *>
<* (i, 2) contain the name of disc number i. *>
<* name (call value, long array). A name is packed *>
<* in name (1:2) or name (1) = 0. *>
<* scope (call value, integer array). The scope of en-*>
<* try specifier no i in call is found in scope *>
<* (i) coded as for the procedure scan_cat. *>
<* doc (call value, long array). A docname is pack- *>
<* in doc (1:2) or doc (1) = 0. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load parameter interpretation page ... 49...
1982.12.28 *>
message list specifiers page 2;
begin
integer disc_no, curr_pos, entry_spec;
long array field disc, name_f;
write (z, <:according to following specifier:>,
if n > 1 then <:s ::> else <: ::>, "nl", 1);
for entry_spec := 1 step 1 until n do
begin <*for each entry spec*>
curr_pos :=
write (out, "nl", 1, "sp", pos, <:discs : disc:>);
for discno := 1 step 1 until no do
begin <*for each disc specified*>
disc := 8 * (entry_spec * no + discno);
if spec (entry_spec, discno) then
begin <*write discname*>
if curr_pos >= 71 then
curr_pos := write (out, ",", 1, "nl", 1, "sp", pos + 12) - 2;
curr_pos := curr_pos +
(if discname.disc (1) <> long <::> then
write (z, <:.:>, discname.disc)
else
write (z, <:.any:>));
end <*write discname*>;
end <*for each disc specified*>;
write (z, "nl", 1, "sp", pos, <:entry ::>);
name_f := 8 * entry_spec;
if name (entry_spec, 1) <> 0 then
write (z, "sp", 1, name.name_f);
if scope (entry_spec) <> 0 then
write (z, if name.name_f (1) <> 0 then <:.:> else <: :>,
<:scope.:>, case scope (entry_spec) of (
<:all:>, <:perm:>, <:system:>,<:own:>,
<:project:>, <:user:>, <:login:>, <:temp:> ));
if doc.name_f (1) <> 0 then
write (z,
if name.name_f (1) <> 0 or scope (entry_spec) <> 0 then <:.:> else <: :>,
<:docname.:>, doc.name_f );
end <*for each entry spec*>;
end list_specifiers;
\f
<* sw8010/2, load catalog scanning page ... 52...
1985.02.06 *>
message scan cat page 1;
boolean
procedure scan_cat (z , length ,
name , scope , newscope, docname ,
no_of_specs , disc_specified, discname, newdiscname,
actual_scope, spec , disc_no );
value length ,
no_of_specs ;
zone z ;
integer length ,
no_of_specs ,
actual_scope, spec , discno ;
long array name , docname ,
discname, newdiscname;
integer array scope , newscope ;
boolean array disc_specified ;
<*********************************************************>
<* *>
<* The procedure scans the save catalog for the next en- *>
<* try with name, scope, docname and discname speci- *>
<* fied in an entry specifier and returns true if such *>
<* an entry is found before the terminating empty entry. *>
<* If an entry is found, its actual scope is returned *>
<* with the entry record and the discno in the *>
<* disc name table where the name of the disc is found *>
<* is returned too, along with the index in the entry *>
<* specifier tables. *>
<* *>
<* Call : scancat (z , length , *>
<* name , scope , *>
<* newscope , docname , *>
<* no_of_specs , disc_specified, *>
<* disc_name , actual_scope , *>
<* spec , discno ); *>
<* *>
<* scan_cat (return value, boolean). True if a qualifi-*>
<* ed entry is found, false if not, which *>
<* means end of scan. *>
<* z (call and return value, zone). The name of *>
<* the save catalog. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* If the procedure returns true, the zone re-*>
<* cord contains an entry record, length hwds *>
<* long. *>
<* length (call value, integer). The length of the re-*>
<* cords in the save catalog. *>
<* name (call value, long array). A name is packed *>
<* in name (i, 1:2) or name (i, 1) = 0, mea- *>
<* ning any name, i = 1, 2, 3, ..., noofspecs.*>
<* *>
<*********************************************************>
\f
<* sw8010/2, load catalog scanning page ... 53...
1985.02.06 *>
message scan cat page 2;
<*********************************************************>
<* *>
<* scope (call value, integer array). *>
<* *>
<* scope (i), i = 1, ... means : *>
<* 0 any scope visible (base <= std *>
<* or *>
<* base >= std) *>
<* and *>
<* (base <= max *>
<* or *>
<* base >= max), any key*>
<* 1 all base <= std , -"- *>
<* 2 perm base <= std , key = 3*>
<* 3 system base = sys , -"- *>
<* 4 own any of below *>
<* 5 project base = max , key = 3*>
<* 6 user base = user, key = 3*>
<* 7 login base = std , key = 2*>
<* 8 temp base = std , key = 0*>
<* newscope (call value, integer array). cf. scope. *>
<* docname (call value, long array). A document name *>
<* packed in docname (i, 1:2) or *>
<* docname (i, 1) = 0 meaning any docname. *>
<* noofspecs (call value, integer). The number of entry *>
<* specifiers to search. *>
<* disc_specified *>
<* (call value, boolean array). cf. the pro- *>
<* cedure check_docname_discno. *>
<* disc_name (call value, long array). cf. the procedu- *>
<* new_ re check_docname_discno. *>
<* disc_name *>
<*********************************************************>
\f
<* sw8010/2, load catalog scanning page ... 53...
1984.04.25 *>
message scan cat page 3;
<*********************************************************>
<* *>
<* actual_ *>
<* scope (return value, integer). If scan_cat re- *>
<* turns true, actual_scope is the scope of *>
<* the entry found, according to below table: *>
<* 0 visible, none of below *>
<* 3 system *>
<* 5 project *>
<* 6 user *>
<* 7 login *>
<* 8 temp *>
<* If scan_cat returns false, actual_scope is *>
<* undefined. *>
<* spec (return value, integer). If the procedure *>
<* returns true, the entry specifier meeting *>
<* the demands of the entry is indexed by spec*>
<* If it returns false, spec is undefined. *>
<* discno (call and return value, integer). *>
<* If discno < 0 at call the disc where the *>
<* entry is found will not be searched or che-*>
<* cked and discno returns unchecked. *>
<* If discno >= 0 at call and the procedure *>
<* returns true, the name of the disc where *>
<* the entry belongs is found in discname *>
<* (spec, discno, 1:2) and disc_specifi- *>
<* ed (spec, discno) is true. *>
<* If discno >= 0 at call and the procedure *>
<* returns false, discno > 0 means that the *>
<* name of the disc where the entry belongs *>
<* is found in discname (spec, discno, 1:2) *>
<* and disc_specified (spec, discno) is true, *>
<* but the *>
<* docname didnt fit, while discno = 0 means *>
<* that the disc is not found or it is not *>
<* specified. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load catalog scanning page ... 53...
1984.08.27 *>
message scan cat page 4;
begin
boolean found, endcat;
integer dummy;
integer field ifld, n_scope, a_scope;
integer array field entry;
long array field laf, new_diskname;
\f
<* sw8010/2, load catalog scanning page ... 54...
1985.02.06 *>
message scan cat page 5;
entry := 0; <*fields the zone record into an integer array*>
a_scope := 38;
n_scope := 40;
new_diskname := 42;
<*find the next entry record in the save catalog which meets*>
<*the specifications of one of the specifiers recorded *>
found := false;
repeat <*until found or endcat*>
endcat := -, next_entry (z, length);
if -, endcat then
begin <*check the next entry*>
if test then
begin
write (out,
"nl", 2, <:scan cat ::>,
"nl", 1, <:entry = :>);
listentry (out, false, z.entry, z.ascope, z.ascope, z.nscope, 0);
end;
change_entry (z.entry, z.a_scope, z.n_scope, z.new_diskname, true <*dump*>);
<*change the entry according to dump specifiers*>
for i := 1 step 1 until no_of_specs do
begin <*search entry specifier*>
laf := 8 * i;
ifld := 2 * i;
found := checkname (z.entry, name.laf);
<*found <=> name fits*>
if test then
write (out, "nl", 1, <:entry spec = :>, i,
<:name :>, if found then <:found :> else <:failed :>);
if found then
found :=
check_scope (z.entry, scope.ifld, actual_scope, newscope.ifld);
<*found <=> name and scope fits*>
if test then
write (out,
<:scope :>, if found then <:found :> else <:failed :>);
if found then
found :=check_docname_discno (z.entry, docname.laf, i, discno,
discspecified, discname, new_discname);
<*found <=> name, scope, docname and discname fits*>
if test then
write (out,
<:docname :>, if found then <:found:> else <:failed:>);
if found then
begin
spec := i ;
i := no_of_specs;
end;
end <*search for entry specifier*>;
end <*-, endcat*>;
until found or endcat;
scan_cat := found;
end scan_cat;
\f
<* sw8010/2, load catalog scanning page ... 55...
1984.08.28 *>
message next entry page 1;
boolean
procedure next_entry (z, length);
value length ;
zone z ;
integer length ;
<**********************************************************>
<* *>
<* The procedure transfers the next entry from the save *>
<* catalog and returns true. If, however, the end of the *>
<* catalog is met (zeroed entry) the procedure returns *>
<* false. *>
<* *>
<* Call : next_entry (z, length); *>
<* *>
<* next_entry (return value, boolean). False if end of *>
<* catalog is met, true otherwise. *>
<* z (call and return value, zone). The name of *>
<* catalog. Determines further the document, *>
<* the buffering and the position of the docu-*>
<* ment. *>
<* length (call value, integer). The length of the *>
<* entry record wanted. *>
<* *>
<**********************************************************>
begin
\f
<* sw8010/2, load catalog scanning page ... 56...
1984.08.28 *>
message next entry page 2;
boolean end_of_cat;
integer hw;
long array field laf;
laf := 0;
hw := inrec6 (z, 0);
if hw >= length then
begin <*next entry record available in zone, maybe empty*>
inrec6 (z, length);
end_of_cat := z.laf (1) = long <::>
end else
if hw = 512 mod length then
begin <*end of segment*>
inrec6 (z, hw);
end_of_cat := -, next_entry (z, length)
end else
system (9) rs alarm :(hw, <:<10>save cat:>); <*catalog io error*>
next_entry := -, end_of_cat;
end next_entry;
\f
<* sw8010/2, load catalog scanning page ... 56...
1981.12.09 *>
message check name page 1;
boolean
procedure check_name (entry, name);
integer array entry ;
long array name ;
<**********************************************************>
<* *>
<* The procedure returns true if the name of the entry *>
<* given equals the name given and is neither c nor v nor *>
<* primout with associated permkeys (0 and 2 resp.). *>
<* *>
<* Call : check_name (entry, name); *>
<* *>
<* check_name (return value, boolean). True if the en- *>
<* try name in entry (4:7) equals the name *>
<* packed in name (1:2) or name (1) = 0, mea-*>
<* ning any name, and the name is neither c *>
<* nor v with permkey 0, nor is it primout *>
<* with permkey 2. *>
<* entry (call value, integer array). An entry *>
<* head and tail is packed in entry (1:17). *>
<* name (call value, long array). A name is pack- *>
<* ed in name (1:2) or name (1) = 0, meaning *>
<* any name. *>
<* *>
<**********************************************************>
begin
integer permkey;
long array field name_f;
permkey := entry (1) extract 3;
name_f := 6; <*fields entry name in entry*>
check_name :=
(name (1) = 0
or name (1) = entry.name_f (1) and
name (2) = entry.name_f (2)) and
<*not c, v or primout*>
((entry.name_f (1) <> long <:c:> and
entry.name_f (1) <> long <:v:> or permkey <> 0) and
(entry.name_f (1) <> long <:primo:> add 'u' or
entry.name_f (2) <> long <:t:> or permkey <> 2));
end check_name;
\f
<* sw8010/2, load catalog scanning page ... 57...
1984.07.10 *>
message check scope page 1;
boolean
procedure check_scope (entry, scope, actual_scope, newscope);
value scope, newscope ;
integer array entry ;
integer scope, actual_scope, newscope ;
<**********************************************************>
<* *>
<* The procedure checks whether the scope of a given en- *>
<* try fits the scope given and returns true if it does, *>
<* in any case with the actual scope of the entry. *>
<* *>
<* Call : check_scope (entry, scope, actual_scope); *>
<* *>
<* check_scope (return value, boolean). True if scope *>
<* fits, false otherwise. *>
<* entry (call value, integer array). The entry *>
<* to be checked is contained in entry *>
<* (1:17). *>
<* scope (call value, integer). The scope given *>
<* as for the procedure scan_cat. *>
<* actual_scope (return value, integer). The actual sco- *>
<* pe as for the procedure scan_cat. *>
<* newscope (call value, integer). If actualscope = *>
<* newcope = 0 and scope <>1 and scope <> 2 *>
<* the procedure must return false even if *>
<* the scope fits as the program load wont *>
<* to find an entry with zero scopekey. *>
<* *>
<**********************************************************>
begin
integer permkey, dummy, i;
integer field scope_key, n_scope_key, a_scope_key;
integer array field base;
base := 2; <*fields entry base in entry record*>
__scope_key := 36; <* - - scope - - - *>
a_scope_key := 38; <* - - actual scope - *>
n_scope_key := 40; <* - - new scope - *>
\f
<* sw8010/2, load catalog scanning page ... 58...
1984.11.01 *>
message check scope page 2;
permkey := entry (1) extract 3;
if entry.scopekey = 1
or entry.scopekey = 2 then
begin <*dumped by scope all or scope perm*>
actual_scope := 0; <*none of below*>
for i := 3, 5, 6, 7, 8 do
if entry.base (1) = ( case i of (
dummy, dummy ,
sys__base (1),
dummy ,
max__base (1),
user_base (1),
std__base (1),
std__base (1) ) ) and
entry.base (2) = ( case i of (
dummy, dummy ,
sys__base (2),
dummy ,
max__base (2),
user_base (2),
std__base (2),
std__base (2) ) ) and
perm_key = ( case i of (
dummy, dummy ,
3 ,
dummy,
3 ,
3 ,
2 ,
0 ) ) then
actual_scope := i;
<*notice : if case i true and case j true and i < j then*>
<*actual_scope := j, which means that if two scopes are *>
<*identical, actual_scope becomes the lower one *>
end else
<*scope key*>
actual_scope :=
if entry.n_scope_key = 0 then
entry.a_scope_key
else
entry.n_scope_key;
\f
<* sw8010/2, load catalog scanning page ... 59...
1984.11.20 *>
message check scope page 3;
check_scope :=
(case (scope + 1) of (
if entry.scopekey = 1 <*saved by scope.all *>
or entry.scopekey = 2 <*saved by scope.perm*> then
(entry.base (1) >= std_base (1) and
entry.base (2) <= std_base (2) <*in std*>
or
entry.base (1) <= std_base (1) and
entry.base (2) >= std_base (2)) <*out std*>
and
entry.base (1) >= max_base (1) and
entry.base (2) <= max_base (2) <*in max*>
else
actual_scope > 0 <*scope > 0*> , <*any act*>
entry.base (1) >= std_base (1) and
entry.base (2) <= std_base (2) , <*all *>
entry.base (1) >= std_base (1) and
entry.base (2) <= std_base (2) and perm_key = 3, <*perm *>
actual_scope = scope <*scope = 3*> , <*system *>
actual_scope > scope <*scope = 4*> , <*own *>
actual_scope = scope <*scope = 5*> , <*project*>
actual__scope = scope <*scope = 6*> , <*user *>
actual_scope = scope <*scope = 7*> , <*login *>
actual_scope = scope <*scope = 8*> ));<*temp *>
end check_scope;
\f
<* sw8010/2, load catalog scanning page ... 60...
1985.02.06 *>
message check docname discno page 1;
boolean
procedure check_docname_discno (entry, docname, entry_spec , discno ,
discspecified, discname ,
new_discname );
integer array entry ;
long array docname,
discname ,
new_discname ;
integer entry_spec , discno ;
boolean array discspecified ;
<**********************************************************>
<* *>
<* The procedure returns true if the document name and *>
<* the disc name of the entry given both equal the docu- *>
<* ment name and the disc name given in discname (entry_ *>
<* spec, 1:no_of_discs+no_of_unknown_discs, 1:2) of a *>
<* disc specified in discspecified (entry_spec, no_of_ *>
<* discs+no_of_unknown_discs). *>
<* *>
<* Call: check_docname_discno (entry, docname, discno) *>
<* *>
<* check_docname_discno (return value, boolean). True *>
<* if : *>
<* - the document bame of the en- *>
<* try packed in entry (9:12) e- *>
<* quals the document name pack- *>
<* ed in docname (1:2) or doc- *>
<* name (1) = 0 *>
<* and *>
<* - the name of the disc packed in*>
<* new discname field of the en- *>
<* try eqals a name *>
<* packed in discname (1:no_ *>
<* of_discs + no_of_unknowndiscs,*>
<* 1:2) and the disc *>
<* is specified in discspecified *>
<* (1:noofdiscs+noofunknowndiscs)*>
<* entry (call value, integer array). *>
<* See above. *>
<* docname (call value, long array). *>
<* See above. *>
<* entry_spec (call value, integer). The no *>
<* of the entry specifier checked*>
<* and the index in discname (1: *>
<* no_of_entry_specs, 1:no_of_ *>
<* discs+no_of_unknown_discs,1:2)*>
<* to check. *>
<* *>
<**********************************************************>
\f
<* sw8010/2, load catalog scanning page ... 61...
1985.02.06 *>
message check docname discno page 2;
<**********************************************************>
<* *>
<* discno (call and return value, int). *>
<* If discno < 0 at call, the *>
<* disc where the entry belongs *>
<* is not searched or checked and*>
<* discno returns unchanged. *>
<* If discno >= 0 at call and *>
<* the procedure returns true, *>
<* discno > 0 and the name of the*>
<* disc where entry belongs is *>
<* found in discname (entry_spec,*>
<* discno, 1:2) *>
<* and disc_specified (entryspec,*>
<* discno) is *>
<* true. *>
<* If discno >= 0 at call and *>
<* the procedure returns false *>
<* discno > 0 means that the name*>
<* of the disc where the entry *>
<* belongs is found in discname *>
<* (entry_spec, discno, 1:2) and *>
<* disc_specified (entry_spec, *>
<* discno) is true, but the *>
<* docname <> 0 and is not the *>
<* docname of the entry. If disc-*>
<* no = 0, the disc is either not*>
<* specified or it is not found *>
<* in disc name table. *>
<* disc_specified (call value, boolean array). *>
<* cf. above. *>
<* disc_name (call value, long array). *>
<* new_ cf. above. *>
<* disc_name *>
<**********************************************************>
\f
<* sw8010/2, load catalog scanning page ... 61...
1985.02.06 *>
message check docname discno page 3;
begin
integer i, j;
integer field size;
long array field doc, disc, new_diskname;
size := doc := 16; <*field size and document name in entry*>
new_diskname := 42; <* - new disc name field - - *>
if discno >= 0 then
begin <*check the name of the disc holding the entry*>
j := 0;
for i := 1 step 1 until no_of_discs + no_of_unknown_discs do
begin <*search the name of the disc in discname table*>
disc := 8 * (entry_spec * (no_of_discs + no_of_unknown_discs) + i);
if discspecified (entry_spec, i) and
(discname.disc (1) = entry.new_diskname (1) and
discname.disc (2) = entry.new_diskname (2)
or discname.disc (1) = long <::> ) then
begin
j := i;
if discname.disc (1) = long <::> and
new_discname.disc (1) = long <::> then
<*any disc ok*>
for i := 1, 2 do
new_discname.disc (i) := entry.new_diskname (i);
i := no_of_discs + no_of_unknown_discs;
end;
end <*search*>;
discno := j; <* 0 means not found or not specified*>
end <*find disc holding the entry*>;
check_docname_discno :=
(docname (1) = 0
or docname (1) = entry.doc (1) and
docname (2) = entry.doc (2)) and
(discno <> 0 ) ;
end check_docname_discname;
\f
<* sw8010/2, load base handling page ... 62...
1982.02.04 *>
message set_catbase page 1;
procedure set_catbase (base);
integer array base ;
<***********************************************************>
<* *>
<* The procedure changes the catalog base of own process *>
<* to the base given. *>
<* If the result becomes 4 : new base illegal, it is sup- *>
<* posed that the new base is outside the max base of the *>
<* process and the procedure will set cat base to max base.*>
<* *>
<* Call : set_catbase (entry); *>
<* *>
<* base (call value, integer array). The new base *>
<* in base (1:2). *>
<* *>
<***********************************************************>
begin
own
boolean called_before;
integer i;
integer array own_bases (1:8);
integer result;
integer array field max;
zone z (1, 1, stderror);
if -,called_before then
begin
called_before := true;
reset_catbase; <*init reset catbase*>
end;
open (z, 0, <::>, 0); <*own process*>
close (z, true);
for i := 1, 2 do own_bases (i) := base (i);
<*to avoid fielding in call of system*>
result := monitor (72, z, 0, own_bases);
if result = 4 then
begin <*outside max*>
max := 12; <*fields max base in own_bases (7:8)*>
system (11 )bases:( 0, own_bases);
set_catbase (own_bases.max);
end <*outside max*> else
if result <> 0 then
system (9, result, <:<10>cat base:>);
end set_catbase;
\f
<* sw8010/2, load base handling page ... 63...
1982.02.04 *>
message reset catbase page 1;
procedure reset_catbase;
<***********************************************************>
<* *>
<* The procedure resets the catbase of own process *>
<* to the original catbase before the first change *>
<* of catbase by a call of set_catbase. *>
<* *>
<***********************************************************>
begin
own
boolean called_before;
own
integer catbase_lower, catbase_upper;
if -,called_before then
begin <*save catbase and init branch*>
called_before := true;
catbase_lower := catbase (1);
catbase_upper := catbase (2);
reset_catbase;
end else
begin <*set catbase*>
integer array catbase (1:2);
catbase (1) := catbase_lower;
catbase (2) := catbase_upper;
set_catbase (catbase);
end <*set catbase*>;
end reset_catbase;
\f
<* sw8010/2, load base handling page ... 64...
1981.12.09 *>
message bases page 1;
procedure bases (cat_base, std_base, user_base, max_base, sys_base);
long array cat_base, std_base, user_base, max_base, sys_base ;
<**********************************************************>
<* *>
<* The procedure gets the cat-, std-, user- and max_bases *>
<* of the process together with the system_base and re- *>
<* turns them in the parameters. *>
<* *>
<* Call : bases (cat_base, std_base, user_base, max_base, *>
<* sys_base);*>
<* *>
<* cat_base, std_base, user_base, max_base, sys_base : *>
<* (call values, long arrays). Will at return contain *>
<* the respective bases in the first two words. *>
<* Since the type is long, base comparison will not give *>
<* integer exception. *>
<* *>
<**********************************************************>
begin
integer array ia (1:8);
system (11, 1, ia);
cat__base (1) := ia (1); cat__base (2) := ia (2);
std_base (1) := ia (3); std__base (2) := ia (4);
user_base (1) := ia (5); user_base (2) := ia (6);
max__base (1) := ia (7); max__base (2) := ia (8);
sys__base (1) := -8388607;
sys__base (2) := 8388605;
end bases;
\f
<* sw8010/2, load save catalog head page ... xx...
1984.07.10*>
message in savecat head page 1;
integer
procedure in_savecat_head (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure inputs a number of segments containing a *>
<* save catalog head from the document connected to the *>
<* zone z. *>
<* *>
<* Call : in_savecat_head (z); *>
<* *>
<* in_savecathead (return value, integer). The number of *>
<* blocks input (= segments). *>
<* z (cal and return value, zone). Determi- *>
<* nes the document, the buffering and *>
<* the position of the document. *>
<* The block length must be one segment *>
<* and the zone opened to a magnetic tape.*>
<* At return the zone is positioned to *>
<* the next block after the catalog *>
<* head. *>
<* *>
<* A number of global values are input from their fields *>
<* of the catalog head and *>
<* the next block number returned as no of blocks input. *>
<* *>
<***********************************************************>
begin
integer discno, copy, volume, file, block;
<*local dummies*>
integer local_no_of_discs, local_max_no_of_vol,
local_copy_count , local_vol_count ;
long array local_tapename (1:2);
integer field ifld;
long array field disc, current_tape;
\f
<* sw8010/2, load save catalog head page ... xx...
1987.04.29 *>
message in savecat head page 2;
local_vol__count := vol__count (copy_count); <*save global vol__count*>
local_copy_count := copy_count ; <*- - copy_count*>
current_tape := name_field (copy_count , vol_count);
for i := 1, 2 do
local_tapename (i) := tapename.current_tape (i); <*save gl tapename*>
inrec6 (z, 28); <*first 28 halfs of head*>
tofrom (dumpbases, z, 16); <*move dumpbases from zone record*>
ifld := 16 + 2; local_no_ofdiscs := z.ifld;
ifld := ifld + 2; local_maxnoofvol := z.ifld;
ifld := ifld + 2; no_of_copies := z.ifld;
ifld := ifld + 2; no_of_vol (1) := z.ifld;
ifld := ifld + 2; no_of_vol (2) := z.ifld;
ifld := ifld + 2; segm := z.ifld;
if local_maxnoofvol <> max_noofvol then
terminate_alarm (out,
<:max no of volumes in save catalog incompatible with load program:>,
local_tapename, max_noofvol, <: in save catalog : :>, local_maxnoofvol);
for discno := 1 step 1 until local_no_of_discs do
begin <*discnames*>
<*disc := 8 * discno;*>
in_rec6 (z, 8);
<*tofrom (z, discname.disc, 8);*>
end;
for copycount := 1 step 1 until 2 do
for volume := 1 step 1 until max_no_of_vol do
begin <*tapenames*>
vol_count (copy_count) := volume;
current_tape := namefield (copy_count, vol_count);
in_rec6 (z, 8);
tofrom (tapename.current_tape, z, 8);
end;
stopzone (z, false );
getposition (z, file, block);
setposition (z, file, block);
for copy := 1 step 1 until no_of_copies do
for volume := 1 step 1 until no_of_vol (copy) do
begin <*find saved tapename among new tapenames*>
copy_count := copy ;
vol__count (copy_count) := volume;
current_tape := name_field (copy_count, vol_count);
if tapename.current_tape (1) = local_tapename (1) and
tapename.current_tape (2) = local_tapename (2) then
begin <*found, stop search*>
copy := no_of_copies;
volume := no_of_vol (copy);
end;
file__no (copy_count) := file__no (local_copycount);
block_no (copy_count) := block_no (local_copycount);
end <*find saved tapename*>;
in__savecathead := block;
end in_savecat_head;
\f
<* sw8010/2, load store entries page ... xx...
1984.07.10 *>
message store entries page 1;
integer
procedure store_entries (zto , zfrom , length ,
name , scope , newscope, docname ,
noofspecs, disc_specified, discname, new_discname);
value length ,
noofspecs ;
zone zto , zfrom ;
integer length ,
noofspecs ;
integer array scope , newscope ;
boolean array disc_specified ;
long array name , docname ,
discname, new_discname ;
<*********************************************************>
<* *>
<* The procedure scans the catalog connected to the zone *>
<* zfrom to find entry records with entries belonging to *>
<* the discs specified which have the proper name, scope *>
<* and document name, all according to one entry speci- *>
<* fier. *>
<* For each entry found, a record with the entry together*>
<* with an extension with room for scope, actual scope, *>
<* new scope, new disc name and one or two sets of volu- *>
<* me number, file number and block number are stored *>
<* in the catalog connected to the zone zto. *>
<* *>
<* call : *>
<* store_entries (zfrom, zto , copies, *>
<* name , scope , newscope, docname, *>
<* no_of_recs); *>
<* *>
<* storeentries (return value, integer). The number of *>
<* entries found in the save catalog be- *>
<* longing to a disc specified and satis- *>
<* fying the name, scope, document name *>
<* specifiers of one of the entry speci- *>
<* fiers in the call. *>
<* zto, zfrom (call and return value, zone). The name *>
<* of the document, the buffering and the *>
<* position of the document where to store *>
<* or get the entries. *>
<* The zone state is supposed to be ready *>
<* for outrec and is left the same. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load store entries page ... xx...
1984.08.10 *>
message store entries page 2;
<*********************************************************>
<* *>
<* length (call value, integer). The length of the*>
<* record to store away. *>
<* name (call value, long array). Either a name *>
<* is given in name (i, 1:2) or name (i, 1)*>
<* = 0, meaning any name. *>
<* scope (cal value, integer array). *>
<* Either scope (i) contains a scope value*>
<* or scope (i) = 0 meaning any scope. *>
<* newscope (call value, integer array). *>
<* Either newscope (i) contains the new *>
<* scope given or newscope (i) = 0, meaning*>
<* no change of scope. *>
<* doc_name (call value, long array). Either doc- *>
<* name (i, 1:2) contains a document name *>
<* or doc_name (i, 1) = 0 meaning any docu-*>
<* ment name. *>
<* no_of_specs (call value, integer). The number of en-*>
<* try specifications to search. *>
<* discspecified (call value, boolean array). cf. the *>
<* cedure check_docname_discno. *>
<* discname *>
<* new_ *>
<* discname (call value, long array). cf. the pro- *>
<* cedure check_docname_discno. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load store entries page ... xx...
1984.07.10 *>
message store entries page 3;
begin
integer discno, actual_scope, entries_stored, spec;
integer field scop, act_scop, new_scop, disk_no;
long array field disc, new_diskname;
scop := 36; <*fields scope in entry record*>
act_scop := scop + 2; <*- sctual scope - - *>
new_scop := act_scop + 2; <*- new scope - - *>
disk_no := new_scop + 2; <*- discno - - - *>
new_diskname := disk_no ; <*- new discname - - *>
\f
<* sw8010/2, load store entries page ... xx...
1985.02.06 *>
message store entries page 4;
entries_stored := 0; <*local total entry count*>
disc_no := 0; <*disc holding candidate entries are checked*>
while
scan_cat (zfrom , length ,
name , scope , newscope, docname,
no_of_specs, disc_specified, discname, newdiscname,
actualscope, spec , disc_no )
do
begin <*the next entry is found in zfrom and is specified by spec*>
outrec6 (zto, length);
to_from (zto, zfrom, length); <*move entry record*>
zto.act_scop := actual_scope ;
zto.new_scop := new____scope (spec);
zto.disk_no := disc_no ;
disc := 8 * (spec * (no_of_discs + no_of_unknown_discs) + discno);
to_from (zto.new_diskname, new_discname.disc, 8); <*move new disc name*>
entries_stored := entries_stored + 1;
if test then
begin
integer array field entry;
entry := 0;
write (out,
"nl", 2, <:store entries : :>,
"nl", 1, <:entry : :>);
listentry (out, false, zto.entry, zto.scop, zto.actscop, zto.newscop, 0);
end;
end <*the next entry record is found in zfrom specified by spec*>;
store_entries := entries_stored;
end store_entries;
\f
<* sw8010/2, load load entries page ... 65...
1984.07.10 *>
message load entries page 1;
integer
procedure load_entries ( za , copy_count, copies , vol_count ,
zcat , cat_name , entries_cat, reclength ,
zpart, partname , entriespart, loadsegs );
value copies ,
entries_cat, reclength ,
entriespart ;
zone array za ;
integer copy_count, copies ,
entries_cat, reclength ,
entriespart, loadsegs ;
integer array vol_count ;
zone zcat ,
zpart ;
long array cat_name ,
partname ;
<*********************************************************>
<* *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load load entries page ... 66...
1984.09.12 *>
message load entries page 2;
begin
integer entries_input, result, entries_ready, entries_loaded,
segs_loaded, segments, j, partcat_volume, partcat_block,
partcat_size, discno;
integer field size, scop, act_scop, new_scop, disk_no, changed,
vol, file, block;
integer array field entry, base;
long array field name, new_diskname;
boolean skipped_area_entry, entry_found;
zone zhelp (1, 1, stderror);
\f
<* sw8010/2, load load entries page ... 67...
1984.07.10 *>
message load entries page 3;
entry := 0; <*fields entry head in zcat record*>
base := 2; <*fields entry base in zcat record*>
name := 6; <*fields entry name in zcat record*>
size := 16; <*fields entry size in zcat record*>
scop := 36;
act_scop := scop + 2;
new_scop := act_scop + 2;
disk_no := new_scop + 2;
new_diskname := disk_no;
changed := new_diskname + 10;
trap (remove_wrk_entry);
vol := case copy_count of (54, 60);
file := vol + 2 ;
block := file + 2 ;
entries_loaded :=
segs____loaded := 0; <*local total counters*>
partcat_size := (entries_part + 14) // 15;
open (zcat, 4, catname, 0);
setposition (zcat, 0, 0);
partname (1) := long <::>;
result := connect_output (zpart, 4, partname, partcat_size, 0);
if result > 0 then
connect_alarm (out, partname, result)
else
begin <*area and process created, zpart connected*>
<*remove fp area process*>
open (zhelp, 4,<:fp:>, 0);
close (zhelp, true);
<*prepare partial catalog*>
setposition (zpart, 0, partcat_size);
disconnect_output (zpart, false); <*cut down, dont remove process*>
\f
<* sw8010.1, save load entries page ... xx...
1984.09.12 *>
message load entries page 4;
open (zpart, 4, partname, 0); <*reopen*>
setposition (zpart, 0, 0);
partcat_volume := vol_count (copy_count);
partcat_block := 0 ;
entries_ready := entries_part ; <*ensures xfer part*>
entries_input := 0;
while entries_input < entries_cat do
begin <*next entry record from load cat*>
inrec6 (zcat, reclength);
entries_input := entries_input + 1;
<* zcat.vol = 0 : already positioned *>
<* zcat.vol <> 0 and *>
<* (zcat.vol <> partcat_volume *>
<*or zcat.block <> partcat_block) : position to new *>
if zcat.vol <> 0 and
(zcat.vol <> partcat_volume
or zcat.block <> partcat_block) and
-, survey then
begin <*position to new partial catalog*>
if zcat.vol <> partcat_volume then
begin <*proper volume*>
if zcat.vol = vol_count (copy_count) then
partcat_volume := zcat.vol <*no change of volume*>
else
begin <*change of volume*>
partcat_volume :=
vol_count (copy_count) := zcat.vol;
fileno (copy_count) := zcat.file;
blockno (copy_count) := 0;
next_volume (za (1), copy_count, vol_count, fileno, blockno);
end <*change of volume*>;
end <*proper volume*>;
fileno (copy_count) := zcat.file ;
partcat_block :=
blockno (copy_count) := zcat.block;
setposition (za (1), zcat.file, zcat.block);
entries_ready := entries_part; <*prepare transfer of partcat*>
end <*position to new partial catalog*>;
\f
<* sw8010/2, load load entries page ... xx...
1978.04.29 *>
message load entries page 5;
repeat <*until entry found*>
if entries_ready = entries_part and
-, survey then
begin <*positioned at next part cat, transfer it*>
open (za (2), 4, partname, 0);
setposition (za (1), fileno (copycount), blockno (copycount));
if test then
write (out,
"nl", 1, <:file, block = :>,
<< ddd>, fileno (copycount), blockno (copycount));
if version_id = 2 and
release_id > 1 shift 12 then
begin <*skip until sync block*>
check (za (1)); <*check position operation*>
open__inout (za, 1);
expellinout (za, 2);
repeat
j :=
inoutrec (za, 0);
inoutrec (za, j);
if test then
write (out,
"nl", 1, <:blocklength = :>, j);
until j = sync_blocklength;
stopzone (za (1), false);
getposition (za (1), fileno (copy_count), blockno (copy_count));
closeinout (za);
setposition (za (1), fileno (copy_count), blockno (copy_count));
setposition (za (2), 0 , 0 );
if test then
write (out,
"nl", 1, <:file, block = :>,
<< ddd>, fileno (copycount), blockno (copycount));
end <*skip until sync block*>;
segments :=
transfer (za, copy_count, copies, fileno, blockno,
partcat_size, end_of_doc, false <*expell*>);
if segments <> partcatsize then
continue_warning (out,
<:incomplete partial catalog transferred from tape:>,
partcatname, partcatsize, <: transferred : :>, abs (segments));
setposition (zpart, 0, 0); <*reposition zpart*>
entries_ready := 0;
end <*positioned at next part cat, transfer it*>;
if survey then
begin <*dummy record*>
setposition (zpart, 0, 0);
inrec6 (zpart, 34);
tofrom (zpart, zcat, 34);
end else
inrec6 (zpart, 34);
entries_ready := entries_ready + 1;
skipped_area_entry := zpart.size > 0 and
zpart.entry (1) shift (-12) = 0;
entry_found := zpart.base (1) = zcat.base (1) and
zpart.base (2) = zcat.base (2) and
zpart.name (1) = zcat.name (1) and
zpart.name (2) = zcat.name (2) ;
<*survey => entry_found*>
if test then
begin
write (out,
"nl", 2, <:entries input, ready, cat, part = :>,
entriesinput, entriesready, entriescat, entriespart,
"nl", 1, <:zcat.vol, block, partvol, block = :>,
zcat.vol, zcat.block, partcatvolume, partcatblock,
"nl", 1, <:skipped area entry = :>,
if skippedareaentry then <:true:> else <:false:>,
"nl", 1, <:entry found = :>,
if entryfound then <:true:> else <:false:>,
"nl", 1, <:entry : :>);
listentry (out, false, zpart.entry, zcat.actscop, zcat.actscop,
zcat.newscop, 0);
end;
if entry_found then
change_entry (zpart.entry, zcat.act_scop , zcat.new_scop ,
zcat.new_diskname, false <*not dump*>);
\f
<* sw8010/2, load load entries page ... xx...
1984.11.08 *>
message load entries page 6;
if entry_found and
load then
begin <*entry found and to be loaded (survey => -,load)*>
if skipped_area_entry then
begin
open (za (2), 4, zpart.name, 0);
result := 7;
end else
result :=
connect_wrk_or_existing (za (2), zpart.entry,
z_cat.new_diskname, connect);
end <*entry found*> else
begin <*not entry found (maybe empty) or it should not be loaded*>
open (za (2), 4, zpart.name, 0);
result :=
if skipped_area_entry then
7
else
0;
end <*not entry found*>;
if entry_found and
list_entries then
begin
if result > 0 then
skip_entry (out, list_only_name, zpart.entry,
zcat.scop, zcat.actscop, zcat.newscop,
zcat.changed, result )
else
list_entry (out, list_only_name, zpart.entry,
zcat.scop, zcat.actscop, zcat.newscop,
zcat.changed);
end;
\f
<* sw8010/2, load load entries page ... 70...
1987.04.29 *>
message load entries page 6;
if zpart.size > 0 then
begin <*transfer possibly empty area with or without output*>
if survey then
segments := if skipped_area_entry then 0 else zpart.size
else
begin <*not survey*>
if aux_synclength > 0 and -, skipped_area_entry then
blockno (copycount) := blockno (copycount) + 1;
setposition (za (1), fileno (copycount), blockno (copycount));
segments :=
transfer (za, copy_count, copies, fileno, blockno,
if skipped_area_entry then 0 else zpart.size,
end_of_doc,
-,entry_found or -,load or result > 0 <*expell*>);
end <*not survey*>;
end else
segments := 0; <*not area entry*>
if zpart.size > 0 and
-, skipped_area_entry and
result = 0 and
zpart.size <> abs (segments) then
begin <*warning and correct zpart.size*>
continue_warning (out,
if zpart.size > abs (segments) then
<:warning : not all segments of area transferred from tape:>
else
<:warning : too many segments of area transferred from tape:>,
zpart.name, zpart.size, <: transferred : :>, abs (segments));
zpart.size := abs (segments);
end <*warning and correct ...*>;
if entry_found and
load and
result = 0 and
(segments >= 0
or connect ) then
result := rename_wrk (za (2), zpart.entry, discno);
close (za (2), false); <*possible area process removed by transfer*>
<*area process was removed by transfer*>
if entry_found then
begin <*update counters for entries and segments read*>
total_entry_count := total_entry_count + 1;
total_segm__count := total__segm_count + abs (segments);
if load and
result = 0 and
(segments >= 0
or connect ) then
begin <*update counters for entries and segments loaded*>
segments := abs (segments);
slice_count (discno) :=
slice_count (discno) +
(segments +
slicelength (discno) - 1)//
slicelength (discno) ;
segs____loaded := segs____loaded + segments;
entries_loaded := entries_loaded + 1;
entry_count (discno) := entry_count (discno) + 1;
end <*update counters for entries and segments loaded*>;
end <*update counters for entries and segmentst read*>;
until entry_found;
end <*while entries_input < entries_cat*>;
end <*partial catalog connected*>;
close (zpart, true); <*remove part catalog area process*>
close (zcat , true); <*remove save catalog area process*>
load_segs := segs____loaded;
load_entries := entries_loaded;
if false then
remove_wrk_entry:
begin
<*fjern entry hvis docname i za(2) er forskellig fra
name i zpart.entry d.v.s. docname i zone er et wrk-navn *>
integer array zd (1 : 20);
long array field docname;
maybe_device_status (out);
docname := 2;
getzone (zpart, zd);
if zd (13) = 5 <*after inrec*> then
begin
getzone_6 (za (2), zd);
for j := 1 step 1 until 2 do
if zpart.entry.name (j) <> zd.docname (j) then
begin
set_catbase (zpart.entry.base);
monitor (48)remove_entry:(za (2), 1, zd);
j := 2;
reset_catbase;
end;
end;
trap (1);
end; <*remove_wrk_entry*>
end load_entries;
\f
<* sw8010/2, load entry handling page ... 72...
1984.07.10 *>
message change entry page 1;
procedure change_entry (entry, actual_scope, new_scope, new_discname, dump);
value actual_scope, new_scope ;
integer array entry ;
integer actual_scope, new_scope ;
long array new_discname ;
boolean dump ;
<*********************************************************>
<* *>
<* The procedure changes parts of the entry head and *>
<* tail specified according to the parameters. *>
<* *>
<* Call : change_entry (entry, actual_scope, new_scope, *>
<* new_discname, dump ); *>
<* *>
<* entry (call value, integer array). An entry *>
<* head and tail is stored in entry (1:17). *>
<* actual_scope (call value, integer). The actual scope *>
<* of the entry : *>
<* 0 : visible, none of below *>
<* 3 : system *>
<* 5 : project *>
<* 6 : user *>
<* 7 : login *>
<* 8 : temp *>
<* new_scope (call value, integer). The new scope wan-*>
<* ted, coded as for actual_scope, zero mea-*>
<* ning no change of scope. *>
<* If new_scope <> 0 and new_scope <> actu- *>
<* al_scope the permkey and entry base of *>
<* the entry is changed accordingly. *>
<* new_discname (call value, long array). *>
<* If the entry is an area entry, the docu- *>
<* ment name in the tail of the entry is *>
<* changed (maybe no change) to the name gi-*>
<* ven in the long array new_discname (1:2).*>
<* dump (call value, boolean). If true, the bases*>
<* recorded in the global integer array *>
<* dumpbases are used, else the process ba- *>
<* ses. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load entry handling page ... 73...
1984.11.20 *>
message change entry page 2;
begin
integer i, act_key, dummy, target_scope;
long array cat_base, std_base, user_base, max_base, sys_base,
act_base (1:2);
integer field permkey, size;
integer array field base;
long array field docname;
permkey := 2; <*fields permkey in head*>
base := 2; <* -"- base (1:2) -"- *>
size := 16; <* -"- size in tail*>
doc_name := 16; <* -"- docname -"- *>
target_scope :=
if new_scope <> 0 and new_scope <> actual_scope then
new____scope
else
actual_scope;
if target_scope > 0 then
begin <*change permkey and base in head*>
bases (cat_base, std_base, user_base, max_base, sys_base); <*proc bases*>
if dump then
begin <*dumpbases*>
for i := 1, 2 do
begin
cat__base (i) := dumpbases (i );
std__base (i) := dumpbases (2 + i);
user_base (i) := dumpbases (4 + i);
max__base (i) := dumpbases (6 + i);
end;
end <*dumpbases*>;
act_key := case target_scope of (
<*dummy *> dummy, <*dummy *> dummy, <*system *> 3,
<*dummy *> dummy, <*project*> 3, <*user *> 3,
<*login *> 2, <*temp *> 0 );
for i := 1, 2 do
act_base (i) := case target_scope of (
dummy , dummy , sys__base (i),
dummy , max_base (i), user_base (i),
std_base (i ), std_base (i) );
entry.permkey :=
entry.permkey shift (-3) shift 3 add act_key;
for i := 1, 2 do
entry.base (i) := act_base (i);
end <*change permkey and base in head*>;
<*change tail*>
if entry.size >= 0 then
for i := 1, 2 do
entry.docname (i) := new_discname (i);
end change_entry;
\f
<* sw8010/2, load entry handling page ... 74...
1984.06.07 *>
message list entry page 1;
procedure list_entry (z, nameonly, entry, scope, act_scope, newscope ,
changed );
value scope, act_scope, newscope ,
changed ;
zone z ;
boolean nameonly ;
integer array entry ;
integer scope, act_scope, newscope ,
changed ;
<*********************************************************>
<* *>
<* The procedure lists on the zone z the entry given on *>
<* the form : *>
<* (name) (size/modekind) (permkey/scopekey).(docname) *>
<* (entry base) (shortclock) *>
<* *>
<* Call : list_entry (z, nameonly, entry, scope, *>
<* act_scope, newscope) *>
<* *>
<* z (call and return value, zone). The name of *>
<* the document. Determines further the docu- *>
<* ment, the buffering and the position of *>
<* the document. *>
<* nameonly (call value, boolean). If nameonly is true *>
<* the procedure returns after having listed *>
<* the name of the entry. *>
<* entry (call value, integer array). Contains an *>
<* entry head and tail in entry (1:17). *>
<* If it is not an algol/fortran procedure *>
<* the shortclocl in the tail is listed. *>
<* scope (call value, integer). If scope equals one *>
<* or two (scope.perm or scope.all) the perm- *>
<* key is listed instead of the scopekey and *>
<* the entry base is listed too. *>
<* act_scope (call value, integer). The actual scope of *>
<* the entry, cf. scan_cat, which is listed, *>
<* i.e. if newscope = 0 (no change of scope). *>
<* newscope (call value, integer). If newscope <> 0 *>
<* (change of scope), newscope is listed as *>
<* scopekey, else act_scope is. *>
<* changed (call value, integer). Listed as short- *>
<* clock for latest changed. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load entry handling page ... 75...
1988.08.11 *>
message list entry page 2;
begin
integer modekind, scopekey;
real hhmmss;
integer field shortclock, contents, size, permkey;
integer array field base;
long array field name, docname;
permkey := 2; <*fields permkey in head*>
base := 2; <* -"- base (1:2) -"- *>
name := 6; <* -"- name -"- *>
size := 16; <* -"- size in tail*>
docname := 16; <* -"- docname -"- *>
shortclock := 26; <* -"- shortclock -"- *>
contents := 32; <* -"- contents -"- *>
write (z, "nl", 1, true, 12, entry.name);
if -,name_only then
begin <*list more*>
<*modekind*>
modekind := modekind_case (entry.size); <*no of modekind in table*>
if entry.size >= 0 then
write (z, <<__ddddd>, true, 10, entry.size)
else
if modekind = 0 then
write (z, <<dddd>, entry.size shift (-12),
<:.:>, <<dd>, true, 5, entry.size extract 12)
else
if monrelease < 80 shift 12 + 0 then
write (z, "sp", 3, true, 7, case modekind of (
<: ip:>, <: bs:>, <: tw:>, <: tro:>, <: tre:>, <: trn:>,
<: trf:>, <: trz:>, <: tpo:>, <: tpe:>, <: tpn:>, <: tpf:>,
<: tpt:>, <: lp:>, <: crb:>, <: crd:>, <: crc:>, <:mtlh:>,
<: mte:>, <:mtll:>, <:nrze:>, <:mt32:>, <:mt08:>, <:mthh:>,
<:mthl:>, <: pl:> ))
else
write (z, "sp", 3, true, 7, case modekind of (
<: ip:>, <: bs:>, <: tw:>, <: tro:>, <: tre:>, <: trn:>,
<: trf:>, <: trz:>, <: tpo:>, <: tpe:>, <: tpn:>, <: tpf:>,
<: tpt:>, <: lp:>, <: crb:>, <: crd:>, <: crc:>, <:mt62:>,
<: mte:>, <:mt16:>, <:nrze:>, <:mt32:>, <:mt08:>, <:mthh:>,
<:mthl:>, <: pl:> ));
<*permkey/scopekey . docname*>
scopekey := if newscope <> 0 then newscope else act_scope;
if scope = 1 or scope = 2 then
write (z, <<______d>, entry.permkey extract 3)
else
write (z, case (scopekey + 1) of (
<: ***:>, <::>, <::>,
<: system:>, <::>,
<:project:>,
<: user:>,
<: login:>,
<: temp:> ) );
write (z, ".", 1, true, 12, entry.docname);
\f
<* sw8010/2, load entry handling page ... 76...
1984.06.07 *>
message list entry page 3;
<*entry base*>
if scope = 1 or scope = 2 then
write (z, <<_-ddddddd>, entry.base (1), entry.base (2));
<*shortclock*>
if entry.shortclock <> 0 and
entry.contents shift (-12) <> 4 and
entry.contents shift (-12) < 32 then
write (z, <: d.:>, <<zddddd>,
systime (6) shortclock to decimal :(
entry.shortclock, hhmmss),
<:.:>, <<zddd>, entier (hhmmss/100))
else
write (z, "sp", 14);
<*latest changed*>
if changed <> 0 then write (z, <: d.:>, <<zddddd>,
systime (6) shortclock to decimal :(
changed, hhmmss),
<:.:>, <<zddd>, entier (hhmmss/100));
end <*list more*>;
end list_entry;
\f
<* sw8010/2, load entry handling page ... 77...
1984.11.08 *>
message skip entry page 1;
procedure skip_entry (z, only_name, entry, scope, actscop, newscop ,
clock , result );
value scope, actscop, newscop ,
clock , result ;
zone z ;
boolean only_name ;
integer array entry ;
integer scope, actscop, newscop ,
clock , result ;
<*********************************************************>
<* *>
<* The procedure lists an entry on the zone z the same *>
<* way list_entry does with the addition of the text : *>
<* skipped <cause> *>
<* where cause is a text explaining the result value of *>
<* create area process or reserve area process. *>
<* *>
<* Call : skip_entry (z, only_name, entry, scope, *>
<* actualscope, result);*>
<* *>
<* z (call and return value). See list_entry. *>
<* only_name (call value, boolean). -do- *>
<* entry (call value, integer array). -do- *>
<* scope (call value, integer). -do- *>
<* actscop (call value, integer). -do- *>
<* newscop (call value, integer -do- *>
<* clock (call value, integer). -do- *>
<* result (call value, integer). If result 7, the *>
<* entry was never saved and a proper mes- *>
<* sage is written, if result = 8, it is *>
<* covered by a better entry, if result is 9 *>
<* it is the result from create, permanent *>
<* or set entry base and is ignored, if right*>
<* half of result > 0 but neither of above, *>
<* it is the result of create area process, *>
<* if left half > 0 it is the result of re- *>
<* serve process. *>
<* *>
<*********************************************************>
begin
long array field name;
name := 6;
list_entry (z, only_name, entry, scope, actscop, newscop, clock);
write (z, "nl", 1, <:*** :>, true, 12, entry.name, <: skipped : :>,
if result = 7 then <:area was inaccessible at save:> else
if result = 8 then <:covered by a better entry :> else
if result = 9 then <::> else
if result extract 12 > 0 then <:create area process, :> else
if result shift (-12) > 0 then <:reserve process , :> else
<::>);
if result extract 12 > 0 then
write (out, case result of (
<:area claims exceeded:>,
<:cat i/o error, state of document does not permit:>,
<:entry not found:>,
<:not area entry:>,
<::>,
<:name format illegal:>,
<::>,
<::>,
<::> ))
else
if result > 0 then
write (out, case (result shift (-12)) of (
<:reserved by another process:>,
<:not user, cannot be reserved:>,
<:does not exist:> ));
write (out, "nl", 1);
errorbits := 2; <*warning.yes ok.yes*>
end skip_entry;
\f
<* sw8010/2, load entry handling page ... 78...
1988.08.11 *>
message modekind case page 1;
integer
procedure modekind_case (modekind);
value modekind ;
integer modekind ;
<*********************************************************>
<* *>
<* The procedure finds the number of the given modekind *>
<* in the modekind table commonly used, zero meaning un- *>
<* known. *>
<* *>
<* Call : modekind_case (modekind) *>
<* *>
<* modekind:case (return value, integer). The number of *>
<* the modekind given as found in the *>
<* table. If not found, a zero is retur- *>
<* ned. *>
<* modekind (call value, integer). The modekind *>
<* given. *>
<* *>
<*********************************************************>
begin
integer i, j;
j := 0;
for i := 1 step 1 until 26 do
if modekind = ( case i of (
1 shift 23 + 0 shift 12 + 0, <* ip*>
1 shift 23 + 0 shift 12 + 4, <* bs*>
1 shift 23 + 0 shift 12 + 8, <* tw*>
1 shift 23 + 0 shift 12 + 10, <* tro*>
1 shift 23 + 2 shift 12 + 10, <* tre*>
1 shift 23 + 4 shift 12 + 10, <* trn*>
1 shift 23 + 6 shift 12 + 10, <* trf*>
1 shift 23 + 8 shift 12 + 10, <* trz*>
1 shift 23 + 0 shift 12 + 12, <* tpo*>
1 shift 23 + 2 shift 12 + 12, <* tpe*>
1 shift 23 + 4 shift 12 + 12, <* tpn*>
1 shift 23 + 6 shift 12 + 12, <* tpf*>
1 shift 23 + 8 shift 12 + 12, <* tpt*>
1 shift 23 + 0 shift 12 + 14, <* lp*>
1 shift 23 + 0 shift 12 + 16, <* crb*>
1 shift 23 + 8 shift 12 + 16, <* crd*>
1 shift 23 + 10 shift 12 + 16, <* crc*>
1 shift 23 + 0 shift 12 + 18, <* mt62, mto, mtlh*>
1 shift 23 + 2 shift 12 + 18, <* mte*>
1 shift 23 + 4 shift 12 + 18, <* mt16, nrz, mtll*>
1 shift 23 + 6 shift 12 + 18, <* nrze*>
1 shift 23 + 8 shift 12 + 18, <* mt32*>
1 shift 23 + 12 shift 12 + 18, <* mt08*>
1 shift 23 +128 shift 12 + 18, <* mthh*>
1 shift 23 +132 shift 12 + 18, <* mthl*>
1 shift 23 + 0 shift 12 + 20))<* pl*> then
begin j := i; i := 26 end;
modekind_case := j;
end modekind_case;
\f
<* sw8010/2, load entry handling page ... 79...
1984.09.10 *>
message list counters page 1;
procedure list_counters (z, entry_count, slice_count);
zone z ;
integer array entry_count, slice_count ;
<*********************************************************>
<* *>
<* The procedure list on the document z the values of *>
<* counters given for each disc together with its name *>
<* and possible new name. *>
<* *>
<* Call : list_counters (z, entry_count, slice_count); *>
<* *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* entry_count (call values, integer array). For disc *>
<* slice_count number i, entry_count (i) and *>
<* slice_count (i) are the entries and sli- *>
<* ces saved belonging to the disc. *>
<* *>
<*********************************************************>
begin
integer disc_no, segments, entry_spec;
long sum_s, sum_e;
long array field disc ;
sum_s := sum_e := 0; <*sum segments and sum entriies*>
write (z, "nl", 1, "ff", 1, "nl", 3,
<:entries and slices/segments loaded ::>, "nl", 2,
true, 12, <:disc name ::>,
true, 11, <:entries ::>,
true, 10, <:slices ::>,
true, 14, <:slicelength ::>,
true, 11, <:segments ::>,
"nl", 1);
for discno := 1 step 1 until no_of_discs do
if (entry_count (disc_no) > 0
or slice_count (disc_no) > 0 ) then
begin
disc := disc_no * 8; <*fields disc name*>
segments := slice_count (discno) * slice_length (discno);
sum_s := sum_s + segments;
sum_e := sum_e + entry_count (discno);
write (z, << ddddddd>, "nl", 1,
true, 12, incl_discname.disc,
true, 11, entry_count (disc_no),
true, 10, slice_count (disc_no), << ddd>,
true, 14, slicelength (disc_no), << ddddddd>,
true, 11, segments);
end;
write (z, << ddddddd>, "nl", 2,
true, 12, <:total:>,
true, 11, sum_e,
true, 24, <: :>,
true, 11, sum_s, "nl", 1);
end list_counters;
\f
<* sw8010/2, load entry handling page ... 80...
1984.09.12 *>
message list total counters page 1;
procedure list_total_counters (z, entries_l, segments_l ,
entries_r, segments_r);
value entries_l, segments_l ,
entries_r, segments_r ;
zone z ;
integer entries_l, segments_l ,
entries_r, segments_r ;
<*********************************************************>
<* *>
<* The procedure lists on the document z the values of *>
<* the counters given. *>
<* *>
<* Call : list_total_counters (z, entries, segments); *>
<* *>
<* z (call and return value, zone). The name of *>
<* the document. Determines further the docu- *>
<* ment, the buffering and the position of *>
<* the document. *>
<* entries_l (call values, integers). The values to be *>
<* segments_l listed. *>
<* entries_r *>
<* segments_r *>
<* *>
<*********************************************************>
write (z, << ddddddd>, "nl", 2,
<:entries and segments loaded ::>, "nl", 2,
true, 12, <:total:>,
true, 11, <:entries ::>,
true, 24, <: :>,
true, 11, <:segments ::>, "nl", 2,
true, 12, <: :>,
true, 11, entries_l,
true, 24, <: :>,
true, 11, segments_l, "nl", 3,
<:entries and segments read ::>, "nl", 2,
true, 12, <:total:>,
true, 11, <:entries ::>,
true, 24, <: :>,
true, 11, <:segments ::>, "nl", 2,
true, 12, <: :>,
true, 11, entries_r,
true, 24, <: :>,
true, 11, segments_r, "nl", 3);
<*end list_total_counters;*>
\f
<* sw8010/2, load tape handling procedures page ... 84...
1988.02.11 *>
message open tape page 1;
procedure open_tape (z, devno, modekind, docname);
value devno, modekind ;
zone z ;
integer devno, modekind ;
long array docname ;
<*********************************************************>
<* *>
<* The procedure opens the zone specified with modekind, *>
<* docname as specified and a give up mask with end of *>
<* document (1<18). *>
<* If the device number specified is not zero, a mount- *>
<* special message is sent to the parent with deviceno *>
<* and docname as specified. *>
<* *>
<* Call : open_tape (z, devno, modekind, docname) *>
<* *>
<* z (call and return value, zone). The name of *>
<* the document, further the document, the buf-*>
<* fering and the position of the document. *>
<* devno (call value, integer). If devno <> 0 a *>
<* mount special mesage is sent to the parent *>
<* with devno and docname as specified. *>
<* modekind (call value, integer). Used in call of open.*>
<* docname (call value, long array). A document name *>
<* packed in docname (1:2) is used in open and *>
<* maybe mount special message. *>
<* *>
<*********************************************************>
begin
integer i, dummy, proc_descr_addr;
integer array mess (1:8) ;
real array field raf;
if devno <> 0 then
begin <*mount special*>
mess (1) := 32 shift 12 + 16 shift 5 + 0; <*mount spec, no wait*>;
raf := 2; <*fields mess (2:...)*>
movestring (mess.raf, 1, <:mount :>);
mess (4) := devno ;
raf := 8; <*fields mess (5:...)*>
to_from (mess.raf, docname, 8); <*document name*>
system (10 )parent mess:( dummy, mess);
end <*mount special*>;
open (z,
logand (modekind, -(1 shift 19 + 1)) extract 23, <*clear speed bit*>
docname, 1 shift 14 + 1 shift 18 + 1 shift 21);
end open_tape;
\f
<* sw8010/2, load tape handling procedures page ... 85...
1984.07.13 *>
message get file no page 1;
procedure getfileno (z, i, copies, volcount, no_of_vol, tapename ,
devno , modekind, fileno , blockno );
value i, copies ;
zone z ;
integer i, copies ;
long array tapename ;
integer array volcount, no_of_vol,
devno , modekind, fileno , blockno ;
<*********************************************************>
<* *>
<* The procedure returns the volume, file and block num- *>
<* ber given if the file no is non negative. *>
<* If it is negative, the volume and file numbers are *>
<* searched as the first file on the first volume on the*>
<* tapes in copy no i, which is neither version nor con- *>
<* tinue dump label, and the volume, file and block num- *>
<* bers are returned. *>
<* The search extends over as many volumes as are needed, *>
<* as long as they are specified by volume counter below *>
<* no_of_volumes for the proper copy and on the tape *>
<* found in the proper sequence in tape name array. *>
<* If the tape sequence runs out during the search, the *>
<* procedure gives up (end of document). *>
<* *>
<* Call : getfileno (za, i, copies, volcount, no_of_vol, *>
<* tapename , devno , modekind , *>
<* fileno , blockno ) *>
<* *>
<* z (call and returnvalue, zone). *>
<* The name, buffering and position of the *>
<* document. At call the zone state must *>
<* be after declaration. *>
<* i (call value, integer). The index in the*>
<* below magnetic tape file descriptions. *>
<* copies (call value, integer). The top index in *>
<* below magnetic tape file descriptors. *>
\f
<* sw8010/2, load tape handling procedures page ... 85...
1984.07.13 *>
message get file no page 2;
<* tapename (call name, long array). Volume no. j *>
<* in copy no. i is supposed to be speci- *>
<* fied in long array tapename (1:no_of_co-*>
<* pies) as tapename (i, 2*j-1) and tape- *>
<* name (i, 2*j). *>
<* no_of_vol (call value, integer array). The number *>
<* of volmes specified in each copy is spe-*>
<* cified in no_of_vol (1:no_of_copies). *>
<* vol_count (call and return value, integer array). *>
<* At call, vol_count (i) is the volume *>
<* counter corresponding to the file num- *>
<* ber given in fileno (i), at return it *>
<* corresponds to the returned filenumber .*>
<* devno (call value, integer array). The device *>
<* numbers used in possible mount special *>
<* parent message sent before search. *>
<* modekind (call value, integer array). The mode- *>
<* kind used during the search on copy num-*>
<* ber i is modekind (i). *>
<* fileno (call and return value, integer array). *>
<* At call, fileno (i) is the file number *>
<* on the tape specified by vol_count (i) *>
<* and copy number i where to start the *>
<* search for a non-version dump file. *>
<* If the file number is non-negative, it *>
<* is considered found and returned again, *>
<* else it is searched. *>
<* blockno (return value, integer array). At re- *>
<* turn blockno (i) is the blockno of the *>
<* found position. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load tape handling procedures page ... 86...
1985.02.06 *>
message get file no page 3;
begin
integer hwds, volume, file, block;
integer array zdescr (1:20);
boolean file_no_found, label_found;
long array field curr_tape, label_type;
label_type := 18; <*fields labeltype in labelrecord*>
<*if fileno missing then init search*>
fileno_found := fileno (i) >= 0; <*<tape>.last => fileno < 0*>
if -,fileno_found then
begin <*init search*>
volume := vol_count (i) ;
file := fileno (i) := 1; <*start in fileno 1*>
block := blockno (i) := 0;
currtape := name_field (i, volcount);
open_tape (z, devno (i), modekind (i), tapename.curr_tape);
end <*init search*>;
\f
<* sw8010/2, load tape handling procedures page ... 87...
1985.02.06 *>
message get file no page 4;
while -, fileno_found do
begin <*read tape to find position*>
setposition (z, fileno (i), blockno (i));
<*get a record from first block of file*>
getzone6 (z, zdescr);
zdescr (12) := 1; <*partial word := index*>
setzone6 (z, zdescr);
label_found := get_labelrec (z, segm, entries_in_partcat,
entries_in_savecat ,
savecat_name,
savecat_base,
savecat_size,
dump_time ,
version_id ,
release_id ,
aux_synclength,
sync_blocklength );
while end_of_doc (1) do
begin <*next volume*>
vol_count (i) := vol_count (i) + 1;
file__no (i) := 1;
block_no (i) := 0;
next_volume (z, i, vol_count, fileno, blockno);
end_of_doc (1) := false; <*ready for eot again*>
getzone6 (z, zdescr);
zdescr (12) := 1; <*partial word := index*>
setzone6 (z, zdescr);
file__no (i) := 1;
block_no (i) := 0;
setposition (z, fileno (i), blockno (i));
label_found := get_labelrec (z, segm, entries_in_partcat,
entries_in_savecat,
savecat_name,
savecat_base,
savecat_size,
dump_time ,
version_id ,
release_id ,
aux_synclength,
sync_blocklength );
end <*next volume*>;
file_no_found := label_found extract 12 = 2;
\f
<* sw8010/2, load tape handling procedures page ... 85...
1984.09.10 *>
message get file no page 5;
if fileno_found then
begin <*the first empty labelled or non labelled file found*>
if vol_count (i) <> volume then
begin
vol_count (i) := volume;
file__no (i) := file ;
block_no (i) := block ;
next_volume (z, i, vol_count, fileno, blockno);
end;
file__no (i) := file ;
block_no (i) := block;
setposition (z, fileno (i), blockno (i));
close (z, false); <*terminate search, no release*>
end else
begin <*version or continue dump label, record the position and continue*>
if label_found then
begin
volume := vol_count (i);
file := file_no (i);
block := block_no (i);
end;
increase (fileno (i));
end;
end <*while -, fileno_found*> ;
end get_file_no;
\f
<* sw8010/2, load tape handling procedures page ... 88...
1984.07.13 *>
message name field page 1;
integer
procedure name_field (copy_count, vol_count);
value copy_count ;
integer copy_count ;
integer array vol_count ;
<*********************************************************>
<* *>
<* The procedure returns the value proper to field the *>
<* tape name of the tape corresponding to copy_count *>
<* and vol_count (copy_count) in the long array tapename *>
<* (1:no_of_copies : 1:2 * max_no_of_vol). *>
<* *>
<* Call : name_field (copy_count, vol_count); *>
<* *>
<* name_field (return value, integer). See above. *>
<* copy_count (call value, integer). See above. *>
<* vol__count (call value, integer array). See above. *>
<* *>
<*********************************************************>
name_field := copy_count * 8 * max_no_of_vol +
(vol_count (copy_count) - 1) * 8 ;
\f
<* sw8010/2, load tape handling procedures page ... 89...
1985.03.25 *>
message get labelrec page 1;
boolean
procedure get_labelrec (z, segm, part_entries, save_entries ,
savecat_name, savecat_base, savecat_size ,
dump____time ,
version ,
release ,
aux_sync ,
sync_blength);
zone z ;
integer segm, part_entries, save_entries ,
savecat_size ,
dump____time ,
version ,
release ,
aux_sync ,
sync_blength ;
long array savecat_name ;
integer array savecat_base ;
<*******************************************************>
<* *>
<* The procedure makes a zone record of 100 halfwords *>
<* available in the zone buffer of z and fills it *>
<* with characters constituting a save dump label from *>
<* the tape connected to z. *>
<* The values of the fields in the record are display- *>
<* ed on current output. *>
<* *>
<* Call : get_labelrec (z, segm , part_entries, *>
<* save_entries, *>
<* savecat_name, *>
<* savecat_base, *>
<* savecat_size, *>
<* dump____time) *>
<* *>
<* get_labelrec *>
<* (return value, boolean). Returns true if *>
<* a proper dump or continue label record *>
<* is found in the current block. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* To make sense, the zone must be in the *>
<* state open and positioned at call. *>
<* *>
<*******************************************************>
\f
<* sw8010/2, load tape handling procedures page ... 89...
1984.10.31 *>
message get labelrec page 2;
<*******************************************************>
<* *>
<* segm *>
<* part_entries *>
<* save_entries *>
<* (return values, integers). *>
<* savecat_name *>
<* (return value, long array) *>
<* savecat_base *>
<* (return value, integer array). *>
<* savecat_size *>
<* (return value, integer). *>
<* (return value, long array). *>
<* dump_time (return value, integer). *>
<* All return values from their respective *>
<* fields of the dump label record. *>
<* Only defined if the procedure returns *>
<* true. *>
<* *>
<*******************************************************>
begin
integer hwds;
long array field laf;
integer field ifld;
\f
<* sw8010/2, load tape handling procedures page ... 89...
1985.02.08 *>
message get labelrec page 3;
laf := 0; <*fields ztape into a long array*>
hwds := inrec6 (z, 0);
if hwds <> 100 then
begin
if hwds = 2 then get_labelrec := false add 2
else get_labelrec := false;
end
else
begin <*record of 100 hwds ready*>
laf := 0;
inrec6 (z, 100);
if z.laf (1) <> long <:save :> add 'sp' and
z.laf (1) <> long <:incsa:> add 'v' then
get_labelrec := false
else
begin <*save vers 2*>
laf := 18;
if z.laf (1) <> long <:vers.:> add 'sp' and
z.laf (1) <> long <:cont.:> add 'sp' then
get_labelrec := false
else
begin <*version or continue dump label*>
get_labelrec := true;
ifld := 60 ; segm := z.ifld;
ifld := ifld + 2; part_entries := z.ifld;
ifld := ifld + 2; save_entries := z.ifld;
laf := ifld ; tofrom (savecat_name, z.laf, 8);
ifld := ifld + 10; savecat_base (1) := z.ifld;
ifld := ifld + 2; savecat_base (2) := z.ifld;
ifld := ifld + 2; savecat_size := z.ifld;
ifld := ifld + 2; dump____time := z.ifld;
ifld := ifld + 2; version := z.ifld;
ifld := ifld + 2; release := z.ifld;
ifld := ifld + 2; sync_blength := z.ifld;
ifld := ifld + 2; aux_sync := z.ifld;
if release < 3 shift 12 then aux_sync := 0;
if test then
write (out,
"nl", 2, <:get labelrec ::>,
"nl", 1, <:segm = :>, segm,
"nl", 1, <:entries in partcat = :>, partentries,
"nl", 1, <:entries in savecat = :>, saveentries,
"nl", 1, <:savecat name = :>, savecatname,
"nl", 1, <:savecat base = :>, savecatbase (1),
"nl", 1, <: :>, savecatbase (2),
"nl", 1, <:savecat size = :>, savecatsize,
"nl", 1, <:dumptime = :>, dumptime,
"nl", 1, <:version = :>, version ,
"nl", 1, <:release = :>, release,
"nl", 1, <:sync blocklength = :>, sync_blength);
end <*version or continue dump label*>;
end <*save vers 2*>;
laf := 0;
write (out, "nl", 2, <:read from volume tape ::>,
"nl", 2, z.laf); <*display on current out*>
laf := 0;
if z.laf (1) = long <:dump :> add 'sp' then
write (out, "nl", 1,
<:*the label was created by save version 1 and should be read by load13:>,
"nl", 1);
end <*record of 100 hwds*>;
stopzone (z, false); <*stop the zone*>
end get_labelrec;
\f
<* sw8010/2, load tape handling procedures page ... 92...
1984.07.06 *>
message out continue mess page 1;
procedure out_continue_mess (zout, z, entries, segments, name);
value entries, segments ;
zone zout, z ;
integer entries, segments ;
long array name ;
<*********************************************************>
<* *>
<* The procedure displays on the zone zout the values of *>
<* file and block count in the zone z and the values of *>
<* the parameters entries, segments and name. *>
<* *>
<* Call : out_continue_mess (zout, z, entries, segments, *>
<* name );*>
<* *>
<* zout (call and return value, zone). The name, buf-*>
<* fering and position of the document where to *>
<* write the message. *>
<* z (call and return value, zone). The name, buf-*>
<* fering and position of the document to be re-*>
<* ported. *>
<* entries (call value, integer). The values of entry *>
<* segments (call value, integer). and segment counters *>
<* to be reported. *>
<* name (call value, long array). The name of the *>
<* continue tape in name (1:2) to be reported. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load tape handling procedures page ... 93...
1984.07.06 *>
message out continue mess page 2;
begin
integer file, block;
integer array zdescr (1:20);
long array field procname;
procname := 2; <*fields procname in zdescr*>
getzone6 (z, zdescr );
getposition (z, file, block);
write (out, "nl", 2,
true, 12, zdescr.procname, <:left:>, "nl", 2,
<<ddddddd>,
true, 12, <:file count:>, file , "nl", 1,
true, 12, <:block count:>, block , "nl", 1,
true, 12, <:entry count:>, entries, "nl", 1,
true, 12, <:segm count:>, segments,"nl", 2,
true, 12, name, <:continues:>, "ff", 1);
end out_continue_mess;
\f
<* sw8010/2, load tape handling procedures page ... 92...
1984.07.06 *>
message out end mess page 1;
procedure out_end_mess (zout, z, entries, segments);
value entries, segments ;
zone zout, z ;
integer entries, segments ;
<*********************************************************>
<* *>
<* The procedure displays on the zone zout the values of *>
<* file and block count in the zone z and the values of *>
<* the parameters entries, segments. *>
<* *>
<* Call : out_end_mess (zout, z, entries, segments); *>
<* *>
<* zout (call and return value, zone). The name, buf-*>
<* fering and position of the document where to *>
<* write the message. *>
<* z (call and return value, zone). The name, buf-*>
<* fering and position of the document to be re-*>
<* ported. *>
<* entries (call value, integer). The values of entry *>
<* segments (call value, integer). and segment counters *>
<* to be reported. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, load tape handling procedures page ... 93...
1984.07.06 *>
message out end mess page 2;
begin
integer file, block;
integer array zdescr (1:20);
long array field procname;
procname := 2; <*fields procname in zdescr*>
getzone6 (z, zdescr );
getposition (z, file, block);
write (out, "nl", 2,
true, 12, zdescr.procname, <:left:>, "nl", 2,
<<ddddddd>,
true, 12, <:file count:>, file , "nl", 1,
true, 12, <:block count:>, block , "nl", 1,
true, 12, <:entry count:>, entries, "nl", 1,
true, 12, <:segm count:>, segments,"nl", 2);
end out_end_mess;
\f
<* sw8010/2, load tape handling procedures page ... xx...
1984.07.13 *>
message transfer page 1;
integer
procedure transfer (za, i, copies, file, block, segments, endtape, expell);
value i, copies, segments ;
zone array za ;
integer i, copies, segments ;
integer array file, block ;
boolean array endtape ;
boolean expell ;
<******************************************************************>
<* *>
<* The procedure transfers a number of segments from a magnetic *>
<* tape file to a backing storage area, starting in the position *>
<* given in the file and block counts of the zones in the zone *>
<* array connected to the files. *>
<* A possible end of tape condition will be signalled in the boo- *>
<* lean array end_tape (1:1) by the block procedure in the *>
<* first zone of the array. *>
<* Any zone for which expell (i) is true will be expelled from *>
<* the set of output procedures, i.e. no output will take place *>
<* in the zone. *>
<* *>
<* Call : *>
<* *>
<* transfer (za, i, copies, file, block, segments, endtape,expell)*>
<* *>
<* transfer (return value, integer). The number of segments *>
<* transferred. *>
<* za (call and return, zone array). The buffering, posi- *>
<* tion and name of the source and target documents. *>
<* The zone array is supposed to be declared za (1:2, *>
<* buflength_io (2, 2, segm * 512), 2, end_of_document)*>
<* i. e. with a blocklength of segm * 512 hwds. *>
<* The output is performed in za (1) while the *>
<* input is performed in za (2). *>
<* The input zone as well as the output zones are in *>
<* the states after open and position. *>
<* *>
<******************************************************************>
\f
<* sw8010/2, load tape handling procedures page ... xx...
1984.07.13 *>
message transfer page 2;
<******************************************************************>
<* *>
<* The zones in the array are opened for inoutrec af- *>
<* ter a check of used share to check possible move o- *>
<* perations pending. *>
<* All the zones are positioned according to the posi- *>
<* tions given in the zones. *>
<* The transfer takes place until all segments given *>
<* are transferred with error handling according *>
<* to the user bits in the giveup mask and the block *>
<* procedure. *>
<* The zone za (1) is left in the state after *>
<* open and position, while the zone za (2) *>
<* is left in the state after declaration, i. e. the *>
<* area process has been removed. *>
<* *>
<* i (call value, integer). The index in the magnetic *>
<* tape file descriptions below to be used. *>
<* copies (call value, integer). See below. *>
<* file, (call and return values, integer arrays). The star- *>
<* block ting position of the tapes are found in file and *>
<* block count of the zones, at return the new positi- *>
<* on is returned in the arrays file, block. *>
<* segments (call value, integer). The number of segments to be *>
<* transferred. *>
<* endtape (call value, boolean array). The name of the array *>
<* where the procedure will suppose the blockprocedure *>
<* of the tape zone to signal end of document condi- *>
<* tion. *>
<* If end of document condition is found in the *>
<* input zone , a change of volume tape will be per- *>
<* formed in that zone. *>
<* expell (call value, boolean). If expell is true, the out- *>
<* put zone will be expelled *>
<* from the set of output zones just after openinout, *>
<* i. e. no output will take place in the zone. *>
<* *>
<******************************************************************>
\f
<* sw8010/2, load tape handling procedures page ... xx...
1990.03.13 *>
message transfer page 3;
begin
integer hwds, area, block_area, tape, j, name_table_addr,
segs, sumsegs;
boolean tapemark, rem_parity;
integer array zdescr (1:20), dummyia (1:1), user (1:16);
long array proc_name (1:2);
long array field area_name, curr_tape;
tapemark := false ;
rem_parity:= false ;
sumsegs := 0 ;
area_name := 2 ; <*fields process name in zone descriptor*>
area := copies + 1; <*index in file, block arrays for area zone*>
<*check position operation in zone and get position*>
check (za (1));
getposition (za (1), file (i ), block (i ));
getposition (za (2), file (area), block (area));
if modekind (i) shift 4 < 0 then
begin <*high speed bit specified*>
getzone6 (za (1), zdescr);
zdescr (1) :=
if segments <
speedlimit / (if modekind (i) shift 9 < 0 then 4 else 1) then
logand (modekind (i), -(1 shift 19 + 1)) extract 23 <*clear*>
else
logor (modekind (i), 1 shift 19 ) extract 23;<*set *>
if test then
write (out,
"nl", 1, <:speed bit = :>, zdescr (1) shift (-19) extract 1);
setzone6 (za (1), zdescr);
end;
getzone6 (za (2), zdescr );
tofrom (proc_name, zdescr.area_name, 8 );
name_table_addr := zdescr (6 );
openinout (za, 1); <*allocate shares for inoutrec, tape is input*>
if test then
write (out,
"nl", 2, <: transfer ::>,
"sp", 2, <: file (:>, i, <:) = :>, file (i),
"sp", 2, <:block (:>, i, <:) = :>, block (i),
"sp", 2, <:area name = :>, procname,
"sp", 2, <:pos in area :>, file (area), block (area),
"sp", 2, <:n.t. addr = :>, name_table_addr);
if expell then
expellinout (za, 2);
while sumsegs < segments and
-, tapemark do
begin <*still not all segments xferred and not tapemark before e o t*>
hwds := inoutrec (za, 0);
segs := (hwds + 511) // 512;
if parity (1) then
begin <*parity error input tape zone*>
parity (1) := false;
rem_parity := true ;
if sumsegs < segments - segments mod segm then
segs := segm
else
begin
segs := segments mod segm; <*last block*>
if segs * 512 < hwds then
hwds := segs * 512;
end;
write (out,
"nl", 1, "sp", 4, <:loading to:>,
"nl", 1, "sp", 4, true, 12, procname,
<: last :>, segs * 512 - hwds, <: halfwords of segments :>,
sumsegs, <: - :>, sumsegs + segs - 1,
if expell then <: would be:> else <: are:>, <: zeroed:>,
"nl", 1);
if test then
begin
write (out,
"nl", 1, <:parity, block length error or word defect ::>,
"nl", 1, <:hwds = :>, hwds,
"nl", 1, <:segs = :>, segs,
"nl", 1, <:segm = :>, segm,
"nl", 1, <:segments = :>, segments,
"nl", 1, <:sumsegs = :>, sumsegs,
"nl", 1, <:segments mod segm = :>, segments mod segm,
"nl", 1, <:aux sync length = :>, aux_sync_length,
"nl", 2);
end;
end;
if hwds > 2 then
begin <*not end of document or file mark in tape zone*>
if sumsegs + segs < segments then
begin <*transfer not terminated check correct blocksize*>
if segs <> segm
or hwds = aux_sync_length then
begin <*data blocks expired too early*>
if hwds = aux_sync_length then
begin <*sync block read as last data block*>
segs := 0; <*regret record*>
hwds := 0; <*makes the coming changerecio regret record*>
changerecio (za, hwds); <*regret record*>
getposition (za (1), file (i ), block (i )); <*log pos before sync*>
setposition (za (1), file (i ), block (i )); <*phys pos = logical*>
getposition (za (2), file (area), block (area));
setposition (za (2), file (area), block (area));
end;
segments := sumsegs + segs; <*to terminate loop*>
end <*data blocks expired too early*>;
end;
if hwds > 0 then
changerecio (za, segs * 512); <*assures blockchange next inoutrec*>
sumsegs := sumsegs + segs;
end else
if endtape (1) then
begin <*hwds = 2 and endtape (1), end of document in tape zone*>
\f
<* sw8010/2, load tape handling procedures page ... xx...
1990.03.12 *>
message transfer page 4;
<*begin hwds = 2 and andtape (1), end of document in tape zone*>
endtape (1) := false; <*ignore end of document*>
<*stop all zones, position before tape mark*>
stop_zone (za (1), false ); <*no tape mark*>
getposition (za (1), file (i), block (i));
getposition (za (2), 0 , block_area); <*remember position*>
closeinout (za); <*check position operation and reallocate*>
<*change to next volume in this zone*>
vol_count (i) := vol_count (i) + 1;
file (i) := 1; <*position of label record on next volume*>
block (i) := 0;
next_volume (za (1), i, vol_count, file, block);
curr_tape := namefield (copycount, vol_count );
close (za (2), false);
open (za (2), 4, save_cat_name, 0);
setposition (za (1), file (i), block (i));
reading_savecat := true;
j :=
transfer (za, i, copies, file, block, savecat_size,
endtape, true <*expell out*>);
reading_savecat := false;
if abs (j) <> savecatsize then
terminate_alarm (out,
<:incomplete save catalog bypassed on tape:>,
tapename.curr_tape, savecatsize, <: transferred : :>, abs (j));
open (za (2), 4, proc_name , 0);
setposition (za (2), 0 , block_area); <*reposition*>
getzone6 (za (2), zdescr );
zdescr (6) := name_table_addr ;
setzone6 (za (2), zdescr );
if modekind (i) shift 4 < 0 then
begin <*high speed bit specified*>
getzone6 (za (1), zdescr);
zdescr (1) :=
if segments - sumsegs <
speedlimit / (if modekind (i) shift 9 < 0 then 4 else 1) then
logand (modekind (i), -(1 shift 19 + 1)) extract 23 <*clear*>
else
logor (modekind (i), 1 shift 19 ) extract 23;<*set *>
if test then
write (out,
"nl", 1, <:speed bit = :>, zdescr (1) shift (-19) extract 1);
setzone6 (za (1), zdescr);
end;
setposition (za (1), file (i), block (i) );
check (za (1) ); <*check pos operation*>
openinout (za, 1); <*reallocate for inoutrec*>
if expell then
expellinout (za, 2); <*reexpell zone*>
end <*hwds = 2 and endtape (1), end of document in tape zone*>
else <*hwds = 2 and -, endtape (1), tapemark in tape zone*>
tapemark := true;
end <*while loop : still not all segments transferred*>;
\f
<* sw8010/2, load tape handling procedures page ... xx...
1988.11.17 *>
message transfer page 5;
<*end while loop: still not all segments transferred*>
getzone6 (za (1), zdescr);
if aux_sync_length > 0 and
zdescr (16) > 0 and
not reading_savecat then <*record length*>
begin
<*sync blocks present and present record not one, *>
<*check that next share has input a sync block and*>
<*- if not : read on until sync block *>
<*- if : leave *>
integer array sdescr1, sdescr2, sdescr3 (1:12);
integer used_share, next_share, reclength;
getzone6 (za (1), zdescr);
used_share := zdescr (17); <*save used share*>
next_share := used_share + 1; <*save next share*>
if next_share > zdescr (18) then
next_share := 1;
zdescr (17) := next_share;
getshare6 (za (1), sdescr1, used_share);
getshare6 (za (1), sdescr2, next_share);
<* if test then
begin
write (out, "nl", 1, <:zone and shares before check next share ::>,
"nl", 1, <:used share = :>, used_share,
"sp", 1, <:next share = :>, next_share);
writezone (za (1), 1);
writeshare (za (1), used_share);
writeshare (za (1), next_share);
end;
*>
setzone6 (za (1), zdescr); <*used share updated*>
check (za (1) ); <*check it*>
getshare6 (za (1), sdescr3, next_share); <*get checked share*>
sdescr2 (1) := sdescr3 (1) := 1; <*share.state := ready*>
setshare6 (za (1), sdescr3, next_share); <*reset the share*>
<* if test then
begin
write (out, "nl", 1, <:zone and shares after check next share ::>);
writezone (za (1), 1);
writeshare (za (1), used_share);
writeshare (za (1), next_share);
end;
*>
reclength :=
sdescr3 (12) - sdescr3 (5) ;
<*sh.top xferred - sh.first addr*>
zdescr (17) := used_share;
setzone6 (za (1), zdescr); <*reset zone*>
setshare6 (za (1), sdescr1, used_share); <*and shares*>
<* if test then
begin
integer i;
write (out,
"nl", 1, <:zone and shares before set share next share ::>,
"nl", 1, <:reclength = :>, reclength,
"nl", 1, <:zdescr(16)= :>, zdescr(16));
writezone (za (1), 1);
writeshare (za (1), used_share);
writeshare (za (1), next_share);
write (out, "nl", 1, <:sdescr2 = :>);
for i := 1 step 1 until 12 do
write (out, "nl", 1, "sp", 10, << dddddd>, sdescr2 (i));
end;
*>
setshare6 (za (1), sdescr2, next_share);
if reclength > aux_sync_length then
begin <*too many data blocks, read on until sync block*>
getposition (za (1), file (i ), block (i )); <*log pos before last block*>
getposition (za (2), file (area), block (area));
closeinout (za); <*terminate zones, reinit zone array*>
block (i) := block (i) + 1; <*log pos after last block*>
setposition (za (1), file (i ), block (i )); <*phys = log pos*>
setposition (za (2), file (area), block (area));
<* if test then
write (out,
"nl", 1, <:position before transfer : :>,
file (i), block (i),
"nl", 1, <:- in area : :>,
file (area), block (area));
*>
segs :=
transfer (za, i, copies, file, block, 8388607, endtape, expell);
<*transfer until sync block, but expell disc zone*>
sumsegs := sumsegs + segs;
setposition (za (1), file (i), block (i)); <*save pos in zone*>
<* if test then
write (out,
"nl", 1, <:position after transfer : :>,
file (i), block (i),
"nl", 1, <:- in area : :>,
file (area), block (area));
*>
end <*too many full length blocks*>;
end <*aux_sync_length > 0*>;
\f
<* sw8010/2, load tape handling procedures page ... xx...
1988.02.02*>
message transfer page 6;
<*stop zones, maybe tapemark, position after last block or mark*>
stop_zone (za (1), false ); <*not tape mark*>
getposition (za (1), file (i), block (i));
getzone6 (za (2), zdescr);
name_table_addr := zdescr (6);
if zdescr (13) >= 32 then <*z.state < 32 == closeinout was here before*>
closeinout (za); <*reallocate buffer area*>
if test then
begin
write (out,
"nl", 2, <:end transfer ::>,
"nl", 1, <:expell = :>, if expell then <:yes:> else <:no:>,
"sp", 2, <:area name = :>, zdescr.area_name,
"sp", 2, <:segments = :>, segments,
"sp", 1, <:xferred = :>, sumsegs,
"nl", 1, "sp", 14,
"sp", 2, <: file (:>, i, <:) = :>, file (i),
"sp", 2, <:block (:>, i, <:) = :>, block (i),
"sp", 2, <:n.t. addr = :>, name_table_addr);
end;
if name_table_addr > 0 then
begin <*prepare remove process*>
system (5) move core :(name_table_addr, user); <*name table address*>
system (5) move core :(user (1) - 4 , user); <*process bases *>
if test then
write (out,
"nl", 2, <:prepare remove process :>,
"nl", 1, <:name table address = :>, name_table_addr,
"nl", 1, <:proc bases = :>, user (1), "sp", 2, user (2),
"nl", 1, <:segments = :>, user (12));
set_catbase (user);
end <*prepare remove process*>;
close (za (2), name_table_addr > 0); <*remove area process*>
reset_catbase;
transfer :=
if rem_parity then
- sumsegs
else
sumsegs; <*segments transferred = segments if no tapemark*>
end <*transfer*>;
\f
<* sw8010/2, load tape handling procedures page ... xx...
1984.09.07 *>
message next volume page 1;
procedure next_volume (z, index, vol_count, file, block);
value index ;
zone z ;
integer index ;
integer array vol_count, file, block ;
begin
<***************************************************>
<* *>
<* The procedure performs a change of tape to the *>
<* volume given and reads and checks the block in *>
<* the position given for a version or continue *>
<* dump label record. *>
<* If no such record is found or the key values of *>
<* it does not equal the contents of the current *>
<* key values, the procedure terminates with a pro-*>
<* per alarm. *>
<* *>
<* - close the zone with release message to parent *>
<* - open the zone with a new document name and a *>
<* possible mount ring message to the parent *>
<* - position to the position given *>
<* *>
<* Call : *>
<* *>
<* next_volume (z, index, vol_count, file, block); *>
<* *>
<* z (call and return value, zone ). *>
<* The zone z specifies the *>
<* buffering, position and name of the *>
<* document to be left, at return the *>
<* new document. At call the state must *>
<* be zero (positioned), at return it *>
<* is zero again. *>
<* *>
<***************************************************>
\f
<* sw8010/2, load tape handling procedures page ... xx...
1984.09.07 *>
message next volume page 2;
<***************************************************>
<* *>
<* index (call value, integer). Specifies a *>
<* possible device number (cf. the pro- *>
<* cedure open tape), a modekind and a *>
<* document name. *>
<* vol_count (call value, integer array). The vo- *>
<* lume to be mounted is recorded in *>
<* vol_count (index). *>
<* file (call and return value, integer ar- *>
<* block ray). At call the position where to *>
<* find the label record, at return the *>
<* position after the label record. *>
<* recorded in file, block (index). *>
<* *>
<* Function : *>
<* *>
<* If the next volume name is not specified, the *>
<* procedure gives up with a runtime alarm. *>
<* During the in put operations performed in *>
<* the procedure, the end of document status in *>
<* the answer is ignored. *>
<* *>
<***************************************************>
\f
<* sw8010/2, load tape handling procedures page ... xx...
1987.04.29 *>
message next volume page 3;
integer n_segm, n_saveentries, n_partentries,
n_savecatsize, n_dumptime, n_versionid,
n_releaseid, n_auxsynclength, n_syncblocklength;
integer array n_savecatbase (1:2);
long array n_savecatname (1:2);
long array field curr_tape;
if vol_count (index) > no_of_vol (index) then
begin
out_end_mess (out, z, total_entrycount, total_segmcount);
give_up ( z, 1 shift 18, 0); <*end of document*>
end;
curr_tape := name_field (index, vol_count);
out_continue_mess (out,
z, total_entrycount, total_segmcount, tapename.curr_tape);
fpproc (33) outend :(0, out, 'nul');
<*outend on current out before release message to parent*>
<*if parent is s the output would be mixed with message *>
close (z, false add 1); <*release*>
open_tape (z, deviceno (index), modekind (index),
tapename.curr_tape);
<*zone.partial word := index := 1*>
setposition (z, file (index), block (index)); <*pos in call*>
if -,get_labelrec (z, n_segm, n_partentries, n_saveentries,
n_savecatname, n_savecatbase, n_savecatsize,
n_dump___time, n_version_id , n_release_id,
n_auxsynclength , n_sync_blocklength) then
terminate_alarm (out,
<:no proper dumplabel on volume tape, file number ::>,
tapename.curr_tape, file (index), <: block number : :>, block (index));
if segm <> n_segm
or entriesinpartcat <> n_partentries
or entries_in_savecat <> n_saveentries
or savecatsize <> n_savecatsize
or dumptime <> n_dumptime then
begin
if test then
write (out,
"nl", 2, <:next volume ::>,
"nl", 1, <:segm , nsegm = :>, segm, nsegm,
"nl", 1, <:partentries , npartentries = :>, entriesinpartcat, npartentries,
"nl", 1, <:saveentries , nsaveentries = :>, entriesinsavecat, nsaveentries,
"nl", 1, <:savecatname , nsavecatname = :>, true, 12, savecatname, nsavecatname,
"nl", 1, <:savecatbase, nsavecatbase = :>, savecatbase (1),
nsavecatbase (1),
"nl", 1, <: :>, savecatbase (2),
nsavecatbase (2),
"nl", 1, <:savecatsize, nsavecatsize = :>, savecatsize, nsavecatsize,
"nl", 1, <:dumptime , ndumptime = :>, dumptime, ndumptime,
"nl", 1, <:version , nversion = :>, versionid, nversionid,
"nl", 1, <:release , nrelease = :>, releaseid, nreleaseid,
"nl", 1, <:aux sync , nauxsyncleng = :>, aux_synclength,
naux_synclength,
"nl", 1, <:syncblocklength, nsyncbl = :>, syncblocklength,
nsyncblocklength);
terminate_alarm (out,
<:dumplabel incompatible on volume tape, file number ::>,
tapename.curr_tape, file (index), <: block number : :>, block (index));
end;
getposition (z, file (index), block (index)); <*pos at return*>
end <*next volume*>;
\f
<* sw8010/2, load area handling procedures page ...102...
1983.10.31 *>
message give up page 1;
procedure give_up (z, status, hwds);
zone z ;
integer status, hwds ;
<**********************************************************>
<* *>
<* The procedure resets the catalog base and calls the *>
<* standard give up procedure stderror. *>
<* *>
<**********************************************************>
begin
reset_catbase;
stderror (z, status, hwds);
end give up;
\f
<* sw8010/2, load block procedures page ... xx...
1984.09.26 *>
message end of document page 1;
procedure end_of_document (ztape, status, hwds);
value status ;
zone ztape ;
integer status, hwds ;
begin
<**********************************************************>
<* *>
<* The procedure acts as a block procedure in the zone ar-*>
<* ray za (1:2) and supposes that there are *>
<* no other user bits in the status than 1<18, e. o. d., *>
<* and 1 shift 14, mode error. *>
<* The purpose of the procedure is to : *>
<* *>
<* If give up bit is raised : *>
<* - give up and call stderror. *>
<* *>
<* If end of document status : *>
<* - signal end of document status in the global boolean *>
<* array end_of_doc indexed with the index found in the *>
<* partial word of the zone ztape (set there by openin- *>
<* out or explicitly by the program in case of normal *>
<* record io). *>
<* - ignore the status if the operation was output *>
<* - simulate a block of 2 halfs if the operation was in- *>
<* put and nothing was transferred *>
<* *>
<* If mode error status : *>
<* - try the next mode in the reportoire and give up if *>
<* all have been tried *>
<* - close the zone, open it again with new mode, setpo- *>
<* sition, check position operation (with possible call *>
<* of block procedure) and return with bytes transfer- *>
<* red = 0. *>
<* *>
<**********************************************************>
integer array zdescr (1:20), sdescr (1:12);
integer index, operation, i, j, nextmode;
long array field docname;
own
integer startmode;
\f
<* sw8010/2, load block procedure page ... xx...
1990.03.13 *>
message end of document page 2;
docname := 2; <*fields docname in zone*>
if status extract 1 = 1 and
(status shift (-22) extract 1 = 0 and <*not parity*>
status shift (-20) extract 1 = 0 and <*not dataov*>
status shift (-19) extract 1 = 0 and <*not blockl*>
status shift (- 7) extract 1 = 0 <*not wd.def*>
or status shift (-13) extract 1 = 1) then <*read error*>
give_up (ztape, status, hwds); <*hard error, not parity or read error*>
getzone__6 (ztape, zdescr );
getshare_6 (ztape, sdescr, zdescr (17)); <*used share*>
index := zdescr (12);
operation := sdescr ( 4) shift (-12);
if status shift (-21) extract 1 = 1 then
begin <*timer*>
if operation = 3 and
hwds = 0 <*nothing transferred*> then
hwds := 2 <*end of recorded media - on adp streamer tape*>
else giveup (ztape, status, hwds);
end <*timer*> else
if status shift (-22) extract 1 = 1
or status shift (-20) extract 1 = 1
or status shift (-19) extract 1 = 1
or status shift (- 7) extract 1 = 1 then
begin <*parity error, data overrun, blocklength error or word defect*>
if operation <> 3 then
give_up (ztape, status, hwds); <*not input*>
getposition (ztape, i, j);
write_alarm (out,
<:persistent parity error, data overrunn, block length error or word defect on tape:>);
errorbits := 2; <*warning.yes, ok.yes*>
write (out,
"nl", 1, "sp", 4, true, 12, zdescr.docname,
<: file, block no :>, i, <:, :>, j);
parity (index) := true;
if hwds < 4 then
hwds := 4; <*not filemark*>
end <*parity error*> else
if status shift (-18) extract 1 = 1 then
begin <*end of document*>
end_of_doc (index) := true;
if operation = 3 <* input*> and
hwds = 0 <*nothing xferred*> then
hwds := 2;
end <*end of document*> else
begin <*mode error*>
if startmode = 0 then
startmode := 1 shift 11 add (zdescr (1) shift (-12) extract 11);
for i := 1 step 1 until 8 do
if zdescr (1) shift (-12) extract 11 = ( case i of (
0, 2, 4, 6, 8, 12, 128, 132 ) ) then
begin j := i; i := 8; end;
j := if j = 8 then 1 else j + 1;
nextmode := 1 shift 11 add ( case j of (
0, 2, 4, 6, 8, 12, 128, 132 ) );
if test then
write (out,
"nl", 2, <:block procedure tape zone :>,
"nl", 1, <:index = :>, index,
"nl", 1, <:operation = :>, operation,
"nl", 1, <: , mode = :>, sdescr (4) extract 12,
"nl", 1, <:status = :>, status,
"nl", 1, <:hwds xferred = :>, hwds,
"nl", 1, <:startmode = :>, startmode extract 11,
"nl", 1, <:next mode = :>, next_mode extract 11);
getstate (ztape, i);
if nextmode = startmode <*all modes h been tried*>
or i shift (-5) extract 1 = 1 <*after inoutrec/chrecio*> then
give_up (ztape, status, hwds);
mode_kind (copycount) := nextmode shift 12 + 18;
close (ztape, false );
open_tape (ztape, 0 , modekind (copycount),
zdescr.docname );
setposition (ztape, fileno (index), blockno (index ));
getzone6 (ztape, zdescr );
zdescr (12) := index; <*partial word := index*>
setzone6 (ztape, zdescr );
write (out,
"nl", 2, <:*mode error on :>, true, 12, zdescr.docname,
"sp", 1, <:, trying :> , case j of (
<:mt62/mtlh:>, <:mte :>, <:mt16/mtll:>, <:nrze:>,
<:mt32:>, <:mt08:>, <:mthh:>, <:mthl:>));
status := hwds := 0; <*position checked ok, in case of inrec repeat*>
end <*mode error*>;
end <*end of document*>;
\f
<* sw8010/2, load program head page ...103...
1981.12.14 *>
message program head page 1;
outfile (1) := chain_name (1) := real <::>; <*no outfile, no zone stack*>
zone_level := 0; <*no input zone stack*>
prepare_param_scan (0);
scan_param (outfile);
if scan_param (progname) shift (-12) extract 12 <> 6 <*equal*> then
begin <*no outfile, progname is next param after program name*>
for i := 1, 2 do
begin
progname (i) := outfile (i);
outfile (i) := real <::>;
repeat_param := true ; <*progname must be repeated*>
end;
end <*no outfile*>;
if outfile (1) <> real <::> then
begin <*stack current out and connect*>
result := stack_current_output (outfile);
if result <> 0 then
begin <*connect not ok*>
param_warning (out, <:warning outfile param connect impossible:>);
write (out, <: :>, case result of (
<:no resources:>, <:malfunction:>, <:not user, non exist:>,
<:convention error:>, <:not allowed:>, <:name format error:>));
end <*connect not ok*>;
end <*stack current out and connect*>;
\f
<* sw8010/2, load program page ...104...
1983.07.13 *>
message program page 1;
<*initialize disc name table for active discs and find maincat disc*>
system (5, discs (1), name_table); <*name_table (1:no_of_discs)*>
k := 0; <*pointer to next active disc*>
for i := 1 step 1 until no_of_discs do
begin
long array la (1:2); integer array ia (1:1);
system (5, name_table (i) - 18, la); <*disc name*>
if la (1) shift (-24) extract 24 <> 0 then
begin <*chaintable ok*>
k := k + 1; <*next active disc*>
disc := 8 * k; <*fields disc name in discname table*>
for j := 1, 2 do
incl_discname.disc (j) := la (j); <*move disc name*>
if name_table (i) = discs (4) <*main catalog disc*> then
main_cat_disc := k; <*pointer to active disc*>
<*initialize auxcat nametable active discs*>
system (5) move core :(nametable (i) - 28, la);
for j := 1, 2 do
incl_auxcat_name.disc (j) := la (j);
<*initialize slicelength table active discs*>
system (5, name_table (i) - 8, ia); <*slicelength*>
slicelength (k) := ia (1);
end <*chaintable ok*>;
end;
no_of_discs := k; <*no of non idle discs*>
\f
<* sw8010/2, load program page ...105...
1988.08.11 *>
message program page 2;
trap (slutlabel); <*to maybe remove savecat entry and unstack cur out*>
trapmode := 1 shift 13; <*ignore trap alarm messages*>
inc_dump := progname (1) shift (-24) shift 24 = real <:inc:>;
<*init own bases*>
bases (cat_base, std_base, user_base, max_base, sys_base);
<*remove fp area process*>
open (zsavecat, 4, <:fp:>, 0); <*zsavecat borrowed*>
close (zsavecat, true); <*remove area proc *>
open (zsavecat, 0, <::>, 0); close (zsavecat, false); <*clear names*>
open (zloadcat, 0, <::>, 0); close (zloadcat, false); <*to prevent *>
open (zpartcat, 0, <::>, 0); close (zpartcat, false); <*troubles *>
<*get monitor release*>
system (5) move core :(64, dummyia);
monrelease := dummyia (1); <*rel shift 12 + subrel*>
<*obtain area and buffer claim*>
system (5) move core :(
system (6, dummy, procname) + 26, claim); <*buf, area*>
buf__claim := claim (1) shift (-12);
area_claim := claim (1) extract 12 ;
<*area for program has been taken*>
areas_needed := 4 + 2; <*program, savecat, outfile, infile, partcat, entry*>
if area_claim + 1 < areas_needed then
begin
write_alarm (out, <:area claim, needed ::>);
write (out, << ddd>, areas_needed, <:, claim ::>, area_claim + 1, "nl", 1);
trap (-1);
end;
<*initialize entry and segment counters*>
entries_stored :=
total_entry_count :=
total_segm__count := 0;
for i := 1 step 1 until no_of_discs do
entry_count (i) :=
slice_count (i) := 0;
\f
<* sw8010/2, load program page ... 106...
1987.04.24 *>
message program page 3;
<*prepare parameter reading and interpretation*>
point_int := 8 shift 12 + 4; point_txt := 8 shift 12 + 10;
space_int := 4 shift 12 + 4; space_txt := 4 shift 12 + 10;
startvolume := no_of_copies := 1; <*default in case of tape param missing*>
for i := 1, 2 do
begin
device_no (i) := 0; <*default : no spec device*>
release (i) := true; <*default : release.yes *>
parity (i) :=
end_of_doc (i) := false;
mode_kind (i) := 1 shift 23 + 18; <*default : modekind = mto*>
for j := 1 step 1 until 2 * max_no_of_vol do
tape_name (i, j) := para_name (i, j) := 0; <*all tapenames zero*>
mount_param_spec (i) := false ; <*no mountspec*>
file_no (i) := 0; <*file no zero*>
block_no (i) := 0; <*blockno zero*>
no_of_vol (i) := 0; <*volume count*>
for j := 1, 2 do
dump_label (i, j) := long <::>; <*dumplabel*>
end;
tape_param_ok := true;
<*write (out, "nl", 1, <:speed limit : :>, "<", 1);
*>
<*stopzone (out, false);*>
<*read (in, speedlimit);
write (out, "nl", 1, <:speed limit : :>, speedlimit, "nl", 1);
*>
<*stopzone (out, false);*>
speedlimit := 100;
\f
<* sw8010/2, load program page ...105...
1988.08.21 *>
message program page 4;
<*maybe mount parameters, tape parameters*>
copy_count := 1; <*counts no of copies*>
seplength := scan_param (item);
repeat
for action := mount_param (seplength, item) while action > 0 do
begin <*item is a name and a mount param*>
mount_param_spec (copy_count) := true; <*=> tape param obligatory*>
case action of
begin
begin <*mount special*>
if scan_param (item) <> point_int then
begin
param_alarm (out, <:alarm mountspec param syntax:>);
tape_param_ok := false; <*to prevent default save*>
end else
device_no (copy_count) := round item (1);
end <*mount special*>;
begin <*release*>
if scan_param (item) <> point_txt
or item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning release param syntax:>)
else
release (copy_count) := item (1) = real <:yes:>;
end <*release*>;
modekind (copycount) := 1 shift 23 + 18; <*mt62, mtlh, mto*>
modekind (copycount) := 1 shift 23 + 2 shift 12 + 18; <*mte*>
modekind (copycount) := 1 shift 23 + 4 shift 12 + 18; <*mt16, mtll, nrz*>
modekind (copycount) := 1 shift 23 + 6 shift 12 + 18; <*nrze*>
modekind (copycount) := 1 shift 23+ 8 shift 12 + 18; <*mt32*>
modekind (copycount) := 1 shift 23+ 12 shift 12 + 18; <*mt08*>
modekind (copycount) := 1 shift 23+128 shift 12 + 18; <*mthh*>
modekind (copycount) := 1 shift 23+132 shift 12 + 18; <*mthl*>
end case action ;
seplength := scan_param (item);
end <*while action > 0*> ;
\f
<* sw8010/2, load program page ...106...
1985.02.11 *>
message program page 5;
<*tape parameter*>
old_length := seplength;
for i := 1, 2 do
old_item (i) := item (i) ;
seplength := scan_param (item);
if (old_length = point_txt
or old_length = space_txt ) and (old_item (1) <> real <:segm:> and
old_item (1) <> real <:level:> and
old_item (1) <> real <:copy:> and
old_item (1) <> real <:vol:> ) and
(sep_length = point_int
or sep_length = point_txt and item (1) = real <:last:>) then
begin <* <s><tapename>.<fileno> or <s><tapename>.last *>
no_of_vol (copy_count) := 1; <*first volume*>
current_tape := name_field (copy_count, no_of_vol);
tofrom (para_name.current_tape, old_item, 8); <*remember parameter*>
file_no (copy_count) :=
file_no_tape_name (olditem, tapename.current_tape, modekind (copy_count)) +
(if seplength = point_txt and item (1) = real <:last:> then
-8388607
else
round item (1)
);
for seplength := scan_param (item)
while
seplength = point_txt and
item (1) <> real <:label:> and
no_of_vol (copy_count) < max_no_of_vol
do
begin <* .<name next volume> *>
increase (no_of_vol (copy_count)); <*next volume*>
current_tape := name_field (copy_count, no_of_vol);
tofrom (para_name.current_tape, item, 8); <*remember parameter*>
file_no_tape_name (item, tapename.current_tape, modekind (copy_count));
<*a possible file descriptor is looked up and docname returned*>
end <* .<name next volume> *>;
\f
<* sw8010/2, load program page ...104...
1983.07.13 *>
message program page 6;
<*seplength <> point_txt or item(1) = <:label:> or volcount = max*>
if seplength = point_txt and item (1) <> real <:label:> then
begin
param_alarm (out, <:alarm tape param too many volumes:>);
seplength := scan_param (item); <*zero param to stop tape param*>
tape_param_ok := false; <*to prevent default save*>
end else
if seplength = point_txt and item (1) = real <:label:> then
begin <* .label *>
seplength := scan_param (item );
if seplength <> point_txt then
begin
param_alarm (out, <:alarm label param syntax:>);
seplength := scan_param (item); <*zero param to stop tape par*>
tape_param_ok := false; <*to prevent default save*>
end else
begin <* .label.<name> *>
for i := 1, 2 do
dump_label (copy_count, i) := long item (i);
seplength := scan_param (item); <*next param*>
end <* .label.<name> *>;
end <* .label *>;
no_of_copies := copy_count ;
copy_count := copy_count + 1 ;
<* end <s><tapename>.<fileno> or <s><tapename>.last else*>
\f
<* sw8010/2, load program page ...107...
1984.12.04 *>
message program page 7;
end <* <s><tapename>.<fileno> or <s><tapename>.last *> else
<* old_length <> space_txt or old_item (1) = real <:segm:> or*>
<* old_item (1) = real <:level:>or*>
<*(sep_length <> point_int and *>
<*(sep_length <> point_txt or item (1) <> real <:last:> ))*>
<* <=> not <s><tapename>.<fileno> and not <s><tapename>.last *>
if copy_count = 1 or mount_param_spec (copy_count) then
begin
param_alarm (out, <:alarm tape param missing:>);
seplength := scan_param (item); <*zero param to stop tape param*>
tape_param_ok := false; <*to prevent default save*>
end else
begin <*not tape parameter, not required*>
seplength := oldlength ; <*take old parameter into current *>
for i := 1, 2 do
item (i) := olditem (i);
repeat_param := true ; <*repeat the one formerly in current*>
copy_count := 3; <*to stop tape param*>
end <*not tape parameter, not required*>;
until copy_count > 2
or -,tape_param_ok;
\f
<* sw8010/2, load program page ...108...
1984.07.13 *>
message program page 8;
<*maybe special parameter*>
<*initialize special param variables*>
copy_count := 1; <*default copy no*>
basetime :=
baselevel :=
dumplevel := 0; <*default dumplevel*>
load :=
list_entries := true;
test :=
survey :=
check_tape :=
list_only_name := false;
begin <*special block to access program entry*>
zone zprog (1, 1, stderror);
integer array entry (1:17);
open (zprog, 0, progname, 0);
close (zprog, false ); <*wont remove area process*>
monitor (76 )lookup head and tail :( zprog, 0, entry);
progbase_lower := entry (2);
progbase_upper := entry (3);
connect := entry (14) extract 1 = 1;
end <*special block*>;
\f
<* sw8010/2, load program page ...109...
1985.02.06 *>
message program page 9;
<*seplength = space_txt*>
for action := special_param (seplength, item) while action > 0 do
begin <*space_txt and special param*>
seplength := scan_param (item);
case action of
begin
<*vol*>
start_volume := round item (1);
<*copy*>
begin
copy_count := round item (1);
if copy_count > 2 then
copy_count := 1; <*back to default*>
end;
<*segm*>
;
<*level*>
dumplevel :=
if inc_dump then
round item (1)
else
0; <*if not incload ignore level*>
<*list*>
if item (1) <> real <:names:> and
item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning list param unknown:>)
else
if item (1) = real <:names:> then
list_entries := list_only_name := true
else
begin
list_entries := item (1) = real <:yes:>;
list_only_name := false ;
end;
\f
<* sw8010/2, load program page ...110...
1984.07.06 *>
message program page 10;
<*test*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning test param unknown:>)
else
test := item (1) = real <:yes:>;
<*load*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning load param unknown:>)
else
begin
load := item (1) = real <:yes:>;
survey := -, load and survey;
end;
<*survey*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning survey param unknown:>)
else
begin
survey := item (1) = real <:yes:>;
load := -, survey and load;
end;
<*check*>
; <*ignore check param*>
<*connect*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning connect param unknown:>)
else
connect := item (1) = real <:yes:>;
<*reserve*>
; <*ignore reserve param*>
end case action;
seplength := scan_param (item);
end <* space_txt and special param*> ;
\f
<* sw8010/2, load program page ...111...
1984.07.13 *>
message program page 11;
<*load states*>
load_state := before_load_spec := 1;
after_modifier := 2;
after_disc_spec := 3;
after_entry_spec := 4;
after_error := 5;
<*scan the parameter list to count the number of entry specifiers*>
no_of_unknown_discs := 0;
entry_spec_count := 1;
for action := load_specifier (seplength, item) while action > 0 do
begin <*modifier, disc specifier or entry specifier*>
case action of
begin
begin <*changedisc or changekit*>
for seplength := scan_param (item) while seplength = point_txt do
begin <*the first of a pair*>
seplength := scan_param (item); <*the next of a pair*>
end <*the first of a pair*>;
load_state := after_modifier;
end <*changedisc or changekit*>;
begin <*newscope*>
seplength := scan_param (item);
seplength := scan_param (item); <*get next item*>
loadstate := after_modifier ;
end <*newscope*>;
\f
<* sw8010/2, load program page ...114...
1984.07.13 *>
message program page 12;
<*case action of*>
begin <*disc or kit specifier*>
for seplength := scan_param (item) while seplength = point_txt do
begin <*parameter accepted*>
for i := 1, 2 do
disc_spec_name (i) := long item (i);
if disc_spec_name (1) = long <:mainc:> add 'a' and
disc_spec_name (2) = long <:tdisc:> then
begin <*disc.maincatdisc*>
for i := 1, 2 do
disc_spec_name (i) := incl_discname (maincatdisc, i);
end;
j := 0;
for i := 1 step 1 until no_of_discs do
if disc_spec_name (1) = incl_discname (i, 1) and
disc_spec_name (2) = incl_discname (i, 2)
or disc_spec_name (1) = long <:main:>
or disc_spec_name (1) = long <:all:> then
<*disc found in disc name table or disc.all*>
j := i;
if j = 0 then
increase (no_of_unknown_discs);
end <*parameter accepted*>;
load_state := after_disc_spec;
end <*disc or kit specifier*>;
\f
<* sw8010/2, load program page ...115...
1984.07.13 *>
message program page 13;
<*case action of*>
begin <*entry specifier*>
<* <s><name>, neither a modifier nor a disc specifier*>
for action :=
entry_specifier (point_txt, item, true <*look ahead*>),
entry_specifier (seplength, item, true <*look ahead*>) while action > 0 do
begin <* .scope, .docname or .<name> *>
case action of
begin <*qualifier or entry name*>
<* .scope *>
seplength := scan_param (item);
<* .docname *>
seplength := scan_param (item);
<* .<entry name> *>
;
end <*case action qualifier or entry name*>;
seplength := scan_param (item);
end while action > 0;
\f
<* sw8010/2, load program page ...117...
1985.02.06 *>
message program page 14;
if load_state <> after_error then
load_state := after_entry_spec;
if load_state = after_entry_spec then
increase (entry_spec_count);
end <*entry specifier*>;
end <*case action*>;
end while action > 0;
if load_state = after_entry_spec then
entry_spec_count := entry_spec_count - 1;
no_of_entry_specs := entry_spec_count;
if no_of_unknown_discs = 0 then
no_of_unknown_discs := 1; <*at least one unknown for any disc*>
message listfile 1;
if test then
begin
integer i;
boolean b;
write (out,
"nl", 2, <:special parameters read first time around ::>,
"nl", 1, <:vol, copy, segm, level, list, test, load, survey, connect:>,
"nl", 1, << ddddddd>, startvolume, copycount, segm, dumplevel);
for i := 1 step 1 until 5 do
begin
b := case i of (listentries, test, load, survey, connect);
write (out, if b then <: yes:> else <: no:>);
end;
write (out,
"nl", 2, <:specifiers read first time around ::>,
"nl", 2, <:no of entry specs = :>, noofentryspecs,
"nl", 1, <:no of discs = :>, noofdiscs,
"nl", 1, <:no of unkn discs = :>, noofunknowndiscs,
"nl", 1, <:load state = :>, case loadstate of (
<:before load spec:>, <:after modifier:>, <:after disc spec:>,
<:after entry spec:>, <:after error:>) );
end <*test*>;
\f
<* sw8010/2, load declarations third block page ...111...
1984.07.13 *>
message decl. third block page 1;
if tapeparam_ok then
begin <*block for declarations of discname, new_discname*>
long array discname,
new_discname (1:no_of_entry_specs ,
1:no_of_discs + no_of_unknown_discs,
1:2 );
boolean array disc_specified (1:no_of_entry_specs ,
1:no_of_discs + no_of_unknown_discs);
long array name,
docname (1:no_of_entry_specs ,
1:2 );
integer array scope,
new_scope (1:no_of_entry_specs);
\f
<* sw8010/2, load program page ...105...
1984.12.04 *>
message program page 15;
<*scan parameters again until load specifier without recording*>
prepare_param_scan (0); <*start all over again*>
<*maybe mount parameters, tape parameters*>
for j := 1 step 1 until no_of_copies do
begin <*for each copy*>
vol_count (j) := 1; <*first volume in the copy set*>
current_tape := name_field (j, vol_count);
if test then
write (out,
"nl", 2, <:skip mount params copy no :>, j);
repeat
seplength := scan_param (item);
if test then
write_param (out, seplength, item);
until
item (1) = real para_name.current_tape (1) and
item (2) = real para_name.current_tape (2) ;
if test then
write (out,
"nl", 1, <:skip tape params copy no :>, j);
for i := 1 step 1 until no_of_vol (j) do
begin
seplength := scan_param (item); <*from volume no 2 until file number*>
if test then
write_param (out, seplength, item);
end;
if dumplabel (j, 1) <> long <::> then
for i := 1, 2 do
seplength := scan_param (item); <*.label.<label>*>
end <*for each copy*>;
seplength := scan_param (item); <*first param after tape param*>
if test then
begin
write (out,
"nl", 2, <:after skip of mount and tape parameters :>);
write_param (out, seplength, item);
end;
\f
<* sw8010/2, load program page ...108...
1984.10.02 *>
message program page 16;
<*maybe special parameter*>
<*seplength = space_txt*>
for action := special_param (seplength, item) while action > 0 do
begin <*space_txt and special param*>
seplength := scan_param (item);
case action of
begin
<*vol*>
;
<*copy*>
;
<*segm*>
;
<*level*>
;
<*list*>
if item (1) <> real <:names:> and
item (1) <> real <:yes:> and
item (1) <> real <:no:> then
; <*dummy*>
<*warning list param unknown*>
<*else ok, skip*>
\f
<* sw8010/2, load program page ...110...
1984.08.14 *>
message program page 17;
<*test*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
; <*dummy*>
<*warning test param unknown*>
<*else ok, skip*>
<*load*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
; <*dummy*>
<*warning load param unknown*>
<*else ok, skip*>
<*survey*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
; <*dummy*>
<*warning survey param unknown*>
<*else ok, skip*>
<*check*>
; <*ignore check param*>
<*connect*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
; <*dummy*>
<*warning connect param unknown*>
<*else ok, skip*>
end case action;
seplength := scan_param (item);
end <* space_txt and special param*> ;
if test then
begin
write (out,
"nl", 2, <:after skip special parameters ::>);
write_param (out, seplength, item);
end;
\f
<* sw8010/2, load program page ...111...
1985.02.06 *>
message program page 18;
<*load state*>
load_state := before_load_spec;
<*load specifier*>
<*initialize load specifier variables*>
anyscope := 0; all := 1; perm := 2;
sistem := 3; owen := 4; project := 5;
user := 6; login := 7; temp := 8;
for entry_spec_count := 1 step 1 until no_of_entry_specs do
begin <*for each entry specifier*>
for i := 1, 2 do
name (entry_spec_count, i) :=
doc_name (entry_spec_count, i) := long <::>; <*default no name/docname*>
____scope (entry_spec_count) := any_scope; <*default : any *>
new_scope (entry_spec_count) := any_scope; <*default : no change of scope*>
for i := 1 step 1 until no_of_discs + no_of_unknown_discs do
begin
disc_specified (entry_spec_count, i) := i <= no_of_discs + 1;
<*default : all known + any unknown*>
for j := 1, 2 do
new_discname (entry_spec_count, i, j) :=
____discname (entry_spec_count, i, j) :=
if i <= no_of_discs then
incl_disc_name (i, j)
else
long <::>;
<*default : all discs included are specified, no change disc*>
end;
end <*for each entry specifier*>;
\f
<* sw8010/2, load program page ...112...
1985.02.12 *>
message program page 19;
<*interpret load specifiers*>
entry_spec_count := 1;
for action := load_specifier (seplength, item) while action > 0 do
begin <*modifier, disc specifier or entry specifier*>
case action of
begin
begin <*changedisc or changekit*>
for seplength := scan_param (item) while seplength = point_txt do
begin <*the first of a pair*>
for i := 1, 2 do
from_to_discname (1, i) := long item (i);
seplength := scan_param (item); <*the next of a pair*>
if seplength <> point_txt and
(seplength <> point_int
or round item (1) >= 2) then
begin <*give it up*>
param_warning (out, <:warning changedisc param syntax:>);
from_to_discname (2, 1) := long <:no:>; <*no change*>
end <*give it up*> else
if seplength = point_int then
begin <*discname = 0 or 1*>
from_to_discname (2, 1) := extend (round item (1)) shift 24 add 1;
from_to_discname (2, 2) := long <::> ;
end else
for i := 1, 2 do
from_to_discname (2, i) := long item (i);
for i := 1, 2 do
if from_to_discname (i, 1) = long <:mainc:> add 'a' and
from_to_discname (i, 2) = long <:tdisc:>
or i=2 and
from_to_discname (i, 1) = long <:main:> then
begin <*from- or to-disc = maincatdisc or to-disc = main*>
for j := 1, 2 do
from_to_discname (i, j) := incl_disc_name (maincatdisc, j);
end;
\f
<* sw8010/2, load program page ...111...
1985.02.06 *>
message program page 20;
for i := 1 step 1 until no_of_discs + no_of_unknown_discs do
begin
if (from_to_discname (1, 1) = long <:all:>
or from_to_discname (1, 1) = long <:main:>) and i <= no_of_discs
or from_to_discname (1, 1) = long <:any:> and i > no_of_discs
or from_to_discname (1, 1) = disc_name (entry_spec_count, i, 1) and
from_to_discname (1, 2) = disc_name (entry_spec_count, i, 2) then
begin <*either from-disc = all, main or any or from-disc found*>
<*record modifier in modifier table of each succeeding spec*>
for k := entry_spec_count step 1 until no_of_entry_specs do
for j := 1, 2 do
new_discname (k, i, j) :=
if from_to_discname (2, 1) = long <:no:> then
discname (entry_spec_count, i, j)
else
from_to_discname (2, j);
end <*either*>;
end for i := 1;
end <*the first of a pair*>;
load_state := after_modifier;
end <*changedisc or changekit*>;
\f
<* sw8010/2, load program page ...113...
1984.07.13 *>
message program page 21;
<*case action of*>
begin <*newscope*>
seplength := scan_param (item);
if seplength <> point_txt then
param_warning (out, <:warning newscope param syntax:>)
else
begin <*parameter accepted*>
j := -1;
for i := temp step (-1) until project, any_scope do <*87650*>
if item (1) = real ( case (9-i) of (
<:temp:> , <:login:>, <:user:> , <:proje:> add 'c',
<::> , <::> , <::> , <::> ,
<:no:> )) and
item (2) = real ( case (9-i) of (
<::> , <::> , <::> , <:t:> ,
<::> , <::> , <::> , <::> ,
<::> )) then
begin j := i; i := any_scope; end;
if j = -1 then
param_warning (out, <:warning newscope param unknown:>)
else
for k := entry_spec_count step 1 until no_of_entry_specs do
new_scope (k) := j;
end <*parameter accepted*>;
seplength := scan_param (item); <*get next item*>
load_state := after_modifier ;
end <*newscope*>;
\f
<* sw8010/2, load program page ...114...
1984.08.15 *>
message program page 22;
<*case action of*>
begin <*disc or kit specifier*>
if scan_param (item) = point_txt then
begin <*first disc specifier param will be accepted*>
for k := entry_spec_count step 1 until no_of_entry_specs do
for i := 1 step 1 until no_of_discs + no_of_unknown_discs do
begin
disc_specified (k, i) := false; <*disc specifiers erased*>
if i > no_of_discs then
for j := 1, 2 do
___discname (k, i, j) :=
newdiscname (k, i, j) := long <::>;
end;
end <*first disc specifier will be accepted*>;
repeat_param := true;
for seplength := scan_param (item) while seplength = point_txt do
begin <*parameter accepted*>
for i := 1, 2 do
disc_spec_name (i) := long item (i);
if disc_spec_name (1) = long <:mainc:> add 'a' and
disc_spec_name (2) = long <:tdisc:> then
begin <*disc.maincatdisc*>
for i := 1, 2 do
disc_spec_name (i) := incl_discname (maincatdisc, i);
end;
\f
<* sw8010/2, load program page ...111...
1985.02.06 *>
message program page 23;
<*find disc specified in disc name table for entry spec*>
j := 0;
for i := 1 step 1 until no_of_discs + no_of_unknown_discs do
if disc_spec_name (1) = discname (entry_spec_count, i, 1) and
disc_spec_name (2) = discname (entry_spec_count, i, 2)
or (disc_spec_name (1) = long <:main:>
or disc_spec_name (1) = long <:all:> and i <= no_of_discs) then
begin <*disc found in disc name table or disc.all*>
for k := entry_spec_count step 1 until no_of_entry_specs do
begin
disc_specified (k, i) := true;
for j := 1, 2 do
___discname (k, i, j) :=
newdiscname (k, i, j) := discname (entry_spec_count, i, j);
j := i;
end;
end;
i := no_of_discs;
if j = 0 then
begin <*disc specified unknown, insert in next idle*>
repeat
i := i + 1;
until discname (entry_spec_count, i, 1) = long <::>;
for k := entry_spec_count step 1 until no_of_entry_specs do
begin
for j := 1, 2 do
____discname (k, i, j) :=
new_discname (k, i, j) :=
if disc_specname (1) = long <:any:> then
long <::>
else
disc_specname (j);
disc_specified (k, i ) := true;
end;
end <*disc specified unknown*>;
end <*parameter accepted*>;
load_state := after_disc_spec;
end <*disc or kit specifier*>;
\f
<* sw8010/2, load program page ...115...
1984.07.13 *>
message program page 24;
<*case action of*>
begin <*entry specifier*>
<* <s><name>, neither a modifier nor a disc specifier*>
scope (entry_spec_count) := any_scope; <*back to default*>
for action :=
entry_specifier (point_txt, item, true <*look ahead*>),
entry_specifier (seplength, item, true <*look ahead*>) while action > 0 do
begin <* .scope, .docname or .<name> *>
case action of
begin <*qualifier or entry name*>
begin <* .scope *>
seplength := scan_param (item);
if seplength <> point_txt then
begin
param_warning (out, <:warning scope param syntax:>);
load_state := after_error;
end else
begin <* .scope.<name> *>
j := 0;
for i := all step 1 until temp do
if item (1) = real ( case i of (
<:all:> , <:perm:> , <:syste:> add 'm',
<:own:> , <:proje:> add 'c', <:user:> ,
<:login:> , <:temp:> )) and
item (2) = real ( case i of (
<::> , <::> , <::> ,
<::> , <:t:> , <::> ,
<::> , <::> )) then
begin j := i; i := temp; end;
if j = 0 then
begin
param_warning (out, <:warning scope param unknown:>);
load_state := after_error;
end;
scope (entry_spec_count) := j;
end <* .scope.<name> *>;
end <* .scope *>;
\f
<* sw8010/2, load program page ...116...
1984.07.13 *>
message program page 25;
<*case action of *>
<*begin qualifier or entry name*>
begin <* .docname *>
seplength := scan_param (item);
if seplength <> point_txt then
begin
param_warning (out, <:warning docname param syntax:>);
load_state := after_error;
end else
for i := 1, 2 do
docname (entry_spec_count, i) := long item (i);
end <* .docname *>;
begin <* .<entry name> *>
if item (1) = real <:c:>
or item (1) = real <:v:>
or item (1) = real <:primo:> add 'u' and
item (2) = real <:t:> then
begin
param_warning (out, <:warning name illegal:>);
load_state := after_error;
end else
if name (entry_spec_count, 1) <> 0 then
begin <*name already assigned*>
param_warning (out, <:warning name double defined:>);
<*load state unchanged => entry specifier maybe recorded*>
end else
for i := 1, 2 do
name (entry_spec_count, i) := long item (i);
end <* .<entry name> *>;
end <*case action qualifier or entry name*>;
seplength := scan_param (item);
end while action > 0;
\f
<* sw8010/2, load program page ...117...
1984.08.15 *>
message program page 26;
if load_state <> after_error then
load_state := after_entry_spec;
if load_state = after_entry_spec then
increase (entry_spec_count);
for i := entry_spec_count step 1 until no_of_entry_specs do
begin <*next and following entry specifiers back to default*>
for j := 1, 2 do
___name (i, j) :=
docname (i, j) := long <::>;
scope (i) := any_scope;
end <*next and following*>;
end <*entry specifier*>;
end <*case action*>;
end while action > 0;
<*action = 0 : not <s><name>, maybe zero*>
while seplength <> 0 do
begin <*skip until end of parameter list with warning for each*>
param_warning (out, <:warning load spec param unknown:>);
seplength := scan_param (item);
end;
if load_state = after_entry_spec then
entry_spec_count := entry_spec_count - 1;
if entry_spec_count <> no_of_entry_specs then
param_alarm (out, <:alarm entry specifiers not properly recorded:>);
message listfile 2;
if test then
begin <*1*>
long array name1, name2 (1:2);
integer i;
boolean b;
write (out,
"nl", 1, <:special parameters::>,
"nl", 1, <:copy, vol, segm, level, list, test, load, survey, connect:>,
"nl", 1, << ddddddd>,copycount, startvolume, segm, dumplevel);
for i := 1 step 1 until 5 do
begin
b := case i of (listentries, test, load, survey, connect);
write (out, if b then <: yes:> else <: no:>);
end;
write (out,
"nl", 2, <:specifiers : :>,
"nl", 2, <:no of entry specifiers = :>, noofentryspecs,
"nl", 1, <:no of discs = :>, noofdiscs,
"nl", 1, <:no of unknown discs = :>, noofunknowndiscs);
for entryspeccount := 1 step 1 until noofentryspecs do
begin <*2*>
write (out,
"nl", 2, <:next specifier ::>);
for i := 1 step 1 until noofdiscs + noofunknowndiscs do
begin <*3*>
for j := 1, 2 do
begin <*4*>
name1 (j) := ___discname (entryspeccount, i, j);
name2 (j) := newdiscname (entryspeccount, i, j);
end <*4*>;
write (out,
"nl", 1, <:disc = :>, true, 12, name1,
<:new disc = :>, true, 12, name2,
"sp", 3, <:spec = :>,
if discspecified (entryspeccount, i) then <:yes:> else <:no:>);
end <*3*>;
for j := 1, 2 do
begin <*3*>
name1 (j) := ____name (entryspeccount, j);
name2 (j) := doc_name (entryspeccount, j);
end <*3*>;
write (out,
"nl", 1, <:name = :>, name1,
"nl", 1, <:scope = :>, case (___scope (entryspeccount) + 1) of (
<:any:> , <:all:> , <:perm:> , <:system:>, <:own:>,
<:project:>, <:user:>, <:login:>, <:temp:> ),
"nl", 1, <:new scope = :>, case (newscope (entryspeccount) + 1) of (
<:any:> , <:all:> , <:perm:> , <:system:>, <:own:>,
<:project:>, <:user:>, <:login:>, <:temp:>),
"nl", 1, <:docname = :>, name2);
end <*2*>;
end <*1*>;
\f
<* sw8010/2, load prepare tape zones page ...110...
1987.04.29 *>
message prepare tapes page 1;
<*prepare tape*>
vol_count (copy_count) :=
if start_volume < 1 then
1
else
if start_volume > no_of_vol (copy_count) then
no_of_vol (copy_count)
else
startvolume;
begin <*prepare tape, maybe search the volume, file and block*>
integer array zdescr (1:20);
zone array ztape (1, 128, 1, end_of_document);
get_fileno (ztape (1), copy_count, no_of_copies, vol_count, no_of_vol,
tapename , device_no , modekind ,
file_no , block__no );
current_tape := name_field (copy_count, vol_count); <*tape name*>
open_tape (ztape (1), deviceno (copy_count),
modekind (copy_count), tapename.current_tape);
<*zone.partial word := index := 1*>
setposition (ztape (1), fileno (copy_count), blockno (copy_count));
<*get version dump or continue label*>
current_tape := name_field (copy_count, vol_count); <*tape name*>
label_name := copy_count * 8; <*fields labelname in dumplabel*>
if get_labelrec (ztape (1), segm, entries_in_partcat, entries_in_savecat,
savecat_name, savecat_base, savecat_size, dumptime,
version_id , release_id, aux_synclength , sync_blocklength) then
<*record the position of the tape*>
getposition (ztape (1), fileno (copy_count), blockno (copycount))
else
terminate_alarm (out,
<:no dump label found on volume tape, file no:>,
tapename.current_tape, fileno (copycount), <: block no :>, blockno (copy_count));
if test then
begin real hms;
write (out,
"nl", 2, <:segm = :>, segm,
"nl", 1, <:entries in partcat = :>, entriesinpartcat,
"nl", 1, <:entries in savecat = :>, entriesinsavecat,
"nl", 1, <:savecat name = :>, savecatname,
"nl", 1, <:savecat base = :>, savecatbase (1),
"nl", 1, <: :>, savecatbase (2),
"nl", 1, <:savecat size = :>, savecatsize,
"nl", 1, <:dumptime = :>, <<zddddd>,
systime (6, dumptime, hms), <:.:>, <<zddd>, entier (hms/100),
"nl", 1, <:version = :>, <<zddddd>, versionid,
"nl", 1, <:release = :>, releaseid,
"nl", 1, <:aux synclength = :>, aux_synclength,
"nl", 1, <:sync blocklength = :>, syncblocklength);
end;
end <*prepare tape*>;
\f
<* sw8010/2, load declarations fourth block page ... xx...
1985.01.16 *>
message declare zones page 1;
no_of_shares := 2; <*basta*>
bufs_needed := 2 * (no_of_shares - 1); <*2 zones*>
<*buffers for iorec*>
bufs_needed := bufs_needed + 1;
if buf_claim < bufs_needed then
begin
write_alarm (out, <:buffer claim, needed ::>);
write (out, << ddd>, bufs_needed + 1, <:, claim ::>, buf_claim + 1,
"nl", 1);
trap (-1); <*to slutlabel to unstack current out*>
end;
buf_length := buflengthio (2, no_of_shares, segm * 512);
<*minimum for openio/inoutrec with blocklength segm * 512*>
begin <*declarations of disc and tape zones, fourth block level*>
zone array ztape (
2 ,
buflength ,
no_of_shares ,
end_of_document);
\f
<* sw8010/2, load prepare savecat and loadcat page ... xx...
1984.08.28 *>
message prepare save-loadcat page 1;
if false then
traplabel:
begin <*traproutine to release and remove processes*>
maybe_device_status (out);
getstate (ztape (1), i);
if i = 32 <*after openinout *>
or i = 40 <*after openinout on mt*>
or i = 41 <*after inoutrec *> then
closeinout (ztape); <*stop zones and reallocate*>
fpproc (33) out end :(0, out, 'nul');
close (ztape (1),
if release (copy_count) then false add 1 else false);
close (ztape (2), true); <*release and remove*>
trapmode := 1 shift 13; <*ignore trap message*>
trap (1); <*next trap label*>
end <*trap routine*>;
\f
<* sw8010/2, load prepare savecat and loadcat page ... xx...
1988.11.17 *>
message prepare save-loadcat page 2;
trap (traplabel); <*to release and remove processes*>
<*maybe create save catalog file, connect zsavecat and get head*>
<*check savecat file*>
savecatfile_connected :=
connect_savecatfile (zsavecat, savecatname, savecatbase,
savecatsize, dumptime );
if inc_dump and savecatfile_connected then
open (ztape (2), 4, savecat_name, 0 ) <*no output*>
else
begin <*create file and transfer save catalog*>
savecat_name (1) := long <::>;
connect_alarm (out , savecat_name,
connect_output (ztape (2), 4, savecat_name, savecatsize, 0)); <*output*>
close (zsavecat , false );
open (zsavecat , 4, savecat_name, 0 ); <*input*>
end;
current_tape := name_field (copy_count, vol_count);
open_tape (ztape (1), deviceno (copy_count), modekind (copycount),
tapename.current_tape);
setposition (ztape (1), fileno (copycount), blockno (copycount));
reading_savecat := true;
segments :=
transfer (ztape, copycount , no_of_copies, fileno, blockno,
savecatsize, end_of_doc ,
inc_dump and savecat_file_connected <*expell*>);
reading_savecat := false;
if segments <> savecatsize then
terminate_alarm (out,
<:incomplete save catalog transferred from tape:>,
tapename.current_tape, savecatsize, <: transferred : :>, abs (segments));
savecat_recstart := in_savecat_head (zsavecat);
<*no_of_copies and no_of_vol (1:2) overwritten*>
if test then
begin integer copy, v; integer array vol (1:2); long array field name;
write (out,
"nl", 2, <:incdump = :>, if incdump then <:yes:> else <:no:>,
"nl", 2, <:savecat file conn. = :>, if savecatfileconnected then <:yes:> else <:no:>,
"nl", 1, <:savecat name = :>, savecatname,
"nl", 1, <:savecat recstart = :>, savecatrecstart,
"nl", 1, <:no of copies, vol = :>, noofcopies, noofvol (1), noofvol (2),
"nl", 1, <:segm = :>, segm);
for copy := 1 step 1 until noofcopies do
for v := 1 step 1 until noofvol (copy) do
begin
vol (copy) := v;
name := namefield (copy, vol);
write (out,
"nl", 1, <:tape name = :>, tapename.name);
end;
write (out,
"nl", 1, <:copy count = :>, copycount,
"nl", 1, <:vol count = :>, volcount (copycount));
end;
savecat_reclength := if no_of_copies = 1 then 58 else 64;
<*connect zsavecat to area, create area process*>
loadcat_name (1) := long <::>;
connect_alarm (out , loadcat_name,
connect_output (zloadcat, 4 , loadcat_name, savecatsize, 0));
\f
<* sw8010/2, load load entries page ... xx...
1985.02.07 *>
message store entries in cat page 1;
<*store into load catalog entries from save catalog qualifying specs*>
entries_stored :=
store_entries (zloadcat , zsavecat , savecat_reclength ,
name , scope , newscope, docname ,
no_of_entry_specs, disc_specified, discname, new_discname);
close (zsavecat, false); <*finish*>
disconnect_output (zloadcat, false); <*cut *>
<*load entries recorded in load catalog*>
entries_loaded :=
if entries_stored > 0 then
load_entries (
ztape , copy_count , no_of_copies , vol_count ,
zloadcat, loadcatname, entries_stored , savecat_reclength,
zpartcat, partcatname, entries_in_partcat , segs_loaded )
else
0;
if entries_loaded = 0
or entries_stored = 0 then
begin <*no entries found or no entries loaded*>
if entries_stored = 0
or load then
begin <*warning*>
list_specifiers (out,
write_alarm (out,
if entries_stored = 0 then
<:no entries found:>
else
<:no entries loaded:>),
no_of_entry_specs, no_of_discs + no_of_unknown_discs, disc_specified,
discname , name , scope , docname );
error_bits := 2; <*warning.yes, ok.yes*>
end <*warning*> else
<*message*>
write (out,
"nl", 2, <:nothing loaded because of :>,
if survey then <:survey.yes:> else <:load.no:>);
end <*no entries found or no entries loaded*>;
\f
<* sw8010/2, load end third and fourth block page ...118...
1984.08.28 *>
message end fourth block page 1;
<*finish tape*>
out_endmess (out, ztape (1), total_entrycount, total_segmcount);
fpproc (33 )out end:( 0, out, 'nul');
<*outend on current out before possible release message*>
<*if parent is s output would be mixed with message *>
close (ztape (1),
if release (copy_count) then false add 1 else false); <*maybe rel*>
end <*declarations of disc and tape zones, fourth block level*>;
end <*declarations of specifier arrays, third block level*>;
\f
<* sw8010/2, load program page ...119...
1984.11.20 *>
message program page 27;
getzone_6 (out, zdescr);
if tapeparam_ok and zdescr (1) extract 12 = 4 then
begin <*write load statistics*>
list_______counters (out, entry_count, slice_count);
list_total_counters (out, entries_loaded , segs_loaded ,
total_entry_count, total_segm_count);
end <*write load statistics*>;
\f
<* sw8010/2, load program tail page ...120...
1984.10.31 *>
message program tail page 1;
if false then
slutlabel:
begin <*after rs alarm*>
maybe_device_status (out);
errorbits := 3; <*warning, alarm*>
end;
<*maybe remove save catalog, remove partial catalog*>
close (zsavecat, true); <*remove process in not already removed*>
close (zloadcat, true); <*remove ...*>
close (zpartcat, true); <*remove ...*>
if -, savecatfile_connected then
monitor (48) remove entry :(zsavecat, 1, dummyia);
__monitor (48) remove entry :(zloadcat, 1, dummyia);
__monitor (48) remove entry :(zpartcat, 1, dummyia);
if chain_name (1) <> real <::> then
unstack_current_output;
end <*second level*>;
end;
▶EOF◀