



		    bind.pl1                        01/17/85  1330.6r w 01/17/85  1231.5      192753



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


bind:
oldbind:
bd:
	procedure ();

/* *	BIND -- the command procedure of the Multics binder
   *
   *
   *	Redesigned and coded by Michael J. Spier, September 17, 1970
   *	Modified 75.06.24 by M. Weaver to remove no_old_alm option
   *	Modified 5/76 by M. Weaver to add -brief option, identify bad control args and improve names in messages
   *	Completely reimplemented, to make comprehensible, 01/14/81 W. Olin Sibert; Added several features:
   *	  warning for no bindfile, -force_order, -force_update, warning for update by earlier version.
   *	Modified 11/22/83 by M. Weaver to initialize inp.bindfile_name
   *	Modified 11/06/84 by M. Sharpe to implement -segment, -archive and -bindfile;
   *	  bind now uses a new version of binder_input.incl.pl1 which removes the limitation
   *	  on the number of archives/segments and object components.
   *	Modified 01/07/84 by M. Sharpe to correct problem with control argument processing;
   */

/*   Automatic   */

dcl  access_mode			bit (3);
dcl  archive_dname			char (168);
dcl  archive_ename			char (32);
dcl  archive_idx			fixed bin;
dcl (argno, nargs)			fixed bin;
dcl  argp				pointer;
dcl  argl				fixed bin (21);
dcl  bindfile_flag			bit (1) aligned init ("0"b);
dcl  bindfile_to_use		char (32);
dcl  code				fixed bin (35);
dcl  component_name			char (32) init ("");
dcl  comp_ptr			pointer;
dcl 1 comp_info			aligned like archive_component_info;
dcl  ctl_arg			char (10) varying;
dcl  (inpp, p)			pointer;   /* pointers which must be declared to use binder_input.incl.pl1 */
dcl  error_sw			bit (1) aligned;
dcl  ignore_not_found		bit (1) aligned;
dcl  obj_idx			fixed bin;
dcl  real_dname			char (168);
dcl  real_ename			char (32);
dcl  standalone_segment		bit (1) aligned init ("0"b);
dcl  update_idx			fixed bin;

/*   Based   */

dcl  arg				char (argl) based (argp);


/*   Builtin   */

dcl  (addr, char, index, length,
	  null, reverse, rtrim,
	  search, substr) 	builtin;

/*   Condition   */

dcl  cleanup			condition;

/*   Entries   */

dcl  absolute_pathname_		entry (char(*), char(*), fixed bin(35));
dcl  absolute_pathname_$add_suffix	entry (char (*), char (*), char (*), fixed bin (35));
dcl  archive_$next_component_info	entry (pointer, fixed bin (24), pointer, pointer, fixed bin (35));
dcl  bind_			entry (pointer);
dcl  com_err_			entry options (variable);
dcl  cu_$arg_count			entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr			entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  date_time_			entry (fixed bin (71), char (*));
dcl  expand_pathname_$component	entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  expand_pathname_$add_suffix	entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_temp_segment_		entry (char(*), ptr, fixed bin(35));
dcl  hcs_$terminate_noname		entry (pointer, fixed bin (35));
dcl  initiate_file_			entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  release_temp_segment_		entry (char(*), ptr, fixed bin(35));
dcl  translator_info_$get_source_info	entry (pointer, char (*), char (*), fixed bin (71), bit (36) aligned,
				       fixed bin (35));

/*   External Static   */

dcl  error_table_$archive_pathname	fixed bin (35) external static;
dcl  error_table_$badopt		fixed bin (35) external static;
dcl  error_table_$noarg		fixed bin (35) external static;
dcl  error_table_$noentry		fixed bin (35) external static;
dcl  error_table_$pathlong		fixed bin (35) external static;

/*   Internal Static   */

dcl  ARCHIVE_SUFFIX			char (7) internal static options (constant) init ("archive");
dcl  WHOAMI			char (32) internal static options (constant) init ("bind");

dcl  binder_invoked			bit (1) aligned internal static init ("0"b);	/* Prevent recursion */


%page;

	if binder_invoked then do;
	     call com_err_ (0, WHOAMI, "^a^/^a",
		"The binder may not be invoked while a previous invocation is",
		"suspended. Use the ""release"" or ""start"" command first.");
	     return;				/* Avoid resetting the flag, of course */
	     end;


	inpp = null;
	on cleanup call CLEAN_UP ();


	binder_invoked = "1"b;			/* Set recursion-prevention flag */

	call get_temp_segment_ (WHOAMI, inpp, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Could not obtain temporary segment. Report to maintainer.");
	     return;
	end;

	inp.ntotal = 0;

	inp.version = BINDER_INPUT_VERSION_2;
	inp.caller_name = WHOAMI;

	inp.bindfilep = null ();
	inp.bindfile_name = "";

	update_idx = 0;
	archive_idx = 0;
	error_sw = "0"b;				/* Only set when multiple errors might occur */
	ignore_not_found = "0"b;


	call cu_$arg_count (nargs, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI);

MAIN_RETURN:   if error_sw then			/* Make mention of the fact that nothing will happen */
		call com_err_ (0, WHOAMI, "Fatal errors have occurred; binding will not be attempted.");

	     call CLEAN_UP ();			/* This is the ONLY exit from this program */
	     return;				/* except for the one which prevents recursion */
	     end;

%page;


/* Now, loop through the arguments, picking up the options and the archive pathnames.
   This loop initiates all the supposed archives, and fills in inp.archive_file for
   each one, but does not inspect their contents.
   */

/* The first part of the loop handles the simple control argument options */

	argno = 1;
	do while (argno <= nargs);
	     call cu_$arg_ptr (argno, argp, argl, (0));

	     if (arg = "-debug") | (arg = "-db") then
		inp.debug = "1"b;

	     else if (arg = "-map") then do;
		inp.list_seg = "1"b;
		inp.map_opt = "1"b;
		end;

	     else if (arg = "-list") | (arg = "-ls") then do;
		inp.list_opt = "1"b;
		inp.list_seg = "1"b;
		inp.map_opt = "1"b;
		end;

	     else if (arg = "-brief") | (arg = "-bf") then
		inp.brief_opt = "1"b;

	     else if (arg = "-force_order") | (arg = "-fco") then
		inp.force_order_opt = "1"b;

%page;


/* The next portion of the loop handles some of the more complicated control arguments */

	     else if (arg = "-update") | (arg = "-ud") then do;
		if inp.narc = 0 then do;
NO_PRIMARY_ARCHIVE:      call com_err_ (0, WHOAMI, "^a specified before any primary archive names.", arg);
		     goto MAIN_RETURN;
		     end;

		if update_idx > 0 then do;
MULTIPLE_UPDATES:	     call com_err_ (0, WHOAMI, "Multiple -update or -force_update control arguments not allowed.");
		     goto MAIN_RETURN;
		     end;

		update_idx = inp.narc + 1;		/* Start updating with the next archive */
		end;

	     else if (arg = "-force_update") | (arg = "-fud") then do;
		if inp.narc = 0 then
		     goto NO_PRIMARY_ARCHIVE;
		if update_idx > 0 then
		     goto MULTIPLE_UPDATES;

		ignore_not_found = "1"b;		/* Set the flag to ignore update archives not found */
		update_idx = inp.narc + 1;		/* Start updating with the next archive */
		end;

%page;

/* This portion handles control args that require another argument immediatedly following them */
	     else if (arg = "-segment") | (arg = "-sm") then do;
		if argno = nargs then goto MISSING_ARG;

		ctl_arg = arg;
		call cu_$arg_ptr (argno+1, argp, argl, (0)); /* Just checking! */
		if char (arg, 1) = "-" then do;
		     call com_err_ (error_table_$badopt, WHOAMI,
			"^a ^a^/ ^a must be followed by a pathname.^/", ctl_arg, arg, ctl_arg);
		     goto MAIN_RETURN;
		end;

		standalone_segment = "1"b;
	     end;

	     else if (arg = "-archive") | (arg = "-ac") then do;

		if argno = nargs then do;
MISSING_ARG:	     call com_err_ (error_table_$noarg, WHOAMI, "^a must be followed by a pathname", arg);
		     goto MAIN_RETURN;
		end;

		ctl_arg = arg;
		call cu_$arg_ptr (argno+1, argp, argl, (0)); /* Just checking! */
		if char (arg, 1) = "-" then do;
		     call com_err_ (error_table_$badopt, WHOAMI,
			"^a ^a^/ ^a must be followed by a pathname.^/", ctl_arg, arg, ctl_arg);
		     goto MAIN_RETURN;
		end;

		standalone_segment = "0"b;
	     end;
	     
	     else if (arg = "-bindfile") | (arg = "-bdf") then do;
		if bindfile_flag then do;
		     call com_err_ (0, WHOAMI, "Multiple -bindfile control args not allowed.");
		     goto MAIN_RETURN;
		end;

		if argno = nargs then do;
		     call com_err_ (error_table_$noarg, WHOAMI,
			"^a must be followed by an entry name.", arg);
		     goto MAIN_RETURN;
		end;

		bindfile_flag = "1"b;		/* don't use this arg again */

		ctl_arg = arg;
		argno = argno + 1;
		call cu_$arg_ptr (argno, argp, argl, (0));
		if (search (arg, "<>") > 0) | (index (arg, "-") = 1)
		then do;
		     call com_err_ (0, WHOAMI,
			"^a must be followed by an entry name ^[not^;not a pathname.^] ^a.",
			ctl_arg, (index (arg,"-") = 1), arg);
		     error_sw = "1"b;
		end;

		if (argl > 4 & index (arg, ".bind") = argl - 4) then do;  /* has .bind suffix */
		     if argl > 32 then do;		/* too long */
			call com_err_ (0, WHOAMI, "Bindfile name is too long. ^a", arg);
			error_sw = "1"b;
		     end;
		     else bindfile_to_use = arg;
		end;

		else do;				/* no .bind suffix */
		     if argl > 27 then do;		/* too long */
			call com_err_ (0, WHOAMI, "Bindfile name is too long. ^a", arg);
			error_sw = "1"b;
		     end;
		     else bindfile_to_use = arg || ".bind";
		end;
	     end;					/* -bindfile */

	     else if char (arg, 1) = "-" then do;
		call com_err_ (error_table_$badopt, WHOAMI, "^a", arg);
		goto MAIN_RETURN;
		end;

%page;
/* The final portion deals with initiating archives and getting information about them */

	     else do;				/* If not a control argument, must be an archive name */
		inp.ntotal,			/* update the array bound */
		archive_idx = archive_idx + 1;	/* and the index */
		inp.archive(archive_idx).ptr = null;	/* initialize the ptr so that CLEAN_UP won't break */


		if standalone_segment then call absolute_pathname_
		     (arg, inp.archive (archive_idx).path, code);
		else call absolute_pathname_$add_suffix
		     (arg, ARCHIVE_SUFFIX, inp.archive (archive_idx).path, code);
		if code ^= 0 then do;
BAD_ARCHIVE_PATH:	     call com_err_ (code, WHOAMI, "^a", arg);
		     goto MAIN_RETURN;
		     end;

		if standalone_segment then call expand_pathname_$component
		     (inp.archive (archive_idx).path, archive_dname, archive_ename, component_name, code);
		else call expand_pathname_$add_suffix (inp.archive (archive_idx).path,
		     ARCHIVE_SUFFIX, archive_dname, archive_ename, code);
		if code ^= 0 then
		     goto BAD_ARCHIVE_PATH;
		if component_name ^= "" then do;
		     call com_err_ (error_table_$archive_pathname, "bind_", inp.archive (archive_idx).path);
		     component_name = "";
		     archive_idx = archive_idx - 1;
		     goto SKIP_ARCHIVE;
		end;

		inp.archive(archive_idx).entryname = archive_ename;

		call initiate_file_ (archive_dname, archive_ename, access_mode,
		     inp.archive (archive_idx).ptr, inp.archive (archive_idx).bc, code);

		if inp.archive (archive_idx).ptr = null () then do;
		     if ignore_not_found then		  /* We can skip it */
			if code = error_table_$noentry then do;
			     archive_idx = archive_idx - 1; /* Keep this one out of the array */
			     goto SKIP_ARCHIVE;
			     end;

BAD_SEGMENT:	     call com_err_ (code, WHOAMI, "^a", inp.archive (archive_idx).path);
		     goto MAIN_RETURN;
		     end;

		if ^inp.brief_opt			/* Warn about empties */
		     & inp.archive (archive_idx).bc = 0 then
		     call com_err_ (0, WHOAMI, "Warning: ^a is empty.", inp.archive (archive_idx).path);

		call translator_info_$get_source_info (inp.archive (archive_idx).ptr, real_dname, real_ename,
		     inp.archive (archive_idx).dtm, inp.archive (archive_idx).uid, code);
		if code ^= 0 then
		     goto BAD_SEGMENT;

		if (length (rtrim (real_dname)) + length (rtrim (real_ename)) + 1) > 168 then do;
		     call com_err_ (error_table_$pathlong, WHOAMI, "^a>^a", real_dname, real_ename);
		     goto MAIN_RETURN;
		     end;

		inp.archive (archive_idx).real_path = rtrim (real_dname) || ">" || rtrim (real_ename);

		inp.archive (archive_idx).standalone_seg = standalone_segment;

		if archive_idx = 1 then		/* Apply default value for output segment */
		     inp.bound_seg_name = substr (archive_ename, 1,
			(length (rtrim (archive_ename)) - (length (ARCHIVE_SUFFIX) + 1)));

		if update_idx > 0 then		/* Update the counts in the input */
		     inp.nupd = inp.nupd + 1;
		else inp.narc = inp.narc + 1;
SKIP_ARCHIVE:
	     end;				/* Of processing one archive */
	     if char (arg, 1) = "-" & arg ^= "-segment" & arg ^= "-sm" then standalone_segment = "0"b;
					/* -segment is only in effect until the next control argument. */
	     argno = argno + 1;

	end; 					/* Of loop through arguments */

	if inp.narc = 0 then do;
	     call com_err_ (error_table_$noarg, WHOAMI,
		"^/Usage:^-^a archive_path{s} {-update update_archive_path{s}} {-control_args}", WHOAMI);
	     goto MAIN_RETURN;
	     end;

	if (update_idx > 0) & (inp.nupd = 0) & (^ignore_not_found) then do;
	     call com_err_ (0, WHOAMI, "-update was specified, but not followed by any update archive names.");
	     goto MAIN_RETURN;
	     end;

%page;
	comp_info.version = ARCHIVE_COMPONENT_INFO_VERSION_1;  /* In preparation for calling archive */

	do archive_idx = 1 to inp.ntotal;		/* Go through all the input archives */
	     comp_ptr = null ();			/* Set up to loop through components */

GET_NEXT_OBJECT:
	     if inp.archive (archive_idx).standalone_seg then do;
		comp_info.comp_ptr = inp.archive (archive_idx).ptr;
		comp_info.comp_bc = inp.archive (archive_idx).bc;
		comp_info.name = inp.archive (archive_idx).entryname;
		comp_info.time_updated,
		     comp_info.time_modified = inp.archive (archive_idx).dtm;
	     end;

	     else do;
		call archive_$next_component_info
		     (inp.archive (archive_idx).ptr, inp.archive (archive_idx).bc, comp_ptr, addr (comp_info), code);

		if code ^= 0 then do;
		     call com_err_ (code, WHOAMI, "Searching ^a.", inp.archive (archive_idx).path);
		     goto MAIN_RETURN;
		end;

		if comp_ptr = null () then		/* Nothing more in this archive */
		     goto GET_NEXT_ARCHIVE;
	     end;

	     if substr (reverse (rtrim (comp_info.name)), 1, 5) = reverse (".bind") then do; /* A bindfile */
		if bindfile_flag then do;		/* -bindfile was specified */
		     if comp_info.name ^= bindfile_to_use then goto IGNORE_BINDFILE;
		end;

		else if inp.bindfilep ^= null () then do;
		     if archive_idx <= inp.narc then do; /* We are not processing an update archive */
			if ^inp.brief_opt then	/* Complain about it if not brief */
			     call com_err_ (0, WHOAMI, "Warning: Multiple bindfile ^a in ^a ignored.",
				comp_info.name, inp.archive (archive_idx).path);

			goto IGNORE_BINDFILE;	/* and ignore it in any case */
		     end;				/* of case for duplicate bindfile in non-update archive */

		     if ^inp.brief_opt then		/* Mention it if not brief */
			call com_err_ (0, WHOAMI, "Warning: ^a of ^a^/^2xreplaced by: ^a of ^a",
			     inp.bindfile_name, inp.archive (inp.bindfile_idx).path,
			     comp_info.name, inp.archive (archive_idx).path);
		end;				/* of checking for duplicate bindfile */

		inp.bindfilep = comp_info.comp_ptr;	/* In any case, make this the bindfile */
		inp.bindfile_bc = comp_info.comp_bc;
		inp.bindfile_idx = archive_idx;	/* Index of archive from which this came */
		inp.bindfile_name = comp_info.name;
		inp.bindfile_time_up = comp_info.time_updated;
		inp.bindfile_time_mod = comp_info.time_modified;

IGNORE_BINDFILE:					/* Now that we have it, go on to the next component */
		if inp.archive (archive_idx).standalone_seg then goto GET_NEXT_ARCHIVE;
		else goto GET_NEXT_OBJECT;	
		end;				/* Of processing a bindfile entry */
%page;

/* If we get here, we are known to be processing a "object" component. Put it in
   the list, perhaps replacing one which was there earlier, and complaining about
   a variety of things. */

	     do obj_idx = 1 to inp.nobj;		/* Look for this one elsewhere in the input stream */
		if inp.obj (obj_idx).filename = comp_info.name then do;
		     if archive_idx <= inp.narc then do;
			call com_err_ (0, WHOAMI, "Duplicate object ^a in ^a",
			     comp_info.name, inp.archive (archive_idx).path);

			error_sw = "1"b;		/* Report all of these, but don't try binding */

			if inp.archive (archive_idx).standalone_seg then goto GET_NEXT_ARCHIVE;
			else goto GET_NEXT_OBJECT;	

			end;

		     inp.obj (obj_idx).base = comp_info.comp_ptr; /* Replace the previous entry for this component */
		     inp.obj (obj_idx).bitcount = comp_info.comp_bc; /* The name, of course, is already correct */

		     if inp.obj (obj_idx).time_mod > comp_info.time_modified then
			if ^inp.brief_opt then	/* Mention it, in case the user has made a mistake */
			     call com_err_ (0, WHOAMI,
				"Note: ^a in ^a (modified ^a)^/^3xreplaced by earlier (^a) copy in ^a",
				comp_info.name, inp.archive (inp.obj (obj_idx).archive_idx).path,
				DATE_TIME (inp.obj (obj_idx).time_mod), DATE_TIME (comp_info.time_modified),
				inp.archive (archive_idx).path);

		     inp.obj (obj_idx).time_mod = comp_info.time_modified;
		     inp.obj (obj_idx).time_up = comp_info.time_updated;
		     inp.obj (obj_idx).archive_idx = archive_idx;

	     inp.obj(obj_idx).to_be_ignored = (inp.obj(obj_idx).bitcount = 0);
						/* set ignore bit if seg is zero length; */
						/* reset it if it was previously set & bitcount > 0 */
	     if inp.obj(obj_idx).bitcount = 0 then inp.zeroseg_seen = "1"b;
						/* Tell parse_bindfile_ to check for zsegs */
						/* Having found the replacement, look no further */
		     if inp.archive (archive_idx).standalone_seg then goto GET_NEXT_ARCHIVE;
		     else goto GET_NEXT_OBJECT;	

		     end; 			/* Of replacing a component */
		end;				/* of loop through objects */

%page;

/* If we fall through to here, the object we are processing was not already in our
   list of objects, so we must add it to the list. */


	     obj_idx = inp.nobj + 1;

	     inp.obj (obj_idx).filename = comp_info.name; /* These items need only be set the first time */
	     inp.obj (obj_idx).option = ""b;		/* No options yet, of course */

	     inp.obj (obj_idx).base = comp_info.comp_ptr;
	     inp.obj (obj_idx).bitcount = comp_info.comp_bc;
	     inp.obj (obj_idx).time_mod = comp_info.time_modified;
	     inp.obj (obj_idx).time_up = comp_info.time_updated;
	     inp.obj (obj_idx).archive_idx = archive_idx;

	     inp.obj(obj_idx).to_be_ignored = (inp.obj(obj_idx).bitcount = 0);
						/* set ignore bit if seg is zero length; */
						/* reset it if it was previously set & bitcount > 0 */
	     if inp.obj(obj_idx).bitcount = 0 then inp.zeroseg_seen = "1"b;
						/* Tell parse_bindfile_ to check for zsegs */
	     inp.nobj = obj_idx;

	     if ^inp.archive (archive_idx).standalone_seg
		then goto GET_NEXT_OBJECT;		/* Having added it, go find another */

GET_NEXT_ARCHIVE:					/* This "loop" is only reached after running out of */
						/* components in an archive or processing a standalone */
	     end; 				/* segment -- see the top of the loop for details. */

/* Having done all the processing of the input archives, we now just call
   the subroutine which does the real work, and hope for the best.
   */

	if error_sw then				/* Reject the binding attempt, because something happened */
	     goto MAIN_RETURN;

	if inp.bindfilep = null () then do;		/* Make this be more useful */
	     if bindfile_flag then do;		/* Bindfile specified but not found -- ERROR */
		call com_err_ ((0), WHOAMI,
		     "Specified bindfile ^a was not found in the input archive^[s^].",
		     bindfile_to_use, ((inp.narc + inp.nupd) ^= 1));
		goto MAIN_RETURN;
	     end;

	     else					/* No bindfiles specified or found -- Warning */
		if ^inp.brief_opt then 		/* But only if we're allowed to be noisy */
		call com_err_ (0, WHOAMI, "Warning: No bindfile was found in the input archive^[s^].",
		     ((inp.narc + inp.nupd) ^= 1));
	end;

	call bind_ (inpp);

	goto MAIN_RETURN;				/* All done. Finish up, and return */

%page;

CLEAN_UP: proc ();

/* cleanup and exit procedure -- terminates all the input archives */

dcl  idx fixed bin;
dcl  tempp pointer;

	if inpp ^= null then do;
	     do idx = 1 to inp.ntotal;
		if inp.archive (idx).ptr ^= null () then do;
		     tempp = inp.archive (idx).ptr;
		     inp.archive (idx).ptr = null ();
		     call hcs_$terminate_noname (tempp, (0));
		end;
	     end;

	     call release_temp_segment_ (WHOAMI, inpp, (0));
	     binder_invoked = "0"b;			/* Always turn off the flag */
	end;

	return;
	end CLEAN_UP;



DATE_TIME: proc (P_time) returns (char (14));

dcl  P_time fixed bin (71) parameter;

dcl  ret_str char (14);
dcl  date_str char (24);


	call date_time_ (P_time, date_str);

	substr (ret_str, 1, 8) = substr (date_str, 1, 8);
	substr (ret_str, 9, 1) = " ";
	substr (ret_str, 10, 2) = substr (date_str, 11, 2);
	substr (ret_str, 12, 1) = ":";
	substr (ret_str, 13, 2) = substr (date_str, 13, 2);

	return (ret_str);
	end DATE_TIME;

%page;	%include binder_input;
%page;	%include archive_component_info;

	end bind;




		    bind_.pl1                       11/12/86  1736.3rew 11/12/86  1607.4      241731



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




/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Modified cleanup handler to work with new bound object being created in a
     temp segment and then copied into the working dir.
  2) change(86-09-05,JMAthane), approve(86-09-05,MCR7525),
     audit(86-09-11,Martinson), install(86-11-12,MR12.0-1212):
     Generate first_ref_traps must be called after make_defs because make_defs
     my generate links when binding PASCAL objects. First ref traps must be
     generated after links.
                                                   END HISTORY COMMENTS */


/* This is the main program of the binder.

   Designed and initially coded by Michael J. Spier, August 19, 1970,
   Completely revised by Michael J. Spier, December 23, 1971  */
/* modified 75.06.20 by M. Weaver for separate static */
/* modified 5/76 by M. Weaver  for -brief option */
/* modified 1/77 by Melanie Weaver to call ext_link_$finish */
/* modified 8/77 by Melanie Weaver to check for perprocess static in non-standard  */
/* modified 9/78 by David Spector to release temp segments on cleanup */
/* modified Dec 78 by David Spector to make repatch table automatically extensible */
/* Modified 01/14/81 W. Olin Sibert for new format of input structure, and -force_order */
/* Modified 01/21/81, WOS, to rename to bind_ so binder_ could remain "compatible" */
/* Modified 05/3/83 by Melanie Weaver to add handler for fatal_binder_error condition */
/* Modified  10/20/84 by M. Sharpe to use new binder_input_.incl.pl1; to check for bindfile
   errors before wiping out the old bound segment */

/* Warning: several places in the binder a fixed bin variable is referenced as
   based bit or based char; currently, referencing them via addr(variable)
   will make the pl1 compiler realize what is really being changed. */

/* format: style4,^indattr,^indcomtxt */

bind_: procedure (argp);

declare  argp pointer;


/* DECLARATION OF EXTERNAL ENTRIES */

declare  relocate_symbol_ external entry ();
declare  com_err_ external entry options (variable);
declare  decode_link_$init external entry ();
declare  dissect_object_ external entry (pointer);
declare  dissect_object_$init external entry ();
declare  ext_link_$init external entry ();
declare  ext_link_$finish entry ();
declare  generate_def_$init external entry ();
declare  get_temp_segment_ external entry (char (*), ptr, fixed bin (35));
declare  form_bind_map_ external entry (pointer, fixed bin (35));
declare  form_link_info_ external entry (pointer, fixed bin (35));
declare  get_wdir_ external entry () returns (char (168) aligned);
declare  generate_first_ref_traps_ external entry ();
declare  int_link_$init external entry ();
declare  hcs_$set_bc_seg external entry (pointer, fixed bin (24), fixed bin (35));
declare  hcs_$chname_seg ext entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35));
declare  ioa_ external entry options (variable);
declare  ioa_$rs external entry options (variable);
declare  incorporate_options_ external entry ();
declare  make_bindmap_ external entry ();
declare  make_defs_$regenerate_block external entry (pointer);
declare  make_defs_$open_section external entry ();
declare  make_defs_$close_section external entry ();
declare  make_bound_object_map_ external entry (fixed bin (35));
declare  parse_bindfile_ external entry ();
declare  rebuild_object_$init external entry ();
declare  rebuild_object_ external entry (pointer);
declare  release_temp_segment_ external entry (char (*), ptr, fixed bin (35));
declare  temp_mgr_$allocate external entry (fixed bin);
declare  temp_mgr_$reserve external entry (pointer);
declare  temp_mgr_$init external entry ();
declare  temp_mgr_$make_object external entry ();
declare  temp_mgr_$close_files external entry ();
declare  terminate_file_ external entry (ptr, fixed bin (24), bit (*), fixed bin (35));
declare  tssi_$clean_up_segment external entry (pointer);
declare  tssi_$get_segment external entry (char (*) aligned, char (*) aligned, ptr, ptr, fixed bin (35));
declare  tssi_$finish_segment external entry (pointer, fixed bin (24), bit (36) aligned,
	    ptr, fixed bin (35));

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare  (i, pos, nobjects) fixed bin;
declare  hash_index fixed bin (34);
declare  (val, lng, symb_relc) fixed bin (18);
declare  code fixed bin (35);
declare  list_acinfop pointer;
declare  (inpp, linkptr, old_ptr, p, sp, textp) pointer;
declare  (dirname char (168), segname char (32)) aligned;
declare  listname char (32) aligned;
declare  whalf char (3) aligned;

declare  1 x aligned,
	 2 obj_ptr pointer,
	 2 list_ptr pointer,
	 2 list_bc fixed bin (24),
	 2 long fixed bin,
	 2 nopts fixed bin;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare  (addr, addrel, bin, bit, divide, fixed, hbound, index, min, mod, null, rel, substr, unspec) builtin;
declare  size builtin;
declare  rank builtin;

declare  cleanup condition;
declare  fatal_binder_error condition;

/* DECLARATION OF EXTERNAL STATIC */

declare  (error_table_$pathlong, error_table_$segnamedup) ext fixed bin (35);

/* DECLARATION OF INTERNAL STATIC */

declare  BINDER_INPUT_VERSION_1 char (4) aligned internal static options (constant) init ("BI.1");
declare  NL char (1) static options (constant) init ("
");
declare  FF char (1) static options (constant) init ("");

/* DECLARATION OF BASED STRUCTURES */

declare  linksection (val) aligned fixed bin based;
declare  1 halfword aligned based,
	 2 lhe18 bit (18) unaligned,
	 2 rhe18 bit (18) unaligned;
declare  1 pr_offset aligned based,
	 2 dum1 bit (3) unaligned,
	 2 lhe15 bit (15) unaligned,
	 2 dum2 bit (3) unaligned,
	 2 rhe15 bit (15) unaligned;
declare  1 clngns_overlay aligned based (addr (comp.clngns)),
	 2 dum bit (35) unaligned,
	 2 odd bit (1) unaligned;
declare  reset_bx (bx_$size) fixed bin (35) based (addr (bx_$area_begin));
declare  based_string char (10000) based (p);

declare  1 temp_seg based aligned,			/* Format of temp segments */
	 2 next_temp_ptr ptr,			/* ptr to next temp seg in chain */
	 2 storage bit (0);				/* Start of temp_mgr_ storage */

%page;

/* PROLOGUE - Initialize binder's temporaries, and validate format of
   bindfile before starting actual binding.			*/


	inpp = argp;				/* copy pointer to input structure */

	reset_bx (*) = 0;				/* reset main data base to zeros */

	bx_$inpp = inpp;				/* record address of input structure */
	bx_$caller = inp.caller_name;

	list_acinfop,
	     old_ptr,
	     bx_$temp,
	     bx_$bsegp,
	     bx_$temp_bsegp,
	     bx_$bseg_acinfop = null;


	on cleanup begin;				/* delete the temp copy of the bound seg on a fault */
	     if bx_$temp_bsegp ^= null then call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_DELETE, 0);
						/* clean up temp for new bound object */
	     if list_acinfop ^= null then call tssi_$clean_up_segment (list_acinfop);
						/* clean up temp for list segment */

/* Return all temp segments to free pool. */

	     if old_ptr ^= null then do;		/* release the temp seg we got for version 2 input */
		call release_temp_segment_ ("bind_", inpp, (0));
		inpp = old_ptr;
	     end;

	     do p = bx_$temp repeat sp while (p ^= null); /* Follow chain of temp segments */
		sp = p -> temp_seg.next_temp_ptr;	/* Get ptr to next temp segment */
		call release_temp_segment_ ("bind", p, code);
		if code ^= 0 then
		     do;
		     call com_err_ (code, inp.caller_name);
		     return;
		end;
	     end;
	end;


	if inp.version = BINDER_INPUT_VERSION_1 then call CONVERT_I_TO_II (); /* convert to new version */
	else if inp.version ^= BINDER_INPUT_VERSION_2 then do; /* Complain and give up */
	     call com_err_ (0, inp.caller_name, "Invalid version ""^4a"" in binder input structure.", inp.version);
	     return;
	end;


	bx_$debug = fixed (inp.debug, 1);		/* copy debug flag */
	bx_$brief = bin (inp.brief_opt, 1);		/* copy brief flag */
	bx_$force_order = bin (inp.force_order_opt, 1);	/* Copy command-line Force_order option */
						/* (this may also get set in parse_bindfile)_ */
	on fatal_binder_error begin;
	     bx_$fatal_error = 1;
	     go to return;
	end;



	call temp_mgr_$init;
						/* create temp segment, return pointer to main database */
	if bx_$fatal_error = 1 then goto return;

	bx_$v_lng = rank (substr (bx_$vers_name, 1, 1));	/* get length of version name */

	sntp,
	     bx_$sntp = bx_$freep;			/* allocate segname table */
	snt.max_size = bx_$snt_limit;
	call temp_mgr_$reserve (addr (snt.entry (snt.max_size + 1))); /* determine end of table */
						/* reserve the area allocated to main table */
	if bx_$fatal_error ^= 0 then goto return;

	odnp,
	     bx_$odnp = bx_$freep;			/* oddname table  */
	od.max_size = bx_$oddname_limit;
	call temp_mgr_$reserve (addr (od.entry (od.max_size + 1)));

	rptp = bx_$freep;				/* Reserve first chunk of repatch table */
	bx_$first_rptp,
	     bx_$last_rptp = rptp;
	call temp_mgr_$reserve (addrel (addr (rpt), size (rpt)));
	rpt.thread = null;				/* No more chunks */
	rpt.npt = 0;				/* No entries in chunk */

	bx_$ncomp = inp.nobj;
	bx_$adnp = null;

	call parse_bindfile_;			/* parse the bindfile, if there is one */
	if bx_$fatal_error = 1 then goto return;

	inpp = bx_$inpp;				/* refresh, in case it was modified by parse_bindfile_ */

	if list_seg then do;			/* be sure segname || ".list" is <= 32 chars */
	     i = index (bx_$bound_segname, " ");	/* get length of name */
	     if ((i = 0) | (i > 27)) then do;
		call com_err_ (error_table_$pathlong, inp.caller_name, "Cannot add .list to ^a", bx_$bound_segname);
		bx_$fatal_error = 1;
		go to return;			/* don't make user have to delete empty seg */
	     end;
	end;

	ctp,
	     bx_$ctp = bx_$freep;			/* allocate component table */
	nobjects = bx_$ncomp;			/* get number of component objects */
	call temp_mgr_$reserve (addr (comp_tbl (nobjects + 1))); /* reserve area for component table */
	if bx_$fatal_error = 1 then goto return;


	call temp_mgr_$make_object;			/* create the new bound segment */
	if bx_$fatal_error = 1 then goto return;

	if ^inp.brief_opt then call ioa_ ("Binding ^a", bx_$bound_segname);


%page;

/* FIRST PASS OF BINDER = obtain ITS pointers to all relevant parts (e.g., definition
   section, relocation bits, etc.) of every object to be bound, and copy the text
   sections into the new bound segment.				*/


	call dissect_object_$init;

	do i = 1 to nobjects;			/* start processing components */
	     ctep,
		comp_tbl (i) = bx_$freep;		/* allocate entry for this component */
	     call temp_mgr_$reserve (addr (comp.last_item));
	     unspec (comp) = ""b;			/* iniitalize structure; seems to be necessary */
	     comp.cindex = i;			/* remember entry's index in table */
	     comp.filename = inp.obj (i).filename;	/* store object's filename */
	     lng = index (comp.filename, " ");		/* compute filename's length */
	     if lng = 0 then lng = 32;
	     else lng = lng - 1;
	     comp.fn_lng = lng;			/* remember length */
	     comp.ctxtp = inp.obj (i).base;		/* get pointer to object segment */
	     comp.cbitcount = inp.obj (i).bitcount;	/* and its bitcount */
	     call dissect_object_ (ctep);		/* and process this object segment */
	end;

	if bx_$tintlng >= 16384 then do;		/* max is 16K because of 15-bit link offsets */
	     call com_err_ (0, inp.caller_name,
		"length of internal static >= 16384, the maximum static section length");
	     bx_$fatal_error = 1;
	end;

	bx_$maxlinklng = min (bx_$maxlinklng, 16384);	/* enforce usable size */
	if (bx_$has_comb_stat = 0 & bx_$has_sep_stat = 1)
	then bx_$bound_sep_stat = 1;			/* have at  least 1 nonzero sep stat and no comb stat */
	else bx_$bound_sep_stat = 0;

	if bx_$fatal_error = 1 then go to return;

	call incorporate_options_;
	if bx_$fatal_error = 1 then goto return;

/* Create hash table for segname table (snt), all of whose entries have already been stored. */

	do hash_index = 0 to hbound (snt.hash_table, 1);
	     snt.hash_table (hash_index) = null;	/* Clear hash table */
	end;
	do i = 1 to snt.n_names;			/* Scan entire snt */

/* Hash code segment name from table. */

	     hash_index = 0;
	     do pos = 1 to min (snt.entry (i).lng, 24);	/* 24 times max */
		hash_index = 2 * hash_index + bin (unspec (substr (snt.entry (i).name, pos, 1)), 9);
	     end;
	     hash_index = mod (hash_index, hbound (snt.hash_table, 1) + 1);

/* Push snt entry into bucket thus found. */

	     snt.entry (i).hash_thread = snt.hash_table (hash_index);
	     snt.hash_table (hash_index) = addr (snt.entry (i));
	end;

%page;

/* SECOND PASS OF THE BINDER = allocate temporary area for construction of
   new linkage section, relocate all text sections building up the linkage
   section in the process, and finally construct the new definition section
   of the new bound object segment.				*/

	val = bx_$textlng;				/* get length of text portion */
	val = divide (val + 1, 2, 17, 0) * 2;		/* make it a 0 mod 2 value */
	bx_$textlng = val;				/* and restore to data base */


	bx_$tdefp = addrel (bx_$temp_bsegp, val);
	call temp_mgr_$allocate (bx_$maxlinklng);	/* make sure an area of sufficient size available */
	if bx_$bound_sep_stat = 1 then do;
	     bx_$tintp = bx_$freep;			/* static will be between defs and link */
	     val = 8;				/* locatiion of first link */
	     linkptr,
		bx_$tlinkp = addrel (bx_$tintp, bx_$tintlng); /*  ptr to temp linkage section */
	end;
	else do;					/* bound segment has static in linkage */
	     linkptr,
		bx_$tlinkp = bx_$freep;		/*  linkage immediately follows defs */
	     val = bx_$tintlng + 8;
	     bx_$tintp = addrel (linkptr, 8);
	end;
	call temp_mgr_$reserve (addrel (bx_$freep, bx_$maxlinklng)); /* and reserve area */

	strmp,
	     bx_$strmp = bx_$freep;			/* get pointer to generated string map */
	strm.max_size = bx_$stringmap_limit;
	call temp_mgr_$reserve (addr (strm.entry (strm.max_size + 2)));

/* now fabricate a new header for this linkage section */

	linkptr -> virgin_linkage_header.link_begin = bit (bin (val, 18), 18); /* and store in header */
	bx_$tlinklng = val;				/* remember current length of linkage section */

