



		    check_mst.pl1                   07/16/87  1350.1r   07/15/87  1602.4       77904



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(87-01-13,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for storing boot program as first segment of MST image stored
     in a file.
                                                   END HISTORY COMMENTS */


/* format: style2 */
/* Command version of Multics checker */
/* Written long ago by someone who probably wouldn't admit it today, anyway */
/* Modified 26 June 1981, W. Olin Sibert, to call get_collection_$init and avoid creeping sizes */
/* Completely rewritten 7/82 BIM */


check_mst:
ckm:
     procedure;

	dcl     (
	        error_table_$noarg,
	        error_table_$inconsistent,
	        error_table_$too_many_args,
	        error_table_$badopt,
	        error_table_$bad_conversion,
	        error_table_$bad_arg
	        )			 ext static fixed bin (35);

	dcl     density		 fixed bin;
	dcl     thing_name		 char (168);
	dcl     filename		 char (168);
	dcl     code		 fixed bin (35);
	dcl     (file, positional, tape)
				 bit (1) aligned;	/* file --> -file, positional --> positional control arg seen, tape --> -tape */
	dcl     ap		 pointer;
	dcl     al		 fixed bin (21);
	dcl     argument		 char (al) based (ap);
	dcl     argx		 fixed bin;
	dcl     n_args		 fixed bin;

	dcl     (addr, before, binary, char, fixed, null, string)
				 builtin;

	dcl     (get_temp_segments_, release_temp_segments_)
				 entry (char (*), dim (*) ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     checker_print_$init	 entry;
	dcl     define_area_	 entry (ptr, fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     tape_reader_$init	 entry (char (*), char (*), fixed bin, bit (1) aligned, fixed bin (35));
	dcl     tape_reader_$final	 entry;
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_wdir_		 entry returns (char (168));

	dcl     checker_init_meters_	 entry;
	dcl     checker_load_MST_	 entry;
	dcl     checker_crossref_	 entry;

	dcl     sslt_manager_$init	 entry (ptr);
	dcl     sslt_init_		 entry (ptr, ptr);

	dcl     cleanup		 condition;
	dcl     checker_fatal_error_	 condition;
	dcl     conversion		 condition;
%page;
%include iox_modes;
%page;
%include iox_entries;
%page;
%include area_info;
	dcl     1 AI		 aligned like area_info;

%page;
%include checker_dcls_;

	dcl     sys_info$max_seg_size	 fixed bin (35) ext;

	dcl     ME		 char (32) init ("check_mst") int static options (constant);


	call cu_$arg_count (n_args, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;

	thing_name = "";
	positional = "0"b;
	file = "0"b;
	tape = "0"b;
	density = 0;
	checker_data_$severity = 0;

	do argx = 1 to n_args;
	     call cu_$arg_ptr (argx, ap, al, (0));
	     if char (argument, 1) ^= "-"
	     then do;
		     if positional			/* only one positional allowed */
		     then do;
			     call com_err_ (error_table_$too_many_args, ME,
				"Only one MST may be supplied. ^a cannot be processed.", argument);
			     return;
			end;
		     positional = "1"b;
		     thing_name = argument;
		end;
	     else if argument = "-severity" | argument = "-sv"
	     then do;
		     if argx = n_args
		     then do;
			     call com_err_ (error_table_$noarg, ME,
				"-severity must be followed by a severity number.");
			     return;
			end;
		     on conversion
			begin;
			     call com_err_ (error_table_$bad_conversion, ME, "Invalid severity number ^a.",
				argument);
			     go to RETURN;
			end;
		     argx = argx + 1;
		     call cu_$arg_ptr (argx, ap, al, (0));
		     checker_data_$severity = fixed (argument);
		     revert conversion;
		     if checker_data_$severity > 4 | checker_data_$severity < 0
		     then do;
			     call com_err_ (error_table_$bad_arg, ME,
				"-severity must be followed by N, for 0 <= N <= 4.");
			     return;
			end;
		end;
	     else if argument = "-tape"
	     then do;
		     if file | tape
		     then
DUP_INPUT:
			do;
			     call com_err_ (error_table_$inconsistent, ME,
				"-tape and -file may not both be specified.");
			     return;
			end;
		     tape = "1"b;
		end;
	     else if argument = "-file"
	     then do;
		     if file | tape
		     then goto DUP_INPUT;
		     file = "1"b;
		end;
	     else if argument = "-density" | argument = "-den"
	     then do;
		     if argx = n_args
		     then do;
			     call com_err_ (error_table_$noarg, ME, "-density must be followed by a density.");
			     return;
			end;
		     argx = argx + 1;
		     call cu_$arg_ptr (argx, ap, al, (0));
		     if char (argument, 1) = "-"
		     then do;
			     call com_err_ (error_table_$noarg, ME,
				"-density must be followed by a density, but a control argument, ^a, was found.",
				argument);
			     return;
			end;
		     on conversion
			begin;
			     call com_err_ (error_table_$bad_conversion, ME, "^a is not a valid density.", argument)
				;
			     go to RETURN;
			end;

		     density = binary (argument);
		     revert conversion;
		end;

	     else do;
		     call com_err_ (error_table_$badopt, ME, "Unrecognized control argument ^a", argument);
RETURN:
		     return;
		end;
	end;

	if ^file & ^tape
	then tape = "1"b;
	if thing_name = ""
	then do;
		call com_err_ (error_table_$noarg, ME, "No input specified.");
		return;
	     end;

	if file & density ^= 0
	then do;
		call com_err_ (error_table_$inconsistent, ME, "-density may not be specified with -file.");
		return;
	     end;

	thing_name = before (thing_name, ",");		/* in case of ,den= */

	checker_data_$temp_ptrs (*) = null ();
	checker_data_$input_iocbp, checker_data_$output_iocbp = null;
	on cleanup call clean_up;

	call get_temp_segments_ (ME, checker_data_$temp_ptrs, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "No temp segs to be had.");
		go to EXIT;
	     end;

	call tape_reader_$init (ME, thing_name, density, file, code);
	if code ^= 0
	then go to EXIT;

	AI.version = area_info_version_1;
	AI.owner = "check_mst";
	AI.size = sys_info$max_seg_size;
	AI.areap = checker_data_$area_ptr;
	string (AI.control) = ""b;
	AI.no_freeing = "1"b;
	AI.extend = "1"b;

	call define_area_ (addr (AI), code);
	if code ^= 0
	then do;
		call com_err_ (code, "check_mst", "Could not define def area.");
		go to EXIT;
	     end;

	call expand_pathname_$add_suffix (thing_name, "ckrout", (""), filename, code);
	filename = pathname_ (get_wdir_ (), (filename));

	call iox_$attach_name ("checker_output_", checker_data_$output_iocbp, "vfile_ " || filename, null (), code);
	if code ^= 0
	then do;
outerr:
		call com_err_ (code, "check_mst", "checker output file");
		go to EXIT;
	     end;
	call iox_$open (checker_data_$output_iocbp, Stream_output, "0"b, code);
	if code ^= 0
	then go to outerr;



	call ioa_ ("Begin checker");

	call checker_init_meters_;
	call checker_print_$init;

	call sslt_init_ (checker_data_$slt_ptr, checker_data_$name_table_ptr);
	call sslt_manager_$init (checker_data_$slt_ptr);	/* initialize "simulated slt" */

	on checker_fatal_error_
	     begin;
		call com_err_ (0, ME, "Fatal error. Checker run aborted.");
		go to EXIT;
	     end;

	call checker_load_MST_;

	call checker_crossref_;

	call tape_reader_$final;

	call ioa_ ("End checker");

EXIT:
	call clean_up;

	return;


clean_up:
     proc;


	if checker_data_$temp_ptrs (1) ^= null ()
	then call release_temp_segments_ (ME, checker_data_$temp_ptrs, code);
	checker_data_$temp_ptrs (*) = null;

	call tape_reader_$final ();

	if checker_data_$output_iocbp ^= null
	then do;
		call iox_$close (checker_data_$output_iocbp, code);
		call iox_$detach_iocb (checker_data_$output_iocbp, code);
		checker_data_$output_iocbp = null;
	     end;

	return;
     end;

     end check_mst;




		    checker_crossref_.pl1           06/01/84  1546.7r w 06/01/84  1426.8      137943



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* checker_crossref_ -- Program to look at all the links in an MST */
/* and see if they can be resolved */
/* format: style2 */
/* Modified December 1983 by Keith Loepere for non-loaded collections; also
   so that temp segs in one minor collection can reference segs in another
   minor collection within the same major collection. */
checker_crossref_:
     procedure;


%include checker_dcls_;
%page;
%include slte;
%include slt;
%page;

	declare 1 list_head		 aligned based,
		2 first		 ptr unaligned,
		2 count		 fixed bin;

	declare 1 segment_not_found_head
				 aligned like list_head;
	declare 1 found_online_head	 aligned like list_head;
	declare 1 entrypoint_not_found_head
				 aligned like list_head;
	declare 1 special_link_head	 aligned like list_head;

	declare ONLINE		 fixed bin init (-2) int static options (constant);
	declare SEGMENT_NOT_FOUND	 fixed bin init (-1) int static options (constant);
	declare ENTRYPOINT_NOT_FOUND	 fixed bin init (-4) int static options (constant);
	declare SPECIAL_LINK	 fixed bin init (-3) int static options (constant);
	declare SELF_LINK		 fixed bin init (-5) int static options (constant);

	declare 1 IL_arg		 aligned,
		2 segname		 char (32) aligned,
		2 entryname	 char (33) aligned,
		2 expression	 char (8) aligned,
		2 modifier	 char (4) aligned,
		2 trap		 char (32) aligned;

	declare cep		 pointer;
	declare cx		 fixed bin;
	declare 1 chain_entry	 based (cep),
		2 next		 ptr unal,
		2 linker		 char (32) unal,
		2 link		 char (256) unal;


	declare checker_print_$error	 entry () options (variable);
	declare checker_print_$error_term
				 entry () options (variable);
	declare checker_print_	 entry () options (variable);
	declare checker_print_$page	 entry;
	declare checker_print_$skip	 entry;
	declare hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	declare ioa_		 entry () options (variable);
	declare interpret_link_$given_exp
				 entry (ptr, fixed bin (18), bit (6), ptr, fixed bin (35));
	declare hash_$opt_size	 entry (fixed bin) returns (fixed bin);
	declare hash_$in		 entry (ptr, char (*), bit (36) aligned, fixed bin (35));
	declare hash_$make		 entry (ptr, fixed bin, fixed bin (35));
	declare hash_$search	 entry (ptr, char (*), bit (36) aligned, fixed bin (35));
	declare get_definition_	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	declare get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	declare release_temp_segment_	 entry (char (*), ptr, fixed bin (35));

	declare error_table_$no_ext_sym
				 fixed bin (35) ext static;
	declare error_table_$seg_not_found
				 fixed bin (35) ext static;

	declare cleanup		 condition;
	declare htp		 pointer;
	declare (hbound, null, length, rtrim, char, substr, ptr, addr, unspec)
				 builtin;
	declare ME		 init ("checker_crossref_") int static options (constant) char (32);


	htp = null;
	on cleanup
	     begin;
		if htp ^= null ()
		then call release_temp_segment_ (ME, htp, (0));
	     end;

	call get_temp_segment_ (ME, htp, (0));
	call hash_$make (htp, hash_$opt_size (5000), (0));/* hash table to remember where we found (that we found) a given segname */

	segment_not_found_head.first, found_online_head.first, entrypoint_not_found_head.first,
	     special_link_head.first = null;

	segment_not_found_head.count, found_online_head.count, entrypoint_not_found_head.count,
	     special_link_head.count = 0;

	call checker_print_$page;
	call checker_print_ ("Begin Crossreference:");
	call checker_print_$skip;
	call ioa_ ("Begin Crossreference.");

	sltp = checker_data_$slt_ptr;
	names_ptr = checker_data_$name_table_ptr;

	call FILL_HASH_TABLE;

	do cx = 0 to hbound (meters.per_collection, 1)
	     while (meters.per_collection (cx).read & cx <= checker_data_$last_supervisor_collection);
	     if checker_data_$loaded (cx) then call COLLECTION (cx);
	end;

	call REPORT;
	call ioa_ ("Done Crossreference.");
	call release_temp_segment_ (ME, htp, (0));
	return;


COLLECTION:
     procedure (collection);
	declare collection		 fixed bin;
	declare 1 PC		 aligned like meters.per_collection defined (meters.per_collection (collection));
	declare segment_number	 fixed bin (18);

	call ioa_ ("Checking collection ^d.^d.", checker_data_$collection_names (collection).major,
	     checker_data_$collection_names (collection).minor);

	do segment_number = PC.first_segment repeat meters.per_segment (segment_number).next
	     while (segment_number ^< 0);
	     if addr (slt.seg (segment_number)) -> slte_uns.ringbrack (1) = 0
		& meters.per_segment (segment_number).link_ptr ^= null
	     then call LOOK_AT_LINKS (segment_number, (meters.per_segment (segment_number).link_ptr),
		     (meters.per_segment (segment_number).defs_ptr));
	end;
	return;
     end COLLECTION;

LOOK_AT_LINKS:
     procedure (segment_number, links_ptr, defs_ptr);
	declare segment_number	 fixed bin (18);
	declare defs_ptr		 ptr;
	declare links_ptr		 pointer;
	declare exp_relp		 fixed bin (18);
	declare modifier		 bit (6);
	declare segment_name	 char (32);
	declare lx		 fixed bin;
	declare def_section_ptr	 ptr;

	def_section_ptr = addr (defs_ptr -> segment_defs.definitions);
	segment_name = NAME (segment_number);
	segment_links_ptr = links_ptr;

	do lx = 1 to segment_links.n_links;
	     exp_relp = segment_links.expression_relps (lx);
	     modifier = segment_links.modifiers (lx);

	     call PROCESS_LINK (segment_number, segment_name, def_section_ptr, exp_relp, modifier);
	end;
     end LOOK_AT_LINKS;

PROCESS_LINK:
     procedure (segment_number, segment_name, defs_ptr, exp_relp, modifier);
	declare segment_number	 fixed bin (18);
	declare segment_name	 char (32);
	declare defs_ptr		 pointer;
	declare exp_relp		 fixed bin (18);
	declare modifier		 bit (6);
	declare link_entrypoint	 char (32);
	declare found_in_segno	 fixed bin;
	declare 1 (linking_slte, linked_slte)
				 aligned like slte_uns;
	declare link_printed_rep	 char (256);


/* Get the name that this references */

	call interpret_link_$given_exp (addr (IL_arg), exp_relp, modifier, defs_ptr, (0));

	sltep = addr (slt.seg (segment_number));
	linking_slte = slte_uns;

/* Look for the definitions */

	if substr (IL_arg.entryname, 1, 1) = "|"
	then link_entrypoint = "";
	else link_entrypoint = substr (IL_arg.entryname, 2);
	found_in_segno = SEARCH (IL_arg.segname, link_entrypoint, linking_slte.ringbrack (2) > 0);
	link_printed_rep = LINK_REP ();		/* IL_arg is global */
	if found_in_segno ^< 0
	then do;					/* hardcore segment */

		sltep = addr (slt.seg (found_in_segno));
		linked_slte = slte_uns;

		if linking_slte.temp_seg
		     & checker_data_$collection_names (meters.per_segment (found_in_segno).collection).major 
		     > checker_data_$collection_names (meters.per_segment (segment_number).collection).major
		then call checker_print_$error (CHECKER_ERROR, (0), "crossref",
			"Temp seg ^a link ^a: target is in a later collection.", segment_name, link_printed_rep);

		else if linking_slte.temp_seg & linked_slte.temp_seg
			& checker_data_$collection_names (meters.per_segment (found_in_segno).collection).major
			^= checker_data_$collection_names (meters.per_segment (segment_number).collection).major
		then call checker_print_$error (CHECKER_ERROR, (0), "crossref",
			"Temp seg ^a link ^a: target is temp segment in a different collection.", segment_name,
			link_printed_rep);

		else if linked_slte.temp_seg
			& checker_data_$collection_names (meters.per_segment (found_in_segno).collection).major
			< checker_data_$collection_names (meters.per_segment (segment_number).collection).major
		then call checker_print_$error (CHECKER_ERROR, (0), "crossref",
			"Seg ^a link ^a links to earlier temp seg.", segment_name, link_printed_rep);

/* Check for ring order here */
	     end;

	else if found_in_segno = ONLINE
	then call ADD_TO_CHAIN (segment_name, link_printed_rep, found_online_head);
	else if found_in_segno = SEGMENT_NOT_FOUND
	then call ADD_TO_CHAIN (segment_name, link_printed_rep, segment_not_found_head);
	else if found_in_segno = ENTRYPOINT_NOT_FOUND
	then call ADD_TO_CHAIN (segment_name, link_printed_rep, entrypoint_not_found_head);
	else if found_in_segno = SPECIAL_LINK
	then call ADD_TO_CHAIN (segment_name, link_printed_rep, special_link_head);
						/* other case is SELF, which is okay */

     end PROCESS_LINK;


SEARCH:
     procedure (segname, entrypoint, runs_in_user_ring) returns (fixed bin);
	declare segname		 char (*) aligned;
	declare entrypoint		 char (*);	/* "" for numeric based links */
	declare segno_in_word	 bit (36) aligned;
	declare segno		 fixed bin (35);
	declare runs_in_user_ring	 bit (1) aligned;
	declare code		 fixed bin (35);
	declare (cx, sx)		 fixed bin (18);
	declare s_ptr		 pointer;
	declare segname_u		 char (32);
	declare def_section_ptr	 pointer;
	declare searched_hardcore	 bit (1) aligned;

	searched_hardcore = "0"b;
	segname_u = segname;
	if segname_u = "*symbol" | segname_u = "*system" | segname_u = "*defs"
	then return (SPECIAL_LINK);
	else if char (segname_u, 1) = "*"
	then return (SELF_LINK);
	call hash_$search (htp, segname_u, segno_in_word, code);
	if code = 0
	then do;
		unspec (segno) = segno_in_word;
		go to HAVE_SEGNO;
	     end;

/* Try online */

SEARCH_ONLINE:
	call hcs_$make_ptr (null (), segname_u, entrypoint, s_ptr, code);
	if s_ptr ^= null
	then return (ONLINE);
	else do;
		if code = error_table_$no_ext_sym | searched_hardcore
						/* return original error */
		then return (ENTRYPOINT_NOT_FOUND);
		else return (SEGMENT_NOT_FOUND);
	     end;

HAVE_SEGNO:
	if entrypoint = ""
	then return (segno);			/* easy enough */

	sx = segno;
	if meters.per_segment (sx).defs_ptr = null
	then go to NO_ENTRYPOINT;

	def_section_ptr = addr (meters.per_segment (sx).defs_ptr -> segment_defs.definitions);

	call get_definition_ (def_section_ptr, segname_u, entrypoint, (null), code);
	if code ^= 0
	then
NO_ENTRYPOINT:
	     do;
		if ^runs_in_user_ring | searched_hardcore
		then return (ENTRYPOINT_NOT_FOUND);
		else do;
			searched_hardcore = "1"b;
			go to SEARCH_ONLINE;
		     end;
	     end;
	return (segno);
     end SEARCH;


NAME:
     procedure (s) returns (char (32)) reducible;
	declare s			 fixed bin (18);
	return (ptr (checker_data_$name_table_ptr, addr (slt.seg (s)) -> slte_uns.names_ptr) -> segnam.names (1).name);
     end NAME;

LINK_REP:
     procedure returns (char (256));

	declare arep		 char (256);

	arep = rtrim (IL_arg.segname) || rtrim (IL_arg.entryname) || rtrim (IL_arg.expression)
	     || rtrim (IL_arg.modifier) || " " || IL_arg.trap;
	return (arep);
     end LINK_REP;

ADD_TO_CHAIN:
     procedure (sn, lrep, head);
	declare sn		 char (*);	/* segment name making the link */
	declare lrep		 char (256);	/* the link offending */
	declare 1 head		 aligned like list_head;
						/* the chain */
	declare new_cep		 ptr;
	declare prev_cep		 ptr;

	allocate chain_entry in (checker_area) set (new_cep);
	new_cep -> chain_entry.linker = sn;
	new_cep -> chain_entry.link = lrep;
	new_cep -> chain_entry.next = null;

	head.count = head.count + 1;
	if head.first = null
	then do;
		head.first = new_cep;
		return;
	     end;

	prev_cep = null;
	do cep = head.first repeat chain_entry.next while (cep ^= null);
	     if sn < chain_entry.linker
	     then
INSERT:
		do;				/* insert here */
		     new_cep -> chain_entry.next = cep;
		     if prev_cep = null		/* to beginning */
		     then head.first = new_cep;
		     else prev_cep -> chain_entry.next = new_cep;
		     return;
		end;
	     else if sn = chain_entry.linker
	     then do;				/* look for multiples on this segname */
		     do cep = cep repeat chain_entry.next while (cep ^= null);
			if lrep < chain_entry.link
			then go to INSERT;
			if sn ^= chain_entry.linker
			then go to INSERT;		/* last on this segname */
			prev_cep = cep;
		     end;
		     go to OFF_END;
		end;
	     prev_cep = cep;
	end;


OFF_END:						/* prev_cep -> last one */
	prev_cep -> chain_entry.next = new_cep;
     end ADD_TO_CHAIN;


REPORT:
     procedure;

	if entrypoint_not_found_head.count > 0
	then do;
		call THROW;
		call checker_print_$error (CHECKER_SEVERE, (0), "crossref",
		     "Links exist to entrypoints not defined.");
		call checker_print_$skip;

		call PRINT_CHAIN (entrypoint_not_found_head.first, CHECKER_ERROR, error_table_$no_ext_sym);
	     end;

	if segment_not_found_head.count > 0
	then do;
		call THROW;
		call checker_print_$error (CHECKER_SEVERE, (0), "crossref", "Links exist to segments not found.");
		call checker_print_$skip;

		call PRINT_CHAIN (segment_not_found_head.first, CHECKER_ERROR, error_table_$seg_not_found);
	     end;

	if found_online_head.count > 0
	then do;
		call THROW;
		call checker_print_$error (CHECKER_WARNING, (0), "crossref",
		     "Links exist to segments found only online.");
		call checker_print_$skip;

		call PRINT_CHAIN (found_online_head.first, 0, 0);
	     end;

	if special_link_head.count > 0
	then do;
		call THROW;
		call checker_print_$error (CHECKER_WARNING, (0), "crossref",
		     "Links exist to special ""*"" segnames.");
		call checker_print_$skip;

		call PRINT_CHAIN (special_link_head.first, 0, 0);
	     end;
	return;

THROW:
     procedure;
	call checker_print_$page;
	call checker_print_$skip;
     end THROW;

PRINT_CHAIN:
     procedure (first_cep, severity, code);
	declare first_cep		 ptr unal;
	declare last_s		 char (32);
	declare severity		 fixed bin;
	declare code		 fixed bin (35);
	declare line		 char (136);
	declare column		 fixed bin;

	line = "";
	column = 1;
	last_s = "";
	do cep = first_cep repeat chain_entry.next while (cep ^= null);
	     if chain_entry.linker ^= last_s
	     then do;
		     if column > 1
		     then call checker_print_ ("^a", line);
						/* leftovers */
		     call checker_print_$skip;
		     call checker_print_ ("^a", chain_entry.linker);
		     line = "";
		     column = 1;
		end;

	     last_s = chain_entry.linker;
	     if length (rtrim (chain_entry.link)) <= length (line) - column + 1
	     then begin;
		     declare next		      char (length (rtrim (chain_entry.link)) + 1)
					      defined (line) position (column);
		     next = chain_entry.link;
		     column = column + length (next);
		end;
	     else do;
		     call checker_print_ ("^a", line);
		     column = length (rtrim (chain_entry.link)) + 2;
		     line = chain_entry.link;
		end;
	     if severity > 0
	     then call checker_print_$error_term (severity, code, "", "^a links to ^a.", chain_entry.linker,
		     chain_entry.link);


	end;
	if column > 1
	then call checker_print_ ("^a", line);		/* leftovers */
     end PRINT_CHAIN;
     end REPORT;

FILL_HASH_TABLE:
     procedure;
	declare sx		 fixed bin (18);
	declare nx		 fixed bin;
	do sx = slt.first_sup_seg to slt.last_sup_seg, slt.first_init_seg to slt.last_init_seg;
	     namep = ptr (checker_data_$name_table_ptr, addr (slt.seg (sx)) -> slte_uns.names_ptr);
	     do nx = 1 to segnam.count;
		call hash_$in (htp, segnam.names (nx).name, unspec (sx), (0));
	     end;
	end;
     end FILL_HASH_TABLE;

     end checker_crossref_;




		    checker_data_.cds               07/16/87  1350.1r   07/15/87  1601.9       33291



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Bull Inc., 1987                *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */





/* HISTORY COMMENTS:
  1) change(87-01-13,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for storing boot program as first segment of MST image stored
     in a file.
                                                   END HISTORY COMMENTS */


/* CHECKER_DATA_ -- static data for the MST checker subsystem */
/* The bulk of the data is actually kept in a temporary area */
/* found by a pointer here. Needless to say, the checker is */
/* nonrecursive. */
/* Modified December 1983 by Keith Loepere for collections that aren't 
   loaded into segments and other subtleties. */
/* Modified January 1985 by Keith Loepere so that collection 3 isn't
   claimed to take up defintions_, etc. */
/* format: style3,idind30 */

checker_data_:
     proc;

dcl	1 cdsa			like cds_args auto aligned;

dcl	1 checker_stat		aligned auto,
	  2 input_iocbp		ptr,		/* checker input switch */
	  2 output_iocbp		ptr,		/* checker output switch */
	  2 temp_ptrs		bit (0),		/* Look at all the following as an array for g_t_segments_ */
	  2 slt_ptr		bit (0),		/* simulated SLT (sslt) */
	  2 sslt_ptr		ptr init (null ()),
	  2 area_ptr		ptr init (null ()), /* area in which most static data is put */
	  2 name_table_ptr		bit (0),		/* simulated name_table */
	  2 sname_table_ptr		ptr init (null ()),
	  2 buffer_ptr		ptr init (null ()), /* Tape reader buffer */
	  2 meter_ptr		ptr init (null ()), /* big structure of checker meters */
	  2 severity		fixed bin,	/* worst error encountered */
	  2 file_attachment		bit (1) init ("0"b);/* MST is a file. */

dcl	1 checker_text		aligned,
	  2 last_wired_collection	fixed bin init (4), /* make_segs_paged runs here, paging defs, etc. */
	  2 last_text_wired_collection
				fixed bin init (2), /* after this, text is not loaded directly into memory */
	  2 last_supervisor_collection
				fixed bin init (5), /* after this load into >sl1 */
	  2 collection_names	(0:10) aligned,
	    3 major		fixed bin init (0, 0, 1, 1, 1, 2, 3, (4) 0),
	    3 minor		fixed bin init (0, 5, 0, 2, 5, 0, 0, (4) 0),
	  2 loaded		(0:10) bit (1) aligned
				init ("1"b, "0"b, "1"b, "0"b, "1"b, "1"b, "0"b, (4) (1)"0"b),
						/* objects in collection are loaded into segments */
	  2 n_temp_ptrs		fixed bin init (4);

dcl	code			fixed bin (35);
dcl	create_data_segment_	entry (ptr, fixed bin (35));
dcl	com_err_			entry options (variable);

dcl	(addr, size, string)	builtin;

%page;

%include cds_args;

	cdsa.sections (1).p = addr (checker_text);
	cdsa.sections (1).len = size (checker_text);
	cdsa.sections (1).struct_name = "checker_text";

	cdsa.sections (2).p = addr (checker_stat);
	cdsa.sections (2).len = size (checker_stat);
	cdsa.sections (2).struct_name = "checker_stat";

	cdsa.seg_name = "checker_data_";

	cdsa.num_exclude_names = 0;

	string (cdsa.switches) = "0"b;
	cdsa.switches.have_static = "1"b;
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), code);

	if code ^= 0
	then call com_err_ (code, "checker_data_");

	return;
     end checker_data_;




		    checker_init_meters_.pl1        06/04/84  1601.8rew 06/04/84  1242.1       12267



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: style2 */

checker_init_meters_:
     procedure;

/* Put appropriate values in checker_data_$meters_ptr -> meters */
/* BIM 8/82 */

%include checker_dcls_;
%include hc_definitions_seg;

	declare cx		 fixed bin;
	declare sx		 fixed bin;
	declare (currentsize, hbound, lbound, null, unspec)
				 builtin;
	declare 1 auto_definitions_	 aligned like definitions;


	allocate meters in (checker_area);

	unspec (meters) = ""b;			/* zero, presumptively */

	meters.sizes = -1;
	meters.wired_definitions_used, meters.paged_definitions_used = currentsize (auto_definitions_);
						/* count in the DOT */

	do cx = lbound (meters.per_collection, 1) to hbound (meters.per_collection, 1);
	     meters.per_collection (cx).first_segment, meters.per_collection.last_segment = -1;
	end;
	do sx = lbound (meters.per_segment, 1) to hbound (meters.per_segment, 1);
	     meters.per_segment (sx).link_ptr = null;
	     meters.per_segment (sx).defs_ptr = null;
	     meters.per_segment (sx).next = -1;
	end;

	return;
     end checker_init_meters_;




		    checker_load_MST_.pl1           07/16/87  1350.1r   07/15/87  1602.4      351594



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-01-13,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for storing boot program as first segment of MST image stored
     in a file.
                                                   END HISTORY COMMENTS */


/* checker_load_MST_.pl1 -- eat an entire Multics system tape */
/* format: style2 */
/* BIM 8/82, bugfix to linkage sections 11/82 */
/* Modified by Keith Loepere to handle collections in which objects aren't 
   loaded into segments. */
/* Modified 3/84 by Keith Loepere for "unpaged segs" and bugfixes. */
/* Modified 1/85 by Keith Loepere to really understand unloaded collections. */

checker_load_MST_:
     procedure;


/* This program reads an MST, building the data structure */
/* needed to do a crossreference later. As it goes, it checks */
/* for a variety of errors. Emphasis is given to errors made */
/* be the preparer of the header file, RATHER than on generate_mst */
/* gratuitously screwing up. Useful data on each segment is printed, */
/* and serious errors (overflowed segments) produce com_err_ calls. */

/* We expect tape_reader_ to signal MST_tape_eof_ if it runs out of */
/* tape. */

	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));

	dcl     checker_print_	 entry options (variable);
	dcl     checker_print_$error	 entry options (variable);
	dcl     checker_print_$skip	 entry;
	dcl     checker_print_$page	 entry;
	dcl     ioa_		 entry () options (variable);
	dcl     tape_reader_	 entry (ptr, fixed bin (18));
	dcl     sslt_manager_$build_entry
				 entry (ptr, ptr, fixed bin (17));
	dcl     sslt_manager_$get_seg_num
				 entry (char (32), fixed bin (18), fixed bin (35));
	dcl     object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35));

	dcl     com_err_		 entry () options (variable);
	dcl     error_table_$namedup	 fixed bin (35) ext static;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     ME		 char (32) init ("checker_load_MST_") int static options (constant);

	dcl     (addr, addrel, after, baseno, before, bin, char, currentsize, divide, hbound, index, max, min, ptr,
	        substr, sum, unspec, size)
				 builtin;


	dcl     collection_started	 bit (1) aligned;
	dcl     header_ptr		 pointer;
	dcl     header_area		 (1000) bit (36) aligned;
	dcl     HEADER_MAX_SIZE	 fixed bin init (1000) int static options (constant);


	declare 1 control_word	 aligned,
		2 type		 fixed bin (18) uns unal,
		2 count		 fixed bin (18) uns unal;

	declare 1 collection_mark	 aligned,
		2 major		 fixed bin (18) uns unal,
		2 minor		 fixed bin (18) uns unal;

	declare (
	        SEGMENT		 init (1),
	        HEADER		 init (0),
	        COLLECTION_MARK	 init (2)
	        )			 fixed bin (18) uns int static options (constant);

