


		    cob_xfer_vector.alm             11/15/82  1814.7rew 11/15/82  1532.7        3861


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
	name	cob_xfer_vector
"
	entry	binoct
binoct:
	tra	<lang_util_>|[binoct]
"
	entry	vs
vs:
	tra	<lang_util_>|[vs]
"
	end
   



		    compare_defs_.pl1               11/16/82  1320.9rew 11/16/82  1317.1       42048


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


compare_defs_:	proc(optr,a_diff,a_brief,segptr);

dcl	optr pointer;
dcl	a_diff bit(1) unaligned;
dcl	a_brief bit(1) unaligned;
dcl	segptr pointer;

%include object_info;

dcl	1 oi(2) based(optr) aligned like object_info;

dcl	1 seg based(segptr),
		2 p(4) pointer,	/* segment pointers */
		2 sname(2) char(200) aligned;	/* segment names */


dcl	first bit(1) aligned init("1"b);
dcl	differ bit(1) aligned init("0"b);
dcl	brief bit(1) aligned;

dcl	1 def_header based aligned,
		2 def_list bit(18) unaligned,
		2 unused bit(54) unaligned;

/* Definition block returned by decode_definition_$full */

dcl	1 def(2) aligned,
		2 next_def pointer,
		2 last_def pointer,
		2 block_ptr pointer,
		2 section char(4) aligned,
		2 offset fixed bin,
		2 entrypoint fixed bin,
		2 symbol char(256) aligned,
		2 symbol_lng fixed bin,
		2 flags,
			3 new_format bit(1) unal,
			3 ignore bit(1) unal,
			3 entrypoint bit(1) unal,
			3 retain bit(1) unal,
			3 descr_sw bit(1) unal,
			3 unused bit(31) unal,
		2 n_args fixed bin,
		2 descr_ptr pointer;

dcl	arg_desc bit(36) aligned based;
dcl	dptr(n_args(1)) bit(18) unaligned based;


dcl	def_ptr(2) pointer;	/* points to definition block to be examined */
dcl	oip(2) pointer init(addr(oi(1)),addr(oi(2)));
dcl	stptr(2) pointer;	/* points to receiving structure for defs */
dcl	tp(2) pointer init(oi.textp(1),oi.textp(2));	/* text pointers */

dcl	are_defs bit(1) aligned init ("1"b);
dcl	end_thread(2) bit(1) aligned;
dcl	(i,j,lng) fixed bin (17);

/* function definitions */

dcl	decode_definition_$full entry(ptr,ptr,ptr) returns(bit(1) aligned);
dcl	ioa_ entry options(variable);

dcl	(addr,addrel,fixed,string,substr) builtin;

/* Initialize flag */

          stptr(1) = addr(def(1));
          stptr(2) = addr(def(2));
	                        /* points to receiving structure for defs */
	brief = a_brief;

/* Point to first definitions */

/* (decode_definition_ automatically points to first definition if given the header */


	def_ptr(1) = oi.defp(1);
	def_ptr(2) = oi.defp(2);

/* LOOP FOR DECODING DEFINITIONS */

	do while (are_defs);
		do i = 1 to 2;
			end_thread(i) = decode_definition_$full(def_ptr(i),stptr(i),oip(i));
		end;
		are_defs = ^(end_thread(1)|end_thread(2));
		if are_defs then

/* Compare the 2 definitions */

		do;
			if section(1) ^= section(2) then go to baddefs;
			if def.offset(1) ^= def.offset(2) then go to baddefs;
			if def.entrypoint(1) ^= def.entrypoint(2) then go to baddefs;
			if symbol_lng(1) ^= symbol_lng(2) then go to baddefs;
			lng = symbol_lng(1);
			if substr(symbol(1),1,lng) ^= substr(symbol(2),1,lng) then go to baddefs;
			if string(flags(1)) ^= string(flags(2)) then go to baddefs;
			if descr_sw(1) then
			do;
				if n_args(1) ^= n_args(2) then go to baddefs;
				do i = 1 to n_args(1) while
				(addrel(tp(1),descr_ptr(1)->dptr(i))->arg_desc =
				 addrel(tp(2),descr_ptr(2)->dptr(i))->arg_desc);
				end;
				if i <= n_args(1) then go to baddefs;
			end;
		end;

comploop:		def_ptr(1) = next_def(1);
		def_ptr(2) = next_def(2);
	end;

	if ^(end_thread(1)&end_thread(2)) then
	do;
		differ = "1"b;
		if end_thread(1) then
		do;
			i=2;
			j=1;
		end;
		else
		do;
			i=1;
			j=2;
		end;
		call ioa_("^/^a has more definitions than ^a.",sname(i),sname(j));
	end;

/* RETURN SECTION */

	a_diff = differ;
	return;

/* BADDEFS */

baddefs:	differ = "1"b;
	if ^brief then
	do;
		if first then
		do;
			call ioa_("^/**Definition discrepancies between the 2 segments have been found.^/");
			first = "0"b;
		end;
		do j = 1 to 2;
			call ioa_
("^/^a:^/^-section = ^a^-offset = ^o^-entrypoint = ^o^/^-symbol = ^a^/^-symbol_lng = ^o
^-new_format = ^o^-ignore = ^o^-ep = ^o^-retain = ^o^-descr_sw = ^o",sname(j),section(j),def.offset(j),
def.entrypoint(j),symbol(j),symbol_lng(j),fixed(new_format(j),1),
fixed(ignore(j),1),fixed(flags.entrypoint(j),1),fixed(retain(j),1),fixed(descr_sw(j),1));
			if descr_sw(j) then
			do;
				call ioa_("^-n_args = ^d^/^/^-argument descriptors:^/",n_args(j));
				do i = 1 to n_args(j);
					call ioa_("^-^w",addrel(tp(j),descr_ptr(j)->dptr(i))
					->arg_desc);
				end;
			end;
		end;
		call ioa_("^/");
	end;
	go to comploop;

end;



		    compare_link_.pl1               06/03/83  1338.8r   06/03/83  1330.4       54000


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

compare_link_:	proc(optr,a_diff,a_brief,segptr);

/* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */

dcl	optr pointer;
dcl	a_diff bit(1) unaligned;
dcl	a_brief bit(1) unaligned;
dcl	segptr pointer;

%include object_info;


%include interpret_link_info;
%include linkdcl;

dcl	1 oi(2) based(optr) aligned like object_info;

dcl	1 seg based(segptr),
		2 p(4) pointer,	/* segment pointers */
		2 sname(2) char(200) aligned;	/* segment names */


dcl	differ bit(1) aligned init("0"b);
dcl	brief bit(1) aligned;


/* Linkage Info for printing */

dcl 1 link_info (2) aligned like interpret_link_info;


dcl	liptr(2) ptr;
dcl	lptr(2) pointer;

