|
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: 301824 (0x49b00)
Types: TextFile
Names: »save3tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »save3tx «
begin
\f
<* sw8010/2, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save 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, save parameter scanning page ... 36...
1981.12.07 *>
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 := 2; <*1<1 <=> 1 segment, preferably on drum*>
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, save 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, save parameter scanning page ... 38...
1984.04.25 *>
message connect output page 1;
integer
procedure connect__output (z, kind, name, giveup);
value giveup ;
zone z ;
long array name ;
integer kind, 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 := 1 shift 1; <*one slice, pref drum*>
fpproc (28, result, z, name);
connect_output := result;
end connect_output;
\f
<* sw8010/2, save 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, save 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, save 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, save decl. for parameters/discs page ... 38...
1985.01.16 *>
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 *>
test ,
reserve , <*unused *>
inc_dump ,
ida_copy ,
tape_param_ok ;
boolean array end_of_doc ,
expell_zone (1:3),
release , <*mount param *>
mount_param_spec (1:2), <*mount param *>
disc_specified (1:no_of_discs); <*save specifier*>
\f
<* sw8010/2, save 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 ,
copy_count ,
no_of_copies ,
no_of_shares ,
no_of_ida_shares ,
buflength ,
scope ,
new_scope ,
save_state ,
before_save_spec ,
after_modifier ,
after_disc_spec ,
after_entry_spec ,
after_error ,
any_scope ,
all ,
perm ,
sistem ,
owen ,
project ,
user ,
login ,
temp ,
result ,
maincat_disc ,
main_proc ,
main_kind ,
progbase_lower ,
progbase_upper ,
buf__claim ,
area_claim ,
bufs_needed ,
areas_needed ,
segm ,
savecat_size ,
savecat_reclength ,
savecat_recstart ,
baselevel ,
basetime ,
dumplevel ,
dumptime ,
version_id ,
release_id ,
syncblocklength ,
aux_synclength ,
entries_in_partcat ,
entries_stored ,
entries_saved ,
total_entries_stored ,
total_entry_count ,
total_segm__count ,
dummy ,
i ,
j ,
k ;
\f
<* sw8010/2, save decl. for parameters/discs page ... 39...
1984.10.31 *>
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),
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 ,
name ,
docname ,
mainname ,
partcat_name ,
savecat_name ,
disc_spec_name (1:2),
dump_label ,
from_to_discname (1:2 ,
1:2),
tape_name (1:2 ,
1:2 * max_no_of_vol),
auxcat_name ,
disc_name ,
new_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_savecat (128, 1, stderror);
\f
<* sw8010/2, save parameter scanning page ... xx...
1984.04.30*>
message get level clock page 1;
integer
procedure get_level_clock (dumplevel, baselevel);
value dumplevel ;
integer dumplevel, baselevel ;
<***********************************************************>
<* *>
<* The procedure looks up in the catalog a user entry with *>
<* the greatest level number less than the dumplevel given.*>
<* If such an entry exists the shortclock from its tail and*>
<* and level number is returned. If no such entry exists, a*>
<* shortclock of zero and a level number of zero is retur- *>
<* ned. *>
<* *>
<* Call : get_level_clock (dumplevel, baselevel); *>
<* *>
<* get_level_clock (return value, integer). The short- *>
<* clock from the entry tail of the user *>
<* entry with the greatest level number *>
<* less than the dumplevel, or zero if no *>
<* such entry exists. *>
<* dumplevel (call value, integer). The dumplevel *>
<* given. *>
<* baselevel (return value, integer). The level num-*>
<* ber from the entry found or zero if no *>
<* entry is found. *>
<* *>
<***********************************************************>
begin
integer result, i;
integer array entry (1:17), user (1:2);
long array level (1:2);
zone z (1, 1, stderror);
own
boolean userbase_set;
\f
<* sw8010/2, save parameter scanning page ... xx...
1984.05.07 *>
message get level clock page 2;
for i := 1, 2 do
user (i) := user_base (i); <*from long array to integer array*>
level (1) := long <:level:>;
level (2) := long <::> ;
if dumplevel > 9 then dumplevel := 9;
if dumplevel <= 0 then
get_level_clock := base_level := 0
else
begin <*positive dumplevel*>
if -,userbase_set then
begin
set_catbase (user);
userbase_set := true;
end;
level (1) := level (1) add ('0' + dumplevel - 1); <*lookup lower level*>
open (z, 0, level, 0);
close (z, true);
result := monitor (76) lookup head and tail :(z, 1, entry);
if result = 0 and
entry (2) = user_base (1) and
entry (3) = user_base (2) and
entry (1) extract 3 = 3 then
begin <*entry exists*>
base_level := dumplevel - 1;
get_level_clock := entry (13) ; <*shortlock*>
end else
get_level_clock := get_level_clock (dumplevel - 1, baselevel);
if userbase_set then
begin
reset_catbase;
userbase_set := false;
end;
end <*positive dumplevel*>;
end get_level_clock;
\f
<* sw8010/2, save parameter scanning page ... xx...
1984.04.30*>
message set level clock page 1;
integer
procedure set_level_clock (dumplevel, shortclock);
value dumplevel, shortclock ;
integer dumplevel, shortclock ;
<*********************************************************>
<* *>
<* The procedure creates an entry named 'level' concat *>
<* dumplevel digit with a shortclock in word six of the *>
<* tail as given by shortclock and scopes it user. *>
<* If the entry cannot be created/permanented/base chan- *>
<* ged, an alarm is written and the parameter list is ex-*>
<* hausted to terminate the program when parameters are *>
<* needed. *>
<* *>
<* Call : set_level_clock (dumplevel, shortclock); *>
<* *>
<* set_level_ *>
<* clock (return value, integer). The result of crea-*>
<* te / permanent / changebase entry. *>
<* dumplevel (call value,integer). The dumplevel given *>
<* is converted to zero or nine if outside the *>
<* interval. *>
<* shortclock(call value, integer). The shortclock given.*>
<* *>
<*********************************************************>
begin
integer result, i;
integer array entry (1:17), tail (1:10), user (1:2);
long array level (1:2);
integer array field tailpart;
zone z (1, 1, stderror);
\f
<* sw8010/2, save parameter scanning page ... xx...
1984.05.07 *>
message set level clock page 2;
tailpart := 14; <*fields tailpart of entry head and tail*>
if dumplevel < 0 then dumplevel := 0;
if dumplevel > 9 then dumplevel := 9;
for i := 1, 2 do
user (i) := user_base (i); <*from long array to integer array*>
level (1) := long <:level:> add ('0' + dumplevel); <*level concat level digit*>
level (2) := long <::>;
open (z, 0, level, 0);
close (z,true);
set_catbase (user);
result := monitor (76) lookup head and tail :(z, 1, entry);
reset_catbase;
if result = 0 and
entry (2) = user_base (1) and
entry (3) = user_base (2) and
entry (1) extract 3 = 3 <*permkey*> then
begin <*entry exists as user entry*>
for i := 1 step 1 until 10 do
tail (i) := entry.tailpart (i);
tail (6) := shortclock;
set_catbase (user);
monitor_alarm (out, 44, level,
monitor (44) change entry :(z, 1, tail));
reset_catbase;
<*end else*>
\f
<* sw8010/2, save parameter scanning page ... xx...
1984.05.07 *>
message set level clock page 3;
end else
begin <*entry does not exist or not user*>
for i := 1 step 1 until 10 do
tail (i) := 0;
tail (1) := 3; <*size*>
tail (2) := 1; <*disc*>
tail (6) := shortclock;
result := monitor (40) create entry:(z, 1, tail);
if result = 3 <*name conflict*> then
result := 0;
if result > 0 then
monitor_alarm (out, 40, level, result)
else
begin <*created*>
result := monitor (50) permanent :(z, 3 <*key*>, tail);
if result > 0 then
monitor_alarm (out, 50, level, result)
else
begin <*permanented*>
result := monitor (74) set entry base :(z, 1, user);
if result > 0 then
monitor_alarm (out, 74, level, result);
end <*permanented*>;
end <*created*>;
end <*does not exist or not user*>;
set_level_clock := result;
end set_level_clock;
\f
<* sw8010/2, save parameter scanning page ... xx...
1984.04.30 *>
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 , 74 or 44) *>
<* 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 = 74 then 3 else 4;
startpos :=
write_alarm (z, case entry of (
<:create entry:> ,
<:permanent entry:>,
<:set entry base:> ,
<:change entry:> ));
write (z, name,
"nl", 1, "sp", startpos, case result of (
<::>,
<:catalog i/o error/document not ready:>,
<:name conflict/not found:>,
case entry of (<:claims exceeded:>,
<:entry protected/key illegal:>,
<:entry protected/base illegal:>,
<:entry protected:>),
case entry of (<:catbase outside std base:>,
<:reserved by another:>,
<:used by another:>,
<:reserved by another:>),
case entry of (<:name format illegal:>,
<:claims exceeded:>,
<:name format illegal:>,
<:new size illegal/claims exceeded:>),
<:maincat not present:>));
end;
end monitor alarm;
\f
<* sw8010/2, save parameter interpretation page ... 40...
1981.12.04*>
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 -"- , -"- mto, mtlh *>
<* 4 -"- , -"- mte *>
<* 5 -"- , -"- nrz, mtll *>
<* 6 -"- , -"- nrze *>
<* 7 -"- , -"- mthh *>
<* 8 -"- , -"- 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, save parameter interpretation page ... 41...
1984.05.30 *>
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 8) do
if item (1) = real ( case i of (
<:mount:> add 's',
<:relea:> add 's',
<:mtlh:> ,
<::> ,
<:mtll:> ,
<::> ,
<:mthh:> ,
<:mthl:> ) ) and
item (2) = real ( case i of (
<:pec:> ,
<:e:> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) )
or item (1) = real ( case i of (
<::> ,
<::> ,
<:mto:> ,
<:mte:> ,
<:nrz:> ,
<:nrze:> ,
<::> ,
<::> ) ) and
item (2) = real ( case i of (
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ,
<::> ) ) then
begin j := i; i := 8; end;
mount_param := j;
end mount_param;
\f
<* sw8010/2, save parameter interpretation page ... 41...
1984.04.30 *>
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 = segm *>
<* 2 <s><name> and name = level *>
<* 3 <s><name> and name = list *>
<* 4 <s><name> and name = test *>
<* 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, save parameter interpretation page ... 42...
1985.02.05 *>
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, save 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, save 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, save 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, save parameter interpretation page ... 46...
1981.12.09 *>
message save specifier page 1;
integer
procedure save_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 : save_specifier (seplength, item); *>
<* *>
<* save_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, save parameter interpretation page ... 47...
1982.03.24 *>
message save 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 save spec keyword or *>
<*next param is .scope, .docname or anything but .<name>*>
save_specifier := j;
end save_specifier;
\f
<* sw8010/2, save parameter interpretation page ... 48...
1982.12.28 *>
message list specifiers page 1;
procedure list_specifiers (z, pos, no, spec, discname, name, scope, doc);
value pos, no, scope ;
zone z ;
integer pos, no, scope ;
boolean array spec ;
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, 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. *>
<* no (call value, integer). The number of discs *>
<* included in the bs-system at save initiali- *>
<* zation. *>
<* 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). The scope coded as *>
<* procedure scan_cat. *>
<* doc (call value, long array). A docname is pack- *>
<* in doc (1:2) or doc (1) = 0. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, save parameter interpretation page ... 49...
1982.12.28 *>
message list specifiers page 2;
begin
integer disc_no, curr_pos;
long array field disc ;
write (z, <:according to following specifier ::>, "nl", 1);
curr_pos :=
write (out, "sp", pos, <:disc : disc:>);
for discno := 1 step 1 until no do
if spec (discno) then
begin
disc := discno * 8; <*fields discname*>
if curr_pos >= 71 then
curr_pos := write (out, ",", 1, "nl", 1, "sp", pos + 12) - 2;
curr_pos := curr_pos +
write (z, <:.:>, discname.disc);
end;
write (z, "nl", 1, "sp", pos, <:entry ::>);
if name (1) <> 0 then
write (z, "sp", 1, name);
if scope <> 0 then
write (z, if name (1) <> 0 then <:.:> else <: :>,
<:scope.:>, case scope of (
<:all:>, <:perm:>, <:system:>,<:own:>,
<:project:>, <:user:>, <:login:>, <:temp:> ));
if docname (1) <> 0 then
write (z,
if name (1) <> 0 or scope <> 0 then <:.:> else <: :>,
<:docname.:>, doc );
end list_specifiers;
\f
<* sw8010/2, save catalog scanning page ... 50...
1984.04.24 *>
message prepare cat scan page 1;
integer
procedure prepare_cat_scan (z, name, name_key);
zone z ;
long array name ;
integer name_key ;
<*********************************************************>
<* *>
<* The procedure prepares a catalog scan for an entry *>
<* with a given name, i.e. checks the existence of the *>
<* catalog area process, positions the document accor- *>
<* ding to the namekey derived from the name and returns *>
<* the corresponding entrycount from the segment. *>
<* If no name is specified, a catalog scan from the *>
<* start of the catalog is prepared. *>
<* *>
<* Call : prepare_cat_scan (z, name, namekey); *>
<* *>
<* prepare_cat_scan (return value, integer). The entry-*>
<* count from the segment correspon- *>
<* ding to the namekey of the name. *>
<* z (call and return value, zone). *>
<* The name of the *>
<* catalog together with the document *>
<* the buffering and the position of *>
<* the document. *>
<* The zone state must be after open. *>
<* name (call value, long array). The name *>
<* to be searched is packed in *>
<* name (1:2), or name (1) = name (2) *>
<* = 0 meaning any name. *>
<* name_key (return value, integer). The name *>
<* key corresponding to the name. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, save catalog scanning page ... 51...
1985.07.09 *>
message prepare cat scan page 2;
begin
integer result, proc_descr_addr, segm_no, noofkeys, size,
word1, word2;
integer array dummy (1:1), proc_descr (0:9);
integer field entrycount;
long sum;
entrycount := 512; <*fields the last word of a catalog segment*>
result := monitor (52) create area process :(z, 1, dummy);
if result <> 0 then
system (9) general alarm :(result, <:<10>catalog:>)
else
begin <*process exists*>
proc_descr_addr := monitor (4) proc descr addr :(z, 1, dummy);
system (5 )move core:( proc_descr_addr, proc_descr); <*size*>
system (5 )move core:( 64 , dummy ); <*mon rel*>
size := proc_descr (9);
no_of_keys :=
if dummy (1) >= 9 shift 12 + 0 <*release 9.0*> then
proc_descr (7) extract 12
else
size ;
sum := name (1) + name (2) ;
word1 := sum shift (-24) extract 24 ;
word2 := sum extract 24 ;
word2 := word__1 + word__2 ;
sum := word__2 +
(word__2 shift (-12) shift 12) // 4096;
sum := sum shift 24 shift (-24) ;
segm_no := sum mod size ;
name_key := segm_no mod no_of_keys ;
setposition (z, 0, segm_no); <*segment no namekey*>
inrec6 (z, 512);
prepare_cat_scan := z.entrycount ; <*entry count *>
setposition (z, 0, segm_no); <*position document *>
end <*process exists*>;
end prepare_cat_scan;
\f
<* sw8010/2, save catalog scanning page ... 52...
1984.08.21 *>
message scan cat page 1;
boolean
procedure scan_cat (z, name, scope, docname, newscope, disc_no ,
actual_scope, entry , name_key, name_count);
value scope, newscope ;
zone z ;
long array name, docname ;
integer array entry ;
integer newscope, disc_no ,
scope,
actual_scope, name_key, name_count ;
<*********************************************************>
<* *>
<* The procedure scans the main catalog for the next en- *>
<* try with name, scope, docname and a discname speci- *>
<* fied and returns true if such an entry is found. *>
<* If an entry is found, its actual scope is returned *>
<* with the entry head and tail and the discno in the *>
<* disc name table where the name of the disc is found. *>
<* If name is specifi- *>
<* ed the namecount specified is decreased each time an *>
<* entry with the namekey specified is found during the *>
<* scan. *>
<* *>
<* Call : scan_cat (z, name, scope, docname, discno , *>
<* actual_scope, entry , name_key, *>
<* name_count)*>
<* *>
<* 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 main catalog. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* name (call value, long array). A name is packed *>
<* in name (1:2) or name (1) = 0 meaning any *>
<* name. *>
\f
<* sw8010/2, save catalog scanning page ... 53...
1984.08.21 *>
message scan cat page 2;
<* scope (call value, integer). *>
<* scope : 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*>
<* docname (call value, long array). A document name *>
<* packed in docname (1:2) or docname (1) = 0 *>
<* meaning any document name. *>
<* newscope (call value, integer). As for scope. *>
<* 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 is belongs is found in discname *>
<* (discno, 1:2) and disc_specified (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 (discno, 1:2) and *>
<* discspecified (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, save 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. *>
<* entry (return value, integer array). If scan_cat *>
<* returns true, entry (1:17) will contain the *>
<* head and tail of the entry found, if false *>
<* the contents of entry are undefined. *>
<* name_key (call value, integer). If a name is speci- *>
<* fied, name_key is supposed to be the corre- *>
<* sponding namekey. *>
<* If a name is not specified, name_key is com-*>
<* pletely transparent. *>
<* name_count (call and return value, integer). If a name *>
<* is specified, name_count is supposed to be *>
<* the number of entries with the same namekey *>
<* left in the catalog for further scan, as i- *>
<* nitially found in the last word of segment *>
<* number namekey. At return the number will *>
<* be decreased by one for each entry with the *>
<* same namekey found during the scan. *>
<* If name is not specified, name_count is com-*>
<* pletely transparent. *>
<* *>
<**********************************************************>
\f
<* sw8010/2, save catalog scanning page ... 54...
1984.04.25 *>
message scan cat page 4;
begin
boolean found, end_of_catalog;
integer dummy, entry_namekey;
<*scan the catalog from segment no namekey (zero for an empty*>
<*name) for an entry with given name (maybe empty) and scope *>
<*(maybe any scope) *>
if name (1) <> 0 and name_count <= 0 then
found := false <*catalog exhausted for given name*>
else
begin <*scan*>
repeat
end_of_catalog := -, next_entry (z, entry);
if name (1) <> 0 and
end_of_catalog then
end_of_catalog := -, next_entry (z, entry);
<*given name : ignore end of catalog, i.e. seacrh cyclically*>
<* -"- : end of catalog never becomes true *>
entry_namekey := entry (1) shift (-3) extract 9; <*entry key*>
found := -,end_of_catalog and check_name (entry, name);
<*found <=> not end of catalog and name fits*>
if name (1) <> 0 and entry_namekey = namekey then
name_count := name_count - 1; <*given namekey found*>
if found then
found := check_scope (entry, scope, actual_scope, newscope);
<*found <=> name and scope fits*>
if found then
found :=check_docname_discno (entry, docname, discno);
<*found <=> name, scope, docname and discname fits*>
until found or end_of_catalog or name (1) <> 0 and namecount = 0;
end <scan*>;
scan_cat := found;
end scan_cat;
\f
<* sw8010/2, save catalog scanning page ... 55...
1981.12.09 *>
message next entry page 1;
boolean
procedure next_entry (z, entry);
zone z ;
integer array entry ;
<**********************************************************>
<* *>
<* The procedure transfers the next non-empty entry from *>
<* the catalog to entry and returns true. If, however, *>
<* the end of the catalog is met, the procedure positions *>
<* to the start of the catalog and returns false. *>
<* *>
<* Call : next_entry (z, entry); *>
<* *>
<* 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. *>
<* entry (return value, integer array). If the pro- *>
<* cedure returns true, entry (1:17) contains *>
<* the head and tail of the entry, else un- *>
<* changed. *>
<* *>
<**********************************************************>
begin
integer hw;
integer field intf;
real array field raf;
raf := 0;
intf := 2;
hw := inrec6 (z, 0);
if hw >= 34 then
begin <*next entry available in zone, maybe empty*>
inrec6 (z, 34); <*next entry*>
if z.intf = -1 <*empty*> then
next_entry := next_entry (z, entry)
else
begin <*not empty*>
next_entry := true;
to_from (entry.raf, z, 34);
end;
end <*next entry available*> else
if hw = 2 then
begin <*name count record or end catalog record available*>
inrec6 (z, 2);
if z.intf <> 'em' shift 16 + 'em' shift 8 + 'em' then
next_entry := next_entry (z, entry) <*was namecount record*>
else
begin <*end of catalog*>
next_entry := false;
setposition (z, 0, 0);
end;
end <*name count record or end of catalog*> else
system (9, hw, <:<10>catalog:>); <*catalog input error*>
end next_entry;
\f
<* sw8010/2, save 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, save catalog scanning page ... 57...
1981.12.09 *>
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 array field base;
base := 2; <*fields entry base in entry*>
permkey := entry (1) extract 3;
\f
<* sw8010/2, save catalog scanning page ... 58...
1981.12.09 *>
message check scope page 2;
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 *>
\f
<* sw8010/2, save catalog scanning page ... 59...
1981.12.09 *>
message check scope page 3;
check_scope :=
(actual_scope > 0 or
new____scope > 0 or
scope = 1 <*all *> or
scope = 2 <*perm*> ) and <*load wont accept a scopekey of zero*>
(case (scope + 1) of (
(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*>
or
entry.base (1) <= max_base (1) and
entry.base (2) >= max_base (2)) <*out max*>
and
entry.base (1) >= sys_base (1) and <*in sys*>
entry.base (2) <= sys_base (2) , <*visible*>
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, save catalog scanning page ... 60...
1984.04.25 *>
message check docname discno page 1;
boolean
procedure check_docname_discno (entry, docname, discno );
integer array entry ;
long array docname ;
integer discno ;
<**********************************************************>
<* *>
<* 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 (1:no_of *>
<* discs, 1:2) of a disc specified in discspecified (1:no *>
<* of 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 where *>
<* the entry belongs equals a na-*>
<* me packed in discname (1:no_ *>
<* of_discs, 1:2) and the disc *>
<* is specified in discspecified *>
<* (1:no_of_discs). *>
<* entry (call value, integer array). *>
<* See above. *>
<* docname (call value, long array). *>
<* See above. *>
<* 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 (discno,1:2)*>
<* and discspecified (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 *>
<* (discno, 1:2) and discspeci_ *>
<* fied (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. *>
<* *>
<**********************************************************>
\f
<* sw8010/2, save catalog scanning page ... 61...
1984.04.25 *>
message check docname discno page 2;
begin
integer first_slice, permkey, min_auxcat_permkey,
twice_chain_no, i, j;
integer array first_bs, chain_addr (1:1);
integer field size;
long array bs_name (1:2);
long array field doc, disc;
size := doc := 16; <*field size and document name in entry*>
min_auxcat_permkey := 2;
if discno >= 0 then
begin <*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 discspecified (i) and
discname.disc (1) = bs_name (1) and
discname.disc (2) = bs_name (2) then
begin j := i; i := no_of_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, save 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, save 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, save 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, save save catalog head page ... xx...
1984.06.20*>
message out savecat head page 1;
integer
procedure out_savecat_head (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure outputs a number of segments containing a *>
<* save catalog head to the document connected to the zone *>
<* z. *>
<* *>
<* Call : out_savecat_head (z); *>
<* *>
<* out_savecathead (return value, integer). The number of *>
<* blocks output (= 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 backing sto- *>
<* rage area. *>
<* At return the zone is positioned to *>
<* the next segment after the catalog *>
<* head. *>
<* *>
<* A number of global values area output in their fields *>
<* of the catalog head, the current block is output and *>
<* the next block number returned as no of segments output.*>
<* *>
<***********************************************************>
begin
integer discno, copycount, volume, file, block;
integer array vol_count (1:2), ia (1:8);
integer field ifld;
long array field disc, current_tape;
system (11) bases :(1, ia);
\f
<* sw8010/2, save save catalog head page ... xx...
1984.06.20 *>
message out savecat head page 2;
outrec6 (z, 28); <*first 28 halfs of head*>
tofrom (z, ia, 16); <*move bases to zone record*>
ifld := 16 + 2; z.ifld := no_of_discs ;
ifld := ifld + 2; z.ifld := max_no_of_vol;
ifld := ifld + 2; z.ifld := no_of_copies ;
ifld := ifld + 2; z.ifld := no_of_vol (1);
ifld := ifld + 2; z.ifld := no_of_vol (2);
ifld := ifld + 2; z.ifld := segm ;
for discno := 1 step 1 until no_of_discs do
begin <*discnames*>
disc := 8 * discno;
outrec6 (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);
outrec6 (z, 8);
tofrom (z, tapename.current_tape, 8);
end;
stopzone (z, false );
getposition (z, file, block);
out_savecathead := block;
end out_savecat_head;
\f
<* sw8010/2, save find entry page ... xx...
1984.10.30 *>
message find entry page 1;
integer
procedure find_entry (catname, scope, name, bases, entry);
long array catname, name ;
integer scope ;
integer array bases, entry ;
<********************************************************** *>
<* *>
<* The procedure scans the catalog given by catname to find *>
<* within a given scope frame *>
<* an entry with a given name and a given entry base to re- *>
<* turn the entry head and tail. *>
<* *>
<* Call : find_entry (catname, scope, name, bases, entry); *>
<* *>
<* find_entry (return value, integer). *>
<* 0 an entry with the given name and bases *>
<* is found and returned *>
<* 3 no entry is found *>
<* 6 name format illegal (name or catname (1)*>
<* is null. *>
<* catname (call value, long array). The name of an *>
<* cat is found in catname (1:2) *>
<* scope (call value, integer). The scope frame *>
<* given, cf. scan_cat *>
<* name (call value, long array). The name of an *>
<* entry is given in name (1:2). *>
<* bases (call value, integer array). The bases of *>
<* entry wanted is given in bases (1:2). *>
<* entry (return value, integer array). If the pro-*>
<* cedure returns zero, entry (1:17) will *>
<* contain the cat entry head and tail, *>
<* else the contents of entry is undefined. *>
<* *>
<************************************************************>
\f
<* sw8010/2, save find entry page ... xx...
1985.02.05 *>
message find entry page 2;
begin
boolean end_of_scan;
integer any_disc, any_actual_scope, namekey, namecount,
result;
long array any_docname (1:2);
integer array field base;
zone zcat (128, 1, stderror);
base := 2; <*fields entry base*>
any_docname (1) := long <::>;
any_disc := -1 ; <*disc holding candidates not checked*>
result := 3 ; <*default : does not exist*>
if name (1) = long <::>
or catname (1) = long <::> then
result := 6
else
begin <*names ok*>
open (zcat, 4, catname, 0);
name_count :=
prepare_cat_scan (zcat, name, namekey);
repeat
end_of_scan :=
-, scancat (zcat, name, scope, any_docname, 3 <*phony newscope*>,
any_disc, any_actual_scope, entry, namekey, namecount);
if -,end_of_scan and
entry.base (1) = bases (1) and
entry.base (2) = bases (2) then
result := 0; <*found*>
until result = 0 or end_of_scan;
close (zcat, true);
end <*names ok*>;
find_entry := result;
end find_entry;
\f
<* sw8010/2, save store entries page ... xx...
1984.06.04 *>
message store entries page 1;
integer
procedure store_entries (zaway, length,
name , scope , newscope, docname, time);
value length,
scope , newscope, time ;
zone zaway ;
integer length,
scope , newscope, time ;
long array name , docname ;
<*********************************************************>
<* *>
<* The procedure scans the main catalog for entries be- *>
<* longing to the discs specified, to find *>
<* the entries with proper name, scope and document name *>
<* which have been updated since the time given by time. *>
<* 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 docu- *>
<* ment name, file number and block number is stored away*>
<* in the file specified by the zone zaway. *>
<* *>
<* call : *>
<* store_entries (zaway, copies, *>
<* name , scope , newscope, docname, time)*>
<* *>
<* storeentries (return value, integer). The number of *>
<* entries found in the main catalog be- *>
<* longing to a disc specified and satis- *>
<* fying the name, scope, document name *>
<* and time specifications given in the *>
<* call. *>
<* zaway (call and return value, zone). The name *>
<* of the document, the buffering and the *>
<* position of the document where to store *>
<* away the entry. *>
<* The zone state is supposed to be ready *>
<* for outrec and is left the same. *>
<* length (call value, integer). The length of the*>
<* record to store away. *>
<* name (call value, long array). Either a name *>
<* is given in name (1:2) or name (1) = 0 *>
<* meaning any name. *>
<* scope (call value, integer). Either scope con-*>
<* tains a scope value (cf. the procedure *>
<* check_scope) or scope = 0 meaning any *>
<* scope. *>
<* newscope (call value, integer). The new scope gi-*>
<* ven, 0 meaning no change of scope. *>
<* doc_name (call value, long array). Either doc- *>
<* name (1:2) contains a document name or *>
<* doc_name (1) = 0 meaning any document *>
<* name. *>
<* time (call value, integer). Contains a short-*>
<* clock. Only entries with a latest upda- *>
<* te time since time are stored away. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, save store entries page ... xx...
1984.06.04 *>
message store entries page 2;
begin
integer disc_no, name_count, name_key, actual_scope,
disc_no_b, actual_scope_b, entries_stored,
key, kind, clock, cont, j, min_auxcat_permkey, loop_count;
integer array entry , entry_b, aux_entry (1:17);
long array catname, name_a, docname_a (1:2);
integer field scop, act_scop, new_scop, disk_no, size, changed;
integer array field base;
long array field disc, entryname, doc_name_f, new_disk_name;
real array field raf1, raf2;
zone zcat (128, 1, stderror);
base := 2; <*fields base in entry*>
entryname := 6; <*fields name in entry*>
size := 16; <*fields size in entry*>
docname_f := 16; <*fields docn in entry*>
scop := 36;
act_scop := scop + 2;
new_scop := act_scop + 2;
disk_no := new_scop + 2;
new_diskname := disk_no ;
changed := new_diskname + 10;
min_auxcat_permkey := 2;
\f
<* sw8010/2, save store entries page ... xx...
1984.08.21 *>
message store entries page 3;
entries_stored := 0; <*local total entry count*>
disc_no := 0; <*disc holding candidate entries are checked*>
catname (1) := long <:catal:> add 'o';
catname (2) := long <:g:> ;
open (zcat, 4, catname, 0); <*scan main catalog*>
name_count :=
prepare_cat_scan (zcat, name, name_key);
while scan_cat (zcat, name , scope, docname , newscope , discno,
actual_scope, entry, name_key, name_count) do
begin <*check the entry found for time*>
if name (1) <> 0 and scope = 0 then
begin <*find the best entry*>
disc_no_b := 0; <*discs holding candidate entries are checked*>
while scan_cat (zcat, name , scope , docname, newscope ,
disc_no_b, actual_scope_b, entry_b, namekey, namecount) do
if entry_b.base (1) >= extend entry.base (1) and
entry_b.base (2) <= extend entry.base (2) then
begin <* entry_b better than entry *>
disc_no := disc_no_b ;
actual_scope := actual_scope_b;
for j := 1 step 1 until 17 do
entry (j) := entry_b (j) ;
end <* entry_b better then entry *>
end <* find the best *>;
\f
<* sw8010/2, save store entries page ... xx...
1984.10.30 *>
message store entries page 4;
result := 0;
key := entry (1) extract 3; <*permkey*>
kind := entry.size ; <*kind *>
clock := entry (13) ; <*shortcl*>
cont := entry (16) ; <*content*>
for i := 1, 2 do
begin
name_a (i) := entry.entryname (i);
doc_name_a (i) := entry.docname_f (i);
end;
loop_count := 1;
while kind = 1 shift 23 + 4 <*bs*> and loop_count < 10 do
begin <*get main entry in maincat into auxentry*>
result := findentry (catname, scope, docname_a, entry.base, auxentry);
key := aux_entry (1) extract 3; <*permkey*>
kind := aux_entry.size ; <*kind *>
clock := aux_entry (13) ; <*shclock*>
cont := aux_entry (16) ; <*content*>
for i := 1, 2 do
begin
name_a (i) := aux_entry.entryname (i);
doc_name_a (i) := aux_entry.docname_f (i);
end;
loop_count := loop_count + 1;
if loop_count = 10 then result := 1;
end <*while*>;
if result > 0 then
begin <*main not found, dumped only in level zero dump*>
result := 0;
auxentry (9) := 1;
end else
if key < min_auxcat_permkey and
(cont = 4
or cont >= 32) then <*temporary procedure *>
aux_entry (9) := systime (7, 0, 0.0) <*now*>
else
if key < min_auxcat_permkey <*temporary, not procedure area*>
or kind < 0 and
kind <> 1 shift 23 + 4 then <*file descr, not bs*>
aux_entry (9) := clock <*shortclock*>
else
begin <*main entry found, find it in proper aux catalog*>
disc := 0;
repeat
disc := disc + 8;
until disc = 8 * no_of_discs
or discname.disc (1) = doc_name_a (1) and
discname.disc (2) = doc_name_a (2) ;
result := findentry (auxcatname.disc, scope,
name_a, entry.base, aux_entry);
end <*main entry found, find it in proper aux catalog*>;
\f
<* sw8010/2, save store entries page ... xx...
1984.06.04 *>
message store entries page 5;
if result > 0 then
skip_entry (out, list_only_name, entry, scope, actual_scope,
auxentry (9), result shift 12)
else
if time = 0
or extend 0 add aux_entry (9) > extend 0 add time then
begin <*not incremental or level zero or entry changed since time*>
outrec6 (zaway, length);
raf1 := 0;
to_from (zaway.raf1, entry.raf1, 34); <*move entry head and tail*>
zaway.scop := scope;
zaway.act_scop := actual_scope;
zaway.new_scop := new____scope;
zaway.disk_no := disc_no ;
disc := 8 * disc_no; <*fields discname of the original entry*>
raf1 := new_diskname;
to_from (zaway.raf1, new_discname.disc, 8); <*move new disc name*>
zaway.changed := aux_entry (9);
raf1 := changed ;
raf2 := raf1 + 4;
zaway.raf1 (1) := real <::>; <*zero first element*>
tofrom (zaway.raf2, zaway.raf1, length - 56);
<*zero one or two tape records*>
entries_stored := entries_stored + 1;
end <*entry ok, updated since time*>;
end <*check the entry found for time*>;
close (zcat, true); <*end catalog scan*>;
store_entries := entries_stored;
end store_entries;
\f
<* sw8010/2, save save entries page ... 65...
1985.01.16 *>
message save entries page 1;
integer
procedure save_entries ( zida , za , copies , idacopy ,
zcat , cat_name, entries_cat, reclength , rec_start,
zpart, partname, entriespart );
value copies ,
entries_cat, reclength , rec_start,
entriespart ;
zone zida ,
zcat ,
zpart ;
zone array za ;
integer copies ,
entries_cat, reclength , rec_start,
entriespart ;
boolean idacopy ;
long array cat_name,
partname ;
<*********************************************************>
<* *>
<* *>
<*********************************************************>
\f
<* sw8010/2, save save entries page ... 66...
1985.07.08 *>
message save entries page 2;
begin
integer recs_pr_segment, entries_input, partcat_size,
segs_input, recs_in_last_seg, result, copy_count,
last_area_in_part,
entries_ready, entries_saved, segments, j, monrelease,
idaproc, mainproc, mainkind, write_accesses, outproc, areaproc,
catproc, next_area;
integer array proc (1:18), tail (1:10), zdescr (1:20),
entry_kind , entry_discno, entry_nta, entry_wr_acc
(1:entries_part + 1), areas (1 : (entries_part + 1) * 17);
long array entry_name (1:entries_part + 1, 1:2),
main__name (1:2);
integer field size, scop, act_scop, new_scop, disk_no, changed,
vol, file, block;
integer array field head, base;
real array field current_entry;
long array field name, new_diskname, disk, doc_name;
boolean partcat, area_entry, mark;
zone zhelp (1, 1, stderror);
\f
<* sw8010/2, save save entries page ... 67...
1985.02.21 *>
message save entries page 3;
docname := 2; <*fields docname in entry tail *>
head := 0; <*fields entry head 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;
recs_pr_segment := 512 // reclength;
outproc := monitor (4) proc :(out, 0, proc); <*area proc exists if area*>
if test then
write (out,
"nl", 1, <:save entries , outproc = :>, outproc);
system (5) move core :(64, proc); <*monitor release*>
mon_release := proc (1); <*release < 12 + subrelease*>
entries_saved := 0; <*local total entry count*>
open (zcat, 4, catname, 0);
setposition (zcat, 0, rec_start );
\f
<* sw8010/2, save save entries page ... 68...
1985.01.16 *>
message save entries page 4;
partname (1) := long <::>;
idaproc :=
if idacopy then
monitor (4) proc addr :(zida, 0, proc <*dummy*>)
else
0;
if idaproc > 0 then
begin <*ida main exists*>
j := 0;
repeat
j := j + 1;
disk := j * 8;
open (zhelp, 0, discname.disk, 0);
close (zhelp, true );
mainproc := get_mainproc (
monitor (4) proc addr :(zhelp, 0, proc <*dummy*>),
mainkind, mainname );
until
mainproc = idaproc
or j = no_of_discs;
if mainproc = idaproc then
begin <*disc with idaproc as main is found*>
open (zpart, 0, partname, 0);
close (zpart, false );
tail (1) := slicelength (j);
tofrom (tail.docname, discname.disk, 8);
monitor (40) create entry :(zpart, 0, tail); <*ignore result*>
end;
end <*ida main exists*>;
result := connect_output (zpart, 4, partname, 0);
\f
<* sw8010/2, save save entries page ...69...
1985.07.03 *>
message save entries page 5;
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);
<*transfer save catalog to tape(s)*>
open (za (copies + 1), 4, catname, 0);
inrec6 (za (copies + 1), 2 ); <*est. nta*>
setposition (za (copies + 1), 0, 0);
if mon_release >= 9 shift 12 + 1 then
monitor (30) write protect :(za (copies + 1), dummy, dummyia)
else
monitor ( 8) reserve :(za (copies + 1), dummy, dummyia);
segments :=
if idacopy then
copy_area (zida, za (2), za (1), segm)
else
transfer (za, copies, file_no , block_no,
end_of_doc, expell_zone, false <*no tape mark*>);
if ida_copy then
begin <*stop ida before partial cat*>
stop_zone (zida, false);
getposition (zida, fileno (1), blockno (1));
end <*stop ida*>;
open (za (copies + 1), 4, catname, 0);
inrec6 (za (copies + 1), 2 );
close (za (copies + 1), false ); <*dont remove proc*>
if mon_release >= 9 shift 12 + 1 then
monitor (30) write protect :(za (copies + 1), dummy, dummyia)
else
monitor ( 8) reserve :(za (copies + 1), dummy, dummyia);
catproc :=
monitor ( 4) proc descr ad :(za (copies + 1), dummy, dummyia);
<*prepare partial catalog*>
partcat_size := (entries_part + 14) // 15;
setposition (zpart, 0, partcat_size);
disconnect_output (zpart, false); <*cut down, dont remove process*>
open (zpart, 4, partname, 0); <*reopen*>
setposition (zpart, 0, 0);
\f
<* sw8010/2, save save entries page ... xx...
1984.08.21 *>
message save entries page 6;
entries_input := 0;
repeat <*until entries_input = entries_cat, notice : entries_cat >= 1*>
base := 2; <*fields entry base in zcat record*>
name := 6; <*- - name - - - *>
entries_ready := 0;
repeat <*until entries_ready = entries_part + 1 or
entries_input = entries_cat *>
partcat := entries_ready = 0; <*partcat entry prepared*>
if -,partcat then
begin <*new entry from savecat*>
swoprec6 (zcat, reclength);
entries_input := entries_input + 1;
area_entry := zcat.size > 0;
end <*new entry from savecat*>;
if area_entry or partcat then
begin <*area entry, partcat or new*>
if partcat then
open (zhelp, 4, partname, 0)
else
begin <*entry from savecat*>
set_catbase (zcat.base); <*if outside max then max*>
open (zhelp, 4, zcat.name, 0); <*no user bits*>
end <*entry from savecat*>;
close (zhelp, false);
result :=
monitor (92) create e l process :(zhelp, 0, proc <*dummy*>);
\f
<* sw8010/2, save save entries page ... xx...
1985.07.08 *>
message save entries page 7;
result := result shift 12 + (
if result = 0 and mon_release >= 9 shift 12 + 1 then
monitor (30) set write protection :(zhelp, 0, proc <*dummy*>)
<*process created and mon rel >= 9.1*>
else
if result = 0 then
monitor ( 8) reserve process :(zhelp, 0, proc <*dummy*>)
<*process created and mon rel < 9.1*>
else
0);
<*process not created*>
if result extract 12 = 2 then
result := result shift (-12) shift 12;
<*ignore result 2 : cannot be protected/reserved*>
if result = 0 and -,partcat then
begin <*savecat entry, process exists, check bases*>
area_proc := monitor (4) proc :( zhelp, 0, proc <*dummy*>);
system (5) move core :(area_proc - 4, proc); <*process descr*>
if proc (1) <> zcat.base (1)
or proc (2) <> zcat.base (2) then <*area inaccessible *>
result := 2; <*result 2 from reserve proc is borrowed*>
if area_proc = out_proc then
result := 4; <*outfile*>
if area_proc = cat_proc then
result := 5; <*save catalog*>
if test then
write (out,
"nl", 1, <:save entries, outproc = :>, outproc,
"nl", 1, <: areaproc = :>, areaproc,
"nl", 1, <: catproc = :>, catproc);
zcat.size := proc (12); <*update savecat with size right now*>
write_accesses := proc (17); <*get write access counter*>
end <*process exists*>;
if -,partcat then
reset_catbase; <*name table address has been established*>
end <*area entry*> else
result := 0; <*bs entry, entry ok*>
\f
<* sw8010/2, save save entries page ... 69...
1985.07.09 *>
message save entries page 8;
if result > 0 then
begin <*entry not ok*>
if -,partcat then
set_catbase (zcat.base);
close (zhelp, areaproc <> outproc and
areaproc <> catproc ); <*maybe remove proc*>
if -,partcat then
begin <*entry from savecat*>
reset_catbase;
if list_entries then
skip_entry (out, list_only_name,
zcat.head, zcat.scop, zcat.act_scop,
zcat.changed , result);
end <*entry from savecat*>;
end <*entry not ok*>;
<*begin entry ready, update tables, records in partcat and savecat*>
entries_ready := entries_ready + 1;
getzone6 (zhelp, zdescr); <*get name table address*>
entry_kind (entries_ready) := if partcat then
partcatsize
else
zcat.size ;
entry_discno (entries_ready) := if partcat then 0 else zcat.diskno;
entry_nta (entries_ready) := zdescr (6) ;
entry_wr_acc (entries_ready) := write_accesses;
for j := 1, 2 do
entry_name (entries_ready, j) :=
if partcat then
part_name (j)
else
zcat.name (j);
\f
<* sw8010/2, save save entries page ... 70...
1984.11.15 *>
message save entries page 9;
if -,partcat then
begin <*move savecat entry to partcat*>
outrec6 (zpart, 34); <*prepare record in partial catalog*>
tofrom (zpart, zcat, 34); <*transfer record*>
change_entry (zpart.head, zcat.act_scop, zcat.new_scop,
zcat.new_diskname);
if result > 0 then
begin <*zero first slice in save- and partcat entries and
entry in -kind *>
zcat (1) := zcat (1) shift 12 shift (-12);
zpart (1) := zpart (1) shift 12 shift (-12);
entry_kind (entries_ready) := 0;
end <*zero first slice etc*> else
if list_entries and entries_input < entries_cat <*not dummy*> then
list_entry (out, list_only_name, zpart.head,
zcat.scop, zcat.actscop, zcat.newscop,
zcat.changed);
for copy_count := 1 step 1 until copies do
begin <*update record in save catalog*>
vol := case copy_count of (54, 60);
file := vol + 2 ;
block := file + 2 ;
zcat.vol := vol_count (copy_count);
zcat.file := file__no (copy_count);
zcat.block := block_no (copy_count);
end <*update record in save catalog*> ;
<*save catalog entry for later use - page 12 - *>
current_entry := (entries_ready - 1) * 34;
tofrom (areas.current_entry, zcat, 34);
end <*move savecat entry into partcat*> ;
\f
<* sw8010/2, save save entries page ... 71...
1984.08.21 *>
message save entries page 10;
if entry_kind (entries_ready) > 0 and result = 0 then
last_area_in_part := entries_ready; <*maybe partcat itself*>
<*end entry ready*>;
until entries_ready = entries_part + 1 or
entries_input = entries_cat ;
setposition (zpart, 0, 0); <*stop zone and reposition*>
<*output current block in save catalog, position to next record*>
segs_input := entries_input // recs_pr_segment;
recs_in_last_seg := entries_input - recs_pr_segment * segs_input;
setposition (zcat, 0, rec_start + segs_input ); <*terminate zone and position*>
swoprec6 (zcat, rec_length * recs_in_last_seg); <*next record*>
\f
<* sw8010/2, save save entries page ... 70...
1985.07.03 *>
message save entries page 11;
<*transfer areas described in tables entry-name, -kind, -discno, -nta*>
for j := 1 step 1 until entries_ready do
begin <*next entry*>
name := 8 * j;
base := 4 * j;
if j > 1 and entry_name.name (1) <> long <::> then
begin <*not part cat and not dummy entry*>
increase (total_entry_count );
increase (entries_saved );
increase (entry_count (entry_discno (j)));
end <*not part cat*>;
if entry_kind (j) > 0 then
begin <*area entry*>
if j = 1 then
begin <*partial catalog, output sync block*>
long array field laf1, laf2, laf;
laf1 := 0; laf := 2; laf2 := 4;
for copy_count := 1 step 1 until copies do
begin <*stop zone, close, open and position*>
stop_zone (za (copy_count), false); <*no mark*>
close (za (copy_count), false);
getzone_6 (za (copy_count), zdescr);
open_tape (za (copy_count), 0, zdescr (1), zdescr.laf);
setposition (za (copy_count), fileno (copy_count), blockno (copy_count));
end <*stop zone, close, open and position*>;
for copy_count := 1 step 1 until copies do
begin <*outrec6, stopzone, get and setposition*>
check(za (copy_count));
outrec_6 (za (copy_count), sync_blocklength);
za (copy_count).laf1 (1) := long <::>;
to_from (za (copy_count).laf2, za (copy_count).laf1, sync_blocklength - 4);
stopzone (za (copy_count), false); <*no mark*>
getposition (za (copy_count), fileno (copy_count), blockno (copy_count));
setposition (za (copy_count), fileno (copy_count), blockno (copy_count));
end <*outrec6, stopzone, get and setposition*>;
if ida_copy then
begin <*update position in ida zone*>
getzone6 (zida, zdescr);
zdescr (7) := fileno (1);
zdescr (8) := blockno (1);
setzone6 (zida, zdescr);
end;
end <*output sync block*>;
\f
<* sw8010/2, save save entries page ... 72...
1985.07.02 *>
message save entries page 12;
open (za (copies + 1), 4, entry_name.name, 0);
setposition (za (copies + 1), 0, 0);
getzone_6 (za (copies + 1), zdescr );
zdescr (6) := entry_nta (j); <*name table address *>
setzone_6 (za (copies + 1), zdescr );
mark := false;
if (entry_kind (j) // segm) > 4
and copies = 1 then
begin <*change to highspeed if specified*>
getzone_6 (za (1), zdescr);
zdescr (1) := modekind (1) extract 23;
setzone_6 (za (1), zdescr);
end;
if ida_copy then
begin
if mark then
begin <*set mark mode in ida zone*>
getzone6 (zida, zdescr );
zdescr (1) := 1 shift 12 + 0; <*mark*>
setzone6 (zida, zdescr );
end;
segments := copy_area (zida, za (2), za (1), segm);
end else
segments :=
transfer (za, copies, fileno, blockno, end_of_doc ,
expellzone, mark <*mark after last area*>);
if j > 1 then
begin <*not part cat*>
total_segm_count := total_segm_count + segments;
slice_count (entry_discno (j)) :=
slice_count (entry_discno (j)) +
(segments +
slicelength (entry_discno (j)) - 1) //
slicelength (entry_discno (j)) ;
<* <. write acces counter again.>
system (5) move core :(
monitor (4) proc addr :( za (copies + 1), 0, proc) - 4, proc);
if proc (17) <> entry_wr_acc (j) then
begin <.warning.>
write (out,
"nl", 2, <:*** warning : write accesses to area during save :>,
true, 12, entry_name.name, true, 9, proc (1), true, 9, proc (2),
"nl", 1);
errorbits := 2; <.warning.yes, ok.yes.>
end <.warning.>;
if entry_kind (j) <> segments then
begin <.alarm.>
write (out,
"nl", 2, <:*** alarm : area size changed during save :>,
true, 12, entry_name.name, true, 9, proc (1), true, 9, proc (2),
"nl", 1);
trap (-1);
end <.alarm.>;
*>
end <*not part cat*>;
for copy_count := 1 step 1 until copies do
begin
<*make one sync block*>
integer array zd (1 : 20);
integer bl;
if copies = 1 then
begin <*remove highspeed bit in modekind*>
getzone_6 (za (1), zd);
zd (1) := modekind (1) extract 18;
setzone_6 (za (1), zd);
end;
if ida_copy then
begin <*update position in tape zone*>
getposition (zida, fileno (1), blockno (1));
getzone_6 (za (1), zd);
zd (7) := fileno (1);
zd (8) := blockno (1);
setzone_6 (za (1), zd);
end;
bl := outrec_6 (za (copy_count), 0);
outrec_6 (za (copy_count), aux_synclength);
za (copy_count, 1) := real <::>;
current_entry := 4;
<*zeroize zync block*>
tofrom (za (copy_count).current_entry, za (copy_count), aux_synclength - 4);
for next_area := j + 1 step 1 until entries_ready do
begin <*find descriptor of next area to be transferred*>
if entry_kind (next_area) > 0 then
begin <*area found - copy descriptor to sync block*>
current_entry := (next_area - 1) * 34;
tofrom (za (copy_count), areas.current_entry, 34);
next_area := entries_ready;
end;
end;
outrec_6 (za (copy_count), bl);
changerec_6 (za (copy_count), 0);
stopzone (za (copy_count), false);
getposition (za (copy_count), fileno (copy_count), blockno (copy_count));
if ida_copy then
begin <*update position in ida zone*>
getzone_6 (zida, zd);
zd (7) := fileno (1);
zd (8) := blockno (1);
setzone_6 (zida, zd);
end;
end; <*make sync blocks *>
close (za (copies + 1), false); <*dont remove process*>
end <*area entry*>;
end <*next entry*>;
<*
if ida_copy then
begin <.stop ida zone before next partial cat.>
stop_zone (zida, false);
getposition (zida, fileno (1), blockno (1));
end <stop ida.>;
*>
getzone (zhelp, zdescr);
for j := 2 step 1 until entries_ready do
begin
if entry_kind (j) > 0 then
begin <*remove process*>
name := (j-1)*34 + 6;
base := (j-1)*34 + 2;
set_catbase (areas.base);
tofrom (zdescr.docname, areas.name, 8);
setzone_6 (zhelp, zdescr);
monitor (64)remove_process:(zhelp, 0, zdescr);
end;
end;
reset_catbase;
until entries_input = entries_cat;
for copy_count := 1 step 1 until copies do
begin <*terminate with filemark*>
outrec_6 (za (copy_count), 0);
setposition (za (copy_count), fileno (copy_count) + 1, 0);
getposition (za (copy_count), fileno (copy_count), blockno (copy_count));
end;
end <*partial catalog connected*>;
close (zcat, true); <*remove save catalog area process*>
save_entries := entries_saved;
end save_entries;
\f
<* sw8010/2, save entry handling page ... 72...
1981.12.29 *>
message change entry page 1;
procedure change_entry (entry, actual_scope, new_scope, new_discname);
value actual_scope, new_scope ;
integer array entry ;
integer actual_scope, new_scope ;
long array new_discname ;
<*********************************************************>
<* *>
<* The procedure changes parts of the entry head and *>
<* tail specified according to the parameters. *>
<* *>
<* Call : change_entry (entry, actual_scope, new_scope, *>
<* disc_no) *>
<* *>
<* 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).*>
<* *>
<*********************************************************>
\f
<* sw8010/2, save entry handling page ... 73...
1984.05.04 *>
message change entry page 2;
begin
integer i, act_key, dummy;
long array 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 -"- *>
if new_scope <> 0 and new_scope <> actual_scope then
begin <*change permkey and base in head*>
act_key := case new_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 new_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, save 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, save entry handling page ... 75...
1981.12.30 *>
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
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:>, <: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, save 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, save entry handling page ... 77...
1985.07.08 *>
message skip entry page 1;
procedure skip_entry (z, only_name, entry, scope, actualscope, clock ,
result);
value scope, actualscope, clock ,
result ;
zone z ;
boolean only_name ;
integer array entry ;
integer scope, actualscope, 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- *>
<* actualscope (call value, integer). -do- *>
<* clock (call value, integer). -do- *>
<* result (call value, integer). The result of *>
<* create area process < 12 + result of *>
<* reserve area process. *>
<* *>
<*********************************************************>
begin
long array field name;
name := 6;
list_entry (z, only_name, entry, scope, actualscope ,
0 , clock); <*no newscope*>
write (z, "nl", 1, <:***:>, true, 12, entry.name, <:skipped : :>,
case (result shift (-12) + 1) of (
<::> ,
<:area claims exceeded:> ,
<:catalog i/o error, state of doc does not permit call:> ,
<:entry not found:> ,
<:entry does not describe an area:> ,
<::> ,
<:name format illegal:> ) ,
case (result extract 12 + 1) of (
<::> ,
<:reserved by another process:> ,
<:covered by a better entry:>,
<:process does not exist, process not user of area proc:>,
<:current output file:>,
<:save catalog file:>),
"nl", 1);
errorbits := 2; <*warning.yes ok.yes*>
end skip_entry;
\f
<* sw8010/2, save entry handling page ... 78...
1981.12.30 *>
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 24 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, <* mto, mtlh*>
1 shift 23 + 2 shift 12 + 18, <* mte*>
1 shift 23 + 4 shift 12 + 18, <* nrz, mtll*>
1 shift 23 + 6 shift 12 + 18, <*nrze*>
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 := 24 end;
modekind_case := j;
end modekind_case;
\f
<* sw8010/2, save entry handling page ... 79...
1982.01.05 *>
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;
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,
true, 12, <:disc name ::>,
true, 11, <:entries ::>,
true, 10, <:slices ::>,
true, 14, <:slicelength ::>,
true, 11, <:segments ::>,
true, 16, <:new disc name ::>,
"nl", 1);
for disc_no := 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, discname.disc,
true, 11, entry_count (disc_no),
true, 10, slice_count (disc_no), << ddd>,
true, 14, slicelength (disc_no), << ddddddd>,
true, 11, segments, "sp", 4,
true, 12, new_discname.disc);
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, save entry handling page ... 80...
1982.01.05 *>
message list total counters page 1;
procedure list_total_counters (z, entries, segments);
value entries, segments ;
zone z ;
integer entries, segments ;
<*********************************************************>
<* *>
<* 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 (call values, integers). The values to be *>
<* segments listed. *>
<* *>
<*********************************************************>
write (z, << ddddddd>, "nl", 2,
true, 12, <:total saved:>,
true, 11, <:entries ::>,
true, 24, <: :>,
true, 11, <:segments ::>, "nl", 2,
true, 12, <: :>,
true, 11, entries,
true, 24, <: :>,
true, 11, segments, "nl", 3);
<*end list_total_counters;*>
\f
<* sw8010/2, save tape handling procedures page ... 84...
1985.03.25 *>
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. *>
<* If the process does not exist *>
<* a print message is sent to the parent demanding a *>
<* write enable ring on the tape. *>
<* *>
<* 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, modekind extract 23, docname, 1 shift 21 + 1 shift 18);
proc_descr_addr := monitor (4) proc descr addr :(z, dummy, mess);
if proc_descr_addr = 0 then
begin <*parent message : print <:ring <docname>:>*>
for i := 1, 2 do
begin <*ring message, density message*>
mess (1) := 16 shift 12; <*print mess, no wait*>
raf := 2;
movestring (mess.raf, 1,
if i = 1 then
<:enable :>
else
case (modekind shift (-14) extract 1 + 1) of
(<:high :>, <:low :>) );
raf := 8;
to_from (mess.raf, docname, 8); <*document name*>
system (10 )parent mess:( dummy, mess);
end <*ring and density message*>;
end <*parent message : print <:ring <docname>:>*>;
end open_tape;
\f
<* sw8010/2, save tape handling procedures page ... 85...
1984.02.06 *>
message get file nos page 1;
procedure getfilenos (za, copies, volcount, no_of_vol, tapename ,
devno , modekind , fileno );
value copies ;
zone array za ;
integer copies ;
long array tapename ;
integer array volcount, no_of_vol,
devno , modekind , fileno ;
<*********************************************************>
<* *>
<* The procedure returns the file numbers and volume *>
<* counters given, if they are non-negative. *>
<* If they are negative, the file numbers are searched *>
<* as the numbers of the first files (one on each out of *>
<* no_of_copies) which are neither version nor continue *>
<* dump files, and *>
<* the corresponding volume counters are returned. *>
<* The search goes on simultaneously on no_of_copies *>
<* tapes and 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 : getfilenos (za, i, copies, volcount, no_of_vol,*>
<* tapename , devno , modekind ,*>
<* fileno )*>
<* *>
<* za (call and returnvalue, zone array). The *>
<* name, buffering and positions of the do-*>
<* cuments. At call the zone states must *>
<* be after declaration. *>
<* copies (call value, integer). See za. *>
<* 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 messages 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. *>
<* *>
<*********************************************************>
\f
<* sw8010/2, save tape handling procedures page ... 86...
1984.06.06 *>
message get file nos page 2;
begin
integer i;
integer array hw (1:copies), zdescr (1:20);
boolean file_nos_found;
boolean array file_no_found (1:copies);
long array field curr_tape, label_type;
label_type := 18; <*fields labeltype in labelrecord*>
filenos_found := true;
for i := 1 step 1 until copies do
begin <*if fileno missing then init search*>
fileno_found (i) := fileno (i) >= 0; <*<tape>.last => fileno < 0*>
filenos_found := filenos_found and fileno_found (i);
if -,fileno_found (i) then
begin <*init search*>
fileno (i) := 1; <*start in fileno 1*>
currtape := name_field (i, volcount);
open_tape (za (i), devno (i), modekind (i) extract 18, tapename.curr_tape);
end <*init search*>;
end <*if fileno missing then init search*>;
\f
<* sw8010/2, save tape handling procedures page ... 87...
1984.06.06 *>
message get file nos page 3;
while -,filenos_found do
begin <*read tapes to find position*>
for i := 1 step 1 until copies do
if -,fileno_found (i) then
setposition (za (i), fileno (i), 0); <*simultaneously*>
for i := 1 step 1 until copies do
if -,fileno_found (i) then
begin <*get a record from first block of file*>
getzone6 (za (i), zdescr);
zdescr (12) := i; <*partial word := index*>
setzone6 (za (i), zdescr);
hw (i) := inrec6 (za (i), 0 );
while end_of_doc (i) do
begin <*next volume*>
next_volume (za, i, fileno, blockno, false <*output*>);
end_of_doc (i) := false; <*ready for eot again*>
getzone6 (za (i), zdescr);
zdescr (12) := i; <*partial word := index*>
setzone6 (za (i), zdescr);
hw (i) := inrec6 (za (i), 0 );
end <*next volume*>;
inrec6 (za (i), hw (i));
end <*get a record*>;
filenos_found := true;
for i := 1 step 1 until copies do
if -,fileno_found (i) then
begin <*check record*>
fileno_found (i) := hw (i) = 2;
filenos_found := filenos_found and fileno_found (i);
if fileno_found (i) then
close (za (i), false) <*terminate search, no release*>
else
increase (fileno (i)); <*continue search in next file*>
end <*check record*>;
end <*while -,filenos_found*> ;
end get_file_nos;
\f
<* sw8010/2, save tape handling procedures page ... 88...
1984.02.06 *>
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, save tape handling procedures page ... 89...
1984.10.31 *>
message out labelrec page 1;
procedure out_labelrec (ztape , tapename , fileno , type, segm, lab,
catname , catbase , catsize ,
dumptime, dumplevel, basetime );
value fileno , segm,
catsize ,
dumptime, dumplevel, basetime ;
zone ztape ;
long array tapename , lab,
catname ;
string type ;
integer fileno , segm,
catsize ,
dumptime, dumplevel, basetime ;
integer array catbase ;
<*******************************************************>
<* The procedure makes a zone record of 100 halfwords *>
<* available in the zone buffer of ztape and fills it *>
<* with characters constituting a save dump label. *>
<* Next, the record is output and the zone is stopped. *>
<* The values of the fields in the record are display- *>
<* ed on current output. *>
<* *>
<* Call : out_labelrec (ztape, tapename, fileno, *>
<* segm, lab); *>
<* *>
<* ztape (call and return value, zone). The name *>
<* of the document. Determones 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. *>
<* tapename (call value, long array). A name is pack- *>
<* ed in tapename (1:2). Written in the la- *>
<* bel as tapename. *>
<* fileno (call value, integer). A number which is *>
<* written as filenumber in the label. *>
<* type (call value, string). Should be one of *>
<* the strings : <:vers.:>, <:cont.:> or *>
<* <:empty:>. Written in the label. *>
<* segm (call value, integer). A value which is *>
<* written as no of segments in the label. *>
<* lab (call value, long array). A label name is *>
<* packed in label (1:2) or it is empty *>
<* (null characters). The name is written in *>
<* the label record. *>
<* catname (call value, long array). Contains the na-*>
<* me of the save catalog in catname (1:2). *>
<* catbase (call value, integer array). Contain the *>
<* entry bases of the save catalog in *>
<* catbase (1:2). *>
<* catsize (call value, integer). The size of -do-. *>
<* dumptime (call value, integer). The shortclock -do-*>
<* dumplavel (call value, integer). Value of dumplevel.*>
<* basetime (call value, integer). Value of basetime. *>
<* *>
<*******************************************************>
begin
\f
<* sw8010/2, save tape handling procedures page ... 90...
1982.01.19 *>
message out labelrec page 2;
procedure convproc (z, s, b);
zone z ;
integer s, b ;
<*******************************************************>
<* *>
<* The procedure is blockprocedure for the zone zconv *>
<* in which zone output messages are sent to a non ex- *>
<* isting process. When the dummy answer return, the *>
<* checksystem will call this procedure, which trans- *>
<* fers the contents of the core area described by *>
<* first and last address in the message to the zone *>
<* buffer of ztape and returns with status = 0 and the *>
<* proper number of halfwords transferred. *>
<* *>
<*******************************************************>
begin
integer halfwords;
integer array zdescr (1:20), shdescr (1:12);
getzone6 (z, zdescr);
getshare6 (z, shdescr, zdescr (17)); <*used share*>
halfwords := shdescr (6) - shdescr (5) + 2; <*last - first + 2*>
begin real array ra (1: (halfwords+3)//4); array field raf, raf1;
if system (5 )move core :( shdescr (5), ra) <> 1 then
stderror (z, s, b);
raf:= 4; raf1 := raf - 4;
ztape.raf1 (1) := real <::>;
to_from (ztape.raf, ztape.raf1, 96); <*zero ztape (1:25)*>
to_from (ztape, ra, halfwords); <*ra moved to tape buffer*>
end;
s := 0; <*status := 0*>
b := halfwords;
end convproc;
\f
<* sw8010/2, save tape handling procedures page ... 91...
1984.11.16 *>
message out labelrec page 3;
integer i, d;
real ymd, hms;
integer array zdescr (1:20), tail (1:10), user (1:2);
long array field laf;
integer field ifld;
zone zconv (15, 1, convproc);
laf := 0; <*fields ztape into a long array*>
if dumptime >= 0 and
dumptime <= 4213806 then
d := 4213807 <*750101.000000*> else d := dumptime;
if basetime >= 0 and
basetime <= 4213806 then
basetime := 4213807 ; <*750101.000000*>
ymd := systime (6) shortclock to decimal :(d, hms);
outrec6 (ztape, 100 ); <*make a record of 100 hw ready*>
getzone6 (ztape, zdescr); <*get record descr*>
open (zconv, 0, <:1:>, 0); <*will give dummy answer*>
write (zconv,
true, 9, if incdump then <:incsave:> else <:save:>,
true, 12, tapename, <<zdd>, ".", 1,
true, 5, fileno ,
true, 6, type ,
<<zddddd>, ymd, ".", 1,
<<zddd>, true, 8, entier (hms/100),
<:segm.:>, <<d>,
true, 4, segm ,
if inc_dump then
<:level.:> else <:label.:>);
if inc_dump then
write (zconv, <<d>,
true, 3, dumplevel,
<<zddddd>, systime (6, basetime, hms), ".", 1,
<<zddd>, true, 7, entier (hms/100))
else
write (zconv,
true, 17, lab);
\f
<* sw8010/a, save tape handling procedures page ... 92...
1985.02.08 *>
message out labelrec page 4;
write (zconv,
"nl", 1, "nul", 5, "em", 1); <*58 hwds*>
<*the nul characters to prevent em to get in current out*>
close (zconv, true); <*convproc moves zconv to ztape*>
write (out, "nl", 2, <:written on volume tape ::>,
"nl", 2, ztape.laf); <*display on current out*>
ifld := 60; ztape.ifld := segm;
ifld := ifld + 2; ztape.ifld := entries_in_partcat;
ifld := ifld + 2; ztape.ifld := total_entries_stored;
laf := ifld ; tofrom (ztape.laf, savecatname, 8); <*name*>
ifld := ifld + 10; ztape.ifld := catbase (1); <*bases*>
ifld := ifld + 2; ztape.ifld := catbase (2);
ifld := ifld + 2; ztape.ifld := catsize ; <*size*>
ifld := ifld + 2; ztape.ifld := dumptime ; <*shortclock*>
ifld := ifld + 2; ztape.ifld := version_id ; <*version *>
ifld := ifld + 2; ztape.ifld := release_id ; <*release*>
ifld := ifld + 2; ztape.ifld := sync_blocklength;
ifld := ifld + 2; ztape.ifld := aux_synclength;
stopzone (ztape, false); <*no tapemark*>
end out_labelrec;
\f
<* sw8010/2, save 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, save 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, <:exhausted:>, "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, save 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, save 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, <:ends:>, "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, save tape handling procedures page ... xx...
1984.02.22 *>
message transfer page 1;
integer
procedure transfer (za, copies, file, block, endtape, expell, mark);
value copies ;
zone array za ;
integer copies ;
integer array file, block ;
boolean array endtape, expell ;
boolean mark ;
<******************************************************************>
<* *>
<* The procedure transfers the segments of the backing storage a- *>
<* rea by the name area from segment number firstseg to as many *>
<* magnetic tape files as given by copies by the names given in *>
<* the zone array za (1:copies) starting in the positions given *>
<* in the file and block counts of the zones. *>
<* A possible end of tape condition will be signalled in the boo- *>
<* lean array end_tape (1:copies) by the block procedure in the *>
<* zones 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, copies, file, block, endtape, expell, mark); *>
<* *>
<* transfer (return value, integer). The number of segments *>
<* transferred. *>
<* za (call and return, zone array). The buffering, posi- *>
<* tion and name of the target documents. *>
<* The zone array is supposed to be declared za (1:co- *>
<* pies+1, buflengthio (copies+1, 2, segm*512), 2, *>
<* end_of_document), i.e. with a blocklength of segm* *>
<* 512 halfs. *>
<* The output is performed in za (1:copies) while the *>
<* input is performed in za (copies+1). *>
<* The input zone as well as the output zones are in *>
<* the states after open and position. *>
<******************************************************************>
\f
<* sw8010/2, save tape handling procedures page ... xx...
1984.03.06 *>
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 of the *>
<* area are transferred with error handling according *>
<* to the user bits in the giveup mask and the block *>
<* procedure. *>
<* The zone za (1:copies) are left in the state after *>
<* open and position, while the zone za (copies + 1) *>
<* is left in the state after declaration, i. e. the *>
<* area process has been removed. *>
<* *>
<* copies (call value, integer). See above. *>
<* 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. *>
<* endtape (call value, boolean array). The name of the array *>
<* where the procedure will suppose the blockprocedure *>
<* of the tape zones to signal end of document condi- *>
<* tion. *>
<* If end of document condition is found in one of the *>
<* output zones, a change of volume tape will be per- *>
<* formed in that zone. *>
<* expell (call value, boolean array). For output zones for *>
<* which expell (i) is true, the zone will be expelled *>
<* from the set of output zones just after openinout, *>
<* i. e. no output will take place in the zone. *>
<* mark (call value, boolean). If true, the tapes are posi- *>
<* tioned after a finishing tape mark, else after the *>
<* last block written and no tapemark is output. *>
<* *>
<******************************************************************>
\f
<* sw8010/2, save tape handling procedures page ... xx...
1984.11.08 *>
message transfer page 3;
begin
long sumhwds;
integer hwds, area, block_area, i, name_table_addr;
boolean end_of_doc_condition;
boolean array l_expell (1:copies);
integer array zdescr (1:20), dummyia (1:1), user (1:2);
long array proc_name (1:2);
long array field area_name;
sumhwds := 0 ;
area_name := 2 ; <*fields process name in zone descriptor*>
area := copies + 1; <*index in za for area zone*>
for i := 1 step 1 until copies do
begin <*check position operation in zones and get position*>
check (za (i));
getposition (za (i), file (i), block (i));
end;
getposition (za (area), file (area), block (area));
getzone6 (za (area), zdescr);
tofrom (proc_name, zdescr.area_name, 8);
name_table_addr := zdescr (6);
openinout (za, area); <*allocate shares for inoutrec*>
for i := 1 step 1 until copies do
begin
if test then
write (out,
"nl", 2, <: transfer ::>,
"sp", 2, <: file (:>, i, <:) = :>, file (i),
"sp", 2, <:block (:>, i, <:) = :>, block (i),
"sp", 2, <:n.t. addr = :>, name_table_addr);
if expell (i) then
expellinout (za, i);
end;
for hwds := inoutrec (za, 0) <*blockchange*> while hwds > 2 do
begin <*still not end of document in inputzone*>
<*check end of document in tapezones*>
end_of_doc_condition := false;
for i := 1 step 1 until copies do
end_of_doc_condition := end_of_doc_condition or endtape (i);
if -, end_of_doc_condition then
begin <*not end of document in any tape zone*>
changerecio (za, hwds); <*assures blockchange next inoutrec*>
sumhwds := sumhwds + hwds;
end else
begin <*end of document in one or more tape zones*>
\f
<* sw8010/2, save tape handling procedures page ... xx...
1986.10.12 *>
message transfer page 4;
<*begin end of document in one or more tape zones*>
end_of_doc_condition := false; <*ignore end of tape*>
for i := 1 step 1 until copies do
begin <*stop all zones, position before tape mark*>
stop_zone (za (i), endtape (i)); <*tape mark if endtape*>
getposition (za (i), file (i), block (i));
end;
getposition (za (area), 0, block_area); <*remember position*>
closeinout (za); <*check position operation and reallocate*>
for i := 1 step 1 until copies do
if end_tape (i) then
begin <*change to next volume in this zone*>
next_volume (za, i, file, block, true <*output*>);
l_expell (i) :=
end_tape (i) := false;
end <*change to next tape*> else
begin <*after closeinout the zone states are 'unpositioned'*>
setposition (za (i), file (i), block (i));
l_expell (i) := true; <*set expell condition*>
end;
for i := 1 step 1 until copies do
stopzone (za (i), false); <*no mark*>
close (za (area), false);
if inc_dump then
begin
for i := 1, 2 do
user (i) := user_base (i);
set_catbase (user);
end;
open (za (area), 4, save_cat_name, 0);
inrec6 (za (area), 2 ); <*est. nta*>
setposition (za (area), 0, 0);
if inc_dump then
reset_catbase;
transfer (za, copies, file, block, endtape, l_expell, false);
<*no tape mark*>
open (za (area), 4, proc_name, 0);
setposition (za (area), 0, block_area ); <*reposition*>
getzone6 (za (area), zdescr);
zdescr (6) := name_table_addr ;
setzone6 (za (area), zdescr);
for i := 1 step 1 until copies do
l_expell (i) := false; <*remove expell condition*>
openinout (za, area); <*reallocate for inoutrec*>
end <*end of document in one or more tape zones*>;
end <*for loop : still not end of document in input zone*>;
\f
<* sw8010/2, save tape handling procedures page ... xx...
1986.10.12 *>
message transfer page 5;
<*end of document in input zone, the area has been transferred*>
for i := 1 step 1 until copies do
begin <*stop zones, maybe tapemark, position after last block or mark*>
stop_zone (za (i), mark ); <*maybe tape mark*>
getposition (za (i), file (i), block (i));
getzone6 (za (area), zdescr );
name_table_addr := zdescr (6);
if test then
write (out,
"nl", 1, <:end transfer ::>,
"sp", 2, <: file (:>, i, <:) = :>, file (i),
"sp", 2, <:block (:>, i, <:) = :>, block (i),
"sp", 2, <:n.t. addr = :>, name_table_addr);
end;
closeinout (za); <*reallocate buffer area*>
<*after closeinout the zonestates are 'unpositioned'*>
for i := 1 step 1 until copies do
setposition (za (i), file (i), block (i));
for i := 1 step 1 until copies do
stopzone (za (i), false); <*no mark*>
close (za (area), false); <*remove area process*>
reset_catbase;
transfer := (sumhwds + 511) // 512; <*segments transferred*>
end <*transfer*>;
\f
<* sw8010/2, save tape handling procedures page ... xx...
1984.02.06 *>
message next volume page 1;
procedure next_volume (za, index, file, block, output);
value index ;
zone array za ;
integer index ;
integer array file, block ;
boolean output ;
begin
<***************************************************>
<* *>
<* The procedure performs a change of tape to next *>
<* volume : *>
<* *>
<* output : *>
<* *>
<* - write a continue record on the tape *>
<* - 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 the tape to file 1, block 0 *>
<* - write a continuation dump label record *>
<* *>
<* input : *>
<* *>
<* - 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 file 1, block 0 *>
<* *>
<* Call : *>
<* *>
<* next_volume (za, index, file, block, output); *>
<* *>
<* za (call and return value, zone array). *>
<* The zone za (index) 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, save tape handling procedures page ... xx...
1984.03.08 *>
message next volume page 2;
<* index (call value, integer). Apart from *>
<* the above zone, index specifies a *>
<* possible device number (cf. the pro- *>
<* cedure open tape), a modekind and a *>
<* possible label to be written in the *>
<* label record. *>
<* file (return value, integer arrays). At *>
<* block return the position of the tape is *>
<* recorded in file, block (index). *>
<* output (call value, boolean). Determines *>
<* whether the output or the input act- *>
<* ion is performed. *>
<* *>
<* Function : *>
<* *>
<* If the next volume name is not specified, the *>
<* procedure gives up with a runtime alarm. *>
<* During the in/output operations performed in *>
<* the procedure, the and of document status in *>
<* the answer is ignored. *>
<* *>
<***************************************************>
\f
<* sw8010/2, save tape handling procedures page ... xx...
1984.10.31 *>
message next volume page 3;
long array field labelname, curr_tape;
integer i;
vol_count (index) := vol_count (index) + 1; <*next volume*>
if vol_count (index) > no_of_vol (index) then
begin
out_end_mess (out, za (index), total_entrycount, total_segmcount);
give_up (za (index), 1 shift 18, 0); <*end of document*>
end;
curr_tape := name_field (index, vol_count);
if output then
out_continue_mess (out, za (index),
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 *>
if output then
begin
setposition (za (index), file (index), 0);
for i := 1 , 2 do
begin
outrec6 (za (index), 0);
setposition (za (index), file (index) + i, 0);
end;
end;
close (za (index), false add 1); <*release*>
open_tape (za (index), deviceno (index), modekind (index) extract 18,
tapename.curr_tape);
file (index) := 1;
block (index) := 0;
setposition (za (index), file (index), block (index));
if output then
begin
label_name := index * 8;
out_labelrec (za (index), tapename.curr_tape, file (index),
<:cont.:>, segm, dumplabel.labelname, savecatname, savecatbase,
savecatsize , dumptime , dumplevel , basetime );
end;
stop_zone (za (index), false ); <*no tape mark*>
getposition (za (index), file (index), block (index));
end <*next volume*>;
\f
<* sw8010/2, save 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, save ida process handling page ... xx...
1984.05.23*>
message get main proc page 1;
integer
procedure get_main_proc (subproc, main_kind, main_name);
value subproc ;
integer subproc, main_kind ;
long array main_name ;
<***********************************************************>
<* *>
<* The procedure returns the address, kind and name of the *>
<* main process to a given external process (subprocess). *>
<* *>
<* Call : get_mainproc (subproc, mainkind, mainname); *>
<* *>
<* get_mainproc (return value, integer). The address of *>
<* the main process. *>
<* subproc (call value, integer). The address of an *>
<* external process. *>
<* mainkind (return value, integer). The kind of the *>
<* main process. *>
<* mainname (return value, long array). The name of *>
<* the main process is returned in mainname *>
<* (1:2). *>
<* *>
<***********************************************************>
begin
integer array main_proc (1:1);
system (5) move core :(sub_proc + 10, mainproc); <*addr of sub.main*>
get_mainproc := mainproc (1);
system (5) move core :(mainproc (1) + 2, mainname); <*name - - - *>
system (5) move core :(mainproc (1) , mainproc); <*kind - - - *>
main_kind := mainproc (1);
end get_mainproc;
\f
<* sw8010/2, save ida process handling page ... xx...
1984.05.23 *>
message get next ida proc page 1;
integer
procedure get_next_idaproc (name);
long array name ;
<*********************************************************>
<* *>
<* The procedure returns the address and name of the *>
<* next external process of kind 20 (ida kind) if the *>
<* procedure has been called before, else the first one. *>
<* *>
<* Call : get_next_idaproc (name); *>
<* *>
<* get_next_idaproc (return value, integer). The add- *>
<* ress of the next ida process if the *>
<* procedure has been called before, *>
<* the address of the first one. If no *>
<* ida process exist a zero is retur- *>
<* ned. *>
<* name (return value, long array). The na- *>
<* me of the next ida process or the *>
<* first one, or a zero name as above. *>
<* *>
<*********************************************************>
begin
integer no_of_devices;
integer array devices (1:2);
own
integer device_no;
system (5) move core :(74, devices); <*first device, area in name table*>
no_of_devices := (devices (2) - devices (1)) // 2;
\f
<* sw8010/2, save ida process handling page ... xx...
1984.05.23 *>
message get next ida proc page 2;
begin <*block for nametable*>
integer array nametable (1:no_of_devices), proc (1:5);
integer i;
long array field device_name;
device_name := 2; <*fields name in process descr*>
system (5) move core :( devices (1), nametable);
for i := 1, 2 do
name (i) := long <::>; <*default*>
get_next_idaproc := 0 ; <*default*>
repeat <*until proc (1) = 20 or deviceno >= noofdevices*>
device_no := device_no + 1;
system (5) move core :( nametable (device_no), proc);
if proc (1) = 20 <*ida kind*> then
begin
for i := 1, 2 do
name (i) := proc.device_name (i);
get_next_idaproc := nametable (device_no);
end;
until proc (1) = 20 or device_no >= no_of_devices;
end <*block for nametable*>;
end get_next_idaproc;
\f
<* sw8010/2, save 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, save program page ...104...
1983.10.28 *>
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
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
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, save program page ...105...
1985.01.16 *>
message program page 2;
trap (slutlabel); <*to maybe remove savecat entry and unstack cur out*>
trapmode := 1 shift 13; <*ignore trap alarm message*>
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 *>
<*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_claim := area_claim - 2;
<*areas for program and maybe outfile have been taken*>
<*set two aside for savecat and possible infile*>
areas_needed := 4 + 2; <*program, savecat, outfile, infile, partcat, entry*>
entries_in_partcat :=area_claim - 1; <*reserve one for partcat*>
if entries_in_partcat > 50 then entries_in_partcat := 50;
if entries_in_partcat < 1 then
begin
write_alarm (out, <:area claim, at least needed ::>);
write (out, << ddd>, areas_needed, <:, claim ::>, area_claim + 3, "nl", 1);
trap (-1); <*to slutlabel to unstack current out*>
end;
version_id := 2; <*version of save*>
release_id := 3 shift 12 + 0; <*release of save*>
sync_blocklength := 200 ; <*length of syncblock*>
aux_synclength := 320;
<*initialize entry and segment counters*>
total_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, save program page ... 106...
1984.05.30 *>
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;
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 *>
end_ofdoc (i) :=
expellzone(i) := false; <*starting condition *>
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) := 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;
\f
<* sw8010/2, save program page ...105...
1981.12.15 *>
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*>;
mode_kind (copy_count) := 1 shift 23 + 18; <*mto, mtlh*>
mode_kind (copy_count) := 1 shift 23 + 2 shift 12 + 18; <*mte*>
mode_kind (copy_count) := 1 shift 23 + 4 shift 12 + 18; <*nrz, mtll*>
mode_kind (copy_count) := 1 shift 23 + 6 shift 12 + 18; <*nrze*>
mode_kind (copy_count) := 1 shift 23+128 shift 12 + 18; <*mthh*>
mode_kind (copy_count) := 1 shift 23+132 shift 12 + 18; <*mthl*>
end case action ;
seplength := scan_param (item);
end <*while action > 0*> ;
\f
<* sw8010/2, save 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);
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);
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> *>;
<*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, save program page ...107...
1984.12.04 *>
message program page 6;
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, save program page ...108...
1985.01.16 *>
message program page 7;
<*maybe special parameter*>
<*initialize special param variables*>
basetime :=
baselevel :=
dumplevel := 0; <*default dumplevel*>
list_entries := true;
test :=
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);
segm :=
if entry (14) > 1 and
entry (14) < 85 then entry (14) else 3; <*word 7 in tail if pos*>
progbase_lower := entry (2);
progbase_upper := entry (3);
end <*special block*>;
\f
<* sw8010/2, save program page ...109...
1985.02.06 *>
message program page 8;
<*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*>
begin
segm := round item (1);
if segm < 2 then
segm := 2; <*min for recprocs in zone array dim for iorecs*>
end;
<*level*>
dumplevel :=
if inc_dump then
round item (1)
else
0; <*if not incsave 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, save program page ...110...
1985.02.06 *>
message program page 9;
<*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*>
; <*survey*>
; <*check*>
; <*connect*>
; <*reserve*>
end case action;
seplength := scan_param (item);
end <* space_txt and special param*> ;
\f
<* sw8010/2, save declarations third block page ... xx...
1985.01.16 *>
message declare zones page 1;
ida_copy := no_of_copies = 1 and segm < 21 and 21 mod segm = 0;
<*segm has to be an integer divisor in 21 and less than 21*>
no_of_ida_shares := 1;
no_of_shares := if segm > 21 then 2 else 3; <*io operations*>
bufs_needed := (no_of_copies + 1) * (no_of_shares - 1);
<*buffers for iorec*>
if ida_copy and no_of_ida_shares > bufs_needed then
bufs_needed := no_of_ida_shares; <*buffers for copy operations*>
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;
savecat_name (1) := long <::>; <*default wrk...*>
for i := 1, 2 do
savecat_base (i) := std_base (i);
dumptime := systime (7) shortclock :(0, r);
if inc_dump then
begin <*get baselevel and basetime for dumplevel*>
basetime :=
get_level_clock (dumplevel, baselevel);
if set_level_clock (dumplevel, dumptime) = 0 then
for i := 1, 2 do
savecat_base (i) := user_base (i);
savecat_name (1) :=
long <:level:> add ('0' + ( if dumplevel < 0 then 0 else
if dumplevel > 9 then 9 else
dumplevel ));
savecat_name (2) := long <::>;
end <*get baselevel*>;
<*connect save zsavecat to backing storage area, create area proc*>
connect_alarm (out , savecatname,
connect_output (zsavecat, 4, savecatname, 0));
savecat_recstart := out_savecat_head (zsavecat) ;
savecat_reclength := if no_of_copies = 1 then 58 else 64;
<*record length in save catalog*>
buf_length := buflengthio (no_of_copies + 1, no_of_shares, segm * 512);
<*minimum for openio/inoutrec with blocklength segm * 512*>
begin <*declarations of ida, disc and tape zones, third block level*>
zone zida (
no_of_ida_shares * 20,
no_of_ida_shares,
take_over );
zone array ztape (
no_of_copies + 1,
buflength ,
no_of_shares ,
end_of_document);
\f
<* sw8010/2, save block procedures page ... xx...
1984.08.27 *>
message take over page 1;
procedure take_over (zmaster, status, segments);
zone zmaster ;
integer status, segments ;
begin
<*******************************************************>
<* *>
<* The procedure acts a block procedure in the zone *>
<* connected to the ida master process and supposes *>
<* a giveup mask of 1<16 + 1<5 + 1<4 + 1<3 + 1<2 + 1<1,*>
<* which leads all normal answers without error but *>
<* possibly tapemark sensed and all dummy answers to *>
<* call the block procedure without give up bit set, *>
<* while all normal answers with error will go to the *>
<* block procedure with give up bit set. *>
<* The status word then looks this way : *>
<* *>
<* 1<0 ; hard error, status in left half, normal *>
<* 1<1 : normal answer, hard error or not *>
<* *>
<* 1<2 - 1<5 : dummy answer, left half, normal, hard 0 *>
<* 1<2 : rejected *>
<* not reserver of master process *>
<* not reserver of tape process *>
<* not user of area process *>
<* 1<3 : unintelligible *>
<* mode/tape mode/blocksize illegal *>
<* source/destination device unknown *>
<* disk and tape station not on same ida *>
<* 1<4 : receiver malfunction *>
<* 1<5 : receiver does not exist *>
<* *>
<* 1<6 , 1<7 : do not occur *>
<* *>
<* 1<8 : stopped will not occur (calls stdaction)*>
<* *>
<* 1<9, 1<11 : do not occur *>
<* *>
<* 1<16 : tapemark sensed *>
<* 1<12-1<23 except 1<16 : *>
<* device status, 1<1 and 1<0 are set too *>
<* 1<12 : area error else tape error *>
<* *>
<*******************************************************>
\f
<* sw8010/2, save block procedures page ... xx...
1984.03.08 *>
message take over page 2;
<*******************************************************>
<* *>
<* The purpose og the procedure is to : *>
<* - update file and block count for all normal ans- *>
<* wers without error *>
<* - take over all transfers with error and update fi- *>
<* le and block count after the transfer *>
<* - try to reserve the master process in case of re- *>
<* jected before the transfer is taken over *>
<* The transfer is taken over by means of the procedu- *>
<* re transfer and the description of the transfer so *>
<* far in used share of the zone and the answer in rs *>
<* entry latest answer plus the position of the latest *>
<* checked transfer in file and block count of zmaster,*>
<* leaving the handling of the status to the normal *>
<* i/o in the zones of the transfer. *>
<* *>
<*******************************************************>
\f
<* sw8010/2, save block procedures page ... xx...
1984.08.21 *>
message take over page 3;
integer array dummyia (1:1), zdescr (1:20), sdescr (1:12),
answer (1:8), base (1: 2);
long array area, tape, main (1:2);
integer dummy, first_segm, i, sh, tape_addr, file,
block, kind, mon_release;
boolean mark;
long array field master;
master := 2; <*fields name in zone descr*>
getzone6 (zmaster, zdescr ); <*get master zone descr*>
getshare6 (zmaster, sdescr, zdescr (17)); <*get used share descr*>
<*mess in sdescr (4:11)*>
mark := sdescr (4) extract 12 = 1; <*write a finis tape mark*>
first_segm := sdescr (7) + segments ; <*first segm + segs xferred*>
system (14) latest answer :(dummy, answer); <*get answer*>
file := answer (4); <*file count from answer*>
block := answer (5); <*block count from answer*>
system (5) move core :(sdescr (6) - 4, base); <*proc bases*>
system (5) move core :(sdescr (6) + 2, area); <*area name *>
system (5) move core :(sdescr (9) + 2, tape); <*tape name *>
if test then
begin
write (out,
"nl", 2, <: take over ::>,
"nl", 1, <:ida name ::>, zdescr.master,
"nl", 1, <:status ::>, << ddd>, status,
"sp", 2, <:segs xferred ::>, segments,
"nl", 1, <:mark ::>, if mark then <: yes:> else <: no:>,
"nl", 2, <:message share ::>, zdescr (17));
for i := 4 step 1 until 11 do
begin
write (out,
"nl", 1, <: mess (:>, <<dd>, 2 * (i-4), <:) : :>, << dddddd>,
sdescr (i), sdescr (i) shift (-12), sdescr (i) extract 12);
if i = 6 then
write (out, "sp", 2, area);
if i = 9 then
write (out, "sp", 2, tape);
end;
write (out,
"nl", 2, <:answer ::>);
for i := 1 step 1 until 8 do
write (out,
"nl", 1, <: answ (:>, <<dd>, 2*(i-1), <:) ::>, << dddddd>,
answer (i));
end;
\f
<* sw8010/2, save block procedures page ... xx...
1984.03.06 *>
message take over page 4;
close (ztape (2), false ); <*dont remove present process*>
open (ztape (2), 4 , area, 0); <*insert name of area checked*>
set_catbase (base); <*to remove proc or connect *>
<*status extract 2 = 2 <=> normal answer, no hard arror*>
if status extract 2 = 2 then
begin <*remove the process checked*>
close (ztape (2), false); <*remove old process*>
reset_catbase;
end else
begin <*normal answer, hard error or dummy answer, no hard error*>
sh := zdescr (17);<*used share *>
for sh :=
(if sh+1 > zdescr (18) <*no of shares*> then
1 <*first share *>
else
sh+1 <*next share *>)
while sh <> zdescr (17) <*used share *> do
begin <*wait all pending operations, no check*>
getshare6 (zmaster, sdescr, sh);
if sdescr (1) > 1 then
begin
monitor (18) wait answer :(zmaster, sh, answer);
sdescr (1) := 1; <*share state := ready*>
setshare6 (zmaster, sdescr, sh);
end;
end <*wait all pending*>;
inrec6 (ztape (2), 0); <*connect establishing name table addr*>
stopzone (ztape (2), false);
\f
<* sw8010/2, save block procedures page ... xx...
1984.08.21 *>
message take over page 5;
if status extract 2 = 0 then
begin <*dummy answer, no hard error*>
file := zdescr (7); <*file count from zone*>
block := zdescr (8); <*block count from zone*>
if status shift (-3) extract 1 = 1 then
begin <*area and tape not same main process a. o.*>
get_main_proc (sdescr (9) <*tape proc*>, mainkind, mainname);
if mainkind = 20 <*ida kind*> and
(mainname (1) <> zdescr.master (1)
or mainname (2) <> zdescr.master (2)) then
begin <*reopen zmaster with new name*>
close (zmaster, false);
open (zmaster, 0 , mainname, 62); <*dummy + normal*>
end <*reopen*>;
end <*area and tape not same main process a. o.*>;
if status shift (-2) extract 1 = 1 <*rejected*> then
begin <*tape not reserved, area nor protected/reserved*>
monitor (8) reserve :(ztape (1), dummy, dummyia); <*ignore result*>
system (5) move core :(64, dummyia); <*monitor release*>
mon_release := dummyia (1); <*rel < 12 + sub *>
if mon_release >= 9 shift 12 + 1 then
monitor (30) write prot :(ztape (2), dummy, dummyia)
else
monitor ( 8) reserve :(ztape (2), dummy, dummyia);
end;
end <*dummy answer*>;
reset_catbase;
<*in case of normal answer, hard error, file and block are from answer*>
setposition (ztape (2), 0 , first_segm);
setposition (ztape (1), file , block );
segments := segments +
transfer (ztape, 1, fileno, blockno, end_of_doc, expell_zone, mark);
file := file_no (1);
block := blockno (1);
\f
<* sw8010/2, save block procedures page ... xx...
1984.08.27 *>
message take over page 6;
tape_addr :=
monitor (4) proc descr addr :(ztape (1), dummy, dummyia);
sh := zdescr (17);<*used share *>
for sh :=
(if sh+1 > zdescr (18) <* no of shares*> then
1 <*first share *>
else
sh+1 <*next share *>)
while sh <> zdescr (17) <*used share *> do
begin <*send all ready shares again with updated tape addr*>
getshare6 (zmaster, sdescr, sh);
sdescr (9) := tape_addr;
setshare6 (zmaster, sdescr, sh);
if sdescr (1) = 1 <*ready*> then
monitor (16) send message :(zmaster, sh, dummyia);
end <*send all ready shares again with updated tape addr*>;
status := 0;
end <*normal answer, hard error or dummy answer, no hard error*>;
if test then
write (out,
"nl", 2, <:status ::>, << ddd>, status,
"sp", 2, <:segs xferred ::>, segments,
"nl", 1, <:file ::>, file,
"sp", 2, <:block ::>, block,
"nl", 2, <:end take over :>, "nl", 1 );
zdescr (7) := file ;
zdescr (8) := block;
setzone6 (zmaster, zdescr);
segments := 0; <*to prevent index alarm in check at return*>
end take over;
\f
<* sw8010/2, save block procedures page ... xx...
1984.06.06 *>
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:no_of_copies + 1) and supposes that there are*>
<* no other user bits in the status than 1<18, e. o. d. *>
<* The purpose of the procedure is to : *>
<* - give up and call stderror if give up bit is raised *>
<* - 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 *>
<* *>
<**********************************************************>
integer array zdescr (1:20), sdescr (1:12);
integer index, operation;
if status extract 1 = 1 then
give_up (ztape, status, hwds);
if status shift (-18) extract 1 = 1 then
begin <* end of document *>
getzone__6 (ztape, zdescr );
getshare_6 (ztape, sdescr, zdescr (17)); <*used share*>
index := zdescr (12);
operation := sdescr ( 4) shift (-12);
end_of_doc (index) := true;
end <* end of document *>;
if operation = 3 <* input*> and
hwds = 0 <*nothing xferred*> then
hwds := 2;
end <*end of document*>;
\f
<* sw8010/2, save program page ...111...
1981.12.15 *>
message program page 8;
<*save specifier*>
<*initialize save specifier variables*>
anyscope := 0; all := 1; perm := 2;
sistem := 3; owen := 4; project := 5;
user := 6; login := 7; temp := 8;
for i := 1, 2 do
name (i) := docname (i) := long <::>; <*default : no name or docname*>
scope := temp ; <*default : temp *>
new_scope := any_scope; <*default : no change of scope*>
for i := 1 step 1 until no_of_discs do
begin
disc_specified (i) := true; <*default : all discs specif*>
for j := 1, 2 do
new_disc_name (i, j) := disc_name (i, j); <*default : no changedisc *>
end;
<*save states*>
save_state := before_save_spec := 1;
after_modifier := 2;
after_disc_spec := 3;
after_entry_spec := 4;
after_error := 5;
\f
<* sw8010/2, save program page ...112...
1985.02.06 *>
message program page 9;
<*interpret save specifiers*>
for action := save_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_int then
begin <*to disc = 0/1*>
from_to_discname (2, 1) := extend (round item (1)) shift 24 add 1;
from_to_discname (2, 2) := long <::>;
end else
if seplength <> point_txt 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
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) := disc_name ( maincatdisc, j);
end;
for i := 1 step 1 until no_of_discs do
begin
if from_to_discname (1, 1) = long <:all:>
or from_to_discname (1, 1) = long <:any:>
or from_to_discname (1, 1) = long <:main:>
or from_to_discname (1, 1) = disc_name (i, 1) and
from_to_discname (1, 2) = disc_name (i, 2) then
begin <*either from-disc = all or from-disc found*>
for j := 1, 2 do
new_discname (i, j) :=
if from_to_discname (2, 1) = long <:no:> then
discname (i, j)
else
from_to_discname (2, j);
end <*either*>;
end for i := 1;
end <*the first of a pair*>;
save_state := after_modifier;
end <*changedisc or changekit*>;
\f
<* sw8010/2, save program page ...113...
1981.12.15 *>
message program page 10;
<*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 new_scope := j := i; i := any_scope; end;
if j = -1 then
param_warning (out, <:warning newscope param unknown:>);
end <*parameter accepted*>;
seplength := scan_param (item); <*get next item*>
savestate := after_modifier ;
end <*newscope*>;
\f
<* sw8010/2, save program page ...114...
1981.12.15 *>
message program page 11;
<*case action of*>
begin <*disc or kit specifier*>
for i := 1 step 1 until no_of_discs do
disc_specified (i) := false; <*previous disc specifiers erased*>
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) := discname (maincatdisc, i);
end;
j := 0;
for i := 1 step 1 until no_of_discs do
if disc_spec_name (1) = discname (i, 1) and
disc_spec_name (2) = discname (i, 2)
or disc_spec_name (1) = long <:main:>
or disc_spec_name (1) = long <:all:> then
begin <*disc found in disc name table or disc.all*>
disc_specified (i) := true;
j := i;
end;
if j = 0 then
param_warning (out, <:warning disc spec param unknown:>);
end <*parameter accepted*>;
save_state := after_disc_spec;
end <*disc or kit specifier*>;
\f
<* sw8010/2, save program page ...115...
1982.03.24 *>
message program page 12;
<*case action of*>
begin <*entry specifier*>
<* <s><name>, neither a modifier nor a disc specifier*>
scope := 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:>);
save_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:>);
save_state := after_error;
end;
scope := j;
end <* .scope.<name> *>;
end <* .scope *>;
\f
<* sw8010/2, save program page ...116...
1982.12.28 *>
message program page 13;
<*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:>);
save_state := after_error;
end else
for i := 1, 2 do
docname (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:>);
save_state := after_error;
end else
if name (1) <> 0 then
begin <*name already assigned*>
param_warning (out, <:warning name double defined:>);
<*save state unchanged => entry specifier maybe saved*>
end else
for i := 1, 2 do
name (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, save program page ...117...
1985.02.21 *>
message program page 14;
if save_state <> after_error then
save_state := after_entry_spec;
<*a save specifier is ready*>
if save_state = after_entry_spec then
begin <*save the entries*>
entries_stored := store_entries (zsavecat, savecat_reclength,
name, scope, newscope, docname, basetime);
if entries_stored = 0 then
begin <*no entries found*>
list_specifiers (out,
write_alarm ( out, <:no entries found:>),
no_of_discs, disc_specified, discname, name, scope, docname);
errorbits := 2; <*warning.yes, alarm.no*>
end else
total_entries_stored := total_entries_stored + entries_stored;
end <*save the entries*>;
for i := 1, 2 do
name (i) := docname (i) := long <::>; <*back to default*>
scope := temp ; <*back to default*>
save_state := after_entry_spec ; <* - no errors*>
end <*entry specifier*>;
end <*case action*>;
end while action > 0;
\f
<* sw8010/2, save program page ...117...
1985.02.11 *>
message program page 15;
<*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 save spec param unknown:>);
seplength := scan_param (item);
end;
if save_state<> after_error and save_state <> after_entry_spec and
tape_param_ok then
begin <*default : save entries with default scope*>
entries_stored := store_entries (zsavecat, savecat_reclength,
name , scope, newscope, docname, basetime);
if entries_stored = 0 then
begin <*no entries found*>
list_specifiers (out,
write_alarm (out, <:no entries found:>),
no_of_discs, disc_specified, discname, name, scope, docname);
errorbits := 2; <*warning.yes, alarm.no*>
end else
total_entries_stored := total_entries_stored + entries_stored;
end;
<*outrec zeroed record, stop zsavecat, cut down area and disconnect*>
outrec6 (zsavecat, savecat_reclength);
raf1 := 0;
raf2 := 4;
zsavecat.raf1 (1) := real <::>;
tofrom (zsavecat.raf2, zsavecat.raf1, savecat_reclength - 4);
total_entries_stored := total_entries_stored + 1;
savecat_size := disconnect_output (zsavecat, false);
\f
<* sw8010/2, save prepare tape zones page ...110...
1984.10.31 *>
message prepare tapes and ida page 1;
<*prepare tapes*>
for copy_count := 1 step 1 until no_of_copies do
vol_count (copy_count) := 1; <*first volume each copy*>
if tapeparam_ok and total_entries_stored > 1 then
begin <*maybe search file numbers, share the buffer, open and pos*>
trap (trap_label); <*to release and remove processes*>
get_filenos (ztape, no_of_copies, vol_count, no_of_vol,
tapename , device_no, modekind , fileno);
for copy_count := 1 step 1 until no_of_copies do
begin <*simultaneously*>
current_tape := name_field (copy_count, vol_count); <*tape name*>
open_tape (ztape (copy_count), deviceno (copy_count),
modekind (copy_count) extract 18, tapename.current_tape);
setposition (ztape (copy_count), fileno (copy_count), 0);
end <*simultaneously*>;
for copy_count := 1 step 1 until no_of_copies do
begin <*version dump label*>
current_tape := name_field (copy_count, vol_count); <*tape name*>
label_name := copy_count * 8; <*fields labelname in dumplabel*>
out_labelrec (ztape (copy_count), tapename.current_tape,
fileno (copy_count), <:vers.:>, segm, dumplabel.labelname,
savecatname, savecatbase, savecatsize,
dumptime , dumplevel , basetime );
end <*version dump label*>;
for copy_count := 1 step 1 until no_of_copies do
begin <*position the tape zones*>
stopzone (ztape (copy_count), false); <*no tape mark*>
getposition (ztape (copy_count), fileno (copy_count), blockno (copy_count));
setposition (ztape (copy_count), fileno (copy_count), blockno (copy_count));
end <*position the tapes*>
\f
<* sw8010/2, save prepare tape zones page ... xx...
1985.01.16 *>
message prepare tapes and ida page 2;
<*prepare ida*>
if ida_copy then
begin <*init ida zone*>
mainproc :=
get_mainproc (monitor (4) proc addr :(ztape (1), dummy, dummyia),
mainkind, mainname);
if mainkind = 20 <*ida kind*> then
open (zida, 0, mainname, 1 shift 16 + 62) <*mark + dummy + normal*>
else
begin <*search any ida proc*>
mainproc := get_next_idaproc (mainname);
if mainname (1) <> long <::> then
open (zida, 0, mainname, 1 shift 16 + 62) <*mark + dummy + normal*>
else
open (zida, 0, <:1p:> , 1 shift 16 + 62); <*not exist*>
end <*search any ida*>;
getzone6 (zida, zdescr);
zdescr (1) := 0 ; <*tapemode < 12 + kind*>
zdescr (7) := file_no (1); <*file count *>
zdescr (8) := blockno (1); <*block count *>
setzone6 (zida, zdescr);
end;
\f
<* sw8010/2, save save entries page ... xx...
1985.02.11 *>
message save entries in cat page 1;
<*save entries recorded in save catalog*>
entries_saved :=
save_entries (
zida , ztape , no_of_copies , ida_copy ,
zsavecat, savecatname, total_entries_stored, savecat_reclength,
savecat_recstart ,
zpartcat, partcatname, entries_in_partcat );
if entries_saved = 0 then
begin <*nothing saved*>
write_alarm (out,
if total_entries_stored > 1 then
<:no entries saved according to any specifier:>
else
<:nothing saved:>);
errorbits :=
if total_entries_stored > 1 then
3 <*warning.yes, ok.no *>
else
2 <*warning.yes, ok.yes*>;
end <*nothing saved*>;
\f
<* sw8010/2, save end third block page ...118...
1985.01.16 *>
message end third block page 1;
<*finish ida and tapes*>
if ida_copy then
begin
close (zida, true); <*before tapes*>
getzone6 (zida, zdescr);
file_no (1) := zdescr (7);
blockno (1) := zdescr (8);
end;
for copy_count := 1 step 1 until no_of_copies do
out_endmess (out, ztape (copy_count), total_entrycount,
total_segm_count);
fpproc (33)out end:( 0, out, 'nul');
for copy_count := 1 step 1 until no_of_copies do
begin <* terminate with filemark *>
close (ztape (copy_count),
if release (copy_count) then false add 1 else false); <*maybe rel*>
end <*terminate with filemark*>;
end <*maybe search*>;
\f
<* sw8010/2, save end third block page ...119...
1985.07.09 *>
message end third block page 2;
if false then
traplabel:
begin <*traproutine to release and remove processes*>
maybe_device_status (out);
close (zida, true); <*release*>
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');
for copy_count := 1 step 1 until no_of_copies do
begin <*out tapemark*>
setposition (ztape (copy_count),
fileno (copy_count),
blockno (copy_count));
outrec6 (ztape (copy_count), 0);
setposition (ztape (copy_count),
fileno (copy_count) + 1,
0 );
close (ztape (copy_count),
if release (copy_count) then false add 1 else false);
end <*out tapemark*>;
close (ztape (no_of_copies + 1), true); <*release and remove*>
trapmode := 1 shift 13; <*ignore trap message*>
trap (1); <*next trap label*>
end <*trap routine*>;
end <*declarations of disc and tape zones, third block level*>;
\f
<* sw8010/2, save program page ...119...
1982.02.15 *>
message program page 16;
getzone_6 (out, zdescr);
if zdescr (1) extract 12 = 4 then
begin
<*write save statistics*>
list_______counters (out, entry_count, slice_count);
list_total_counters (out, total_entry_count, total_segm_count);
end;
\f
<* sw8010/2, save program tail page ...120...
1984.10.30 *>
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*>
if -, inc_dump then
monitor (48) remove entry :(zsavecat, 1, dummyia)
else
close (zsavecat, true ); <*remove proc*>
monitor (48) remove entry :(zpartcat, 1, dummyia);
close (zpartcat , true );
if chain_name (1) <> real <::> then
unstack_current_output;
end <*second level*>;
end;
▶EOF◀