/* format: off */
%page; %include slt;
%page; %include slte;
%page; %include object_link_dcls;
%page; %include definition_dcls;
%page; %include checker_dcls_;
%page; %include object_info;
%page; %include tape_mult_boot_info;
/* format: on */

	dcl     1 oi		 aligned like object_info;

	dcl     1 cur_slte		 aligned like slte_uns;
	dcl     Collection		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     hc_seg_ptr		 ptr;
	dcl     segment_name	 character (32);
	dcl     segment_number	 fixed bin (18);
	dcl     nx		 fixed bin;
	dcl     (first, second, third) char (32);
	dcl     MST_tape_eof_	 condition;
%page;

	sltp = checker_data_$slt_ptr;			/* pointer to simulated slt */
	names_ptr = checker_data_$name_table_ptr;

	sltep, header_ptr = addr (header_area);
	namep = addrel (header_ptr, size (slte));	/* SLT entry is 4 words long */


	call CHECK_BOOTABLE_LABEL;


/* First, report on the collection 0 segments. Trust the data that */
/* sslt_init_ put in the slt for bound_bootload_1 */


	call checker_print_ ("Begin collection 0.0:");
	meters.per_collection (0).read = "1"b;

	Collection = 0;

/* The first control word :: the header for BBL1 */

	call Read_Control_Word;
	if control_word.type ^= HEADER
	then call checker_print_$error (CHECKER_FATAL, (0), "tape format", "Tape does not begin with header record.");

	call tape_reader_ (addr (header_area), (control_word.count));
						/* take the header */
	do segment_number = slt.first_sup_seg to slt.last_sup_seg;
	     call checker_print_$skip;
	     call PROCESS_SLTE (segment_number);	/* do for slte data */
	end;
	do segment_number = slt.first_init_seg to slt.last_init_seg;
	     call checker_print_$skip;
	     call PROCESS_SLTE (segment_number);	/* ditto */
	end;

	call checker_print_$skip;
	call checker_print_ ("End collection 0.0");

	call COLLECTION_SUMMARY;


/* Read in the first segment, which has already been described by the */
/* collection 0 template. This code could be expanded to check if */
/* it bears some reasonable resemblance to the template. */

	call Read_Control_Word;			/* Control word for first seg */
	call tape_reader_ (checker_data_$buffer_ptr, (control_word.count));

/* Fine, preliminaries are set */

	on MST_tape_eof_ go to NO_MORE_COLLECTIONS;

	do while ("1"b);
	     Collection = Collection + 1;
	     if Collection > hbound (meters.per_collection, 1)
	     then do;
		     call com_err_ (code, ME, "More than ^d collections.", Collection - 1);
		     return;
		end;
	     call LOAD_ONE_COLLECTION;
	     call COLLECTION_SUMMARY;
	end;

NO_MORE_COLLECTIONS:
	call TOTAL_SUMMARY;
	return;					/* Let our caller move on to the cref */
%page;
LOAD_ONE_COLLECTION:
     procedure;

	declare expect_link		 bit (1) aligned;
	declare expect_defs		 bit (1) aligned;
	declare 1 prev_slte		 aligned like slte_uns;
	declare text_segment_number	 fixed bin (18);

	unspec (prev_slte) = ""b;
	expect_link, expect_defs = "0"b;
	text_segment_number = -1;
	collection_started = "0"b;


LOAD_LOOP:
	call Read_Control_Word;


/* Allow EOF to take on last collection */

	if ^collection_started
	then do;
		meters.per_collection (Collection).read = "1"b;
		call checker_print_$page;
		call checker_print_ ("Begin collection ^d.^d: ^[WIRED ENVIROMNENT^]",
		     checker_data_$collection_names (Collection).major,
		     checker_data_$collection_names (Collection).minor,
		     Collection <= checker_data_$last_wired_collection);
		collection_started = "1"b;
	     end;

	call checker_print_$skip;

	if control_word.type = COLLECTION_MARK
	then do;
		if expect_link | expect_defs
		then do;
			call checker_print_$error (CHECKER_SEVERE, (0), "tape format",
			     " Collection ended without expected ^[definitions^;linkage^] segment.", expect_link);
		     end;
		if control_word.count ^= 1
		then call checker_print_$error (CHECKER_FATAL, (0), "tape format",
			"Collection mark not one word long.");

		call tape_reader_ (addr (collection_mark), (control_word.count));
		if collection_mark.major ^= checker_data_$collection_names (Collection).major
		     | collection_mark.minor ^= checker_data_$collection_names (Collection).minor
		then call checker_print_$error (CHECKER_WARNING, (0), "collection mark",
			"Collection ^d.^d ended with mark ^d.^d.",
			checker_data_$collection_names (Collection).major,
			checker_data_$collection_names (Collection).minor, collection_mark.major,
			collection_mark.minor);

		meters.per_collection (Collection).mark.major = collection_mark.major;
		meters.per_collection (Collection).mark.minor = collection_mark.minor;
		call checker_print_ ("Collection mark ^d.^d", collection_mark.major, collection_mark.minor);
		call ioa_ ("Read collection ^d.^d", collection_mark.major, collection_mark.minor);

		return;
	     end;

	else if control_word.type ^= HEADER
	then call checker_print_$error (CHECKER_FATAL, (0), "tape format",
		"Segment ^a was not followed by a header record.", segment_name);

/* Process header record */

	if (control_word.count > HEADER_MAX_SIZE) | (control_word.count < 4)
	then call checker_print_$error (CHECKER_FATAL, (0), "tape format", "Header size ^d unreasonable.",
		control_word.count);

/* So far, a well-formed tape */

/* Check in a segment */

	call tape_reader_ (addr (header_area), (control_word.count));

	cur_slte = addr (header_area) -> slte_uns;

/* check for duplicated segment names */
	segment_name = segnam.names (1).name;		/* primary name */

	if checker_data_$loaded (Collection)
	then do nx = 1 to segnam.count;
		call sslt_manager_$get_seg_num (segnam.names (nx).name, segment_number, code);
		if code = 0
		then call checker_print_$error (CHECKER_SEVERE, error_table_$namedup, "segment_name",
			"Name ^a already on seg # ^o", segnam.names (nx).name, segment_number);
	     end;

/* Now get control word for seg itself */

	call Read_Control_Word;

	if control_word.type ^= SEGMENT
	then call checker_print_$error (CHECKER_FATAL, (0), segment_name, "Segment header not followed by contents.");

	if ^checker_data_$loaded (Collection)		/* object is specially handled */
	then do;
		call PROCESS_SPECIAL_SLTE (addr (header_area));
		call tape_reader_ (checker_data_$buffer_ptr, (control_word.count));
		go to LOAD_LOOP;
	     end;

	if ^cur_slte.defs & ^(cur_slte.link_sect & prev_slte.combine_link)
	then do;					/* If a segment is to be created ... */
		call sslt_manager_$build_entry (addr (header_area), hc_seg_ptr, (0));

		segment_number = bin (baseno (hc_seg_ptr), 18);
		call PROCESS_SLTE (segment_number);	/* classify and record */
						/* and set cur_slte to be the version slt_manager_ cooked up */
	     end;

/* now see what sort of beast */

	if cur_slte.firmware_seg
	then do;
		call tape_reader_ (checker_data_$buffer_ptr, (control_word.count));
		go to LOAD_LOOP;
	     end;

	if cur_slte.link_sect			/* somebodies linkage */
	then do;
		if ^expect_link			/* orphan linkage ? */
		then call checker_print_$error (CHECKER_FATAL, (0), "tape format", "Unexpected linkage section ^a.",
			segment_name);

		expect_link = "0"b;
		expect_defs = "1"b;			/* just as night follows day */

		if prev_slte.combine_link		/* this is to be combined */
		then call ENTER_COMBINED_LINKAGE;
		else call ENTER_UNCOMBINED_LINKAGE;
	     end;

	else if cur_slte.defs
	then do;
		if ^expect_defs
		then call checker_print_$error (CHECKER_FATAL, (0), "tape format", "Unexpected definitions seg ^a.",
			segment_name);

		call ENTER_DEFINITIONS;
		expect_defs = "0"b;
	     end;

	else do;					/* A text section, by george */
		if expect_link | expect_defs
		then call checker_print_$error (CHECKER_FATAL, (0), "tape format", "Unexpected text section ^a.",
			segment_name);


		expect_link = cur_slte.link_provided;

		call ENTER_TEXT;
		text_segment_number = segment_number;
	     end;
	prev_slte = cur_slte;
	go to LOAD_LOOP;
