



		    lib_access_mode_.pl1            02/15/84  0911.2rew 02/15/84  0749.8      186084



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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name:  lib_access_mode_							*/
	/*									*/
	/*      This subroutine is part of the library maintenance tools.  It gets and sets the	*/
	/* current user's (person.project.a) access to a given library entry.			*/
	/*									*/
	/* Entry:  lib_access_mode_$get						*/
	/*									*/
	/*      This entry gets user's access to a given entry.				*/
	/*									*/
	/* Usage									*/
	/*									*/
	/* dcl lib_access_mode_$get entry (ptr, fixed bin(35));				*/
	/*									*/
	/* call lib_access_mode_$get (Pnode, code);					*/
	/*									*/
	/* where:									*/
	/* 1. Pnode	is a pointer to the library node representing the library entry. (In)	*/
	/* 2. code	is an error code. (Out)					*/
	/*									*/

	/* Entry:  lib_access_mode_$set						*/
	/*									*/
	/*      This entry sets the user's access to a given library entry.  If necessary,	*/
	/* the user will be given access to the archive, directory, or MSF which contains the	*/
	/* library entry.  Links are chased.						*/
	/*									*/
	/*      If the user already has sufficient access to meet the requirements of the 	*/
	/* requested access mode, then no changes are made.  				*/
	/*									*/
	/*      Access is granted in such a way that it can be unset, leaving the ACL in its	*/
	/* original state, by call lib_access_mode_$unset.				*/
	/*									*/
	/* Usage									*/
	/*									*/
	/* dcl lib_access_mode_$set (ptr, bit(36) aligned, fixed bin, fixed bin(35));		*/
	/*									*/
	/* call lib_access_mode_$set (Pnode, new_mode, unset_depth, code);			*/
	/*									*/
	/* where:									*/
	/* 1.  Pnode	is as above. (In)						*/
	/* 2.  new_mode	is a bit string describing the required user access. (In)		*/
	/*		For directories, the bits represent "sma..."b.			*/
	/*		For other entries, the bits represent "rew..."b.			*/
	/* 3.  unset_depth	defines the depth up or down the library node tree to which access	*/
	/*		changes had to be made in order to set the user's access.  This	*/
	/*		value must be given to lib_access_mode_$unset to properly unset	*/
	/*		the access mode. (Out)					*/
	/* 4.  code	is as above. (Out)						*/
	/*									*/
	/* Entry:  lib_access_mode_$unset						*/
	/*									*/
	/*      This entry undoes what the $set entry does, so that all ACLs are in their original*/
	/* state.									*/
	/*									*/
	/* Usage									*/
	/*									*/
	/* dcl lib_access_mode_$unset (ptr, fixed bin, fixed bin(35));			*/
	/*									*/
	/* call lib_access_mode_$unset (Pnode, unset_depth, code);				*/
	/*									*/
	/* where:									*/
	/* 1. - 3.	are as described above.					*/
	/*									*/
	/* Status:								*/
	/*									*/
	/* 0) Created in  June, 1976  by Gary C. Dixon					*/
	/* 1) Modified on October 11, 1983 by Jim Lippard to change all occurrences of		*/
	/* error_table_$invalid_data_format to error_table_$improper_data_format.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_access_mode_:	procedure;

     dcl						/*	Parameters			*/
	new_mode			bit(36) aligned,	/* access to node which is required.		*/
	unset_depth		fixed bin,	/* depth up/down tree to which setting was done.	*/
	code			fixed bin(35);	/* return code.				*/

     dcl						/*	Automatic Variables			*/
	Bmode			bit(5),		/* bit access mode (xrewx, or xsmxa).		*/
	Nmode			fixed bin(5),	/* binary access mode.			*/
	Pmsf_fcb			ptr,		/* ptr to msf_manager_ control block.		*/
	Sunset_required		bit(1) aligned,	/* on if ACL changed during $set call.		*/
	1 acle			aligned,		/* segment ACL entry addition structure.	*/
	  2 user			char(32),
	  2 mode			bit(36),
	  2 pad			bit(36),
	  2 code			fixed bin(35),
	1 del_acle		aligned,		/* segment ACL entry deletion structure.	*/
	  2 user			char(32),
	  2 code			fixed bin(35),
	dir			char(168) varying,	/* dir part of node pathname.			*/
	1 dir_acle		aligned,		/* directory ACL entry addition structure.	*/
	  2 user			char(32),
	  2 mode			bit(36),
	  2 code			fixed bin(35),
	ent			char(32) varying;	/* ent part of node pathname.			*/

     dcl						/* 	Built-in Functions and Conditions	*/
         (addr, bit, null, substr)
				builtin,
	cleanup			condition;

     dcl						/*	Entries Called			*/
	get_group_id_	entry returns (char(32)),
	get_ring_		entry returns (fixed bin(3)),
         (hcs_$add_acl_entries,
	hcs_$add_dir_acl_entries,
	hcs_$delete_acl_entries,
	hcs_$delete_dir_acl_entries,
	installation_tools_$add_acl_entries,
	installation_tools_$delete_acl_entries)
				entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$get_user_effmode	entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)),
         (hcs_$list_acl,
	hcs_$list_dir_acl)		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying),
         (msf_manager_$acl_add,
	msf_manager_$acl_delete)	entry (ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$acl_list	entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$close		entry (ptr),
	msf_manager_$open		entry (char(*), char(*), ptr, fixed bin(35));
 
     dcl						/*	Static Variables			*/
	False			bit(1) aligned int static options(constant) init ("0"b),
	True			bit(1) aligned int static options(constant) init ("1"b),
         (error_table_$improper_data_format,
	error_table_$link,
	error_table_$out_of_sequence,
	error_table_$user_not_found)	fixed bin(35) ext static,
	ring			fixed bin int static init (8),
	user			char(32) int static init ("");


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get:	entry	(Pnode, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*  lib_access_mode_$get sets the node.Smode field of input mode current user's access	*/
	/*  to the library entry associated with the node.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	if user = "" then user = get_group_id_();	/* initialize internal static values.		*/
	if ring = 8  then ring = get_ring_();

	code = 0;					/* initialize return code.			*/
	if Svalid.mode then;			/* if mode already known, return.		*/
	else if node.T = Tlink then do;		/* chase links to get associated access mode.	*/
	     if Svalid.kids then do;
		do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes);
		     end;
		if Dnodes.N ^= 1 then code = error_table_$link;
		else do;
		     call get (addr(Dnodes.nodes(1)), code);
		     if code = 0 then do;
			node.Smode = addr(Dnodes.nodes(1))->node.Smode;
			Svalid.mode = True;
			end;
		     end;
		end;
	     else code = error_table_$link;
	     end;
	else if node.T = Tarchive_comp then do;		/* assoc access to containing archive with comp.	*/
ARCH_COMP:     call get (node.Pparent, code);
	     if code ^= 0 then do;
		node.Smode = node.Pparent->node.Smode;
		Svalid.mode = True;
		end;
	     end;
	else if node.T = Tarchive & node.offset ^= 0 then	/* do same for archived archive.		*/
	     go to ARCH_COMP;
	else do;					/* get user's access to the library entry.	*/
	     call lib_node_path_ (Pnode, dir, ent);
	     call hcs_$get_user_effmode ((dir), (ent), user, ring, Nmode, code);
	     if code = 0 then do;
		Bmode = bit(Nmode,5);
		if node.T = Tdirectory then do;	/* for directories:				*/
		     substr (node.Smode, 1, 1) = substr (Bmode, 2, 1);
		     substr (node.Smode, 2, 2) = substr (Bmode, 4, 2);
		     end;				/*   map 'xsxma' into 'sma'.			*/
		else if node.T = Tmsf then do;	/* for msfs:				*/
		     substr (node.Smode, 1, 1) = substr (Bmode, 2, 1);
		     substr (node.Smode, 2, 1) = "0"b;
		     substr (node.Smode, 3, 1) = substr (Bmode, 4, 1);
		     end;				/*   map 'xsxma' into 'rxw'.			*/
		else				/* for segments:				*/
		     substr (node.Smode, 1, 3) = substr (Bmode, 2, 3);
		     				/*   map 'xrewx' into 'rew'.			*/
		Svalid.mode = True;			/* mark access mode as being valid.		*/
		end;
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set:	entry	(Pnode, new_mode, unset_depth, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* lib_access_mode_$set sets the user's access (person.proj.a) to a given library entry	*/
	/* to a specified mode.  Information is returned to reverse the setting to the original	*/
	/* ACL contents.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	if user = "" then user = get_group_id_();	/* initialize internal static values.		*/
	if ring = 8  then ring = get_ring_();

	code = 0;					/* initialize return code.			*/
	unset_depth = 0;				/* to start with, no unsetting is required.	*/


set_recurse:	entry	(Pnode, new_mode, unset_depth, code);

	if Svalid.mode then;			/* get current mode, if not already known.	*/
	else do;
	     call get (Pnode, code);
	     if code ^= 0 then return;
	     end;

	if (node.Smode & new_mode) = new_mode then 	/* do nothing if current mode sufficient to meet	*/
	     Sunset_required = False;			/*   user's needs.				*/
	else Sunset_required = True;

	if Sunset_required then			/* cannot set ACL if previously set without unset	*/
	     if Svalid.prev_mode then do;
		code = error_table_$out_of_sequence;
		Sunset_required = False;
		end;

	if Sunset_required then do;			/* must take positive action to set the ACL.	*/
	     unset_depth = unset_depth + 1;		/* indicate taking another step up/down tree.	*/
	     if node.T = Tlink then do;		/* chase links to set mode.			*/
		if Svalid.kids then do;
		     do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes);
			end;
		     if Dnodes.N ^= 1 then code = error_table_$link;
		     else do;
			call set_recurse (addr(Dnodes.nodes(1)), new_mode, unset_depth, code);
			if code = 0 then do;
			     node.Smode       = addr(Dnodes.nodes(1))->node.Smode;
			     node.Sprev_mode  = addr(Dnodes.nodes(1))->node.Sprev_mode;
			     Svalid.mode      = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.mode;
			     Svalid.prev_mode = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.prev_mode;
			     end;
			end;
		     end;
		else code = error_table_$link;
		end;
	     else if node.T = Tarchive_comp then do;	/* set ACL on containing archive.		*/
ARCH_COMP_ACL:	call set_recurse ((node.Pparent), new_mode, unset_depth, code);
		if code = 0 then do;
		     node.Smode       = node.Pparent->node.Smode;
		     node.Sprev_mode  = node.Pparent->node.Sprev_mode;
		     Svalid.mode      = addr(node.Pparent->node.Svalid)->Svalid.mode;
		     Svalid.prev_mode = addr(node.Pparent->node.Svalid)->Svalid.prev_mode;
		     end;
		end;
	     else if node.T = Tarchive & node.offset ^= 0 then
		go to ARCH_COMP_ACL;		/* do same for archived archive.		*/
	     else if node.T = Tmsf_comp then		/* do same for MSF component (must keep MSF ACL	*/
		go to ARCH_COMP_ACL;		/*   consistent).				*/

	     else do;
		if node.Pparent ^= null then do;	/* make sure we have access to set access.	*/
		     call set_recurse ((node.Pparent), "110"b, unset_depth, code);
		     if code ^= 0 then return;
		     end;
		call lib_node_path_ (Pnode, dir, ent);	/* get pathname of entry being considered.	*/
		if node.T = Tsegment then do;		/* set segment ACL.				*/
SEG_ACL:		     acle.user = user;
		     acle.mode = ""b;
		     acle.pad  = ""b;
		     acle.code = 0;
		     call hcs_$list_acl ((dir), (ent), null, null, addr(acle), 1, code);
		     if code ^= 0 then return;
		     if acle.code = error_table_$user_not_found then
			node.Sprev_mode = node.Smode;	/*     save user's prev mode, but do NOT mark	*/
						/*       prev mode as valid;  this is reserved	*/
						/*       for prev modes appearing in separate	*/
						/*       ACL entry for user.			*/
		     else do;
			node.Sprev_mode = acle.mode;
			Svalid.prev_mode = True;
			end;
		     acle.mode = new_mode;
		     acle.code = 0;
		     if node.rb(1) < ring then
			call installation_tools_$add_acl_entries ((dir), (ent), addr(acle), 1, code);
		     else call hcs_$add_acl_entries                ((dir), (ent), addr(acle), 1, code);
		     end;
		else if node.T = Tdirectory then do;	/* set directory ACL.			*/
		     dir_acle.user = user;		/*     get current ACLe applying to person.proj.a	*/
		     dir_acle.mode = ""b;
		     dir_acle.code = 0;
		     call hcs_$list_dir_acl ((dir), (ent), null, null, addr(dir_acle), 1, code);
		     if code ^= 0 then return;
		     if dir_acle.code = error_table_$user_not_found then
			node.Sprev_mode = node.Smode;	/*     save user's prev mode, but do NOT mark	*/
						/*       prev mode as valid;  this is reserved	*/
						/*       for prev modes appearing in separate	*/
						/*       ACL entry for user.			*/
		     else do;
			node.Sprev_mode = dir_acle.mode;
			Svalid.prev_mode = True;
			end;
		     dir_acle.mode = new_mode;	/*     set the new mode.			*/
		     dir_acle.code = 0;
		     call hcs_$add_dir_acl_entries ((dir), (ent), addr(dir_acle), 1, code);
		     end;

		else if node.T = Tarchive then 	/* most archives can be handled like segments.	*/
		     go to SEG_ACL;
		else if node.T = Tmsf then do;	/* set MSF ACL.				*/
		     acle.user = user;
		     acle.mode = ""b;
		     acle.pad  = ""b;
		     acle.code = 0;
		     Pmsf_fcb = null;
		     on cleanup begin;
			if Pmsf_fcb ^= null then
			     call msf_manager_$close (Pmsf_fcb);
			end;
		     call msf_manager_$open ((dir), (ent), Pmsf_fcb, code);
		     if code ^= 0 then return;
		     call msf_manager_$acl_list (Pmsf_fcb, null, null, addr(acle), 1, code);
		     if code ^= 0 then do;
			call msf_manager_$close (Pmsf_fcb);
			return;
			end;
		     if acle.code = error_table_$user_not_found then
			node.Sprev_mode = node.Smode;	/*     save user's prev mode, but do NOT mark	*/
						/*       prev mode as valid;  this is reserved	*/
						/*       for prev modes appearing in separate	*/
						/*       ACL entry for user.			*/
		     else do;
			node.Sprev_mode = acle.mode;
			Svalid.prev_mode = True;
			end;
		     acle.mode = new_mode;
		     acle.code = 0;
		     call msf_manager_$acl_add (Pmsf_fcb, addr(acle), 1, code);
		     call msf_manager_$close (Pmsf_fcb);
		     revert cleanup;
		     end;
		end;
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


unset:	entry	(Pnode, unset_depth, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* lib_access_mode_$unset reverts any access change made by the $set entry point.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	if user = "" then user = get_group_id_();	/* initialize internal static values.		*/
	if ring = 8  then ring = get_ring_();

	code = 0;					/* initialize return values.			*/

	if unset_depth = 0 then return;		/* no unsetting required.			*/

	unset_depth = unset_depth - 1;		/* for what we are about to do, count it.	*/

	if node.T = Tlink then do;			/* link unsetting must be done to link kids.	*/
	     if ^Svalid.mode then;			/*     must have gotten error setting; ignore	*/
	     else if ^Svalid.kids then
		code = error_table_$improper_data_format;
	     else do;
		do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes);
		     end;
		if Dnodes.N = 1 then
		     code = error_table_$improper_data_format;
		else do;
		     call unset (addr(Dnodes.nodes(1)), unset_depth, code);
		     node.Smode       = addr(Dnodes.nodes(1))->node.Smode;
		     node.Sprev_mode  = addr(Dnodes.nodes(1))->node.Sprev_mode;
		     Svalid.mode      = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.mode;
		     Svalid.prev_mode = addr (addr(Dnodes.nodes(1))->node.Svalid)->Svalid.prev_mode;
		     end;
		end;
	     end;

	else do;					/* all other unsetting done to node and its parent*/
	     call lib_node_path_ (Pnode, dir, ent);
	     if node.T = Tsegment then do;		/* restore segment ACL			*/
SEG_ACL_UNSET:	if Svalid.prev_mode then do;		/*     restore previous ACL entry mode.		*/
		     acle.user = user;
		     acle.mode = node.Sprev_mode;
		     acle.pad  = ""b;
		     acle.code = 0;
		     if node.rb(1) < ring then
			call installation_tools_$add_acl_entries ((dir), (ent), addr(acle), 1, code);
		     else call hcs_$add_acl_entries                ((dir), (ent), addr(acle), 1, code);
		     if code ^= 0 then;
		     else do;
			Svalid.prev_mode = False;
			node.Smode = node.Sprev_mode;
			end;
		     end;
		else do;				/*     delete ACL entry for user.		*/
		     del_acle.user = user;
		     del_acle.code = 0;
		     if node.rb(1) < ring then
			call installation_tools_$delete_acl_entries ((dir), (ent), addr(del_acle), 1, code);
		     else call hcs_$delete_acl_entries                ((dir), (ent), addr(del_acle), 1, code);
		     if code ^= 0 then;
		     else node.Smode = node.Sprev_mode;
		     end;
		end;
	     else if node.T = Tdirectory then do;	/* restore directory ACL.			*/
		if Svalid.prev_mode then do;		/*     restore previous ACL entry mode.		*/
		     dir_acle.user = user;
		     dir_acle.mode = node.Sprev_mode;
		     dir_acle.code = 0;
		     call hcs_$add_dir_acl_entries ((dir), (ent), addr(dir_acle), 1, code);
		     if code ^= 0 then;
		     else do;
			Svalid.prev_mode = False;
			node.Smode = node.Sprev_mode;
			end;
		     end;
	 	else do;				/*     delete ACL entry for user.		*/
		     del_acle.user = user;
		     del_acle.code = 0;
		     call hcs_$delete_dir_acl_entries ((dir), (ent), addr(del_acle), 1, code);
		     if code ^= 0 then;
		     else node.Smode = node.Sprev_mode;
		     end;
		end;
	     else if node.T = Tarchive then
		if node.offset > 0 then
		     go to ARCH_ACL_UNSET;
		else go to SEG_ACL_UNSET;
	     else if node.T = Tarchive_comp then do;	/* restore archive component ACL.		*/
ARCH_ACL_UNSET:	call unset ((node.Pparent), unset_depth, code);
		node.Smode       = node.Pparent->node.Smode;
		node.Sprev_mode  = node.Pparent->node.Sprev_mode;
		Svalid.mode      = addr(node.Pparent->node.Svalid)->Svalid.mode;
		Svalid.prev_mode = addr(node.Pparent->node.Svalid)->Svalid.prev_mode;
		end;

	     else if node.T = Tmsf then do;		/* restore MSF ACL.				*/
		Pmsf_fcb = null;
		on cleanup begin;
		     if Pmsf_fcb ^= null then
			call msf_manager_$close (Pmsf_fcb);
		     end;
		call msf_manager_$open ((dir), (ent), Pmsf_fcb, code);
		if code ^= 0 then return;
		if Svalid.prev_mode then do;		/*     restore previous ACL entry mode.		*/
		     acle.user = user;
		     acle.mode = node.Sprev_mode;
		     acle.pad  = ""b;
		     acle.code = 0;
		     call msf_manager_$acl_add (Pmsf_fcb, addr(acle), 1, code);
		     if code ^= 0 then;
		     else do;
			Svalid.prev_mode = False;
			node.Smode = node.Sprev_mode;
			end;
		     end;
		else do;				/*     delete ACL entry for user.		*/
		     del_acle.user = user;
		     del_acle.code = 0;
		     call msf_manager_$acl_delete (Pmsf_fcb, addr(del_acle), 1, code);
		     if code ^= 0 then;
		     else node.Smode = node.Sprev_mode;
		     end;
		call msf_manager_$close (Pmsf_fcb);
		revert cleanup;
		end;
	     else if node.T = Tmsf_comp then
		go to ARCH_ACL_UNSET;		/* unset MSF acl for MSF components.		*/
	     if code = 0 then
		if unset_depth > 0 then
		     call unset ((node.Pparent), unset_depth, code);
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_node_;

	end lib_access_mode_;




		    lib_args_.pl1                   02/11/86  1611.4rew 02/11/86  1609.7      265788



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



/****^  HISTORY COMMENTS:
  1) change(83-10-24,Lippard), approve(), audit(), install():
      add -page_length, -all_matches, and -first_match options
  2) change(86-01-15,GDixon), approve(86-02-06,MCR7338),
     audit(86-02-06,Lippard), install(86-02-11,MR12.0-1016):
      A) Fix bugs in handling of -pn control arg.
      B) Add standard short names to many control args.
                                                   END HISTORY COMMENTS */


lib_args_: procedure (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, Parg_struc, Acode);

     dcl						/*	Parameters			*/
	Acode			fixed bin(35);	/* a status code. (Out)			*/

     dcl						/*	Automatic variables			*/
	Larg			fixed bin,	/* length of control argument.		*/
	Loperand			fixed bin,	/* length of control argument operand.		*/
	PSname			ptr,		/* ptr to switch for name table which overflowed.	*/
	PSreq			ptr,		/* ptr to a set of requirements switches.	*/
	Parg			ptr,		/* ptr to control argument.			*/
	Poperand 			ptr,		/* ptr to control argument operand.		*/
	Sallowed			bit(1) aligned,	/* on if ctl arg requiring operand is allowed.	*/
	Slib			bit(1) aligned,	/* on if TOO_MANY_LIBS msg already printed once.	*/
	Scontrol_disallowed		bit(36) aligned,	/* control bits which may NOT be set.		*/
	Srequirements_disallowed	bit(72) aligned,	/* rqeuirements bits which may NOT be set.	*/
	1 bad_library		like LIBRARY,
						/* storage for bad library names.		*/
	code			fixed bin(35),	/* an error table code.			*/
	i			fixed bin,	/* number of input argument being processed.	*/
 	j			fixed bin,	/* index of found control arg in keyword table.	*/
	Sstar			bit(1) aligned,	/* on if TOO_MANY_STAR msg already printed once.	*/
	name_type			char(7) aligned,	/* type of name table which has overflowed.	*/
	names_allowed		fixed bin;	/* number of names allowed in overflowing table.	*/

     dcl						/*	Based Variables			*/
	Sname			bit(1) aligned based(PSname),
						/* on if corresponding name table ovfl msg printed*/
	1 Sreq			aligned like Svalid_req based(PSreq),
						/* requirements switches.			*/
	arg			char(Larg) based(Parg),
						/* a control argument.			*/
	operand			char(Loperand) based(Poperand);
						/* a control argument operand.		*/

     dcl						/*	Built-in Functions and Conditions	*/
         (addr, convert, dimension, max, string, substr)
				builtin,
	conversion		condition;

     dcl						/*	Entries Called			*/
	check_star_name_$entry	entry (char(*), fixed bin(35)),
	cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin, fixed bin(35), ptr),
	lib_descriptor_$validate_library
				entry (char(168) varying, ptr, ptr, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying);

     dcl						/*	Static Variables			*/
	1 Sc_req			int static aligned,	/* relationship between requirements and control	*/
	  2 acl			bit(72) init(""b),	/*   switches.				*/
	  2 iacl			bit(72),
	  2 object_info		bit(72),
	  2 check_ascii		bit(72),
	  2 check_archive		bit(72),
	  2 all_status		bit(72),
	  2 quota			bit(72),
	False			bit(1) aligned int static options(constant) init ("0"b),
	True			bit(1) aligned int static options(constant) init ("1"b),
         (error_table_$bad_arg,
	error_table_$badstar,
	error_table_$too_many_names,
	error_table_$unimplemented_version,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static;

     dcl	keyword (66)		char (30) varying int static options(constant) init (
				     "-access                      ",	/*    1	*/
				     "-access_class                ",	/*    2	*/
				     "-acl                         ",	/*    3	*/
				     "-all                         ",	/*    4	*/
				     "-all_matches                 ",	/*    5	*/
				     "-author                      ",	/*    6	*/
				     "-bit_count                   ",	/*    7	*/
				     "-brief                       ",	/*    8	*/
				     "-chase                       ",	/*    9	*/
				     "-compiler_name               ",	/*   10	*/
				     "-compiler_options            ",	/*   11	*/
				     "-compiler_version            ",	/*   12	*/
				     "-components                  ",	/*   13	*/
				     "-container                   ",	/*   14	*/
				     "-contents                    ",	/*   15	*/
				     "-copy                        ",	/*   16	*/
				     "-cross_reference             ",	/*   17	*/
				     "-current_length              ",	/*   18	*/
				     "-date                        ",	/*   19	*/
				     "-date_time_compiled          ",	/*   20	*/
				     "-date_time_dumped            ",	/*   21	*/
				     "-date_time_entry_modified    ",	/*   22	*/
				     "-date_time_contents_modified ",	/*   23	*/
				     "-date_time_used              ",	/*   24	*/
				     "-default                     ",	/*   25	*/
				     "-delete                      ",	/*   26	*/
				     "-descriptor                  ",	/*   27	*/
				     "-device                      ",	/*   28	*/
				     "-entry                       ",	/*   29	*/
				     "-error                       ",	/*   30	*/
				     "-first_match                 ",	/*   31	*/
				     "-footer                      ",	/*   32	*/
				     "-header                      ",	/*   33	*/
				     "-initial_acl                 ",	/*   34	*/
				     "-into                        ",	/*   35	*/
				     "-length                      ",	/*   36	*/
				     "-level                       ",	/*   37	*/
				     "-library                     ",	/*   38	*/
				     "-link_target                 ",	/*   39	*/
				     "-list                        ",	/*   40	*/
				     "-long                        ",	/*   41	*/
				     "-match                       ",	/*   42	*/
				     "-max_length                  ",	/*   43	*/
				     "-mode                        ",	/*   44	*/
				     "-name                        ",	/*   45	*/
				     "-new_line                    ",	/*   46	*/
				     "-no_chase                    ",	/*   47	*/
				     "-no_cross_reference          ",	/*   48	*/
				     "-non_ascii                   ",	/*   49	*/
				     "-object_info                 ",	/*   50	*/
				     "-offset                      ",	/*   51	*/
				     "-omit                        ",	/*   52	*/
				     "-output_file                 ",	/*   53	*/
				     "-page_length                 ",	/*   54	*/
				     "-pathname                    ",	/*   55	*/
				     "-primary                     ",	/*   56	*/
				     "-quota                       ",	/*   57	*/
				     "-records                     ",	/*   58	*/
				     "-retain                      ",	/*   59	*/
				     "-ring_brackets               ",	/*   60	*/
				     "-safety                      ",	/*   61	*/
				     "-search_name                 ",	/*   62	*/
				     "-status                      ",	/*   63	*/
				     "-time                        ",	/*   64	*/
				     "-type                        ",	/*   65	*/
				     "-unique_id                   ");	/*   66	*/

     dcl	key_ab (47)		char(6) int static options(constant) init (
				     "-acc  ",	/*   2	*/
				     "-a    ",	/*   4	*/
				     "-amch ",	/*   5	*/
				     "-at   ",	/*   6	*/
				     "-bc   ",	/*   7	*/
				     "-bf   ",	/*   8	*/
				     "-comp ",	/*  13	*/
				     "-cont ",	/*  14	*/
				     "-cp   ",	/*  16	*/
				     "-cref ",	/*  17	*/
				     "-dt   ",	/*  19	*/
				     "-dtc  ",	/*  20	*/
				     "-dtd  ",	/*  21	*/
				     "-dtem ",	/*  22	*/
				     "-dtcm ",	/*  23	*/
				     "-dtu  ",	/*  24	*/
				     "-dft  ",	/*  25	*/
				     "-dl   ",	/*  26	*/
				     "-desc ",	/*  27    */
				     "-dv   ",	/*  28	*/
				     "-et   ",	/*  29	*/
				     "-fmch ",	/*  31	*/
				     "-fo   ",	/*  32	*/
				     "-he   ",	/*  33	*/
				     "-iacl ",	/*  34	*/
				     "-ln   ",	/*  36	*/
				     "-lev  ",	/*  37	*/
				     "-lb   ",	/*  38	*/
				     "-ls   ",	/*  40	*/
				     "-lg   ",	/*  41	*/
				     "-ml   ",	/*  43	*/
				     "-md   ",	/*  44	*/
				     "-nm   ",	/*  45	*/
				     "-nl   ",	/*  46	*/
				     "-ncref",	/*  48	*/
				     "-ofs  ",	/*  51	*/
				     "-of   ",	/*  53	*/
	 			     "-pl   ",	/*  54	*/
				     "-pn   ",	/*  55	*/
				     "-pri  ",	/*  56	*/
				     "-rec  ",	/*  58	*/
				     "-ret  ",	/*  59	*/
				     "-rb   ",	/*  60	*/
				     "-st   ",	/*  63	*/
				     "-tm   ",	/*  64	*/
				     "-tp   ",	/*  65	*/
				     "-uid  ");	/*  66	*/

     dcl	key_ab_for_key_no (47)	fixed bin int static options(constant) init (
				   /* -acc   */	     2,
				   /* -a     */	     4,
				   /* -amch  */	     5,
				   /* -at    */	     6,
				   /* -bc    */	     7,
				   /* -bf    */	     8,
				   /* -comp  */	    13,
				   /* -cont  */	    14,
				   /* -cp    */	    16,
				   /* -cref  */	    17,
				   /* -dt    */	    19,
				   /* -dtc   */	    20,
				   /* -dtd   */	    21,
				   /* -dtem  */	    22,
				   /* -dtcm  */	    23,
				   /* -dtu   */	    24,
				   /* -dft   */	    25,
				   /* -dl    */	    26,
				   /* -desc  */	    27,
				   /* -dv    */	    28,
				   /* -et    */	    29,
				   /* -fmch  */	    31,
				   /* -fo    */	    32,
				   /* -he    */	    33,
				   /* -iacl  */	    34,
				   /* -ln    */	    36,
				   /* -lev   */	    37,
				   /* -lb    */	    38,
				   /* -ls    */	    40,
				   /* -lg    */	    41,
				   /* -ml    */	    43,
				   /* -md    */	    44,
				   /* -nm    */	    45,
				   /* -nl    */	    46,
				   /* -ncref */	    48,
				   /* -ofs   */	    51,
				   /* -of    */	    53,
	 			   /* -pl    */	    54,
				   /* -pn    */	    55,
				   /* -pri   */	    56,
				   /* -rec   */	    58,
				   /* -ret   */	    59,
				   /* -rb    */	    60,
				   /* -st    */	    63,
				   /* -tm    */	    64,
				   /* -tp    */	    65,
				   /* -uid   */	    66);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	if Sc_req.acl = ""b then do;			/* initialize requirements which force given	*/
	     PSreq = addr(Sc_req.acl);		/*   Scontrol bits on.			*/
	     Sreq.acl = True;

	     PSreq = addr(Sc_req.iacl);
	     string(Sreq) = ""b;
	     Sreq.iacl = True;

	     PSreq = addr(Sc_req.object_info);
	     string(Sreq) = ""b;
	     Sreq.compiler_name = True;
	     Sreq.compiler_options = True;
	     Sreq.compiler_version = True;
	     Sreq.dtc = True;
	     Sreq.object_info = True;

	     PSreq = addr(Sc_req.check_ascii);
	     string(Sreq) = ""b;
	     Sreq.not_ascii = True;

	     PSreq = addr(Sc_req.check_archive);	/* all of these bits must be on in Srequirements	*/
	     string(Sreq) = ""b;
	     Sreq.compiler_name = True;		/*   to cause Sc.check_archive to be turned on.	*/
	     Sreq.compiler_options = True;
	     Sreq.compiler_version = True;
	     Sreq.dtc = True;
	     Sreq.entry_bound = True;
	     Sreq.not_ascii = True;
	     Sreq.object_info = True;

	     PSreq = addr(Sc_req.all_status);
	     string(Sreq) = ""b;
	     Sreq.aim = True;
	     Sreq.access_class = True;
	     Sreq.author = True;
	     Sreq.bit_count_author = True;
	     Sreq.entry_bound = True;

	     PSreq = addr(Sc_req.quota);
	     string(Sreq) = ""b;
	     Sreq.quota = True;
	     end;

	Acode = 0;
	if arg_struc.version ^= Varg_struc_1 then go to BAD_ARG_STRUC;
	if ^Sc_init.descriptor 	then arg_struc.descriptor = "";
						/* initialize argument-holding variables.	*/
	if ^Sc_init.footing 	then arg_struc.footing = "";
	if ^Sc_init.heading 	then arg_struc.heading = "";
	if ^Sc_init.output_file 	then arg_struc.output_file = "";
	if ^Sc_init.page_length	then arg_struc.page_length = 0;
	if ^Sc_init.into_path 	then arg_struc.into_path = "";
	if ^Sc_init.time		then arg_struc.time = 0;
	if ^Sc_init.search_names 	then STARNAME.N = 0;
	if ^Sc_init.library 	then LIBRARY.N = 0;
	EXCLUDE.N = 0;
	Srequirements = arg_struc.Srequirements_initial;
	Scontrol = arg_struc.Scontrol_initial;
	Sc.descriptor   = False;
	Sc.footing      = False;
	Sc.heading      = False;
	Sc.output_file  = False;
	Sc.page_length  = False;
	Sc.into_path    = False;
	Sc.search_names = False;
	Sc.library      = False;
	Sc.time         = False;
	Poperand = addr(Poperand);			/* initialize operand to a null string for use	*/
	Loperand = 0;				/*   in error messages.			*/
	Slib = False;
	Sstar = False;
	Srequirements_disallowed = ^arg_struc.Srequirements_allowed;
	Scontrol_disallowed = ^arg_struc.Scontrol_allowed;

	do i = arg_struc.Iarg_list to arg_struc.Larg_list;
	     call cu_$arg_ptr_rel (i, Parg, Larg, code, arg_struc.Parg_list);
						/* get the argument.			*/
	     if substr (arg, 1, 1) = "-" then;		/* if argument is not a control argument, it must	*/
	     else do;				/* be a star name.				*/
		Poperand = Parg;
		Loperand = Larg;
		Larg = 0;
		if Sc_allowed.search_names then
		     go to SET_STARNAME;
		else go to SET_LIBNAME;
		end;
	     do j = 1 to dimension (key_ab, 1) while (arg ^= key_ab(j));
		end;
	     if j > dimension (key_ab, 1) then do;
		do j = 1 to dimension (keyword, 1) while (arg ^= keyword(j));
		     end;
		if j > dimension (keyword, 1) then go to BAD_OPT;
		end;
	     else j = key_ab_for_key_no (j);
	     go to KEY(j);				/* if arg is a valid keyword, process it.	*/

KEY(27):	     Sallowed = Sc_allowed.descriptor;		/* if this is a keyword which requires an operand,*/
	     go to GET_OPERAND;
KEY(32):	     Sallowed = Sc_allowed.footing;		/*   then get the next argument.		*/
	     go to GET_OPERAND;
KEY(33):	     Sallowed = Sc_allowed.heading;
	     go to GET_OPERAND;
KEY(35):	     Sallowed = Sc_allowed.into_path;
	     go to GET_OPERAND;
KEY(38):	     Sallowed = Sc_allowed.library;
	     go to GET_OPERAND;
KEY(53):	     Sallowed = Sc_allowed.output_file;
	     go to GET_OPERAND;
KEY(54):	     Sallowed = Sc_allowed.page_length;
	     go to GET_OPERAND;
KEY(62):	     Sallowed = Sc_allowed.search_names;
	     go to GET_OPERAND;
KEY(64):	     Sallowed = Sc_allowed.time;
	     go to GET_OPERAND;
GET_OPERAND:   if i = arg_struc.Larg_list then		/* See if there's another arg.  It's expected.	*/
		if Sallowed then
		     go to MISSING_ARG;
		else go to BAD_OPT;
	     i = i + 1;
	     call cu_$arg_ptr_rel (i, Poperand, Loperand, code, arg_struc.Parg_list);
						/* get the next arg.			*/
	     if ^Sallowed then go to BAD_OPT;
	     go to KEY_OPERAND(j);			/* process it.				*/

KEY(1):	     S.mode = True;				/* -access (all access attributes required)	*/
	     S.rb = True;
	     S.acl = True;
	     Sc.acl = True;
	     S.iacl = True;
	     Sc.iacl = True;
	     S.access_class = True;
	     S.aim = True;
	     S.entry_bound = True;
	     S.safety = True;
	     Sc.all_status = True;
	     go to NEXT_ARG;

KEY(2):	     S.access_class = True;			/* -access_class				*/
	     S.aim = True;
	     Sc.all_status = True;
	     go to NEXT_ARG;

KEY(3):	     S.acl = True;				/* -acl					*/
	     Sc.acl = True;
	     go to NEXT_ARG;

KEY(4):	     Srequirements = arg_struc.Srequirements_allowed;
	     if (Srequirements & Sc_req.acl) then	/* -all or -a (set all requirements on).	*/
		Sc.acl = True;
	     if (Srequirements & Sc_req.iacl) then Sc.iacl = True;
	     if (Srequirements & Sc_req.object_info) then Sc.object_info = True;
	     if (Srequirements & Sc_req.check_ascii) then Sc.check_ascii = True;
	     if ((Srequirements & Sc_req.check_archive) = Sc_req.check_archive) then
		Sc.check_archive = True;
	     if (Srequirements & Sc_req.all_status) then Sc.all_status = True;
	     if (Srequirements & Sc_req.quota) then Sc.quota = True;
	     go to NEXT_ARG;

KEY(5):	     Sc.first_match = False;			/* -all_matches or -amch			*/
	     go to NEXT_ARG;

KEY(6):	     S.author = True;			/* -author or -at				*/
	     S.bit_count_author = True;
	     Sc.all_status = True;
	     go to NEXT_ARG;

KEY(7):	     S.bit_count = True;			/* -bit_count or -bc 			*/
	     S.msf_indicator = True;
	     go to NEXT_ARG;

KEY(8):	     Sc.long = False;			/* -brief or -bf				*/
	     go to NEXT_ARG;

KEY(9):	     Sc.chase = True;			/* -chase (links should be chased).		*/
	     go to NEXT_ARG;

KEY(10):	     S.compiler_name = True;			/* -compiler_name				*/
	     Sc.object_info = True;
	     go to NEXT_ARG;

KEY(11):	     S.compiler_options = True;		/* -compiler_options		 	*/
	     Sc.object_info = True;
	     go to NEXT_ARG;

KEY(12):	     S.compiler_version = True;		/* -compiler_version			*/
	     Sc.object_info = True;
	     go to NEXT_ARG;

KEY(13):	     Sc.components = True;			/* -components or -comp (print all nodes below a 	*/
	     go to NEXT_ARG;			/*   parent node)				*/

KEY(14):	     Sc.container = True;			/* -container or -cont  (print parent nodes)	*/
	     go to NEXT_ARG;

KEY(15):	     S.dtc = True;				/* -contents (description of entry contents	*/
	     S.compiler_version = True;		/*    is required).				*/
	     S.compiler_name = True;
	     S.compiler_options = True;
	     S.object_info = True;
	     Sc.object_info = True;
	     S.not_ascii = True;
	     Sc.check_ascii = True;
	     S.entry_bound = True;
	     Sc.all_status = True;
	     Sc.check_archive = True;
	     go to NEXT_ARG;

KEY(16):	     S.copy = True;				/* -copy or -cp (copy switch setting reqd).	*/
	     go to NEXT_ARG;

KEY(17):	     S.cross_ref = True;			/* -cross_reference or -cref.			*/
	     go to NEXT_ARG;

KEY(18):       S.current_length = True;			/* -current_length				*/
	     go to NEXT_ARG;

KEY(19):	     S.dtm = True;				/* -date or -dt (all storage system dates reqd).	*/
	     S.dtu = True;
	     S.dtem = True;
	     S.dtd = True;
	     S.dtc = True;
	     Sc.object_info = True;
	     go to NEXT_ARG;

KEY(20):	     S.dtc = True;				/* -date_time_compiled or -dtc		*/
	     Sc.object_info = True;
	     go to NEXT_ARG;

KEY(21):	     S.dtd = True;				/* -date_time_dumped or -dtd			*/
	     go to NEXT_ARG;

KEY(22):	     S.dtem = True;				/* -date_time_entry_modified or -dtem		*/
	     go to NEXT_ARG;

KEY(23):	     S.dtm = True;				/* -date_time_contents_modified or -dtcm	*/
	     go to NEXT_ARG;

KEY(24):	     S.dtu = True;				/* -date_time_used or -dtu			*/
	     go to NEXT_ARG;

KEY(25):	     Sc.default = True;			/* -default or -dft (default info required for	*/
	     go to NEXT_ARG;			/*    each entry, according to library search pgm,*/
						/*    in addition to info reqd by control args).	*/

KEY(26):	     Sc.delete = True;			/*  -delete of -dl (Library entries to be deleted)*/
	     go to NEXT_ARG;

KEY_OPERAND(27):
	     arg_struc.descriptor = operand;		/* -descriptor or -desc (use other than		*/
	     Sc.descriptor = True;			/*   default library descriptor.)		*/
	     go to NEXT_ARG;

KEY(28):	     S.lvid = True;				/* -device or -dv				*/
	     go to NEXT_ARG;

KEY(29):	     Sc.components = False;			/* -entry or -et (info about parent or component	*/
	     Sc.container = False;			/*   of matching library entry is not required).	*/
	     go to NEXT_ARG;

KEY(30):	     S.kids_error = True;			/* -error (errors obtaining descendant		*/
	     go to NEXT_ARG;			/*    nodes required).			*/

KEY(31):	     Sc.first_match = True;			/* -first_match or -fmch			*/
	     go to NEXT_ARG;

KEY_OPERAND(32):
	     arg_struc.footing = operand;		/* -footer or -fo (set value of footing).	*/
	     Sc.footing = True;
	     go to NEXT_ARG;

KEY_OPERAND(33):
	     arg_struc.heading = operand;		/* -header or -he (set value of heading line.)	*/
	     Sc.heading = True;
	     go to NEXT_ARG;

KEY(34):	     S.iacl = True;				/* -initial_acl or -iacl			*/
	     Sc.iacl = True;
	     go to NEXT_ARG;

KEY_OPERAND(35):
	     arg_struc.into_path = operand;		/* -into	(path into which entries are fetched).	*/
	     Sc.into_path = True;
	     go to NEXT_ARG;

KEY(36):	     S.records_used = True;			/* -length or -ln (all lengths required).	*/
	     S.current_length = True;
	     S.bit_count = True;
	     S.msf_indicator = True;
	     S.offset = True;
 	     S.max_length = True;
	     S.quota = True;
	     Sc.quota = True;
	     go to NEXT_ARG;

KEY(37):	     S.level = True;			/* -level or -lev (level number to precede each	*/
	     go to NEXT_ARG;			/*    entry).				*/

KEY_OPERAND(38):					/* -library or -lb;  store library name.	*/
SET_LIBNAME:   if ^Sc.library then do;
		LIBRARY.N = 0;			/* user wants to override initial value.	*/
		Sc.library = True;
		end;
	     if LIBRARY.N = dimension(LIBRARY.group,1) then go to TOO_MANY_LIBS;
	     LIBRARY.N = LIBRARY.N + 1;
	     LIBRARY.V(LIBRARY.N) = operand;
	     call check_star_name_$entry (operand, code);
	     if code = error_table_$badstar then do;
		LIBRARY.N = LIBRARY.N - 1;
		go to BAD_LIB;			/* make sure library name has proper format.	*/
		end;
	     else LIBRARY.C(LIBRARY.N) = code;
	     if LIBRARY.C(LIBRARY.N) = 2 then do;	/* if star name is **, make it first name.	*/
		if LIBRARY.C(1) = 2 then LIBRARY.N = max(LIBRARY.N - 1, 1);
		else do;				/*   1st name not already **; swap with Nth name.	*/
		     LIBRARY.V(LIBRARY.N) = LIBRARY.V(1);
		     LIBRARY.C(LIBRARY.N) = LIBRARY.C(1);
		     LIBRARY.V(1) = operand;
		     LIBRARY.C(1) = 2;
		     end;
		end;
	     go to NEXT_ARG;

KEY(39):	     S.link_target = True;			/* -link_target				*/
	     go to NEXT_ARG;

KEY(40):	     Sc.list = True;			/* -list or -ls (Library entries subject to 	*/
	     go to NEXT_ARG;			/*   cleanup are to be listed.)		*/

KEY(41):	     Sc.long = True;			/* -long or -lg				*/
	     go to NEXT_ARG;

KEY(42):	     S.matching_names = True;			/* -match (all matching names required).	*/
	     go to NEXT_ARG;

KEY(43):	     S.max_length = True;			/* -max_length or -ml			*/
	     go to NEXT_ARG;

KEY(44):	     S.mode = True;				/* -mode or -md				*/
	     go to NEXT_ARG;

KEY(45):	     S.names = True;			/* -name or -nm				*/
	     go to NEXT_ARG;

KEY(46):	     S.new_line = True;			/* -new_line or -nl (new-line char to separate	*/
	     go to NEXT_ARG;			/*    major entries.			*/

KEY(47):	     Sc.chase = False;			/* -no_chase				*/
	     go to NEXT_ARG;

KEY(48):	     S.cross_ref = False;			/* -no_cross_reference or -ncref		*/
	     go to NEXT_ARG;

KEY(49):	     S.not_ascii = True;			/* -non_ascii (check for non-ascii segment	*/
	     Sc.check_ascii = True;			/*    required).				*/
	     go to NEXT_ARG;

KEY(50):	     S.object_info = True;			/* -object_info (other compiler attributes	*/
	     Sc.object_info = True;			/*    required).				*/
	     go to NEXT_ARG;

KEY(51):	     S.offset = True;			/* -offset or -ofs (offset of archive comps reqd).*/
	     go to NEXT_ARG;

KEY(52):	     Sc.retain = False;			/* -omit (don't retain entries awaiting deletion).*/
	     go to NEXT_ARG;

KEY_OPERAND(53):
	     arg_struc.output_file = operand;		/* -output_file or -of			*/
	     Sc.output_file = True;
	     go to NEXT_ARG;

KEY_OPERAND(54):					/* -page_length or -pl			*/
	     on conversion go to BAD_TIME;
	     arg_struc.page_length = convert(arg_struc.page_length, operand);
	     revert conversion;
	     if arg_struc.page_length < 10 | arg_struc.page_length > 120 then go to BAD_TIME;
	     go to NEXT_ARG;

KEY(55):	     S.pathname = True;			/* -pathname or -pn				*/
	     go to NEXT_ARG;

KEY(56):	     S.primary_name = True;			/* -primary or -pri				*/
	     go to NEXT_ARG;

KEY(57):	     S.quota = True;			/* -quota					*/
	     Sc.quota = True;
	     go to NEXT_ARG;

KEY(58):	     S.records_used = True;			/* -records or -rec				*/
	     go to NEXT_ARG;

KEY(59):	     Sc.retain = True;			/* -retain or -ret (keep nodes awaiting deletion).*/
	     go to NEXT_ARG;

KEY(60):	     S.rb = True;				/* -ring_brackets or -rb			*/
	     S.entry_bound = True;
	     Sc.all_status = True;
	     go to NEXT_ARG;

KEY(61):	     S.safety = True;			/* -safety				*/
	     go to NEXT_ARG;

KEY_OPERAND(62):					/* -search_name (arg which follows looks	*/
SET_STARNAME:					/*    like a keyword, but is really a star name.	*/
	     if ^Sc.search_names then do;
		STARNAME.N = 0;
		Sc.search_names = True;
		end;
	     else if STARNAME.N = 1 then		/* if a star name of ** has been encountered	*/
		if STARNAME.C(1) = 2 then		/*    previously, ignore all other star names.	*/
		     go to NEXT_ARG;
	     if STARNAME.N = dimension (STARNAME.group,1) then go to TOO_MANY_STAR;
	     STARNAME.N = STARNAME.N + 1;
	     STARNAME.V(STARNAME.N) = operand;
	     call check_star_name_$entry (operand, code);
	     if code = error_table_$badstar then do;
		STARNAME.N = STARNAME.N - 1;
		go to BAD_STAR;			/* make sure starname name has proper format.	*/
		end;
	     else STARNAME.C(STARNAME.N) = code;
	     if STARNAME.C(STARNAME.N) = 2 then do;	/* if this starname is **, then ignore all other	*/
		STARNAME.N = 1;			/*    star names, and use only this one.	*/
		STARNAME.V(1) = operand;
		STARNAME.C(1) = 2;
		end;
	     go to NEXT_ARG;

KEY(63):	     S.primary_name = True;			/* -status (all info given by status -all).	*/
	     S.matching_names = True;
	     S.kids = True;
	     S.kids_error = True;
	     S.type = True;
	     S.copy = True;
	     S.unique_id = True;
	     S.dtem = True;
	     S.dtd = True;
	     S.dtm = True;
	     S.dtu = True;
	     S.link_target = True;
	     S.records_used = True;
	     S.current_length = True;
	     S.msf_indicator = True;
	     S.bit_count = True;
	     S.offset = True;
	     S.lvid = True;
	     S.max_length = True;

	     S.author = True;
	     S.bit_count_author = True;
	     Sc.all_status = True;
	     go to NEXT_ARG;

KEY_OPERAND(64):
	     Sc.time = True;
	     on conversion go to BAD_TIME;		/* -time NN   or   -tm NN			*/
	     arg_struc.time = convert(arg_struc.time, operand);
	     revert conversion;
	     if arg_struc.time < 0 then go to BAD_TIME;
	     go to NEXT_ARG;

KEY(65):	     S.type = True;				/* -type or -tp				*/
	     go to NEXT_ARG;

KEY(66):	     S.unique_id = True;			/* -unique_id or -uid			*/
	     go to NEXT_ARG;

BAD_TIME:	     revert conversion;
	     go to BAD_OPT;

NEXT_ARG:	     if Srequirements & Srequirements_disallowed then do;
		Srequirements = Srequirements & arg_struc.Srequirements_allowed;
BAD_OPT:		code = error_table_$bad_arg;
BAD_LIB:
BAD_STAR:		call arg_struc.put_error (code, arg_struc.program, " ^a ^a", arg, operand);
		if Acode = 0 then Acode = code;
		end;
	     else if Scontrol & Scontrol_disallowed then do;
		Scontrol = Scontrol & arg_struc.Scontrol_allowed;
		go to BAD_OPT;
		end;
	     Loperand = 0;
	     go to END_LOOP;

MISSING_ARG:   call arg_struc.put_error (error_table_$wrong_no_of_args, arg_struc.program, "
  The  ^a  control argument requires an operand.", arg);
	     if Acode = 0 then Acode = error_table_$wrong_no_of_args;
	     go to END_LOOP;

TOO_MANY_LIBS: name_type = "Library";
	     names_allowed = dimension(LIBRARY.group, 1);
	     PSname = addr(Slib);
	     go to TOO_MANY;
TOO_MANY_STAR: name_type = "Search";
	     names_allowed = dimension(STARNAME.group, 1);
	     PSname = addr(Sstar);

TOO_MANY:	     if Sname then
		call arg_struc.put_error (error_table_$too_many_names, arg_struc.program, "
  ^a name  ^a ^a  ignored.", name_type, arg, operand);
	     else do;
		Sname = True;
		call arg_struc.put_error (error_table_$too_many_names, arg_struc.program, "
  ^a name storage exceeded;  only ^d names can be given.
  ^a ^a  ignored.", name_type, names_allowed, arg, operand);
		if Acode = 0 then Acode = error_table_$too_many_names;
		end;
	     go to END_LOOP;

END_LOOP:	     end;

						/* mark args requiring operand as present if	*/
						/*   arg given, or if default value given.	*/
          Sc.descriptor   = Sc.descriptor   | Sc_init.descriptor;         
          Sc.footing      = Sc.footing      | Sc_init.footing;            
          Sc.heading      = Sc.heading      | Sc_init.heading;
          Sc.output_file  = Sc.output_file  | Sc_init.output_file;
	Sc.page_length  = Sc.page_length  | Sc_init.page_length;
          Sc.into_path    = Sc.into_path    | Sc_init.into_path;
          Sc.search_names = Sc.search_names | Sc_init.search_names;
          Sc.library      = Sc.library      | Sc_init.library;
	Sc.time	      = Sc.time         | Sc_init.time;

	if LIBRARY.N > 0 then do;			/* validate the library names.		*/
	     call lib_descriptor_$validate_library (arg_struc.descriptor, addr(LIBRARY), addr(bad_library), code);
	     if bad_library.N > 0 then do;
		call arg_struc.put_error (error_table_$bad_arg, arg_struc.program, "
  Library descriptor '^a' does not define the", arg_struc.descriptor);
		call lib_error_list_ ("library name", addr(bad_library), arg_struc.program);
		if Acode = 0 then Acode = error_table_$bad_arg;
		end;
	     else if code ^= 0 then do;
		call arg_struc.put_error (code, arg_struc.program, "
  While accessing library descriptor:  ^a ", arg_struc.descriptor);
		if Acode = 0 then Acode = code;
		end;
	     else if LIBRARY.C(1) = 2 then LIBRARY.N = 1;	/* If ** given as library name, ignore all others.*/
	     end;
	return;


BAD_ARG_STRUC:
	call arg_struc.put_error (error_table_$unimplemented_version, "lib_args_", "
  Version ^d of the library argument structure is not supported.", arg_struc.version);
	code = error_table_$unimplemented_version;

%include lib_arg_struc_;

%include lib_Svalid_req_;

%include lib_Scontrol_;

	end lib_args_;




		    lib_descriptor_.pl1             02/15/84  0911.2rew 02/15/84  0750.0      236574



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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* NAME:  lib_descriptor_							*/
	/*									*/
	/*     THis procedure interfaces between the various library maintenance tools and the	*/
	/* library status gathering subroutines by mapping user-supplied (or default) library	*/
	/* names into the pathnames of library directories or archives to be searched.  It 	*/
	/* also provides a pre-defined, per-library search procedure to find library entries.	*/
	/*									*/
	/* ENTRIES:  $info, $map, $print, $fetch, $cleanup				*/
	/*									*/
	/*      These entries are provided to support the five basic library maintenance tools,	*/
	/* library_info, library_map, library_print, library_fetch, and library_cleanup.  All	*/
	/* perform the same basic function of gathering library status;  however, this status	*/
	/* gathering operation often differs in depth of search, cross-referencing, default info	*/
	/* returned, etc between the different library tools.				*/
	/*									*/
	/* ENTRIES:  $name, $set_name							*/
	/*									*/
	/*      These entries return and set the name of the library descriptor which is used	*/
	/* by default to do the name mapping, etc.  The initial default value is the		*/
	/* multics_libraries_ library descriptor.					*/
	/*									*/
	/* ENTRY:  $default_values	 						*/
	/*									*/
	/*      This entry returns information about the default library names and search names	*/
	/* which are used by the various library tools.					*/
	/*									*/
	/* ENTRIES:  $libraries, $validate_library					*/
	/*									*/
	/*      These entries return information about the libraries defined in a given library	*/
	/* descriptor, and validate the correctness of library names with respect to a given	*/
	/* library descriptor.							*/
	/*									*/
	/* STATUS									*/
	/*									*/
	/* 0) Created on:   March 1, 1975  by  G. C. Dixon				*/
	/* 1) Modified on:  May 25, 1976   by  G. C. Dixon				*/
	/*    a) Use new library descriptor format provided by library_descriptor_compiler,	*/
	/*       Version 3.0.							*/
	/* 2) Modified on:  January 18, 1984 by Jim Lippard to add n_found			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

lib_descriptor_:	procedure;


     dcl						/*	parameters			*/
	Adescriptor		char(168) varying;	/* name of a library descriptor. (In/Out)	*/
%include lib_based_args_;
     dcl	1 bad_library		based (Pbad_library),
	  2 N			fixed bin,
	  2 group (0 refer (bad_library.N))
				like library.group,
	Pbad_library		ptr,
	ASrequirements		bit(72) aligned,	/* requirement switches. (In)			*/
	AScontrol			bit(36) aligned,	/* control switches. (In)			*/
	Parea			ptr,		/* ptr to area in which status tree is to be	*/
						/*    allocated. (In)			*/
	Acommand			fixed bin,	/* index of a command using the descriptor. (In)	*/
	Acommand_name		char(32),		/* name of command using the descriptor. (Out)	*/
	ASunsupported		bit(1) unal,	/* on if command is not supported by the 	*/
						/*    specified descriptor. (Out)		*/
	Ptree			ptr,		/* ptr to status tree. (Out)			*/
	progress			fixed bin,	/* integer identifying progress of search. (Out)	*/
	Acode			fixed bin(35);	/* a status code. (Out)			*/

     dcl						/*	automatic variables			*/
	Nnodes			fixed bin,	/* = dimension (root node array of status tree)	*/
	Pnodes			ptr,		/* = addr (root node array of status tree)	*/
	Prt			ptr,		/* = addr (rt).				*/
	Sfound			bit(1) aligned,
						/* switch:  on if library found.		*/
	code			fixed bin(35),	/* a status code.				*/
         (i, j, k)			fixed bin;	/* do group indices.			*/

     dcl	1 command_info		aligned,		/* info passed to search routine		*/
	  2 command		fixed bin,	/* index of command referencing descriptor.	*/
	  2 n_found		fixed bin;	/* number of entries found			*/

     dcl						/* 	based variables			*/
	area			area based (Parea),	/* an allocation area.			*/
	1 rt			like root based (Prt);
						/* overlay for a root.			*/


     dcl						/*	builtin functions			*/
         (addr, addrel, dimension, length, min, null, substr)
				builtin;


     dcl						/*	entries				*/
	cu_$decode_entry_value	entry (entry, ptr, ptr),
	cv_entry_			entry (char(*), ptr, fixed bin(35)) returns (entry),
	lib_free_node_$array	entry (ptr),
	lib_get_tree_$root_array	entry (fixed bin, ptr, ptr, fixed bin(35)),
	lib_get_tree_$root_array_info entry (ptr, fixed bin, fixed bin(35)),
	lib_get_tree_$lib_root_node	entry (ptr, fixed bin, char(168) varying, char(65) varying, ptr, ptr,
				       bit(72) aligned, bit(36) aligned, ptr,
				       entry, ptr, ptr, fixed bin, fixed bin(35)),
	match_star_name_		entry (char(*), char(*), fixed bin(35));

     dcl						/*	static variables			*/
	1 defaultP		aligned like P int static,
						/* pointers to the aggregates of the default	*/
						/*    library descriptor.			*/
         (error_table_$name_not_found,
	error_table_$noarg,
	error_table_$nomatch,
	error_table_$out_of_bounds,
	error_table_$process_stopped,
	error_table_$request_not_recognized,
	error_table_$unimplemented_version)
				fixed bin(35) ext static,
	first_call		bit(1) aligned int static init ("1"b),
						/* switch:  on if lib_descriptor_ has not been	*/
						/*    referenced in this process before.	*/
	multics_libraries_$descriptor	fixed bin ext static,
						/* first word of the initial default library	*/
						/*    descriptor.				*/
	1 zero_names		int static options(constant),
						/* an empty name structure.			*/
	  2 N			fixed bin init(0);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


info:	entry	(Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree,
		 progress, Acode);

	command_info.command = library_info;
	go to common;


map:	entry	(Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree,
		 progress, Acode);

	command_info.command = library_map;
	go to common;


print:	entry 	(Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree,
		 progress, Acode);

	command_info.command = library_print;
	go to common;


fetch:	entry     (Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree,
		 progress, Acode);

	command_info.command = library_fetch;
	go to common;


cleanup:	entry	(Adescriptor, Plibrary, Pstarname, Pexclude, ASrequirements, AScontrol, Parea, Ptree,
		 progress, Acode);

	command_info.command = library_cleanup;
	go to common;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* _p_r_o_g_r_e_s_s								*/
	/*									*/
	/* 1) If the user has specified a descriptor, then get a pointer to it and its aggregates.*/
	/*    Otherwise, get pointers to the default descriptor's aggregates, and return the	*/
	/*    name of the default descriptor.						*/
	/* 2) See if the command is supported by this descriptor.  If not, return an error code.	*/
	/* 3) See if the user supplied any library names.  If not, address the default library	*/
	/*    names specified by the descriptor for this command.  If none in descriptor either,	*/
	/*    return an error code.							*/
	/* 4) Repeat step 3 for star names used to search for library entries.		*/
	/* 5) Allocate an array of root nodes for the status tree which is big enough to hold _a_l_l	*/
	/*    of the roots defined by this descriptor.  This will handle the maximum possible	*/
	/*    case.								*/
	/* 6) Compare the library names with the names of defined roots.  When a match is found,	*/
	/*    fill in a status tree root node for that root, and look for library entries in the	*/
	/*    root which match the search name(s).  If no matching library entries are found,	*/
	/*    remove the root from the root node array.					*/
	/* 7) If the root node array of the status tree is empty after all roots identified	*/
	/*    by the library names have been searched, then free the root node array and return	*/
	/*    an error code.  Otherwise, return a pointer to the status tree.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

common:	Ptree = null;				/* initialize return arguments.		*/
	command_info.n_found = 0;

	progress = 1;				/* find descriptor.				*/
	call find_descriptor (Adescriptor, P, Acode);	/* note that Acode is initialized here.		*/
	if Acode ^= 0 then return;

	progress = 2;				/* see if command supported.			*/
	if command_default_values.N < command then go to unsupported;
	if command_default_values(command).S.unsupported then do;
unsupported:   Acode = error_table_$request_not_recognized;
	     return;
	     end;

	progress = 3;				/* address library names.			*/
	if library.N < 1 then do;
	     Plibrary_names = addrel (P.descriptor, command_default_values(command).library_names.O);
	     Plibrary = addr(library_names.N);
	     end;
	if library.N < 1 then do;
	     Acode = error_table_$noarg;
	     return;
	     end;

	progress = 4;				/* address the search names.			*/
	if starname.N < 1 then do;
	     Psearch_names = addrel (P.descriptor, command_default_values(command).search_names.O);
	     Pstarname = addr(search_names.N);
	     end;
	if starname.N < 1 then do;
	     Acode = error_table_$noarg;
	     return;
	     end;

	progress = 5;				/* allocate the root nodes of the status tree.	*/
	call lib_get_tree_$root_array (roots.N, Parea, Pnodes, Acode);
	if Acode ^= 0 then
	     return;

	progress = 6;				/* find library entries in roots matching library	*/
	Sfound = "0"b;				/*    names.				*/
	do k = 1 to roots.N;
	     Proot_names = addrel (P.descriptor, roots.root(k).name.O);
	     do i = 1 to root_names.N;
		do j = 1 to library.N;
		     go to match (library(j).C);

match(0):		     if root_names.root_name(i) = library(j).V then go to match_found;
		     go to no_match;

match(1):		     call match_star_name_ (root_names.root_name(i), library(j).V, code);
		     if code = 0 then go to match_found;

no_match:		     end;
		end;
	     go to next_name;

match(2):
match_found:   Sfound = "1"b;
	     Prt = addr(roots.root(k));
	     call lib_get_tree_$lib_root_node (Proot_names, rt.type, rt.path, rt.search_proc_name, Pstarname,
		Pexclude, ASrequirements, AScontrol, Parea, rt.search_proc, addr(command_info),
		Pnodes, roots.N, code);
	     if code = error_table_$process_stopped then do;
		code = 0;
		go to stop_searching;
		end;
	     else if code ^= 0 then
		Acode = code;			/* return last bad error to caller.		*/
next_name:     end;
stop_searching:
	call lib_get_tree_$root_array_info (Pnodes, Nnodes, code);
	if (Nnodes > 0) | Sfound then do;		/* find out about resultant status tree.	*/
	     if Acode = 0 then 			/* return any code from tree except nomatch.	*/
		if code ^= error_table_$nomatch then
		     Acode = code;
	     Ptree = Pnodes;			/* if non-empty, return tree, with any code rec'd	*/
	     return;				/*    while getting tree, to caller.		*/
	     end;

	progress = 7;				/* tree empty.  Tell user why and return.	*/
	if Acode = 0 then
	     if code ^= 0 then
		Acode = code;			/* return lib_get_tree_'s reason for empty tree.	*/
	     else
		Acode = error_table_$nomatch;
	call lib_free_node_$array (Pnodes);		/* free up Dnodes.				*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


name:	entry	(Adescriptor);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point returns the name of the current default library descriptor.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	if first_call then call find_descriptor ("", P, code);
	else P.descriptor = defaultP.descriptor;
	Adescriptor = descriptor.name;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set_name:	entry	(Adescriptor, Acode);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point sets the name of the default library descriptor.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	if Adescriptor = "" then first_call = "1"b;	/* if returning to the initial default descriptor,*/
						/*    re-initialize default descriptor values.	*/
	call find_descriptor (Adescriptor, P, Acode);
	if Acode = 0 then
	     defaultP = P;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


default_values:	entry    (Adescriptor, Acommand, Acommand_name, ASunsupported, Plibrary, Pstarname, Pexclude,
			progress, Acode);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point expects as input either:  1) the index of a library command; or 	*/
	/* 2) the name of a library command.  If a name is given, it converts the name to an	*/
	/* index.  If the index is valid, the entry point returns the following information about	*/
	/* the command:  the name of the command;  a switch indicating whether or not the	*/
	/* command is supported by the specified (or default) library descriptor;  and the	*/
	/* default library names and search names associated with the command (if any).  If the	*/
	/* index is invalid, or if the specified library descriptor cannot be located, it returns	*/
	/* a non-zero error code.							*/
	/*									*/
	/* _p_r_o_g_r_e_s_s								*/
	/*									*/
	/* 0) Validate the command index (if given), or convert the command name to a command	*/
	/*    index.								*/
	/* 1) If the user specified a library descriptor, then get a pointer to it and its	*/
	/*    aggregates.  Otherwise, get pointers to the default descriptor's aggregates.	*/
	/* 2) Report whether or not the command is supported.				*/
	/* 3) If supported, return any default values for library names and search names.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	ASunsupported = "1"b;			/* initialize output values.			*/
	Plibrary = addr(zero_names);
	Pstarname = addr(zero_names);
	Acode = 0;

	progress = 0;				/* progress command index.			*/
	if Acommand < 1 then do;			/* a command name was given.  Convert it to an	*/
						/*    index.				*/
	     do i = 1 to dimension (command_name,1) while (command_name(i) ^= Acommand_name);
		end;
	     if i > dimension (command_name,1) then do;
		do i = 1 to dimension (command_abbrev,1) while (command_abbrev(i) ^= Acommand_name);
		     end;
		if i > dimension (command_abbrev,1) then go to bad_command_name;
		Acommand_name = command_name(i);	/* return full command name in place of abbrev.	*/
		end;
	     command_info.command = i;
	     Acommand = i;
	     end;
	else do;					/* validate the command index.		*/
	     if Acommand > dimension (command_name,1) then go to bad_command_index;
	     command_info.command = Acommand;
	     Acommand_name = command_name(command_info.command);	/* return the command name.			*/
	     end;

	progress = 1;				/* find the descriptor.			*/
	call find_descriptor (Adescriptor, P, Acode);
	if Acode ^= 0 then return;

	progress = 2;				/* report whether or not command supported.	*/
	if command_default_values.N < command_info.command then do;
	     ASunsupported = "1"b;			/* an old library descriptor doesn't include this	*/
	     return;				/*    command.  Command is unsupported.		*/
	     end;
	ASunsupported = command_default_values(command_info.command).S.unsupported;
	if ASunsupported then return;			/* no more to do for an unsupported command.	*/

	progress = 3;				/* report on any default values.		*/
	Plibrary_names = addrel (P.descriptor, command_default_values(command_info.command).library_names.O);
	Plibrary = addr (library_names.N);
	Psearch_names = addrel (P.descriptor, command_default_values(command_info.command).search_names.O);
	Pstarname = addr (search_names.N);
	return;

bad_command_index:
	Acode = error_table_$out_of_bounds;		/* no such command index as being asked for.	*/
	return;

bad_command_name:
	Acode = error_table_$name_not_found;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


libraries:	entry    (Adescriptor, Plibrary, ASrequirements, Parea, Ptree, progress, Acode);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point expects as input an array of library names.  It returns as output an	*/
	/* array of library root nodes (suitable for printing by the lib_output_node_ subroutine) */
	/* for the libraries in the library descriptor which match the specified library names.	*/
	/* If no library names are given, an error is returned.				*/
	/*									*/
	/* _p_r_o_g_r_e_s_s								*/
	/*									*/
	/* 1) If the user specified a library descriptor, then get a pointer to it and its	*/
	/*    aggregates.  Otherwise, get pointers to the default descriptor's aggregates.	*/
	/* 3) Make sure caller specified some library names, and overlay these names.		*/
	/* 5) Allocate an array of root nodes big enough to hold all of the roots defined in the	*/
	/*    descriptor being referenced.  This is a guaranteed fit.			*/
	/* 6) Compare the library names with the names of the defined roots.  When a match is	*/
	/*    found, fill in a root node for that root.  					*/
	/* 7) If no matching roots are found, free the array of root nodes and return an error.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	Ptree = null;				/* initialize output argument.		*/
	progress = 1;				/* find the descriptor.			*/
	call find_descriptor (Adescriptor, P, Acode);
	if Acode ^= 0 then return;

	progress = 3;				/* check for and overlay library names.		*/
	if library.N <= 0 then do;
	     Acode = error_table_$noarg;
	     return;
	     end;

	progress = 5;				/* allocate array of root nodes big enough for	*/
						/*    all roots defined by this descriptor.	*/
	call lib_get_tree_$root_array (roots.N, Parea, Pnodes, Acode);
	if Acode ^= 0 then return;

	progress = 6;				/* find/output root nodes for matching roots.	*/
	do k = 1 to roots.N;
	     Proot_names = addrel (P.descriptor, roots.root(k).name.O);
	     do i = 1 to root_names.N;
		do j = 1 to library.N;
		     go to match_lib (library(j).C);

match_lib (0):	     if root_names.root_name(i) = library(j).V then go to match_found_lib;
		     go to no_match_lib;

match_lib (1):	     call match_star_name_ (root_names.root_name(i), library(j).V, code);
		     if code = 0 then go to match_found_lib;

no_match_lib:	     end;
		end;
	    go to next_name_lib;

match_lib (2):
match_found_lib:
	     Prt = addr(roots.root(k));
	     call lib_get_tree_$lib_root_node (Proot_names, rt.type, rt.path, rt.search_proc_name, addr(zero_names),
		addr(zero_names), ASrequirements, "0"b, Parea, null_search_proc, addr(command_info.command),
		Pnodes, roots.N, code);
	     if code = error_table_$process_stopped then do;
		code = 0;
		go to stop_searching_lib;
		end;
	     else if code ^= 0 then
		Acode = code;			/* return last bad error to caller.		*/
next_name_lib: end;
stop_searching_lib:

	call lib_get_tree_$root_array_info (Pnodes, Nnodes, code);
	progress = 7;
	if Nnodes = 0 then do;			/* no matching root definitions found. ERROR	*/
	     Acode = error_table_$nomatch;
	     call lib_free_node_$array (Pnodes);
	     end;
	else
	     Ptree = Pnodes;
	return;

null_search_proc:	procedure;			/* Null search procedure which does nothing.	*/

	end null_search_proc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


validate_library:	entry (Adescriptor, Plibrary, Pbad_library, Acode);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point expects as input an array of library names and an empty library	*/
	/* name array of the same size.  It returns as output in the empty array the names from	*/
	/* the input array that do not match any library name defined in the given library	*/
	/* descriptor.  If no library names are input, an error is returned.			*/
	/*									*/
	/* _p_r_o_g_r_e_s_s								*/
	/*									*/
	/* 1) If the user specified a library descirptor, then get a pointer to it and its	*/
	/*    aggregates.  Otherwise, get pointers to the default descriptor's aggregates.	*/
	/* 3) Make sure the caller specified some library names.				*/
	/* 6) Copy all of the caller's names to the bad_library array.  Compare the names in	*/
	/*    this array with the valid library names from the descriptor, and REMOVE input	*/
	/*    library names from bad_library when they match a valid library name.		*/
	/*									*/
	/* NOTES									*/
	/*									*/
	/* A non-zero error code is returned ONLY IF the specified descriptor cannot be located,	*/
	/* or if no library names were given as input.					*/
	/*									*/
	/* A zero code is returned otherwise.  If there are bad library names, bad_library.N will	*/
	/* be greater than 0 on output.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	bad_library.N = 0;				/* initialize output argument.		*/

	call find_descriptor (Adescriptor, P, Acode);	/* find the descriptor.			*/
	if Acode ^= 0 then return;

	if library.N <= 0 then do;			/* check for library names given as input.	*/
	     Acode = error_table_$noarg;
	     return;
	     end;

	Pbad_library -> library = library;		/* copy all input library names to bad_library.	*/
 
	do k = 1 to roots.N while (bad_library.N > 0);	/* compare input names with valid library names.	*/
	     Proot_names = addrel (P.descriptor, roots.root(k).name.O);
	     do j = bad_library.N to 1 by -1;
		Sfound = "0"b;
		do i = 1 to root_names.N while (^Sfound);
		     go to match_valid (bad_library(j).C);

match_valid (0):	     if root_names.root_name(i) = bad_library(j).V then Sfound = "1"b;
		     go to end_match_valid;

match_valid (1):	     call match_star_name_ (root_names.root_name(i), bad_library(j).V, code);
		     if code = 0 then Sfound = "1"b;
		     go to end_match_valid;

match_valid (2):	     Sfound = "1"b;

end_match_valid:	     end;

		if Sfound then do;
		     do i = j+1 to bad_library.N;
			bad_library(i-1).V = bad_library(i).V;
			bad_library(i-1).C = bad_library(i).C;
			end;
		     bad_library.N = bad_library.N - 1;
		     end;
		end;
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


find_descriptor:	procedure (Adescriptor, P1, code);

     dcl						/*	parameters			*/
	Adescriptor		char(168) varying,	/* descriptor to be found. (In)		*/
						/*    If Adescriptor = "", then name of		*/
						/*    default descriptor. (Out)		*/
	1 P1			aligned like P,	/* descriptor pointer structure to be filled in.	*/
						/*    (Out)				*/
	code			fixed bin(35);	/* a status code. (Out)			*/

     dcl	E			entry variable,	/* an entry variable temp.			*/
	P_me			ptr,		/* a pointer temp.				*/
	i			fixed bin;

     dcl						/*	based variable			*/
	1 descriptor1		aligned like descriptor based (P1.descriptor);


	if first_call then do;			/* first call.  Initialize default descriptor ptr.*/
	     P1.descriptor = addr (multics_libraries_$descriptor);
	     defaultP.descriptor = P1.descriptor;
	     defaultP.command_default_values = addrel(P1.descriptor, descriptor1.command_default_values.O);
	     defaultP.roots = addrel(P1.descriptor, descriptor1.roots.O);
	     first_call = "0"b;
	     end;

	if Adescriptor = "" then do;			/* use default descriptor, and return its name.	*/
	     P1 = defaultP;
	     Adescriptor = descriptor1.name;
	     code = 0;
	     end;
	else do;					/* use user-specified descriptor.		*/
	     call cu_$decode_entry_value (lib_descriptor_, P_me, null);
	     i = verify (reverse (Adescriptor), " ");
	     i = length(Adescriptor) - (i-1);
	     if search (Adescriptor, "<>") > 0 then
		E = cv_entry_ (substr(Adescriptor,1,i) || "|descriptor", P_me, code);
	     else E = cv_entry_ (substr(Adescriptor,1,i) || "$descriptor", P_me, code);
	     call cu_$decode_entry_value (E, P1.descriptor, null);
	     if code ^= 0 then P1.descriptor = null;
	     else if descriptor1.version ^= Vdescriptor_2 then do;
		code = error_table_$unimplemented_version;
		P1.descriptor = null;
		end;
	     else do;
		P1.command_default_values = addrel(P1.descriptor, descriptor1.command_default_values.O);
		P1.roots = addrel(P1.descriptor, descriptor1.roots.O);
		code = 0;				/* ignore superfluous errors.			*/
		end;
	     end;

	end find_descriptor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_descriptor_;

	end lib_descriptor_;




		    lib_error_list_.pl1             02/15/84  0911.2rew 02/15/84  0819.0       52371



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: lib_error_list_							*/
	/*									*/
	/*    This procedure prints information for error messages and other output from the	*/
	/* arrays used by the library descriptor tools interfaces.				*/
	/*									*/
	/* Status									*/
	/* 0) Created:  Aug, 1971 by G. C. Dixon					*/
	/* 1) Modified: Dec, 1980 by G. C. Dixon - add $return_string entry point.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


lib_error_list_:
	procedure (label, Pstarname, proc);		/* Procedure to output an array of names in an	*/
						/*    error message.			*/

     dcl						/*		parameters		*/
	label			char(32) varying;	/* label for name array.			*/
	%include lib_based_args_;

     dcl	proc			char(32) varying,	/* Name of caller to be used in error message.	*/
	APiocb			ptr;		/* ptr to iocb of switch array to be output on.	*/

     dcl						/*	automatic variables		*/
         (Lfield (3), Lprefix)	fixed bin,	/* length of output fields.			*/
	Piocb			ptr,		/* ptr: to output switch.			*/
	Sreturn_string		bit(1),		/* switch:  on if entered at $return_string	*/
	field (3)			char(32),		/* output fields.				*/
         (i, j, k)			fixed bin,	/* do group indices.			*/
	return_string		char(10000) var;	/* temp string to hold results during calc.	*/

     dcl (length, min, reverse, verify)	builtin;

     dcl	ioa_$rsnpnnl		entry options(variable),
	ioa_$ioa_switch		entry options (variable);

     dcl (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	iox_$error_output		ptr ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Sreturn_string = FALSE;			/* Entry to output results to error_output	*/
	Piocb = iox_$error_output;
	go to COMMON;


lib_array_list_:
	entry (label, Pstarname, APiocb);		/* Entry to output results on user_output.	*/

	Sreturn_string = FALSE;
	Piocb = APiocb;
	go to COMMON;


return_string:					/* Entry to return formatted results as a string. */
	entry (label, Pstarname) returns (char(*) varying);

	Sreturn_string = TRUE;
	return_string = "";


COMMON:	Lprefix = 2;				/* indent heading line by 2 chars.		*/
	if starname.N > 1 then field(1) = label || "s:";
	else field(1) = label || ":";			/* 1st field is label (singular or plural).	*/
	Lfield(1) = 23;
	i = 1;					/* indicate first field has been used.		*/

	j = 1;					/* begin outputing with 1st name.		*/
	do while (j <= starname.N);
	     if i = 3 then do;			/* if all fields full, output the line.		*/
		if Sreturn_string then
		     call ioa_$rsnpnnl ("^a^[^/^]^vx^va^va^va", return_string, 0, return_string,
			length(return_string)>0, Lprefix, Lfield(1), field(1),
			Lfield(2), field(2), Lfield(3), field(3));
		else call ioa_$ioa_switch (Piocb, "^vx^va^va^va", Lprefix, Lfield(1), field(1),
			Lfield(2), field(2), Lfield(3), field(3));
		i = 0;				/* no fields used.				*/
		Lprefix = 5;			/* indent all succeeding lines by 5 chars.	*/
		end;

	     i = i + 1;				/* process next field.			*/
	     Lfield(i) = min (32, 33 - verify (reverse (starname.V(j)), " "));
	     if Lfield(i) <= 18 then do;		/* if name <= 18 chars;  it will fit in 1 field.	*/
		Lfield(i) = 20;
		field(i) = starname.V(j);
		end;
	     else if i < 3 then do;			/* name > 18 chars;  it will fit in 2 fields.	*/
		if i = 1 then do;			/*     put name in 2nd field of line, if next	*/
						/*       name won't fit in first field.		*/
		     if j < starname.N then do;
			k = min (32, 33 - verify (reverse (starname.V(j+1)), " "));
			if k <= 18 then do;
			     Lfield(i) = 20;
			     field (i) = starname.V(j+1);
			     i = i + 1;
			     Lfield(i) = 40;
			     field (i) = starname.V(j);
			     i = i + 1;
			     Lfield(i) = 0;
			     field (i) = "";
			     j = j + 1;
			     go to NEXT_NAME;
			     end;
			end;
		     Lfield(i) = 20;
		     field (i) = "";
		     i = i + 1;
		     end;
		Lfield(i) = 40;
		field(i) = starname.V(j);
		i = i + 1;			/* 2d of the 2 fields needs no further processing.*/
		Lfield(i) = 0;
		field(i) = "";
		end;
	     else do;				/* name > 18 chars and only 1 field left.	*/
		Lfield(i) = 0;			/* make it a blank field.			*/
		field(i) = "";
		j = j - 1;			/* process this name again on the next line.	*/
		end;
NEXT_NAME:     j = j + 1;				/* process the next name.			*/
	     end;
	do i = i+1 to 3;				/* null out any unused fields on last line.	*/
	     Lfield(i) = 0;
	     field(i) = "";
	     end;

	if Sreturn_string then do;
	     call ioa_$rsnpnnl ("^a^[^/^]^vx^va^va^va", return_string, 0, return_string,
		length(return_string)>0, Lprefix, Lfield(1), field(1),
		Lfield(2), field(2), Lfield(3), field(3));
	     return (return_string);
	     end;
	else call ioa_$ioa_switch (Piocb, "^vx^va^va^va", Lprefix, Lfield(1), field(1),
	     Lfield(2), field(2), Lfield(3), field(3));	/* output the last line.			*/

	end lib_error_list_;




		    lib_fetch_.pl1                  09/25/84  1155.7rew 09/25/84  1154.5      221823



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


/* Modified October 26, 1983 by Jim Lippard to fix bug in the call to get_equal_name_ and to properly handle	*/
/*    name duplication									*/
/* Modified June 13, 1984 by Jim Lippard to not sort found names					*/


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_fetch_: 	procedure (Plibrary, Pstarname, Pexclude, Srequirements, Scontrol, Parg_struc, Acode)
		options	(rename ((alloc_, smart_alloc_)));

     dcl						/*	Parameter				*/
	Acode			fixed bin(35);	/* an error table code.			*/

     dcl						/*	automatic variables			*/
	Iname			fixed bin,	/* count of names processed so far.		*/
	Lcopy			fixed bin(21),	/* length of target segment (in chars).		*/
	Nentries_fetched		fixed bin,	/* number of library entries successfully fetched.*/
	Parea			ptr,		/* ptr to an MSA.				*/
	Pcopy			ptr,		/* ptr to target segment (ie, copy fetched into).	*/
	Pent			ptr,		/* ptr to library entry being fetched.		*/
	Pmsf_fcb			ptr,		/* ptr to msf_manager_'s control block.		*/
	Ptarget_node		ptr,		/* ptr to node for actual library entry being	*/
						/*   fetched.				*/
	Ptree			ptr,		/* ptr to a tree of status nodes.		*/
	1 S_			structure,	/* switches:				*/
	 (2 link_error_output,			/*     on if link error message already output.	*/
	  2 error,				/*     on if error occurred making target seg.	*/
	  2 fetch_not_done,				/*     on if fetch not yet complete.		*/
	  2 acl_init,				/*     on if ACL structure already initialized.	*/
	  2 msf,					/*     on if entry being fetched is an MSF.	*/
	  2 no_action,				/*     on if user said "no" to nd_handler_	*/
	  2 delete_msf)		bit(1) unal,	/*     on if target MSF needs to be deleted after	*/
						/*       an error occurred.			*/
	1 acl			structure,	/* an ACL addition structure.			*/
	  2 access_name		char(32),
	  2 modes			bit(36),
	  2 zero_pad		bit(36),
	  2 code			fixed bin(35),
	bc			fixed bin(24),	/* bit count of library entry.		*/
	clock			fixed bin(71),	/* a clock value.				*/
	code			fixed bin(35),	/* a status code.				*/
	date			char(16) aligned,	/* a date/time string.			*/
	dir			char(168) varying,	/* dir part of library entry pathname.		*/
	ent			char(32) varying,	/* ent part of library entry pathnamer.	*/
	1 fcb_temp		like fcb,		/* storage for file control block.		*/
	i			fixed bin,	/* a do-group index.			*/
	into_dir			char(168),	/* dir part of into_path.			*/
	into_ent			char(32),		/* ent part of into_path.			*/
	msf_comp			fixed bin(24),	/* number of next msf_comp to be initiated.	*/
	nd_result			fixed bin(35),	/* return code from nd_handler_.		*/
	node_name			char(32),		/* a name on the library entry being fetched.	*/
	progress			fixed bin init (0),	/* integer indicating progress of our search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_fetch command supported*/
						/*       by this descriptor.			*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	state			char(16),		/* an error temporary char string.		*/
	target_name		char(32),		/* name to be put on target segment.		*/
	unique_name		char(32);		/* unique name by which target segment created.	*/

     dcl						/* 	based variables			*/
	area			area based (Parea),	/* an MSA (multi-segment area).		*/
	copy			char(Lcopy) based (Pcopy);
						/* (all or part of) library entry being fetched.	*/

     dcl (addr, divide, length, min, null, string, substr)
				builtin;
     dcl	cleanup			condition;

     dcl						/*	Entries Called			*/
	clock_			entry returns (fixed bin(71)),
	condition_		entry (char(*),  entry),
	date_time_		entry (fixed bin(71), char(*) aligned),
	delete_$path		entry (char(*), char(*), bit(6), char(*), fixed bin(35)),
	expand_path_		entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
	get_equal_name_		entry (char(*), char(*), char(32), fixed bin(35)),
         (get_group_id_,
	get_group_id_$tag_star)	entry returns (char(32) aligned),
	get_system_msa_		entry (ptr, fixed bin, ptr),
	hcs_$add_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$chname_file		entry (char(*), char(*), char(*), char(*), fixed bin(35)),
	hcs_$make_seg		entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)),
	hcs_$set_bc_seg		entry (ptr, fixed bin(24), fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
         (ioa_,
	ioa_$ioa_switch)		entry options (variable),
	iox_$attach_ioname		entry (char(*), ptr, char(*), fixed bin(35)),
	iox_$close		entry (ptr, fixed bin(35)),
	iox_$detach_iocb		entry (ptr, fixed bin(35)),
	iox_$open			entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
	lib_array_list_		entry (char(32) varying, ptr, ptr),
	lib_descriptor_$fetch	entry (char(168) varying, ptr, ptr, ptr, bit(72) aligned,  bit(36) aligned,
				       ptr, ptr, fixed bin, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying),
	lib_next_name_		entry (bit(72) aligned, ptr, fixed bin, ptr) returns (char(32)),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying),
	lib_output_node_list_$info	entry (ptr, ptr, ptr, ptr, char(45) varying, bit(72) aligned, ptr),
	lib_ptr_and_bc_		entry (ptr, fixed bin(24), ptr, ptr, fixed bin(24), fixed bin(35)),
	lib_sort_tree_$make_name_list
				entry (ptr, ptr, ptr, ptr, fixed bin(35)),
	msa_manager_$area_handler	entry,
	msf_manager_$open		entry (char(*), char(*), ptr, fixed bin(35)),
	msf_manager_$get_ptr	entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)),
	msf_manager_$close		entry (ptr),
	nd_handler_		entry (char(*), char(*), char(*), fixed bin(35)),
	release_system_msa_		entry (ptr, fixed bin(35)),
	unique_chars_		entry (bit(*) aligned) returns (char(15));

     dcl						/*	static variables			*/
	False			bit(1) int static options(constant) init ("0"b),
	True			bit(1) int static options(constant) init ("1"b),
         (error_table_$action_not_performed,
	error_table_$entlong,
	error_table_$longeql,
	error_table_$namedup,
	error_table_$noentry,
	error_table_$not_detached,
	error_table_$not_done,
	error_table_$not_open)	fixed bin(35) ext static,
	finish			bit(1) aligned int static options(constant) init ("1"b),
	group_id			char(32) int static init (""),
	on_unit			bit(1) aligned int static options(constant) init ("0"b),
	stream_output		fixed bin int static init (2);
						/* iox_ opening mode for stream-output I/O.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) initialize library pgm's file control block.				*/
	/* 2) establish cleanup on unit.						*/
	/* 3) attach/open output file.						*/
	/* 4) get ptr to system multi-segment area, and establish area on unit.		*/
	/* 5) search and build status tree for library entries being sought.			*/
	/* 6) make a list of found entries						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Acode = 0;				/* initialize output argument.		*/

	Pfcb = addr(fcb_temp);
	fcb.version = Vfcb_1;
	fcb.ioname = "lib_fetch_";			/* do all of our output on the lib_fetch_ ioname.	*/
	fcb.Piocb = null;				/* indicate no attachment so far.		*/
	fcb.Eend_page = no_end_page;
	fcb.page_length = 131071;
	fcb.page_text_length = 131071;
	fcb.page_no = 1;
	fcb.line_length = 79;
	fcb.line_no = 2;

	Parea = null;				/* initialize values used by cleanup on unit.	*/
	Pent = null;
	Pmsf_fcb = null;
	Pcopy = null;
	string(S_) = ""b;				/* initialize all switches.			*/
	on cleanup call janitor(on_unit);

	if Sc.output_file then do;			/* attach/open output file if required.		*/
	     if substr(arg_struc.output_file, length(arg_struc.output_file)-5) ^= ".fetch" then
		if length(arg_struc.output_file) > 162 then do;
		     code = error_table_$entlong;
		     go to  BAD_ATTACH;
		     end;
		else arg_struc.output_file = arg_struc.output_file || ".fetch";
	     call iox_$attach_ioname (fcb.ioname, fcb.Piocb,
		"vfile_ " || arg_struc.output_file || " -extend", code);
	     if code ^= 0 then go to BAD_ATTACH;
	     call iox_$open (fcb.Piocb, stream_output, "0"b, code);
	     if code ^= 0 then go to BAD_OPEN;
	     end;

	call expand_path_ (addr(substr(arg_struc.into_path,1)), length(arg_struc.into_path), addr(into_dir),
	     addr(into_ent), code);
	if code ^= 0 then go to BAD_INTO;		/* validate -into path specification.		*/
	call get_equal_name_ ((32) ".", into_ent, target_name, code);
	if code = error_table_$longeql then;
	else if code ^= 0 then go to BAD_INTO;

	call condition_ ("area", msa_manager_$area_handler);
						/* let msa_manager_ handle area conditions.	*/
	call get_system_msa_ (addr(Parea), 0, (null));	/* get MSA ptr.				*/

	call lib_descriptor_$fetch (arg_struc.descriptor, Plibrary, Pstarname, Pexclude,
	     Srequirements, Scontrol, Parea, Ptree, progress, code);
						/* get a tree of status nodes reflecting the	*/
	if code ^= 0 then go to BAD_SEARCH;		/* library entries which match the star name.	*/

	allocate 	index_list in (area),		/* allocate space for sorting the status nodes.	*/
		name_list in (area),
		node_list in (area);
	index_list.I = 0;				/* initialize count of entries in each list.	*/
	name_list.I = 0;
	node_list.I = 0;
	call lib_sort_tree_$make_name_list (Ptree, Pname_list, Pindex_list, Pnode_list, code);
	if code ^= 0 then go to NO_MATCH;		/* put the outputable nodes into a name list.	*/
	do i = 1 to index_list.I;			/* initialize the index list			*/
	     index_list.e (i) = i;
	end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* For EACH library entry which was found:					*/
	/* 1) Get a pointer to the node describing the found entry.				*/
	/* 2) Complain if the entry is a link, and links are not being chased.		*/
	/* 3) Get pointer to, and bit count of, the library entry to be fetched.		*/
	/* 4) For segments, archives, archive components, and MSF components:			*/
	/*    a) create a uniquely-named target segment in the user-specified directory.	*/
	/*    b) copy the library entry into the target segment.				*/
	/*    c) if the library entry is an object segment, set the user's access to the target	*/
	/*       segment to 're'.							*/
	/*    d) terminate the library entry.						*/
	/*									*/
	/*    For MSFs:								*/
	/*    a) create a uniquely-name target MSF in the user-specified directory, via 	*/
	/*       msf_manager_.							*/
	/*    b) copy the library MSF into the target MSF, component by component.		*/
	/*    c) terminate each library MSF component as it is copied.			*/
	/* 5) Add ALL, the PRIMARY, or the MATCHING names to the uniquely-named target, as	*/
	/*    the user specified.							*/
	/* 6) Remove the unique name.							*/
	/* 7) Output message to the user if -long was specified.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	Nentries_fetched = 0;
	do i = 1 to index_list.I;			/* loop through nodes to be fetched.		*/
	     unique_name = unique_chars_ (""b);		/*     get unique name to place on target segment.*/
	     Pnode = node_list.e (index_list.e(i));	/*     get ptr to node.			*/
	     call lib_node_path_ (Pnode, dir, ent);	/*     get pathname of library entry.		*/
	     if node.T = Tlink then if ^Sc.chase then do;	/*     warn user that links aren't chased.	*/
		if S_.link_error_output then
		     call arg_struc.put_error (error_table_$not_done, arg_struc.program, " Link  ^a>^a",
			dir, ent);
		else do;
		     call arg_struc.put_error (error_table_$not_done, arg_struc.program, "
  Use the -chase option to fetch the target of the link
  ^a>^a.", dir, ent);
		     S_.link_error_output = True;
		     end;
		node_list.e (index_list.e(i)) = null;
		Acode = code;
		go to NEXT_NODE;
		end;
	     msf_comp = 0;
	     call lib_ptr_and_bc_ (Pnode, msf_comp, Ptarget_node, Pent, bc, code);
	     if code ^= 0 then do;
		if node.T = Tlink then
		     call arg_struc.put_error (code, arg_struc.program, "
  Unable to fetch through null link  ^a>^a.", dir, ent);
		else call arg_struc.put_error (code, arg_struc.program, "
  Unable to fetch ^a  ^a>^a.", node_type(node.T), dir, ent);
		node_list.e (index_list.e(i)) = null;
		Acode = code;
		go to NEXT_NODE;
		end;
	     if node.T = Tlink then
		go to COPY (Ptarget_node->node.T);	/*     copy according to type of library entry.	*/
	     else go to COPY (node.T);
 
COPY(1):						/*     segment entries.			*/
COPY(4):						/*     MSF component entries.			*/
COPY(5):						/*     archive entries.			*/
COPY(6):						/*     archive component entries.		*/
	     call hcs_$make_seg (into_dir, unique_name, "", 01010b, Pcopy, code);
	     if Pcopy = null then do;			/*     create new segment in which ent is copied.	*/
		call arg_struc.put_error (code, arg_struc.program, "
  Unable to create segment  ^a
  (^a>^a)
  into which the library entry will be copied.", ent, into_dir, unique_name);
		S_.error = True;
		Acode = code;
		go to TERM_ENT;
		end;
	     S_.fetch_not_done = True;
	     Lcopy = divide (bc+8, 9, 21, 0);		/*     compute number of characters to be copied.	*/
	     copy = Pent -> copy;			/*     copy library entry into target segment.	*/
	     call hcs_$set_bc_seg (Pcopy, bc, code);	/*     set the bit count on the target segment.	*/
	     if Svalid.object_info then do;		/*     set ACL of object segs to 're'		*/
		if ^S_.acl_init then do;
		     if group_id = "" then group_id = get_group_id_$tag_star();
		     acl.access_name = group_id;
		     acl.modes       = "110"b;
		     acl.zero_pad    = ""b;
		     end;
		call hcs_$add_acl_entries (into_dir, unique_name, addr(acl), 1, code);
		if code ^= 0 then
		     call arg_struc.put_error (code, arg_struc.program, "
  Unable to give user 're' access to fetched entry  ^a,
  (^a>^a).", ent, into_dir, unique_name);
		end;
TERM_ENT:	     call hcs_$terminate_noname (Pent, code);
	     Pent = null;
	     if S_.error then do;
		S_.error = False;
		node_list.e(index_list.e(i)) = null;
		go to NEXT_NODE;
		end;
	     go to JOIN;
 
COPY(3):						/*     MSF entries.				*/
	     S_.msf = True;				/*     Indicate we're dealing with an MSF.	*/
	     call msf_manager_$open (into_dir, unique_name, Pmsf_fcb, code);
	     if code ^= 0 then if code ^= error_table_$noentry then do;
						/*     create new MSF into which ent is copied.	*/
		call arg_struc.put_error (code, arg_struc.program, "
  Unable to create MSF  ^a
  (^a>^a)
  into which the library MSF will be copied.", ent, into_dir, unique_name);
		S_.error = True;
		Acode = code;
		go to TERM_MSF;
		end;
	     do while (Pent ^= null);			/*     copy MSF, component by component.	*/
		call msf_manager_$get_ptr (Pmsf_fcb, msf_comp-1, True, Pcopy, 0, code);
		if Pcopy = null then do;
		     call arg_struc.put_error (code, arg_struc.program, "
  Unable to create MSF component ^d in MSF  ^a
  (^a>^a).", msf_comp-1, ent, into_dir, unique_name);
		     S_.error = True;
		     S_.delete_msf = (msf_comp >= 2);
		     Acode = code;
		     go to TERM_MSF;
		     end;
	  	S_.fetch_not_done = True;
		Lcopy = divide (bc+8, 9, 21, 0);
		copy = Pent -> copy;
		call hcs_$set_bc_seg (Pcopy, bc, code);
		call hcs_$terminate_noname (Pent, 0);
		call lib_ptr_and_bc_ (Pnode, msf_comp, Ptarget_node, Pent, bc, code);
		end;
TERM_MSF:	     call msf_manager_$close (Pmsf_fcb);
	     Pmsf_fcb = null;
	     if S_.delete_msf then do;
		call delete_$path (into_dir, unique_name, "000100"b, (arg_struc.program), code);
		S_.delete_msf = False;
		end;
	     if S_.error then do;
		S_.error = False;
		node_list.e(index_list.e(i)) = null;
		go to NEXT_NODE;
		end;
	     go to JOIN;

JOIN:	     do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
		end;				/*     get list of names on library entry.	*/
	     Iname = 0;				/*     indicate no names in list processed yet.	*/
	     node_name = lib_next_name_ (node.Sreq, PDnames, Iname, Pstarname);
	     S_.no_action = False;

	     do while (node_name ^= "");		/*     add names to target, 1 by 1.		*/
		call get_equal_name_ (node_name, into_ent, target_name, code);
		if code ^= 0 then do;
		     call arg_struc.put_error (code, arg_struc.program, "
  Unable to apply equal name  ^a  to library entry name  ^a.", into_ent, node_name);
		     go to NEXT_NAME;
		     end;
		call hcs_$chname_file (into_dir, unique_name, "", target_name, code);
		if code = error_table_$namedup then do;
		     call nd_handler_ ((arg_struc.program), into_dir, target_name, nd_result);
		     if nd_result = 0 then
			call hcs_$chname_file (into_dir, unique_name, "", target_name, code);
		     else if nd_result = error_table_$action_not_performed then S_.no_action = True;
		     end;
		else if code ^= 0 then do;
		     call arg_struc.put_error (code, arg_struc.program, "
  Unable to add name  ^a  to copied library entry  ^a
  (^a>^a).", target_name, Dnames.names(1), into_dir, unique_name);
		     Acode = code;
		     end;
NEXT_NAME:	node_name = lib_next_name_ (node.Sreq, PDnames, Iname, Pstarname);
		end;

	     S_.fetch_not_done = False;
	     call hcs_$chname_file (into_dir, unique_name, unique_name, "", code);
	     if code ^= 0 then do;			/* If unique name is only name on copy, complain!	*/
		if ^S_.no_action then call arg_struc.put_error (code, arg_struc.program, "
  Unable to add any names to copied library entry  ^a
  The entry could not be fetched.", Dnames.names(1));
		call delete_$path (into_dir, unique_name, "000100"b, (arg_struc.program), code);
		node_list.e(index_list.e(i)) = null;
		go to NEXT_NODE;
		end;

	     Nentries_fetched = Nentries_fetched + 1;	/* Increment count of entries actually fetched.	*/

	     if Sc.long then do;			/*     output the fetched message.		*/
		call ioa_ ("Library ^a  ^a  ^/  fetched from  ^a", node_type(node.T), ent, dir);
		if arg_struc.into_path ^= "==" then
		     call ioa_ ("  into  ^a>^a.", into_dir, target_name);
		end;

NEXT_NODE:     end;					/* That completes the processing for this node.	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Output list of fetched nodes into output file.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Nentries_fetched = 0 then return;
	else if Sc.output_file then;
	else return;

	clock = clock_();
	call date_time_ (clock, date);
	if Nentries_fetched = 1 then
	     call ioa_$ioa_switch (fcb.Piocb, "^/Entry   Fetched:^-^5x1");
	else call ioa_$ioa_switch (fcb.Piocb, "^/Entries Fetched:^-^5x^d", Nentries_fetched);
	call ioa_$ioa_switch (fcb.Piocb, "     Fetched on:^-^5x^a", date);
	call ioa_$ioa_switch (fcb.Piocb, "     Fetched by:^-^5x^a", get_group_id_());
	call ioa_$ioa_switch (fcb.Piocb, "     Descriptor:^-^5x^a", arg_struc.descriptor);
	if library.N = 1 then
	     call lib_array_list_ (" Library Name", Plibrary, fcb.Piocb);
	else call lib_array_list_ ("Library Name", Plibrary, fcb.Piocb);
	if starname.N = 1 then
	     call lib_array_list_ ("  Search Name", Pstarname, fcb.Piocb);
	else call lib_array_list_ (" Search Name", Pstarname, fcb.Piocb);

	call lib_output_node_list_$info (Pfcb, Pnode_list, Pname_list, Pindex_list, "",
	     (72)"1"b, addr(starname));
						/* print the nodes, including names which	*/
						/*    match the user's search names.		*/
DETACH:	if Acode = 0 then Acode = code;
	call janitor(finish);			/* clean up.				*/
	return;

janitor:	procedure (invocation_mode);			/* cleanup procedure.			*/

     dcl	invocation_mode		bit(1) aligned;	/* off if invoked by cleanup on unit.		*/

	if Parea ^= null then			/* cleanup by releasing any system MSA.		*/
	     call release_system_msa_ (addr(Parea), code);
	if fcb.Piocb ^= null then do;			/* close/detach our output file, if open.	*/
	     call iox_$close (fcb.Piocb, code);
	     if invocation_mode = finish then if code ^= 0 then if code ^= error_table_$not_open
		then go to BAD_CLOSE;
	     call iox_$detach_iocb (fcb.Piocb, code);
	     fcb.Piocb = null;			/* we've done all we can.  Stop trying.		*/
	     if invocation_mode = finish then if code ^= 0 then go to BAD_DETACH;
	     end;
	if Pent ^= null then
	     call hcs_$terminate_noname (Pent, code);
	if S_.msf then
	     if Pmsf_fcb ^= null then
		call msf_manager_$close (Pmsf_fcb);
	     else;
	else if Pcopy ^= null then
	     call hcs_$terminate_noname (Pent, code);
	if S_.fetch_not_done then
	     call delete_$path (into_dir, unique_name, "000100"b, (arg_struc.program), code);

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


BAD_ATTACH:
	if code = error_table_$not_detached then go to MULTIPLE_ATTACH;
	state = "attaching";
	fcb.Piocb = null;
	go to BAD_IO;
BAD_CLOSE:
	state = "closing";
	go to BAD_IO;
BAD_DETACH:
	state = "detaching";
	go to BAD_IO;
BAD_OPEN:
	state = "opening";
BAD_IO:	call arg_struc.put_error (code,arg_struc.program, "
  While ^a the fetch record  ^R^a^B
  using the I/O switch  ^R^a^B.",
	     state, arg_struc.output_file, fcb.ioname);
	go to DETACH;

MULTIPLE_ATTACH:
	call arg_struc.put_error (code, arg_struc.program, "
  While attaching the map file  ^R^a^B
  to the I/O switch  ^R^a^B.
  Release any other activations of ^a and try again.", arg_struc.output_file, fcb.ioname, arg_struc.program);
	Acode = code;
	return;

BAD_INTO:	call arg_struc.put_error (code, arg_struc.program, " -into ^a", arg_struc.into_path);
	Acode = code;
	return;

BAD_SEARCH:
	progress = min (progress, 7);
	go to BAD_S (progress);
BAD_S(0): call arg_struc.put_error (code, arg_struc.program, "
  While calling lib_descriptor_$map.");
	go to DETACH;
BAD_S(1): call arg_struc.put_error (code, arg_struc.program, "
  While finding the  '^R^a^B'  library descriptor.",
	     arg_struc.descriptor);
	go to DETACH;
BAD_S(2): call arg_struc.put_error (code, arg_struc.program, "
  Library descriptor  '^R^a^B'  does not implement
  the ^a command.",
	     arg_struc.descriptor, arg_struc.program);
	go to DETACH;
BAD_S(3): state = "library";
	go to NO_DEFAULT_NAMES;
BAD_S(4): state = "search";
NO_DEFAULT_NAMES:
	call arg_struc.put_error (code, arg_struc.program, "
  No ^a names were specified, and the  '^R^a^B'
  library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state);
	go to DETACH;
BAD_S(5): call arg_struc.put_error (code, arg_struc.program, "
  While allocating the root nodes of the library tree.");
	go to DETACH;

BAD_S(6):
NO_MATCH:	call arg_struc.put_error (code, arg_struc.program, "
  While searching for entries in the library.
  Descriptor:^-^5x^a",
	     arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	call lib_error_list_ ("search name", Pstarname, arg_struc.program);
	go to DETACH;
BAD_S(7):	call arg_struc.put_error (code, arg_struc.program, "
  No libraries matching the library name(s) could be found.
  Descriptor:^-^5x^a", arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	go to DETACH;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


no_end_page:	procedure;			/* This is a null end-of-page handling proc.	*/

	fcb.page_no = fcb.page_no + 1;
	fcb.line_no = 1;

	end no_end_page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_fcb_;

%include lib_list_;

%include lib_node_;


	end lib_fetch_;




		    lib_free_node_.pl1              02/15/84  0911.2rew 02/15/84  0819.1       44361



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  lib_free_node_							*/
	/*									*/
	/*      This procedure frees the storage used by library nodes.			*/
	/*									*/
	/* E__n_t_r_y:  lib_free_node_$array						*/
	/*									*/
	/*      This entry point frees all structures attached to each node of a library node	*/
	/* array, and then frees the node array, itself.					*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  lib_free_node_$array entry (ptr);					*/
	/*									*/
	/*      call lib_free_node_$array (PDnodes);					*/
	/*									*/
	/* 1) PDnodes	points to the library node array to be freed. (In)		*/
	/*		is a null pointer. (Out)					*/
	/*									*/
	/* E__n_t_r_y:  lib_free_node_$descriptors						*/
	/*									*/
	/*      This entry point frees all structures attached to a single library node.	*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  lib_free_node_$descriptors entry (ptr);				*/
	/*									*/
	/*      call lib_free_node_$descriptors (Pnode);					*/
	/*									*/
	/* 1) Pnode	points to the library node whose descriptors are to be freed. (In)	*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created:  Aug, 1973 by G. C. Dixon					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/**/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_free_node_:		procedure;

     dcl	APnode			ptr,		/* ptr to node whose descriptors are to be freed.	*/
						/* (In)					*/
	APDnodes			ptr;		/* ptr to node array to be freed. (In)		*/
						/* null ptr. (Output)			*/
     dcl	Parea			ptr,		/* ptr to an area.				*/
	i			fixed bin;	/* do group index.				*/

     dcl	area			area based (Parea);
						/* create a dummy area to make PL/I happy when	*/
						/* it executes the free statements.		*/

     dcl	1 Dfree			based (PD),	/* structure used to free all descriptors.	*/
	  2 header		like D,
	  2 body (Dfree.length-size(D))
				fixed bin(35);

     dcl (addr, null, size)		builtin;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


array:		entry	(APDnodes);		/* entry to free a node descriptor, and its	*/
						/* descriptors.				*/

	PDnodes = APDnodes;				/* address the node array descriptor.		*/
	Parea = PDnodes;				/* for PL/I's benefit, fake ptr to area for free.	*/
	if PDnodes = null then			/* if descriptor has already been freed, done.	*/
	     return;
	if Dnodes.version ^= Vnodes_1 then		/* if structure of descriptor unknown, exit.	*/
	     return;
	do i = 1 to Dnodes.N;			/* for each node in the node array:		*/
	     Pnode = addr (Dnodes.nodes(i));		/*   (1) address the node.			*/
	     call free_node_descriptors;		/*   (2) free its descriptors.		*/
	     end;					/* then:					*/
	free Dnodes in (area);			/*   (3) free the node array descriptor.	*/
	APDnodes = null;				/*   (4) null out the ptr to the freed descriptor	*/
						/*       to prevent mistaken attempts to refree.	*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


descriptors:	entry	(APnode);			/* entry to free a node's descriptors.		*/

	Pnode = APnode;				/* address the node.			*/
	Parea = Pnode;				/* for PL/I's benefit, fake ptr to area for free.	*/
	call free_node_descriptors;			/* free its descriptors.			*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


free_node_descriptors:	procedure;		/* This internal procedure frees descriptors 	*/
						/* attached to the node pointed to by Pnode.	*/

	do PD = node.PD repeat node.PD while (PD ^= null);/* free descriptors, one at a time.		*/
	     node.PD = D.Pnext;			/* save ptr to next descriptor.		*/
	     if D.T = Tnodes then			/* if this is a node array descriptor, then	*/
		call array (PD);			/* call array freer to do the work.		*/
	     else					/* otherwise, do the freeing ourself.		*/
		free Dfree in (area);
	     end;

	end free_node_descriptors;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_node_;

	end lib_free_node_;




		    lib_get_tree_.pl1               07/18/86  1518.6rew 07/18/86  1235.1      540747



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


/****^  HISTORY COMMENTS:
  1) change(75-08-01,GDixon), approve(), audit(),
     install(86-07-18,MR12.0-1098):
     Written initially.
  2) change(84-01-20,Lippard), approve(), audit(),
     install(86-07-18,MR12.0-1098):
     Use archive_$list_components.
  3) change(84-03-05,Lippard), approve(), audit(),
     install(86-07-18,MR12.0-1098):
     Free the correct archive component array structure and treat
     error_table_$logical_volume_not_connected as a fatal error (so it will
     complain instead of being quiet about it.
  4) change(86-02-15,GDixon), approve(86-03-24,MCR7365),
     audit(86-04-22,Dickson), install(86-04-22,MR12.0-1042):
     Fix bug which prevents listing segments when a .1 version of the segment
     also exists in the libraries.
  5) change(86-05-17,GDixon), approve(86-05-17,MCR7357),
     audit(86-07-10,Farley), install(86-07-18,MR12.0-1098):
     Changed call to tct_ to reference find_char_$first_in_table; this
     subroutine was renamed.
                                                   END HISTORY COMMENTS */



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_get_tree_:	procedure (APparent, path, Pstarname, Pexclude, Srequirements, Scontrol, tree_level, 
			 link_level, Parea, director, Pdirector_args, Pnodes, Acode)
		options	(rename	((alloc_, smart_alloc_)));

     dcl	APparent			ptr,		/* ptr to parent node of the node array we are	*/
						/* to create.  It must not be null. (In)	*/
	path			char(168) varying;	/* path name of the parent node, or a link path	*/
						/* if the parent node was a link. (In)		*/
%include lib_based_args_;
     dcl	tree_level		fixed bin,	/* number of generations which are parent to the	*/
						/* node array we are to create. (In)		*/
	link_level		fixed bin,	/* number of consecutive links we have processed	*/
						/* when in no-chase-links mode. (In)		*/
	Parea			ptr,		/* ptr to MSA we are to create the node in. (In)	*/
	director			entry (ptr, char(168) varying, ptr, ptr, bit(72) aligned, bit(36) aligned,
				       fixed bin, fixed bin, ptr, entry, ptr, ptr, fixed bin(35)),
						/* entry we are to call to validate (and further	*/
						/* process) each node in the array. (In)	*/
						/* Note that the director's calling sequence is	*/
						/* the same as ours.			*/
	Pdirector_args		ptr,		/* ptr to director-defined structure containing	*/
						/* information used by the director. (In)	*/
	Pnodes			ptr,		/* ptr to the node array which we created. (Out)	*/
	Acode			fixed bin(35),	/* (Ignored)				*/
	1 root_names		based (Proot_names),/* list of names on a root. 			*/
	  2 N			fixed bin,	/*     count of names.			*/
	  2 root_name (0 refer (root_names.N))		/*     array of names.			*/
				char (32),
	Proot_names		ptr,		/* ptr to root_names structure. (In)		*/
	root_type			fixed bin,	/* type of a root.  2 = directory, 4 = archive.	*/
	root_search_proc		char(65) varying,	/* procedure used to search root. (In)		*/
	MNnodes			fixed bin;	/* maximum size of the root node array. (In)	*/

     dcl						/*	automatic variables			*/
	Inode			fixed bin,	/* index of the node array element (node) we're	*/
						/* working on now.				*/
	Lstring_			fixed bin(35),	/* length of string_.			*/
	Nentries			fixed bin,	/* number of arch comp entries.		*/
	Nterminal_account		fixed bin(1),	/* terminal account switch from hcs_$quota_read	*/
	PBDarch			ptr unal,		/* ptr to base of archive descriptor chain.	*/
	PDarch			ptr,		/* ptr to an archive descriptor chain entry.	*/
	Pacl			ptr,		/* ptr to a segment ACL.			*/
	Parch			ptr,		/* ptr to the archive component we're working on.	*/
	Pdir_acl			ptr,		/* ptr to a directory ACL.			*/
	Piacl			ptr,		/* ptr to a group of IACLs from list_inacl_all.	*/
	Pparent			ptr,		/* ptr to our node's parent node.		*/
	Pstring_			ptr,		/* ptr to string_.				*/
	Ptemp			ptr,		/* a temporary ptr.				*/
	Schase_links		fixed bin(1),	/* chase switch.				*/
	author			char(33),		/* author of a link (33 chars so guaranteed to	*/
						/*  end with a space).			*/
	bit_count			fixed bin(24),	/* a segment or archive component bit count.	*/
	call_id			bit(70) aligned,	/* unique identifier of each logical call to	*/
						/* hcs_$star_ or hcs_$status_long.		*/
	char32			char(32),		/* character temporary.			*/
	clock			fixed bin(71),	/* a binary clock value.			*/
	code			fixed bin(35),	/* a status code.				*/
	count			fixed bin,	/* number of matching entries in a dir.		*/
	e			fixed bin,	/* entry switch:  1-$lib_root_node, 2-$root_node 	*/
	ent			char(32),		/* entry part of a path name.			*/
	error			label local,	/* address of current error handler.		*/
	1 flags			aligned,
	  2 archive		bit(1),		/* segment is an archive.			*/
	  2 object_seg		bit(1),		/* segment is an object segment.		*/
	  2 ascii			bit(1),		/* segment contains only ascii characters.	*/
	i			fixed bin,	/* a do-group index and integer temporary.	*/
	1 iacl_info,				/* information structure req'd by list_inacl_all.	*/
	  2 seg,					/*   information about segment IACLs.		*/
	    3 offsets (0:7)		bit(18) aligned,	/*     per ring offset of first ACLe in array.	*/
	    3 counts  (0:7)		fixed bin,	/*     per ring count of ACL entries.		*/
	  2 dir,					/*   information about directory IACLs.		*/
	    3 offsets (0:7)		bit(18) aligned,	/*     per ring offset of first ACLe in array.	*/
	    3 counts  (0:7)		fixed bin,	/*     per ring count of ACL entries.		*/
	j			fixed bin,	/* a do-group index.			*/
	k			fixed bin,	/* a do-group index.			*/
	msf_dir			char(168),	/* pathname of MSF directory.			*/
	n_components		fixed bin,	/* number of archive components		*/
	type			fixed bin;	/* a temporary containing node type of parent to	*/
						/* the node array we're creating.		*/

%include status_for_backup;

declare 1 sfb automatic aligned like status_for_backup;

     dcl						/*	based variables			*/
	1 Darch			aligned based (PDarch),
						/* an archive component descriptor.		*/
	  2 Pnext			ptr unal,		/* ptr to the next descriptor in the chain.	*/
	  2 Parch			ptr unal,		/* ptr to the archive component.		*/
	  2 Smode			bit(3) unal,	/* mode from archive component.		*/
	  2 pad			bit(8) unal,
	  2 bit_count		fixed bin(24) unal,	/* bit count from archive component.		*/
	  2 dtm			bit(36) aligned,	/* date-time modified for archive component.	*/
	  2 dtupdated		bit(36) aligned,	/* date-time component last updated.		*/
	  2 name			char(32) aligned,	/* component name.				*/
	1 acl (Nacls)		based (Pacl) like Dacl.acls,
						/* a segment ACL structure.			*/
	1 arch			based (Parch),	/* an archive component header.		*/
	  2 header_begin		char(8),		/* start-of-archive-header identification field.	*/
	  2 pad1			char(4),
	  2 name			char(32),		/* name of the archive component.		*/
	  2 dtem			char(16),		/* date-time component updated.		*/
	  2 mode			char(4),		/* user's access mode to segment when archived.	*/
	  2 dtm			char(16),		/* date-time segment last modified before it was	*/
	  2 pad2			char(4),		/*     archived.				*/
	  2 bit_count		char(8),		/* length of archive component (minus header), in	*/
						/* bits).					*/
	  2 header_end		char(8),		/* end-of-archive-header identification field.	*/
	area_var			area based (Parea),	/* area where tree is to be allocated.		*/
	clock_string		bit(72) aligned based (addr (clock)),
						/* bit string overlay for a binary clock value.	*/
	1 dir_acl (Ndir_acls)	based (Pdir_acl) like Ddir_acl.acls,
						/* a directory ACL structure.			*/
	node_string		bit(Lnode_string) aligned based (Pnode),
						/* overlay for the storage occupied by a node.	*/
	stop_search		label local,	/* where to go if search is being stopped	*/
	string_			char(Lstring_) based (Pstring_);

     dcl						/*	builtin functions			*/
         (addr, addrel, binary, divide, length, min, mod, null, pointer, rel,
          reverse, rtrim, size, string, substr, sum, verify)
				builtin;


     dcl						/*	entries				*/
	area			condition,	/* a condition name.			*/
	cleanup			condition,	/* a condition name.			*/
	archive_$list_components	entry (ptr, fixed bin(24), fixed bin, ptr, ptr, fixed bin, fixed bin(35)),
	find_char_$first_in_table	entry (char(*), char(512) aligned) returns (fixed bin(21)) reducible,
	get_ring_			entry returns (fixed bin(5)),
	hcs_$get_author		entry (char(*), char(*), fixed bin(1), char(*), fixed bin(35)),
	hcs_$get_max_length		entry (char(*), char(*), fixed bin(35), fixed bin(35)),
	hcs_$get_safety_sw		entry (char(*), char(*), bit(1), fixed bin(35)),
	hcs_$initiate		entry (char(*), char(*), char(*), fixed bin(1),
				       fixed bin(2), ptr, fixed bin(35)),
	hcs_$list_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	hcs_$list_dir_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	hcs_$list_inacl_all		entry (char(*), ptr, ptr, ptr, fixed bin(35)),
         (hcs_$dir_quota_read,
	hcs_$quota_read)		entry (char(*), fixed bin(35), fixed bin(71), bit(36), fixed bin(35),
				       fixed bin(1), fixed bin(35), fixed bin(35)),
	hcs_$star_		entry (char(*), char(*), fixed bin(2), ptr, fixed bin,
				       ptr, ptr, fixed bin(35)),
	hcs_$status_for_backup	entry (char(*), char(*), ptr, fixed bin(35)),
	hcs_$status_long		entry (char(*), char(*), fixed bin(1), ptr, ptr,
				       fixed bin(35)),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	lib_free_node_$array	entry (ptr),
	lib_free_node_$descriptors	entry (ptr),
	lib_ptr_and_bc_		entry (ptr, fixed bin, ptr, ptr, fixed bin(24), fixed bin(35)),
	match_star_name_		entry (char(*), char(*)) returns (fixed bin(35)),
	msf_manager_$acl_list	entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35)),
	msf_manager_$close		entry (ptr),
	msf_manager_$open		entry (char(*), char(*), ptr, fixed bin(35)),
	object_info_$display	entry (ptr, fixed bin(24), ptr, fixed bin(35)),
	smart_alloc_$area_full	entry (fixed bin, ptr, bit(70) aligned);

     dcl						/*	static variables			*/
						/* length of an archive component header (in bits)*/
	Lnode_string		fixed bin int static init (0),
						/* length of a node (in bits).		*/
	Lrecord			fixed bin(35) int static init (0),
						/* length of a record (in bits).		*/
	NO_MATCH			fixed bin(2) unsigned int static options(constant) init(3),
         (Svalid_added_status, Svalid_archive, Svalid_archive_comp, Svalid_directory, Svalid_link, Svalid_msf, 
	Svalid_msf_comp, Svalid_object_info, Svalid_root init(""b), Svalid_segment)
				bit(72) aligned int static,
         (archive_data_$header_begin,
	archive_data_$header_end,
	archive_data_$ident)	char(8) aligned ext static,
         (error_table_$archive_fmt_err,
	error_table_$logical_volume_not_connected,
	error_table_$noalloc,
	error_table_$nomatch,
	error_table_$notalloc,
	error_table_$out_of_bounds,
	error_table_$process_stopped,
	error_table_$toomanylinks,
	error_table_$typename_not_found)
				fixed bin(35) ext static,
	find_char_$not_ascii_table	char(512) aligned external static,
	ring			fixed bin(5) int static init(8),
						/* current validation level.			*/
	sys_info$maxlinks		fixed bin(35) ext static,
	sys_info$page_size		fixed bin(35) ext static;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Acode = 0;
	if Svalid_root = ""b then call init_Svalid();
	if ring > 7 then ring = get_ring_();
	if Lnode_string = 0 then do;
	     Lnode_string = size(node) * 36;
	     Lrecord = sys_info$page_size * 36;
	     end;
	Schase_links = 0;
	Pparent = APparent;				/* copy input argument for use by internal subr.	*/
	Pnodes = null;				/* initialize output arguments.		*/
	PDnodes = null;				/* initialize node structure ptr.		*/
	Parch = null;				/* initialize temporary pointer so that cleanup	*/
						/* can see if segment must be terminated.	*/
	on cleanup call terminate_archive;		/* cleanup by terminating any archive.		*/

	type = Pparent -> node.T;			/* get parent's node type.			*/
	go to proc_node(type);			/* process each node, according to its type.	*/

proc_node(1):					/* don't process nodes whose parents are	*/
proc_node(4):					/*    segments, archive components, or msf	*/
proc_node(6):					/*    components any further.			*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


proc_node(0):
	error = fatal;				/* processing used when parent is a link.  Any 	*/
						/* error is fatal.				*/
	if link_level > sys_info$maxlinks then do;	/* too many consecutive links can get us into a	*/
	     code = error_table_$toomanylinks;		/* loop.  Use the system-defined limit for	*/
	     go to error;				/* consecutive links to prevent this.		*/
	     end;

	ent = "";					/* use path as entire path name of link.	*/
	call get_node_array (1);			/* get a node array containing only a single node.*/
	call init_node;				/* initialize this node.			*/
	Schase_links = binary (Sc.chase, 1);		/* interpret link chase switch here.		*/
	call status_long ((path), ent);		/* get status info about the item linked to.	*/
						/* store this information in the node.		*/
	stop_search = end_search;
	call director_caller;			/* let director have a chance to validate node.	*/
end_search:
	Pnodes = PDnodes;				/* return ptr to the node array descriptor.	*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


proc_node(2):					/* processing used when parent is a directory.	*/
	if starname.N > 1 then			/* process multiple starnames in outer ring.	*/
	     ent = "**";
	else					/* let ring 0 process single starname.		*/
	     ent = starname(1).V;
	go to call_star;

proc_node(3):					/* processing used when parent is an msf.	*/
	ent = "**";				/* return information about all msf components.	*/

call_star:
	call_id = "0"b;				/* initialize call id, so that it will be set the	*/
						/* first time smart_alloc_$area_full is called.	*/
call_again:
	call hcs_$star_ ((path), ent, star_ALL_ENTRIES, Parea,
	   star_entry_count, star_entry_ptr, star_names_ptr, code);
						/* get the name and type of each matching entry 	*/
						/* in the directory.			*/
	if code = error_table_$notalloc then do;	/* if the current SSA of the MSA is full, 	*/
	     call smart_alloc_$area_full (0, Parea, call_id);
	     go to call_again;			/* get another SSA in the MSA, and try again.	*/
	     end;
	else if code ^= 0 then			/* treat any other status code as a fatal error.	*/
	     go to fatal;

	count = star_entry_count;			/* find out how many entries match any starname.	*/
	go to star_test(type);			/* no checking needed for msfs.		*/

star_test(2):
	if starname.N > 1 then do;			/* compare entry names with starnames.  Flag	*/
	     do i = 1 to star_entry_count;		/*    entry type with "11"b for non-matches.	*/
		do j = star_entries(i).nindex  to  star_entries(i).nindex + star_entries(i).nnames - 1;
		     do k = 1 to starname.N;
			go to dir_test(starname(k).C);

dir_test(0):		if star_names(j) = starname(k).V then go to dir_match;
			go to dir_nomatch;

dir_test(1):		if match_star_name_(star_names(j), starname(k).V) = 0 then go to dir_match;

dir_nomatch:		end;
		     end;
		star_entries(i).type = NO_MATCH;	/* Flag entry as non-matching.		*/
		count = count - 1;			/* Exclude it from entry count.		*/
dir_test(2):
dir_match:	end;

	     if count = 0 then do;
		code = error_table_$nomatch;
		go to fatal;
		end;
	     end;

star_test(3):
	call get_node_array (count);			/* get a node array with 1 node for each matching	*/
						/* entry in the directory.			*/
	error = record_and_skip;			/* record any errors returned by status.	*/

	stop_search = star_test_stop;
	do i = star_entry_count to 1 by -1;		/* fill in nodes, one by one, most recently	*/
						/*   created first.				*/
	     if star_entries(i).type = NO_MATCH then go to next_entry;
						/* Ignore this entry.  It didn't match.		*/
						/* then discard the erring entry, and continue.	*/
	     call init_node;			/* initialize this node.			*/
	     call status_long ((path), star_names (star_entries(i).nindex));
						/* fill status of this entry into the node.	*/

	     call director_caller;			/* the director has his chance at the node now.	*/
	     go to next_entry;			/* if director OKed node, then fill in next one.	*/

record_and_skip:
	     if Dnodes.C ^= error_table_$logical_volume_not_connected then
		Dnodes.C = code;			/* remember what the last code was from status.	*/
	     call lib_free_node_$descriptors (Pnode);	/* free any node descriptors.			*/
	     Inode = Inode - 1;			/* reuse this node for the next entry.		*/

next_entry:    end;

star_test_stop:
	free star_names in (area_var),		/* free name list returned by star_.		*/
	     star_entries in (area_var);		/* free entry array returned by star_.		*/
	Dnodes.N = Inode;				/* store count of nodes we've filled into descr.	*/
	if Inode = 0 then do;			/* if no nodes were filled (because of bad status	*/
	     if Dnodes.C ^= 0 then code = Dnodes.C;
	     else code = error_table_$nomatch;		/* or director rejection), then tell parent node.	*/
	     go to fatal;
	     end;
	else Dnodes.C = 0;
	Pnodes = PDnodes;				/* return ptr to the node array descriptor.	*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


proc_node(5):					/* processing used when parent node is an archive	*/
	error = terminate_arch;			/* terminate the archive if an error occurs.	*/

	call lib_ptr_and_bc_ (Pparent, 0, null, Parch, bit_count, code);
	if code ^= 0 then go to error;		/* get ptr to, and bit count of, parent archive.	*/
	PDarch = addr (PBDarch);			/* make PBDarch point to the first archive	*/
						/* descriptor (Darch) we create.		*/
	PBDarch = null;				/* to start with, there are no descriptors.	*/
	Nentries = 0;

	call_id = "0"b;

get_components:
	on area go to arch_expand_area;

	call archive_$list_components (Parch, bit_count, ARCHIVE_COMPONENT_INFO_VERSION_1,
	     Parea, archive_component_info_ptr, n_components,
	     code);

	revert area;

	if code ^= 0 then do;
	     call terminate_archive;
	     go to fatal;
	     end;

	do j = 1 to n_components;
	     do k = 1 to starname.N;
		go to arch_test(starname(k).C);

arch_test(0):	if starname (k).V = archive_component_info_array (j).name then go to arch_match;
		go to arch_nomatch;

arch_test(1):	if match_star_name_ (archive_component_info_array (j).name, starname (k).V) = 0 then
		     go to arch_match;
		go to arch_nomatch;

arch_test(2):
arch_match:
		Nnames = 1;			/* create a name descriptor; use temporarily as	*/
		allocate Dnames in (area_var) set (Ptemp); /* archive component descriptor until we find out	*/
		Darch.Pnext = Ptemp;
		PDarch = Ptemp;			/* how many matching archive components exist.	*/
		Darch.Pnext = null ();
		Darch.Parch = archive_component_info_array (j).comp_ptr;
		Darch.name = archive_component_info_array (j).name;
		Darch.bit_count = archive_component_info_array (j).comp_bc;
		clock = archive_component_info_array (j).time_modified;
		Darch.dtm = substr (clock_string, 21, 36);
		clock = archive_component_info_array (j).time_updated;
		Darch.dtupdated = substr (clock_string, 21, 36);
		Darch.Smode = substr (archive_component_info_array (j).access, 1, 3);
		Nentries = Nentries + 1;
		if starname.N = 1 then
		     if starname (1).C = 0 then go to arch_test_done;
arch_nomatch:
		end;
	     end;

	     free archive_component_info_array in (area_var);

arch_test_done:					/* if a format error occurred, or if we scanned	*/
	if Nentries = 0 then do;			/* thru entire archive, or if no *'s in star name,*/
	     if code = error_table_$archive_fmt_err then;	/* then if no matching components were found,	*/
	     else					/* store an error code in patent node, terminate	*/
		code = error_table_$nomatch;		/* the archive, and return.			*/
terminate_arch:
	     call terminate_archive;
	     go to fatal;
	     end;

	stop_search = arch_test_stop;
	error = director_reject;			/* errors in this section are caused by the	*/
						/* director's rejection of a node.		*/
	call get_node_array (Nentries);		/* get node array with 1 node for each matching	*/
						/* component.				*/

	if Dnodes.C ^= error_table_$logical_volume_not_connected then
	     Dnodes.C = code;			/* save any archive format error.		*/
	PDarch = PBDarch;				/* starting at head of descriptor chain,	*/
	do i = 1 to Nentries;			/* scan thru component descriptors, filling	*/
						/* in a node for each matching component.	*/
	     call init_node;			/* initialize the node.			*/
	     node.bit_count = Darch.bit_count;		/* store bit count from descriptor.		*/
	     node.Smode = Darch.Smode;		/* store mode.				*/
	     node.dtm = Darch.dtm;			/* store dtm.				*/
	     node.dtem = Darch.dtupdated;		/* store dtem.				*/
	     PDnames = PDarch;			/* use archive descriptor as name descriptor.	*/
	     Parch = Darch.Parch;			/* but first, save ptr to archive component.	*/
	     PDarch  = Darch.Pnext;			/* Also, save ptr to next descriptor.		*/
	     Dnames.N = 1;				/* set number of names in descriptor to 1.	*/
	     Dnames.length = size (Dnames);		/* store length of descriptor.		*/
	     Dnames.version = Vnames_1;		/* and version number.			*/
	     Dnames.Pnext = node.PD;			/* chain descriptor to node.			*/
	     node.PD = PDnames;
	     Dnames.T = Tnames;			/* specify this is a name descriptor.		*/

	     node.current_length = divide (node.bit_count + Lrecord - 1, Lrecord, 35, 0);
						/* compute current length (in records) from	*/
						/* component's bit count.			*/
	     node.offset = binary (rel (Parch), 18);
						/* fill in component's offset from base of segment*/
						/* containing the archive.  This works		*/
						/* for archived archives, too.		*/

	     node.Svalid = Svalid_archive_comp;		/* indicate which basic node fields are valid.	*/
	     if Sc.check_ascii then do;		/* see if component contents is printable.	*/
		call test_ascii (Parch, node.bit_count, flags.ascii);
		Svalid.not_ascii = ^flags.ascii;
		end;
	     else do;
		flags.ascii = "0"b;
		end;
	     flags.archive = "0"b;			/* assume component is not an archived archive.	*/
	     if Sc.check_archive then
	          flags.archive = test_archive (node.bit_count);
	     if flags.archive then
		node.T = Tarchive;
	     else do;
		node.T = Tarchive_comp;
		if flags.ascii & Sc.check_ascii then;
		else if Sc.object_info then do;	/* see if component is an object component.	*/
		     flags.object_seg = object_seg_ (Parch, node.bit_count);
		     if flags.object_seg then
			node.Svalid = node.Svalid | Svalid_object_info;
		     end;
		end;
	     node.Sreq = node.Svalid & Srequirements;	/* say which fields are required for output.	*/
	     call director_caller;			/* let the director validate this node.		*/
	     go to end_component;			/* all done for this component.		*/

director_reject:					/* if director rejected this node, then		*/
	     call lib_free_node_$descriptors (Pnode);	/* free node's descriptors.			*/
	     Inode = Inode - 1;			/* reuse this node for next component.		*/
end_component: end;

arch_test_stop:
	Dnodes.N = Inode;				/* record number of filled nodes in node array.	*/
	call terminate_archive;			/* terminate the archive.			*/
	if Inode = 0 then do;			/* if no acceptable components were found,	*/
	     if code = error_table_$archive_fmt_err then;	/* set error code in a null node array descriptor.*/
	     else
		code = error_table_$nomatch;
	     go to fatal;
	     end;
	Pnodes = PDnodes;				/* return ptr to the node array descriptor.	*/
	return;

arch_expand_area:					/* let msa_manager_ expand the area		*/
	revert area;
	call smart_alloc_$area_full (0, Parea, call_id);
	go to get_components;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


fatal:						/* this is the global exit for errors which are	*/
						/* fatal to the process of getting a node array.	*/
	if PDnodes ^= null then do;			/* if a node array was allocated, free it.	*/
	     Dnodes.N = Inode;			/* store count of number of filled node in descr.	*/
	     call lib_free_node_$array (PDnodes);
	     end;
	call get_node_array (0);			/* get a node descriptor with zero nodes.	*/
	if Dnodes.C ^= error_table_$logical_volume_not_connected then
	     Dnodes.C = code;			/* fill in its error code.			*/
	Pnodes = PDnodes;				/* return this error code descriptor.		*/
	return;					/* You lose, buddy.  Too bad.			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	A  D  D  I  T  I  O  N  A  L     E  N  T  R  Y     P  O  I  N  T  S		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


root_array:	entry	(MNnodes, Parea, Pnodes, Acode);

	call get_node_array(MNnodes);			/* get a node array of specified length.	*/
	Dnodes.N = 0;				/* record current length of node array.		*/
	Pnodes = PDnodes;				/* return pointer to node array.		*/
	Acode = 0;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


root_array_info:	entry	(Pnodes, MNnodes, Acode);

	PDnodes = Pnodes;				/* address the specified node array.		*/
	MNnodes = Dnodes.N;				/* return current dimension of array, and any	*/
	Acode = Dnodes.C;				/*    error code returned while getting array.	*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_root_node:	entry	(Proot_names, root_type, path, root_search_proc, Pstarname, Pexclude, Srequirements,
			 Scontrol, Parea, director, Pdirector_args, Pnodes, MNnodes, Acode);

	e = 1;
	go to COMMON;


root_node:	entry	(Proot_names, root_type, path, Pstarname, Pexclude, Srequirements, Scontrol,
			 Parea, director, Pdirector_args, Pnodes, MNnodes, Acode);

	e = 2;

COMMON:	if Svalid_root = ""b then call init_Svalid();	/* initialize internal static variables.	*/
	Pparent = null;				/* a root node has no parent node.		*/
	PDnodes = Pnodes;				/* address the root node array.		*/
	if Dnodes.N = MNnodes then do;		/* make sure array isn't full.		*/
	     Acode = error_table_$out_of_bounds;
	     return;
	     end;
	if root_type ^= Tdirectory then if root_type ^= Tarchive then do;
	     Acode = error_table_$typename_not_found;
	     return;
	     end;

	Inode = Dnodes.N;				/* address the last filled node of array.	*/
	Dnodes.N = Dnodes.N + 1;			/* extend current length of array.		*/
	call init_node;				/* initialize new node.			*/
	link_node.T = root_type;			/* fill in root type.			*/
	link_node.Svalid = Svalid_root;		/*	      valid fields.			*/
	Nnames = root_names.N;			/*	      names.			*/
	if Nnames > 0 then do;
	     allocate Dnames in (area_var);
	     Dnames.length = size (Dnames);
	     Dnames.version = Vnames_1;
	     Dnames.Pnext = link_node.PD;
	     link_node.PD = PDnames;
	     Dnames.T = Tnames;
	     Dnames.names(*) = root_names.root_name(*);
	     end;
	else do;
	     Svalid.primary_name = "0"b;
	     Svalid.matching_names = "0"b;
	     Svalid.names = "0"b;
	     end;
	link_node.link_target = path;			/* 	      path.			*/
	if e = 1 then if length(root_search_proc) > 0 then do;
	     allocate Dsearch_proc in (area_var);
	     Dsearch_proc.length = size(Dsearch_proc);
	     Dsearch_proc.version = Vsearch_proc_1;
	     Dsearch_proc.Pnext = link_node.PD;
	     link_node.PD = PDsearch_proc;
	     Dsearch_proc.T = Tsearch_proc;
	     Dsearch_proc.search_proc = root_search_proc;
	     Svalid.root_search_proc = "1"b;
	     end;
	node.Sreq = node.Svalid & Srequirements;	/*              required fields.		*/

	Acode = 0;				/* no more errors from here on can affect code.	*/
	error = root_error;
	stop_search = root_stop;
	call director_caller;			/* search this root for entries matching starname.*/
root_stop:
	return;

root_error:
	if Dnodes.C ^= error_table_$logical_volume_not_connected then
	     Dnodes.C = code;			/* remember last root error code.		*/
	call lib_free_node_$descriptors (Pnode);
	Dnodes.N = Dnodes.N - 1;			/* remove node from array.			*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	     I  N  T  E  R  N  A  L          P  R  O  C  E  D  U  R  E  S		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


cv_num:	proc (n) returns (char(32));			/* procedure to convert integer to char string.	*/

     dcl	n			fixed bin,	/* number to be converted. (In)		*/
	char32			char(32),		/* the result.				*/
	i			fixed bin,
	pic			pic "zzzzzzzzzzzz9";

	pic = n;
	i = verify (pic, " ");
	char32 = substr(pic,i);
	return (char32);

	end cv_num;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  * 
 *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


director_caller:	procedure;			/* This internal procedure is called in order to	*/
						/* have the director validate each node after it	*/
						/* has been filled, but before the next node	*/
						/* in the array is filled.  If the director	*/
						/* rejects the node, then this procedure	*/
						/* branches to the caller's error handler.	*/

	code = 0;					/* initialize search director's return code 	*/
	PD = null;				/* and output node ptr.			*/
	if node.Pparent = null then			/* for a root node, pass the root path, tree level*/
						/* 1, link level 0.				*/
	     call director (Pnode, link_node.link_target, Pstarname, Pexclude, Srequirements, Scontrol, 1, 0, 
			Parea, director, Pdirector_args, PD, code);
	else if node.T = Tlink then			/* for the first link in a chain, pass the link 	*/
	     if link_level = 0 then			/* path and increment both tree and link level.	*/
		call director (Pnode, link_node.link_target, Pstarname, Pexclude, Srequirements, Scontrol,
			     tree_level+1, link_level+1, Parea, director, Pdirector_args, PD, code);
	     else					/* for succeeding links in a chain, pass the link	*/
						/* path and increment just the link level.	*/
		call director (Pnode, link_node.link_target, Pstarname, Pexclude, Srequirements, Scontrol,
			     tree_level, link_level+1, Parea, director, Pdirector_args, PD, code);
	else if link_level > 0 then			/* for the target of a link, pass on the target	*/
						/* path, zero the link level, and pass on the	*/
						/* current tree level.			*/
	     call director (Pnode, path, Pstarname, Pexclude, Srequirements, Scontrol,
			tree_level, 0, Parea, director, Pdirector_args, PD, code);
	else do;					/* otherwise, compute path by adding node's 1st	*/
						/* name to path we rec'd as input, increment	*/
						/* the tree level, and zero the link level.	*/
	     j = min(32, 33-verify(reverse(Dnames.names(1)), " "));
	     if path = ">" then
		call director (Pnode, path || substr (Dnames.names(1), 1, j), Pstarname, Pexclude,
			     Srequirements, Scontrol, tree_level+1, 0, Parea, director, Pdirector_args, PD, code);
	     else call director (Pnode, path || ">" || substr (Dnames.names(1), 1, j), Pstarname, Pexclude,
			     Srequirements, Scontrol, tree_level+1, 0, Parea, director, Pdirector_args, PD, code);
	     end;

	if PD ^= null then do;			/* if the director created a node descriptor,	*/
	     D.Pnext = node.PD;			/* attach it to the node.			*/
	     node.PD = PD;
	     Svalid.kids = "1"b;
	     if PD -> Dnodes.C ^= 0 then do;		/* validate the error code, if there was one.	*/
		Svalid.kids_error = "1"b;
		Sreq.kids_error = S.kids_error;
		Sreq.primary_name = Sreq.primary_name | S.kids_error;
		end;
	     end;
	if code = error_table_$process_stopped then
	     go to stop_search;
	else if code ^= 0 then			/* if the director rejected the node for any	*/
	     go to error;				/* reason, then go to the caller's error handler.	*/

	end director_caller;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_acl:		procedure (dir, ent);		/* Internal procedure called to get ACL for a	*/
						/* segment, and store it in a segment ACL	*/
						/* descriptor.				*/
     dcl	dir			char(*),		/* dir part of segment's path name. (In)	*/
	ent			char(*);		/* ent part of segment's path name. (In)	*/

	call_id = "0"b;				/* initialize id used for smart_alloc_.		*/
acl_again:
	call hcs_$list_acl (dir, ent, Parea, Pacl, null, Nacls, code);
	if code = error_table_$noalloc then do;		/* if our SSA of MSA was full, get another one.	*/
	     call smart_alloc_$area_full (0, Parea, call_id);
	     go to acl_again;
	     end;
	else if code ^= 0 then Nacls = 0;		/* fake it if there is no ACL.		*/
						/* if no trouble getting ACL, get access class.	*/
	allocate Dacl in (area_var);
	Dacl.length = size(Dacl);
	Dacl.version = Vacl_1;
	Dacl.Pnext = node.PD;			/* chain ACL descriptor to the node.		*/
	node.PD = PDacl;
	Dacl.T = Tacl;
	Dacl.C = code;
	Dacl.N = Nacls;
	if Dacl.N > 0 then Dacl.acls = acl;		/* copy ACL into descriptor.			*/

	end get_acl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_dir_acl:	procedure (dir, ent);		/* Internal procedure to get ACL for a directory	*/
						/* and store it in a directory ACL descriptor.	*/
     dcl	dir			char(*),		/* dir part of directory's path name. (In)	*/
	ent			char(*);		/* ent part of directory's path name. (In)	*/

	call_id = "0"b;				/* initialize id used for smart_alloc_.		*/
dir_acl_again:
	call hcs_$list_dir_acl (dir, ent, Parea, Pdir_acl, null, Ndir_acls, code);
	if code = error_table_$noalloc then do;		/* if our SSA of MSA was full, get another one.	*/
	     call smart_alloc_$area_full (0, Parea, call_id);
	     go to dir_acl_again;
	     end;
	else if code ^= 0 then Ndir_acls = 0;		/* fake it if there is no ACL.		*/
						/* if no trouble getting ACL, get access class.	*/
	allocate Ddir_acl in (area_var);
	Ddir_acl.length = size(Ddir_acl);
	Ddir_acl.version = Vdir_acl_1;
	Ddir_acl.Pnext = node.PD;			/* chain descriptor onto node.		*/
	node.PD = PDdir_acl;
	Ddir_acl.T = Tdir_acl;
	Ddir_acl.C = code;
	Ddir_acl.N = Ndir_acls;
	if Ddir_acl.N > 0 then Ddir_acl.acls = dir_acl;	/* copy ACL into descriptor.			*/

	end get_dir_acl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_iacls:	procedure (dir, ent);		/* Internal procedure to get all IACLs for a	*/
						/* directory and store them in an IACL descriptor.*/
     dcl	dir			char(*),		/* dir part of directory's path name. (In)	*/
	ent			char(*),		/* ent part of directory's path name. (In)	*/
	i			fixed bin,	/* a do-group index.			*/
	path			char(168);	/* directory's path name.			*/

	path = dir || ">" || ent;
	call_id = "0"b;				/* initialize id used for smart_alloc_.		*/
iacl_again:
	call hcs_$list_inacl_all (path, Parea, Piacl, addr(iacl_info), code);
	if code = error_table_$noalloc then do;		/* if our SSA of MSA was full, get another one.	*/
	     call smart_alloc_$area_full (0, Parea, call_id);
	     go to iacl_again;
	     end;
	else if code ^= 0 then			/* fake it if a fatal error occurred.		*/
	     do i = 0 to 7;
		iacl_info.seg.counts(i) = 0;
		iacl_info.dir.counts(i) = 0;
		end;
	Niacls, Ndir_iacls = 0;
	do i = 0 to 7;				/* add up counts of IACL entries.		*/
	     Niacls = Niacls + iacl_info.seg.counts(i);
	     Ndir_iacls = Ndir_iacls + iacl_info.dir.counts(i);
	     end;

	allocate Diacl in (area_var);			/* fill in the segment IACL descriptor.		*/
	Diacl.length = size(Diacl);
	Diacl.version = Viacl_1;
	Diacl.Pnext = node.PD;			/* chain descriptor onto node.		*/
	node.PD = PDiacl;
	Diacl.T = Tiacl;
	Diacl.C = code;
	Diacl.N = Niacls;
	Diacl.N = 1;				/* copy IACLs into descriptor.		*/
	do i = 0 to 7;
	     Diacl.Iring(i) = Diacl.N;
	     Diacl.Nring(i) = iacl_info.seg.counts(i);
	     if iacl_info.seg.counts(i) > 0 then do;
		Pacl = addrel(Piacl, iacl_info.seg.offsets(i));
		Nacls = iacl_info.seg.counts(i);
		addr(Diacl.acls(Diacl.N)) -> acl = acl;
		Diacl.N = Diacl.N + Nacls;
		end;
	     end;
	Diacl.N = Diacl.N - 1;
	allocate Ddir_iacl in (area_var);			/* fill in the directory IACL descriptor.	*/
	Ddir_iacl.length = size(Ddir_iacl);
	Ddir_iacl.version = Vdir_iacl_1;
	Ddir_iacl.Pnext = node.PD;			/* chain descriptor onto node.		*/
	node.PD = PDdir_iacl;
	Ddir_iacl.T = Tdir_iacl;
	Ddir_iacl.C = code;
	Ddir_iacl.N = Ndir_iacls;
	Ddir_iacl.N = 1;				/* copy IACLs into descriptor.		*/
	do i = 0 to 7;
	     Ddir_iacl.Iring(i) = Ddir_iacl.N;
	     Ddir_iacl.Nring(i) = iacl_info.dir.counts(i);
	     if iacl_info.dir.counts(i) > 0 then do;
		Pdir_acl = addrel(Piacl, iacl_info.dir.offsets(i));
		Ndir_acls = iacl_info.dir.counts(i);
		addr(Ddir_iacl.acls(Ddir_iacl.N)) -> dir_acl = dir_acl;
		Ddir_iacl.N = Ddir_iacl.N + Ndir_acls;
		end;
	     end;
	Ddir_iacl.N = Ddir_iacl.N - 1;

	end get_iacls;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_msf_acl:	procedure (dir, ent);		/* Internal procedure to get ACL for an MSF,	*/
						/* and store it in a segment ACL descriptor.	*/
     dcl	dir			char(*),		/* dir part of MSF's path name. (In)		*/
	ent			char(*);		/* ent part of MSF's path name. (In)		*/

	call msf_manager_$open (dir, ent, Ptemp, code);	/* open the MSF.				*/
	if code = 0 then do;
	     call_id = "0"b;			/* initialize id used for smart_alloc_.		*/
msf_acl_again: call msf_manager_$acl_list (Ptemp, Parea, Pacl, null, Nacls, code);
	     if code = error_table_$noalloc then do;	/* if our SSA of MSA is full, get another one.	*/
		call smart_alloc_$area_full (0, Parea, call_id);
		go to msf_acl_again;
		end;
	     end;
	if code ^= 0 then Nacls = 0;			/* fake it if there is no ACL.		*/
						/* if no trouble getting ACL, get access class.	*/
	allocate Dacl in (area_var);
	Dacl.length = size(Dacl);
	Dacl.version = Vacl_1;
	Dacl.Pnext = node.PD;			/* chain descriptor onto the node.		*/
	node.PD = PDacl;
	Dacl.T = Tacl;
	Dacl.C = code;
	Dacl.N = Nacls;
	if Dacl.N > 0 then Dacl.acls = acl;		/* copy ACL into descriptor.			*/
	call msf_manager_$close (Ptemp);		/* close the MSF.				*/

	end get_msf_acl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_node_array:	procedure (N);			/* This internal procedure allocates a node array	*/
						/* and initializes its header.		*/

     dcl	N			fixed bin;	/* Number of nodes to be allocated in the array.	*/

	Nnodes = N;				/* set variable which controls number of nodes	*/
						/* which get allocated in our adjustable based	*/
						/* array.					*/
	allocate Dnodes in (area_var);		/* allocate the node array descriptor.		*/
	Dnodes.length = size (Dnodes);		/* fill in its size,			*/
	Dnodes.version = Vnodes_1;			/*	     version,			*/
	Dnodes.Pnext = null;			/*	     next descriptor ptr, and		*/
	Dnodes.header.T = Tnodes;			/*	     type.			*/
	Dnodes.C = 0;				/* clear its error code.			*/

	Inode = 0;				/* initialize number of filled nodes to zero.	*/

	end get_node_array;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


init_Svalid:	procedure;			/* Internal procedure which initializes the 	*/
						/* internal static constants defining which of	*/
						/* the basic node fields are valid for each type	*/
     dcl	Srequirements		bit(72) aligned,	/* of node.				*/
	1 S			like Svalid_req based (addr(Srequirements));

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtem = "1"b;
	S.dtd = "1"b;
	S.link_target = "1"b;
	S.new_line = "1"b;
	S.level = "1"b;
	S.cross_ref = "1"b;
	Svalid_link = Srequirements;

	string(S) = ""b;
 	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtm = "1"b;
	S.dtu = "1"b;
	S.dtem = "1"b;
	S.dtd = "1"b;
	S.current_length = "1"b;
	S.records_used = "1"b;
	S.bit_count = "1"b;
	S.max_length = "1"b;
	S.lvid = "1"b;
	S.mode = "1"b;
	S.rb = "1"b;
	S.copy = "1"b;
	S.safety = "1"b;
	S.unique_id = "1"b;
	S.new_line = "1"b;
	S.level = "1"b;
	S.cross_ref = "1"b;
	Svalid_segment = Srequirements;
	Svalid_msf_comp = Srequirements;
	Svalid_archive = Srequirements;
	S.max_length = "0"b;
	S.copy = "0"b;
	S.msf_indicator = "1"b;
	Svalid_msf = Srequirements;
	S.bit_count = "0"b;
	S.msf_indicator = "0"b;
	Svalid_directory = Srequirements;

	string(S) = ""b;
	S.dtc = "1"b;
	S.compiler_name = "1"b;
	S.compiler_version = "1"b;
	S.compiler_options = "1"b;
	S.object_info = "1"b;
	Svalid_object_info = Srequirements;

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtm = "1"b;
	S.dtem = "1"b;
	S.current_length = "1"b;
	S.bit_count = "1"b;
	S.offset = "1"b;
	S.mode = "1"b;
	S.new_line = "1"b;
	S.level = "1"b;
	S.cross_ref = "1"b;
	Svalid_archive_comp = Srequirements;

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.new_line = "1"b;
	S.level = "1"b;
	S.cross_ref = "1"b;
	Svalid_root = Srequirements;

	string(S) = ""b;
	S.access_class = "1"b;
	S.aim = "1"b;
	S.author = "1"b;
	S.bit_count_author = "1"b;
	S.entry_bound = "1"b;
	S.pvid = "1"b;
	Svalid_added_status = Srequirements;

	end init_Svalid;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


init_node:	procedure;			/* This internal procedure initializes a node.	*/

	Inode = Inode + 1;				/* increment the filled node count to get the next*/
						/* available node.				*/
	Pnode = addr (Dnodes.nodes (Inode));		/* access the node.				*/
	node_string = ""b;				/* zero out storage occupied by node.		*/
	node.Pparent = Pparent;
	node.PD = null;				/* initialize the node's pointers.		*/

	end init_node;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


object_seg_:	procedure (Pseg, bit_count)		/* This internal procedure checks to see if a	*/
		returns	(bit(1) aligned);		/* segment is an object segment and, if so, it	*/
						/* appends an object_info_ descriptor to the node	*/
						/* which represents the segment.		*/

     dcl	Pseg			ptr,		/* ptr to the segment.			*/
	bit_count			fixed bin(35);	/* bit count of the segment.			*/
						/* overlay for object segment strings.		*/

	oi.version_number = object_info_version_2;	/* initialize the object_info_ structure.	*/
	call object_info_$display (Pseg, binary(bit_count, 24), addr(oi), code);
	if code ^= 0 then				/* let object_info_ decide if this is an obj seg.	*/
	     return ("0"b);
	allocate Dobj in (area_var);			/* create an object_info_ descriptor.		*/
	Dobj.version = Vobj_1;			/* initialize its header.			*/
	Dobj.length = size (Dobj);
	Dobj.T = Tobj;
	Dobj.Pnext = node.PD;
	node.PD = PDobj;


	Dobj.info.Otext = binary (rel (oi.textp), 18);	/* fill in the structure, converting pointers	*/
	Dobj.info.Odefinitions = binary (rel (oi.defp),18);/* to offsets.				*/
	Dobj.info.Olink = binary (rel (oi.linkp), 18);
	Dobj.info.Ostatic = binary (rel (oi.statp), 18);
	Dobj.info.Osymbols = binary (rel (oi.symbp), 18);
	Dobj.info.Obreaks = binary (rel (oi.bmapp), 18);
	Dobj.info.Ltext = oi.tlng;
	Dobj.info.Ldefinitions = oi.dlng;
	Dobj.info.Llink = oi.llng;
	Dobj.info.Lstatic = oi.ilng;
	Dobj.info.Lsymbols = oi.slng;
	Dobj.info.Lbreaks = oi.blng;
	string (Dobj.info.format) = string (oi.format);
	Dobj.info.entry_bound = oi.entry_bound;
	Dobj.info.Otext_links = binary (rel (oi.textlinkp), 18);
	Dobj.info.compiler = oi.compiler;
	Dobj.info.compile_time = oi.compile_time;
	Dobj.info.userid = oi.userid;
	Dobj.info.cversion.O = Dobj.info.Osymbols +  binary (oi.cvers.offset, 18);
	Dobj.info.cversion.L = binary (oi.cvers.length, 18);
	Dobj.info.comment.O = Dobj.info.Osymbols + binary (oi.comment.offset, 18);
	Dobj.info.comment.L = binary (oi.comment.length, 18);
	Dobj.info.Osource = Dobj.info.Osymbols + oi.source_map;
	Pstring_ = pointer (Pseg, Dobj.info.cversion.O);
	Lstring_ = Dobj.info.cversion.L;
	Dobj.cversion = string_;
	Pstring_ = pointer (Pseg, Dobj.info.comment.O);
	Lstring_ = Dobj.info.comment.L;
	Dobj.comment = string_;

	return ("1"b);

	end object_seg_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

status_long:	procedure (dir, ent);		/* This procedure calls hcs_$status_long to get	*/
						/* status information for dir>ent, and fills this	*/
						/* information in the node.			*/

     dcl	dir			char(*),		/* dir part of path of entry to get status of.(In)*/
	ent			char(*);		/* ent path of path of entry to get status of.(In)*/

     dcl	i			fixed bin;	/* do-group index.				*/

	call_id = "0"b;				/* initialize call id so that it will be set on	*/
						/* our first call to smart_alloc_$area_full.	*/
	status_ptr = addr (auto_status_branch);
call_again:
	status_area_ptr = Parea;
	call hcs_$status_long (dir, ent, Schase_links, addr (status_branch),
	   Parea, code);
	if code = error_table_$noalloc then do;		/* if our SSA of MSA was full, get another SSA by	*/
						/* calling smart_alloc_$area_full.		*/
	     call smart_alloc_$area_full (0, Parea, call_id);
	     go to call_again;			/* try getting status info again.		*/
	     end;
	else if code ^= 0 then			/* return to caller's error handler for any other	*/
	     go to error;				/* error.					*/

	Nnames = status_branch.nnames;		/* compute number of names.			*/
	allocate Dnames in (area_var);		/* store them in a name descriptor, attached to	*/
	Dnames.length = size (Dnames);		/* the node.				*/
	Dnames.version = Vnames_1;
	Dnames.T = Tnames;
	addr(Dnames.names)->status_entry_names = status_entry_names;
	free status_entry_names in (area_var);		/* copy names into the descriptor.		*/

	go to type (status_branch.type);		/* do rest of processing according to type of 	*/
						/* entry we got the status of.		*/

type(0):	link_node.T = Tlink;			/* this is a link!				*/
	link_node.link_target = status_pathname;
	free status_pathname in (area_var);		/* free the link path name status returned.	*/
	link_node.dtem = status_link.dtem;		/* fill in the dates.			*/
	link_node.dtd = status_link.dtd;
	link_node.Svalid = Svalid_link;		/* record which attributes of link_node are valid.*/
	if Sc.all_status then do;
	     call hcs_$get_author (dir, ent, 0, author, 0);
	     link_node.author = rtrim(author);
	     Svalid.author = "1"b;
	     end;
	link_node.Sreq = link_node.Svalid & Srequirements;/* record which are required for output.	*/
	Dnames.Pnext = node.PD;			/* make name descriptor first in the chain of	*/
	node.PD = PDnames;				/*   descriptors off node.  It's referenced most.	*/
	return;					/* not much processing for a link node.		*/

type(1):						/* this is a segment!			*/
	node.Smode = substr (status_branch.mode, 2, 3);	/* map "xrewx" into "rew".			*/
	node.rb = status_branch.ring_brackets;		/* copy ring brackets into node.		*/
	node.records_used = status_branch.records_used;
	node.current_length = status_branch.current_length;
						/* copy the current length.			*/
	node.bit_count = status_branch.bit_count;	/* copy the bit count.			*/
	call hcs_$get_max_length (dir, ent, node.max_length, code);

	call test_segment (dir, ent, flags);		/* find out about segment.			*/
	if Pparent -> node.T = Tmsf then do;		/* is it an msf component?			*/
	     node.T = Tmsf_comp;			/* yes.					*/
	     node.Svalid = Svalid_msf_comp;
	     if flags.archive then			/* MSF component is also an archive. Hum!	*/
		go to process_archive;
	     else 				/* process flags further, and set requirements	*/
		go to process_segment;		/* switches in node.			*/
	     end;
	else if flags.archive then do;		/* is it an archive?			*/
	     node.Svalid = Svalid_archive;
process_archive:
	     node.T = Tarchive;
	     Svalid.not_ascii = ^flags.ascii;
	     end;
	else do;	 				/* otherwise, it's just a plain segment.	*/
	     node.T = Tsegment;
	     node.Svalid = Svalid_segment;
process_segment:
	     if flags.object_seg then			/* if an object segment, say so.		*/
		node.Svalid = node.Svalid | Svalid_object_info;
	     Svalid.not_ascii = ^flags.ascii;		/* say whether segment is printable or not.	*/
	     end;
	if Sc.acl & (node.T ^= Tmsf_comp) then do;	/* get ACL for segment or archive.		*/
	     call get_acl (dir, ent);			/*   This call automatically chains ACL to node.	*/
	     Svalid.acl = "1"b;
	     end;
	go to fill_node;				/* fill remainder of node from status block.	*/

type(2):						/* this is a directory!			*/
	node.records_used = status_branch.records_used;
	node.current_length = status_branch.current_length;
	if status_branch.bit_count = 0 then do;		/* is it a directory?			*/
	     node.T = Tdirectory;			/*  yes, it is.				*/
	     node.Svalid = Svalid_directory;
	     substr (node.Smode, 1, 1) = substr (status_branch.mode, 2, 1);
	     substr (node.Smode, 2, 2) = substr (status_branch.mode, 4, 2);
						/* map "xsxma" into "sma".			*/
	     node.rb = status_branch.ring_brackets;
	     if Sc.acl then do;			/* get acl of directory.			*/
		call get_dir_acl (dir, ent);		/*   This call automatically chains ACL to node.	*/
		Svalid.acl = "1"b;
		end;
	     if Sc.iacl then do;			/* get initial ACLs associated with directory.	*/
		call get_iacls (dir, ent);		/*   This call automatically chains IACLs to node.*/
		Svalid.iacl = "1"b;
		end;
	     end;
	else do;					/* is it an MSF?				*/
	     node.T = Tmsf;				/* yes, it is.				*/
	     node.Svalid = Svalid_msf;
	     substr (node.Smode, 1, 1) = substr (status_branch.mode, 2, 1);
	     substr (node.Smode, 2, 1) = "0"b;		/* map "xsxmx" dir mode into "rxw" seg mode.	*/
	     substr (node.Smode, 3, 1) = substr (status_branch.mode, 4, 1);
	     node.rb(1) = status_branch.ring_brackets(1);
	     node.rb(2) = status_branch.ring_brackets(2);
	     node.rb(3) = status_branch.ring_brackets(2); /* map dir rb's into seg rb's.		*/
	     node.msf_indicator = status_branch.bit_count;
	     if dir = ">" then
		msf_dir = dir || ent;
	     else msf_dir = dir || ">" || ent;
	     do i = 0  to  node.msf_indicator - 1;	/* get aggregate records_used, current_length,	*/
		char32 = cv_num(i);			/*  and bit_count for MSF dir and components.	*/
		call hcs_$status_long (msf_dir, char32, 1, addr(msf_comp), null, code);
		if code = 0 then do;
		     node.records_used = node.records_used + msf_comp.records_used;
		     node.current_length = node.current_length + msf_comp.current_length;
		     node.bit_count = node.bit_count + msf_comp.bit_count;
		     end;
		end;
	     if Sc.acl then do;			/* get acl of MSF.				*/
		call get_msf_acl (dir, ent);		/*   This call automatically chains ACL to node.	*/
		Svalid.acl = "1"b;
		end;
	     end;
	if Sc.quota then do;			/* get quota information for MSFs and directories.*/
	     call hcs_$quota_read (dir||">"||ent, node.segment.quota, node.segment.trp,
		node.segment.dttrp, node.segment.Ninf_quota,
		Nterminal_account, node.segment.quota_used, code);
	     if code ^= 0 then go to error;
	     if Nterminal_account > 0 then node.Sterminal_account = "1"b;
	     call hcs_$dir_quota_read (dir||">"||ent, node.directory.quota, node.directory.trp,
		node.directory.dttrp, node.directory.Ninf_quota,
		Nterminal_account, node.directory.quota_used, code);
	     if code ^= 0 then go to error;
	     if Nterminal_account > 0 then node.Sterminal_account_dir = "1"b;
	     Svalid.quota = "1"b;
	     end;

fill_node:					/* fill in node values from entry status.	*/
	node.Scopy = status_branch.copy_switch;
	node.Stpd = status_branch.tpd_switch;		/* NEED TO ADD SUPPORT FOR OTHER SWITCHES.	*/
	call hcs_$get_safety_sw (dir, ent, node.Ssafety, code);
	node.unique_id = status_branch.uid;
	node.lvid = status_branch.lvid;
	node.dtem = status_branch.dtem;
	node.dtd = status_branch.dtd;
	node.dtm = status_branch.dtcm;
	node.dtu = status_branch.dtu;
	if Sc.all_status then do;			/* get additional information about branches.	*/
	     sfb.version = status_for_backup_version_2;
	     call hcs_$status_for_backup (dir, ent, addr(sfb), code);
	     if code ^= 0 then go to error;
	     node.Smaster_dir = sfb.master_dir;
	     node.Saim_security_oos = sfb.security_oosw;
	     node.Saim_audit = sfb.audit_flag;
	     node.Saim_multiple_class = sfb.multiple_class;
	     i = min (32, 33-verify(reverse(sfb.author)," "));
	     node.author = substr(sfb.author,1,i);
	     node.access_class = sfb.access_class;
	     i = min (32, 33-verify(reverse(sfb.bc_author), " "));
	     node.bit_count_author = substr(sfb.bc_author,1,i);
	     node.entry_bound = binary (sfb.entrypt_bound,14);
	     node.pvid = sfb.pvid;
	     node.Svalid = node.Svalid | Svalid_added_status;
	     if ^sfb.entrypt then do;
		node.entry_bound = 0;
		Svalid.entry_bound = "0"b;
		end;
	     end;
	Dnames.Pnext = node.PD;			/* make name descriptor first in the chain of	*/
	node.PD = PDnames;				/*   descriptors off node.  It's referenced most.	*/
	node.Sreq = node.Svalid & Srequirements;

	end status_long;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


terminate_archive:	procedure;			/* This internal procedure terminates an archive	*/
						/* if one has been initiated.			*/
     dcl	code			fixed bin(35);	/* a dummy status code.			*/

	if Parch ^= null then do;
	     call hcs_$terminate_noname (Parch, code);
	     Parch = null;
	     end;

	end terminate_archive;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


test_archive:	procedure (bit_count)		/* This internal procedure determines if a segment*/
		returns (bit(1) aligned);		/* is an archive.				*/
     dcl	bit_count			fixed bin(35);

	if bit_count >= 900 then
	     if arch.header_begin = archive_data_$header_begin then
		if arch.header_end = archive_data_$header_end then
		     return ("1"b);
		else;
	    else if arch.header_begin = archive_data_$ident then
		return ("1"b);
	return ("0"b);

	end test_archive;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


test_ascii:	procedure (Pseg, bit_count, Sascii);	/* This internal procedure checks the contents of	*/
						/* a segment to see if it is completely ascii	*/
     dcl	Pseg			ptr,		/* ptr to base of segment.(In)		*/
	bit_count			fixed bin(35),	/* segment's bit count.(In)			*/
	Sascii			bit(1) aligned;	/* on, if ascii segment. (Out)		*/
     dcl	Inon_ascii		fixed bin(21);	/* index of first non-ascii character of segment.	*/

	if bit_count = 0 then go to not_ascii;
	if mod (bit_count, 9) ^= 0 then do;		/* segment can't contain chars if bit count bad.	*/
not_ascii:     Sascii = "0"b;
	     return;
	     end;
	Pstring_ = Pseg;				/* overlay segment with character string.	*/
	Lstring_ = divide (bit_count, 9, 24, 0);	/* compute character length of segment.		*/
	Inon_ascii = find_char_$first_in_table (string_, find_char_$not_ascii_table);
						/* search for a non-ascii character in the string.*/
	if Inon_ascii = 0 then			/* if none found, its an ascii segment.		*/
	     Sascii = "1"b;
	else Sascii = "0"b;

	end test_ascii;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


test_segment:	procedure (dir, ent, flags);		/* This internal procedure examines a segment to	*/
						/* determine if it is an archive or an object 	*/
						/* segment.				*/
     dcl (dir, ent)			char(*),		/* dir/ent of segment to be tested.		*/
	1 flags			aligned,
	  2 archive		bit(1),		/* segment is an archive.			*/
	  2 object_seg		bit(1),		/* segment is an object segment.		*/
	  2 ascii			bit(1);		/* segment is composed only of ascii characters.	*/

	flags.archive = "0"b;			/* initialize output flags.			*/
	flags.object_seg = "0"b;
	flags.ascii = "1"b;				/* assume segment is ascii until check made.	*/
	if node.rb(2) < ring then;			/* if segment is readable from our ring,	*/
	else if ^substr(node.Smode,1,1) then;
	else if node.bit_count <= 0 then; 		/* and it has a non-zero bit count, 		*/
	else if divide(node.bit_count + Lrecord - 1, Lrecord, 35, 0) > node.current_length then;
	else if (Sc.check_archive & node.bit_count >= 900) | Sc.check_ascii | Sc.object_info then do;
						/* if caller requests archive/ascii/object info,	*/
	     call hcs_$initiate (dir, ent, "", 0, 0, Parch, code);
	     if Parch = null then return;		/* initiate the segment.			*/
	     if Sc.check_ascii then			/* check for ascii segments.			*/
		call test_ascii (Parch, node.bit_count, flags.ascii);
	     if Sc.check_archive then			/* check for archives.			*/
		flags.archive = test_archive (node.bit_count);
	     if flags.archive then;
	     else if flags.ascii & Sc.check_ascii then;
	     else if Sc.object_info then		/* check for object segment.			*/
		flags.object_seg = object_seg_ (Parch, node.bit_count);
	     call terminate_archive;			/* terminate the segment.			*/
	     end;

	end test_segment;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


%include lib_node_;

%include archive_component_info;

     dcl	1 archive_component_info_array (n_components)
				aligned like archive_component_info based (archive_component_info_ptr);

%include object_info;

     dcl	1 oi			aligned like object_info;

%include star_structures;

%include status_structures;

     dcl	1 auto_status_branch	aligned like status_branch,
	1 msf_comp		aligned like status_branch;

	end lib_get_tree_;




		    lib_next_name_.pl1              02/15/84  0911.2rew 02/15/84  0819.0       35640



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




lib_next_name_:	procedure (Srequirements, PDnames, Iname, Pstarname)
		returns (char(32));

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This procedure is part of the library maintenance subsystem of tools.  Documentation of*/
	/* the complete subsystem is available in AN-80, Library Maintenance.			*/
	/* This procedure, when given node requirements bits, a pointer to the names descriptor,	*/
	/* a name index, and an array of starnames, returns the next name in the descriptor which	*/
	/* meets the name requirements.  Three cases are considered:			*/
	/*									*/
	/*     1) the first name is required.						*/
	/*     2) names which match one of the starnames are required.			*/
	/*     3) all names are required.						*/
	/*									*/
	/* Any combination of cases is allowed.  If there are no remaining names which meet one	*/
	/* of the requirements, then a null character string is returned.			*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created by:   G. C. Dixon,  May 16, 1975					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

     dcl						/*	Parameters			*/
/*	PDnames			ptr,		/* ptr to a names descriptor. (In)		*/
	Iname			fixed bin;	/* index into name array of next name to be	*/
						/*   checked.  For the first call to process a	*/
						/*   given name descriptor, this should be set to	*/
						/*   0. (In)				*/
						/* index of last name checked.  For subsequent	*/
						/*   calls to process a given name descriptor, 	*/
						/*   this output value should be used as input.	*/
						/*   (Out)				*/

     dcl	blank_name		char(32) aligned int static init ((32)" "),
						/* a blank name or null string.		*/
	code			fixed bin(35),	/* a status code.				*/
	i			fixed bin;	/* a do-group index.			*/

     dcl	addr			builtin;

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


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

 	Iname = Iname + 1;				/* get index of next name.			*/
	if Iname > Dnames.N then			/* name array exhausted?  Return blank name.	*/
	     return (blank_name);
	if S.names then				/* return all names.			*/
	     return (Dnames.names(Iname));
	if S.primary_name then			/* return first name.			*/
	     if Iname = 1 then
		return (Dnames.names(Iname));
	if S.matching_names then do;			/* return next name matching a starname.	*/
	     do Iname = Iname to Dnames.N;		/*   scan thru remaining names.		*/
		do i = 1 to starname.N;		/*     for each name, compare with each starname.	*/
		     go to check (starname.C(i));

check(0):		     if Dnames.names(Iname) = starname.V(i) then
			return (Dnames.names(Iname));
		     go to nomatch;

check(1):		     call match_star_name_ (Dnames.names(Iname), starname.V(i), code);
		     if code = 0 then return (Dnames.names(Iname));
		     go to nomatch;

check(2):		     return (Dnames.names(Iname));

nomatch:		     end;
		end;
	     end;

	return (blank_name);			/* if none of remaining names meet requirements,	*/
						/*   return a blank name (null string).		*/


%include lib_node_;

%include lib_based_args_;

	end lib_next_name_;




		    lib_node_path_.pl1              02/15/84  0911.2rew 02/15/84  0819.1       45675



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e:  lib_node_path_							*/
	/*									*/
	/*      This procedure returns the path name of the entry represented by a library node.	*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/*      dcl  lib_node_path_ entry (ptr, char(168) varying, char(32) varying);		*/
	/*									*/
	/*      call lib_node_path_ (Pnode, directory, entry);				*/
	/*									*/
	/* 1) Pnode	is a pointer to the library node representing the entry whose path	*/
	/*		name is to be returned. (In)					*/
	/* 2) directory	is the directory portion of the path name. (Out)			*/
	/* 3) entry	is the entry portion of the path name. (Out)			*/
	/*									*/
	/*									*/
	/* E__n_t_r_y:  lib_node_path_$absolute						*/
	/*									*/
	/* This entry points returns an absolute pathname, include archive component names.	*/
	/*									*/
	/* U__s_a_g_e:									*/
	/*									*/
	/*      dcl lib_node_path_$absolute (ptr, char(200) varying);			*/
	/*      call lib_node_path_$absolute (Pnode, pathname);				*/
	/*									*/
	/* where:									*/
	/* 1) Pnode	is as above. (In)						*/
	/* 2) pathname	is the absolute pathname. (Out)				*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created:  Aug, 1973 by G. C. Dixon					*/
	/* 1) Modified: Dec, 1980 by G. C. Dixon - add $absolute entry point.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_node_path_:	procedure (APnode, dir, ent);

     dcl	APnode			ptr,		/* ptr to node whose path is to be obtained. (In)	*/
	dir			char(168) varying,	/* directory part of path. (Out)		*/
	ent			char(32) varying;	/* entry part of path. (Out)			*/

     dcl	i			fixed bin,	/* a do-group index.			*/
	path			char(200) varying;	/* path name of the node.			*/

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

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	path = recurse (APnode);			/* get path name of the node.			*/
	
	i = index (path, "::");			/* Look for archive component name in path.	*/
	if i > 0 then do;				/* If one found, treat it as the entryname.	*/
	     dir = substr(path, 1, i-1);
	     ent = substr (path, i+2);
	     end;
	else do;
	     i = length(path) + 1 - index (reverse (path), ">");
	     if i = 1 then				/* special case the root.			*/
		dir = ">";
	     else dir = substr (path, 1, i-1);
	     ent = substr (path, i+1);
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


absolute: entry (APnode) returns (char(200) varying);

	return (recurse (APnode));

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


recurse:	procedure (APnode)				/* This internal procedure constructs the path	*/
	returns	(char(200) varying);		/* name of the node.			*/

     dcl	APnode			ptr;		/* ptr to the node whose path name is desired.	*/

	Pnode = APnode;				/* address the node in question.		*/
	if node.Pparent = null then			/* is this a root node of the tree?		*/
	     go to root_node;			/* if so, then return path name assoc with it.	*/
	else if addr (node.Pparent -> node.Svalid) -> Svalid.link_target then do;
						/* else, does node's parent have a path name	*/
	     Pnode = node.Pparent;			/* assoc with it?  Return that path name.	*/
root_node:     return (link_node.link_target);
	     end;
	else do;					/* otherwise, concatenate parent node's path	*/
						/* with primary name of this node.		*/
	     do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
		end;				/* address the node's name descriptor.		*/
	     if node.T = Tarchive_comp then
		return (recurse (node.Pparent) || "::" || rtrim (Dnames.names(1)));
	     else return (recurse (node.Pparent) || ">" || rtrim (Dnames.names(1)));

	     end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_node_;

	end recurse;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	end lib_node_path_;




		    lib_output_node_.pl1            02/15/84  0911.2rew 02/15/84  0819.1      511011



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


lib_output_node_:	procedure;

     dcl						/*	parameters			*/
	ASrequirements		bit(72) aligned,	/* requirements bits determine output fields.	*/
	level			fixed bin(35),	/* indentation level at which node is to be	*/
						/* printed in the listing. (In)		*/
	Inode			fixed bin,	/* number of this node in the node list. (In)	*/
	Pprev_parent		ptr,		/* ptr to parent node of previous node which 	*/
						/*   was output. (In)			*/
	name			char(32),		/* name to be used in the cross reference	*/
						/* entry. (In)				*/
	path			char(168) varying;	/* path name to be used in the cross reference	*/
						/* entry. (In)				*/

     dcl	Iaccess_string (8)		fixed bin,	/* starting indices of 50-char chunks of access	*/
	Iacl			fixed bin,	/* number of ACL entries which have been output.	*/
						/*   string.				*/
	Idir_iacl			fixed bin,	/* number of directory IACLe output.		*/
	Iiacl			fixed bin,	/* number of segment   IACLe output.		*/
	Iname			fixed bin,	/* number of names which have been output.	*/
	Laccess_string		fixed bin,	/* length of non-blank portion of access string.	*/
	Lacl			fixed bin,	/* length of ACL we are outputting.		*/
	Lname			fixed bin,	/* length of the name field in the output, 	*/
	Llevel			fixed bin,	/* length of level field (in characters).	*/
						/* adjusted for indentation level.		*/
	Nindent			fixed bin,	/* number of spaces that names at this level are	*/
						/* to be indented.				*/
	Sfield_blank		bit(1) aligned init ("0"b),
						/* on if all node fields which can be put in 	*/
						/* right-hand column have been output.		*/
	Scleanup			bit(1) aligned init ("0"b),
						/* on if entered at the $cleanup entry point.	*/
	Sinfo			bit(1) aligned init ("0"b),
						/* on if output to go to user's terminal.	*/
	Snames_first		bit(1) aligned init ("0"b),
						/* on if all names to be output first.		*/
	1 Squota			aligned,		/* switches dealing with output of quota info.	*/
	  2 master_dir		bit(1) unal,	/*   on if master directory to be output.	*/ 
	 (2 quota,				/*   on if quota to be output.		*/
	  2 quota_used,				/*   on if quota used to be output.		*/
	  2 terminal_account,			/*   on if terminal account switch to be output.	*/
	  2 Ninf,					/*   on if number of inf directories with quota...*/
	  2 trp,					/*   on if time/record product to be output.	*/
	  2 dttrp)		bit(1) unal,	/*   on if date-time time/record product to be out*/
	Stpd			bit(1) aligned,	/* on if transparent paging dev switch  output	*/

	access_string		char(300),	/* character representation of an access class.	*/
	aim			char(100) varying,	/* character representation of AIM access switches*/
	attributes		char(100) varying,	/* object segment attributes string.		*/
	code			fixed bin(35),	/* a status code.				*/
	dir			char(168) varying,	/* dir part of a node's path name.		*/
	e			fixed bin,	/* entry point indicator for out_ch proc.	*/
	ent			char(32) varying,	/* entry part of a node's path name.		*/
	field			char(108),	/* character string output in right-hand column.	*/
	flag			char(1) aligned,	/* library_cleanup entry deletion flag.		*/
	i			fixed bin,	/* a string index.				*/
	iacc			fixed bin,	/* do-group index used in processing access string*/
	iacle			char(104),	/* character string containing IACL entries.	*/
	level_suppressed		bit(1) aligned,	/* on if no level field to be put into output line*/
	long			char(100),	/* an error message character string.		*/
	lvname			char(32),		/* a logical volume name.			*/
	lv_name			char(32) varying,	/* lvname without trailing blanks.		*/
	mode			char(4),		/* a mode character string.			*/
	pvname			char(32),		/* a physical volume name.			*/
	pv_name			char(32) varying,	/* pvname without trailing blanks.		*/
	rbs			char(12) varying,	/* a ring bracket character string.		*/
	saved_Iname		fixed bin,	/* save value of Iname across a test.		*/
	short			char(8),		/* an abbreviated error message char string.	*/
	type			char(20);		/* a character node type.			*/

     dcl (addr, binary, dimension, index, length, max, min, null, search, string, substr, reverse, verify)
				builtin;

     dcl						/*	entries				*/
	convert_authorization_$to_string_short entry (bit(72) aligned, char(*), fixed bin(35)),
	convert_binary_integer_$long_octal_string
				entry (fixed bin(71)) returns (char(25) varying),
	convert_binary_integer_$octal_string
				entry (fixed bin(35)) returns (char(13) varying),
	convert_status_code_	entry (fixed bin(35), char(8), char(100)),
         (cv_acl			variable,
	cv_acl_,
	cv_dir_acl_)		entry (ptr, fixed bin, char(*), fixed bin, bit(*)),
	date_time_		entry (fixed bin(71) aligned, char(*) aligned),
	date_time_$fstime		entry (bit(36), char(*) aligned),
	ioa_$ioa_switch		entry options (variable),
	lib_next_name_		entry (bit(72) aligned, ptr, fixed bin, ptr) returns (char(32)),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying),
	mdc_$find_lvname		entry (bit(36), char(*), fixed bin(35)),
	mdc_$find_volname		entry (bit(36), char(*), char(*), fixed bin(35));

     dcl						/*	static variables			*/
	FT (0:1)			char(5) int static init ("false", "true"),
	1 null_name_descriptor	aligned int static options(constant),
						/* a fake name descriptor which has no names.	*/
	  2 length		fixed bin(17) unal init (5),
	  2 version		fixed bin(17) unal init (1),
	  2 T			fixed bin init (1),
	  2 Pnext			ptr init (null),
	  2 N			fixed bin init (0),	/* no names in name array.			*/
	1 null_user_descriptor	aligned int static options(constant),
						/* a fake user descriptor which has no info.	*/
	  2 length		fixed bin(17) unal init (5),
	  2 version		fixed bin(17) unal init (1),
	  2 T			fixed bin init (6),
	  2 Pnext			ptr init (null),
	  2 L			fixed bin init (0),	/* no user information.			*/
	status_data_$dir_mode (0:7)	char(4) varying aligned ext static,
						/* array which maps directory mode into a 	*/
						/* printable string.			*/
	status_data_$mode (0:7)	char(4) varying aligned ext static,
						/* array which maps segment/msf/archive mode into	*/
						/* a printable string.			*/
	sys_info$max_seg_size	fixed bin(35) ext static;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


cleanup:	entry	(Pfcb, Pnode, ASrequirements, level, Pstarname, Inode, Pprev_parent);

	Scleanup = "1"b;

info:	entry	(Pfcb, Pnode, ASrequirements, level, Pstarname);

	Sinfo = "1"b;				/* output directed to user's terminal.		*/

map:	entry	(Pfcb, Pnode, ASrequirements, level, Pstarname);

print:	entry	(Pfcb, Pnode, ASrequirements, level, Pstarname);
						/* format for printing on the online printer.	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SET UP REQUIREMENTS BITS WHICH WILL DRIVE OUTPUT OF THE VARIOUS FIELDS:		*/
	/* 1) And requirements bits from node with those in our argument list; put result in our	*/
	/*    bit string we can overlay and modify as we like without harm.			*/
	/* 2) Turn off selected output bits to suppress "standard" data (zero bit count, bit	*/
	/*    count author = author, etc).						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Srequirements = node.Sreq & ASrequirements;	/* copy req bits to overlay with structure.	*/

	if S.dtc | S.compiler_name | S.compiler_version | S.compiler_options | S.object_info then
		  				/* Don't tell user an object segment isn't	*/
	     S.not_ascii = "0"b;			/*   printable.				*/
	if S.copy then				/* if user wants to know about the copy switch,	*/
	     S.copy = node.Scopy;			/* but it is not on, then don't mention it.	*/
	if S.safety then				/* do same for safety switch setting.		*/
	     S.safety = node.Ssafety;
	if S.records_used then			/* if user wants to know about records used and	*/
	     if S.current_length then			/* about current length, and if these two values	*/
		if node.records_used = node.current_length then
		     S.records_used = "0"b;		/* are equal, then don't mention records used.	*/
	if S.max_length then			/* output max length only if different from	*/
	     if node.max_length = sys_info$max_seg_size then
		S.max_length = "0"b;		/*  the maximum segment size.			*/
	if S.quota then do;				/* Set output switches for quota elements.	*/
	     string(Squota) = ""b;
	     Squota.master_dir = node.Smaster_dir;
	     if node.segment.quota_used ^= 0 | node.directory.quota_used ^= 0 then Squota.quota_used = "1"b;
	     if node.segment.quota ^= 0 | node.directory.quota ^= 0 then do;
		Squota.quota = "1"b;
		Squota.terminal_account = node.Sterminal_account | node.Sterminal_account_dir;
		if node.segment.Ninf_quota ^= 0 | node.directory.Ninf_quota ^= 0 then Squota.Ninf = "1"b;
		Squota.trp = "1"b;
		Squota.dttrp = "1"b;
		end;
	     end;
	else string(Squota) = "0"b;
	if S.bit_count_author then			/* suppress bit count author if same as author.	*/
	     if S.author then
		if node.bit_count_author = node.author then
		     S.bit_count_author = "0"b;
	if S.aim then				/* suppress AIM switch settings if not on.	*/
	     S.aim = node.Saim_security_oos | node.Saim_audit | node.Saim_multiple_class;
	if S.lvid then				/* suppress TPD switch if not on.		*/
	     Stpd = node.Stpd;
	else Stpd = "0"b;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ADDRESS DESCRIPTORS FOR VARIABLE-LENGTH or OPTIONAL INFORMATION CHAINED OFF THE NODE.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Svalid.names then			/* access the name descriptor, if it exists.	*/
	     do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
		end;
	else
	     PDnames = addr (null_name_descriptor);	/* otherwise, fake a null name descriptor.	*/
	if S.dtc | S.compiler_name | S.compiler_version | S.compiler_options | S.object_info then
						/* address object info descriptor, if need be.	*/
	     do PDobj = node.PD repeat Dobj.Pnext while (Dobj.T ^= Tobj);
		end;
	if S.root_search_proc then			/* address the search_proc info descriptor.	*/
	     do PDsearch_proc = node.PD repeat Dsearch_proc.Pnext while (Dsearch_proc.T ^= Tsearch_proc);
		end;
	if S.user then				/* address user info descriptor, if need be.	*/
	     do PDuser = node.PD repeat Duser.Pnext while (Duser.T ^= Tuser);
		end;
	if S.kids_error then			/* address node array descriptor, if needed.	*/
	     do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes);
		end;
	if S.acl then do;				/* address ACL descriptor.			*/
	     if node.T = Tdirectory then do;
		do PDdir_acl = node.PD repeat Ddir_acl.Pnext while (Ddir_acl.T ^= Tdir_acl);
		     end;
		PDacl = PDdir_acl;			/* cheat by treating directory ACL descriptor	*/
		cv_acl = cv_dir_acl_;		/*   as segment ACL descriptor, and letting the	*/
		end;				/*   conversion routine worry about differences.	*/
	     else do;
		do PDacl = node.PD repeat Dacl.Pnext while (Dacl.T ^= Tacl);
		     end;
		cv_acl = cv_acl_;
		end;
	     end;
	if S.iacl then do;				/* address segment/directory IACL descriptors.	*/
	     do PDiacl = node.PD repeat Diacl.Pnext while (Diacl.T ^= Tiacl);
		end;
	     do PDdir_iacl = node.PD repeat Ddir_iacl.Pnext while (Ddir_iacl.T ^= Tdir_iacl);
		end;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* DO COMPLICATED FIELD CONVERSIONS BEFORE STARTING THE OUTPUT.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.mode then
	     if node.T = Tdirectory then
		mode = status_data_$dir_mode (binary (node.Smode, 3));
	     else
		mode = status_data_$mode (binary (node.Smode, 3));
	if S.rb then do;
	     rbs = cv_dec(binary(node.rb(1), 35)) || ", ";
	     rbs = rbs || cv_dec(binary(node.rb(2), 35));
	     if node.T ^= Tdirectory then do;
		rbs = rbs || ", ";
		rbs = rbs || cv_dec(binary(node.rb(3), 35));
		end;
	     end;
	if S.access_class then do;
		call convert_authorization_$to_string_short (node.access_class, access_string, code);
		if code ^= 0 then do;
bad_access_class:        call convert_status_code_ (code, short, long);
		     access_string = "Error -  " || long;
		     Laccess_string = length(access_string) - verify (reverse (access_string), " ") + 1;
		     end;
		if access_string = "" then S.access_class = "0"b;
		else do;
		     Laccess_string = index(access_string," ");
split_access_class:	     Iaccess_string(1) = 1;
		     do iacc = 1 to dimension(Iaccess_string,1)-1;
			if Iaccess_string(iacc) > Laccess_string then
			     Iaccess_string(iacc+1) = Laccess_string+1;
			else if Laccess_string - Iaccess_string(iacc) + 1 <= 50 then
			     Iaccess_string(iacc+1) = Laccess_string+1;
			else Iaccess_string(iacc+1) = Iaccess_string(iacc) + 52 -
			     search (reverse (substr (access_string, Iaccess_string(iacc), 51)), " ,");
			end;
		     end;
	     end;
	if S.aim then do;
	     aim = "";
	     if node.Saim_audit then aim = "audit";
	     if node.Saim_multiple_class then do;
		if length(aim) ^= 0 then aim = aim || ", ";
		aim = aim || "multiple-class";
		end;
	     if node.Saim_security_oos then do;
		if length(aim) ^= 0 then aim = aim || ", ";
		aim = aim || "out-of-service";
		end;
	     end;

	if S.object_info then do;
	     attributes = "";
	     if Dobj.info.format.bound 	then attributes = attributes || "bound object";
	     if Dobj.info.format.old_format 	then do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "old format";
		end;
	     if Dobj.info.format.standard 	then;
	     else do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "non-standard format";
		end;
	     if Dobj.info.format.procedure	then;
	     else do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "data";
		end;
	     if Dobj.info.format.relocatable 	then;
	     else do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "non-relocatable";
		end;
	     if Dobj.info.format.gate 	then do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "gate (" ||
		     convert_binary_integer_$octal_string (Dobj.info.entry_bound) || ")";
		end;
	     if Dobj.info.format.separate_static then do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "separate static";
		end;
	     if Dobj.info.format.links_in_text	then do;
		if length (attributes) > 0 then attributes = attributes || ", ";
		attributes = attributes || "links in text";
		end;
	     if length (attributes) = 0 then attributes = "standard object";
	     end;
	if S.pvid then do;
	     S.pvid = "0"b;				/* NEVER OUTPUT THE PVNAME!			*/
	     call mdc_$find_volname (node.pvid, pvname, lvname, 0);
	     pv_name = substr(pvname,1, length(pvname) + 1 - verify(reverse(pvname)," "));
	     lv_name = substr(lvname,1, length(lvname) + 1 - verify(reverse(lvname)," "));
	     end;
	else if S.lvid then do;
	     call mdc_$find_lvname (node.lvid, lvname, 0);
	     lv_name = substr(lvname,1, length(lvname) + 1 - verify(reverse(lvname)," "));
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* OUTPUT THE LINES DESCRIBING THIS NODE WHICH ARE REQUIRED AND HAVE NOT BEEN SUPPRESSED.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call set_field_widths;			/* set length of level, indentation, name fields	*/
	if S.new_line then				/* <NL> required at start of entry?		*/
	     call out_nl;				/* put one into output.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* For library_cleanup, output directory pathname, followed by a list of nodes, with list	*/
	/* entries numbered consecutively.  Flag entries to be deleted with *.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Scleanup then do;
	     if S.pathname then do;
		S.pathname = "0"b;
		if Pprev_parent ^= null then
		     if node.Pparent = Pprev_parent then;
		     else do;
CLEANUP_PATH:		call lib_node_path_ (Pnode, dir, ent);
			if node.Pparent = null then
			     if dir = ">" then
				dir = dir || ent;
			     else dir = dir || ">" || ent;
			call out_pn (dir);
			if S.new_line then
			     call out_nl;
			end;
		else go to CLEANUP_PATH;
		end;
	     if Svalid.delete then
		flag = "*";
	     else flag = " ";
	     if S.type then do;
		S.type = "0"b;
		type = brief_node_type (node.T);
		end;
	     else type = "";
	     call out_cln (flag, Inode, type);
	     end;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* If short terminal length requires that all names be output first, followed by other	*/
	/* fields, output the names, then make the <name> field zero length in lines which follow.*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Snames_first then do;
	     ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
	     do while (ent ^= "");
		call out_name (ent, "", "");
		ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
		end;
	     Lname = 0;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:<lv> <name>	<type>          in: <path-name>			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Sinfo then do;				/* Special case short terminals.		*/
	     if S.type then do;
		type = brief_node_type(node.T);
		call out_ch2 ("              type:", type);
		end;
	     if S.pathname & (level <= 1) then do;
		call lib_node_path_ (Pnode, dir, ent);
		if node.Pparent = null then do;
		     type = "              path:";
		     if dir = ">" then
			dir = dir || ent;
		     else dir = dir || ">" || ent;
		     end;
		else type = "              path:";
		saved_Iname = Iname;
		ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
		Iname = saved_Iname;
		if ent = "" then do;
		     if length (dir) <= 16 then do;
			dir = dir || (19)" ";
			dir = substr(dir,1,19);
			dir = dir || get_field();
			i = length(dir) + 1 - verify(reverse(dir), " ");
			dir = substr(dir,1,i);
			end;
		     else do;
			Lname = Lname - 40;
			Sinfo = "0"b;
			end;
		     call out_vc2 (type, dir);
		     S.pathname = "0"b;
		     end;
		else if Nindent+Llevel+Lname+21+length(dir) <= fcb.line_length then do;
		     call out_vc2 (type, dir);
		     S.pathname = "0"b;
		     end;
		end;
	      end;


	else if S.type | S.pathname then do;
	     if S.type then
		type = brief_node_type(node.T);
	     else
		type = "";
	     if level > 1 then do;
		dir = (19)" " || get_field();
		i = length(dir) + 1 - verify(reverse(dir), " ");
		dir = substr(dir,1,i);
		end;
	     else if S.pathname then do;
		call lib_node_path_ (Pnode, dir, ent);
		if node.Pparent = null then do;	/* special case a library root node.		*/
		     substr (type, 15, 5) = "path:";
		     if dir = ">" then
			dir = dir || ent;
		     else dir = dir || ">" || ent;
		     end;
		else substr (type, 17, 3) = "in:";
		if length (dir) <= 16 then do;
		     dir = dir || (19)" ";
		     dir = substr(dir,1,19);
		     dir = dir || get_field();
		     i = length(dir) + 1 - verify(reverse(dir), " ");
		     dir = substr(dir,1,i);
		     end;
		end;
	     else
		dir = "";
	     call out_vc2 (type, dir);
	     S.pathname = "0"b;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	contents modified:	<date>		<field>		*/
	/*	LINE:	<name>	entry modified:	<date>		<field>		*/
	/*	LINE:	<name>	date used:	<date>		<field>		*/
	/*	LINE:	<name>	date dumped:	<date>		<field>		*/
	/*	LINE:	<name>	date compiled:	<date>		<field>		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if node.T = Tarchive_comp then if S.dtem then do;
	     S.dtem = "0"b;
	     call out_ch3 (" component updated:", cv_date(node.dtem), get_field());
	     end;
	if S.dtm then do;
	     S.dtm = "0"b;
	     call out_ch3 (" contents modified:", cv_date(node.dtm), get_field());
	     end;
	if S.dtem then do;
	     S.dtem = "0"b;
	     call out_ch3 ("    entry modified:", cv_date(node.dtem), get_field());
	     end;
	if S.dtu then do;
	     S.dtu = "0"b;
	     call out_ch3 ("         date used:", cv_date(node.dtu), get_field());
	     end;
	if S.dtd then do;
	     S.dtd = "0"b;
	     call out_ch3 ("       date dumped:", cv_date(node.dtd), get_field());
	     end;
	if S.dtc then do;
	     S.dtc = "0"b;
	     if Dobj.info.format.bound then
		call out_ch3 ("        date bound:", cv_long_date(Dobj.info.compile_time), get_field());
	     else call out_ch3 ("     date compiled:", cv_long_date(Dobj.info.compile_time), get_field());
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	msf indicator:	<decimal number>	<field>		*/
	/*	LINE:	<name>	bit count:	<decimal number>	<field>		*/
	/*	LINE:	<name>	length:		<decimal number>	<field>		*/
	/*	LINE:	<name>	records used:	<decimal number>	<field>		*/
	/*	LINE:	<name>	max length:	<decimal number>	<field>		*/
	/*	LINE:	<name>	offset:		<octal number>	<field>		*/
	/* 	LINE:	<name>	entry bound:	<octal number>	<field>		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.msf_indicator then do;
	     S.msf_indicator = "0"b;
	     call out_ch3 ("     msf indicator:", cv_dec(node.msf_indicator), get_field());
	     end;
	if S.bit_count then do;
	     S.bit_count = "0"b;
	     call out_ch3 ("         bit count:", cv_dec(node.bit_count), get_field());
	     end;
	if S.current_length then do;
	     S.current_length = "0"b;
	     call out_ch3 ("            length:", cv_dec(node.current_length), get_field());
	     end;
	if S.records_used then do;
	     S.records_used = "0"b;
	     call out_ch3 ("      records used:", cv_dec(node.records_used), get_field());
	     end;
	if S.max_length then do;
	     S.max_length = "0"b;
	     call out_ch3 ("        max length:", cv_dec(node.max_length), get_field());
	     end;
	if S.offset then do;
	     S.offset = "0"b;
	     call out_ch3 ("            offset:", convert_binary_integer_$octal_string(node.offset),
		get_field());
	     end;
	if S.entry_bound then do;
	     S.entry_bound = "0"b;
	     call out_ch3 ("       entry bound:", convert_binary_integer_$octal_string(node.entry_bound),
		get_field());
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	author:		<author>		<field>		*/
	/*	LINE:	<name>	bit count author:	<bit count author>	<field>		*/
	/*	LINE:	<name>	logical volume:	<lvname>		<field>		*/
	/*	LINE:	<name>	physical volume:	<pvname>		<field>		*/
	/*	LINE:	<name>	never on paging dv:	true		<field>		*/
	/*	LINE:	<name>	master  directory:	true		<field>		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.author then if length(node.author) <= 16 then do;
	     S.author = "0"b;
	     call out_vc3 ("            author:", node.author, get_field());
	     end;
	if S.bit_count_author then if length(node.bit_count_author) <= 16 then do;
	     S.bit_count_author = "0"b;
	     call out_vc3 ("  bit count author:", node.bit_count_author, get_field());
	     end;
	if S.lvid then if length(lv_name) <= 16 then do;
	     S.lvid = "0"b;
	     if node.T = Tdirectory | node.T = Tmsf then
		call out_vc3 ("  sons log. volume:", lv_name, get_field());
	     else call out_vc3 ("    logical volume:", lv_name, get_field());
	     end;
	if S.pvid then if length (pv_name) <= 16 then do;
	     S.pvid = "0"b;
	     call out_vc3 ("   physical volume:", pv_name, get_field());
	     end;
	if Stpd then do;
	     Stpd = "0"b;
	     call out_ch3 ("never on paging dv:", "true", get_field());
	     end;
	if Squota.master_dir then do;
	     Squota.master_dir = "0"b;
	     call out_ch3 ("  master directory:", "true", get_field());
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	access class:	<class string>	<field>		*/
	/*	LINE:	<name>	AIM attributes:	<aim attributes>	<field>		*/
	/*	LINE:	<name>	mode:		<mode string>	<field>		*/
	/*	LINE:	<name>	ring brackets:	<ring bracket>	<field>		*/
	/*	LINE:	<name>	safety switch:	on		<field>		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.access_class then if Laccess_string <= 16 then do;
	     S.access_class = "0"b;
	     call out_ch3 ("      access class:", substr(access_string,1,Laccess_string), get_field());
	     end;
	if S.aim then if length(aim) <= 16 then do;
	     S.aim = "0"b;
	     call out_vc3 ("    AIM attributes:", aim, get_field());
	     end;
	if S.mode then do;
	     S.mode = "0"b;
	     call out_ch3 ("              mode:", mode, get_field());
	     end;
	if S.rb then do;
	     S.rb = "0"b;
	     call out_vc3 ("     ring brackets:", rbs, get_field());
	     end;
	if S.safety then do;
	     S.safety = "0"b;
	     call out_ch3 ("     safety switch:", "on", get_field());
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	copy switch:	on		<field>		*/
	/*	LINE:	<name>	unique id:	<octal number>	<field>		*/
	/*	LINE:	<name>	<user label>:	<user info>	<field>		*/
	/*	LINE:	<name>	object attributes:	<object attributes>	<field>		*/
	/*	LINE:	<name>	printable:	<yes-or-no>	<field>		*/
	/*	LINE:	<name>	compiler:		<compiler-name>	<field>		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.copy then do;
	     S.copy = "0"b;
	     call out_ch3 ("       copy switch:", "on", get_field());
	     end;
	if S.unique_id then do;
	     S.unique_id = "0"b;
	     call out_ch3 ("         unique id:",
		convert_binary_integer_$octal_string(binary (node.unique_id, 36)), get_field());
	     end;
	if S.user then if Duser.L <= 16 then do;
	     S.user = "0"b;
	     call out_ch3 (Duser.label || ":", Duser.info, get_field());
	     end;
	if S.object_info then if length (attributes) <= 16 then do;
	     S.object_info = "0"b;
	     call out_vc3 (" object attributes:", attributes, get_field());
	     end;
	if S.not_ascii then do;
	     S.not_ascii = "0"b;
	     call out_ch3 ("         printable:", "no", get_field());
	     end;
	if S.compiler_name then do;
	     S.compiler_name = "0"b;
	     call out_ch3 ("          compiler:", Dobj.info.compiler, get_field());
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FINISH OUTPUTTING SHORT DATA BEFORE BEGINNING LONG DATA.				*/
	/* 1) Output remaining ACL entries, unless on short terminal or in 1-datum per line mode.	*/
	/* 2) Output remaining names, unless on short terminal.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.acl then
	     if Snames_first | Sinfo then;
	     else do;
		field = get_acl();
		do while (field ^= "");
		     call out_ch3 ("", "", field);
		     field = get_acl();
		     end;
		end;
	if ^Snames_first then if Sinfo then do;		/* For short terminals, print rest of names now.	*/
	     ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
	     do while (ent ^= "");
		call out_name (ent, "", "");
		ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
		end;
	     Lname = Lname - 40;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* OUTPUT ITEMS LONGER THAN A SINGLE COLUMN					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 	LINE:	<name>	quota:		<quota>		<field>		*/
	/*	LINE:	<name>	quota used:	<quota used>	<field>		*/
	/*	LINE:	<name>	time * records(TR):	<time/record prod.>	<field>		*/
	/*	LINE:	<name>	date TR modified:	<date trp modified>	<field>		*/
	/*	LINE:	<name>	terminal account:	true		<field>		*/
	/*	LINE:	<name>	inf. term. accts.:	<number of dirs>	<field>		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Squota.quota then do;
	     Squota.quota = "0"b;
	     call out_ch3 ("             quota:",     cv_dec(node.segment.quota),
		         "         dir quota:  " || cv_dec(node.directory.quota));
	     end;
	if Squota.quota_used then do;
	     Squota.quota_used = "0"b;
	     call out_ch3 ("        quota used:",     cv_dec(node.segment.quota_used),
		         "    dir quota used:  " || cv_dec(node.directory.quota_used));
	     end;
	if Squota.trp then if length(cv_long_dec(node.segment.trp)) <= 16 then do;
	     Squota.trp = "0"b;
	     call out_ch3 ("time * records(TR):",     cv_long_dec(node.segment.trp), 
		         "            dir TR:  " || cv_long_dec(node.directory.trp));
	     end;
	if Squota.dttrp then do;
	     Squota.dttrp = "0"b;
	     call out_ch3 ("       TR modified:",     cv_date(node.segment.dttrp),
		         "   dir TR modified:  " || cv_date(node.directory.dttrp));
	     end;
	if Squota.terminal_account then do;
	     Squota.terminal_account = "0"b;
	     call out_ch3 (" terminal acct(TA):",     FT(binary(node.Sterminal_account,1)),
		         "            dir TA:  " || FT(binary(node.Sterminal_account_dir,1)));
	     end;
	if Squota.Ninf then do;
	     Squota.Ninf = "0"b;
	     call out_ch3 ("     # inferior TA:",     cv_dec(node.segment.Ninf_quota),
		         " dir # inferior TA:  " || cv_dec(node.directory.Ninf_quota));
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	time * records(TR):	<time/record prod.>	<field>		*/
	/*	LINE:	<name>	           path:	<path>				*/
	/*	LINE:	<name>	author:		<author>				*/
	/*	LINE:	<name>	bit count author:	<bit count author>			*/
	/*	LINE:	<name>	device:		<device name>			*/
	/*	LINE:	<name>	compiler version:	<compiler version string>		*/
	/*	LINE:	<name>	compiler comment:	<compiler comment string>		*/
	/*	LINE:	<name>	search procedure:	<root search proc>			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Squota.trp then do;
	     Squota.trp = "0"b;
	     call out_ch2 ("time * records(TR):", cv_long_dec(node.segment.trp));
	     call out_ch2 ("	  dir TR:", cv_long_dec(node.directory.trp));
	     end;
	if S.pathname then if (level <= 1) then
	     call out_vc2 (type, dir);
	if S.author then do;
	     S.author = "0"b;
	     call out_vc2 ("            author:", node.author);
	     end;
	if S.bit_count_author then do;
	     S.bit_count_author = "0"b;
	     call out_vc2 ("  bit count author:", node.bit_count_author);
	     end;
	if S.lvid then do;
	     S.lvid = "0"b;
	     if node.T = Tdirectory | node.T = Tmsf then
		call out_vc2 ("  sons log. volume:", lv_name);
	     else call out_vc2 ("    logical volume:", lv_name);
	     end;
	if S.pvid then do;
	     S.pvid = "0"b;
	     call out_vc2 ("   physical volume:", pv_name);
	     end;
	if S.compiler_version then
	     if length (Dobj.cversion) > 0 then
		call out_vc2 ("  compiler version:", Dobj.cversion);
	if S.compiler_options then
	     if length (Dobj.comment) > 0 then
		call out_vc2 ("  compiler comment:", Dobj.comment);
	if S.root_search_proc then
	     call out_vc2 ("  search procedure:", Dsearch_proc.search_proc);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	object attributes:	<object attributes>			*/
	/*	LINE:	<name>	<user label>:	<user information>			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.object_info then
	     call out_vc2 (" object attributes:", attributes);
	if S.user then
	     call out_ch2 (Duser.label || ":", Duser.info);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	links to:		<link path name>			*/
	/*	LINE:	<name>	error:		<error message>			*/
	/*	LINE:	<name>	access class:	<class string>			*/
	/*	LINE:	<name>	AIM attributes:	<aim attributes>			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.link_target then
	     call out_vc2 ("          links to:", link_node.link_target);
	if S.kids_error then do;
	     call convert_status_code_ (Dnodes.C, short, long);
	     call out_ch2 ("             error:", long);
	     end;
	if S.access_class then do;
	     S.access_class = "0"b;
	     call out_ch2 ("      access class:",
			substr(access_string, Iaccess_string(1), Iaccess_string(2)-Iaccess_string(1)));
	     do iacc = 2 to dimension(Iaccess_string,1)-1 while (Iaccess_string(iacc) <= Laccess_string);
		call out_ch2 ("",
		     substr(access_string, Iaccess_string(iacc), Iaccess_string(iacc+1)-Iaccess_string(iacc)));
		end;
	     end;
	if S.aim then do;
	     S.aim = "0"b;
	     call out_vc2 ("    AIM attributes:", aim);
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Finish printing any names that haven't been printed yet.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
	do while (ent ^= "");
	     call out_name (ent, "", "");
	     ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* All names guaranteed printed, so we can force short terminal format.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if ^Snames_first & Sinfo then Lname = Lname - 40;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Print ACL if hasn't been printed because of short terminal lengths.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.acl then do;
	     call out_ch2 ("               acl:", substr (get_acl(), 7));
	     field = get_acl();
	     do while (field ^= "");
		call out_ch2 ("", substr(field, 7));
		field = get_acl();
		end;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Print Segment and Directory IACLs.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if S.iacl then do;
	     iacle = get_iacl();
	     if iacle = "" then;
	     else do;
		call out_ch2 ("      segment IACL:", iacle);
		iacle = get_iacl();
		do while (iacle ^= "");
		     call out_ch2 ("", iacle);
		     iacle = get_iacl();
		     end;
		end;
	     iacle = get_dir_iacl();
	     if iacle = "" then;
	     else do;
		call out_ch2 ("    directory IACL:", iacle);
		iacle = get_dir_iacl();
		do while (iacle ^= "");
		     call out_ch2 ("" , iacle);
		     iacle = get_dir_iacl();
		     end;
		end;
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


cross_reference:	entry	(Pfcb, Pnode, ASrequirements, level, name, path);


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	LINE:	<name>	<date>    see:	<parent-path>			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Srequirements = node.Sreq & ASrequirements;	/* copy user-specified requirements to aligned	*/
						/* bit string we can overlay, modifying 	*/
						/* requirements according to which node fields	*/
						/* are valid.				*/
	call set_field_widths;			/* set length of level, indentaiton, name fields.	*/
	if S.new_line then				/* <NL> req'd at start of entry?		*/
	     call out_nl;				/* put one into the output.			*/
	if S.user then				/* address user info descriptor, if need be.	*/
	     do PDuser = node.PD repeat Duser.Pnext while (Duser.T ^= Tuser);
		end;
	else PDuser = addr(null_user_descriptor);
	if S.user & Duser.L <= 14 then		/* if user info available, put it in cross-ref.	*/
	     type = Duser.info;
	else if node.T = Tarchive_comp then		/* for archive component, return dtem		*/
	     if S.dtem then
		type = cv_date (node.dtem);
	     else if S.dtm then			/* or dtm, if dtem not requested.		*/
		type = cv_date(node.dtm);
	     else if S.type then			/* or type, if dates not requested.		*/
		type = brief_node_type (node.T);
	     else type = "";
	else if node.T = Tlink then			/* for link, return dtem			*/
	     if S.dtem then
		type = cv_date (node.dtem);
	     else if S.type then			/* or type, if dtem not requested.		*/
		type = brief_node_type (node.T);
	     else
		type = "";
	else if S.dtm then				/* for everything else, return dtm		*/
	     type = cv_date (node.dtm);
	else if S.type then				/* or type.				*/
	     type = brief_node_type (node.T);
	else
	     type = "";
	substr (type, 15, 5) = " see:";		/* put path header into type string.		*/
	ent = name;
	call out_name (ent, type, path);		/* output the cross-reference entry.		*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


cv_date:	procedure	(date)				/* Internal procedure which converts a file	*/
	returns (char(16));				/* system date into a character string.		*/

     dcl	date			bit(36),		/* date to be converted.			*/
	long_date			fixed bin(71) aligned,
	date_string		char(16) aligned;	/* a date character string.			*/

	call date_time_$fstime (date, date_string);

	return (date_string);

cv_long_date:	entry (long_date)
		returns (char(16));

	call date_time_ (long_date, date_string);

	return (date_string);

	end cv_date;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

cv_dec:	procedure	(number)				/* Internal procedure to convert binary numbers	*/
	returns	(char(13) varying);			/* to decimal character strings.		*/

     dcl	number			fixed bin(35),	/* number to be converted. (In)		*/
	number_string		picture "------------9",
	Ifirst_significant_digit	fixed bin;	/* index of first significant digit in number_st.	*/
						/* form of converted number.			*/

	number_string = number;
	Ifirst_significant_digit = verify (number_string, " ");
	return (substr (number_string, Ifirst_significant_digit));

	end cv_dec;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */



cv_long_dec:	procedure (number)			/* Internal procedure to convert long binary	*/
		returns	(char(23) varying);		/* to decimal character strings.		*/

     dcl	number			fixed bin(71),	/* number to be converted. (In)		*/
	number_string		pic "----------------------9",
	Ifirst_significant_digit	fixed bin;

	number_string = number;
	Ifirst_significant_digit = verify (number_string, " ");
	return (substr (number_string, Ifirst_significant_digit));

	end cv_long_dec;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_acl:		procedure returns (char(106));	/* Internal procedure which returns the next	*/
						/* ACL entry, formatted for printed.		*/

     dcl	field			char(108);	/* temporary in which ACLe is formatted.	*/
	Iacl = Iacl + 1;				/* get index of next ACLe.			*/
	if Iacl > Dacl.N then do;			/* if there are no more ACLe's, return blank field*/
	     S.acl = "0"b;
	     if Iacl = 1 then			/* unless there is an error code.		*/
		if Dacl.C ^= 0 then do;
		     call convert_status_code_ (Dacl.C, short, long);
		     return ("acl:  " || long);
		     end;
	     return ("");
	     end;
	call cv_acl (addr(Dacl.acls), Iacl, field, 0, "100"b);
	if Iacl = 1 then return ("acl:  " || field);
	else return ("      " || field);		/* format/return the ACLe.			*/

	end get_acl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_dir_iacl:	procedure returns(char(109));		/* Internal procedure to format segment IACLs.	*/

     dcl	iacle			char(42),
	i			fixed bin,	/* a do-group index.			*/
	r			pic "9";		/* Ring number.				*/

	Idir_iacl = Idir_iacl + 1;			/* see if IACLs exhausted.			*/
	if Idir_iacl > Ddir_iacl.N then do;		/* if so, return a blank string, unless there	*/
	     if Idir_iacl = 1 then			/*   is a non-zero error code.		*/
		if Ddir_iacl.C ^= 0 then do;
		     call convert_status_code_ (Ddir_iacl.C, short, long);
		     return ("Error -  " || long);
		     end;
	     return ("");
	     end;
	do i = 0 to 7 while ((Ddir_iacl.Iring(i) ^= Idir_iacl) | (Ddir_iacl.Nring(i) = 0));
	     end;					/* see if we are beginning IACL for a ring.	*/
	call cv_dir_acl_ (addr(Ddir_iacl.acls), Idir_iacl, iacle, 0, "100"b);
	if i < 8 then do;				/* if so, return ring number before ACLe.	*/
	     r = i;
	     return (r || ":  " || iacle);
	     end;
	else return ("    " || iacle);

	end get_dir_iacl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_field:	procedure				/* Internal procedure which returns either an	*/
		returns (char(108));		/* ACL entry or another field value.		*/

     dcl	blank_field		char(108) aligned int static init ((108)" "),
	field			char(108) aligned;


	if Snames_first then go to return_blank;	/* library_info:  short terminal, no 3rd column.	*/

	if Sinfo then do;				/* library_info:  longer terminal, move 2nd col.	*/
	     saved_Iname = Iname;			/*    into names field after all names output.	*/
	     ent = lib_next_name_ (Srequirements, PDnames, Iname, Pstarname);
	     Iname = saved_Iname;
	     if ent = "" then do;
		Lname = Lname - 40;			/*    Output 3rd col. under 2nd's previous pos.	*/
		Sinfo = "0"b;
		end;
	     else go to return_blank;
	     end;

	if Sfield_blank then go to return_blank;	/* 3rd column output exhausted.		*/

	if S.acl then do;
	     field = get_acl();
	     go to return;
	     end;
	if S.access_class then if Laccess_string <= 22 then do;
	     S.access_class = "0"b;
	     field = "      access class:  " || access_string;
	     go to return;
	     end;
	if S.aim then if length(aim) <= 22 then do;
	     S.aim = "0"b;
	     field = "    AIM attributes:  " || aim;
	     go to return;
	     end;
	if S.mode then do;
	     S.mode = "0"b;
	     field = "              mode:  " || mode;
	     go to return;
	     end;
	if S.rb then do;
	     S.rb = "0"b;
	     field = "     ring brackets:  " || rbs;
	     go to return;
	     end;
	if S.safety then do;
	     S.safety = "0"b;
	     field = "     safety switch:  on";
	     go to return;
	     end;
	if S.user then if Duser.L <= 22 then do;
	     S.user = "0"b;
	     field = Duser.label || ":  " || Duser.info;
	     go to return;
	     end;
	if S.unique_id then do;
	     S.unique_id = "0"b;
	     field = "         unique id:  " ||
		convert_binary_integer_$long_octal_string((binary(node.unique_id,36)));
	     go to return;
	     end;
	if S.copy then do;
	     S.copy = "0"b;
	     field = "       copy switch:  on";
	     go to return;
	     end;
	if S.lvid then if length(lv_name) <= 22 then do;
	     S.lvid = "0"b;
	     if node.T = Tdirectory | node.T = Tmsf then
		field = "  sons log. volume:  " || lv_name;
	     else field = "    logical volume:  " || lv_name;
	     go to return;
	     end;
	if S.pvid then if length(pv_name) <= 22 then do;
	     S.pvid = "0"b;
	     field = "   physical volume:  " || pv_name;
	     go to return;
	     end;
	if Stpd then do;
	     Stpd = "0"b;
	     field = "never on paging dv:  " || "true";
	     go to return;
	     end;
	if S.author then if length(node.author) <= 22 then do;
	     S.author = "0"b;
	     field = "            author:  " || node.author;
	     go to return;
	     end;
	if S.bit_count_author then if length(node.bit_count_author) <= 22 then do;
	     S.bit_count_author = "0"b;
	     field = "  bit count author:  " || node.bit_count_author;
	     go to return;
	     end;
	if S.msf_indicator then do;
	     S.msf_indicator = "0"b;
	     field = "     msf indicator:  " || cv_dec (node.msf_indicator);
	     go to return;
	     end;
	if S.bit_count then do;
	     S.bit_count = "0"b;
	     field = "         bit count:  " || cv_dec (node.bit_count);
	     go to return;
	     end;
	if S.current_length then do;
	     S.current_length = "0"b;
	     field = "            length:  " || cv_dec (node.current_length);
	     go to return;
	     end;
	if S.records_used then do;
	     S.records_used = "0"b;
	     field = "      records used:  " || cv_dec (node.records_used);
	     go to return;
	     end;
	if S.max_length then do;
	     S.max_length = "0"b;
	     field = "        max length:  " || cv_dec (node.max_length);
	     go to return;
	     end;
	if S.offset then do;
	     S.offset = "0"b;
	     field = "            offset:  " || convert_binary_integer_$octal_string (node.offset);
	     go to return;
	     end;
	if S.entry_bound then do;
	     S.entry_bound = "0"b;
	     field = "       entry bound:  " || convert_binary_integer_$octal_string (node.entry_bound);
	     go to return;
	     end;
	if Squota.master_dir then do;
	     Squota.master_dir = "0"b;
	     field = "  master directory:" || "true";
	     go to return;
	     end;
	if node.T = Tarchive_comp then if S.dtem then do;
	     S.dtem = "0"b;
	     field = " component updated:  " || cv_date(node.dtem);
	     go to return;
	     end;
	if S.dtm then do;
	     S.dtm = "0"b;
	     field = " contents modified:  " || cv_date(node.dtm);
	     go to return;
	     end;
	if S.dtem then do;
	     S.dtem = "0"b;
	     field = "    entry modified:  " || cv_date(node.dtem);
	     go to return;
	     end;
	if S.dtu then do;
	     S.dtu = "0"b;
	     field = "         date used:  " || cv_date(node.dtu);
	     go to return;
	     end;
	if S.dtd then do;
	     S.dtd = "0"b;
	     field = "       date dumped:  " || cv_date(node.dtd);
	     go to return;
	     end;
	if S.dtc then do;
	     S.dtc = "0"b;
	     if Dobj.info.format.bound then
		field = "        date bound:  " || cv_long_date(Dobj.info.compile_time);
	     else field = "     date compiled:  " || cv_long_date(Dobj.info.compile_time);
	     go to return;
	     end;
	if S.compiler_name then do;
	     S.compiler_name = "0"b;
	     field = "          compiler:  " || Dobj.info.compiler;
	     go to return;
	     end;
	if S.object_info then if length (attributes) <= 22 then do;
	     S.object_info = "0"b;
	     field = " object attributes:  " || attributes;
	     go to return;
	     end;
	if S.not_ascii then do;
	     S.not_ascii = "0"b;
	     field = "         printable:  no";
	     go to return;
	     end;

	Sfield_blank = "1"b;
return_blank:
	return (blank_field);

return:	return (field);

	end get_field;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_iacl:		procedure returns(char(109));		/* Internal procedure to format segment IACLs.	*/

     dcl	iacle			char(42),
	i			fixed bin,	/* a do-group index.			*/
	r			pic "9";		/* Ring number.				*/

	Iiacl = Iiacl + 1;				/* see if IACLs exhausted.			*/
	if Iiacl > Diacl.N then do;			/* if so, return a blank string, unless there	*/
	     if Iiacl = 1 then			/*   is a non-zero error code.		*/
		if Diacl.C ^= 0 then do;
		     call convert_status_code_ (Diacl.C, short, long);
		     return ("Error -  " || long);
		     end;
	     return ("");
	     end;
	do i = 0 to 7 while ((Diacl.Iring(i) ^= Iiacl) | (Diacl.Nring(i) = 0));
	     end;					/* see if we are beginning IACL for a ring.	*/
	call cv_acl_ (addr(Diacl.acls), Iiacl, iacle, 0, "100"b);
	if i < 8 then do;				/* if so, return ring number before ACLe.	*/
	     r = i;
	     return (r || ":  " || iacle);
	     end;
	else return ("    " || iacle);

	end get_iacl;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

get_level:	procedure				/* Internal procedure to return the level field	*/
		returns	(char(2));

     dcl	blank_level		char(2) aligned int static init ("  "),
	level_string		char(2);		/* character representation of level.		*/

	if level_suppressed then			/* if no level required, return a blank string.	*/
	     return (blank_level);
	level_suppressed = "1"b;			/* suppress level in lines which follow.	*/
	level_string = cv_dec(level);
	return (level_string);			/* and return the character string number.	*/

	end get_level;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


out_ch2:	procedure	(label, value_ch);
						/* Internal procedure to output a line.		*/
	e = 1;					/* indicate character value.			*/
	go to common;


out_vc2:	entry	(label, value_vc);

	e = 2;					/* indicate varying character string value.	*/
	if length (value_vc) + 71 > fcb.line_length then
	     fcb.line_no = fcb.line_no + 1;
	go to common;


out_ch3:	entry	(label, value_ch, field);

	e = 3;					/* indicate character value and field value.	*/
	go to common;


out_vc3:	entry	(label, value_vc, field);

	e = 4;					/* indicate varying character value & field value.*/
	go to common;


out_name:	entry	(name, label, value_vc);

	e = 5;					/* indicate special name line.		*/
	go to common;


out_nl:	entry;

	e = 6;					/* indicate that a new_line char is to be output.	*/
	go to common;


out_pn:	entry 	(value_vc);			/* indicate that a new pathname to be output.	*/

	e = 7;
	go to common;


out_cln:	entry	(flag, Inode, type);		/* indicate library_cleanup 1st line to be output.*/

	e = 8;

     dcl	Inode			fixed bin,	/* node number.				*/
	field			char(108),	/* field to be placed in line.		*/
	flag			char(1) aligned,	/* deletion flag.				*/
	label			char(*),		/* label for the value field.			*/
	name			char(32) varying,	/* name to be placed in line.			*/
	type			char(20),		/* type of node.				*/
	value_ch			char(*),		/* a character string value.			*/
	value_no			fixed bin(35),	/* a number value.				*/
	value_vc			char(*) varying aligned;
						/* a varying character string value.		*/

     dcl	Lvalue			fixed bin,	/* maximum length of value part of field.	*/
	i			fixed bin;	/* a string index.				*/

common:	if fcb.line_no = fcb.page_text_length then	/* if current page is full, skip to a new page.	*/
	     call fcb.Eend_page();
	fcb.line_no = fcb.line_no + 1;		/* increment number of lines on current page.	*/

	go to out(e);				/* output line.				*/
out(1):	call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21a^a", Llevel, get_level(), Nindent, 
			  Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname), label, value_ch);
	return;

out(2):	if length (value_vc) + Nindent + Lname + Llevel + 21 <= fcb.line_length then
	     call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21a^a", Llevel, get_level(), Nindent, 
		Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname), label, value_vc);
	else do;
	     Lvalue = fcb.line_length - (Nindent + Lname + Llevel + 21);
	     i = Lvalue + 1 - index(reverse(substr(value_vc,1,Lvalue)), " ");
	     call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21a^a", Llevel, get_level(), Nindent,
		Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname),
		label, substr(value_vc,1,i));
	     call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21x^a", Llevel, get_level(), Nindent,
		Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname), substr(value_vc,i+1));
	     end;
	return;

out(3):	call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21a^16a^3x^a", Llevel, get_level(), Nindent, 
			  Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname),
			  label, value_ch, field);
	return;

out(4):	call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21a^16a^3x^a", Llevel, get_level(), Nindent, 
			  Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname),
			  label, value_vc, field);
	return;

out(5):	call ioa_$ioa_switch (fcb.Piocb, "^va^vx^va^21a^a", Llevel, get_level(), Nindent, 
			  Lname, name, label, value_vc);
	return;

out(6):	if fcb.line_no = 2 then			/* if top of page, forget new_line char.	*/
	     fcb.line_no = 1;
	else
	     call ioa_$ioa_switch (fcb.Piocb, "");
	return;

out(7):	call ioa_$ioa_switch (fcb.Piocb, "^/IN ^a:", value_vc);
	return;

out(8):	call ioa_$ioa_switch (fcb.Piocb, "^1a^vd^1x^va^a", flag, Llevel-2, Inode,
			  Lname, lib_next_name_ (Srequirements, PDnames, Iname, Pstarname), type);
	return;

	end out_ch2;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set_field_widths:	procedure;			/* Internal procedure which sets the lengths	*/
						/* of the level number, name indentation, and	*/
						/* name fields, initializes the names-output	*/
						/* counter, and computes initial value of	*/
						/* level_suppressed switch.			*/

	Nindent = min (level+level-2, 14);		/* indent the names for nodes at successive levels*/
	Nindent = max (Nindent, 0);			/* of the tree by 2-spaces/node (max = 8 levels)	*/
	Llevel = min (level+level, 2);		/* level field is 2-char long, unless there is	*/
	Llevel = max (Llevel, 0);			/* no indentation.				*/
	level_suppressed = (Llevel = 0) | ^S.level;	/* suppress level field if there's no room for it	*/
						/* or if it's not required.			*/
	if Scleanup then				/* for library_cleanup, leave room for node list	*/
	     Llevel = 5;				/*   numbers, and for * deletion flag.		*/
	if Sinfo then				/* if output directed to user's terminal,	*/
	     if fcb.line_length >= 79 & ^S.acl then do;
		Nindent = 0;			/* shrink name column.			*/
		Lname = 34;
		end;
	     else if fcb.line_length >= 88 then do;
		Nindent = 0;
		Lname = 40;
		end;
	     else do;				/* For very short terminals, print 1 item/line.	*/
		Snames_first = "1"b;
		Nindent = 0;
		Lname = 34;
		end;
	else Lname = 48 - Nindent;			/* For file output, indent names by level.	*/
	if Sinfo then				/* For user's terminal, output single name 1st.	*/
	     if ^S.names & ^S.matching_names & S.primary_name then
		Snames_first = "1"b;
	Iname = 0;				/* so far, no names have been printed.		*/
	Iacl = 0;					/* so far, no ACL entries have been output.	*/
	Iiacl, Idir_iacl = 0;			/* so far, no IACL entries have been output.	*/

	end set_field_widths;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_fcb_;

%include lib_based_args_;

%include lib_node_;


	end lib_output_node_;




		    lib_output_node_list_.pl1       04/22/86  1447.2rew 04/22/86  1444.4      241533



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


/****^  HISTORY COMMENTS:
  1) change(83-11-18,Lippard), approve(), audit(), install():
     Use 60 line page lengths.
  2) change(86-03-24,GDixon), approve(86-03-24,MCR7365),
     audit(86-04-22,Dickson), install(86-04-22,MR12.0-1042):
     Change page number format in footing and index to accomodate 5-digit page
     numbers.
                                                   END HISTORY COMMENTS */


lib_output_node_list_:	procedure;

     dcl						/*	parameters			*/
	footing			char(45) varying,	/* footing line. (In)			*/
	ASrequirements		bit(72) aligned;	/* bits indicating what information is required	*/
						/*   in the printout of non-archive-comp nodes.	*/
						/*   (In)					*/

     dcl						/*	automatic variables			*/
	Lfirst_name		fixed bin(35),	/* length of the first name in a 2-name footer.	*/
	Llast_name		fixed bin(35),	/* length of the last name in a 2-name footer.	*/
	Lname			fixed bin(35),	/* length of a name in the index.		*/
	Nchars			fixed bin(24),	/* length of chars string.			*/
	Nentries			fixed bin,	/* number of nodes input to print entry point.	*/
	1 POD_storage		aligned like POD,
	Pchars			ptr,		/* ptr to chars string.			*/
	Pindex_entry		ptr,		/* ptr to a name to be put in an index entry.	*/
	Pname			ptr,		/* ptr to name to be put in the footer.		*/
	Ptarget			ptr,		/* ptr to target node we're outputing.		*/
	added_NL			fixed bin(35),	/* number of addition new_line chars which must	*/
						/* be output before appending footing to page.	*/
	cleanup			condition,
	code			fixed bin(35),	/* a status code.				*/
	dir			char(168) varying,	/* a directory path name.			*/
	e			fixed bin,	/* the entry point indicator.			*/
	ent			char(32) varying,	/* an entry name.				*/
	1 eop			aligned,		/* structure containing values used by the	*/
						/*    end-of-page (eop) handler to gen footing.	*/
	  2 Pfirst_name		ptr,		/*    ptr to name of first node listed on this pg.*/
	  2 Plast_name		ptr,		/*    ptr to name of last node listed on this pg.	*/
	  2 multiple_names		bit(1) aligned,	/*    on if footing line can contain 2 names.	*/
         (i, j)			fixed bin,	/* a do-group index.			*/
	long			char(100) aligned,	/* a convert error code.			*/
	page			pic "zzzz9",	/* a page number char. string.		*/
	saved_Eend_page		entry variable,	/* previous value of fcb.Eend_page.		*/
	saved_page_text_length	fixed bin,	/* previous value of fcb.page_text_length.	*/
	short			char(8) aligned;	/* a short converted error code.		*/

     dcl						/*	based variables			*/
	chars			char(Nchars) based (Pchars),
						/* character overlay for the outputable part of	*/
	name			char(32) based;	/* the name of a node.			*/

     dcl (addr, divide, hbound, length, lbound, min, mod, null, reverse, string, substr, verify)
				builtin;

     dcl						/*	entries				*/
	convert_status_code_	entry (fixed bin(35), char(8) aligned, char(100) aligned),
	hcs_$terminate_noname	entry (ptr, fixed bin(35)),
	ioa_$ioa_switch_nnl		entry options (variable),
	iox_$put_chars		entry (ptr, ptr, fixed bin(21), fixed bin(35)),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying),
	lib_output_node_$cross_reference
				entry (ptr, ptr, bit(72) aligned, fixed bin(35), char(32),
				       char(168) varying),
         (lib_output_node_$info,
	lib_output_node_$map,
	lib_output_node_$print)	entry (ptr, ptr, bit(72) aligned, fixed bin(35), ptr),
	lib_paged_output_		entry (ptr, fixed bin(21), ptr, fixed bin(35)),
	lib_ptr_and_bc_		entry (ptr, fixed bin(24), ptr, ptr, fixed bin(24), fixed bin(35)),
	sort_items_indirect_$char	entry (ptr, ptr, fixed bin(24));

     dcl						/*	static variables			*/
	DOTS			char(40) aligned int static init ((20)" ."),
	INDEX			char(32) aligned int static init ("INDEX"),
	NL			char(1) aligned int static init ("
"),						/* a new_line char.				*/
	NULL_NAME			char(32) int static init (""),
						/* a null name for use in index.		*/
	line_2NL			char(134) int static init (
"____________________________________________________________________________________________________________________________________

"),						/* init ((132)"_" || NL || NL)		*/
	line_NL			char(133) defined line_2NL position(1),
	line			char(132) defined line_2NL position(1);
						/* current ring number.			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


info:	entry	(Pfcb, Pnode_list, Pname_list, Pindex_list, footing, ASrequirements, Pstarname);

	e = 1;					/* set entry point indicator.			*/
	eop.multiple_names = "0"b;			/* don't worry about names in footers.		*/
	go to begin;


map:	entry	(Pfcb, Pnode_list, Pname_list, Pindex_list, footing, ASrequirements, Pstarname);

	e = 2;					/* set entry point indicator.			*/
	eop.multiple_names = "1"b;			/* enable multiple names in the footers.	*/
	go to begin;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*      These entry points scan a sorted list of nodes to output selected node		*/
	/* information.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


print:	entry	(Pfcb, Pnode_list, Pname_list, Pindex_list, footing, ASrequirements, Pstarname, Ppage_list);

	e = 3;					/* set entry point indicator.			*/
	eop.multiple_names = "0"b;			/* suppress multiple names in the footers.	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*      This entry point writes the contents of the printable library entries represented	*/
	/* by the nodes in the list.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


begin:	saved_page_text_length = fcb.page_text_length;	/* perform end-of-page processing requiring	*/
	fcb.page_text_length = fcb.page_length - 4;	/*    4 lines.				*/
	saved_Eend_page = fcb.Eend_page;
	fcb.Eend_page = new_page;			/* establish end_page condition handler.	*/

	Srequirements = ASrequirements;		/* copy requirements and suppress new_line before	*/
	S.new_line = "0"b;				/*    nodes printed at levels 2-n.		*/

	go to entry (e);				/* do rest of processing by entry point.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


entry(1):						/* library_info processing.			*/
	eop.Pfirst_name, eop.Plast_name = addr(NULL_NAME);/* don't worry about names in the footers.	*/
	do i = 1 to index_list.I;			/* scan through the list of nodes to be output.	*/
	     Pnode = node_list.e (index_list.e(i));	/* access the ith node in the list.		*/
	     if Pnode = null then go to END_NODE;
	     Pname = name_list.e (index_list.e(i));	/* access its name.				*/
	     if first_outputable_node (Pnode, Ptarget) then do;
						/* if this is the first outputable node in this	*/
						/* branch of the tree, then output it at level 1.	*/
		call lib_output_node_$info (Pfcb, Pnode, ASrequirements, 1, Pstarname);
		if Svalid.kids then			/* if this node has kids, output them too.	*/
		     call output_nodes_kids (Pnode, 2);	/* Start with kids at level 2 of the tree.	*/
		end;
END_NODE:	     end;
	call ioa_$ioa_switch_nnl (fcb.Piocb, "^2/");	/* skip 2 lines before start of next command.	*/
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


entry(2):						/* library_map				*/
	eop.Pfirst_name = name_list.e (index_list.e (1));	/* store name of first node to be output for use	*/
						/* in the footing line.			*/
	do i = 1 to index_list.I;			/* scan through the list of nodes to be output.	*/
	     Pnode = node_list.e (index_list.e (i));	/* address the ith node of the list,		*/
	     Pname = name_list.e (index_list.e (i));	/* and its name.				*/
	     if fcb.line_no+3 > fcb.page_text_length then do;
		call new_page();			/* if we can't get at least 3 lines of output	*/
		eop.Pfirst_name = Pname;		/*    for this one on the current page, skip to	*/
		end;				/*    a new page, and report node as 1st on page.	*/
	     eop.Plast_name = Pname;			/* At this point in time, this node is the last	*/
						/* on this page.				*/
	     if first_outputable_node (Pnode, Ptarget) then do;
						/* if this is the first outputable node in this	*/
						/* branch of the tree, then output it at level 1.	*/
		call lib_output_node_$map (Pfcb, Pnode, ASrequirements, 1, Pstarname);
		if Svalid.kids then			/* if this node has kids, map them at level 2.	*/
		     call output_nodes_kids (Pnode, 2);
		end;
	     else do;				/* if this node is not the first outputable node	*/
						/* of the branch, then cross-reference it at	*/
						/* level 1.				*/
		call lib_node_path_ (Ptarget, dir, ent);/* get path name of first outputable node for use	*/
		if dir = ">" then
		     dir = dir || ent;
		else dir = dir || ">" || ent;		/* in cross-reference entry.			*/
		call lib_output_node_$cross_reference (Pfcb, Pnode, ASrequirements, 1, Pname -> name, dir);
		end;
	     end;
	call new_page();				/* Put a footing line on the last page.		*/
	go to return;				/* All done!				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


return:	fcb.page_text_length = saved_page_text_length;	/* restore previous end-of-page processor.	*/
	fcb.Eend_page = saved_Eend_page;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


entry(3):	PPOD = addr(POD_storage);
	POD.version = VPOD_1;			/* fill in lib_paged_output_ data struc.	*/
	POD.Lline = fcb.line_length;
	POD.Lpage = fcb.page_text_length;
	POD.Ltop_margin = 0;
	POD.Lbottom_margin = 0;
	POD.Nfrom = 1;
	POD.Nto = 0;
	POD.switch = fcb.Piocb;
	POD.end_page = print_footer;
	string(POD.switches) = "0"b;
	POD.Send_page = "1"b;
	POD.Spartial_last_page = "1"b;
	POD.Iat_column = 0;
	POD.Icolumns_used = 0;
	POD.Iline = fcb.line_no-1;
	POD.Ipage = fcb.page_no;
	POD.Imsf_comp = -1;
	POD.heading = "";

	name_list.I = name_list.N;			/* make name list as large as possible.		*/
	page_list.I = page_list.N;
	Nentries = node_list.I;

	Pchars = null;				/* initialize cleanup on-unit's variables.	*/
	on cleanup begin;
	     if Pchars ^= null then do;
		call hcs_$terminate_noname (Pchars, 0);
		Pchars = null;
		end;
	     end;

	do i = 1 to index_list.I;			/* scan through the sorted node list.		*/
	     Pnode = node_list.e (index_list.e (i));	/* address the ith sorted node.		*/
	     Pname = name_list.e (index_list.e (i));	/* address the name by which it was referenced.	*/
	     page_list.e (index_list.e (i)) = POD.Ipage;	/* record page number on which node is output.	*/
						/* cross-reference names of node in index.	*/
	     do PDnames = node.PD repeat (Dnames.Pnext) while (Dnames.T ^= Tnames);
		end;
	     do j = 2 to Dnames.N while (node_list.I < node_list.N);
		node_list.I = node_list.I + 1;
		node_list.e (node_list.I) = Pnode;
		name_list.e (node_list.I) = addr (Dnames.names(j));
		page_list.e (node_list.I) = POD.Ipage;
		end;

	     call lib_paged_output_ (addr(line_NL), length(line_NL), PPOD, code);
	     fcb.line_no = POD.Iline+1;
	     fcb.page_no = POD.Ipage;
	     if Svalid.kids then do;			/* if node has kids, use level numbers in header.	*/
		call lib_output_node_$print (Pfcb, Pnode, ASrequirements, 1, Pstarname);
		call output_nodes_kids (Pnode, 2);
		end;
	     else
		call lib_output_node_$print (Pfcb, Pnode, ASrequirements, 0, Pstarname);
	     POD.Iline = fcb.line_no-1;
	     POD.Ipage = fcb.page_no;
	     call lib_paged_output_ (addr(line_2NL), length(line_2NL), PPOD, code);
	     call output_node (Pnode);		/* print the contents of the node.		*/
	     end;
	fcb.line_no = POD.Iline+1;
	fcb.page_no = POD.Ipage;
	if Nentries > 1 then do;			/* if there was more than 1 entry output, 	*/
	     name_list.I = node_list.I;		/* then generate an index.			*/
	     index_list.I = node_list.I;		/* adjust bounds of name and index arrays.	*/
	     call sort_items_indirect_$char (addr(name_list.I), addr(index_list.I), 32);
	     call output_index;			/* sort the name array and output the index.	*/
	     end;
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


first_outputable_node:	procedure (P, Pfirst)	/* Internal procedure to return ptr to first node	*/
			returns (bit(1) aligned);	/* in tree branch containing node pointed	*/
						/* to by P, which is outputable.		*/
     dcl	P			ptr,		/* ptr to node to be tested. (In)		*/
	Pfirst			ptr,		/* ptr to the first printable node. (Out)	*/
	Pn			ptr,		/* a ptr temp.				*/
	Pp			ptr;		/* a ptr temp.				*/

	Pn = P;					/* save ptr to node at current tree level.	*/
	do Pp = P -> node.Pparent repeat (Pp -> node.Pparent) while (Pp ^= null);
						/* scan up the tree looking for a non-outputable	*/
						/* parent.				*/
	     if Pp -> node.Sreq then;			/* when one is found, save ptr to its kid.	*/
	     else
		go to found;
	     Pn = Pp;
	     end;
found:	Pfirst = Pn;				/* return ptr to first outputable node.		*/
	if Pn = P then do;				/* if our input node was the first outputable,	*/
	     if addr(P->node.Sreq)->Sreq.cross_ref then;	/* if node's names aren't being cross-referenced,	*/
	     else return("1"b);			/*   first time we encounter node is only time,	*/
						/*   and we must output it now.		*/
	     do PDnames = P -> node.PD repeat (Dnames.Pnext) while (Dnames.T ^= Tnames);
		end;				/* and if name from name-list is first on node,	*/
	     if Pname = addr (Dnames.names(1)) then	/* then node is first outputable.		*/
		return ("1"b);
	     end;
	return ("0"b);				/* otherwise, it is not the first outputable.	*/

	end first_outputable_node;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


new_page:	procedure;				/* on new_page_, write a footer and skip to next	*/
						/* page.					*/
	     if fcb.page_text_length + 4 > fcb.page_length then
		return;				/* do _n_o_t_h_i_n_g if no room on page for footer.	*/
	     added_NL = fcb.page_text_length - fcb.line_no;
	     if added_NL > 0 then
		call ioa_$ioa_switch_nnl (fcb.Piocb, "^v/", added_NL);
						/* skip to first footing line.		*/
	     call ioa_$ioa_switch_nnl (fcb.Piocb, "^2/^a", line);
						/* write a line of underscores to divide output	*/
						/* from footer.				*/

						/* output the footing line.			*/
	     if eop.multiple_names then		/* if the footing line can contain two names, then*/
		if eop.Pfirst_name = eop.Plast_name then/* if both names are the same, use only the first.*/
		     call ioa_$ioa_switch_nnl (fcb.Piocb, "^/^45a^5x^32a^40xPage ^5d^|",
					 footing, eop.Pfirst_name -> name, fcb.page_no);
		else do;				/* else do, use both names in the footing line.	*/
		     Lfirst_name = min (32, 33 - verify (reverse (Pfirst_name -> name), " "));
		     Llast_name = min (32, 33 - verify (reverse (Plast_name -> name), " "));
		     call ioa_$ioa_switch_nnl (fcb.Piocb, "^/^45a^5x^68a^4xPage ^5d^|",
			footing, substr (Pfirst_name -> name, 1, Lfirst_name) ||
			" -- " || substr (Plast_name -> name, 1, Llast_name), fcb.page_no);
		     eop.Pfirst_name = eop.Plast_name;	/* last node on this page is first on next page.	*/
		     end;
	     else					/* else, output the name of the current node.	*/
		call ioa_$ioa_switch_nnl (fcb.Piocb, "^/^45a^5x^32a^40xPage ^5d^|",
			                footing, Pname -> name, fcb.page_no);
	     fcb.page_no = fcb.page_no + 1;		/* increment page number.			*/
	     fcb.line_no = 1;			/* set number of lines on this new page.	*/

	end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


output_index:	procedure;			/* Internal procedure to output an index of the	*/
						/* node which were printed.			*/

     dcl	1 line (2:fcb.page_text_length) unaligned,	/* allocate the index page in the stack.	*/
	 (2 column (3)		char(40),		/* page is divide into 3 columns of 40-chars.	*/
	  2 new_line		char(1));
     dcl	column_ent		char(40) varying aligned;
						/* bug bypass variable.			*/

	do i = lbound(line,1) to hbound(line,1);	/* initialize new_line char at end of each line	*/
	     line(i).new_line = NL;			/* of the index page.			*/
	     end;
	j = 1;					/* number of the current column.		*/
	Pname = addr (INDEX);			/* use the word "INDEX" in footers of index pages.*/
	if fcb.line_no ^= 1 then call new_page();	/* start index on a new page.			*/

	do i = 1 to index_list.I;			/* scan thru the list of names to be in index.	*/
	     Pindex_entry = name_list.e (index_list.e(i));/* address the ith name in the sorted list.	*/
	     if Pindex_entry = addr (NULL_NAME) then;	/* skip names being excluded from the index.	*/
	     else do;
		fcb.line_no = fcb.line_no + 1;	/* add the ith name/page-no to next line.	*/
		if fcb.line_no > hbound(line,1) then	/* if name/page-no won't fit in this column:	*/
		     if j < 3 then do;		/* then put it in next column, if there is one.	*/
			j = j + 1;
			fcb.line_no = lbound(line,1);
			end;
		     else do;			/* if no more columns exist, then:		*/
			call iox_$put_chars (fcb.Piocb, addr(line), length(string(line)), code);
						/* output this index page.			*/
			call new_page();		/* skip to a new page of the index.		*/
			j = 1;			/* start with column 1, line 1 of this page.	*/
			end;
		Lname = min (32, 33 - verify (reverse (Pindex_entry -> name), " "));
						/* compute length of ith name in sorted list.	*/
		Lname = Lname + mod (Lname, 2);	/* make the length even.			*/
		page = page_list.e (index_list.e(i));	/* convert page number to a character string.	*/
		column_ent = substr(Pindex_entry -> name, 1, Lname) || substr(DOTS, 1, 32-Lname) || page;
		line(fcb.line_no).column(j) = column_ent;
		     				/* fill in the entry of the index.		*/
		end;
	     end;
	do j = j to 3;				/* blank out unused entries on this index page.	*/
	     do fcb.line_no = fcb.line_no + 1 to hbound(line,1);
		line(fcb.line_no).column(j) = "";
		end;
	     fcb.line_no = lbound(line,1) - 1;
	     end;
	fcb.line_no = hbound(line,1);			/* set proper count of lines on this page.	*/
	call iox_$put_chars (fcb.Piocb, addr(line), length(string(line)), code);
	call new_page();				/* output the final page of the index.		*/

	end output_index;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


output_node:	procedure	(Pnode_);			/* This internal procedure outputs the contents	*/
						/* of the entry represented by a node.		*/

     dcl	Pnode_			ptr;		/* ptr to the node to be output.		*/

     dcl	length			builtin,		/* avoid name conflict.			*/
	msg			char(200) varying,	/* special message to be output.		*/
	msf_comp_no		fixed bin(24),	/* an MSF component number.			*/
						/* a node or node-component.			*/
	1 node_			aligned based (Pnode_) like node;
						/* a node.				*/


test_node:
	if node_.T = Tsegment then do;		/* if the node is a segment, then		*/
seg:	     call lib_ptr_and_bc_ (Pnode_, 0, Pnode_, Pchars, Nchars, code);
	     if Pchars = null then			/* initiate the segment.			*/
		go to error;
segment_target:					/* compute how many chars in non-pt segment.	*/
	     Nchars = divide (Nchars, 9, 24, 0);
	     POD.Spartial_last_page = "0"b;
	     call lib_paged_output_ (addr(chars), length(chars), PPOD, code);
	     call hcs_$terminate_noname (Pchars, code);	/* terminate the segment.			*/
	     end;					/* simple, wasn't it.			*/

	else if node_.T = Tlink then do;		/* get link target, and process that.		*/
	     msf_comp_no = 0;
	     call lib_ptr_and_bc_ (Pnode_, msf_comp_no, Pnode_, Pchars, Nchars, code);
	     if Pchars = null then go to error;
	     if node_.T = Tsegment then go to segment_target;
	     if node_.T = Tarchive then go to archive_target;
	     if node_.T = Tarchive_comp then go to archive_target;
	     if node_.T = Tmsf_comp then do;
		Pnode_ = node_.Pparent;
		go to msf_target;
		end;
	     go to error;
	     end;

	else if node_.T = Tdirectory then do;
	     msg = "lib_output_node_list_$print:  The contents of a directory cannot be printed.";
	     POD.Spartial_last_page = "0"b;
	     call lib_paged_output_ (addr(substr(msg,1)), length(msg), PPOD, code);
	     end;

	else if node_.T = Tarchive_comp then		/* if the node is an archive component, treat	*/
	     go to arch;				/* it like an archive.			*/

	else if node_.T = Tarchive then do;		/* if the node is an archive then,		*/
arch:	     call lib_ptr_and_bc_ (Pnode_, 0, null, Pchars, Nchars, code);
	     if Pchars = null then
		go to error;
archive_target:
	     Nchars = divide (Nchars, 9, 24, 0);	/* convert bit count into a character count.	*/
	     POD.Spartial_last_page = "0"b;
	     call lib_paged_output_ (addr(chars), length(chars), PPOD, code);
	     call hcs_$terminate_noname (Pchars, code);	/* terminate the archive.			*/
	     Pchars = null;
	     end;

	else if node_.T = Tmsf then do;		/* if the node is an MSF, then		*/
	     msf_comp_no = 0;
	     POD.Imsf_comp = msf_comp_no;
	     call lib_ptr_and_bc_ (Pnode_, msf_comp_no, null, Pchars, Nchars, code);
	     if Pchars = null then go to error;
msf_target:    Nchars = divide (Nchars, 9, 24, 0);
	     call lib_paged_output_ (addr(chars), length(chars), PPOD, code);
	     do while (msf_comp_no < node_.bit_count);
		call hcs_$terminate_noname (Pchars, code);
		Pchars = null;
		POD.Imsf_comp = msf_comp_no;		/* msf_comp_no is no of NEXT MSF component.	*/
		call lib_ptr_and_bc_ (Pnode_, msf_comp_no, null, Pchars, Nchars, code);
		if Pchars = null then go to error;
		Nchars = divide (Nchars, 9, 24, 0);
		call lib_paged_output_ (addr(chars), length(chars), PPOD, code);
		end;
	     POD.Spartial_last_page = "0"b;
	     call lib_paged_output_ (addr(chars), 0, PPOD, code);
						/* output footer after last component.		*/
	     call hcs_$terminate_noname (Pchars, code);
	     Pchars = null;
	     end;

	else if node_.T = Tmsf_comp then		/* treat an MSF component to be output alone as	*/
	     go to seg;				/* a segment.				*/

	POD.Spartial_last_page = "1"b;		/* prepare POD for next node.			*/
	POD.Imsf_comp = -1;
	return;

error:	call convert_status_code_ (code, short, long);	/* convert error code to a string.		*/
	msg = "lib_output_node_list_$print:  " || long;
	POD.Spartial_last_page = "0"b;
	call lib_paged_output_ (addr(substr(msg,1)), length(msg), PPOD, code);
	POD.Spartial_last_page = "1"b;
	POD.Imsf_comp = -1;
						/* output the error message.			*/

	end output_node;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


output_nodes_kids:	procedure (P, level);		/* Internal procedure to output the outputable	*/
						/* kid nodes of a given node.			*/

     dcl	P			ptr,		/* ptr to node whose kids are to be printed. (In)	*/
	level			fixed bin(35);	/* level at which they are to be put in map.(In)	*/

     dcl	PDnodes_			ptr,		/* ptr to kid's node array descriptor.		*/
	Pnode_			ptr,		/* ptr to a kid node.			*/
	i			fixed bin;	/* a do-group index.			*/

     dcl	1 Dnodes_			aligned based (PDnodes_),
						/* kid's node array descriptor.		*/
	  2 header		like Dnodes.header,
	  2 nodes (Nnodes refer (Dnodes_.N))
				like node,

	1 Svalid			aligned based (addr (node_.Svalid)) like Svalid_req,
						/* switches telling which kid node fields are OK.	*/
	1 node_			aligned based (Pnode_) like node;
						/* a kid node.				*/

	do PDnodes_ = P->node_.PD repeat Dnodes_.Pnext while (Dnodes_.header.T ^= Tnodes);
	     end;					/* address the node array descriptor of the kids.	*/
	do i = 1 to Dnodes_.N;			/* scan through node array.			*/
	     Pnode_ = addr (Dnodes_.nodes(i));		/* access the ith node of the array.		*/
	     if e = 1 then
		call lib_output_node_$info (Pfcb, Pnode_, Srequirements, level, Pstarname);
	     else if e = 2 then
		call lib_output_node_$map (Pfcb, Pnode_, Srequirements, level, Pstarname);
	     else if e = 3 then do;
		call lib_output_node_$print (Pfcb, Pnode_, Srequirements, level, Pstarname);
		end;
	     if Svalid.kids then			/* look for kid's kids to print, if any.	*/
		call output_nodes_kids (Pnode_, level + 1);
	     end;

	end output_nodes_kids;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


print_footer: procedure (Ipage);			/* Internal procedure to print footing line	*/
						/*   for lib_output_node_list_$print at end of	*/
						/*   page (detected by lib_paged_output_).	*/

     dcl	Ipage			fixed bin;	/* current page number.			*/

	call ioa_$ioa_switch_nnl (fcb.Piocb, "^2/^a", line);
						/* write a line of underscores to divide output	*/
						/* from footer.				*/
	call ioa_$ioa_switch_nnl (fcb.Piocb, "^/^45a^5x^32a^40xPage ^5d^|",
			                footing, Pname -> name, Ipage);
						/* print footing line containing name of node.	*/
	fcb.page_no = Ipage;			/* increment page number.			*/
	fcb.line_no = 1;				/* set number of lines on this new page.	*/

	end print_footer;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_fcb_;

%include lib_paged_output_data_;

%include lib_based_args_;

%include lib_list_;

%include lib_node_;


	end lib_output_node_list_;




		    lib_paged_output_.pl1           07/18/86  1518.6rew 07/18/86  1230.0      146214



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


/****^  HISTORY COMMENTS:
  1) change(76-11-23,GDixon), approve(), audit(), install():
     Program created.
  2) change(86-05-17,GDixon), approve(86-05-17,MCR7357),
     audit(86-07-10,Farley), install(86-07-18,MR12.0-1098):
     Change call to tct_$translate to reference
     find_char_$translate_first_in_table instead.  This subroutine was renamed.
                                                   END HISTORY COMMENTS */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* NAME:  lib_paged_output_							*/
	/*									*/
	/*      This subroutine splits a segment up into printable pages, and outputs each page	*/
	/* on a given I/O switch.  It provides for variable line length, page length, for	*/
	/* top and bottom margin settings, for a caller-supplied end-of-page routine, and for	*/
	/* processing of MSF component segments which are to be treated as part of a logical	*/
	/* MSF.									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

lib_paged_output_:
	procedure (APch, ALch, PPOD, Acode);

     dcl						/*	Parameters			*/
	APch			ptr,		/* ptr to char string to be output with paging. 	*/
						/*   (In)					*/
	ALch			fixed bin(21),	/* length of char string. (In)		*/
/*	PPOD			ptr,		/* ptr to input data structure. (In)		*/
	Acode			fixed bin(35);	/* return code.	(Out)			*/

     dcl	Cbreak 			char(512) varying,	/* temporary string in which break table built.	*/
	Cop			char(1),		/* character from break table corresponding to	*/
						/*   break which was found.			*/
	Iat_column		fixed bin,	/* current column of current line.		*/
	Icolumns_used		fixed bin,	/* number of columns usedin current line.	*/
	J			fixed bin(21),	/* index value.				*/
	Lch			fixed bin(21),	/* length of unoutput part of input char str.	*/
	Lline			fixed bin,	/* length of processed part of current line.	*/
	Lprocessed		fixed bin(21),	/* length of processed part not output yet.	*/
	Lunprocessed		fixed bin(21),	/* length of unprocessed part of input char str.	*/
	Nheading_lines		fixed bin,	/* estimated number of lines required to print	*/
						/*   the heading.				*/
	Nlines			fixed bin,	/* number of print lines with the current line	*/
						/*   will take up when printed.		*/
	Nlines_page		fixed bin,	/* number of lines from input char str which will	*/
						/*   fit on each page.			*/
	Nvert_tabs		fixed bin,
	Pch			ptr,		/* ptr to unoutput part of input char str.	*/
	Punprocessed		ptr,		/* ptr to unprocessed part of input char str.	*/
	Send_of_line		bit(1) aligned,	/* on if end of current line reached.		*/
	Send_of_page		bit(1) aligned,	/* on if end of current page reached.		*/
	Spartial			bit(1) aligned,	/* copy of POD.Spartial_last_page.		*/
	Sprint			bit(1) aligned,	/* on if within page boundaries to be printed.	*/
	Svertical_tab		bit(1) aligned,	/* on if vertical tab encountered.		*/
	cleanup			condition,
	code 			fixed bin(35),	/* status code.				*/
	op			fixed bin(35),	/* binary value of Cop.			*/
	vert_tab_lines (20)		fixed bin;	/* lines to skip for each vertical tab on this	*/
						/*   page.  These ARE NOT TAB STOP SETTINGS.  	*/
						/*   Tab stops assumed at 13,23,33... skipping	*/
						/*   2 lines at top of each page for heading 	*/
						/*   lines, just as the printer does.		*/
	
	
     dcl						/*	based variables.			*/
	ch_array (Lch)		char(1) based (Pch),
	unprocessed		char(Lunprocessed) based(Punprocessed),
	unprocessed_array (Lunprocessed)
				char(1) based(Punprocessed);

%include lib_paged_output_data_;

     dcl (addr, binary, copy, divide, length, max, mod, substr, unspec)
				builtin;

     dcl	find_char_$translate_first_in_table
				entry (char(*), char(512) aligned, fixed bin(21)) returns (char(1)),
	ioa_$ioa_switch_nnl		entry() options(variable),
	iox_$put_chars		entry (ptr, ptr, fixed bin(21), fixed bin(35));

     dcl (ONE_POS			init (""),	/* \000 - ignored by find_char_.		*/
	IGNORE			init ("1"),	/* "1"  - returned by find_char_.		*/
	ESCAPE			init ("2"),	/* "2"  - returned by find_char_.		*/
	BS			init ("3"),	/* "3"  - returned by find_char_.		*/
	HT			init ("4"),	/* "4"  - returned by find_char_.		*/
	NL			init ("5"),	/* "5"  - returned by find_char_.		*/
	NP			init ("6"),	/* "6"  - returned by find_char_.		*/
	CR			init ("7"),	/* "7"  - returned by find_char_.		*/
	VT			init ("8"))	/* "8"  - returned by find_char_.		*/
				char(1) int static options(constant),
	False			bit(1) aligned int static options(constant) init ("0"b),
	NLs			char(200) aligned int static options(constant) init ((200)"
"),
	VTchar			char(1) aligned int static options(constant) init(""),
	NPchar			char(1) aligned int static options(constant) init (""),
	Sfirst			bit(1) aligned int static init ("1"b),
						/* on if pgm invoked for first time in process.	*/
	True			bit(1) aligned int static options(constant) init ("1"b),
	break_table		char(512) aligned int static,
	error_table_$unimplemented_version
				fixed bin(35) ext static;
						/* static copy of Cbreak, the break table used	*/
						/*   by find_char_$translate_first_in_table.	*/


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	if Sfirst then do;				/* construct search table.			*/
	     Cbreak = IGNORE;			/* 000    :  NUL is ignored wrt print positions.	*/
	     Cbreak = Cbreak || copy(ESCAPE,6);		/* 001-006:  are escape sequences.		*/
	     Cbreak = Cbreak || ESCAPE;		/* 007    :  BEL is escaped.			*/
	     Cbreak = Cbreak || BS;			/* 010    :  BS is a -1 print positions.	*/
	     Cbreak = Cbreak || HT;			/* 011    :  HT is variable number of print pos.	*/
	     Cbreak = Cbreak || NL;			/* 012    :  NL is after last print position.	*/
	     Cbreak = Cbreak || VT;			/* 013    :  VT ends line, skips to next VT stop. */
	     Cbreak = Cbreak || NP;			/* 014    :  NP ends line and page.		*/
	     Cbreak = Cbreak || CR;			/* 015    :  CR sets position to col 1.		*/
	     Cbreak = Cbreak || copy(ESCAPE,2);		/* 016-017:  BRS-RRS are escaped.		*/
	     Cbreak = Cbreak || copy(ESCAPE,16);	/* 020-037:  are escape sequences.		*/
	     Cbreak = Cbreak || copy(ONE_POS,95);	/* 040-176:  are printable, taking 1 position.	*/
	     Cbreak = Cbreak || IGNORE;		/* 177    :  PAD is ignored.			*/
	     Cbreak = Cbreak || copy(ESCAPE,384);	/* 200-777:  are escape sequences.		*/
	     break_table = Cbreak;			/* copy into internal static break table.	*/
	     Sfirst = False;
	     end;

	if POD.version ^= VPOD_1 then   do;
	     Acode = error_table_$unimplemented_version;
	     return;
	     end;
	Acode = 0;
	Pch = APch;				/* copy input args so we can change them.	*/
	Lch = ALch;
	Iat_column = POD.Iat_column;
	Icolumns_used = POD.Icolumns_used;
	Nlines_page = POD.Lpage - POD.Lbottom_margin;

	if POD.Sheader & POD.Imsf_comp < 1 then do;
	     Nheading_lines = 2 + divide(length(POD.heading) + (POD.Lline-1), POD.Lline, 17, 0);
						/* estimate number of lines occupied by heading.	*/
						/* exclude widowed heading lines by requiring at	*/
						/*   least 2 text lines on page with heading.	*/
	     if Nheading_lines > Nlines_page then;	/* heading can never fit on a page. Ignore it.	*/
	     else do;
		if Nheading_lines + POD.Iline > Nlines_page then do;
		     if Sprint then do;		/* heading won't fit on current page. Force EOP.	*/
			if (POD.Lpage-POD.Iline > 0) then do;
			     call iox_$put_chars (POD.switch, addr(NLs), (POD.Lpage - POD.Iline), code);
			     if code ^= 0 then go to FATAL_ERROR;
			     end;
			if POD.Send_page then call end_page (POD.Ipage);
			end;
		     POD.Ipage = POD.Ipage + 1;
		     POD.Iline = 0;
		     end;
		Spartial = POD.Spartial_last_page;
		on cleanup begin;
		     POD.Sheader = True;
		     POD.Spartial_last_page = Spartial;
		     end;
		POD.Sheader = False;
		POD.Spartial_last_page = True;
		Punprocessed = addr(substr(POD.heading,1));
		Lunprocessed = length(POD.heading);
		call lib_paged_output_ (Punprocessed, Lunprocessed, PPOD, code);
		if code ^= 0 then go to FATAL_ERROR;
		POD.Sheader = True;
		POD.Spartial_last_page = Spartial;
		revert cleanup;
		end;
	     end;

	do while (((POD.Ipage <= POD.Nto) | (POD.Nto = 0)) & (Lch > 0)); 
						/* Process input looking for pages to print.	*/
	     if (POD.Nfrom <= POD.Ipage) & ((POD.Ipage <= POD.Nto) | (POD.Nto = 0)) then
		Sprint = True;
	     else Sprint = False;			/* Determine printability.			*/
	     if (POD.Iline < POD.Ltop_margin) then do;
		if Sprint then do;
		     call iox_$put_chars (POD.switch, addr(NLs), (POD.Ltop_margin-POD.Iline), code);
		     if code ^= 0 then go to FATAL_ERROR;
		     end;
		POD.Iline = POD.Ltop_margin;		/* output top margin.			*/
		end;

	     Send_of_page = False;			/* Prepare to process each page.		*/
	     Punprocessed = Pch;
	     Lunprocessed = Lch;
	     Lprocessed = 0;
	     Nlines = 0;
	     Nvert_tabs = 0;
	     do while ((POD.Iline + Nlines <= Nlines_page) & (Lunprocessed > 0) & ^Send_of_page);
		Send_of_line = False;		/* Scan input until a page has been processed.	*/
		Svertical_tab = False;
		Lline = 0;			/* Note that lines are not output at this time.	*/
		do while ((Lunprocessed > 0) & ^Send_of_line);
						/* This loop processes each printed line.	*/
		     Cop = find_char_$translate_first_in_table (unprocessed, break_table, J);
		     if J = 0 then do;		/* end of input detected with no NL char.	*/
			J = Lunprocessed;
			Iat_column = Iat_column + J;
			go to END_NOT_BREAK;
			end;
		     else op = binary (unspec(Cop), 9);
		     go to DO(op);

DO(49):		     Iat_column = Iat_column + (J - 1);	/* 49 = \061 = "1" = IGNORE.			*/
		     go to END;

DO(50):		     Iat_column = Iat_column + (J + 3);	/* 50 = \062 = "2" = ESCAPE.			*/
		     go to END;

DO(51):		     Iat_column = Iat_column + (J - 2);	/* 51 = \063 = "3" = BS (backspace).		*/
		     Icolumns_used = max (Icolumns_used, Iat_column+1);
		     go to END;

DO(52):		     Iat_column = Iat_column + (J - 1);	/* 52 = \064 = "4" = HT (horizontal tab).	*/
		     Iat_column = Iat_column + (10 - mod(Iat_column,10));
		     go to END;

DO(53):		     Iat_column = Iat_column + (J - 1);	/* 53 = \065 = "5" = NL (new line).		*/
		     Send_of_line = True;
		     go to END;

DO(54):		     Iat_column = Iat_column + (J - 1);	/* 54 = \066 = "6" = NP (new page).		*/
		     Send_of_line = True;
		     Send_of_page = True;
		     go to END;

DO(55):		     Iat_column = Iat_column + (J - 1);	/* 55 = \067 = "7" = CR (carriage return).	*/
		     Icolumns_used = max (Icolumns_used, Iat_column);
		     Iat_column = 0;
		     go to END;

DO(56):		     Iat_column = Iat_column + (J - 1); /* 56 = \068 = "8" = VT (vertical tab)		*/
		     Send_of_line = True;
		     Svertical_tab = True;
		     go to END;

END:		     if ^Send_of_line then do;
			Punprocessed = addr (unprocessed_array(J+1));
			Lunprocessed = Lunprocessed - J;
			Lline = Lline + J;
			J = 0;			/* clear used value, in case do group ends.	*/
			end;
		     end;
END_NOT_BREAK:	Icolumns_used = max (Icolumns_used, Iat_column);
		Nlines = divide (Icolumns_used + (POD.Lline-1), POD.Lline, 17, 0);
		if Send_of_line then Nlines = max(Nlines,1);
		if POD.Iline + Nlines > Nlines_page then do;
		     Iat_column = POD.Iat_column;	/* record where we were for subsequent invocation.*/
		     Icolumns_used = POD.Icolumns_used;
		     end;
		else do;
		     if ((Lunprocessed - J <= 0) & ^Send_of_line & POD.Spartial_last_page) then
			POD.Iline = POD.Iline + Nlines-1;
						/* Last line didn't end in NL or NP (final page)	*/
						/*   and partial last pages are allowed.	*/
		     else do;			/* Otherwise--				*/
			POD.Iline = POD.Iline + Nlines;
			Iat_column = 0;
			Icolumns_used = 0;
			end;
		     POD.Iat_column = Iat_column;
		     POD.Icolumns_used = Icolumns_used;
		     if (Lunprocessed - J > 0) then
			Punprocessed = addr (unprocessed_array(J+1));
		     Lunprocessed = Lunprocessed - J;
		     Lline = Lline + J;
		     Lprocessed = Lprocessed + Lline;
		     if Svertical_tab then do;	/* Process vertical table to count its extra lines*/
			Nvert_tabs = Nvert_tabs + 1;
			vert_tab_lines(Nvert_tabs) = 10 - mod(POD.Iline-POD.Ltop_margin-1, 10);
			Nlines = vert_tab_lines(Nvert_tabs);
			POD.Iline = POD.Iline - 1;	/* Omit line containing VT from line count.	*/
			if  POD.Iline + Nlines < Nlines_page  then
			     POD.Iline = POD.Iline + Nlines;
						/*   The computed value of Nlines includes a NL	*/
						/*   at end of line containing VT.		*/
			else Send_of_page = True;	/*   Or else, the end-of-page routine will supply */
			end;			/*   this NL.				*/
		     Nlines = 0;			/* line just processed definitely on this page.	*/
		     end;
		end;

	     if Sprint & (Lprocessed > 0) then		/* If we are to output anything, do it now.	*/
		if ch_array(Lprocessed) = NPchar then do;
		     call out (Lprocessed-1);
		     call iox_$put_chars (POD.switch, addr(NLs), 1, code);
		     if code ^= 0 then go to FATAL_ERROR;
		     end;
		else if ch_array(Lprocessed) = VTchar then do;
		     call out (Lprocessed-1);
		     end;
		else do;
		     call out (Lprocessed);
		     end;
	     if (Lch - Lprocessed > 0) then		/* Forget now about what's been processed.	*/
		Pch = addr (ch_array (Lprocessed+1));
	     Lch = Lch - Lprocessed;

	     if (Lch > 0 | Send_of_page | ^POD.Spartial_last_page) then do;
		if Sprint then do;
		     if (POD.Lpage-POD.Iline > 0) then do;
						/* Output footing for all but last page.  On last	*/
						/*   page, output footing only if partial page	*/
						/*   is not desired.			*/
			call iox_$put_chars (POD.switch, addr(NLs), (POD.Lpage - POD.Iline), code);
			if code ^= 0 then go to FATAL_ERROR;
			end;
		     if POD.Send_page then call end_page (POD.Ipage);
		     end;
		POD.Ipage = POD.Ipage + 1;
		POD.Iline = 0;
		end;
	     end;

	return;
	
FATAL_ERROR:
	Acode = code;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


out:	proc (L);
	
     dcl	L			fixed bin(21),
	Lstr			fixed bin(21),
	Pstr			ptr,
	str			char(Lstr) based(Pstr),
	str_array (Lstr)		char(1) based(Pstr);

	Nvert_tabs = 0;
	Pstr = Pch;
	Lstr = L;
	do while(Lstr > 0);
	     Cop = find_char_$translate_first_in_table (str, break_table, J);
	     if J = 0 then do;
		call iox_$put_chars (POD.switch, Pstr, Lstr, code);
		if code ^= 0 then go to FATAL_ERROR;
		Lstr = 0;
		end;
	     else do;
		op = binary (unspec(Cop), 9);
		go to OUT(op);
		
OUT(49):						/* IGNORE					*/
OUT(51):						/* BS					*/
OUT(52):						/* HT					*/
OUT(53):						/* NL					*/
OUT(54):						/* NP (should never process one of these.	*/
OUT(55):						/* CR					*/
		call iox_$put_chars (POD.switch, Pstr, J, code);
		if code ^= 0 then go to FATAL_ERROR;
		go to END_OUT;
		
OUT(50):		if J > 1 then do;			/* ESCAPE SEQUENCE.				*/
		     call iox_$put_chars (POD.switch, Pstr, J-1, code);
		     if code ^= 0 then go to FATAL_ERROR;
		     end;
		call ioa_$ioa_switch_nnl (POD.switch, "\^3.3b", unspec(str_array(J)));
		go to END_OUT;
		
OUT(56):		if J > 1 then do;			/* VT					*/
		     call iox_$put_chars (POD.switch, Pstr, J-1, code);
		     if code ^= 0 then go to FATAL_ERROR;
		     end;
		Nvert_tabs = Nvert_tabs + 1;
		call ioa_$ioa_switch_nnl (POD.switch, "^v/", vert_tab_lines(Nvert_tabs));
		go to END_OUT;

END_OUT:		if J < Lstr then
		     Pstr = addr(str_array(J+1));
		Lstr = Lstr - J;
		end;
	     end;
	end out;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	end lib_paged_output_;




		    lib_pathname_.pl1               02/15/84  0911.2rew 02/15/84  0750.0       47439



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: lib_pathname_							*/
	/*									*/
	/* This is the subroutine interface for the library_pathname command/af.  Given a	*/
	/* library descriptor name, an array of library names, an array of star_names, it	*/
	/* returns an array of pathnames of library entries matching the star_names.  The	*/
	/* lib_args_.incl.pl1 include file can be used by the valler to declare space for the	*/
	/* library names and star names arrays.						*/
	/*									*/
	/* Status:								*/
	/* 0) Created:    October, 1981 by G. C. Dixon					*/
	/* 1) Modified:   January, 1984 by Jim Lippard to get Srequirements and Scontrol from the	*/
	/*                calling procedure.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	
lib_pathname_:
	proc (Adescriptor, Plibrary, Pstarname, Pexclude, Srequirements,
	     Scontrol, Presult_area, Ppaths, Npaths, progress, Acode)
	options (rename ((alloc_, smart_alloc_)));

     dcl	Adescriptor		char(168) varying,	/* name of library descriptor to be used. (In)	*/
						/*   If = "", then default descriptor is used.	*/
	Presult_area		ptr,		/* ptr to area in which array of found pathnames	*/
						/*   is allocated. (In)			*/
	Ppaths			ptr,		/* ptr to array of allocated pathnames. (Out)	*/
	Npaths			fixed bin,	/* number of allocated pathnames. (Out)		*/
	progress			fixed bin,	/* integer indicating progress of search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_info command supported	*/
						/*       by this descriptor.			*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	Acode			fixed bin(35);	/* status code.  				*/

     dcl	Parea			ptr,
	Pnode			ptr,
	Ptree			ptr,
	cleanup			condition,
	code			fixed bin(35),
	i			fixed bin;

     dcl	area			area based(Parea),
	paths (Npaths)		char(200) based(Ppaths),
	result_area		area based(Presult_area);
	
     dcl (addr, null)		builtin;

     dcl	condition_		entry (char(*), entry),
	get_system_msa_		entry (ptr, fixed bin(35), ptr),
	lib_descriptor_$info	entry (char(168) var, ptr, ptr, ptr, bit(72) aligned, bit(36) aligned,
				     ptr, ptr, fixed bin, fixed bin(35)),
	lib_node_path_$absolute	entry (ptr) returns(char(200) var),
	lib_sort_tree_$make_name_list	entry (ptr, ptr, ptr, ptr, fixed bin(35)),
	msa_manager_$area_handler	entry (ptr, char(*), ptr, ptr, bit(1) aligned),
	release_system_msa_		entry (ptr, fixed bin(35));

     dcl (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant);

	Acode = 0;				/* Initialize return code.			*/

	Sc.check_archive = TRUE;
	Sc.search_names = TRUE;
	S.primary_name = TRUE;
	S.pathname = TRUE;

	Parea = null;				/* Prepare for release of multi-segment area (MSA)*/
	on cleanup call janitor();

	call condition_ ("area", msa_manager_$area_handler);
						/* let msa_manager_ handle area conditions.	*/
	call get_system_msa_ (addr(Parea), 0, null);	/* get a system MSA.			*/

	call lib_descriptor_$info (Adescriptor, Plibrary, Pstarname, Pexclude,
	     Srequirements, Scontrol, Parea, Ptree, progress, Acode);
	if Acode ^= 0 then go to BAD_SEARCH;

	allocate  index_list in (area),		/* allocate space to hold list of found status	*/
		name_list  in (area),		/*   nodes.				*/
		node_list  in (area);
	index_list.I = 0;
	name_list.I = 0;
	node_list.I = 0;
	call lib_sort_tree_$make_name_list (Ptree, Pname_list, Pindex_list, Pnode_list, Acode);
	if Acode ^= 0 then go to NO_MATCH;		/* Fill in the list.			*/

	Npaths = node_list.I;			/* Fill in resulting pathnames.		*/
	allocate paths in (result_area);
	do i = 1 to node_list.I;
	     Pnode = node_list.e(i);
	     paths(i) = lib_node_path_$absolute (Pnode);
	     end;
	call janitor();
	return;


BAD_SEARCH:
NO_MATCH: Ppaths = null;
	Npaths = 0;
	call janitor();
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


janitor:	proc;

	if Parea ^= null then
	     call release_system_msa_ (addr(Parea), code);

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include lib_based_args_;

%include lib_list_;

%include lib_Svalid_req_;

%include lib_Scontrol_;

	end lib_pathname_;




		    lib_ptr_and_bc_.pl1             02/15/84  0911.2rew 02/15/84  0819.1       67563



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




lib_ptr_and_bc_:	procedure (Pnode, msf_comp_no, Ptarget_node, ptr, bc, Acode);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This procedure is part of the library maintenance subsystem of tools.  Documentation of*/
	/* the complete subsystem is available in AN-80, Library Maintenance.			*/
	/*									*/
	/* This procedure, when given the pointer to a library node, initiates the segment	*/
	/* containing the entry identified by the node and returns the ptr and bit count of	*/
	/* the segment.  The procedure can handle archive components (and even archived-archive	*/
	/* components, etc).  For MSFs, msf_comp_no should be set to 0 to obtain a ptr to and	*/
	/* bit count of the first component (named 0).  msf_comp_no will be incremented for use	*/
	/* in obtaining ptr/bc for the next component in a subsequent call.  If ptr is null, then	*/
	/* the library entry identified by the node could not exist (or there is no MSF component	*/
	/* which corresponds to the value of msf_comp_no).  Links are chased and their target	*/
	/* is initiated.  A pointer to the target node for link targets and MSF components is	*/
	/* returned as Ptarget_node.							*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created by:   G. C. Dixon, April 8, 1975					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

     dcl						/*		Parameters		*/
/*	Pnode			ptr,		/* ptr to node identifying lib entry to be	*/
						/*   initiated. (In)			*/
	msf_comp_no		fixed bin(24),	/* if node identifies an MSF, numeric name of MSF	*/
						/*   component to be initiated. (In)		*/
						/* if node identifies an MSF, the input value	*/
						/*   is incremented by 1. (Out)		*/
	Ptarget_node		ptr,		/* ptr to the node which identifies the library	*/
						/*   entry actually initiated.  This node is the	*/
						/*   final target node of a link, or the MSF comp	*/
						/*   node for an MSF. (Out)			*/
	ptr			ptr,		/* is the pointer to the initiated entry. (Out)	*/
	bc			fixed bin(24),	/* is the bit count of the initiated entry. (Out)	*/
	Acode			fixed bin(35);	/* a status Acode. (Out)			*/

     dcl						/*	Automatic Variables			*/
	code			fixed bin(35),	/* an error code.				*/
	dir			char(168) varying,	/* dir part of path name of lib node.		*/
	ent			char(32) varying,	/* ent part of path name of lib node.		*/
         (i, j)			fixed bin,	/* do group index variables.			*/
	name			char(32) aligned;	/* character string name of MSF comp we		*/
						/*   are looking for.			*/

     dcl						/*	Builtin Functions			*/
         (addr, min, null, pointer, substr, verify)
				builtin;

     dcl						/*		Entries			*/
	hcs_$initiate		entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2),
				       ptr, fixed bin(35)),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying);

     dcl						/*	Static Variables			*/
         (error_table_$dirseg,
	error_table_$improper_data_format,
	error_table_$noentry)	fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	Acode = 0;				/* initialize the output status Acode.		*/
	if node.T = Tsegment then do;			/* initiate the segment, as is.		*/
like_segment:  call lib_node_path_ (Pnode, dir, ent);	/*   first, get path name of segment.		*/
	     call hcs_$initiate ((dir), (ent), "", 0, 0, ptr, code);
	     if ptr ^= null then do;
		bc = node.bit_count;
		Ptarget_node = Pnode;
		end;
	     else Acode = code;
	     end;

 	else if node.T = Tarchive then
	     if node.offset = 0 then go to like_segment;	/* unarchived-archives are like segments.	*/
	     else go to like_archive_component;		/* archived-archives are really archive comps.	*/

	else if node.T = Tarchive_comp then do;		/* get ptr/bc of parent node for the		*/
like_archive_component:				/* archive component, then use offset/bc in node.	*/
	     call lib_ptr_and_bc_ (node.Pparent, 0, null, ptr, 0, Acode);
	     if ptr ^= null then do;
		ptr = pointer (ptr, node.offset);
		bc = node.bit_count;
		Ptarget_node = Pnode;
		end;
	     end;

	else if node.T = Tlink then do;		/* get ptr/bc for link target, if any.		*/
	     if Svalid.kids then do;
		do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes);
		     end;				/*   find target of this link.		*/
		if Dnodes.N = 1 then		/*   get ptr/bc for this target.		*/
		     call lib_ptr_and_bc_ (addr(Dnodes.nodes(1)), msf_comp_no, Ptarget_node, ptr, bc, Acode);
		else do;
		     ptr = null;
		     Acode = error_table_$improper_data_format;
		     end;
		end;
	     else ptr = null;
	     end;

	else if node.T = Tdirectory then do;		/* can't initiate directories.		*/
	     ptr = null;
	     Acode = error_table_$dirseg;
	     end;

	else if node.T = Tmsf_comp then go to like_segment;
						/* msf components are really segments at heart.	*/


	else if node.T = Tmsf then			/* get the correspondingly-named msf component.	*/
	     if msf_comp_no + 1 <= node.msf_indicator then/*   test for existence of desired comp.	*/
		if Svalid.kids then do;
		     do PDnodes = node.PD repeat Dnodes.Pnext while (Dnodes.header.T ^= Tnodes);
			end;
		     name = char_form (msf_comp_no);
		     Ptarget_node = null;
		     do i = msf_comp_no+1 to Dnodes.N,
			  1 to min(msf_comp_no, Dnodes.N) while (Ptarget_node = null);
			do PDnames = addr(Dnodes.nodes(i))->node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
			     end;
			do j = 1 to Dnames.N while (Dnames.names(j) ^= name);
			     end;
			if j <= Dnames.N then Ptarget_node = addr(Dnodes.nodes(i));
			end;
		     if Ptarget_node ^= null then
			call lib_ptr_and_bc_ (Ptarget_node, msf_comp_no, Ptarget_node, ptr, bc, Acode);
		     else ptr = null;
		     msf_comp_no = msf_comp_no + 1;
		     end;
		else ptr = null;
	     else ptr = null;

	else ptr = null;				/* I don't know what it is!  Too bad.		*/

	if ptr = null then if Acode = 0 then Acode = error_table_$noentry;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


char_form: procedure (number) returns (char(32) aligned);	/* internal proc to convert an integer to a	*/
						/* left-justified 32-char string.		*/

     dcl	number			fixed bin(24),
	char_number		pic "zzzzz9",
	i			fixed bin;

	char_number = number;			/* convert number to right-justified numeric	*/
						/* string.				*/
	i = verify (char_number, " ");		/* find left-most significant digit.		*/
	return (substr(char_number,i));		/* return significant digits.			*/

	end char_form;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_node_;
	end lib_ptr_and_bc_;




		    lib_sort_tree_.pl1              02/15/84  0911.2rew 02/15/84  0819.1       67095



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


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


lib_sort_tree_:	procedure;

     dcl	Ptree			ptr,		/* ptr to node tree to be sorted. (In)		*/
	code			fixed bin(35);	/* a status code. (Out)			*/

     dcl	I			fixed bin,	/* do-group index.				*/
	i			fixed bin;	/* do-group index.				*/

     dcl (addr, null)		builtin;

     dcl	sort_items_indirect_$char	entry (ptr, ptr, fixed bin(24));

     dcl	error_table_$nomatch	fixed bin(35) ext static,
	null_name			char(32) aligned int static init ("");
						/* a null name used for nodes without name	*/
						/* descriptors.				*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


make_node_list:	entry	(Ptree, Pnode_list, code);	/* entry to find inner-most tree nodes with	*/
						/*   some node.Sreq bits on;  return a list of	*/
						/*   such nodes.				*/
	code = 0;					/* initialize output code.			*/
	i = node_list.I;				/* remember how many nodes already in list.	*/
	call recurse (Ptree, Pnode_list);		/* scan thru tree, putting desired nodes in list.	*/
	if node_list.I = i then code = error_table_$nomatch;
	return;					/* return error if no nodes found.		*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


make_name_list:	entry	(Ptree, Pname_list, Pindex_list, Pnode_list, code);
						/* entry to put printable nodes of a node tree	*/
						/* into a name list.			*/

	code = 0;					/* initialize output code.			*/
	i = node_list.I;				/* remember how many nodes are already in list.	*/
	call recurse (Ptree, Pnode_list);		/* scan through the tree, putting printable nodes	*/
						/* into the node list.			*/
	if node_list.I = i then do;			/* if no outputable entries were found,		*/
	     code = error_table_$nomatch;		/* return an error.				*/
	     return;
	     end;
	do I = i+1 to node_list.I;			/* make the name_list elements point to the	*/
						/* primary name of nodes in the node list.	*/
	     Pnode = node_list.e(I);			/* first, access node pointed to by node list	*/
						/* element.				*/
	     if Svalid.names then do;			/* if node has a name descriptor, then		*/
		do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
		     end;				/* access the name descriptor;		*/
		name_list.e(I) = addr (Dnames.names(1));/* make name_list element point to first name.	*/
		index_list.e(I) = I;		/* initialize index list.			*/
		if Sreq.cross_ref then 		/* if all names on node are to be cross referenced*/
		     do i = 2 to Dnames.N while (node_list.I < node_list.N);
			node_list.I = node_list.I + 1;/* add the rest of it's names to the name list.	*/
			node_list.e(node_list.I) = Pnode;
			name_list.e(node_list.I) = addr (Dnames.names(i));
			index_list.e(node_list.I) = node_list.I;
			end;
		end;
	     else do;				/* if node has no names, then point to a null name*/
		name_list.e(I) = addr (null_name);
		index_list.e(I) = I;
		end;
	     end;
	name_list.I = node_list.I;			/* set number of name list and index list elements*/
	index_list.I = node_list.I;			/* equal to the number of elements in node list.	*/
	return;					/* All done!				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


name_list:	entry	(Pname_list, Pindex_list);	/* entry to sort a name list.			*/

	if name_list.I > 1 then			/* if there's more than one matching node,	*/
	     call sort_items_indirect_$char (addr(name_list.I), addr(index_list.I), 32);
						/* sort the elements of index_list.e into order	*/
						/* so that:				*/
						/*    name_list.e(index_list.e(i))->based_name <=	*/
						/*       name_list.e(index_list.e(j))->based_name	*/
						/* for all i < j.				*/
	else					/* otherwise, fill in the only item's index list.	*/
	     index_list.e(1) = 1;
	return;					/* All done!				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


recurse:	procedure (PDnodes_, Pnode_list);		/* Recursive internal procedure to scan node tree	*/
						/* looking for printable nodes to put into the	*/
     dcl	PDnodes_			ptr,		/* node list.				*/
	Pnode_list		ptr;

     dcl	PD_			ptr,		/* ptr to a node array descriptor.		*/
	Pnode_			ptr,		/* ptr to a node.				*/
	i			fixed bin;	/* do-group index.				*/

     dcl	1 D_			aligned based (PD_) like D,
						/* a kid's node array descriptor.		*/
	1 Dnodes_			aligned based (PDnodes_),
						/* node array to be scanned for outputable nodes.	*/
	  2 header		like Dnodes.header,
	  2 nodes (Nnodes refer (Dnodes_.N))
				like node,

	1 Sreq			aligned based (addr (node_.Sreq)) like Svalid_req,
						/* switches defining which node data is required.	*/
	1 Svalid			aligned based (addr (node_.Svalid)) like Svalid_req,
						/* switches defining which node data is valid.	*/
	1 node_			aligned based (Pnode_) like node,
						/* a node.				*/
	1 node_list		aligned based (Pnode_list),
	  2 N			fixed bin,	/* the node list.				*/
	  2 I			fixed bin,
	  2 e (0 refer (node_list.I)) ptr unaligned;


	do i = 1 to Dnodes_.N while (node_list.I < node_list.N);
						/* scan all nodes in node array at this tree level*/
						/* or until our node list is full.		*/
	     Pnode_ = addr (Dnodes_.nodes(i));		/* address the ith node of the node array.	*/
	     if node_.Pparent ^= null then		/* if node has a parent then if its parent is	*/
		if node_.Pparent -> node_.Sreq then	/*    outputable, only put the node into the	*/
		     if Sreq.cross_ref then;		/*    node list if it is to be cross-referenced.	*/
		     else go to skip_it;		/* otherwise, do _n_o_t add to list.		*/
	     if node_.Sreq then do;			/* if node can be output, then:		*/
		node_list.I = node_list.I + 1;	/* get index of next node list element.		*/
		node_list.e(node_list.I) = Pnode_;	/* put pointer to node in node list.		*/
		if node_.T ^= Tlink then		/* if this outputable node is not a link or msf,	*/
		     if node_.T ^= Tmsf then		/* add any of its kids to the node list too.	*/
			if Svalid.kids then do;
			     do PD_ = node_.PD repeat D_.Pnext while (D_.T ^= Tnodes);
				end;
			     call recurse (PD_, Pnode_list);
			     end;
		end;

	     else if Svalid.kids then do;		/* if this node is not outputable, see if any of	*/
						/* it's kids are.				*/
		do PD_ = node_.PD repeat D_.Pnext while (D_.T ^= Tnodes);
		     end;
		call recurse (PD_, Pnode_list);
		end;
skip_it:	     end;

	end recurse;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
%include lib_list_;

%include lib_node_;



	end lib_sort_tree_;




		    library_cleanup.pl1             02/15/84  0911.2rew 02/15/84  0749.4      168273



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

/* Modified:  January, 1984 by Jim Lippard to align structures passed to lib_args_			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


library_cleanup: lcln:	procedure
		options	(rename ((alloc_, smart_alloc_)));

     dcl						/*	automatic variables			*/
	Bgrace_begins		bit(36) aligned,	/* time grace period begins (fstime in bits).	*/
	Idelete			fixed bin,	/* count of nodes to be deleted.		*/
	Inode			fixed bin,	/* count of nodes which are candidates for delete	*/
	Ngrace_begins		fixed bin(71),	/* time grace period begins.			*/
	Parea			ptr,		/* ptr to an MSA.				*/
	Pdelete			ptr,		/* ptr to node currently being deleted.		*/
	Pprev_parent		ptr,		/* ptr to parent of node just listed/deleted.	*/
	Ptree			ptr,		/* ptr to a tree of status nodes.		*/
	1 arg_struc_temp		like arg_struc,	/* storage for argument structure.		*/
	code			fixed bin(35),	/* a status code.				*/
	dir			char(168) varying,	/* dir part of node pathname.			*/
	ent			char(32)  varying,	/* ent part of node pathname.		*/
	1 fcb_temp		like fcb,		/* storage for file control block.		*/
	i			fixed bin,	/* a do-group index.			*/
	prev_dir			char(168) varying,	/* dir part of prev node pathname.		*/
	prev_ent			char(32)  varying,	/* ent part of prev node pathname.		*/
	progress			fixed bin init (0),	/* integer indicating progress of our search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_cleanup command	*/
						/*       supported by this descriptor.		*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	state			char(16),		/* an error temporary char string.		*/
	unset_depth		fixed bin,	/* height/depth up/down tree to which access	*/
	yes_no			char(3) varying;	/* answer to a command_query_ question.		*/
						/*   was set and must be unset.		*/

     dcl						/* 	based variables			*/
	area			area based (Parea),	/* an MSA (multi-segment area).		*/
	Ngrace_begins_bits		bit(72) based (addr(Ngrace_begins));
						/* bit string overlay for Ngrace_begins.	*/

     dcl (addr, min, null, substr)
				builtin;
     dcl	cleanup			condition;

     dcl						/*	Entries Called			*/
	clock_			entry returns (fixed bin(71)),
         (com_err_,
	com_err_$suppress_name)	entry options(variable),

	command_query_		entry options(variable),
	condition_		entry (char(*) aligned, entry),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_list_ptr		entry returns(ptr),
	delete_$path 		entry (char(*), char(*), bit(6), char(*), fixed bin(35)),
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns (fixed bin),
	get_ring_			entry returns (fixed bin),
	get_system_msa_		entry (ptr, fixed bin, ptr),
	hcs_$set_copysw		entry (char(*), char(*), bit(1), fixed bin(35)),
	hcs_$set_safety_sw		entry (char(*), char(*), bit(1), fixed bin(35)),
	ioa_			entry options(variable),
	installation_tools_$set_ring_brackets
				entry (char(*), char(*), (3) fixed bin(3), fixed bin(35)),
	lib_access_mode_$set	entry (ptr, bit(36) aligned, fixed bin, fixed bin(35)),
	lib_access_mode_$unset	entry (ptr, fixed bin, fixed bin(35)),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_descriptor_$cleanup	entry (char(168) varying, ptr, ptr, ptr, bit(72) aligned,  bit(36) aligned,
				       ptr, ptr, fixed bin, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying),
	lib_output_node_$cleanup	entry (ptr, ptr, bit(72) aligned, fixed bin, ptr, fixed bin, ptr),
	lib_sort_tree_$make_node_list
				entry (ptr, ptr, fixed bin(35)),
	msa_manager_$area_handler	entry,
	release_system_msa_		entry (ptr, fixed bin(35)),
	system_info_$titles		entry (char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned);

     dcl						/*	static variables			*/
	False			bit(1) aligned int static options(constant) init ("0"b),
	True			bit(1) aligned int static options(constant) init ("1"b),
	comment (0:1)		char(28) varying int static options(constant) init (
				     "listed",
				     "flagged with an asterisk (*)"),
         (error_table_$noarg,
	error_table_$nomatch,
	error_table_$not_done,
	error_table_$out_of_bounds)	fixed bin(35) ext static,
	iox_$user_output		ptr ext static,
	ring (3)			fixed bin(3) int static init ((3)0),
	sys_info$time_of_bootload	fixed bin(71) ext static;
						/* iox_ opening mode for stream-output I/O.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Parg_struc = addr(arg_struc_temp);		/* Initialize argument processing structure.	*/
	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_cleanup";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 1;
	arg_struc.Larg_list = cu_$arg_count();
	arg_struc.put_error = com_err_;
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;


	Sc_allowed.descriptor     = True;		/* Mark Sc bits- show which ctl args allowed.	*/
	Sc_allowed.library        = True;
	Sc_allowed.search_names   = True;
	Sc_allowed.delete         = True;
	Sc_allowed.list           = True;
	Sc_allowed.long           = True;
	Sc_allowed.time           = True;

	Sc_init.time              = True;
	arg_struc.time = 7;				/* set default grace time of 7 days.		*/

	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;			/* call subr to process all arguments.		*/

	if arg_struc.time < 0 then go to BAD_TIME;

	Sc.default = True;				/* give user default output.			*/

	if Sc.long then Sc.list = True;		/* -long implies -list.			*/

	if ^Sc.list then if ^Sc.delete then Sc.list = True;
						/* -list is the default.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) establish cleanup on unit.						*/
	/* 2) get ptr to system multi-segment area.					*/
	/* 3) search and build status tree for library entries which are candidates for deletion.	*/
	/* 4) make a list of the entries found.						*/
	/* 5) initialize file control block.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Parea = null;
	Pprev_parent = null;
	unset_depth = 0;
	Pdelete = null;
	on cleanup call janitor;

	call get_system_msa_ (addr(Parea), 0, null);
	call condition_ ("area", msa_manager_$area_handler);

	Plibrary = addr(LIBRARY);
	Pstarname = addr(STARNAME);
	Pexclude = addr(EXCLUDE);
	call lib_descriptor_$cleanup (arg_struc.descriptor, Plibrary, Pstarname, Pexclude,
	     Srequirements, Scontrol, Parea, Ptree, progress, code);
	if code ^= 0 then go to BAD_SEARCH;

	allocate node_list in (area);
	node_list.I = 0;
	call lib_sort_tree_$make_node_list (Ptree, Pnode_list, code);
	if code ^= 0 then go to NO_MATCH; 

	Pfcb = addr(fcb_temp);
	fcb.version = Vfcb_1;
	fcb.ioname = "user_output";			/* print output on user's terminal.		*/
	fcb.Piocb = iox_$user_output;
	fcb.Eend_page = no_end_page;
	fcb.page_length = 131071;			/* use large page size to avoid footings.	*/
	fcb.page_text_length = 131071;
	fcb.page_no = 1;
	fcb.line_length = get_line_length_$switch (fcb.Piocb, code);
	if code ^= 0 then fcb.line_length = 79;
	fcb.line_no = 2;				/* prevent new_line from being suppressed before	*/
						/*   the first entry.  They're suppressed for 1st	*/
						/*   line of a page.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) Compute date on which grace period began.  It must be before time system came up.	*/
	/* 2) For each node in the list (nodes which are candidates for deletion):		*/
	/*    A) Set Svalid.delete on if node not modified within the grace period.		*/
	/*    B) If -list given, output the node in a numbered list, flagging those to be deleted.*/
	/* 3) If -delete given without -list, ask if user really wants to delete without listing.	*/
	/*    Abide by his decision.  If the answer is yes, proceed with step 5.		*/
	/* 4) Else if -delete given with -list, ask if user wants to delete flagged entries.	*/
	/*    If the answer is yes, proceed with step 5.					*/
	/*    If the answer is no,  then quit.						*/
	/* 5) Delete the list entries eligible for deletion.				*/
	/*    Only links, segments, directories, MSFs, MSF components and archives can be deleted.*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	Ngrace_begins = clock_() - (arg_struc.time * 86400000000);
						/* subtract grace (days * micro_sec/day) from now.*/
	Ngrace_begins = min (Ngrace_begins, sys_info$time_of_bootload);
						/* don't delete anything if someone could be using*/
						/*   it (ie, it was marked out of circulation 	*/
						/*   after system came up).			*/
	Bgrace_begins = substr(Ngrace_begins_bits,21,36);	

	Inode = 0;
	Idelete = 0;
	Pprev_parent = null;
	do i = 1 to node_list.I;
	     Pnode = node_list.e(i);
	     if node.dtem < Bgrace_begins then do;
 		Svalid.delete = True;
		Idelete = Idelete + 1;
		end;
	     else Svalid.delete = False;
	     if Sc.long | (Sc.list & Svalid.delete) then do;
		Inode = Inode + 1;
		call lib_output_node_$cleanup (Pfcb, Pnode, (72)"1"b, 0, Pstarname, Inode, Pprev_parent);
		Pprev_parent = node.Pparent;
		end;
	     end;
	if Inode > 0 then call ioa_ ("");

	if Idelete = 0 then do;
	     code = error_table_$nomatch;
	     go to NO_MATCH;
	     end;


	if Sc.delete then do;
	     query_info.version = 2;
	     query_info.yes_or_no_sw = True;
	     query_info.suppress_name_sw = False;
	     query_info.status_code = 0;
	     query_info.query_code = 0;
	     if ^Sc.list then do;
		call com_err_$suppress_name (0, arg_struc.program, "
  Grace Time:^-^5x^d days
  Descriptor:^-^5x^a", arg_struc.time,  arg_struc.descriptor);
		call lib_error_list_ ("library name", Plibrary, arg_struc.program);
		call lib_error_list_ ("search name", Pstarname, arg_struc.program);
		call command_query_ (addr(query_info), yes_no, arg_struc.program, "
  Given the information above, ^d library entries are eligible for deletion.
  Do you want to delete them?", Idelete);
		if yes_no = "no" then go to FINISH;
		end;
	     else do;
		call command_query_ (addr(query_info), yes_no, arg_struc.program, "
  Do you want to delete ALL of the ^d entries ^a above?", Idelete, comment (binary (Sc.long,1)));
		if yes_no = "no" then go to FINISH;
		end;
	     Pprev_parent = null;
	     do i = 1 to node_list.I;
		Pnode = node_list.e(i);
		if Svalid.delete then do;
		     Pdelete = Pnode;
		     call delete_entry (Pnode, Pprev_parent);
		     Pdelete = null;
		     Pprev_parent = node.Pparent;
		     end;
		end;
	     end;

FINISH:	call janitor;				/* clean up.				*/
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


delete_entry:	procedure (Pnode_, Pprev_parent);	/* internal procedure to delete a library entry.	*/

     dcl	Pnode_			ptr,		/* ptr to node for entry to be deleted.		*/
	Pprev_parent		ptr;		/* ptr to parent node for last node deleted.	*/

     dcl	1 node_			like node based (Pnode_);
		
		
	call lib_node_path_ (Pnode_, dir, ent);		/* get pathname of entry to be deleted.		*/

	if node_.T = Tarchive_comp then do;		/* cannot delete archive components.		*/
	     call com_err_ (error_table_$not_done, arg_struc.program, "
  Unable to delete archive components, such as
  ^a>^a", dir, ent);
	     end;
	else if node_.T = Tlink & node_.Pparent->node_.T ^= Tdirectory then do;
	     call com_err_ (error_table_$not_done, arg_struc.program, "
  Unable to unlink links which are the target of library links, such as
  ^a>^a.  Library links themselves may be unlinked.", dir, ent);
	     end;
	else do;
	     if Pprev_parent ^= node_.Pparent then do;	/* make sure user has access to delete entry.	*/
		if Pprev_parent ^= null then do;
		     call lib_access_mode_$unset (Pprev_parent, unset_depth, code);
		     if code ^= 0 then do;
			call lib_node_path_ (Pprev_parent, prev_dir, prev_ent);
			call com_err_ (code, arg_struc.program, "
  While restoring the ACL of the library ^a
  ^a>^a.", node_type(Pprev_parent->node_.T), prev_dir, prev_ent);
			end;
		     Pprev_parent = null;
		     end;
		call lib_access_mode_$set ((node_.Pparent), "110"b, unset_depth, code);
		if code ^= 0 then do;
		     call com_err_ (code, arg_struc.program, "
  Unable to obtain modify access to the library ^a
  ^a
  containing entries to be deleted.", node_type(node_.Pparent->node_.T), dir);
		     end;
		end;

	     if node_.T ^= Tlink then do;		/* take special precautions for non-links.	*/
		if ring(1) = 0 then ring = get_ring_();	/*     make sure entry is in our ring.		*/
		if node_.rb(1) < ring(1) then do;
		     call installation_tools_$set_ring_brackets ((dir), (ent), ring, code);
		     if code ^= 0 then
			call com_err_ (code, arg_struc.program, "
  Unable to set ring brackets on library ^a
  ^a>^a.", node_type(node_.T), dir, ent);
		     end;
		if node_.Ssafety then do;		/*     Turn off safety switch to ease deletion.	*/
		     call hcs_$set_safety_sw ((dir), (ent), "0"b, code);
		     if code ^= 0 then
			call com_err_ (code, arg_struc.program, "
  Unable to turn off safety switch of library ^a
  ^a>^a.", node_type(node_.T), dir, ent);
		     end;
		if node_.Scopy then do;		/*     Turn off copy switch to ease deletion.	*/
		     call hcs_$set_copysw ((dir), (ent), "0"b, code);
		     if code ^= 0 then
			call com_err_ (code, arg_struc.program, "
  Unable to turn off copy switch of library ^a
  ^a>^a.", node_type(node_.T), dir, ent);
		     end;
		end;

	     call delete_$path ((dir), (ent), "011110"b, (arg_struc.program), code);
	     if code ^= 0 then do;			/* delete the library entry.			*/
		call com_err_ (code, arg_struc.program, "
  Unable to delete library ^a
  ^a>^a", node_type(node_.T), dir, ent);
		if node_.Scopy then
		     call hcs_$set_copysw ((dir), (ent), "1"b, code);
		if node_.Ssafety then
		     call hcs_$set_safety_sw ((dir), (ent), "1"b, code);
		if node_.rb(1) < ring(1) then
		     call installation_tools_$set_ring_brackets ((dir), (ent), node_.rb, code);
		end;
	     end;
	end delete_entry;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


janitor:	procedure;				/* cleanup procedure.			*/

	if Pprev_parent ^= null then do;
	     call lib_access_mode_$unset (Pprev_parent, unset_depth, code);
	     Pprev_parent = null;
	     end;
	if Pdelete ^= null then do;
	     call lib_node_path_ (Pdelete, prev_dir, prev_ent);
	     call com_err_ (error_table_$not_done, arg_struc.program, "
  Cleanup occurred while deleting library ^a
  ^a>^a.
  This entry may not be completely deleted.  Those which follow
  it have not been deleted.", node_type(Pdelete->node.T), prev_dir, prev_ent);
	     end;
	if Parea ^= null then			/* cleanup by releasing any system MSA.		*/
	     call release_system_msa_ (addr(Parea), code);

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


no_end_page:	procedure;			/* This is a null end-of-page handling proc.	*/

	fcb.page_no = fcb.page_no + 1;
	fcb.line_no = 2;

	end no_end_page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


BAD_TIME:	call com_err_ (error_table_$out_of_bounds, arg_struc.program, "^d
  A positive grace period must be given.", arg_struc.time);
	return;

BAD_SEARCH:
	progress = min (progress, 7);
	go to BAD_S (progress);
BAD_S(0): call com_err_ (code, arg_struc.program, "^/  While calling lib_descriptor_$map.");
	go to FINISH;
BAD_S(1): call com_err_ (code, arg_struc.program, "^/  While finding the  '^R^a^B'  library descriptor.",
	     arg_struc.descriptor);
	go to FINISH;
BAD_S(2): call com_err_ (code, arg_struc.program,
	     "^/  Library descriptor  '^R^a^B'  does not implement^/  the ^a command.",
	     arg_struc.descriptor, arg_struc.program);
	go to FINISH;
BAD_S(3): state = "library";
	go to NO_DEFAULT_NAMES;
BAD_S(4): state = "search";
NO_DEFAULT_NAMES:
	call com_err_ (code, arg_struc.program,
	     "^/  No ^a names were specified, and the  '^R^a^B'
  library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state);
	go to FINISH;
BAD_S(5): call com_err_ (code, arg_struc.program, "^/  While allocating the root nodes of the library tree.");
	go to FINISH;
BAD_S(6):
NO_MATCH:	call com_err_ (code, arg_struc.program,
	     "^/  While searching for entries eligible for deletion in the library.^/  Descriptor:^-^5x^a",
	     arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	call lib_error_list_ ("search name", Pstarname, arg_struc.program);
	go to FINISH;
BAD_S(7):	call com_err_ (code, arg_struc.program, "^/  No libraries matching the library name(s) could be found.
  Descriptor:^-^5x^a", arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	go to FINISH;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_fcb_;

%include lib_list_;

%include lib_node_;

%include query_info_;


	end library_cleanup;




		    library_descriptor.pl1          02/15/84  0911.2rew 02/15/84  0750.0      115992



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

/* Modified:  January, 1984 by Jim Lippard to align structures passed to lib_args_			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


library_descriptor: lds: procedure;


     dcl						/*	automatic variables			*/
	Larg			fixed bin,	/* length of input argument.			*/
	Lkey			fixed bin,	/* length of function key.			*/
	Lret			fixed bin,	/* max length of active fnc return value.	*/
	Nargs			fixed bin,	/* number of input arguments.			*/
	Parg			ptr,		/* ptr to input argument.			*/
	Pkey			ptr,		/* ptr to function key.			*/
	Pret			ptr,		/* ptr to active function return value.		*/
	Scommand			bit(1) aligned,	/* on if invoked as a command.		*/
	Sunsupported		bit(1) unal,	/* on if library command is not supported by desc.*/
	1 arg_struc_temp		structure like arg_struc,
	command_name		char(32),		/* name of a library command.			*/
	code			fixed bin(35),	/* error code.				*/
	dir			char(168) varying,	/* dir part of library pathname.		*/
	ent			char(32) varying,	/* ent part of library pathname.		*/
	error			entry options(variable) variable,
						/* procedure to call to report errors to user.	*/
	1 fcb_temp		like fcb,		/* storage for file control block.		*/
	get_arg			entry (fixed bin, ptr, fixed bin, fixed bin(35)) variable,
						/* procedure to call to get next argument.	*/
	i			fixed bin,	/* function index; also, do-group index.	*/
	progress			fixed bin;	/* progress of lib_descriptor_ operations.	*/

     dcl						/*	based variables			*/
	arg			char(Larg) based (Parg),
						/* an input argument.			*/
	key			char(Lkey) based (Pkey),
						/* a function key.				*/
	ret			char(Lret) varying based (Pret);
						/* our active function return value.		*/

     dcl						/*	builtin functions & conditions	*/
         (addr, dimension, length, null)
				builtin,
	cleanup			condition;

     dcl						/*	entries called			*/
         (active_fnc_err_,
	com_err_)			entry options(variable),
	cu_$af_arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$af_return_arg 		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$arg_count		entry returns(fixed bin),
	cu_$arg_list_ptr		entry returns (ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns (fixed bin),
	get_system_free_area_	entry returns(ptr),
	ioa_			entry options(variable),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_array_list_		entry (char(32) varying, ptr, ptr),
	lib_descriptor_$default_values
				entry (char(168) varying, fixed bin, char(32), bit(1), ptr, ptr, ptr,
				       fixed bin, fixed bin(35)),
	lib_descriptor_$libraries	entry (char(168) varying, ptr, bit(72) aligned, ptr, ptr,
				       fixed bin, fixed bin(35)),
	lib_descriptor_$name	entry (char(168) varying),
	lib_descriptor_$set_name	entry (char(168) varying, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying),
	lib_free_node_$array	entry (ptr),
	lib_node_path_		entry (ptr, char(168) varying, char(32) varying),
	lib_output_node_$info	entry (ptr, ptr, bit(72) aligned, fixed bin, ptr);

     dcl						/*	static variables			*/
	False			bit(1) aligned int static options(constant) init ("0"b),
	Parea			ptr int static init (null),
	True			bit(1) aligned int static options(constant) init ("1"b),
	allowed_keys (9)		char(8) varying int static options(constant) init (
				     "name", "nm",
				     "set",
				     "pathname", "pn",
				     "default", "dft",
				     "root", "rt"),
	error_table_$bad_arg	fixed bin(35) ext static,
	error_table_$wrong_no_of_args	fixed bin(35) ext static,
	iox_$user_output		ptr ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */



	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;			/* invoked as an active function.		*/
	     Scommand = False;
	     error = active_fnc_err_;
	     get_arg = cu_$af_arg_ptr;
	     ret = "";
	     end;
	else do;					/* invoked as a command.			*/
	     Scommand = True;
	     error = com_err_;
	     get_arg = cu_$arg_ptr;
	     Nargs = cu_$arg_count();
	     end;

	if Nargs = 0 then go to GIVE_HELP;		/* user doesn't know what to do with this program.*/

	call get_arg (1, Pkey, Lkey, 0);		/* find out what we're doing, by getting key.	*/
	do i = 1 to dimension(allowed_keys,1) while (key ^= allowed_keys(i));
	     end;
	if i > dimension(allowed_keys,1) then go to GIVE_HELP_1;

	go to CHECK_AF(i);				/* check allowability of active function invoc.	*/

CHECK_AF(3):					/* set					*/
CHECK_AF(6):					/* default				*/
CHECK_AF(7):					/* dft					*/
CHECK_AF(8):					/* root					*/
CHECK_AF(9):					/* rt					*/
	if ^Scommand then go to INVALID_ACTIVE_FCN;
CHECK_AF(1):					/* name					*/
CHECK_AF(2):					/* nm					*/
CHECK_AF(4):					/* pathname				*/
CHECK_AF(5):					/* pn					*/
	Parg_struc = addr(arg_struc_temp);
	go to STEP_1(i);				/* perform function in steps.			*/

STEP_1(1):					/* name - has only 1 step.			*/
STEP_1(2):					/* nm					*/
	if Nargs > 1 then go to WRONG_NO_OF_ARGS;
	call lib_descriptor_$name (arg_struc.descriptor);
	if Scommand then
	     call ioa_ ("^2x^a^/", arg_struc.descriptor);
	else ret = arg_struc.descriptor;
	return;					/* have gotten name of current descriptor.	*/

STEP_1(3):					/* set - has only 1 step, too.		*/
	if Nargs > 2 then go to WRONG_NO_OF_ARGS;	/*   set name of default library descriptor.	*/
	if Nargs = 2 then do;
	     call get_arg (2, Parg, Larg, 0);
	     arg_struc.descriptor = arg;
	     end;
	else arg_struc.descriptor = "";		/*   return to initial default descriptor.	*/
	call lib_descriptor_$set_name (arg_struc.descriptor, code);
	if code ^= 0 then go to BAD_SET;
	return;

STEP_1(4):					/* pathname				*/
STEP_1(5):					/* pn					*/
STEP_1(6):					/* default				*/
STEP_1(7):					/* dft					*/
STEP_1(8):					/* root					*/
STEP_1(9):					/* rt					*/
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;
	go to STEP_2(i);

STEP_2(4):					/* pathname				*/
STEP_2(5):					/* pn					*/
	Sc_allowed.library = True;
	Sc_allowed.descriptor = True;
	Sc_init.library = True;
	LIBRARY.N = 1;
	LIBRARY.V(1) = "**";
	LIBRARY.C(1) = 2;
	go to DO_ARGS;
STEP_2(6):					/* default				*/
STEP_2(7):					/* dft					*/
	Sc_allowed.search_names = True;
	Sc_allowed.descriptor = True;
	go to DO_ARGS;
STEP_2(8):					/* root					*/
STEP_2(9):					/* rt					*/
	Sc_allowed.library = True;
	Sc_allowed.descriptor = True;
	Sreq_allowed.names = True;
	Sreq_allowed.matching_names = True;
	Sreq_allowed.primary_name = True;
	Sc_init.library = True;
	LIBRARY.N = 1;
	LIBRARY.V(1) = "**";
	LIBRARY.C(1) = 2;
	go to DO_ARGS;

DO_ARGS:	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_descriptor";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 2;
	arg_struc.Larg_list = Nargs;
	arg_struc.put_error = error;
	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;
	go to STEP_3(i);				/* This step does all the work.		*/

STEP_3(4):					/* pathname				*/
STEP_3(5):					/* pn					*/
	if Parea = null then Parea = get_system_free_area_();
	PDnodes = null;
	on cleanup call lib_free_node_$array (PDnodes);
	Plibrary = addr(LIBRARY);
	call lib_descriptor_$libraries (arg_struc.descriptor, Plibrary, Srequirements, Parea, PDnodes,
	     progress, code);
	if code ^= 0 then go to BAD_LIB;
	do i = 1 to Dnodes.N;
	     Pnode = addr(Dnodes.nodes(i));
	     call lib_node_path_ (Pnode, dir, ent);
	     if dir = ">" then
		dir = dir || ent;
	     else dir = dir || ">" || ent;
	     if Scommand then
		call ioa_ ("^2x^a", dir);
	     else do;
		if length(dir) + 1  >  Lret - length(ret) then return;
		ret = ret || dir;
		ret = ret || " ";
		end;
	     end;
	if Scommand then call ioa_ ("");
	else ret = substr(ret,1,length(ret)-1);
	call lib_free_node_$array (PDnodes);
	return;
 
STEP_3(6):					/* default				*/
STEP_3(7):					/* dft					*/
	if STARNAME.N = 0 then do;			/* list all command defaults.			*/
	     call lib_descriptor_$default_values (arg_struc.descriptor, 1, command_name, Sunsupported,
		Plibrary, Pstarname, Pexclude, progress, code);
	     if progress = 1 then go to BAD_DESCRIPTOR;
	     do i = 1 by 1 while (code = 0);
		call print_defaults ();
		call lib_descriptor_$default_values (arg_struc.descriptor, i+1, command_name, Sunsupported,
		     Plibrary, Pstarname, Pexclude, progress, code);
		end;
	     end;
	else do;
	     do i = 1 to STARNAME.N;
		command_name = STARNAME.V(i);
		call lib_descriptor_$default_values (arg_struc.descriptor, 0, command_name, Sunsupported,
		     Plibrary, Pstarname, Pexclude, progress, code);
		if progress = 0 then
		     call error (code, arg_struc.program, " Invalid library command:  ^a", STARNAME.V(i));
		else if progress = 1 then go to BAD_DESCRIPTOR;
		else call print_defaults ();
		end;
	     end;
	return;

print_defaults: procedure;				/* procedure to print command default values.	*/

	if Sunsupported then
	     call ioa_ ("unsupported command:  ^a", command_name);
	else do;
	     call ioa_ ("command:  ^a", command_name);
	     if library.N = 0 then
		call ioa_ ("^2xlibrary names:^-^5x(none)");
	     else call lib_array_list_ ("library name", Plibrary, iox_$user_output);
	     if starname.N = 0 then
		call ioa_ ("^2xsearch names:^-^5x(none)");
	     else call lib_array_list_ ("search name", Pstarname, iox_$user_output);
	     end;
	call ioa_ ("");

	end print_defaults;

STEP_3(8):					/* root					*/
STEP_3(9):					/* rt					*/
	if S.names | S.matching_names | S.primary_name then;
	else if LIBRARY.N = 1 & LIBRARY.C(1) = 2 then
	          S.primary_name = True;
	     else S.matching_names = True;
	S.type = True;
	S.pathname = True;
	S.root_search_proc = True;
	S.new_line = True;

	if Parea = null then Parea = get_system_free_area_();
	PDnodes = null;
	on cleanup call lib_free_node_$array (PDnodes);
	Plibrary = addr(LIBRARY);
	call lib_descriptor_$libraries (arg_struc.descriptor, Plibrary, Srequirements, Parea, PDnodes,
	     progress, code);
	if code ^= 0 then go to BAD_LIB;
	Pfcb = addr(fcb_temp);
	fcb.version = Vfcb_1;
	fcb.ioname = "user_output";
	fcb.Piocb = iox_$user_output;
	fcb.Eend_page = no_end_page;
	fcb.page_length = 131071;
	fcb.page_text_length = 131071;
	fcb.page_no = 1;
	fcb.line_length = get_line_length_$switch (fcb.Piocb, code);
	fcb.line_no = 2;
	do i = 1 to Dnodes.N;
	     Pnode = addr(Dnodes.nodes(i));
	     call lib_output_node_$info (addr(fcb), Pnode, Srequirements, 0, Plibrary);
	     end;
	call lib_free_node_$array (PDnodes);
	return;


no_end_page: procedure;

	end no_end_page;
 

GIVE_HELP:
	code = error_table_$wrong_no_of_args;
	Lkey = 0;
	Pkey = addr(Pkey);
	go to GIVE_HELP_;
GIVE_HELP_1:
	code = error_table_$bad_arg;
GIVE_HELP_:
	if Scommand then
	     call error (code, "library_descriptor", " ^a
  Calling sequence:	 lds  key  -args-
      where key is:  name (nm), set, pathname (pn), default (dft), root (rt)", key);
	else
	     call error (code, "library_descriptor", " ^a
  Calling sequence:  [lds  key -args-]
      where key is:  name (nm), or pathname (pn)", key);
	return;

INVALID_ACTIVE_FCN:
	call error (code, "library_descriptor", "
  'lds ^a'  may not be used as an active function.", key);
	return;

WRONG_NO_OF_ARGS:
	call error (error_table_$wrong_no_of_args, "library_descriptor", "
  Calling sequence:  lds ^a ^vs^a", key, i-1, "", "", "descriptor_name");
	return;

BAD_SET:	call error (code, "library_descriptor", "
  While setting the name of the default library descriptor to
  ^a.", arg_struc.descriptor);
	return;

BAD_LIB:	call error (code, "library_descriptor", "
  While obtaining information about the libraries.
  descriptor:	^a", arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	if PDnodes ^= null then call lib_free_node_$array (PDnodes);
	return;

BAD_DESCRIPTOR:
	call error (code, "library_descriptor", "
  While accessing library descriptor: ^a", arg_struc.descriptor);
	return;

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_fcb_;

%include lib_node_;


	end library_descriptor;




		    library_descriptor_compiler.rd  03/17/86  1520.9rew 03/17/86  1440.1      570960



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

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name:  library_descriptor_compiler, ldc					*/
	/*									*/
	/*      This command accepts as input a library descriptor source segment, and creates	*/
	/* as output an ALM segment which can be compiled into a binary data base which is a	*/
	/* library descriptor segment.  This data base is used by the library_info, library_map,	*/
	/* and library_print commands (among others), and is part of the Multics Library 	*/
	/* Maintenance System.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/* HISTORY COMMENTS:
  1) change(74-07-04,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 1.0--
      Created initial version of the program.
  2) change(75-02-28,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.0--
      Remove Global keywords; make root keyword more flexible;
      rename it to Root
  3) change(75-12-01,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 2.1--
      a) Change 'Define: default value;' stmt to 'Define: commands;'.
      b) Make commands unsupported unless named explicitly
         in 'Define:commands;' stmt.
      c) Accept the singular keywords, 'library name' and 'search name'.
  4) change(76-05-25,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 3.0--
      Reorganize name structures contained in library descriptor to put the
      names for each entity into a separate, self-defining structure.
  5) change(77-01-17,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 3.1--
      Insure that the ALM labels chosen to link root definitions with root
      names are unique for each root.
  6) change(84-09-08,GDixon), approve(), audit(),
     install(86-03-17,MR12.0-1032):
     Version 3.2--
      a) accommodate change to lex_string_ handling of quoted strings by adding
         the <null_string_name> relative syntax function to replace an absolute
         syntax function of "".
      b) add support for per-process date/time format in header comment of the
         compiled library descriptor.
  7) change(86-01-14,GDixon), approve(86-02-06,MCR7336),
     audit(86-02-11,Dickson), install(86-02-11,MR12.0-1015):
     Version 3.3--
      corrects a bug which prevents library root names from having
      more than two components.
                                                   END HISTORY COMMENTS */


/*++
BEGIN	/ Descriptor : <name> ;		/ LEX(2) [obj_desc.name = token_value] LEX(2)
					  descriptor_begin				/ descriptor_body \
	/ Descriptor			/ ERROR(1) descriptor_begin NEXT_STMT		/ BEGIN	\
	/ <no-token>			/ ERROR(2)				/ stop	\
	/ <any-token>			/ ERROR(3) descriptor_begin			/	\

descriptor_body
	/ Root :				/ LEX(2) root_begin PUSH(root_body)		/ names	\
	/ Root				/ ERROR(4) NEXT_STMT root_begin		/ root_body \
	/ Define : commands ;		/ [Icommand = 0] NEXT_STMT			/ command_block \
	/ Define : <any-token>		/ ERROR(7) NEXT_STMT			/ descriptor_body \
	/ Define				/ ERROR(1) NEXT_STMT			/ descriptor_body \
	/ End : <descriptor_name> ;		/ NEXT_STMT				/ end	\
	/ End : <name> ;			/ ERROR(6) NEXT_STMT			/ end	\
	/ End				/ ERROR(1) NEXT_STMT			/ end	\
	/ <any-token>			/ ERROR(8) NEXT_STMT			/ descriptor_body \
	/ <no-token>			/ ERROR(9) 				/ stop	\

names	/ ;				/             			LEX	/ STACK_POP \
	/ ( <valid_name>			/ new_element(Pfirst_name_elements) 	LEX	/ name_elements \
	/ ( <null_string_name>		/ new_element(Pfirst_name_elements)	LEX	/ name_elements \
	/   <valid_name>			/ set_name    			LEX	/ names	\
	/   <any-token>			/ ERROR(12)   			LEX	/ names	\
	/   <no-token>			/ ERROR(13)				/ stop	\

name_elements
	/ ) . ( <valid_name>		/ new_element(name_elements.Pnext)      LEX(3)	/ name_elements \
	/ ) . ( <null_string_name>		/ new_element(name_elements.Pnext)      LEX(3)	/ name_elements \
	/ )				/ combine_elements(Pfirst_name_elements,"")	
					  [Pname = addr(obj_root_name)]         LEX	/ names	\
	/ ;				/ combine_elements(Pfirst_name_elements,"") 
					  ERROR(11) [Pname = addr(obj_root_name)] LEX	/ STACK_POP \
	/       <valid_name>		/ set_element      			LEX	/ name_elements \
	/       <null_string_name>		/ set_element      			LEX	/ name_elements \
	/       <any-token>			/ ERROR(12)        			LEX	/ name_elements \
	/       <no-token>			/ ERROR(13)				/ stop	\

root_body	/ path : <absolute_pathname> ;	/ LEX(2) [obj_root.path = token_value] LEX(2)	/ root_body \
	/ path : <any-token> ;		/ ERROR(15) NEXT_STMT			/ root_body \
	/ path				/ ERROR(1) NEXT_STMT			/ root_body \
	/ type : archive ;			/ LEX(4) [obj_root.type = Tarchive]		/ root_body \
	/ type : directory ;		/ LEX(4)					/ root_body \
	/ type : <any-token>		/ LEX(2) ERROR(38) NEXT_STMT			/ root_body \
	/ type				/        ERROR(1)  NEXT_STMT			/ root_body \
	/ search procedure : <entryname> ;	/ LEX(3) [search_proc.ename = ename] 
					  LEX(2)					/ root_body \
	/ search procedure : <any-token> ;	/ ERROR(5) NEXT_STMT			/ root_body \
	/ search				/ ERROR(1) NEXT_STMT			/ root_body \
	/ <any-token>			/ root_end				/ descriptor_body \
	/ <no-token>			/ ERROR(9)				/ stop	\

command_block
	/ command : <command_name_> ;		/ LEX(4) [Scommand = "1"b] command_begin	/ default_value \
	/ unsupported command : <command_name_> ;
					/ LEX(5) [Scommand = "0"b] command_begin	/ command_block \
	/ library 			/ ERROR(35) NEXT_STMT			/ command_block \
	/ search	 			/ ERROR(36) NEXT_STMT			/ command_block \
	/ command : <any-token> ;		/ LEX(2) ERROR(25) NEXT_STMT			/ command_block \
	/ unsupported command : <any-token> ;	/ LEX(3) ERROR(25) NEXT_STMT			/ command_block \
	/ <any-token>			/ 					/ descriptor_body \
	/ <no-token>			/ ERROR(9)				/ stop	\

default_value
	/ library names :			/					/ library_names \
	/ library name :			/					/ library_names \
	/ search names :			/					/ search_names \
	/ search name :			/					/ search_names \
	/ <any-token>			/ command_end				/ command_block \
	/ <no-token>			/					/ command_block \
library_names
	/ 				/ [Pname = addr(obj_dflt_lib_names)]
					  [Pobj_star_code = addr(obj_dflt_lib_codes)]
					  LEX(3) PUSH(default_value)			/ starname \
search_names
	/ 				/ [Pname = addr(obj_dflt_search_names)]
					  [Pobj_star_code = addr(obj_dflt_search_codes)]
					  LEX(3) PUSH(default_value)			/ starname \

starnames	/ ;				/                            LEX		/ STACK_POP \
starname	/ <starname>			/ set_name set_obj_star_code LEX		/ starnames \
	/ ;				/ ERROR(10) 	         NEXT_STMT		/ STACK_POP \
	/ <any-token>			/ ERROR(12) 	         LEX		/ starnames \
	/ <no-token>			/ ERROR(13)				/ STACK_POP \

end	/ <no-token>			/					/ stop	\
	/ <any-token>			/ ERROR(17)				/ stop	\

stop	/ 				/ compile_descriptor			/ RETURN	\
											++*/

library_descriptor_compiler:
ldc:	procedure;

     dcl						/*	automatic variables			*/
	Icommand			fixed bin,	/* index of the command in command default values	*/
						/*    struc.				*/
	Larg			fixed bin,	/* length of an input argument.		*/
	Lin			fixed bin(21),	/* length of input segment (in chars).		*/
	Lout			fixed bin(21),	/* length of output segment (in chars).		*/
	Nargs			fixed bin,	/* number of input arguments.			*/
						/*   to definition of root just being parsed.	*/
	Pacl_out			ptr,		/* ptr to ACL struc for output segment.		*/
	Parg			ptr,		/* ptr to an input argument.			*/
	Pfirst_name_elements	ptr,		/* ptr to the first name elements structure.	*/
	Pin			ptr,		/* ptr to the input segment.			*/
	Pname			ptr,		/* ptr to the current name structure.		*/
						/*    the library names struc, when forming	*/
						/*    full names assoc with current root.	*/
	Pname_elements		ptr,		/* ptr to current name elements structure.	*/
	Pobj_dflt_lib_codes		ptr,		/* ptr to the object default library starcodes.	*/
	Pobj_dflt_lib_names		ptr,		/* ptr to the object default library names struc.	*/
	Pobj_dflt_search_codes	ptr,		/* ptr to the object default search starcodes.	*/
	Pobj_dflt_search_names	ptr,		/* ptr to the object default search names struc.	*/
	Pobj_root			ptr,		/* ptr to the current object root struc.	*/
	Pobj_root_array		ptr,		/* ptr to the object root struc.		*/
	Pobj_root_name		ptr,		/* ptr to the object root names struc.		*/
	Pobj_search_proc		ptr,		/* ptr to the object search procedure struc.	*/
	Pobj_star_code		ptr,		/* ptr to the current object star code struc.	*/
	Pout			ptr,		/* ptr to the output segment.			*/
	Ptemp_seg			ptr,		/* ptr to our temporary segment.		*/
	Scommand			bit(1) aligned,	/* switch: on if command indicated by Icommand is	*/
						/*    "supported" in object command default values*/
	Sreject_root		bit(1) aligned,	/* switch: on if root definition is to be rejected*/
	bc_in			fixed bin(24),	/* length of input segment (in bits).		*/
	cleanup			condition,
	code			fixed bin(35),	/* a status code.				*/
	compilation_date		char(52),		/* date/time output segment was compiled.	*/
	dir_in			char(168),	/* dir part of path name of input segment.	*/
	dir_out			char(168),	/* dir part of path name of output segment.	*/
	ent_in			char(32),		/* ent part of path name of input segment.	*/
	ent_out			char(32),		/* ent part of path name of output segment.	*/
	entry_point		char(70),		/* an ALM format entry point name.		*/
	entry_point_name		char(65) varying,	/* a PL/I format entry point name.		*/
	1 ename			aligned,		/* current entry point name.			*/
	  2 ref			char(32),		/*    reference name			*/
	  2 ent			char(32),		/*        entry name			*/
         (i, j, k)			fixed bin,	/* do-group indices.			*/

	1 obj_command_dflt_values (dimension (command_name,1))
				aligned,		/* object command default values structure.	*/
	  2 S			unaligned,	/*    switches:				*/
	    3 supported		bit(1),		/*       this command is supported.		*/
	  2 lib_names,				/*    library names to be used if none specified.	*/
	    3 Ifirst		fixed bin,
	    3 Ilast		fixed bin,	/*       indices of first/last name in table.	*/
	  2 search_names,				/*    search names to be used if none specified.	*/
	    3 Ifirst		fixed bin,
	    3 Ilast		fixed bin,
	1 obj_desc,				/* object descriptor.			*/
	  2 name			char(32) init ("default_descriptor"),
	path			char(168) aligned,	/* a path name temporary.			*/
	1 search_proc		aligned,		/* struc for the local search procedure.	*/
	  2 ename,
	    3 ref			char(32),		/*    reference name of search proc entry point.	*/
	    3 ent			char(32),		/*        entry name of search proc entry point.	*/
	starcode			fixed bin(35),	/* return code from check_star_name_$entry.	*/
	temp_name			char(32),		/* a name temporary.			*/
	temp_name30		char(30) varying;	/* another name temporary.			*/

     dcl						/*	based variables			*/
	arg			char(Larg) based (Parg),
						/* an input argument.			*/
	1 name			aligned based (Pname),
						/* the name structure.			*/
	  2 M			fixed bin,	/*    maximum number of names struc will hold.	*/
	  2 N			fixed bin,	/*    current number of names in struc.		*/
	  2 ERROR			fixed bin,	/*    error message to print when struc overflows.*/
	  2 V (0 refer (name.N))	char(32) varying aligned,
						/*    array of names.			*/
	1 name_elements		aligned based (Pname_elements),
						/* temp storage for elements of a compound name.	*/
	  2 header,
	    3 Pnext		ptr,		/*   ptr to next name element structure.	*/
	    3 M			fixed bin,	/*   maximum number of names struc will hold.	*/
	    3 N			fixed bin,	/*   current number of names in struc.		*/
	    3 ERROR		fixed bin,	/*   error message to print when struc overflows*/
	  2 V (50 refer (name_elements.N))
				char(32) varying,	/*   array of name elements.			*/
	1 obj_dflt_lib_codes	aligned based (Pobj_dflt_lib_codes),
						/* return codes from check_star_name_$entry for	*/
						/*    names on a 'library names' statement in a	*/
						/*    'Define: commands;' block.		*/
	  2 M			fixed bin,	/*    maximum no of codes structure will hold.	*/
	  2 N			fixed bin,	/*    current no of codes in structure.		*/
	  2 C (100 refer (obj_dflt_lib_codes.M))
				fixed bin,	/*    array of codes.			*/
	1 obj_dflt_lib_names	aligned based (Pobj_dflt_lib_names),
						/* names on a 'library names' statement in a	*/
						/*    'Define: commands;' block.		*/
	  2 M			fixed bin,	/*    maximum no of names structure will hold.	*/
	  2 N			fixed bin,	/*    current no of names in structure.		*/
	  2 ERROR			fixed bin,	/*    error message to print when struc overflows.*/
	  2 V (100 refer (obj_dflt_lib_names.M))
				char(32) varying,	/*    array of names.			*/

	1 obj_dflt_search_codes	aligned based (Pobj_dflt_search_codes),
						/* return codes from check_star_name_$entry for	*/
						/*    names on a 'search names' statement in a	*/
						/*    'Define: commands;' block.		*/
	  2 M			fixed bin,	/*    maximum no of codes structure will hold.	*/
	  2 N			fixed bin,	/*    current no of codes in structure.		*/
	  2 C (100 refer (obj_dflt_search_codes.M))
				fixed bin,	/*    array of codes.			*/
	1 obj_dflt_search_names	aligned based (Pobj_dflt_search_names),
						/* names on a 'search names' statement.		*/
	  2 M			fixed bin,	/*    maximum no of names structure will hold.	*/
	  2 N			fixed bin,	/*    current no of names in structure.		*/
	  2 ERROR			fixed bin,	/*    error message to print when struc overflows.*/
	  2 V (100 refer (obj_dflt_search_names.M))
				char(32) varying,	/*    array of names.			*/
	1 obj_root		aligned based (Pobj_root),
						/* object root definition structure.		*/
	  2 name,					/*    root names:				*/
	    3 Ifirst		fixed bin,	/*       index of first name in list.		*/
	    3 Ilast		fixed bin,	/*       index of last name in object root names.	*/
	    3 label		char(30) varying,	/*       ALM label used to reference root names.	*/
	  2 path			char(168) varying,	/*    path name of defined root.		*/
	  2 search_proc,				/*    entry point of procedure for searching root.*/
	    3 I			fixed bin,	/*       index of search procedure in obj table.	*/
	  2 type			fixed bin,	/*    root type.  2 = directory, 4 = archive	*/
	  2 Pstmt			ptr,		/*    ptr to root statement's descriptor.	*/
	1 obj_root_array		aligned based (Pobj_root_array),
						/* array of object root definition structures.	*/
	  2 M			fixed bin,	/*    maximum number of root definitions which	*/
						/*       the struc will hold.			*/
	  2 N			fixed bin,	/*    the current number of root definitions.	*/
	  2 obj_root (100 refer (obj_root_array.M))	/*    the root definition structures.		*/
				like obj_root,
	1 obj_root_name		aligned based (Pobj_root_name),
						/* full names of all of the roots defined so far.	*/
	  2 M			fixed bin,	/*    maximum number of names struc will hold.	*/
	  2 N			fixed bin,	/*    current number of names in structure.	*/
	  2 ERROR			fixed bin,	/*    error message to print when struc overflows.*/
	  2 V (5000 refer (obj_root_name.M))
				char(32) varying,	/*    array of names.			*/
	1 obj_search_proc		aligned based (Pobj_search_proc),
						/* entry points on the 'search procedure' stmt	*/
						/*    of a root definition.			*/
	  2 M			fixed bin,	/*    maximum no. of entry points struc will hold.*/
	  2 N			fixed bin,	/*    current no of entry points in struc.	*/
	  2 ename (30 refer (obj_search_proc.M)),	/*    array of entry point names.		*/
	    3 ref			char(32),		/*       reference name part of entry point name.	*/
	    3 ent			char(32),		/*       entry part of entry point name.	*/
	1 obj_star_code		aligned based (Pobj_star_code),
	  					/* the star code structure.			*/
	  2 M			fixed bin,	/*    maximum no of codes structure will hold.	*/
	  2 N			fixed bin,	/*    current no of codes in structure.		*/
	  2 C (0 refer (obj_star_code.N))
				fixed bin(35),	/*    array of codes.			*/
	out			char(Lout) based (Pout),
						/* overlay for the _r_e_m_a_i_n_d_e_r of the output segment*/
	stmt_array (stmt.Lvalue)	char(1) based (stmt.Pvalue),
						/* character array overlay for stmt_value.	*/
	stmt_part			char(j) based (stmt.Pvalue);
						/* partial overlay for stmt_value.		*/
 
     dcl (addr, addrel, dimension, divide, index, length, null, search, size, substr, verify)
				builtin;

     dcl						/*	entries				*/
	backup_name_		entry (char(*)) returns (char(32)),
	check_star_name_$entry	entry (char(*), fixed bin(35)),
	check_star_name_$path	entry (char(*), fixed bin(35)),
	clock_			entry returns (fixed bin(71)),
	com_err_			entry options(variable),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	date_time_$format		entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
	decode_entryname_		entry (char(*), char(32) aligned, char(32) aligned),
	expand_path_		entry (ptr, fixed bin, ptr, ptr, fixed bin(35)),
	get_wdir_			entry returns (char(168) aligned),
	hcs_$truncate_seg		entry (ptr, fixed bin, fixed bin(35)),
	initiate_file_		entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
	lex_string_$lex		entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*) aligned,
				       char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned, char(*) aligned varying, char(*) aligned varying,
				       char(*) aligned varying, char(*) aligned varying,
				       ptr, ptr, fixed bin(35)),
	lex_string_$init_lex_delims	entry (char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned, bit(*) aligned, char(*) aligned varying,
				       char(*) aligned varying, char(*) aligned varying,
				       char(*) aligned varying),
	lex_error_		entry options(variable),
	suffixed_name_$make		entry (char(*), char(*), char(32), fixed bin(35)),
	suffixed_name_$new_suffix	entry (char(*), char(*), char(*), char(32), fixed bin(35)),
	terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35)),
	translator_temp_$get_segment	entry (char(*), ptr, fixed bin(35)),
	translator_temp_$release_all_segments
				entry (ptr, fixed bin(35)),
	tssi_$clean_up_segment	entry (ptr),
	tssi_$finish_segment	entry (ptr, fixed bin(35), bit(36) aligned, ptr, fixed bin(35)),
	tssi_$get_segment		entry (char(*), char(*), ptr, ptr, fixed bin(35));

     dcl						/*	static variables			*/
	MLout			fixed bin(21) int static init (0),
						/* maximum length of an output segment (in chars).*/
	NL			char(1) int static options(constant) init ("
"),
	NP			char(1) int static options(constant) init (""),
						/* a new-page character.			*/
	breaks			char(7) varying aligned int static options(constant) init (" 	:()
"),							/* SP HT : ( ) NL NP			*/
						/* list of break characters.			*/
         (error_table_$badopt,
	error_table_$fatal_error,
	error_table_$noentry,
	error_table_$no_makeknown,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static,
	ignored_breaks		char(4) varying aligned int static options(constant) init (" 	
"),							/* SP HT NL NP				*/
						/* list of ignored break characters.		*/
	lex_control_chars		char(128) varying aligned int static,
	lex_delims		char(128) varying aligned int static init (""),
						/* lex_string_ control information.		*/
	proc			char(32) aligned int static options(constant)
				     init ("library_descriptor_compiler"),
	ring_no			pic "9" int static init(8),
						/* current ring number.			*/
	sys_info$max_seg_size	fixed bin(35) ext static;

     dcl	1 error_control_table (38)	aligned int static options(constant),
						/* error message text and specifications.	*/
	  /* 1     2     3     4     5     6     7     8     9    10    11    12    13    14    15	*/
	  /*16    17    18    19    20    21    22    23    24    25    26    27    28    29    30	*/
	  /*31    32    33    34    35    36    37    38    39    40    41    42    43    44    45	*/
	  2 severity		fixed bin(17) unaligned init (
	     2,    3,    1,    2,    2,    2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
	     2,    2,    2,    2,    4,    2,    2,    2,    2,    2,    4,    2,    2,    2,    2,
	     2,    3,    4,    4,    2,    2,    3,    2),
	  2 Soutput_stmt		bit(1) unaligned init (
	    "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b,
	    "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b,
	    "1"b, "0"b, "1"b, "0"b, "1"b, "1"b, "0"b, "1"b),
	  2 message		char(252) varying init (
	  /*  1 */
"A '^a' statement has an invalid format.  The statement has been
ignored.",
	  /*  2 */
"There are no statements in the library descriptor source segment.",
	  /*  3 */
"The first statement is not a 'Descriptor' statement.  A name of
default_descriptor has been assumed.",
	  /*  4 */
"A '^a' statement has an invalid format.  A ^a statement
without a name list has been assumed.",
	  /*  5 */
"An invalid entry name has been given in a '^a'
statement.  The statement has been ignored.",
	  /*  6 */
"The name used in the 'Descriptor' statement was not used in
the 'End' statement.  The proper name has been assumed.",
	  /*  7 */
"A 'Define' statement contains an invalid keyword.  Only
'Define: commands;' may be given.  The statement has been ignored.",
	  /*  8 */
"An unknown or misplaced statement has been encountered.
It has been ignored.",
	  /*  9 */
"The final 'End' statement is missing from the library descriptor
source.  One has been assumed.",
	  /* 10 */
"A name list ends when a name is expected.",
	  /* 11 */
"A Root name list ends when a right parenthesis ()) is expected.
The list will be processed as if the parenthesis were present.",
	  /* 12 */
"An invalid name, '^a', has been encountered in a name list.
It has been ignored.",
	  /* 13 */
"The library descriptor source ends in the middle of a statement.
Also, it does not end with an 'End' statement.",
	  /* 14 */
"An unexpected string, '^a', was found in a list when a comma (,),
or a semi-colon (;) was expected.  The remainder of the list
has been ignored.",
	  /* 15 */
"An invalid absolute path name was specified in a '^a' statement.
The statement will be ignored.",
	  /* 16 */
"",
	  /* 17 */
"Symbols appear after the 'End' statement.  These symbols
will be ignored.",
	  /* 18 */
"Restriction:  only ^d library names can be specified after
a 'Define: commands;' statement.  Name '^a' has been ignored.",
	  /* 19 */
"Restriction:  only ^d search names can be specified after
a 'Define: commands;' statement.  Search name '^a' has been ignored.",
	  /* 20 */
"Restriction:  the total number of library root names
cannot exceed ^d.  Name '^a' and all root names which
follow are in excess of this number.",
	  /* 21 */
"Restriction:  only ^d elements of a compound root name
may be defined.  Name element '^a' has been ignored.",
	  /* 22 */
"",
	  /* 23 */
"Restriction:  only ^d names can be defined for
the roots of the library.  Name '^a' has been ignored.",
	  /* 24 */
"",
	  /* 25 */
"'^a' is an invalid command name.  This statement has been
ignored.",
	  /* 26 */
"Restriction:  only ^d roots can be defined.  The following
root definition, and any which follow it, are in excess of
this number.",
	  /* 27 */
"No '^a' statement was given in the definition of a root.
The root definition has been ignored.",
 	  /* 28 */
"No '^a' statement was given in the definition of a root.
The definition has been ignored.",
	  /* 29 */
"A full root name is longer than 32 characters.  Full name
'^a' will be ignored.",
	  /* 30 */
"A full root name formed from a library name and a name on
the root statement has already been specified for another
root.  The name '^a' will be ignored.",
	  /* 31 */
"No legal full root names were defined for a root.  The root
definition will be ignored.",
	  /* 32 */
"The library descriptor source does not end with a complete
statement.",
	  /* 33 */
"Restriction: only ^d unique search procedures can be defined.
Search procedure '^a$^a' has been ignored.",
	  /* 34 */
"Restriction:  the library descriptor is too large, causing
the output segment to overflow.",
	  /* 35 */
"A 'library names' statement appears after a 'Define: commands;'
statement, but before a 'command' or 'unsupported command'
statement.  The 'library names' statement has been ignored.",
	  /* 36 */
"A 'search names' statement appears after a 'Define: commands;'
statement, but before a 'command' or 'unsupported command'
statement.  The 'search names' statement has been ignored.",
	  /* 37 */
"No legal root definitions appear in the library descriptor
source segment.",
	  /* 38 */
"An invalid root type '^a' appears in the 'type' statement
of a root definition.  A type of directory has been assumed."),
	  2 brief_message		char(40) varying init (
	  /*  1 */
"Bad '^a' stmt ignored.",
	  /*  2 */
"No source stmts.",
	  /*  3 */
"'Descriptor' stmt missing.",
	  /*  4 */
"Bad '^a' stmt.",
	  /*  5 */
"Bad entry name ignored.",
	  /*  6 */
"Bad name in 'End' stmt.",
	  /*  7 */
"Bad 'Define' keyword ignored.",
	  /*  8 */
"Bad stmt.",
	  /*  9 */
"'End' stmt missing.",
	  /* 10 */
"Name list ends too soon.",
	  /* 11 */
"Missing ) in name list.",
	  /* 12 */
"Bad name, '^a' ignored.",
	  /* 13 */
"Bad end of source.",
	  /* 14 */
"Bad '^a'.  List skipped.",
	  /* 15 */
"Bad absolute path ignored.",
	  /* 16 */
"",
	  /* 17 */
"Symbols after 'End' ignored.",
	  /* 18 - 24 */
(7)(1)">^d names.  '^a' ignored.",
	  /* 25 */
"Bad command name '^a' ignored.",
	  /* 26 */
">^d roots.  Roots ignored.",
	  /* 27 */
"Root '^a' missing.  Root ignored.",
	  /* 28 */
"Root '^a' missing.  Root ignored.",
	  /* 29 */
"Root name '^a' too long.",
	  /* 30 */
"Root name '^a' duplicated.",
	  /* 31 */
"No legal names.  Root ignored.",
	  /* 32 */
"Incomplete statement.",
	  /* 33 */
">^d search procs.  '^a$^a' ignored.",
	  /* 34 */
"Object segment overflow.",
	  /* 35 */
"Missing 'command' stmt.",
	  /* 36 */
"Missing 'command' stmt.",
	  /* 37 */
"No legal root definitions.",
	  /* 38 */
"Bad root type '^a'.  Directory assumed.");

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Nargs = cu_$arg_count();			/* complain if <1 or >2 arguments.		*/
	if Nargs < 1 then go to wnoa;
	if Nargs > 2 then go to wnoa;
	call cu_$arg_ptr (1, Parg, Larg, code);		/* get path name of input segment.		*/
	call expand_path_ (Parg, Larg, addr(dir_in), addr(ent_in), code);
	if code ^= 0 then go to bad_path;		/* expand path name to absolute form.		*/
	call suffixed_name_$make (ent_in, "ld", ent_in, code);
	if code ^= 0 then go to bad_input;		/* make sure entry name is properly suffixed.	*/
	call suffixed_name_$new_suffix (ent_in, "ld", "alm", ent_out, code);
	if code ^= 0 then go to bad_output_name;	/* insure name of output segment is suffixed OK.	*/
	dir_out = get_wdir_();			/* put output segment in working directory.	*/

	if Nargs > 1 then do;			/* process any control argument.		*/
	     call cu_$arg_ptr (2, Parg, Larg, code);
	     if arg = "-bf" then
		SERROR_CONTROL = "01"b;
	     else if arg = "-brief" then
		SERROR_CONTROL = "01"b;
	     else if arg = "-lg" then
		SERROR_CONTROL = "10"b;
	     else if arg = "-long" then
		SERROR_CONTROL = "10"b;
	     else
		go to badopt;
	     end;

	Ptemp_seg = null;				/* initialize pointers used by cleanup on unit.	*/
	Pin = null;
	Pout = null;
	on cleanup call cleaner;			/* cleanup temp seg, initiated segments when req'd*/

cleaner:	procedure;				/* This is a cleanup procedure.		*/
	if Ptemp_seg ^= null then
	     call translator_temp_$release_all_segments (Ptemp_seg, 0);
	if Pin ^= null then
	     call terminate_file_ (Pin, 0, TERM_FILE_TERM, 0);
						/* terminate source segment.			*/
	if Pout ^= null then			/* clean up out segment.			*/
	     call tssi_$clean_up_segment (Pacl_out);
	end cleaner;

          call initiate_file_ (dir_in, ent_in, R_ACCESS, Pin, bc_in, code);
	if Pin = null then go to bad_input;		/* initiate source segment.			*/
	Lin = divide (bc_in, 9, 35, 0);		/* convert bit count to char count.		*/
	call translator_temp_$get_segment ((proc), Ptemp_seg, code);
	if code ^= 0 then go to bad_area;

	call tssi_$get_segment (dir_out, ent_out, Pout, Pacl_out, code);
	if code ^= 0 then go to bad_output;		/* get ptr to output segment.			*/
	if MLout = 0 then				/* initialize limit on max. chars in output seg.	*/
	     MLout = sys_info$max_seg_size * 4;

	Pfirst_name_elements = null;
	Pstmt, Pthis_token = null;			/* start out with no input tokens.		*/
	if length(lex_delims) = 0 then		/* initialize static variables used by lex_string_*/
	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, breaks, ignored_breaks,
		lex_delims, lex_control_chars);
	call lex_string_$lex (Pin, Lin, 0, Ptemp_seg, "1000"b, """", """", "/*", "*/", ";",
	     breaks, ignored_breaks, lex_delims, lex_control_chars, null, Pthis_token, code);
	if code ^= 0 then call ERROR(32);		/* parse input into tokens.			*/
	if Pthis_token = null then go to RETURN;	/* a really fatal error occurred in parsing.	*/
	code = 0;					/* clear error code for use below.		*/
	call SEMANTIC_ANALYSIS();			/* This one call does all the work.		*/
RETURN:	if MERROR_SEVERITY > 2 then do;		/* Fatal error?  No output created.		*/
	     Lout = 0;
	     if code = 0 then
		code = error_table_$fatal_error;
	     end;
	if Lout = 0 then				/* error if output segment has zero length.	*/
	     call hcs_$truncate_seg (Pout, 0, 0);	/* even tho char count is zero, truncate to free	*/
						/* records used by output segment.		*/
	call tssi_$finish_segment (Pout, Lout * 9, "1000"b, Pacl_out, 0);
	Pout = null;				/* finish up now.				*/
	call cleaner;				/* clean up areas, initiated source.		*/
	if code ^= 0 then go to error;		/* report any errors to user.			*/
	return;					/* That's All Folks!			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

wnoa:	call com_err_ (error_table_$wrong_no_of_args, proc,
	     "^/Calling sequence:^-library_descriptor_compiler pathname -option-
where pathname is:^-the relative path name of the library descriptor source segment.
        option is:^--long | -lg | -brief | -bf");
	return;

badopt:	call com_err_ (error_table_$badopt, proc, arg);
	return;

bad_path:
	call com_err_ (code, proc, " ^R^a^B", arg);
	return;

bad_input:
	if code = error_table_$no_makeknown then code = error_table_$noentry;
	call com_err_ (code, proc, " ^R^a>^a^B", dir_in, ent_in);
	return;

bad_output_name:
	call suffixed_name_$new_suffix (ent_in, "ld", "", ent_out, 0);
	call com_err_ (code, proc, "^a.alm^/While creating the entry name for the output segment.", ent_out);
	return;

bad_output:
	call com_err_ (code, proc, "^/While creating the output segment (^R^a>^a>B).", dir_out, ent_out);
	call cleaner;
	return;

error:	call com_err_ (code, proc, "^/No output segment will be generated.");
	return;

bad_area:	call com_err_ (code, proc, "^/While creating a temporary segment in the process directory.");
	call cleaner;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	T  O  K  E  N     R  E  Q  U  I  R  E  M  E  N  T     F  U  N  C  T  I  O  N  S	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


absolute_pathname:	procedure returns (bit(1) aligned);	/* This token requirement function determines	*/
						/* whether the current token is an absolute path.	*/

     dcl (Igreater, Inext_greater, Lentryname)
				fixed bin;

	if token.Lvalue > 0 then
	     if token.Lvalue <= 168 then
		if search (token_value, "<") = 0 then
		     if substr (token_value,1,1) = ">" then do;
			Igreater = 1;
			do while (Igreater < token.Lvalue);
			     Inext_greater = index(substr(token_value,Igreater+1),">");
			     if Inext_greater = 0 then
			          Inext_greater = token.Lvalue - (Igreater - 1);
			     Lentryname = Inext_greater - 1;
			     if Lentryname = 0 then
			          go to reject;
			     if Lentryname > 32 then
			          go to reject;
			     Igreater = Igreater + Inext_greater;
			     end;
			call check_star_name_$path (token_value, code);
			if code = 0 then
			     return ("1"b);
			end;
reject:	return ("0"b);

	end absolute_pathname;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

command_name_:	procedure returns (bit(1) aligned);	/* This token requirement function checks that a	*/
						/* token names one of the library maintenance	*/
						/* commands (eg, those commands which can use the	*/
						/* library descriptor).			*/

     dcl	i 			fixed bin;	/* a do-group index.			*/

	do i = 1 to dimension (command_name,1) while (token_value ^= command_name(i));
	     end;					/* see if token matches a command name.		*/
	if i > dimension (command_name,1) then do;	/* if not, see about command name abbreviation.	*/
	     do i = 1 to dimension (command_abbrev,1) while (token_value ^= command_abbrev(i));
		end;
	     if i > dimension (command_abbrev,1) then
		return ("0"b);			/* no match.  Oh, well.			*/
	     end;
	Icommand = i;				/* save index of command for later use.		*/
	return ("1"b);

	end command_name_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


descriptor_name:	procedure returns (bit(1) aligned);	/* This token requirement function checks that the*/
						/* library descriptor name given in an 'End'	*/
						/* statement is the same as that given in a	*/
						/* 'Descriptor' statement.			*/
	if token_value = obj_desc.name then
	     return ("1"b);
	else
	     return ("0"b);

	end descriptor_name;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


entryname:	procedure returns (bit(1) aligned);	/* This token requirement function checks that	*/
						/* a reference to a procedure entry point has a	*/
						/* correct format.  Acceptable formats are:	*/
						/*    reference_name$entry_point_name		*/
						/*    reference_name (equivalent to		*/
						/*	reference_name$reference_name)	*/
						/* It decodes the input name into its two parts	*/
						/* and stores these in the ename structure.	*/

     dcl	Idollar			fixed bin;

	if token.Lvalue > 0 then
	     if token.Lvalue <= 65 then do;
		Idollar = index (token_value, "$");
		if Idollar = 0 then
		     Idollar = token.Lvalue;
		else
		     Idollar = Idollar - 1;
		if Idollar <= 32 then
		     if verify (substr(token_value,1,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
		     = 0 then
			if verify (token_value,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_$")
			= 0 then do;
			     call decode_entryname_ (token_value, ename.ref, ename.ent);
			     if ename.ent ^= "" then
				return("1"b);	/* exclude case of reference_name$		*/
			     end;
		end;
	return("0"b);

	end entryname;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


starname:	procedure returns (bit(1) aligned);		/* This token requirement function checks that a	*/
						/* token is a valid storage system entry name	*/
						/* which may be a star name.			*/
 	if token.Lvalue > 0 then
	     if token.Lvalue <= 32 then do;
		call check_star_name_$entry (token_value, starcode);
		if starcode = 0 then
		     return("1"b);
		if starcode = 1 then
		     return("1"b);
		if starcode = 2 then
		     return("1"b);
		end;				/* save starcode for use by set_obj_star_code.	*/
	return("0"b);

	end starname;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


valid_name:	procedure returns (bit(1) aligned);	/* This token requirement function checks that a	*/
						/* library name, library group name, or root	*/
						/* name is valid.				*/

	if token.Lvalue > 0 then
	     if token.Lvalue <= 32 then
		if search (token_value, "(),;<>*?%=") = 0 then
		     return("1"b);
	return("0"b);


null_string_name:
	entry returns(bit(1) aligned);
	
	if token.S.quoted_string &
	     token.Lvalue = 0 then
	          return("1"b);
	return("0"b);

	end valid_name;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*		  A  C  T  I  O  N        R  O  U  T  I  N  E  S			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


combine_elements:	procedure(Pname_elements_, name_sofar);	/* This action routine combines the sets of name	*/
						/*   elements from a compound root name into	*/
						/*   complete root names.			*/

     dcl	Pname_elements_		ptr,		/* ptr to name_elements structure at this level 	*/
						/*   of recursion.				*/
	name_sofar		char(100) varying,	/* part of a complete name constructed so far.	*/
	1 name_elements_		based(Pname_elements_),
	  2 header		like name_elements.header,
	  2 V (50 refer (name_elements_.N))
				char(32) varying,
						/* copy of name_elements structure based upon	*/
						/*   our input argument.			*/
	i			fixed bin,	/* a do-group index.			*/
	l			fixed bin;	/* length of name so far, on entrance.		*/

	l = length(name_sofar);			/* record original length of input for reuse later*/
	do i = 1 to name_elements_.N;			/* index through all names at this recursion level*/
	     if name_elements_.V(i) = "" then;		/*   use name_sofar if our name element is null.	*/
	     else if name_sofar = "" then		/*   use just our element if name_sofar is null.	*/
		name_sofar = name_elements_.V(i);
	     else name_sofar = name_sofar || "." || name_elements_.V(i);

	     if name_elements_.Pnext = null then do;	/* Case 1:  no additional element structures.	*/
add_name:						/* add the name to obj_root_name list.		*/
		if name_sofar = "" then;		/*   do nothing with complete names which are null*/
		else if length(name_sofar) > 32 then	/*   check for complete names which are too long.	*/
		     call lex_error_ (29, SERROR_PRINTED(29), (error_control_table(29).severity),
			MERROR_SEVERITY, obj_root.Pstmt, null, SERROR_CONTROL,
			(error_control_table(29).message), (error_control_table(29).brief_message),
			name_sofar);
		else if obj_root_name.N = obj_root_name.M then
		     call lex_error_ (obj_root_name.ERROR, SERROR_PRINTED(obj_root_name.ERROR),
			(error_control_table(obj_root_name.ERROR).severity), MERROR_SEVERITY,
			obj_root.Pstmt, null, SERROR_CONTROL,
			(error_control_table(obj_root_name.ERROR).message),
			(error_control_table(obj_root_name.ERROR).brief_message),
			obj_root_name.M, name_sofar);	/*   complain if obj_root_name list is full.	*/
		else do;
		     obj_root_name.N = obj_root_name.N + 1;
		     obj_root_name.V(obj_root_name.N) = name_sofar;
		     end;
		end;

	     else if name_elements_.Pnext -> name_elements_.N = 0 then
		go to add_name;			/* Case 2:  there is a next name element struc,	*/
						/*	    but no names in it.		*/
	     else					/* Case 3:  there are more element structures.	*/
		call combine_elements (name_elements_.Pnext, name_sofar);
	     name_sofar = substr(name_sofar,1,l);	/* reset to original value on input to this 	*/
	     end;					/*   level of the subroutine.			*/

	end combine_elements;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

command_begin:	procedure;			/* This action routine performs the prologue	*/
						/* functions necessary for defining command	*/
						/* default values.				*/

	obj_command_dflt_values(Icommand).S.supported = Scommand;
						/* record whether or not command is supported.	*/
	if Scommand then do;			/* if supported, initialize library name and	*/
						/* search name lists.			*/
	     obj_command_dflt_values(Icommand).lib_names.Ifirst = obj_dflt_lib_names.N + 1;
	     obj_command_dflt_values(Icommand).lib_names.Ilast = obj_dflt_lib_names.N;
	     obj_command_dflt_values(Icommand).search_names.Ifirst = obj_dflt_search_names.N + 1;
	     obj_command_dflt_values(Icommand).search_names.Ilast = obj_dflt_search_names.N;
	     end;

	end command_begin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


command_end:	procedure;			/* This action routine performs epilogue	*/
						/* functions necessary to complete the definition	*/
						/* of command default values.			*/

	if Icommand = 0 then			/* ignore bad definition block.		*/
	     return;
	obj_command_dflt_values(Icommand).lib_names.Ilast = obj_dflt_lib_names.N;
	obj_command_dflt_values(Icommand).search_names.Ilast = obj_dflt_search_names.N;
						/* set upper bounds of name lists.		*/

	end command_end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

compile_descriptor:	procedure;			/* This action routine converts the information	*/
						/* in the tables filled in by other action rtns	*/
						/* into ALM code which is written into the output	*/
						/* segment.				*/

	if obj_root_array.N = 0 then			/* don't generate output if no roots defined.	*/
	     call ERROR(37);
	if MERROR_SEVERITY > 2 then			/* don't go any further if a fatal error occurred.*/
	     return;
	Lout = MLout;				/* start out with an empty output segment	*/
						/*    (all of the segment remaining).		*/

						/* output header.				*/
	call OUT("
	""*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *""
	""*							*""
	""*  COMPILED OUTPUT FROM SEGMENT  ");
	call OUT(ent_in);
	call OUT("	*""
	""*  Compiled by:  library_descriptor_compiler,			*""
	""*		    Version 3.3 of January 14, 1986 		*""
	""*  Compiled on:  ");
	compilation_date = date_time_$format ("date_time", clock_(), "", "");
	call OUT(compilation_date);
	call OUT("*""
	""*     Refer to:  lib_descriptor_.incl.pl1			*""
	""*		    for a declaration of entries in this database *""
	""*							*""
	""*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *""");

						/* output name and descriptor segdef.		*/
	call OUT("

	name	");
	call OUT(obj_desc.name);
	call OUT("
	segdef	descriptor");

						/* output descriptor structure.		*/
	call OUT("

descriptor:					"" 1 descriptor,
	dec	   2				""   2 version,
	aci	""");
	call OUT(obj_desc.name);
	call OUT("""	""   2 name,
						""   2 command_default_values,
	vfd	18/0,18/command_default_values	""     3 O,");
	call OUT("
						""   2 roots,
	vfd	18/0,18/roots			""     3 O;");

						/* output command_default_values structure.	*/
	call OUT("
						"" ");
	call OUT(NP);
	call OUT("
	even
command_default_values:				"" 1 command_default_values,");
	call OUT ("
	dec	");
	call OUTN(dimension(command_name,1));
	call OUT ("				""   2 N,
						""   2 group (");
	call OUTVN (dimension(command_name,1));
	call OUT (")");
	do i = 1 to dimension(command_name,1);
	     call OUT(",
						""     3 S,/* (");
	     call OUTVN(i);
	     call OUT(": ");
	     call OUTV(command_name(i));
	     call OUT(") */
	oct	");
	     if obj_command_dflt_values(i).S.supported then
		call OUT("000000000000");
	     else
		call OUT("400000000000");
	     call OUT	("			""       4 unsupported,
						""     3 library_names,
	vfd	18/0,18/library_names_");
	     call OUTVN(i);
	     call OUT		("		""       4 O,
						""     3 search_names,
	vfd	18/0,18/search_names_");
	     call OUTVN (i);
	     call OUT		("		""       4 O");
	     end;
	call OUT(";");

						/* output default library names arrays.		*/
	call OUT("
						"" ");
	call OUT(NP);
	do i = 1 to dimension(command_name,1);
	     call OUT ("
	even
library_names_");
	     call OUTVN(i);
	     call OUT
	(":					"" ");
	     call OUTV(command_name(i));
	     call OUT ("
						"" 1 library_names,
	dec	");
	     j = obj_command_dflt_values(i).lib_names.Ilast -
	         obj_command_dflt_values(i).lib_names.Ifirst + 1;
	     call OUTVN (j);
	     call OUT ("				""   2 N,
						""   2 group (");
	     call OUTVN(j);
	     call OUT (")");
	     do j = obj_command_dflt_values(i).lib_names.Ifirst
	         to obj_command_dflt_values(i).lib_names.Ilast by 1;
		call OUT (",
	aci	""");
		temp_name = obj_dflt_lib_names.V(j);
		call OUT(temp_name);
		call OUT			("""	""     3 V,
	dec	");
		call OUTVN (obj_dflt_lib_codes.C(j));
		call OUT
		("				""     3 C");
		end;
	     call OUT (";
");
	     end;

						/* output default search names arrays.		*/
	call OUT("
						"" ");
	call OUT(NP);
	do i = 1 to dimension(command_name,1);
	     call OUT ("
	even
search_names_");
	     call OUTVN(i);
	     call OUT
	(":					"" ");
	     call OUTV(command_name(i));
	     call OUT ("
						"" 1 search_names,
	dec	");
	     j = obj_command_dflt_values(i).search_names.Ilast -
	         obj_command_dflt_values(i).search_names.Ifirst + 1;
	     call OUTVN (j);
	     call OUT ("				""   2 N,
						""   2 group (");
	     call OUTVN(j);
	     call OUT (")");
	     do j = obj_command_dflt_values(i).search_names.Ifirst
	         to obj_command_dflt_values(i).search_names.Ilast by 1;
		call OUT (",
	aci	""");
		temp_name = obj_dflt_search_names.V(j);
		call OUT(temp_name);
		call OUT			("""	""     3 V,
	dec	");
		call OUTVN (obj_dflt_search_codes.C(j));
		call OUT
		("				""     3 C");
		end;
	     call OUT (";
");
	     end;

						/* output root definition structure.		*/
	call OUT("
						"" ");
	call OUT(NP);
	call OUT("
	even
roots:						"" 1 roots,
	dec	");
	call OUTN (obj_root_array.N);
	call OUT ("				""   2 N,
						""   2 root (");
	call OUTVN (obj_root_array.N);
	call OUT(")");
	do i = 1 to obj_root_array.N;
	     call OUT(",
""
""	");
	     Pobj_root = addr(obj_root_array.obj_root(i));
	     Pstmt = obj_root.Pstmt;
	     j = index(stmt_value, NL);
	     do while (j > 0);
		call OUT (stmt_part);
		call OUT ("""	");
		stmt.Pvalue = addr(stmt_array(j+1));
		stmt.Lvalue = stmt.Lvalue - j;
		j = index (stmt_value, NL);
		end;
	     call OUT (stmt_value);
	     call OUT ("
	even					""          (");
	     call OUTVN(i);
	     call OUT(")
						""     3 name,
	vfd	18/0,18/.");
	     temp_name30 = "";			/* find a unique, 30 char root name to use as	*/
						/*   label on list of root names.		*/
	     do j = obj_root.name.Ifirst to obj_root.name.Ilast;
		if length(obj_root_name.V(j)) <= 30 then do;
		     temp_name30 = obj_root_name.V(j);	/*     save 1st possibility, in case none unique.	*/
		     do k = 1 to i-1;
			if obj_root_array.obj_root(k).name.label = obj_root_name.V(j) then go to NAME_DUP;
			end;
		     go to NAME_FOUND;
		     end;
NAME_DUP:		end;
	     if temp_name30 = "" then			/*    no names short enough.			*/
		temp_name30 = obj_root_name.V(obj_root.name.Ifirst);
	     do k = 1 to i-1;			/*    make chosen name unique.		*/
		if obj_root_array.obj_root(k).name.label = temp_name30 then do;
		     temp_name30 = substr(backup_name_ (":." || temp_name30),3);
		     temp_name30 = substr(temp_name30,1,length(temp_name30)+1-verify(reverse(temp_name30)," "));
		     end;
		end;
NAME_FOUND:    obj_root.name.label = temp_name30;
	     call OUTV(temp_name30);
	     call OUT ("
						""       4 O,
	dec	");
	     call OUTN(length(obj_root.path));
	     call OUT("				""     3 path,
	aci	""");
	     path = obj_root.path;			/* assign output path to fixed-length char string.*/
	     do j = 1 to 129 by 32;			/* output path name in 32 char ch.		*/
		call OUT(substr(path,j,32));
		call OUT("""
	aci	""");
		end;
	     call OUT(substr(path,161,8));
	     call OUT("""
	dec	");
	     call OUTN(obj_root.type);
	     call OUT("				""     3 type,
	dec	");
	     j = obj_root.search_proc.I;
	     entry_point = obj_search_proc.ename.ref(j);
	     entry_point_name = substr(entry_point,1,length(entry_point) + 1 - verify(reverse(entry_point)," "));
	     if obj_search_proc.ename.ent(j) ^= "" then do;
		entry_point_name = entry_point_name || "$";
		entry_point = obj_search_proc.ename.ent(j);
		entry_point_name = entry_point_name ||
		     substr(entry_point,1,length(entry_point) + 1 - verify(reverse(entry_point)," "));
		end;
	     call OUTN (length(entry_point_name));
	     call OUT ("				""     3 search_proc_name,
	aci	""");
	     entry_point = entry_point_name;
	     call OUT (substr(entry_point,1,68));
	     call OUT ("""
	even
	itp	bp,search_procs+(");
	     call OUTVN(obj_root.search_proc.I);
	     call OUT("*2)-*
	its	-1,1				""     3 search_proc");
	     end;
	call OUT(";");

						/* output root names arrays.			*/
	call OUT("
						"" ");
	call OUT(NP);
	do i = 1 to obj_root_array.N;
	     call OUT ("
	even
.");
	     Pobj_root = addr (obj_root_array.obj_root(i));
	     call OUTV (obj_root.name.label);
	     call OUT (":
						"" 1 root_names,
	dec	");
	     j = obj_root.name.Ilast - obj_root.name.Ifirst + 1;
	     call OUTVN (j);
	     call OUT ("				""   2 N,
						""   2 root_name (");
	     call OUTVN(j);
	     call OUT (");");
	     do j = obj_root.name.Ifirst to obj_root.name.Ilast by 1;
		call OUT ("
	aci	""");
		temp_name = obj_root_name.V(j);
		call OUT(temp_name);
		call OUT			("""");
		end;
	     end;


						/* output the search procedure transfer vector.	*/
	call OUT("
						"" ");
	call OUT(NP);
	call OUT("
	even
search_procs:					"" search procedure transfer vector
	dec	0
	dec	0");
	do i = 1 to obj_search_proc.N;
	     call OUT("
	getlp					""		/* (");
	     call OUTVN(i);
	     call OUT(") */
	tra	");
	     entry_point = obj_search_proc.ename.ref(i);
	     entry_point_name = "<" ||
		substr (entry_point,1,length(entry_point) + 1 - verify(reverse(entry_point)," ")) || ">";
	     if obj_search_proc.ename.ent(i) = "" then
		entry_point_name = entry_point_name || "|0";
	     else do;
		entry_point = obj_search_proc.ename.ent(i);
		entry_point_name = entry_point_name || "|[" ||
		     substr(entry_point,1,length(entry_point)+1-verify(reverse(entry_point)," ")) || "]";
		end;
	     call OUTV(entry_point_name);
	     end;

	call OUT("

	end
");

	Lout = MLout - Lout;			/* convert Lout to a count of _u_s_e_d chars in output*/

	end compile_descriptor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


descriptor_begin:	procedure;			/* This procedure performs prologue functions	*/
						/* for the library descriptor compiler.	 	*/

	Pobj_dflt_lib_codes = allocate(Ptemp_seg, size(obj_dflt_lib_codes));
	obj_dflt_lib_codes.M = 100;
	Pobj_dflt_search_codes = allocate(Ptemp_seg, size(obj_dflt_search_codes));
	obj_dflt_search_codes.M = 100;
	Pobj_dflt_lib_names = allocate(Ptemp_seg, size(obj_dflt_lib_names));
	obj_dflt_lib_names.M = 100;
	Pobj_dflt_search_names = allocate(Ptemp_seg, size(obj_dflt_search_names));
	obj_dflt_search_names.M = 100;
	Pobj_root_name = allocate(Ptemp_seg, size(obj_root_name));
	obj_root_name.M = 5000;
	Pobj_root_array = allocate(Ptemp_seg, size(obj_root_array));
	obj_root_array.M = 100;
	Pobj_search_proc = allocate(Ptemp_seg, size(obj_search_proc));
	obj_search_proc.M = 30;

	obj_dflt_lib_codes.N = 0;			/* initialize star code structures.		*/
	obj_dflt_search_codes.N = 0;

	Pname_elements = null;			/* initialize name structures.		*/
	obj_dflt_lib_names.N = 0;
	obj_dflt_lib_names.ERROR = 18;
	obj_dflt_search_names.N = 0;
	obj_dflt_search_names.ERROR = 19;
	obj_root_name.N = 0;

	obj_root_array.N = 0;			/* initialize the array of object roots.	*/
	obj_search_proc.N = 0;			/* initialize the array of search procedures.	*/

	do i = 1 to dimension (obj_command_dflt_values,1);/* initialize command defaults structure.	*/
	     obj_command_dflt_values(i).S.supported = "0"b;
	     obj_command_dflt_values(i).lib_names.Ifirst = 0;
	     obj_command_dflt_values(i).lib_names.Ilast = -1;
	     obj_command_dflt_values(i).search_names.Ifirst = 0;
	     obj_command_dflt_values(i).search_names.Ilast = -1;
	     end;

	end descriptor_begin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */



new_element:	procedure(Pname_elements_next);	/* This action routine gets space for the next	*/
						/*   set of name elements in a compound name.	*/

     dcl	Pname_elements_next		ptr,		/* Pointer to the next name_elements structure.	*/
	1 name_elements_next	based(Pname_elements_next),
	  2 header		like name_elements.header,
	  2 V (50 refer (name_elements_next.N))
				char(32) varying;

	if Pname_elements_next = null then do;		/* If no next structure has been allocated, do it.*/
	     Pname_elements_next = allocate(Ptemp_seg, size(name_elements_next));
	     name_elements_next.M = 50;
	     name_elements_next.ERROR = 21;
	     name_elements_next.Pnext = null;
	     end;
	name_elements_next.N = 0;			/* there are no names in this new list yet.	*/
	if name_elements_next.Pnext^= null then		/* initialize next next name_elements strucuture	*/
	     name_elements_next.Pnext -> name_elements_next.N = 0;
						/*   if any.				*/
	Pname_elements = addr(name_elements_next);	/* set current name_elements structure to one we	*/
						/*   just allocated.			*/
	Pname = addr(name_elements_next.M);		/* set set_elements structure pointer to next	*/
						/*   name_elements_next structure.			*/
	end new_element;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

root_begin:	procedure;			/* This action routine performs prologue functions*/
						/* necessary prior to defining a new root.	*/

	if obj_root_array.N = obj_root_array.M then do;	/* complain if no more roots can be defined.	*/
	     call lex_error_ (26, SERROR_PRINTED(26), (error_control_table(26).severity), MERROR_SEVERITY,
		obj_root.Pstmt, null, SERROR_CONTROL, (error_control_table(26).message),
		(error_control_table(26).brief_message), obj_root_array.M);
	     go to RETURN;
	     end;
	obj_root_array.N = obj_root_array.N + 1;	/* address the next root.			*/
	Pobj_root = addr(obj_root_array.obj_root(obj_root_array.N));

	obj_root.path = "";				/* initialize the root.			*/
	search_proc.ename.ref = "";
	search_proc.ename.ent = "";
	obj_root.search_proc.I = 0;

	obj_root.type = Tdirectory;			/* assume root is a directory, by default.	*/
	obj_root.Pstmt = token.Pstmt;			/* save pointer to root's statement descriptor.	*/
						/* This will be used in error messages.		*/

	Pname = addr(obj_root_name);
	obj_root.name.Ifirst = obj_root_name.N+1;	/* save index of first name for this root.	*/

	end root_begin;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


root_end:	procedure;				/* This action routine perform epilogue functions	*/
						/* necessary to defining a root.		*/
						/* Steps include:  insuring that definition is	*/
						/* consistent and complete;  applying defaults to	*/
						/* unspecified values;  constructing the root's	*/
						/* list of full names.			*/

	Sreject_root = "0"b;
	if obj_root.path = "" then do;		/* complain if path name unspecified.		*/
	     call lex_error_ (27, SERROR_PRINTED(27), (error_control_table(27).severity), MERROR_SEVERITY,
		obj_root.Pstmt, null, SERROR_CONTROL, (error_control_table(27).message),
		(error_control_table(27).brief_message), "path");
	     Sreject_root = "1"b;
	     end;
	if search_proc.ename.ref = "" then do;	/* complain if search procedure unspecified.	*/
	     call lex_error_ (27, SERROR_PRINTED(27), (error_control_table(27).severity), MERROR_SEVERITY,
		obj_root.Pstmt, null, SERROR_CONTROL, (error_control_table(27).message),
		(error_control_table(27).brief_message), "search procedure");
	     Sreject_root = "1"b;
	     end;

	do i = 1 to obj_search_proc.N;		/* add search procedure to table.		*/
	     if search_proc.ename.ref = obj_search_proc.ename(i).ref then
		if search_proc.ename.ent = obj_search_proc.ename(i).ent then
		     go to already_there;
	     end;
	if i > obj_search_proc.M then do;		/* complain if the table is full.		*/
	     call lex_error_ (33, SERROR_PRINTED(33), (error_control_table(33).severity), MERROR_SEVERITY,
		obj_root.Pstmt, null, SERROR_CONTROL, (error_control_table(33).message),
		(error_control_table(33).brief_message), obj_search_proc.M, search_proc.ename.ref,
		search_proc.ename.ent);
	     go to RETURN;
	     end;
	obj_search_proc.N = i;
	obj_search_proc.ename(i) = search_proc.ename;
already_there:
	obj_root.search_proc.I = i;			/* fill table index into root structure.	*/

	obj_root.name.Ilast = obj_root_name.N;		/* set upper bound on root's name list.		*/
	if obj_root.name.Ifirst > obj_root.name.Ilast then do;
			   			/* complain if no legal names found for root.	*/
	     call lex_error_ (31, SERROR_PRINTED(31), (error_control_table(31).severity), MERROR_SEVERITY,
		obj_root.Pstmt, null, SERROR_CONTROL, (error_control_table(31).message),
		(error_control_table(31).brief_message));
	     Sreject_root = "1"b;
	     end;

	if Sreject_root then do;			/* some error requires that we reject this root.	*/
	     obj_root_name.N = obj_root.name.Ifirst - 1;	/* ignore any root names which were defined.	*/
	     obj_root_array.N = obj_root_array.N - 1;	/* ignore the root.				*/
	     end;

	end root_end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set_element:
set_name:	procedure;				/* This action routine adds a name to the current	*/
						/* name list.				*/

	if name.N = name.M then			/* make sure there is room for another name.	*/
	     call lex_error_ (name.ERROR, SERROR_PRINTED(name.ERROR), (error_control_table(name.ERROR).severity),
		MERROR_SEVERITY, addrel(token.Pstmt,0), null, SERROR_CONTROL,
		(error_control_table(name.ERROR).message), (error_control_table(name.ERROR).brief_message),
		name.M, token_value);
	else do;
	     name.N = name.N + 1;
	     name.V(name.N) = token_value;		/* add name to the table.			*/
	     end;

	end set_name;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set_obj_star_code:	procedure;			/* This action routine adds a starcode to the	*/
						/* current starcode list.			*/

	if obj_star_code.N = obj_star_code.M then;	/* list full; message already printed by set_name.*/
	else do;
	     obj_star_code.N = obj_star_code.N + 1;
	     obj_star_code.C(obj_star_code.N) = starcode;
	     end;

	end set_obj_star_code;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*		  O  U  T  P  U  T        R  O  U  T  I  N  E  S			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


OUT:	procedure (value);				/* This procedure outputs a character string into	*/
						/* the output segment.			*/

     dcl	value			char(*);		/* character string to be output.		*/

	if length(value) > Lout then do;		/* if no room for string in output seg, quit.	*/
	     call ERROR(34);
	     go to RETURN;
	     end;
	substr (out, 1, length(value)) = value;
	Pout = addr (substr (out, length(value)+1));
	Lout = Lout - length(value);

	end OUT;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


OUTV:	procedure (value);				/* This procedure outputs a character string into	*/
						/* the output segment.			*/

     dcl	value			char(*) varying;	/* character string to be output.		*/

	if length(value) > Lout then do;		/* if no room for string in output seg, quit.	*/
	     call ERROR(34);
	     go to RETURN;
	     end;
	substr (out, 1, length(value)) = value;
	Pout = addr (substr (out, length(value)+1));
	Lout = Lout - length(value);

	end OUTV;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


OUTN:	procedure (N);				/* This procedure outputs a number into the	*/
						/* output segment.				*/

     dcl	N			fixed bin,	/* Number to be output.			*/
	Nchar			pic "---9";	/* character string representation of the number.	*/

	Nchar = N;
	if length(Nchar) > Lout then do;		/* make sure number will fit in output segment.	*/
	     call ERROR(34);
	     go to RETURN;
	     end;
	substr (out, 1, length(Nchar)) = Nchar;
	Pout = addr (substr (out, length(Nchar)+1));
	Lout = Lout - length(Nchar);

	end OUTN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

OUTVN:	procedure(N);				/* This procedure outputs a number, stripped of 	*/
						/* any leading spaces, into the output segment.	*/

     dcl	N			fixed bin,	/* number to be output.			*/
	Nchar			pic "---9",	/* character string representation of the number.	*/
	Isignificant		fixed bin;	/* index of first significant character of number.*/

	Nchar = N;				/* convert number to character representation.	*/
	Isignificant = verify (Nchar," ");		/* get index of first significant character.	*/
	call OUT(substr(Nchar,Isignificant));		/* output significant digits of the number.	*/

	end OUTVN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


%include translator_temp_alloc;

%include access_mode_values;

%include lib_descriptor_;

%include lib_node_;

%include terminate_file;




		    library_fetch.pl1               09/25/84  1155.7rew 09/25/84  1154.5       55530



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

/* Modified October 26, 1983 by Jim Lippard to add -first_match (-fmch) and -all_matches (-amch)		*/
/* Modified March 5, 1984 by Jim Lippard to assume -all_matches if more than one searchname or any starnames	*/
/*    are supplied										*/
/* Modified June 13, 1984 by Jim Lippard to assume -amch if -components is specified			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


library_fetch: lf:	procedure;

     dcl						/*	automatic variables			*/
	1 arg_struc_temp		like arg_struc,	/* storage for argument structure.		*/
	code			fixed bin(35);	/* a status code.				*/

     dcl 	addr			builtin;

     dcl						/*	Entries Called			*/
	com_err_			entry options(variable),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_list_ptr		entry returns(ptr),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_fetch_		entry (ptr, ptr, ptr, bit(72) aligned, bit(36) aligned, ptr, fixed bin(35));

     dcl						/*	static variables			*/
	True			bit(1) aligned int static options(constant) init ("1"b),
	False			bit(1) aligned int static options(constant) init ("0"b);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Parg_struc = addr(arg_struc_temp);		/* Initialize argument processing structure.	*/
	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_fetch";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 1;
	arg_struc.Larg_list = cu_$arg_count();
	arg_struc.put_error = com_err_;
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;

	Sreq_allowed.access_class        = True;	/* Mark Sreq bits-  show which output args allowed*/
	Sreq_allowed.acl                 = True;
	Sreq_allowed.aim                 = True;
	Sreq_allowed.author              = True;
	Sreq_allowed.bit_count           = True;
	Sreq_allowed.bit_count_author    = True;
	Sreq_allowed.compiler_name       = True;
	Sreq_allowed.compiler_options    = True;
	Sreq_allowed.compiler_version    = True;
	Sreq_allowed.copy                = True;
	Sreq_allowed.current_length      = True;
	Sreq_allowed.dtc                 = True;
	Sreq_allowed.dtd                 = True;
	Sreq_allowed.dtem                = True;
	Sreq_allowed.dtm                 = True;
	Sreq_allowed.dtu                 = True;
	Sreq_allowed.entry_bound         = True;
	Sreq_allowed.iacl                = True;
	Sreq_allowed.kids                = True;
	Sreq_allowed.kids_error          = True;
	Sreq_allowed.level               = True;
	Sreq_allowed.link_target         = True;
	Sreq_allowed.lvid                = True;
	Sreq_allowed.matching_names      = True;
	Sreq_allowed.max_length          = True;
	Sreq_allowed.mode                = True;
	Sreq_allowed.msf_indicator       = True;
	Sreq_allowed.names               = True;
	Sreq_allowed.new_line            = True;
	Sreq_allowed.not_ascii           = True;
	Sreq_allowed.object_info         = True;
	Sreq_allowed.offset              = True;
	Sreq_allowed.pathname            = True;
	Sreq_allowed.primary_name        = True;
	Sreq_allowed.pvid                = True;
	Sreq_allowed.quota               = True;
	Sreq_allowed.rb                  = True;
	Sreq_allowed.records_used        = True;
	Sreq_allowed.root_search_proc    = True;
	Sreq_allowed.safety              = True;
	Sreq_allowed.type                = True;
	Sreq_allowed.unique_id           = True;
	Sreq_allowed.user                = True;



	Sreq_init.user		   = True;	/* Mark bits on by default.			*/

	Sc_allowed.acl            = True;		/* Mark Sc bits- show which ctl args allowed.	*/
	Sc_allowed.all_status     = True;
	Sc_allowed.chase          = True;
	Sc_allowed.check_archive  = True;
	Sc_allowed.check_ascii    = True;
	Sc_allowed.components     = True;
	Sc_allowed.container      = True;
	Sc_allowed.default        = True;
	Sc_allowed.iacl           = True;
	Sc_allowed.object_info    = True;
	Sc_allowed.quota          = True;
	Sc_allowed.retain         = True;
	Sc_allowed.descriptor     = True;
	Sc_allowed.into_path      = True;
	Sc_allowed.long           = True;
	Sc_allowed.library        = True;
	Sc_allowed.output_file    = True;
	Sc_allowed.search_names   = True;
	Sc_allowed.first_match    = True;

	Sc_init.into_path 	      = True;		/* Mark bits for ctl args supplied by default.	*/
	arg_struc.into_path = "==";
	Sc_init.default           = True;
	Sc_init.first_match       = True;

	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;			/* call subr to process all arguments.		*/
						/*   errors are reported by lib_args_.		*/

	if ^Sc.default & ^S.names & ^S.matching_names & ^S.primary_name then
	     S.matching_names = True;			/* use matching names by default.		*/

	/* the following code does not work for a descriptor with default search names			*/
	if STARNAME.N > 1 then Sc.first_match = False;	/* get all matches if more than one search name	*/
	else if STARNAME.N = 1 then
	     if STARNAME.C (1) ^= 0 then Sc.first_match = False; /* get all matches if it's a starname	*/
	else if Sc.components then Sc.first_match = False; /* or if -components */

	call lib_fetch_ (addr(LIBRARY), addr(STARNAME), addr(EXCLUDE), Srequirements, Scontrol,
	     addr(arg_struc), code);
	return;					/* errors reported by lib_fetch_.		*/

%include lib_arg_struc_;

%include lib_Svalid_req_;

%include lib_Scontrol_;


	end library_fetch;




		    library_info.pl1                02/15/84  0911.2rew 02/15/84  0750.0      109746



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

/* Modified:  January, 1984 by Jim Lippard to align structures passed to lib_args_			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


library_info: li:	procedure
		options	(rename ((alloc_, smart_alloc_)));

     dcl						/*	automatic variables			*/
	Parea			ptr,		/* ptr to an MSA.				*/
	Ptree			ptr,		/* ptr to a tree of status nodes.		*/
	1 arg_struc_temp		like arg_struc,	/* storage for argument structure.		*/
	code			fixed bin(35),	/* a status code.				*/
	1 fcb_temp		like fcb,		/* storage for file control block.		*/
	progress			fixed bin init (0),	/* integer indicating progress of our search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_info command supported	*/
						/*       by this descriptor.			*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	state			char(16);		/* an error temporary char string.		*/

     dcl						/* 	based variables			*/
	area			area based (Parea);	/* an MSA (multi-segment area).		*/

     dcl (addr, divide, length, min, null, reverse, substr, verify)
				builtin;
     dcl	cleanup			condition;

     dcl						/*	Entries Called			*/
	com_err_			entry options(variable),
	condition_		entry (char(*) aligned, entry),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_list_ptr		entry returns(ptr),
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns (fixed bin),
	get_system_msa_		entry (ptr, fixed bin, ptr),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_descriptor_$info	entry (char(168) varying, ptr, ptr, ptr, bit(72) aligned,  bit(36) aligned,
				       ptr, ptr, fixed bin, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying),
	lib_output_node_list_$info	entry (ptr, ptr, ptr, ptr, char(45) varying, bit(72) aligned, ptr),
	lib_sort_tree_$make_name_list
				entry (ptr, ptr, ptr, ptr, fixed bin(35)),
	lib_sort_tree_$name_list	entry (ptr, ptr),
	msa_manager_$area_handler	entry,
	release_system_msa_		entry (ptr, fixed bin(35));

     dcl						/*	static variables			*/
	True			bit(1) aligned int static options(constant) init ("1"b),
          error_table_$noarg		fixed bin(35) ext static,
	iox_$user_output		ptr ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Parg_struc = addr(arg_struc_temp);		/* Initialize argument processing structure.	*/
	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_info";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 1;
	arg_struc.Larg_list = cu_$arg_count();
	arg_struc.put_error = com_err_;
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;

	Sreq_allowed.access_class        = True;	/* Mark Sreq bits-  show which output args allowed*/
	Sreq_allowed.acl                 = True;
	Sreq_allowed.aim                 = True;
	Sreq_allowed.author              = True;
	Sreq_allowed.bit_count           = True;
	Sreq_allowed.bit_count_author    = True;
	Sreq_allowed.compiler_name       = True;
	Sreq_allowed.compiler_options    = True;
	Sreq_allowed.compiler_version    = True;
	Sreq_allowed.copy                = True;
	Sreq_allowed.current_length      = True;
	Sreq_allowed.dtc                 = True;
	Sreq_allowed.dtd                 = True;
	Sreq_allowed.dtem                = True;
	Sreq_allowed.dtm                 = True;
	Sreq_allowed.dtu                 = True;
	Sreq_allowed.entry_bound         = True;
	Sreq_allowed.iacl                = True;
	Sreq_allowed.kids                = True;
	Sreq_allowed.kids_error          = True;
	Sreq_allowed.level               = True;
	Sreq_allowed.link_target         = True;
	Sreq_allowed.lvid                = True;
	Sreq_allowed.matching_names      = True;
	Sreq_allowed.max_length          = True;
	Sreq_allowed.mode                = True;
	Sreq_allowed.msf_indicator       = True;
	Sreq_allowed.names               = True;
	Sreq_allowed.new_line            = True;
	Sreq_allowed.not_ascii           = True;
	Sreq_allowed.object_info         = True;
	Sreq_allowed.offset              = True;
	Sreq_allowed.pathname            = True;
	Sreq_allowed.primary_name        = True;
	Sreq_allowed.pvid                = True;
	Sreq_allowed.quota               = True;
	Sreq_allowed.rb                  = True;
	Sreq_allowed.records_used        = True;
	Sreq_allowed.root_search_proc    = True;
	Sreq_allowed.safety              = True;
	Sreq_allowed.type                = True;
	Sreq_allowed.unique_id           = True;
	Sreq_allowed.user                = True;



	Sreq_init.root_search_proc	   = True;	/* Mark bits on by default.			*/
	Sreq_init.level		   = True;
	Sreq_init.new_line		   = True;
	Sreq_init.user                   = True;

	Sc_allowed.acl            = True;		/* Mark Sc bits- show which ctl args allowed.	*/
	Sc_allowed.all_status     = True;
	Sc_allowed.chase          = True;
	Sc_allowed.check_archive  = True;
	Sc_allowed.check_ascii    = True;
	Sc_allowed.components     = True;
	Sc_allowed.container      = True;
	Sc_allowed.default        = True;
	Sc_allowed.iacl           = True;
	Sc_allowed.object_info    = True;
	Sc_allowed.quota          = True;
	Sc_allowed.retain         = True;
	Sc_allowed.descriptor     = True;
	Sc_allowed.library        = True;
	Sc_allowed.search_names   = True;

	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;			/* call subr to process all arguments.		*/

	if Srequirements & ^arg_struc.Srequirements_initial then;
	else Sc.default = True;			/* give user default output if he didn't care.	*/

	if ^Sc.default & ^S.names & ^S.matching_names & ^S.primary_name then do;
	     S.primary_name = True;
	     S.matching_names = True;
	     end;					/* output first, matching names by default.	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) initialize library pgm's file control block.				*/
	/* 2) establish cleanup on unit.						*/
	/* 3) get ptr to system multi-segment area, and establish area on unit.		*/
	/* 4) search and build status tree for library entries being sought.			*/
	/* 5) make a list of found entries, and sort the list.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Pfcb = addr(fcb_temp);
	fcb.version = Vfcb_1;
	fcb.ioname = "user_output";			/* print output on user's terminal.		*/
	fcb.Piocb = iox_$user_output;
	fcb.Eend_page = no_end_page;
	fcb.page_length = 131071;			/* use large page size to avoid footings.	*/
	fcb.page_text_length = 131071;
	fcb.page_no = 1;
	fcb.line_length = get_line_length_$switch (fcb.Piocb, code);
	if code ^= 0 then fcb.line_length = 79;
	fcb.line_no = 2;				/* prevent new_line from being suppressed before	*/
						/*   the first entry.  They're suppressed for 1st	*/
						/*   line of a page.			*/

	Parea = null;				/* initialize values used by cleanup on unit.	*/
	on cleanup call janitor;

	call condition_ ("area", msa_manager_$area_handler);
						/* let msa_manager_ handle area conditions.	*/
	call get_system_msa_ (addr(Parea), 0, (null));	/* get MSA ptr.				*/

	Plibrary = addr(LIBRARY);
	Pstarname = addr(STARNAME);
	Pexclude = addr(EXCLUDE);
	call lib_descriptor_$info (arg_struc.descriptor, Plibrary, Pstarname, Pexclude,
	     Srequirements, Scontrol, Parea, Ptree, progress, code);
						/* get a tree of status nodes reflecting the	*/
	if code ^= 0 then go to BAD_SEARCH;		/* library entries which match the star name.	*/

	allocate 	index_list in (area),		/* allocate space for sorting the status nodes.	*/
		name_list in (area),
		node_list in (area);
	index_list.I = 0;				/* initialize count of entries in each list.	*/
	name_list.I = 0;
	node_list.I = 0;
	call lib_sort_tree_$make_name_list (Ptree, Pname_list, Pindex_list, Pnode_list, code);
	if code ^= 0 then go to NO_MATCH;		/* put the outputable nodes into a name list.	*/
	call lib_sort_tree_$name_list (Pname_list, Pindex_list);
						/* sort the name list.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Generate the info from the sorted list of status entries.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call lib_output_node_list_$info (Pfcb, Pnode_list, Pname_list, Pindex_list, arg_struc.footing,
	     (72)"1"b, addr(starname));
						/* print the nodes, including names which	*/
						/*    match the user's search names.		*/
DETACH:	call janitor;				/* clean up.				*/
	return;

janitor:	procedure;				/* cleanup procedure.			*/
	if Parea ^= null then			/* cleanup by releasing any system MSA.		*/
	     call release_system_msa_ (addr(Parea), code);

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


BAD_SEARCH:
	progress = min (progress, 7);
	go to BAD_S (progress);
BAD_S(0): call com_err_ (code, arg_struc.program, "^/  While calling lib_descriptor_$info.");
	go to DETACH;
BAD_S(1): call com_err_ (code, arg_struc.program, "^/  While finding the  '^R^a^B'  library descriptor.",
	     arg_struc.descriptor);
	go to DETACH;
BAD_S(2): call com_err_ (code, arg_struc.program,
	     "^/  Library descriptor  '^R^a^B'  does not implement^/  the ^a command.",
	     arg_struc.descriptor, arg_struc.program);
	go to DETACH;
BAD_S(3): state = "library";
	go to NO_DEFAULT_NAMES;
BAD_S(4): state = "search";
NO_DEFAULT_NAMES:
	call com_err_ (code, arg_struc.program,
	     "^/  No ^a names were specified, and the  '^R^a^B'
  library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state);
	go to DETACH;
BAD_S(5): call com_err_ (code, arg_struc.program, "^/  While allocating the root nodes of the library tree.");
	go to DETACH;
BAD_S(6):
NO_MATCH:	call com_err_ (code, arg_struc.program,
	     "^/  While searching for entries in the library.^/  Descriptor:^-^5x^a",
	     arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	call lib_error_list_ ("search name", Pstarname, arg_struc.program);
	go to DETACH;
BAD_S(7):	call com_err_ (code, arg_struc.program, "^/  No libraries matching the library name(s) could be found.
  Descriptor:^-^5x^a", arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	go to DETACH;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


no_end_page:	procedure;			/* This is a null end-of-page handling proc.	*/

	fcb.page_no = fcb.page_no + 1;
	fcb.line_no = 2;

	end no_end_page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_fcb_;

%include lib_list_;

%include lib_node_;


	end library_info;




		    library_map.pl1                 02/15/84  0911.2rew 02/15/84  0749.4      189756



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

/* Modified November 18, 1983 by Jim Lippard for a 60-line page length				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


library_map: lm:	procedure
		options	(rename ((alloc_, smart_alloc_)));

     dcl						/*	automatic variables			*/
	Parea			ptr,		/* ptr to an MSA.				*/
	Ptree			ptr,		/* ptr to a tree of status nodes.		*/
	1 arg_struc_temp		like arg_struc,	/* storage for argument structure.		*/
	clock			fixed bin(71),	/* a clock value.				*/
	code			fixed bin(35),	/* a status code.				*/
	date			char(16) aligned,	/* a date/time string.			*/
	1 fcb_temp		like fcb,		/* storage for file control block.		*/
	i			fixed bin,	/* a do-group index.			*/
	j			fixed bin,	/* a do-group index.			*/
	progress			fixed bin init (0),	/* integer indicating progress of our search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_map command supported	*/
						/*       by this descriptor.			*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	state			char(16);		/* an error temporary char string.		*/

     dcl						/* 	based variables			*/
	area			area based (Parea);	/* an MSA (multi-segment area).		*/

     dcl (addr, divide, length, min, null, reverse, substr, verify)
				builtin;
     dcl	cleanup			condition;

     dcl						/*	Entries Called			*/
	clock_			entry returns (fixed bin(71)),
	com_err_			entry options(variable),
	condition_		entry (char(*) aligned, entry),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_list_ptr		entry returns(ptr),
	date_time_		entry (fixed bin(71), char(*) aligned),
	get_group_id_		entry returns (char(32) aligned),
	get_system_msa_		entry (ptr, fixed bin, ptr),
	ioa_$ioa_switch		entry options (variable),
	ioa_$ioa_switch_nnl		entry options (variable),
	iox_$attach_ioname		entry (char(*), ptr, char(*), fixed bin(35)),
	iox_$close		entry (ptr, fixed bin(35)),
	iox_$detach_iocb		entry (ptr, fixed bin(35)),
	iox_$open			entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_descriptor_$map		entry (char(168) varying, ptr, ptr, ptr, bit(72) aligned,  bit(36) aligned,
				       ptr, ptr, fixed bin, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying),
	lib_output_node_list_$map	entry (ptr, ptr, ptr, ptr, char(45) varying, bit(72) aligned, ptr),
	lib_sort_tree_$make_name_list
				entry (ptr, ptr, ptr, ptr, fixed bin(35)),
	lib_sort_tree_$name_list	entry (ptr, ptr),
	msa_manager_$area_handler	entry,
	release_system_msa_		entry (ptr, fixed bin(35)),
	system_info_$titles		entry (char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned);

     dcl						/*	static variables			*/
	Lcompany			fixed bin int static,
	Ldepartment		fixed bin int static,
	Ocompany			fixed bin int static,
	Odepartment		fixed bin int static,
	Sno_titles		bit(1) aligned int static init ("1"b),
	True			bit(1) aligned int static options(constant) init ("1"b),
	company			char(120) aligned int static,
	department		char(120) aligned int static,
         (error_table_$entlong,
	error_table_$noarg,
	error_table_$not_detached,
	error_table_$not_open)	fixed bin(35) ext static,
	finish			bit(1) aligned int static options(constant) init ("1"b),
	on_unit			bit(1) aligned int static options(constant) init ("0"b),
	stream_output		fixed bin int static init (2);
						/* iox_ opening mode for stream-output I/O.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Parg_struc = addr(arg_struc_temp);		/* Initialize argument processing structure.	*/
	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_map";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 1;
	arg_struc.Larg_list = cu_$arg_count();
	arg_struc.put_error = com_err_;
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;

	Sreq_allowed.access_class        = True;	/* Mark Sreq bits-  show which output args allowed*/
	Sreq_allowed.acl                 = True;
	Sreq_allowed.aim                 = True;
	Sreq_allowed.author              = True;
	Sreq_allowed.bit_count           = True;
	Sreq_allowed.bit_count_author    = True;
	Sreq_allowed.compiler_name       = True;
	Sreq_allowed.compiler_options    = True;
	Sreq_allowed.compiler_version    = True;
	Sreq_allowed.copy                = True;
	Sreq_allowed.cross_ref           = True;
	Sreq_allowed.current_length      = True;
	Sreq_allowed.dtc                 = True;
	Sreq_allowed.dtd                 = True;
	Sreq_allowed.dtem                = True;
	Sreq_allowed.dtm                 = True;
	Sreq_allowed.dtu                 = True;
	Sreq_allowed.entry_bound         = True;
	Sreq_allowed.iacl                = True;
	Sreq_allowed.kids                = True;
	Sreq_allowed.kids_error          = True;
	Sreq_allowed.level               = True;
	Sreq_allowed.link_target         = True;
	Sreq_allowed.lvid                = True;
	Sreq_allowed.matching_names      = True;
	Sreq_allowed.max_length          = True;
	Sreq_allowed.mode                = True;
	Sreq_allowed.msf_indicator       = True;
	Sreq_allowed.names               = True;
	Sreq_allowed.new_line            = True;
	Sreq_allowed.not_ascii           = True;
	Sreq_allowed.object_info         = True;
	Sreq_allowed.offset              = True;
	Sreq_allowed.pathname            = True;
	Sreq_allowed.primary_name        = True;
	Sreq_allowed.pvid                = True;
	Sreq_allowed.quota               = True;
	Sreq_allowed.rb                  = True;
	Sreq_allowed.records_used        = True;
	Sreq_allowed.root_search_proc    = True;
	Sreq_allowed.safety              = True;
	Sreq_allowed.type                = True;
	Sreq_allowed.unique_id           = True;
	Sreq_allowed.user                = True;



	Sreq_init.cross_ref		   = True;	/* Mark bits on by default.			*/
	Sreq_init.root_search_proc       = True;
	Sreq_init.user                   = True;

	Sc_allowed.acl            = True;		/* Mark Sc bits- show which ctl args allowed.	*/
	Sc_allowed.all_status     = True;
	Sc_allowed.chase          = True;
	Sc_allowed.check_archive  = True;
	Sc_allowed.check_ascii    = True;
	Sc_allowed.components     = True;
	Sc_allowed.container      = True;
	Sc_allowed.default        = True;
	Sc_allowed.iacl           = True;
	Sc_allowed.object_info    = True;
	Sc_allowed.quota          = True;
	Sc_allowed.retain         = True;
	Sc_allowed.descriptor     = True;
	Sc_allowed.footing        = True;
	Sc_allowed.heading        = True;
	Sc_allowed.library        = True;
	Sc_allowed.output_file    = True;
	Sc_allowed.search_names   = True;

	Sc_init.container	      = True;		/* Mark bits for ctl args supplied by default.	*/
	Sc_init.output_file	      = True;
	arg_struc.output_file = "library.map";

	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;			/* call subr to process all arguments.		*/

	if Srequirements & ^arg_struc.Srequirements_initial then;
	else Sc.default = True;			/* give user default output if he didn't care.	*/

	if ^Sc.default & ^S.names & ^S.matching_names & ^S.primary_name then
	     go to NO_NAME;				/* complain if output devoid of names.		*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) initialize library pgm's file control block.				*/
	/* 2) establish cleanup on unit.						*/
	/* 3) attach/open output file.						*/
	/* 4) get ptr to system multi-segment area, and establish area on unit.		*/
	/* 5) search and build status tree for library entries being sought.			*/
	/* 6) make a list of found entries, and sort the list.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Pfcb = addr(fcb_temp);
	fcb.version = Vfcb_1;
	fcb.ioname = "lib_map_";			/* do all of our output on the lib_map_ ioname.	*/
	fcb.Piocb = null;				/* indicate no attachment so far.		*/
	fcb.Eend_page = no_end_page;
	fcb.page_length = 60;
	fcb.page_text_length = 60;
	fcb.page_no = 1;
	fcb.line_length = 132;
	fcb.line_no = 1;

	Parea = null;				/* initialize values used by cleanup on unit.	*/
	on cleanup call janitor(on_unit);

	if substr(arg_struc.output_file, length(arg_struc.output_file)-3) ^= ".map" then
	     if length(arg_struc.output_file) > 164 then do;
		code = error_table_$entlong;
		go to  BAD_ATTACH;
		end;
	     else arg_struc.output_file = arg_struc.output_file || ".map";
	call iox_$attach_ioname (fcb.ioname, fcb.Piocb, "vfile_ " || arg_struc.output_file, code);
	if code ^= 0 then go to BAD_ATTACH;
	call iox_$open (fcb.Piocb, stream_output, "0"b, code);
	if code ^= 0 then go to BAD_OPEN;

	call condition_ ("area", msa_manager_$area_handler);
						/* let msa_manager_ handle area conditions.	*/
	call get_system_msa_ (addr(Parea), 0, (null));	/* get MSA ptr.				*/

	Plibrary = addr(LIBRARY);
	Pstarname = addr(STARNAME);
	Pexclude = addr(EXCLUDE);
	call lib_descriptor_$map (arg_struc.descriptor, Plibrary, Pstarname, Pexclude,
	     Srequirements, Scontrol, Parea, Ptree, progress, code);
						/* get a tree of status nodes reflecting the	*/
	if code ^= 0 then go to BAD_SEARCH;		/* library entries which match the star name.	*/

	allocate 	index_list in (area),		/* allocate space for sorting the status nodes.	*/
		name_list in (area),
		node_list in (area);
	index_list.I = 0;				/* initialize count of entries in each list.	*/
	name_list.I = 0;
	node_list.I = 0;
	call lib_sort_tree_$make_name_list (Ptree, Pname_list, Pindex_list, Pnode_list, code);
	if code ^= 0 then go to NO_MATCH;		/* put the outputable nodes into a name list.	*/
	call lib_sort_tree_$name_list (Pname_list, Pindex_list);
						/* sort the name list.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Output a header page for the map which includes:				*/
	/*   1) company and department titles.						*/
	/*   2) count of library entries mapped at level 1.				*/
	/*   3) a heading line indicating which library was searched.			*/
	/*   4) a line stating what search names were used to identify the sought entries.	*/
	/*   5) date of mapping; process group id of mapper; and name of library descriptor.	*/
	/* Construct the footing phrase to appear in the last line of each page of output.	*/
	/* Generate the map from the sorted list of status entries.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Sno_titles then do;			/* get titles for output file.		*/
	     call system_info_$titles ("", "", company, department);
	     Lcompany = min (120, 121 - verify (reverse (company), " "));
	     Ocompany = divide (132-Lcompany, 2, 0, 0);
	     Ldepartment = min (120, 121 - verify (reverse (department), " "));
	     Odepartment = divide (132-Ldepartment, 2, 0, 0);
	     Sno_titles = "0"b;
	     end;
	call ioa_$ioa_switch (fcb.Piocb, "^4/^vx^va", Ocompany, Lcompany, company);
	fcb.line_no = fcb.line_no + 5;
	call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", Odepartment, Ldepartment, department);
	fcb.line_no = fcb.line_no + 2;
	if name_list.I = 1 then
	     call ioa_$ioa_switch (fcb.Piocb, "^6/^56xMap of the 1 Entry");
	else
	     call ioa_$ioa_switch (fcb.Piocb, "^6/^55xMap of the ^3d Entries", name_list.I);
	fcb.line_no = fcb.line_no + 7;
	if Sc.heading then do;			/* use user-specified heading line.		*/
	     i = length (arg_struc.heading);
	     call ioa_$ioa_switch (fcb.Piocb, "^/^63xof the^2/^vx^va", divide (132-i, 2, 0, 0), i,
		arg_struc.heading);
	     fcb.line_no = fcb.line_no + 4;
	     end;
	else do;					/* form default heading line from library names.	*/
	     if library.N = 1 then do;
		j = min (32, 33 - verify (reverse (library.V(1)), " "));
		arg_struc.heading = substr (library.V(1), 1, j) || " Library";
		i = length (arg_struc.heading);
		call ioa_$ioa_switch (fcb.Piocb, "^/^63xof the^2/^vx^va", divide (132-i, 2, 0, 0), i, 
		     arg_struc.heading);
		fcb.line_no = fcb.line_no + 4;
		end;
	     else do;
		call ioa_$ioa_switch (fcb.Piocb, "^/^62xof  the^2/^61xLibraries");
		fcb.line_no = fcb.line_no + 4;
		arg_struc.heading = "";
		do i = 1 to library.N;
		     j = min (32, 33 - verify (reverse (library.V(i)), " "));
		     if length (arg_struc.heading) + j + 2 > 120 then do;
			call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-(length(arg_struc.heading)-1),
			     2, 0, 0), length(arg_struc.heading)-1, arg_struc.heading);
			fcb.line_no = fcb.line_no + 2;
			arg_struc.heading = "";
			end;
		     arg_struc.heading = arg_struc.heading || substr (library.V(i), 1, j) || ", ";
		     end;
		arg_struc.heading = substr (arg_struc.heading, 1, length(arg_struc.heading) - 2);
						/* remove last ", " from final heading line.	*/

		call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-(length(arg_struc.heading)), 2, 0, 0),
		     length(arg_struc.heading), arg_struc.heading);
		fcb.line_no = fcb.line_no + 2;
		end;
	     end;
	if starname.C(1) = 2 then;			/* Don't list search names if name of '**' given.	*/
	else if starname.N = 1 then do;
	     i = min (32, 33 - verify (reverse (starname.V(1)), " "));
	     call ioa_$ioa_switch (fcb.Piocb, "^2/^53xWhich Match the Search Name^2/^51x^vx^va",
		divide (32 - i, 2, 0, 0), i, starname.V(1));
	     fcb.line_no = fcb.line_no + 3;
	     end;
	else do;
	     call ioa_$ioa_switch (fcb.Piocb, "^2/^51xWhich Match the Search Names");
	     fcb.line_no = fcb.line_no + 3;
	     arg_struc.heading = "";
	     do i = 1 to starname.N;
		j = min (32, 33 - verify (reverse (starname.V(i)), " "));
		if length (arg_struc.heading) + j + 2 > 120 then do;
		     call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-(length(arg_struc.heading)-1),
			2, 0, 0), length(arg_struc.heading)-1, arg_struc.heading);
		     fcb.line_no = fcb.line_no + 2;
		     arg_struc.heading = "";
		     end;
		arg_struc.heading = arg_struc.heading || substr (starname.V(i), 1, j) || ", ";
		end;
	     arg_struc.heading = substr (arg_struc.heading, 1, length(arg_struc.heading)  - 2);
	     call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-length(arg_struc.heading), 2, 0, 0),
		length(arg_struc.heading), arg_struc.heading);
	     fcb.line_no = fcb.line_no + 2;
	     end;
	j = 46 - fcb.line_no;			/* space down near bottom of page.		*/
	if j > 0 then
	     call ioa_$ioa_switch_nnl (fcb.Piocb, "^v/", j);
	clock = clock_();
	call date_time_ (clock, date);
	call ioa_$ioa_switch (fcb.Piocb, "^/^30xMapped on:^-^a", date);
	call ioa_$ioa_switch (fcb.Piocb, "^/^30xMapped by:^-^a", get_group_id_());
	call ioa_$ioa_switch (fcb.Piocb, "^/^30xDescriptor:^-^a", arg_struc.descriptor);
	if name_list.I = max_entries then
	     call ioa_$ioa_switch_nnl (fcb.Piocb,
		"^/^3-Maximum number of entries (^d) exceeded.
			Entries may have been excluded from the map.^/^|",
		max_entries);
	else
	     call ioa_$ioa_switch_nnl (fcb.Piocb, "^|");
	fcb.line_no = 1;

	if Sc.footing then;				/* use default value for footer if user didn't	*/
	else do;
	     arg_struc.heading = "";
	     do i = 1 to library.N - 1;
		j = min (32, 33 - verify (reverse (library.V(i)), " "));
		if length (arg_struc.heading) + j + 5 > 45 then do;
		     arg_struc.heading = arg_struc.heading || "...";
		     go to SET_FOOTING;
		     end;
		arg_struc.heading = arg_struc.heading || substr(library.V(i), 1, j) || ", ";
		end;
	     j = min (32, 33 - verify (reverse (library.V(i)), " "));
	     if length (arg_struc.heading) + j > 45 then arg_struc.heading = arg_struc.heading || "...";
	     else arg_struc.heading = arg_struc.heading || library.V(i);
SET_FOOTING:   arg_struc.footing = arg_struc.heading;
	     end;

	call lib_output_node_list_$map (Pfcb, Pnode_list, Pname_list, Pindex_list, arg_struc.footing,
	     (72)"1"b, addr(starname));
						/* print the nodes, including names which	*/
						/*    match the user's search names.		*/
DETACH:	call janitor(finish);			/* clean up.				*/
	return;

janitor:	procedure (invocation_mode);			/* cleanup procedure.			*/

     dcl	invocation_mode		bit(1) aligned;	/* off if invoked by cleanup on unit.		*/

	if Parea ^= null then			/* cleanup by releasing any system MSA.		*/
	     call release_system_msa_ (addr(Parea), code);
	if fcb.Piocb ^= null then do;			/* close/detach our output file, if open.	*/
	     call iox_$close (fcb.Piocb, code);
	     if invocation_mode = finish then if code ^= 0 then if code ^= error_table_$not_open
		then go to BAD_CLOSE;
	     call iox_$detach_iocb (fcb.Piocb, code);
	     fcb.Piocb = null;			/* we've done all we can.  Stop trying.		*/
	     if invocation_mode = finish then if code ^= 0 then go to BAD_DETACH;
	     end;

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


BAD_ATTACH:
	if code = error_table_$not_detached then go to MULTIPLE_ATTACH;
	state = "attaching";
	fcb.Piocb = null;
	go to BAD_IO;
BAD_CLOSE:
	state = "closing";
	go to BAD_IO;
BAD_DETACH:
	state = "detaching";
	go to BAD_IO;
BAD_OPEN:
	state = "opening";
BAD_IO:	call com_err_ (code,arg_struc.program, "^/  While ^a the map file  ^R^a^B^/  using the I/O switch  ^R^a^B.",
	     state, arg_struc.output_file, fcb.ioname);
	go to DETACH;

MULTIPLE_ATTACH:
	call com_err_ (code, arg_struc.program,
	     "^/  While attaching the map file  ^R^a^B^/  to the I/O switch  ^R^a^B.
  Release any other activations of ^a and try again.", arg_struc.output_file, fcb.ioname, arg_struc.program);
	return;

BAD_SEARCH:
	progress = min (progress, 7);
	go to BAD_S (progress);
BAD_S(0): call com_err_ (code, arg_struc.program, "^/  While calling lib_descriptor_$map.");
	go to DETACH;
BAD_S(1): call com_err_ (code, arg_struc.program, "^/  While finding the  '^R^a^B'  library descriptor.",
	     arg_struc.descriptor);
	go to DETACH;
BAD_S(2): call com_err_ (code, arg_struc.program,
	     "^/  Library descriptor  '^R^a^B'  does not implement^/  the ^a command.",
	     arg_struc.descriptor, arg_struc.program);
	go to DETACH;
BAD_S(3): state = "library";
	go to NO_DEFAULT_NAMES;
BAD_S(4): state = "search";
NO_DEFAULT_NAMES:
	call com_err_ (code, arg_struc.program,
	     "^/  No ^a names were specified, and the  '^R^a^B'
  library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state);
	go to DETACH;
BAD_S(5): call com_err_ (code, arg_struc.program, "^/  While allocating the root nodes of the library tree.");
	go to DETACH;

BAD_S(6):
NO_MATCH:	call com_err_ (code, arg_struc.program,
	     "^/  While searching for entries in the library.^/  Descriptor:^-^5x^a",
	     arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	call lib_error_list_ ("search name", Pstarname, arg_struc.program);
	go to DETACH;
BAD_S(7):	call com_err_ (code, arg_struc.program, "^/  No libraries matching the library name(s) could be found.
  Descriptor:^-^5x^a", arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	go to DETACH;

NO_NAME:	call com_err_ (error_table_$noarg, arg_struc.program,
	     "^/  At least one of the following control arguments must be given
  so that the name of each library entry will be output:
     -name, -match, -primary, or -default.");
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


no_end_page:	procedure;			/* This is a null end-of-page handling proc.	*/

	fcb.page_no = fcb.page_no + 1;
	fcb.line_no = 1;

	end no_end_page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_fcb_;

%include lib_list_;

%include lib_node_;


	end library_map;




		    library_pathname.pl1            02/15/84  0911.2rew 02/15/84  0749.8       70083



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Names: library_pathname, lpn						*/
	/*									*/
	/* This command/af is part of the Multics library descriptor tools.  Given a library	*/
	/* descriptor name, a set of library names, and a set of star_names, it returns the	*/
	/* pathnames of library entries which match the star_names.  Archive pathnames are	*/
	/* returned for library entries in archives.  The default library descriptor name is set	*/
	/* (for a process) by the library_descriptor command.  The defaults for library and	*/
	/* star_names (search_names) are specified for the library_info command (and for this	*/
	/* command/af) in each library descriptor.  To list the defaults, use the command:	*/
	/*    lds default library_info						*/
	/*									*/
	/* Status:								*/
	/* 0) Created:   October, 1981 by G. C. Dixon					*/
	/* 1) Modified:  October 11, 1983 by Jim Lippard to rtrim return pathnames and not say	*/
	/* anything about entries "eligible for deletion" and add -all_matches (-amch) and	*/
	/* -first_match (-fmch).							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

library_pathname:
lpn:	procedure;

     dcl						/*	automatic variables			*/
	Lret			fixed bin(21),
	Nargs			fixed bin,
	Npaths			fixed bin,
	Ppaths			ptr,
	Pret			ptr,
	Scommand			bit(1),
	1 arg_struc_temp		like arg_struc,	/* storage for argument structure.		*/
	code			fixed bin(35),	/* a status code.				*/
	i			fixed bin,	/* a do-group index.			*/
	progress			fixed bin init (0),	/* integer indicating progress of our search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_pathname command	*/
						/*       supported by this descriptor.		*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	state			char(7) varying;
	

     dcl						/* 	based variables			*/
	area			area based (Parea),
	paths (Npaths)		char(200) based(Ppaths),
	ret			char(Lret) varying based(Pret);

     dcl (addr, length, min, null, rtrim, substr)
				builtin;

     dcl	cleanup			condition;

     dcl						/*	Entries Called			*/
	active_fnc_err_		entry() options(variable),
	com_err_			entry options(variable),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$arg_list_ptr		entry returns(ptr),
	err			entry options(variable) variable,
	get_system_free_area_	entry() returns(ptr),
	ioa_			entry options(variable),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_error_list_$return_string	entry (char(32) var, ptr) returns(char(*) var),
	lib_pathname_		entry (char(168) var, ptr, ptr, ptr, bit (72) aligned, bit (36) aligned, ptr, ptr,
				     fixed bin, fixed bin, fixed bin(35)),
	requote_string_		entry (char(*)) returns(char(*));

     dcl						/*	static variables			*/
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	Parea			ptr int static init(null);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;
	     Scommand = FALSE;
	     err = active_fnc_err_;
	     ret = "";
	     end;
	else do;
	     Scommand = TRUE;
	     err = com_err_;
	     end;

	Parg_struc = addr(arg_struc_temp);		/* Initialize argument processing structure.	*/
	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_pathname";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 1;
	arg_struc.Larg_list = Nargs;
	arg_struc.put_error = err;
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;

	Sc_allowed.descriptor     = TRUE;		/* Mark Sc bits- show which ctl args allowed.	*/
	Sc_allowed.library        = TRUE;
	Sc_allowed.search_names   = TRUE;
	Sc_allowed.first_match    = TRUE;

	if ^Scommand then Sc_init.first_match = TRUE;

	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;			/* call subr to process all arguments.		*/

	Plibrary = addr(LIBRARY);
	Pstarname = addr(STARNAME);
	Pexclude = addr(EXCLUDE);
	if Parea = null then
	     Parea = get_system_free_area_();

	Ppaths = null;
	on cleanup call janitor();

	call lib_pathname_ (arg_struc.descriptor, Plibrary, Pstarname, Pexclude, Srequirements, Scontrol, Parea, Ppaths, Npaths, progress, code);
	if code ^= 0 then go to BAD_SEARCH;

	if Scommand then 
	     call ioa_ ("^(^a^/^)", paths);
	else do;
	     do i = 1 to Npaths;
		ret = ret || requote_string_ (rtrim(paths(i)));
		ret = ret || " ";
		end;
	     ret = substr (ret, 1, length (ret) - 1);
	     end;

FINISH:	call janitor;				/* clean up.				*/
	return;


janitor:	proc;

	if Ppaths ^= null then
	     free paths in (area);
	Ppaths = null;

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

BAD_SEARCH:
	progress = min (progress, 7);
	go to BAD_S (progress);

BAD_S(0): call err (code, arg_struc.program, "^/  While calling lib_descriptor_$map.");
	go to FINISH;

BAD_S(1): call err (code, arg_struc.program, "^/  While finding the  '^R^a^B'  library descriptor.",
	     arg_struc.descriptor);
	go to FINISH;

BAD_S(2): call err (code, arg_struc.program,
	     "^/  Library descriptor  '^R^a^B'  does not implement^/  the ^a command.",
	     arg_struc.descriptor, arg_struc.program);
	go to FINISH;

BAD_S(3): state = "library";
	go to NO_DEFAULT_NAMES;

BAD_S(4): state = "search";
NO_DEFAULT_NAMES:
	call err (code, arg_struc.program,
	     "^/  No ^a names were specified, and the  '^R^a^B'
  library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state);
	go to FINISH;

BAD_S(5): call err (code, arg_struc.program, "^/  While allocating the root nodes of the library tree.");
	go to FINISH;

BAD_S(6):
NO_MATCH:	call err (code, arg_struc.program,
	     "^/  While searching for entries in the library.^/  Descriptor:^-^5x^a^/^a^/^a",
	     arg_struc.descriptor,
	     lib_error_list_$return_string ("library name", Plibrary),
	     lib_error_list_$return_string ("search name", Pstarname));
	go to FINISH;

BAD_S(7):	call err (code, arg_struc.program, "^/  No libraries matching the library name(s) could be found.
  Descriptor:^-^5x^a^/^a", arg_struc.descriptor,
	     lib_error_list_$return_string ("library name", Plibrary));
	go to FINISH;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_Scontrol_;

%include lib_Svalid_req_;

	end library_pathname;




		    library_print.pl1               02/15/84  0911.2rew 02/15/84  0749.8      190863



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


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* Modified October 24, 1983 by Jim Lippard to add page_length option */

library_print: lpr:	procedure
		options	(rename ((alloc_, smart_alloc_)));

     dcl						/*	automatic variables			*/
	Parea			ptr,		/* ptr to an MSA.				*/
	Ptree			ptr,		/* ptr to a tree of status nodes.		*/
	1 arg_struc_temp		like arg_struc,	/* storage for argument structure.		*/
	clock			fixed bin(71),	/* a clock value.				*/
	code			fixed bin(35),	/* a status code.				*/
	date			char(16) aligned,	/* a date/time string.			*/
	1 fcb_temp		like fcb,		/* storage for file control block.		*/
	i			fixed bin,	/* a do-group index.			*/
	j			fixed bin,	/* a do-group index.			*/
	progress			fixed bin init (0),	/* integer indicating progress of our search.	*/
						/*   0 = search beginning.			*/
						/*   1 = finding library descriptor.		*/
						/*   2 = seeing if library_print command supported	*/
						/*       by this descriptor.			*/
						/*   3 = getting default library names if user	*/
						/*       specified none.			*/
						/*   4 = getting default search names if user	*/
						/*       specified none.			*/
						/*   5 = allocating the root nodes of the tree.	*/
						/*   6 = searching each library root for entries	*/
						/*       identified by the search names.	*/
						/*   7 = no entries matching search names found.	*/
	state			char(16);		/* an error temporary char string.		*/

     dcl						/* 	based variables			*/
	area			area based (Parea);	/* an MSA (multi-segment area).		*/

     dcl (addr, divide, length, min, null, reverse, substr, verify)
				builtin;
     dcl	cleanup			condition;

     dcl						/*	Entries Called			*/
	clock_			entry returns (fixed bin(71)),
	com_err_			entry options(variable),
	condition_		entry (char(*) aligned, entry),
	cu_$arg_count		entry returns (fixed bin),
	cu_$arg_list_ptr		entry returns(ptr),
	date_time_		entry (fixed bin(71), char(*) aligned),
	get_group_id_		entry returns (char(32) aligned),
	get_system_msa_		entry (ptr, fixed bin, ptr),
	ioa_$ioa_switch		entry options (variable),
	ioa_$ioa_switch_nnl		entry options (variable),
	iox_$attach_ioname		entry (char(*), ptr, char(*), fixed bin(35)),
	iox_$close		entry (ptr, fixed bin(35)),
	iox_$detach_iocb		entry (ptr, fixed bin(35)),
	iox_$open			entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
	lib_args_			entry (1 aligned like LIBRARY, 1 aligned like STARNAME, 1 aligned like STARNAME, bit(72) aligned,
				       bit(36) aligned, ptr, fixed bin(35)),
	lib_descriptor_$print	entry (char(168) varying, ptr, ptr, ptr, bit(72) aligned,  bit(36) aligned,
				       ptr, ptr, fixed bin, fixed bin(35)),
	lib_error_list_		entry (char(32) varying, ptr, char(32) varying),
	lib_output_node_list_$print	entry (ptr, ptr, ptr, ptr, char(45) varying, bit(72) aligned, ptr, ptr),
	lib_sort_tree_$make_name_list
				entry (ptr, ptr, ptr, ptr, fixed bin(35)),
	lib_sort_tree_$name_list	entry (ptr, ptr),
	msa_manager_$area_handler	entry,
	release_system_msa_		entry (ptr, fixed bin(35)),
	system_info_$titles		entry (char(*) aligned, char(*) aligned, char(*) aligned,
				       char(*) aligned);

     dcl						/*	static variables			*/
	Lcompany			fixed bin int static,
	Ldepartment		fixed bin int static,
	Ocompany			fixed bin int static,
	Odepartment		fixed bin int static,
	Sno_titles		bit(1) aligned int static init ("1"b),
	True			bit(1) aligned int static options(constant) init ("1"b),
	company			char(120) aligned int static,
	department		char(120) aligned int static,
         (error_table_$entlong,
	error_table_$noarg,
	error_table_$not_detached,
	error_table_$not_open)	fixed bin(35) ext static,
	finish			bit(1) aligned int static options(constant) init ("1"b),
	on_unit			bit(1) aligned int static options(constant) init ("0"b),
	stream_output		fixed bin int static init (2);
						/* iox_ opening mode for stream-output I/O.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	Parg_struc = addr(arg_struc_temp);		/* Initialize argument processing structure.	*/
	arg_struc.version = Varg_struc_1;
	arg_struc.program = "library_print";
	arg_struc.Parg_list = cu_$arg_list_ptr();
	arg_struc.Iarg_list = 1;
	arg_struc.Larg_list = cu_$arg_count();
	arg_struc.put_error = com_err_;
	arg_struc.Srequirements_allowed = ""b;
	arg_struc.Srequirements_initial = ""b;
	arg_struc.Scontrol_allowed = ""b;
	arg_struc.Scontrol_initial = ""b;

	Sreq_allowed.access_class        = True;	/* Mark Sreq bits-  show which output args allowed*/
	Sreq_allowed.acl                 = True;
	Sreq_allowed.aim                 = True;
	Sreq_allowed.author              = True;
	Sreq_allowed.bit_count           = True;
	Sreq_allowed.bit_count_author    = True;
	Sreq_allowed.compiler_name       = True;
	Sreq_allowed.compiler_options    = True;
	Sreq_allowed.compiler_version    = True;
	Sreq_allowed.copy                = True;
	Sreq_allowed.current_length      = True;
	Sreq_allowed.dtc                 = True;
	Sreq_allowed.dtd                 = True;
	Sreq_allowed.dtem                = True;
	Sreq_allowed.dtm                 = True;
	Sreq_allowed.dtu                 = True;
	Sreq_allowed.entry_bound         = True;
	Sreq_allowed.iacl                = True;
	Sreq_allowed.kids                = True;
	Sreq_allowed.kids_error          = True;
	Sreq_allowed.level               = True;
	Sreq_allowed.link_target         = True;
	Sreq_allowed.lvid                = True;
	Sreq_allowed.matching_names      = True;
	Sreq_allowed.max_length          = True;
	Sreq_allowed.mode                = True;
	Sreq_allowed.msf_indicator       = True;
	Sreq_allowed.names               = True;
	Sreq_allowed.new_line            = True;
	Sreq_allowed.not_ascii           = True;
	Sreq_allowed.object_info         = True;
	Sreq_allowed.offset              = True;
	Sreq_allowed.pathname            = True;
	Sreq_allowed.primary_name        = True;
	Sreq_allowed.pvid                = True;
	Sreq_allowed.quota               = True;
	Sreq_allowed.rb                  = True;
	Sreq_allowed.records_used        = True;
	Sreq_allowed.root_search_proc    = True;
	Sreq_allowed.safety              = True;
	Sreq_allowed.type                = True;
	Sreq_allowed.unique_id           = True;
	Sreq_allowed.user                = True;



	Sreq_init.root_search_proc	   = True;	/* Mark bits on by default.			*/
	Sreq_init.user                   = True;

	Sc_allowed.acl            = True;		/* Mark Sc bits- show which ctl args allowed.	*/
	Sc_allowed.all_status     = True;
	Sc_allowed.chase          = True;
	Sc_allowed.check_archive  = True;
	Sc_allowed.check_ascii    = True;
	Sc_allowed.components     = True;
	Sc_allowed.container      = True;
	Sc_allowed.default        = True;
	Sc_allowed.iacl           = True;
	Sc_allowed.object_info    = True;
	Sc_allowed.quota          = True;
	Sc_allowed.retain         = True;
	Sc_allowed.descriptor     = True;
	Sc_allowed.footing        = True;
	Sc_allowed.heading        = True;
	Sc_allowed.library        = True;
	Sc_allowed.output_file    = True;
	Sc_allowed.page_length    = True;
	Sc_allowed.search_names   = True;

	Sc_init.output_file	      = True;		/* Mark bits for ctl args supplied by default.	*/
	Sc_init.page_length       = True;
	arg_struc.output_file = "library.print";
	arg_struc.page_length = 60;

	call lib_args_ (LIBRARY, STARNAME, EXCLUDE, Srequirements, Scontrol, addr(arg_struc), code);
	if code ^= 0 then return;			/* call subr to process all arguments.		*/

	if Srequirements & ^arg_struc.Srequirements_initial then;
	else Sc.default = True;			/* give user default output if he didn't care.	*/

	if ^Sc.default & ^S.names & ^S.matching_names & ^S.primary_name then
	     go to NO_NAME;				/* complain if output devoid of names.		*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) initialize library pgm's file control block.				*/
	/* 2) establish cleanup on unit.						*/
	/* 3) attach/open output file.						*/
	/* 4) get ptr to system multi-segment area, and establish area on unit.		*/
	/* 5) search and build status tree for library entries being sought.			*/
	/* 6) make a list of found entries, and sort the list.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Pfcb = addr(fcb_temp);
	fcb.version = Vfcb_1;
	fcb.ioname = "lib_print_";			/* do all of our output on the lib_print_ ioname.	*/
	fcb.Piocb = null;				/* indicate no attachment so far.		*/
	fcb.Eend_page = no_end_page;
	fcb.page_length, fcb.page_text_length = arg_struc.page_length;
	fcb.page_no = 1;
	fcb.line_length = 132;
	fcb.line_no = 1;

	Parea = null;				/* initialize values used by cleanup on unit.	*/
	on cleanup call janitor(on_unit);

	if substr(arg_struc.output_file, length(arg_struc.output_file)-5) ^= ".print" then
	     if length(arg_struc.output_file) > 162 then do;
		code = error_table_$entlong;
		go to  BAD_ATTACH;
		end;
	     else arg_struc.output_file = arg_struc.output_file || ".print";
	call iox_$attach_ioname (fcb.ioname, fcb.Piocb, "vfile_ " || arg_struc.output_file, code);
	if code ^= 0 then go to BAD_ATTACH;
	call iox_$open (fcb.Piocb, stream_output, "0"b, code);
	if code ^= 0 then go to BAD_OPEN;

	call condition_ ("area", msa_manager_$area_handler);
						/* let msa_manager_ handle area conditions.	*/
	call get_system_msa_ (addr(Parea), 0, (null));	/* get MSA ptr.				*/

	Plibrary = addr(LIBRARY);
	Pstarname = addr(STARNAME);
	Pexclude = addr(EXCLUDE);
	call lib_descriptor_$print (arg_struc.descriptor, Plibrary, Pstarname, Pexclude,
	     Srequirements, Scontrol, Parea, Ptree, progress, code);
						/* get a tree of status nodes reflecting the	*/
	if code ^= 0 then go to BAD_SEARCH;		/* library entries which match the star name.	*/

	allocate 	index_list in (area),		/* allocate space for sorting the status nodes.	*/
		name_list in (area),
		node_list in (area),
		page_list in (area);
	index_list.I = 0;				/* initialize count of entries in each list.	*/
	name_list.I = 0;
	node_list.I = 0;
	page_list.I = 0;
	call lib_sort_tree_$make_name_list (Ptree, Pname_list, Pindex_list, Pnode_list, code);
	if code ^= 0 then go to NO_MATCH;		/* put the outputable nodes into a name list.	*/
	call lib_sort_tree_$name_list (Pname_list, Pindex_list);
						/* sort the name list.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Output a header page for the print out which includes:				*/
	/*   1) company and department titles.						*/
	/*   2) count of library entries printed at level 1.				*/
	/*   3) a heading line indicating which library was searched.			*/
	/*   4) a line stating what search names were used to identify the sought entries.	*/
	/*   5) date of generation; process group id of generator; and name of library descriptor.*/
	/* Construct the footing phrase to appear in the last line of each page of output.	*/
	/* Generate the print out from the sorted list of status entries.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Sno_titles then do;			/* get titles for output file.		*/
	     call system_info_$titles ("", "", company, department);
	     Lcompany = min (120, 121 - verify (reverse (company), " "));
	     Ocompany = divide (132-Lcompany, 2, 0, 0);
	     Ldepartment = min (120, 121 - verify (reverse (department), " "));
	     Odepartment = divide (132-Ldepartment, 2, 0, 0);
	     Sno_titles = "0"b;
	     end;
	call ioa_$ioa_switch (fcb.Piocb, "^4/^vx^va", Ocompany, Lcompany, company);
	fcb.line_no = fcb.line_no + 5;
	call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", Odepartment, Ldepartment, department);
	fcb.line_no = fcb.line_no + 2;
	if name_list.I = 1 then
	     call ioa_$ioa_switch (fcb.Piocb, "^6/^54xPrintout of the 1 Entry");
	else
	     call ioa_$ioa_switch (fcb.Piocb, "^6/^53xPrintout of the ^3d Entries", name_list.I);
	fcb.line_no = fcb.line_no + 7;
	if Sc.heading then do;			/* use user-specified heading line.		*/
	     i = length (arg_struc.heading);
	     call ioa_$ioa_switch (fcb.Piocb, "^/^63xof the^2/^vx^va", divide (132-i, 2, 0, 0), i,
		arg_struc.heading);
	     fcb.line_no = fcb.line_no + 4;
	     end;
	else do;					/* form default heading line from library names.	*/
	     if library.N = 1 then do;
		j = min (32, 33 - verify (reverse (library.V(1)), " "));
		arg_struc.heading = substr (library.V(1), 1, j) || " Library";
		i = length (arg_struc.heading);
		call ioa_$ioa_switch (fcb.Piocb, "^/^63xof the^2/^vx^va", divide (132-i, 2, 0, 0), i, 
		     arg_struc.heading);
		fcb.line_no = fcb.line_no + 4;
		end;
	     else do;
		call ioa_$ioa_switch (fcb.Piocb, "^/^62xof  the^2/^61xLibraries");
		fcb.line_no = fcb.line_no + 4;
		arg_struc.heading = "";
		do i = 1 to library.N;
		     j = min (32, 33 - verify (reverse (library.V(i)), " "));
		     if length (arg_struc.heading) + j + 2 > 120 then do;
			call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-(length(arg_struc.heading)-1),
			     2, 0, 0), length(arg_struc.heading)-1, arg_struc.heading);
			fcb.line_no = fcb.line_no + 2;
			arg_struc.heading = "";
			end;
		     arg_struc.heading = arg_struc.heading || substr (library.V(i), 1, j) || ", ";
		     end;
		arg_struc.heading = substr (arg_struc.heading, 1, length(arg_struc.heading) - 2);
						/* remove last ", " from final heading line.	*/

		call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-(length(arg_struc.heading)), 2, 0, 0),
		     length(arg_struc.heading), arg_struc.heading);
		fcb.line_no = fcb.line_no + 2;
		end;
	     end;
	if starname.C(1) = 2 then;			/* Don't list search names if name of '**' given.	*/
	else if starname.N = 1 then do;
	     i = min (32, 33 - verify (reverse (starname.V(1)), " "));
	     call ioa_$ioa_switch (fcb.Piocb, "^2/^53xWhich Match the Search Name^2/^51x^vx^va",
		divide (32 - i, 2, 0, 0), i, starname.V(1));
	     fcb.line_no = fcb.line_no + 3;
	     end;
	else do;
	     call ioa_$ioa_switch (fcb.Piocb, "^2/^51xWhich Match the Search Names");
	     fcb.line_no = fcb.line_no + 3;
	     arg_struc.heading = "";
	     do i = 1 to starname.N;
		j = min (32, 33 - verify (reverse (starname.V(i)), " "));
		if length (arg_struc.heading) + j + 2 > 120 then do;
		     call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-(length(arg_struc.heading)-1),
			2, 0, 0), length(arg_struc.heading)-1, arg_struc.heading);
		     fcb.line_no = fcb.line_no + 2;
		     arg_struc.heading = "";
		     end;
		arg_struc.heading = arg_struc.heading || substr (starname.V(i), 1, j) || ", ";
		end;
	     arg_struc.heading = substr (arg_struc.heading, 1, length(arg_struc.heading)  - 2);
	     call ioa_$ioa_switch (fcb.Piocb, "^/^vx^va", divide (132-length(arg_struc.heading), 2, 0, 0),
		length(arg_struc.heading), arg_struc.heading);
	     fcb.line_no = fcb.line_no + 2;
	     end;
	j = 46 - fcb.line_no;			/* space down near bottom of page.		*/
	if j > 0 then
	     call ioa_$ioa_switch_nnl (fcb.Piocb, "^v/", j);
	clock = clock_();
	call date_time_ (clock, date);
	call ioa_$ioa_switch (fcb.Piocb, "^/^30xPrinted on:^-^a", date);
	call ioa_$ioa_switch (fcb.Piocb, "^/^30xPrinted by:^-^a", get_group_id_());
	call ioa_$ioa_switch (fcb.Piocb, "^/^30xDescriptor:^-^a", arg_struc.descriptor);
	if name_list.I = max_entries then
	     call ioa_$ioa_switch_nnl (fcb.Piocb,
		"^/^3-Maximum number of entries (^d) exceeded.
			Entries may have been excluded from the print out.^/^|",
		max_entries);
	else
	     call ioa_$ioa_switch_nnl (fcb.Piocb, "^|");
	fcb.line_no = 1;

	if Sc.footing then;				/* use default value for footer if user didn't	*/
	else do;
	     arg_struc.heading = "";
	     do i = 1 to library.N - 1;
		j = min (32, 33 - verify (reverse (library.V(i)), " "));
		if length (arg_struc.heading) + j + 5 > 45 then do;
		     arg_struc.heading = arg_struc.heading || "...";
		     go to SET_FOOTING;
		     end;
		arg_struc.heading = arg_struc.heading || substr(library.V(i), 1, j) || ", ";
		end;
	     j = min (32, 33 - verify (reverse (library.V(i)), " "));
	     if length (arg_struc.heading) + j > 45 then arg_struc.heading = arg_struc.heading || "...";
	     else arg_struc.heading = arg_struc.heading || library.V(i);
SET_FOOTING:   arg_struc.footing = arg_struc.heading;
	     end;

	call lib_output_node_list_$print (Pfcb, Pnode_list, Pname_list, Pindex_list, arg_struc.footing,
	     (72)"1"b, addr(starname), Ppage_list);
						/* print the nodes, including names which	*/
						/*    match the user's search names.		*/
DETACH:	call janitor(finish);			/* clean up.				*/
	return;


janitor:	procedure (invocation_mode);			/* cleanup procedure.			*/

     dcl	invocation_mode		bit(1) aligned;	/* off if invoked by cleanup on unit.		*/

	if Parea ^= null then			/* cleanup by releasing any system MSA.		*/
	     call release_system_msa_ (addr(Parea), code);
	if fcb.Piocb ^= null then do;			/* close/detach our output file, if open.	*/
	     call iox_$close (fcb.Piocb, code);
	     if invocation_mode = finish then if code ^= 0 then if code ^= error_table_$not_open
		then go to BAD_CLOSE;
	     call iox_$detach_iocb (fcb.Piocb, code);
	     fcb.Piocb = null;			/* we've done all we can.  Stop trying.		*/
	     if invocation_mode = finish then if code ^= 0 then go to BAD_DETACH;
	     end;

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


BAD_ATTACH:
	if code = error_table_$not_detached then go to MULTIPLE_ATTACH;
	state = "attaching";
	fcb.Piocb = null;
	go to BAD_IO;
BAD_CLOSE:
	state = "closing";
	go to BAD_IO;
BAD_DETACH:
	state = "detaching";
	go to BAD_IO;
BAD_OPEN:
	state = "opening";
BAD_IO:	call com_err_ (code,arg_struc.program, "^/  While ^a the print file  ^R^a^B^/  using the I/O switch  ^R^a^B.",
	     state, arg_struc.output_file, fcb.ioname);
	go to DETACH;

MULTIPLE_ATTACH:
	call com_err_ (code, arg_struc.program,
	     "^/  While attaching the print file  ^R^a^B^/  to the I/O switch  ^R^a^B.
  Release any other activations of ^a and try again.", arg_struc.output_file, fcb.ioname, arg_struc.program);
	return;

BAD_SEARCH:
	progress = min (progress, 7);
	go to BAD_S (progress);
BAD_S(0): call com_err_ (code, arg_struc.program, "^/  While calling lib_descriptor_$print.");
	go to DETACH;
BAD_S(1): call com_err_ (code, arg_struc.program, "^/  While finding the  '^R^a^B'  library descriptor.",
	     arg_struc.descriptor);
	go to DETACH;
BAD_S(2): call com_err_ (code, arg_struc.program,
	     "^/  Library descriptor  '^R^a^B'  does not implement^/  the ^a command.",
	     arg_struc.descriptor, arg_struc.program);
	go to DETACH;
BAD_S(3): state = "library";
	go to NO_DEFAULT_NAMES;
BAD_S(4): state = "search";
NO_DEFAULT_NAMES:
	call com_err_ (code, arg_struc.program,
	     "^/  No ^a names were specified, and the  '^R^a^B'
  library descriptor does not define any default ^a names.", state, arg_struc.descriptor, state);
	go to DETACH;
BAD_S(5): call com_err_ (code, arg_struc.program, "^/  While allocating the root nodes of the library tree.");
	go to DETACH;

BAD_S(6):
NO_MATCH:	call com_err_ (code, arg_struc.program,
	     "^/  While searching for entries in the library.^/  Descriptor:^-^5x^a",
	     arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	call lib_error_list_ ("search name", Pstarname, arg_struc.program);
	go to DETACH;
BAD_S(7):	call com_err_ (code, arg_struc.program, "^/  No libraries matching the library name(s) could be found.
  Descriptor:^-^5x^a", arg_struc.descriptor);
	call lib_error_list_ ("library name", Plibrary, arg_struc.program);
	go to DETACH;

NO_NAME:	call com_err_ (error_table_$noarg, arg_struc.program,
	     "^/  At least one of the following control arguments must be given
  so that the name of each library entry will be output:
     -name, -match, -primary, or -default.");
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


no_end_page:	procedure;			/* This is a null end-of-page handling proc.	*/

	fcb.page_no = fcb.page_no + 1;
	fcb.line_no = 1;

	end no_end_page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_arg_struc_;

%include lib_based_args_;

%include lib_fcb_;

%include lib_list_;

%include lib_node_;


	end library_print;




		    multics_library_search_.pl1     04/10/84  1009.2rew 04/10/84  1004.2      485343



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

/* Modified 10/11/83 by Jim Lippard to remove references to sys_dates_ */
/* Modified 03/05/84 by Jim Lippard to return error_table_$logical_volume_not_connected			*/

multics_library_search_:	procedure options(rename((alloc_,smart_alloc_)));

     dcl						/* 		parameters		*/
/*	Pnode			ptr,		/* ptr to node to be examined/searched. (In)	*/
	path			char(168) varying;	/* path name of this node. (In)		*/
%include lib_based_args_;
     dcl	APstarname		ptr,		/* ptr to input starnames. (In)		*/
	APexclude			ptr,		/* ptr to input exclude search names. (In)	*/
	ASrequirements		bit(72) aligned,	/* requirements bits. (In)			*/
	AScontrol			bit(36) aligned,	/* control bits.				*/
	tree_level		fixed bin,	/* depth of our node in the tree. (In)		*/
	link_level		fixed bin,	/* number of links chased from last non-link node	*/
						/*    to reach our node. (In)			*/
	Parea			ptr,		/* ptr to an allocation area.			*/
	Adirector			entry (ptr, char(168) varying, ptr, bit(72) aligned,
				       bit(36) aligned, fixed bin, fixed bin, ptr, entry, ptr, ptr,
				       fixed bin(35)) variable,
						/* entry point where our search proc entered.(In)	*/
	PA			ptr,		/* ptr to our control argument struc. (In)	*/
	PA_saved			ptr,		/* saved copy of PA so we can return info to caller */
/*	PDnodes			ptr,		/* ptr to descendant nodes of input node. (Out)	*/
	Acode			fixed bin(35);	/* a status code. (Out)			*/

     dcl						/*		automatic variables		*/
	Soutputable		bit(1) aligned,	/* on if an MSF node is outputable.		*/
	1 auto_star		structure,	/* a star name temporary.			*/
	  2 N			fixed bin,
	  2 V			char(32),
	  2 C			fixed bin(35),
	code			fixed bin(35),	/* a status code.				*/
         (max_Scontrol, min_Scontrol)	bit(36) aligned,	/* max/min control bits.			*/
	1 director_args,				/* our control argument structure.		*/
	  2 command		fixed bin,	/*    command index.			*/
						/*      1 = library_info			*/
						/*      2 = library_map			*/
						/*      3 = library_print			*/
	  2 n_found		fixed bin,	/*    = number of entries found		*/
	  2 Pstar			ptr,		/*    = addr (starname) at level 1.		*/
	  2 Sreq			bit(72) aligned,	/*    = ASrequirements at level 1.		*/
	  2 Scontrol		bit(36) aligned,	/*    = AScontrol at level 1.			*/
	  2 search_type		fixed bin,	/*    type of search being performed.		*/
						/*      1 = online directories.		*/
						/*      2 = hardcore directories.		*/
         (i, j)			fixed bin,	/* a do-group index.			*/
	search_type		fixed bin;	/* type of search being performed, as specified	*/
						/*    in director_args.search_type.		*/

     dcl						/*		based variables		*/
	1 A			like director_args based (PA);
						/* our control argument structure.		*/

     dcl						/*		builtin functions		*/
         (addr, index, mod, null, reverse, string, substr)
				builtin;

     dcl						/*		entry constants		*/
	get_ring_			entry returns (fixed bin(6)),
	lib_free_node_$array	entry (ptr),
	lib_get_tree_		entry (ptr, char(168) varying, ptr, ptr, bit(72) aligned,
				       bit(36) aligned, fixed bin, fixed bin, ptr, entry, ptr, ptr,
				       fixed bin(35)),
	match_star_name_		entry (char(*), char(*), fixed bin(35));

     dcl						/*		static variables		*/
	Sinit			bit(1) aligned int static init ("1"b),
						/* switch:  on if requirements must be inited.	*/
	max_Srequirements (1:5)	bit(72) aligned int static,
         (max_cleanup_Scontrol,
	min_cleanup_Scontrol)	bit(36) aligned int static,
         (max_exec_Scontrol,
	max_list_info_Scontrol,
	max_object_Scontrol,
	max_source_Scontrol,
	min_exec_Scontrol,
	min_list_info_Scontrol,
	min_object_Scontrol,
	min_source_Scontrol) (1:4)
				bit(36) aligned int static,
         (Sreq_archive_comp_parent,
	Sreq_archive_comp_no_parent,
	Sreq_msf_comp,
	Sreq_link,
	Sreq_offline_seg,
	Sreq_seg) (1:5)
				bit(72) aligned int static,
         (error_table_$logical_volume_not_connected,
	error_table_$nomatch,
	error_table_$process_stopped,
	error_table_$undefined_order_request)
				fixed bin(35) ext static,
	ring			fixed bin(6) int static,
	1 starstar		int static options(constant),
	  2 N			fixed bin init(1),	/* starname structure for a star name of "**".	*/
	  2 V			char(32) init ("**"),
	  2 C			fixed bin(35) init (2);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


offline_execution_dirs:
online_execution_dirs:
execution_dirs: entry (Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to execdir(A.command * 10 + tree_level);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


offline_list_info_dirs:
online_list_info_dirs:
list_info_dirs: entry (Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to lsinfodir(A.command * 10 + tree_level);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


offline_object_dirs:
online_object_dirs:
object_dirs: entry	(Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			 link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to objdir(A.command * 10 + tree_level);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


offline_source_dirs:
online_source_dirs:
source_dirs: entry	(Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			 link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to searchdir(A.command * 10 + tree_level);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

execdir(11):					/* library_info,  level 1:  execution dirs.	*/
execdir(21):					/* library_map,   level 1:  execution dirs.	*/
execdir(31):					/* library_print, level 1:  execution dirs.	*/
execdir(41):					/* library_fetch, level 1:  execution dirs.	*/
	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	min_Scontrol = min_exec_Scontrol(A.command);	/* set up control info.			*/
	max_Scontrol = max_exec_Scontrol(A.command);
	go to online_level_1;


lsinfodir(11):					/* library_info,  level 1:  list/info dirs.	*/
lsinfodir(21):					/* library_map,   level 1:  list/info dirs.	*/
lsinfodir(31):					/* library_print, level 1:  list/info dirs.	*/
lsinfodir(41):					/* library_fetch, level 1:  list/info dirs.	*/
	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	min_Scontrol = min_list_info_Scontrol(A.command);	/* set up control info.			*/
	max_Scontrol = max_list_info_Scontrol(A.command);
	go to online_level_1;


objdir(11):					/* library_info,  level 1:  object dirs.	*/
objdir(21):					/* library_map,   level 1:  object dirs.	*/
objdir(31):					/* library_print, level 1:  object dirs.	*/
objdir(41):					/* library_fetch, level 1:  object dirs.	*/
	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	min_Scontrol = min_object_Scontrol(A.command);	/* set up control info.			*/
	max_Scontrol = max_object_Scontrol(A.command);
	go to online_level_1;


searchdir(11):					/* library_info,  level 1:  source dirs.	*/
searchdir(21):					/* library_map,   level 1:  source dirs.	*/
searchdir(31):					/* library_print, level 1:  source dirs.	*/
searchdir(41):					/* library_fetch, level 1:  source dirs.	*/
	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	min_Scontrol = min_source_Scontrol(A.command);	/* set up control info.			*/
	max_Scontrol = max_source_Scontrol(A.command);
	go to online_level_1;



online_level_1:
	if node.T ^= Tdirectory then go to reject;	/* accept only directories as root nodes.	*/
	search_type = 1;
	call set_director_args (min_Scontrol, max_Scontrol, search_type);
						/* set up complete director control arguments.	*/
	node.Sreq = ""b;				/* output nothing about root directory.		*/
	call next_tree_level (Sreq_seg(A.command), reject);
						/* apply segment default requirements when	*/
						/*    getting the next level of the tree, and	*/
						/*    reject the directory root node of the tree	*/
						/*    if no matching library entries were found	*/
						/*    in that directory.			*/
	PA = PA_saved;
	A.n_found = director_args.n_found;
	go to return;

execdir(12):					/* library_info,  level 2:  exec ents.		*/
lsinfodir(12):					/* library_info,  level 2:  list/info ents.	*/
objdir(12):					/* library_info,  level 2:  object ents.	*/
searchdir(12):					/* library_info,  level 2:  source ents.	*/
execdir(22):					/* library_map,   level 2:  exec ents.		*/
lsinfodir(22):					/* library_map,   level 2:  list/info ents.	*/
objdir(22):					/* library_map,   level 2:  object ents.	*/
searchdir(22):					/* library_map,   level 2:  source ents.	*/
	Scontrol = A.Scontrol;
	if Sc.retain then;				/* eliminate nodes for library entries awaiting	*/
	else call reject_node_if_obsolete();		/*    deletion.				*/
	if node.Pparent -> node.T = Tlink then		/* mark first name of link target as outputable.	*/
	     Sreq.primary_name = "1"b;
	if node.T = Tsegment			/* for segments:				*/
	     then ;
	else if node.T = Tlink then do;		/* for links:				*/
	     if Sc.default then			/*    add further default requirements to link.	*/
		node.Sreq = (node.Sreq | Sreq_link(A.command)) & node.Svalid;
	     call next_tree_level ((ASrequirements), return);
	     end;
	else if node.T = Tarchive then do;		/* for archives:				*/
	     if Sc.components then
		Pstarname = addr(starstar);		/*    tell about all archive components.	*/
	     else Pstarname = A.Pstar;
	     Srequirements = A.Sreq;
	     if Sc.default then
		if Sc.container then		/*    say little about archive component if we	*/
		     Srequirements = Srequirements | Sreq_archive_comp_parent(A.command);
		else				/*    we are already given that info about parent.*/
		     Srequirements = Srequirements | Sreq_archive_comp_no_parent(A.command);
	     call next_tree_level_special (suppress_nomatch);
	     Sreq.cross_ref = "0"b;			/*  do not cross-reference archive names.	*/
	     if Sc.container then do;			/* say nothing about added names on parent archive*/
						/*   when all comps being listed unless asked.	*/
		Srequirements = A.Sreq;
		Pstarname = A.Pstar;
		if starname(1).C = 2 then do;		/* User is listing all comps in all archives.	*/
		     Sreq.names = S.names;		/*   Give only names explicitly reqd (non-default)*/
		     Sreq.matching_names = S.matching_names;
		     Sreq.primary_name = "1"b;	/*   But always return first name.		*/
		     end;
		else if Sc.components then		/* User listing all comps of one archive.	*/
		     Sreq.names = S.names;		/*   Only give all names if explicitly asked for.	*/
		end;
	     else if Sc.components & (A.command ^= library_info) then
		if Sc.default then do;
		     Srequirements = A.Sreq;
		     Sreq.names = S.names;
		     Sreq.matching_names = S.matching_names;
		     end;
		else;
	     else					/* if user didn't ask about parent archive,	*/
		node.Sreq = ""b;			/*    then mum's the word.			*/
	     end;
	else if node.T = Tmsf then			/* for msfs:				*/
	     call next_tree_level (Sreq_msf_comp(A.command), return);
	else go to reject;				/* reject all other node types.		*/
	go to return;


execdir(13):					/* library_info,  level 3:  exec comps.		*/
lsinfodir(13):					/* library_info,  level 3:  list/info comp?	*/
objdir(13):					/* library_info,  level 3:  object comps.	*/
searchdir(13):					/* library_info,  level 3:  source comps.	*/
execdir(23):					/* library_map,   level 3:  exec comps.		*/
lsinfodir(23):					/* library_map,   level 3:  list/info comp?	*/
objdir(23):					/* library_map,   level 3:  object comps.	*/
searchdir(23):					/* library_map,   level 3:  source comps.	*/
	Scontrol = A.Scontrol;
	Sreq.names = "1"b;				/* must always require that names of things	*/
						/*   at this level be output, so that when -match	*/
						/*   is specified, archive and MSF component names*/
						/*   are still printed.			*/
	if node.T = Tarchive_comp	 		/* for archive components:			*/
	     then ;
	else if node.Pparent -> node.T = Tmsf then do;	/* for msf components:			*/
	     if node.T = Tmsf_comp then;
	     else if node.T = Tlink then do;		/*    msf components which are links --		*/
chase_searchdir23:	if Sc.default then
		     node.Sreq = (node.Sreq | Sreq_link(A.command)) & node.Svalid;
		call next_tree_level ((ASrequirements), return);
		end;
	     else go to reject;
	     end;
	else if node.Pparent -> node.T = Tlink then do;	/* for msf components which are links --	*/
	     if node.T = Tsegment then;
	     else if node.T = Tlink then go to chase_searchdir23;
	     else go to reject;
	     end;
	else go to reject;				/* reject all other node types.		*/
	go to return;

execdir(32):					/* library_print, level 2:  exec ents.		*/
lsinfodir(32):					/* library_print, level 2:  list/info ents.	*/
objdir(32):					/* library_print, level 2:  object ents.	*/
searchdir(32):					/* library_print, level 2:  source ents.	*/
	Scontrol = A.Scontrol;
	if Sc.retain then;				/* eliminate nodes for library entries awaiting	*/
	else call reject_node_if_obsolete();		/*    deletion.				*/
	if node.Pparent -> node.T = Tlink then		/* mark first name of link target as outputable.	*/
	     Sreq.primary_name = "1"b;
	if node.T = Tsegment then			/* for segments:				*/
	     if node_outputable (Pnode) then;		/*    ensure outputability of node.		*/
	     else go to reject;
	else if node.T = Tlink then do;		/* for links:				*/
	     if Sc.default then			/*    add further default requirements to link.	*/
		node.Sreq = (node.Sreq | Sreq_link(A.command)) & node.Svalid;
	     call next_tree_level ((ASrequirements), reject);
	     end;					/*    reject link if its target is rejected.	*/
	else if node.T = Tarchive then do;		/* for archives:				*/
	     if Sc.components then			/*    if asked to, output all components of arch.	*/
		Pstarname = addr(starstar);
	     else					/*    otherwise, output matching components.	*/
		Pstarname = A.Pstar;
	     Srequirements = A.Sreq;
	     if Sc.default then
		Srequirements = Srequirements | Sreq_archive_comp_no_parent(A.command);
	     if node_outputable (Pnode) then do;	/*    if archive itself is outputable:		*/
		call next_tree_level_special (suppress_nomatch);
		node.Sreq = ""b;			/*       output entire archive _o_n_l_y if no comps 	*/
		end;				/*       match star names.			*/
	     else do;				/*    if archive is not printable:		*/
		call next_tree_level_special (reject);	/*       reject it if no matching comps found,	*/
		node.Sreq = ""b;			/*       or mark it unprintable if matches found.	*/
		end;
	     end;
	else if node.T = Tmsf then do;		/* for msfs:				*/
	     call next_tree_level (Sreq_msf_comp(3), return);
	     Dnodes.Pnext = node.PD;
	     node.PD = PDnodes;
	     Svalid.kids = "1"b;
	     Soutputable = node_outputable (Pnode);
	     node.PD = Dnodes.Pnext;
	     Dnodes.Pnext = null;
	     Svalid.kids = "0"b;
	     if ^Soutputable then go to reject;		/*    reject MSF if any components not outputable	*/
	     end;
	else go to reject;				/* reject all other node types.		*/
	go to return;

execdir(33):					/* library_print, level 3:  exec comps.		*/
lsinfodir(33):					/* library_print, level 3:  list/info comp?	*/
objdir(33):					/* library_print, level 3:  object comps.	*/
searchdir(33):					/* library_print, level 3:  source comps.	*/
	Scontrol = A.Scontrol;
	Sreq.names = "1"b;				/* must always require that names of things	*/
						/*   at this level be output, so that when -match	*/
						/*   is specified, archive and MSF component names*/
						/*   are still printed.			*/
	if node.T = Tarchive_comp then		/* for archive components:			*/
	     if node_outputable (Pnode) then;		/*    reject component if not outputable.	*/
	     else go to reject;
	else if node.Pparent -> node.T = Tmsf then do;	/* for msf components:			*/
	     if node.T = Tmsf_comp then;
	     else if node.T = Tlink then do;		/*    msf components which are links --		*/
chase_searchdir33:	if Sc.default then
		     node.Sreq = (node.Sreq | Sreq_link(A.command)) & node.Svalid;
		call next_tree_level ((ASrequirements), return);
		end;
	     end;
	else if node.Pparent -> node.T = Tlink then do;	/* for msf components which are links --	*/
	     if node.T = Tsegment then;
	     else if node.T = Tlink then go to chase_searchdir33;
	     end;
	else go to reject;				/* reject all other node types.		*/
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


execdir(42):					/* library_fetch, level 2:  exec ents.		*/
lsinfodir(42):					/* library_fetch, level 2:  list/info ents.	*/
objdir(42):					/* library_fetch, level 2:  object ents.	*/
searchdir(42):					/* library_fetch, level 2:  source ents.	*/
	Scontrol = A.Scontrol;
	if Sc.retain then;				/* eliminate nodes for library entries awaiting	*/
	else call reject_node_if_obsolete();		/*   deletion.				*/
	if node.T = Tsegment then;			/* for segments, all done.			*/
	else if node.T = Tlink then do;		/* for links:				*/
	     if Sc.default then			/*   add further default requirements to link.	*/
		node.Sreq = (node.Sreq | Sreq_link(A.command)) & node.Svalid;
	     if Sc.chase then			/*   if caller asked to chase links, do so.	*/
		call next_tree_level ((ASrequirements), return);
	     end;
	else if node.T = Tarchive then do;		/* for archives:				*/
	     if Sc.components then			/* tell about archive components.		*/
		Pstarname = addr(starstar);
	     else					/* tell about selected archive components.	*/
		Pstarname = A.Pstar;
	     if Sc.container then			/* wants to extract parent archive, not components*/
		Sreq.primary_name = "1"b;		/*   must return first name of archive as well.	*/
	     else do;				/* wants matching components, not parent archive.	*/
		Srequirements = A.Sreq;
		if Sc.default then Srequirements = Srequirements | Sreq_seg(4);
		call next_tree_level_special (return);
		node.Sreq = ""b;			/* return nothing about archive if matching	*/
		end;				/*   archive component(s) found.		*/
	     end;
	else if node.T = Tmsf then			/* for msfs:				*/
	     call next_tree_level (Sreq_msf_comp(A.command), return);
	else go to reject;				/* all other types of nodes should not be.	*/
	go to return;

execdir(43):					/* library_fetch, level 3:  exec comps.		*/
lsinfodir(43):					/* library_fetch, level 3:  list/info comp?	*/
objdir(43):					/* library_fetch, level 3:  object comps.	*/
searchdir(43):					/* library_fetch, level 3:  source comps.	*/
	Scontrol = A.Scontrol;
	if node.T = Tarchive_comp then
	     Sreq.primary_name = "1"b;		/* must get atleast first name back.		*/
	else if node.Pparent -> node.T = Tmsf then do;	/* for msf components:			*/
	     if node.T = Tmsf_comp then;
	     else if node.T = Tlink then do;		/*    msf components which are links --		*/
chase_searchdir43:	if Sc.default then
		     node.Sreq = (node.Sreq | Sreq_link(A.command)) & node.Svalid;
		call next_tree_level ((ASrequirements), return);
		end;
	     else go to reject;
	     end;
	else if node.Pparent -> node.T = Tlink then do;	/* for msf components which are links --	*/
	     if node.T = Tsegment then;
	     else if node.T = Tlink then go to chase_searchdir43;
	     else go to reject;
	     end;
	else go to reject;
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


execdir(51):					/* library_cleanup,level 1: execution dirs.	*/
lsinfodir(51):					/* library_cleanup,level 1: list/info dirs.	*/
objdir(51):					/* library_cleanup,level 1: object dirs.	*/
searchdir(51):					/* library_cleanup,level 1: source dirs.	*/
	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	if node.T ^= Tdirectory then go to reject;	/* accept only directories as root nodes.	*/
	min_Scontrol = min_cleanup_Scontrol;
	max_Scontrol = max_cleanup_Scontrol;
	search_type = 1;
	call set_director_args (min_Scontrol, max_Scontrol, search_type);
						/* set up complete director control arguments.	*/
	node.Sreq = ""b;				/* output nothing about the root directory.	*/
	call next_tree_level (Sreq_seg(A.command), reject);
	go to return;				/* get nodes for lib entries p be deleted.	*/


execdir(52):					/* library_cleanup,level 2: exec ents.		*/
lsinfodir(52):					/* library_cleanup,level 2: list/info ents.	*/
objdir(52):					/* library_cleanup,level 2: object ents.	*/
searchdir(52):					/* library_cleanup,level 2: source ents.	*/
	if APstarname->starname.N = 1 then if APstarname->starname.V(1) = "!??????????????" then go to obsolete;
						/* if looking only for obsolete segments, skip	*/
						/* next check.				*/
	do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
	     end;					/* make sure entry has a unique name on it.	*/
	do i = 1 to APstarname->starname.N;
	     if APstarname->starname.V(i) = "!??????????????" then go to test;
	     end;
	go to obsolete;				/* omit test for unique name if no search name	*/
						/*   matches unique names.			*/
test:	if index (string(Dnames.names), "!") > 0 then
	     do i = 1 to Dnames.N;
		call match_star_name_ (Dnames.names(i), "!??????????????", code);
		if code = 0 then go to obsolete;
		end;
	go to reject;				/* reject nodes which aren't obsolete.		*/

obsolete:	if node.T = Tdirectory then go to reject;	/* can't delete directories; shouldn't anyway.	*/
	if node.T = Tarchive_comp then go to reject;	/* same for archive components.		*/
	if node.T = Tmsf_comp then go to reject;	/* same for msf components.			*/
	go to return;				/* all other types of nodes can be deleted.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


hardcore_bc_dir:	entry     (Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			 link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to hbd(A.command * 10 + tree_level);



hbd(11):						/* library_info,  level 1:  hardcore bc dir.	*/
hbd(21):						/* library_map,   level 1:  hardcore bc dir.	*/
hbd(31):						/* library_print, level 1:  hardcore bc dir.	*/
hbd(41):						/* library_fetch, level 1:  hardcore bc dir.	*/
	search_type = 2;				/* set search type info for hardcore.		*/

	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	if node.T ^= Tdirectory then go to reject;	/* accept only the bound component dir as a root.	*/
	call set_director_args (min_object_Scontrol(A.command), max_object_Scontrol(A.command), search_type);
						/* set up complete director control arguments.	*/
	node.Sreq = ""b;				/* output nothing about the root directory.	*/
	Scontrol = A.Scontrol;			/* Because some of user's star names may match	*/
	Srequirements = A.Sreq;			/*    bc archives while others may match only	*/
	if Sc.default then Srequirements = Srequirements | Sreq_offline_seg(A.command);
	Pstarname = addr(starstar);			/*    bc archive components, we must search _a_l_l	*/
	call next_tree_level_special (reject);		/*    does not cost use anything if the user's	*/
	go to return;				/*    star name is "**".			*/

hbd(12):						/* library_info,  level 2:  hardcore bc archives.	*/
hbd(22):						/* library_map,   level 2:  hardcore bc archives.	*/
hbd(42):						/* library_fetch, level 2:  hardcore bc archives.	*/
	if ^Svalid.names then go to bc_nonames;
	do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
	     end;					/* If any of this bc archive's names match a	*/
	Pstarname = A.Pstar;			/*    user-specified star name, then output info	*/
						/*    about this bc archive.  Otherwise, don't.	*/
	do i = 1 to Dnames.N;
	     do j = 1 to starname.N;
		go to bc_test (starname.C(j));

bc_test(0):	if Dnames.names(i) = starname.V(j) then go to bc_match;
		else go to bc_nomatch;

bc_test(1):	call match_star_name_ (Dnames.names(i), starname.V(j), code);
		if code = 0 then go to bc_match;
		else go to bc_nomatch;

bc_test(2):	go to bc_match;
bc_nomatch:	end;
	     end;
bc_nonames:					/* Case 1:  no archive names match user star names*/
	if node.T ^= Tarchive then go to reject;	/*  Only archives handled in this case.		*/
	Scontrol = A.Scontrol;
	if starname.N = 1 then do;			/* speed up extraction of bind files.		*/
	     call match_star_name_ (starname.V(1), "**.bind", code);
	     if code = 0 then do;
		i = 33 - index(reverse(starname.V(1)), ".");
		auto_star.V = substr(starname.V(1),1,i) || "archive";
		call match_star_name_ (Dnames.names(1), auto_star.V, code);
		if code ^= 0 then go to reject;
		end;
	     end;
	if Sc.container then do;			/* user want's to know about parent archive	*/
						/*    of a matching archive component.		*/
	     call next_tree_level (Sreq_archive_comp_parent(A.command), reject);
	     if A.command = library_fetch then		/* for library_fetch, want to extract only the	*/
		call lib_free_node_$array (PDnodes);	/*   archive containing matching components, not	*/
						/*   the components as well.			*/
	     end;
	else do;					/* user doesn't want to know about parent archive.*/
	     node.Sreq = ""b;
	     call next_tree_level (Sreq_archive_comp_no_parent(A.command), reject);
	     end;
	go to return;
bc_match:						/* Case 2:  an archive name matches user star name*/
	if node.T ^= Tarchive then go to lsinfodir (A.command * 10 + tree_level);
	Scontrol = A.Scontrol;			/* set up control and requirements info.	*/
	Srequirements = A.Sreq;
	if Sc.default then 
	     if Sc.container then			/*    say little about archive component if we	*/
	          Srequirements = Srequirements | Sreq_archive_comp_parent(A.command);
	     else					/*    we are already given that info about parent.*/
	          Srequirements = Srequirements | Sreq_archive_comp_no_parent(A.command);

	if Sc.components then			/* user wants to know about _a_l_l archive comps	*/
	     Pstarname = addr(starstar);		/*    in this matching archive.		*/
	else					/* user wants info on only matching archive comps.*/
	     Pstarname = A.Pstar;
	call next_tree_level_special (suppress_nomatch);
	if A.command = library_fetch then		/* for library_fetch, if matching components	*/
	     node.Sreq = ""b;			/*    found, don't extract matching archive too.	*/
	else if ^Sc.container then 			/* if matching components found and parent info	*/
	     node.Sreq = ""b;			/*   not required, don't output it.		*/
	go to return;
 
hbd(13):						/* library_info,  level 3:  hardcore bc arch comp.*/
hbd(23):						/* library_map,   level 3:  hardcore bc arch comp.*/
	if node.Pparent -> node.T ^= Tarchive then go to reject;
						/* reject any node which isn't an archive comp.	*/
	Sreq.names = "1"b;				/* must always require that names of things	*/
						/*   at this level be output, so that when -match	*/
						/*   is specified, archive and MSF component names*/
						/*   are still printed.			*/
	go to return;


hbd(43):						/* library_fetch, level 3:  hardcore bc arch comp.*/
	if node.Pparent -> node.T ^= Tarchive then go to reject;
						/* reject any node (archive component or archived	*/
						/*   archive) which isn't in an archive.	*/
	Sreq.primary_name = "1"b;			/* must get atleast first name back.		*/
	go to return;

hbd(32):						/* library_print, level 2:  hardcore bc archives.	*/
	if node.T = Tarchive then node.Sreq = ""b;	/* an object archive itself can never be output.	*/
	if ^Svalid.names then go to bc_pr_nonames;
	do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
	     end;					/* If any of this bc archive's names match a	*/
	Pstarname = A.Pstar;			/*    user-specified star name, then output info	*/
						/*    about this bc archive.  Otherwise, don't.	*/
	do i = 1 to Dnames.N;
	     do j = 1 to starname.N;
		go to bc_pr_test (starname.C(j));

bc_pr_test(0):	if Dnames.names(i) = starname.V(j) then go to bc_pr_match;
		else go to bc_pr_nomatch;

bc_pr_test(1):	call match_star_name_ (Dnames.names(i), starname.V(j), code);
		if code = 0 then go to bc_pr_match;
		else go to bc_pr_nomatch;

bc_pr_test(2):	go to bc_pr_match;
bc_pr_nomatch:	end;
	     end;
bc_pr_nonames:					/* Case 1:  no archive names match user star names*/
	if node.T ^= Tarchive then go to reject;
	call next_tree_level (Sreq_archive_comp_no_parent(A.command), reject);
	go to return;

bc_pr_match:					/* Case 2:  an archive name matches user star name*/
	if node.T ^= Tarchive then go to lsinfodir(A.command * 10 + tree_level);
	Scontrol = A.Scontrol;			/* set up control and requirements info.	*/
	Srequirements = A.Sreq;
	if Sc.default then Srequirements = Srequirements | Sreq_archive_comp_no_parent(A.command);
	if Sc.components then			/* user wants to know about all components of	*/
	     Pstarname = addr(starstar);		/*    of this matching archive.		*/
	else					/* user wants info on only matching archive comps.*/
	     Pstarname = A.Pstar;
	call next_tree_level_special (reject);
	go to return;


hbd(33):						/* library_print, level 3:  hardcore bc arch comp.*/
	if node.Pparent -> node.T ^= Tarchive then go to reject;
						/* reject any node which isn't an archive comp.	*/
	if node_outputable (Pnode) then;		/* reject an unoutputable archive component.	*/
	else go to reject;
	Sreq.names = "1"b;				/* must always require that names of things	*/
						/*   at this level be output, so that when -match	*/
						/*   is specified, archive and MSF component names*/
						/*   are still printed.			*/
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


hardcore_object_dir: entry	(Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			 link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to hod(A.command * 10 + tree_level);



hod(11):						/* library_info,  level 1:  hardcore object dir.	*/
hod(21):						/* library_map,   level 1:  hardcore object dir.	*/
hod(31):						/* library_print, level 1:  hardcore object dir.	*/
hod(41):						/* library_fetch, level 1:  hardcore object dir.	*/
	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	search_type = 2;				/* set up search type.			*/

	if node.T ^= Tdirectory then go to reject;	/* accept only the object directory as a root.	*/
	call set_director_args (min_exec_Scontrol(A.command), max_exec_Scontrol(A.command), search_type);
						/* set up complete director control arguments.	*/
	node.Sreq = ""b;				/* output nothing about the root directory.	*/
	call next_tree_level (Sreq_offline_seg(A.command), reject);
						/* apply offline segment reqmts when getting	*/
	go to return;				/*    object segments at next tree level.	*/

hod(12):						/* library_info,  level 2:  hardcore object ents.	*/
hod(22):						/* library_map,   level 2:  hardcore object ents.	*/
hod(42):						/* library_fetch, level 2:  hardcore object ents.	*/
	if node.T ^= Tsegment then go to reject;	/* only segments are allowed in object dir.	*/
	go to return;				/* add system id to node information.		*/


hod(32):						/* library_print, level 2:  hardcore object ents.	*/
	if node.T ^= Tsegment then go to reject;	/* only segments are allowed in object dir.	*/
	if node_outputable (Pnode) then;		/* reject any unoutputable segment.		*/
	else go to reject;
	go to return;				/* add system id to node information.		*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


hardcore_source_dir: entry	(Pnode, path, APstarname, APexclude, ASrequirements, AScontrol, tree_level,
			 link_level, Parea, Adirector, PA, PDnodes, Acode);

	Scontrol = AScontrol;
	if Sc.first_match & A.n_found > 0 then go to reject;
	go to hsd(A.command * 10 + tree_level);


hsd(11):						/* library_info,  level 1:  hardcore source dir.	*/
hsd(21):						/* library_map,   level 1:  hardcore source dir.	*/
hsd(31):						/* library_print, level 1:  hardcore source dir.	*/
hsd(41):						/* library_fetch, level 1:  hardcore source dir.	*/
	search_type = 2;				/* set search type info for hardcore.		*/

	if Sinit then call init_vars();		/* initialize internal static variables.	*/
	if node.T ^= Tdirectory then go to reject;	/* accept only the source directory as a root.	*/
	call set_director_args (min_source_Scontrol(A.command), max_source_Scontrol(A.command), search_type);
						/* set up complete director control arguments.	*/
	node.Sreq = ""b;				/* output nothing about the source directory.	*/
	Scontrol = A.Scontrol;			/* set up control and requirements info in	*/
	Srequirements = A.Sreq;			/*    for getting next tree level.		*/
	if Sc.default then Srequirements = Srequirements | Sreq_offline_seg(A.command);
	Pstarname = A.Pstar;			/* access the user's star name.		*/
	code = 1;
	if A.command = library_info then		/* for library_info, if a single star name was	*/
	     if starname.N = 1 then			/*   given, and it matches archive name format,	*/
		call match_star_name_ (starname.V(1), "**.archive", code);
						/*   treat it as the search name w/o modification.*/
	if (starname.N = 1) & (code ^= 0) then do;	/* if he gave only 1 star name, we can look only	*/
						/*    in those source archives which might hold	*/
						/*    matches for that name.			*/
	     auto_star.N = 1;
	     auto_star.V = substr(starname.V(1),1,1) || "?.archive";
	     auto_star.C = 1;			/* map    "able.pl1" into "a?.archive";		*/
	     Pstarname = addr(auto_star);		/*	"*.alm"    into "*?.archive";		*/
	     end;					/*	"?able.*"  into "??.archive".		*/
	else if code = 0 then;			/* use user's archive name if in that format.	*/
	else					/* if more than one star name, we must look in	*/
	     Pstarname = addr(starstar);		/*    _a_l_l source archives for matches.		*/
	call next_tree_level_special (reject);		/* get tree nodes for archives which contain	*/
						/*    source components which match user's star	*/
	go to return;				/*    names.				*/


hsd(12):						/* library_info,  level 2:  hardcore source arch.	*/
hsd(22):						/* library_map,   level 2:  hardcore source arch.	*/
hsd(32):						/* library_print, level 2:  hardcore source arch.	*/
hsd(42):						/* library_fetch, level 2:  hardcore source arch.	*/
	if node.T ^= Tarchive then go to reject;	/* accept only source archives.		*/
	Pstarname = A.Pstar;			/* see if this archive can possible contain what	*/
	do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
	     end;					/*     what we're looking for.		*/
	do i = 1 to starname.N;
	     call match_star_name_ (Dnames.names(1), substr(starname.V(i),1,1) || "?.archive", code);
	     if code = 0 then go to hs_match;
	     end;
	go to reject;
hs_match:	if A.command ^= library_info then do;
	     call next_tree_level (Sreq_archive_comp_no_parent(A.command), reject);
						/* get tree nodes for matching source comps, but	*/
						/*    reject node for source archive if no	*/
						/*    matching source components are found.	*/
	     node.Sreq = ""b;
	     end;
	else do;					/* for library_info, allow information about the	*/
						/*   source archives, themselves.		*/
	     Scontrol = A.Scontrol;
	     Srequirements = A.Sreq;
	     if Sc.default then
		if Sc.container then		/*    say little about archive component if we	*/
		     Srequirements = Srequirements | Sreq_archive_comp_parent(A.command);
		else				/*    we are already given that info about parent.*/
		     Srequirements = Srequirements | Sreq_archive_comp_no_parent(A.command);
	     if APstarname = A.Pstar then do;		/* if user gave an archive name, rather than a	*/
						/*   component name, process things differently.	*/
		if Sc.components then do;		/* User wants all components back as well. OK	*/
		     Pstarname = addr(starstar);
		     call next_tree_level_special (return);
		     end;
		end;
	     else do;				/* user gave an archive component name.		*/
		Pstarname = A.Pstar;
		call next_tree_level_special (reject);	/* find matching archive components.		*/
		if ^Sc.container then
		    node.Sreq = ""b;
		end;
	     end;
	go to return;


hsd(13):						/* library_info,  level 3:  hardcore source comp.	*/
hsd(23):						/* library_map,   level 3:  hardcore source comp.	*/
hsd(33):						/* library_print, level 3:  hardcore source comp.	*/
hsd(43):						/* library_fetch, level 3:  hardcore source comp.	*/
	if node.T ^= Tarchive_comp then go to reject;	/* accept only archive components at this level.	*/
	Sreq.names = "1"b;				/* must always require that names of things	*/
						/*   at this level be output, so that when -match	*/
						/*   is specified, archive and MSF component names*/
						/*   are still printed.			*/
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


         execdir(61):
         lsinfodir(61):
         objdir(61):
         searchdir(61):
         ptd(61):
hbd(51): hbd(61):
hod(51): hod(61):
hsd(51): hsd(61):
	Acode = error_table_$undefined_order_request;	/* complain about unsupported commands/dirs	*/
	go to return;

reject:	Acode = error_table_$nomatch;			/* reject our input node.			*/
	return;

return:	if node.Sreq ^= ""b then A.n_found = A.n_found + 1;
	if Sc.first_match & A.n_found > 0 then Acode = error_table_$process_stopped;
	if PDnodes ^= null then
	     if Dnodes.C = error_table_$logical_volume_not_connected then Acode = Dnodes.C;
	return;					/* return our input node, in spite of any error	*/
						/*    in getting its descendant nodes.		*/

suppress_nomatch:					/* suppress a nomatch error when getting any	*/
	if PDnodes = null then;			/*    descendants of our input node.		*/
	else call lib_free_node_$array(PDnodes);
	go to return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

init_vars:  procedure;		  		/* This procedure initializes internal static	*/
						/*    variables which are used as constants.	*/
						/*    The variables include node requirement	*/
				 		/*    switches and search control switches.  They	*/
			 			/*    are initialized by referencing the switch	*/
						/*    bits by name to allow flexibility in	*/
						/*    reordering and extending the switches, and	*/
						/*    to simplify the interpretation of the	*/
						/*    array of switch bits.			*/

	ring = get_ring_();				/* get current ring number.			*/

	Srequirements = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtm = "1"b;
	S.level = "1"b;
	S.new_line = "1"b;
	S.kids_error = "1"b;
	Sreq_offline_seg(1) = Srequirements;		/* library_info:  default requirements		*/
	Sreq_seg(1) = Srequirements;

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtm = "1"b;
	S.dtem = "1"b;
	S.copy = "1"b;
	S.safety = "1"b;
	S.level = "1"b;
	S.new_line = "1"b;
	S.kids_error = "1"b;
	S.cross_ref = "1"b;
	Sreq_offline_seg(2) = Srequirements;		/* library_map:  offline segs, default reqmts.	*/
	S.dtd = "1"b;
	S.current_length = "1"b;
	S.records_used = "1"b;
	S.max_length = "1"b;
	S.bit_count = "1"b;
	S.rb = "1"b;
	Sreq_seg(2) = Srequirements;			/* library_map:  online segs, default requirements*/

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtm = "1"b;
	S.dtem = "1"b;
	S.copy = "1"b;
	S.level = "1"b;
	S.new_line = "1"b;
	S.kids_error = "1"b;
	Sreq_seg(3) = Srequirements;			/* library_print:  online segs, default reqmts.	*/
	Sreq_offline_seg(3) = Srequirements;		/* library_print:  offline segs, default reqmts.	*/

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtm = "1"b;
	S.copy = "1"b;
	S.bit_count = "1"b;
	S.dtc = "1"b;
	S.compiler_version = "1"b;
	S.compiler_options = "1"b;
	S.object_info = "1"b;
	S.level = "1"b;
	S.new_line = "1"b;
	S.kids_error = "1"b;
	Sreq_seg(4) = Srequirements;			/* library_fetch:  default requirements.	*/
	Sreq_offline_seg(4) = Srequirements;

	string(S) = ""b;
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.type = "1"b;
	S.pathname = "1"b;
	S.dtem = "1"b;
	S.copy = "1"b;
	S.kids_error = "1"b;
	Sreq_seg(5) = Srequirements;			/* library_cleanup:  default requirements	*/

	string(S) = ""b;
	S.link_target = "1"b;
	Sreq_link(4) = Srequirements;			/* for library_fetch - add only link path.	*/
	S.dtem = "1"b;
	Sreq_link(1) = Srequirements;			/* requirements added by default for links.	*/
	Sreq_link(2) = Srequirements;
	Sreq_link(3) = Srequirements;
	Sreq_link(5) = Srequirements;

	Sreq_msf_comp(1) = Sreq_seg(1);		/* requirements for online msf comp = online segs.*/
	Sreq_msf_comp(2) = Sreq_seg(2);
	Sreq_msf_comp(3) = Sreq_seg(3);
	Sreq_msf_comp(4) = Sreq_seg(4);

	string(S) = ""b;				/* requirements for mapped archive components	*/
	S.primary_name = "1"b;
	S.matching_names = "1"b;
	S.names = "1"b;
	S.dtem = "1"b;
	S.level = "1"b;
	S.new_line = "1"b;
	S.kids_error = "1"b;
	Sreq_archive_comp_parent(1) = Srequirements;	/* for archive comp when parent archive listed.	*/
	S.cross_ref = "1"b;
	Sreq_archive_comp_parent(2) = Srequirements;
	S.cross_ref = "0"b;
	Sreq_archive_comp_parent(3) = Srequirements;
	Sreq_archive_comp_parent(4) = Sreq_seg(4);
	S.type = "1"b;
	S.pathname = "1"b;
	Sreq_archive_comp_no_parent(1) = Srequirements;	/* for archive comp when parent archive omitted.	*/
	Sreq_archive_comp_no_parent(2) = Srequirements;
	Sreq_archive_comp_no_parent(3) = Srequirements;
	S.bit_count = "1"b;
	S.dtc = "1"b;
	S.compiler_version = "1"b;
	S.compiler_options = "1"b;
	S.object_info = "1"b;
	S.level = "0"b;
	Sreq_archive_comp_no_parent(4) = Srequirements;

	max_Srequirements(2) = (72)"1"b;		/* any requirements are allowed for library_map.	*/
	Srequirements = (72)"1"b;
	S.cross_ref = "0"b;
	max_Srequirements(1) = Srequirements;		/* name cross-reference omitted for library_info. */
	max_Srequirements(3) = Srequirements;		/* same for library_print.			*/
	max_Srequirements(4) = Srequirements;		/* same for library_fetch.			*/
	max_Srequirements(5) = Srequirements;		/* same for library_cleanup.			*/

	min_cleanup_Scontrol = ""b;			/* library_cleanup:  no minimum control.	*/
	Scontrol = (36)"1"b;
	Sc.chase = "0"b;
	Sc.object_info = "0"b;
	Sc.acl = "0"b;
	Sc.iacl = "0"b;
	Sc.all_status = "0"b;
	Sc.check_ascii = "0"b;
	Sc.check_archive = "0"b;
	max_cleanup_Scontrol = Scontrol;		/* library_cleanup:  maximum control.		*/

	min_exec_Scontrol(1) = ""b;			/* library_info:   exec dirs, no minimum control.	*/
	min_exec_Scontrol(2) = ""b;			/* library_map:    exec dirs, no minimum control.	*/
	Scontrol = ""b;
	Sc.check_ascii = "1"b;
	min_exec_Scontrol(3) = Scontrol;		/* library_print:  exec dirs, check printability.	*/
	Scontrol = ""b;
	Sc.object_info = "1"b;
	min_exec_Scontrol(4) = Scontrol;		/* library_fetch:  exec dirs, check for obj seg.	*/
	Scontrol = (36)"1"b;
	Sc.check_archive = "0"b;
	max_exec_Scontrol(1) = Scontrol;		/* library_info:   exec dirs, no archives.	*/
	max_exec_Scontrol(2) = Scontrol;		/* library_map:    exec dirs, no archives.	*/
	max_exec_Scontrol(3) = Scontrol;		/* library_print:  exec dirs, no archives.	*/
	Sc.check_ascii = "0"b;
	max_exec_Scontrol(4) = Scontrol;		/* library_fetch:  no ascii check either.	*/

	min_list_info_Scontrol(1) = ""b;		/* library_info:   list/info, no minimum control.	*/
	min_list_info_Scontrol(2) = ""b;		/* library_map:    list/info, no minimum control.	*/
	min_list_info_Scontrol(3) = ""b;		/* library_print:  list/info, no minimum control.	*/
	min_list_info_Scontrol(4) = ""b;		/* library_fetch:  list/info, no minimum control.	*/
	Scontrol = (36)"1"b;
	Sc.object_info = "0"b;
	Sc.check_archive = "0"b;
	Sc.check_ascii = "0"b;
	max_list_info_Scontrol(1) = Scontrol;		/* library_info:   list/info, no checking needed.	*/
	max_list_info_Scontrol(2) = Scontrol;		/* library_map:    list/info, no checking needed.	*/
	max_list_info_Scontrol(3) = Scontrol;		/* library_print:  list/info, no checking needed.	*/
	max_list_info_Scontrol(4) = Scontrol;		/* library_fetch:  list/info, no checking needed.	*/

	Scontrol = ""b;
	Sc.check_archive = "1"b;
	min_object_Scontrol(1) = Scontrol;		/* library_info:   object dirs, check archives.	*/
	min_object_Scontrol(2) = Scontrol;		/* library_map:    object dirs, check archives.	*/
	Sc.check_ascii = "1"b;
	min_object_Scontrol(3) = Scontrol;		/* library_print:  object dirs, check printability*/
	Scontrol = ""b;
	Sc.check_archive = "1"b;
	Sc.object_info = "1"b;
	min_object_Scontrol(4) = Scontrol;		/* library_fetch:  object dirs, check arch/obj seg*/
	max_object_Scontrol(1) = (36)"1"b;		/* library_info:   object dirs, no maximum control*/
	max_object_Scontrol(2) = (36)"1"b;		/* library_map:    object dirs, no maximum control*/
	max_object_Scontrol(3) = (36)"1"b;		/* library_print:  object dirs, no maximum control*/
	max_object_Scontrol(4) = (36)"1"b;		/* library_fetch:  object dirs, no maximum control*/

	Scontrol = ""b;
	Sc.check_archive = "1"b;
	min_source_Scontrol(1) = Scontrol;		/* library_info:   source dirs, check archives.	*/
	min_source_Scontrol(2) = Scontrol;		/* library_map:    source dirs, check archives.	*/
	min_source_Scontrol(3) = Scontrol;		/* library_print:  source dirs, check archives.	*/
	min_source_Scontrol(4) = Scontrol;		/* library_fetch:  source dirs, check archives.	*/
	Scontrol = (36)"1"b;
	Sc.object_info = "0"b;
	Sc.check_ascii = "0"b;
	max_source_Scontrol(1) = Scontrol;		/* library_info:   source dirs, no obj/ascii segs.*/
	max_source_Scontrol(2) = Scontrol;		/* library_map:    source dirs, no obj/ascii segs.*/
	max_source_Scontrol(3) = Scontrol;		/* library_print:  source dirs, no obj/ascii segs.*/
	max_source_Scontrol(4) = Scontrol;		/* library_fetch:  source dirs, no obj/ascii segs.*/

	Sinit = "0"b;

	end init_vars;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


next_tree_level:	procedure (default_Sreq, error_return);	/* procedure which obtains descendants of our	*/
						/*    input node.				*/

     dcl	default_Sreq		bit(72) aligned,	/* default requirements switches. (In)		*/
	error_return		label;		/* error return point. (In)			*/

	Scontrol = A.Scontrol;
	Srequirements = A.Sreq;
	if Sc.default then Srequirements = Srequirements | default_Sreq;
						/* apply default requirements if asked to do so.	*/
	Pstarname = A.Pstar;


next_tree_level_special:	entry	(error_return);	/* entry for using special star names, etc.	*/

	call lib_get_tree_ (Pnode, path, Pstarname, APexclude, Srequirements, Scontrol, tree_level,
			link_level, Parea, Adirector, PA, PDnodes, code);
						/* get the node(s) at the descendant tree level.	*/
	if PDnodes = null then go to error_return;	/* a very serious error has occurred.		*/
	if Dnodes.C = error_table_$nomatch then		/* only other important error is no descendants.	*/
	     go to error_return;

	end next_tree_level;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


node_outputable:	procedure (Pnode_)			/* This internal procedure determines if a library*/
	     returns	(bit(1) aligned);		/* entry is outputable.			*/

     dcl	Pnode_			ptr;		/* ptr to node to be tested.			*/

     dcl	PDnodes_			ptr,		/* ptr to a node array descriptor.		*/
	i			fixed bin;	/* a do-group index.			*/

     dcl	1 Dnodes_			aligned based (PDnodes_),
		     				/* a node array descriptor.			*/
	  2 header		like Dnodes.header, 
	  2 nodes (Nnodes refer (Dnodes_.N))
				like node,

	1 node_			aligned based (Pnode_) like node,
		     				/* a node.				*/
	1 Svalid			aligned based (addr (node_.Svalid)) like Svalid_req;
		     				/* switches indicating which node info is valid.	*/

	if node_.T = Tsegment then			/* if this node is a segment,			*/
msf_comp:	     if node_.rb(2) < ring then;		/*    and it is readable in this ring,		*/
	     else if ^substr(node_.Smode,1,1) then;
	     else
arch_comp:	if node_.bit_count < 9 then;		/*    and it has a non-zero bit count,		*/
	     else if mod (node_.bit_count, 9) ^= 0 then;	/*    and its bit count says it contains chars,	*/
	     else if Svalid.object_info then;		/*    and it was not proven to be an obj segment	*/
	     else if Svalid.not_ascii then;
						/*    and it is not a non-ascii or pt seg, 	*/
	     else return ("1"b);			/*    then segment is outputable.		*/

	else if node_.T = Tmsf_comp then		/* if this node is an msf component, treat it	*/
	     go to msf_comp;			/*    like a segment.			*/

	else if node_.T = Tlink then			/* if this node is a link,			*/
	     if Svalid.kids then do;			/*    if the link was chased,			*/
	          do PDnodes_ = node_.PD repeat Dnodes_.Pnext while (Dnodes_.header.T ^= Tnodes);
		     end;
	     	return (node_outputable (addr (Dnodes_.nodes(1))));
	          end;				/*    Let outputability of link target determine	*/
	     else;				/*    outputability of link.			*/

	else if node_.T = Tarchive then		/* if this node is an archive,		*/
	     if Svalid.not_ascii then;		/*    and it is not a non-ascii archive,	*/
	     else return ("1"b);			/*    then it is outputable.			*/

	else if node_.T = Tarchive_comp then		/* if this node is an archive component,	*/
	     go to arch_comp;			/*    treat it like a segment to which we already	*/
		     				/*    know we have access.  (We found out it was	*/
		     				/*    an archive component, didn't we?)		*/

	else if node_.T = Tmsf then			/* if this node is an MSF, let it's outputability	*/
	     if Svalid.kids then do;			/*    hinge on outputability of its components.	*/
	          do PDnodes_ = node_.PD repeat Dnodes_.Pnext while (Dnodes_.header.T ^= Tnodes);
		     end;
	          do i = 1 to Dnodes_.N while (node_outputable (addr (Dnodes_.nodes(i))));
		     end;
		if i > Dnodes_.N then return ("1"b);	/*    if all components outputable, so if MSF.	*/
	          end;

	return ("0"b);				/* otherwise, node is not outputable.		*/

	end node_outputable;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


reject_node_if_obsolete:	procedure;		/* This procedure examines the names on a node to	*/
						/*    determine if any are unique names.  If so,	*/
						/*    then the node is rejected.		*/

	do PDnames = node.PD repeat Dnames.Pnext while (Dnames.T ^= Tnames);
	     end;
	if index (string(Dnames.names), "!") > 0 then
	     do i = 1 to Dnames.N;
	          call match_star_name_ (Dnames.names(i), "!??????????????", code);
	          if code = 0 then go to reject;
	          end;

	end reject_node_if_obsolete;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


set_director_args:	procedure (min_Scontrol, max_Scontrol, search_type);
						/* procedure to replace incoming director	*/
						/*    control argument, which is a command index,	*/
						/*    by a more elaborate structure which includes*/
						/*    all user arguments which might be modified	*/
						/*    when getting one tree level, and then be	*/
						/*    restored at the next tree level.		*/

     dcl (max_Scontrol, min_Scontrol)	bit(36) aligned,	/* min/max control switch settings. (In)	*/
	search_type		fixed bin;	/* search type. (In)			*/

	director_args.command = A.command;		/* fill in director arguments.		*/
	director_args.n_found = A.n_found;
	PA_saved = PA;
	PA = addr(director_args);
	A.Pstar = APstarname;
	A.Sreq = ASrequirements & max_Srequirements(A.command);
	Scontrol = AScontrol;
	Scontrol = Scontrol & max_Scontrol;
	Scontrol = Scontrol | min_Scontrol;
	A.Scontrol = Scontrol;
	A.search_type = search_type;

	end set_director_args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include lib_node_;


%include lib_commands_;

	end multics_library_search_;




		    status_data_.alm                11/15/82  1839.1rew 11/15/82  1533.8       11799



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

	name	status_data_
"
"    dcl	status_data_$mode (0:7)	char(4) varying aligned ext static;
"					/* character string interpretations of	*/
"					/* segment modes.			*/
"

	segdef	mode

mode:	dec	4				" null
	aci	'null'
	dec	3				" w
	aci	'  w '
	dec	2				" e
	aci	' e  '
	dec	3				" ew
	aci	' ew '
	dec	1				" r
	aci	'r   '
	dec	3				" rw
	aci	'r w '
	dec	2				" re
	aci	're  '
	dec	3				" rew
	aci	'rew '


"
"    dcl	status_data_$dir_mode (0:7)	char (4) varying aligned ext static;
"					/* character string interpretations of	*/
"					/* directory modes.			*/
"

	segdef	dir_mode

dir_mode:	dec	4				" null
	aci	'null'
	dec	3				" a
	aci	'  a '
	dec	2				" m
	aci	' m  '
	dec	3				" ma
	aci	' ma '
	dec	1				" s
	aci	's   '
	dec	3				" sa
	aci	's a '
	dec	2				" sm
	aci	'sm  '
	dec	3				" sma
	aci	'sma '

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