dcl	rptr(2) pointer;	/* relocation pointers */

dcl	lp(2) pointer;
dcl	sp(2) pointer;
dcl	tp(2) pointer;

dcl	relwrd(oi.llng(1)+oi.llng(2)) based(rptr(1)) fixed bin(17);

dcl	even bit(1) aligned init("1"b);
dcl	last_ne bit(1) aligned init("0"b);

dcl	code fixed bin(17);
dcl	first bit(1) aligned init("1"b);
dcl	limit fixed bin(17);
dcl	loff(2) fixed bin(17);
dcl	(i,j) fixed bin(17);
dcl	lword fixed bin(17) based;
dcl	nwords fixed bin (17);
dcl	nw(2) fixed bin(17);
dcl	rname char(14) int static init("compare_object");
dcl	start(2) fixed bin(17);
dcl	word(limit) fixed bin(17) based;

/* Function Definitions */

dcl	ioa_ entry options (variable);
dcl	display_text_ entry(ptr,ptr,fixed bin,fixed bin,fixed bin);
dcl	com_err_ entry options(variable);
dcl	interpret_link_$tptr entry(ptr,ptr,ptr,fixed bin);
dcl	(addr,addrel,divide,fixed,min,size,string,substr) builtin;

/* INITIALIZE */

	brief = a_brief;
	substr(link_info(1).entry_point_name,33,4) = "    ";
	substr(link_info(2).entry_point_name,33,4) = "    ";
	liptr(1) = addr(link_info(1));
	liptr(2) = addr(link_info(2));
	lp(1) = oi.linkp(1);
	lp(2) = oi.linkp(2);
	tp(1) = oi.textp(1);
	tp(2) = oi.textp(2);


/* COMPARE INTERNAL STATIC */

	if ^ oi.separate_static(1)
	then do;
	     do i=1 to 2;
	     nw(i) = fixed(lp(i) -> header.begin_links,18) - size(header);
	     end;

	     call comp_stat(lp,size(header));
	     end;

/* COMPARE LINKS */
/* zero out relocation bits */

	rptr(1) = p(3);
	rptr(2) = addrel(rptr(1),oi.llng(1));
	relwrd = 0;

/* initialize search */

	first = "1"b;
	do i = 1 to 2;
		loff(i) = fixed(lp(i) -> header.begin_links,17);
		nw(i) = oi.llng(i) - loff(i);
	end;

/* Check for same number of links */

	if nw(1) = nw(2) then limit = nw(1);
	else
	do;
		limit = min(nw(1),nw(2));
		differ = "1"b;
		call ioa_("^/**^a has ^d words of links while ^a has ^d words of links.",
			sname(1),nw(1),sname(2),nw(2));
	end;

/* MAIN COMPARISON LOOP */

	do i = 1 to limit;
		lptr(1) = addrel(lp(1),loff(1));
		lptr(2) = addrel(lp(2),loff(2));
		if even then	/* if even we have to look for ft2 flags */
		do;
			if lptr(1)->link.ft2 ^= lptr(2)->link.ft2 then go to odd;
			if lptr(1)->link.ft2 ^= "100110"b then go to odd;

			/* We've found 2 link pairs */

			if last_ne then call badtext;
			do j = 1 to 2;
				link_info(j).version = INTERPRET_LINK_INFO_VERSION_1;
				call interpret_link_$tptr(liptr(j),lptr(j),tp(j),code);
				if code ^= 0 then
				do;
					call com_err_(code,rname,sname(j));
					go to return;
				end;
			end;
			if string(link_info(1)) ^= string(link_info(2)) then
			do;
				differ = "1"b;
				if ^brief then
				do;
					if first then call title;
					do j = 1 to 2;
						call ioa_("^a(^o):^-^a^a^a^a^a",
							sname (j), loff (j),
							link_info (j).segment_name,
							link_info (j).entry_point_name,
							link_info (j).expression,
							link_info (j).modifier,
							link_info (j).trap);
					end;
					call ioa_("^/");
				end;
			end;
			i = i + 1;
			loff(1) = loff(1) + 2;
			loff(2) = loff(2) + 2;
		end;

		/* We have plain text (entry sequences) to check */

		else
odd:		do;
			if last_ne then if lptr(1)->lword=lptr(2)->lword then call badtext;
				else;
			else if lptr(1)->lword ^= lptr(2)->lword then
				do;
					last_ne = "1"b;
					start(1) = loff(1);
					start(2) = loff(2);
				end;
			even = ^even;
			loff(1) = loff(1) + 1;
			loff(2) = loff(2) + 1;
		end;
	end;
	if last_ne then call badtext;
/* RETURN SECTION */

return:	a_diff = differ;
	return;

/* COMPARE STATIC */

compare_static_:	entry(optr,a_diff,a_brief,segptr);

	brief = a_brief;
	sp(1) = oi.statp(1);
	sp(2) = oi.statp(2);
	nw(1) = oi.ilng(1);
	nw(2) = oi.ilng(2);
	call comp_stat(sp,0);
	a_diff = differ;
	return;

/* COMP_STAT */

comp_stat:     proc(pt,inc);

dcl	(p(2),pt(2)) ptr;
dcl	inc fixed bin;

	p(1) = pt(1);
	p(2) = pt(2);

	if nw(1) = nw(2)
	then limit = nw(1) + inc;
	else do;
	     limit = min(nw(1),nw(2)) + inc;
	     differ = "1"b;
	     call ioa_("^/**Internal static for ^a has ^d words while that of ^a has ^d words.",
		     sname(1),nw(1),sname(2),nw(2));
	     end;

	do i = inc + 1 to limit;
	if p(1) -> word(i) ^= p(2) -> word(i)
	then do;
	     differ = "1"b;
	     if ^ brief
	     then do;
		if first
		then do;
		     first = "0"b;
		     call ioa_
("^/**Internal Static Discrepancies^/^/Location^-^-^2xSegment 1^-^2xSegment 2^/");
		     end;
		call ioa_("^o^-^-^w^-^w",i-1,p(1)->word(i),p(2)->word(i));
		end;
	     end;
	end;

end;

/* BADTEXT */

badtext:	proc;
	nwords = loff(1) - start(1);
	last_ne = "0"b;
	differ = "1"b;
	if ^brief then
	do;
		if first then call title;
		do j = 1 to 2;
			call ioa_("^/^a:",sname(j));
			call display_text_(lp(j),rptr(j),start(j),nwords,oi.llng(j));
		end;
		call ioa_("^/");
	end;
end;

/* TITLE */

title:	proc;
	first = "0"b;
	call ioa_("^/**Link discrepancies have been found.^/");
end;

end;



		    compare_object.pl1              10/15/84  1048.7rew 10/15/84  1024.1       91323


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