%page;
ENTER_TEXT:
     procedure;

	call tape_reader_ (checker_data_$buffer_ptr, (control_word.count));
						/* skip it, at least */

	if cur_slte.ringbrack (1) = 0			/* hardcore segments have no linkage, or linkage */
						/* stripped off */
	then return;

/* For user ring segments, the linkage and defs are still in the segment */

	if cur_slte.bit_count ^= (control_word.count * 36)/* match? */
	then return;

	oi.version_number = object_info_version_2;
	call object_info_$brief (checker_data_$buffer_ptr, (cur_slte.bit_count), addr (oi), code);
	if code = 0
	then do;
		call PROCESS_LINKAGE (segment_number, oi.linkp, (oi.llng));
		call PROCESS_DEFS (segment_number, oi.defp, (oi.dlng));
	     end;

     end ENTER_TEXT;
%page;
ENTER_COMBINED_LINKAGE:
     procedure;

/* See what linkage section is in question */

	if /* tree */ prev_slte.link_sect_wired
	then if prev_slte.init_seg
	     then do;				/* WI linkage */
		     if Collection <= checker_data_$last_wired_collection
		     then do;
			     meters.wired_wi_linkage_used = meters.wired_wi_linkage_used + control_word.count;
			     call CHECK (meters.wired_wi_linkage_size, meters.wired_wi_linkage_used, "1"b /*wired*/,
				"wi_linkage", meters.overflown.wired_wi_linkage);
			end;
		     meters.paged_wi_linkage_used = meters.paged_wi_linkage_used + control_word.count;
		     call CHECK (meters.paged_wi_linkage_size, meters.paged_wi_linkage_used, "0"b, "wi_linkage",
			meters.overflown.paged_wi_linkage);
		     meters.per_collection (Collection).wi_linkage_used =
			meters.per_collection (Collection).wi_linkage_used + control_word.count;
		end;
	     else do;				/* WS linkage */
		     if Collection <= checker_data_$last_wired_collection
		     then do;
			     meters.wired_ws_linkage_used = meters.wired_ws_linkage_used + control_word.count;
			     call CHECK (meters.wired_ws_linkage_size, meters.wired_ws_linkage_used, "1"b,
				"ws_linkage", meters.overflown.wired_ws_linkage);
			end;

		     meters.paged_ws_linkage_used = meters.paged_ws_linkage_used + control_word.count;
		     call CHECK (meters.paged_ws_linkage_size, meters.paged_ws_linkage_used, "0"b, "ws_linkage",
			meters.overflown.paged_ws_linkage);
		     meters.per_collection (Collection).ws_linkage_used =
			meters.per_collection (Collection).ws_linkage_used + control_word.count;
		end;
	else if prev_slte.init_seg			/* AI linkage */
	     then do;
		     if Collection <= checker_data_$last_wired_collection
		     then do;
			     meters.wired_ai_linkage_used = meters.wired_ai_linkage_used + control_word.count;
			     call CHECK (meters.wired_ai_linkage_size, meters.wired_ai_linkage_used, "1"b,
				"ai_linkage", meters.overflown.wired_ai_linkage);
			end;
		     meters.paged_ai_linkage_used = meters.paged_ai_linkage_used + control_word.count;
		     call CHECK (meters.paged_ai_linkage_size, meters.paged_ai_linkage_used, "0"b, "ai_linkage",
			meters.overflown.paged_ai_linkage);
		     meters.per_collection (Collection).ai_linkage_used =
			meters.per_collection (Collection).ai_linkage_used + control_word.count;
		end;
	     else do;				/* AS linkage */
		     if Collection <= checker_data_$last_wired_collection
		     then do;
			     meters.wired_as_linkage_used = meters.wired_as_linkage_used + control_word.count;
			     call CHECK (meters.wired_as_linkage_size, meters.wired_as_linkage_used, "1"b,
				"as_linkage", meters.overflown.wired_as_linkage);
			end;
		     meters.paged_as_linkage_used = meters.paged_as_linkage_used + control_word.count;
		     call CHECK (meters.paged_as_linkage_size, meters.paged_as_linkage_used, "1"b, "as_linkage",
			meters.overflown.paged_ai_linkage);
		     meters.per_collection (Collection).as_linkage_used =
			meters.per_collection (Collection).as_linkage_used + control_word.count;
		end;

ENTER_UNCOMBINED_LINKAGE:
     entry;

	call tape_reader_ (checker_data_$buffer_ptr, (control_word.count));
	checker_data_$buffer_ptr -> linkage_header.segment_number = text_segment_number;
	call PROCESS_LINKAGE (text_segment_number, checker_data_$buffer_ptr, (control_word.count));
	return;
%page;
CHECK:
     procedure (limit, amount, paged, name, printed);
	declare limit		 fixed bin;
	declare amount		 fixed bin;
	declare paged		 bit (1) aligned;
	declare name		 char (32);
	declare printed		 bit (1) unaligned;

	if limit < 0
	then return;				/* as yet unknown */
	if amount < limit
	then return;				/* clear */

	if ^printed
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
		" ^[PAGED^;WIRED^] ^a OVERFLOW. Increase ^[max_length^;cur_length^] of ^a.", paged, name, paged, name)
		;
	else printed = "1"b;
     end CHECK;

     end ENTER_COMBINED_LINKAGE;
%page;
ENTER_DEFINITIONS:
     procedure;

	if Collection <= checker_data_$last_wired_collection
	then meters.wired_definitions_used = meters.wired_definitions_used + control_word.count;
	meters.paged_definitions_used = meters.paged_definitions_used + control_word.count;
	meters.per_collection (Collection).definitions_used =
	     meters.per_collection (Collection).definitions_used + control_word.count;
	if meters.wired_definitions_size > 0
	then if Collection <= checker_data_$last_wired_collection
	     then if meters.wired_definitions_used > meters.wired_definitions_size
		then do;
			if ^meters.overflown.wired_definitions
			then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
				" WIRED DEFINITIONS OVERFLOW. Increase cur_length for definitions_");
			meters.overflown.wired_definitions = "1"b;
		     end;
		else ;
	     else if meters.paged_definitions_used > meters.paged_definitions_size
	     then do;
		     if ^meters.overflown.paged_definitions
		     then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
			     " PAGED DEFINITIONS OVERFLOW. Increase max_length of definitions_.");
		     meters.overflown.paged_definitions = "1"b;
		end;

	call tape_reader_ (checker_data_$buffer_ptr, (control_word.count));
	call PROCESS_DEFS (text_segment_number, checker_data_$buffer_ptr, (control_word.count));
     end ENTER_DEFINITIONS;
%page;
PROCESS_LINKAGE:
     procedure (segment_number, link_ptr, links_length);

	declare segment_number	 fixed bin (18);
	declare link_ptr		 pointer;
	declare links_ptr		 pointer;
	declare links_length	 fixed bin (18) uns;
	declare links_count		 fixed bin;
	declare lx		 fixed bin;
	declare section_length	 fixed bin;


	section_length = min (links_length, link_ptr -> virgin_linkage_header.linkage_section_lng);

	if section_length ^> size (virgin_linkage_header)
	then return;

	links_count = divide (section_length, 2, 17, 0);	/* 2 words each */

	if links_count = 0
	then return;

/* and see if the count we have is good */

	links_ptr = addrel (link_ptr, link_ptr -> linkage_header.begin_links);
	begin;
	     declare 1 links	      (1:links_count) aligned like object_link based (links_ptr);
	     do lx = 1 to links_count;
		if links (lx).tag ^= "46"b3 | links (lx).mbz ^= "0"b | links (lx).mbz2 ^= "0"b
		then do;
			links_count = lx - 1;
			goto COUNTED;
		     end;
	     end;
COUNTED:
	end;

	a_n_links = links_count;
	allocate segment_links in (checker_area);
	unspec (segment_links.per_link) = ""b;

	begin;
	     declare 1 links	      (1:links_count) aligned like object_link based (links_ptr);
	     do lx = 1 to links_count;
		segment_links.expression_relps (lx) = links (lx).expression_relp;
		segment_links.modifiers (lx) = links (lx).modifier;
	     end;
	end;
	meters.per_segment (segment_number).link_ptr = segment_links_ptr;
     end PROCESS_LINKAGE;
%page;
PROCESS_DEFS:
     procedure (segno, defs_ptr, defs_length);
	declare defs_ptr		 pointer;
	declare defs_length		 fixed bin (18) uns;
	declare dptr		 pointer;
	declare segno		 fixed bin (18);

	a_defs_length = defs_length;
	allocate segment_defs in (checker_area);

	dptr = addr (segment_defs.definitions);
	begin;
	     declare to		      (defs_length) bit (36) aligned based (dptr);
	     declare from		      (defs_length) bit (36) aligned based (defs_ptr);
	     to = from;
	end;
	meters.per_segment (segno).defs_ptr = segment_defs_ptr;
     end PROCESS_DEFS;
     end LOAD_ONE_COLLECTION;
%page;
PROCESS_SLTE:
     procedure (p_segment_number);
	declare p_segment_number	 fixed bin (18);
	declare p_sltep		 ptr;

	declare segment_number	 fixed bin (18);
	declare this_sltep		 ptr;
	declare 1 this_slte		 aligned like slte_uns based (this_sltep);
	declare this_namep		 ptr;
	declare this_pathp		 ptr;
	declare this_aclp		 ptr;
	declare a_name		 char (32);
	declare next_name		 fixed bin;
	declare aclx		 fixed bin;

	declare (word_length, wired_length)
				 fixed bin (19);
	declare paged_length	 fixed bin;

	segment_number = p_segment_number;
	this_sltep = addr (slt.seg (segment_number));
	this_namep = ptr (checker_data_$name_table_ptr, this_slte.names_ptr);
	if this_sltep -> slte.branch_required
	then do;
		this_pathp = ptr (checker_data_$name_table_ptr, this_slte.path_ptr);
		this_aclp = addr (this_pathp -> path.acls);
	     end;

	call REPORT_SEGMENT;

/* meter this object */

	meters.per_collection (Collection).segment_count = meters.per_collection (Collection).segment_count + 1;
	if Collection <= checker_data_$last_wired_collection
	then do;
		meters.wired_sdw_count = meters.wired_sdw_count + 1;
		meters.wired_slte_count = meters.wired_slte_count + 1;
		meters.wired_nt_used = meters.wired_nt_used + currentsize (this_namep -> segnam);
		if this_slte.branch_required
		then meters.wired_nt_used = meters.wired_nt_used + currentsize (this_pathp -> path);
		if this_slte.acl_provided
		then meters.wired_nt_used = meters.wired_nt_used + currentsize (this_aclp -> acls) - 1;
						/* overlaps path */

		if meters.wired_nt_size > 0
		then if meters.wired_nt_used > meters.wired_nt_size
		     then do;
			     if ^meters.overflown.wired_nt
			     then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
				     " WIRED NAME_TABLE OVERFLOW. Increase cur_length of name_table in template_slt_.cds"
				     );
			     meters.overflown.wired_nt = "1"b;
			end;
	     end;
	else do;
		meters.paged_sdw_count = meters.paged_sdw_count + 1;
		meters.paged_slte_count = meters.paged_slte_count + 1;
		meters.paged_nt_used = meters.paged_nt_used + currentsize (this_namep -> segnam);
		if this_slte.branch_required
		then meters.paged_nt_used = meters.paged_nt_used + currentsize (this_pathp -> path);
		if this_slte.acl_provided
		then meters.paged_nt_used = meters.paged_nt_used + currentsize (this_aclp -> acls) - 1;
						/* overlaps path */
		if meters.paged_nt_size > 0
		then if meters.paged_nt_used > meters.paged_nt_size
		     then do;
			     if ^meters.overflown.paged_nt
			     then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
				     " PAGED NAME_TABLE OVERFLOW. Increase max_length of name_table in template_slt_.cds"
				     );
			     meters.overflown.paged_nt = "1"b;
			end;
	     end;

	if Collection <= checker_data_$last_text_wired_collection
	then if ^this_slte.layout_seg			/* not taken from free pool */
	     then meters.per_collection (Collection).words_used =
		     meters.per_collection (Collection).words_used + wired_length;

	meters.per_collection (Collection).name_table_used =
	     meters.per_collection (Collection).name_table_used + currentsize (this_namep -> segnam);
	if this_slte.branch_required
	then meters.per_collection (Collection).name_table_used =
		meters.per_collection (Collection).name_table_used + currentsize (this_pathp -> path);
	if this_slte.acl_provided
	then meters.name_table_used = meters.name_table_used + currentsize (this_aclp -> acls) - 1;

	if this_slte.paged
	then meters.per_collection (Collection).pages_used =
		meters.per_collection (Collection).pages_used + paged_length;

	if this_slte.wired & this_slte.paged
	then meters.per_collection (Collection).wired_pages_used =
		meters.per_collection (Collection).wired_pages_used + paged_length;

	if this_slte.temp_seg
	then meters.per_collection (Collection).temp_segment_count =
		meters.per_collection (Collection).temp_segment_count + 1;

	else if this_slte.init_seg
	then meters.per_collection (Collection).init_segment_count =
		meters.per_collection (Collection).init_segment_count + 1;

	else meters.per_collection (Collection).perm_segment_count =
		meters.per_collection (Collection).perm_segment_count + 1;

	if this_slte.ringbrack (1) > 0
	then do;
		meters.per_collection (Collection).user_ring_segment_count =
		     meters.per_collection (Collection).user_ring_segment_count + 1;
		meters.per_collection (Collection).user_ring_segment_pages =
		     meters.per_collection (Collection).user_ring_segment_pages + paged_length;
	     end;

	if meters.per_collection (Collection).first_segment = -1
	then meters.per_collection (Collection).last_segment, meters.per_collection (Collection).first_segment =
		segment_number;
	else do;
		meters.per_segment (meters.per_collection (Collection).last_segment).next = segment_number;
		meters.per_collection (Collection).last_segment = segment_number;
	     end;

	meters.per_segment (segment_number).collection = Collection;

	call INTERESTING_SEGMENT;
	return;
%page;
PROCESS_SPECIAL_SLTE:
     entry (p_sltep);

	this_sltep = p_sltep;
	this_namep = addrel (this_sltep, size (slte));
	if this_sltep -> slte.branch_required
	then do;
		this_pathp = addrel (this_namep, currentsize (this_namep -> segnam));
		this_aclp = addr (this_pathp -> path.acls);
	     end;

	call REPORT_SEGMENT;

/* meter this object */

	meters.per_collection (Collection).segment_count = meters.per_collection (Collection).segment_count + 1;
	if Collection <= checker_data_$last_wired_collection
	then meters.per_collection (Collection).words_used =
		meters.per_collection (Collection).words_used + wired_length;

	if this_slte.paged
	then meters.per_collection (Collection).pages_used =
		meters.per_collection (Collection).pages_used + paged_length;

	if this_slte.wired & this_slte.paged
	then meters.per_collection (Collection).wired_pages_used =
		meters.per_collection (Collection).wired_pages_used + paged_length;

	if Collection <= checker_data_$last_supervisor_collection
	then meters.per_collection (Collection).temp_segment_count =
		meters.per_collection (Collection).temp_segment_count + 1;

	else meters.per_collection (Collection).perm_segment_count =
		meters.per_collection (Collection).perm_segment_count + 1;

	if this_slte.ringbrack (1) > 0
	then do;
		meters.per_collection (Collection).user_ring_segment_count =
		     meters.per_collection (Collection).user_ring_segment_count + 1;
		meters.per_collection (Collection).user_ring_segment_pages =
		     meters.per_collection (Collection).user_ring_segment_pages + paged_length;
	     end;
	return;
%page;
INTERESTING_SEGMENT:
     procedure;

/* See if this segment is one whose size is a limiter */
/* use the global "segment_name" for comparisons */

	if segment_name = "ai_linkage"
	then call SIZES (meters.wired_ai_linkage_size, meters.paged_ai_linkage_size);
	else if segment_name = "as_linkage"
	then call SIZES (meters.wired_as_linkage_size, meters.paged_as_linkage_size);
	else if segment_name = "wi_linkage"
	then call SIZES (meters.wired_wi_linkage_size, meters.paged_wi_linkage_size);
	else if segment_name = "ws_linkage"
	then call SIZES (meters.wired_ws_linkage_size, meters.paged_ws_linkage_size);
	else if segment_name = "definitions_"
	then call SIZES (meters.wired_definitions_size, meters.paged_definitions_size);
	else if segment_name = "name_table"
	then call SIZES (meters.wired_nt_size, meters.paged_nt_size);
	else if segment_name = "dseg"
	then do;
		meters.wired_sdw_count = divide (wired_length, 2, 18, 0);
		meters.paged_sdw_count = 2048;	/* not available from header */
	     end;
	else if segment_name = "slt"
	then do;
		meters.wired_slte_count = divide (wired_length - 8, 4, 19, 0);
						/* header is 4 words slte is 8 words */
		meters.paged_slte_count = divide ((paged_length * 1024) - 8, 4, 19, 0);
	     end;

	return;

SIZES:
     procedure (wired_to_set, paged_to_set);
	declare (wired_to_set, paged_to_set)
				 fixed bin;

	wired_to_set = wired_length;
	paged_to_set = paged_length * 1024;
     end SIZES;

     end INTERESTING_SEGMENT;

SEG_PAGED:
     procedure returns (bit (1) aligned);

/* Should we report paged length? */

	return (this_slte.ringbrack (1) > 0 /* all user ring segments */
	     | Collection > checker_data_$last_wired_collection /* loaded paged */
	     | (Collection ^> checker_data_$last_wired_collection & /* else */ (this_slte.paged & ^this_slte.temp_seg))
	     /* must stay around */);
     end SEG_PAGED;
%page;
REPORT_SEGMENT:
     procedure;

	segment_name = this_namep -> segnam.names (1).name;

	call checker_print_ (
	     "^32a^2x^[^3o^;^3x^s^]^2x(^1d, ^1d, ^1d)^50t^[read ^]^[execute ^]^[write ^]^[privileged ^]^[encacheable ^]^[gate ^]^[wired^]",
	     segment_name, checker_data_$loaded (Collection), segment_number, slte_uns.ringbrack,
	     substr (this_slte.access, 1, 1), substr (this_slte.access, 2, 1), substr (this_slte.access, 3, 1),
	     substr (this_slte.access, 4, 1), this_slte.cache, this_slte.ringbrack (3) > this_slte.ringbrack (2),
	     this_slte.wired | this_slte.firmware_seg);	/* firmware segs are wired */

/* use the namep from the header */

	if this_namep -> segnam.count > 1
	then a_name = this_namep -> segnam.names (2).name;
	else a_name = "";

	if ^this_slte.init_seg & ^this_slte.temp_seg & ^this_slte.per_process & ^this_slte.firmware_seg
	then next_name = 2;
	else do;
		call checker_print_ ("^5x^32a^50t^[init seg; ^]^[temp seg; ^]^[per process; ^]^[firmware^]", a_name,
		     this_slte.init_seg, this_slte.temp_seg, this_slte.per_process, this_slte.firmware_seg);
		next_name = 3;
	     end;

	word_length = divide (this_slte.bit_count, 36, 24, 0);
	wired_length = divide (word_length + 1023, 1024, 18, 0) * 1024;
	paged_length = max (this_slte.cur_length, this_slte.max_length);

	if this_namep -> segnam.count >= next_name
	then do;
		a_name = this_namep -> segnam.names (next_name).name;
		next_name = next_name + 1;
	     end;
	else a_name = "";

	if this_slte.abs_seg
	then call checker_print_ ("^5x^32a^50tabs seg -- no storage allocated.", a_name);

	else call checker_print_ (
		"^5x^32a^50t^[wired length: ^d words;^;^s^] ^[paged length: ^d pages;^;^s^] ^[max length: ^d pages;^;^s^]",
		a_name, Collection ^> checker_data_$last_wired_collection, wired_length, SEG_PAGED (), paged_length,
		this_slte.branch_required & (this_slte.max_length ^= paged_length & this_slte.max_length ^= 0),
		this_slte.max_length);


	if this_slte.branch_required
	then do;
		if this_namep -> segnam.count >= next_name
		then do;
			a_name = this_namep -> segnam.names (next_name).name;
			next_name = next_name + 1;
		     end;
		else a_name = "";

		call checker_print_ ("^5x^32a^50tpath: ^a>^a", a_name, this_pathp -> path.name, segment_name);
	     end;

	if next_name ^> this_namep -> segnam.count
	then begin;
		declare namex		 fixed bin;
		do namex = next_name to this_namep -> segnam.count by 4;
		     if namex + 3 > this_namep -> segnam.count
		     then do;
			     go to RESIDUE (this_namep -> segnam.count - namex + 1);
