|
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: 228096 (0x37b00)
Types: TextFile
Names: »save133tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »save133tx «
begin
\f
<* sw8010/1, save pageheads page ... 1...
1983.10.31 *>
message pageheads page 1;
<***************************************************>
<* *>
<* Contents : *>
<* *>
<* Procedure/program heads : Page : *>
<* *>
<* pageheads page 1 ...... 1 *>
<* decl first level page 1 ...... 3 *>
<* prepare_paramscan page 1 ...... 4 *>
<* scan param page 1 ...... 5 *>
<* next item page 1 ...... 6 *>
<* param alarm page 1 ...... 9 *>
<* param warning page 1 ...... 10 *>
<* write alarm page 1 ...... 11 *>
<* write param list page 1 ...... 12 *>
<* write param page 1 ...... 13 *>
<* write char page 1 ...... 14 *>
<* system four page 1 ...... 15 *>
<* init fp table page 1 ...... 32 *>
<* skip until nl page 1 ...... 33 *>
<* stack current in put page 1 ...... 34 *>
<* unstack current input page 1 ...... 35 *>
<* stack current output page 1 ...... 36 *>
<* unstack current output page 1 ...... 37 *>
<* decl. second level page 1 ...... 38 *>
<* mount param page 1 ...... 40 *>
<* special param page 1 ...... 41 *>
<* file no tape name page 1 ...... 43 *>
<* entry specifier page 1 ...... 44 *>
<* save specifier page 1 ...... 46 *>
<* list specifiers page 1 ...... 48 *>
<* prepare cat scan page 1 ...... 50 *>
<* scan cat page 1 ...... 52 *>
<* next entry page 1 ...... 55 *>
<* check name page 1 ...... 56 *>
<* check scope page 1 ...... 57 *>
<* check docname discno page 1 ...... 60 *>
<* set_catbase page 1 ...... 62 *>
<* reset catbase page 1 ...... 63 *>
<* bases page 1 ...... 64 *>
<* save entries page 1 ...... 65 *>
<* change entry page 1 ...... 72 *>
<* list entry page 1 ...... 74 *>
<* *>
<***************************************************>
\f
<* sw8010/1, save pageheads page ... 2...
1983.10.31 *>
message pageheads page 2;
<***************************************************>
<* *>
<* skip entry page 1 ...... 77 *>
<* modekind case page 1 ...... 78 *>
<* list counters page 1 ...... 79 *>
<* list total counters page 1 ...... 80 *>
<* disc buf length page 1 ...... 81 *>
<* share buffer area page 1 ...... 83 *>
<* open tape page 1 ...... 84 *>
<* get file nos page 1 ...... 85 *>
<* name field page 1 ...... 88 *>
<* out labelrec page 1 ...... 89 *>
<* changerec continuerec page 1 ...... 92 *>
<* outrec endrec page 1 ...... 94 *>
<* outrec entryrec page 1 ...... 95 *>
<* outrec segmentrec page 1 ...... 97 *>
<* next volume page 1 ...... 99 *>
<* give up page 1 ...... 102 *>
<* program head page 1 ...... 103 *>
<* program page 2 ...... 104 *>
<* declare zones page 1 ...... 109 *>
<* prepare tapes page 1 ...... 110 *>
<* program page 7 ...... 111 *>
<* end third block page 1 ...... 118 *>
<* program page 13 ...... 119 *>
<* program tail page 1 ...... 120 *>
<* *>
<***************************************************>
\f
<* sw8010/1, save declarations first level page ... 3...
1982.12.21 *>
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 chain_name (1:2);
\f
<* sw8010/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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 prog_name (1:2);
system (2, 1, prog_name);
outchar (out, 'nl');
write_alarm :=
write (z, <:*** :>, prog_name, <: :>, text, <: :>);
end write_alarm;
\f
<* sw8010/1, 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 ... 13...
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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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 *>
<* and terminated it. *>
<* *>
<***********************************************************>
begin
fp_proc (34, 0, out, 25); <*close up *>
fp_proc (79, 0, out, 0); <*terminate*>
fp_proc (30, 0, out, chain_name); <*unstack *>
end unstack_current_output;
\f
<* sw8010/1, save decl. for parameters/discs page ... 38...
1983.10.28*>
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 *>
reserve_area ,
not_prog_area ,
tape_param_ok ;
boolean array release (1:2) , <*mount param *>
mount_param_spec (1:2) , <*mount param *>
disc_specified (1:no_of_discs); <*save specifier*>
integer action , <*param action *>
point_int ,
point_txt ,
space_int ,
space_txt ,
seplength ,
old_length ,
copy_count ,
no_of_copies ,
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 ,
progbase_lower ,
progbase_upper ,
segm ,
tape_buffers ,
tape_buflength ,
reserve_core ,
total_entry_count ,
total_segm__count ,
i ,
j ,
k ;
\f
<* sw8010/1, save decl. for parameters/discs page ... 39...
1981.12.11 *>
message decl. second level page 2;
integer array device_no ,
mode_kind ,
vol_count ,
no_of_vol ,
file_no (1:2),
slice_length ,
entry_count ,
slice_count ,
name_table (1:no_of_discs);
long array name ,
docname ,
disc_spec_name (1:2),
dump_label ,
from_to_discname (1:2 ,
1:2),
tape_name (1:2 ,
1:2 * max_no_of_vol),
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 ,
outfile ,
prog_name (1:2);
\f
<* sw8010/1, 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 *>
<* 4 -"- , -"- mte *>
<* 5 -"- , -"- nrz *>
<* 6 -"- , -"- nrze *>
<* 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 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 6) do
if item (1) = real ( case i of (
<:mount:> add 's',
<:relea:> add 's',
<:mto:> ,
<:mte:> ,
<:nrz:> ,
<:nrze:> ) ) and
item (2) = real ( case i of (
<:pec:> ,
<:e:> ,
<::> ,
<::> ,
<::> ,
<::> ) ) then
begin j := i; i := 6; end;
mount_param := j;
end mount_param;
\f
<* sw8010/1, save parameter interpretation page ... 41...
1983.02.08 *>
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 = list *>
<* 3 <s><name> and name = reserve *>
<* 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/1, save parameter interpretation page ... 42...
1983.02.09 *>
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 3) do
if item (1) = real ( case i of (
<:segm:>,
<:list:>,
<:reser:> add 'v')) and
item (2) = real ( case i of (
<::>,
<::>,
<:e:>)) then
begin j := i; i := 3; 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 = 1 <*segm*> and next_seplength <> point_int <*not .<int>*>
or j > 1 <*list*> 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/1, 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/1, 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/1, 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/1, 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/1, 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/1, 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. *>
<* docname (call value, long array). A docname is pack- *>
<* in docname (1:2) ordocname (1) = 0. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, 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.:>, docname );
end list_specifiers;
\f
<* sw8010/1, save catalog scanning page ... 50...
1981.12.10 *>
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 main catalog scan for an en- *>
<* 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 main 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 main *>
<* catalog together with the document *>
<* the buffering and the position of *>
<* the document. *>
<* 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/1, save catalog scanning page ... 51...
1982.12.28 *>
message prepare cat scan page 2;
begin
integer result, proc_descr_addr, segm_no, noofkeys, size;
integer array dummy (1:1), proc_descr (0:9);
integer field entrycount;
long twoexp36, sum;
entrycount := 512; <*fields the last word of a catalog segment*>
twoexp36 := extend 1 shift 36; <*2**36 as long*>
open (z, 4, <:catalog:>, 0); <*name of main catalog*>
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) ;
sum := sum shift (-24) +
sum shift 24 shift (-24) ;
sum := sum shift 24 shift (-24) +
(sum shift (-12) shift 36 ) // twoexp36;
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/1, save catalog scanning page ... 52...
1981.12.10 *>
message scan cat page 1;
boolean
procedure scan_cat (z, name, scope, docname, discno ,
actual_scope, entry , name_key, name_count);
value scope ;
zone z ;
long array name, docname ;
integer array entry ;
integer discno ,
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. *>
<* 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. *>
<* discno (return value, integer). If the procedure *>
<* returns true, the name of the disc where *>
<* the entry belongs is found in discname *>
<* (discno, 1:2) and discspecified (discno) *>
<* is true. *>
<* If the procedure returns false, discno is *>
<* 0, meaning any disc name. *>
\f
<* sw8010/1, save catalog scanning page ... 53...
1981.12.09 *>
message scan cat page 2;
<* 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/1, save catalog scanning page ... 54...
1981.12.09 *>
message scan cat page 3;
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/1, 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/1, 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/1, 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;
long array cat_base, std_base, user_base, max_base,
sys_base (1:2);
integer array field base;
base := 2; <*fields entry base in entry*>
permkey := entry (1) extract 3;
bases (cat_base, std_base, user_base, max_base, sys_base);
\f
<* sw8010/1, 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/1, 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/1, save catalog scanning page ... 60...
1981.12.09 *>
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 (return value, integer). If *>
<* 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 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/1, save catalog scanning page ... 61...
1981.12.09 *>
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;
<*find the name of the disc where entry belongs*>
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*>
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/1, 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/1, 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;
long array stdbase, userbase, maxbase, sysbase (1:2);
if -,called_before then
begin <*save catbase and init branch*>
long array catbase (1:2);
called_before := true;
bases (catbase, stdbase, userbase, maxbase, sysbase);
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/1, 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/1, save save entries page ... 65...
1982.12.21 *>
message save entries page 1;
integer
procedure save_entries (za , i , copies , zarea ,
name, scope, newscope, docname);
value copies ,
scope, newscope ;
zone array za ;
zone zarea ;
integer i , copies ,
scope, newscope ;
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.*>
<* For each entry found, the entry together with a pos- *>
<* sible area is dumped on the tape(s) specified. *>
<* *>
<* call : save_entries (za, i, copies, *>
<* name, scope, newscope, docname); *>
<* *>
<* save_entries (return value, integer). The number of *>
<* entries found in the main catalog be- *>
<* longing to a disc specified and satis- *>
<* fying the name, scope and document name *>
<* specifications given in the call. *>
<* za (call and return value, zone array). The do-*>
<* cument, buffering and position of the docu- *>
<* ments. The zones za (1:copies) are supposed *>
<* to share the same buffer area. *>
<* i (call value, integer). Used as index in za *>
<* (1:copies). To cooperate with the block pro-*>
<* cedure next_volume, actual parameter has to *>
<* be copy_count. *>
<* copies (call value, integer). See za. *>
<* zarea (call and return value, zone). The name of *>
<* the document, the buffering and the positi- *>
<* on of the document holding the area. *>
<* The zone state is supposed to be after de- *>
<* claration and is left the same. *>
<* 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. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, save save entries page ... 66...
1983.10.28 *>
message save entries page 2;
begin
integer disc_no, name_count, name_key, actual_scope,
disc_no_b, actual_scope_b,
entries_saved, hwds, result, segmentcount,
segments, write_accesses, j, mon_release;
integer array entry , entry_b (1:17), proc (1:18), create_base (1:2);
integer field size;
integer array field base;
long array field disc, entryname;
zone zcat (128, 1, stderror);
\f
<* sw8010/1, save save entries page ... 67...
1983.02.08 *>
message save entries page 3;
base := 2; <*fields base in entry*>
entryname := 6; <*fields name in entry*>
size := 16; <*fields size in entry*>
system (5) move core :(64, proc); <*monitor release*>
mon_release := proc (1); <*release < 12 + subrelease*>
entries_saved := 0; <*local total entry count*>
name_count :=
prepare_cat_scan (zcat, name, name_key);
while scan_cat (zcat, name, scope, docname, discno,
actual_scope, entry, name_key, name_count) do
begin <*save the entry found, update tables and counters*>
if name (1) <> 0 and scope = 0 then
begin <*find the best entry*>
while scan_cat (zcat, name, scope, docname,
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/1, save save entries page ... 68...
1983.10.28 *>
message save entries page 4;
disc := 8 * discno; <*fields disc name in discname*>
if entry.size > 0 then
begin <*open area*>
set_catbase (entry.base); <*if outside max then max*>
for j := 1, 2 do
create_base (j) := entry.base (j); <*base where to remove process*>
open (zarea, 4, entry.entryname, 0); <*no user bits*>
result :=
monitor (52 )create area process:( zarea, 0, proc <*dummy*>);
result := result shift 12 + (
if result = 0 and mon_release >= 9 shift 12 + 1 then
monitor (30) set write protection :(zarea, 0, proc <*dummy*>)
<*process created and mon rel >= 9.1*>
else
if result = 0 and reserve_area then
monitor ( 8) reserve process :(zarea, 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 then
begin <*process exists, get write access counter and check bases*>
system (5 )move core :(
monitor (4 )proc desc :( zarea, 0, proc <*dummy*>) - 4,
proc ); <*process description*>
write_accesses := proc (17);
if proc (1) <> entry.base (1)
or proc (2) <> entry.base (2) then <*area inaccessible *>
result := 2; <*result 2 from reserve proc is borrowed*>
if result = 0 then
begin <*get name table address*>
inrec6 (zarea, 0 ); <*send message *>
setposition (zarea, 0, 0); <*reset segm count*>
end <*get name table address*>;
end <*process exists*>;
not_prog_area :=
progname (1) <> entry.entryname (1) or
progname (2) <> entry.entryname (2) or
progbase_lower <> entry.base (1) or
progbase_upper <> entry.base (2) ;
reset_catbase; <*name table address has been established*>
end <*open area*> else
result := 0; <*bs entry, entry ok*>
\f
<* sw8010/1, save save entries page ... 69...
1982.02.05 *>
message save entries page 5;
if result > 0 then
begin <*entry not ok*>
if list_entries then
skip_entry (out, list_only_name, entry, scope, actualscope, result);
end <*entry not ok*> else
begin <*entry ok, update counters, save and list*>
change_entry (entry, actual_scope, new_scope, disc_no);
outrec_entryrec (za, i, copies,
entry, scope, newscope, actual_scope, discno,
total_entry_count,
if entry.size > 0 then entry.size else 0 );
<*total_entrycount is increased by one in outrec_entryrec*>
entry_count (discno) := entry_count (discno) + 1; <*disc entry count*>
entries_saved := entries_saved + 1; <*loc. entry count*>
if list_entries then
list_entry (out, list_only_name, entry, scope, actual_scope,
new_scope);
\f
<* sw8010/1, save save entries page ... 70...
1983.02.09 *>
message save entries page 6;
if entry.size > 0 then
begin <*save the area*>
segmentcount := 0; <*local segment count*>
for hwds := inrec6 (zarea, 0) while hwds > 2 do
begin <*not end of document*>
if hwds > segm * 512 then hwds := segm * 512;
inrec6 (zarea, hwds); <*record of segm * 512 hwds*>
segments := segmentcount; <*to measure increment*>
outrec_segmentrec (za , i , copies ,
zarea, total_entrycount, segmentcount);
<*segments_saved is incremented in outrec segmentrec*>
segments := segmentcount - segments; <*increment*>
total_segmcount := total_segmcount + segments;
end <*not end of document*>;
slice_count (discno) :=
slice_count (discno) + (segmentcount +
slicelength (discno) - 1) //
slicelength (discno) ;
<*get write access counter again*>
system (5 )move core :(
monitor (4 )proc desc :( zarea, 0, proc <*dummy*>) - 4,
proc ); <*proc descr*>
if proc (17) <> write_accesses then
begin <*changed during save*>
if -,list_entries then
list_entry (out, false <*entire entry*>, entry, scope,
actual_scope, newscope);
write (out, "nl", 2,
<:*** warning : area changed during save:>, "nl", 1);
errorbits := 2; <*warning.yes, ok.yes*>
end else
if entry.size <> segmentcount then
begin <*inconsistent*>
if -,list_entries then
list_entry (out, false <*entire entry*>, entry, scope,
actual_scope, newscope);
write (out, "nl", 2,
<:*** warning : area and entry inconsistent, area length :>,
segmentcount,
<: segment:>, if segmentcount > 1 then "s" else "nul", 1,
"nl", 1);
errorbits := 2; <*warning.yes ok.yes*>
end <*inconsistent*>;
end <*save the area*>;
\f
<* sw8010/1, save save entries page ... 71...
1983.10.28 *>
message save entries page 7;
end <*entry ok*>;
if entry.size > 0 then
begin <*close area*>
set_catbase (create_base);
close (zarea, not_prog_area); <*remove areaprocess if not program*>
reset_catbase;
end <*close area*>;
end <*save the entry found*>;
close (zcat, true); <*end catalog scan*>
save_entries := entries_saved;
end save_entries;
\f
<* sw8010/1, save entry handling page ... 72...
1981.12.29 *>
message change entry page 1;
procedure change_entry (entry, actual_scope, new_scope, disc_no);
value actual_scope, new_scope, disc_no ;
integer array entry ;
integer actual_scope, new_scope, disc_no ;
<*********************************************************>
<* *>
<* 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. *>
<* disc_no (call value, integer). The number in the *>
<* disc table of the disc to which the en- *>
<* try belongs. *>
<* 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 global long array new_disc_ *>
<* name for that disc. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, save entry handling page ... 73...
1981.12.29 *>
message change entry page 2;
begin
integer i, act_key, dummy;
long array cat_base, std_base, user_base, max_base,
sys_base, act_base (1:2);
integer field permkey, size;
integer array field base;
long array field docname, disc;
permkey := 2; <*fields permkey in head*>
base := 2; <* -"- base (1:2) -"- *>
size := 16; <* -"- size in tail*>
doc_name := 16; <* -"- docname -"- *>
disc := discno * 8; <*fields discname in new_discname*>
if new_scope <> 0 and new_scope <> actual_scope then
begin <*change permkey and base in head*>
bases (cat_base, std_base, user_base, max_base, sysbase);
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.disc (i);
end change_entry;
\f
<* sw8010/1, save entry handling page ... 74...
1981.12.29 *>
message list entry page 1;
procedure list_entry (z, nameonly, entry, scope, act_scope, newscope);
value scope, act_scope, newscope ;
zone z ;
boolean nameonly ;
integer array entry ;
integer scope, act_scope, newscope ;
<*********************************************************>
<* *>
<* 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. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, 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),
<:.:>, 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:>, <: mto:>,
<: mte:>, <: nrz:>, <:nrze:>, <: 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/1, save entry handling page ... 76...
1981.12.30 *>
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.contents shift (-12) <> 4 and
entry.contents shift (-12) < 32 then
write (z, <: d.:>, <<zddddd>,
systime (6) shortclock to decimal :(entry.shortclock, hhmmss),
<:.:>, <<zddd>, hhmmss/100 );
end <*list more*>;
end list_entry;
\f
<* sw8010/1, save entry handling page ... 77...
1983.02.09 *>
message skip entry page 1;
procedure skip_entry (z, only_name, entry, scope, actualscope, result);
value scope, actualscope, result ;
zone z ;
boolean only_name ;
integer array entry ;
integer scope, actualscope, 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- *>
<* result (call value, integer). The result of *>
<* create area process < 12 + result of *>
<* reserve area process. *>
<* *>
<*********************************************************>
begin
list_entry (z, only_name, entry, scope, actualscope, 0); <*no newscope*>
write (z, "nl", 2, <:*** warning : entry 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:>),
"nl", 1);
errorbits := 2; <*warning.yes ok.yes*>
end skip_entry;
\f
<* sw8010/1, 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 22 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*>
1 shift 23 + 2 shift 12 + 18, <* mte*>
1 shift 23 + 4 shift 12 + 18, <* nrz*>
1 shift 23 + 6 shift 12 + 18, <*nrze*>
1 shift 23 + 0 shift 12 + 20))<* pl*> then
begin j := i; i := 22 end;
modekind_case := j;
end modekind_case;
\f
<* sw8010/1, 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 disc_specified (disc_no) and
(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/1, 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/1, save tape handling procedures page ... 81...
1982.01.19 *>
message disc buf length page 1;
integer
procedure disc_buflength (reserved, segmprbuf, tbuflength, tbuffers);
value reserved, segmprbuf ;
integer reserved, segmprbuf, tbuflength, tbuffers ;
<*********************************************************>
<* *>
<* The procedure allocates buffer lengths and number of *>
<* buffers according to below algorithm : *>
<* *>
<* It is tried to reserve a given amount of core to al- *>
<* low for algol pages and stack space sufficient to a- *>
<* void paging in the central loop. *>
<* One tape buffer item equals 8 + 512 * segmprbuf hwds. *>
<* One disc buffer item equals 512 * segmprbuf hwds. *>
<* *>
<* If free core - reserved < 2 tape buffer items then *>
<* one disc buffer item is allocated for single buf- *>
<* fered disc and tape zones, reducing reserved core *>
<* else *>
<* if free core - reserved <= 2 tape buffer items and *>
<* 1 disc buffer item then *>
<* one tape buffer item is allocated for single buf- *>
<* fered tape zone and the remaining disc buffer items *>
<* for single buffered disc zone, maintaining reserved *>
<* core *>
<* else *>
<* two tape buffer otems are allocated for double buf- *>
<* fered tape zone and the remaining disc buffer items *>
<* for single buffered disc zone, still maintaining *>
<* reserved core. *>
<* *>
<* Call : discbuflength (reserved, segmprbuf, *>
<* tbuflength, tbuffers) *>
<* *>
<* discbuflength (return value, integer). Number of *>
<* reals (one or more disc buffer items) *>
<* to allocate single buffered disc zone. *>
<* reserved (call value, integer). Number of half- *>
<* words tried to set aside to avoid pa- *>
<* ging in inner loop. *>
<* segmprbuf (call value, integer). Number of seg- *>
<* ments in each buffer item. *>
<* tbuflength (return value, integer). Number of *>
<* reals (one or two tape buffer items) *>
<* to allocate tape zone. *>
<* tbuffers (return value, integer). Number of *>
<* buffers (of one tape buffer item each) *>
<* to allocate tape zone. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, save tape handling procedures page ... 82...
1982.01.19 *>
message disc buf length page 2;
begin
integer tbuf_item, dbuf_item, free_core, dummy;
long array dummy_la (1:2);
free_core := system (2, dummy, dummyla) <*free core *>
+ 1024 <*two pages *>
+ 22 <*local declarations *>
+ 18 <*type proc, two surr. bl. *>
+ 20 ; <*params, one constant *>
tbuf_item := 8 + 512 * segmprbuf; <*tape buffer item*>
dbuf_item := 512 * segmprbuf; <*disc buffer item*>
tbuffers :=
if free_core - reserved <= 2 * tbuf_item + dbuf_item then 1 else 2;
tbuflength := tbuffers * tbuf_item;
discbuflength := (
if free_core - reserved < tbuf_item + dbuf_item then
dbuf_item
else
(free_core - reserved - tbuflength) // dbuf_item * dbuf_item
) // 4; <*reals*>
tbuf_length := tbuf_length // 4; <*reals*>
end disc_buffer_length;
\f
<* sw8010/1, save tape handling procedures page ... 83...
1982.01.19 *>
message share buffer area page 1;
procedure share_buffer_area (za);
zone array za ;
<*********************************************************>
<* *>
<* The procedure supposes that the zone array is decla- *>
<* red with two zones. *>
<* The procedure changes the zone descriptions to des- *>
<* cribe as buffer area for each one the united buffer *>
<* area for the two zones, except two elements in the *>
<* end. *>
<* *>
<* Call : share_buffer_area (za); *>
<* *>
<* za (call and returm value, zone array). Supposed to *>
<* be declared zone array za (2, ...). *>
<* *>
<* First the entire zone buffer is shared among the *>
<* two zones with the two last elements to z (2) and *>
<* all the rest to z (1), and the two zones are gi- *>
<* ven the same number of shares, taken from z (1). *>
<* Second a zone buffer for z(2) with base zero and *>
<* length equal the entire buffer area of z (1) is *>
<* allocated to z (2). *>
<* The zone state of z (2) becomes 4 (after decl). *>
<* *>
<*********************************************************>
begin
integer array buflength, shares (1:2), zdescr (1:20);
getzone6 (za (1), zdescr);
buflength (1) := (zdescr (20) - 1) * 2; <*all except two elem*>
buflength (2) := 2; <*two elem *>
shares (1) :=
shares (2) := zdescr (18) ; <*no of shares z (1) *>
initzones (za, buflength, shares) ;
allocbuf (za (2), za (1), 0 <*base*>, 4 * buflength (1) <*length*>);
getzone6 (za (1), zdescr);
setzone6 (za (2), zdescr);
end share_buffer_area;
\f
<* sw8010/1, save tape handling procedures page ... 84...
1982.12.28 *>
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, blproc)*>
<* *>
<* 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, docname, 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>:>*>
mess (1) := 16 shift 12; <*print mess, no wait*>
raf := 2;
movestring (mess.raf, 1, <:ring :>);
raf := 8;
to_from (mess.raf, docname, 8); <*document name*>
system (10 )parent mess:( dummy, mess);
end <*parent message : print <:ring <docname>:>*>;
end open_tape;
\f
<* sw8010/1, save tape handling procedures page ... 85...
1982.01.19 *>
message get file nos page 1;
procedure getfilenos (za, i, copies, volcount, no_of_vol, tapename ,
devno , modekind , fileno );
value copies ;
zone array za ;
integer i, 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. *>
<* i (call value, integer). Used as index in *>
<* zone array za (1:copies). To cooperate *>
<* with the block procedure next_volume, *>
<* the actual parameter has to be copy_ *>
<* count. *>
<* 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/1, save tape handling procedures page ... 86...
1982.01.19 *>
message get file nos page 2;
begin
integer array hw (1:copies);
boolean file_nos_found;
boolean array file_no_found (1:copies);
long array field curr_tape;
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), tapename.curr_tape);
end <*init search*>;
end <*if fileno missing then init search*>;
\f
<* sw8010/1, save tape handling procedures page ... 87...
1982.01.19 *>
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*>
hw (i) := inrec6 (za (i), 0);
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*>
if hw (i) <> 100 then
fileno_found (i) := true
else
fileno_found (i) :=
za (i, 1) <> real <:dump :> add 'sp' or
za (i, 5) <> real <:vers.:> add 'sp' and
za (i, 5) <> real <:cont.:> add 'sp';
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/1, save tape handling procedures page ... 88...
1982.01.19 *>
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/1, save tape handling procedures page ... 89...
1982.01.19 *>
message out labelrec page 1;
procedure out_labelrec (ztape, tapename, fileno, type, segm, lab);
value fileno, segm ;
zone ztape ;
long array tapename, lab ;
string type ;
integer fileno, segm ;
<*******************************************************>
<* 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 a new record of zero *>
<* halfwords is made available in the zone buffer. *>
<* 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. *>
<* *>
<*******************************************************>
begin
\f
<* sw8010/1, 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/1, save tape handling procedures page ... 91...
1983.02.22 *>
message out labelrec page 3;
real time, dmy, hms, release_no;
integer array zdescr (1:20);
long array field laf;
zone zconv (14, 1, convproc);
laf := 0; <*fields ztape into a long array*>
<*********************************>
<* *>
<**> release_no := 13.0; <**>
<* *>
<*********************************>
systime (1, 0 , time);
dmy :=
systime (2, time, hms );
getzone6 (ztape, zdescr); <*get bufferlength*>
outrec6 (ztape, 100 ); <*make a record of 100 hw ready*>
open (zconv, 0, <:1:>, 0); <*will give dummy answer*>
write (zconv,
true, 6, <:dump:>,
true, 12, tapename, <<zdd>,
true, 6, fileno ,
true, 6, type ,
<<zddddd>, dmy, ".", 1, <<zd>,
true, 5, round (hms)//10000,
<:s=:>, <<d>,
true, 4, segm ,
true, 12, lab, <*12 chars*>
<:release :>, <<dd.d>, release_no, <*12 chars*>
"nl", 1, "nul", 4, "em", 1); <*14 reals = 56 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 ::>, "nl", 1, ztape.laf); <*display on out*>
out___rec6 (ztape, 4 * zdescr (20) // zdescr (18)); <*change block*>
changerec6 (ztape, 0 ); <*new rec prep*>
end out_labelrec;
\f
<* sw8010/1, save tape handling procedures page ... 92...
1982.01.19 *>
message changerec continuerec page 1;
procedure changerec_continuerec (z, entries, segments, name);
value entries, segments ;
zone z ;
integer entries, segments ;
long array name ;
<*********************************************************>
<* *>
<* The procedure makes a zone record of 100 hwds avail- *>
<* able in the zone buffer of z, ensuring no block change*>
<* takes place, and fills it with a continue record. *>
<* The values of the fields in the record are displayed *>
<* on current output. *>
<* *>
<* Call : outrec_continuerec (z, entries, segments, name)*>
<* *>
<* z (call and return value, zone). The name, buf-*>
<* fering and position of the document. *>
<* The zone state at call time must be open and *>
<* ready for record output, at return it is af- *>
<* ter record output. *>
<* entries (call value, integer). The values of entry *>
<* segments (call value, integer). and segment counters *>
<* to be written in the record. *>
<* name (call value, long array). The name of the *>
<* continue tape in name (1:2) to be written *>
<* in the record. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, save tape handling procedures page ... 93...
1983.02.09 *>
message changerec continuerec page 2;
begin
integer i;
integer array zdescr (1:20);
long array field procname;
procname := 2; <*fields procname in zdescr*>
changerec6 (z, 100); <*no block change*>
for i := 1, 5 step 1 until 25 do
z (i) := real (extend 4 shift 24 + 16);
z (2) := real (extend entries shift 24 + segments); <*ent, segm*>
for i := 1, 2 do
z (i + 2) := real name (i); <*tape name*>
getzone6 (z, zdescr);
write (out, "nl", 2,
true, 12, zdescr.procname, <:exhausted:>, "nl", 2,
<<ddddddd>,
true, 12, <:entry count:>, entries, "nl", 1,
true, 12, <:segm count:>, segments, "nl", 2,
true, 12, name, <:continues:>, "ff", 1);
end changerec_continuerec;
\f
<* sw8010/1, save tape handling procedures page ... 94...
1982.01.22 *>
message outrec endrec page 1;
procedure outrec_endrec (za, i, copies, entries, segments);
value copies, entries, segments ;
zone array za ;
integer i, copies, entries, segments ;
<*********************************************************>
<* *>
<* The procedure makes a record of 100 hwds available in *>
<* the common zone buffer of the zones in the zone array *>
<* za, ensuring that a blockchange takes place in each *>
<* zone, and fills the record with with an end record. *>
<* *>
<* Call : *>
<* outrec_endrec (za, i, copies, entries, segments); *>
<* *>
<* za (call and return value, zone array ). *>
<* A blockchange takes place in the zones *>
<* za (1:copies). *>
<* i (call and return value, integer). The *>
<* index in the zone array. To cooperate *>
<* with the block procedure next_volume, *>
<* actual parameter must be copy_count. *>
<* copies (call value, integer). Upper index of *>
<* the zone array. To cooperate with the *>
<* block procedure next_volume, actual pa- *>
<* rameter must be no_of_copies. *>
<* entries (call value, integer). The values of en-*>
<* segments (call value, integer). tries and seg- *>
<* ments written in the record *>
<* *>
<*********************************************************>
begin
integer j;
integer array zdescr (1:20);
getzone6 (za (1), zdescr); <*get common buffer descr*>
for i := 1 step 1 until copies do
begin <*ensure blockchange*>
out___rec6 (za (i), 4 * zdescr (20) // zdescr (18)); <*leng//sh*>
changerec6 (za (i), 100); <*blockchange, record available*>
end <*ensure blockchange*>;
for j := 1, 3 step 1 until 25 do
za (1, j) := real (extend 3 shift 24 + 8); <*kind, length*>
za (1, 2):= real (extend entries shift 24 + segments);
end outrec_endrec;
\f
<* sw8010/1, save tape handling procedures page ... 95...
1982.01.25 *>
message outrec entryrec page 1;
procedure outrec_entryrec (za, i, copies, entry , scope , newscope ,
actual_scope , discno, entries, segments);
value copies, scope , newscope ,
actual_scope , discno, segments ;
zone array za ;
integer array entry ;
integer i, copies, scope , newscope ,
actual_scope , discno, entries, segments ;
<*********************************************************>
<* *>
<* The procedure makes a record of 100 hwds available in *>
<* the common zone buffer of the zones in the zone array *>
<* za (1:copies), ensuring that a block change takes pla-*>
<* ce in each zone, and fills the record with an entry *>
<* record, increasing the entry count by one. *>
<* *>
<* Call : outrec_entryrec (za, i, copies, entry, scope, *>
<* newscope, actual_scope, *>
<* discno , entries, segments); *>
<* *>
<* za (call and return value, zone array). *>
<* The name, buffering and position of the *>
<* documents. AT call the zones must be in *>
<* states after open on magtape or after *>
<* record output, at return they will be *>
<* in the state after record output. *>
<* i (call and return value, integer). Used *>
<* as index in the zone array za. To co- *>
<* operate with the block procedure next_ *>
<* volume, actual parameter must be copy_ *>
<* count. *>
<* copies (call value, integer). Upper index of *>
<* the zone array. *>
<* entry (call value, integer array). An entry *>
<* head and tail in entry (1:17). *>
<* scope (call value, integer). If scope = 1 or *>
<* scope = 2 (all, perm) the namekey else *>
<* newscope (call value, integer). if newscope <> 0 *>
<* and newscope <> actual scope then new_ *>
<* scope else *>
<* actual_scope (call value, integer). actual scope is *>
<* written in the record. *>
<* discname (call value, integer). The discname *>
<* packed in newdiscname (discno,1:2) is *>
<* written in the record. *>
<* the record. *>
<* entries (call and return value, integer). The *>
<* entry count is increased by one when *>
<* the record is available and written in *>
<* the record. *>
<* segments (call value, integer). The segment *>
<* count is written in the record. *>
<* *>
<********************************************************>
\f
<* sw8010/1, save tape handling procedures page ... 96...
1982.01.25 *>
message outrec entryrec page 2;
begin
integer j;
integer array zdescr (1:20);
real array field ztail, etail, ename, disc;
z_tail := 16; <*fields entry tail in zone *>
e_tail := 14; <*fields entry tail in entry*>
e_name := 6; <*fields entry name in entry*>
disc := 8 * discno; <*fields the discname in newdiscname*>
getzone6 (za (1), zdescr); <*get buffer and no of shares*>
for i := 1 step 1 until copies do
begin <*provoke blockchange*>
out___rec6 (za (i), 4 * zdescr (20) // zdescr (18)); <*buf//sh*>
changerec6 (za (i), 100); <*make 100 hwds available*>
end <*provoke blockchange*>;
for j := 1, 14 step 1 until 25 do
za (1, j) := real ( extend 1 shift 24 + (
if scope = 1 <*all *>
or scope = 2 <*perm*> then
52
else
48)); <*kind, length*>
entries := entries + 1; <*entry count increased by one when rec ready*>
za (1, 2) := real (extend entries shift 24 + segments); <*ent, seg*>
for j := 3, 4 do
za (1, j) := entry.e_name (j - 2); <*entry name*>
to_from (za (1).z_tail, entry.e_tail, 20); <*entry tail*>
za (1, 10) :=
if scope = 1 <*all *>
or scope = 2 <*perm*> then entry (1) extract 3 <*permkey*> else
if newscope <> 0 and
newscope <> actual_scope then newscope <*scopekey*> else
actual_scope; <*permkey or scopekey converted to real*>
for j := 11, 12 do
za (1, j) := newdiscname.disc (j - 10); <*new disc name*>
za (1, 13) := real (
if scope = 1 <*all *>
or scope = 2 <*perm*> then
extend entry (2) shift 24 + entry (3) <*base*>
else
extend 1 shift 24 + 48 ); <*kind, length*>
end outrec_entryrec;
\f
<* sw8010/1, save tape handling procedures page ... 97...
1982.01.25 *>
message outrec segmentrec page 1;
procedure outrec_segmentrec (za, i, copies, discz, entries, segments);
value copies, entries ;
zone array za ;
zone discz ;
integer i, copies, entries, segments ;
<*********************************************************>
<* *>
<* The procedure makes a record of maximal length avail- *>
<* able for output in the common zone buffer area of the *>
<* zones za (1:copies), thereby creating a block change *>
<* in each zone, and fills the record with a segment re- *>
<* cord. *>
<* The data of the segment field of the record are trans-*>
<* ferred from the zone record of the zone discz. *>
<* The segment count is increased by the number of seg- *>
<* ments thus transferred and the new value is written *>
<* the record. *>
<* *>
<* Call : outrec_segmentrec (za, i, copies, discz, *>
<* entries, segments); *>
<* *>
<* za (call and return value, zone array). The do-*>
<* cument, buffering and position of the docu- *>
<* ments. The zones za (1:copies) are supposed *>
<* to share the same buffer area. *>
<* i (call value, integer). Used as index in za *>
<* (1:copies). To cooperate with the block pro-*>
<* cedure next_volume, actual parameter has to *>
<* be copy_count. *>
<* copies (call value, integer). See za. *>
<* discz (call value, zone). The zone record present *>
<* in the buffer area of discz is transferred *>
<* the common buffer area of the zones za (1: *>
<* copies) after the record has been made a- *>
<* vailable. *>
<* entries (call value, integer). The entry count *>
<* written in the record. *>
<* segments (call and return value, integer). The seg- *>
<* ment count is increased by the number of *>
<* segments ready in the zone record of discz *>
<* when the record in za is available and the *>
<* new value is written in the record. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, save tape handling procedures page ... 98...
1982.01.25 *>
message outrec segmentrec page 2;
begin
integer j, t_buflength, d_reclength;
integer array zdescr (1:20);
real array field t_rec, d_rec;
t_rec := 8; <*fields segment record in za (1)*>
d_rec := 0; <*fields segment reccord in discz*>
getzone6 (za (1), zdescr); <*get common buflength and shares*>
t_buflength := 4 * zdescr (20) // zdescr (18); <*length//shares*>
getzone6 (discz, zdescr); <*get recordlength*>
d_reclength := zdescr (16);
for i := 1 step 1 until copies do
begin
out___rec6 (za (i), tbuflength ); <*change block *>
changerec6 (za (i), dreclength + 8); <*rec available*>
end;
za (1, 1) := real (extend 2 shift 24 + dreclength + 8); <*kind, lengt*>
za (1, 2) := real (extend entries shift 24 + segments ); <*ent, seg*>
<*segment count is segment no of first segment in record*>
segments := segments + dreclength // 512; <*segment count increased*>
to_from (za (1).t_rec, discz.d_rec, d_reclength); <*transfer*>
end outrec_segmentrec;
\f
<* sw8010/1, save tape handling procedures page ... 99...
1982.12.30 *>
message next volume page 1;
procedure next_volume (z, status, hwds);
zone z ;
integer status, hwds ;
<*********************************************************>
<* *>
<* The procedure acts as block procedure for the magne- *>
<* tic tape in- and output zones, and supposes that the *>
<* end of document bit (1<18) is the only bit in the gi- *>
<* ve up mask of the zones, so that all other errors ex- *>
<* cept hard ones are treated by the standard recovery *>
<* actions before this procedure is entered. *>
<* The procedure gives up for all other call reasons *>
<* than end of document. *>
<* *>
<* Output : *>
<* *>
<* If another volume is specified, an end record is pre- *>
<* pared in the zone, which is terminated. During the *>
<* checking of the pending transfers the block procedure *>
<* will be called again, but the end of document condi- *>
<* tion will be ignored. *>
<* The next volume is prepared (opened, positioned a la- *>
<* bel record prepared in the zone). *>
<* Before exit, it is secured that the checking of the *>
<* label record and the succeding transfers will not ig- *>
<* nore end of document. *>
<* *>
<* Input : *>
<* *>
<* If another volume is specified, the zone is termina- *>
<* ted, i.e. pending transfers are not checked. *>
<* The next volume is prepared (opened and positioned), *>
<* leaving it up to the record input procedures to re- *>
<* peat the input. *>
<* *>
<* Both : *>
<* *>
<* If no more volumes are specified, the procedure gi- *>
<* ves up (end of document). *>
<* *>
<* Call : called by check. *>
<* *>
<*********************************************************>
\f
<* sw8010/1, save tape handling procedures page ...100...
1983.02.08 *>
message next volume page 2;
begin
integer operation;
integer array zdescr (1:20), sdescr (1:12);
long array field curr_tape;
own
boolean ignore_endtape_1, ignore_endtape_2;
if status extract 1 = 1 <*hard error*> then
stderror (z, status, hwds); <*give up*>
getzone_6 (z, zdescr ); <*get operation*>
getshare6 (z, sdescr, zdescr (17)); <*in used share*>
operation := sdescr (4) shift (-12) extract 12; <*3 : in, 5 : out*>
if operation = 3 <*in put*>
or operation = 5 <*output*> and
(case copy_count of (-,ignore_endtape_1, -,ignore_endtape_2)) then
begin <*either input or not during tape shift in output*>
file_no (copy_count) := 1; <*file no 1*>
increase (vol_count (copy_count)); <*next volume*>
if vol_count (copy_count) > no_of_vol (copy_count) then
stderror (z, status, hwds); <*no more volumes, give up*>
curr_tape := name_field (copy_count, vol_count); <*name*>
if operation = 5 then
begin <*output, changerec continue rec*>
case copy_count of
begin
ignore_endtape_1 := true; <*ignore end of tape condition *>
ignore_endtape_2 := true; <* - do - *>
end;
changerec_continuerec (z, total_entrycount, total_segmcount,
tapename.curr_tape);
<*cont rec and all pending will be checked disregarding eot*>
end <*output*>;
\f
<* sw8010/1, save tape handling procedures page ...101...
1983.02.08 *>
message next volume page 3;
fpproc (33 )outend :( 0, out, 'nul');
<*outend on current out before release message to parent*>
<*if parent is s the output would be mixed with message *>
close (z, false add 1); <*release*>
open_tape (z, deviceno (copy_count), modekind (copy_count),
tapename.curr_tape );
setposition (z, fileno (copy_count), 0); <*file no 1*>
<*for input the operation will be repeated in rec input procs*>
if operation = 5 then
begin <*output a cont. dump label record*>
label_name := copy_count * 8; <*fields labelname in dumplabel*>
out_labelrec (z, tapename.curr_tape, fileno (copy_count),
<:cont.:>, segm, dumplabel.labelname);
case copy_count of
begin
ignore_endtape_1 := false; <*dont ignore*>
ignore_endtape_2 := false;
end;
end <*output*>;
status := hwds := 0; <*repeat*>
end <*either input or not during tape shift in output*>;
end next_volume;
\f
<* sw8010/1, 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 acts as a block procedure for the disc *>
<* area input zone and supposes that all call reasons *>
<* are give up reasons. *>
<* 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/1, 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/1, save program page ...104...
1983.10.28 *>
message program page 2;
<*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 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*>
<*initialize entry and segment counters*>
total_entry_count := total_segm_count := 0;
for i := 1 step 1 until no_of_discs do
entry_count (i) :=
slice_count (i) := 0;
<*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 *>
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*>
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/1, save program page ...105...
1981.12.15 *>
message program page 3;
<*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*>
mode_kind (copy_count) := 1 shift 23 + 2 shift 12 + 18; <*mte*>
mode_kind (copy_count) := 1 shift 23 + 4 shift 12 + 18; <*nrz*>
mode_kind (copy_count) := 1 shift 23 + 6 shift 12 + 18; <*nrze*>
end case action ;
seplength := scan_param (item);
end <*while action > 0*> ;
\f
<* sw8010/1, save program page ...106...
1982.12.28 *>
message program page 4;
<*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
(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/1, save program page ...107...
1981.12.15 *>
message program page 5;
end <* <s><tapename>.<fileno> or <s><tapename>.last *> else
<* old_length <> space_txt or old_item (1) = real <:segm:> 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 oldlength <> 0 <*zero param*> and
(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 ;
\f
<* sw8010/1, save program page ...108...
1983.02.09 *>
message program page 6;
<*maybe special parameter*>
<*initialize special param variables*>
list_entries := reserve_area := true;
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) > 0 and
entry (14) < 10 then entry (14) else 1; <*word 7 in tail if pos*>
progbase_lower := entry (2);
progbase_upper := entry (3);
end <*special block*>;
<*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
<*segm*>
segm := round item (1);
<*list*>
if item (1) <> real <:name:> and
item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning list param unknown:>)
else
if item (1) = real <:name:> then
list_entries := list_only_name := true
else
begin
list_entries := item (1) = real <:yes:>;
list_only_name := false ;
end;
<*reserve*>
if item (1) <> real <:yes:> and
item (1) <> real <:no:> then
param_warning (out, <:warning reserve param unknown:>)
else
reserve_area := item (1) = real <:yes:>;
end case action;
seplength := scan_param (item);
end <* space_txt and special param*> ;
\f
<* sw8010/1, save declarations third block page ...109...
1982.01.27 *>
message declare zones page 1;
reservecore := 26000; <*hwds core to reserve for paging in inner loop*>
begin <*declarations of disc and tape zones, third block level*>
zone zdisc (
discbuflength (reservecore, segm, tapebuflength, tapebuffers),
1,
give_up);
zone array ztape (
no_of_copies,
tapebuflength // no_of_copies + no_of_copies - 1,
tapebuffers,
next_volume);
<*if no_of_copies = 2 the entire zone buffer is*>
<*tapebuflength + 2 in excess *>
\f
<* sw8010/1, save prepare tape zones page ...110...
1982.01.26 *>
message prepare tapes 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 tape_param_ok then
begin <*maybe search file numbers, share the buffer, open and pos*>
get_filenos (ztape, copy_count, no_of_copies, vol_count, no_of_vol,
tapename , device_no , modekind , fileno );
if no_of_copies = 2 then
share_buffer_area (ztape);
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), 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);
end <*version dump label*>;
end <*maybe search*>;
\f
<* sw8010/1, save program page ...111...
1981.12.15 *>
message program page 7;
<*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/1, save program page ...112...
1981.12.15 *>
message program page 8;
<*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_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 <: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/1, save program page ...113...
1981.12.15 *>
message program page 9;
<*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/1, save program page ...114...
1981.12.15 *>
message program page 10;
<*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/1, save program page ...115...
1982.03.24 *>
message program page 11;
<*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/1, save program page ...116...
1982.12.28 *>
message program page 12;
<*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;
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*>
if save_entries (ztape, copy_count, no_of_copies, zdisc ,
name , scope , newscope , docname) = 0 then
begin <*no entries found*>
list_specifiers (out,
write_alarm ( out, <:no entries found/saved:>),
no_of_discs, disc_specified, discname, name, scope, docname);
errorbits := 2; <*warning.yes, alarm.no*>
end;
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/1, save program page ...117...
1982.12.28 *>
message program page 13;
<*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*>
if save_entries (ztape, copy_count, no_of_copies, zdisc ,
name , scope , newscope , docname) = 0 then
begin <*no entries found*>
list_specifiers (out,
write_alarm (out, <:no entries found/saved:>),
no_of_discs, disc_specified, discname, name, scope, docname);
errorbits := 2; <*warning.yes, alarm.no*>
end;
end;
\f
<* sw8010/1, save end third block page ...118...
1982.01.27 *>
message end third block page 1;
if tapeparam_ok then
begin <*finish tapes*>
outrec_endrec (ztape, copy_count, no_of_copies,
total_entrycount, total_segmcount);
for copy_count := 1 step 1 until no_of_copies do
begin <*next file*>
close (ztape (copy_count), false); <*no release*>
current_tape := namefield (copy_count, volcount);
<*the blockprocedure might have changed to next volume*>
increase (fileno (copy_count));
open_tape ( ztape (copy_count), device_no (copy_count),
modekind (copy_count), tapename.current_tape);
setposition (ztape (copy_count), fileno (copy_count), 0);
end <*next file*>;
for copy_count := 1 step 1 until no_of_copies do
begin <*empty label record*>
current_tape := name_field (copy_count, vol_count);
label_name := copy_count * 8; <*fields labelname in dumplabel*>
out_labelrec ( ztape (copy_count), tapename.current_tape,
fileno (copy_count), <:empty:>, segm, dumplabel.labelname);
fpproc (33 )out end:( 0, out, 'nul');
<*outend on current out before possible release message*>
<*if parent is s output would be mixed with message *>
close (ztape (copy_count),
if release (copy_count) then false add 1 else false); <*maybe rel*>
end <*empty label record*>;
end <*finish tapes*>;
end <*declarations of disc and tape zones, third block level*>;
\f
<* sw8010/1, save program page ...119...
1982.02.15 *>
message program page 13;
<*write save statistics*>
list_______counters (out, entry_count, slice_count);
list_total_counters (out, total_entry_count, total_segm_count);
\f
<*sw8010/1, save program tail page ...120...
1981.12.14 *>
message program tail page 1;
if chain_name (1) <> real <::> then
unstack_current_output;
end <*second level*>;
slutlabel:
end;
▶EOF◀