/* now compute length of first part of binder's symbol block */

	bx_$n_lng = index (bx_$bound_segname, " ") - 1;
	if bx_$n_lng = -1 then bx_$n_lng = 32;

/* make symbol section header length mod 8 */
	i = divide (bx_$v_lng + 3, 4, 17, 0);		/* compute length of version name in words */
	bx_$s_lng = divide ((27 + i), 8, 17, 0) * 8;	/* 27 for 20 + 7 */
	call rebuild_object_$init;
	call decode_link_$init;
	call int_link_$init;
	call make_defs_$open_section;			/* must call before ext_link_$init */
	call ext_link_$init;
	call generate_def_$init;

	symb_relc = bx_$s_lng;
	do i = 1 to nobjects;
	     ctep = comp_tbl (i);			/* pointer to component entry */
						/* the following must be done here because incorporate_options_ may have changed comp.clngns */
	     if clngns_overlay.odd then comp.cpads = 1;
	     comp.crels = symb_relc;
	     symb_relc = symb_relc + comp.clngns + comp.cpads;
						/* compute new relocation counter */
	     if comp.ignore = 0 then call rebuild_object_ (ctep);
	end;


	do i = 1 to nobjects;
	     ctep = comp_tbl (i);			/* pointer to component entry */
	     if comp.ignore = 0 then call make_defs_$regenerate_block (ctep);
	end;

	if bx_$n_firstrefs > 0 then call generate_first_ref_traps_ ();
						/* combine first ref trap arrays of each  component */


	call make_defs_$close_section;		/* close new definition section */

	call ext_link_$finish;			/* print out multiple init messages */
	if bx_$fatal_error = 1 then goto return;


%page;

/* FINAL PASS OF THE BINDER = copy new linkage section into new object segment,
   and relocate symbol sections into it 			*/

	val = bx_$curdeflng;			/* length of new definition section */
	val = divide (val + 1, 2, 17, 0) * 2;		/* make it a 0 mod 2 value */
	bx_$curdeflng = val;			/* restore just in case */
	if bx_$bound_sep_stat = 0 then do;		/*  int static is inside linkage */
	     bx_$blnkp = addrel (bx_$tdefp, val);	/* ptr to location of new  linkage sectiin */
	     val = bx_$tlinklng;			/* includes static */
	     bx_$blnkp -> linksection = bx_$tlinkp -> linksection;
	     bx_$bstatp = addrel (bx_$blnkp, 8);
	end;
	else do;					/*  static precedes linkage */
	     bx_$bstatp = addrel (bx_$tdefp, val);
	     val = bx_$tintlng + bx_$tlinklng;		/* get length of link and static */
	     bx_$bstatp -> linksection = bx_$tintp -> linksection; /* copy linkage and static into object */
	     bx_$blnkp = addrel (bx_$bstatp, bx_$tintlng);/* get ptr to linkage in object */
	     val = bx_$tlinklng;			/* fill in length of actual linkage */
	end;
	bx_$t_lng = bx_$textlng + bx_$curdeflng;	/* length of new text section */
	val = divide (val + 1, 2, 17, 0) * 2;		/* make length of linkage section 0 mod 2 value */
	bx_$l_lng = val;				/* and store in main data base */
	bx_$bdefp = bx_$tdefp;
	bx_$d_lng = bx_$curdeflng;
	bx_$i_lng = bx_$tintlng;

	bx_$blnkp -> virgin_linkage_header.linkage_section_lng = bit (bin (bx_$l_lng, 18), 18);
	bx_$blnkp -> virgin_linkage_header.def_offset = rel (bx_$bdefp);
	bx_$blnkp -> virgin_linkage_header.static_length = bit (bin (bx_$i_lng, 18), 18);

	bx_$bsymp = addrel (bx_$blnkp, bx_$l_lng);	/* compute base of symbol section */

	call relocate_symbol_;			/* relocate and assemble symbol sections */
	if bx_$fatal_error = 1 then goto return;


/* EPILOG - make bindmap and object map, and complete addresses and values
   which were not available at some previous point of time. Close all
   files and terminate names.				*/

	call make_bindmap_;


	do rptp = bx_$first_rptp repeat rpt.thread while (rptp ^= null);
						/* Scan repatch table */
	     do i = 1 to rpt.npt;			/* Scan chunk of repatch table */
		rptep = addr (rpt.entry (i));		/* pointer to next repatch table entry */
		if rpte.pbase = "t" then textp = bx_$temp_bsegp;
		else if rpte.pbase = "l" then textp = bx_$blnkp;
		else if rpte.pbase = "s" then textp = bx_$bsymp;
		textp = addrel (textp, rpte.poffset);	/* get pointer to instruction to patch */
		whalf = rpte.halfword;		/* determine which halfword to patch */
		if whalf = "lhe" then val = fixed (textp -> halfword.lhe18, 18);
		else if whalf = "l15" then val = fixed (textp -> pr_offset.lhe15, 15);
		else if whalf = "rhe" then val = fixed (textp -> halfword.rhe18, 18);
		val = val + fixed (rpte.pexpr, 18);	/* add expression value */
		if rpte.code = "l" then val = val + bin (rel (bx_$blnkp), 18);
		else if rpte.code = "s" then val = val + bin (rel (bx_$bsymp), 18);
		if whalf = "lhe" then textp -> halfword.lhe18 = bit (bin (val, 18), 18);
		else if whalf = "l15" then textp -> pr_offset.lhe15 = addr (val) -> pr_offset.rhe15;
		else textp -> halfword.rhe18 = bit (bin (val, 18), 18);
	     end;
	end;


/* and now, at last, make an object map for the new object segment */

	call make_bound_object_map_ (code);
	if code ^= 0 then
	     do;
	     call com_err_ (0, inp.caller_name, "Cannot generate object map");
	     bx_$fatal_error = 1;
	     bx_$o_lng = bx_$t_lng + (bx_$bound_sep_stat * bx_$i_lng) + bx_$l_lng + bx_$s_lng; /* to get bitcount */
	     bx_$bseg_bitcount = bx_$o_lng * 36;	/* ... */
	end;

	bx_$o_lng = divide (bx_$bseg_bitcount, 36, 17, 0);


	if bx_$fatal_error = 1 then goto return;
	call hcs_$set_bc_seg (bx_$temp_bsegp, bx_$bseg_bitcount, code);

	if list_seg = "1"b then			/* produce a listing segment */
	     do;
	     dirname = get_wdir_ ();			/* get directory name */
	     segname = bx_$bound_segname;		/* get name of bound object segment */
	     i = index (segname, " ");
	     substr (segname, i, 5) = ".list";
	     list_ptr = null;
	     call tssi_$get_segment (dirname, segname, list_ptr, list_acinfop, code); /* create segment */
	     if list_ptr = null then
		do;
		call com_err_ (code, inp.caller_name, segname);
		bx_$fatal_error = 1;
		goto return;
	     end;
	     listname = segname;			/* copy segment name */
	     substr (listname, i, 5) = ".map ";
	     call hcs_$chname_seg (list_ptr, "", listname, code);
	     if code ^= 0 then			/* name duplication */
		if code ^= error_table_$segnamedup then
		     do;
		     call com_err_ (0, inp.caller_name, "Cannot add name ^a to segment ^a", listname, segname);
		end;
	     obj_ptr = bx_$temp_bsegp;		/* pointer to new bound object segment */
	     list_bc = 0;
	     if list_opt = "1"b then
		do;				/* copy bindfile, if any */
		if inp.bindfilep = null then goto output_bindmap;
		p = list_ptr;			/* copy for convenience */
		call ioa_$rs ("^/^/^-^-Bindfile for ^a^/", dirname, val, bx_$bound_segname);
		substr (based_string, 1, val) = substr (dirname, 1, val);
		lng = divide (inp.bindfile_bc, 9, 17, 0); /* get character count */
		substr (based_string, val + 1, lng) = substr (bindfilep -> based_string, 1, lng);
		lng = lng + val;
		substr (based_string, lng + 1, 2) = FF || NL;
		list_bc = (lng + 2) * 9;		/* set bitcount of list segment */
	     end;
output_bindmap:
	     long = 1;
	     nopts = 0;
	     if map_opt = "1"b then call form_bind_map_ (addr (x), code); /* go produce bindmap information */
	     if list_opt = "1"b then
		do;
		unspec (x.long) = "740000000000"b3;	/* fabricate form_link_info_ arguments */
		lng = divide (list_bc, 9, 17, 0);	/* get length in chars of list seg */
		substr (list_ptr -> based_string, lng + 1, 2) = FF || NL;
		list_bc = list_bc + 18;		/* increase length by 2 chars */
		call form_link_info_ (addr (x), code);	/* output link info  */
	     end;
	     if list_ptr ^= null then call tssi_$finish_segment
		     (list_ptr, list_bc, "1011"b, list_acinfop, code);
	end;

return:
	if bx_$fatal_error = 1 then
	     do;
	     bx_$addname = 0;
	     call com_err_ (0, inp.caller_name,
		"Fatal error has occurred; binding of ^a unsuccessful.^/The incomplete version exists in [pd]>^a.",
		bx_$bound_segname, bx_$bound_segname);
	end;

	call temp_mgr_$close_files;

	if old_ptr ^= null then do;			/* release the temp seg we got for version 2 input */
	     call release_temp_segment_ ("bind_", inpp, (0));
	     inpp = old_ptr;
	end;


	return;
%page;

CONVERT_I_TO_II:
     proc ();

/* program to convert version 1 inp to version 2 inp. */

/*  Automatic  */

dcl  idx fixed bin;

/*  Based */

dcl  1 v1_inp aligned based (old_ptr),			/* the now-obsolete version 1 binder_input */
       2 version char (4) aligned,
       2 caller_name char (32) unaligned,		/* Name of command on whose behalf binder is being invoked */

       2 bound_seg_name char (32) unaligned,		/* name of new bound segment */

       2 narc fixed bin,				/* number of input archive files */
       2 nupd fixed bin,				/* number of update archive files */

       2 archive (30) aligned,			/* info about input archives, for source map, etc. */
         3 path char (168) unaligned,			/* for identifying archive */
         3 real_path char (168) unaligned,		/* determined by translator_info_ */
         3 ptr pointer,				/* pointer to archive */
         3 bc fixed bin (24),				/* and its bitcount */
         3 uid bit (36) aligned,			/* unique id of archive */
         3 dtm fixed bin (71),			/* date-time modified of archive */

       2 bindfilep pointer,				/* pointer to bindfile */
       2 bindfile_bc fixed bin (24),			/* bitcount of bindfile */
       2 bindfile_name char (32) unaligned,		/* name of bindfile */
       2 bindfile_time_up fixed bin (71),		/* date updated in archive */
       2 bindfile_time_mod fixed bin (71),		/* date last modified */
       2 bindfile_idx fixed bin,			/* index of archive bindfile was in */

       2 options aligned,
         3 debug bit (1) unaligned,			/* 1-> debug option ON */
         3 list_seg bit (1) unaligned,			/* 1 -> make list seg */
         3 map_opt bit (1) unaligned,			/* 1 -> map option  */
         3 list_opt bit (1) unaligned,			/* 1 -> list option */
         3 brief_opt bit (1) unaligned,			/* 1 -> brief option */
         3 force_order_opt bit (1) unaligned,		/* 1 -> force_order option from command line */
         3 flags_pad bit (30) unaligned,

       2 nobj fixed bin,				/* number of objects to be bound */

       2 v1_obj (400) aligned like v1_obj;

dcl  1 v1_obj aligned based (p),			/* dcl of single input entry for version 1 binder_input */
       2 filename char (32) unaligned,
       2 base pointer,				/* pointer to base of object segment */
       2 bitcount fixed bin (24),			/* bitcount of object segment */
       2 option bit (18) unaligned,			/* pointer into option structure */
       2 flag bit (1) unaligned,			/* This word of unaligned bits ought to be a substructure, */
       2 pad bit (17) unaligned,			/* but if it is, pl1 scope-of-names stupidly rejects refs */
						/* to obj.flag as "ambiguous", because of inp.obj.flag */
       2 archive_idx fixed bin,			/* index of archive from which this component comes */
       2 time_mod fixed bin (71),			/* DTCM of component (from archive) */
       2 time_up fixed bin (71);			/* Time updated in archive */

	old_ptr = inpp;
	call get_temp_segment_ ("bind_", inpp, code);
	if code ^= 0 then do;
	     call com_err_ (code, "bind_", "Could not get temporary segment for version 2 input structure");
	     bx_$fatal_error = 1;
	     goto return;
	end;

	inp.version = BINDER_INPUT_VERSION_2;
	inp.caller_name = v1_inp.caller_name;
	inp.bound_seg_name = v1_inp.bound_seg_name;
	inp.narc = v1_inp.narc;
	inp.nupd = v1_inp.nupd;
	inp.ntotal = inp.narc + inp.nupd;
	inp.nobj = v1_inp.nobj;

	inp.bindfilep = v1_inp.bindfilep;
	inp.bindfile_bc = v1_inp.bindfile_bc;
	inp.bindfile_name = v1_inp.bindfile_name;
	inp.bindfile_time_up = v1_inp.bindfile_time_up;
	inp.bindfile_time_mod = v1_inp.bindfile_time_mod;
	inp.bindfile_idx = v1_inp.bindfile_idx;

	unspec (inp.options) = unspec (v1_inp.options);

	do idx = 1 to inp.ntotal;
	     inp.archive (idx) = v1_inp.archive (idx), by name;
	     inp.archive (idx).standalone_seg = "0"b;
	end;

	do idx = 1 to inp.nobj;
	     inp.obj (idx) = v1_inp.v1_obj (idx), by name;
	     inp.obj (idx).new_order = 0;
	     inp.obj (idx).to_be_ignored,
		inp.obj (idx).objectname_stmt = "0"b;
	end;

	return;

     end CONVERT_I_TO_II;


%page; %include bindext;
%page; %include comptbl;
%page; %include bndtbl;
%page; %include linkdcl;
%page; %include binder_input;
%page; %include terminate_file;

     end bind_;




		    binder_.pl1                     12/18/84  0913.4r w 12/18/84  0836.8       44721



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


binder_: proc (P_old_input_ptr);

/* *	BINDER_
   *
   *	This procedure, once the standard subroutine interface for the binder, is now
   *	just a writearound to call bind_ with the appropriately formatted new structure.
   *	It is slightly complicated by the fact that it must copy between two structures
   *	both named input, described in two different include files; this is done by
   *	including one in the outer procedure, and one in a begin block.
   *
   *	01/21/81, W. Olin Sibert
   *	10/3/84, M. Sharpe modified to use version 2 of binder_input.incl.pl1
   */

dcl  P_old_input_ptr pointer parameter;

dcl 1 old_input aligned like inp based (P_old_input_ptr);

dcl (p, inpp) pointer;				/* Silly pointers not declared by the include files */
dcl  time_now fixed bin (71);
dcl  (idx, old_idx) fixed bin;

dcl  inp_area area;

dcl  bind_ entry (pointer);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  get_system_free_area_ entry () returns (area);

dcl (clock, null, substr) builtin;

dcl cleanup condition;

%page;

	inpp = null ();
	on cleanup begin;
	     if inpp ^= null () then free inp in (inp_area);
	end;
	begin;					/* Copy all the information which is meaningful */

	inp_area = get_system_free_area_ ();
	NTOTAL = old_input.nupd+old_input.narc;
	NOBJ = old_input.nobj;
	allocate inp in (inp_area) set (inpp);



	     unspec (inp) = ""b;

	     inp.version = BINDER_INPUT_VERSION_2;
	     inp.caller_name = "binder_";		/* The "caller_name name", left as binder_ for compatibility */

	     inp.bound_seg_name = old_input.bound_seg_name;

	     inp.narc = old_input.narc;
	     inp.nupd = old_input.nupd;
	     inp.ntotal = old_input.narc + old_input.nupd;
	     inp.nobj = old_input.nobj;


	     inp.archive (*).path = "";		/* First, clean these all out, then copy the used entries */
	     inp.archive (*).real_path = "";	/* Most things were already initialized by the unspec, above */
	     inp.archive (*).ptr = null ();	/* All archive pointers will be null, sorry */

	     do idx = 1 to inp.ntotal;		/* Now, copy what we can from the old input */
		inp.archive (idx).real_path =
		     substr (old_input.archive_file (idx).name, 1, old_input.archive_file (idx).lng);
		inp.archive (idx).uid = old_input.archive_file (idx).uid;
		inp.archive (idx).dtm = old_input.archive_file (idx).dtm;
		end;

	     inp.bindfilep = old_input.bindfilep;
	     inp.bindfile_bc = old_input.bindfile_bc;
	     inp.bindfile_name = substr (old_input.bindfile_name, 1, old_input.bindfile_name_lng);
	     call convert_date_to_binary_ ((old_input.bindfile_date_up), inp.bindfile_time_up, (0));
	     call convert_date_to_binary_ ((old_input.bindfile_date_mod), inp.bindfile_time_mod, (0));
	     inp.bindfile_idx = 1;		/* All archive indices are faked to be one, even though */
						/* this may be incorrect, since the field must have some */
						/* value for certain error messages to work at all. */

	     inp.options.debug = old_input.debug;
	     inp.options.list_seg = old_input.list_seg;
	     inp.options.map_opt = old_input.map_opt;
	     inp.options.list_opt = old_input.list_opt;
	     inp.options.brief_opt = old_input.brief_opt;

	     inp.obj (*).base = null ();		/* Initialize certain values for all the input components */
	     inp.obj (*).filename = "";

	     time_now = clock ();

	     idx = 0;
	     do old_idx = 1 to old_input.nobj;		/* Copy all meaningful values for real components */
		if old_input.obj (old_idx).bitcount > 0 then do;
		     idx = idx + 1;
		     inp.obj (idx).filename = old_input.obj (old_idx).filename;
		     inp.obj (idx).base = old_input.obj (old_idx).base;
		     inp.obj (idx).bitcount = old_input.obj (old_idx).bitcount;
		     inp.obj (idx).option = old_input.obj (old_idx).option;
		     inp.obj (idx).flag = old_input.obj (old_idx).flag;

		     inp.obj (idx).archive_idx = 1;	/* To make messages work; same as for bindfile above */
		     inp.obj (idx).time_mod = time_now; /* This is as valid as we can make it. They will all be */
		     inp.obj (idx).time_up = time_now; /* the same, though they will all also be wrong */
		end;
	     end;

	     inp.nobj = idx;			/* reset after tossing out zero-length segs */
	     call bind_ (addr (inp));		/* Call the real interface */

%page;	%include binder_input;

	     end; 				/* Begin block */

	if inpp ^= null () then free inp in (inp_area);
	return;					/* All done */

%page;	%include input;

	end binder_;




		    bx_.cds                         07/16/86  1217.0rew 07/16/86  0846.3       70191



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

/* HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Changed version number to 12, added bx_$caller and bx_$temp_bsegp
                                                   END HISTORY COMMENTS */

/* BX_ - Static Segment for the Multics Binder.
   Rewritten in CDS 12/16/76 by Noel I. Morris	*/
/* Modified 8/16/77 by Melanie Weaver to add perprocess_static switch */
/* Modified Oct 78 by David Spector to delete temp pointers and count */
/* Modified Dec 78 by David Spector to make repatch table extensible */
/* Version 10.2: 01/15/81, W. Olin Sibert: -force_order, -force_update, bind command warnings */
/* Modified 5/25/82 by Melanie Weaver to increase addname limit */
/* Modified 06/16/83 by Melanie Weaver to handle list template external variable initialization */
/* Modified 11/03/83 by Melanie Weaver to change version for changes made by JMAthane in 1982 */
/* Modified 11/15/84 by M. Sharpe to change version number */

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


/* format: style3,^indnoniterdo */
bx_:
     proc;

dcl	1 cdsa		like cds_args auto aligned;


dcl	Binder_Version_Name char (167) static options (constant)
			init ("Multics Binder, Version 12 of Tuesday, March 26, 1985");
dcl	Binder_Version_Number
			fixed bin static options (constant) init (12);


dcl	1 bx_text		aligned auto,		/* pure portion of bx_ */
	  2 vers_name,				/* ASCII version name, in ACC form */
	    3 lth		fixed bin (8) unal,
	    3 chr		char (167) unal,
	  2 vers_number	fixed bin,		/* integer part of version number */
	  2 size		fixed bin,		/* size of main data base, for resetting */
	  2 snt_limit	fixed bin,		/* preset limit for segname table */
	  2 oddname_limit	fixed bin,		/* preset limit for oddname table */
	  2 stringmap_limit fixed bin,		/* preset limit for stringmap table */
	  2 addname_limit	fixed bin;		/* preset limit for addname table */


dcl	1 bx_link		aligned auto,		/* internal static portion of bx_ */
	  2 area_begin	bit (0) unal,		/* beginning of main data base */
	  2 ctp		pointer,			/* pointer to component table */
	  2 freep		pointer,			/* pointer to beginning of free area */
	  2 isp		pointer,			/* pointer to first insym table */
	  2 inpp		pointer,			/* pointer to binder's input structure */
	  2 bsegp		pointer,			/* pointer to base of new object segment */
	  2 temp_bsegp	ptr,			/* pointer to temporary bound seg (in [pd]) */
	  2 temp		pointer,			/* pointer to threaded temp segments */
	  2 optp		pointer,			/* pointer to options table */
	  2 odnp		pointer,			/* pointer to oddname table */
	  2 first_rptp	pointer,			/* pointer to first chunk of repatch table */
	  2 last_rptp	pointer,			/* pointer to current chunk of repatch table */
	  2 adnp		pointer,			/* pointer to addname table */
	  2 bindmap_def	pointer,			/* pointer to new object's "bind_map" definition */
	  2 bdefp		pointer,			/* pointer to new object's definition section */
	  2 bstatp	pointer,			/* pointer to new object's static section */
	  2 blnkp		pointer,			/* pointer to new object's linkage section */
	  2 bsymp		pointer,			/* pointer to new object's symbol section */
	  2 sntp		pointer,			/* pointer to segname table */
	  2 tdefp		pointer,			/* pointer to temporary new definition section */
	  2 tintp		pointer,			/* pointer to temporary new internal static */
	  2 tlinkp	pointer,			/* pointer to temporary new linkage section */
	  2 strmp		pointer,			/*  pointer to stringmap table */
	  2 n_firstrefs	fixed bin,		/* ptr to comp tbl for seg with frt */
	  2 bound_segname	char (32) aligned,		/* name of new bound object */
	  2 caller	char (32) aligned,		/* name of calling program */
	  2 fatal_error	fixed bin,		/* 1 -> fatal error was detected */
	  2 bseg_acinfop	pointer,			/* new object's acinfop for "tssi_" */
	  2 bseg_bitcount	fixed bin (24),		/* new object's bitcount */
	  2 o_lng		fixed bin (19),		/* length of new bound object */
	  2 t_lng		fixed bin (18),		/* length of new text section */
	  2 d_lng		fixed bin (18),		/* length of new definition section */
	  2 i_lng		fixed bin,		/* length of new static section */
	  2 l_lng		fixed bin,		/* length of new linkage section */
	  2 s_lng		fixed bin (18),		/* length of new symbol section */
	  2 addname	fixed bin,		/* 1 -> addname option specified */
	  2 debug		fixed bin,		/* 1 -> debug option was specified */
	  2 brief		fixed bin,		/* 1 -> brief option was specified */
	  2 force_order	fixed bin,		/* 1 -> -force_order specified on command line */
	  2 has_sep_stat	fixed bin,		/* 1 -> a comp has nonzero sep static */
	  2 has_comb_stat	fixed bin,		/* 1 -> a comp has nonzero compined static */
	  2 bound_sep_stat	fixed bin,		/* 1 -> bound segment has separate static */
	  2 perprocess_static
			fixed bin,		/* 1 -> bound seg has perprocess static switch on */
	  2 standard	fixed bin,		/* 1 -> bound seg is in standard format */
	  2 bproc		fixed bin,		/* 1 -> at least one component is a procedure */
	  2 textlng	fixed bin (18),		/* length of new pure text portion */
	  2 curdeflng	fixed bin (18),		/* current length of new definition section */
	  2 tintlng	fixed bin,		/* current length of new internal static */
	  2 maxlinklng	fixed bin,		/* maximum size linkage section may attain */
	  2 maxdeflng	fixed bin (18),		/* maximum size definitions section may attain */
	  2 tlinklng	fixed bin,		/* current size of linkage section */
	  2 ncomp		fixed bin,		/* number of component objects to be bound */
	  2 v_lng		fixed bin,		/* length of version name string */
	  2 n_lng		fixed bin,		/* length of bound segment name string */
	  2 nsymdefs	fixed bin,		/* count of non-null symbol definitions */
	  2 nsegdefs	fixed bin;		/* count of non-null segment name definitions */


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

dcl	(addr, length, null, size, string, unspec)
			builtin;

%page;

	unspec (bx_text) = "0"b;			/* Clear data bases. */
	unspec (bx_link) = "0"b;

	vers_name.lth = length (Binder_Version_Name);
	vers_name.chr = Binder_Version_Name;
	vers_number = Binder_Version_Number;
	bx_text.size = size (bx_link);
	snt_limit = 900;
	oddname_limit = 256;
	stringmap_limit = 2048;
	addname_limit = 250;

	ctp, freep, isp, inpp, bsegp, temp_bsegp, optp, odnp, first_rptp, last_rptp, adnp, bindmap_def, bdefp, bstatp,
	     blnkp, bsymp, sntp, tdefp, tintp, tlinkp, strmp, bseg_acinfop = null ();

	n_firstrefs = 0;


	cdsa.sections (1).p = addr (bx_text);
	cdsa.sections (1).len = size (bx_text);
	cdsa.sections (1).struct_name = "bx_text";

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

	cdsa.seg_name = "bx_";

	cdsa.num_exclude_names = 0;

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

	call create_data_segment_ (addr (cdsa), code);

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

	return;

%page;
%include cds_args;

     end bx_;




		    decode_link_.pl1                11/20/86  1403.9r w 11/20/86  1142.2       78732



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

/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and readability and changed errname to use a caller
     supplied value instead of "binder_".
                                                   END HISTORY COMMENTS */

/* format: style3,^indnoniterdo */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */


/********************************************************************/
/*							*/
/*	Name:	decode_link_				*/
/*	Input:	structure_ptr				*/
/*	Function:	given the offset of a link in the linkage section	*/
/*		(from loffset in ext), extract the following	*/
/*		information from the link:			*/
/*		  Tm modifier	- from tag field of link	*/
/*				  stored in ext.link_tm	*/
/*		  Td modifier	- from tag field of link	*/
/*				  store in ext.link_td	*/
/*		  expression value	- from expression word in	*/
/*				  definition section	*/
/*				  store in ext.expr		*/
/*		  link type	- from type-pair in defn scn	*/
/*				  store in ext.type		*/
/*		  trap pointer	- from type-pair in defn scn	*/
/*				  store in ext.trap		*/
/*		  segname		- from segname ACC string in	*/
/*				  defn scn or decoded from	*/
/*				  type and segpointer:	*/
/*				    tp 1, sp 0 = *text	*/
/*				    tp 1, sp 1 = *link	*/
/*				    tp 1, sp 2 = *symbol	*/
/*				    tp 1, sp 4 = *static	*/
/*				    tp 5, sp 5 = *system	*/
/*				    tp 5 = component filename	*/
/*				    other = segname ACC str	*/
/*				  store in ext.segname	*/
/*		  entryname	- from entryname ACC string	*/
/*				  for type 4, 5, 6 links only	*/
/*				  store in ext.entryname	*/
/*		The flag ext.dont_prelink is also set for *system	*/
/*		links since they must remain external		*/
/*	Output:	code					*/
/*							*/
/********************************************************************/

/* Designed and coded by Michael J. Spier February 13,1971 */
/* modified 6/20/75 by M. Weaver for separate static */
/* modified 10/22/76 by M. Weaver for *system */


decode_link_:
     procedure (structure_ptr, code);

declare	structure_ptr	pointer,
	code		bit (1) aligned;



/* DECLARATION OF EXTERNAL ENTRIES */

declare	com_err_		external entry options (variable);

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	errname		char (16) aligned internal static;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, type)		fixed bin (18);
declare	(extp, defptr)	pointer;
declare	(linkp, expp, typep, ACCp)
			pointer;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bit, index, substr, unspec)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 ext		aligned based (extp) like external_ref;


declare	1 link		aligned like object_link based (linkp);
declare	1 exp		aligned like exp_word based (expp);
declare	1 loffset_overlay	aligned based (addr (ext.loffset)),
	  2 dum		bit (35) unaligned,
	  2 odd		bit (1) unaligned;
declare	1 type_pr		aligned like type_pair based (typep);
declare	1 segname_ACC	aligned based (addr (ext.segname)) like acc_string;
declare	1 entryname_ACC	aligned based (addr (ext.entryname)) like acc_string;
declare	1 ACC		aligned like acc_string based (ACCp);
declare	segname_overlay	bit (297) aligned based (addr (ext.segname));
declare	entryname_overlay	bit (2313) aligned based (addr (ext.entryname));


/*  */

%include object_link_dcls;

/*  */

%include definition_dcls;

/*  */

%include extref;

/*  */

%include bindext;

/*  */

%include comptbl;

/*  */


	extp = structure_ptr;			/* copy pointer to external ref structure */
	ctep = ext.compent_ptr;			/* copy argument into stack for efficiency */
	defptr = comp.cdefp;			/* copy pointer to component object's def section */
	code = "0"b;				/* reset return value */



	if loffset_overlay.odd
	then /* compiler error,should refer to an even location */
	     do;
	     call com_err_ (0, errname, "^a|^o of ^a referencing odd location in linkage section.", ext.section,
		ext.offset, comp.filename);
	     goto error_skip;
	end;
	linkp = addrel (comp.clnkp, ext.loffset);	/* pointer to link fault */
	if link.tag ^= "100110"b
	then do;
	     call com_err_ (0, errname, "link|^o referenced by ^a|^o of ^a not linkfault (46)8.", ext.loffset,
		ext.section, ext.offset, comp.filename);
	     goto error_skip;
	end;
	ext.link_tm = substr (link.modifier, 1, 2);	/* get link's TM modifier */
	ext.link_td = substr (link.modifier, 3, 4);	/* get link's TD modifier */
	segname_overlay, entryname_overlay = "0"b;	/* clear ACC strings */
	ext.slng, ext.elng = 0;			/* and their respective lengths */
	expp = addrel (defptr, link.expression_relp);	/* get pointer to expression word */
	ext.expr = unspec (exp.expression);		/* get expression  value */
	typep = addrel (defptr, exp.type_relp);		/* get pointer to type-pair */
	ext.type = bit (type_pr.type);		/* get type */
	ext.trap = bit (type_pr.trap_relp);		/* and trap pointer */
	type = type_pr.type;
	if type ^= 3
	then if type ^= 4
	     then if type ^= 1
		then if type ^= 5
		     then if type ^= 6
			then do;
			     call com_err_ (0, errname,
				"External link type ^o in link|^o of ^a; not handled by current version.", type,
				ext.loffset, comp.filename);
			     goto error_skip;
			end;
	ext.code15 = bit (type_pr.segname_relp);	/* copy types 1 & 5 segbase code */
	i = type_pr.segname_relp;			/* convert segpointer to fix for type-1 link */
	if type = 1
	then /*  *|expr,m  link */
	     do;
	     segname_ACC.count = 5;			/* preset char count */
	     if i = 0
	     then segname_ACC.string = "*text";
	     else if i = 1
	     then segname_ACC.string = "*link";
	     else if i = 2
	     then do;
		segname_ACC.count = 7;
		segname_ACC.string = "*symbol";
	     end;
	     else if i = 4
	     then do;
		segname_ACC.count = 7;
		segname_ACC.string = "*static";
	     end;
	     else do;
		call com_err_ (0, errname, "type-1 link at link|^o of ^a has illegal seg-ptr value ^o", ext.loffset,
		     comp.filename, i);
		goto error_skip;
	     end;
	     ext.slng = segname_ACC.count + 1;
	     goto extract_symbol;
	end;
	if type = 5
	then /*  *|symbol+exp,m link */
	     do;
	     if i = 5
	     then do;				/* *system, not ordinary type 5 */
		segname_ACC.count = 7;
		segname_ACC.string = "*system";
	     end;
	     else do;				/* make segname = filename  */
		segname_ACC.count = index (comp.filename, " ") - 1;
		segname_ACC.string = substr (comp.filename, 1, segname_ACC.count);
	     end;
	     ext.slng = segname_ACC.count + 1;		/* length of entire ACC string (incl. count) */
	     goto extract_symbol;
	end;					/* get pointer to segment name */
	ACCp = addrel (defptr, type_pr.segname_relp);
	segname_ACC.count = ACC.count;		/* get ACC string length */
	if segname_ACC.count > 32
	then /* string too long */
	     do;
	     call com_err_ (0, errname, "external segname ^a longer than 32 chars; segname truncated.", ACC.string);
	     segname_ACC.count = 32;
	end;
	ext.slng = segname_ACC.count + 1;		/* store length in structure */
						/* and copy string into structure */
	segname_ACC.string = substr (ACC.string, 1, segname_ACC.count);
extract_symbol:
	if type = 4 | type = 5 | type = 6
	then /* there is an entryname */
	     do;
	     ACCp = addrel (defptr, type_pr.offsetname_relp);
	     entryname_ACC.count = ACC.count;
	     if entryname_ACC.count > 256
	     then do;
		call com_err_ (0, errname, "external entryname ^a longer than 256 chars; entryname truncated.",
		     ACC.string);
		entryname_ACC.count = 256;
	     end;
	     ext.elng = entryname_ACC.count + 1;
	     entryname_ACC.string = substr (ACC.string, 1, entryname_ACC.count);
	end;					/* *system must be external */
	if ((type = 5) & (i = 5))
	then ext.dont_prelink = "1"b;

	return;

error_skip:
	code = "1"b;				/* error occurred, return code */
	return;

init:
     entry;					/* set error message caller name */
	if bx_$debug = 1
	then errname = "decode_link_";
	else errname = bx_$caller;

	return;

     end decode_link_;




		    dissect_object_.pl1             11/20/86  1403.9r w 11/20/86  1145.0      175482



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Changed errname to use caller supplied name instead of "binder_", improved
     documentation and readability, deleted obsolete nonstandard object
     support, and added code to create the link_regeneration_table.
  2) change(86-07-02,Elhard), approve(86-07-02,MCR7284),
     audit(86-07-23,JRGray), install(86-08-06,MR12.0-1119):
     Modified to not use segname definitions already in the component as search
     names for resolving intercomponent calls.
                                                   END HISTORY COMMENTS */

/**********************************************************************/
/*							*/
/*	Name:	dissect_object_				*/
/*	Input:	compent_ptr				*/
/*	Function:	breaks down the object segment specified by the	*/
/*		component table entry pointed to by compent and	*/
/*		fills in the rest of the component table entry.	*/
/*		This procedure is also responsible for the	*/
/*		following:				*/
/*		  1) copying the component's text section into	*/
/*		     the new object	segment, padding the end of	*/
/*		     the the previous text section if required	*/
/*		     to get the proper text section alignment,	*/
/*		     and calculating the new text section	*/
/*		     relocation counter.			*/
/*		  2) calculate the relocation counter for the	*/
/*		     internal static section and pad the static	*/
/*		     section of the previous component if reqd	*/
/*		     to align the current component's static	*/
/*		     section on the proper boundary.		*/
/*		  3) the segname table is updated to include the	*/
/*		     new component.				*/
/*		  4) copy the definition section into the insym	*/
/*		     table.				*/
/*		  5) determine the number of symbol blocks that	*/
/*		     are present in the object segment.		*/
/*		  6) allocate the link_regeneration_table for the	*/
/*		     component.				*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* Designed and initially coded by Michael J. Spier, August 20, 1970	*/
/* modified 75.06.20 by M. Weaver for separate static		*/

/* format: style3,^indnoniterdo */
dissect_object_:
     procedure (compent_ptr);

declare	compent_ptr	pointer;



/* DECLARATION OF EXTERNAL ENTRIES */

declare	decode_definition_$full
			external entry (pointer, pointer, pointer) returns (bit (1) aligned);
declare	object_info_$long	external entry (pointer, fixed bin (24), pointer, fixed bin (35));
declare	com_err_		external entry options (variable);
declare	ioa_		external entry options (variable);
declare	temp_mgr_$allocate	external entry (fixed bin);
declare	temp_mgr_$reserve	external entry (pointer);

/* DECLARATION OF EXTERNAL STATIC */

declare	error_table_$bad_segment
			external fixed bin (35);
declare	error_table_$unimplemented_version
			external fixed bin (35);

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	last_insym	pointer internal static initial (null);
declare	(text_relc, is_relc)
			fixed bin internal static initial (0);
declare	errname		char (16) aligned internal static;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	i		fixed bin;
declare	(def_begin, def_offset, val, lng)
			fixed bin (18);
declare	code		fixed bin (35);
declare	(p, sblkp, ddp, oip)
			pointer;
declare	(defp, insymp, insymep)
			pointer;
declare	type_string	char (5) aligned;
declare	link_start	fixed bin (18) unsigned;
declare	link_end		fixed bin (18) unsigned;
declare	lrt_len		fixed bin;
declare	lrt_word_count	fixed bin;

declare	1 dd		aligned,			/* output structure for decode_definition_ */
	  2 next_def	pointer,
	  2 last_def	pointer,
	  2 block_ptr	pointer,
	  2 section	char (4) aligned,
	  2 value		fixed bin (18),
	  2 entrypoint	fixed bin,
	  2 symbol	char (256) aligned,
	  2 symbol_lng	fixed bin,		/* actual length of symbol */
	  2 flags,
	    3 new_format	bit (1) unaligned,
	    3 ignore	bit (1) unaligned,		/* def is to be ignored but will be regenerated */
	    3 entrypoint	bit (1) unaligned,		/* def is for entrypoint */
	    3 retain	bit (1) unaligned,
	    3 arg_count	bit (1) unaligned,		/* there is an arg count for entry */
	    3 descr_sw	bit (1) unaligned,		/* there are descriptors for entry */
	    3 unused	bit (13) unaligned,
	  2 n_args	fixed bin,		/* no of args entry expects */
	  2 descr_ptr	ptr;			/* ptr to array of rel ptrs to descriptors in def section */

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, divide, fixed, min, null, ptr, rel, substr, trunc)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 insyme		aligned like is based (insymep);
declare	1 symbol_acc	aligned based (addr (insyme.symbol)),
	  2 len		fixed bin (9) unsigned unaligned,
	  2 text		char (32 refer (symbol_acc.len)) unaligned;