RESIDUE (1):
			     call checker_print_ ("^5x^32a", this_namep -> segnam.names (namex).name);
			     go to EXIT_NAMES;
RESIDUE (2):
			     call checker_print_ ("^5x^32a^x^32a", this_namep -> segnam.names (namex).name,
				this_namep -> segnam.names (namex + 1).name);
			     go to EXIT_NAMES;
RESIDUE (3):
			     call checker_print_ ("^5x^32a^x^32a^x^32a", this_namep -> segnam.names (namex).name,
				this_namep -> segnam.names (namex + 1).name,
				this_namep -> segnam.names (namex + 2).name);
EXIT_NAMES:
			end;
		     else call checker_print_ ("^5x^32a^x^32a^x^32a^x^32a", this_namep -> segnam.names (namex).name,
			     this_namep -> segnam.names (namex + 1).name,
			     this_namep -> segnam.names (namex + 2).name,
			     this_namep -> segnam.names (namex + 3).name);
		end;
	     end;

	if this_slte.acl_provided
	then do;
		do aclx = 1 to this_aclp -> acls.count;
		     call checker_print_ ("^5x^[null^]^[r^]^[e^]^[w^]^10t^32a",
			substr (this_aclp -> acls.mode (aclx), 1, 3) = "000"b,
			substr (this_aclp -> acls.mode (aclx), 1, 1), substr (this_aclp -> acls.mode (aclx), 2, 1),
			substr (this_aclp -> acls.mode (aclx), 3, 1), this_aclp -> acls.userid (aclx));
		end;
	     end;

/* Now check for mistakes */


	if this_slte.temp_seg & ^this_slte.init_seg
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
		" Temp seg but not init seg, will not be deleted.");

	if ^substr (this_slte.access, 1, 1) & ^this_slte.abs_seg
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " No read access in SDW");

	if this_slte.branch_required & ^this_slte.paged
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " Only paged segments may have branches.");

	if this_slte.branch_required & this_slte.init_seg
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, "  Init segs may not have branches.");

	if this_slte.paged & (this_slte.max_length ^= 0) & (this_slte.max_length < this_slte.cur_length)
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " Max length < Cur length.");

	if this_slte.paged & (this_slte.cur_length * 1024) < word_length
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " Cur length < Bit count.");

	if this_slte.ringbrack (1) > this_slte.ringbrack (2) | this_slte.ringbrack (1) > this_slte.ringbrack (3)
	     | this_slte.ringbrack (2) > this_slte.ringbrack (3)
	then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " Illegal ring bracket order.");

	if (this_slte.ringbrack (1) > 0 | this_slte.ringbrack (2) > 0 | this_slte.ringbrack (3) > 0)
	     & ^this_slte.branch_required
	then call checker_print_ (CHECKER_SEVERE, (0), segment_name, " Gate has no branch.");

	if this_slte.branch_required
	then do;
		if this_pathp -> path.size = 0
		then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " Zero length branch pathname.");
		if char (this_pathp -> path.name, 1) ^= ">"
		then call checker_print_$error (CHECKER_SEVERE, (0), segment_name, " Pathname must begin with > .");
		call absolute_pathname_ (this_pathp -> path.name, (""), code);
		if code ^= 0
		then call checker_print_$error (CHECKER_SEVERE, code, segment_name, " Bad pathname: ^a.",
			this_pathp -> path.name);
	     end;

	if this_slte.acl_provided
	then do aclx = 1 to this_aclp -> acls.count;
		first = before (this_aclp -> acls.userid (aclx), ".");
		second = before (after (this_aclp -> acl.userid (aclx), "."), ".");
		third = after (after (this_aclp -> acls.userid (aclx), "."), ".");
		if first = "" | second = "" | third = "" | index (third, ".") > 0
		then call checker_print_$error (CHECKER_SEVERE, (0), segment_name,
			" Invalid Access Name Format in ^a.", this_aclp -> acls.userid (aclx));
	     end;
	return;
     end REPORT_SEGMENT;
     end PROCESS_SLTE;
%page;
Read_Control_Word:
     proc;

	call tape_reader_ (addr (control_word), 1);

     end Read_Control_Word;
%page;
COLLECTION_SUMMARY:
     procedure;
	declare 1 PC		 aligned like meters.per_collection defined (meters.per_collection (Collection));

	call checker_print_$page;
	call checker_print_ ("Summary of Collection: ^d.^d", PC.mark.major, PC.mark.minor);
	call checker_print_$skip;
	call checker_print_ ("Segments read:^32t^d; ^d temp, ^d init, ^d perm(^d user ring)", PC.segment_count,
	     PC.temp_segment_count, PC.init_segment_count, PC.perm_segment_count, PC.user_ring_segment_count);
	if Collection <= checker_data_$last_wired_collection
	then call checker_print_ ("Wired storage:^32t^d words.", PC.words_used);
	call checker_print_ ("Paged storage:^32t^d pages.", PC.pages_used);
	call checker_print_ ("Wired paged storage:^32t^d pages.", PC.wired_pages_used);
	if PC.user_ring_segment_count > 0
	then call checker_print_ ("User ring pages:^32t^d pages.", PC.user_ring_segment_pages);
	call checker_print_$skip;

	if Collection <= checker_data_$last_supervisor_collection & checker_data_$loaded (Collection)
	then do;

		call checker_print_ ("Combined linkage usage:  Active Wired (in words)");
		call checker_print_ ("-----------------------|------|------");
		call checker_print_ ("                  init: ^6d^x^6d", PC.ai_linkage_used, PC.wi_linkage_used);
		call checker_print_ ("                   sup: ^6d^x^6d", PC.as_linkage_used, PC.ws_linkage_used);
		call checker_print_$skip;

		call checker_print_ ("Definitions Used: ^5d words.", PC.definitions_used);
		call checker_print_ ("Name Table Used:  ^5d words.", PC.name_table_used);
	     end;
     end COLLECTION_SUMMARY;
%page;
TOTAL_SUMMARY:
     procedure;

	call checker_print_$page;
	call checker_print_ ("Total Summary:");
	call checker_print_$skip;

	call checker_print_ ("total segments: ^d.", sum (meters.per_collection.segment_count));
	call checker_print_ ("          temp: ^d.", sum (meters.per_collection.temp_segment_count));
	call checker_print_ ("          init: ^d.", sum (meters.per_collection.init_segment_count));
	call checker_print_ ("          perm: ^d.", sum (meters.per_collection.perm_segment_count));
	call checker_print_ ("     user ring: ^d.", sum (meters.per_collection.user_ring_segment_count));

	call checker_print_ ("Wired Environment Usage");
	call checker_print_ ("     Name                 Size            Used");
	call USAGE ("ai_linkage", meters.wired_ai_linkage_size, meters.wired_ai_linkage_used,
	     meters.overflown.wired_ai_linkage);
	call USAGE ("wi_linkage", meters.wired_wi_linkage_size, meters.wired_wi_linkage_used,
	     meters.overflown.wired_wi_linkage);
	call USAGE ("as_linkage", meters.wired_as_linkage_size, meters.wired_as_linkage_used,
	     meters.overflown.wired_as_linkage);
	call USAGE ("ws_linkage", meters.wired_ws_linkage_size, meters.wired_ws_linkage_used,
	     meters.overflown.wired_ws_linkage);
	call USAGE ("definitions", meters.wired_definitions_size, meters.wired_definitions_used,
	     meters.overflown.wired_definitions);
	call USAGE ("name table", meters.wired_nt_size, meters.wired_nt_used, meters.overflown.wired_nt);

	call checker_print_$skip;
	call checker_print_ ("Paged Environment Usage");
	call checker_print_ ("     Name                 Size            Used");
	call USAGE ("ai_linkage", meters.paged_ai_linkage_size, meters.paged_ai_linkage_used,
	     meters.overflown.paged_ai_linkage);
	call USAGE ("wi_linkage", meters.paged_wi_linkage_size, meters.paged_wi_linkage_used,
	     meters.overflown.paged_wi_linkage);
	call USAGE ("as_linkage", meters.paged_as_linkage_size, meters.paged_as_linkage_used,
	     meters.overflown.paged_as_linkage);
	call USAGE ("ws_linkage", meters.paged_ws_linkage_size, meters.paged_ws_linkage_used,
	     meters.overflown.paged_ws_linkage);
	call USAGE ("definitions", meters.paged_definitions_size, meters.paged_definitions_used,
	     meters.overflown.paged_definitions);
	call USAGE ("name table", meters.paged_nt_size, meters.paged_nt_used, meters.overflown.paged_nt);

	return;

USAGE:
     procedure (name, size, used, overflown);
	declare name		 char (*);
	declare size		 fixed bin;
	declare used		 fixed bin;
	declare overflown		 bit (1) unaligned;

	call checker_print_ ("^[*****^;^5x^]^20a^x^6d^36t^6d^43t^[OVERFLOWN^]", overflown, name, size, used, overflown);
     end USAGE;
     end TOTAL_SUMMARY;
%page;
CHECK_BOOTABLE_LABEL:
     procedure;

	declare 1 BPI		 aligned like boot_program_info;
	declare tape_reader_$rewind	 entry (char (32), fixed bin (21));

	call tape_reader_$rewind (BPI.boot_program_name, BPI.boot_program_text_length);
	if BPI.boot_program_name = ""
	then do;
		call checker_print_ ("No bootable label on MST.");
		return;				/* No boot program */
	     end;

	call checker_print_ ("Boot program: ^a, ^d words.", BPI.boot_program_name, BPI.boot_program_text_length);

	call checker_print_$skip;

     end CHECK_BOOTABLE_LABEL;

     end checker_load_MST_;




		    checker_print_.pl1              06/04/84  1601.8rew 06/04/84  1242.1       36522



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */



/* CHECKER_PRINT_ - Output Routine for the MST Checker.
   Initial coding - T. Skinner, June 10, 1969 
   Revised by N. I. Morris, October 1, 1969	
   iox'ed November 2, 1976 by N. I. Morris	*/

/* Modified BIM 8/82 new checker */

checker_print_: procedure options (variable);

%include checker_dcls_;
%page;

	dcl     iox_$error_output	 ptr ext static;
	dcl     check_mst_severity_	 fixed bin external;

	dcl     checker_data_$time_string char (24) static;
	dcl     com_err_		 entry () options (variable);
	dcl     ioa_		 entry options (variable);
	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));

	dcl     ioa_$general_rs	 entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
	dcl     ioa_$rsnnl		 entry() options (variable);
	dcl     ioa_$ioa_switch	 entry () options (variable);
	dcl     cu_$arg_list_ptr	 entry returns (pointer);
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     error_table_$fatal_error fixed bin(35) ext static;
	dcl     (cs, ff)		 fixed bin;
	dcl     (output_buffer, file_message) char (136);
	dcl     message		 char (100) aligned;
	dcl     segname		 char (32);
	dcl     prefix		 char (24);
	dcl     severity		 fixed bin;
	dcl     based_fb		 fixed bin based;
	dcl     based_fb_35		 fixed bin (35) based;
	dcl     ap		 pointer;
	dcl     al		 fixed bin (21);
	dcl     argument		 char (al) based (ap);
	dcl     code		 fixed bin (35);
	dcl     error_switch	 bit (1) aligned;
	dcl     term_switch		 bit (1) aligned;

	dcl     (clock, max, rtrim)	 builtin;

	dcl     checker_fatal_error_	 condition;


	error_switch = "0"b;
	cs = 1;					/* control arg */
	ff = 2;					/* first substitute arg */
	go to COMMON;

error:
     entry options (variable);

/* call checker_print_$error (SEVERITY, CODE, segname, cs, arg1 ... argn); */

	term_switch = "0"b;
	go to ERROR_COMMON;

error_term:
     entry options (variable);

          term_switch = "1"b; /* Print only on terminal */
ERROR_COMMON:
	error_switch = "1"b;
	cs = 4;
	ff = 5;

	call cu_$arg_ptr (1, ap, (0), (0));
	severity = ap -> based_fb;
	call cu_$arg_ptr (2, ap, (0), (0));
	code = ap -> based_fb_35;
	call cu_$arg_ptr (3, ap, al, (0));
	segname = argument;
COMMON:

	output_buffer = "";
	call ioa_$general_rs (cu_$arg_list_ptr (), cs, ff, output_buffer, (0), "1"b, "0"b);

	if ^error_switch
	then do;
		if output_buffer ^= ""
		then call ioa_$ioa_switch (checker_data_$output_iocbp, "^a", output_buffer);
		return;
	     end;

	prefix = ERROR_NAMES (severity);

	message = "";
	if code ^= 0
	then call convert_status_code_ (code, (8)" ", message);

	if ^term_switch 
	then call ioa_$ioa_switch (checker_data_$output_iocbp,
	     "***** ^a: ^a ^a", prefix, message, output_buffer);

	check_mst_severity_ = max (check_mst_severity_, severity);
	if severity <= checker_data_$severity
	then return;				/* No print on terminal */
	call ioa_$ioa_switch (iox_$error_output, "");
	call ioa_$ioa_switch (iox_$error_output,
	     "^a ^a: ^a ^a", prefix, segname, message, output_buffer);
	return;

page:
     entry;
	call ioa_$ioa_switch (checker_data_$output_iocbp, "^|");
	return;

skip:
     entry;
	call ioa_$ioa_switch (checker_data_$output_iocbp, "");
	return;

init: entry;
	check_mst_severity_ = 0;
	return;

final:
     entry;
	if check_mst_severity_ > 2
	then call com_err_ (error_table_$fatal_error, "check_mst",
		"Errors of severity 3 encountered.");
	return;
     end checker_print_;




		    compare_mst.pl1                 07/16/87  1350.1r   07/15/87  1716.0      449658



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

compare_mst: proc;

/* format: off */

/* This command mounts two mst tapes (the names of which are given as arguments)
   and compares them, printing out all significant changes.

   Written 9/20/74 by C. D. Tavares.

   Rewritten by Kobziar 3/75 to handle additions, deletions, and moves. Also allows saving of segment contents
   if they are different, and header copmparisons corrected to ignore acl pad field.
   Can compare any number of collections, ie. service or bos tapes.

   Modified 11/05/80, W. Olin Sibert, to add -file control argument.
   Modified 06/08/84, Keith Loepere, to work when an object appears on a tape more than once.
   */


/****^  HISTORY COMMENTS:
  1) change(87-01-12,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for comparing MST data coming from either tape or disk files,
     via -master_file and -copy_file control args.  Add a severity variable
     to allow testing of success/fail of the compare operation.  Modernize code
     somewhat (it needs more work, at some point in future, however).
                                                   END HISTORY COMMENTS */