/*
	 Written:	20 Sept 1972 by Richard A. Barnes
	Modified:	4 May 1977 by RAB for get_temp_segments_
	Modified: 17 August 1977 by MBW for perprocess static switch	
	Err msgs fixed to contain target pathname S. Herbst 07/23/79
	Usage message added 10/03/79 S. Herbst
	Utilize date_time_$format("date_time" 06/19/84 J A Falksen */
compare_object:	cob:	procedure;
dcl	alen fixed bin(17);
dcl	aptr pointer;
dcl	arg char(alen) unaligned based(aptr);
dcl	arg_num fixed bin(17) init(3);
dcl	code fixed bin(35);		/* error code */
dcl	command bit(1) aligned;	/*  "1"b if invoked as command */
dcl	command_error condition;
dcl	dname(2) char(168);		/* directory pathname */
dcl	ename(2) char(32);		/* entry name */
dcl	have_ptrs bit(1) aligned;	/* "1"b if object ptrs provided */
dcl	(i,j) fixed bin;
dcl	line char(80) varying aligned;
dcl	isparm bit(1) init("1"b);
dcl	nbits(2) fixed bin(24);
dcl	oip ptr;
dcl	1 parm,
		2 brief bit(1) unaligned init("0"b),
		2 all unaligned,
		 (3 text bit (1),
		 3 defs bit(1),
		 3 link bit(1),
		 3 static bit(1),
		 3 symbol bit(1))  init ("0"b);
dcl	path (2) char(168);
dcl	qual bit(1) init("0"b);
dcl	1 relinfo based aligned,
	2 decl_vers fixed bin,
	2 n_bits fixed bin,
	2 relbits bit(0 refer(relinfo.n_bits));
dcl	serious bit(1) aligned;
dcl	time char(64)var;
dcl	segp ptr;
dcl	1 seg,
		2 p(2) pointer init ((2) null),	/* segment pointers */
		2 scratch(2) pointer init((2) null),	/* scratch for relocation bits */
		2 sname(2) char(200);	/* segment names */
dcl	1 result,
		(2 text,
		2 defs,
		2 link,
		2 static,
		2 symbol,
		2 perprocess_static,
		2 length) bit(1) unaligned init ("0"b);
dcl	rslt(7) bit(1) defined(result);
dcl	keyword(14) char(8) aligned static init("-brief","-text","-defs","-link","-static","-symbol",
		 "-all", "-bf"," "," ", "-lk","-stat","-sym","-a") options (constant);
dcl	nparm fixed bin(17) init(divide(hbound(keyword,1),2,17,0));
dcl	bits(6) bit(1) defined (parm);
dcl	token char(8);
dcl	error_table_$badopt external fixed bin(35);
dcl	rname char(14) init("compare_object") static options(constant);
dcl	word char(14) varying;
%include object_info;

dcl	1 oi(2) aligned like object_info;

/*  function declarations */

dcl	date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
dcl	cu_$arg_ptr entry(fixed bin,ptr,fixed bin,fixed bin(35));
dcl	expand_pathname_ entry(char(*),char(*),char(*),fixed bin(35));
dcl	get_equal_name_ entry(char(*),char(*),char(*),fixed bin(35));
dcl	hcs_$initiate_count entry(char(*),char(*),char(*),fixed bin(24),fixed bin(12),
		ptr,fixed bin(35));
dcl	(get_temp_segments_, release_temp_segments_) entry(char(*),(*) ptr,fixed bin(35));
dcl	object_info_$long entry(ptr,fixed bin(24),ptr,fixed bin(35));
dcl	(com_err_, com_err_$suppress_name) entry options(variable);
dcl	ioa_ entry options(variable);
dcl	compare_text_ entry(ptr,bit(1),bit(1),ptr);
dcl	compare_defs_ entry (ptr,bit(1),bit(1),ptr);
dcl	compare_link_ entry (ptr,bit(1),bit(1),ptr);
dcl	compare_static_ entry (ptr,bit(1),bit(1),ptr);
dcl	hcs_$terminate_noname entry(ptr,fixed bin(35));

dcl (addr, divide, hbound, mod, null, rtrim, string, substr) builtin;

dcl	cleanup condition;

	command = "1"b;
	have_ptrs = "0"b;
	go to join;

compare_object_$ptr:	entry(ptr1,len1,ptr2,len2) returns(bit(1) aligned);

dcl	ptr1 ptr,		/* ptr to first object segment */
	len1 fixed bin(24),	/* bit_count of first object segment */
	ptr2 ptr,		/* ptr to second object segment */
	len2 fixed bin(24);	/* bit_count of second object segment */

	have_ptrs = "1"b;
	p(1) = ptr1;
	p(2) = ptr2;
	nbits(1) = len1;
	nbits(2) = len2;
	sname(1) = " ";
	sname(2) = " ";
	go to not_command;

compare_object_:	entry(P_path1,P_path2) returns(bit(1) aligned);

dcl	(P_path1,P_path2) char(*);	/* pathnames of segs to be compared */

	have_ptrs = "0"b;
	path(1) = P_path1;
	path(2) = P_path2;

not_command:
	command = "0"b;
	parm.brief = "1"b;
	isparm = "0"b;
	on condition(command_error) string(result) = "111111"b;

/* set up 2 segments for comparison */

join:
	oip = addr(oi);
	segp = addr(seg);

	on condition(cleanup) call clean_up;

	do j= 1 to 2;
	     if ^ have_ptrs
	     then do;
		if command
		then do;
		     call cu_$arg_ptr(j,aptr,alen,code);
		     if code ^= 0 then do;
			call com_err_$suppress_name (0, "compare_object",
			     "Usage:  compare_object oldpath newpath {-control_args}");
			return;
		     end;
		     path(j) = arg;
		     end;
		call expand_pathname_(path(j),dname(j),ename(j),code);
		if code ^= 0 then call error(path(j));
		if j = 2 then
		do;
			call get_equal_name_(ename(1),(ename(2)),ename(2),code);
			if code ^= 0 then call error(ename(2));
		end;
		sname(j) = rtrim(dname(j)) || ">" || ename(j);
		call hcs_$initiate_count(dname(j),ename(j),"",nbits(j),1,p(j),code);
		if p(j)=null then call error(sname(j));
		end;

	     /* get object information */

	     oi(j).version_number = object_info_version_2;


	     call object_info_$long(p(j),nbits(j),addr(oi(j)),code);
	     if code ^= 0 then call error(sname(j));


	end;

/* Check for consistency of type for the 2 segments */

	if oi.old_format(1) ^= oi.old_format(2) then call error
		("Cannot compare old format segment with new format segment.");

	if oi.separate_static(1) ^= oi.separate_static(2)
	     then call error("Cannot compare separate static segment with non separate static segment.");

	if oi.compiler(1) ^= oi.compiler(2)
	     then call error("The 2 segments were compiled by incompatible compilers.");

	if oi.relocatable(1) ^= oi.relocatable(2)
	     then call error("Cannot compare relocatable with nonrelocatable object segment.");

	if oi.perprocess_static(1) ^= oi.perprocess_static(2)
	     then do;
		result.perprocess_static = "1"b;
		if ^brief then call ioa_ ("The 2 segments have different perprocess static attributes.");
	     end;