declare	1 rhb		based aligned,
	  2 dum		bit (35) unaligned,
	  2 odd		bit (1) unaligned;		/* to determine if a value is even/odd */

declare	textsection	(lng) fixed bin based (p);

/*  */

%include bindext;

/*  */

%include comptbl;

/*  */

%include bndtbl;

/*  */

%include insym;

/*  */

declare	1 oi		aligned like object_info;

%include object_info;

/*  */

%include object_link_dcls;

/*  */

%include symbol_block;


%include pl1_symbol_block;


declare	1 firstref_block	aligned based,
	  2 version	fixed bin,
	  2 n_traps	fixed bin,
	  2 traps		(0 refer (firstref_block.n_traps), 2) bit (18) unaligned;

declare	1 lh		aligned based (oi.linkp),
	  2 defseg	fixed bin,		/* 0->defs in text, 16->defs in link  */
	  2 defptr	bit (18) unaligned,		/* offset of definition section */
	  2 first_reference bit (18) unaligned,		/* offset of first ref trap array */
	  2 fthread	pointer,			/* unused */
	  2 bthread	pointer,			/* unused */
	  2 link_begin	bit (18) unaligned,		/* offset in linkage section of linkage info */
	  2 block_lng	bit (18) unaligned,
	  2 dum2		bit (18) unaligned,
	  2 linkage_lng	bit (18) unaligned;



/*  */

	ctep = compent_ptr;				/* copy pointer to component table entry */
	sntp = bx_$sntp;				/* pointer to segname table */
	oip = addr (oi);				/* initialize */

	oi.version_number = object_info_version_2;
	call object_info_$long (comp.ctxtp, comp.cbitcount, addr (oi), code);
	if code ^= 0
	then do;					/* bad object segment */
faterr:
	     call com_err_ (code, errname, comp.filename);
	     bx_$fatal_error = 1;
	     return;
	end;

	if ^oi.format.standard
	then do;
	     code = error_table_$bad_segment;		/* don't process non-standard new objects */
	     go to faterr;				/* this is fatal */
	end;

	if oi.bmapp ^= null
	then do;					/* also a no-no */
	     call com_err_ (0, errname, "Component ^a has a break map.", comp.filename);
	     bx_$fatal_error = 1;
	     return;
	end;

	if ^oi.format.relocatable
	then do;
	     if oi.compiler = "binder  "
	     then type_string = "bound";
	     else type_string = "";
	     call com_err_ (0, errname, "Component ^a is a nonrelocatable ^a segment.", comp.filename, type_string);
	     bx_$fatal_error = 1;
	     return;				/*  don't generate all those name  conflict messages  */
	end;

/* find the number of links to determine the size of the linke_regeneration table */
/* and allocate it.							  */

	if oi.linkp -> virgin_linkage_header.defs_in_link = "010000"b
	then link_end = oi.linkp -> virgin_linkage_header.def_offset;
	else link_end = oi.linkp -> virgin_linkage_header.linkage_section_lng;

	if oi.linkp -> virgin_linkage_header.first_ref_relp ^= 0
	then link_end = min (link_end, oi.linkp -> virgin_linkage_header.first_ref_relp);

	link_start = oi.linkp -> virgin_linkage_header.link_begin;

	lrt_len = (link_end - link_start) * 0.5;	/* calculate number of links */
	lrt_word_count = trunc ((lrt_len + 1) * 0.5) + 2; /* calculate number of words reqd for table */
	call temp_mgr_$allocate (lrt_word_count);	/* allocate the table */
	lrtp, comp.clrtp = bx_$freep;
	call temp_mgr_$reserve (addrel (lrtp, lrt_word_count));

	lrt.count = lrt_len;			/* initialize lrt */
	lrt.start_offset = link_start;
	lrt.regenerated (*) = ""b;

	comp.clngt, val = oi.tlng;			/* get length of pure-text section */
	if addr (comp.clngt) -> rhb.odd
	then comp.cpadt = 1;			/* if text length odd number, pad text with one word */
	if oi.text_boundary ^= 2			/* text must sit on 4,8,16,64 boundary */
	then if comp.cindex ^= 1			/* and this is not first entry */
	     then do;
		i = oi.text_boundary;		/* copy for convenience */
		val = divide (text_relc + i - 1, i, 17, 0) * i;
						/* compute new base */
		i = val - text_relc;		/* get difference	*/
		if i > 0
		then /* there was a difference */
		     do;
		     p = bx_$ctp -> comp_tbl (comp.cindex - 1);
						/* get previous entry */
		     p -> comp.cpadt = p -> comp.cpadt + i;
						/* extend previous pad */
		     text_relc = val;		/* adjust new base address */
		end;
	     end;
	comp.crelt = text_relc;			/* get relocation counter value for this text section */
	i = comp.clngt + comp.cpadt;			/* compute effective length of text section */
	bx_$textlng, text_relc = text_relc + i;		/* compute relocation value for next text section */

	comp.cdefp = oi.defp;			/* pointer to definition section */
	comp.clngd = oi.dlng;			/* length of definition section */

	comp.csymp = oi.symbp;			/* pointer to symbol section */
	comp.clngs = oi.slng;			/* length of symbol section */
	comp.clngns = oi.default_truncate;		/* length of symbol section without relbits */
	comp.clngss = oi.optional_truncate;		/* length of symbol section without relbits or table */

/* if there is a symbol table and it is needed by v2pl1 io, we must make
   a note of it so that we will not delete it later */
	if oi.compiler = "v2pl1" | oi.compiler = "PL/I"	/* so far only compiler that can have this */
	then if oi.standard				/* only std objs have the special flags */
	     then if oi.symbp -> sb.area_ptr		/* there might be a symbol table */
		then if addrel (oi.symbp, oi.symbp -> sb.area_ptr) -> pl1_symbol_block.flags.io
		     then comp.io_table = 1;		/* table is needed by runtime io */

	comp.clngi = oi.ilng;			/* length of internal static */
	if addr (comp.clngi) -> rhb.odd
	then comp.cpadi = 1;			/* if length of int static odd number, then pad */
	if oi.static_boundary ^= 2
	then /* if static must start at mod 4,8,16,64 */
	     if comp.cindex ^= 1
	     then /* if this is not first entry */
		do;
		i = oi.static_boundary;		/* copy for convenience */
		val = divide (is_relc + i - 1, i, 17, 0) * i;
		i = val - is_relc;			/* get difference */
		if i > 0
		then do;
		     p = bx_$ctp -> comp_tbl (comp.cindex - 1);
						/* pointer to previous entry */
		     p -> comp.cpadi = p -> comp.cpadi + i;
		     is_relc = is_relc + i;
		end;
	     end;
	comp.creli = is_relc;			/* get relocation counter value for this internal static */
	i = comp.clngi + comp.cpadi;			/* get effective length of static */
	bx_$tintlng, is_relc = is_relc + i;
	comp.clnkp = oi.linkp;			/* pointer to linkage section header */
	comp.cstatp = oi.statp;
	comp.separate_static = 0;			/* initialize */
	if oi.ilng > 0
	then do;					/* don't worry about 0 length static */
	     if oi.format.separate_static
	     then do;
		bx_$has_sep_stat = 1;
		comp.separate_static = 1;		/* this variable is needed by rebuild_object_ */
	     end;
	     else bx_$has_comb_stat = 1;
	end;
	bx_$maxlinklng = bx_$maxlinklng + oi.llng + (comp.separate_static * comp.clngi);
						/*  vble used to allocate space for both  stat + link */
	bx_$maxdeflng = bx_$maxdeflng + comp.clngd;	/* compute size of temporary for new linkage section */

	comp.crltp = oi.rel_text;
	comp.crllp = oi.rel_link;
	comp.crlsp = oi.rel_symbol;			/* pointers to relocation information */

	comp.standard_object = fixed (oi.format.standard, 1);
						/* copy object format indicator */

	dd.symbol = comp.filename;			/* put in structure for compatibility */
	do i = 32 to 1 by -1 while (substr (comp.filename, i, 1) = " ");
	end;
	dd.symbol_lng = i;				/* fill in length too */
	call update_segname_table;			/* put name in segment name table */

/* scan definition section to buildup insym entry for this object segment */

	insymp, comp.insymentp = bx_$freep;		/* get pointer to new area for insym entry */
	if last_insym ^= null
	then last_insym -> insym.thread = insymp;	/* thread insym entries together */
	else bx_$isp = insymp;			/* remember beginning of insym-table */
	last_insym = insymp;			/* remember pointer to current entry */
	insymp -> insym.thread = null;		/* indicate this last entry */
	defp, dd.next_def = oi.defp;			/* set up definition search */
	def_begin = bin (rel (defp), 18);
	ddp = addr (dd);				/* initialize before loop */

follow_defs:					/* get offset of next def rel to defp */
	def_offset = bin (rel (dd.next_def), 18) - def_begin;
	if decode_definition_$full (dd.next_def, ddp, oip) = "1"b
	then /* get next definition */
	     do;					/* make a last null entry for type 3 links */
	     insymp -> insym.n_insyms, i = insymp -> insym.n_insyms + 1;
	     insymep = addr (insymp -> insym.entry (i));
	     insyme.null_entry = "1"b;		/* set null entry indicator */
	     goto identify_format;
	end;

	if dd.section = "segn"
	then goto follow_defs;

	insymp -> insym.n_insyms, i = insymp -> insym.n_insyms + 1;
						/* get current insym-table index */
	insymep = addr (insymp -> insym.entry (i));	/* and get pointer to next entry */
	insyme.value = bit (bin (dd.value, 18), 18);
	if dd.section = "link"
	then insyme.class = "000000000000000001"b;
	else if dd.section = "symb"
	then insyme.class = "000000000000000010"b;
	else if dd.section = "stat"
	then insyme.class = "000000000000000100"b;
	symbol_acc.len = dd.symbol_lng;		/* get ACC length */
	symbol_acc.text = substr (dd.symbol, 1, dd.symbol_lng);
	insyme.lng = symbol_lng + 1;
	insyme.entrypoint = dd.flags.entrypoint;
	insyme.ignore = dd.flags.ignore;		/* def is probably for unofficial entryname */
	insyme.retain_flag = dd.flags.retain;
	insyme.def_offset = def_offset;		/* keep track of loc so we can relocate later */
	insyme.nargs = dd.n_args;
	insyme.descr_ptr = dd.descr_ptr;		/* get ptr to descr ptr list */
	insyme.has_descr = dd.flags.descr_sw;		/* copy switch indicating valid descriptors */
	goto follow_defs;

identify_format:
	comp.compiler = oi.compiler;			/* get compiler name */
	if comp.standard_object = 1
	then do;
standard_format:
	     comp.format = "standard";
	     if lh.first_reference
	     then do;				/* have some traps to regenerate */
		comp.cfrtp = addrel (oi.linkp, lh.first_reference);
		if comp.cfrtp -> firstref_block.version ^= 1
		then do;
		     call com_err_ (error_table_$unimplemented_version, errname,
			"A version ^d trap on first reference encountered.", comp.cfrtp -> firstref_block.version);
		     bx_$fatal_error = 1;
		end;
		bx_$n_firstrefs = bx_$n_firstrefs + comp.cfrtp -> firstref_block.n_traps;
	     end;
	     else comp.cfrtp = null;
	     if oi.format.procedure
	     then bx_$bproc = 1;			/* for obj map--bound seg is part proc */
	     go to block_number;			/* anything else will turn off standard flag */
	end;
	else do;
	     call com_err_ (0, errname, "object ^a is not a standard object segment", comp.filename);
	     bx_$fatal_error = 1;
	end;

	bx_$standard = 0;				/* at least one component is non-standard */

/* find number of symbol blocks this component has */

block_number:
	comp.n_sym_blks = 1;			/* object has to have at least 1 */
	sblkp = oi.symbp;				/* start with first block and thread */

block_loop:
	if sb.next_block = "0"b
	then go to return;				/* no more blocks */
	sblkp = addrel (oi.symbp, sb.next_block);	/* get ptr to next block */
	comp.n_sym_blks = comp.n_sym_blks + 1;		/* found another one */
	go to block_loop;				/* see if there are any more */

return:
	call temp_mgr_$reserve (addr (insymp -> insym.entry (insymp -> insym.n_insyms + 1)));
						/* reserve area allocated for insym table */

/* now copy text section into new bound object */

	p = ptr (bx_$temp_bsegp, comp.crelt);		/* pointer to new text location */
	lng = comp.clngt;
	p -> textsection = oi.textp -> textsection;	/* and copy the stuff */

	return;


init:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	dissect_object_$init			*/
/*	Input:	none					*/
/*	Function:	initializes the static variables used by dissect	*/
/*		object prior to the first invocation.  The text	*/
/*		and static section relocation counters are	*/
/*		cleared, and clear various external static flags	*/
/*		and counters.				*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	last_insym = null;				/* initialize INSYM thread */
	text_relc, is_relc = 0;
	bx_$maxlinklng = 128;			/* give it a small margin of safety */
	bx_$n_firstrefs = 0;			/* so far, seen none */
	bx_$bproc = 0;				/* turn on if any component is a proc */
	bx_$standard = 1;				/* assume standard output; turn off if any component is not */
	bx_$has_sep_stat, bx_$has_comb_stat = 0;	/* will count  only nonzero length static */
	if bx_$debug = 1
	then errname = "dissect_object_";
	else errname = bx_$caller;
	return;


/*  */

update_segname_table:
     procedure;

declare	i		fixed bin;
declare	sntep		ptr;
declare	val		fixed bin;
declare	acc_actual	char (33) aligned;
declare	acc_overlay	bit (297) based (addr (acc_actual));
declare	acc_str		char (val) based (addr (acc_actual));
declare	01 acc		aligned based (addr (acc_actual)),
	  02 len		fixed bin (9) unsigned unaligned,
	  02 text		char (32 refer (acc.len)) unaligned;
declare	01 snte		aligned based (sntep) like seg;

	val = symbol_lng;
	if symbol_lng > 32
	then do;					/* not acceptable for segnames */
	     call ioa_ (
		"Warning: Segment name ^a^/in definitions for component ^a^/is being truncated to 32 characters.",
		dd.symbol, comp.filename);
	     val = 32;
	end;
	acc_overlay = "0"b;				/* pad ACC temporary with zeroes */
	acc.len = val;
	acc.text = substr (dd.symbol, 1, val);

	val = val + 1;				/* adjust length to entire ACC string */
	do i = 1 to snt.n_names;			/* lookup segment name table */
	     sntep = addr (snt.entry (i));
	     if acc_str = substr (snte.name, 1, val)
	     then do;
		if snte.comp = ctep
		then return;			/* OK, its same component */
		call com_err_ (0, errname, "Segment name ^a for component ^a^/^-already used for component ^a",
		     dd.symbol, comp.filename, snte.comp -> comp.filename);
		bx_$fatal_error = 1;
		return;
	     end;
	end;
	snt.n_names, i = snt.n_names + 1;
	if i > snt.max_size
	then do;
	     call com_err_ (0, errname, "Segname table overflow; please contact maintenance");
	     snt.n_names = 1;
	     bx_$fatal_error = 1;
	     return;
	end;
	sntep = addr (snt.entry (i));			/* pointer to new entry */
	substr (snte.name, 1, val) = acc_str;
	snte.lng = val;
	snte.comp = ctep;

     end update_segname_table;


     end dissect_object_;




		    ext_link_.pl1                   11/20/86  1403.9r w 11/20/86  1142.2      379260



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation, changed errname to use the caller-supplied name
     instead of "binder_", and modified to store relocation address in the
     link_regeneration_table and just return relocated address on subsequent
     references.
                                                   END HISTORY COMMENTS */

/**********************************************************************/
/*							*/
/*	Name:	ext_link_					*/
/*	Input:	argument_pointer				*/
/*	Function:	given an external_ref structure (pointed to by	*/
/*		argument_pointer) defining a link in the current	*/
/*		input component, create a corresponding external	*/
/*		link in the new object segments linkage section.	*/
/*	Output:	none.					*/
/*							*/
/*	Notes:	External links are created by the following	*/
/*		process:					*/
/*		  - if the link is type-6 or *system, then find	*/
/*		    or create an init_map entry matching the	*/
/*		    initialization info for the link.		*/
/*		  - if the link is a trap-before-call link, then	*/
/*		    recursively generate the trap link, and the	*/
/*		    arg_link (if present)			*/
/*		  - try to find the segname, and entryname in the	*/
/*		    stringmap				*/
/*		  - scan the link_map for another link to the	*/
/*		    target.				*/
/*		  - if the link is a type-6 or *system link, and	*/
/*		    the init-info does not match then we must	*/
/*		    select one of the init info's or combine them	*/
/*		    The following algorithm is used to select	*/
/*		    the initialization info:			*/
/*		     If one links has an area initialization	*/
/*		     and the other does not, then abort with a	*/
/*		     fatal error.  This cannot be resolved.	*/
/*							*/
/*		     Initializations same size		*/
/*							*/
/*		     no new initialization			*/
/*		     1 was init before	use old		*/
/*		     2 was not init before	use old		*/
/*							*/
/*		     new initialization			*/
/*		     3 was init before	use old; print msg	*/
/*		     4 was not init before	use new		*/
/*							*/
/*		     New initialization smaller		*/
/*							*/
/*		     no new initialization			*/
/*		     5 was init before	use old		*/
/*		     6 was not init before	use old		*/
/*							*/
/*		     new initialization			*/
/*		     7 was init before	use old; print msg	*/
/*		     8 was not init before	*use new with	*/
/*					 larger size	*/
/*							*/
/*		     New initialization larger		*/
/*							*/
/*		     no new initialization			*/
/*		     9 was init before	*use old with	*/
/*					 larger size	*/
/*		     10 was not init before	use new		*/
/*							*/
/*		     new initialization			*/
/*		     11 was init before	use new; print msg	*/
/*		     12 was not init before	use new		*/
/*							*/
/*		     * using a given init info template with a	*/
/*		       larger size means that it must be extended	*/
/*		       with zeros				*/
/*							*/
/*		  - if an existing link is found and can be used	*/
/*		    relocate the referencing halfword and return	*/
/*		  - generate a new expression word in the	*/
/*		    definition section			*/
/*		  - generate a new type pair if the existing one	*/
/*		    could not be used			*/
/*		  - if the segname or entryname were not found in	*/
/*		    the stringmap, then add them		*/
/*		  - generate a new link in the linkage section	*/
/*		    and a new link_map entry.			*/
/*		  - relocate the referencing halfword and return	*/
/*							*/
/*	A note on error handling:				*/
/*	bx_$fatal_error is set when the error is fatal (i.e. there	*/
/*	should be no bound segment) but it is useful to continue	*/
/*	and possibly generate more messages for the user.		*/
/*	fatal_binder_error is signaled when the error is so severe	*/
/*	that the binder cannot reasonably continue (as when it runs	*/
/*	out of room).  (It is possible that a different		*/
/*	implementation could avoid having to abort.)		*/
/*							*/
/**********************************************************************/

/* Designed and initially coded by Michael J. Spier, October 6, 1970	*/
/* modified 75.06.20 by M. Weaver to fix type 6 link initialization */
/* modified July 1975 for separate static */
/* modified October 1976 to regenerate *system */
/* modified January 1977 by M. Weaver to use largest init sizes and convert some type 6 links to *system */
/*  modified March 18, 1977 by M. Weaver to handle 0 trap ptr for *system links  */
/* modified October 21, 1977 by M. Weaver to add non-relocation mode */
/* modified December 6, 1977 by M. Weaver to allow larger external variable init sizes */
/* modified Sept 1978 by David Spector for hash-coding strm */
/* Modified 01/15/81, W. Olin Sibert, to remove ribbon shifts. */
/* modified March 1, 1983 by M. Weaver to use standard include files and allocate init structures during finish */
/* modified December 29, 1983 by M. Weaver to not relocate n for *text|offsetname+n */

/* format: style3,^indnoniterdo */
ext_link_:
     procedure (argument_pointer);

declare	argument_pointer	pointer;


/* DECLARATION OF EXTERNAL SYMBOLS */

declare	decode_link_	external entry (pointer) returns (bit (1) aligned);
declare	ext_link_$gen_trap	external entry (pointer) returns (fixed bin (18) unsigned aligned);
declare	com_err_		external entry options (variable);
declare	ioa_		entry options (variable);
declare	temp_mgr_$allocate	external entry (fixed bin);
declare	temp_mgr_$reserve	external entry (pointer);
declare	strm_hash_$lookup	external entry (char (*), fixed bin (17));
declare	strm_hash_$make_entry
			external entry (char (*) aligned, fixed bin (17));

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	(linkbase, defbase, tblp, newlinkp, init_map_ptr)
			pointer internal static;
declare	(n_tbls, nlinks, init_map_lng)
			fixed bin internal static;
declare	null_acc_offset	fixed bin (18) unsigned aligned internal static;
declare	errname		char (16) aligned internal static;
declare	wsegname		char (33) aligned internal static;
declare	wentryname	char (257) aligned internal static;
declare	ext_lng		fixed bin (18) internal static;
declare	linklimit		fixed bin internal static;	/* number of links generated */

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, def_growth, map_lng, linkmapx, mapx, extension_size, new_init_map_index, strm_index, new_init_type,
	existing_init_type) fixed bin (17);
declare	(val, step, xoffset, class, name_offset)
			fixed bin (18);
declare	lrt_index		fixed bin;
declare	real_init_size	fixed bin (35);
declare	scratch		(100) fixed bin;
declare	(p, ap, link_ptr, old_trap, extp, new_ptr)
			ptr;
declare	(orig_init_info_ptr, cur_init_info_ptr, init_entry_ptr)
			ptr;
declare	new_link_modifier	bit (6) aligned;
declare	(segname_found, entryname_found, typepair_found, trap_sw, convert, new_has_init_template, init_before)
			bit (1) aligned;
declare	new_ename		char (256) varying;

declare	1 new_exp_word	aligned like exp_word;

declare	1 new_type_pair	aligned like type_pair;

declare	1 new_trap_pair	aligned like link_trap_pair;

declare	1 new		aligned,
	  2 (smaller, equal, larger)
			bit (1) aligned;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, currentsize, divide, fixed, index, length, mod, null, size, sign, string, substr,
	unspec, wordno)	builtin;

declare	fatal_binder_error	condition;

/* DECLARATION OF BASED STRUCTURES */

declare	1 linkmap		(10000) aligned based (newlinkp),
	  2 type_ptr	ptr,			/* ptr to link's generated type pair */
	  2 linkaddr	fixed bin (18) unsigned unaligned,
	  2 init_map_index	fixed bin unaligned,
	  2 init_source	char (32) aligned,		/* origin of init info */
	  2 has_init_template
			bit (1) unaligned,		/* "1"b -> has an associated */
						/* initialization template */
	  2 diff_init_size	bit (1) unaligned,		/* >1 size of init info specified for link */
	  2 print_msg	bit (1) unaligned,		/* >1 init template specified for link */
	  2 incompatible_init_types
			bit (1) unaligned;		/* ext var both area and other init type */

declare	1 init_map	(5000) aligned based (init_map_ptr),
	  2 init_ptr	ptr,			/* ptr to original initialization info */
	  2 new_init_ptr	ptr,			/* ptr to regenerated initialization info */
	  2 template_size	fixed bin (35),		/* expanded size of template */
	  2 total_init_size fixed bin (35),		/* size of variable incl extension */
	  2 reference_count fixed bin unaligned,	/* # of links that reference this entry */
	  2 init_type	fixed bin unaligned;	/* type of init info */

declare	1 tbl_map		based (tblp) aligned,	/* newly generated trap_pair map */
	  2 tbl_offset	(1000) fixed bin (18) unsigned unaligned;

declare	init_size_compares	(-1:1) bit (1) aligned based (addr (new));

declare	copy_save		(ext_lng) fixed bin based (p);

declare	1 word		aligned based,
	  2 left_half	bit (18) unaligned,
	  2 right_half	bit (18) unaligned;

declare	1 ext		aligned based (ap) like external_ref;

	trap_sw = "0"b;				/* indicate that this is a regular link */

start:
	def_growth = 0;
	ctp = bx_$ctp;
	strmp = bx_$strmp;
	ap = argument_pointer;			/* copy argument into our stack frame */
	ctep = ext.compent_ptr;
	val = 0;

	lrtp = comp.clrtp;
	lrt_index = ((ext.loffset - lrt.start_offset) * 0.5) + 1;
	if (lrt.regenerated (lrt_index) ^= UNRESOLVED) & (lrt.regenerated (lrt_index) ^= INTERNALLY_RESOLVED)
	then do;
	     step = fixed (lrt.regenerated (lrt_index), 18);
	     goto adjust_text;
	end;

	new_link_modifier = ext.link_tm || ext.link_td;	/* this program doesn't need them separated */

	segname_found, entryname_found, typepair_found = "0"b;

	map_lng = strm.nstr;
	new_init_map_index = 0;
	old_trap = null;
	new_has_init_template = "0"b;

	unspec (new_exp_word) = "0"b;
	unspec (new_trap_pair) = "0"b;

	new_type_pair.type = bin (ext.type, 18);	/* copy type/trap values into new type pair */
	new_type_pair.trap_relp,			/* this field does not get filled in */
	     new_type_pair.segname_relp, new_type_pair.offsetname_relp = 0;

	class = bin (ext.code15, 18);			/* use class instead of segname for types 1 & 5 */

	if new_type_pair.type = LINK_REFNAME_BASE
	then do;
	     new_type_pair.offsetname_relp = null_acc_offset;
						/* use null acc offset to compare with type 6 */
	     entryname_found = "1"b;			/* we know it's allocated */
	end;

	if ^trap_sw				/* normal ext_link_ entry (not gen_trap entry) */
	then do;					/* format name for possible error message */
	     wsegname = substr (ext.segname, 2, ext.slng - 1);
	     i = ext.elng;
	     wentryname = substr (ext.entryname, 1, i);
	     if wsegname = "*system"
	     then substr (wentryname, 1, 1) = "|";
	     else if i > 0
	     then substr (wentryname, 1, 1) = "$";
	     else do;
		i = 2;
		wentryname = "|0";
	     end;
	end;

	if ext.trap
	then if (new_type_pair.type = LINK_CREATE_IF_NOT_FOUND)
		| ((new_type_pair.type = LINK_SELF_OFFSETNAME) & (class = SECTION_SYSTEM))
	     then do;				/* have create-if-not-found or *system link */
						/* find/create an init map entry for this */
		orig_init_info_ptr = addrel (comp.cdefp, ext.trap);
		call find_init_map_entry ();
		new_has_init_template = (init_map (new_init_map_index).template_size > 0);
	     end;

	     else do;				/* have trap before link */
		addr (scratch) -> copy_save = ap -> copy_save;
						/* save input structure */
		ext.offset = ext.loffset;		/* change input struc to process trap links */
		ext.section = "link";
		ext.relinfo = " ";
		old_trap = addrel (comp.cdefp, ext.trap);
		ext.loffset = old_trap -> link_trap_pair.call_relp;
		if decode_link_ (ap)
		then go to trap_error;


		new_trap_pair.call_relp = ext_link_$gen_trap (ap);
						/* will need to recreate link */

		ext.loffset = old_trap -> link_trap_pair.info_relp;
						/* will look at arg link now */
		if ext.loffset > 0
		then do;				/* process arg link */
		     if decode_link_ (ap) = "1"b
		     then go to trap_error;
		     new_trap_pair.info_relp = ext_link_$gen_trap (ap);
		end;
		else new_trap_pair.info_relp = 0;

		do i = 1 to n_tbls;			/* scan trap before link trap pair map */
		     if unspec (new_trap_pair) = unspec (addrel (defbase, tbl_offset (i)) -> link_trap_pair)
		     then do;
			new_type_pair.trap_relp = tbl_offset (i);
						/* put rel ptr into new link's trap field */
			go to restore_ext;
		     end;
		end;				/* of searching table */

		n_tbls = i;			/* increment size of map */
		tbl_offset (i), new_type_pair.trap_relp = bx_$curdeflng;
		bx_$curdeflng = bx_$curdeflng + 1;	/* update def section size */
		addrel (defbase, tbl_offset (i)) -> link_trap_pair = new_trap_pair;
						/* copy trap pair */
restore_ext:
		ap -> copy_save = addr (scratch) -> copy_save;
						/* restore input struc */
	     end;					/* of trap decoding processing */

/* scan current portion of new linkage section to see if such ext link already exists */

	def_growth = 0;
	new_exp_word.expression = bin (ext.expr, 17);

	if new_type_pair.type = LINK_SELF_BASE | new_type_pair.type = LINK_SELF_OFFSETNAME
	then do;					/* type 1 & type 5 links don't have symbolic segnames */
	     new_type_pair.segname_relp = class;	/* retrieve segbase code */
	     segname_found = "1"b;			/* we know the "segment name" */
	     if bx_$bound_sep_stat ^= 1
	     then if class = SECTION_STATIC		/* link to *static */
		then new_type_pair.segname_relp = SECTION_LINK;
						/* will be no sep static; convert to *link */
	     if new_type_pair.type = LINK_SELF_BASE
	     then do;				/* there is no entryname symbol */
		entryname_found = "1"b;
		if class = SECTION_TEXT
		then new_exp_word.expression = new_exp_word.expression + comp.crelt;
		if class = SECTION_STATIC
		then do;				/* link to static; seg relp may have been changed */
		     if wsegname = "*static"
		     then do;			/* link to static of referencing component */
			if bx_$bound_sep_stat = 1
			then i = 0;
			else i = 8;
			new_exp_word.expression = new_exp_word.expression + comp.creli + i;
		     end;
		end;				/* Otherwise link to static of another component;
					   	   relocation of expression already done by int_link_;
						   ext.segname = original segname, etc. */
		go to lookup_links;
	     end;
	end;

/* Lookup stringmap table for segname and entryname (avoid extra strings) */

	if ^segname_found
	then do;
	     call strm_hash_$lookup (substr (ext.segname, 1, ext.slng), strm_index);
	     if strm_index ^= 0
	     then do;				/* segname found in stringmap */
		new_type_pair.segname_relp = bin (strm.entry (strm_index).map, 18);
		segname_found = "1"b;
	     end;
	end;
	if ^entryname_found
	then do;
	     call strm_hash_$lookup (substr (ext.entryname, 1, ext.elng), strm_index);
	     if strm_index ^= 0
	     then do;				/* entryname found in stringmap */
		new_type_pair.offsetname_relp = bin (strm.entry (strm_index).map, 18);
		entryname_found = "1"b;
	     end;
	end;

lookup_links:
	do linkmapx = 1 to nlinks;			/* scan all newly generated links */
	     step = linkmap (linkmapx).linkaddr;	/* get rel pointer to link */
	     link_ptr = addrel (linkbase, step);	/* and ITS pointer to it */
	     if link_ptr -> object_link.modifier ^= new_link_modifier
	     then go to advance;
	     exp_ptr = addrel (defbase, link_ptr -> object_link.expression_relp);
	     if ^typepair_found
	     then do;
		new_exp_word.type_relp = exp_ptr -> exp_word.type_relp;
						/* fill in in case this type pair fits */
		type_ptr = linkmap (linkmapx).type_ptr;
	     end;
	     else go to use_typepair;

	     if segname_found & entryname_found
	     then do;				/* see if this type pair may be reused */
		if unspec (new_type_pair) ^= unspec (type_ptr -> type_pair)
		then go to advance;			/* type pairs do not match */
						/* but not comparing init info offsets here */
		if new_init_map_index = linkmap (linkmapx).init_map_index
		then go to use_typepair;		/* init info also matches */

/* now see if the init info can be made to match */

		if (new_type_pair.type ^= LINK_CREATE_IF_NOT_FOUND)
		     & ^((new_type_pair.type = LINK_SELF_OFFSETNAME) & (class = SECTION_SYSTEM))
		then go to advance;			/* diff trap-before-links or 1 trap and 1 not */

/* At this point we know we have a reference to a variable and we can't
   have 2 links to the same variable.  We must use the existing link and
   either choose one of the init infos or combine them. */

/* Assume that ALL such links have initialization info. */

/* We can't combine the links if one is for an area and the other is not */

		existing_init_type = init_map (linkmap (linkmapx).init_map_index).init_ptr -> link_init.type;
		if linkmap (linkmapx).incompatible_init_types
		then return;			/* don't print redundant messages */
		if ((new_init_type = INIT_DEFINE_AREA) & (existing_init_type ^= INIT_DEFINE_AREA))
		     | ((existing_init_type = INIT_DEFINE_AREA) & (new_init_type ^= INIT_DEFINE_AREA))
		then do;
		     call com_err_ (0, errname,
			"External variable ^[^a^a^;^2s^]^a has incompatible initialization types.",
			wsegname ^= "*system", wsegname, substr (wentryname, 1, 1), substr (wentryname, 2));
		     bx_$fatal_error = 1;
		     linkmap (linkmapx).incompatible_init_types = "1"b;
		     return;			/* we will bomb anyway */
		end;

/* now we find out how the two initializations compare */

		string (new) = "0"b;
		real_init_size = init_map (linkmap (linkmapx).init_map_index).total_init_size;
		if real_init_size = 0		/* no template */
		then real_init_size = init_map (linkmap (linkmapx).init_map_index).init_ptr -> link_init.n_words;
		init_size_compares (
		     sign (init_map (new_init_map_index).init_ptr -> link_init.n_words - real_init_size)) = "1"b;
						/* compare new and previous init sizes and set
						   appropriate flag via based array */
		if linkmap (linkmapx).has_init_template
		then init_before = "1"b;
		else init_before = "0"b;
		if ^new.equal
		then do;				/* print warning first time around */
		     if ^linkmap (linkmapx).diff_init_size
		     then do;
			if bx_$brief ^= 1
			then call ioa_ (
				"Warning: external variable ^[^a^a^;^2s^]^a has different sizes;^/^-the largest will be used.",
				wsegname ^= "*system", wsegname, substr (wentryname, 1, 1),
				substr (wentryname, 2));
			linkmap (linkmapx).diff_init_size = "1"b;
		     end;
		end;

/* cases 1, 2, 5, 6 just go to use_typepair */

		if new_has_init_template & init_before
		then if init_map (new_init_map_index).init_ptr
			^= init_map (linkmap (linkmapx).init_map_index).init_ptr
						/* make sure it's not the same template */
		     then do;			/* cases 3, 7, 11 */
			linkmap (linkmapx).print_msg = "1"b;
			if new.equal
			then if init_map (linkmap (linkmapx).init_map_index).total_init_size
				> init_map (linkmap (linkmapx).init_map_index).template_size
			     then call replace_init_info;
						/* if old was extended, new is probably better */
		     end;

		if (new_has_init_template & ((new.equal & ^init_before) | (new.larger & init_before)))
		     | (new.larger & ^init_before)	/* cases 4, 10, 11, 12 */
		then call replace_init_info;

		else if new.smaller & new_has_init_template & ^init_before
		then do;				/* case 8 */
						/* use new init template but extend it to length of old */
		     call extend_template ((new_init_map_index),
			init_map (linkmap (linkmapx).init_map_index).init_ptr -> link_init.n_words);
		     call replace_init_info;
		end;

		else if new.larger & ^new_has_init_template & init_before
		then do;				/* case 9 */
						/* use old template extended to new size */
		     call extend_template (linkmap (linkmapx).init_map_index,
			init_map (new_init_map_index).init_ptr -> link_init.n_words);
		     call change_init_map_index;
		end;

use_typepair:
		typepair_found = "1"b;
		if unspec (new_exp_word) = unspec (exp_ptr -> exp_word)
		then goto adjust_text;		/* expression words must also match for actual link to be used */
	     end;
advance:
	end;					/* end of loop for looking at linkmap */

generate_definition:				/* generate expression word and type pair, if necessary */
	def_growth = 1;				/* def section will grow by one expression word */
	xoffset = bx_$curdeflng;			/* offset of expression word */
	exp_ptr = addrel (defbase, xoffset);
	if ^typepair_found				/* we have to generate a type pair */
	then new_exp_word.type_relp = xoffset + 1;	/* thread to type pair to be created */
	exp_ptr -> exp_word = new_exp_word;		/* put expression word into definition section */

	if typepair_found
	then go to generate_link;

	type_ptr = addrel (exp_ptr, 1);		/* ptr to type pair to be generated */
	type_ptr -> type_pair = new_type_pair;		/* copy type pair into new definition section */
	def_growth = def_growth + 2;			/* remember def section grew by 2 words */
	if new_init_map_index > 0			/* references are made by type pairs */
	then init_map (new_init_map_index).reference_count = init_map (new_init_map_index).reference_count + 1;

	if ^segname_found
	then do;					/* we have to generate an ACC string for the segname */
	     call add_name (addr (ext.segname), ext.slng);
	     type_ptr -> type_pair.segname_relp = name_offset;
	end;

	if ^entryname_found
	then do;
	     if substr (ext.entryname, 1, 33) = ext.segname
	     then type_ptr -> type_pair.offsetname_relp = type_ptr -> type_pair.segname_relp;
	     else do;				/* must generate an ACC string for the entryname */
		call add_name (addr (ext.entryname), ext.elng);
		type_ptr -> type_pair.offsetname_relp = name_offset;
	     end;
	end;

/* now update official stringmap length */

	strm.nstr = map_lng;
	if strm.nstr > strm.max_size
	then do;
	     call com_err_ (0, errname, "Stringmap table overflow; please notify maintenance.");
	     strm.nstr = 0;
	     bx_$fatal_error = 1;
	end;