%page;
	dcl     REWP		 char (64) static aligned options(constant)
				 initial ("NULL   P  W   WP E   E P EW  EWPR   R  PR W R WPRE  RE PERW REWP");
	dcl     OFF_ON		 char (8) static aligned options(constant) initial ("OFF ON  ");
	dcl    (UNSET		 init(0),
	        MASTER		 init(1),
	        COPY		 init(2)) fixed bin int static options(constant);
	dcl     abs_changes		 fixed bin int static options(constant) init (45);
	dcl     mst_name		 (2) char (19) varying int static options(constant)
				 initial ("compare_mst.master.", "compare_mst.copy.");
	dcl     rew		 char (24) static aligned options(constant) initial ("n    w e  ewr  r wre rew");

	dcl     arg		 char(argl) based(argp),
	        opt		 char(optl) based(optp);

	dcl     bits		 (bit_len) bit (1) unaligned based (bits_ptr); /* for index comparisons */

	dcl     1 bootstrap_header	 aligned based,	/* special format for bound_bootload_0 header */
		2 header_control_word like mst1.header_control_word aligned,
		2 slte		 like slte aligned,
		2 minus_ones	 (18) fixed bin (35), /* bad filler */
		2 segment_control_word like mst1.segment_control_word aligned;

	dcl     1 collection_mark_data based,
		2 pad		 bit (36),	/* header word */
		2 major		 fixed bin (18) uns unal,
		2 minor		 fixed bin (18) uns unal;

	dcl     header_words	 (bit_len) based fixed bin; /* entire header */

	dcl     1 mst1		 aligned based (mst_ptr (1)), /* Format of an MST segment header */
		2 header		 aligned,
		  3 header_control_word aligned,
		    4 collection_mark bit (18) unaligned, /* if non-zero, this is a 2-word collection mark only */
		    4 header_length	 fixed bin (17) unaligned, /* length of REST of header, not counting first 2 wds */

		  3 slte		 like slte aligned, /* first word of slte is a dummy, rest used */

		  3 names_array	 aligned,		/* this is always there, except for bound_bootload_0 */
		    4 n_names	 fixed bin aligned, /* number of names */
		    4 name_element	 (n_names (1)) aligned,
		      5 n_chars	 fixed bin aligned, /* number of chars in each name */
		      5 name	 char (32) aligned, /* the name */

		  3 pathname_array	 (has_branch (1)) aligned, /* This may or may not be there, hence the zero subscripting */
		    4 pathname_length fixed bin aligned,/* pathname is exactly this long, plus spaces to fill */
		    4 pathname	 char (path_length (1)) aligned, /* out to end of a word */

		  3 acl_structure	 (has_acl (1)) aligned, /* This also may or may not be there */
		    4 n_acls	 fixed bin,	/* number of acl entries */
		    4 acl		 (n_acls (1)) aligned, /* Each acl */
		      5 accessname	 char (32) aligned,
		      5 mode	 bit (3) aligned,	/* r, e, w */
		      5 pad	 (2) fixed bin,

		  3 segment_control_word aligned,	/* This tells about the segment following */
		    4 ident	 fixed bin (17) unaligned, /* This is always a one */
		    4 segment_length fixed bin (17) unaligned; /* in words, of seg following */


	dcl     1 mst2		 based (mst_ptr (2)) aligned, /* same thing as mst1; look up there. */
		2 header		 aligned,
		  3 header_control_word aligned,
		    4 collection_mark bit (18) unaligned,
		    4 header_length	 fixed bin (17) unaligned,

		  3 slte		 like slte aligned,

		  3 names_array	 aligned,
		    4 n_names	 fixed bin aligned,
		    4 name_element	 (n_names (2)) aligned,
		      5 n_chars	 fixed bin aligned,
		      5 name	 char (32) aligned,

		  3 pathname_array	 (has_branch (2)) aligned,
		    4 pathname_length fixed bin aligned,
		    4 pathname	 char (path_length (2)) aligned,

		  3 acl_structure	 (has_acl (2)) aligned,
		    4 n_acls	 fixed bin,
		    4 acl		 (n_acls (2)) aligned,
		      5 accessname	 char (32) aligned,
		      5 mode	 bit (3) aligned,
		      5 pad	 (2) fixed bin,

		  3 segment_control_word aligned,
		    4 ident	 fixed bin (17) unaligned,
		    4 segment_length fixed bin (17) unaligned;

	dcl     segment_1		 (seg_length (1)) based fixed bin;
	dcl     segment_2		 (seg_length (2)) based fixed bin;

	dcl     sys_id_pickup	 char (8) aligned based;

	dcl     1 tp_name		 based aligned,
		2 order_info,			/* info that we maintain relative to an object's order on the tape. */
		  3 name		 char (32),	/* primary name of seg */
		  3 org_index	 fixed bin,	/* value of org sequence in list before sort */
		  3 major_collection fixed bin,	/* segment contained within */
		  3 minor_collection fixed bin,
		  3 sw		 unaligned,	/* status of this seg */
		    4 col		 bit (1),		/* indicates a collection mark */
		    4 add		 bit (1),
		    4 del		 bit (1),
		    4 mov		 bit (1),
		2 info_ptr	 ptr,		/* pts to seg  body if saving or moved */
		2 head_ptr	 ptr,		/* pts to header if seg  has been moved */
		2 move_index	 fixed bin,	/* points to second list's correspondin g seg */
		2 pos_n		 fixed bin;	/* points to place in list where orjg name now is stored */

	dcl     1 tp1_names		 (name_count (1)) based (np (1)) aligned like tp_name;
	dcl     1 tp2_names		 (name_count (2)) based (np (2)) aligned like tp_name;

	dcl     argl		 fixed bin(21);
	dcl     anp		 (2) ptr;
	dcl     argp		 pointer;
	dcl     arg_count		 fixed bin;
	dcl     argx		 fixed bin;
	dcl     atd		 char(256);
	dcl     bit_len		 fixed bin;
	dcl     bits_ptr		 pointer;
	dcl     boot_label		 (2) bit(1) aligned;
	dcl     boot_ptr		 (2) ptr;
	dcl     bootstrap_sw	 (2) bit (1) aligned;
	dcl     1 bpi		 (2) aligned like boot_program_info;
	dcl     code		 fixed bin (35);
	dcl     collection		 bit (1) aligned;
	dcl     copy_ptr		 ptr;
	dcl     has_acl		 dimension (2) fixed bin;
	dcl     has_branch		 dimension (2) fixed bin;
	dcl     have_sysid		 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     in_den		 (2) fixed bin;
	dcl     in_file_name	 (2) char(168);
	dcl     in_tape_name	 (2) char(32);
	dcl     iocb_ptr		 (2) ptr;
	dcl     j			 fixed bin;
	dcl     k			 fixed bin;
	dcl     l1_index		 fixed bin;
	dcl     l2_index		 fixed bin;
	dcl     master_copy		 fixed bin;
	dcl     mst_ptr		 (2) pointer;
	dcl     mst_ptr_hold	 (2) ptr;
	dcl     n_acls		 dimension (2) fixed bin;
	dcl     n_names		 dimension (2) fixed bin;
	dcl     name_count		 (2) fixed bin;
	dcl     name_len		 fixed bin(18) uns unal;
	dcl     nelemt		 fixed bin (21);
	dcl     np		 (2) ptr;
	dcl     optl		 fixed bin(21);
	dcl     optp		 ptr;
	dcl     path_length		 dimension (2) fixed bin;
	dcl     saving		 bit (1);
	dcl     sci_ptr		 ptr;
	dcl     seg_len		 fixed bin(18) uns unal;
	dcl     seg_length		 (2) fixed bin;
	dcl     segment_name	 char (32);
	dcl     set		 fixed bin;
	dcl     skip_1		 bit (1) aligned;
	dcl     sys_id		 (2) char (8) aligned;

	dcl     absolute_pathname_	 entry (char(*), char(*), fixed bin(35));
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_list_ptr	 entry returns(ptr);
	dcl     get_shortest_path_	 entry (char(*)) returns(char(168));
	dcl     get_wdir_		 entry returns (char (168));
	dcl     initiate_file_$create	 entry (char(*), char(*), bit(*), ptr, bit(1) aligned, fixed bin(24),
				     fixed bin(35));
	dcl     ioa_		 entry options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$control	 entry (ptr, char(*), ptr, fixed bin(35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$get_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     parse_tape_reel_name_	 entry (char(*), char(*));
	dcl     ssu_$abort_subsystem	 entry() options(variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin(21));
	dcl     ssu_$destroy_invocation
				 entry (ptr);
	dcl     ssu_$get_temp_segment	 entry (ptr, char(*), ptr);
	dcl     ssu_$standalone_invocation
				 entry (ptr, char(*), char(*), ptr, entry, fixed bin(35));
	dcl     terminate_file_	 entry (ptr, fixed bin(24), bit(*), fixed bin(35));
	dcl     unique_chars_	 entry (bit(*)) returns(char(15));


          dcl     compare_mst_severity_  fixed bin ext static init(0);

	dcl    (error_table_$bad_arg,
	        error_table_$badopt,
	        error_table_$end_of_info,
	        error_table_$inconsistent,
	        error_table_$noarg)
				 fixed bin (35) external static;

	dcl     (abs, addr, binary, char, convert, divide, index, length,
	         ltrim, max, null, ptr, reverse, rtrim, size, string, substr)
				 builtin;

	dcl     cleanup		 condition;
%page;
	compare_mst_severity_ = 4;
	bits_ptr = null ();
	boot_ptr = null ();
	iocb_ptr = null ();
	mst_ptr_hold = null ();
	np = null ();
	sci_ptr = null();
	on cleanup call clean_up;

	call ssu_$standalone_invocation (sci_ptr, "compare_mst", "1.0",
	   cu_$arg_list_ptr(), exit_proc, code);
	if code ^= 0 then call com_err_ ("compare_mst", code, "Creating standalone ssu_ subsystem.");

	bootstrap_sw = "0"b;			/* set for first pass */
	have_sysid = "0"b;
	saving = "0"b;

	call ssu_$arg_count (sci_ptr, arg_count);
	
	in_file_name, in_tape_name = "";
	in_den = UNSET;
	master_copy = UNSET;

	do argx = 1 to arg_count;
	   call ssu_$arg_ptr (sci_ptr, argx, argp, argl);
	   if index (arg, "-") = 1 then do;
	      if arg = "-save" then
	         saving = "1"b;
	      else if arg = "-master_volume" | arg = "-mvol" then do;
	         master_copy = MASTER;
SETTAPE:	         in_tape_name(master_copy), in_file_name(master_copy) = "";
	         if argx = arg_count then
		  call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
		     "^a must be followed by a tape volume name.", arg);
	         else do;
		  argx = argx + 1;
		  call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
		  in_tape_name(master_copy) = opt;
		  end;
	         end;
	      else if arg = "-master_file" | arg = "-mf" then do;
	         master_copy = MASTER;
SETFILE:	         in_tape_name(master_copy), in_file_name(master_copy) = "";
	         if argx = arg_count then
		  call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
		     "^a must be followed by a file name.", arg);
	         else do;
		  argx = argx + 1;
		  call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
		  in_file_name(master_copy) = opt;
		  end;
	         master_copy = UNSET;
	         end;
	      else if (arg = "-copy_volume" | arg = "-cvol") then do;
	         master_copy = COPY;
	         go to SETTAPE;
	         end;
	      else if (arg = "-copy_file" | arg = "-cf") then do;
	         master_copy = COPY;
	         go to SETFILE;
	         end;
	      else if arg = "-density" | arg = "-den" then do;
	         if argx = arg_count then
		  call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
		     "^a must be followed by a tape density.", arg);
	         else do;
		  argx = argx + 1;
		  call ssu_$arg_ptr (sci_ptr, argx, optp, optl);
		  if opt = "800" | opt = "1600" | opt = "6250" then do;
		     if master_copy = UNSET then
		        call ssu_$abort_subsystem (sci_ptr,
			 error_table_$inconsistent,
			 "^a ^a must follow either -mvol or -cvol.", arg,
			 opt);
		     else
		        in_den(master_copy) = convert(in_den(1), opt);
		     end;
		  else
		     call ssu_$abort_subsystem (sci_ptr,
		        error_table_$bad_arg,
		        "^a ^a^/Allowed densities are: 800, 1600, 6250.",
		        arg, opt);
		  end;
	         end;
	      else
	         call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, arg);
	      end;
	   else if in_tape_name(MASTER) = "" & in_file_name(MASTER) = "" then
	      in_tape_name(MASTER) = arg;
	   else if in_tape_name(COPY) = "" & in_file_name(COPY) = "" then
	      in_tape_name(COPY) = arg;
	   else
	      call ssu_$abort_subsystem (sci_ptr, error_table_$bad_arg, arg);
	   end;

	do i = MASTER to COPY;
	   if in_tape_name(i) = "" & in_file_name(i) = "" then
	      call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
	         "^/A ^[master^;copy^] tape or file must be specified via -^[m^;c^]vol or -^[m^;c^]f.",
	         i, i, i);
	   end;

          do i = MASTER to COPY;
	   call ssu_$get_temp_segment (sci_ptr, "boot pgm", boot_ptr(i));
	   call ssu_$get_temp_segment (sci_ptr, "buffer", mst_ptr_hold(i));
	   call ssu_$get_temp_segment (sci_ptr, "tape names", np(i));
	   call get_in_medium (i);
	   end;
	mst_ptr = mst_ptr_hold;
	call ssu_$get_temp_segment (sci_ptr, "bit seg", bits_ptr);
	compare_mst_severity_ = 0;
%page;
	call ioa_ ("^/Begin comparison.");

	if boot_label(MASTER) ^= boot_label(COPY) then do;
	   call ioa_ (
	      "^/^[Master^;Copy^] MST has a bootload label program, while ^[Master^;Copy^] MST does not.",
	      boot_label(MASTER), boot_label(COPY));
	   compare_mst_severity_ = max(compare_mst_severity_, 3);
	   end;
	else if boot_label(MASTER) then do;
	   if bpi(MASTER).boot_program_name ^= bpi(COPY).boot_program_name then do;
	      call ioa_ ("Boot program names disagree.
  Master:  ^a
  Copy:    ^a", bpi(MASTER).boot_program_name, bpi(COPY).boot_program_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      end;
	   else if bpi(MASTER).boot_program_text_length ^=
		 bpi(COPY).boot_program_text_length then do;
	      call ioa_ ("Boot program lengths disagree.
  Master:  ^d
  Copy:    ^d",    bpi(MASTER).boot_program_text_length,
	         bpi(COPY).boot_program_text_length);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      end;
	   else do;
	      seg_length(MASTER) = bpi(MASTER).boot_program_text_length;
	      seg_length(COPY)   = bpi(COPY).boot_program_text_length;
	      mst_ptr = bpi.boot_program_ptr;
	      segment_name = "bootload label program";
	      call check_segments();
	      mst_ptr = mst_ptr_hold;
	      end;
	   end;
%page;

	call read_tape (MASTER);

/* rewind first tape */
	call rewind_in_medium (MASTER);

	call read_tape (COPY);

	if have_sysid then call ioa_ ("System ^a to ^a", sys_id (MASTER), sys_id (COPY));

/* rewind tape COPY */
	call rewind_in_medium (COPY);

	call sort_names (MASTER);
	call sort_names (COPY);
	call list_comp;				/* get add,del,and mov bits set up */

	bootstrap_sw = "0"b;			/* reset for second pass */
	l1_index, l2_index = 1;
	skip_1 = "0"b;
%page;

/* now do the dirty work */
	do while ((l1_index ^> name_count (MASTER)) & (l2_index ^> name_count (COPY)));
	   j = tp2_names (l2_index).pos_n;		/* use tape order to process names */
	   if skip_1 then do;
	      skip_1 = "0"b;
	      goto try_2;
	      end;
	   i = tp1_names (l1_index).pos_n;


	   call read_header (MASTER, collection);
	   if collection then
	      if ^tp1_names (i).sw.col then do;
out_of_sync:       compare_mst_severity_ = max(compare_mst_severity_, 3);
	         call ssu_$abort_subsystem (sci_ptr, 0,
		  "tape out of sync.");
	         end;
	      else do;
	         if tp1_names (i).sw.del then do;
		  call ioa_ ("^a mark deleted.", tp1_names (i).name);
		  compare_mst_severity_ = max(compare_mst_severity_, 3);
		  end;
	         l1_index = l1_index + 1;
	         goto loop_cont;
	         end;
	   else if segment_name ^= tp1_names (i).name then goto out_of_sync;


	   if tp1_names (i).sw.del then do;
	      call ioa_ ("^a deleted", segment_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      call skip_block (MASTER);
	      l1_index = l1_index + 1;
	      goto loop_cont;
	      end;

						/* if moved, has first been read in already ? */
	   if tp1_names (i).sw.mov then if tp1_names (i).move_index ^= 0 then do;
						/* top segment already in  */
	      set = tp1_names (i).move_index; /* pick up other list offset */
	      mst_ptr (COPY) = tp2_names (set).head_ptr;
	      call header_setup_2;
	      call check_headers;
	      call read_segment (MASTER);
	      mst_ptr (COPY) = tp2_names (set).info_ptr;
	      call check_segments;
	      mst_ptr (COPY) = mst_ptr_hold (COPY);
	      l1_index = l1_index + 1;
	      goto loop_cont;
	      end;
	   else do;				/* save the header and body */
	      call ioa_ ("^a moved down.", segment_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      call ssu_$get_temp_segment (sci_ptr,
	         "header", tp1_names(i).head_ptr);
	      bit_len = mst1.header_length + 2;
	      tp1_names (i).head_ptr -> header_words = mst_ptr (MASTER) -> header_words;
	      call ssu_$get_temp_segment (sci_ptr,
	         "info", tp1_names(i).info_ptr);
	      mst_ptr (MASTER) = tp1_names (i).info_ptr;
	      call read_segment (MASTER);
	      mst_ptr (MASTER) = mst_ptr_hold (MASTER);
	      l1_index = l1_index + 1;
	      goto loop_cont;
	      end;

try_2:
	   call read_header (COPY, collection);
	   if collection then
	      if ^tp2_names (j).sw.col then goto out_of_sync;
	      else do;
	         if tp2_names (j).sw.add then do;
		  call ioa_ ("^a mark added.", tp2_names (j).name);
		  compare_mst_severity_ = max(compare_mst_severity_, 3);
		  end;
	         l2_index = l2_index + 1;
	         skip_1 = "1"b;
	         goto loop_cont;
	         end;
	   else if segment_name ^= tp2_names (j).name then goto out_of_sync;


	   if tp2_names (j).sw.add then do;
	      call ioa_ ("^a added.", segment_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      if saving then do;
	         call initiate_file_$create (get_wdir_(),
		  "tp2." || segment_name, RW_ACCESS,
		  tp2_names (j).info_ptr, "0"b, 0, code);
	         if tp2_names (j).info_ptr = null then goto make_x;
	         mst_ptr (COPY) = tp2_names (j).info_ptr;
	         call read_segment (COPY);
	         mst_ptr (COPY) = mst_ptr_hold (COPY);
	         call terminate_file_ (tp2_names(j).info_ptr,
		  seg_length(COPY) * BITS_PER_WORD, TERM_FILE_TRUNC_BC_TERM, 
		  code);
	         end;
	      else call skip_block (COPY);
	      l2_index = l2_index + 1;
	      skip_1 = "1"b;
	      goto loop_cont;
	      end;


	   if tp2_names (j).sw.mov then
	   if tp2_names (j).move_index ^= 0 then do;
	      set = tp2_names (j).move_index;
	      mst_ptr (MASTER) = tp1_names (set).head_ptr;
	      call header_setup_1;
	      call check_headers;
	      call read_segment (COPY);
	      mst_ptr (MASTER) = tp1_names (set).info_ptr;
	      call check_segments;
	      mst_ptr (MASTER) = mst_ptr_hold (MASTER);
	      l2_index = l2_index + 1;
	      skip_1 = "1"b;
	      goto loop_cont;
	      end;
	   else do;
	      call ioa_ ("^a moved up.", segment_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      call ssu_$get_temp_segment (sci_ptr, "hdr." || segment_name,
	         tp2_names (j).head_ptr);
	      bit_len = mst2.header_length + 2;
	      tp2_names (j).head_ptr -> header_words = mst_ptr (COPY) -> header_words;
	      call ssu_$get_temp_segment (sci_ptr, "tp2." || segment_name,
	         tp2_names (j).info_ptr);
	      mst_ptr (COPY) = tp2_names (j).info_ptr;
	      call read_segment (COPY);
	      mst_ptr (COPY) = mst_ptr_hold (COPY);
	      l2_index = l2_index + 1;
	      skip_1 = "1"b;
	      goto loop_cont;
	      end;
						/* compare segments */
	   call check_headers;
	   call read_segment (MASTER);
	   call read_segment (COPY);
	   call check_segments;
	   l1_index = l1_index + 1;
	   l2_index = l2_index + 1;
loop_cont:
	   end;					/* do while */

	if l1_index > name_count (MASTER) then if l2_index ^> name_count (COPY)
	   then i = 2;
	else goto detach_and_return;			/* process end of longer tape */
	else i = 1;

	if i = 1 then j = l1_index;
	else j = l2_index;
	do while (j ^> name_count (i));
	   call read_header (i, collection);
	   if collection then goto incr_j;
	   k = np (i) -> tp1_names (j).pos_n;
	   if segment_name ^= np (i) -> tp1_names (k).name then goto out_of_sync;
	   if np (i) -> tp1_names (k).sw.add then do;
	      call ioa_ ("^a added.", segment_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      if saving then do;
	         call initiate_file_$create (get_wdir_ (),
		  "tp2." || segment_name, RW_ACCESS, mst_ptr (i), ""b, 0,
		  code);
	         if mst_ptr (i) = null then goto make_x;
	         call read_segment (i);
	         call terminate_file_ (mst_ptr (i),
		  seg_length(i) * BITS_PER_WORD, TERM_FILE_TRUNC_BC_TERM,
		  code);
	         mst_ptr (i) = mst_ptr_hold (i);
	         end;
	      else call skip_block (i);
	      end;
	   else do;				/* must be deleted */
	      call skip_block (i);
	      call ioa_ ("^a deleted.", segment_name);
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      end;
incr_j:	   j = j + 1;
	   end;
	call ioa_ ("End of comparison.^/");

detach_and_return:
	call clean_up;
	return;					/* successful job finish */

exit_proc:
	procedure;
	go to detach_and_return;
	end exit_proc;

make_x:   compare_mst_severity_ = max(compare_mst_severity_, 4);
	call ssu_$abort_subsystem (sci_ptr, code,
	   "Making -save segment in working directory.");
	go to detach_and_return;
%page;
clean_up: proc;
	do i = MASTER to COPY;
	   if iocb_ptr (i) = null ()
	      then go to CLEAN;
	   call iox_$close (iocb_ptr (i), code);
	   call iox_$detach_iocb (iocb_ptr (i), code);
CLEAN:	   end;
	call ssu_$destroy_invocation (sci_ptr);
	end;
%page;
get_data:	proc (index, data_ptr, data_words);

    dcl	index			 fixed bin,
	data_ptr			 ptr,
	data_words		 fixed bin(18) uns unal;

	call iox_$get_chars (iocb_ptr(index),
	   data_ptr, data_words * CHARS_PER_WORD, (0), code);
	if code = error_table_$end_of_info then go to detach_and_return;
	else if code ^= 0 then do;
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "Tape error on ^[master^;copy^] tape.", index);
	   end;
	end get_data;


get_in_file:
	proc (index);

    dcl	index			 fixed bin;

    dcl	1 control_word		 aligned,
	  2 type			 fixed bin (17) unaligned,
	  2 count			 fixed bin (18) uns unal;

	call absolute_pathname_ (in_file_name(index),
	   in_file_name(index), code);
	if code ^= 0 then
	   call ssu_$abort_subsystem (sci_ptr, code, "^[-if^;-of^] ^a.",
	      index, in_file_name);

	in_file_name(index) = get_shortest_path_ (in_file_name(index));

	call iox_$attach_name (mst_name(index) || unique_chars_(""b),
	   iocb_ptr(index), "vfile_ " || in_file_name(index) || " -old",
	   null, code);
	if code ^= 0 then
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "Cannot attach input file ^a.", in_file_name(index));

REWIND_FILE:
	call iox_$open (iocb_ptr(index), Stream_input, ("0"b), code);
	if code ^= 0 then 
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "Cannot open input file ^a.", in_file_name(index));

	call get_data (index, addr (control_word), size(control_word));
	if control_word.type = -1 then do;		/* bootload program control word */
						/* It is written as a name, followed by the pgm.	*/

	   bpi(index).version = BOOT_PROGRAM_INFO_VERSION_1;
						/* set version */
	   boot_label(index) = "1"b;			/* set flag to copy onto output tape */
	   name_len = divide (length (bpi(index).boot_program_name), CHARS_PER_WORD, 18, 0);
	   seg_len = control_word.count - name_len;	/* set copy length */
	   call get_data (index, addr (bpi(index).boot_program_name), name_len);
	   call get_data (index, boot_ptr(index), seg_len);
						/* copy boot program in to temp seg */
	   bpi(index).boot_program_ptr = boot_ptr(index); /* set new boot program ptr */
	   bpi(index).boot_program_text_length = seg_len;
	   end;
	else do;
	   boot_label(index) = "0"b;
	   call iox_$close (iocb_ptr(index), (0));
	   call iox_$open (iocb_ptr(index), Stream_input, ""b, (0));
	   end;
	return;

rewind_in_file:
	entry (index);

	call iox_$close (iocb_ptr(index), code);
	if code ^= 0 then do;
	   compare_mst_severity_ = max(compare_mst_severity_, 4);
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "error in reopening. Aborting.");
	   end;
	go to REWIND_FILE;

     end get_in_file;


get_in_medium:
  	proc (index);

    dcl	index			 fixed bin;

	if in_file_name(index) ^= "" then
	   call get_in_file (index);
	else if in_tape_name(index) ^= "" then
	   call get_in_tape (index);
	return;

rewind_in_medium:
	entry (index);

	if in_file_name(index) ^= "" then
	   call rewind_in_file (index);
	else
	   call rewind_in_tape (index);

	end get_in_medium;

get_in_tape:
	proc (index);
	
    dcl	index			 fixed bin;

    dcl	copy			 (seg_len) fixed bin(35) based;

	call parse_tape_reel_name_ (in_tape_name(index), atd);
	if in_den(index) ^= UNSET
	   then atd = rtrim (atd) || " -density " || ltrim (char (in_den(index)));

	call iox_$attach_name (mst_name(index) || unique_chars_ (""b),
	   iocb_ptr(index), "tape_mult_ " || rtrim (atd), null, code);
	if code ^= 0 then
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "Cannot attach input tape ^a.", in_tape_name(index));

REWIND_TAPE:
	call iox_$open (iocb_ptr(index), Stream_input, ("0"b), code);
	if code ^= 0 then 
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "Cannot open input tape ^a.", in_tape_name(index));

	bpi(index).version = BOOT_PROGRAM_INFO_VERSION_1;	/* set version */
	call iox_$control (iocb_ptr(index), "get_boot_program",
	   addr (bpi(index)), code);
	if code ^= 0 then
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "Getting bootload program info from input tape ^a.",
	      in_tape_name(index));

	if bpi(index).boot_program_ptr ^= null then do;	/* if this tape has a boot label... */
	   boot_label(index) = "1"b;			/* set flag to copy onto output tape */
	   seg_len = bpi(index).boot_program_text_length;
						/* set copy length */
	   boot_ptr(index) -> copy = bpi(index).boot_program_ptr -> copy;
						/* copy boot program in to temp seg */
	   bpi(index).boot_program_ptr = boot_ptr(index);
						/* set new boot program ptr */
	   end;
	else
	   boot_label(index) = "0"b;
	return;
	