/* Get the parameters */

	do while (isparm);
		call cu_$arg_ptr(arg_num,aptr,alen,code);
		if code ^= 0 then isparm = "0"b;
		else
		do;
			token=arg;
			do i= 1 to hbound(keyword,1) while(token^=keyword(i));
			end;
			if i <= hbound(keyword,1) then
			do;
				i = mod(i-1,nparm) + 1;
				if i=nparm then string(all)="11111"b;
				else
				do;
					bits(i) = "1"b;
					if i >= 2 then qual = "1"b;
				end;
			end;
			else
			do;
				code = error_table_$badopt;
				call error(token);
			end;
		end;
		arg_num = arg_num + 1;
	end;
	if ^qual then string(all) = "11111"b;

	if ^oi.separate_static(1)
	then if parm.static
	     then do;
		parm.link = "1"b;
		parm.static = "0"b;
		end;

/* display information about the segment */

	if ^brief
	then do j = 1 to 2;
		call ioa_("^/^a:  (segment ^d)",sname(j),j);
		time = date_time_$format ("date_time",oi(j).compile_time,"","");
		call ioa_("^a^4x^a^/",time,oi(j).compiler);
	     end;

/* Compare lengths returned by object_info_ */

	if oi.tlng(1) ^= oi.tlng(2) then call badlen("text",oi.tlng);
	if oi.dlng(1) ^= oi.dlng(2) then call badlen("defs",oi.dlng);
	if oi.llng(1) ^= oi.llng(2) then call badlen("link",oi.llng);
	if oi.ilng(1) ^= oi.ilng(2) then call badlen("stat",oi.ilng);
	if oi.slng(1) ^= oi.slng(2) 
	then do;
		call badlen("symb",oi.slng);
		if ^brief & oi.relocatable(1)
		then do;
		     serious = "1"b;
		     if oi.rel_def(1) -> relinfo.n_bits = oi.rel_def(2) -> relinfo.n_bits
		     then if oi.rel_text(1) -> relinfo.n_bits = oi.rel_text(2) -> relinfo.n_bits
			then if oi.rel_link(1) -> relinfo.n_bits = oi.rel_link(2) -> relinfo.n_bits
			     then if oi.rel_link(1) -> relinfo.relbits = oi.rel_link(2) -> relinfo.relbits
				then if oi.rel_text(1) -> relinfo.relbits = oi.rel_text(2) -> relinfo.relbits
				     then serious = "0"b;
		     if serious
			then word = "may be serious";
			else word = "is trivial";

		     call ioa_("The discrepancy ^a",word);
		     end;
	     end;

/* Set up scratch segment for relocation bits */

	call get_temp_segments_(rname,scratch,code);
	if code ^= 0
	     then call error("scratch seg for relocation bits");

/* DO TEXT COMPARISON */

	if parm.text then call compare_text_(oip,result.text,parm.brief,segp);

/* DO DEFS COMPARISON */

	if parm.defs then call compare_defs_(oip,result.defs,parm.brief,segp);

/* DO LINK COMPARISON */

	if parm.link then call compare_link_(oip,result.link,parm.brief,segp);

/* DO STATIC COMPARISON */

	if parm.static then call compare_static_(oip,result.static,parm.brief,segp);

/*  RETURN SECTION */


	if command
	then do;
		if string(result) then
		do;
			call ioa_
("^/The following sections or attributes of the object segments do not match:");
			line = "^/";
			if result.length then line = "length  ";
			if result.perprocess_static then line = line || "perprocess_static ";
			do j = 1 to hbound(rslt,1)-2;
				if rslt(j) then line = line || substr(keyword(j+1),2);
			end;
			call ioa_(line);
		end;
		else call ioa_("The 2 segments match.");
	     end;

return:	call clean_up;
	if command
	     then return;
	     else return(substr(string(result),1,4) = "0000"b);


clean_up:	proc;

	do j = 1 to 2;
		if p(j) ^= null
		then do;
		     if ^ have_ptrs
		     then do;
			call hcs_$terminate_noname(p(j),code);
			p(j) = null;
			end;
		     end;
	end;

	call release_temp_segments_(rname,scratch,code);

end;

/* ERROR SECTION */

error:	proc (msg);
dcl	msg char(*);
	if command
	     then call com_err_(code,rname,msg);
	     else string(result) = "1111111"b;
	go to return;
end;

badlen:	proc (type,array);
dcl	type char(4);
dcl	array(*) fixed bin(17);
	if ^brief then call ioa_("Lengths of the ^a section of the 2 segments do not agree. ^/^a : ^d ^/^a : ^d",
		type,sname(1),array(1),sname(2),array(2));
	result.length = "1"b;
	return;
end;

end;
 



		    compare_text_.pl1               11/15/82  1814.7rew 11/15/82  1501.0       76266


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


compare_text_:	proc (optr,a_diff,a_brief,segptr);

/*	Modified:	2 May 1977 by RAB to improve IC checking	*/
/*	Modified: 4 May 1977 by SHW to use new calling sequence for display_text_  */
/*	Modified:	9 April 1979 by RAB to improve comparison of text references */

dcl	optr pointer;


%include object_info;

dcl	1 oi(2) based(optr) aligned like object_info;

dcl	a_diff bit(1) unaligned;

dcl	a_brief bit(1) unaligned;

dcl	segptr pointer;

dcl	1 seg based(segptr),
		2 p(4) pointer,	/* segment pointers */
		2 sname(2) char(200) aligned;	/* segment names */


dcl	differ bit(1) aligned init("0"b);
dcl	brief bit(1) aligned;
dcl	first bit(1) aligned init("1"b);

dcl	(i,j,k) fixed bin(17);
dcl	limit fixed bin;
dcl	r pointer;
dcl	onp pointer;
dcl	1 rel_tab based(r) aligned,
		2 array(limit) unaligned,
			3 dummy unal bit(13),
			3 rbits unal bit(5);
dcl	rptr(2) pointer;	/* pointers to unpacked relocation bits */

dcl	tl(2) fixed bin(17) init(oi.tlng(1),oi.tlng(2));	/* TEXT LENGTHS */
dcl	tlmax fixed bin(17);
dcl	tp(2) pointer init(oi.textp(1),oi.textp(2));	/* TEXT POINTERS */

dcl	rscan fixed bin (17);	/* relocation scanner */
dcl	1 relinfo based,
		2 decl_vers fixed bin(17),
		2 n_bits fixed bin (17),
		2 relbits bit(nb refer(n_bits));