generate_link:					/* regenerate link itself */
	step = bx_$tlinklng;			/* location where new link will be generated */

	linkmapx, nlinks = nlinks + 1;		/* increment table size */
	if nlinks > linklimit
	then do;					/* table overflow */
	     call com_err_ (0, errname,
		"Linktable overflow while adding link to ^a^a^/^-for component ^a.^/^-You have room for only ^d links^/^-after your ^d words of internal static.^/^-Consider using separate static (pl1 or alm) or large arrays (fortran)^/^-to make more room for links.",
		wsegname, wentryname, ext.compent_ptr -> comp.filename, linklimit, bx_$tintlng);
	     signal fatal_binder_error;		/* stop now; don't prolong the agony */
	end;
	linkmap (nlinks).type_ptr = type_ptr;		/* remembering this will make patching easier */
	linkmap (nlinks).linkaddr = step;		/* remember where link is */
	linkmap (nlinks).init_source = comp.filename;	/* and origin of init structure */
	linkmap (nlinks).init_map_index = new_init_map_index;
	linkmap (nlinks).has_init_template = new_has_init_template;
	linkmap (nlinks).diff_init_size = "0"b;
	linkmap (nlinks).print_msg = "0"b;

	link_ptr = addrel (linkbase, step);		/* get pointer to new link */
	bx_$tlinklng = step + 2;			/* and adjust new length of linkage section */
	link_ptr -> object_link.header_relp = -step;	/* backpointer to head of linkage section */
	link_ptr -> object_link.tag = "46"b3;		/* add fault tag 2 code */
	link_ptr -> object_link.expression_relp = xoffset;/* ptr to expression word in def section */
	link_ptr -> object_link.modifier = new_link_modifier;
						/* restore modifiers of original link */

adjust_text:
	bx_$curdeflng = bx_$curdeflng + def_growth;	/* adjust def section length if necessary */
	if ^ext.dont_relocate
	then do;					/* sometimes we regenerate links that aren't referenced */
	     if trap_sw
	     then trap_offset = step;			/* return rel ptr to trap fault */
	     else if ext.relinfo = "lnk18   "
	     then do;
		if ext.side = "lhe"
		then ext.ref_ptr -> word.left_half = bit (bin (step, 18), 18);
		else ext.ref_ptr -> word.right_half = bit (bin (step, 18), 18);
	     end;
	     else substr (ext.ref_ptr -> word.left_half, 4, 15) = bit (bin (step, 15), 15);
						/* put in textsection rel ptr to linkage */
	end;

	lrt.regenerated (lrt_index) = bit (bin (step, 18), 18);

	return;

trap_error:
	ap -> copy_save = addr (scratch) -> copy_save;	/* restore original link information */
	call com_err_ (0, errname, "cannot process trap before link for ^a^a referenced by ^a|^o of ^a", wsegname,
	     wentryname, ext.section, ext.offset, comp.filename);
	bx_$fatal_error = 1;
	return;



gen_trap:
     entry (argument_pointer, trap_offset);

/**********************************************************************/
/*							*/
/*	Name:	ext_link_$gen_trap				*/
/*	Input:	argument_pointer				*/
/*	Function:	This entry point generates a link in essentially	*/
/*		the same manner as ext_link_ except that it	*/
/*		returns a relptr to the trap link relative to the	*/
/*		base of the linkage section.			*/
/*	Output:	trap_offset				*/
/*							*/
/**********************************************************************/

declare	trap_offset	fixed bin (18) unsigned aligned;

	trap_sw = "1"b;				/* indicate this is a trap before link */
	trap_offset = 0;				/* preset return argument */
	go to start;

init:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	ext_link_$init				*/
/*	Input:	none					*/
/*	Function:	allocates static tables for use by ext_link_ and	*/
/*		initializes various static lengths		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	linkbase = bx_$tlinkp;			/* beginning of linkage section */
	if mod (bx_$tlinklng, 2) = 1
	then bx_$tlinklng = bx_$tlinklng + 1;		/* make links start on even location */

	tblp = bx_$freep;				/* pointer to map of trap-pairs */
	linklimit = divide ((bx_$maxlinklng - bx_$tlinklng), 2, 17, 0);
						/* get max no of links */

	call temp_mgr_$reserve (addrel (tblp, linklimit));/* reserve map */
	n_tbls = 0;				/* indicate no trap-pairs yet */

	i = linklimit * 7;				/* get max size of init map */
	call temp_mgr_$allocate (i);			/* make sure that there is enough room */
	init_map_ptr = bx_$freep;			/* pointer to init info map */
	call temp_mgr_$reserve (addrel (init_map_ptr, i));/* reserve init info map */
	i = linklimit * 12;				/* get max size of link map */
	call temp_mgr_$allocate (i);			/* make sure that there is enough room */
	init_map_lng = 0;				/* reset length of init map */

	newlinkp = bx_$freep;			/* make new link table */
	call temp_mgr_$reserve (addrel (newlinkp, i));
	nlinks = 0;				/* preset table size */

	if bx_$debug = 1
	then errname = "ext_link_";
	else errname = bx_$caller;
	defbase = bx_$tdefp;			/* beginning of definition section */

	null_acc_offset = bx_$curdeflng - 1;		/* all zero word set in make_defs_$open_section */
						/* compute the size of the external reference structure 'ext'  */

	ap = addr (scratch);
	ext_lng = size (ext);
	return;

finish:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	ext_link_$finish				*/
/*	Input:	none					*/
/*	Function:	allocates the initialization structures in the	*/
/*		bound segment and patches the initialization	*/
/*		info relptrs back into the links.  If the init	*/
/*		info for a copy_info initialization has been	*/
/*		extended, and the extension is longer than an	*/
/*		arbitrary size (50 words), the copy_info is	*/
/*		converted to a list_template containing a single	*/
/*		copy of the existing info and a repeated zero	*/
/*		Messages are also printed for links which had	*/
/*		multiple initializations specified.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	n_bad_links	fixed bin;

/* print all multiple initialization messages */

	do i = 1 to nlinks;
	     if linkmap (i).print_msg
	     then do;
		type_ptr = linkmap (i).type_ptr;
		if type_ptr -> type_pair.type = LINK_SELF_OFFSETNAME
		then wsegname = "";			/* no segname; don't print *system */
		else wsegname = addrel (defbase, type_ptr -> type_pair.segname_relp) -> acc_string.string || "$";

		call com_err_ (0, errname,
		     "Multiple initializations specified for external variable ^a^a;^/^-the one in ^a will be used.",
		     wsegname, addrel (defbase, type_ptr -> type_pair.offsetname_relp) -> acc_string.string,
		     linkmap (i).init_source);
	     end;
	end;

/* Now allocate all init info structures that the links in the bound segment reference. */

	link_init_n_bits_in_datum = 0;
	do mapx = 1 to init_map_lng;
	     if init_map (mapx).reference_count > 0
	     then do;				/* copy into bound segment */
		init_map (mapx).new_init_ptr, cur_init_info_ptr = addrel (defbase, bx_$curdeflng);
		extension_size = init_map (mapx).total_init_size - init_map (mapx).template_size;

		if init_map (mapx).init_type = INIT_COPY_INFO
		then do;
		     if extension_size <= 50		/* arbitrary limit */
		     then do;
			cur_init_info_ptr -> link_init_copy_info = init_map (mapx).init_ptr -> link_init_copy_info;
			if extension_size > 0
			then cur_init_info_ptr -> link_init_copy_info.header.n_words =
				init_map (mapx).total_init_size;
			bx_$curdeflng = bx_$curdeflng + currentsize (cur_init_info_ptr -> link_init_copy_info);
		     end;				/* of no or small extension */
		     else do;			/* convert to list template */
			cur_init_info_ptr -> link_init_list_template.header.type = INIT_LIST_TEMPLATE;
			cur_init_info_ptr -> link_init_list_template.n_words_in_list =
			     init_map (mapx).init_ptr -> link_init_copy_info.header.n_words
			     + size (list_template_entry) + 1;
			init_entry_ptr = addr (cur_init_info_ptr -> link_init_list_template.template);
			init_entry_ptr -> list_template_entry.n_bits =
			     init_map (mapx).init_ptr -> link_init_copy_info.n_words * 36;
			init_entry_ptr -> list_template_entry.repeat = 1;
			init_entry_ptr -> list_template_entry.datum =
			     unspec (init_map (mapx).init_ptr -> link_init_copy_info.initial_data);


			init_entry_ptr =
			     addrel (init_entry_ptr, currentsize (init_entry_ptr -> list_template_entry));
			call add_extension;
			bx_$curdeflng = bx_$curdeflng + currentsize (cur_init_info_ptr -> link_init_list_template);
		     end;				/* of conversion to list */

		end;				/* of init_copy_info case */

		else if init_map (mapx).init_type = INIT_LIST_TEMPLATE
		then do;
		     cur_init_info_ptr -> link_init_list_template =
			init_map (mapx).init_ptr -> link_init_list_template;
		     if extension_size > 0
		     then do;			/* 0 repeat entry starts where last word now is */
			init_entry_ptr =
			     addrel (cur_init_info_ptr,
			     currentsize (cur_init_info_ptr -> link_init_list_template) - 1);
			call add_extension;
		     end;
		     bx_$curdeflng = bx_$curdeflng + currentsize (cur_init_info_ptr -> link_init_list_template);
		end;				/* of init_list template case */

		else do;				/* no template; just header */
		     cur_init_info_ptr -> link_init = init_map (mapx).init_ptr -> link_init;
		     if extension_size > 0
		     then cur_init_info_ptr -> link_init.n_words = init_map (mapx).total_init_size;
		     bx_$curdeflng = bx_$curdeflng + size (link_init);
		end;
	     end;
	end;					/* of copying init_info into bound segment */

/* Now update the links that have init info */

	n_bad_links = 0;
	xoffset = wordno (defbase);
	do mapx = 1 to nlinks;
	     if linkmap (mapx).init_map_index > 0
	     then do;				/* have init info to fill in */
		new_ptr = init_map (linkmap (mapx).init_map_index).new_init_ptr;
		if new_ptr ^= null
		then linkmap (mapx).type_ptr -> type_pair.trap_relp = wordno (new_ptr) - xoffset;
		else do;				/* indicates bug in this program */
		     n_bad_links = n_bad_links + 1;
		     call com_err_ (0, errname,
			"Link to external variable ^a has missing initialization information.^/^-Notify maintenance personnel.",
			addrel (defbase, linkmap (mapx).type_ptr -> type_pair.offsetname_relp) -> acc_string.string)
			;			/* segname is usually meaningless in this case */
		end;
	     end;
	end;

	if n_bad_links > 0
	then bx_$fatal_error = 1;

	return;

find_init_map_entry:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	find_init_map_entry				*/
/*	Input:	orig_init_info_ptr, new_type_pair, wsegname,	*/
/*		external_ref (pointed to by ap)		*/
/*	Function:	finds or creates an init_map entry for a given	*/
/*		link.  Certain type-6 (create-if-not-found) links	*/
/*		are first converted into *system links.  If an	*/
/*		init_map entry is found that matches, it's	*/
/*		reference count is incremented and it is used.	*/
/*		otherwise an new entry is created.		*/
/*	Output:	new_init_map_index				*/
/*							*/
/**********************************************************************/

	convert = "0"b;
	if new_type_pair.type = LINK_CREATE_IF_NOT_FOUND
	then do;					/* see if it needs to be converted */
	     extp = ap;				/* normal, non trap case */
	     if wsegname = "stat_"
	     then do;
		convert = "1"b;
		new_ename = addr (ext.entryname) -> acc_string.string;
	     end;
	     else if ext.elng = 1
	     then do;				/* null entryname */
		i = index (ext.segname, ".com");
		if (i > 0) & (i = (ext.slng - 3))
		then do;
		     new_ename = substr (ext.segname, 2, i - 2);
		     if new_ename = "b_"
		     then new_ename = "blnk*com";
		     convert = "1"b;
		end;
		else do;
		     new_type_pair.offsetname_relp = null_acc_offset;
						/* set to point to all zero word */
		     entryname_found = "1"b;
		end;
	     end;
	     else if wsegname = "cobol_fsb_"
	     then do;
		new_ename = "cobol_fsb_" || addr (ext.entryname) -> acc_string.string;
		convert = "1"b;
	     end;
	end;

	if convert
	then do;					/* diddle info to make it look like *system link */
	     extp -> ext.code15 = bit (bin (LINK_SELF_OFFSETNAME, 18), 18);
	     new_type_pair.type = LINK_SELF_OFFSETNAME;
	     class = SECTION_SYSTEM;
	     wsegname = "*system";
	     addr (extp -> ext.segname) -> acc_string.count = length ("*system");
	     addr (extp -> ext.segname) -> acc_string.string = "*system";
	     extp -> ext.slng = length ("*system") + 1;
	     wentryname = "|" || new_ename;
	     addr (extp -> ext.entryname) -> acc_string.count = length (new_ename);
	     addr (extp -> ext.entryname) -> acc_string.string = new_ename;
	     extp -> ext.elng = length (new_ename) + 1;
	end;

/* See if an identical init structure is already in our map */

	new_init_type = orig_init_info_ptr -> link_init.type;

	do new_init_map_index = 1 to init_map_lng;
	     cur_init_info_ptr = init_map (new_init_map_index).init_ptr;
						/* get ptr to current entry's init info */
	     if unspec (orig_init_info_ptr -> link_init) = unspec (cur_init_info_ptr -> link_init)
	     then do;				/* so far, init headers match */
		if new_init_type = INIT_COPY_INFO
		then if unspec (orig_init_info_ptr -> link_init_copy_info.initial_data)
			= unspec (cur_init_info_ptr -> link_init_copy_info.initial_data)
		     then return;
		     else ;			/* templates don't match; continue */
		else if new_init_type = INIT_LIST_TEMPLATE
		then if unspec (orig_init_info_ptr -> link_init_list_template.template)
			= unspec (cur_init_info_ptr -> link_init_list_template.template)
		     then return;
		     else ;			/* templates don't match; continue */
		else return;			/* no templates to match in these cases */
	     end;					/* of = headers part */
	end;					/* of comparison loop */

/* if we get here a match was not found, so we have to add an init_map entry */

	init_map_lng = init_map_lng + 1;		/* new_init_map_index should already be = to this */
	init_map (init_map_lng).init_ptr = orig_init_info_ptr;
	init_map (init_map_lng).reference_count = 0;
	init_map (init_map_lng).init_type = new_init_type;
	init_map (init_map_lng).new_init_ptr = null;

/* now set template size */

	if (new_init_type = INIT_COPY_INFO) | (new_init_type = INIT_LIST_TEMPLATE)
	then init_map (init_map_lng).template_size = orig_init_info_ptr -> link_init_copy_info.header.n_words;

	else init_map (init_map_lng).template_size = 0;

	init_map (init_map_lng).total_init_size = init_map (init_map_lng).template_size;
						/* equality indicates not extended */

	return;
     end;

replace_init_info:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	replace_init_info				*/
/*	Input:	new_has_init_info, linkmapx, new_init_map_index	*/
/*	Function:	Changes the init_map index in the link specified	*/
/*		by linkmapx to use the initialization info	*/
/*		referred to by new_init_map_index.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	linkmap (linkmapx).init_source = comp.filename;
	linkmap (linkmapx).has_init_template = new_has_init_template;
	call change_init_map_index;

	return;

     end;





change_init_map_index:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	change_init_map_index			*/
/*	Input:	linkmapx, new_init_map_index			*/
/*	Function:	replaces the init_map entry for the specified	*/
/*		link and adjusts the reference counts in the	*/
/*		init_map entries				*/
/*	Output:	none					*/
/*							*/
/*	Notes:	this procedure is logically a part of		*/
/*		replace_init_info but must sometimes be called	*/
/*		separately				*/
/*							*/
/**********************************************************************/

	init_map (linkmap (linkmapx).init_map_index).reference_count =
	     init_map (linkmap (linkmapx).init_map_index).reference_count - 1;

	init_map (new_init_map_index).reference_count = init_map (new_init_map_index).reference_count + 1;

	linkmap (linkmapx).init_map_index = new_init_map_index;

	return;

     end;

extend_template:
     proc (cur_init_map_index, target_size);

/**********************************************************************/
/*							*/
/*	Name:	extend_template				*/
/*	Input:	cur_init_map_index, target_size		*/
/*	Function:	extends the specified init_map entry to the size	*/
/*		indicated by target size.  This is done by first	*/
/*		attempting to find an existing init_map entry	*/
/*		that matches the requirements, or by creating one	*/
/*		if no matching init_info already exists.	*/
/*	Output:	new_init_map_index				*/
/*							*/
/**********************************************************************/

declare	cur_init_map_index	fixed bin unal;
declare	target_size	fixed bin (35);

/* first try to match an existing template  */

	do mapx = 1 to init_map_lng;
	     if init_map (mapx).total_init_size = target_size
	     then if init_map (mapx).init_ptr = init_map (cur_init_map_index).init_ptr
						/* the unextended templates must match;
						   the init_map has no duplicates;
						   so if they match, they are the same */
		then do;
		     new_init_map_index = mapx;
		     return;
		end;
	end;					/* of mapx loop */

/* Did not find match.  Must create a new init_map entry for the extension. */

	init_map_lng = init_map_lng + 1;

/* copy whole entry, then update */

	init_map (init_map_lng) = init_map (cur_init_map_index);
	init_map (init_map_lng).total_init_size = target_size;
	init_map (init_map_lng).reference_count = 0;	/* this will be updated later */

	new_init_map_index = init_map_lng;

	return;

     end;

add_name:
     proc (new_name_ptr, name_length);

/**********************************************************************/
/*							*/
/*	Name:	add_name					*/
/*	Input:	new_name_ptr, name_length			*/
/*	Function:	adds a new name to the definition section and to	*/
/*		the string map.				*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	new_name_ptr	ptr;			/* to an ACC string */
declare	name_length	fixed bin;
declare	new_name		char (name_length) aligned based;

	name_offset = xoffset + def_growth;
	addrel (defbase, name_offset) -> new_name = new_name_ptr -> new_name;
	def_growth = def_growth + divide (name_length + 3, 4, 17, 0);

	map_lng = map_lng + 1;
	strm.entry (map_lng).map = bit (name_offset, 18);
	call strm_hash_$make_entry (new_name_ptr -> new_name, map_lng);

	return;

     end;


add_extension:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	add_extension				*/
/*	Input:	init_entry_ptr, extension_size		*/
/*	Function:	adds a list_template entry to the list template	*/
/*		initialization to add <extension_size> zero words	*/
/*		to the end of the initialization		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* add the extension to skip the required number of bits	*/

	init_entry_ptr -> list_template_entry.n_bits = extension_size * 36;
	init_entry_ptr -> list_template_entry.repeat = 0;

/* append the end-of-list-template marker (n_bits = 0)	*/

	addrel (init_entry_ptr, size (list_template_entry)) -> list_template_entry.n_bits = 0;

/* adjust the length of the template	*/

	cur_init_info_ptr -> link_init_list_template.n_words_in_list =
	     cur_init_info_ptr -> link_init_list_template.n_words_in_list + size (list_template_entry);
	cur_init_info_ptr -> link_init_list_template.header.n_words = init_map (mapx).total_init_size;


	return;

     end;

%include extref;

%include bindext;

%include comptbl;

%include bndtbl;

%include definition_dcls;

%include object_link_dcls;



     end;						/* of ext_link_ */




		    generate_def_.pl1               11/20/86  1403.9r w 11/20/86  1145.0      108036



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


/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation, changed errname to use the caller-supplied name
     instead of  "binder_", deleted support for obsolete non-standard objects.
                                                   END HISTORY COMMENTS */

/* format: style3,^indnoniterdo */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

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

/**********************************************************************/
/*							*/
/*	Name:	generate_def_				*/
/*	Input:	compent_ptr, definition_ptr			*/
/*	Function:	given a pointer to the current component_table	*/
/*		entry (compent_ptr) and a pointer to an insym	*/
/*		entry (definition_ptr), regenerates the specfied	*/
/*		definition in the definition section of the new	*/
/*		bound object_segment and threads it in place. The	*/
/*		references are relocated and any links referenced	*/
/*		by the definitions (as in pascal exported vars)	*/
/*		are generated.				*/
/*	Ouptut:	none					*/
/*							*/
/**********************************************************************/


/* Designed and initially coded by Michael J. Spier, October 6, 1970	*/
/* modified  June, july 1975 by M. Weaver for separate static */
/* modified Sept 1978 by David Spector for hash-coding strm */
/* modified Sept 82 by JMAthane for PASCAL exportable variables definitions */

generate_def_:
     procedure (compent_ptr, definition_ptr);

declare	(compent_ptr, definition_ptr)
			pointer;

/* DECLARATION OF CONSTANTS */

declare	lda_pr0_instr	bit (18) static options (constant) init ("010011101001010000"b);

/* DECLARATION OF EXTERNAL SYMBOLS */

declare	com_err_		external entry options (variable);
declare	strm_hash_$lookup	external entry (char (*), fixed bin (17));
declare	strm_hash_$make_entry
			external entry (char (*), fixed bin (17));
declare	int_link_		entry (ptr) returns (bit (1));
declare	decode_link_	entry (ptr) returns (bit (1));
declare	ext_link_		entry (ptr);

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	(defbase, linkbase) pointer internal static;
declare	inlink		fixed bin internal static;
declare	errname		char (16) aligned internal static;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, linkoffset)	fixed bin;
declare	defoffset		fixed bin (18);
declare	(p, ip, dp, sp, lp, dsp)
			pointer;
dcl	1 my_ext		aligned like external_ref;

dcl	generate_ext_link	bit (1) init ("0"b);

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, divide, fixed, substr)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 new_def		aligned based (dp),
	  2 forward_relp	unal fixed bin (18) unsigned,
	  2 backward_relp	unal fixed bin (18) unsigned,
	  2 thing_relp	unal fixed bin (18) unsigned,
	  2 flags		unal like definition_flags,
	  2 class		unal fixed bin (3) unsigned,
	  2 name_relp	unal fixed bin (18) unsigned,
	  2 segname_relp	unal fixed bin (18) unsigned,
	  2 n_args	unal fixed bin (18) unsigned,
	  2 descriptor_relp (0 refer (new_def.n_args)) unal fixed bin (18) unsigned;
declare	1 last_def	aligned like new_def based (lp);
declare	1 insyme		aligned like is based (sp);

declare	descr_list	(1000) unal fixed bin (18) unsigned based (dsp);
						/* based on descriptor ptrs in def */

declare	1 dum_instr	aligned,
	  2 register	bit (3) unaligned,
	  2 rel_address	bit (15) unaligned,
	  2 op_code	bit (18) unaligned;
declare	acc_string_overlay	char (257) aligned based;

%page;
	ctp = bx_$ctp;
	strmp = bx_$strmp;
	ctep = compent_ptr;				/* copy pointer to current component table entry */
	sp = definition_ptr;			/* copy pointer to definition entry */
	if insyme.regenerated = "1"b
	then return;

	ip = comp.insymentp;			/* pointer to component's definitions */

	defoffset = bx_$curdeflng;			/* get current size of definition section */
	linkoffset = bx_$tlinklng;			/* get current length of new linkage section */

	dp = addrel (defbase, defoffset);		/* pointer to location where new def will be generated */
	if comp.defblockp = "0"b
	then do;
	     comp.defblockp, comp.current_def = bit (bin (defoffset, 18), 18);
						/* remember current definition */
	end;
	else do;
	     lp = addrel (defbase, comp.current_def);	/* pointer to last def  */
	     new_def.backward_relp = fixed (comp.current_def, 18);
						/* backwards pointer */
	     last_def.forward_relp = defoffset;		/* thread defs together */
	     comp.current_def = bit (bin (defoffset, 18), 18);
						/* remember last def */
	end;
	insyme.defrel = comp.current_def;
	new_def.thing_relp = fixed (insyme.value, 18);	/* copy value of definition */
	new_def.class = fixed (insyme.class, 18);	/* class of definition */
	new_def.flags.new = "1"b;			/* and set new format flag */
	defoffset = defoffset + 3;			/* grow def section by 3 words */

/* now copy descriptor ptrs, if they exist for this entry */
/* if ^insyme.has_descr then descriptors may be invalid, but copy them anyway */

	if insyme.nargs > 0
	then do;					/* entry has descriptors */
	     new_def.flags.argcount = "1"b;		/* indicate we have arg count */
	     if insyme.has_descr
	     then new_def.flags.descriptors = "1"b;	/* have valid descriptors */
	     new_def.n_args = insyme.nargs;
	     dsp = insyme.descr_ptr;			/* initialize for better referencing */
	     do i = 1 to insyme.nargs;		/* copy and relocate ptrs */
		new_def.descriptor_relp (i) = descr_list (i) + comp.crelt;
	     end;
	     defoffset = defoffset + divide (insyme.nargs + 2, 2, 17, 0);
						/* grow def section by length of array */
	end;

	if bx_$standard = 1
	then if insyme.retain_flag
	     then new_def.flags.retain = "1"b;		/* turn on only if on before */

/* now lookup generated strings to see if one can be reused */

	call strm_hash_$lookup (substr (insyme.symbol, 1, insyme.lng), i);
	if i ^= 0
	then do;					/* string is already in strm */
	     new_def.name_relp = fixed (strm.entry (i).map, 18);
	     goto adjust_value;
	end;

/* string not found, generate string and put into map */

	i, strm.nstr = strm.nstr + 1;
	if strm.nstr > strm.max_size
	then do;
	     call com_err_ (0, errname, "stringmap table overflow; please contact maintenance");
	     strm.nstr = 1;
	     bx_$fatal_error = 1;
	end;
	new_def.name_relp = defoffset;		/* pointer to newly generated symbol string */
	strm.entry (i).map = bit (bin (defoffset, 18), 18);
	p = addrel (defbase, defoffset);		/* pointer to new string */
	substr (p -> acc_string_overlay, 1, insyme.lng) = substr (insyme.symbol, 1, insyme.lng);
	defoffset = defoffset + divide (insyme.lng + 3, 4, 17, 0);
						/* grow definition section */

	call strm_hash_$make_entry (substr (insyme.symbol, 1, insyme.lng), i);

/* now compute the value of the new definition */

adjust_value:
	bx_$nsymdefs = bx_$nsymdefs + 1;

	if new_def.class = 0
	then /* simple text reference */
	     do;
	     new_def.thing_relp = new_def.thing_relp + comp.crelt;

	     if comp.standard_object = 1
	     then /* have to do some extra fiddling here */
		do;
		if insyme.entrypoint
		then new_def.flags.entry = "1"b;	/* standard entries are only text */
		if (insyme.ignore) | (insyme.delete)
		then do;
		     new_def.flags.ignore = "1"b;	/* need this for name but don't want linker to find it */
		     bx_$nsymdefs = bx_$nsymdefs - 1;
		end;
	     end;
	     goto return;
	end;
	else if new_def.class = 2
	then /* reference relative to symbol section */
	     do;
	     new_def.thing_relp = new_def.thing_relp + comp.crels;
						/* get value of symbol */
	     goto return;
	end;
	else if new_def.class = 1
	then do;
	     if new_def.thing_relp < comp.clngi + 8
	     then do;				/* this is an ALM segdef located in the linkage section */
		new_def.thing_relp = new_def.thing_relp + comp.creli;
		goto return;
	     end;
	     else do;
		if comp.compiler = "PASCAL  "
		then do;

/* We have a definition for a link, i.e. for a Pascal exportable variable which
   is represented by a link.  We must regenerate the link.  To do this,
   we fabricate an "instruction" that references the link along with the other
   link info.  The link may indirect through another link that may be in
   another component.  To handle this case, we must first call int_link_ to 
   regenerate the correct target for this definition's link. */

		     dum_instr.rel_address = bit (bin (new_def.thing_relp, 15), 15);
		     dum_instr.register = "000"b;
		     dum_instr.op_code = lda_pr0_instr; /* make instruction = lda 0|nn,* */
		     my_ext.ref_ptr = addr (dum_instr);
		     my_ext.dont_prelink = "0"b;
		     my_ext.compent_ptr = ctep;
		     my_ext.loffset = new_def.thing_relp;
		     my_ext.side = "lhe";
		     my_ext.relinfo = "link15";
		     my_ext.dont_relocate = "0"b;
		     if decode_link_ (addr (my_ext)) = "1"b
		     then go to error_skip;
		     generate_ext_link = "1"b;
		     go to return;
		end;
	     end;
	end;
	else if new_def.class = 4
	then do;					/* segdef in separate static  */
	     if bx_$bound_sep_stat = 1
	     then i = 0;				/*  will still have separate static */
	     else do;				/* static will be in linkage section */
		new_def.class = 1;			/* change to  linkage */
		i = 8;				/* now static  will be further offset by linkage header */
	     end;
	     new_def.thing_relp = new_def.thing_relp + comp.creli + i;
	     goto return;
	end;
	call com_err_ (0, errname, "definition ^a in file ^a has illegal class ^o",
	     substr (insyme.symbol, 2, insyme.lng - 1), comp.filename, new_def.class);

error_skip:
	bx_$fatal_error = 1;

return:
	insyme.regenerated = "1"b;			/* indicate that this def has been regenerated */
	if ^new_def.flags.ignore
	then ip -> insym.retained = "1"b;		/* indicate that a def was retained for this component */
	bx_$curdeflng = defoffset;			/* update length of new definition section */
	bx_$tlinklng = linkoffset;			/* update length of new linkage section */

	if generate_ext_link
	then do;
	     if int_link_ (addr (my_ext)) = "1"b
	     then do;
		my_ext.segname = "*link";
		my_ext.slng = 6;
		my_ext.elng = 0;
		my_ext.code15, my_ext.type = "000000000000000001"b;
		my_ext.expr = "000"b || dum_instr.rel_address;
	     end;
	     call ext_link_ (addr (my_ext));
	     new_def.thing_relp = fixed (dum_instr.rel_address, 15);
	end;

	return;


%page;


init:
     entry;

	defbase = bx_$tdefp;			/* pointer to base of new definition section */
	linkbase = bx_$tlinkp;			/* pointer to base of new linkage section */
	inlink = 0;				/* reset pointer to inbound link */
	if bx_$debug = 1
	then errname = "generate_def_";
	else errname = bx_$caller;

	return;

%page;
%include extref;
%page;
%include bindext;
%page;
%include comptbl;
%page;
%include bndtbl;
%page;
%include insym;
%page;
%include definition_dcls;

     end generate_def_;




		    generate_first_ref_traps_.pl1   08/06/86  1449.9rew 08/06/86  1419.6       47970



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved readability and documentation.
  2) change(86-07-02,Elhard), approve(86-07-02,MCR7285),
     audit(86-07-23,JRGray), install(86-08-06,MR12.0-1119):
     Modified to zero the info_relp value for the correct trap when no info
     link is present instead of zeroing the info_relp for the first trap.
                                                   END HISTORY COMMENTS */

/* format: style3,^indnoniterdo */
generate_first_ref_traps_:
     procedure;

/**********************************************************************/
/*							*/
/*	Name:	generate_firstref_traps_			*/
/*	Input:	none					*/
/*	Function:	scans the component table and copies the firstref	*/
/*		traps from each component into the new firstref	*/
/*		trap block, relocating each of the references and	*/
/*		regenerating the links.			*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* DECLARATION OF EXTERNAL ENTRIES */

declare	ext_link_		entry (pointer);

declare	decode_link_	entry (pointer) returns (bit (1) aligned);

/* DECLARATION OF AUTOMATIC VARIABLES */

declare	(component_firstref_blockp, linkp, extp, firstref_blockp)
			pointer;

declare	(compno, j, k)	fixed bin;

declare	eside		(2) char (3) aligned init ("lhe", "rhe");

declare	1 firstref_block	aligned automatic,		/* dcl of first reference trap structure */
	  2 version	fixed bin,
	  2 n_traps	fixed bin,		/* number of traps in array */
	  2 trap		(bx_$n_firstrefs, 2) bit (18) unaligned;
						/* automatic adjustable storage */
						/* array for easier referencing */
declare	1 ext		aligned like external_ref;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, null, rel, size, unspec)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 based_firstref_block
			aligned based (firstref_blockp) like firstref_block;
declare	1 component_firstref_block
			aligned based (component_firstref_blockp) like firstref_block;
declare	1 lh		aligned based,		/* linkage header */
	  2 defseg	fixed bin,		/* 0->defs in text, 16->defs in link */
	  2 defptr	bit (18) unaligned,		/* offset of definition section */
	  2 first_reference bit (18) unaligned,		/* offset of first ref trap array */
	  2 fthread	pointer,			/* unused */
	  2 bthread	pointer,			/* unused */
	  2 link_begin	bit (18) unaligned,		/* offset in linkage section of linkage info */
	  2 block_lng	bit (18) unaligned,
	  2 dum2		bit (18) unaligned,
	  2 linkage_lng	bit (18) unaligned;


/*  */

%include extref;

/*  */

%include bindext;

/*  */

%include comptbl;

/*  */


/* assume that all regular links have already been generated */
	firstref_block.version = 1;
	firstref_block.n_traps = 0;			/* for now */

	extp = addr (ext);				/* to use when decoding and generating  links */
	ext.relinfo = "lnk18";			/* fudge relocation info; can't be anything else */
	ext.section = "link";			/* offsets are wrt linkage section */

/* look at each object for traps */

	ctp = bx_$ctp;

	do compno = 1 to bx_$ncomp;

	     ctep = comp_tbl (compno);
	     if comp.cfrtp ^= null
	     then do;				/* this component has a firstref trap */

		linkp = comp.clnkp;			/* get ptr to component's linkage section */
		component_firstref_blockp = comp.cfrtp; /* get ptr to component's trap array */
		ext.compent_ptr = ctep;

/* get offset of trap array relative to component's linkage section */

		ext.offset = bin (rel (comp.cfrtp), 18) - bin (rel (comp.clnkp), 18) + 2;

		do j = 1 to component_firstref_block.n_traps;
						/* do for each trap in component */

		     firstref_block.n_traps = firstref_block.n_traps + 1;
		     ext.ref_ptr = addr (firstref_block.trap (firstref_block.n_traps, 1));
						/* get ptr to new trap pair (incl header) */

		     do k = 1 to 2;			/* call and arg ptrs are processed the same */
			ext.side = eside (k);
			ext.loffset = bin (component_firstref_block.trap (j, k), 18);
						/* get offset of original link */
			if ext.loffset = 0
			then firstref_block.trap (firstref_block.n_traps, k) = ""b;
			else if decode_link_ (extp)
			then bx_$fatal_error = 1;	/* presumably a message will have been printed */
			else call ext_link_ (extp);	/* regenerate link; must be external */
		     end;
		end;
	     end;
	end;

/* allocate the firstref block in the linkage section */

	firstref_blockp = addrel (bx_$tlinkp, bx_$tlinklng);
	bx_$tlinkp -> lh.first_reference = bit (bin (bx_$tlinklng, 18), 18);
	bx_$tlinklng = bx_$tlinklng + size (firstref_block);
						/* adjust the linkage length */
	unspec (based_firstref_block) = unspec (firstref_block);

	return;
     end generate_first_ref_traps_;




		    get_relinfo_.pl1                07/16/86  1217.0rew 07/16/86  0848.0       45414



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and remove nonstandard object segment support.
                                                   END HISTORY COMMENTS */

/* format: style3,^indnoniterdo */
get_relinfo_:
     procedure (argp);

/**********************************************************************/
/*							*/
/*	Name:	get_relinfo_				*/
/*	Input:	none					*/
/*	Function:	returns the word_offset, halfword identifier,	*/
/*		and relocation type of the next non-absolute	*/
/*		halfword in the current blcok of relocation	*/
/*		info.  The current relocation block and the last	*/
/*		halfword returned are maintained in static	*/
/*		storage.  Expanded_absolute relocation bits are	*/
/*		also skipped over.  get_relinfo_$init must be	*/
/*		called prior to calling get_relinfo_ to initiate	*/
/*		the sequential search through the specified block	*/
/*		of relocation information.			*/
/*	Output:	word_offset, halfword_selector, relocation_code	*/
/*							*/
/**********************************************************************/

/* Initially coded by M. J. Spier on 24 August 1970
Completely re-written for efficiency by M. B. Weaver on 21 November 1972   */
/* modified Sept 1978 by David Spector to correct precision declarations */

declare	type		fixed bin;
declare	j		fixed bin (19);

declare	i		fixed bin (19) int static;
declare	nhwords		fixed bin (19) aligned int static;
declare	bitcount		fixed bin (24) int static;
declare	baseptr		pointer int static;
declare	symb		(0:15) char (8) aligned int static
			initial ("text    ", "negtext ", "lnk18   ", "neglnk18", "lnk15   ", "def     ", "symb    ",
			"negsymb ", "int18   ", "int15   ", "selfrel ", "unused  ", "unused  ", "unused  ",
			"exp_abs ", "escape  ");

declare	(ap, argp)	pointer;

declare	(addr, bin, divide, index, substr)
			builtin;

declare	relsection	bit (bitcount) based (baseptr);

declare	1 arg		aligned based (ap),
	  2 offset	fixed bin,
	  2 side		char (3) aligned,
	  2 relinfo	char (8) aligned;

declare	1 word		aligned based,
	  2 pad		bit (35) unaligned,
	  2 odd		bit (1) unaligned;

/**/

	ap = argp;				/* copy argument */
loop:
	j = index (substr (relsection, i), "1"b);	/* find next non-abs rel bit */
	if j = 0
	then do;					/* no more rel bits for this section */
	     arg.relinfo = "overflow";
	     go to fill_loc;			/* return location info of last call */
	end;

	i = i + j + 4;				/* set bit counter after current half word info */
						/* find type of relocation */
	type = bin (substr (relsection, i - 4, 4), 4);

	if type = 14
	then do;					/* have expanded absolute */
	     nhwords = nhwords + j + bin (substr (relsection, i, 10), 10) - 1;
						/* just skipping over */
						/* determine number of half words to skip */
	     i = i + 10;				/* skip bit counter 10 more in this case */
	     go to loop;				/* don't have real relocation info yet */
	end;
	else nhwords = nhwords + j;			/* update half word count */

/* fill in return info */

	arg.relinfo = symb (type);			/* fill in type indicator */
fill_loc:
	if addr (nhwords) -> word.odd
	then arg.side = "lhe";
	else arg.side = "rhe";			/* get word offset */
	arg.offset = divide (nhwords - 1, 2, 17, 0);

	return;

/**/

init:
     entry (rel_base);

