1
2
3
4
5
6
7
8
9
10
11
12 compare_mst: proc;
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40 %page;
41 dcl REWP char (64) static aligned options(constant)
42 initial ("NULL P W WP E E P EW EWPR R PR W R WPRE RE PERW REWP");
43 dcl OFF_ON char (8) static aligned options(constant) initial ("OFF ON ");
44 dcl (UNSET init(0),
45 MASTER init(1),
46 COPY init(2)) fixed bin int static options(constant);
47 dcl abs_changes fixed bin int static options(constant) init (45);
48 dcl mst_name (2) char (19) varying int static options(constant)
49 initial ("compare_mst.master.", "compare_mst.copy.");
50 dcl rew char (24) static aligned options(constant) initial ("n w e ewr r wre rew");
51
52 dcl arg char(argl) based(argp),
53 opt char(optl) based(optp);
54
55 dcl bits (bit_len) bit (1) unaligned based (bits_ptr);
56
57 dcl 1 bootstrap_header aligned based,
58 2 header_control_word like mst1.header_control_word aligned,
59 2 slte like slte aligned,
60 2 minus_ones (18) fixed bin (35),
61 2 segment_control_word like mst1.segment_control_word aligned;
62
63 dcl 1 collection_mark_data based,
64 2 pad bit (36),
65 2 major fixed bin (18) uns unal,
66 2 minor fixed bin (18) uns unal;
67
68 dcl header_words (bit_len) based fixed bin;
69
70 dcl 1 mst1 aligned based (mst_ptr (1)),
71 2 header aligned,
72 3 header_control_word aligned,
73 4 collection_mark bit (18) unaligned,
74 4 header_length fixed bin (17) unaligned,
75
76 3 slte like slte aligned,
77
78 3 names_array aligned,
79 4 n_names fixed bin aligned,
80 4 name_element (n_names (1)) aligned,
81 5 n_chars fixed bin aligned,
82 5 name char (32) aligned,
83
84 3 pathname_array (has_branch (1)) aligned,
85 4 pathname_length fixed bin aligned,
86 4 pathname char (path_length (1)) aligned,
87
88 3 acl_structure (has_acl (1)) aligned,
89 4 n_acls fixed bin,
90 4 acl (n_acls (1)) aligned,
91 5 accessname char (32) aligned,
92 5 mode bit (3) aligned,
93 5 pad (2) fixed bin,
94
95 3 segment_control_word aligned,
96 4 ident fixed bin (17) unaligned,
97 4 segment_length fixed bin (17) unaligned;
98
99
100 dcl 1 mst2 based (mst_ptr (2)) aligned,
101 2 header aligned,
102 3 header_control_word aligned,
103 4 collection_mark bit (18) unaligned,
104 4 header_length fixed bin (17) unaligned,
105
106 3 slte like slte aligned,
107
108 3 names_array aligned,
109 4 n_names fixed bin aligned,
110 4 name_element (n_names (2)) aligned,
111 5 n_chars fixed bin aligned,
112 5 name char (32) aligned,
113
114 3 pathname_array (has_branch (2)) aligned,
115 4 pathname_length fixed bin aligned,
116 4 pathname char (path_length (2)) aligned,
117
118 3 acl_structure (has_acl (2)) aligned,
119 4 n_acls fixed bin,
120 4 acl (n_acls (2)) aligned,
121 5 accessname char (32) aligned,
122 5 mode bit (3) aligned,
123 5 pad (2) fixed bin,
124
125 3 segment_control_word aligned,
126 4 ident fixed bin (17) unaligned,
127 4 segment_length fixed bin (17) unaligned;
128
129 dcl segment_1 (seg_length (1)) based fixed bin;
130 dcl segment_2 (seg_length (2)) based fixed bin;
131
132 dcl sys_id_pickup char (8) aligned based;
133
134 dcl 1 tp_name based aligned,
135 2 order_info,
136 3 name char (32),
137 3 org_index fixed bin,
138 3 major_collection fixed bin,
139 3 minor_collection fixed bin,
140 3 sw unaligned,
141 4 col bit (1),
142 4 add bit (1),
143 4 del bit (1),
144 4 mov bit (1),
145 2 info_ptr ptr,
146 2 head_ptr ptr,
147 2 move_index fixed bin,
148 2 pos_n fixed bin;
149
150 dcl 1 tp1_names (name_count (1)) based (np (1)) aligned like tp_name;
151 dcl 1 tp2_names (name_count (2)) based (np (2)) aligned like tp_name;
152
153 dcl argl fixed bin(21);
154 dcl anp (2) ptr;
155 dcl argp pointer;
156 dcl arg_count fixed bin;
157 dcl argx fixed bin;
158 dcl atd char(256);
159 dcl bit_len fixed bin;
160 dcl bits_ptr pointer;
161 dcl boot_label (2) bit(1) aligned;
162 dcl boot_ptr (2) ptr;
163 dcl bootstrap_sw (2) bit (1) aligned;
164 dcl 1 bpi (2) aligned like boot_program_info;
165 dcl code fixed bin (35);
166 dcl collection bit (1) aligned;
167 dcl copy_ptr ptr;
168 dcl has_acl dimension (2) fixed bin;
169 dcl has_branch dimension (2) fixed bin;
170 dcl have_sysid bit (1) aligned;
171 dcl i fixed bin;
172 dcl in_den (2) fixed bin;
173 dcl in_file_name (2) char(168);
174 dcl in_tape_name (2) char(32);
175 dcl iocb_ptr (2) ptr;
176 dcl j fixed bin;
177 dcl k fixed bin;
178 dcl l1_index fixed bin;
179 dcl l2_index fixed bin;
180 dcl master_copy fixed bin;
181 dcl mst_ptr (2) pointer;
182 dcl mst_ptr_hold (2) ptr;
183 dcl n_acls dimension (2) fixed bin;
184 dcl n_names dimension (2) fixed bin;
185 dcl name_count (2) fixed bin;
186 dcl name_len fixed bin(18) uns unal;
187 dcl nelemt fixed bin (21);
188 dcl np (2) ptr;
189 dcl optl fixed bin(21);
190 dcl optp ptr;
191 dcl path_length dimension (2) fixed bin;
192 dcl saving bit (1);
193 dcl sci_ptr ptr;
194 dcl seg_len fixed bin(18) uns unal;
195 dcl seg_length (2) fixed bin;
196 dcl segment_name char (32);
197 dcl set fixed bin;
198 dcl skip_1 bit (1) aligned;
199 dcl sys_id (2) char (8) aligned;
200
201 dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35));
202 dcl com_err_ entry options (variable);
203 dcl cu_$arg_list_ptr entry returns(ptr);
204 dcl get_shortest_path_ entry (char(*)) returns(char(168));
205 dcl get_wdir_ entry returns (char (168));
206 dcl initiate_file_$create entry (char(*), char(*), bit(*), ptr, bit(1) aligned, fixed bin(24),
207 fixed bin(35));
208 dcl ioa_ entry options (variable);
209 dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
210 dcl iox_$close entry (ptr, fixed bin (35));
211 dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35));
212 dcl iox_$detach_iocb entry (ptr, fixed bin (35));
213 dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
214 dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
215 dcl parse_tape_reel_name_ entry (char(*), char(*));
216 dcl ssu_$abort_subsystem entry() options(variable);
217 dcl ssu_$arg_count entry (ptr, fixed bin);
218 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
219 dcl ssu_$destroy_invocation
220 entry (ptr);
221 dcl ssu_$get_temp_segment entry (ptr, char(*), ptr);
222 dcl ssu_$standalone_invocation
223 entry (ptr, char(*), char(*), ptr, entry, fixed bin(35));
224 dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
225 dcl unique_chars_ entry (bit(*)) returns(char(15));
226
227
228 dcl compare_mst_severity_ fixed bin ext static init(0);
229
230 dcl (error_table_$bad_arg,
231 error_table_$badopt,
232 error_table_$end_of_info,
233 error_table_$inconsistent,
234 error_table_$noarg)
235 fixed bin (35) external static;
236
237 dcl (abs, addr, binary, char, convert, divide, index, length,
238 ltrim, max, null, ptr, reverse, rtrim, size, string, substr)
239 builtin;
240
241 dcl cleanup condition;
242 %page;
243 compare_mst_severity_ = 4;
244 bits_ptr = null ();
245 boot_ptr = null ();
246 iocb_ptr = null ();
247 mst_ptr_hold = null ();
248 np = null ();
249 sci_ptr = null();
250 on cleanup call clean_up;
251
252 call ssu_$standalone_invocation (sci_ptr, "compare_mst", "1.0",
253 cu_$arg_list_ptr(), exit_proc, code);
254 if code ^= 0 then call com_err_ ("compare_mst", code, "Creating standalone ssu_ subsystem.");
255
256 bootstrap_sw = "0"b;
257 have_sysid = "0"b;
258 saving = "0"b;
259
260 call ssu_$arg_count (sci_ptr, arg_count);
261
262 in_file_name, in_tape_name = "";
263 in_den = UNSET;
264 master_copy = UNSET;
265
266 do argx = 1 to arg_count;
267 call ssu_$arg_ptr (sci_ptr, argx, argp, argl);
268 if index (arg, "-") = 1 then do;
269 if arg = "-save" then
270 saving = "1"b;
271 else if arg = "-master_volume" | arg = "-mvol" then do;
272 master_copy = MASTER;
273 SETTAPE: in_tape_name(master_copy), in_file_name(master_copy) = "";
274 if argx = arg_count then
275 call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
276 "^a must be followed by a tape volume name.", arg);
277 else do;
278 argx = argx + 1;
279 call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
280 in_tape_name(master_copy) = opt;
281 end;
282 end;
283 else if arg = "-master_file" | arg = "-mf" then do;
284 master_copy = MASTER;
285 SETFILE: in_tape_name(master_copy), in_file_name(master_copy) = "";
286 if argx = arg_count then
287 call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
288 "^a must be followed by a file name.", arg);
289 else do;
290 argx = argx + 1;
291 call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
292 in_file_name(master_copy) = opt;
293 end;
294 master_copy = UNSET;
295 end;
296 else if (arg = "-copy_volume" | arg = "-cvol") then do;
297 master_copy = COPY;
298 go to SETTAPE;
299 end;
300 else if (arg = "-copy_file" | arg = "-cf") then do;
301 master_copy = COPY;
302 go to SETFILE;
303 end;
304 else if arg = "-density" | arg = "-den" then do;
305 if argx = arg_count then
306 call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
307 "^a must be followed by a tape density.", arg);
308 else do;
309 argx = argx + 1;
310 call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
311 if opt = "800" | opt = "1600" | opt = "6250" then do;
312 if master_copy = UNSET then
313 call ssu_$abort_subsystem (sci_ptr,
314 error_table_$inconsistent,
315 "^a ^a must follow either -mvol or -cvol.", arg,
316 opt);
317 else
318 in_den(master_copy) = convert(in_den(1), opt);
319 end;
320 else
321 call ssu_$abort_subsystem (sci_ptr,
322 error_table_$bad_arg,
323 "^a ^a^/Allowed densities are: 800, 1600, 6250.",
324 arg, opt);
325 end;
326 end;
327 else
328 call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, arg);
329 end;
330 else if in_tape_name(MASTER) = "" & in_file_name(MASTER) = "" then
331 in_tape_name(MASTER) = arg;
332 else if in_tape_name(COPY) = "" & in_file_name(COPY) = "" then
333 in_tape_name(COPY) = arg;
334 else
335 call ssu_$abort_subsystem (sci_ptr, error_table_$bad_arg, arg);
336 end;
337
338 do i = MASTER to COPY;
339 if in_tape_name(i) = "" & in_file_name(i) = "" then
340 call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
341 "^/A ^[master^;copy^] tape or file must be specified via -^[m^;c^]vol or -^[m^;c^]f.",
342 i, i, i);
343 end;
344
345 do i = MASTER to COPY;
346 call ssu_$get_temp_segment (sci_ptr, "boot pgm", boot_ptr(i));
347 call ssu_$get_temp_segment (sci_ptr, "buffer", mst_ptr_hold(i));
348 call ssu_$get_temp_segment (sci_ptr, "tape names", np(i));
349 call get_in_medium (i);
350 end;
351 mst_ptr = mst_ptr_hold;
352 call ssu_$get_temp_segment (sci_ptr, "bit seg", bits_ptr);
353 compare_mst_severity_ = 0;
354 %page;
355 call ioa_ ("^/Begin comparison.");
356
357 if boot_label(MASTER) ^= boot_label(COPY) then do;
358 call ioa_ (
359 "^/^[Master^;Copy^] MST has a bootload label program, while ^[Master^;Copy^] MST does not.",
360 boot_label(MASTER), boot_label(COPY));
361 compare_mst_severity_ = max(compare_mst_severity_, 3);
362 end;
363 else if boot_label(MASTER) then do;
364 if bpi(MASTER).boot_program_name ^= bpi(COPY).boot_program_name then do;
365 call ioa_ ("Boot program names disagree.
366 Master: ^a
367 Copy: ^a", bpi(MASTER).boot_program_name, bpi(COPY).boot_program_name);
368 compare_mst_severity_ = max(compare_mst_severity_, 3);
369 end;
370 else if bpi(MASTER).boot_program_text_length ^=
371 bpi(COPY).boot_program_text_length then do;
372 call ioa_ ("Boot program lengths disagree.
373 Master: ^d
374 Copy: ^d", bpi(MASTER).boot_program_text_length,
375 bpi(COPY).boot_program_text_length);
376 compare_mst_severity_ = max(compare_mst_severity_, 3);
377 end;
378 else do;
379 seg_length(MASTER) = bpi(MASTER).boot_program_text_length;
380 seg_length(COPY) = bpi(COPY).boot_program_text_length;
381 mst_ptr = bpi.boot_program_ptr;
382 segment_name = "bootload label program";
383 call check_segments();
384 mst_ptr = mst_ptr_hold;
385 end;
386 end;
387 %page;
388
389 call read_tape (MASTER);
390
391
392 call rewind_in_medium (MASTER);
393
394 call read_tape (COPY);
395
396 if have_sysid then call ioa_ ("System ^a to ^a", sys_id (MASTER), sys_id (COPY));
397
398
399 call rewind_in_medium (COPY);
400
401 call sort_names (MASTER);
402 call sort_names (COPY);
403 call list_comp;
404
405 bootstrap_sw = "0"b;
406 l1_index, l2_index = 1;
407 skip_1 = "0"b;
408 %page;
409
410
411 do while ((l1_index ^> name_count (MASTER)) & (l2_index ^> name_count (COPY)));
412 j = tp2_names (l2_index).pos_n;
413 if skip_1 then do;
414 skip_1 = "0"b;
415 goto try_2;
416 end;
417 i = tp1_names (l1_index).pos_n;
418
419
420 call read_header (MASTER, collection);
421 if collection then
422 if ^tp1_names (i).sw.col then do;
423 out_of_sync: compare_mst_severity_ = max(compare_mst_severity_, 3);
424 call ssu_$abort_subsystem (sci_ptr, 0,
425 "tape out of sync.");
426 end;
427 else do;
428 if tp1_names (i).sw.del then do;
429 call ioa_ ("^a mark deleted.", tp1_names (i).name);
430 compare_mst_severity_ = max(compare_mst_severity_, 3);
431 end;
432 l1_index = l1_index + 1;
433 goto loop_cont;
434 end;
435 else if segment_name ^= tp1_names (i).name then goto out_of_sync;
436
437
438 if tp1_names (i).sw.del then do;
439 call ioa_ ("^a deleted", segment_name);
440 compare_mst_severity_ = max(compare_mst_severity_, 3);
441 call skip_block (MASTER);
442 l1_index = l1_index + 1;
443 goto loop_cont;
444 end;
445
446
447 if tp1_names (i).sw.mov then if tp1_names (i).move_index ^= 0 then do;
448
449 set = tp1_names (i).move_index;
450 mst_ptr (COPY) = tp2_names (set).head_ptr;
451 call header_setup_2;
452 call check_headers;
453 call read_segment (MASTER);
454 mst_ptr (COPY) = tp2_names (set).info_ptr;
455 call check_segments;
456 mst_ptr (COPY) = mst_ptr_hold (COPY);
457 l1_index = l1_index + 1;
458 goto loop_cont;
459 end;
460 else do;
461 call ioa_ ("^a moved down.", segment_name);
462 compare_mst_severity_ = max(compare_mst_severity_, 3);
463 call ssu_$get_temp_segment (sci_ptr,
464 "header", tp1_names(i).head_ptr);
465 bit_len = mst1.header_length + 2;
466 tp1_names (i).head_ptr -> header_words = mst_ptr (MASTER) -> header_words;
467 call ssu_$get_temp_segment (sci_ptr,
468 "info", tp1_names(i).info_ptr);
469 mst_ptr (MASTER) = tp1_names (i).info_ptr;
470 call read_segment (MASTER);
471 mst_ptr (MASTER) = mst_ptr_hold (MASTER);
472 l1_index = l1_index + 1;
473 goto loop_cont;
474 end;
475
476 try_2:
477 call read_header (COPY, collection);
478 if collection then
479 if ^tp2_names (j).sw.col then goto out_of_sync;
480 else do;
481 if tp2_names (j).sw.add then do;
482 call ioa_ ("^a mark added.", tp2_names (j).name);
483 compare_mst_severity_ = max(compare_mst_severity_, 3);
484 end;
485 l2_index = l2_index + 1;
486 skip_1 = "1"b;
487 goto loop_cont;
488 end;
489 else if segment_name ^= tp2_names (j).name then goto out_of_sync;
490
491
492 if tp2_names (j).sw.add then do;
493 call ioa_ ("^a added.", segment_name);
494 compare_mst_severity_ = max(compare_mst_severity_, 3);
495 if saving then do;
496 call initiate_file_$create (get_wdir_(),
497 "tp2." || segment_name, RW_ACCESS,
498 tp2_names (j).info_ptr, "0"b, 0, code);
499 if tp2_names (j).info_ptr = null then goto make_x;
500 mst_ptr (COPY) = tp2_names (j).info_ptr;
501 call read_segment (COPY);
502 mst_ptr (COPY) = mst_ptr_hold (COPY);
503 call terminate_file_ (tp2_names(j).info_ptr,
504 seg_length(COPY) * BITS_PER_WORD, TERM_FILE_TRUNC_BC_TERM,
505 code);
506 end;
507 else call skip_block (COPY);
508 l2_index = l2_index + 1;
509 skip_1 = "1"b;
510 goto loop_cont;
511 end;
512
513
514 if tp2_names (j).sw.mov then
515 if tp2_names (j).move_index ^= 0 then do;
516 set = tp2_names (j).move_index;
517 mst_ptr (MASTER) = tp1_names (set).head_ptr;
518 call header_setup_1;
519 call check_headers;
520 call read_segment (COPY);
521 mst_ptr (MASTER) = tp1_names (set).info_ptr;
522 call check_segments;
523 mst_ptr (MASTER) = mst_ptr_hold (MASTER);
524 l2_index = l2_index + 1;
525 skip_1 = "1"b;
526 goto loop_cont;
527 end;
528 else do;
529 call ioa_ ("^a moved up.", segment_name);
530 compare_mst_severity_ = max(compare_mst_severity_, 3);
531 call ssu_$get_temp_segment (sci_ptr, "hdr." || segment_name,
532 tp2_names (j).head_ptr);
533 bit_len = mst2.header_length + 2;
534 tp2_names (j).head_ptr -> header_words = mst_ptr (COPY) -> header_words;
535 call ssu_$get_temp_segment (sci_ptr, "tp2." || segment_name,
536 tp2_names (j).info_ptr);
537 mst_ptr (COPY) = tp2_names (j).info_ptr;
538 call read_segment (COPY);
539 mst_ptr (COPY) = mst_ptr_hold (COPY);
540 l2_index = l2_index + 1;
541 skip_1 = "1"b;
542 goto loop_cont;
543 end;
544
545 call check_headers;
546 call read_segment (MASTER);
547 call read_segment (COPY);
548 call check_segments;
549 l1_index = l1_index + 1;
550 l2_index = l2_index + 1;
551 loop_cont:
552 end;
553
554 if l1_index > name_count (MASTER) then if l2_index ^> name_count (COPY)
555 then i = 2;
556 else goto detach_and_return;
557 else i = 1;
558
559 if i = 1 then j = l1_index;
560 else j = l2_index;
561 do while (j ^> name_count (i));
562 call read_header (i, collection);
563 if collection then goto incr_j;
564 k = np (i) -> tp1_names (j).pos_n;
565 if segment_name ^= np (i) -> tp1_names (k).name then goto out_of_sync;
566 if np (i) -> tp1_names (k).sw.add then do;
567 call ioa_ ("^a added.", segment_name);
568 compare_mst_severity_ = max(compare_mst_severity_, 3);
569 if saving then do;
570 call initiate_file_$create (get_wdir_ (),
571 "tp2." || segment_name, RW_ACCESS, mst_ptr (i), ""b, 0,
572 code);
573 if mst_ptr (i) = null then goto make_x;
574 call read_segment (i);
575 call terminate_file_ (mst_ptr (i),
576 seg_length(i) * BITS_PER_WORD, TERM_FILE_TRUNC_BC_TERM,
577 code);
578 mst_ptr (i) = mst_ptr_hold (i);
579 end;
580 else call skip_block (i);
581 end;
582 else do;
583 call skip_block (i);
584 call ioa_ ("^a deleted.", segment_name);
585 compare_mst_severity_ = max(compare_mst_severity_, 3);
586 end;
587 incr_j: j = j + 1;
588 end;
589 call ioa_ ("End of comparison.^/");
590
591 detach_and_return:
592 call clean_up;
593 return;
594
595 exit_proc:
596 procedure;
597 go to detach_and_return;
598 end exit_proc;
599
600 make_x: compare_mst_severity_ = max(compare_mst_severity_, 4);
601 call ssu_$abort_subsystem (sci_ptr, code,
602 "Making -save segment in working directory.");
603 go to detach_and_return;
604 %page;
605 clean_up: proc;
606 do i = MASTER to COPY;
607 if iocb_ptr (i) = null ()
608 then go to CLEAN;
609 call iox_$close (iocb_ptr (i), code);
610 call iox_$detach_iocb (iocb_ptr (i), code);
611 CLEAN: end;
612 call ssu_$destroy_invocation (sci_ptr);
613 end;
614 %page;
615 get_data: proc (index, data_ptr, data_words);
616
617 dcl index fixed bin,
618 data_ptr ptr,
619 data_words fixed bin(18) uns unal;
620
621 call iox_$get_chars (iocb_ptr(index),
622 data_ptr, data_words * CHARS_PER_WORD, (0), code);
623 if code = error_table_$end_of_info then go to detach_and_return;
624 else if code ^= 0 then do;
625 call ssu_$abort_subsystem (sci_ptr, code,
626 "Tape error on ^[master^;copy^] tape.", index);
627 end;
628 end get_data;
629
630
631 get_in_file:
632 proc (index);
633
634 dcl index fixed bin;
635
636 dcl 1 control_word aligned,
637 2 type fixed bin (17) unaligned,
638 2 count fixed bin (18) uns unal;
639
640 call absolute_pathname_ (in_file_name(index),
641 in_file_name(index), code);
642 if code ^= 0 then
643 call ssu_$abort_subsystem (sci_ptr, code, "^[-if^;-of^] ^a.",
644 index, in_file_name);
645
646 in_file_name(index) = get_shortest_path_ (in_file_name(index));
647
648 call iox_$attach_name (mst_name(index) || unique_chars_(""b),
649 iocb_ptr(index), "vfile_ " || in_file_name(index) || " -old",
650 null, code);
651 if code ^= 0 then
652 call ssu_$abort_subsystem (sci_ptr, code,
653 "Cannot attach input file ^a.", in_file_name(index));
654
655 REWIND_FILE:
656 call iox_$open (iocb_ptr(index), Stream_input, ("0"b), code);
657 if code ^= 0 then
658 call ssu_$abort_subsystem (sci_ptr, code,
659 "Cannot open input file ^a.", in_file_name(index));
660
661 call get_data (index, addr (control_word), size(control_word));
662 if control_word.type = -1 then do;
663
664
665 bpi(index).version = BOOT_PROGRAM_INFO_VERSION_1;
666
667 boot_label(index) = "1"b;
668 name_len = divide (length (bpi(index).boot_program_name), CHARS_PER_WORD, 18, 0);
669 seg_len = control_word.count - name_len;
670 call get_data (index, addr (bpi(index).boot_program_name), name_len);
671 call get_data (index, boot_ptr(index), seg_len);
672
673 bpi(index).boot_program_ptr = boot_ptr(index);
674 bpi(index).boot_program_text_length = seg_len;
675 end;
676 else do;
677 boot_label(index) = "0"b;
678 call iox_$close (iocb_ptr(index), (0));
679 call iox_$open (iocb_ptr(index), Stream_input, ""b, (0));
680 end;
681 return;
682
683 rewind_in_file:
684 entry (index);
685
686 call iox_$close (iocb_ptr(index), code);
687 if code ^= 0 then do;
688 compare_mst_severity_ = max(compare_mst_severity_, 4);
689 call ssu_$abort_subsystem (sci_ptr, code,
690 "error in reopening. Aborting.");
691 end;
692 go to REWIND_FILE;
693
694 end get_in_file;
695
696
697 get_in_medium:
698 proc (index);
699
700 dcl index fixed bin;
701
702 if in_file_name(index) ^= "" then
703 call get_in_file (index);
704 else if in_tape_name(index) ^= "" then
705 call get_in_tape (index);
706 return;
707
708 rewind_in_medium:
709 entry (index);
710
711 if in_file_name(index) ^= "" then
712 call rewind_in_file (index);
713 else
714 call rewind_in_tape (index);
715
716 end get_in_medium;
717
718 get_in_tape:
719 proc (index);
720
721 dcl index fixed bin;
722
723 dcl copy (seg_len) fixed bin(35) based;
724
725 call parse_tape_reel_name_ (in_tape_name(index), atd);
726 if in_den(index) ^= UNSET
727 then atd = rtrim (atd) || " -density " || ltrim (char (in_den(index)));
728
729 call iox_$attach_name (mst_name(index) || unique_chars_ (""b),
730 iocb_ptr(index), "tape_mult_ " || rtrim (atd), null, code);
731 if code ^= 0 then
732 call ssu_$abort_subsystem (sci_ptr, code,
733 "Cannot attach input tape ^a.", in_tape_name(index));
734
735 REWIND_TAPE:
736 call iox_$open (iocb_ptr(index), Stream_input, ("0"b), code);
737 if code ^= 0 then
738 call ssu_$abort_subsystem (sci_ptr, code,
739 "Cannot open input tape ^a.", in_tape_name(index));
740
741 bpi(index).version = BOOT_PROGRAM_INFO_VERSION_1;
742 call iox_$control (iocb_ptr(index), "get_boot_program",
743 addr (bpi(index)), code);
744 if code ^= 0 then
745 call ssu_$abort_subsystem (sci_ptr, code,
746 "Getting bootload program info from input tape ^a.",
747 in_tape_name(index));
748
749 if bpi(index).boot_program_ptr ^= null then do;
750 boot_label(index) = "1"b;
751 seg_len = bpi(index).boot_program_text_length;
752
753 boot_ptr(index) -> copy = bpi(index).boot_program_ptr -> copy;
754
755 bpi(index).boot_program_ptr = boot_ptr(index);
756
757 end;
758 else
759 boot_label(index) = "0"b;
760 return;
761
762 rewind_in_tape:
763 entry (index);
764
765 call iox_$close (iocb_ptr (index), code);
766 if code ^= 0 then do;
767 compare_mst_severity_ = max(compare_mst_severity_, 4);
768 call ssu_$abort_subsystem (sci_ptr, code,
769 "error in rewind, aborting");
770 end;
771 go to REWIND_TAPE;
772
773 end get_in_tape;
774 %page;
775 read_header: proc (index, found_mark);
776
777 dcl found_mark bit (1) aligned;
778 dcl index fixed bin;
779
780
781
782
783
784
785
786 call iox_$get_chars (iocb_ptr (index), mst_ptr (index), 8, nelemt, code);
787 if code = 0 then do;
788 if mst_ptr (index) -> mst1.collection_mark then do;
789 found_mark = "1"b;
790 return;
791 end;
792 else call iox_$get_chars (iocb_ptr (index), ptr (mst_ptr (index), 2),
793 mst_ptr (index) -> mst1.header_length * 4, nelemt, code);
794
795 if code ^= 0 then call check_status;
796 found_mark = "0"b;
797
798 if index = 1 then call header_setup_1;
799 else call header_setup_2;
800 end;
801 else if code ^= error_table_$end_of_info then call check_status;
802
803 end;
804 %page;
805 header_setup_1: proc;
806
807 n_names (MASTER) = mst_ptr (MASTER) -> mst1.n_names;
808
809 if n_names (MASTER) = -1 then do;
810 if bootstrap_sw (MASTER) then do;
811 call ioa_ ("second bound_bootload_0 found on master tape. Aborting.");
812 compare_mst_severity_ = max(compare_mst_severity_, 3);
813 goto detach_and_return;
814 end;
815 bootstrap_sw (MASTER) = "1"b;
816 n_names (MASTER) = 0;
817 has_acl (MASTER) = 0;
818 n_acls (MASTER) = 0;
819 has_branch (MASTER) = 0;
820 path_length (MASTER) = 0;
821 segment_name = "bound_bootload_0";
822 seg_length (MASTER) = mst_ptr (MASTER) -> bootstrap_header.segment_length;
823 end;
824 else do;
825 has_acl (MASTER) = binary (mst_ptr (MASTER) -> mst1.slte.acl_provided);
826 has_branch (MASTER) = binary (mst_ptr (MASTER) -> mst1.slte.branch_required);
827 if has_branch (MASTER) = 1 then path_length (MASTER) = mst_ptr (MASTER) -> mst1.pathname_length (1);
828 else path_length (MASTER) = 0;
829 if has_acl (MASTER) = 1 then n_acls (MASTER) = mst_ptr (MASTER) -> mst1.n_acls (1);
830 else n_acls (MASTER) = 0;
831 segment_name = mst_ptr (MASTER) -> mst1.name (MASTER);
832 seg_length (MASTER) = mst_ptr (MASTER) -> mst1.segment_length;
833 end;
834 end;
835
836 header_setup_2: proc;
837
838 n_names (COPY) = mst_ptr (COPY) -> mst2.n_names;
839 if n_names (COPY) = -1 then do;
840 if bootstrap_sw (COPY) then do;
841 call ioa_ ("second bound_bootload_0 found on copy tape. Aborting.");
842 compare_mst_severity_ = max(compare_mst_severity_, 3);
843 goto detach_and_return;
844 end;
845 bootstrap_sw(COPY) = "1"b;
846 n_names (COPY) = 0;
847 has_acl (COPY) = 0;
848 n_acls (COPY) = 0;
849 has_branch (COPY) = 0;
850 path_length (COPY) = 0;
851 segment_name = "bound_bootload_0";
852 seg_length (COPY) = mst_ptr (COPY) -> bootstrap_header.segment_length;
853 end;
854 else do;
855 has_acl (COPY) = binary (mst_ptr (COPY) -> mst2.slte.acl_provided);
856 has_branch (COPY) = binary (mst_ptr (COPY) -> mst2.slte.branch_required);
857 if has_branch (COPY) = 1 then path_length (COPY) = mst_ptr (COPY) -> mst2.pathname_length (1);
858 else path_length (COPY) = 0;
859 if has_acl (COPY) = 1 then n_acls (COPY) = mst_ptr (COPY) -> mst2.n_acls (1);
860 else n_acls (COPY) = 0;
861 segment_name = mst_ptr (COPY) -> mst2.name (1);
862 seg_length (COPY) = mst_ptr (COPY) -> mst2.segment_length;
863 end;
864 end;
865 %page;
866 check_headers: proc;
867
868
869 if mst1.header_length ^= mst2.header_length then goto header_discrepancy;
870
871 bit_len = mst1.header_length + 2;
872 bits = mst_ptr (MASTER) -> header_words = mst_ptr (COPY) -> header_words;
873 if (^string (bits)) ^= ""b then
874 if ((n_acls (MASTER) = 0) | (n_acls (COPY) = 0)) then goto header_discrepancy;
875 else do;
876 do k = 1 to n_acls (MASTER);
877 mst1.acl (1, k).pad (1), mst1.acl (1, k).pad (2) = 0;
878 end;
879 do k = 1 to n_acls (COPY);
880 mst2.acl (1, k).pad (1), mst2.acl (1, k).pad (2) = 0;
881 end;
882 bits = mst_ptr (MASTER) -> header_words = mst_ptr (COPY) -> header_words;
883 if (^string (bits)) ^= ""b then goto header_discrepancy;
884 end;
885 return;
886
887 header_discrepancy:
888 call ioa_ ("^/Segment ^a:", segment_name);
889 compare_mst_severity_ = max(compare_mst_severity_, 3);
890
891
892 if mst_ptr (MASTER) -> mst1.access ^= mst_ptr (COPY) -> mst2.access then
893 call ioa_ ("^-SDW access has changed from ^a to ^a",
894 substr (REWP, binary (mst_ptr (MASTER) -> mst1.access) * 4 + 1, 4),
895 substr (REWP, binary (mst_ptr (COPY) -> mst2.access) * 4 + 1, 4));
896 if mst_ptr (MASTER) -> mst1.cache ^= mst_ptr (COPY) -> mst2.cache then
897 call ioa_ ("^-Cache bit has changed from ^a to ^a",
898 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.cache) * 4 + 1, 3),
899 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.cache) * 4 + 1, 3));
900 if mst_ptr (MASTER) -> mst1.wired ^= mst_ptr (COPY) -> mst2.wired then
901 call ioa_ ("^-Wired bit has changed from ^a to ^a.",
902 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.wired) * 4 + 1, 3),
903 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.wired) * 4 + 1, 3));
904 if mst_ptr (MASTER) -> mst1.paged ^= mst_ptr (COPY) -> mst2.paged then
905 call ioa_ ("^-Paged bit has changed from ^a to ^a.",
906 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.paged) * 4 + 1, 3),
907 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.paged) * 4 + 1, 3));
908 if mst_ptr (MASTER) -> mst1.per_process ^= mst_ptr (COPY) -> mst2.per_process then
909 call ioa_ ("^-Per-process bit has changed from ^a to ^a.",
910 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.per_process) * 4 + 1, 3),
911 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.per_process) * 4 + 1, 3));
912 %page;
913 if mst_ptr (MASTER) -> mst1.acl_provided ^= mst_ptr (COPY) -> mst2.acl_provided then
914 call ioa_ ("^-ACL-provided switch has changed from ^a to ^a.",
915 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.acl_provided) * 4 + 1, 3),
916 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.acl_provided) * 4 + 1, 3));
917 else if has_acl (MASTER) = 1 then
918 if n_acls (MASTER) ^= n_acls (COPY) then goto print_acls;
919 else do;
920 bit_len = 11 * n_acls (MASTER) + 1;
921 anp (MASTER) = addr (mst1.acl_structure (1));
922 anp (COPY) = addr (mst2.acl_structure (1));
923 bits = anp (MASTER) -> header_words = anp (COPY) -> header_words;
924 if (^string (bits)) ^= ""b then do;
925 print_acls: call ioa_ ("^-Number of ACLs was ^d, now is ^d.",
926 n_acls (MASTER), n_acls (COPY));
927 if abs (n_acls (MASTER) - n_acls (COPY)) > abs_changes then do;
928 too_much: compare_mst_severity_ = max(compare_mst_severity_, 4);
929 call ssu_$abort_subsystem (sci_ptr, 0,
930 "Probable bad tape, aborting.");
931 goto detach_and_return;
932 end;
933 call ioa_ ("^5xACL was:");
934 do k = 1 to n_acls (MASTER);
935 call ioa_ ("^-^3a ^a",
936 substr (rew, binary (mst_ptr (MASTER) -> mst1.acl (1, k).mode) * 3 + 1, 3),
937 mst_ptr (MASTER) -> mst1.acl (1, k).accessname);
938 end;
939 call ioa_ ("^5xACL is:");
940 do k = 1 to n_acls (COPY);
941 call ioa_ ("^-^3a ^a",
942 substr (rew, binary (mst_ptr (COPY) -> mst2.acl (1, k).mode) * 3 + 1, 3),
943 mst_ptr (COPY) -> mst2.acl (1, k).accessname);
944 end;
945 end;
946 end;
947 if mst_ptr (MASTER) -> mst1.branch_required ^= mst_ptr (COPY) -> mst2.branch_required then
948 call ioa_ ("^-Hierarchy-branch required indicator has changed from ^a to ^a.",
949 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.branch_required) * 4 + 1, 3),
950 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.branch_required) * 4 + 1, 3));
951 else if has_branch (MASTER) = 1 then
952 if mst_ptr (MASTER) -> mst1.pathname (1) ^= mst_ptr (COPY) -> mst2.pathname (1) then
953 call ioa_ ("^-Pathname has changed from ^a to ^a.",
954 mst_ptr (MASTER) -> mst1.pathname (1), mst_ptr (COPY) -> mst2.pathname (1));
955 if mst_ptr (MASTER) -> mst1.init_seg ^= mst_ptr (COPY) -> mst2.init_seg then
956 call ioa_ ("^-Initialization-seg indicator has changed from ^a to ^a.",
957 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.init_seg) * 4 + 1, 3),
958 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.init_seg) * 4 + 1, 3));
959 if mst_ptr (MASTER) -> mst1.temp_seg ^= mst_ptr (COPY) -> mst2.temp_seg then
960 call ioa_ ("^-Temp-seg indicator has changed from ^a to ^a.",
961 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.temp_seg) * 4 + 1, 3),
962 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.temp_seg) * 4 + 1, 3));
963 %page;
964 if mst_ptr (MASTER) -> mst1.link_provided ^= mst_ptr (COPY) -> mst2.link_provided then
965 call ioa_ ("^-Linkage-provided indicator has changed from ^a to ^a.",
966 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.link_provided) * 4 + 1, 3),
967 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.link_provided) * 4 + 1, 3));
968 if mst_ptr (MASTER) -> mst1.link_sect ^= mst_ptr (COPY) -> mst2.link_sect then
969 call ioa_ ("^-Linkage-segment indicator has changed from ^a to ^a.",
970 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.link_sect) * 4 + 1, 3),
971 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.link_sect) * 4 + 1, 3));
972 if mst_ptr (MASTER) -> mst1.link_sect_wired ^= mst_ptr (COPY) -> mst2.link_sect_wired then
973 call ioa_ ("^-Linkage-wired indicator has changed from ^a to ^a.",
974 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.link_sect_wired) * 4 + 1, 3),
975 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.link_sect_wired) * 4 + 1, 3));
976 if mst_ptr (MASTER) -> mst1.combine_link ^= mst_ptr (COPY) -> mst2.combine_link then
977 call ioa_ ("^-Combine-linkage switch has changed from ^a to ^a.",
978 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.combine_link) * 4 + 1, 3),
979 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.combine_link) * 4 + 1, 3));
980 if mst_ptr (MASTER) -> mst1.pre_linked ^= mst_ptr (COPY) -> mst2.pre_linked then
981 call ioa_ ("^-Pre-linked indicator has changed from ^a to ^a.",
982 substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.pre_linked) * 4 + 1, 3),
983 substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.pre_linked) * 4 + 1, 3));
984 if mst_ptr (MASTER) -> mst1.cur_length ^= mst_ptr (COPY) -> mst2.cur_length then
985 call ioa_ ("^-Cur-length has changed from ^o to ^o.",
986 binary (mst_ptr (MASTER) -> mst1.cur_length, 35),
987 binary (mst_ptr (COPY) -> mst2.cur_length, 35));
988 if mst_ptr (MASTER) -> mst1.ringbrack (1) ^= mst_ptr (COPY) -> mst2.ringbrack (1) |
989 mst_ptr (MASTER) -> mst1.ringbrack (2) ^= mst_ptr (COPY) -> mst2.ringbrack (2) |
990 mst_ptr (MASTER) -> mst1.ringbrack (3) ^= mst_ptr (COPY) -> mst2.ringbrack (3) then
991 call ioa_ ("^-Ring brackets have changed from ^d,^d,^d to ^d,^d,^d.",
992 binary (mst_ptr (MASTER) -> mst1.ringbrack (1), 35),
993 binary (mst_ptr (MASTER) -> mst1.ringbrack (2), 35),
994 binary (mst_ptr (MASTER) -> mst1.ringbrack (3), 35),
995 binary (mst_ptr (COPY) -> mst2.ringbrack (1), 35),
996 binary (mst_ptr (COPY) -> mst2.ringbrack (2), 35),
997 binary (mst_ptr (COPY) -> mst2.ringbrack (3), 35));
998 if mst_ptr (MASTER) -> mst1.segno ^= mst_ptr (COPY) -> mst2.segno then
999 call ioa_ ("^-Segment number has changed from ^o to ^o.",
1000 binary (mst_ptr (MASTER) -> mst1.segno, 35),
1001 binary (mst_ptr (COPY) -> mst2.segno, 35));
1002 if mst_ptr (MASTER) -> mst1.max_length ^= mst_ptr (COPY) -> mst2.max_length then
1003 call ioa_ ("^-Max length has changed from ^o to ^o.",
1004 binary (mst_ptr (MASTER) -> mst1.max_length, 35),
1005 binary (mst_ptr (COPY) -> mst2.max_length, 35));
1006 if mst_ptr (MASTER) -> mst1.bit_count ^= mst_ptr (COPY) -> mst2.bit_count then
1007 call ioa_ ("^-Bit count has changed from ^d to ^d.",
1008 binary (mst_ptr (MASTER) -> mst1.bit_count, 35),
1009 binary (mst_ptr (COPY) -> mst2.bit_count, 35));
1010 %page;
1011 if n_names (MASTER) = 0 then return;
1012 if n_names (MASTER) ^= n_names (COPY) then goto print_names;
1013 else do;
1014 bit_len = 9 * n_names (MASTER) + 1;
1015 anp (MASTER) = addr (mst1.names_array);
1016 anp (COPY) = addr (mst2.names_array);
1017 bits = anp (MASTER) -> header_words = anp (COPY) -> header_words;
1018 if (^string (bits)) ^= ""b then do;
1019 print_names: call ioa_ ("^-Number of names was ^d, now is ^d.",
1020 n_names (MASTER), n_names (COPY));
1021 if abs (n_names (MASTER) - n_names (COPY)) > abs_changes then goto too_much;
1022 call ioa_ ("^5xNames were:");
1023 do k = 1 to n_names (MASTER);
1024 call ioa_ ("^-^a", mst_ptr (MASTER) -> mst1.name (k));
1025 end;
1026 call ioa_ ("^5xNames are:");
1027 do k = 1 to n_names (COPY);
1028 call ioa_ ("^-^a", mst_ptr (COPY) -> mst2.name (k));
1029 end;
1030 end;
1031 end;
1032 if mst_ptr (MASTER) -> mst1.segment_length ^= mst_ptr (COPY) -> mst2.segment_length then
1033 call ioa_ ("^-Segment length has changed from ^o to ^o.",
1034 mst_ptr (MASTER) -> mst1.segment_length, mst_ptr (COPY) -> mst2.segment_length);
1035
1036 end;
1037 %page;
1038 skip_block: proc (index);
1039 dcl index fixed bin;
1040
1041 call iox_$get_chars (iocb_ptr (index), mst_ptr (index), seg_length (index) * 4, nelemt, code);
1042 if code ^= 0 then call check_status;
1043 end;
1044
1045 read_segment: proc (index);
1046 dcl index fixed bin;
1047
1048 call iox_$get_chars (iocb_ptr (index), mst_ptr (index), seg_length (index) * 4, nelemt, code);
1049 if code ^= 0 then call check_status;
1050
1051 end;
1052
1053 check_status: proc;
1054 compare_mst_severity_ = max(compare_mst_severity_, 4);
1055 call ssu_$abort_subsystem (sci_ptr, code,
1056 "Error in manipulating tapes.");
1057 end;
1058
1059 read_tape: proc (index);
1060
1061 dcl index fixed bin parameter;
1062
1063 dcl i fixed bin;
1064 dcl last_collection_mark fixed bin;
1065 dcl name_index fixed bin;
1066 dcl 1 tp_names (name_count (index)) based (np (index)) aligned like tp_name;
1067
1068 last_collection_mark = 0;
1069 name_index, name_count (index) = 0;
1070 do while (code ^= error_table_$end_of_info);
1071 call read_header (index, collection);
1072 if code = 0 then do;
1073 name_index, name_count (index) = name_count (index) + 1;
1074 tp_names (name_index).org_index = name_index;
1075 tp_names (name_index).pos_n = name_index;
1076 tp_names (name_index).head_ptr = null;
1077 tp_names (name_index).info_ptr = null;
1078 if index = 1 then tp_names (name_index).sw.del = "1"b;
1079
1080 else tp_names (name_index).sw.add = "1"b;
1081 if collection then do;
1082 do i = last_collection_mark + 1 to name_index;
1083
1084 tp_names (i).major_collection = mst_ptr (index) -> collection_mark_data.major;
1085 tp_names (i).minor_collection = mst_ptr (index) -> collection_mark_data.minor;
1086 end;
1087 last_collection_mark = name_index;
1088
1089 tp_names (name_index).name = "collection." ||
1090 ltrim (char (mst_ptr (index) -> collection_mark_data.major)) ||
1091 "." || ltrim (char (mst_ptr (index) -> collection_mark_data.minor));
1092 tp_names (name_index).sw.col = "1"b;
1093 end;
1094 else do;
1095 tp_names (name_index).name = segment_name;
1096 call skip_block (index);
1097 if segment_name = "active_all_rings_data" then do;
1098 have_sysid = "1"b;
1099 sys_id (index) = mst_ptr (index) -> sys_id_pickup;
1100 end;
1101 end;
1102 end;
1103 end;
1104
1105 if substr (tp_names (name_index).name, 1, 10) ^= "collection" then do;
1106 call ioa_ ("tape ^d does not end in a collection mark.", index);
1107 compare_mst_severity_ = max(compare_mst_severity_, 3);
1108 end;
1109 return;
1110 end;
1111 %page;
1112 check_segments: proc;
1113
1114 if seg_length (MASTER) ^= seg_length (COPY) then goto check_saving;
1115 bit_len = seg_length (MASTER);
1116
1117 bits = mst_ptr (MASTER) -> segment_1 = mst_ptr (COPY) -> segment_1;
1118
1119 if (^string (bits)) ^= ""b then goto segment_contents_discrepancy;
1120
1121 return;
1122
1123
1124 segment_contents_discrepancy:
1125 k = index (string (bits), "0"b) - 1;
1126 call ioa_ ("^/Segment ^a contains differences from word ^o.", segment_name, k);
1127 compare_mst_severity_ = max(compare_mst_severity_, 3);
1128 k = bit_len - index (reverse (string (bits)), "0"b);
1129 call ioa_ ("^-last difference found at word ^o.", k);
1130 check_saving:
1131 if saving then do;
1132 call initiate_file_$create (get_wdir_ (),
1133 "tp1." || segment_name, RW_ACCESS, copy_ptr, ""b, 0, code);
1134 if copy_ptr = null then return;
1135 copy_ptr -> segment_1 = mst_ptr (MASTER) -> segment_1;
1136 call terminate_file_ (copy_ptr, size(segment_1) * BITS_PER_WORD,
1137 TERM_FILE_TRUNC_BC_TERM, code);
1138
1139 call initiate_file_$create (get_wdir_ (),
1140 "tp2." || segment_name, RW_ACCESS, copy_ptr, ""b, 0, code);
1141 if copy_ptr = null then return;
1142 copy_ptr -> segment_2 = mst_ptr (COPY) -> segment_2;
1143 call terminate_file_ (copy_ptr, size(segment_2) * BITS_PER_WORD,
1144 TERM_FILE_TRUNC_BC_TERM, code);
1145 end;
1146 return;
1147 end;
1148 %page;
1149 sort_names: proc (index);
1150
1151 dcl index fixed bin;
1152
1153 dcl 1 hold_info aligned like tp_name.order_info;
1154 dcl sd fixed bin;
1155 dcl si fixed bin;
1156 dcl sj fixed bin;
1157 dcl sk fixed bin;
1158 dcl 1 tp_names (name_count (index)) aligned based (np (index)) like tp_name;
1159
1160 sd = name_count (index);
1161
1162 down: sd = 1 + 2 * divide (sd, 4, 17, 0);
1163 do si = 1 to name_count (index) - sd;
1164 sj = si + sd;
1165 up: sk = sj - sd;
1166 if tp_names (sk).name <= tp_names (sj).name then goto ok;
1167
1168 hold_info = tp_names (sk).order_info;
1169
1170 tp_names (sk).order_info = tp_names (sj).order_info;
1171 tp_names (tp_names (sk).org_index).pos_n = sk;
1172
1173 tp_names (sj).order_info = hold_info;
1174 tp_names (tp_names (sj).org_index).pos_n = sj;
1175
1176 if sk > sd then do;
1177 sj = sk;
1178 goto up;
1179 end;
1180 ok: end;
1181 if sd > 1 then goto down;
1182
1183 end;
1184 %page;
1185 name_search: proc (tp_name_ptr, index, ret_ans);
1186
1187
1188
1189
1190 dcl index fixed bin;
1191 dcl ret_ans fixed bin;
1192 dcl tp_name_ptr ptr;
1193
1194 dcl low_index fixed bin;
1195 dcl high_index fixed bin;
1196 dcl 1 tp_names (name_count (index)) aligned based (np (index)) like tp_name;
1197
1198 ret_ans = 0;
1199 low_index = 1;
1200 high_index = name_count (index);
1201 do while (high_index > low_index);
1202 k = divide (low_index + high_index, 2, 17);
1203 if tp_names (k).name = tp_name_ptr -> tp_name.name then go to match;
1204 else if tp_names (k).name < tp_name_ptr -> tp_name.name then low_index = k + 1;
1205 else high_index = k - 1;
1206 end;
1207 if high_index < 1 then return;
1208 if low_index > name_count (index) then return;
1209 if tp_names (high_index).name = tp_name_ptr -> tp_name.name then do;
1210 k = high_index;
1211 match:
1212
1213
1214
1215 do ret_ans = k to name_count (index) while (tp_name_ptr -> tp_name.name = tp_names (ret_ans).name),
1216 k - 1 to 1 by -1 while (tp_name_ptr -> tp_name.name = tp_names (ret_ans).name);
1217 if tp_name_ptr -> tp_name.major_collection = tp_names (ret_ans).major_collection &
1218 tp_name_ptr -> tp_name.minor_collection = tp_names (ret_ans).minor_collection then return;
1219 end;
1220 ret_ans = ret_ans + 1;
1221 end;
1222 return;
1223 end;
1224 %page;
1225 list_comp: proc;
1226
1227 dcl add_count fixed bin;
1228 dcl del_count fixed bin;
1229 dcl offset_1 fixed bin;
1230 dcl offset_2 fixed bin;
1231
1232 do i = 1 to name_count (MASTER);
1233 call name_search (addr (tp1_names (tp1_names (i).pos_n)), 2, offset_1);
1234 if offset_1 = 0 then go to d_lp_c;
1235 else do;
1236 tp1_names (tp1_names (i).pos_n).sw.del = "0"b;
1237 tp2_names (offset_1).sw.add = "0"b;
1238 end;
1239 d_lp_c: end;
1240
1241 i, j = 1;
1242 add_count, del_count = 0;
1243
1244 do while ((i <= name_count (MASTER)) & (j <= name_count (COPY)));
1245 if tp1_names (tp1_names (i).pos_n).sw.del |
1246 tp1_names (tp1_names (i).pos_n).move_index ^= 0 then do;
1247 i = i + 1;
1248 go to l_cont;
1249 end;
1250 if tp2_names (tp2_names (j).pos_n).sw.add |
1251 tp2_names (tp2_names (j).pos_n).move_index ^= 0 then do;
1252 j = j + 1;
1253 go to l_cont;
1254 end;
1255
1256 if tp1_names (tp1_names (i).pos_n).name = tp2_names (tp2_names (j).pos_n).name then do;
1257 i = i + 1;
1258 j = j + 1;
1259 goto l_cont;
1260 end;
1261
1262 call name_search (addr (tp1_names (tp1_names (i).pos_n)), COPY, offset_2);
1263 call name_search (addr (tp2_names (tp2_names (j).pos_n)), MASTER, offset_1);
1264
1265 del_count = tp1_names (offset_1).org_index - tp1_names (tp1_names (i).pos_n).org_index;
1266 add_count = tp2_names (offset_2).org_index - tp2_names (tp2_names (j).pos_n).org_index;
1267
1268 if del_count > add_count then do;
1269 tp2_names (tp2_names (j).pos_n).sw.mov = "1"b;
1270 tp1_names (offset_1).sw.mov = "1"b;
1271 tp1_names (offset_1).move_index = tp2_names (j).pos_n;
1272 j = j + 1;
1273 goto l_cont;
1274 end;
1275 else do;
1276 tp1_names (tp1_names (i).pos_n).sw.mov = "1"b;
1277 tp2_names (offset_2).sw.mov = "1"b;
1278 tp2_names (offset_2).move_index = tp1_names (i).pos_n;
1279 i = i + 1;
1280 goto l_cont;
1281 end;
1282 l_cont: end;
1283 end;
1284 %page; %include access_mode_values;
1285 %page; %include iox_modes;
1286 %page; %include slte;
1287 %page; %include system_constants;
1288 %page; %include tape_mult_boot_info;
1289 %page; %include terminate_file;
1290 end;