dcl	rt(2) pointer init(oi.rel_text(1),oi.rel_text(2));	/* pointers to packed relocation bits */

dcl	minwords fixed bin int static init(5);
dcl	(af,aj,bf,bj) fixed bin;

dcl	tlen(2) fixed bin;		/* LENGTHS LEFT TO BE SCANNED */
dcl	ilc(2) fixed bin;		/* SCANNERS */

dcl	word(0:65535) bit(36) aligned based;	/* ARRAY USED FOR NORMAL SCANNING */

dcl	1 inst(0:65535) based aligned,	/* ARRAY OF INSTRUCTIONS FOR IC CHECKING */
	2 address fixed bin(17) unal,
	2 right unaligned,
	  3 op_code bit(10) unal,
	  3 inhibit bit(1) unal,
	  3 ext_base bit(1) unal,
	  3 tag bit(6) unal;


/* function declarations */

dcl	display_text_ entry(ptr,ptr,fixed bin,fixed bin,fixed bin,ptr);
dcl	get_operator_names_ptr_ entry (char (*), ptr);
dcl	ioa_ entry options(variable);

dcl	(addr,addrel,divide,fixed,index,max,min,mod,null,string,substr) builtin;

	brief = a_brief;
	if ^brief then call get_operator_names_ptr_ ((oi (1).compiler), onp);
	tlmax = max(tl(1),tl(2));


/* Check for old style object segment and adjust relocation pointers accordingly */

	if oi.old_format(1) & rt(1) ^= null
	then do;
		rt(1) = addrel(rt(1),-1);
		rt(2) = addrel(rt(2),-1);
	     end;

/* DO TEXT COMPARISON */


/* Convert relocation info to unpacked form */

		rptr(1) = p(3);
		rptr(2) = p(4);
		if rt(1) ^= null
		then do j = 1 to 2;	/*  for each segment */
			rscan = 1;
			r = rptr(j);
			limit = 2 * tl(j);
			k = 1;

search_1:			i = index(substr(rt(j)->relbits,rscan),"1"b);
			if i ^= 0
			then do;
				rscan = rscan + (i - 1);
				k = k + (i - 1);
				if k > limit then go to jloop;
				if substr(rt(j)->relbits,rscan,5)="11110"b
				then do;
					k = k + fixed(substr(rt(j)->relbits,rscan+5,10),17);
					rscan = rscan + 15;
				     end;
				else do;
					rbits(k) = substr(rt(j)->relbits,rscan,5);
					k = k + 1;
					rscan = rscan + 5;
				     end;
				go to search_1;
			     end;

jloop:		     end;

/*  SECTION TO DO THE ACTUAL SCANNING */

/* Initialize scanners */

	tlen(1) = tl(1);
	tlen(2) = tl(2);
	ilc(1), ilc(2) = 0;

/* Main loop, skip through blocks of matching lines */

l1:
	if tlen(1) <= 0
	then if tlen(2) <= 0
	     then do;
stop:		a_diff = differ;
		return;
		end;
	     else do;		/* A finished, print B */
		differ = "1"b;
		if ^brief
		then do;
		     call print(1,2,tlen(2));
		     call ioa_("^RAdded to end.^B");
		     end;
		go to stop;
		end;
	if tlen(2) <= 0
	then do;
	     differ = "1"b;		/* B finished, print A */
	     if ^brief
	     then do;
		call print(1,1,tlen(1));
		call ioa_("^RDeleted from end.^B");
		end;
	     go to stop;
	     end;

/* COMPARE */

	if tp(1) -> word(ilc(1)) = tp(2) -> word(ilc(2))	/* If lines equal, */
	then do;
check_reloc:
	     if rptr(1) -> word(ilc(1)) = rptr(2) -> word(ilc(2))
	     then do;				/* then move up the scanners */
		ilc(1) = ilc(1) + 1;
		ilc(2) = ilc(2) + 1;
		tlen(1) = tlen(1) -1;
		tlen(2) = tlen(2) - 1;
		go to l1;
		end;
	     end;
	else if check_ic(ilc(1),ilc(2))
	     then go to check_reloc;

/*  No match, start looking for matching group to sync on */

	af, bf = 1;
	differ = "1"b;
	if brief then go to stop;

l2:
	if minwords > tlen(2)	/* Make sure we don't run off the end */
	     then go to nomatch;

	if (af+minwords) > tlen(1)	/* Ditto */
	     then go to nomatch;

	if equal(af,0)		/* First, look for a match on the first line */
	     then do;
		bf = 0;
		go to rematch;
		end;

	if (bf+minwords) > tlen(2)	/* Again, watch out for end of segment */
	     then go to nomatch;

	bj = 0;
	do i = 1 to bf while(bj = 0);	/* Look for a matching group */
	     if equal(af,i)
		then bj = i;
	end;

	if minwords > tlen(1)	/* Watch out for end of segment */
	     then go to nomatch;

	if equal(0,bf)		/* Look for match the other way on the first line */
	     then do;
		af = 0;
		go to rematch;
		end;

	if bj > 0
	     then do;
		bf = bj;
		go to rematch;
		end;

	aj = 0;			/* Scan for a matching group */
	do i = 1 to af while (aj = 0);
	     if equal(i,bf)
		then aj = i;
	end;

	if aj > 0
	     then do;
		af = aj;
		go to rematch;
		end;

/* Look further in each segment for a matching group */

	af = af + 1;
	bf = bf + 1;
	go to l2;

/* No match, entire ends of files changed */

nomatch:
	af = tlen(1);
	bf = tlen(2);

/* We have found a match to resync with if we get here by a goto */

rematch:
	if af <= 0
	then do;
	     call print(1,2,bf);
	     call ioa_("^RInserted before:^B");
	     call print(0,1,(minwords));
	     end;
	else if bf <= 0
	     then do;
		call print(1,1,af);
		call ioa_("^RDeleted before:^B");
		call print(0,2,(minwords));
		end;
	     else do;
		call print(1,1,af);
		call ioa_("^RChanged to:^B");
		call print(1,2,bf);
		end;

	call ioa_("^2/");
	tlen(1) = tlen(1) - af;
	tlen(2) = tlen(2) - bf;
	go to l1;
/*  INTERNAL PROCEDURE FOR COMPARING BLOCKS OF CODE */

equal:	proc(astart,bstart) returns(bit(1) aligned);
dcl	(a,astart,b,bstart,i) fixed bin;

	a = astart + ilc(1);
	b = bstart + ilc(2);

	do i = 0 to minwords - 1;
	     if tp(1) -> word(i+a) ^= tp(2) -> word(i+b)
	     then if ^ check_ic(i+a, i+b)
		then return("0"b);
	     if rptr(1) -> word(i+a) ^= rptr(2) -> word(i+b)
		then return("0"b);
	end;

	return("1"b);