/**********************************************************************/
/*							*/
/*	Name:	get_relinfo_$init				*/
/*	Input:	rel_base					*/
/*	Function:	initializes a static pointer to the beginning of	*/
/*		the string of relocation bits, saves the bitcount	*/
/*		in static storage and sets the word position	*/
/*		counter (nhwords) to zero and sets the bit string	*/
/*		index (i) to the start of the bit string.  	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	rel_base		pointer;

declare	1 relinfo		aligned based (rel_base),
	  2 decl_vers	fixed bin,
	  2 n_bits	fixed bin,
	  2 bits		bit (0 refer (relinfo.n_bits));

/* initialize counters */
	i = 1;					/* current index into rel bit string */
	nhwords = 0;				/* # of half words covered so far */

	bitcount = relinfo.n_bits;
	baseptr = addr (relinfo.bits);

	return;



     end get_relinfo_;




		    hash_defs_.pl1                  11/20/86  1403.9r w 11/20/86  1145.0      136566



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

/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation.
                                                   END HISTORY COMMENTS */

/* HASH_DEFS - Program to Convert Object Segments for Definition Hashing.
	12/2/76 by Noel I. Morris	*/

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

/**********************************************************************/
/*							*/
/*	Name:	hash_defs_				*/
/*	Input:	component_table				*/
/*	Function:	given the component_table and associated insym	*/
/*		tables, builds a definition_hash_table for the	*/
/*		new bound object segment.  Creation of the hash	*/
/*		table occcurs in three stages:		*/
/*		  -- scanning of the definitions for duplicate	*/
/*		     definition names to create the duplicate	*/
/*		     tables, mark the duplicate definitions as	*/
/*		     duplicates, and to redefine the location of	*/
/*		     the definition to point to the duplicate	*/
/*		     table.				*/
/*		  -- hashing the non-duplicate symbols into the	*/
/*		     definition hash table.			*/
/*		  -- if there were duplicates in the definition	*/
/*		     hash table, hashing the segname definitions	*/
/*		     into the component hash table.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* format: style3,^indnoniterdo */
hash_defs_:
     proc;

dcl	(sp, sp1)		ptr,			/* pointers to insym entries */
	ctep1		ptr,			/* pointer to component table entry */
	(ip, ip1)		ptr,			/* pointers to insym table entries */
	(sytp, sgtp)	ptr,			/* pointers to seg/sym hash tables */
	(symx, segx, cx, cx1, sx, sx1)
			fixed bin,		/* table indices */
	defrel		bit (18) aligned,		/* rel ptr to definition */
	defp		ptr,			/* ITS pointer to definition */
	namep		ptr,			/* pointer to symbol */
	axtp		ptr,			/* pointer to auxiliary table */
	axx		fixed bin,		/* aux table index */
	dupn		fixed bin,		/* duplicate symbol counter */
	htsize		fixed bin (17);		/* size of hash table */


dcl	(addr, addrel, bin, bit, hbound, mod, substr, unspec)
			builtin;

dcl	1 symht		based aligned,		/* def symbol hash table */
	  2 size		fixed bin,
	  2 table		(0 refer (symht.size)),
	  ( 3 defp	bit (18),
	    3 pad		bit (18)
	    )		unal;

dcl	1 seght		based aligned,		/* segment name def hash table */
	  2 size		fixed bin,
	  2 table		(0 refer (seght.size)),
	  ( 3 defp	bit (18),
	    3 headp	bit (18)
	    )		unal;

dcl	1 auxt		based aligned,		/* auxiliary symbol table */
	  2 size		fixed bin,
	  2 table		(0 refer (auxt.size)),
	  ( 3 defp	bit (18),
	    3 headp	bit (18)
	    )		unal;

dcl	1 accname		based aligned,
	( 2 lth		fixed bin (8),
	  2 chr		char (0 refer (accname.lth))
	  )		unal;

dcl	1 bound_seg_comp	aligned like comp auto;	/* dummy comp table entry for bound segment */

dcl	1 bound_seg_seg	aligned like seg auto;	/* dummy seg table entry for bound segment */

dcl	1 symbol_table_is	aligned like is auto;	/* dummy is entry for symbol_table */

dcl	1 bind_map_is	aligned like is auto;	/* dummy insym entry for bind_map */


%include bindext;


%include comptbl;


%include bndtbl;


%include insym;


%include definition;


/* first we generate a dummy component entry for the bound segment	*/
/* table as well as dummy insym entries for the bind map and symbol	*/
/* table.						*/


	ctp = bx_$ctp;				/* Get pointer to component table. */

	unspec (bound_seg_comp) = "0"b;		/* Prepare to make dummy comp table entry. */
	defrel = bx_$tdefp -> definition.forward;	/* Get rel ptr to seg def for bound segment. */
	bound_seg_comp.defthread = bin (defrel, 18);	/* Place in dummy comp table entry. */

	unspec (bound_seg_seg) = "0"b;		/* Prepare to make dummy segname table entry. */
	bound_seg_seg.comp = addr (bound_seg_comp);
	defp = addrel (bx_$tdefp, defrel);		/* Get pointer to definition. */
	bound_seg_seg.defrel = defrel;
	namep = addrel (bx_$tdefp, defp -> definition.symbol);
						/* Get pointer to name. */
	unspec (substr (bound_seg_seg.name, 1, namep -> accname.lth + 1)) = unspec (namep -> accname);
	bound_seg_seg.lng = namep -> accname.lth + 1;	/* Copy the segment name. */

	unspec (symbol_table_is) = "0"b;		/* Prepare dummy insym entry for symbol_table. */
	defrel = defp -> definition.forward;		/* Get rel ptr to def for symbol_table. */
	symbol_table_is.defrel = defrel;
	defp = addrel (bx_$tdefp, defrel);
	namep = addrel (bx_$tdefp, defp -> definition.symbol);
	unspec (substr (symbol_table_is.symbol, 1, namep -> accname.lth + 1)) = unspec (namep -> accname);
	symbol_table_is.lng = namep -> accname.lth + 1;	/* Copy the symbol name. */

	unspec (bind_map_is) = "0"b;			/* Prepare dummy insym entry for bind_map. */
	defrel = defp -> definition.forward;		/* Get rel ptr to def for bind_map. */
	bind_map_is.defrel = defrel;
	defp = addrel (bx_$tdefp, defrel);
	namep = addrel (bx_$tdefp, defp -> definition.symbol);
	unspec (substr (bind_map_is.symbol, 1, namep -> accname.lth + 1)) = unspec (namep -> accname);
	bind_map_is.lng = namep -> accname.lth + 1;	/* Copy the symbol name. */


/* now we scan through the component table and check each insym	*/
/* to see if it is a duplicate.  If it is a duplicate, then create	*/
/* a duplicate table for the symbol if necessary and then add the	*/
/* duplicate to the table.					*/

	axtp = addrel (bx_$tdefp, bx_$curdeflng);	/* Get pointer to end of defs. */
	dupn = 0;					/* Initialize duplicate counters. */

	cx = 0;					/* Start with zeroth component. */
	ctep = addr (bound_seg_comp);			/* Point to fake comp for bound segment. */
	sp = addr (bind_map_is);			/* Point to fake insym entry for bind_map. */
	call dup_search;				/* Search for duplicate name. */
	sp = addr (symbol_table_is);			/* Point to fake insym entry for symbol_table. */
	call dup_search;				/* Search for duplicate name. */

	do cx = 1 to bx_$ncomp;			/* Iterate through components. */
	     ctep = comp_tbl (cx);			/* Get pointer to component table entry. */
	     ip = comp.insymentp;			/* Get pointer to syms for this component. */

	     do sx = 1 to ip -> insym.n_insyms - 1;	/* Look through the symbols. */
		sp = addr (ip -> insym.entry (sx));	/* Get pointer to symbol table entry. */

		if ^(sp -> is.ignore | sp -> is.delete | sp -> is.duplicate)
		then call dup_search;		/* Search for duplicate name. */
	     end;
	end;


/* now we take all of the definitions that are not duplicates and	*/
/* hash them into the definition has table.			*/

	sytp = axtp;				/* Get pointer for sym hash table. */

	bx_$tdefp -> definition.value = bit (bx_$curdeflng);
						/* Set pointer to hash table. */

	htsize = hlen (bx_$nsymdefs + 2);		/* Compute size of hash table. */
	sytp -> symht.size = htsize;			/* Set size of hash table. */

	sp = addr (bind_map_is);			/* Point to fake insym entry for bind_map. */
	call hash_sym;				/* Make hash table entry for it. */

	sp = addr (symbol_table_is);			/* Point to fake insym entry for symbol_table. */
	call hash_sym;				/* Make hash table entry for it. */

	do cx = 1 to bx_$ncomp;			/* Through the components again. */
	     ctep = comp_tbl (cx);
	     ip = comp.insymentp;

	     do sx = 1 to ip -> insym.n_insyms - 1;	/* Through the symbols again. */
		sp = addr (ip -> insym.entry (sx));

		if ^(sp -> is.ignore | sp -> is.delete | sp -> is.duplicate)
		then call hash_sym;			/* Enter symbol in hash table, if desired. */
	     end;
	end;

	bx_$curdeflng = bx_$curdeflng + sytp -> symht.size + 1;
						/* Increase size of defs. */


/* if there were no duplicates, we return now, otherwise we create	*/
/* a component hash table from the segment name table.		*/

	if dupn = 0
	then /* If no duplicated names ... */
	     return;				/* No need for seg name hash table. */

	sgtp = addrel (bx_$tdefp, bx_$curdeflng);	/* Get pointer to seg name hash table. */

	htsize = hlen (bx_$nsegdefs + 1);		/* Compute size of seg name hash table. */
	sgtp -> seght.size = htsize;			/* Fill in size of table. */

	sp = addr (bound_seg_seg);			/* Point to fake seg entry for bound segment. */
	call hash_seg;				/* Insert in hash table. */

	sntp = bx_$sntp;				/* Get pointer to segment name table. */
	do sx = 1 to sntp -> snt.n_names;		/* Go through the segment name table. */
	     sp = addr (sntp -> snt.entry (sx));	/* Get pointer to segment name table entry. */

	     if sp -> seg.defrel
	     then /* If this is a real name ... */
		call hash_seg;			/* Insert seg name in hash table. */
	end;

	bx_$curdeflng = bx_$curdeflng + sgtp -> seght.size + 1;
						/* Compute final size of defs. */


	return;					/* All finished. */


dup_search:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	dup_search				*/
/*	Input:	cx, sp					*/
/*	Function:	given a component table index (cx) and a pointer	*/
/*		to an insym entry (sp), scan all of the later	*/
/*		components insym lists for another definition	*/
/*		with the same name.  If duplicate definitions are	*/
/*		found, create a duplicate table, add all of the	*/
/*		duplicates to it, flag that the duplicates are	*/
/*		duplicates, and change the rel_ptr in the insym	*/
/*		for the original to point to the duplicate table	*/
/*		rather than the definition itself.		*/
/*	Output:	duplicate table, dupn			*/
/*							*/
/**********************************************************************/

	axx = 0;					/* Initialize auxiliary table index. */
	do cx1 = cx + 1 to bx_$ncomp;			/* Look at the rest of the components. */
	     ctep1 = comp_tbl (cx1);
	     ip1 = ctep1 -> comp.insymentp;

	     do sx1 = 1 to ip1 -> insym.n_insyms - 1;
		sp1 = addr (ip1 -> insym.entry (sx1));

		if ^(sp1 -> is.ignore | sp1 -> is.delete)
		then if substr (sp -> is.symbol, 1, sp -> is.lng) = substr (sp1 -> is.symbol, 1, sp1 -> is.lng)
		     then do;
			if axx = 0
			then do;			/* If this is first occurrence of duplicate ... */
			     axx = 1;		/* Initialize index. */
			     axtp -> auxt.defp (1) = sp -> is.defrel;
						/* Fill in first entry. */
			     axtp -> auxt.headp (1) = bit (bin (comp.defthread, 18));
			     sp -> is.defrel = bit (bx_$curdeflng, 18);
			end;			/* Save rel ptr to aux table instead of def. */

			axx = axx + 1;		/* Step index. */
			axtp -> auxt.defp (axx) = sp1 -> is.defrel;
						/* Fill in another entry. */
			axtp -> auxt.headp (axx) = bit (bin (ctep1 -> comp.defthread, 18));
			sp1 -> is.duplicate = "1"b;	/* Indicate symbol was a duplicate. */
		     end;


	     end;
	end;

	if axx ^= 0
	then do;					/* If we found a dup ... */
	     axtp -> auxt.size = axx;			/* Fill in size of aux table. */
	     bx_$curdeflng = bx_$curdeflng + axx + 1;	/* Increase length of defs. */
	     axtp = addrel (axtp, axx + 1);		/* Get new aux table pointer. */
	     dupn = dupn + 1;			/* Count another duplicated name. */
	end;


     end dup_search;


hash_sym:
     proc;


/**********************************************************************/
/*							*/
/*	Name:	hash_sym					*/
/*	Input:	sp					*/
/*	Function:	inserts the relp for the specified definition	*/
/*		into the definition hash table.  The entry is	*/
/*		inserted into the first empty slot at of after	*/
/*		the index calculated by the hash function.	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	namep = addr (sp -> is.symbol);		/* Get pointer to first word of ACC string. */
	symx = hash ();				/* Hash the name. */

	do while (sytp -> symht.defp (symx));		/* Find empty slot in hash table. */
	     symx = mod (symx, htsize) + 1;
	end;

	sytp -> symht.defp (symx) = sp -> is.defrel;	/* Set pointer in hash table entry. */



     end hash_sym;


hash_seg:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	hash_seg					*/
/*	Input:	sp					*/
/*	Function:	given a pointer to an insym entry, inserts a relp	*/
/*		for that definition into the first empty slot in	*/
/*		the component hash table at of after the index	*/
/*		generated by the hashing function.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	namep = addr (sp -> seg.name);
	segx = hash ();

	do while (sgtp -> seght.defp (segx));		/* Find an empty slot in the hash table. */
	     segx = mod (segx, htsize) + 1;
	end;

	sgtp -> seght.defp (segx) = sp -> seg.defrel;	/* Set def pointer in hash table entry. */
	ctep = sp -> seg.comp;			/* Get address of component table entry. */
	sgtp -> seght.headp (segx) = bit (bin (ctep -> comp.defthread, 18));
						/* Set pointer to first segname def. */


     end hash_seg;


hash:
     proc returns (fixed bin);

/**********************************************************************/
/*							*/
/*	Name:	hash					*/
/*	Input:	namep, htsize				*/
/*	Function:	given a pointer to an acc string, calculates the	*/
/*		hash function on it and returns the index.  The	*/
/*		hash function used is the remainder of the first	*/
/*		word of the acc string (count and first three	*/
/*		characters) divided by the size of the hash table	*/
/*	Output:	hash_index				*/
/*							*/
/**********************************************************************/

dcl	word		fixed bin (35) based;	/* first word of name */


	return (mod (namep -> word, htsize) + 1);


     end hash;



hlen:
     proc (s) returns (fixed bin);

/**********************************************************************/
/*							*/
/*	Name:	hlen					*/
/*	Input:	s					*/
/*	Function:	given the number of definitions to be placed into	*/
/*		a hash table, returns the size of the hash table	*/
/*		The hash table is sized such that it is not more	*/
/*		than 80% full.				*/
/*	Output:	htsize					*/
/*							*/
/**********************************************************************/

dcl	s		fixed bin;		/* required hash buckets */

dcl	s1		fixed bin,		/* minimum hash table size desired */
	i		fixed bin;		/* iteration variable */

dcl	sizes		(11) fixed bin static options (constant)
			init (13, 27, 53, 89, 157, 307, 503, 733, 1009, 1451, 2003);


	s1 = s * 1.25e0;				/* Allow for 20% of buckets to be empty. */
	do i = 1 to hbound (sizes, 1);		/* Pick an appropriate sizes. */
	     if s1 <= sizes (i)
	     then return (sizes (i));
	end;
	return (s1);				/* Default for very large hash tables. */


     end hlen;




     end;




		    incorporate_options_.pl1        08/06/86  1449.9rew 08/06/86  1419.4       96885



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


/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Changed errname to use the caller-supplied name instead of "binder_",
     improved documentation, removed non-functional support for obsolete
     "indirect" keyword.  "indirect" now functions the same as "retain".
  2) change(86-07-02,Elhard), approve(86-07-02,MCR7281),
     audit(86-07-23,JRGray), install(86-08-06,MR12.0-1119):
     Modified to improve error messages for multiple retain, delete, or no_link
     keywords given for a single input component.
                                                   END HISTORY COMMENTS */


/**********************************************************************/
/*							*/
/*	Name:	incorporate_options_			*/
/*	Input:	none					*/
/*	Function:	incorporates the options specified in the	*/
/*		bindfile into the component table, (symbol length	*/
/*		based on no_table specification), insym lists,	*/
/*		(indirect, retain, delete, or nolink specified),	*/
/*		and segname table, (synonym statements).  checks	*/
/*		are also made to insure that all the options are	*/
/*		processed and that none of the segnames in the	*/
/*		segname table match the bound objectname.  Checks	*/
/*		are also made to insure that all options are	*/
/*		consistent.				*/
/*	Output:	none.					*/
/*							*/
/**********************************************************************/

/* format: style3,^indnoniterdo */
incorporate_options_:
     procedure;

/* coded by Michael J. Spier 1970? */
/* modified 11/24/76 by M. Weaver to set comp.table_deleted */
/* Modified 01/14/81 W. Olin Sibert for new format of input structure */
/* Modified 85-02-11 by Dean Elhard to change errname to "bind"	*/
/* Modified 85-03-18 by Dean Elhard to clean up documentation and	*/
/*		    remove support for the indirect keyword.  It	*/
/*		    now behaves exactly as retain.		*/

/* DECLARATION OF EXTERNAL SYMBOLS */

declare	(com_err_, ioa_)	external entry options (variable);

/* DECLARATION OF INTERNAL STATIC VARIABLES */


/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, j, k, ndefs, nobjects)
			fixed bin;
declare	(p, inpp, areap, optp, ip, dp, sp)
			pointer;
declare	(g_nt, g_rt, g_in, g_dl, g_nl, op_sw, tab_sw)
			bit (1) aligned;
declare	opt_code		char (1) aligned;
declare	(errname, str1, str3)
			char (32) aligned;
declare	str2		char (256) aligned;
declare	newname		char (33) aligned;
declare	message		char (256) varying;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, index, null, substr)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	reset		bit (297) aligned based (p);
declare	acc_count		bit (9) aligned based (p);

/*  */

	ctp = bx_$ctp;
	inpp = bx_$inpp;
	sntp = bx_$sntp;
	areap = bx_$optp;

	if bx_$debug = 1
	then errname = "incorporate_options_";
	else errname = bx_$caller;

	addr (newname) -> reset = "0"b;		/* make acc string of bound segname */
	i = index (bx_$bound_segname, " ");
	if i = 0
	then i = 32;
	else i = i - 1;
	addr (newname) -> acc_count = bit (bin (i, 9), 9);
	substr (newname, 2, i) = substr (bx_$bound_segname, 1, i);

	nobjects = bx_$ncomp;			/* number of component objects */
	if areap = null
	then goto check_bound_name;


/* incorporate specified options into insym table */

	g_nt, g_rt, g_in, g_dl, g_nl = "0"b;

/* copy global options */

	if option.g_delete = "d"
	then g_dl = "1"b;
	else if option.g_indirect = "i"
	then g_rt = "1"b;
	else if option.g_retain = "r"
	then g_rt = "1"b;
	else if option.g_nolink = "l"
	then do;
	     g_rt, g_nl = "1"b;
	end;

	if option.g_notable = "t"
	then g_nt = "1"b;

	do i = 1 to nobjects;
	     ctep = comp_tbl (i);
	     if comp.ignore = 1
	     then goto next_object;
	     ip = comp.insymentp;			/* pointer to insym table of this component */
	     ndefs = ip -> insym.n_insyms - 1;		/* number of defs to scan */
	     op_sw = "0"b;				/* preset option flag */
	     optp = null;				/* reset pointer to option structure */
	     tab_sw = "0"b;				/* reset switch for keeping specific table */
	     if option.g_nolink = "l"
	     then ip -> insym.global_nolink = "1"b;
	     if inp.obj (i).option ^= "0"b
	     then do;				/* there is an option entry */
		optp = addrel (areap, inp.obj (i).option);
		if op.n_options > op.n_synonyms
		then op_sw = "1"b;			/* more than just synonyms */
		if op.no_link = "l"
		then ip -> insym.global_nolink = "1"b;
		if op.table = "t"
		then do;				/* want to keep table */
		     if comp.clngns = comp.clngss
		     then call ioa_ ("Warning: ^a has no symbol table, which bindfile wanted kept.", comp.filename);
		     else tab_sw = "1"b;		/* do not delete this table */
		end;
	     end;
	     if g_nt
	     then if ^tab_sw
		then do;				/* truncate any symbol table */
		     if comp.io_table ^= 0
		     then call ioa_ (
			     "Warning: symbol table not removed from ^a^/^-because it may be needed for data-directed I/O.",
			     comp.filename);
		     else do;
			if comp.clngns > comp.clngss
			then comp.table_deleted = 1;
			comp.clngns = comp.clngss;	/* use the shorter length */
		     end;
		end;
	     do j = 1 to ndefs;			/* scan insym table */
		dp = addr (ip -> insym.entry (j));	/* pointer to one definition */
		if op_sw = "1"b
		then do k = 2 to op.n_options;	/* lookup options */
			p = addr (op.opes (k));
			if p -> ope.symb ^= dp -> is.symbol
			then goto next_option;
			opt_code = p -> ope.code;
			if opt_code = "r"
			then dp -> is.retain = "1"b;
			else if opt_code = "i"
			then dp -> is.retain = "1"b;
			else if opt_code = "d"
			then dp -> is.delete = "1"b;
			else if opt_code = "l"
			then do;
			     dp -> is.retain, dp -> is.no_link = "1"b;
			end;
			else goto next_option;	/* skip synonyms */
			p -> ope.code = "*";	/* indicate that entry has been processed */
			goto next_def;
next_option:
		     end;
		if optp ^= null
		then do;				/* use "global" options */
		     if op.delete = "d"
		     then dp -> is.delete = "1"b;
		     else if op.indirect = "i"
		     then dp -> is.retain = "1"b;
		     else if op.retain = "r"
		     then dp -> is.retain = "1"b;
		     else if op.no_link = "l"
		     then do;
			dp -> is.retain, dp -> is.no_link = "1"b;
		     end;
		     else goto use_Global;
		end;
		else do;				/* use "Global" options */
use_Global:
		     dp -> is.retain = g_rt;
		     dp -> is.delete = g_dl;
		     dp -> is.no_link = g_nl;
		end;
next_def:
	     end;
next_object:
	end;

/* next process all synonyms */

	ndefs = snt.n_names;			/* size of segname table */
	do i = 1 to nobjects;
	     if inp.obj (i).option = "0"b
	     then goto try_next;			/* no option here */
	     optp = addrel (areap, inp.obj (i).option);	/* pointer to option table */
	     if op.n_options = 0
	     then goto try_next;			/* only global stuff */
	     p = addr (op.opes (1));			/* first string is the filename */
	     do j = 1 to snt.n_names;			/* scan segname table */
		if snt.entry (j).name = substr (p -> ope.symb, 1, 33)
		then goto filename_found;
	     end;
	     goto try_next;
filename_found:
	     ctep = snt.entry (j).comp;		/* pointer to file's component entry */
	     op.opes (1).code = "*";
	     do k = 2 to op.n_options;		/* now locate all synonyms for this file */
		p = addr (op.opes (k));
		if p -> ope.code ^= "s"
		then goto not_synonym;
		do j = 1 to ndefs;			/* compare with all segnames in table */
		     sp = addr (snt.entry (j));
		     if sp -> seg.name = substr (p -> ope.symb, 1, 33)
		     then do;
			if sp -> seg.comp = ctep
			then goto set_mark;		/* already in table */
			call com_err_ (0, errname, "segname ^a has been multiply declared in bindfile",
			     substr (sp -> seg.name, 2, sp -> seg.lng - 1));
			goto not_synonym;
		     end;
		end;
		ndefs = ndefs + 1;
		sp = addr (snt.entry (ndefs));	/* pointer to segname table entry */
		sp -> seg.name = p -> ope.symb;	/* copy string */
		sp -> seg.comp = ctep;		/* remember pointer to component table entry */
		sp -> seg.lng = p -> ope.lng;
set_mark:
		p -> ope.code = "*";		/* indicate that entry was processed */
not_synonym:
	     end;
try_next:
	end;
	snt.n_names = ndefs;			/* update size of segname table */
	if ndefs > snt.max_size
	then do;
	     call com_err_ (0, errname, "Segname table overflow; current limit = ^d.", snt.max_size);
	     bx_$fatal_error = 1;
	end;



/* Now check to see if all options were correctly processed */

	do i = 1 to nobjects;
	     if inp.obj (i).option ^= "0"b
	     then do;
		optp = addrel (areap, inp.obj (i).option);
		if op.n_options = 0
		then goto next_comp;
		p = addr (op.opes (1));
		str3 = substr (p -> ope.symb, 2, p -> ope.lng - 1);
		do j = 1 to op.n_options;
		     p = addr (op.opes (j));
		     if p -> ope.code ^= "*"
		     then do;
			message =
			     "'^a: ^a;' of bind-file entry ^a:^/Only one the 'retain', 'delete', or 'no_link', keywords may be specified."
			     ;
			opt_code = p -> ope.code;
			str2 = substr (p -> ope.symb, 2, p -> ope.lng - 1);
			if opt_code = "r"
			then str1 = "retain";
			else if opt_code = "i"
			then str1 = "indirect";
			else if opt_code = "d"
			then str1 = "delete";
			else if opt_code = "l"
			then str1 = "no_link";
			else if opt_code = "s"
			then do;
			     if j = 1
			     then str1 = "objectname";
			     else str1 = "synonym";
			     message = "'^a: ^a;' of bind-file entry ^a could not be processed";
			end;
			else str1 = "'" || opt_code || "'";
			call com_err_ (0, errname, message, str1, str2, str3);
			bx_$fatal_error = 1;
		     end;
		end;
	     end;
next_comp:
	end;



check_bound_name:
	do i = 1 to snt.n_names;			/* rescan segname table */
	     p = addr (snt.entry (i));
	     if p -> seg.name = newname
	     then do;
		if areap ^= null
		then /* have a bindfile */
		     call com_err_ (0, errname, "segname ^a has been multiply declared in bindfile",
			bx_$bound_segname);
		else call com_err_ (0, errname, "segname ^a has been multiply declared", bx_$bound_segname);
		bx_$fatal_error = 1;
	     end;
	end;


%page;
%include bindext;
%page;
%include comptbl;
%page;
%include bndtbl;
%page;
%include insym;
%page;
%include binder_input;
%page;
%include option;

     end incorporate_options_;




		    int_link_.pl1                   07/16/86  1217.0rew 07/16/86  0846.4      191628



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


/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation, removed red/black shifts, changed errname to use
     the caller-supplied name instead of "binder_", removed obsolete
     nonstandard object support, modified to update the link_regeneration_table
     with a flag ("777777"b3) to indicate internal link resolution.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */


/**********************************************************************/
/*							*/
/*	Name:	int_link_					*/
/*	Input:	argument_pointer				*/
/*	Function:	given a pointer to an external_ref structure	*/
/*		(argument_pointer), determine whether the target	*/
/*		of the reference is in a component of the bound	*/
/*		object segment and perform the pre-linking.  The	*/
/*		determination is done in the following manner:	*/
/*		  -- if the dont_prelink flag is on in the	*/
/*		     external_ref structure, just return since	*/
/*		     this must remain external.		*/
/*		  -- for type 3, 4, 5, or 6 links, determine	*/
/*		     whether the entryname is in the segname	*/
/*		     table (type 1 have no segname, they are	*/
/*		     self-references).  If the component is not	*/
/*		     found an external link must be regenerated.	*/
/*		  -- for type 4, 5, or 6 links, scan the insym	*/
/*		     list for the target component to find the	*/
/*		     target definition (type 1 and 3 links do not	*/
/*		     refer to a definition but to the base of a	*/
/*		     section/component). If the definition is not	*/
/*		     found, display a message indicating that the	*/
/*		     target could not be found and enter the name	*/
/*		     into the oddname table to prevent duplicate	*/
/*		     messages.				*/
/*		  -- if the reference is a type 1 or type 5 ref	*/
/*		     to the static section and we have a separate	*/
/*		     static section, generate an external link	*/
/*		     since we don't know where the static section	*/
/*		     will be.				*/
/*		  -- if the reference is a type 1 reference to	*/
/*		     the static section, relocate the reference,	*/
/*		     adjust the instruction, and return.	*/
/*		  -- if the reference is a type 1 link to the	*/
/*		     text section, relocate it, patch the	*/
/*		     instruction and return.			*/
/*		  -- if the reference is a type 1 link to a	*/
/*		     different section, create a repatch table	*/
/*		     entry for it to be filled in later since we	*/
/*		     don't know where the other stuff will be,	*/
/*		     patch the instruction and return.		*/
/*		  -- if the target of the link is to the static	*/
/*		     section of another component, we transform	*/
/*		     the link into a type 1 link to *static by	*/
/*		     adjusting the external_ref structure and	*/
/*		     then returning so that the call to ext_link_	*/
/*		     will generate the type 1 link.		*/
/*		  -- if the link has an indirect modifier, and	*/
/*		     the compiler is "PASCAL", and the target of	*/
/*		     the link refers to the linkage section, then	*/
/*		     we have an indirect reference to a link in	*/
/*		     another component.  This is resolved by	*/
/*		     removing the indirection and changing the	*/
/*		     instruction to refer directly to the target	*/
/*		     link.  We then call int_link_ recursively	*/
/*		     to try to resolve that link internally.  If	*/
/*		     that fails, we call ext_link_ to generate	*/
/*		     it externally.				*/
/*		  -- if the links has a modifier and the	*/
/*		     instruction has other than a simple	*/
/*		     indirection modifier, then generate an	*/
/*		     external link and print a message indicating	*/
/*		     that this link cannot be resolved internally	*/
/*		  -- now the link is resolved depending on the	*/
/*		     target section of the referenced definition.	*/
/*		     The following procedures are used for the	*/
/*		     different sections:			*/
/*		       -- Text section			*/
/*			The definition value is relocated, the	*/
/*			instruction word is patched, and the	*/
/*			modifier from the link is copied into	*/
/*			the instruction.			*/
/*		       -- Linkage section			*/
/*			If the reference is within the static	*/
/*			storage portion of the linkage section,	*/
/*			(ie. an ALM segdef), the definition	*/
/*			value is relocated, the instruction	*/
/*			word is patched, and the modifier from	*/
/*			the link copied into the instruction	*/
/*			modifier.  Otherwise an error message	*/
/*			is printed indicating that an illegal	*/
/*			sequence into the linkage section was	*/
/*			found.				*/
/*		       --	Symbol section			*/
/*			The symbol relocation is calculated and	*/
/*			a repatch table entry for the halfword	*/
/*			is generated and the instruction is	*/
/*			patched and the modifier copied.	*/
/*		       -- Static section			*/
/*		       	Since by this point we know we are not	*/
/*			creating a separate static section, we	*/
/*			adjust the static section reference for	*/
/*			the linkage header, and then treat as a	*/
/*			segdef in the linkage section.	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* Designed and initially coded by Michael J. Spier, October 6, 1970	*/
/* modified June, July 1975 by M. Weaver for separate static */
/* modified 9/78 by David Spector for hash coding "snt" */
/* modified Dec 78 by David Spector to make repatch table automatically extensible */

/* modified Oct 80 by JMAthane to allow relocation of reference to PASCAL REF variables
   and internal text references through link section */
/* modified October 1983 by Melanie Weaver to fix *text relocation and add error message to above */

int_link_:
     procedure (argument_pointer, result);

declare	argument_pointer	pointer,
	result		bit (1) aligned;


/* DECLARATION OF EXTERNAL SYMBOLS */

declare	com_err_		external entry options (variable);
declare	ioa_		external entry options (variable);
declare	temp_mgr_$allocate	ext entry (fixed bin);
declare	temp_mgr_$reserve	ext entry (ptr);
dcl	ext_link_		entry (ptr);
dcl	decode_link_	entry (ptr) returns (bit (1));

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	(text_relocation, symbol_relocation)
			fixed bin internal static;
declare	errname		char (16) aligned internal static;
declare	internally_resolved bit (18) static options (constant) init ("777777"b3);

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, val, type, ndefs, class, toffset, value, expression, link_modifier, int_limit)
			fixed bin (18);
declare	hash_index	fixed bin (34);
declare	hash_ptr		ptr;
declare	pos		fixed bin;
declare	wnpt		fixed bin;
declare	lrt_index		fixed bin;
declare	force_retain	bit (1) aligned;
declare	(p, refp, ap, ip, dp, targp)
			pointer;
declare	modp		pointer;
declare	string		char (33) aligned;
declare	wsegname		char (32) aligned;
declare	wentryname	char (256) aligned;
declare	oddname		char (65) aligned;
declare	estring		char (257) aligned based (addr (ebit));
declare	ebit		bit (2340) aligned init ("0"b);
						/* will be acc string */
dcl	my_result		bit (1) aligned;
dcl	1 my_ext		aligned like external_ref;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, fixed, hbound, min, mod, null, rel, substr, unspec)
			builtin;
declare	size		builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 ext		aligned based (ap) like external_ref;
declare	1 insyme		aligned based (dp) like is;
declare	1 word		aligned based,
	  2 lhe18		bit (18) unaligned,
	  2 rhe18		bit (18) unaligned;
declare	1 instr		aligned based,
	  2 dum1		bit (3) unaligned,
	  2 lhe15		bit (15) unaligned,
	  2 op_code	bit (9) unaligned,
	  2 dum2		bit (2) unaligned,
	  2 bit29		bit (1) unaligned,
	  2 modifier	bit (6) unaligned;
declare	1 modifier_overlay	aligned based (modp),
	  2 dum		bit (30) unaligned,
	  2 tm		bit (2) unaligned,
	  2 td		bit (4) unaligned;
declare	1 b5		aligned based (p),
	  2 dum		bit (21) unaligned,
	  2 rhe15		bit (15) unaligned;


/*  */
%include extref;

/*  */
%include bindext;

/*  */
%include comptbl;

/*  */
%include bndtbl;

/*  */
%include insym;

/*  */


	ctp = bx_$ctp;
	sntp = bx_$sntp;
	ap = argument_pointer;			/* copy argument into stack */
	result = "0"b;				/* preset return argument */
	if ext.dont_prelink = "1"b
	then return;				/* ******* */
	p = ext.compent_ptr -> comp.insymentp;		/* pointer to referencing object's definitions */
	force_retain = "0"b;
	if p -> insym.global_nolink = "1"b
	then force_retain = "1"b;			/* retain referenced entry for nolink */
	wsegname = substr (ext.segname, 2, ext.slng - 1);
	if ext.elng > 1
	then wentryname = substr (ext.entryname, 2, ext.elng - 1);
						/* copy ACC strings into regular format */
	else wentryname = " ";			/* there is no entryname */
	refp = ext.ref_ptr;				/* copy into stack for efficiency */
	ctep = ext.compent_ptr;			/* copy pointer to referencing component's entry */
	lrtp = comp.clrtp;
	lrt_index = ((ext.loffset - lrt.start_offset) * 0.5) + 1;
	link_modifier = 0;
	modp = addr (link_modifier);
	modifier_overlay.tm = ext.link_tm;		/* get modifier of original ext.link */
	modifier_overlay.td = ext.link_td;		/* ... */
	val = 0;					/* reset conversion variable */
	type = fixed (ext.type, 18);

	if type = 1
	then go to have_target;			/* it's an internal type-1 link */
	string = ext.segname;			/* copy ext.segname for efficiency */

/* Perform hash-coded lookup of snt. */

/* Hash-code the string (segname to be found) */

	hash_index = 0;
	do pos = 1 to min (ext.slng, 24);		/* prevent overflow of hash_index */
	     hash_index = 2 * hash_index + bin (unspec (substr (string, pos, 1)), 9);
	end;
	hash_index = mod (hash_index, hbound (snt.hash_table, 1) + 1);

/* Do linear search of this hash-code "bucket" (chain of entries) for
   entry having segname=string. */

	do hash_ptr = snt.hash_table (hash_index) repeat hash_ptr -> seg.hash_thread while (hash_ptr ^= null);
						/* search chain of links */
	     if hash_ptr -> seg.name = string
	     then goto segname_found;			/* success */
	end;
	goto return;				/* failure */

segname_found:
	substr (estring, 1, ext.elng) = substr (ext.entryname, 1, ext.elng);
						/* copy def for efficiency; remove substr when all names are 257 */
	targp = hash_ptr -> seg.comp;			/* pointer to referenced component's entry */
	int_limit = targp -> comp.clngi + 8;		/* scope of internal static */
	text_relocation = targp -> comp.crelt;		/* relocation counter for target component */
	symbol_relocation = targp -> comp.crels;	/* ... */
	ip = targp -> comp.insymentp;			/* pointer to component's definitions */
	if ip -> insym.global_nolink = "1"b
	then goto return;				/* target component not to be prelinked */
	ndefs = ip -> insym.n_insyms;			/* get number of defs for this component */
	if (type = 6 & ext.elng = 1)
	then go to null_ent;			/* treat like type 3 */
	if type = 3
	then /* its a segname|expresiion,m link */
	     do;
null_ent:
	     dp = addr (ip -> insym.entry (ndefs));	/* entry for null-name is the last */
	     goto definition_found;
	end;

/* its a type-4 or type-5 segname|entryname+expression,m  link */

	else do i = 1 to ndefs - 1;			/* scan definitions */
		dp = addr (ip -> insym.entry (i));	/* pointer to a definition entry */
		if estring = insyme.symbol
		then goto definition_found;
	     end;
	oddname = wsegname;
	substr (oddname, ext.slng, 1) = "$";
	substr (oddname, ext.slng + 1, ext.elng - 1) = wentryname;
	odnp = bx_$odnp;
	do i = 1 to od.n_odds;			/* lookup oddname table */
	     if oddname = od.entry (i).name
	     then goto return;			/* message already printed */
	end;

	if type = 5
	then do;
	     result = "1"b;				/* this is an internal link by definition */
	     lrt.regenerated (lrt_index) = internally_resolved;
	     i = fixed (ext.code15, 18);
	     if i = 0
	     then wsegname = "*text";
	     else if i = 1
	     then wsegname = "*link";
	     else if i = 2
	     then wsegname = "*symbol";
	     else if i = 4
	     then wsegname = "*static";
	     call com_err_ (0, errname, "cannot locate ^a|^a for file ^a", wsegname, wentryname, comp.filename);
	     bx_$fatal_error = 1;
	end;
	else call ioa_ ("Warning: cannot match symbol ^a; external link generated.", oddname);
	if i = od.max_size
	then do;
	     od.n_odds = i + 1;
	     call com_err_ (0, errname, "oddname table overflow; please notify maintenance.");
	     goto return;
	end;
	od.entry (i).name = oddname;			/* make new entry */
	od.n_odds = i;
	goto return;