rewind_in_tape:
	entry (index);
	
	call iox_$close (iocb_ptr (index), code);
	if code ^= 0 then do;
	   compare_mst_severity_ = max(compare_mst_severity_, 4);
	   call ssu_$abort_subsystem (sci_ptr, code,
	      "error in rewind, aborting");
	   end;
	go to REWIND_TAPE;

	end get_in_tape;
%page;
read_header: proc (index, found_mark);

	dcl     found_mark		 bit (1) aligned;
	dcl     index		 fixed bin;

/* Get two words.  The first word will tell you how many more words to read to complete
   the header (i.e., it is the header length minus 2.)  If the collection mark is on, however, it
   is complete in itself.  In that case, you
   must reach in and get a whole fresh header. */


	call iox_$get_chars (iocb_ptr (index), mst_ptr (index), 8, nelemt, code); /* read 2 words */
	if code = 0 then do;
	   if mst_ptr (index) -> mst1.collection_mark then do;
	      found_mark = "1"b;			/* don't read rest of header; there is none */
	      return;
	      end;
	   else call iox_$get_chars (iocb_ptr (index), ptr (mst_ptr (index), 2),
	      mst_ptr (index) -> mst1.header_length * 4, nelemt, code);
						/* read rest of header */
	   if code ^= 0 then call check_status;
	   found_mark = "0"b;

	   if index = 1 then call header_setup_1;
	   else call header_setup_2;
	   end;
	else if code ^= error_table_$end_of_info then call check_status;

	end;
%page;
header_setup_1: proc;

	n_names (MASTER) = mst_ptr (MASTER) -> mst1.n_names;
						/* pull out number of names */
	if n_names (MASTER) = -1 then do;		/* special bootstrap processing */
	   if bootstrap_sw (MASTER) then do;
	      call ioa_ ("second bound_bootload_0 found on master tape. Aborting.");
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      goto detach_and_return;
	      end;
	   bootstrap_sw (MASTER) = "1"b;
	   n_names (MASTER) = 0;
	   has_acl (MASTER) = 0;
	   n_acls (MASTER) = 0;
	   has_branch (MASTER) = 0;
	   path_length (MASTER) = 0;
	   segment_name = "bound_bootload_0";
	   seg_length (MASTER) = mst_ptr (MASTER) -> bootstrap_header.segment_length;
	   end;
	else do;
	   has_acl (MASTER) = binary (mst_ptr (MASTER) -> mst1.slte.acl_provided); /* is there an acl? */
	   has_branch (MASTER) = binary (mst_ptr (MASTER) -> mst1.slte.branch_required); /* is there a pathname? */
	   if has_branch (MASTER) = 1 then path_length (MASTER) = mst_ptr (MASTER) -> mst1.pathname_length (1); /* get length */
	   else path_length (MASTER) = 0;
	   if has_acl (MASTER) = 1 then n_acls (MASTER) = mst_ptr (MASTER) -> mst1.n_acls (1);
	   else n_acls (MASTER) = 0;
	   segment_name = mst_ptr (MASTER) -> mst1.name (MASTER);
	   seg_length (MASTER) = mst_ptr (MASTER) -> mst1.segment_length;
	   end;
	end;

header_setup_2: proc;				/* must use references based on mst2 varibs */

	n_names (COPY) = mst_ptr (COPY) -> mst2.n_names;
	if n_names (COPY) = -1 then do;
	   if bootstrap_sw (COPY) then do;
	      call ioa_ ("second bound_bootload_0 found on copy tape. Aborting.");
	      compare_mst_severity_ = max(compare_mst_severity_, 3);
	      goto detach_and_return;
	      end;
	   bootstrap_sw(COPY) = "1"b;
	   n_names (COPY) = 0;
	   has_acl (COPY) = 0;
	   n_acls (COPY) = 0;
	   has_branch (COPY) = 0;
	   path_length (COPY) = 0;
	   segment_name = "bound_bootload_0";
	   seg_length (COPY) = mst_ptr (COPY) -> bootstrap_header.segment_length;
	   end;
	else do;
	   has_acl (COPY) = binary (mst_ptr (COPY) -> mst2.slte.acl_provided);
	   has_branch (COPY) = binary (mst_ptr (COPY) -> mst2.slte.branch_required);
	   if has_branch (COPY) = 1 then path_length (COPY) = mst_ptr (COPY) -> mst2.pathname_length (1);
	   else path_length (COPY) = 0;
	   if has_acl (COPY) = 1 then n_acls (COPY) = mst_ptr (COPY) -> mst2.n_acls (1);
	   else n_acls (COPY) = 0;
	   segment_name = mst_ptr (COPY) -> mst2.name (1);
	   seg_length (COPY) = mst_ptr (COPY) -> mst2.segment_length;
	   end;
	end;
%page;
check_headers: proc;


	if mst1.header_length ^= mst2.header_length then goto header_discrepancy;

	bit_len = mst1.header_length + 2;		/* comparison of headers here */
	bits = mst_ptr (MASTER) -> header_words = mst_ptr (COPY) -> header_words;
	if (^string (bits)) ^= ""b then
	if ((n_acls (MASTER) = 0) | (n_acls (COPY) = 0)) then goto header_discrepancy;
	else do;					/* zero pad in acl structure */
	   do k = 1 to n_acls (MASTER);
	      mst1.acl (1, k).pad (1), mst1.acl (1, k).pad (2) = 0;
	      end;
	   do k = 1 to n_acls (COPY);
	      mst2.acl (1, k).pad (1), mst2.acl (1, k).pad (2) = 0;
	      end;
	   bits = mst_ptr (MASTER) -> header_words = mst_ptr (COPY) -> header_words;
	   if (^string (bits)) ^= ""b then goto header_discrepancy;
	   end;
	return;

header_discrepancy:
	call ioa_ ("^/Segment ^a:", segment_name);
	compare_mst_severity_ = max(compare_mst_severity_, 3);