end;


/* INTERNAL PROCEDURE FOR DISPLAYING BAD TEXT */

print:	proc(bumpsw,which,plen);
dcl	(i,bumpsw,which,len,plen) fixed bin;

	i = which;
	len = plen;

	if first
	     then do;
		call ioa_("^2/**Text discrepancies between the 2 segments have been found.^2/");
		first = "0"b;
		end;

	call ioa_("^a:",sname(i));
	call display_text_(tp(i),rptr(i),ilc(i),len,tl(i),onp);

	if bumpsw ^= 0
	     then ilc(i) = ilc(i) + len;
end;


/* INTERNAL PROCEDURE TO SEE IF TWO DIFFERING INSTRUCTIONS ARE REALLY THE SAME, DIFFERING
ONLY IN THE OFFSET FOR IC MODIFICATION OR TEXT REFERENCING

   check_ic is heuristic not algorithmic */

check_ic:	proc(a,b) returns(bit(1) aligned);

dcl	a fixed bin,	/* location being compared in seg 1 */
	b fixed bin;	/* location being compared in seg 2 */

dcl	a1 fixed bin,	/* operand address in seg 1 */
	b1 fixed bin;	/* operand address in seg 2 */

	differ = "1"b;

	if string(tp(1) -> inst(a).right) = string(tp(2) -> inst(b).right)
	 & ^ tp(1) -> inst(a).ext_base
	then if tp(1) -> inst(a).tag = "000100"b	/* IC */
	      | tp(1) -> inst(a).tag = "010100"b	/* IC* */
	      | tp(1) -> inst(a).tag = "000000"b	/* (text) */
	     then do;
		a1 = tp(1) -> inst(a).address;
		b1 = tp(2) -> inst(b).address;

		if substr(tp(1) -> inst(a).tag,4,1)	/* IC */
		then do;
		     a1 = a1 + a;
		     b1 = b1 + b;
		     end;

		if b1 >= 0 & b1 < tl(2) & a1 >= 0 & a1 < tl(1)
		then if tp(1) -> word(a1) = tp(2) -> word(b1)
		     then if tp(1) -> word(a1+1) = tp(2) -> word(b1+1)
			then return("1"b);
		end;

	return("0"b);

end;


end;
  



		    display_text_.pl1               11/15/82  1814.7rew 11/15/82  1501.1      133200


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


/* program to display output text produced by pl/1

   Initial Version: 17 October, 1968
	Modified: 19 August 1972 by BLW
	Modified:	20 February 1973 by RAB for multiple base-regs
	Modified:	3 July 1973 by RAB for EIS	
	Modified:	29 April 1974 by RAB for use with compare_object	
	Modified: 2 May 1977 by SHW for new format operator_names_
*/

display_text_: proc(t_pt,r_pt,delta,number,t_size,onp);

dcl	t_pt	ptr,	/* points at text base */
	r_pt	ptr,		/* points at relocation base */
	delta	fixed bin,	/* offset of starting position */
	number	fixed bin,	/* number to print */
	t_size	fixed bin,	/* size of text */
	onp	ptr;		/* pointer to appropriate operator name segment */