definition_found:
	if insyme.no_link = "1"b
	then goto return;				/* this symbol must not be prelinked to */
	if force_retain = "1"b
	then do;
	     insyme.delete = "0"b;			/* retain symbol referenced by nolink component */
	     insyme.retain = "1"b;
	end;
have_target:
	expression = fixed (ext.expr, 18);		/* get expression from link */
	if substr (ext.expr, 1, 1)
	then expression = -fixed (^ext.expr, 18) - 1;

	if type = 1 | type = 5
	then do;					/* check   for *static */
	     if bin (ext.code15, 18) = 4
	     then do;				/* *static */
		if bx_$bound_sep_stat = 1
		then return;			/* addr of static not known */
						/* the following treatment of *static links is inconsistent
						   in that they are relocated whereas *link links are not */
		if type = 1
		then do;				/* must change to internal reference to static in linkage */
		     value = 8;			/* must adjust for linkage header */
		     targp = ctep;			/* selfreference */
		     result = "1"b;
		     lrt.regenerated (lrt_index) = internally_resolved;
		     go to segdef_in_linkage;
		end;
	     end;
	end;
	if type = 1
	then /* internal link relative to sections */
	     do;
	     result = "1"b;				/* this is an internal reference */
	     lrt.regenerated (lrt_index) = internally_resolved;
	     if wsegname = "*text"
	     then toffset = comp.crelt;		/* all type-1 links relative to base of section */
	     else do;				/* reference to linkage and symbol must be done in two steps */
		call create_rpt_entry;		/* wnpt = index of repatch table entry */
		rptep = addr (rpt.entry (wnpt));
		rpte.halfword = ext.side;
		rpte.poffset = rel (refp);		/* remember referencing instruction */
		rpte.pbase = "t";			/* relative to text section */
		rpte.pexpr = "0"b;			/* no expression value */
		toffset = 0;			/* type-1 links refer to base of section */
		if wsegname = "*link"
		then /* self reference to linkage section */
		     rpte.code = "l";
		else if wsegname = "*symbol"
		then /* self reference to symbol section */
		     rpte.code = "s";
		else call ioa_ ("int_link_: programming error 1;name=^a", wsegname);
	     end;
	     toffset = toffset + expression;		/* put new address in referencing instruction */
	     refp -> word.lhe18 = addr (toffset) -> word.rhe18;
	     goto patch_modifier;
	end;

	class = fixed (insyme.class, 18);		/* get class of entrypoint */
						/* can't prelink to separate static */
	value = fixed (insyme.value, 18);		/* get value */

	if class = 4
	then if bx_$bound_sep_stat = 1
	     then do;				/* Transform a link to another component's
						   static to a type 1 link to *static. To do
						   this we  change the info in ext so that
						   ext_link_ will generate the right link. */
		if type = 6
		then ext.trap = "0"b;		/* target won't need to be created */
		ext.type = bit (bin (1, 18), 18);
		ext.code15 = bit (bin (4, 18), 18);
		ext.expr = bit (bin (value + targp -> comp.creli + expression, 18), 18);
						/* keep segname and entryname for messages and to distinguish diddled structure */

		go to return;

	     end;

	if link_modifier ^= 0
	then do;					/* the original link had a modifier in it */
	     if comp.compiler = "PASCAL  "
	     then do;
		if link_modifier = 16
		then do;				/* 20 octal (indirect) */
		     if class = 1
		     then do;

/* This link indirects through another link.  We now want to resolve the
   reference directly to the other link (or to its target, if internal).
   We do this by pretending that the reference is actually to the other link. */

			refp -> instr.lhe15 = addr (value) -> rhe15;
			my_ext.ref_ptr = ext.ref_ptr;
			my_ext.compent_ptr = targp;
			my_ext.loffset = value;
			if decode_link_ (addr (my_ext)) = "1"b
			then do;
			     call com_err_ (0, errname, "Cannot regenerate target link of indirect link ^a|^a,*",
				wsegname, wentryname);
			     bx_$fatal_error = 1;
			     return;
			end;
			call int_link_ (addr (my_ext), my_result);
			if my_result = "0"b
			then call ext_link_ (addr (my_ext));
		     end;
		     else if class = 4
		     then do;
			value = value + targp -> comp.creli + 8;
			refp -> instr.lhe15 = addr (value) -> rhe15;
		     end;
		     result = "1"b;
		     lrt.regenerated (lrt_index) = internally_resolved;
		     return;
		end;
	     end;
	     if refp -> modifier_overlay.td ^= "0000"b
	     then /* the referencing instruction has a modifier as well */
		do;
		call ioa_ ("Warning: Modifier at ^a|^o cannot be handled by binder; external link generated.",
		     comp.filename, ext.offset);
		insyme.delete = "0"b;		/* make sure def gets regenerated */
		insyme.retain = "1"b;
		goto return;
	     end;
	end;


	result = "1"b;				/* this is an internal link */
	lrt.regenerated (lrt_index) = internally_resolved;

	if class = 0
	then do;
	     toffset = text_relocation + value + expression;
	     goto update_reference;
	end;

	if class = 1
	then do;
	     p = targp -> comp.clnkp;			/* pointer to base of target's old linkage section */
	     p = addrel (p, value);			/* pointer to symbol's entry sequence in linkage section */
	     if (refp -> modifier_overlay.tm = "11"b) | (value < int_limit)
	     then /* an ALM segdef */
		do;
segdef_in_linkage:
		val = value + targp -> comp.creli + expression;
						/* compute new address of internal static */
		refp -> instr.lhe15 = addr (val) -> rhe15;
						/* and store in referencing instruction */
		if link_modifier = 0
		then refp -> modifier_overlay.tm = "00"b;
		else refp -> instr.modifier = bit (bin (link_modifier, 6), 6);
		if type ^= 1
		then insyme.snapped = "1"b;		/* dp not defined for type 1 */
		goto return;
	     end;

illegal_entry:
	     call com_err_ (0, errname, "illegal ^a entry sequence in link|^o for ^a$^a", targp -> comp.compiler, value,
		targp -> comp.filename, wentryname);
	     bx_$fatal_error = 1;
	     goto return;

	end;


	if class = 2
	then do;
	     toffset = symbol_relocation + value + expression;
	     call create_rpt_entry;			/* wnpt = index of repatch table entry */
	     rpt.entry (wnpt).halfword = ext.side;
	     rpt.entry (wnpt).poffset = rel (refp);	/* remember to finish relocation later */
	     rpt.entry (wnpt).pbase = "t";		/* relative to text section */
	     rpt.entry (wnpt).pexpr = "0"b;		/* no expression value */
	     rpt.entry (wnpt).code = "s";
	     goto update_reference;
	end;

	if class = 4
	then do;					/* in static, but will be combined */
	     value = value + 8;			/* must account for linkage header */
	     go to segdef_in_linkage;
	end;

	call com_err_ (0, errname, "internal entrypoint ^a in file ^a has unrecognized class ^o", wentryname,
	     targp -> comp.filename, class);
	bx_$fatal_error = 1;
	goto return;

update_reference:					/* put new address in referencing instruction */
	refp -> word.lhe18 = addr (toffset) -> word.rhe18;
	insyme.snapped = "1"b;

patch_modifier:
	refp -> instr.bit29 = "0"b;
	if link_modifier = 0
	then refp -> modifier_overlay.tm = "00"b;	/* remove indirection */
	else refp -> instr.modifier = bit (bin (link_modifier, 6), 6);
						/* copy modifier from original link */
	goto return;

illegal_reference:
	call com_err_ (0, errname, "illegal ^a external reference in ^a|^o", comp.compiler, comp.filename, ext.offset);
	bx_$fatal_error = 1;

return:
	return;




init:
     entry;

	if bx_$debug = 1
	then errname = "int_link_";
	else errname = bx_$caller;

	return;

create_rpt_entry:
     procedure;					/* wnpt = index of new repatch table entry */

	rptp = bx_$last_rptp;
	wnpt, rpt.npt = rpt.npt + 1;
	if wnpt = hbound (rpt.entry, 1)
	then do;					/* allocate new chunk of repatch table */
	     call temp_mgr_$allocate (size (rpt));
	     rpt.thread = bx_$freep;
	     rptp = bx_$freep;
	     bx_$last_rptp = rptp;
	     rpt.thread = p;
	     call temp_mgr_$reserve (addrel (rptp, size (rpt)));
	     rpt.thread = null;
	     rpt.npt = 0;
	end;

     end;


     end;						/* End of int_link_ */




		    make_bindmap_.pl1               07/16/86  1217.0rew 07/16/86  0846.5       65790



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation, and force source_map onto a doubleword boundary.
                                                   END HISTORY COMMENTS */


/**********************************************************************/
/*							*/
/*	Name:	make_bindmap_				*/
/*	Input:	none					*/
/*	Function:	Creates the source map, setting the pointer to it	*/
/*		in the symbol header, and creates the bindmap,	*/
/*		setting the area_pointer in the symbol header to	*/
/*		point to it.				*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* Coded sometime in 1972, by Melanie Weaver, as an adaptation of what is
   now called old_make_bindmap_ */
/* Modified 01/14/81 W. Olin Sibert for new format of input structure */
/* Modified 11/14/84 by M. Sharpe to forget non-standard objects ever existed */

/* format: style3,^indnoniterdo */
make_bindmap_:
     procedure;					/* DECLARATION OF EXTERNAL SYMBOLS */

declare	date_time_	entry (fixed bin (71), char (*) aligned);
declare	get_group_id_	entry () returns (char (32) aligned);

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, lng, val, ncomp)
			fixed bin;
declare	block_offset	fixed bin (18);
declare	(p, bmp, sblkp, inpp, smp)
			pointer;
declare	w_string1		char (32) aligned;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, divide, fixed, index, length, rel, rtrim, substr)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 block_offset_overlay
			aligned based (addr (block_offset)),
	  2 dum		bit (35) unaligned,
	  2 odd		bit (1) unaligned;

declare	1 source_map	aligned based (smp),	/* declaration of standard source map */
	  2 decl_vers	fixed bin,
	  2 size		fixed bin,		/* number of source segments */
	  2 map		(size) aligned,		/* one for each input and update archive */
	    3 pathname_offset
			bit (18) unaligned,
	    3 pathname_length
			bit (18) unaligned,
	    3 uid		bit (36) aligned,		/* uid of the source segment */
	    3 dtm		fixed bin (71);		/* last date/time modified of source */

%page;

	ctp = bx_$ctp;
	inpp = bx_$inpp;
	sblkp = bx_$bsymp;
	block_offset = bx_$s_lng;			/* this part of binder's block is at end */

	w_string1 = get_group_id_ ();			/* get user id for symbol header */
	lng = index (w_string1, " ") - 1;		/* get relevant length of user id */
	if lng = -1
	then lng = 32;				/* generate userid string */
	call gen_string (addr (sb.uid_offset), substr (w_string1, 1, lng));

/* generate source map */

	ncomp = inp.ntotal;				/* list both input and update archives */
	if block_offset_overlay.odd
	then block_offset = block_offset + 1;		/* align source map on an even boundary */

	smp = addrel (sblkp, block_offset);		/* get address of source map */
	sb.source_map = bit (bin (block_offset, 18), 18); /* allocate map area */
	block_offset = block_offset + (ncomp * 4) + 2;
	source_map.decl_vers = 1;
	source_map.size = ncomp;
	do i = 1 to ncomp;				/* fill in info for each archive */
	     call gen_string (addr (source_map.map (i).pathname_offset), rtrim (inp.archive (i).real_path));
	     source_map.map (i).uid = inp.archive (i).uid;
	     source_map.map (i).dtm = inp.archive (i).dtm;
	end;

	if block_offset_overlay.odd
	then block_offset = block_offset + 1;		/* start bindmap of even word boundary */

/* generate bind map proper */

	bmp = addrel (sblkp, block_offset);		/* pointer to bindmap structure */
	bindmap.dcl_version = 2;			/* constant '2' to identify structure used */
						/* and remember relpointer */
	sb.area_ptr = bit (bin (block_offset, 18), 18);
	ncomp = inp.nobj;				/* number of bound objects */
	p = addr (bindmap.component (ncomp + 1));	/* compute size of structure */
	val = fixed (rel (p), 18) - fixed (rel (bmp), 18) + 13;
	block_offset = block_offset + val;		/* grow symbol block */
	n_components = ncomp;			/* put size in bindmap */

	do i = 1 to ncomp;				/* generate bindmap */
	     ctep = comp_tbl (i);			/* pointer to component's entry */
	     call gen_string (addr (component (i).name), substr (comp.filename, 1, comp.fn_lng));
	     component (i).comp_name = comp.compiler;
	     component (i).text_start = bit (bin (comp.crelt, 18), 18);
	     component (i).text_lng = bit (bin ((comp.clngt + comp.cpadt), 18), 18);
	     component (i).stat_start = bit (bin (comp.creli, 18), 18);
	     component (i).stat_lng = bit (bin ((comp.clngi + comp.cpadi), 18), 18);
	     component (i).symb_start = bit (bin (comp.crels, 18), 18);
	     component (i).defblock_ptr = bit (bin (comp.defthread, 18), 18);
	     component (i).symb_lng = bit (bin ((comp.clngns + comp.cpads), 18), 18);
	     component (i).n_blocks = bit (bin (comp.n_sym_blks, 18), 18);
	end;

	call gen_string (addr (bindmap.bf_name), rtrim (inp.bindfile_name));
	call date_time_ (inp.bindfile_time_up, bindmap.bf_date_up);
	call date_time_ (inp.bindfile_time_mod, bindmap.bf_date_mod);

/* make block offset even */
	if block_offset_overlay.odd
	then block_offset = block_offset + 1;
	block_size = bit (bin (block_offset - bin (sb.uid_offset, 18) + bin (sb.next_block, 18), 18), 18);
						/* set size of symbol block */
	bx_$s_lng = block_offset;			/* update length of symbol section */

	return;


gen_string:
     procedure (stringpointer, string);

/**********************************************************************/
/*							*/
/*	Name:	gen_string				*/
/*	Input:	stringpointer, string			*/
/*	Function:	given a string and a pointer to a symbol table	*/
/*		string reference (18 bit relp and 18 bit length),	*/
/*		allocate the space for the string at the end of	*/
/*		the symbol section, and set the relp and length.	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	stringpointer	pointer,
	string		char (*);
declare	p		pointer;
declare	(lng, delta)	fixed bin;
declare	1 sp		aligned based (stringpointer),
	  2 relp		bit (18) unaligned,
	  2 n_chars	bit (18) unaligned;
declare	newstring		char (10000) aligned based (p);

	lng = length (string);			/* get length of new string */
	n_chars = bit (bin (lng, 18), 18);		/* and store in strinpointer */
	relp = bit (bin (block_offset, 18), 18);	/* store relpointer to string */
	p = addrel (sblkp, block_offset);		/* ITS pointer to string */
	delta = divide (lng + 3, 4, 17, 0);		/* compute block increment */
	substr (newstring, 1, delta * 4) = string;
	block_offset = block_offset + delta;

     end gen_string;

%page;
%include bindext;
%page;
%include comptbl;
%page;
%include binder_input;
%page;
%include symbol_block;
%page;
%include bind_map;

     end make_bindmap_;




		    make_bound_object_map_.pl1      07/16/86  1217.0rew 07/16/86  0846.6       32706



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and removed obsolete nonstandard object support.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
make_bound_object_map_:
     proc (code);

/**********************************************************************/
/*							*/
/*	Name:	make_bound_object_map_			*/
/*	Input:	none					*/
/*	Function:	builds the bound segment's object map, sets the	*/
/*		object map relp at the end of the object segment,	*/
/*		and calculates the bit count for the new bound	*/
/*		object segment.				*/
/*	Output:	error_code				*/
/*							*/
/**********************************************************************/

/* modified 75.06.20 by M. Weaver  to create version 2 map */
/* modified 77/08/16 by M. Weaver to add perprocess_static switch */

declare	maprel		fixed bin (18);
declare	max_length	fixed bin (19);
declare	code		fixed bin (35);
declare	error_table_$boundviol
			fixed bin (35) external;

declare	hcs_$get_max_length_seg
			entry (ptr, fixed bin (19), fixed bin (35));
declare	(addrel, bin, bit, ptr, multiply, rel, size)
			builtin;

declare	(obj_mapp, seg_ptr) pointer;

declare	01 obj_map	aligned like object_map based (obj_mapp);

%include bindext;

/*  */

%include object_map;

/*  */


	seg_ptr = bx_$temp_bsegp;			/* Get pointer to base of object segment. */

	call hcs_$get_max_length_seg (seg_ptr, max_length, code);
	if code ^= 0
	then return;				/* Get maximum number of words object segment may grow. */
						/* get current object length */
	maprel = bin (rel (bx_$bsymp), 18) + bx_$s_lng;
	if (maprel + size (object_map) + 1) > max_length
	then do;
	     code = error_table_$boundviol;		/* no room for map */
	     return;
	end;

	obj_mapp = ptr (seg_ptr, maprel);		/* make ptr to map */

	obj_map.decl_vers = object_map_version_2;
	obj_map.identifier = "obj_map";
	obj_map.text_offset = "0"b;
	obj_map.text_length = bit (bin (bx_$textlng, 18), 18);
	obj_map.definition_offset = rel (bx_$bdefp);
	obj_map.definition_length = bit (bin (bx_$d_lng, 18), 18);
	obj_map.linkage_offset = rel (bx_$blnkp);
	obj_map.linkage_length = bit (bin (bx_$l_lng, 18), 18);
	obj_map.static_offset = rel (bx_$bstatp);
	obj_map.static_length = bit (bin (bx_$i_lng, 18), 18);
	obj_map.symbol_offset = rel (bx_$bsymp);
	obj_map.symbol_length = bit (bin (bx_$s_lng, 18), 18);
	obj_map.break_map_offset, obj_map.break_map_length = "0"b;
	obj_map.format.bound, obj_map.format.standard = "1"b;
	if bx_$bproc = 1
	then obj_map.format.procedure = "1"b;

	if bx_$bound_sep_stat = 1
	then obj_map.format.separate_static = "1"b;
	if bx_$perprocess_static = 1
	then obj_map.format.perprocess_static = "1"b;

	addrel (obj_mapp, size (object_map)) -> map_ptr = bit (bin (maprel, 18), 18);
						/* fill in rel ptr to beg of obj map */
	bx_$bseg_bitcount = multiply ((maprel + size (object_map) + 1), 36, 24, 0);

	code = 0;
	return;

     end make_bound_object_map_;




		    make_defs_.pl1                  11/20/86  1403.9r w 11/20/86  1145.0      112329



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


/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and readablilty, changed errname to use caller
     supplied name instead of "binder_".
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

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


/* Designed and initially coded by Michael J. Spier, October 6, 1970	*/
/* Modified Sept 1978 by David Spector for hash-coding strm */

make_defs_:
     procedure;


/* DECLARATION OF EXTERNAL SYMBOLS */

declare	com_err_		external entry options (variable);
declare	generate_def_	external entry (pointer, pointer);
declare	hash_defs_	external entry;
declare	strm_hash_$make_entry
			external entry (char (*), fixed bin (17));

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	(defbase, linkbase, last_def, last_segname)
			pointer internal static;
declare	errname		char (16) aligned internal static;
declare	last_def_rel	fixed bin aligned internal static;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, j, ndefs)	fixed bin;
declare	(ip, sp)		pointer;
declare	(defblock_head, segblock_head, rel_ptr)
			fixed bin aligned;
declare	temp_name		char (32) varying;
declare	newignore		bit (1) aligned;

/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, divide, fixed, length, null, rtrim, substr)
			builtin;

/* DECLARATION OF BASED VARIABLES */

declare	acc_string_overlay	char (acc_string.count + 1) based (acc_string_ptr);
declare	01 last_definition	aligned like definition based (last_def);

/*  */

%include bindext;

/*  */

%include comptbl;

/*  */

%include bndtbl;

/*  */

%include insym;

/*  */

%include definition_dcls;

/*  */

open_section:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	make_defs_$open_section			*/
/*	Input:	none					*/
/*	Function:	initializes the definition section of the new	*/
/*		bound object segment and creates the standard	*/
/*		definitions for the bound segment.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	ctp = bx_$ctp;
	strmp = bx_$strmp;
	errname = bx_$caller;
	if bx_$debug = 1
	then errname = "make_defs_";
	last_def, defbase = bx_$tdefp;		/* pointer to base of new definition section */
	linkbase = bx_$tlinkp;			/* pointer to base of new linkage section */
	newignore = "0"b;				/* defs by this entry not ignored */

/* generate dummy def for standard object */

	def_ptr = defbase;
	definition.forward_relp = 2;
	definition.flags.new = "1"b;
	definition.flags.ignore = "1"b;
	bx_$curdeflng = 2;				/* adjust for dummy def */
	last_def = addrel (last_def, 2);		/* have reinitialized everything necessary */


/* Make a definition block for the new bound segment itself */

	last_segname = null;			/* indicate initialization */
	last_def_rel,				/* initialize threads */
	     segblock_head = bx_$curdeflng;

	temp_name = rtrim (bx_$bound_segname);
	call fabricate_def (temp_name, CLASS_SEGNAME, 0);

	last_definition.segname_relp,			/* pointer to def block */
	     last_definition.forward_relp = bx_$curdeflng;
	last_segname = last_def;			/* remember segname thread  */
	call fabricate_def ("symbol_table", CLASS_SYMBOL, 0);
						/* fabricate definitions for bound segment */
	call fabricate_def ("bind_map", CLASS_SYMBOL, 0);
	bx_$bindmap_def = last_def;			/* remember pointer to bindmap definition */

	bx_$curdeflng = bx_$curdeflng + 1;		/* grow def section for the zero word */

	return;




close_section:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	make_defs_$close_section			*/
/*	Input:	none					*/
/*	Function:	generates and threads in segname definitions for	*/
/*		definition blocks which have retained definitions	*/
/*		terminates the threads, and generates the hash	*/
/*		table					*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	ctp = bx_$ctp;
	sntp = bx_$sntp;
	strmp = bx_$strmp;
	do i = 1 to bx_$ncomp;			/* scan all component segments */
	     ctep = comp_tbl (i);			/* pointer to component entry */
						/* rel pointer to head of def list */
	     defblock_head = fixed (comp.defblockp, 18);
	     if defblock_head ^= 0
	     then do;
		call check_ignore ();		/* if defblock ignored, ignore segnames */
						/* remember pointer to first segname */
		segblock_head = bx_$curdeflng;	/* remember defblock head */
		comp.defthread = bx_$curdeflng;
		do j = 1 to snt.n_names;		/* scan segname table */
		     sp = addr (snt.entry (j));	/* pointer to segname entry  */
		     if sp -> seg.comp = ctep		/* this is same component */
		     then do;
			temp_name = substr (sp -> seg.name, 2, sp -> seg.lng - 1);
			call fabricate_def (temp_name, CLASS_SEGNAME, 0);
			if ^newignore
			then do;
			     bx_$nsegdefs = bx_$nsegdefs + 1;
						/* Save rel_ptr to new def. */
			     sp -> seg.defrel = bit (bin (rel_ptr, 18), 18);
			end;
		     end;
		end;				/* pointer to current regular def */
		def_ptr = addrel (defbase, defblock_head);
						/* thread blocks together, forwards ... */
		last_definition.forward_relp = defblock_head;
						/* and backwards */
		definition.backward_relp = last_def_rel;

gen_blockpointer:
		definition.segname_relp = segblock_head;/* pointer to segblock block */
		if definition.forward_relp ^= 0
		then do;				/* follow thread */
		     def_ptr = addrel (defbase, definition.forward_relp);
		     goto gen_blockpointer;
		end;

/* end of list */
		last_def_rel = fixed (comp.current_def, 18);
		last_def = addrel (defbase, last_def_rel);
	     end;
	end;

	last_segname -> definition.thing_relp,		/* last thread points to zero word */
	     last_definition.forward_relp, addrel (defbase, 2) -> definition.backward_relp = bx_$curdeflng;
	if last_definition.class ^= CLASS_SEGNAME
	then last_definition.segname_relp = segblock_head;
	bx_$curdeflng = bx_$curdeflng + 1;		/* thread must end at physical end for checker */

	call hash_defs_;				/* Make defs hash table now. */

	return;






regenerate_block:
     entry (compent_ptr);

/**********************************************************************/
/*							*/
/*	Name:	make_defs_$regenerate_block			*/
/*	Input:	component_entry_pointer			*/
/*	Function:	given a pointer to a component table entry, scan	*/
/*		the insym table for that component and regenerate	*/
/*		any definitions which are to be retained.	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	compent_ptr	pointer;

	ctep = compent_ptr;				/* copy pointer to current component table entry */

	ip = comp.insymentp;			/* pointer to component's definitions */
	ndefs = ip -> insym.n_insyms;			/* get number of definitions for this component */

/* now generate definitions for all insyms which are to be retained */

	do i = 1 to ndefs - 1;			/* scan definition table for component */
	     sp = addr (ip -> insym.entry (i));		/* pointer to current definition */
	     if sp -> is.regenerated
	     then goto skip;			/* this definition has already been regenerated */
	     if ((sp -> is.delete | sp -> is.ignore) & ^sp -> is.retain_flag)
	     then go to skip;
	     call generate_def_ (ctep, sp);		/* generate this definition */
skip:
	end;


	return;


/*  */

check_ignore:
     proc;

/**********************************************************************/
/*							*/
/*	Name:	check_ignore				*/
/*	Input:	defblock_head				*/
/*	Function:	scans the definition block specified by defblock	*/
/*		head for non-ignored definition and sets the	*/
/*		newignore flag if all of the definitions in the	*/
/*		block are ignored.				*/
/*	Output:	newignore					*/
/*							*/
/**********************************************************************/

	newignore = "1"b;				/* ignore unless we find 1 nonignored def */
						/* find beginning of defblock */
	def_ptr = addrel (defbase, defblock_head);
test_ignore:
	if ^definition.flags.ignore
	then do;					/* at least 1 nonignored def */
	     newignore = "0"b;
	     return;				/* don't need to look further */
	end;

	if definition.forward_relp ^= 0
	then do;					/* follow thread */
	     def_ptr = addrel (defbase, definition.forward_relp);
	     go to test_ignore;
	end;

	return;
     end;


/**/


fabricate_def:
     procedure (defstring, newclass, newvalue);

/**********************************************************************/
/*							*/
/*	Name:	fabricate_def				*/
/*	Input:	defstring, newclass, newvalue			*/
/*	Function:	creates a definition in the definition section	*/
/*		with the name specified by defstring, the class	*/
/*		specified by newclass, and a thing_relp specified	*/
/*		by newvalue.				*/
/*							*/
/**********************************************************************/

declare	defstring		char (32) varying;
declare	newclass		fixed bin (3) unsigned;
declare	newvalue		fixed bin (18) unsigned;

declare	(i, defoffset)	fixed bin;
declare	dp		pointer;
declare	01 new_def	aligned like definition based (dp);

	defoffset = bx_$curdeflng;
	rel_ptr = defoffset;			/* relative offset of def */
	dp = addrel (defbase, rel_ptr);		/* absolute pointer to new def */
	new_def.class = newclass;
	new_def.thing_relp = newvalue;
	new_def.flags.new = "1"b;
	new_def.flags.ignore = newignore;
	defoffset = defoffset + 3;
	do i = 1 to strm.nstr;			/* lookup string in map */
						/* pointer to a generated string */
	     acc_string_ptr = addrel (defbase, strm.entry (i).map);
	     if defstring = acc_string.string
	     then do;
		new_def.name_relp = fixed (strm.entry (i).map, 18);
		goto string_generated;
	     end;
	end;
	i, strm.nstr = strm.nstr + 1;
	if strm.nstr > strm.max_size
	then do;
	     call com_err_ (0, errname, "stringmap table overflow; please contact maintenance.");
	     strm.nstr = 1;
	     bx_$fatal_error = 1;
	end;
	new_def.name_relp = defoffset;		/* pointer to newly generated symbol string */
	strm.entry (i).map = bit (bin (defoffset, 18), 18);
	acc_string_ptr = addrel (defbase, defoffset);
	acc_string.count = length (defstring);
	acc_string.string = defstring;
	defoffset = defoffset + divide (acc_string.count + 4, 4, 17, 0);

	call strm_hash_$make_entry (acc_string_overlay, i);

string_generated:
	bx_$curdeflng = defoffset;
	if last_segname = null
	then return;				/* only once for first definition */

	last_definition.forward_relp = rel_ptr;		/* thread entries together */
	new_def.backward_relp = last_def_rel;		/* backwards thread */
	last_def = dp;				/* remember this definition */
	last_def_rel = rel_ptr;			/* and its rel-ptr form */
	if newclass ^= CLASS_SEGNAME
	then /* not a segname */
	     do;					/* pointer to head of segname block */
	     new_def.segname_relp = segblock_head;
	     return;				/* and that's all */
	end;

/* thread of segname entries */
	last_segname -> definition.thing_relp = rel_ptr;
	new_def.segname_relp = defblock_head;		/* set up segname thread  */
	last_segname = dp;				/* remember this segname definition */

	return;

     end fabricate_def;

     end make_defs_;




		    parse_bindfile_.rd              07/16/86  1217.0rew 07/16/86  1212.5      332703



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */

/* HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Change error messages to use the caller supplied name instead of
     "parse_bindfile_", changed to produce a reasonable error message when
     parsing a bindfile with no tokens or a zero length bindfile, and to give a
     warning if the obsolete "indirect" keyword is used in a "global" or
     "Global" statement.
                                                   END HISTORY COMMENTS */

/*++ 
INCLUDE NEXT_STMT	\
INCLUDE LEX	\
INCLUDE ERROR	\

BEGIN
stmt	/			/[keyword_idx = 0]          /         \
	/<no-token>		/epilogue		        /RETURN   \
	/ ;			/LEX		        /stmt     \
	/<keyword>		/	 	        /KEYWORD  \
	/<any-token>		/[if keyword_idx = 0
				  then call ERROR (1)]
				NEXT_STMT		        /stmt     \
KEYWORD
	/Addname			/Addname    LEX	        /ADDNAME  \

	/Force_Order : <long_name>	/LEX (2)
				 [arg_ptr = Ptoken;
				  arg_count = 0]	        /ORD_list \
	/Force_Order		/LEX		        /bad_syntax\

	/Global : <globe_arg> ;	/LEX (2)   Global
				 NEXT_STMT	        /stmt     \
	/Global : <globe_arg>	/LEX (2)   ERROR (7)
				 NEXT_STMT	        /stmt     \
	/Global			/LEX		        /bad_syntax\

	/Ignore : <long_name>	/LEX (2)
				 [arg_ptr = Ptoken;
				  arg_count = 0]	        /ORD_list \
	/Ignore			/LEX		        /bad_syntax\
	/No_Table			/LEX		        /noarg_stmt\

	/Objectname : <long_name> ;	/LEX (2)   Objectname
				 NEXT_STMT	        /stmt     \
	/Objectname : <long_name>	/LEX (2)   ERROR(7)
				 NEXT_STMT	        /stmt     \
	/Objectname		/LEX		        /bad_syntax\

	/Order : <long_name>	/LEX (2)
				 [arg_ptr = Ptoken;
				  arg_count = 0]	        /ORD_list \
	/Order			/LEX		        /bad_syntax\

	/Partial_Order : <long_name>	/LEX (2)
				 [arg_ptr = Ptoken;
				  arg_count = 0]	        /ORD_list \
	/Partial_Order		/LEX		        /bad_syntax\
	/Perprocess_Static		/LEX		        /noarg_stmt\

	/delete : <long_name>	/delete   LEX (2)	        /ENTRY_list\
	/delete			/LEX		        /bad_syntax\
	/global : <globe_arg> ;	/LEX (2)   global
				 NEXT_STMT	        /stmt     \
	/global : <globe_arg>	/LEX (2)   ERROR(7)
				 NEXT_STMT	        /stmt     \
	/global			/LEX		        /bad_syntax\
	/indirect : <long_name>	/indirect   LEX (2)	        /ENTRY_list\
	/indirect			/LEX		        /bad_syntax\

	/no_link : <long_name>	/no_link   LEX (2)	        /ENTRY_list\
	/no_link			/LEX		        /bad_syntax\

	/objectname : <long_name> ;	/LEX (2)   objectname
				 NEXT_STMT	        /stmt     \
	/objectname : <long_name>	/LEX (2)   ERROR (7)
				 NEXT_STMT	        /stmt     \
	/objectname		/LEX		        /bad_syntax\
	/retain : <long_name>	/retain   LEX (2)	        /ENTRY_list\
	/retain			/LEX		        /bad_syntax\

	/synonym : <long_name>	/synonym   LEX (2)	        /SEG_list \
	/synonym			/LEX		        /bad_syntax\

	/table			/LEX		        /noarg_stmt\


ADDNAME  	/;			/LEX		        /stmt     \
	/: ;			/LEX (2)		        /stmt     \
	/: <long_name>		/[an.n_an = 0]   LEX        /ADN_list \

bad_syntax 
	/: <any-token>		/LEX ERROR (2) NEXT_STMT    /stmt     \
	/: <no-token>		/ERROR (3) LEX	        /stmt     \
	/<any-token>		/ERROR (4) NEXT_STMT        /stmt     \
	/<no-token>		/ERROR (3)	        /stmt     \

noarg_stmt
	/ ;			/LEX  perform_noarg	        /stmt     \
	/ : ;			/LEX (2)  perform_noarg     /stmt     \
	/ : <any-token>		/ERROR (6) NEXT_STMT        /stmt     \
	/ : <no-token>		/ERROR (3) LEX	        /stmt     \
	/<any-token>		/ERROR (4) NEXT_STMT        /stmt     \
	/<no-token>		/ERROR (3)	        /stmt     \


ADN_list	/<seg_name> ,		/[an.n_an = an.n_an + 1;
				  if an.n_an > an.max_size
				  then call ERROR (13);
				  else an.syn (an.n_an) = token_value]
				 LEX (2)		        
						        /ADN_list \
	/<seg_name> ;		/[an.n_an = an.n_an + 1;
				  if an.n_an > an.max_size
				  then call ERROR (13);
				  else an.syn (an.n_an) = token_value]
				 NEXT_STMT	        /stmt     \
	/<seg_name>		/ERROR (7)   NEXT_STMT      /stmt     \
	/<long_name> ,		/ERROR (8)   LEX(2)	        /ADN_list \
	/<long_name> ;		/ERROR (8)   NEXT_STMT      /stmt     \
	/<any-token>		/ERROR (2)   NEXT_STMT      /stmt     \
	/<no-token>		/ERROR (3)	        /stmt     \


ORD_list	/<long_name> ,		/[if segname_too_long
				  then call ERROR (8);
				  else arg_count = arg_count + 1]
				 LEX (2)		        /ORD_list \
	/<long_name> ;		/[if segname_too_long
				  then call ERROR (8);
				  else arg_count = arg_count + 1]
				 perform_order NEXT_STMT    /stmt     \
	/<long_name> 		/[if segname_too_long
				  then call ERROR (8);
				  else call ERROR (7)]
				  NEXT_STMT	        /stmt     \
	/<any-token>		/ERROR (2) 
				 [if arg_count > 0 then do;
				    ARG_list_error = "1"b;
				    call perform_order ();
				  end]	NEXT_STMT	        /stmt     \
	/<no-token>		/ERROR (3)
				 [if arg_count > 0 then do;
				    ARG_list_error = "1"b;
				    call perform_order ();
				  end]	NEXT_STMT	        /stmt     \

SEG_list	/<seg_name> ,		/FILL_OPTION_ENTRY
				 LEX (2)		        /SEG_list \
	/<seg_name> ;		/FILL_OPTION_ENTRY
				 GET_OPTION_TOTALS
				 NEXT_STMT	        /stmt     \
	/<long_name> ,		/ERROR (8)   LEX (2)        /SEG_list \
	/<long_name> ;		/ERROR (8)   GET_OPTION_TOTALS
				 NEXT_STMT	        /stmt     \
	/<long_name> 		/[if segname_too_long
				  then call ERROR (8);
				  else call ERROR (7)]
				  NEXT_STMT	        /stmt     \
	/<any-token>		/ERROR (2)   NEXT_STMT      /stmt     \
	/<no-token>		/ERROR (3)	        /stmt     \

ENTRY_list
	/<long_name> ,		/[if ^entryname_too_long
				  then call FILL_OPTION_ENTRY]
				 LEX (2)		        /ENTRY_list\
	/<long_name> ;		/[if ^entryname_too_long
				  then call FILL_OPTION_ENTRY]
				 GET_OPTION_TOTALS
				 NEXT_STMT	        /stmt     \
	/<long_name>		/ERROR (5)  NEXT_STMT       /stmt     \
	/<any-token>		/ERROR (2)  NEXT_STMT       /stmt     \
	/<no-token>		/ERROR (3)	        /stmt     \


++*/
/* format: style3,^indnoniterdo */
%page;
/* Parse Bind File - procedure to go through optional bindfile and extract
the bind parameters from it.

Newly coded by Michael J. Spier, November 23, 1971		*/
/* modified 75.06.24 by M. Weaver to remove no_old_alm keyword */
/* modified 77.08.16 by M. Weaver to add Perprocess_Static keyword */
/* Modified 01/14/81 W. Olin Sibert for new format of input structure, and -force_order */

/* Rewritten 9/20/84 by M.Sharpe to use the reduction compiler, and implement
     the Ignore and Partial_Order statements 
   Modified 01/23/83 by M.Sharpe to correct problem with unrecognized 
     "no_link" attribute on "global" and "Global" statements.
*/

np:
parse_bindfile_:
     proc;

/*  Automatic  */