/* Now find out exactly why. */
	if mst_ptr (MASTER) -> mst1.access ^= mst_ptr (COPY) -> mst2.access then
	   call ioa_ ("^-SDW access has changed from ^a to ^a",
	      substr (REWP, binary (mst_ptr (MASTER) -> mst1.access) * 4 + 1, 4),
	      substr (REWP, binary (mst_ptr (COPY) -> mst2.access) * 4 + 1, 4));
	if mst_ptr (MASTER) -> mst1.cache ^= mst_ptr (COPY) -> mst2.cache then
	   call ioa_ ("^-Cache bit has changed from ^a to ^a",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.cache) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.cache) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.wired ^= mst_ptr (COPY) -> mst2.wired then
	   call ioa_ ("^-Wired bit has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.wired) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.wired) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.paged ^= mst_ptr (COPY) -> mst2.paged then
	   call ioa_ ("^-Paged bit has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.paged) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.paged) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.per_process ^= mst_ptr (COPY) -> mst2.per_process then
	   call ioa_ ("^-Per-process bit has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.per_process) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.per_process) * 4 + 1, 3));
%page;
	if mst_ptr (MASTER) -> mst1.acl_provided ^= mst_ptr (COPY) -> mst2.acl_provided then
	   call ioa_ ("^-ACL-provided switch has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.acl_provided) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.acl_provided) * 4 + 1, 3));
	else if has_acl (MASTER) = 1 then
	     if n_acls (MASTER) ^= n_acls (COPY) then goto print_acls;
	else do;
	   bit_len = 11 * n_acls (MASTER) + 1;
	   anp (MASTER) = addr (mst1.acl_structure (1));
	   anp (COPY) = addr (mst2.acl_structure (1));
	   bits = anp (MASTER) -> header_words = anp (COPY) -> header_words;
	   if (^string (bits)) ^= ""b then do;
print_acls:     call ioa_ ("^-Number of ACLs was ^d, now is ^d.",
	         n_acls (MASTER), n_acls (COPY));
	      if abs (n_acls (MASTER) - n_acls (COPY)) > abs_changes then do;
too_much:	         compare_mst_severity_ = max(compare_mst_severity_, 4);
	         call ssu_$abort_subsystem (sci_ptr, 0,
		  "Probable bad tape, aborting.");
	         goto detach_and_return;
	         end;
	      call ioa_ ("^5xACL was:");
	      do k = 1 to n_acls (MASTER);
	         call ioa_ ("^-^3a  ^a",
		  substr (rew, binary (mst_ptr (MASTER) -> mst1.acl (1, k).mode) * 3 + 1, 3),
		  mst_ptr (MASTER) -> mst1.acl (1, k).accessname);
	         end;
	      call ioa_ ("^5xACL is:");
	      do k = 1 to n_acls (COPY);
	         call ioa_ ("^-^3a  ^a",
		  substr (rew, binary (mst_ptr (COPY) -> mst2.acl (1, k).mode) * 3 + 1, 3),
		  mst_ptr (COPY) -> mst2.acl (1, k).accessname);
	         end;
	      end;
	   end;
	if mst_ptr (MASTER) -> mst1.branch_required ^= mst_ptr (COPY) -> mst2.branch_required then
	   call ioa_ ("^-Hierarchy-branch required indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.branch_required) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.branch_required) * 4 + 1, 3));
	else if has_branch (MASTER) = 1 then
	     if mst_ptr (MASTER) -> mst1.pathname (1) ^= mst_ptr (COPY) -> mst2.pathname (1) then
	   call ioa_ ("^-Pathname has changed from ^a to ^a.",
	      mst_ptr (MASTER) -> mst1.pathname (1), mst_ptr (COPY) -> mst2.pathname (1));
	if mst_ptr (MASTER) -> mst1.init_seg ^= mst_ptr (COPY) -> mst2.init_seg then
	   call ioa_ ("^-Initialization-seg indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.init_seg) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.init_seg) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.temp_seg ^= mst_ptr (COPY) -> mst2.temp_seg then
	   call ioa_ ("^-Temp-seg indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.temp_seg) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.temp_seg) * 4 + 1, 3));
%page;
	if mst_ptr (MASTER) -> mst1.link_provided ^= mst_ptr (COPY) -> mst2.link_provided then
	   call ioa_ ("^-Linkage-provided indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.link_provided) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.link_provided) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.link_sect ^= mst_ptr (COPY) -> mst2.link_sect then
	   call ioa_ ("^-Linkage-segment indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.link_sect) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.link_sect) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.link_sect_wired ^= mst_ptr (COPY) -> mst2.link_sect_wired then
	   call ioa_ ("^-Linkage-wired indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.link_sect_wired) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.link_sect_wired) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.combine_link ^= mst_ptr (COPY) -> mst2.combine_link then
	   call ioa_ ("^-Combine-linkage switch has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.combine_link) * 4 + 1, 3),
	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.combine_link) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.pre_linked ^= mst_ptr (COPY) -> mst2.pre_linked then
	   call ioa_ ("^-Pre-linked indicator has changed from ^a to ^a.",
	      substr (OFF_ON, binary (mst_ptr (MASTER) -> mst1.pre_linked) * 4 + 1, 3),
   	      substr (OFF_ON, binary (mst_ptr (COPY) -> mst2.pre_linked) * 4 + 1, 3));
	if mst_ptr (MASTER) -> mst1.cur_length ^= mst_ptr (COPY) -> mst2.cur_length then
	   call ioa_ ("^-Cur-length has changed from ^o to ^o.",
	      binary (mst_ptr (MASTER) -> mst1.cur_length, 35),
	      binary (mst_ptr (COPY) -> mst2.cur_length, 35));
	if mst_ptr (MASTER) -> mst1.ringbrack (1) ^= mst_ptr (COPY) -> mst2.ringbrack (1) |
	   mst_ptr (MASTER) -> mst1.ringbrack (2) ^= mst_ptr (COPY) -> mst2.ringbrack (2) |
	   mst_ptr (MASTER) -> mst1.ringbrack (3) ^= mst_ptr (COPY) -> mst2.ringbrack (3) then
	   call ioa_ ("^-Ring brackets have changed from ^d,^d,^d to ^d,^d,^d.",
	      binary (mst_ptr (MASTER) -> mst1.ringbrack (1), 35),
	      binary (mst_ptr (MASTER) -> mst1.ringbrack (2), 35),
	      binary (mst_ptr (MASTER) -> mst1.ringbrack (3), 35),
	      binary (mst_ptr (COPY) -> mst2.ringbrack (1), 35),
	      binary (mst_ptr (COPY) -> mst2.ringbrack (2), 35),
	      binary (mst_ptr (COPY) -> mst2.ringbrack (3), 35));
	if mst_ptr (MASTER) -> mst1.segno ^= mst_ptr (COPY) -> mst2.segno then
	   call ioa_ ("^-Segment number has changed from ^o to ^o.",
	      binary (mst_ptr (MASTER) -> mst1.segno, 35),
	      binary (mst_ptr (COPY) -> mst2.segno, 35));
	if mst_ptr (MASTER) -> mst1.max_length ^= mst_ptr (COPY) -> mst2.max_length then
	   call ioa_ ("^-Max length has changed from ^o to ^o.",
	      binary (mst_ptr (MASTER) -> mst1.max_length, 35),
	      binary (mst_ptr (COPY) -> mst2.max_length, 35));
	if mst_ptr (MASTER) -> mst1.bit_count ^= mst_ptr (COPY) -> mst2.bit_count then
	   call ioa_ ("^-Bit count has changed from ^d to ^d.",
	      binary (mst_ptr (MASTER) -> mst1.bit_count, 35),
	      binary (mst_ptr (COPY) -> mst2.bit_count, 35));
%page;
	if n_names (MASTER) = 0 then return;		/* bound_bootload_0 */
	if n_names (MASTER) ^= n_names (COPY) then goto print_names;
	else do;
	   bit_len = 9 * n_names (MASTER) + 1;
	   anp (MASTER) = addr (mst1.names_array);
	   anp (COPY) = addr (mst2.names_array);
	   bits = anp (MASTER) -> header_words = anp (COPY) -> header_words;
	   if (^string (bits)) ^= ""b then do;
print_names:    call ioa_ ("^-Number of names was ^d, now is ^d.",
	         n_names (MASTER), n_names (COPY));
	      if abs (n_names (MASTER) - n_names (COPY)) > abs_changes then goto too_much;
	      call ioa_ ("^5xNames were:");
	      do k = 1 to n_names (MASTER);
	         call ioa_ ("^-^a", mst_ptr (MASTER) -> mst1.name (k));
	         end;
	      call ioa_ ("^5xNames are:");
	      do k = 1 to n_names (COPY);
	         call ioa_ ("^-^a", mst_ptr (COPY) -> mst2.name (k));
	         end;
	      end;
	   end;
	if mst_ptr (MASTER) -> mst1.segment_length ^= mst_ptr (COPY) -> mst2.segment_length then
	   call ioa_ ("^-Segment length has changed from ^o to ^o.",
	      mst_ptr (MASTER) -> mst1.segment_length, mst_ptr (COPY) -> mst2.segment_length);

	end;
%page;
skip_block: proc (index);
	dcl     index		 fixed bin;
						/* positioning not supported, so just read */
	call iox_$get_chars (iocb_ptr (index), mst_ptr (index), seg_length (index) * 4, nelemt, code);
	if code ^= 0 then call check_status;
	end;

read_segment: proc (index);
	dcl     index		 fixed bin;

	call iox_$get_chars (iocb_ptr (index), mst_ptr (index), seg_length (index) * 4, nelemt, code);
	if code ^= 0 then call check_status;

	end;

check_status: proc;
	compare_mst_severity_ = max(compare_mst_severity_, 4);
          call ssu_$abort_subsystem (sci_ptr, code, 
	   "Error in manipulating tapes.");
	end;

read_tape: proc (index);

	dcl     index		 fixed bin parameter;

	dcl     i			 fixed bin;
	dcl     last_collection_mark	 fixed bin;
	dcl     name_index		 fixed bin;
	dcl     1 tp_names		 (name_count (index)) based (np (index)) aligned like tp_name;

	last_collection_mark = 0;
	name_index, name_count (index) = 0;
	do while (code ^= error_table_$end_of_info);	/* get the whole tape */
	   call read_header (index, collection);
	   if code = 0 then do;
	      name_index, name_count (index) = name_count (index) + 1;
	      tp_names (name_index).org_index = name_index;
	      tp_names (name_index).pos_n = name_index;	/* init */
	      tp_names (name_index).head_ptr = null;
	      tp_names (name_index).info_ptr = null;
	      if index = 1 then tp_names (name_index).sw.del = "1"b;
						/* assume not on other tape */
	      else tp_names (name_index).sw.add = "1"b; /* assume everything new */
	      if collection then do;
	         do i = last_collection_mark + 1 to name_index;
						/* record collection contained within */
		  tp_names (i).major_collection = mst_ptr (index) -> collection_mark_data.major;
		  tp_names (i).minor_collection = mst_ptr (index) -> collection_mark_data.minor;
		  end;
	         last_collection_mark = name_index;
	         
	         tp_names (name_index).name = "collection." ||
		  ltrim (char (mst_ptr (index) -> collection_mark_data.major)) ||
		  "." || ltrim (char (mst_ptr (index) -> collection_mark_data.minor));
	         tp_names (name_index).sw.col = "1"b;
	         end;
	      else do;
	         tp_names (name_index).name = segment_name;
	         call skip_block (index);
	         if segment_name = "active_all_rings_data" then do;
		  have_sysid = "1"b;
		  sys_id (index) = mst_ptr (index) -> sys_id_pickup;
		  end;
	         end;
	      end;
	   end;

	if substr (tp_names (name_index).name, 1, 10) ^= "collection" then do;
	   call ioa_ ("tape ^d does not end in a collection mark.", index);
	   compare_mst_severity_ = max(compare_mst_severity_, 3);
	   end;
	return;
	end;
%page;
check_segments: proc;

	if seg_length (MASTER) ^= seg_length (COPY) then goto check_saving;
	bit_len = seg_length (MASTER);			/* ready for bit comparison */

	bits = mst_ptr (MASTER) -> segment_1 = mst_ptr (COPY) -> segment_1; /* set up equal bits */

	if (^string (bits)) ^= ""b then goto segment_contents_discrepancy; /* something has been changed. */

	return;


segment_contents_discrepancy:
	k = index (string (bits), "0"b) - 1;		/* j tells which word first noticed as changed */
	call ioa_ ("^/Segment ^a contains differences from word ^o.", segment_name, k);
	compare_mst_severity_ = max(compare_mst_severity_, 3);
	k = bit_len - index (reverse (string (bits)), "0"b);
	call ioa_ ("^-last difference found at word ^o.", k);
check_saving:
	if saving then do;
	   call initiate_file_$create (get_wdir_ (),
	      "tp1." || segment_name, RW_ACCESS, copy_ptr, ""b, 0, code);
	   if copy_ptr = null then return;
	   copy_ptr -> segment_1 = mst_ptr (MASTER) -> segment_1;
	   call terminate_file_ (copy_ptr, size(segment_1) * BITS_PER_WORD,
	      TERM_FILE_TRUNC_BC_TERM, code);

	   call initiate_file_$create (get_wdir_ (),
	      "tp2." || segment_name, RW_ACCESS, copy_ptr, ""b, 0, code);
	   if copy_ptr = null then return;
	   copy_ptr -> segment_2 = mst_ptr (COPY) -> segment_2;
	   call terminate_file_ (copy_ptr, size(segment_2) * BITS_PER_WORD,
	      TERM_FILE_TRUNC_BC_TERM, code);
	   end;
	return;
	end;
%page;
sort_names: proc (index);
						/* shell sort, keeping track of original position */
	dcl     index		 fixed bin;

	dcl     1 hold_info		 aligned like tp_name.order_info;
	dcl     sd		 fixed bin;
	dcl     si		 fixed bin;
	dcl     sj		 fixed bin;
	dcl     sk		 fixed bin;
	dcl     1 tp_names		 (name_count (index)) aligned based (np (index)) like tp_name;

	sd = name_count (index);

down:	sd = 1 + 2 * divide (sd, 4, 17, 0);
	do si = 1 to name_count (index) - sd;
	   sj = si + sd;
up:	   sk = sj - sd;
	   if tp_names (sk).name <= tp_names (sj).name then goto ok;
	   
	   hold_info = tp_names (sk).order_info;

	   tp_names (sk).order_info = tp_names (sj).order_info;
	   tp_names (tp_names (sk).org_index).pos_n = sk;

	   tp_names (sj).order_info = hold_info;
	   tp_names (tp_names (sj).org_index).pos_n = sj;
	   
	   if sk > sd then do;
	      sj = sk;
	      goto up;
	      end;
ok:	   end;
	if sd > 1 then goto down;

	end;
%page;
name_search: proc (tp_name_ptr, index, ret_ans);

/* See if name exists on list(index).  Do binary search, preferring the object
in the same collection as before. */

	dcl     index		 fixed bin;
	dcl     ret_ans		 fixed bin;
	dcl     tp_name_ptr		 ptr;

	dcl     low_index		 fixed bin;
	dcl     high_index		 fixed bin;
	dcl     1 tp_names		 (name_count (index)) aligned based (np (index)) like tp_name;

	ret_ans = 0;
	low_index = 1;
	high_index = name_count (index);
	do while (high_index > low_index);
	   k = divide (low_index + high_index, 2, 17);
	   if tp_names (k).name = tp_name_ptr -> tp_name.name then go to match;
	   else if tp_names (k).name < tp_name_ptr -> tp_name.name then low_index = k + 1; /* name in high half of subdivision */
	   else high_index = k - 1;			/* low half */
	   end;
	if high_index < 1 then return;
	if low_index > name_count (index) then return;
	if tp_names (high_index).name = tp_name_ptr -> tp_name.name then do;
	   k = high_index;
match:

/* Name the same; look for the one in the same collection. */

	   do ret_ans = k to name_count (index) while (tp_name_ptr -> tp_name.name = tp_names (ret_ans).name), 
		      k - 1 to 1 by -1 while (tp_name_ptr -> tp_name.name = tp_names (ret_ans).name);
	      if tp_name_ptr -> tp_name.major_collection = tp_names (ret_ans).major_collection &
	         tp_name_ptr -> tp_name.minor_collection = tp_names (ret_ans).minor_collection then return;
	      end;
	   ret_ans = ret_ans + 1;			/* pick first one found */
	   end;
	return;
	end;
%page;
list_comp: proc;					/* find out what's added, deleted, or moved */
						/* process in original order to get add/del counts rigHt */
	dcl     add_count		 fixed bin;
	dcl     del_count		 fixed bin;
	dcl     offset_1		 fixed bin;
	dcl     offset_2		 fixed bin;

	do i = 1 to name_count (MASTER);
	   call name_search (addr (tp1_names (tp1_names (i).pos_n)), 2, offset_1);
	   if offset_1 = 0 then go to d_lp_c;		/* remains marked as deleted */
	   else do;
	      tp1_names (tp1_names (i).pos_n).sw.del = "0"b;
	      tp2_names (offset_1).sw.add = "0"b;
	      end;
d_lp_c:	   end;
						/* check for movement by matching list position */
	i, j = 1;
	add_count, del_count = 0;
						/* need process only shortest list */
	do while ((i <= name_count (MASTER)) & (j <= name_count (COPY)));
	   if tp1_names (tp1_names (i).pos_n).sw.del |
	      tp1_names (tp1_names (i).pos_n).move_index ^= 0 then do;
	      i = i + 1;
	      go to l_cont;
	      end;
	   if tp2_names (tp2_names (j).pos_n).sw.add |
	      tp2_names (tp2_names (j).pos_n).move_index ^= 0 then do;
	      j = j + 1;
	      go to l_cont;
	      end;
						/* if names equal then ok */
	   if tp1_names (tp1_names (i).pos_n).name = tp2_names (tp2_names (j).pos_n).name then do;
	      i = i + 1;
	      j = j + 1;
	      goto l_cont;
	      end;
						/* see which side moved */
	   call name_search (addr (tp1_names (tp1_names (i).pos_n)), COPY, offset_2);
	   call name_search (addr (tp2_names (tp2_names (j).pos_n)), MASTER, offset_1);
						/* find out which is farther, ignore adds,deletes */
	   del_count = tp1_names (offset_1).org_index - tp1_names (tp1_names (i).pos_n).org_index;
	   add_count = tp2_names (offset_2).org_index - tp2_names (tp2_names (j).pos_n).org_index;
						/* mark one as moved */
	   if del_count > add_count then do;		/* first tape's match is lower */
	      tp2_names (tp2_names (j).pos_n).sw.mov = "1"b;
	      tp1_names (offset_1).sw.mov = "1"b;
	      tp1_names (offset_1).move_index = tp2_names (j).pos_n;
	      j = j + 1;
	      goto l_cont;
	      end;
	   else do;
	      tp1_names (tp1_names (i).pos_n).sw.mov = "1"b;
	      tp2_names (offset_2).sw.mov = "1"b;
	      tp2_names (offset_2).move_index = tp1_names (i).pos_n;
	      i = i + 1;
	      goto l_cont;
	      end;
l_cont:	   end;					/* do while */
	end;					/* proc */
%page; %include access_mode_values;
%page; %include iox_modes;
%page; %include slte;
%page; %include system_constants;
%page; %include tape_mult_boot_info;
%page; %include terminate_file;
     end;




		    sslt_init_.pl1                  12/15/83  1138.2r   12/15/83  1135.0       14130



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* sslt_init_.pl1 -- copies template slt from template_slt_ into temp segs */
/* for the checker. BIM 7/2/82 */
/* format: style2 */

sslt_init_:
     procedure (slt_ptr, name_table_ptr);

	declare (slt_ptr, name_table_ptr)
				 pointer parameter;

%include slt;

	declare addr		 builtin;

	declare template_slt_$slt_length
				 fixed bin ext;
	declare template_slt_$name_table_length
				 fixed bin ext;

	declare template_slt_$t_slt	 bit (36) aligned ext;
	declare template_slt_$t_name_table
				 bit (36) aligned ext;

	declare move_slt		 (template_slt_$slt_length) bit (36) aligned based;
	declare move_nt		 (template_slt_$name_table_length) bit (36) aligned based;

	declare (init_tox, init_fromx, x)
				 fixed bin;

	slt_ptr -> move_slt = addr (template_slt_$t_slt) -> move_slt;
	name_table_ptr -> move_nt = addr (template_slt_$t_name_table) -> move_nt;

	sltp = slt_ptr;

/*  It still remains to relocate the init segs in their proper place */

	init_fromx = slt.last_sup_seg + 1;
	init_tox = slt.first_init_seg;

	do x = 0 to slt.last_init_seg - slt.first_init_seg;
	     slt.seg (init_tox + x) = slt.seg (init_fromx + x);
	     slt.seg (init_fromx + x) = 0;
	end;

	slt_ptr -> slt.name_seg_ptr = name_table_ptr;
	return;
     end sslt_init_;




		    sslt_manager_.alm               11/05/86  1353.6r w 11/04/86  1039.4       92142



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"	Segment Loading Table Manager		MSPM BL.2.02	"
"							"
"	T.H. Van Vleck			5/19/67		"
"	Rewritten by N. I. Morris		12/27/67		"
"	Last modified by N. I. Morris		08/12/76		"
"							"
"	This program is a utility routine for use in system	"
"	initialization.  It is first called by the Bootstrap	"
"	Initializer, and remains useful well into the execution	"
"	of the Initializer Control Program.			"
"							"
"	Note:	THIS IS NOT A PURE PROCEDURE			"
"							"
"	The Segment Loading Table (SLT) contains an entry for	"
"	each segment that is part of the Multics Initializer	"
"	or hard-core supervisor.  Each entry contains useful	"
"	information about the segment, such as its name, number,	"
"	linkage status, etc.				"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	name	slt_manager


"  ******************************************************
"  *                                                    *
"  *                                                    *
"  * Copyright (c) 1972 by Massachusetts Institute of   *
"  * Technology and Honeywell Information Systems, Inc. *
"  *                                                    *
"  *                                                    *
"  ******************************************************


" Miscellaneous Equivalences:
	equ	wdsnm,32/4	words per segment name







	include	slt



	include	slte



	include	stack_header



	include	stack_frame


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	call slt_manager$init(sltptr)
"
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	use	transfer_vector

	entry	init
	tra	init

	use	main

init:
	epplb	ap|2,*		lb -> SLT pointer
	epplb	lb|0,*		lb -> SLT
	sprilb	slt_ptr		save pointer to the SLT

	eppab	lb|slt.name_seg_ptr,*  ab -> name table segment
	eppbb	lb|slt.first_sup_seg  bb -> limits for sup segs
	tsx2	search		search for and hash in sup seg names

	eppbb	lb|slt.first_init_seg  bb -> limits for init segs
	tsx2	search		search for and hash in init seg names

	tra	return



search:
	ldq	bb|1		get last seg to examine
	sbq	bb|0		minus first seg to examine
	eax5	1,ql		number of segs to examine in X5
	ldq	bb|0		first seg to examine in Q
	eax7	0,ql		place segno in X7
	mpy	slte_size,dl	compute SLT index
	epplp	lb|slt.seg,ql	lp -> SLT entry

search_loop:
	eax5	-1,5		test for completion
	tmi	0,2		return if not in this half of S(S)LT

	ldx0	lp|slte.names_ptr	pick up pointer to names
	eppbp	ab|segnam.name,0	bp -> first name
	tsx6	hash_in		insert names in hash table

	epplp	lp|slte_size	step to next SLT entry
	eax7	1,7		step segment number
	tra	search_loop	and keep looking

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	call slt_manager$build_entry(header, segptr, err)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	use	transfer_vector

	entry	build_entry
	tra	build_entry

	use	main

build_entry:
	tsx1	setup		set everything up

	eppbp	ap|2,*		bp -> header pointer
	eppbp	bp|0,*		bp -> header

	lda	bp|slte.init_seg_word is this an initialization segment?
	cana	slte.init_seg,dl	..
	tze	sup		if zero, supervisor segment

	aos	lb|slt.last_init_seg otherwise, init segment
	ldq	lb|slt.last_init_seg segment number in Q
	tra	jn		..

sup:
	aos	lb|slt.last_sup_seg	supervisor segment
	ldq	lb|slt.last_sup_seg	segment number in Q
	cmpq	lb|slt.first_init_seg are we overlapping the init segs?
	trc	error		fatal error if so

jn:
	lls	36+18		shift to left-half of A
	ora	itspair		make an ITS pair
	staq	ap|4,*		and return pointer to segment
	lrl	36+18		back to the right-half Q
	mpy	slte_size,dl	multiply by length of SLT entry
	epplp	lb|slt.seg,ql	lp -> slot for new SLT entry

	mlr	(pr),(pr)		fill in the SLT entry
	desc9a	bp|0,slte_size*4
	desc9a	lp|0,slte_size*4
	eppbp	bp|slte_size	bp -> next part of header

	eppab	lb|slt.name_seg_ptr,*  ab -> SLT name table
	lxl1	ab|name_seg.next_loc  X1 contains first unused location
	stx1	lp|slte.names_ptr	set name pointer in SLT entry
	eppab	ab|0,1		ab -> place for names

	ldq	bp|segnam.count	count of names in Q
	mpy	wdsnm+1,dl	multiply by length of each name
	adlq	1,dl		add 1 for name count itself
	qls	2		multiply by 4
	mlr	(pr,rl),(pr,rl)	copy the names
	desc9a	bp|0,ql
	desc9a	ab|0,ql
	a9bd	bp|0,ql		step pointers
	a9bd	ab|0,ql		..

	lda	lp|slte.branch_required_word Look for branch-required switch
	cana	slte.branch_required,dl Is path provided
	tze	end_entry		No, all finished for this entry

	eax1	ab|0		X1 -> path name
	sxl1	lp|slte.path_ptr	set path name pointer in SLT entry
	ldq	bp|0		character count of path name in Q
	adlq	7,dl		add in to cover count and round up
	qrl	2		round off
	qls	2		..
	mlr	(pr,rl),(pr,rl)	copy the path name
	desc9a	bp|0,ql
	desc9a	ab|0,ql
	a9bd	bp|0,ql		step pointers
	a9bd	ab|0,ql		..

	ldq	lp|slte.acl_provided_word see if ACL was provided
	canq	slte.acl_provided,du check the bit
	tze	end_entry		no ACL provided
	ldq	bp|0		get number of ACL items
	mpy	11,dl		multiply by item size
	adlq	1,dl		and add one for size word
	qls	2		get character count
	mlr	(pr,rl),(pr,rl)	copy the ACL
	desc9a	bp|0,ql
	desc9a	ab|0,ql
	a9bd	ab|0,ql		bump output pointer

end_entry:
	eax1	ab|0		X1 -> free space in name table
	epbpab	ab|0		ab -> base of name table segment
	sxl1	ab|name_seg.next_loc  save first unused loc'n in name table

	ldx0	lp|slte.names_ptr	get pointer to names again
	ldx7	ap|4,*		X7 contains segment number
	eppbp	ab|segnam.name,0		bp -> first name
	tsx6	hash_in		hash in these names

	tra	return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	call slt_manager$get_seg_ptr(name, ptr, err)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	use	transfer_vector

	entry	get_seg_ptr
	tra	get_seg_ptr

	use	main

get_seg_ptr:
	tsx6	get_seg		go search the SLT

	ora	itspair		make segno into an ITS pair
	ldq	0,dl		clear the Q
	staq	ap|4,*		and return the pointer

	tra	return		return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	call slt_manager$get_seg_num(name, num, err)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	use	transfer_vector

	entry	get_seg_num
	tra	get_seg_num

	use	main

get_seg_num:
	tsx6	get_seg		go search the SLT

	arl	18		right-justify the segment number
	sta	ap|4,*		and return the segment number

	tra	return		return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	call slt_manager$get_text_link_ptr(name, text_ptr, link_ptr, err)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	use	transfer_vector

	entry	get_text_link_ptr
	tra	get_text_link_ptr

	use	main

get_text_link_ptr:
	tsx6	get_seg		go search the SLT

	ora	itspair		make segno into a pointer
	ldq	0,dl		clear the Q
	staq	ap|4,*		return text pointer

	eppbp	sb|stack_header.lot_ptr,*  bp -> LOT
	szn	bp|0,au		linkage for this segment?
	tze	no_lkg		if not, return null lkg ptr
	lprpbp	bp|0,au		bp -> linkage
	spribp	ap|6,*		return linkage ptr to caller
	tra	return		and return

no_lkg:	ldaq	nullptr		make link pointer null
	staq	ap|6,*		..

	tra	return		and then return


" GET_SEG - Search the SLT for a Name.

get_seg:
	tsx1	setup		go to save sequence and initialization
	eppbp	ap|2,*		bp -> segment name (char(32) aligned)

	tsx1	hash_name		generate hash code from name
	ldx2	ab|name_seg.ht,al	get start of thread from hash table
get_seg_loop:
	tze	error		if zero thread, name not found

	eppbb	ab|0,2		bb -> name
	cmpc	(pr),(pr)		is this the one?
	desc9a	bp|0,32
	desc9a	bb|segnam.name-segnam.hp,32
	tze	get_seg_found	if so, return info

	ldx2	bb|0		get thread to next name
	tra	get_seg_loop	and loop

get_seg_found:
	lda	segnam.ref,dl	set referenced bit
	orsa	bb|0		..

	lda	bb|0		get thread word
	als	18-segnam.segno_shift  shift segno to AU
	ana	segnam.segno_mask,du  and mask
	tra	0,6		return to caller with segno in AU



" ERROR - Error Return Sequence.

error:
	ldx7	ap|0		pick up number of arguments
	aos	ap|0,7*		set the error code

" RETURN - Return Sequence.

return:
	eppap	sp|stack_frame.operator_ptr,*  restore ptr to caller's ops
	rtcd	sp|stack_frame.return_ptr  return to caller


" HASH_IN - Enter Names for New Segment in Hash Table.

hash_in:
	lxl3	bp|-segnam.name	count of names in X3

hloop:	tsx1	hash_name		generate hash code from this name
	ldx1	ab|name_seg.ht,al	X1 contains hash table entry
	eax0	bp|-segnam.name+segnam.hp  X0 -> new name
	stx0	ab|name_seg.ht,al	add new name to hash thread
	stx1	bp|-segnam.name+segnam.hp  chain new entry to list
	sxl7	bp|-segnam.name+segnam.hp  insert segno in thread word

	eppbp	bp|wdsnm+1	step to next name
	eax3	-1,3		count names
	tnz	hloop		loop until all names processed
	tra	0,6



" HASH_NAME - Generate Hash Code from Segment Name.

hash_name:
	ldq	bp|0		get first word of name
	erq	bp|2		exclusive in two more words
	erq	bp|3		..
	div	127,dl		divide to generate hash code
	tra	0,1		return with hash code in A

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Subroutines.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "



" SETUP - Execute SAVE Sequence and Get Pointer to SLT Segment.

setup:
	ldx0	ap|0		pick up number of arguments
	stz	ap|0,0*		zero out the error code

	epbplb	slt_ptr,*		lb -> base of SLT segment
	epplp	lb|slt.seg	lp -> beginning of SLT entries
	eppab	lb|slt.name_seg_ptr,*  ab -> name table segment
	tra	0,1		return to caller


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Storage and Constants.
"
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	even
itspair:	its	0,0		ITS pair template
nullptr:	its	-1,1		null pointer

	segref	checker_data_,slt_ptr


	join	/text/transfer_vector,main

	end	slt_manager




		    tape_reader_.pl1                07/16/87  1350.1r   07/15/87  1602.4       67563



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(87-01-13,GDixon), approve(87-04-16,MCR7614),
     audit(87-05-21,Farley), install(87-07-15,MR12.1-1040):
     Add support for storing boot program as first segment of MST image stored
     in a file.
                                                   END HISTORY COMMENTS */


/* TAPE_READER_ - Procedure to Read MST Checker Input Tape.
	iox'ed 11/3/76 by Noel I. Morris	*/

/* Modified 8/82 BIM signal EOF, backup */

/* format: style2 */

tape_reader_:
     proc (Data_ptr, N_words);

	dcl     Data_ptr		 ptr;
	dcl     N_words		 fixed bin (18);

	dcl     atd		 char (256);
	dcl     attach_descrip_ptr	 ptr;
	dcl     code		 fixed bin (35);
	dcl     1 control_word	 aligned,
		2 type		 fixed bin (17) unaligned,
		2 count		 fixed bin (18) uns unal,
	        (name_len, seg_len)	 fixed bin (18);

	dcl     attach_descrip	 char (500) varying based (attach_descrip_ptr);

	dcl     checker_data_$buffer_ptr
				 ptr ext;
	dcl     checker_data_$input_iocbp
				 ptr ext;
	dcl     checker_data_$file_attachment
				 bit (1) aligned ext;
	dcl     error_table_$end_of_info
				 fixed bin (35) ext;

	dcl     (addr, char, divide, length, ltrim, min, null, rtrim, size, substr)
				 builtin;

	dcl     com_err_		 entry () options (variable),
	        sub_err_		 entry () options (variable);

	dcl     MST_tape_eof_	 condition;


	if N_words = 0
	then return;

	call iox_$get_chars (checker_data_$input_iocbp, Data_ptr, N_words * 4, (0), code);

	if code = error_table_$end_of_info
	then signal MST_tape_eof_;
	else if code ^= 0
	then call sub_err_ (code, "checker_tape", ACTION_CANT_RESTART, null (), (0), "Error reading MST.");

	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* REWIND:						       */
/* 1) Close I/O switch to which MST attached.			       */
/* 2) Reopen the switch, thereby repositioning to beginning of MST.	       */
/* 3) Read, skip-over boot program.  On tape, boot program is in the tape    */
/*    label, invisible to iox_$get_chars.  In a file, boot program is the    */
/*    first "segment" stored in MST file, and IS visible to iox_$get_chars.  */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

rewind:
     entry (boot_prog_name, boot_prog_len);

	dcl     boot_prog_name	 char (32),
	        boot_prog_len	 fixed bin (21);

	call iox_$close (checker_data_$input_iocbp, code);
	if code ^= 0
	then call sub_err_ (code, "checker_tape", ACTION_CANT_RESTART, null (), (0), "Error closing MST.");
	call iox_$open (checker_data_$input_iocbp, Stream_input, ""b, code);
	if code ^= 0
	then call sub_err_ (code, "checker_tape", ACTION_CANT_RESTART, null (), (0), "Error reopening MST.");

	bpi.version = BOOT_PROGRAM_INFO_VERSION_1;
	bpi.boot_program_name = "";
	bpi.boot_program_text_length = 0;
	bpi.boot_program_ptr = null;
	if checker_data_$file_attachment
	then do;					/* file input    */
		call tape_reader_ (addr (control_word), size (control_word));
		if control_word.type = -1
		then do;				/* bootload program control word */
						/* It is written as a name, followed by the pgm.	*/
						/* set version */
			name_len = divide (length (boot_program_info.boot_program_name), CHARS_PER_WORD, 18, 0);
			seg_len = control_word.count - name_len;
						/* set copy length */
			call tape_reader_ (addr (bpi.boot_program_name), name_len);
			call tape_reader_ (checker_data_$buffer_ptr, seg_len);
						/* copy boot program in to temp seg */
			bpi.boot_program_text_length = seg_len;
		     end;
		else do;
			call iox_$close (checker_data_$input_iocbp, (0));
			call iox_$open (checker_data_$input_iocbp, Stream_input, ""b, (0));
		     end;
	     end;
	else do;					/* tape input    */
		call iox_$control (checker_data_$input_iocbp, "get_boot_program", addr (boot_program_info), code);
		if code ^= 0
		then do;				/* can't do it */
			call sub_err_ (code, "checker_tape", ACTION_CANT_RESTART, null (), (0),
			     "Error getting boot program info from MST.");
			return;
		     end;
	     end;
	boot_prog_name = bpi.boot_program_name;
	boot_prog_len = bpi.boot_program_text_length;

	return;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* INITIALIZATION:						       */
/* 1) If generate_mst -hold was given, then the mst_tape I/O switch remains  */
/*    attached to the MST.  Use it if it is attached.		       */
/* 2) Otherwise, make our own attachment to appropriate tape or file.  For   */
/*    files, remember to skip over the boot program.		       */
/* 3) Record in checker_data_$file_attachment whether we are dealing with    */
/*    an MST tape or a tape image stored in a file.		       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

init:
     entry (CALLER, name, density, file, Acode);

	dcl     CALLER		 char (*),
	        name		 char (*),
	        density		 fixed bin,
	        file		 bit (1) aligned,
	        Acode		 fixed bin (35);

	checker_data_$file_attachment = "0"b;
	call iox_$look_iocb ("mst_tape", checker_data_$input_iocbp, Acode);
	if Acode = 0
	then call iox_$open (checker_data_$input_iocbp, Stream_input, ""b, Acode);
	if Acode = 0
	then do;					/* ALREADY THERE */
		attach_descrip_ptr = checker_data_$input_iocbp -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr;
		if substr (attach_descrip, 1, min (length (attach_descrip), length ("vfile_ "))) = "vfile_ "
		then checker_data_$file_attachment = "1"b;
	     end;
	else do;					/* not yet attached */
		if file
		then do;
			atd = "vfile_ " || rtrim (name) || " -old";
			checker_data_$file_attachment = "1"b;
		     end;
		else do;
			atd = "tape_mult_ " || rtrim (name);
			if density ^= 0
			then atd = rtrim (atd) || " -density " || ltrim (char (density));
		     end;

		call iox_$attach_name ("mst_tape", checker_data_$input_iocbp, atd, null (), Acode);
		if Acode ^= 0
		then do;
			call com_err_ (Acode, CALLER, "Attaching ^a.", atd);
			return;
		     end;

		call iox_$open (checker_data_$input_iocbp, Stream_input, "0"b, Acode);
		if Acode ^= 0
		then do;
			call com_err_ (Acode, CALLER, "Opening mst tape input.");
			return;
		     end;
	     end;
	call rewind (bpi.boot_program_name, bpi.boot_program_text_length);
						/* position beyond boot pgm*/
	return;



final:
     entry;

	if checker_data_$input_iocbp ^= null
	then do;
		call iox_$close (checker_data_$input_iocbp, code);
		call iox_$detach_iocb (checker_data_$input_iocbp, code);
		checker_data_$input_iocbp = null;
	     end;

	return;

%include iocb;

%include iox_entries;

%include iox_modes;

%include sub_err_flags;

%include system_constants;

%include tape_mult_boot_info;

	dcl     1 bpi		 aligned like boot_program_info;

     end tape_reader_;




		    template_slt_.alm               06/01/84  1546.7r w 06/01/84  1426.8       90900



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	template_slt_
" Modified '82 for bootload Multics 10.2
" Modified '83 for adp by Keith Loepere.

	include	bootload_equs
	include	slt
	include	slte
	include	unpaged_page_tables
" 
	segdef	slt_length
	segdef	name_table_length
	segdef	t_slt
	segdef	t_name_table
	segdef	dseg,adp_dseg
	segdef	upt,init_upt,adp_upt,adp_init_upt
	segdef	dsbr,adp_dsbr

	macro	seg
	set	s.1,0
	set	s.2,0
&=&2,sup&[
	set	sup_segno,sup_segno+1
	set	s.segno,sup_segno
&;
	set	init_segno,init_segno+1
	set	s.segno,init_segno
	set	s.2,s.2+slte_uns.init_seg
&]
	equ	&1_seg_num,s.segno

	use	names
	dec	1		" count
	vfd	18/0,1/0,5/0,12/s.segno
	aci	"&1",32

	set	s.path,0
	set	s.rings,0
	set	s.max_length,0
	set	s.cur_length,0
	set	s.absloc,0
	set	s.access,0
	set	sf.abs_seg,0

	set	seg_index,seg_index+1
	equ	&1_index,seg_index
	&end


	bool	a.read,10
	bool	a.execute,04
	bool	a.write,02
	bool	a.privileged,01

	macro	access
&R&(	set	s.access,s.access+a.&i
&)
	&end


	macro	flags
&R&(	set	s.1,s.1+slte_uns.&i
	set	sf.&i,1
&)
	&end


	macro	flags2
&R&(	set	s.2,s.2+slte_uns.&i
&)
	&end


	macro	absloc
	set_o	s.cur_length,&2
	set	s.max_length,(s.cur_length/1024)
	set_o	s.absloc,&1
	&end


	macro	allocate
	set_o	s.cur_length,&1
	set	s.max_length,(s.cur_length/1024)
	set	s.absloc,first_free_word
	set	first_free_word,first_free_word+s.cur_length
	&end


	macro	branch
	set	s.2,s.2+slte_uns.branch_required
	set	s.path,name_seg_size
	set	s.rings,R055
	&end


	macro	unpaged_seg
	maclist	on
	use	sltes
	maclist	object
	zero	name_seg_size+sl1_path_size+10*seg_index,s.path
	vfd	4/s.access,14/s.1,18/s.2
	vfd	9/((s.cur_length+1023)/1024),9/s.rings,18/s.segno
	vfd	3/0,9/s.max_length,24/36*s.cur_length

	maclist	on
	use	template_dseg
	maclist	object
	vfd	24/s.absloc,9/s.rings,1/(1-sf.abs_seg),2/0
	vfd	1/0,14/(s.cur_length/16-1),4/s.access,1/1,1/1,1/0,14/0

	maclist	on
	use	adp_template_dseg
	maclist	object
	vfd	22/(s.absloc/16),4/0,1/(1-sf.abs_seg),9/s.rings
	vfd	14/(s.cur_length/16-1),4/0,12/0,4/s.access,1/1,1/1

	maclist	on
	use	definitions
	maclist	off
	segdef	&1_ptr
	segdef	&1_absloc
	segdef	&1_lth

	even
	maclist	on
&1_ptr:	its	s.segno,0
&1_absloc: vfd	36/s.absloc
&1_lth:	vfd	36/s.cur_length
	maclist	off
	&end


	macro	paged_seg
&=&2,sup&[
	use	template_upt
	set	s.upt_address,upt_end+upt_absloc+upt_entry.ptws
&;
	use	template_init_upt
	set	s.upt_address,iupt_end+iupt_absloc+upt_entry.ptws
&]
	maclist	on
	use	sltes
	maclist	object
	zero	name_seg_size+sl1_path_size+10*seg_index,s.path
	vfd	4/s.access,14/s.1,18/s.2
	vfd	9/((s.cur_length+1023)/1024),9/s.rings,18/s.segno
	vfd	3/0,9/s.max_length,24/36*s.cur_length

	maclist	off
&^=&3,norm&[
	set	s.page_table_length,s.max_length
&;
	set	s.page_table_length,(s.cur_length/1024)
&]
	maclist	on
	use	template_dseg
	maclist	object
	vfd	24/s.upt_address,9/s.rings,1/1,2/0
	vfd	1/0,14/(s.page_table_length*64-1),4/s.access,1/0,1/1,1/0,14/0

	maclist	on
	use	adp_template_dseg
	maclist	object
	vfd	26/s.upt_address,1/1,9/s.rings
	vfd	8/(s.page_table_length-1),10/0,12/0,4/s.access,1/0,1/1

	maclist	off
&=&2,init&[
	set	iupt_end,iupt_end+upt_entry.ptws+(((s.page_table_length)+1)/2)*2
	maclist	on
	use	template_init_upt
&;	set	upt_end,upt_end+upt_entry.ptws+(((s.page_table_length)+1)/2)*2
	maclist	on
	use	template_upt
&]	maclist	object
	vfd	36/s.page_table_length
	vfd	36/s.segno
	maclist	off
&^=&3,abs_seg&[
	set	s.running_absloc,s.absloc
	dup	(s.cur_length/1024)
	maclist	object
	vfd	18/(s.running_absloc/64),4o/10,1/1,1/0,2/0,1/0,1/0,1/0,1/0,1/0,1/1,1/0,1/1,2/1
	maclist	off
	set	s.running_absloc,s.running_absloc+1024
	dupend
&;&]
&^=&3,norm&[
	dup	(s.max_length-(s.cur_length/1024))
	maclist	object			" pad with bad pages
	vfd	18/0,4o/10,1/1,1/0,2/0,1/0,1/0,1/0,1/0,1/0,1/1,1/0,1/0,2/1
	dupend
&;&]
	even

	maclist	on
&=&2,init&[	use	adp_template_init_upt
&;	use	adp_template_upt
&]	maclist	object
	vfd	36/s.page_table_length
	vfd	36/s.segno
	maclist	off
&^=&3,abs_seg&[
	set	s.running_absloc,s.absloc
	dup	(s.cur_length/1024)
	maclist	object
	vfd	2/0,16/(s.running_absloc/1024),4/0,1/0,1/1,1/0,1/0,1/0,3/0,1/1,1/1,1/0,1/1,1/0,1/0
	maclist	off
	set	s.running_absloc,s.running_absloc+1024
	dupend
&;&]
&^=&3,norm&[
	dup	(s.max_length-(s.cur_length/1024))
	maclist	object			" pad with bad pages
	vfd	2/0,16/0,4/0,1/0,1/1,1/0,1/0,1/0,3/0,1/1,1/0,1/0,1/0,1/0,1/0
	dupend
&;&]
	even

	maclist	on
	use	definitions
	maclist	off
	segdef	&1_ptr
	segdef	&1_absloc
	segdef	&1_lth

	even
	maclist	on
&1_ptr:	its	s.segno,0
&1_absloc: vfd	36/s.absloc
&1_lth:	vfd	36/s.cur_length
	maclist	off
	&end
" 
	equ	FIRST_SUP_SEG,0
	equ	FIRST_INIT_SEG,256
	bool	R055,055
	
	set	sup_segno,FIRST_SUP_SEG-1
	set	init_segno,FIRST_INIT_SEG-1
	set	upt_end,upt.first_entry
	set	iupt_end,upt.first_entry
	set	seg_index,-1
	set	first_free_word,prb_absloc+prb_lth

	use	template_dseg
dseg:
	use	adp_template_dseg
adp_dseg:

	use	template_upt
	org	upt.first_entry

	use	template_init_upt
	org	upt.first_entry

	use	adp_template_upt
	org	upt.first_entry

	use	adp_template_init_upt
	org	upt.first_entry

	use	names
sl1_path:
	dec	17		" count
	aci	">system_library_1",17
	dec	0		" ACL
	equ	sl1_path_size,*-sl1_path


	maclist	off

	seg	dseg,sup		" The DSEG must be segment 0.
	access	read,write
	flags	wired,paged,per_process
	allocate	2000
	set	s.max_length,8
	paged_seg	dseg,init,norm	" dseg is perm but page table is temp
				" since it becomes paged

	use	.text
dsbr:	vfd	24/s.upt_address,12/0
	vfd	1/0,14/(1024/16-1),4/0,1/0,4/0,12/0

adp_dsbr:	vfd	26/s.upt_address,10/0
	vfd	8/(1024/1024-1),6/0,4/0,12/0,4/0,1/0,1/0

	seg	bos_toehold,sup
	access	read,write
	flags	wired,layout_seg
	absloc	10000,2000
	paged_seg	bos_toehold,sup,norm

	seg	config_deck,sup
	access	read,write
	absloc	12000,10000
	flags	abs_seg,paged
	branch
	paged_seg	config_deck,init,norm	becomes paged

	seg	dn355_mailbox,sup
	access	read,write
	flags	wired,layout_seg
	absloc	3400,3000
	unpaged_seg dn355_mailbox,sup

	seg	fault_vector,sup
	access	read,write
	flags	wired,layout_seg
	absloc	0,600
	unpaged_seg fault_vector,sup

	seg	flagbox,sup
	access	read,write
	flags	wired,layout_seg
	absloc	fgbx_absloc,fgbx_lth
	paged_seg	flagbox,sup,norm

	seg	name_table,sup
	access	read,write
	flags	paged
	allocate	14000
	set	s.max_length,12
	branch
	paged_seg	name_table,init,norm

	seg	slt,sup		" The SLT must be segment 7.
	access	read,write
	flags	paged
	allocate	4000
	branch
	paged_seg	slt,init,norm

	seg	toehold_data,sup
	access	read,write
	flags	wired,layout_seg
	absloc	toedata_absloc,toedata_lth
	paged_seg	toehold_data,sup,norm

	seg	iom_mailbox,sup
	access	read,write
	flags	wired,layout_seg
	absloc	1200,2200
	unpaged_seg iom_mailbox,sup

	seg	unpaged_page_tables,sup
	access	read,write
	flags	wired,layout_seg
	absloc	upt_absloc,upt_lth
	paged_seg	unpaged_page_tables,sup,norm

	seg	toehold,sup
	access	read,write
	flags	wired,layout_seg
	absloc	toe_absloc,toe_lth
	paged_seg	toehold,sup,norm

	seg	breakpoint_page,sup
	access	read,write
	flags	wired,layout_seg
	absloc	bkpt_absloc,bkpt_lth
	paged_seg	breakpoint_page,sup,norm

	seg	bound_bootload_0,init
	access	read,execute,write,privileged
	flags	paged,abs_seg	" we destroy ourselves
	absloc	bbl0_absloc,bbl0_lth
	paged_seg	bound_bootload_0,init,norm

	seg	physical_record_buffer,init
	access	read,write
	flags	paged
	absloc	prb_absloc,prb_lth
	paged_seg	physical_record_buffer,init,norm

	seg	abs_seg0,init
	access	read,execute,write,privileged
	flags	abs_seg
	set	s.max_length,256
	set	s.cur_length,0
	paged_seg abs_seg0,init,abs_seg

	seg	int_unpaged_page_tables,init
	access	read,write
	flags	paged,abs_seg	" we destroy ourselves
	absloc	iupt_absloc,iupt_lth
	paged_seg	int_unpaged_page_tables,init,norm

	seg	early_dump,init
	access	read,execute,write,privileged
	flags	abs_seg
	set	s.max_length,1
	set	s.cur_length,0
	paged_seg early_dump,init,abs_seg

	use	slt_header
t_slt:	its	name_table_seg_num,0
	vfd	36/first_free_word
	vfd	36/FIRST_SUP_SEG
	vfd	36/sup_segno
	vfd	36/FIRST_INIT_SEG
	vfd	36/init_segno
	dec	0


	equ	name_words,name_seg_size+sl1_path_size+(seg_index+1)*10

	use	name_header
t_name_table:
	zero	0,name_words
	bss	,name_seg_size-1


	use	template_header
name_table_length:
	vfd	36/name_words
slt_length:
	vfd	36/slt.seg+(seg_index+1)*slte_size

" This is so the checker can find things in this segment.

	use	map
	even
	zero	t_slt,t_name_table
	zero	-1,-1

	use	template_upt
	org	0
upt:	vfd	36/0			" sst_absloc
	vfd	36/0			" sst_last_loc
	vfd	36/upt_absloc		" upt_absloc
	vfd	36/upt_absloc+upt_lth-1 	" upt_last_loc
	vfd	36/iupt_absloc		" iupt_absloc
	vfd	36/iupt_absloc+iupt_lth-1 	" iupt_last_loc
	vfd	36/upt_end
	vfd	36/upt_lth

	use	template_init_upt
	org	0
init_upt:	vfd	36/0			" sst_absloc
	vfd	36/0			" sst_last_loc
	vfd	36/upt_absloc		" upt_absloc
	vfd	36/upt_absloc+upt_lth-1 	" upt_last_loc
	vfd	36/iupt_absloc		" iupt_absloc
	vfd	36/iupt_absloc+iupt_lth-1 	" iupt_last_loc
	vfd	36/iupt_end
	vfd	36/iupt_lth

	use	adp_template_upt
	org	0
adp_upt:	vfd	36/0			" sst_absloc
	vfd	36/0			" sst_last_loc
	vfd	36/upt_absloc		" upt_absloc
	vfd	36/upt_absloc+upt_lth-1 	" upt_last_loc
	vfd	36/iupt_absloc		" iupt_absloc
	vfd	36/iupt_absloc+iupt_lth-1 	" iupt_last_loc
	vfd	36/upt_end
	vfd	36/upt_lth

	use	adp_template_init_upt
	org	0
adp_init_upt: vfd	36/0			" sst_absloc
	vfd	36/0			" sst_last_loc
	vfd	36/upt_absloc		" upt_absloc
	vfd	36/upt_absloc+upt_lth-1 	" upt_last_loc
	vfd	36/iupt_absloc		" iupt_absloc
	vfd	36/iupt_absloc+iupt_lth-1 	" iupt_last_loc
	vfd	36/iupt_end
	vfd	36/iupt_lth

	join	/text/template_header
	join	/text/slt_header,sltes
	join	/text/name_header,names
	join	/text/template_dseg
	join	/text/adp_template_dseg
	join	/text/definitions
	join	/text/template_upt
	join	/text/adp_template_upt
	join	/text/template_init_upt
	join	/text/adp_template_init_upt

	join	/text/map			" this MUST be last

	end



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