dcl	(p,q,line_pt,pt) ptr,
	(i,j,k,m,mop,n,save_k,irand,nrands,ndesc) fixed bin,
	(fract_offset,offset,size,scale) fixed bin(18),
	(ignore_ic_mod,double,eis,eis_desc,need_comma,ext_base,itag,has_ic,decimal) bit(1),
	nl char(1) int static aligned init("
"),
	ht char(1) int static aligned init("	"),	/* tab */
	htht char(2) int static aligned init("		"),	/* two tabs */
	(c,c2) char(1),
	cstring char(12),
	op_code char(5),
	tag char(3),
	line char(256),
	iox_$user_output ptr ext,
	pl1_operator_names_$pl1_operator_names_ ext,
	cobol_operator_names_$cobol_operator_names_ ext,
	pl1_operators_$operator_table fixed bin ext,
	binoct entry(aligned bit(*)) returns (char(12) aligned),
	iox_$put_chars entry (ptr,ptr,fixed bin,fixed bin(35));

dcl	(abs,addr,addrel,baseptr,divide,fixed,min,mod,null,ptr,rel,string,substr,unspec,rtrim,char,length) builtin;

%include operator_names;

dcl	1 op_mnemonic_$op_mnemonic(0:1023) ext static aligned,
		2 opcode		char(6) unal,
		2 dtype		fixed bin(2) unal,	/* 0 - desc9a, 1 - descb, 2 - decimal */
		2 num_desc	fixed bin(5) unal,
		2 num_words	fixed bin(8) unal;

dcl	1 name_pair	aligned based(p),
	2 rel_ptr		unaligned bit(18),		/* ptr to ascii string */
	2 size		unaligned bit(18);		/* size of string */

dcl	based_string aligned char(size) based(p);

dcl	digit(0:9) char(1) aligned int static
	init("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

dcl	relocation(-1:11) char(1) aligned int static
	init("a", "t", "1", "2", "3", "l", "d", "s", "7", "8", "i", "r", "e");

dcl	base(0:7) char(4) aligned int static
	init("pr0|","pr1|","pr2|","pr3|","pr4|","pr5|","pr6|","pr7|");

dcl	modifier(0:63) char(3) aligned int static
	init("n", "au", "qu", "du", "ic", "al", "ql", "dl",
	     "0", "1", "2", "3", "4", "5", "6", "7",
	     "*", "au*", "qu*", "...", "ic*", "al*", "ql*", "...",
	     "0*", "1*", "2*", "3*", "4*", "5*", "6*", "7*",
	     (8)(1)"...",
	     (8)(1)"...",
	     "*n", "*au", "*qu", "...", "*ic", "*al", "*ql", "...",
	     "*0", "*1", "*2", "*3", "*4", "*5", "*6", "*7");

dcl	word(0:1) bit(36) aligned based(p);

dcl	1 instruction	based(p) aligned,
	2 base		unaligned bit(3),
	2 offset		unaligned bit(15),
	2 op_code		unaligned bit(10),
	2 unused		unaligned bit(1),
	2 ext_base	unaligned bit(1),
	2 tag		unaligned bit(6);

dcl	1 half		based(p) aligned,
	2 left		unaligned bit(18),
	2 right		unaligned bit(18);

dcl	1 rel_tab		based(p) aligned,
	2 dummy_l		unaligned bit(14),
	2 left		unaligned bit(4),
	2 dummy_r		unaligned bit(14),
	2 right		unaligned bit(4);

dcl	1 mod_factor	aligned,
	2 ext_base	bit(1) unal,
	2 length_in_reg	bit(1) unal,
	2 indirect_descriptor bit(1) unal,
	2 tag		bit(4) unal;

dcl	mf(3) fixed bin(6) int static init(30,12,3);	/* location of modification factor fields in EIS inst */

dcl	1 packed_ptr_st based aligned,
	2 packed_ptr	ptr unal;

dcl	(ebase,len_reg,ic) (3) bit(1) aligned;
dcl	desc_word char(8) varying;

dcl	desc_op(0:3) char(8) varying int static init("desc9a","descb","desc9fl","desc9ls");

dcl	eis_modifier(0:15) char(3) aligned int static
	init("n", "au", "qu", "du", "ic", "al", "ql", "...",
	     "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7");

dcl	bool_word(0:15) char(6) aligned int static varying
	init("clear", "and", "andnot", "move", "", "", "xor", "or",
	     "", "", "", "", "invert", "", "nand","set");

dcl	1 descriptor	based aligned,	/* EIS descriptor */
	2 address		bit(18) unal,
	2 char		bit(2) unal,
	2 bit		bit(4) unal,
	2 length		bit(12) unal;

%include cgsystem;


begin:	p = addrel(t_pt,delta);
	q = addrel(r_pt,delta);

	line_pt = addr(line);
	eis = "0"b;
	irand = 0;
 
	do i = 1 to number;

	     tag = "   ";
	     substr(line,1,6) = binoct(rel(p));
	     substr(line,7,2) = "  ";

	     if r_pt = null
	     then do;
		substr(line,9,4) = "  ";
		go to body;
		end;

	     if q -> rel_tab.dummy_l then k = fixed(q -> rel_tab.left,4);
	     else k = -1;

	     substr(line,9,1) = relocation(k);

	     if q -> rel_tab.dummy_r then k = fixed(q -> rel_tab.right,4);
	     else k = -1;

	     substr(line,10,3) = relocation(k);

body:	     cstring = binoct(p -> word(0));

	     if ^ eis
	     then do;
		mop = fixed(p->instruction.op_code,10);
		op_code = opcode(mop);
		end;
	     else do;
		mop = 0;
		end;

	     if op_code = ".... "
	     then do;
not_ins:		substr(line,13,3) = "   ";
		substr(line,16,5) = substr(cstring,1,5);
		substr(line,21,7) = substr(cstring,6,7);
		k = 28;
		goto prt;
		end;

	     if num_words(mop) > 1
	     then do;

		/* EIS */

		call init_eis;

		substr(line,13,4) = substr(cstring,1,3);
		substr(line,17,4) = substr(cstring,4,3);
		substr(line,21,4) = substr(cstring,7,3);
		substr(line,25,3) = substr(cstring,10,3);

		substr(line,28,1) = ht;
		substr(line,29,5) = op_code;
		substr(line,34,1) = ht;

		k = 35;

		do j = 1 to ndesc;
		string(mod_factor) = substr(p -> word(0),mf(j),7);
		ebase(j) = mod_factor.ext_base;
		len_reg(j) = mod_factor.length_in_reg;

		substr(line,k,1) = "(";
		k = k + 1;
		need_comma = "0"b;

		if ebase(j)
		then do;
		     substr(line,k,2) = "pr";
		     k = k + 2;
		     need_comma = "1"b;
		     end;

		if len_reg(j)
		then do;
		     if need_comma
		     then do;
			substr(line,k,1) = ",";
			k = k + 1;
			end;
		     substr(line,k,2) = "rl";
		     k = k + 2;
		     need_comma = "1"b;
		     end;

		if mod_factor.tag
		then do;
		     if need_comma
		     then do;
			substr(line,k,1) = ",";
			k = k + 1;
			end;
		     ic(j) = mod_factor.tag = "0100"b;		/* IC */
		     substr(line,k,2) = eis_modifier(fixed(mod_factor.tag,4));
		     k = k + 2;
		     end;
		else ic(j) = "0"b;

		substr(line,k,2) = "),";
		k = k + 2;
		end;


		if substr(p -> word(0),10,1)
		then do;
		     substr(line,k,12) = "enablefault,";
		     k = k + 12;
		     end;

		if desc_word = "desc9a"
		then if ndesc < 3
		     then do;
			if substr(op_code,1,2) ^= "sc"
			     then substr(line,k,5) = "fill(";
			     else substr(line,k,5) = "mask(";
			k = k + 5;
			substr(line,k,3) = substr(cstring,1,3);
			k = k + 3;
			substr(line,k,1) = ")";
			k = k + 1;
			end;
		     else k = k - 1;
		else if desc_word = "descb"
		     then do;
			substr(line,k,5) = "fill(";
			k = k + 5;
			substr(line,k,1) = digit(fixed(substr(p -> word(0),1,1),1));
			k = k + 1;
			substr(line,k,1) = ")";
			k = k + 1;
			if op_code ^= "cmpb "
			then do;
			     substr(line,k,6) = ",bool(";
			     k = k + 6;
			     j = fixed(substr(p -> word(0),6,4),4);
			     m = length(bool_word(j));
			     if m > 0
			     then do;
				substr(line,k,m) = bool_word(j);
				k = k + m;
				end;
			     else do;
				substr(line,k,1) = digit(fixed(substr(p -> word(0),6,1),1));
				substr(line,k+1,1) = digit(fixed(substr(p -> word(0),7,3),3));
				k = k + 2;
				end;
			     substr(line,k,1) = ")";
			     k = k + 1;
			     end;
			end;
		     else if substr(p -> word(0),11,1)
			then do;
			     substr(line,k,5) = "round";
			     k = k + 5;
			     end;
			else k = k - 1;

		irand = 0;
		go to prt;
		end;

	     double, ignore_ic_mod = "0"b;

	     eis_desc = eis & desc_word ^= "arg";
	     if eis_desc
	     then do;
		substr(line,13,2) = "  ";
		substr(line,15,6) = substr(cstring,2,5);
		substr(line,21,3) = substr(cstring,7,2);
		substr(line,24,4) = substr(cstring,9,4);

		substr(line,28,1) = ht;

		if decimal
		     then desc_word = desc_op(2 + fixed(p -> descriptor.bit,4));
		if irand > 1
		then if op_code = "dtb  " | op_code = "mvne "
		     then desc_word = desc_op(0);
		     else;
		else if op_code = "btd  "
		     then desc_word = desc_op(0);

		substr(line,29,length(desc_word)) = desc_word;
		k = length(desc_word) + 29;

		ext_base = ebase(irand);
		itag = len_reg(irand);
		if itag
		     then tag = eis_modifier(fixed(substr(p -> descriptor.length,9,4),4));
		has_ic = ic(irand);
		go to chk_ext;
		end;

	     if op_code = "rpd  " then goto set;
	     if op_code = "rpt  " then goto set;

	     if p -> instruction.unused then goto not_ins;

	     if num_desc(mop) ^= 0
	     then do;
si:		tag = substr(binoct((p -> instruction.tag)),1,2);
		ignore_ic_mod = "1"b;
		goto set;
		end;

	     if p -> instruction.tag
	     then do;
		tag = modifier(fixed(p -> instruction.tag,6));
		if tag = "..." then goto not_ins;
		end;

set:	     substr(line,13,2) = "  ";
	     substr(line,15,6) = substr(cstring,2,5);
	     substr(line,21,5) = substr(cstring,7,4);
	     substr(line,26,2) = substr(cstring,11,2);

	     substr(line,28,1) = ht;
	     k = 29;

	     substr(line,k,5) = op_code;

	     c = substr(line,k+3,1);

	     double = substr(op_code,1,2) = "df" | substr(op_code,3,2) = "aq" | substr(op_code,4,2) = "aq";

	     ext_base = p -> instruction.ext_base;
	     itag = p -> instruction.tag ^= "000000"b;
	     has_ic = p -> instruction.tag = "000100"b;	/* IC */

	     k = 34;
chk_ext:
chk_ext1:	     substr(line,k,1) = ht;
	     k = k + 1;

	     save_k = k;

	     if ^ eis
	     then if p -> instruction.unused
		then do;

		     /* have rpd | rpt instruction */

		     tag = digit(fixed(p -> instruction.tag,6));
		     offset = fixed(substr(p -> half.left,1,8),8);
		     ignore_ic_mod = "1"b;
		     goto sk;
		     end;

	     if ext_base
	     then do;
		substr(line,k,4) = base(fixed(p -> instruction.base,3));
		offset = fixed(p -> instruction.offset,15);
		if offset > 16384 then offset = offset - 32768;
		k = k+4;
		j = 13;
		end;
	     else do;
		offset = fixed(p -> half.left,18);

		if offset > 131072
		then do;
		     if tag = "du " then goto sk;
		     if tag = "dl " then goto sk;
		     offset = offset - 262144;	/* 2's comp */
		     end;

sk:		j = 14;
		end;

	     substr(line,j,1) = cstring;

	     call bin2dec(offset);

	     if eis_desc
	     then do;
		if desc_word = "descb"
		     then fract_offset = fixed(p -> descriptor.char,2) * bits_per_char + fixed(p -> descriptor.bit,4);
		     else fract_offset = fixed(p -> descriptor.char,2);
		if fract_offset ^= 0
		then do;
		     substr(line,k,1) = "(";
		     k = k + 1;
		     call bin2dec(fract_offset);
		     substr(line,k,1) = ")";
		     k = k + 1;
		     end;
		end;

	     if itag
	     then do;
		substr(line,k,1) = ",";
		substr(line,k+1,3) = tag;

		k = k + 2;
		if substr(line,k,1) ^= " " then k = k + 1;
		if substr(line,k,1) ^= " " then k = k + 1;
		end;
	     else if eis_desc
		then do;
		     substr(line,k,1) = ",";
		     k = k + 1;
		     if desc_word = "desc9ls"
		     then do;
			call bin2dec(fixed(substr(p -> descriptor.length,7,6),6));
			substr(line,k,1) = ",";
			k = k + 1;
			scale = fixed(substr(p -> descriptor.length,1,6),6);
			if scale >= 32
			     then scale = scale - 64;
			call bin2dec(scale);
			end;
		     else call bin2dec(fixed(p -> descriptor.length,12));
		     end;

	     if ignore_ic_mod then goto chk_base;

	     if has_ic
	     then do;
		substr(line,k,2) = htht;
		k = k + 2;

		pt = addrel(p,offset-irand);
		substr(line,k,6) = binoct(rel(pt));

		k = k + 6;

		if substr(op_code,1,1) = "t" then goto prt;
		if fixed(rel(pt),18) > t_size then goto prt;

		substr(line,k,1) = " ";
		k = k + 1;

equal:		substr(line,k,2) = "= ";
		substr(line,k+2,12) = binoct(pt -> word(0));
		k = k + 14;

		if double
		then do;
		     substr(line,k,1) = " ";
		     substr(line,k+1,12) = binoct(pt -> word(1));
		     k = k + 13;
		     end;

		goto prt;
		end;

chk_base:	     if onp = null then go to prt;		/* Means don't want to print operator names */

	     if ^ p -> instruction.ext_base then go to prt;

	     if p -> instruction.base then go to prt;

	     if op_code = "xec  "
	     then do;
		pt = addrel(addr(pl1_operators_$operator_table),offset);
		mop = fixed(pt -> instruction.op_code,10);
		if num_words(mop) > 1
		then do;

		     /* we are executing an EIS instruction in pl1_operators_ */

		     call init_eis;

		     do j = 1 to ndesc;
			ebase(j) = "1"b;
			len_reg(j) = ^ decimal;
			ic(j) = "0"b;
			end;

		     irand = 0;
		     end;
		end;

	     if itag then goto prt;

	     if substr(op_code,1,1) ^= "t"
	     then do;
		if offset >= onp -> operator_names.first then goto prt;
		pt = addrel(addr(pl1_operators_$operator_table),offset);
		substr(line,k,2) = htht;
		k = k + 2;
		goto equal;
		end;

	     op_names_pt = onp;

	     if offset >= operator_names.first & offset <= operator_names.last
	     then do;
		pt = addr (operator_names.names(offset));
		goto str_info;
		end;


	     else if offset >= operator_names.first_special & offset <= operator_names.last_special
	     then do;
		do j = 1 to operator_names.number_special;
		     if operator_names.special(j).offset = offset
		     then do;
			pt = addr(operator_names.special(j).namep);
			goto str_info;
			end;
		     end;
		goto prt;
		end;

str_info:	     size = fixed(pt -> name_pair.size,18);
	     pt = ptr(pt,pt -> name_pair.rel_ptr);

	     substr(line,k,2) = htht;
	     k = k + 2;

	     substr(line,k,size) = pt -> based_string;
	     k = size + k;

prt:	     substr(line,k,1) = nl;

	     call iox_$put_chars(iox_$user_output,line_pt,k,(0));

	     if eis
	     then do;
		irand = irand + 1;
		if irand > nrands
		then do;
		     eis = "0"b;
		     irand = 0;
		     end;
		else if irand > ndesc
		     then op_code, desc_word = "arg";
		end;

	     p = addrel(p,1);
	     q = addrel(q,1);
	     end;

	return;

bin2dec:	     proc(number);

dcl	     number fixed bin(18);

	     substr(line,k,length(ltrim(char(number)))) = ltrim(char(number));
	     k = k + length(ltrim(char(number)));

	     end;


init_eis:	     proc;

	     eis = "1"b;
	     nrands = num_words(mop) - 1;
	     ndesc = num_desc(mop);
	     decimal = dtype(mop) = 2;
	     desc_word = desc_op(dtype(mop));

	     end;

	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