declare	breaks		char (9) var aligned,
	ignored_breaks	char (6) var aligned,
	lex_delims	char (70) var aligned,
	lex_control_chars	char (70) var aligned,
	Linput		fixed bin (21),
	Linput_ignore	fixed bin (21) init (0),
	(Pfirst_stmt_descriptor, Pfirst_token_descriptor, Pinput, Psegment)
			ptr init (null ());

declare	MYNAME		char (32);
declare	arg_count		fixed bin;
declare	code		fixed bin (35);
declare	(
	ORDER		init (1),
	FORCE_ORDER	init (2),
	PARTIAL_ORDER	init (3)
	)		fixed bin;
declare	order_type	fixed bin init (0);
declare	(i, j, k)		fixed bin;
declare	keyword_idx	fixed bin;
declare	Word_extent	fixed bin init (0);
declare	new_nobj		fixed bin;
declare	obj_idx		fixed bin init (0);
declare	opt_counter	fixed bin;
declare	partial_order_number
			fixed bin init (0);
declare	stmt_error	(17) fixed bin init ((17) (0));

declare	opt_code		char (1);

declare	ARG_list_error	bit (1) init ("0"b);
declare	entryname_too_long	bit (1) init ("0"b);
declare	ignore_seen	bit (1) init ("0"b);
declare	MAX_error		bit (1) init ("0"b);
declare	no_parameters	bit (1);
declare	order_error	bit (1) init ("0"b);
declare	Parameters	bit (1);
declare	segname_too_long	bit (1) init ("0"b);


declare	(arg_ptr, p, p1, inpp, optp, copyp, areap)
			ptr init (null);


/*  Based  */

declare	arg		char (arg_ptr -> token.Lvalue) based (arg_ptr -> token.Pvalue);
declare	1 acc_ope		aligned based (p),		/* like op but uses acc format char) */
	  2 symb_len	fixed bin (9) unsigned unaligned,
	  2 symb		char (256) unaligned,
	  2 code		char (1) aligned,
	  2 lng		fixed bin;

declare	Word		(Word_extent) fixed bin based;
declare	reset		bit (2313) based (p);


/*  Static  */

/* format: off */

declare	1 error_control_table
			(25) internal static options (constant),
	  2 severity	fixed bin (17) init ((8) 3, 1, 2, (12) 3, (3) 1),
	  2 Soutput_stmt	bit (1) unaligned
			init ((4) ("1"b), "0"b, "1"b, "1"b, "0"b, (3) ("1"b), (12) ("0"b), (2) ("1"b)),
	  2 message	char (90) varying init (
/*   1  */ "'^a ' is not a legal keyword.",
/*   2  */ "Invalid parameter.  '^a'",
/*   3  */ "Bindfile ends with an incomplete statement.",
/*   4  */ "Keyword not delimited by colon.  '^a'",
/*   5  */ "Entryname is longer than 255 characters  '^a.'",
/*   6  */ "This statement does not accept parameters.",
/*   7  */ "Improper delimiter after '^a'.",
/*   8  */ "Possible segment name is longer than 32 characters  '^a'.",
/*   9  */ "'indirect:' is an obsolete keyword.
It should be replaced by 'retain:'.",
/*  10  */ "Duplicate statement.  Statement is ignored.",
/*  11  */ "This statement must follow an 'objectname:' statement.",
/*  12  */ "'Order', 'Force_Order', and 'Partial_Order' are mutually exclusive.",
/*  13  */ "Too many addnames supplied.  Maximum of 128 addnames is allowed.",
/*  14  */ "Duplicate objectname statement for ^a.",
/*  15  */ "Objectname ^a repeated in this statement.",
/*  16  */ "Objectname ^a not found in any archive.",
/*  17  */ "Zero-length object ^a mentioned in objectname statement.",
/*  18  */ "Zero-length object ^a mentioned in Order/Force_Order/Partial_Order statement.",
/*  19  */ "Objectname ^a mentioned in 'objectname' statement but not in Force_Order statement",
/*  20  */ "Objectname ^a mentioned both in Ignore and Order/Force_Order/Partial_Order statements.",
/*  21  */ "Objectname ^a mentioned both in Ignore and objectname statements.",
/*  22  */ "Objectname ^a not mentioned in Order statement.",
/*  23  */ "Objectname ^a ignored because of zero bitcount.",
/*  24  */ "'indirect' is an obsolete Global option
It should be replaced by 'retain'.",
/*  25  */ "'indirect' is an obsolete global option
It should be replaced by 'retain'."),
	  2 brief_message	char (1) varying init ((25) (" "));
						/* brief messages aren't used */

/* format: on */

declare	ERROR_OUTPUT	char (12) int static init ("error_output");

declare	(
	Addname_idx	init (1),
	FOrder_idx	init (2),
	Global_idx	init (3),
	Ignore_idx	init (4),
	No_Table_idx	init (5),
	Objectname_idx	init (6),
	Order_idx		init (7),
	POrder_idx	init (8),
	PStatic_idx	init (9),
	delete_idx	init (10),
	global_idx	init (11),
	indirect_idx	init (12),
	no_link_idx	init (13),
	objectname_idx	init (14),
	retain_idx	init (15),
	synonym_idx	init (16),
	table_idx		init (17)
	)		fixed bin;

declare	(
	DUP_stmt		init (10),
	NO_obj		init (11),
	EXCLUSIVE_stmt	init (12),
	DUP_objectname	init (14),
	NO_such_seg	init (16),
	SKIP_stmt		init (99)
	)		fixed bin internal static;

/*  External  */

declare	error_table_$zero_length_seg
			external fixed bin (35);

/*  Builtin  */

declare	(addr, addrel, bin, bit, collate, dimension, divide, fixed, max, null, rel, size, substr)
			builtin;


/*  Entry  */

declare	com_err_		entry () options (variable),
	ioa_$ioa_stream	entry () options (variable),
	lex_string_$lex	entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*),
			char (*), char (*), char (*) var aligned, char (*) var aligned, char (*) var aligned,
			char (*) var aligned, ptr, ptr, fixed bin (35)),
	lex_string_$init_lex_delims
			entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var aligned,
			char (*) var aligned, char (*) var aligned, char (*) var aligned),
	temp_mgr_$reserve	entry (pointer),
	translator_temp_$get_segment
			entry (char (*), ptr, fixed bin (35)),
	translator_temp_$release_all_segments
			entry (ptr, fixed bin (35));


/*  Condition  */

declare	cleanup		condition;
%page;
	on cleanup
	     begin;
		if Psegment ^= null
		then call translator_temp_$release_all_segments (Psegment, code);
		bx_$fatal_error = 1;
	     end;

	if bx_$debug = 1
	then MYNAME = "parse_bindfile_";
	else MYNAME = bx_$caller;
	inpp = bx_$inpp;
	NTOTAL = inp.ntotal;			/* used for allocating copy area */
	NOBJ = inp.nobj;				/* ditto */
	bx_$bound_segname = inp.bound_seg_name;		/* remember in case of abort */
	if inp.bindfilep = null | inp.bindfile_bc = 0
	then do;
	     bx_$optp = null;			/* indicate there are no bind options */
	     bx_$addname = 0;
	     bx_$adnp = null;
	     if ^inp.zeroseg_seen
	     then return;

	     copyp = bx_$freep;			/* allocate area for archive reorder */
	     call temp_mgr_$reserve (addrel (copyp, size (inp)));
						/* allocate with respect to NTOTAL and NOBJ */
	     call CHECK_CONFLICTS;			/* make new structure, removing zero-length segments */
	     return;
	end;


	call translator_temp_$get_segment (MYNAME, Psegment, code);
						/* reduction compiler needs this */
	if code ^= 0
	then do;
	     call com_err_ (code, MYNAME, "Could not get temp segment.  Report to maintainer.");
	     bx_$fatal_error = 1;
	     return;
	end;

	SERROR_CONTROL = "11"b;			/* use long error messages every time */
	call INIT_PARSE;
	if Linput = 0
	then do;
	     call com_err_ (error_table_$zero_length_seg, MYNAME, inp.bindfile_name);
	     goto Return;
	end;

	if bx_$brief = 1
	then MIN_PRINT_SEVERITY = 2;			/* Don't print warnings if -brief was specified.  */

	ignored_breaks = substr (collate, 10, 5) || " ";
	breaks = ignored_breaks || ",:;";
	call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, breaks, ignored_breaks, lex_delims,
	     lex_control_chars);
	call lex_string_$lex (Pinput, Linput, Linput_ignore, Psegment, "1100"b, """", """", "/*", "*/", ";", breaks,
	     ignored_breaks, lex_delims, lex_control_chars, Pfirst_stmt_descriptor, Pfirst_token_descriptor, code);

	Pthis_token = Pfirst_token_descriptor;

	if code ^= 0
	then do;
	     if Pthis_token = null
	     then do;
		if code = error_table_$zero_length_seg
		then call com_err_ (0, MYNAME, "No tokens found in bindfile. ^a", inp.bindfile_name);
		else call com_err_ (code, MYNAME);
		go to Return;
	     end;					/*	     if code = error_table_$no_stmt_delim | code = error_table_$unbalanced_quotes 
	     error messages which can specify the location of the error are printed during the semantic analysis */
	end;

	call SEMANTIC_ANALYSIS ();
Return:
	if Psegment ^= null
	then call translator_temp_$release_all_segments (Psegment, code);
	return;

%page;
/*****************************************************************************/

/*  These 4 entries are auxiliary scanner/lexical routines */

FUNCTIONS:
     proc returns (bit (1) aligned);			/* this entry returns "1"b if a valid parameter has been specified
   to the Global/global keywords; "0"b otherwise.  */

globe_arg:
     entry returns (bit (1) aligned);

	if token_value = "delete" | token_value = "indirect" | token_value = "no_link" | token_value = "retain"
	then return ("1"b);

	else return ("0"b);


/*  This entry returns "1"b if the current token consists of only alphanumeric
    characters allowed in an entryname.  It also performs asemantic function.
    If the token is longer than 32 characters the segname_too_long flag is
    set; if it is longer than 255 characters the entryname_too_long flag is
    also set.  This reduces the number of reductins necessary for parsing the
    bindfile.  */

long_name:
     entry returns (bit (1) aligned);

	segname_too_long, entryname_too_long = "0"b;


	if token.Lvalue > 32
	then segname_too_long = "1"b;
	if token.Lvalue > 255
	then entryname_too_long = "1"b;

	return ("1"b);


/*  This entry returns "1"b if the current token is an appropriate segment name */

seg_name:
     entry returns (bit (1) aligned);

	segname_too_long = "0"b;

	if token.Lvalue > 32
	then do;
	     segname_too_long = "1"b;
	     call ERROR (8);
	     return ("0"b);
	end;

	return ("1"b);


/*  This entry determines if the current token is a valid keyword.  If so
    keyword_idx is set accordingly; otherwise, keyword_idx is set to 0 and
    "0"b is returned.  Some semantic analysis is also perfomed here.  If a
    token is recognized as a keyword, but one whose presence in the
    bindfile constitues a semantic error, e.g., duplicate master keyword,
    the proper error message is issued here and "0"b is returned.  The
    reduction routine ignores the entire statement if "0"b is returned; it
    issues errors only if keyword_idx is set to 0.   */

keyword:
     entry () returns (bit (1) aligned);

	if token_value = "Addname"
	then keyword_idx = Addname_idx;
	else if token_value = "Force_Order"
	then keyword_idx = FOrder_idx;
	else if token_value = "Global"
	then keyword_idx = Global_idx;
	else if token_value = "Ignore"
	then keyword_idx = Ignore_idx;
	else if token_value = "No_Table"
	then keyword_idx = No_Table_idx;
	else if token_value = "Objectname"
	then keyword_idx = Objectname_idx;
	else if token_value = "Order"
	then keyword_idx = Order_idx;
	else if token_value = "Partial_Order"
	then keyword_idx = POrder_idx;
	else if token_value = "Perprocess_Static"
	then keyword_idx = PStatic_idx;
	else if token_value = "delete"
	then keyword_idx = delete_idx;
	else if token_value = "global"
	then keyword_idx = global_idx;
	else if token_value = "indirect"
	then keyword_idx = indirect_idx;
	else if token_value = "no_link"
	then keyword_idx = no_link_idx;
	else if token_value = "objectname"
	then keyword_idx = objectname_idx;
	else if token_value = "retain"
	then keyword_idx = retain_idx;
	else if token_value = "synonym"
	then keyword_idx = synonym_idx;
	else if token_value = "table"
	then keyword_idx = table_idx;
	else return ("0"b);

	if stmt_error (keyword_idx) = 0
	then return ("1"b);
	else if stmt_error (keyword_idx) = SKIP_stmt
	then return ("0"b);				/* Skip these silently */

	call ERROR (stmt_error (keyword_idx));
	return ("0"b);


     end FUNCTIONS;

%page;
/*****************************************************************************/

/*  The following are the semantic analysis routines.  The entries beginning
    with "Addname" up to "table" correspond to bindfile keywords.  Others are
    auxiliary routines.  */

ACTION:
     proc;


perform_order:
     entry ();

	if keyword_idx = Order_idx
	then call Order ();
	else if keyword_idx = FOrder_idx
	then call Force_Order ();
	else if keyword_idx = POrder_idx
	then call Partial_Order ();
	else if keyword_idx = Ignore_idx
	then call Ignore ();

	else ;					/* should never happen */
	return;


perform_noarg:
     entry ();

	if keyword_idx = No_Table_idx
	then call No_Table ();
	else if keyword_idx = PStatic_idx
	then call Perprocess_Static ();
	else if keyword_idx = table_idx
	then call table ();

	return;


Addname:
     entry ();


	stmt_error (Addname_idx) = DUP_stmt;
	Parameters = "1"b;
	bx_$addname = 1;

	return;


Force_Order:
     entry ();

	stmt_error (FOrder_idx) = DUP_stmt;		/* Don't use this again */
	stmt_error (Order_idx) = EXCLUSIVE_stmt;	/* And this one is mutually exclusive with Force_Order */
	stmt_error (POrder_idx) = EXCLUSIVE_stmt;	/* ... and so's this one */

	order_type = FORCE_ORDER;
	call REORDER_ARCHIVE ();

	return;


Global:
     entry ();

	stmt_error (Global_idx) = DUP_stmt;
	if token_value = "delete"
	then g_delete = "d";			/* This scheme was kept from the original program */
	else if token_value = "retain"
	then g_retain = "r";			/* because it is integral to other parts of the */
	else if token_value = "no_link"
	then g_nolink = "l";			/* binder software */
	else if token_value = "indirect"
	then do;
	     call ERROR (24);
	     g_indirect = "i";
	end;
	else do;
	     call ERROR (2);
	     return;
	end;

	Parameters = "1"b;

	return;


Ignore:
     entry ();

/*  The reduction routine checks the syntax of the "Ignore" statement;
	     if it's OK, it sets arg_ptr to the addr of the 1st parameter and arg_count
	     to the number of parameters.  Because the parameters are separated by commans,
	     every other token is skipped when getting the next parameter */

	stmt_error (Ignore_idx) = DUP_stmt;
	ignore_seen = "1"b;
	p1 = Pthis_token;				/* save it */
	Pthis_token = arg_ptr;			/* allows the correct component names to appear in
						   the error messages in the followin loop */


	do i = 1 to arg_count;			/* Lookup input structure to match parameter */

	     if arg_ptr -> token.Lvalue > 32
	     then goto next_ignore_arg;

	     do j = 1 to bx_$ncomp;
		p = addr (inp.obj (j));
		if obj.filename = arg
		then goto ignore_it;
	     end;

	     call ERROR (NO_such_seg);		/* the segment is not among the components specified by user */
	     goto next_ignore_arg;

ignore_it:
	     if (obj.to_be_ignored & obj.bitcount ^= 0)
	     then do;				/* Duplicated in Ignore statement */
		call ERROR (15);
		goto next_ignore_arg;
	     end;

	     obj.to_be_ignored = "1"b;
next_ignore_arg:
	     Pthis_token, arg_ptr = arg_ptr -> token.Pnext -> token.Pnext;
						/* skip the delimiter between two args */
						/* see opening comments for ignore */
	end;
	Pthis_token = p1;				/* restore to end of Ignore stmt */

	return;


No_Table:
     entry ();

/*  The option table entries are filled by FILL_OPTION_ENTRY by the
	     reduction routine after we return from here.   */

	stmt_error (No_Table_idx) = DUP_stmt;
	option.g_notable = "t";
	no_parameters = "0"b;
	return;


Objectname:
     entry ();

	stmt_error (Objectname_idx) = DUP_stmt;
	if token.Lvalue > 32
	then call ERROR (8);
	else bx_$bound_segname = token_value;

	return;


Order:
     entry ();

	stmt_error (Order_idx) = DUP_stmt;
	stmt_error (FOrder_idx) = EXCLUSIVE_stmt;
	stmt_error (POrder_idx) = EXCLUSIVE_stmt;

	if bx_$force_order ^= 0
	then order_type = FORCE_ORDER;		/* Order becomes Force_Order if -force_order
							   is specified in the command line */
	else order_type = ORDER;
	call REORDER_ARCHIVE ();

	return;


Partial_Order:
     entry ();

	stmt_error (POrder_idx) = DUP_stmt;
	stmt_error (FOrder_idx) = EXCLUSIVE_stmt;
	stmt_error (Order_idx) = EXCLUSIVE_stmt;

	order_type = PARTIAL_ORDER;
	call REORDER_ARCHIVE ();

	return;


Perprocess_Static:
     entry ();

	stmt_error (PStatic_idx) = DUP_stmt;
	bx_$perprocess_static = 1;
	Parameters = "1"b;
	return;


delete:
     entry ();

/*  The option table entries are filled by FILL_OPTION_ENTRY by the
	     reduction routine after we return from here.   */

	stmt_error (delete_idx) = DUP_stmt;
	opt_counter = 0;
	opt_code = "d";
	no_parameters = "0"b;
	return;


global:
     entry ();

	stmt_error (global_idx) = DUP_stmt;
	if token_value = "delete"
	then op.delete = "d";
	else if token_value = "retain"
	then op.retain = "r";
	else if token_value = "no_link"
	then op.no_link = "l";
	else if token_value = "indirect"
	then do;
	     call ERROR (25);
	     op.indirect = "i";
	end;
	else do;
	     call ERROR (2);
	     return;
	end;

	no_parameters = "0"b;

	return;


indirect:
     entry ();

/*  The option table entries are filled by FILL_OPTION_ENTRY by the
	     reduction routine after we return from here.   */

	stmt_error (indirect_idx) = DUP_stmt;
	if bx_$brief = 0
	then call ERROR (9);			/* This is an obsolete keyword; it now functions like "retain" */
	opt_counter = 0;
	opt_code = "i";
	no_parameters = "0"b;
	return;


no_link:
     entry ();

/*  The option table entries are filled by FILL_OPTION_ENTRY by the
	     reduction routine after we return from here.   */

	stmt_error (no_link_idx) = DUP_stmt;
	opt_counter = 0;
	opt_code = "l";
	no_parameters = "0"b;
	return;


objectname:
     entry ();

	stmt_error (objectname_idx) = 0;
	call CLOSE_ENTRY;				/* start a new option table entry, etc. */

	if segname_too_long
	then do;
	     call ERROR (8);
	     goto skip_objname;
	end;
	do obj_idx = 1 to bx_$ncomp;
	     if token_value = inp.obj (obj_idx).filename
	     then go to OPEN_ENTRY;
	end;
	call ERROR (NO_such_seg);

	goto skip_objname;

OPEN_ENTRY:
	if inp.obj (obj_idx).bitcount = 0
	then do;
	     call ERROR (17);			/* zero-length segs can't be specified in any statements */
	     goto skip_objname;
	end;

	if inp.obj (obj_idx).option ^= "0"b
	then do;					/* Another objectname statement for this obj specified earlier */
	     call ERROR (DUP_objectname);
skip_objname:					/* Ignore any attributes pertaining to this rejected */
	     stmt_error (delete_idx),			/*   objectname.  The errors cause the corresponding */
		stmt_error (global_idx),		/*   statements to be ignored (See keyword FUNCTION) */
		stmt_error (indirect_idx),		/*   until the next objectname statement is seen */
		stmt_error (no_link_idx),		/*   when all are reset to 0  */
		stmt_error (retain_idx), stmt_error (synonym_idx), stmt_error (table_idx) = SKIP_stmt;

	     return;
	end;

	op.n_retain, op.n_indirect, op.n_nolink, op.n_options, op.n_synonyms, op.n_delete = 0;
						/* reset structure */
	op.table, op.retain, op.indirect, op.no_link, op.delete = " ";
						/* ... */
	inp.obj (obj_idx).objectname_stmt = "1"b;	/* Now it cannot be Ignore'd or omitted
						   from Order / Force_Order lists */
	no_parameters = "1"b;			/* indicate no params specified yet */

	stmt_error (delete_idx) = 0;			/* reset errors for attribute statements, since any errors */
	stmt_error (global_idx) = 0;			/*   were for previous object and we've got a new one now */
	stmt_error (indirect_idx) = 0;
	stmt_error (no_link_idx) = 0;
	stmt_error (retain_idx) = 0;
	stmt_error (synonym_idx) = 0;
	stmt_error (table_idx) = 0;


/* put objectname into structure, tag it as synonym */

	opt_counter = 0;
	opt_code = "s";				/* pretend it's a synonym */
	call FILL_OPTION_ENTRY;
	op.n_synonyms = 1;

	return;


retain:
     entry ();

/*  The option table entries are filled by FILL_OPTION_ENTRY by the
	     reduction routine after we return from here.   */

	stmt_error (retain_idx) = DUP_stmt;
	opt_counter = 0;
	opt_code = "r";
	no_parameters = "0"b;
	return;

synonym:
     entry ();

/*  The option table entries are filled by FILL_OPTION_ENTRY by the
	     reduction routine after we return from here.   */

	stmt_error (synonym_idx) = DUP_stmt;
	opt_counter = 0;
	opt_code = "s";
	no_parameters = "0"b;
	return;


table:
     entry ();

	stmt_error (table_idx) = DUP_stmt;
	op.table = "t";
	no_parameters = "0"b;
	return;


REORDER_ARCHIVE:
     entry ();

/*  The argument processing is same as Ignore */

	k = 0;
	order_error = ARG_list_error;
	p1 = Pthis_token;				/* save it */
	Pthis_token = arg_ptr;			/*  This will allow the correct component name to be 
						    printed in error messages inside this loop */

	do i = 1 to arg_count;			/* Lookup input structure to match parameter */

	     if arg_ptr -> token.Lvalue > 32
	     then goto next_arg;
	     do j = 1 to bx_$ncomp;
		p = addr (inp.obj (j));
		if obj.filename = arg
		then goto match_found;
	     end;

	     call ERROR (NO_such_seg);
	     order_error = "1"b;
	     goto next_arg;

match_found:
	     if obj.flag = "1"b
	     then do;				/* repeated in order-ing statement */
		call ERROR (15);
		order_error = "1"b;
		goto next_arg;
	     end;

	     if obj.bitcount = 0
	     then do;				/* zero-length obj has no business here */
		call ERROR (18);
		order_error = "1"b;
		goto next_arg;
	     end;

	     obj.flag = "1"b;
	     k = k + 1;				/* increment index */
	     obj.new_order = k;			/* remember the new order index */
next_arg:
	     arg_ptr, Pthis_token = arg_ptr -> token.Pnext -> token.Pnext;
						/* skip the delimiter between two args */
	end;

	Pthis_token = p1;				/* restore to end of the Order stmt */

	if order_type = PARTIAL_ORDER
	then partial_order_number = k;		/* the number of objects so far "ordered".  The rest will be
						   given order numbers, beginning with partial_order_number +1,
						   in the order they appear in the input structure */

	if order_error
	then bx_$fatal_error = 1;
	return;


FILL_OPTION_ENTRY:
     entry ();

	opt_counter = opt_counter + 1;
	op.n_options = op.n_options + 1;
	p = addr (op.opes (op.n_options));
	reset = "0"b;				/* want trailer nulls instead of blanks */
	acc_ope.symb_len = token.Lvalue;
	substr (acc_ope.symb, 1, token.Lvalue) = token_value;
	acc_ope.code = opt_code;
	acc_ope.lng = token.Lvalue + 1;

	return;

GET_OPTION_TOTALS:
     entry ();

/* routine to set the counter for the particular option */

	if keyword_idx = no_link_idx
	then n_nolink = n_nolink + opt_counter;
	else if keyword_idx = indirect_idx
	then n_indirect = n_indirect + opt_counter;
	else if keyword_idx = retain_idx
	then n_retain = n_retain + opt_counter;
	else if keyword_idx = delete_idx
	then n_delete = n_delete + opt_counter;
	else if keyword_idx = synonym_idx
	then n_synonyms = n_synonyms + opt_counter;	/*	 else;		should never happen.  */

	return;



epilogue:
     entry ();

	call CLOSE_ENTRY;
	if order_type > 0 | ignore_seen | zeroseg_seen
	then call CHECK_CONFLICTS;

	if MERROR_SEVERITY > 2
	then do;
	     bx_$fatal_error = 1;
	     return;
	end;

	if Parameters = "0"b
	then do;
	     bx_$adnp = null;			/* ... */
	     bx_$addname = 0;			/* ... */
	     Word_extent = fixed (rel (optp), 18) - fixed (rel (areap), 18) + 128;
	     areap -> Word (*) = 0;			/* reset allocated table area  */
	end;

	call temp_mgr_$reserve (addr (op.opes (opt_counter + 1)));
						/* Mark the extent of the option table */
	return;


CLOSE_ENTRY:
     entry ();

	stmt_error (delete_idx),			/* These statements can't appear again BEFORE */
	     stmt_error (global_idx),			/*    the next objectname stmt */
	     stmt_error (indirect_idx), stmt_error (no_link_idx), stmt_error (retain_idx), stmt_error (synonym_idx),
	     stmt_error (table_idx) = NO_obj;


	if no_parameters
	then /* virgin entry */
	     do;
	     if obj_idx ^= 0
	     then inp.obj (obj_idx).option = "0"b;	/* reset option pointer */
	     return;
	end;

	if obj_idx ^= 0
	then inp.obj (obj_idx).option = bit (bin (fixed (rel (optp), 18) - fixed (rel (areap), 18), 18), 18);
	Parameters = "1"b;
	no_parameters = "1"b;			/* indicate no objectname parameters */
	if op.n_options = 1
	then do;					/* No options; just the objectname used as synonym.  */
	     op.n_options, op.n_synonyms, op.n_options = 0;
	end;
	if obj_idx > 0
	then optp = addr (op.opes (op.n_options + 1));	/* prepare pointer to next option structure */
	obj_idx = 0;

	return;

%page;
/*
 *   It is the responsibility of this routine to examine the inp structure,
 *   verifying that the Ignore, Order, Force_Order and Partial_Order
 *   statements have been used in a consistent fashion.
 *   If no errors are detected, a new copy of the inp structure
 *   is built (in the area reserved and pointed to by copyp) and the
 *   desired objectnames are placed in the new structure, in the
 *   desired order.
 *
 *   It is assumed that the caller has already checked the ignore, order and
 *   zeroseg_seen flags, so this routine is not called when it is not needed.
 */

CHECK_CONFLICTS:
     entry ();

declare	erring_token_value	char (32);


	j = 0;					/*  reset index that is used if no Order-ing statements in bindfile   */

	new_nobj = 0;				/*   reset counter of kept object segments   */

	do i = 1 to bx_$ncomp;			/*   examine every objectname known, looking for errors   */

	     p = addr (inp.obj (i));
	     erring_token_value = obj.filename;

	     if obj.bitcount = 0 /* Warn about zero-lengt segs except where . . . */
		& obj.new_order = 0 /* 1) there's a coflict with order (already handled) */
		& ^obj.objectname_stmt /* 2) there's a conflict with objectname stmt (ditto) */ & bx_$brief = 0
	     then do;				/* 3) they've asked us to keep quiet */
		MERROR_SEVERITY = max (1, MERROR_SEVERITY);
		call ioa_$ioa_stream (ERROR_OUTPUT, "^/WARNING 23^/" || error_control_table.message (23) || "^/",
		     erring_token_value);
	     end;

	     else if obj.to_be_ignored
	     then do;				/* appeared in Ignore stmt */
		if obj.new_order > 0
		then do;				/* ... AND some order stmt */
		     MERROR_SEVERITY = 3;
		     call ioa_$ioa_stream (ERROR_OUTPUT,
			"^/ERROR 20 SEVERITY 3^/" || error_control_table.message (20) || "^/", erring_token_value);
		end;

		if obj.objectname_stmt
		then do;				/* ... AND/OR in an objectname stmt */
		     MERROR_SEVERITY = 3;
		     call ioa_$ioa_stream (ERROR_OUTPUT,
			"^/ERROR 21 SEVERITY 3^/" || error_control_table.message (21) || "^/", erring_token_value);
		end;


	     end;
	     if order_type = FORCE_ORDER & obj.objectname_stmt /* obj was in an objectname stmt... */
		& obj.new_order = 0			/*    but not in the Force_Order stmt */
	     then do;
		MERROR_SEVERITY = 3;
		call ioa_$ioa_stream (ERROR_OUTPUT,
		     "^/ERROR 19 SEVERITY 3^/" || error_control_table.message (19) || "^/", erring_token_value);
	     end;

	     if order_type = ORDER & obj.new_order = 0 /* object not in Order stmt ... */ & ^obj.to_be_ignored
						/*   and had no excuse for not being there */
	     then do;
		MERROR_SEVERITY = 3;
		call ioa_$ioa_stream (ERROR_OUTPUT,
		     "^/ERROR 22 SEVERITY 3^/" || error_control_table.message (22) || "^/", erring_token_value);
	     end;

	     if order_type = PARTIAL_ORDER & ^obj.to_be_ignored & obj.new_order = 0
						/* objects not in Partial_Order stmt ... */
	     then do;				/*   will be assigned orders as we catch them */
		partial_order_number = partial_order_number + 1;
		obj.new_order = partial_order_number;
	     end;

/*
	 *   Assign an order to this module if we had no
	 *   type of Order statement and if this module is
	 *   not to be ignored.
	 */

	     if order_type = 0 & ^obj.to_be_ignored
	     then do;				/*   assign an order index to this not-to-be-ignored object   */
		j = j + 1;
		obj.new_order = j;
	     end;

	     if obj.new_order > 0
	     then new_nobj = new_nobj + 1;
	end;

/*   Now we can fill in the copy of the inp structure and switch pointers, if there were no errors.   */

	if MERROR_SEVERITY < 3
	then do;
	     Word_extent = fixed (fixed (rel (addr (inp.obj (1).filename)), 18) - fixed (rel (inpp), 18), 18);
						/* get size of input structure */
	     copyp -> Word (*) = inpp -> Word (*);	/* copy input structure */

	     do i = 1 to bx_$ncomp;
		p = addr (inp.obj (i).filename);
		if obj.new_order > 0
		then do;
		     p1 = addr (copyp -> inp.obj (obj.new_order).filename);
		     p1 -> obj = p -> obj;
		end;
	     end;

	     bx_$ncomp, copyp -> inp.nobj = new_nobj;
	     inpp, bx_$inpp = copyp;

	end;

	return;

     end ACTION;
%page;

/**************************************************************************************************************************/
INIT_PARSE:
     proc ();


	Pinput = inp.bindfilep;			/* copy pointer to bindfile */

	Linput = divide (inp.bindfile_bc + 8, 9, 17, 0);	/* compute length in characters */
	Parameters = "0"b;
	no_parameters = "1"b;

	copyp = bx_$freep;				/* allocate area for possible archive reorder */
	call temp_mgr_$reserve (addrel (copyp, size (inp)));
						/* allocate with respect to NTOTAL and NOBJ */

	adnp, bx_$adnp = bx_$freep;			/* beginning of addname table */
	call temp_mgr_$reserve (addrel (adnp, (bx_$addname_limit + 2) * 9));
						/* reserve table */
	an.n_an = 0;
	an.max_size = bx_$addname_limit;

	areap, bx_$optp = bx_$freep;			/* beginning of option table */
						/* we shouldn't run off the end of the temp seg by th time the option table 
				   is full.  The temp area for the table is "reserved (actually marked) 
				   before we leave, i.e., when we KNOW how much space is needed. */

/* initialize various variables */

	g_notable, g_retain, g_indirect, g_nolink, g_delete = " ";
						/* reset options structure */
	optp = addr (option.structures);		/* pointer to first structure */

	stmt_error (delete_idx),			/* Can't have any of these stmts until AFTER the next objectname stmt */
	     stmt_error (global_idx), stmt_error (indirect_idx), stmt_error (no_link_idx), stmt_error (retain_idx),
	     stmt_error (synonym_idx), stmt_error (table_idx) = NO_obj;

	if bx_$force_order = 1
	then stmt_error (POrder_idx) = EXCLUSIVE_stmt;	/* if -forcer_order specified on cmmand line, "Order" is "translated" to
					   Force_Order; Partial_Order,however, is not allowed in the bindfile */
	return;

     end INIT_PARSE;

/*	  The binder include files (1:4) and the code generated
		 by the reduction compiler follows.		   */

%page;
%include binder_input;
%page;
%include option;
%page;
%include bndtbl;
%page;
%include bindext;
%page;




		    rebuild_object_.pl1             07/16/86  1217.0rew 07/16/86  0846.5      143811



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


/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and readability, changed errnameto use the
     caller-supplied name instead of "binder_", changed to call
     regenerate_all_links_ after normal resolution to pick up any *system links
     not already regenerated, and to remove obsolete nonstandard object
     support.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/**********************************************************************/
/*							*/
/*	Name:	rebuild_object_				*/
/*	Input:	compent_ptr				*/
/*	Function:	given a pointer to the component table entry for	*/
/*		a given input object segment (compent_ptr),	*/
/*		relocate the text section for that component,	*/
/*		resolving all referenced links in the process,	*/
/*		regenerate any unreferenced *system links.	*/
/*		Then relocate the linkage section.  Finally, we	*/
/*		relocate any external references within the	*/
/*		symbol section by generating a repatch table	*/
/*		entry for it and then attempting to resolve the	*/
/*		link.					*/
/*	Output:	none.					*/
/*							*/
/**********************************************************************/

/* Designed and initially coded by Michael J. Spier, September 30, 1970 */
/* modified 75.06.20 by M. Weaver for separate static */
/* modified 77.10.21 by M. Weaver to regenerate links when there is no text */
/* modified Dec 1978 by David Spector to make repatch table automatically extensible */
/* Modified 01/15/81 W. Olin Sibert to remove red shifts */
/* Modified September 82 JMAthane to relocate links referenced by symbol tables */

rebuild_object_:
     procedure (compent_ptr);

declare	compent_ptr	pointer;



/* DECLARATION OF EXTERNAL ENTRIES */

declare	regenerate_all_links_
			external entry (pointer);
declare	decode_link_	external entry (pointer) returns (bit (1) aligned);
declare	get_relinfo_	external entry (pointer);
declare	get_relinfo_$init	external entry (pointer);
declare	ext_link_		external entry (pointer);
declare	generate_def_	external entry (pointer, pointer);
declare	int_link_		external entry (pointer) returns (bit (1) aligned);
declare	com_err_		external entry options (variable);
declare	temp_mgr_$allocate	ext entry (fixed bin);
declare	temp_mgr_$reserve	external entry (pointer);

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	(textbase, defbase, intbase)
			pointer internal static initial (null);
declare	TRUE		bit (1) static options (constant) init ("1"b);
declare	FALSE		bit (1) static options (constant) init ("0"b);
declare	PR4		bit (3) static options (constant) init ("4"b3);
declare	LDA_INSTR		bit (9) static options (constant) init ("235"b3);
declare	INDIRECT_TM	bit (2) static options (constant) init ("01"b);
declare	INDIRECT_TD	bit (4) static options (constant) init (""b);

declare	SPECIAL_CASE	(4) bit (18) aligned static options (constant) init ("551"b3,
						/* stba */
			"552"b3,			/* stbq */
			"751"b3,			/* stca */
			"752"b3);			/* stcq */
declare	errname		char (16) aligned internal static;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	(i, textoffset, intoffset, int_reloc_offset, symboffset, textend, val, lng, intlimit, relocate)
			fixed bin (18);
declare	(wordp, argp, extp, sp, p, intp)
			pointer;
declare	(textptr, defptr)	pointer;
declare	opcode		bit (18) aligned;

declare	1 ext		aligned like external_ref;	/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, fixed, hbound, null, size)
			builtin;

/* DECLARATION OF BASED STRUCTURES */

declare	1 word		aligned based (wordp),
	  2 lhe18		bit (18) unaligned,
	  2 rhe18		bit (18) unaligned;
declare	1 instr		aligned based,
	  2 lp		bit (3) unaligned,
	  2 lp_offset	bit (15) unaligned,
	  2 op_code	bit (9) unaligned,
	  2 op_code_extension
			bit (1) unaligned,
	  2 inhibit	bit (1) unaligned,
	  2 use_pr	bit (1) unaligned,
	  2 tm		bit (2) unaligned,
	  2 td		bit (4) unaligned;
declare	1 word_instr	aligned based (wordp) like instr;
declare	internal_static	(lng) fixed bin based (p);


/*  */
	ctp = bx_$ctp;
	ext.compent_ptr, ctep = compent_ptr;		/* copy argument into stack for efficiency */

	val = 0;					/* reset conversion variable */
	extp = addr (ext);				/* get address of external ref structure */



	call get_relinfo_$init (comp.crltp);		/* initialize relocation bit scanner */

	argp = addr (ext.offset);
	textoffset = comp.crelt;			/* get relocation value for text section */
	intoffset = comp.creli;			/* copy relocation value for internal static */
	symboffset = comp.crels;			/* copy relocation value for symbol section */
	textptr = addrel (textbase, textoffset);	/* compute pointer to text section */
	textend = comp.clngt;			/* and get length of section */
	int_reloc_offset = intoffset;
	if comp.separate_static = 0
	then intlimit = comp.clngi + 8;		/* offset of links within linkage sectioon */
	else do;
	     intlimit = 8;				/* sep static doesn't have relocation bits */
	     if bx_$bound_sep_stat = 0
	     then int_reloc_offset = int_reloc_offset + 8;/* in this case, refs to static are shifted to link */
	end;
	defptr = comp.cdefp;			/* copy pointer to definition section */

	ext.section = "text";			/* indicate referencing section */

	if comp.clngt = 0
	then /* no text to relocate; regenerate links anyway */
	     goto copy_unresolved_links;

	ext.dont_relocate = "0"b;

relocate_text:
	call get_relinfo_ (argp);			/* get next non-absolute relocation code */
	if ext.relinfo = "overflow"
	then goto copy_unresolved_links;
	if ext.offset >= textend
	then goto copy_unresolved_links;		/* end of text section */

/* First process text-to-text references  */

	ext.ref_ptr, wordp = addrel (textptr, ext.offset);/* compute pointer to specified word */
	if ext.side = "lhe"
	then relocate = fixed (word.lhe18, 18);
	else relocate = fixed (word.rhe18, 18);

	if ext.relinfo = "text    "
	then /* relocate by text relocation counter */
	     do;
	     relocate = relocate + textoffset;
	     goto restore_text;
	end;

/* Now process references to the linkage section */

	else if ext.relinfo = "lnk18   "
	then do;
	     ext.loffset = relocate;
	     if decode_link_ (extp) = "1"b
	     then goto error_skip;
	     call ext_link_ (extp);
	     goto relocate_text;
	end;

	else if ext.relinfo = "int18   "
	then do;
	     relocate = relocate + int_reloc_offset;
	     goto restore_text;
	end;

	else if ext.relinfo = "symb    "
	then do;
	     relocate = relocate + symboffset;
	     goto restore_text;
	end;

	else if ext.relinfo = "int15   "
	then do;
	     if ext.side ^= "lhe"
	     then do;
wrong_halfword:
		call com_err_ (0, errname, "relocation ^a illegal for right half of word ^o in text of ^a",
		     ext.relinfo, ext.offset, comp.filename);
		goto error_skip;
	     end;
	     relocate = fixed (word_instr.lp_offset, 15);
	     relocate = relocate + int_reloc_offset;
	     word_instr.lp_offset = bit (bin (relocate, 15), 15);
	     goto relocate_text;
	end;

	else if ext.relinfo = "lnk15   "
	then do;
	     if ext.side ^= "lhe"
	     then goto wrong_halfword;
	     if word_instr.use_pr ^= "1"b
	     then do;
illegal_link15:
		call com_err_ (0, errname, "illegal instruction format word ^o in text of ^a", ext.offset,
		     comp.filename);
		goto error_skip;
	     end;
	     opcode = word_instr.op_code;
	     do i = 1 to 4;
		if opcode = SPECIAL_CASE (i)
		then goto illegal_link15;
	     end;
	     if word_instr.tm = "10"b
	     then goto illegal_link15;		/* indirect and tally */
	     if word_instr.tm ^= "11"b
	     then /* indirect then index is OK */
		if word_instr.td ^= "0000"b
		then goto illegal_link15;
	     ext.loffset = fixed (word_instr.lp_offset, 15);
	     ext.dont_prelink = "0"b;
	     if decode_link_ (extp) = "1"b
	     then goto error_skip;
	     if ext.trap ^= "0"b
	     then if bin (ext.type, 18) ^= 6
		then ext.dont_prelink = "1"b;		/* trap is just offset of init struc for type 6 */
						/* if link target is found, trapping isn't necessary */

	     if int_link_ (extp) = "1"b
	     then goto relocate_text;
	     call ext_link_ (extp);
	     goto relocate_text;
	end;

	else if ext.relinfo = "negtext "
	then do;
	     relocate = -1;
	     if ext.side = "lhe"
	     then addr (relocate) -> word.rhe18 = word.lhe18;
	     else addr (relocate) -> word.rhe18 = word.rhe18;
	     relocate = relocate + textoffset;
	     goto restore_text;
	end;

	else if ext.relinfo = "def     "
	then do;
	     p = comp.insymentp;
	     do i = 1 to p -> insym.n_insyms - 1;	/* try to find def being referenced */
		if p -> entry (i).def_offset = relocate
		then do;				/* have matching def */
		     call generate_def_ (ctep, addr (p -> insym.entry (i)));
						/* this def has to be regenerated */
		     if ext.side = "lhe"
		     then word.lhe18 = comp.current_def;
		     else word.rhe18 = comp.current_def;
		     goto relocate_text;
		end;
	     end;
	     call com_err_ (0, errname, "def|^o referenced by text|^o of ^a^/^-is not the beginning of a definition",
		relocate, ext.offset, comp.filename);
	     goto error_skip;
	end;

	else if ext.relinfo = "selfrel "
	then goto relocate_text;			/* treat self-relative as absolute */

	call com_err_ (0, errname, "relocation ^a illegal for word ^o in text of ^a", ext.relinfo, ext.offset,
	     comp.filename);

error_skip:
	bx_$fatal_error = 1;
	goto relocate_text;

restore_text:
	if ext.side = "lhe"
	then word.lhe18 = addr (relocate) -> word.rhe18;
	else word.rhe18 = addr (relocate) -> word.rhe18;
	goto relocate_text;

copy_unresolved_links:
	call regenerate_all_links_ (ctep);		/* regenerate all links not already covered */

	lng = comp.clngi;				/* get length of internal static section */
	if lng = 0
	then goto relocate_symbol;			/* no internal static for this component */
	intp = addrel (bx_$tintp, intoffset);		/* pointer to new IS location */
	intp -> internal_static = comp.cstatp -> internal_static;
	if intlimit = 8
	then goto relocate_symbol;			/* there's nothing in linkage to relocate  */

	call get_relinfo_$init (comp.crllp);		/* initiate search of rel_link */
relocate_linkage:
	call get_relinfo_ (argp);
	if ext.relinfo = "overflow"
	then goto relocate_symbol;
	if ext.offset < 8
	then goto relocate_linkage;
	if ext.offset >= intlimit
	then goto relocate_symbol;
	wordp = addrel (intp, ext.offset - 8);		/* pointer to relocatable word */
	if ext.side = "lhe"
	then relocate = fixed (word.lhe18, 18);
	else relocate = fixed (word.rhe18, 18);

	if ext.relinfo = "text    "
	then do;
	     relocate = relocate + textoffset;
	     goto restore_linkage;
	end;

	else do;
	     call com_err_ (0, errname, "relocation ^a illegal for word ^o in linkage of ^a", ext.relinfo, ext.offset,
		comp.filename);
	     bx_$fatal_error = 1;
	     goto relocate_linkage;
	end;

restore_linkage:
	if ext.side = "lhe"
	then word.lhe18 = addr (relocate) -> word.rhe18;
	else word.rhe18 = addr (relocate) -> word.rhe18;
	goto relocate_linkage;


relocate_symbol:
	sp = comp.csymp;
	ext.section = "symb";
	call get_relinfo_$init (comp.crlsp);
	lng = comp.clngns;
	ext.offset = 0;
	do while (ext.offset <= lng);			/* relocate symbol tree */
	     call get_relinfo_ (argp);		/* get next relocation code */
	     if ext.relinfo = "overflow"
	     then goto done;
	     if ext.offset > lng
	     then goto done;			/* get_relinfo_ doesn't know about removal of symbtree */
	     val = 0;
	     if ext.relinfo ^= "lnk18   "
	     then goto skip_this;			/* check only for external refs */
	     wordp = addrel (sp, ext.offset);
	     if ext.side = "lhe"
	     then addr (val) -> word.rhe18 = word.lhe18;
	     else addr (val) -> word.rhe18 = word.rhe18;
	     rptp = bx_$last_rptp;
	     i, rpt.npt = rpt.npt + 1;		/* increment size of repatch table */
	     if i = hbound (rpt.entry, 1)
	     then do;				/* Allocate new chunk of repatch table */
		call temp_mgr_$allocate (size (rpt));
		p = bx_$freep;
		bx_$last_rptp = p;
		rpt.thread = p;
		call temp_mgr_$reserve (addrel (p, size (rpt)));
		p -> rpt.thread = null;
		p -> rpt.npt = 0;
	     end;
	     rptep = addr (rpt.entry (i));		/* pointer to new repatch table entry */
	     rpte.pbase = "s";			/* patching relative to symbol section */
	     rpte.code = "t";			/* patch with 0 relocation value */
	     rpte.poffset = bit (bin ((ext.offset + comp.crels), 18), 18);
	     rpte.halfword = ext.side;		/* get halfword to patch */

	     ext.loffset = val;			/* store offset of referenced link */
	     val = 0;
	     ext.ref_ptr = addr (val);
	     if decode_link_ (extp) = "1"b
	     then goto skip_this;

/* A symbol table reference to an external must always have a link
   associated with it.  But if the external reference is to another
   component, the link is converted to a type 1 link to the other component's
   text or linkage section.  This avoids having to retain segdefs and
   add segment names that aren't otherwise needed. */

/* create a "lda 4|nn,*" instruction */

	     addr (val) -> word.lhe18 = addr (val) -> word.rhe18;
	     addr (val) -> instr.lp = PR4;
	     addr (val) -> instr.op_code = LDA_INSTR;
	     addr (val) -> instr.op_code_extension = FALSE;
	     addr (val) -> instr.inhibit = FALSE;
	     addr (val) -> instr.use_pr = TRUE;
	     addr (val) -> instr.tm = INDIRECT_TM;
	     addr (val) -> instr.td = INDIRECT_TD;

	     ext.dont_prelink = "0"b;
	     ext.side = "lhe";
	     ext.relinfo = "link15";
	     ext.section = "text";
	     ext.offset = 0;
	     ext.dont_relocate = "0"b;
	     if int_link_ (extp) = "1"b
	     then do;
		if (addr (val) -> instr.tm = "00"b) & (addr (val) -> instr.td = "0000"b)
		     & (^addr (val) -> instr.use_pr)
		then do;				/* relocated to "lda nn" */
		     ext.segname = "*text";
		     ext.code15 = "0"b;
		end;
		else if (addr (val) -> instr.tm = "00"b) & (addr (val) -> instr.td = "0000"b)
		     & (addr (val) -> instr.use_pr) & (addr (val) -> instr.lp = PR4)
		then do;				/* relocated to "lda 4|nn" */
		     ext.segname = "*link";
		     ext.code15 = "000000000000000001"b;
		end;
		else goto external_link;
		ext.slng = 6;
		ext.elng = 0;
		ext.type = "000000000000000001"b;
		addr (val) -> instr.lp = "000"b;
		ext.expr = addr (val) -> word.lhe18;
		ext.link_tm, ext.link_td = "0"b;
	     end;
external_link:
	     ext.section = "symb";
	     addr (val) -> instr.lp = "000"b;
	     call ext_link_ (extp);			/* and regenerate the very same link */
	     if ext.side = "lhe"			/* and store in repatch table */
	     then rpte.pexpr = addr (val) -> word.lhe18;
	     else rpte.pexpr = addr (val) -> word.rhe18;

skip_this:
	end;

done:
	return;

init:
     entry;

	textbase = bx_$temp_bsegp;			/* pointer to base of new text section */
	defbase = bx_$tdefp;			/* pointer to base of new definition section */
	intbase = bx_$tintp;			/* pointer to base of new internal static section */
	if bx_$debug = 1
	then errname = "rebuild_object_";
	else errname = bx_$caller;

	return;

%page;
%include extref;
%page;
%include bindext;
%page;
%include comptbl;
%page;
%include insym;
%page;
%include bndtbl;

     end rebuild_object_;




		    regenerate_all_links_.pl1       07/16/86  1217.0rew 07/16/86  0846.6       21240



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Rewritten to regenerate any *system links remaining unresolved in the
     link_regeneration_table rather than all links in the linkage section.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */

regenerate_all_links_:
     proc (ctep);

/**********************************************************************/
/*							*/
/*	Name:	regenerate_all_links_			*/
/*	Input:	ctep (component table entry pointer)		*/
/*	Function:	scans the link_regeneration_table for the given	*/
/*		component and regenerates any link that has not	*/
/*		already been regenerated.  This is primarily used	*/
/*		to pick up unreferenced *system links for fortran	*/
/*		block_data subprograms.			*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

dcl	i		fixed bin;
dcl	extp		ptr;
dcl	addr		builtin;
dcl	fixed		builtin;
dcl	decode_link_	entry (ptr) returns (bit (1) aligned);
dcl	ext_link_		entry (ptr);

dcl	1 ext		aligned like external_ref;	/**/
%include extref;

/**/
%include comptbl;

/**/
%include linkdcl;

/**/
%include bndtbl;

/**/
	extp = addr (ext);
	lrtp = comp.clrtp;
	ext.compent_ptr = ctep;
	ext.section = "none";
	ext.offset = 0;
	ext.dont_relocate = "1"b;
	ext.ref_ptr = comp.clnkp;			/* initialize so ext_link_ won't blow up */

	do i = 1 to lrt.count;
	     if lrt.regenerated (i) = UNRESOLVED
	     then do;
		ext.loffset = lrt.start_offset + ((i - 1) * 2);
		if ^decode_link_ (extp)
		then if (fixed (ext.type, 18) = 5) & (fixed (ext.code15, 18) = 5)
		     then call ext_link_ (extp);
	     end;
	end;

     end regenerate_all_links_;




		    relocate_symbol_.pl1            07/16/86  1217.0rew 07/16/86  0846.9       67185



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and readability, changed errname to use the
     caller-supplied name instead of "binder_"
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */

relocate_symbol_:
     procedure;

/* modified 6/75 by M. Weaver for separate static */
/* modified 11/76 by M. Weaver  to clean up symbol tree thread */
/* Modified 01/15/81 W. Olin Sibert to remove red shifts */

/**********************************************************************/
/*							*/
/*	Name:	relocate_symbol_				*/
/*	Input:	none					*/
/*	Function:	copies the symbol sections of the input object	*/
/*		segments into the new bound object segment and	*/
/*		relocates the references.			*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

/* source map and user_id are actually filled in by make_bindmap_	*/
/* since they, like the bindmap, are variable and are put at the	*/
/* end of the symbol section				*/


/* DECLARATION OF EXTERNAL ENTRIES */

declare	com_err_		external entry options (variable);
declare	bx_$symbol_table	external fixed bin;
declare	clock_		external entry () returns (fixed bin (71));
declare	get_relinfo_$init	external entry (ptr);
declare	get_relinfo_	external entry (ptr);


/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, addrel, bin, bit, substr, string)
			builtin;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	i		fixed bin;
declare	(previous_length, lng, relocate)
			fixed bin;
declare	(textoffset, intoffset, symboffset)
			fixed bin (18);
declare	(p, sblkp, previous_block, wordp, pl1_sbp)
			pointer;
declare	errname		char (16) aligned;

declare	1 ext		aligned,
	  2 offset	fixed bin,
	  2 side		char (3) aligned,
	  2 relinfo	char (8) aligned;

/* DECLARATION OF BASED STRUCTURES */

declare	1 word		aligned based (wordp),
	  2 lhe18		bit (18) unaligned,
	  2 rhe18		bit (18) unaligned;
declare	1 pl1_sb		aligned like pl1_symbol_block based (pl1_sbp);

declare	vers_string	char (10000) aligned based;
declare	symbolsection	(lng) fixed bin based;

/*  */

	if bx_$debug = 1
	then errname = "relocate_symbol_";
	else errname = bx_$caller;

	ctp = bx_$ctp;				/* copy pointer to component table */

/* Make a symbol section header for the new bound object */
/* IMPORTANT: length of this header is preset in 'relocate_symbol_$init'
	   and must not be exceeded unless its preset length is accordingly modified */

	sblkp = bx_$bsymp;				/* copy pointer to symbol section */
	sb.decl_vers = 1;
	sb.identifier = "bind_map";
	sb.gen_version_number = bx_$vers_number;
	p = addr (bx_$symbol_table);			/* ptr to binder's own symbol table */
	sb.gen_creation_time = p -> sb.obj_creation_time; /* get creation date of executing binder */
	sb.obj_creation_time = clock_ ();
	sb.generator = "binder";
	sb.gen_name_offset = bit (bin (20, 18), 18);
	lng = bx_$v_lng;
	sb.gen_name_length = bit (bin (lng, 18), 18);
	substr (addrel (sblkp, 20) -> vers_string, 1, lng) = substr (bx_$vers_name, 2, lng);
	p = ctp -> comp_tbl (1) -> comp.csymp;		/* get ptr to first component's symbol section */
	sb.tbound = p -> sb.tbound;			/* use tbound  of first component */
	sb.stat_bound = p -> sb.stat_bound;		/* same with stat_bound */
	sb.symb_base = "0"b;			/* this is first block in symbol section */

/* the rest of the header items are filled in by make_bindmap_ */

/* Now move all symbol tables over and relocate them */

	previous_length = bx_$s_lng;
	previous_block = sblkp;

	i = 0;
copy_tables:
	i = i + 1;
	if i > bx_$ncomp
	then goto return;				/* all components processed */
	ctep = comp_tbl (i);			/* pointer to component entry */
	if comp.ignore = 1
	then goto copy_tables;
	sblkp = addrel (bx_$bsymp, bx_$s_lng);		/* pointer to location of new section */
	lng = comp.clngns;				/* length of section to be copied */
	sblkp -> symbolsection = comp.csymp -> symbolsection;
						/* copy symbol section */
	sblkp -> sb.symb_base = bit (-bin (bx_$s_lng, 18), 18);
	textoffset = comp.crelt;
	intoffset = comp.creli;
	if bx_$bound_sep_stat = 0
	then if comp.separate_static = 1
	     then intoffset = intoffset + 8;		/* must account for linkage header */
	symboffset = comp.crels;			/* copy relocation counter values */

	call get_relinfo_$init (comp.crlsp);		/* initiate relocation bit lookup */
	ext.offset = 0;
relocate_table:
	call get_relinfo_ (addr (ext));
	if relinfo = "overflow"
	then goto thread_blocks;
	if ext.offset > lng
	then goto thread_blocks;
	wordp = addrel (sblkp, ext.offset);		/* pointer to relocatable word */
	if side = "lhe"
	then relocate = bin (word.lhe18, 18);
	else relocate = bin (word.rhe18, 18);

	if relinfo = "text    "
	then do;
	     relocate = relocate + textoffset;
	     goto restore_halfword;
	end;

	else if relinfo = "lnk18   "
	then do;
	     relocate = 0;				/* zero out to be repatched */
	     goto restore_halfword;
	end;

	else if relinfo = "symb    "
	then do;
	     relocate = relocate + symboffset;
	     goto restore_halfword;
	end;

	else if relinfo = "int18   "
	then do;
	     relocate = relocate + intoffset;
	     goto restore_halfword;
	end;

	else if relinfo = "negsymb "
	then do;
	     relocate = -1;
	     if side = "lhe"
	     then addr (relocate) -> word.rhe18 = word.lhe18;
	     else addr (relocate) -> word.rhe18 = word.rhe18;
	     relocate = relocate + symboffset;
	     goto restore_halfword;
	end;

	else if relinfo = "def     "
	then do;
	     call com_err_ (0, errname, "relocation ^a for word ^o in symbol of ^a not currently handled by binder",
		relinfo, ext.offset, comp.filename);
	     goto relocate_table;
	end;

	else if relinfo = "selfrel  "
	then goto relocate_table;

	call com_err_ (0, errname, "relocation ^a illegal for word ^o in symbol of ^a", relinfo, ext.offset,
	     comp.filename);
	bx_$fatal_error = 1;
	goto relocate_table;

restore_halfword:
	if side = "lhe"
	then word.lhe18 = addr (relocate) -> word.rhe18;
	else word.rhe18 = addr (relocate) -> word.rhe18;
	goto relocate_table;

thread_blocks:
	previous_block -> sb.next_block = bit (bin (bx_$s_lng, 18), 18);
	previous_length = comp.clngns + comp.cpads;
	bx_$s_lng = bx_$s_lng + previous_length;
	previous_block = sblkp;
	if comp.table_deleted = 1			/* symbol section has been truncated */
	then if sblkp -> sb.area_ptr
	     then do;

		pl1_sbp = addrel (sblkp, sblkp -> sb.area_ptr);
		if pl1_sb.identifier = "pl1info"
		then do;				/* don't leave dangling thread */
		     pl1_sb.root = "0"b;
		     string (pl1_sb.map) = "0"b;
		     pl1_sb.flags.table_removed = "1"b;
		end;
	     end;
	goto copy_tables;

return:
	return;

%page;
%include bindext;
%page;
%include comptbl;
%page;
%include symbol_block;
%page;
%include pl1_symbol_block;

     end relocate_symbol_;




		    strm_hash_.pl1                  07/16/86  1217.0rew 07/16/86  0846.5       50517



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



/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation.
                                                   END HISTORY COMMENTS */


/* External procedures to implement hash-coded lookup of
   the STRINGMAP table (strm).

   Sept 1978, David Spector. */

/* format: style3,^indnoniterdo */

make_entry:
     procedure (new_string, entry_nr);

/**********************************************************************/
/*							*/
/*	Name:	strm_hash_$make_entry			*/
/*	Input:	new_string, entry_nr			*/
/*	Function:	stores a new entry into the strm hash table.	*/
/*		Given a string (in ACC format) and the entry	*/
/*		number in the hash table, calculate the hash	*/
/*		function to determine the bucket and thread the	*/
/*		new entry into the appropriate bucket.		*/
/*		Each entry is a bit (18) relative offset in the	*/
/*		definition section of the new object segment	*/
/*		of a string (ACC format) being used in some	*/
/*		definition. The hash table (strm.hash_table)	*/
/*		contains fixed bin(17) array subscripts which	*/
/*		point to the first strm.entry in the particular	*/
/*		hash bucket of entries.  Empty buckets are	*/
/*		represented by zeros in the hash table.  Each	*/
/*		bucket contains a list of entries; the forward	*/
/*		thread for the list is an array subscript	*/
/*		(fixed bin(17)) in strm.entry.hash_thread for	*/
/*		each entry in the bucket.  The end of the list	*/
/*		(or chain) of entries is marked by a hash thread	*/
/*		of zero.					*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	new_string	char (*);			/* new entry's string */
declare	trial_string	char (*);
declare	entry_nr		fixed binary (17);		/* array subscript (location) of new entry */

declare	hash_index	fixed binary (34);		/* array subscript of bucket in hash table */

declare	bx_$strmp		external ptr;		/* global base of strm */
declare	bx_$tdefp		external ptr;		/* global base of def section */

declare	p		ptr;
declare	defbase		ptr;

declare	(addrel, length, substr)
			builtin;

declare	acc_string	char (257) based;

%include bndtbl;

	strmp = bx_$strmp;				/* locate STRINGMAP table */
	call hash_code (new_string, hash_index);	/* hash code the string */
	strm.entry (entry_nr).hash_thread = strm.hash_table (hash_index);
						/* push new entry into hash-code bucket */
	strm.hash_table (hash_index) = entry_nr;
	return;

lookup:
     entry (trial_string, entry_nr);

/**********************************************************************/
/*							*/
/*	Name:	strm_hash_$lookup				*/
/*	Input:	trial_string				*/
/*	Function:	Given a string (trial_string) in ACC format,	*/
/*		compute the hash function on it, and compare the	*/
/*		trial string with each string in the bucket until	*/
/*		a match is found or the bucket is exhausted.  If	*/
/*		the string is found, return the array subscript	*/
/*		of the strm.entry.  If not found, return zero.	*/
/*	Output:	entry_nr					*/
/*							*/
/**********************************************************************/

	strmp = bx_$strmp;				/* locate STRINGMAP table */
	defbase = bx_$tdefp;			/* locate base of def section */
	call hash_code (trial_string, hash_index);	/* hash code the string */
	do entry_nr = strm.hash_table (hash_index) repeat strm.entry (entry_nr).hash_thread while (entry_nr ^= 0);
						/* search the hash-code bucket for the string */
	     p = addrel (defbase, strm.entry (entry_nr).map);
						/* locate strm string */
	     if substr (p -> acc_string, 1, length (trial_string)) = trial_string
	     then return;				/* success: entry_nr is non-zero */
	end;					/* continue scanning this bucket */
	return;					/* failure: entry_nr is zero */

hash_code:
     procedure (char_string, hash_index);

/**********************************************************************/
/*							*/
/*	Name:	hash_code					*/
/*	Input:	char_string				*/
/*	Function:	given a character string, calculates the hash	*/
/*		function and returns the array index of the first	*/
/*		strm hash_table entry in the resulting bucket.	*/
/*	Output:	hash_index				*/
/*							*/
/**********************************************************************/

declare	char_string	char (*);			/* input: string */
declare	hash_index	fixed binary (34);		/* output: subscript of hash bucket */

declare	pos		fixed binary;

declare	(bin, hbound, length, min, mod, unspec)
			builtin;

	hash_index = 0;
	do pos = 1 to min (length (char_string), 24);	/* prevent overflow of hash_index */
	     hash_index = 2 * hash_index + bin (unspec (substr (char_string, pos, 1)), 9);
	end;
	hash_index = mod (hash_index, hbound (strm.hash_table, 1) + 1);
	return;
     end;						/* end of hash_code */

     end;						/* end of make_entry */




		    temp_mgr_.pl1                   07/16/86  1217.0rew 07/16/86  0846.5      132993



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


/****^  HISTORY COMMENTS:
  1) change(85-09-24,Elhard), approve(85-09-24,MCR7198),
     audit(86-06-30,Weaver), install(86-07-16,MR12.0-1094):
     Improved documentation and readability, changed errname to use the
     caller-supplied name instead of "binder_", changed make_object and
     close_files entrypoints to use a process dir temporary until binding is
     complete and then copy into the working dir.
                                                   END HISTORY COMMENTS */


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



/* procedure to do temporary database management for the binder.

Designed and originally coded by Michael J. Spier, August 19, 1970  */
/* Modified 9/78 by David Spector to use get_temp_segment_ and release_temp_segment_ */
/*		Note: -debug no longer stores temp segs in wdir!	*/
/* Modified 9/20/84 by M Sharpe to 1) use nd_handler_;
	2) check for null pointers before using them;
*/

/* format: style3,^indnoniterdo */

temp_mgr_:
     procedure;


/* DECLARATION OF EXTERNAL ENTRIES */

declare	com_err_		external entry options (variable);
declare	error_table_$segnamedup
			external fixed bin (35);
declare	error_table_$namedup
			external fixed bin (35);
declare	error_table_$rqover external fixed bin (35);
declare	get_pdir_		external entry () returns (char (168));
declare	get_wdir_		external entry () returns (char (168));
declare	get_temp_segment_	external entry (char (*), ptr, fixed bin (35));
declare	hcs_$chname_seg	ext entry (ptr, char (*) aligned, char (*) aligned, fixed bin (35));
declare	initiate_file_$create
			ext
			entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
declare	nd_handler_	ext entry (char (*), char (*), char (*), fixed bin (35));
declare	release_temp_segment_
			external entry (char (*), ptr, fixed bin (35));
declare	sys_info$max_seg_size
			external fixed bin (19);
declare	terminate_file_	ext entry (ptr, fixed bin (24), bit (*), fixed bin (35));
declare	tssi_$clean_up_segment
			entry (ptr);
declare	tssi_$get_segment	external entry (char (*) aligned, char (*) aligned, pointer, ptr, fixed bin (35));
declare	tssi_$finish_segment
			external entry (pointer, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));

/* DECLARATION OF INTERNAL STATIC VARIABLES */

declare	pdir		char (168) internal static initial ("");
declare	wdir		char (168) aligned internal static initial (" ");
declare	limit		fixed bin (18) internal static;
declare	mask		bit (36) aligned internal static initial ("000000000000000000111111111111111000"b);
declare	errname		char (16) aligned internal static;

/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

declare	bound_segl	fixed bin (21);
declare	bound_segp	ptr;
declare	created		bit (1) aligned;
declare	offset		fixed bin (18);
declare	i		fixed bin;
declare	code		fixed bin (35);
declare	(p, sp, ip)	pointer;
declare	segname		char (32) aligned;


/* DECLARATION OF BUILTIN FUNCTIONS */

declare	(addr, divide, null, ptr, rel, rtrim, substr)
			builtin;

/* DECLARATION OF CONDITIONS */

declare	cleanup		condition;
declare	record_quota_overflow
			condition;

/* DECLARATION OF BASED STRUCTURES */

declare	1 temp_seg	based aligned,		/* format of temp segments */
	  2 next_temp_ptr	ptr,			/* ptr to next chained temp seg */
	  2 storage	bit (0);			/* start of temp_mgr_ storage */

declare	bound_seg		char (bound_segl) based;

declare	1 offset_overlay	aligned based (addr (offset)),
	  2 dum		bit (18) unaligned,
	  2 relp		bit (18) unaligned;
declare	offset_bits	bit (36) aligned based (addr (offset));

%include access_mode_values;
%page;
%include terminate_file;

%page;
reserve:
     entry (last_used);

/**********************************************************************/
/*							*/
/*	Name:	temp_mgr_$reserve				*/
/*	Input:	last_used					*/
/*	Function:	reserves a block of storage from the current	*/
/*		address pointed to by bx_$freep to the address	*/
/*		pointed to by last_used and realigns bx_$freep	*/
/*		to a 0 mod 8 boundary.  If the new value for	*/
/*		bx_$freep is past a preset limit, a new temp_seg	*/
/*		is procured and chained in and bx_$freep set to	*/
/*		point to the start of it's storage area.	*/
/*		NB.  Since no guarantees can be made about the	*/
/*		     amount of space remaining in the temp_seg	*/
/*		     temp_mgr_$allocate should be called prior	*/
/*		     to calling temp_mgr_$reserve to insure that	*/
/*		     sufficient space is available.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

declare	last_used		pointer;

	offset = 0;				/* preset to zero */
	offset_overlay.relp = rel (last_used);		/* get offset of last-used location */
	offset = offset + 7;			/* make new offset 0 mod 8 */
	offset_bits = offset_bits & mask;		/* ... */
	if offset <= limit
	then /* segment not yet overflowing */
	     do;					/* generate new free pointer */
	     bx_$freep = ptr (last_used, offset_overlay.relp);
	     return;
	end;

/* arrived here we have an overflowing temporary segment, and must create a new one */

create_temp:					/* Initialize a new temp segment.  bx_$temp contains a pointer (initially null) to the
   latest temp seg.  Each temp seg contains a pointer to the previous one in the list.
   Exact format is described by declaration for "temp_seg". */
	call get_temp_segment_ ("bind", p, code);
	if code ^= 0
	then do;
	     call com_err_ (code, errname, "unable to create temporary segment.");
	     bx_$fatal_error = 1;
	     return;
	end;

/* Push new temp segment onto chained list of temp segs, for later releasing. */

	p -> temp_seg.next_temp_ptr = bx_$temp;
	bx_$temp = p;

/* Initialize for storing into space following the fwd ptr. */

	bx_$freep = addr (bx_$temp -> temp_seg.storage);

	return;


allocate:
     entry (area_size);

declare	area_size		fixed bin;

/**********************************************************************/
/*							*/
/*	Name:	temp_mgr_$allocate				*/
/*	Input:	area_size					*/
/*	Function:	checks to make sure that <area_size> words can be	*/
/*		allocated within the current temp_seg, and gets a	*/
/*		new one if not.				*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	offset = 0;
	offset_overlay.relp = rel (bx_$freep);		/* get current offset */
	if offset + area_size <= limit
	then return;				/* there is enough room for area */

	goto create_temp;				/* go make another temporary */
%page;

close_files:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	temp_mgr_$close_files			*/
/*	Input:	none					*/
/*	Function:	copies the process directory copy of the bound	*/
/*		object segment into the working dir and adds the	*/
/*		appropriate names to the new object segment.	*/
/*		If an Addname statement occurred in the bindfile	*/
/*		add the given names if any were given or add the	*/
/*		names off all retained entrypoints if no names	*/
/*		were specified.  The object segment bit count and	*/
/*		acl are set and the temp_segs are released.	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/


	bx_$bseg_acinfop = null;
	bound_segp = null;

	if bx_$fatal_error ^= 0
	then do;

	     call close_file_cleanup ();

	     return;				/* forget the rest */
						/* save the bad version */
	end;

/* move the new bound object from the pdir temporary into the final	*/
/* working dir copy.					*/

	on cleanup
	     begin;
		call close_file_cleanup ();
	     end;

/* create the working dir copy of the bound object segment	*/

	call tssi_$get_segment (wdir, bx_$bound_segname, bound_segp, bx_$bseg_acinfop, code);
	if code ^= 0
	then do;
	     call com_err_ (code, errname, "^/Unable to create ^a, a copy exists in [pd]>^a", bx_$bound_segname,
		bx_$bound_segname);
	     bx_$fatal_error = 1;
	     call close_file_cleanup ();
	     return;
	end;

/* if a record quota overflow occurs while we are copying, print	*/
/* a message indicating that an intact copy of the bound segment is	*/
/* available in the process directory, and then abort.		*/

	on record_quota_overflow
	     begin;
		call com_err_ (error_table_$rqover, errname, "^/Unable to complete ^a, a copy exists in [pd]>^a",
		     bx_$bound_segname, bx_$bound_segname);
		call close_file_cleanup;		/* clean up what would have been the final version */
		goto close_file_return;
	     end;

/* calculate the length of the bound segment expressed in terms of	*/
/* characters for the string overlay copy operation.		*/

	bound_segl = divide (bx_$bseg_bitcount, 9, 21, 0);

/* copy the new bound segment into the working dir copy		*/

	bound_segp -> bound_seg = bx_$temp_bsegp -> bound_seg;

	revert record_quota_overflow;
	bx_$bsegp = bound_segp;			/* now operate on the real thing */

/* now delete the copy of the bound object in the process dir	*/

	call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_DELETE, code);
	bx_$temp_bsegp = null;			/* done with this */


/* add the appropriate synonyms to the bound segment */

	if bx_$addname = 1
	then do;
	     adnp = bx_$adnp;

/* add all names explicitly asked for by Addname statement by	*/
/* direct extraction from the addname table.			*/

	     if an.n_an > 0
	     then do i = 1 to an.n_an;
		     segname = an.syn (i);
		     call Addname;
		end;

/* add names specified by implicit addname (ie. "Addname;") by	*/
/* scanning the segname table, and for each component, scanning the	*/
/* definition list for retained definitions and adding the name of	*/
/* the definition to the bound segment.			*/

	     else do i = 1 to bx_$sntp -> snt.n_names;
		     sp = addr (bx_$sntp -> snt.entry (i));
		     ip = sp -> seg.comp -> comp.insymentp;
		     if ip -> insym.retained = "1"b
		     then do;
			segname = substr (sp -> seg.name, 2, sp -> seg.lng - 1);
			call Addname;
		     end;
		end;
	end;					/* finished processing Addname */


	do p = bx_$temp repeat bx_$temp while (p ^= null);
	     bx_$temp = p -> temp_seg.next_temp_ptr;
	     call release_temp_segment_ ("bind", p, code);
	end;

	if bx_$bseg_acinfop ^= null
	then call tssi_$finish_segment (bx_$bsegp, bx_$bseg_bitcount, "1100"b, bx_$bseg_acinfop, code);

close_file_return:
	return;



close_file_cleanup:
     proc ();

	if bx_$bseg_acinfop ^= null
	then call tssi_$clean_up_segment (bx_$bseg_acinfop);

/* Return all temp segments to free pool. */

	do p = bx_$temp repeat bx_$temp while (p ^= null);
	     bx_$temp = p -> temp_seg.next_temp_ptr;
	     call release_temp_segment_ ("bind", p, code);
	end;

	return;
     end close_file_cleanup;
%page;

init:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	temp_mgr_$init				*/
/*	Input:	none					*/
/*	Function:	sets up the name for error messages and the limit	*/
/*		on how full temp_segs will be allowed to grow.	*/
/*		It then creates the first temp_seg.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	if bx_$debug = 1
	then errname = "temp_mgr_";
	else errname = bx_$caller;
	wdir = get_wdir_ ();			/* get name of working directory */
	pdir = get_pdir_ ();			/* get name of process directory */
	if sys_info$max_seg_size <= 65536
	then limit = sys_info$max_seg_size - 8192;
	else limit = sys_info$max_seg_size - 16384;	/* Slack in temporary will be 8K when 64K segments are maximum */
						/* and will be 16K when 256K segments are maximum. */
	bx_$temp = null;				/* Clear list of temp segments. */
	goto create_temp;

make_object:
     entry;

/**********************************************************************/
/*							*/
/*	Name:	temp_mgr_$make_object			*/
/*	Input:	none					*/
/*	Function:	creates a working copy of the new object in the	*/
/*		process directory with the name specified by	*/
/*		bx_$bound_segname and saves the segment pointer	*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

	bx_$bseg_acinfop = null;

	call initiate_file_$create (pdir, (bx_$bound_segname), RW_ACCESS, bx_$temp_bsegp, created, (0), code);
	if code ^= 0
	then do;
	     call com_err_ (code, errname, "unable to create temporary copy of ^a", bx_$bound_segname);
	     bx_$fatal_error = 1;
	     return;
	end;

	if ^created
	then do;
	     call terminate_file_ (bx_$temp_bsegp, 0, TERM_FILE_TRUNC, code);
	     if code ^= 0
	     then do;
		call com_err_ (code, errname, "unable to truncate temporary copy of ^a", bx_$bound_segname);
		bx_$fatal_error = 1;
		return;
	     end;
	end;

	bx_$bsegp = bx_$temp_bsegp;			/* bind into the temp */

	return;




Addname:
     procedure;

/**********************************************************************/
/*							*/
/*	Name:	Addname					*/
/*	Input:	none					*/
/*	Function:	adds the name specified by the global variable	*/
/*		segname to the output object segment.  If the	*/
/*		name is on another segment, the nd_handler_ is	*/
/*		called to take care of things.		*/
/*	Output:	none					*/
/*							*/
/**********************************************************************/

TRY_ADDNAME:
	call hcs_$chname_seg (bx_$bsegp, "", segname, code);
						/* add name to the bound segment */
	if code ^= 0
	then do;					/* this is a name duplication */
	     if code = error_table_$segnamedup
	     then ;				/*   do nothing if seg already has the addname   */
	     else if code = error_table_$namedup	/*   normal handling for name duplication   */
	     then do;
		call nd_handler_ ((bx_$caller), rtrim (wdir), (segname), code);
		if code = 0
		then go to TRY_ADDNAME;
	     end;
	end;


     end Addname;


%page;
%include bindext;
%page;
%include bndtbl;
%page;
%include comptbl;
%page;
%include insym;



     end temp_mgr_;






		    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
