


		    find_include_file_.pl1          11/04/82  1902.8rew 11/04/82  1613.2       23517


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


/*	Find an include file on behalf of translators

	Rewritten to use search_paths_ 02-Nov-78 by Monte Davidoff.
*/
find_include_file_:
initiate_count:
     procedure (P_translator, P_referencing_ptr, P_entryname, P_bit_count, P_include_seg_ptr, P_code);

	declare P_translator	 char (*);	/* (Input) name of the calling translator */
	declare P_referencing_ptr	 pointer;		/* (Input) pointer into the segment needing the include file */
	declare P_entryname		 char (*);	/* (Input) entryname of the include file */
	declare P_bit_count		 fixed binary (24); /* (Output) include file bit count */
	declare P_include_seg_ptr	 pointer;		/* (Output) pointer to the include file */
	declare P_code		 fixed binary (35); /* (Output) standard status code */

/* automatic */

	declare ref_dir_name	 char (168);
	declare ref_dir_name_length	 fixed binary;
	declare ref_entryname	 char (32);
	declare include_dir_name	 char (168);

/* builtin */

	declare null		 builtin;

/* external static */

	declare error_table_$zero_length_seg
				 fixed binary (35) external static;

/* external entry */

	declare hcs_$fs_get_path_name	 entry (pointer, char (*), fixed binary, char (*), fixed binary (35));
	declare hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2), pointer,
				 fixed binary (35));
	declare search_paths_$find_dir entry (char (*), pointer, char (*), char (*), char (*), fixed binary (35));

	P_bit_count = 0;
	P_include_seg_ptr = null;
	P_code = 0;

	if P_referencing_ptr = null
	then ref_dir_name = "";
	else do;
		call hcs_$fs_get_path_name (P_referencing_ptr, ref_dir_name, ref_dir_name_length, ref_entryname, P_code);
		if P_code ^= 0
		then return;
	     end;

	call search_paths_$find_dir ("translator", null, P_entryname, ref_dir_name, include_dir_name, P_code);
	if P_code ^= 0
	then return;

	call hcs_$initiate_count (include_dir_name, P_entryname, "", P_bit_count, 1, P_include_seg_ptr, P_code);
	if P_include_seg_ptr ^= null
	then P_code = 0;

	if P_code = 0 & P_bit_count = 0
	then P_code = error_table_$zero_length_seg;
     end find_include_file_;
   



		    search_paths_.pl1               07/26/88  1059.1rew 07/26/88  1013.4      530181


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


/****^  HISTORY COMMENTS:
  1) change(87-11-12,Lippard), approve(87-12-21,MCR7822),
     audit(88-02-11,Blair), install(88-02-16,MR12.2-1023):
     Modified to understand linker search paths.
  2) change(88-06-16,Blair), approve(88-06-16,MCR7842),
     audit(88-06-28,Lippard), install(88-07-26,MR12.2-1069):
     Replace the calls to hcs_$status_minf in find_dir and find_all
     entry-pts with a call to fs_util_$get_type so we don't run into trouble
     when looking for extended entry types such as mailboxes that are in
     directories for which the user has no 's' access.
                                                   END HISTORY COMMENTS */


/*	Implement the command search facility

NOTE:     The current implementation will not work if more than one process
	has access to the search segment.  Some locking mechanism must be
	used to prevent two processes from simultaneously changing the
	search segment.  The mark bits in search_list should probably be
	removed.

	Rewritten 16-Aug-78 by Monte Davidoff.

	Modified 07/21/80 by C. D. Tavares to implement extensible default
	search paths, to make the process search segment per-ring, to use
	the search segment for the process' validation level, and to keep
	from re-initializing the segment if search_paths_ is terminated.  */
/* format: style2 */
%page;
/*
N__a_m_e:	search_paths_$find_dir

     The search_paths_$find_dir entry point, given a search list and an
entryname, returns the absolute pathname of a directory in which the
entryname can be found.  The directories in the search list are searched in
order for the entryname.


U__s_a_g_e:


     declare search_paths_$find_dir entry (char (*), pointer, char (*), char (*), char (*), fixed binary (35));

     call search_paths_$find_dir (sl_name, search_seg_ptr, entryname, ref_path, dir_name, code);


where:

1.   sl_name		(Input)
	is the search list name.

2.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

3.   entryname		(Input)
	is the entryname to search for.

4.   ref_path		(Input)
	is the directory name used for the "-referencing_dir" search path.
	If ref_path is null, then the "-referencing_dir" search path is
	skipped.

5.   dir_name		(Output)
	is the directory the entryname was found in.

6.   code			(Output)
	is a standard status code.  It may be one of the following:
	error_table_$no_search_list
	     the search list was not in the search segment.
	error_table_$noentry
	     the entryname was not found in a directory in the search list.
*/
%page;
/*
N__a_m_e:	search_paths_$find_all

     The search_paths_$find_all entry point, given a search list and an
entryname, returns the absolute pathnames of directories in which the
entryname can be found.  The directories in the search list are searched in
order for the entryname.


U__s_a_g_e:


     declare search_paths_$find_all entry (char (*), pointer, char (*), char (*), pointer, fixed binary, pointer,
	fixed binary (35));

     call search_paths_$find_all (sl_name, search_seg_ptr, entryname, ref_path, sl_info_area_ptr, sl_info_version,
	sl_info_ptr, code);


where:

1.   sl_name		(Input)
	is the search list name.

2.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

3.   entryname		(Input)
	is the entryname to search for.

4.   ref_path		(Input)
	is the directory name used for the "-referencing_dir" search path.
	If ref_path is null, then the "-referencing_dir" search path is
	skipped.

5.   sl_info_area_ptr	(Input)
	is a pointer to an area in which sl_info can be allocated.

6.   sl_info_version	(Input)
	is the version of the sl_info structure required.

7.   sl_info_ptr		(Output)
	is a pointer to the sl_info structure containing the directories
	which contain the entryname.  (See search_paths_$get).

8.   code			(Output)
	is a standard status code.  It may be one of the following:
	error_table_$no_search_list
	     the search list was not in the search segment.
	error_table_$noentry
	     the entryname was not found in a directory in the search list.
*/
%page;
/*
N__a_m_e:	search_paths_$get

     The search_paths_$get entry point returns the search paths in a search
list.


U__s_a_g_e:


     declare search_paths_$get entry (char (*), bit (36), char (*), pointer, pointer, fixed binary, pointer,
	fixed binary (35));

     call search_paths_$get (sl_name, sl_control, ref_path, search_seg_ptr, sl_info_area_ptr, sl_info_version,
	sl_info_ptr, code);


where:

1.   sl_name		(Input)
	is the search list name.

2.   sl_control		(Input)
	is an expansion control mask.  See the sl_control_s structure in
	"Notes" below.

3.   ref_path		(Input)
	is the directory name used for the "-referencing_dir" search path.
	If ref_path is null, then the "-referencing_dir" search path is
	skipped.

4.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

5.   sl_info_area_ptr	(Input)
	is a pointer to an area in which sl_info can be allocated.

6.   sl_info_version	(Input)
	is the version of the sl_info structure required.

7.   sl_info_ptr		(Output)
	is a pointer to the sl_info structure containing the search paths in
	the search list.  (See "Notes" below).

8.   code			(Output)
	is a standard status code.  It may be the following:
	error_table_$no_search_list
	     the search list was not in the search segment.


N__o_t_e_s

     The sl_control argument is defined by the sl_control_s structure contained
in sl_control_s.incl.pl1.  Expanding the "-referencing_dir" keyword substitutes
the ref_path argument for the keyword.

     The sl_info structure is contained in sl_info.incl.pl1.

where:

1.   version
	is the version of the sl_info structure.

2.   num_paths
	is the number of search paths in this structure.

3.   change_index_p
	is a pointer to the search lists' update count.  The update count
	is a fixed binary (71) integer, and is incremented each time the
	search list is modified.  The caller can determine if the search
	list has been modified by comparing change_index in this structure
	with the value pointed to by change_index_p.

4.   change_index
	is the current value of the search lists' update count.

5.   type
	specifies the type of the search path.  Keywords in sl_info.incl.pl1
	define the possible values.

6.   code
	is a standard status code for this search path.

7.   pathname
	is the search path.
*/
%page;
/*
N__a_m_e:	search_paths_$set

     The search_paths_$set entry point sets the search paths of a search list.


U__s_a_g_e:


     declare search_paths_$set entry (char (*), pointer, pointer, fixed binary (35));

     call search_paths_$set (sl_name, search_seg_ptr, sl_info_ptr, code);


where:

1.   sl_name		(Input)
	is the search list name.

2.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

3.   sl_info_ptr		(Input)
	is a pointer to an sl_info structure (see search_paths_$get)
	containing the search paths for the search list.  If null, then the
	search list is set to its default.

4.   code			(Output)
	is a standard status code.  It may be one of the following:
	error_table_$action_not_performed
	     the search list was not changed.  (See "Notes" below).
	error_table_$new_search_list
	     a new search list was created.  This is only a warning.
	error_table_$no_search_list_default
	     the search list has no default.
	error_table_$too_many_sr
	     too many search paths were supplied for the linker search
	     list.

N__o_t_e_s

     If the error_table_$action_not_performed status code is returned, then
some search path may be invalid.  A non-zero code for a search path in the
sl_info structure indicates that the search path was invalid.
*/
%page;
/*
N__a_m_e:	search_paths_$list

     The search_paths_$list entry point returns a linked list of the search
list names that are in a search segment.


U__s_a_g_e:


     declare search_paths_$list entry (pointer, pointer, fixed binary, pointer, fixed binary (35));

     call search_paths_$list (search_seg_ptr, sl_list_area_ptr, sl_list_version, sl_list_ptr, code);


where:

1.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

2.   sl_list_area_ptr	(Input)
	is a pointer to an area in which a linked list of sl_list structures
	can be allocated.

3.   sl_list_version	(Input)
	is the version of the sl_list structure required.

4.   sl_list_ptr		(Output)
	is a pointer to a linked list of sl_list structures containing the
	names of the search lists in the search segment.  (See "Notes" below).

5.   code			(Output)
	is a standard status code.


N__o_t_e_s

     The sl_list structure is contained in sl_list.incl.pl1.

where:

1.   version
	is the version of the sl_list structure.

2.   link
	is a pointer to the next sl_list structure in the linked list, or
	null if this is the last structure in the linked list.

3.   name_count
	is the number of synonyms this search list has.

4.   names
	is an array of the names of this search list.
*/
%page;
/*
N__a_m_e:	search_paths_$delete_list

     The search_paths_$delete_list entry point deletes a search list from a
search segment.


U__s_a_g_e:


     declare search_paths_$delete_list entry (char (*), pointer, fixed binary (35));

     call search_paths_$delete_list (sl_name, search_seg_ptr, code);


where:

1.   sl_name		(Input)
	is the search list name.

2.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

3.   code			(Output)
	is a standard status code.  It may be the following:
	error_table_$no_search_list
	     the search list was not in the search segment.
	error_table_$action_not_performed
	     the linker search list may not be deleted.
*/
%page;
/*
N__a_m_e:	search_paths_$init_search_seg

     The search_paths_$init_search_seg entry point initializes a search
segment.


U__s_a_g_e:


     declare search_paths_$init_search_seg entry (pointer, fixed binary (35));

     call search_paths_$init_search_seg (search_seg_ptr, code);


where:

1.   search_seg_ptr		(Input)
	is a pointer to the search segment.  If this pointer is null, then
	the process search segment is used.

2.   code			(Output)
	is a standard status code.
*/
%page;
search_paths_:
     procedure;

	declare P_code		 fixed binary (35);
	declare P_dir_name		 char (*);
	declare P_entryname		 char (*);
	declare P_ref_path		 char (*);
	declare P_search_seg_ptr	 pointer;
	declare P_sl_control	 bit (36);
	declare P_sl_info_area_ptr	 pointer;
	declare P_sl_info_ptr	 pointer;
	declare P_sl_info_version	 fixed binary;
	declare P_sl_list_area_ptr	 pointer;
	declare P_sl_list_ptr	 pointer;
	declare P_sl_list_version	 fixed binary;
	declare P_sl_name		 char (*);

/* automatic */

	declare cleanup_action	 fixed binary;	/* what action to take on cleanup */
	declare cleanup_new_list_header_ptr
				 pointer;		/* pointers to figure out what to do on cleanup */
	declare cleanup_new_list_name_ptr
				 pointer;
	declare cleanup_new_search_list_ptr
				 pointer;
	declare cleanup_old_last_list_header_ptr
				 pointer;
	declare cleanup_old_list_header_ptr
				 pointer;
	declare cleanup_old_list_name_ptr
				 pointer;
	declare cleanup_old_search_list_ptr
				 pointer;
	declare cleanup_sl_list_ptr	 pointer;
	declare list_name_name_count	 fixed binary;
	declare search_list_path_count fixed binary;
	declare search_seg_ptr	 pointer;		/* pointer to the search segment */
%page;
/* based */

/*	search segment data structures

	The list_header must remain in the same generation of storage because
	users are given pointers to list_header.update_count */

	declare 1 search_seg	 based (search_seg_ptr),
		2 header,
		  3 version	 fixed binary,	/* search segment version */
		  3 first_list_header_off
				 offset (search_seg.area),
						/* offset of first list's list_header */
		  3 last_list_header_off
				 offset (search_seg.area),
						/* offset of last list's list_header */
		2 area		 area (sys_info$max_seg_size - divide (length (unspec (search_seg.header)), 36, 19));

	declare 1 list_header	 based,
		2 link		 offset (search_seg.area),
						/* offset of next list's list_header */
		2 back_link	 offset (search_seg.area),
						/* offset of last list's list_header */
		2 list_name_off	 offset (search_seg.area),
						/* offset of list_name */
		2 search_list_off	 offset (search_seg.area),
						/* offset of search_list */
		2 update_count	 fixed binary (71); /* number of times search list has been changed */

	declare 1 list_name		 based,
		2 name_count	 fixed binary,	/* number of synonyms */
		2 names		 (list_name_name_count refer (list_name.name_count)) char (32);
						/* search list names */

	declare 1 search_list	 based,
		2 path_count	 fixed binary,	/* number of search paths */
		2 paths		 (search_list_path_count refer (search_list.path_count)),
		  3 type		 fixed binary,	/* search path type */
		  3 pathname	 char (168),	/* search pathname */
		  3 mark		 bit (1);		/* temporary */

	declare 1 default_search_list	 based,
		2 name_count	 fixed binary,	/* number of synonyms */
		2 path_count	 fixed binary,	/* number of search paths */
		2 names		 (0 refer (default_search_list.name_count)) char (32),
						/* search list names */
		2 paths		 (0 refer (default_search_list.path_count)),
		  3 type		 fixed binary,	/* search path type */
		  3 pathname	 char (168);	/* search pathname */
%page;
/* builtin */

	declare addr		 builtin;
	declare divide		 builtin;
	declare empty		 builtin;
	declare hbound		 builtin;
	declare index		 builtin;
	declare length		 builtin;
	declare ltrim		 builtin;
	declare maxlength		 builtin;
	declare null		 builtin;
	declare nullo		 builtin;
	declare rtrim		 builtin;
	declare search		 builtin;
	declare substr		 builtin;
	declare unspec		 builtin;

/* condition */

	declare cleanup		 condition;

/* internal static */

	declare this_ring		 fixed binary internal static initial (-1);
	declare default_search_seg_ptr pointer internal static initial (null);
	declare NONE		 fixed binary internal static options (constant) initial (0);
	declare FREE_sl_info	 fixed binary internal static options (constant) initial (1);
	declare FREE_sl_list	 fixed binary internal static options (constant) initial (2);
	declare RESTORE		 fixed binary internal static options (constant) initial (3);
	declare FREE_old_search_list	 fixed binary internal static options (constant) initial (4);
	declare FREE_ALL_OLD	 fixed binary internal static options (constant) initial (5);

	declare search_seg_version_2	 fixed binary internal static options (constant) initial (2);
%page;
/* external static */

	declare error_table_$action_not_performed
				 fixed binary (35) external static;
	declare error_table_$badpath	 fixed binary (35) external static;
	declare error_table_$empty_search_list
				 fixed binary (35) external static;
	declare error_table_$invalid_ring_brackets
				 fixed bin (35) ext static;
	declare error_table_$new_search_list
				 fixed binary (35) external static;
	declare error_table_$no_search_list
				 fixed binary (35) external static;
	declare error_table_$no_search_list_default
				 fixed binary (35) external static;
	declare error_table_$noentry	 fixed binary (35) external static;
	declare error_table_$notadir	 fixed binary (35) external static;
	declare error_table_$pathlong	 fixed binary (35) external static;
	declare error_table_$too_many_sr
				 fixed binary (35) external static;
	declare error_table_$unbalanced_brackets
				 fixed binary (35) external static;
	declare error_table_$unimplemented_version
				 fixed binary (35) external static;
	declare sys_info$max_seg_size	 fixed binary (19) external static;

/* external entry */

	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
          declare fs_util_$get_type      entry (char(*), char(*), char(*), fixed bin(35));
	declare get_pdir_		 entry () returns (char (168));
	declare get_wdir_		 entry () returns (char (168));
	declare get_ring_		 entry () returns (fixed bin (3));
	declare ioa_$rsnnl		 ext entry options (variable);
	declare cu_$level_get	 ext entry (fixed bin);
	declare hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
	declare hcs_$get_search_rules	 entry (pointer);
	declare hcs_$get_uid_file	 entry (char (*), char (*), bit (36) aligned, fixed bin (35));
	declare hcs_$initiate_search_rules
				 entry (pointer, fixed binary (35));
	declare hcs_$make_ptr	 entry (pointer, char (*), char (*), pointer, fixed binary (35));
	declare hcs_$make_seg	 entry (char (*), char (*), char (*), fixed binary (5), pointer, fixed binary (35));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed binary (1), fixed binary (2), fixed binary (24),
				 fixed binary (35));
	declare user_info_		 entry (char (*), char (*), char (*));
	declare user_info_$homedir	 entry (char (*));
%page;
%include sl_info;
%include sl_control_s;
%include sl_list;
%page;
/* Search a search list for an entryname */

find_dir:
     entry (P_sl_name, P_search_seg_ptr, P_entryname, P_ref_path, P_dir_name, P_code);

/*	P_sl_name			(Input) search list name
	P_search_seg_ptr		(Input) pointer to the search segment
	P_entryname		(Input) entryname to look for
	P_ref_path		(Input) pathname used for "-referencing_dir" keyword
	P_dir_name		(Output) directory the entryname was found in
	P_code			(Output) standard status code */

	cleanup_action = NONE;
	on cleanup call cleanup_;
	begin;
	     declare code		      fixed binary (35);
	     declare dir_name	      char (168);
	     declare entry_type	      char (32);
	     declare pathx		      fixed binary;
	     declare search_list_header_ptr pointer;
	     declare search_list_ptr	      pointer;

	     P_dir_name = "";
	     P_code = 0;
	     call get_search_segment (P_search_seg_ptr, P_code);
	     if P_code ^= 0
	     then return;
	     if P_sl_name = "linker" then call get_linker_search_list;
	     call get_search_list (P_sl_name, "1"b, search_list_header_ptr, P_code);
	     if P_code ^= 0
	     then return;

	     search_list_ptr = search_list_header_ptr -> list_header.search_list_off;
	     code = -1;
	     do pathx = 1 to search_list_ptr -> search_list.path_count while (code ^= 0);
		call expand_search_path (search_list_ptr -> search_list.paths (pathx).type,
		     search_list_ptr -> search_list.paths (pathx).pathname, P_ref_path, (36)"1"b, dir_name, (""b), code);
		if code = 0 & dir_name = ""
		then code = -1;

		if code = 0
		then call fs_util_$get_type (dir_name, P_entryname, entry_type, code);
	     end;

	     if code = 0
	     then P_dir_name = dir_name;
	     else P_code = error_table_$noentry;
	end;
	return;
%page;
/* Find all the paths on a search list which contain an entryname */

find_all:
     entry (P_sl_name, P_search_seg_ptr, P_entryname, P_ref_path, P_sl_info_area_ptr, P_sl_info_version, P_sl_info_ptr,
	P_code);

/*	P_sl_name			(Input) search list name
	P_search_seg_ptr		(Input) pointer to the search segment
	P_entryname		(Input) entryname to look for
	P_ref_path		(Input) pathname used for "-referencing_dir" keyword
	P_sl_info_area_ptr		(Input) pointer to an area to allocate sl_info in
	P_sl_info_version		(Input) version of the sl_info structure required
	P_sl_info_ptr		(Output) pointer to sl_info structure containing paths which contain the entryname
	P_code			(Output) standard status code */

	cleanup_action = NONE;
	on cleanup call cleanup_;
	begin;
	     declare code		      fixed binary (35);
	     declare dir_name	      char (168);
	     declare entry_type	      char (32);
	     declare found_count	      fixed binary;
	     declare pathx		      fixed binary;
	     declare search_list_header_ptr pointer;
	     declare search_list_ptr	      pointer;

	     P_sl_info_ptr = null;
	     P_code = 0;
	     if P_sl_info_version ^= sl_info_version_1
	     then do;
		     P_code = error_table_$unimplemented_version;
		     return;
		end;

	     call get_search_segment (P_search_seg_ptr, P_code);
	     if P_code ^= 0
	     then return;
	     if P_sl_name = "linker" then call get_linker_search_list;
	     call get_search_list (P_sl_name, "1"b, search_list_header_ptr, P_code);
	     if P_code ^= 0
	     then return;
%skip (10);
	     search_list_ptr = search_list_header_ptr -> list_header.search_list_off;
	     search_list_ptr -> search_list.paths (*).mark = "0"b;
	     found_count = 0;
	     do pathx = 1 to search_list_ptr -> search_list.path_count;
		call expand_search_path (search_list_ptr -> search_list.paths (pathx).type,
		     search_list_ptr -> search_list.paths (pathx).pathname, P_ref_path, (36)"1"b, dir_name, (""b), code);
		if code = 0 & dir_name ^= ""
		then do;
			call fs_util_$get_type (dir_name, P_entryname, entry_type, code);
			if code = 0
			then do;
				search_list_ptr -> search_list.paths (pathx).mark = "1"b;
				found_count = found_count + 1;
			     end;
		     end;
	     end;

	     if found_count = 0
	     then P_code = error_table_$noentry;
	     else begin;
		     declare found_pathx	      fixed binary;

		     cleanup_action = FREE_sl_info;

		     call create_sl_info (P_sl_info_area_ptr, search_list_header_ptr, found_count, P_sl_info_ptr);
		     found_pathx = 1;
		     do pathx = 1 to search_list_ptr -> search_list.path_count while (found_pathx <= found_count);
			if search_list_ptr -> search_list.paths (pathx).mark
			then do;
				P_sl_info_ptr -> sl_info.paths (found_pathx).type =
				     search_list_ptr -> search_list.paths (pathx).type;
				call expand_search_path (search_list_ptr -> search_list.paths (pathx).type,
				     search_list_ptr -> search_list.paths (pathx).pathname, P_ref_path, (36)"1"b,
				     P_sl_info_ptr -> sl_info.paths (found_pathx).pathname,
				     P_sl_info_ptr -> sl_info.paths (found_pathx).uid, code);
				found_pathx = found_pathx + 1;
			     end;
		     end;
		end;
	end;
	return;
%page;
/* Return the search paths in a search list */

get:
     entry (P_sl_name, P_sl_control, P_ref_path, P_search_seg_ptr, P_sl_info_area_ptr, P_sl_info_version, P_sl_info_ptr,
	P_code);

/*	P_sl_name			(Input) search list name
	P_sl_control		(Input) expansion control mask
	P_ref_path		(Input) pathname used for "-referencing_dir" rule
	P_search_seg_ptr		(Input) pointer to the search segment
	P_sl_info_area_ptr		(Input) pointer to an area to allocate sl_info in
	P_sl_info_version		(Input) version of the sl_info structure required
	P_sl_info_ptr		(Output) pointer to sl_info structure containing the search list
	P_code			(Output) standard status code */

	cleanup_action = NONE;
	on cleanup call cleanup_;
	begin;
	     declare code		      fixed binary (35);
	     declare pathx		      fixed binary;
	     declare search_list_header_ptr pointer;
	     declare search_list_ptr	      pointer;
	     declare sl_info_pathx	      fixed binary;

	     P_sl_info_ptr = null;
	     P_code = 0;
	     if P_sl_info_version ^= sl_info_version_1
	     then do;
		     P_code = error_table_$unimplemented_version;
		     return;
		end;

	     call get_search_segment (P_search_seg_ptr, P_code);
	     if P_code ^= 0
	     then return;
	     if P_sl_name = "linker" then call get_linker_search_list;
	     call get_search_list (P_sl_name, "1"b, search_list_header_ptr, P_code);
	     if P_code ^= 0
	     then return;
%skip (10);
	     cleanup_action = FREE_sl_info;

	     search_list_ptr = search_list_header_ptr -> list_header.search_list_off;
	     call create_sl_info (P_sl_info_area_ptr, search_list_header_ptr,
		search_list_ptr -> search_list.path_count
		- null_referencing_dirs (P_sl_control, P_ref_path, search_list_ptr), P_sl_info_ptr);

	     sl_info_pathx = 1;
	     do pathx = 1 to search_list_ptr -> search_list.path_count
		while (sl_info_pathx <= P_sl_info_ptr -> sl_info.num_paths);
		P_sl_info_ptr -> sl_info.paths (sl_info_pathx).type = search_list_ptr -> search_list.paths (pathx).type;

		call expand_search_path (search_list_ptr -> search_list.paths (pathx).type,
		     search_list_ptr -> search_list.paths (pathx).pathname, P_ref_path, P_sl_control,
		     P_sl_info_ptr -> sl_info.paths (sl_info_pathx).pathname,
		     P_sl_info_ptr -> sl_info.paths (sl_info_pathx).uid, code);
		if code ^= 0 & P_code = 0
		then P_code = code;

		if P_sl_info_ptr -> sl_info.paths (sl_info_pathx).pathname ^= ""
		then sl_info_pathx = sl_info_pathx + 1;
	     end;
	end;
	return;
%page;
/* Set a search list to specified search paths */

set:
     entry (P_sl_name, P_search_seg_ptr, P_sl_info_ptr, P_code);

/*	P_sl_name			(Input) search list name
	P_search_seg_ptr		(Input) pointer to the search segment
	P_sl_info_ptr		(Input) pointer to sl_info structure containing the new search list
				or null to reinitialize the search list
	P_code			(Output) standard status code */

	cleanup_action = NONE;
	on cleanup call cleanup_;
	begin;
	     declare search_list_header_ptr pointer;

	     P_code = 0;
	     if P_sl_info_ptr = null
	     then begin;
		     declare code		      fixed binary (35);

		     call get_search_segment (P_search_seg_ptr, P_code);
		     if P_code ^= 0
		     then return;
		     if P_sl_name = "linker" then call get_linker_search_list;
		     call get_search_list (P_sl_name, "0"b, search_list_header_ptr, code);
		     call set_up_to_restore_on_cleanup (search_list_header_ptr);
		     call initialize_search_list_with_default (P_sl_name, search_list_header_ptr, code);
		     if code ^= 0
		     then do;
			     P_code = error_table_$no_search_list_default;
			     return;
			end;
		end;
	     else begin;
		     declare code		      fixed binary (35);
		     declare dir_name	      char (168);
		     declare pathx		      fixed binary;

		     if P_sl_info_ptr -> sl_info.version ^= sl_info_version_1
		     then do;
			     P_code = error_table_$unimplemented_version;
			     return;
			end;

		     call get_search_segment (P_search_seg_ptr, P_code);
		     if P_code ^= 0
		     then return;

		     if P_sl_name = "linker" then call get_linker_search_list;

		     do pathx = 1 to P_sl_info_ptr -> sl_info.num_paths;
			call expand_search_path (P_sl_info_ptr -> sl_info.paths (pathx).type,
			     P_sl_info_ptr -> sl_info.paths (pathx).pathname, "", (36)"1"b, dir_name,
			     P_sl_info_ptr -> sl_info.paths (pathx).uid, code);
			P_sl_info_ptr -> sl_info.paths (pathx).code = code;
			if code ^= 0
			then P_code = error_table_$action_not_performed;
		     end;
		     if P_code ^= 0
		     then return;

		     call get_search_list (P_sl_name, "1"b, search_list_header_ptr, code);
		     call set_up_to_restore_on_cleanup (search_list_header_ptr);
		     if code ^= 0 & code ^= error_table_$empty_search_list
		     then do;
			     P_code = error_table_$new_search_list;
			     call create_search_list_header (cleanup_new_list_header_ptr);
			     search_list_header_ptr = cleanup_new_list_header_ptr;

			     list_name_name_count = 1;
			     allocate list_name in (search_seg.area) set (cleanup_new_list_name_ptr);
			     search_list_header_ptr -> list_header.list_name_off = cleanup_new_list_name_ptr;
			     cleanup_new_list_name_ptr -> list_name.names (1) = P_sl_name;
			end;

		     search_list_path_count = P_sl_info_ptr -> sl_info.num_paths;
		     allocate search_list in (search_seg.area) set (cleanup_new_search_list_ptr);
		     search_list_header_ptr -> list_header.search_list_off = cleanup_new_search_list_ptr;

		     cleanup_new_search_list_ptr -> search_list.paths (*).type = P_sl_info_ptr -> sl_info.paths (*).type;
		     cleanup_new_search_list_ptr -> search_list.paths (*).pathname =
			P_sl_info_ptr -> sl_info.paths (*).pathname;
		end;
	     search_list_header_ptr -> list_header.update_count = search_list_header_ptr -> list_header.update_count + 1;

	     cleanup_action = FREE_old_search_list;
	     call cleanup_;

	     if P_sl_name = "linker" then call set_linker_search_list;
	end;
	return;
%page;
/* Return the search lists in a search segment */

list:
     entry (P_search_seg_ptr, P_sl_list_area_ptr, P_sl_list_version, P_sl_list_ptr, P_code);

/*	P_search_seg_ptr		(Input) pointer to the search segment
	P_sl_list_area_ptr		(Input) pointer to an area to allocate a linked list of sl_list structures in
	P_sl_list_version		(Input) version of the sl_list structure required
	P_sl_list_ptr		(Output) pointer to a linked list of sl_list structures containing the names
				and synonyms of the search lists in the search segment
	P_code			(Output) standard status code */

	cleanup_action = NONE;
	on cleanup call cleanup_;
	begin;
	     declare list_name_ptr	      pointer;
	     declare search_list_header_ptr pointer;
	     declare sl_list_area	      area based;

	     P_sl_list_ptr = null;
	     P_code = 0;
	     if P_sl_list_version ^= sl_list_version_2
	     then do;
		     P_code = error_table_$unimplemented_version;
		     return;
		end;

	     call get_search_segment (P_search_seg_ptr, P_code);
	     if P_code ^= 0
	     then return;

	     call get_linker_search_list;

	     cleanup_sl_list_ptr = null;
	     cleanup_action = FREE_sl_list;

	     do search_list_header_ptr = search_seg.header.first_list_header_off
		repeat search_list_header_ptr -> list_header.link while (search_list_header_ptr ^= null);

		list_name_ptr = search_list_header_ptr -> list_header.list_name_off;

		sl_list_name_count = list_name_ptr -> list_name.name_count;
		allocate sl_list in (P_sl_list_area_ptr -> sl_list_area) set (P_sl_list_ptr);

		P_sl_list_ptr -> sl_list.version = sl_list_version_2;
		P_sl_list_ptr -> sl_list.link = cleanup_sl_list_ptr;
		P_sl_list_ptr -> sl_list.pad (*) = ""b;
		P_sl_list_ptr -> sl_list.names (*) = list_name_ptr -> list_name.names (*);

		cleanup_sl_list_ptr = P_sl_list_ptr;
	     end;
	end;
	return;
%page;
/* Delete a search list */

delete_list:
     entry (P_sl_name, P_search_seg_ptr, P_code);

/*	P_sl_name			(Input) search list to be deleted
	P_search_seg_ptr		(Input) pointer to the search segment
	P_code			(Output) standard status code */

	if P_sl_name = "linker"
	then do;
	     P_code = error_table_$action_not_performed;
	     return;
	     end;

	cleanup_action = NONE;
	on cleanup call cleanup_;
	begin;
	     declare search_list_header_ptr pointer;

	     P_code = 0;
	     call get_search_segment (P_search_seg_ptr, P_code);
	     if P_code ^= 0
	     then return;
	     call get_search_list (P_sl_name, "1"b, search_list_header_ptr, P_code);
	     if P_code = error_table_$empty_search_list
	     then P_code = 0;
	     if P_code ^= 0
	     then return;

	     call set_up_to_restore_on_cleanup (search_list_header_ptr);

	     if search_list_header_ptr -> list_header.link = nullo
	     then search_seg.header.last_list_header_off = search_list_header_ptr -> list_header.back_link;
	     else search_list_header_ptr -> list_header.link -> list_header.back_link =
		     search_list_header_ptr -> list_header.back_link;

	     if search_list_header_ptr -> list_header.back_link = nullo
	     then search_seg.header.first_list_header_off = search_list_header_ptr -> list_header.link;
	     else search_list_header_ptr -> list_header.back_link -> list_header.link =
		     search_list_header_ptr -> list_header.link;

	     cleanup_action = FREE_ALL_OLD;
	     call cleanup_;
	end;
	return;
%page;
/* Initialize a search segment */

init_search_seg:
     entry (P_search_seg_ptr, P_code);

/*	P_search_seg_ptr		(Input) pointer to the search segment to be initialized
	P_code			(Output) standard status code */

	cleanup_action = NONE;
	on cleanup call cleanup_;

	P_code = 0;
	call get_search_segment (P_search_seg_ptr, P_code);
	if P_code ^= 0
	then return;
	call initialize_search_segment;
	return;
%page;
/*	Set up search_seg_ptr, the global pointer to the search segment,
	using the user-supplied search segment pointer.

	Initialize the process search segment if needed.
*/
get_search_segment:
     procedure (given_search_seg_ptr, code);

	declare given_search_seg_ptr	 pointer;		/* (Input) user supplied search segment pointer */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare ps_segname		 char (32);
	declare pdir		 char (168);
	declare ring_bracks		 (3) fixed bin (3);
	declare level		 fixed bin;


	code = 0;

	if given_search_seg_ptr ^= null
	then search_seg_ptr = given_search_seg_ptr;

	else do;
		if this_ring < 0
		then this_ring = get_ring_ ();
		call cu_$level_get (level);
		if (this_ring = level) & (default_search_seg_ptr ^= null)
		then search_seg_ptr = default_search_seg_ptr;

		else do;
			pdir = get_pdir_ ();
			call ioa_$rsnnl ("process_search_segment_.^d", ps_segname, 0, level);
			call hcs_$make_seg (pdir, ps_segname, "", 01010b, search_seg_ptr, code);
			if search_seg_ptr = null
			then return;
			code = 0;

			call hcs_$get_ring_brackets (pdir, ps_segname, ring_bracks, code);
			if code ^= 0
			then return;
			if ring_bracks (1) > level
			then do;
				code = error_table_$invalid_ring_brackets;
				return;
			     end;

			if search_seg.header.version ^= search_seg_version_2
			then call initialize_search_segment;

			if (this_ring = level)
			then default_search_seg_ptr = search_seg_ptr;
		     end;
	     end;

	if search_seg.header.version ^= search_seg_version_2
	then code = error_table_$unimplemented_version;
     end get_search_segment;
%page;
/* Initialize the global search segment */

initialize_search_segment:
     procedure;

	search_seg.header.first_list_header_off = nullo;
	search_seg.header.last_list_header_off = nullo;
	search_seg.area = empty ();
	search_seg.header.version = search_seg_version_2;
     end initialize_search_segment;
%page;
/*	Find a search list in the search segment.

	If the search list is not in the search segment, init_sl_sw
	determines if the search list should be initialized.
*/
get_search_list:
     procedure (sl_name, init_sl_sw, search_list_header_ptr, code);

	declare sl_name		 char (*);	/* (Input) search list name */
	declare init_sl_sw		 bit (1);		/* (Input) on to initialize the search list if it's not
						   in the search segment */
	declare search_list_header_ptr pointer;		/* (Output) pointer to the list_header */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare found		 bit (1);
	declare list_name_ptr	 pointer;
	declare namex		 fixed binary;

	code = 0;
	found = "0"b;
	search_list_header_ptr = search_seg.header.first_list_header_off;
	do while (search_list_header_ptr ^= null & ^found);
	     list_name_ptr = search_list_header_ptr -> list_header.list_name_off;
	     do namex = 1 to list_name_ptr -> list_name.name_count while (^found);
		found = sl_name = list_name_ptr -> list_name.names (namex);
	     end;

	     if ^found
	     then search_list_header_ptr = search_list_header_ptr -> list_header.link;
	end;

	if found
	then if search_list_header_ptr -> list_header.search_list_off = nullo
	     then code = error_table_$empty_search_list;
	     else ;
	else if init_sl_sw
	then do;
		call set_up_to_restore_on_cleanup (null);
		call initialize_search_list_with_default (sl_name, search_list_header_ptr, code);
		cleanup_action = NONE;
	     end;
	else code = error_table_$no_search_list;
     end get_search_list;
%page;
/*	Set a search list to its default.

	If search_list_header_ptr is null, a search list header will be created,
	otherwise, the one it points to will be used.
*/
initialize_search_list_with_default:
     procedure (sl_name, search_list_header_ptr, code);

	declare sl_name		 char (*);	/* (Input) search list name */
	declare search_list_header_ptr pointer;		/* (Input) if null, create a list_header,
						   otherwise, this is the pointer to it.
						   (Output) pointer to the list_header */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare default_segname	 char (32);
	declare default_search_list_ptr
				 pointer;

	code = 0;
	default_segname = rtrim (sl_name) || ".search";

/* When searching for the segment with the default search paths in it, we use
   NO referencing_dir rule.  If we use our own dir (>sss) we would be forcing
   the >sss copy of the defaults on a subsystem (e.g.  in >exl) that might
   well have its own modified version of the defaults in its own dir.  If we
   use our caller's dir (via cu_$caller_ptr) we introduce the same problem,
   since for all we know the caller is probably >sss>add_search_paths!  So we
   let the linker's chips fall where they may and presume the user has his
   linker search rule preferences the way he wants them.  */

	call hcs_$make_ptr (null, default_segname, sl_name, default_search_list_ptr, code);
	if code ^= 0
	then do;
		search_list_header_ptr = null;
		code = error_table_$no_search_list;
		return;
	     end;

	if search_list_header_ptr = null
	then do;
		call create_search_list_header (cleanup_new_list_header_ptr);
		search_list_header_ptr = cleanup_new_list_header_ptr;

		list_name_name_count = default_search_list_ptr -> default_search_list.name_count;
		allocate list_name in (search_seg.area) set (cleanup_new_list_name_ptr);
		search_list_header_ptr -> list_header.list_name_off = cleanup_new_list_name_ptr;
		cleanup_new_list_name_ptr -> list_name.names (*) =
		     default_search_list_ptr -> default_search_list.names (*);
	     end;

	search_list_path_count = default_search_list_ptr -> default_search_list.path_count;
	allocate search_list in (search_seg.area) set (cleanup_new_search_list_ptr);
	search_list_header_ptr -> list_header.search_list_off = cleanup_new_search_list_ptr;

	cleanup_new_search_list_ptr -> search_list.paths (*).type =
	     default_search_list_ptr -> default_search_list.paths (*).type;
	cleanup_new_search_list_ptr -> search_list.paths (*).pathname =
	     default_search_list_ptr -> default_search_list.paths (*).pathname;
     end initialize_search_list_with_default;
%page;
/* Copy hardcore search rules into linker search list. */
get_linker_search_list:
     procedure;

	declare code fixed binary (35);

	declare dname char (168);
	declare ename char (32);

	declare idx fixed binary;

	declare search_list_header_ptr pointer;

	declare 1 search_rules aligned,
		2 number fixed binary,
		2 name (21) character (168) unaligned;

	declare uid bit (36) aligned;

	call hcs_$get_search_rules (addr (search_rules));
	call get_search_list ("linker", "1"b, search_list_header_ptr, code);
	call set_up_to_restore_on_cleanup (search_list_header_ptr);
	if code ^= 0 & code ^= error_table_$empty_search_list
	then do;
	     call create_search_list_header (cleanup_new_list_header_ptr);
	     search_list_header_ptr = cleanup_new_list_header_ptr;

	     list_name_name_count = 1;
	     allocate list_name in (search_seg.area) set (cleanup_new_list_name_ptr);
	     search_list_header_ptr -> list_header.list_name_off = cleanup_new_list_name_ptr;
	     cleanup_new_list_name_ptr -> list_name.names (1) = "linker";
	     end;

	search_list_path_count = search_rules.number;
	allocate search_list in (search_seg.area) set (cleanup_new_search_list_ptr);
	search_list_header_ptr -> list_header.search_list_off = cleanup_new_search_list_ptr;

	do idx = 1 to search_rules.number;
	     if search_rules.name (idx) = "referencing_dir"
	     then do;
		cleanup_new_search_list_ptr -> search_list.paths (idx).type = REFERENCING_DIR;
		cleanup_new_search_list_ptr -> search_list.paths (idx).pathname =
		     "-referencing_dir";
		end;
	     else if search_rules.name (idx) = "working_dir"
	     then do;
		cleanup_new_search_list_ptr -> search_list.paths (idx).type = WORKING_DIR;
		cleanup_new_search_list_ptr -> search_list.paths (idx).pathname =
		     "-working_dir";
		end;
	     else if search_rules.name (idx) = "initiated_segments"
	     then do;
		     cleanup_new_search_list_ptr -> search_list.paths (idx).type = INITIATED_SEGS;
		     cleanup_new_search_list_ptr -> search_list.paths (idx).pathname =
			"-initiated_segments";
		end;
	     else do;
		call expand_pathname_ (search_rules.name (idx), dname, ename, code);
		if code ^= 0
		then return;

		call hcs_$get_uid_file (dname, ename, uid, code);
		if code ^= 0
		then return;

		if uid_matches_home_dir (uid)
		then do;
			cleanup_new_search_list_ptr -> search_list.paths (idx).type = HOME_DIR;
			cleanup_new_search_list_ptr -> search_list.paths (idx).pathname =
			     "-home_dir";
		     end;
		else if uid_matches_process_dir (uid)
		then do;
			cleanup_new_search_list_ptr -> search_list.paths (idx).type = PROCESS_DIR;
			cleanup_new_search_list_ptr -> search_list.paths (idx).pathname =
			     "-process_dir";
		     end;
		else do;
			cleanup_new_search_list_ptr -> search_list.paths (idx).type = ABSOLUTE_PATH;
			cleanup_new_search_list_ptr -> search_list.paths (idx).pathname =
			     search_rules.name (idx);
		     end;
		end;
	end;

	search_list_header_ptr -> list_header.update_count = search_list_header_ptr -> list_header.update_count + 1;

	cleanup_action = FREE_old_search_list;
	call cleanup_;
	return;

uid_matches_home_dir:
     procedure (unique_id) returns (bit (1) aligned);
	declare unique_id bit (36) aligned parameter;
	declare home_dir_pathname char (168);
	declare dname char (168);
	declare ename char (32);
     	declare uid bit (36) aligned;
	declare code fixed bin (35);

	call user_info_$homedir (home_dir_pathname);
	call expand_pathname_ (home_dir_pathname, dname, ename, code);
	if code ^= 0
	then return ("0"b);
	call hcs_$get_uid_file (dname, ename, uid, code);
	if code ^= 0
	then return ("0"b);
	if unique_id = uid then return ("1"b);
	else return ("0"b);

end uid_matches_home_dir;

uid_matches_process_dir:
     procedure (unique_id) returns (bit (1) aligned);
	declare unique_id bit (36) aligned parameter;
	declare dname char (168);
	declare ename char (32);
     	declare uid bit (36) aligned;
	declare code fixed bin (35);

	call expand_pathname_ (get_pdir_ (), dname, ename, code);
	if code ^= 0
	then return ("0"b);
	call hcs_$get_uid_file (dname, ename, uid, code);
	if code ^= 0
	then return ("0"b);
	if unique_id = uid then return ("1"b);
	else return ("0"b);
end uid_matches_process_dir;
	
end get_linker_search_list;
%page;
/* Set hardcore search rules from linker search list. */
set_linker_search_list:
     procedure;

	declare code fixed binary (35);

	declare dname character (168);
	declare ename character (32);

	declare entry_type fixed binary (2);

	declare idx fixed binary;

	declare 1 search_rules aligned,
		2 number fixed binary,
		2 name (21) character (168) unaligned;

	declare sp_type fixed binary;

	declare uid bit (36) aligned;

	declare DIRECTORY_TYPE fixed binary (2) internal static options (constant) initial (2);

	search_rules.number = P_sl_info_ptr -> sl_info.num_paths;
	if search_rules.number > hbound (search_rules.name, 1)
	then do;
	     P_code = error_table_$too_many_sr;
	     return;
	     end;

	do idx = 1 to search_rules.number;
	     sp_type = P_sl_info_ptr -> sl_info.paths (idx).type;
	     if sp_type = REFERENCING_DIR
	     then search_rules.name (idx) = "referencing_dir";
	     else if sp_type = WORKING_DIR
	     then search_rules.name (idx) = "working_dir";
	     else if sp_type = INITIATED_SEGS
	     then search_rules.name (idx) = "initiated_segments";
	     else if sp_type = UNEXPANDED_PATH | sp_type = HOME_DIR | sp_type = PROCESS_DIR
	     then do;
		     call expand_search_path (sp_type,
			P_sl_info_ptr -> sl_info.paths (idx).pathname, "", (36)"1"b, search_rules.name (idx), uid, code);
		     if code ^= 0
		     then do;
			P_sl_info_ptr -> sl_info.paths (idx).code = code;
			P_code = error_table_$action_not_performed;
			return;
			end;
		end;
	     else search_rules.name (idx) = P_sl_info_ptr -> sl_info.paths (idx).pathname;
	end;

	call hcs_$initiate_search_rules (addr (search_rules), code);
	if code ^= 0
	then do;
		P_code = error_table_$action_not_performed;
		do idx = 1 to search_rules.number;
		     if P_sl_info_ptr -> sl_info.paths (idx).type = UNEXPANDED_PATH | P_sl_info_ptr -> sl_info.paths (idx).type = ABSOLUTE_PATH
		     then do;
			     call expand_pathname_ (search_rules.name (idx), dname, ename, code);
			     if code ^= 0
			     then P_sl_info_ptr -> sl_info.paths (idx).code = code;
			     call hcs_$status_minf (dname, ename, (1), entry_type, (0), code);
			     if code ^= 0
			     then P_sl_info_ptr -> sl_info.paths (idx).code = code;
			     else if entry_type ^= DIRECTORY_TYPE
			     then P_sl_info_ptr -> sl_info.paths (idx).code = error_table_$notadir;
			end;
		end;
	     end;
end set_linker_search_list;
%page;
/* Allocate and initialize a new search list header. */

create_search_list_header:
     procedure (search_list_header_ptr);

	declare search_list_header_ptr pointer;		/* (Output) pointer to the new list_header */

	search_list_header_ptr = null;
	allocate list_header in (search_seg.area) set (search_list_header_ptr);

	search_list_header_ptr -> list_header.link = nullo;
	search_list_header_ptr -> list_header.back_link = search_seg.header.last_list_header_off;
	search_list_header_ptr -> list_header.list_name_off = nullo;
	search_list_header_ptr -> list_header.search_list_off = nullo;
	search_list_header_ptr -> list_header.update_count = 0;

	if search_seg.header.first_list_header_off = nullo
	then search_seg.header.first_list_header_off = search_list_header_ptr;

	if search_seg.header.last_list_header_off ^= null
	then search_seg.header.last_list_header_off -> list_header.link = search_list_header_ptr;
	search_seg.header.last_list_header_off = search_list_header_ptr;
     end create_search_list_header;
%page;
/* Allocate and initialize an sl_info structure. */

create_sl_info:
     procedure (sl_info_area_ptr, search_list_header_ptr, path_count, sl_info_ptr);

	declare sl_info_area_ptr	 pointer;		/* (Input) pointer to an area to allocate sl_info in */
	declare search_list_header_ptr pointer;		/* (Input) pointer to list_header */
	declare path_count		 fixed binary;	/* (Input) number of search paths in sl_info */
	declare sl_info_ptr		 pointer;		/* (Output) pointer to sl_info */

	declare sl_info_area	 area based;

	sl_info_ptr = null;
	sl_info_num_paths = path_count;
	allocate sl_info in (sl_info_area_ptr -> sl_info_area) set (sl_info_ptr);

	sl_info_ptr -> sl_info.version = sl_info_version_1;
	sl_info_ptr -> sl_info.change_index_p = addr (search_list_header_ptr -> list_header.update_count);
	sl_info_ptr -> sl_info.change_index = search_list_header_ptr -> list_header.update_count;
	sl_info_ptr -> sl_info.pad1 (*) = ""b;
	sl_info_ptr -> sl_info.paths (*).code = 0;
	sl_info_ptr -> sl_info.paths (*).uid = ""b;
     end create_sl_info;
%page;
/* Count how many "-referencing_dir" search paths are ignored because ref_path is null. */

null_referencing_dirs:
     procedure (expansion_control, ref_path, search_list_ptr) returns (fixed binary);

	declare expansion_control	 bit (36);	/* (Input) keyword expansion control mask */
	declare ref_path		 char (*);	/* (Input) pathname used for "-referencing_dir" rule */
	declare search_list_ptr	 pointer;		/* (Input) pointer to the search_list */

	declare pathx		 fixed binary;
	declare ref_path_count	 fixed binary;

	sl_control = expansion_control;
	if ^sl_control_s.key_ref_dir | ref_path ^= ""
	then return (0);

	ref_path_count = 0;
	do pathx = 1 to search_list_ptr -> search_list.path_count;
	     if search_list_ptr -> search_list.paths (pathx).type = REFERENCING_DIR
	     then ref_path_count = ref_path_count + 1;
	end;

	return (ref_path_count);
     end null_referencing_dirs;
%page;
/* Expand active functions and keywords in a search path according to expansion_control. */

expand_search_path:
     procedure (type, unexpanded_path, ref_path, expansion_control, expanded_path, unique_id, code);

	declare type		 fixed binary;	/* (Input) type of the unexpanded path */
	declare unexpanded_path	 char (*);	/* (Input) pathname to expand */
	declare ref_path		 char (*);	/* (Input) pathname used for "-referencing_dir" rule */
	declare expansion_control	 bit (36);	/* (Input) keyword expansion control mask */
	declare expanded_path	 char (*);	/* (Output) expanded pathname */
	declare unique_id		 bit (36) aligned;	/* (Output) UID of entry */
	declare code		 fixed binary (35); /* (Output) standard status code */


	declare dname		 char (168);
	declare ename		 char (32);
	declare uid_path		 char (168);

	expanded_path = "";
	unique_id = ""b;
	code = 0;
	sl_control = expansion_control;

	if type = UNEXPANDED_PATH & sl_control_s.af_pathname
	then call expand_af_path (unexpanded_path, expanded_path, code);

	else if type = REFERENCING_DIR & sl_control_s.key_ref_dir
	then expanded_path = ref_path;

	else if type = WORKING_DIR & sl_control_s.key_work_dir
	then expanded_path = get_wdir_ ();

	else if type = PROCESS_DIR & sl_control_s.key_proc_dir
	then expanded_path = get_pdir_ ();

	else if type = HOME_DIR & sl_control_s.key_home_dir
	then call user_info_$homedir (expanded_path);

	else expanded_path = unexpanded_path;

/* Get UIDs for process dir, home dir, or absolute path. */
	if type = ABSOLUTE_PATH | type = PROCESS_DIR | type = HOME_DIR
	then do;
	     if type = PROCESS_DIR & ^sl_control_s.key_proc_dir
	     then uid_path = get_pdir_ ();

	     else if type = HOME_DIR & ^sl_control_s.key_home_dir
	     then call user_info_$homedir (uid_path);

	     else uid_path = expanded_path;

	     call expand_pathname_ (uid_path, dname, ename, code);
	     if code ^= 0
	     then return;

	     call hcs_$get_uid_file (dname, ename, unique_id, (0));
	     end;
	return;
%page;
/* Expand active functions embedded in pathnames. */

expand_af_path:
     procedure (unexpanded_path, expanded_path, code);

	declare unexpanded_path	 char (*);	/* (Input) path to expand */
	declare expanded_path	 char (*);	/* (Output) expanded path */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare af_bracket_start_pos	 fixed binary;
	declare af_nesting_depth	 fixed binary;
	declare delta_pos		 fixed binary;
	declare path		 char (168) varying;
	declare pos		 fixed binary;

	expanded_path = "";
	code = 0;

	path = ltrim (rtrim (unexpanded_path));
	af_nesting_depth = 0;
	pos = 1;
	do while (pos <= length (path));
	     delta_pos = search (substr (path, pos), "[]");
	     if delta_pos = 0
	     then do;
		     if af_nesting_depth ^= 0
		     then code = error_table_$unbalanced_brackets;
		     pos = length (path) + 1;
		end;
	     else do;
		     pos = pos + delta_pos;
		     if substr (path, pos - 1, 1) = "["
		     then do;
			     af_nesting_depth = af_nesting_depth + 1;
			     if af_nesting_depth = 1
			     then af_bracket_start_pos = pos - 1;
			end;

		     else do;
			     af_nesting_depth = af_nesting_depth - 1;
			     if af_nesting_depth < 0
			     then do;
				     code = error_table_$unbalanced_brackets;
				     return;
				end;
			     else if af_nesting_depth = 0
			     then do;		/* change to "begin;" when compiler bug 1789 is fixed in MR7.0 */
				     declare af_bracket_length      fixed binary;
				     declare af_text_length	      fixed binary;
				     declare af_text_start_pos      fixed binary;
				     declare expanded_af	      char (168) varying;
				     declare rescan_sw	      bit (1);
				     declare unexpanded_af	      char (168);

				     af_text_start_pos = af_bracket_start_pos + 1;
				     af_text_length = pos - af_text_start_pos - 1;

				     if af_bracket_start_pos = 1
				     then rescan_sw = "1"b;
				     else do;
					     rescan_sw = substr (path, af_bracket_start_pos - 1, 1) ^= "|";
					     if ^rescan_sw
					     then af_bracket_start_pos = af_bracket_start_pos - 1;
					end;
				     af_bracket_length = pos - af_bracket_start_pos;

				     unexpanded_af = substr (path, af_text_start_pos, af_text_length);
				     call expand_af (unexpanded_af, rescan_sw, expanded_af, code);
				     if code ^= 0
				     then return;

				     if length (path) - af_bracket_length + length (expanded_af) > maxlength (path)
				     then do;
					     code = error_table_$pathlong;
					     return;
					end;
				     path = substr (path, 1, af_bracket_start_pos - 1) || expanded_af
					|| substr (path, pos);
				     pos = af_bracket_start_pos + length (expanded_af);
				end;
			end;
		end;
	end;
	expanded_path = path;
	return;
%page;
/*	Expand the active strings allowed in search paths.

	This procedure has the same calling sequence as cu_$af and can be replaced by that entry.
*/
expand_af:
     procedure (line, rescan_sw, return_value, code);

	declare line		 char (*);	/* (Input) input line */
	declare rescan_sw		 bit (1);		/* (Input) on to rescan result for active strings */
	declare return_value	 char (*) varying;	/* (Output) expanded af */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare HT		 char (1) internal static options (constant) initial ("	");
	declare Person_id		 char (22);
	declare Project_id		 char (9);
	declare SP		 char (1) internal static options (constant) initial (" ");
	declare acct		 char (32);
	declare pos		 fixed binary;

	code = 0;
	return_value = ltrim (rtrim (line, SP || HT), SP || HT);

/* change tabs to spaces */

	pos = index (return_value, HT);
	do while (pos ^= 0);
	     substr (return_value, pos, 1) = SP;
	     pos = index (return_value, HT);
	end;

/* delete multiple spaces */

	pos = index (return_value, SP || SP);
	do while (pos ^= 0);
	     return_value = substr (return_value, 1, pos) || substr (return_value, pos + 2);
	     pos = index (return_value, SP || SP);
	end;

/* expand the active strings, now that they are in a canonical form */

	call user_info_ (Person_id, Project_id, acct);
	if return_value = "user name"
	then return_value = rtrim (Person_id);
	else if return_value = "user project"
	then return_value = rtrim (Project_id);
	else do;
		return_value = "";
		code = error_table_$badpath;
	     end;
     end expand_af;

     end expand_af_path;

     end expand_search_path;
%page;
/*	Prepare to restore the search segment back to its original state if the
	cleanup condition is raised.

	If the search list does not exist yet, old_list_header_ptr is null.
*/
set_up_to_restore_on_cleanup:
     procedure (old_list_header_ptr);

	declare old_list_header_ptr	 pointer;		/* (Input) pointer to current list_header */

	cleanup_old_last_list_header_ptr = search_seg.header.last_list_header_off;
	cleanup_old_list_header_ptr = old_list_header_ptr;
	if old_list_header_ptr = null
	then do;
		cleanup_old_list_name_ptr = null;
		cleanup_old_search_list_ptr = null;
	     end;
	else do;
		cleanup_old_list_name_ptr = old_list_header_ptr -> list_header.list_name_off;
		cleanup_old_search_list_ptr = old_list_header_ptr -> list_header.search_list_off;
	     end;

	cleanup_new_list_header_ptr = null;
	cleanup_new_list_name_ptr = null;
	cleanup_new_search_list_ptr = null;

	cleanup_action = RESTORE;
     end set_up_to_restore_on_cleanup;
%page;
cleanup_:
     procedure;

	goto action (cleanup_action);

/* FREE_sl_info */

action (1):
	if P_sl_info_ptr ^= null
	then do;
		free P_sl_info_ptr -> sl_info;
		P_sl_info_ptr = null;
	     end;
	goto action (NONE);

/* FREE_sl_list */

action (2):
	if P_sl_list_ptr ^= null
	then begin;
		declare next_sl_list_ptr	 pointer;

		if P_sl_list_ptr ^= cleanup_sl_list_ptr
		then P_sl_list_ptr -> sl_list.link = cleanup_sl_list_ptr;

		do P_sl_list_ptr = P_sl_list_ptr repeat next_sl_list_ptr while (P_sl_list_ptr ^= null);
		     next_sl_list_ptr = P_sl_list_ptr -> sl_list.link;
		     free P_sl_list_ptr -> sl_list;
		end;
	     end;
	goto action (NONE);
%skip (10);
/* RESTORE */

action (3):
	if cleanup_old_list_header_ptr = null
	then do;
		if search_seg.header.first_list_header_off = cleanup_new_list_header_ptr
		then search_seg.header.first_list_header_off = nullo;

		search_seg.header.last_list_header_off = cleanup_old_last_list_header_ptr;

		if cleanup_old_last_list_header_ptr ^= null
		then cleanup_old_last_list_header_ptr -> list_header.link = nullo;
	     end;
	else do;
		if cleanup_old_last_list_header_ptr -> list_header.back_link = nullo
		then search_seg.header.first_list_header_off = cleanup_old_list_header_ptr;
		else cleanup_old_list_header_ptr -> list_header.back_link -> list_header.link =
			cleanup_old_list_header_ptr;

		if cleanup_old_list_header_ptr -> list_header.link = nullo
		then search_seg.header.last_list_header_off = cleanup_old_list_header_ptr;
		else cleanup_old_list_header_ptr -> list_header.link -> list_header.back_link =
			cleanup_old_list_header_ptr;

		cleanup_old_list_header_ptr -> list_header.list_name_off = cleanup_old_list_name_ptr;
		cleanup_old_list_header_ptr -> list_header.search_list_off = cleanup_old_search_list_ptr;
	     end;

	if cleanup_new_list_header_ptr ^= null & cleanup_new_list_header_ptr ^= cleanup_old_list_header_ptr
	then do;
		free cleanup_new_list_header_ptr -> list_header;
		cleanup_new_list_header_ptr = null;
	     end;
	if cleanup_new_list_name_ptr ^= null & cleanup_new_list_name_ptr ^= cleanup_old_list_name_ptr
	then do;
		free cleanup_new_list_name_ptr -> list_name;
		cleanup_new_list_name_ptr = null;
	     end;
	if cleanup_new_search_list_ptr ^= null & cleanup_new_search_list_ptr ^= cleanup_old_search_list_ptr
	then do;
		free cleanup_new_search_list_ptr -> search_list;
		cleanup_new_search_list_ptr = null;
	     end;
	goto action (NONE);
%skip (10);
/* FREE_old_search_list */

action (4):
	if cleanup_old_search_list_ptr ^= null
	then do;
		free cleanup_old_search_list_ptr -> search_list;
		cleanup_old_search_list_ptr = null;
	     end;
	goto action (NONE);

/* FREE_ALL_OLD */

action (5):
	if cleanup_old_search_list_ptr ^= null
	then do;
		free cleanup_old_search_list_ptr -> search_list;
		cleanup_old_search_list_ptr = null;
	     end;
	if cleanup_old_list_name_ptr ^= null
	then do;
		free cleanup_old_list_name_ptr -> list_name;
		cleanup_old_list_name_ptr = null;
	     end;
	if cleanup_old_list_header_ptr ^= null
	then do;
		free cleanup_old_list_header_ptr -> list_header;
		cleanup_old_list_header_ptr = null;
	     end;
	goto action (NONE);

/* NONE */

action (0):
     end cleanup_;

     end search_paths_;
   



		    set_search_paths.pl1            03/01/88  1334.1rew 03/01/88  1330.0      449739


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


/****^  HISTORY COMMENTS:
  1) change(87-10-15,Lippard), approve(87-10-26,MCR7788),
     audit(88-01-13,GWMay), install(88-01-19,MR12.2-1016):
     Added -inhibit_error (-ihe) and -no_inhibit_error (-nihe) to
     where_search_paths.
  2) change(87-10-29,Lippard), approve(87-11-23,MCR7797),
     audit(88-01-13,GWMay), install(88-01-19,MR12.2-1016):
     Added -force (-fc), -inhibit_error (-ihe), and -no_inhibit_error (-nihe)
     to add_search_paths.
  3) change(87-11-17,Lippard), approve(87-12-21,MCR7822),
     audit(88-02-11,Blair), install(88-02-16,MR12.2-1023):
     Added -initiated_segments (-is).
  4) change(87-11-19,Lippard), approve(87-12-21,MCR7822),
     audit(88-02-11,Blair), install(88-02-16,MR12.2-1023):
     Changed to use UIDs in pathname comparisons.
  5) change(87-11-23,Lippard), approve(87-12-21,MCR7822),
     audit(88-02-11,Blair), install(88-02-16,MR12.2-1023):
     Modified to requote pathnames returned by psp and wsp AFs, reject null
     pathnames, and correct error message given when asp modifiers are given
     out of position.
  6) change(88-02-25,Lippard), approve(87-12-21,PBF7822),
     audit(88-02-25,Farley), install(88-03-01,MR12.2-1031):
     Modified to consider matching UIDs on segments with different entry
     names to be a non-match, so that peculiar uses of search paths
     (e.g. azm's "structure" search list) will continue to work.
                                                   END HISTORY COMMENTS */


/* format: off */

/*	Search Facility Command Interface

	Rewritten 06-Sep-78 by Monte Davidoff.
	ssp -default added 07/01/80 S. Herbst
*/
set_search_paths:
ssp:
     procedure;

/* automatic */

	declare af_return_string_length
				 fixed binary (21);
	declare af_return_string_ptr	 pointer;
	declare af_sw		 bit (1);		/* on for active function, off for command */
	declare af_usage		 char (44);	/* active function usage message */
	declare arg_list_ptr	 pointer;		/* pointer to command's argument list */
	declare args_arg_count	 fixed binary;
	declare args_ptr		 pointer;
	declare cleanup_new_sl_info_ptr
				 pointer;		/* pointers for cleanup_ */
	declare cleanup_sl_info_ptr	 pointer;
	declare cleanup_sl_list_ptr	 pointer;
	declare command		 char (32);	/* what command this is */
	declare sys_err_		 entry options (variable) variable;
	declare usage		 char (44);	/* command usage message */

/* based */

	declare af_return_string	 char (af_return_string_length) varying based (af_return_string_ptr);

	declare 1 args		 based (args_ptr),
		2 arg_count	 fixed binary,	/* how many arguments the command has */
		2 first_arg	 fixed binary,	/* index of first non-control-arg argument */
		2 arg		 (args_arg_count refer (args.arg_count)),
		  3 ptr		 pointer,		/* pointer to argument */
		  3 len		 fixed binary (21), /* length of argument */
		  3 next_arg	 fixed binary,	/* index of next parsed argument */
		  3 pathx		 fixed binary;	/* if used, index of this argument in sl_info */

/* builtin */

	declare addr		 builtin;
	declare hbound		 builtin;
	declare lbound		 builtin;
	declare length		 builtin;
	declare ltrim		 builtin;
	declare null		 builtin;
	declare rtrim		 builtin;
	declare search		 builtin;
	declare substr		 builtin;

/* condition */

	declare cleanup		 condition;

/* internal static */

	declare CHASE		 fixed bin (1) internal static options (constant) initial (1);

	declare HT		 char (1) internal static options (constant) initial ("	");
	declare SP		 char (1) internal static options (constant) initial (" ");

/* external static */

	declare error_table_$action_not_performed
				 fixed binary (35) external static;
	declare error_table_$badarg	 fixed binary (35) external static;
	declare error_table_$badopt	 fixed binary (35) external static;
	declare error_table_$new_search_list
				 fixed binary (35) external static;
	declare error_table_$not_act_fnc
				 fixed binary (35) external static;

/* external entry */

	declare absolute_pathname_	 entry (char (*), char (*), fixed binary (35));
	declare active_fnc_err_	 entry options (variable);
	declare active_fnc_err_$af_suppress_name
				 entry options (variable);
	declare com_err_		 entry options (variable);
	declare com_err_$suppress_name entry options (variable);
	declare cu_$af_arg_count_rel	 entry (fixed binary, fixed binary (35), pointer);
	declare cu_$af_return_arg_rel	 entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
	declare cu_$arg_list_ptr	 entry (pointer);
	declare cu_$arg_ptr_rel	 entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed binary (35));
	declare get_pdir_		 entry returns(char(168));
	declare get_system_free_area_	 entry () returns (pointer);
	declare hcs_$get_uid_file	 entry (char (*), char (*), bit (36) aligned, fixed binary (35));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed binary (1), fixed binary (2), fixed binary (24),
				 fixed binary (35));
	declare ioa_		 entry options (variable);
	declare ioa_$rsnnl		 entry options (variable);
	declare search_paths_$delete_list
				 entry (char (*), pointer, fixed binary (35));
	declare search_paths_$find_all entry (char (*), pointer, char (*), char (*), pointer, fixed binary, pointer,
				 fixed binary (35));
	declare search_paths_$find_dir entry (char (*), pointer, char (*), char (*), char (*), fixed binary (35));
	declare search_paths_$get	 entry (char (*), bit (36), char (*), pointer, pointer, fixed binary, pointer,
				 fixed binary (35));
	declare search_paths_$list	 entry (pointer, pointer, fixed binary, pointer, fixed binary (35));
	declare search_paths_$set	 entry (char (*), pointer, pointer, fixed binary (35));
	declare user_info_$homedir	 entry (char(*));

%include sl_info;
%include sl_control_s;
%include sl_list;
%include status_structures;

/* set_search_paths */

	call initialize ("set_search_paths", "search_list {search_paths} {-control_args}", "");
	call cu_$arg_list_ptr (arg_list_ptr);
	on cleanup
	     call cleanup_;
	call set_search_paths_;
	call cleanup_;
	return;

add_search_paths:
asp:
     entry;

	call initialize ("add_search_paths", "search_list search_paths", "");
	call cu_$arg_list_ptr (arg_list_ptr);
	on cleanup
	     call cleanup_;
	call add_search_paths_;
	call cleanup_;
	return;

delete_search_paths:
dsp:
     entry;

	call initialize ("delete_search_paths", "search_list {search_paths} {-control_args}", "");
	call cu_$arg_list_ptr (arg_list_ptr);
	on cleanup
	     call cleanup_;
	call delete_search_paths_;
	call cleanup_;
	return;

print_search_paths:
psp:
     entry;

	call initialize ("print_search_paths", "{search_lists} {-control_args}", "search_list {-control_args}");
	call cu_$arg_list_ptr (arg_list_ptr);
	on cleanup
	     call cleanup_;
	call print_search_paths_;
	call cleanup_;
	return;

where_search_paths:
wsp:
     entry;

	call initialize ("where_search_paths", "search_list entryname {-control_args}", "");
	call cu_$arg_list_ptr (arg_list_ptr);
	on cleanup
	     call cleanup_;
	call where_search_paths_;
	call cleanup_;
	return;

set_search_paths_:
     procedure;

	declare argx		 fixed binary;
	declare code		 fixed binary (35);
	declare control_arg_sws	 (2) bit (1);
	declare old_argx		 fixed binary;
	declare parsed_arg_count	 fixed binary;
	declare pathx		 fixed binary;
	declare sl_name		 char (32);

	declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);

	declare 1 ssp_args		 aligned internal static options (constant),
		2 keywords	 (10) char (20)
				 initial ("-home_dir", "-hd", "-process_dir", "-pd", "-referencing_dir", "-rd",
				 "-working_dir", "-wd", "-initiated_segments", "-is"),
		2 modifiers,
		  3 name		 (1) char (1) initial (""),
		  3 has_arg	 (1) bit (1) initial ("0"b),
		2 control_args,
		  3 name		 (4) char (8) initial ("-brief", "-bf", "-default", "-df"),
		  3 switch	 (4) fixed binary initial (1, 1, 2, 2),
		  3 value		 (4) bit (1) initial ("1"b, "1"b, "1"b, "1"b);
	declare BRIEF_SW		 fixed binary internal static options (constant) initial (1);
	declare DEFAULT_SW		 fixed binary internal static options (constant) initial (2);

	call get_args (arg_list_ptr, ssp_args, control_arg_sws, parsed_arg_count, code);
	if code ^= 0
	then return;

	if parsed_arg_count = 0
	then do;
		call usage_err_;
		return;
	     end;

	if parsed_arg_count > 1 & control_arg_sws (DEFAULT_SW)
	then do;
		call sys_err_ (0, command, "Search paths cannot be specified with -default.");
		return;
	     end;

	argx = args.first_arg;
	call check_search_list_name (argx_string, sl_name, code);
	if code ^= 0
	then return;

/* -initiated_segments may only be used with linker search paths. */
	old_argx = argx;
	do argx = args.arg (argx).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
	     if (argx_string = "-initiated_segments" | argx_string = "-is") & sl_name ^= "linker"
	     then do;
		     code = error_table_$badopt;
		     call sys_err_ ((0), command, "The ""^a"" keyword may only be used with the linker search list.", argx_string);
		     return;
		end;
	end;
	argx = old_argx;

	call create_sl_info (parsed_arg_count - 1, cleanup_sl_info_ptr);

	args.arg (*).pathx = 0;
	if cleanup_sl_info_ptr ^= null
	then do pathx = 1 to cleanup_sl_info_ptr -> sl_info.num_paths;
		argx = args.arg (argx).next_arg;

		if args.arg (argx).len = 0
		then do;
			code = error_table_$badarg;
			call sys_err_ (code, command, """""");
			return;
		     end;

		call get_path_type (argx_string, cleanup_sl_info_ptr -> sl_info.paths (pathx).type,
		     cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname, code);
		if code ^= 0
		then return;

		if path_index (cleanup_sl_info_ptr, cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname) < pathx
		then do;
			call sys_err_ (0, command, "Search path specified twice. ^a",
			     cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname);
			return;
		     end;

		args.arg (argx).pathx = pathx;
	     end;

	call set_the_search_paths_of_a_search_list (sl_name, control_arg_sws (BRIEF_SW), cleanup_sl_info_ptr, code);
	if code ^= 0 & code ^= error_table_$new_search_list
	then return;

	call check_paths_for_warnings (sl_name, cleanup_sl_info_ptr);
     end set_search_paths_;

add_search_paths_:
     procedure;

	declare argx		 fixed binary;
	declare code		 fixed binary (35);
	declare control_arg_sws	 (2) bit (1);
	declare ignore_current_list	 bit (1);
	declare old_argx		 fixed binary;
	declare parsed_arg_count	 fixed binary;
	declare path_count		 fixed binary;
	declare pathx		 fixed binary;
	declare sl_name		 char (32);

	declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);

	declare 1 asp_args		 aligned internal static options (constant),
		2 keywords	 (10) char (20)
				 initial ("-home_dir", "-hd", "-process_dir", "-pd", "-referencing_dir", "-rd",
				 "-working_dir", "-wd", "-initiated_segments", "-is"),
		2 modifiers,
		  3 name		 (8) char (8)
				 initial ("-first", "-ft", "-last", "-lt", "-before", "-be", "-after", "-af"),
		  3 has_arg	 (8) bit (1) initial ("0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b),
		2 control_args,
		  3 name		 (8) char (17) initial ("-force", "-fc", "-no_force", "-nfc", "-inhibit_error", "-ihe", "-no_inhibit_error", "-nihe"),
		  3 switch	 (8) fixed binary initial (1, 1, 1, 1, 2, 2, 2, 2),
		  3 value		 (8) bit (1) initial ("1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b);
	declare FORCE_SW		 fixed binary internal static options (constant) initial (1);
	declare INHIBIT_ERR_SW	 fixed binary internal static options (constant) initial (2);

	call get_args (arg_list_ptr, asp_args, control_arg_sws, parsed_arg_count, code);
	if code ^= 0
	then return;

	if parsed_arg_count < 2
	then do;
		call usage_err_;
		return;
	     end;

	argx = args.first_arg;
	call check_search_list_name (argx_string, sl_name, code);
	if code ^= 0
	then return;

/* -initiated_segments may only be used with linker search paths. */
	old_argx = argx;
	do argx = args.arg (argx).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
	     if (argx_string = "-initiated_segments" | argx_string = "-is") & sl_name ^= "linker"
	     then do;
		     code = error_table_$badopt;
		     call sys_err_ ((0), command, "The ""^a"" keyword may only be used with the linker search list.", argx_string);
		     return;
		end;
	end;
	argx = old_argx;

	call search_paths_$get (sl_name, ""b, "", null, get_system_free_area_ (), sl_info_version_1, cleanup_sl_info_ptr,
	     code);
	if code ^= 0
	then do;
		call sys_err_ (code, command, "^a", sl_name);
		return;
	     end;

	ignore_current_list = "0"b;

/* Begin block with local variables for compatibility with the style of
   the rest of program (and because this block contains local variables
   having the same names as others outside the block). */
	if control_arg_sws (FORCE_SW)
	then begin;
		declare delete_count	 fixed binary;
		declare new_pathx		 fixed binary;
		declare pathname		 character (168);
		declare pathx		 fixed binary;

/* See which paths are duplicates, and delete them. */
		delete_count = 0;
		do argx = args.arg (argx).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
		     call get_path_type (argx_string, (0), pathname, code);
		     if code ^= 0
		     then return;
		     pathx = path_index (cleanup_sl_info_ptr, pathname);
		     if pathx ^= 0
		     then do;
			     cleanup_sl_info_ptr -> sl_info.paths (pathx).type = 0;
			     cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname = "";
			     delete_count = delete_count + 1;
			end;
		end;

/* They're all duplicates. */
		if delete_count = cleanup_sl_info_ptr -> sl_info.num_paths
		then do;
			ignore_current_list = "1"b;
			path_count = 0;
		end;

/* Delete the duplicates. */
		else if delete_count ^= 0
		then do;
			call create_sl_info (cleanup_sl_info_ptr -> sl_info.num_paths - delete_count, cleanup_new_sl_info_ptr);

			new_pathx = 1;
			do pathx = 1 to cleanup_sl_info_ptr -> sl_info.num_paths
			     while (new_pathx <= cleanup_new_sl_info_ptr -> sl_info.num_paths);
			     if cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname ^= ""
			     then do;
				     cleanup_new_sl_info_ptr -> sl_info.paths (new_pathx).type =
					cleanup_sl_info_ptr -> sl_info.paths (pathx).type;
				     cleanup_new_sl_info_ptr -> sl_info.paths (new_pathx).pathname =
					cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname;
				     cleanup_new_sl_info_ptr -> sl_info.paths (new_pathx).uid =
					cleanup_sl_info_ptr -> sl_info.paths (pathx).uid;
				     new_pathx = new_pathx + 1;
				end;
			end;

			free cleanup_sl_info_ptr -> sl_info;
			cleanup_sl_info_ptr = cleanup_new_sl_info_ptr;
			cleanup_new_sl_info_ptr = null ();
		     end;
	     end;

/* If they're all duplicates, just create a whole new search list. */
	if ignore_current_list
	then do;
		call create_sl_info (parsed_arg_count - 1, cleanup_new_sl_info_ptr);
		cleanup_new_sl_info_ptr -> sl_info.paths (*).type = 0;
		cleanup_new_sl_info_ptr -> sl_info.paths (*).pathname = "";
		cleanup_new_sl_info_ptr -> sl_info.paths (*).uid = ""b;
	     end;

/* Otherwise, just add the new and duplicate paths. */
	else do;
		path_count = cleanup_sl_info_ptr -> sl_info.num_paths;
		call create_sl_info (path_count + parsed_arg_count - 1, cleanup_new_sl_info_ptr);
		cleanup_new_sl_info_ptr -> sl_info.paths (*).type = 0;
		cleanup_new_sl_info_ptr -> sl_info.paths (*).pathname = "";
		cleanup_new_sl_info_ptr -> sl_info.paths (*).uid = ""b;

		do pathx = 1 to path_count;
		     cleanup_new_sl_info_ptr -> sl_info.paths (pathx).type =
			cleanup_sl_info_ptr -> sl_info.paths (pathx).type;
		     cleanup_new_sl_info_ptr -> sl_info.paths (pathx).pathname =
			cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname;
		     cleanup_new_sl_info_ptr -> sl_info.paths (pathx).uid =
			cleanup_sl_info_ptr -> sl_info.paths (pathx).uid;
		end;
	     end;

	free cleanup_sl_info_ptr -> sl_info;
	cleanup_sl_info_ptr = null;

	call add_search_paths_to_sl_info (sl_name, cleanup_new_sl_info_ptr, control_arg_sws (INHIBIT_ERR_SW), path_count, code);
	if code ^= 0
	then return;

	call create_sl_info (path_count, cleanup_sl_info_ptr);
	do pathx = 1 to path_count;
	     cleanup_sl_info_ptr -> sl_info.paths (pathx).type = cleanup_new_sl_info_ptr -> sl_info.paths (pathx).type;
	     cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname =
		cleanup_new_sl_info_ptr -> sl_info.paths (pathx).pathname;
	     cleanup_sl_info_ptr -> sl_info.paths (pathx).uid =
		cleanup_new_sl_info_ptr -> sl_info.paths (pathx).uid;
	end;

	free cleanup_new_sl_info_ptr -> sl_info;
	cleanup_new_sl_info_ptr = null;

	call set_the_search_paths_of_a_search_list (sl_name, "0"b, cleanup_sl_info_ptr, code);
	if code ^= 0
	then return;

	if ^control_arg_sws (INHIBIT_ERR_SW)
	then call check_paths_for_warnings (sl_name, cleanup_sl_info_ptr);
     end add_search_paths_;

delete_search_paths_:
     procedure;

	declare argx		 fixed binary;
	declare code		 fixed binary (35);
	declare control_arg_sws	 (1) bit (1);
	declare old_argx		 fixed binary;
	declare parsed_arg_count	 fixed binary;
	declare sl_name		 char (32);

	declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);

	declare 1 dsp_args		 aligned internal static options (constant),
		2 keywords	 (10) char (20)
				 initial ("-home_dir", "-hd", "-process_dir", "-pd", "-referencing_dir", "-rd", "-working_dir", "-wd", "-initiated_segments", "-is"),
		2 modifiers,
		  3 name		 (1) char (1) initial (""),
		  3 has_arg	 (1) bit (1) initial ("0"b),
		2 control_args,
		  3 name		 (2) char (4) initial ("-all", "-a"),
		  3 switch	 (2) fixed binary initial (1, 1),
		  3 value		 (2) bit (1) initial ("1"b, "1"b);
	declare ALL_SW		 fixed binary internal static options (constant) initial (1);

	call get_args (arg_list_ptr, dsp_args, control_arg_sws, parsed_arg_count, code);
	if code ^= 0
	then return;

	if parsed_arg_count = 0
	then do;
		call usage_err_;
		return;
	     end;

	argx = args.first_arg;
	call check_search_list_name (argx_string, sl_name, code);
	if code ^= 0
	then return;

/* -initiated_segments may only be used with linker search paths. */
	old_argx = argx;
	do argx = args.arg (argx).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
	     if (argx_string = "-initiated_segments" | argx_string = "-is") & sl_name ^= "linker"
	     then do;
		     code = error_table_$badopt;
		     call sys_err_ ((0), command, "The ""^a"" keyword may only be used with the linker search list.", argx_string);
		     return;
		end;
	end;
	argx = old_argx;

	if control_arg_sws (ALL_SW)
	then do;
		call search_paths_$delete_list (sl_name, null, code);
		if code ^= 0
		then do;
			call sys_err_ (code, command, "^a", sl_name);
			return;
		     end;
	     end;
	else begin;
		declare delete_count	 fixed binary;
		declare new_pathx		 fixed binary;
		declare pathname		 character (168);
		declare pathx		 fixed binary;

		call search_paths_$get (sl_name, ""b, "", null, get_system_free_area_ (), sl_info_version_1,
		     cleanup_sl_info_ptr, code);
		if code ^= 0
		then do;
			call sys_err_ (code, command, "^a", sl_name);
			return;
		     end;

		delete_count = 0;
		do argx = args.arg (argx).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
		     if args.arg (argx).len = 0
		     then do;
			     code = error_table_$badarg;
			     call sys_err_ (code, command, """""");
			     return;
			end;
		     call get_path_type (argx_string, (0), pathname, code);
		     if code ^= 0
		     then return;
		     pathx = path_index (cleanup_sl_info_ptr, pathname);
		     if pathx = 0
		     then call sys_err_ (0, command, "Search path ^a is not in the ^a search list.", argx_string, sl_name)
			     ;
		     else do;
			     cleanup_sl_info_ptr -> sl_info.paths (pathx).type = 0;
			     cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname = "";
			     cleanup_sl_info_ptr -> sl_info.paths (pathx).uid = ""b;
			     delete_count = delete_count + 1;
			end;
		end;

		if delete_count = cleanup_sl_info_ptr -> sl_info.num_paths
		then do;
			call sys_err_ (error_table_$action_not_performed, command, "The search list would be empty.");
			return;
		     end;

		if delete_count = 0
		then do;
			call sys_err_ (0, command, "No search paths deleted.");
			return;
		     end;

		call create_sl_info (cleanup_sl_info_ptr -> sl_info.num_paths - delete_count, cleanup_new_sl_info_ptr);

		new_pathx = 1;
		do pathx = 1 to cleanup_sl_info_ptr -> sl_info.num_paths
		     while (new_pathx <= cleanup_new_sl_info_ptr -> sl_info.num_paths);
		     if cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname ^= ""
		     then do;
			     cleanup_new_sl_info_ptr -> sl_info.paths (new_pathx).type =
				cleanup_sl_info_ptr -> sl_info.paths (pathx).type;
			     cleanup_new_sl_info_ptr -> sl_info.paths (new_pathx).pathname =
				cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname;
			     cleanup_new_sl_info_ptr -> sl_info.paths (new_pathx).uid =
				cleanup_sl_info_ptr -> sl_info.paths (pathx).uid;
			     new_pathx = new_pathx + 1;
			end;
		end;

		call set_the_search_paths_of_a_search_list (sl_name, "0"b, cleanup_new_sl_info_ptr, code);
	     end;
     end delete_search_paths_;

print_search_paths_:
     procedure;

	declare code		 fixed binary (35);
	declare control_arg_sws	 (1) bit (1);
	declare parsed_arg_count	 fixed binary;

	declare 1 psp_args		 aligned internal static options (constant),
		2 keywords	 (1) char (1) initial (""),
		2 modifiers,
		  3 name		 (1) char (1) initial (""),
		  3 has_arg	 (1) bit (1) initial ("0"b),
		2 control_args,
		  3 name		 (2) char (12) initial ("-expanded", "-exp"),
		  3 switch	 (2) fixed binary initial (1, 1),
		  3 value		 (2) bit (1) initial ("1"b, "1"b);
	declare EXPAND_SW		 fixed binary internal static options (constant) initial (1);

	call check_for_active_function (arg_list_ptr, code);
	if code ^= 0
	then return;

	call get_args (arg_list_ptr, psp_args, control_arg_sws, parsed_arg_count, code);
	if code ^= 0
	then return;

	if af_sw & parsed_arg_count ^= 1
	then do;
		call usage_err_;
		return;
	     end;

	if parsed_arg_count = 0
	then do;
		call search_paths_$list (null, get_system_free_area_ (), sl_list_version_2, cleanup_sl_list_ptr, code);
		if code ^= 0
		then do;
			call sys_err_ (code, command);
			return;
		     end;

		if cleanup_sl_list_ptr = null
		then call sys_err_ (0, command, "Search segment is empty.");
		else begin;
			declare namex		 fixed binary;
			declare sl_list_ptr		 pointer;

			do sl_list_ptr = cleanup_sl_list_ptr repeat sl_list_ptr -> sl_list.link
			     while (sl_list_ptr ^= null);
			     do namex = 1 to sl_list_ptr -> sl_list.name_count;
				call output_one_line (sl_list_ptr -> sl_list.names (namex));
			     end;
			     call print_search_list (sl_list_ptr -> sl_list.names (1), "0"b,
				control_arg_sws (EXPAND_SW), cleanup_sl_info_ptr);
			end;
		     end;
	     end;
	else begin;
		declare argx		 fixed binary;
		declare sl_name		 char (32);

		declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);

		do argx = args.first_arg repeat args.arg (argx).next_arg while (argx ^= 0);
		     call check_search_list_name (argx_string, sl_name, code);
		     if code = 0
		     then call print_search_list (sl_name, ^af_sw, control_arg_sws (EXPAND_SW), cleanup_sl_info_ptr);
		end;
	     end;
     end print_search_paths_;

where_search_paths_:
     procedure;

	declare argx		 fixed binary;
	declare code		 fixed binary (35);
	declare control_arg_sws	 (2) bit (1);
	declare old_argx		 fixed binary;
	declare parsed_arg_count	 fixed binary;
	declare sl_name		 char (32);

	declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);

	declare 1 wsp_args		 aligned internal static options (constant),
		2 keywords	 (1) char (1) initial (""),
		2 modifiers,
		  3 name		 (1) char (1) initial (""),
		  3 has_arg	 (1) bit (1) initial ("0"b),
		2 control_args,
		  3 name		 (6) char (17) initial ("-all", "-a", "-inhibit_error", "-ihe", "-no_inhibit_error", "-nihe"),
		  3 switch	 (6) fixed binary initial (1, 1, 2, 2, 2, 2),
		  3 value		 (6) bit (1) initial ("1"b, "1"b, "1"b, "1"b, "0"b, "0"b);
	declare ALL_SW		 fixed binary internal static options (constant) initial (1);
	declare INHIBIT_ERR_SW	 fixed binary internal static options (constant) initial (2);

	call check_for_active_function (arg_list_ptr, code);
	if code ^= 0
	then return;

	call get_args (arg_list_ptr, wsp_args, control_arg_sws, parsed_arg_count, code);
	if code ^= 0
	then return;

	if parsed_arg_count ^= 2
	then do;
		call usage_err_;
		return;
	     end;

	argx = args.first_arg;
	call check_search_list_name (argx_string, sl_name, code);
	if code ^= 0
	then return;

/* -initiated_segments may only be used with linker search paths. */
	old_argx = argx;
	do argx = args.arg (argx).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
	     if (argx_string = "-initiated_segments" | argx_string = "-is") & sl_name ^= "linker"
	     then do;
		     code = error_table_$badopt;
		     call sys_err_ (code, command, "^a", argx_string);
		     return;
		end;
	end;
	argx = old_argx;

	argx = args.arg (argx).next_arg;
	if args.arg (argx).len = 0
	then do;
		code = error_table_$badarg;
		call sys_err_ (code, command, """""");
		return;
	     end;
	if control_arg_sws (ALL_SW)
	then begin;
		declare pathx		 fixed binary;

		call search_paths_$find_all (sl_name, null, argx_string, "", get_system_free_area_ (), sl_info_version_1,
		     cleanup_sl_info_ptr, code);
		if code ^= 0
		then do;
			if control_arg_sws (INHIBIT_ERR_SW) & af_sw then af_return_string = "";
			else call sys_err_ (code, command, "^a in ^a search list.", argx_string, sl_name);
			return;
		     end;

		do pathx = 1 to cleanup_sl_info_ptr -> sl_info.num_paths;
		     call output_pathname (cleanup_sl_info_ptr -> sl_info.paths (pathx).pathname, argx_string);
		end;
	     end;
	else begin;
		declare dir_name		 char (168);

		call search_paths_$find_dir (sl_name, null, argx_string, "", dir_name, code);
		if code ^= 0
		then do;
			if control_arg_sws (INHIBIT_ERR_SW) & af_sw then af_return_string = "";
			else call sys_err_ (code, command, "^a in ^a search list.", argx_string, sl_name);
			return;
		     end;
		call output_pathname (dir_name, argx_string);
	     end;
     end where_search_paths_;

/*	Add the search path arguments of add_search_paths to an sl_info structure.

	The sl_info structure must have enough room for all the possible
	search paths in the argument list.
*/
add_search_paths_to_sl_info:
     procedure (sl_name, sl_info_ptr, inhibit_err, path_count, code);

	declare sl_name		 char (*);	/* (Input) search list name */
	declare sl_info_ptr		 pointer;		/* (Input) pointer to a "large enough" sl_info */
	declare inhibit_err		 bit (1);		/* (Input) if warnings shouldn't be printed */
	declare path_count		 fixed binary;	/* (Updated) number of paths in sl_info */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare argx		 fixed binary;
	declare dname		 char (168);
	declare ename		 char (32);
	declare error		 bit (1);
	declare insert_index	 fixed binary;
	declare pathname		 char (168);
	declare type		 fixed binary;
	declare uid		 bit (36) aligned;

	code = 0;

	args.arg (*).pathx = 0;
	do argx = args.arg (args.first_arg).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
	     if args.arg (argx).len = 0
	     then do;
		     code = error_table_$badarg;
		     call sys_err_ (code, command, """""");
		     return;
		end;
	     call get_search_path_and_position (sl_info_ptr, path_count, argx, inhibit_err, type, pathname, insert_index, error, code);
	     if code ^= 0
	     then return;

	     if ^error
	     then begin;
		     declare pathx		      fixed binary;

		     do pathx = path_count to insert_index by -1;
			sl_info_ptr -> sl_info.paths (pathx + 1).type = sl_info_ptr -> sl_info.paths (pathx).type;
			sl_info_ptr -> sl_info.paths (pathx + 1).pathname =
			     sl_info_ptr -> sl_info.paths (pathx).pathname;
			sl_info_ptr -> sl_info.paths (pathx + 1).uid =
			     sl_info_ptr -> sl_info.paths (pathx).uid;
		     end;

		     path_count = path_count + 1;
		     sl_info_ptr -> sl_info.paths (insert_index).type = type;
		     sl_info_ptr -> sl_info.paths (insert_index).pathname = pathname;

/* The following two expansions need to be done for the linker search
   list in order to set the UID correctly. */
		     if type = PROCESS_DIR
		     then pathname = get_pdir_ ();

		     else if type = HOME_DIR
		     then call user_info_$homedir (pathname);

		     uid = ""b;
		     if type = ABSOLUTE_PATH | type = HOME_DIR | type = PROCESS_DIR
		     then do;
			call expand_pathname_ (pathname, dname, ename, code);
			if code = 0
			then call hcs_$get_uid_file (dname, ename, uid, (0));
			end;
		     sl_info_ptr -> sl_info.paths (insert_index).uid = uid;

		     do pathx = 1 to argx - 1;
			if args.arg (pathx).pathx >= insert_index
			then args.arg (pathx).pathx = args.arg (pathx).pathx + 1;
		     end;

		     args.arg (argx).pathx = insert_index;
		end;
	end;
	return;

/*	Convert an argument of add_search_paths to a search path and figure
	out where to put it in the sl_info structure.

	This looks at modifiers that may follow an argument.
*/
get_search_path_and_position:
     procedure (sl_info_ptr, path_count, argx, inhibit_err, type, pathname, insert_index, error, code);

	declare sl_info_ptr		 pointer;		/* (Input) pointer to a "large enough" sl_info */
	declare path_count		 fixed binary;	/* (Input) number of paths in sl_info */
	declare argx		 fixed binary;	/* (Input) current argument number */
	declare inhibit_err		 bit (1);		/* (Input) if warnings shouldn't be printed */
	declare type		 fixed binary;	/* (Output) type of the new search path */
	declare pathname		 char (*);	/* (Output) new search pathname */
	declare insert_index	 fixed binary;	/* (Output) where to insert search path in sl_info */
	declare error		 bit (1);		/* (Output) on means there was a non-fatal error */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare next_arg		 fixed binary;
	declare old_pathname	 char (168);
	declare old_type		 fixed binary;
	declare pathx		 fixed binary;

	declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);
	declare next_arg_string	 char (args.arg (next_arg).len) based (args.arg (next_arg).ptr);

	type = 0;
	pathname = "";
	insert_index = path_count + 1;
	error = "0"b;
	code = 0;

	call get_path_type (argx_string, type, pathname, code);
	if code ^= 0
	then return;

	if path_index (sl_info_ptr, pathname) > 0 & ^inhibit_err
	then do;
		error = "1"b;
		call sys_err_ (0, command, "Warning. ^a is already in the ^a search list.", pathname, sl_name);
	     end;

	if argx >= args.arg_count
	then return;				/* no modifiers */

	next_arg = argx + 1;
	if next_arg_string = "-first" | next_arg_string = "-ft"
	then do;
		insert_index = 1;
		return;
	     end;

	if next_arg_string = "-last" | next_arg_string = "-lt"
	then do;
		insert_index = path_count + 1;
		return;
	     end;

	if next_arg_string = "-before" | next_arg_string = "-be"
	then insert_index = 0;
	else if next_arg_string = "-after" | next_arg_string = "-af"
	then insert_index = 1;
	else return;

	next_arg = next_arg + 1;
	if next_arg > args.arg_count
	then do;
		code = error_table_$badopt;
		call sys_err_ (0, command, "A search path must follow ^[-before^;-after^].", insert_index = 0);
		return;
	     end;

	call get_path_type (next_arg_string, old_type, old_pathname, code);
	if code ^= 0
	then return;

	pathx = path_index (sl_info_ptr, old_pathname);
	if pathx = 0
	then do;
		error = "1"b;
		call sys_err_ (0, command, "Search path ^a was not in the ^a search list.", old_pathname, sl_name);
	     end;

	insert_index = pathx + insert_index;
     end get_search_path_and_position;

     end add_search_paths_to_sl_info;

/*	Initialize global variables

	If af_usage_msg is null, then usage_msg is used.
*/
initialize:
     procedure (command_name, usage_msg, af_usage_msg);

	declare command_name	 char (*);	/* (Input) what command this is */
	declare usage_msg		 char (*);	/* (Input) command usage message */
	declare af_usage_msg	 char (*);	/* (Input) active function usage message */

	command = command_name;
	usage = usage_msg;
	if af_usage_msg = ""
	then af_usage = usage_msg;
	else af_usage = af_usage_msg;

	af_sw = "0"b;
	sys_err_ = com_err_;

	args_ptr = null;
	cleanup_new_sl_info_ptr = null;
	cleanup_sl_info_ptr = null;
	cleanup_sl_list_ptr = null;
     end initialize;

/* Find out if this command was called as an active function */

check_for_active_function:
     procedure (arg_list_ptr, code);

	declare arg_list_ptr	 pointer;		/* (Input) pointer to argument list */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare arg_count		 fixed binary;

	call cu_$af_return_arg_rel (arg_count, af_return_string_ptr, af_return_string_length, code, arg_list_ptr);
	if code = 0
	then do;
		af_sw = "1"b;
		sys_err_ = active_fnc_err_;
		af_return_string = "";
	     end;
	else if code = error_table_$not_act_fnc
	then code = 0;
	else call sys_err_ (code, command);
     end check_for_active_function;

/*	Parse the command's arguments.

	Pointers to the arguments are placed in a structure.
	Control-arguments are checked, and a switch is set when one is
	found.  A parsed_arg_count is returned which gives the number of
	arguments not including control-arguments and modifiers.  The
	parsed arguments are linked together so it is possible to loop
	through them and ignore control-arguments and modifiers.

Note:	The first argument cannot have a modifier.  (add_search_paths is the
	only command which allows modifiers and the first argument of
	add_search_paths is a search list, not a search path).
*/
get_args:
     procedure (arg_list_ptr, command_args, control_arg_sws, parsed_arg_count, code);

	declare arg_list_ptr	 pointer;		/* (Input) pointer to argument list */
	declare 1 command_args	 aligned,		/* (Input) expected arguments description */
		2 keywords	 (*) char (*),	/* control-arg-like keywords that aren't control args */
		2 modifiers,			/* positional control-args that can follow an argument */
		  3 name		 (*) char (*),	/* modifier's name */
		  3 has_arg	 (*) bit (1),	/* on if the modifier takes an argument */
		2 control_args,			/* what control-arguments there are */
		  3 name		 (*) char (*),	/* control-arguments name */
		  3 switch	 (*) fixed binary,	/* what switch to set if found */
		  3 value		 (*) bit (1);	/* what value to set the switch */
	declare control_arg_sws	 (*) bit (1);	/* (Output) what control arguments were found */
	declare parsed_arg_count	 fixed binary;	/* (Output) how many args excluding control-args and modifiers */
	declare code		 fixed binary (35); /* (Output) standard status code */

	declare argx		 fixed binary;
	declare namex		 fixed binary;
	declare last_parsed_arg	 fixed binary;

	declare argx_string		 char (args.arg (argx).len) based (args.arg (argx).ptr);

	control_arg_sws (*) = "0"b;
	parsed_arg_count = 0;
	code = 0;

	call cu_$af_arg_count_rel (args_arg_count, code, arg_list_ptr);
	if code = error_table_$not_act_fnc
	then code = 0;
	if code ^= 0
	then do;
		call sys_err_ (code, command);
		return;
	     end;

	if args_arg_count = 0
	then return;
	allocate args;

	args.first_arg = 0;
	args.arg (*).next_arg = 0;

	do argx = 1 to args.arg_count;
	     call cu_$arg_ptr_rel (argx, args.arg (argx).ptr, args.arg (argx).len, code, arg_list_ptr);
	     if code ^= 0
	     then do;
		     call sys_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;
	end;

	last_parsed_arg = -1;
	argx = 1;
	do while (argx <= args.arg_count);
	     if ^is_control_arg (argx_string) | string_array_index (command_args.keywords (*), argx_string) > 0
	     then do;
		     parsed_arg_count = parsed_arg_count + 1;
		     if last_parsed_arg < 0
		     then args.first_arg = argx;
		     else args.arg (last_parsed_arg).next_arg = argx;
		     last_parsed_arg = argx;
		end;
	     else do;
		     namex = string_array_index (command_args.control_args.name (*), argx_string);
		     if namex > 0
		     then control_arg_sws (command_args.control_args.switch (namex)) = command_args.control_args.value (namex);
		     else do;
			     namex = string_array_index (command_args.modifiers.name (*), argx_string);
			     if last_parsed_arg = argx - 1 & last_parsed_arg > 1 & namex > 0
			     then if command_args.modifiers.has_arg (namex)
				then argx = argx + 1;
				else ;
			     else do;
				     code = error_table_$badopt;
				     if namex > 0
				     then call sys_err_ ((0), command, "The modifier ""^a"" may only follow a path or keyword.", argx_string);
				     else call sys_err_ (code, command, "^a", argx_string);
				     return;
				end;
			end;
		end;

	     argx = argx + 1;
	end;
     end get_args;

/* Make sure the search list name is valid */

check_search_list_name:
     procedure (given_search_list_name, sl_name, code);

	declare given_search_list_name char (*);	/* (Input) supplied search list name */
	declare sl_name		 char (*);	/* (Output) search list name */
	declare code		 fixed binary (35); /* (Output) non-standard status code */

	declare pos		 fixed binary;

	sl_name = "";
	code = 0;

	if is_control_arg (given_search_list_name)
	then do;
		code = -1;
		call usage_err_;
		return;
	     end;

	if length (given_search_list_name) > length (sl_name)
	then do;
		code = -1;
		call sys_err_ (0, command, "Search list name too long. ^a", given_search_list_name);
		return;
	     end;

	pos = search (given_search_list_name, "<>");
	if pos ^= 0
	then do;
		code = -1;
		call sys_err_ (0, command, "Invalid character ""^a"" in search list name. ^a",
		     substr (given_search_list_name, pos, 1), given_search_list_name);
		return;
	     end;

	if given_search_list_name = ""
	then do;
		code = -1;
		call sys_err_ (0, command, "Null search list name.");
		return;
	     end;

	sl_name = given_search_list_name;
     end check_search_list_name;

/* Allocate and initialize an sl_info structure */

create_sl_info:
     procedure (path_count, sl_info_ptr);

	declare path_count		 fixed binary;	/* (Input) number of search paths in sl_info */
	declare sl_info_ptr		 pointer;		/* (Output) pointer to sl_info */

	sl_info_ptr = null;
	if path_count ^= 0
	then do;
		sl_info_num_paths = path_count;
		allocate sl_info set (sl_info_ptr);

		sl_info_ptr -> sl_info.version = sl_info_version_1;
		sl_info_ptr -> sl_info.change_index_p = null;
		sl_info_ptr -> sl_info.change_index = 0;
		sl_info_ptr -> sl_info.pad1 (*) = ""b;
		sl_info_ptr -> sl_info.paths (*).code = 0;
		sl_info_ptr -> sl_info.paths (*).uid = ""b;
	     end;
     end create_sl_info;

/* Convert an argument into a search path type and pathname */

get_path_type:
     procedure (search_path, type, pathname, code);

	declare search_path		 char (*);	/* (Input) search path to convert */
	declare type		 fixed binary;	/* (Output) search path type */
	declare pathname		 char (*);	/* (Output) search pathname */
	declare code		 fixed binary (35); /* (Output) standard status code */

	type = 0;
	pathname = search_path;
	code = 0;
	if is_control_arg (search_path)
	then if search_path = "-home_dir" | search_path = "-hd"
	     then do;
		     type = HOME_DIR;
		     pathname = "-home_dir";
		end;
	     else if search_path = "-process_dir" | search_path = "-pd"
	     then do;
		     type = PROCESS_DIR;
		     pathname = "-process_dir";
		end;
	     else if search_path = "-referencing_dir" | search_path = "-rd"
	     then do;
		     type = REFERENCING_DIR;
		     pathname = "-referencing_dir";
		end;
	     else if search_path = "-working_dir" | search_path = "-wd"
	     then do;
		     type = WORKING_DIR;
		     pathname = "-working_dir";
		end;
	     else if search_path = "-initiated_segments" | search_path = "-is"
	     then do;
		     type = INITIATED_SEGS;
		     pathname = "-initiated_segments";
		end;
	     else do;
		     code = error_table_$badopt;
		     call sys_err_ (code, command, "^a", search_path);
		end;
	else do;
		if search (search_path, "[]") = 0
		then type = ABSOLUTE_PATH;
		else type = UNEXPANDED_PATH;

		call absolute_pathname_ (search_path, pathname, code);
		if code ^= 0
		then call sys_err_ (code, command, "^a", search_path);
	     end;
     end get_path_type;

/*	Check if an argument is a control-argument.

	A control-argument is defined for this procedure to be anything starting with a hyphen.
*/
is_control_arg:
     procedure (arg) returns (bit (1));

	declare arg		 char (*);	/* (Input) a command argument */

	if arg = ""
	then return ("0"b);
	else return (substr (arg, 1, 1) = "-");
     end is_control_arg;

/* Find the index of a search path in sl_info */

path_index:
     procedure (sl_info_ptr, pathname) returns (fixed binary);

	declare sl_info_ptr		 pointer;		/* (Input) pointer to sl_info */
	declare pathname		 char (*);	/* (Input) pathname to look for */

	declare code		 fixed binary (35);

	declare dname		 char (168);
	declare ename		 char (32);

	declare entry_type		 fixed binary (2);

	declare pathx		 fixed binary;

	declare uid		 bit (36) aligned;

	entry_type = 0;
	uid = ""b;
	call expand_pathname_ (pathname, dname, ename, code);
	if code = 0
	then do;
		call hcs_$status_minf (dname, ename, CHASE, entry_type, (0), code);
	     	if code = 0
		then call hcs_$get_uid_file (dname, ename, uid, (0));
	     end;
	do pathx = 1 to sl_info_ptr -> sl_info.num_paths while (unique_pathname ());
	end;
	if pathx > sl_info_ptr -> sl_info.num_paths
	then return (0);
	else return (pathx);

unique_pathname: procedure () returns (bit (1) aligned);
dcl  sl_dname char (168);
dcl  sl_ename char (32);

	     if pathname = sl_info_ptr -> sl_info.paths (pathx).pathname
	     then return ("0"b);

	     if (uid ^= sl_info_ptr -> sl_info.paths (pathx).uid
	     | uid = ""b | sl_info_ptr -> sl_info.paths (pathx).uid = ""b)
	     then return ("1"b);			/* unique */

/* In the case of search lists of segment pathnames, we want to consider
   different names on the same entry to be different.  So if UIDs match
   but the entry names are different, we consider it not to be a match. */

	     if entry_type ^= Segment
	     then return ("0"b);
	     call expand_pathname_ (sl_info_ptr -> sl_info.paths (pathx).pathname, sl_dname, sl_ename, code);
	     if code ^= 0
	     then return ("0"b);
	     if ename ^= sl_ename
	     then return ("1"b);			/* unique */
	     else return ("0"b);
	end unique_pathname;
     end path_index;

/* Find the index of a character string in a character string array */

string_array_index:
     procedure (array, string) returns (fixed binary);

	declare array		 (*) char (*) aligned;
						/* (Input) array of character strings */
	declare string		 char (*);	/* (Input) string to look for */

	declare arrayx		 fixed binary;

	do arrayx = lbound (array, 1) to hbound (array, 1) while (string ^= array (arrayx));
	end;
	if arrayx > hbound (array, 1)
	then return (0);
	else return (arrayx);
     end string_array_index;

/*	Change a search list.

	Appropriate error and warning messages are printed.
*/
set_the_search_paths_of_a_search_list:
     procedure (sl_name, brief_sw, sl_info_ptr, code);

	declare sl_name		 char (*);	/* (Input) search list name */
	declare brief_sw		 bit (1);		/* (Input) on to suppress new search list warning message */
	declare sl_info_ptr		 pointer;		/* (Updated) pointer to sl_info with the new search list */
	declare code		 fixed binary (35); /* (Output) standard status code */

	call search_paths_$set (sl_name, null, sl_info_ptr, code);
	if code ^= 0
	then do;
		if code = error_table_$action_not_performed
		then begin;
			declare pathx		 fixed binary;

			do pathx = 1 to sl_info_ptr -> sl_info.num_paths;
			     if sl_info_ptr -> sl_info.paths (pathx).code ^= 0
			     then call sys_err_ (sl_info_ptr -> sl_info.paths (pathx).code, command, "^a",
				     sl_info_ptr -> sl_info.paths (pathx).pathname);
			end;
		     end;

		else if code ^= error_table_$new_search_list | ^brief_sw
		then call sys_err_ (code, command, "^a", sl_name);
	     end;

	if sl_info_ptr ^= null
	then do;
		free sl_info_ptr -> sl_info;
		sl_info_ptr = null;
	     end;
     end set_the_search_paths_of_a_search_list;

/* Warn the user if directories being added to the search list don't exist */

check_paths_for_warnings:
     procedure (sl_name, sl_info_ptr);

	declare sl_name		 char (*);	/* (Input) search list name */
	declare sl_info_ptr		 pointer;		/* (Output) pointer to allocate sl_info in */

	declare code		 fixed binary (35);

	call search_paths_$get (sl_name, "1"b, "", null, get_system_free_area_ (), sl_info_version_1, sl_info_ptr, code);
	if sl_info_ptr ^= null
	then begin;
		declare argx		 fixed binary;
		declare pathx		 fixed binary;

		do argx = args.arg (args.first_arg).next_arg repeat args.arg (argx).next_arg while (argx ^= 0);
		     pathx = args.arg (argx).pathx;
		     if pathx > 0
		     then if sl_info_ptr -> sl_info.paths (pathx).type = ABSOLUTE_PATH
			     | sl_info_ptr -> sl_info.paths (pathx).type = UNEXPANDED_PATH
			then begin;
				declare bit_count		 fixed binary (24);
				declare dir_name		 char (168);
				declare entry_type		 fixed binary (2);
				declare entryname		 char (32);

				call expand_pathname_ (sl_info_ptr -> sl_info.paths (pathx).pathname, dir_name,
				     entryname, code);
				call hcs_$status_minf (dir_name, entryname, 0, entry_type, bit_count, code);
				if code ^= 0
				then call sys_err_ (code, command, "Warning. ^a",
					sl_info_ptr -> sl_info.paths (pathx).pathname);
			     end;
		end;

		free sl_info_ptr -> sl_info;
		sl_info_ptr = null;
	     end;
     end check_paths_for_warnings;

/* Output the contents of a search list */

print_search_list:
     procedure (sl_name, print_name_sw, expand_sw, sl_info_ptr);

	declare sl_name		 char (*);	/* (Input) search list to print */
	declare print_name_sw	 bit (1);		/* (Input) on to print the search list name */
	declare expand_sw		 bit (1);		/* (Input) on to expand keywords */
	declare sl_info_ptr		 pointer;		/* (Output) pointer to allocate sl_info in */

	declare code		 fixed binary (35);
	declare pathx		 fixed binary;

	if expand_sw
	then do;
		sl_control_s.af_pathname = "1"b;
		sl_control_s.pad1 = "0"b;
		sl_control_s.key_ref_dir = "0"b;
		sl_control_s.key_work_dir = "1"b;
		sl_control_s.key_proc_dir = "1"b;
		sl_control_s.key_home_dir = "1"b;
		sl_control_s.pad2 = ""b;
	     end;
	else sl_control = ""b;
	call search_paths_$get (sl_name, sl_control, "", null, get_system_free_area_ (), sl_info_version_1, sl_info_ptr,
	     code);
	if code = 0
	then do;
		if print_name_sw
		then call output_one_line (sl_name);
		do pathx = 1 to sl_info_ptr -> sl_info.num_paths;
		     call output_one_line (HT || sl_info_ptr -> sl_info.paths (pathx).pathname);
		end;
		call output_one_line ("");
	     end;
	else call sys_err_ (code, command, "^a", sl_name);

	if sl_info_ptr ^= null
	then do;
		free sl_info_ptr -> sl_info;
		sl_info_ptr = null;
	     end;
     end print_search_list;

/*	Output a pathname.

	Handle the Root correctly.
*/
output_pathname:
     procedure (dir_name, entryname);

	declare dir_name		 char (*);	/* (Input) directory name */
	declare entryname		 char (*);	/* (Input) entry in the directory */

	declare length		 fixed binary (21);
	declare pathname		 char (168);

	call ioa_$rsnnl ("^a^[>^]^a", pathname, length, dir_name, dir_name ^= ">", entryname);
	call output_one_line (pathname);
     end output_pathname;

/*	Output a line.

	The line is printed if this is a command, and appended to the
	active function return string, if this is an active function.
*/
output_one_line:
     procedure (line);

	declare line		 char (*);	/* (Input) the line to output */
	declare requote_string_	 entry (char (*)) returns (char (*));

	if af_sw
	then do;
		if ltrim (rtrim (line, HT || SP), HT || SP) = ""
		then return;

		if af_return_string = ""
		then af_return_string =
		     requote_string_ (ltrim (rtrim (line, HT || SP), HT || SP));
		else af_return_string = af_return_string || SP ||
		     requote_string_ (ltrim (rtrim (line, HT || SP), HT || SP));
	     end;
	else call ioa_ ("^a", line);
     end output_one_line;

/*	Print the usage error message.

	Different messages are printed for commands and active functions.
*/
usage_err_:
     procedure;

	if af_sw
	then call active_fnc_err_$af_suppress_name (0, command, "Usage: [^a ^a]", command, af_usage);
	else call com_err_$suppress_name (0, command, "Usage: ^a ^a", command, usage);
     end usage_err_;

cleanup_:
     procedure;

	if args_ptr ^= null
	then do;
		free args;
		args_ptr = null;
	     end;
	if cleanup_sl_info_ptr ^= null
	then do;
		free cleanup_sl_info_ptr -> sl_info;
		cleanup_sl_info_ptr = null;
	     end;
	if cleanup_new_sl_info_ptr ^= null
	then do;
		free cleanup_new_sl_info_ptr -> sl_info;
		cleanup_new_sl_info_ptr = null;
	     end;
	if cleanup_sl_list_ptr ^= null
	then begin;
		declare next_sl_list_ptr	 pointer;

		do while (cleanup_sl_list_ptr ^= null);
		     next_sl_list_ptr = cleanup_sl_list_ptr -> sl_list.link;
		     free cleanup_sl_list_ptr -> sl_list;
		     cleanup_sl_list_ptr = next_sl_list_ptr;
		end;
	     end;
     end cleanup_;

     end set_search_paths;
 



		    set_translator_search_rules.pl1 02/16/88  1442.8rew 02/16/88  1442.0      104616


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


/****^  HISTORY COMMENTS:
  1) change(88-02-16,Lippard), approve(88-02-16,MCR7822),
     audit(88-02-16,Blair):
     Modified to use "uid" instead of "pad2".
                                                   END HISTORY COMMENTS */

/*	Translator Search Rules Commands
	This is just a write-around to search_paths_ and the "translator" search list.

	Rewritten 6-Nov-78 by Monte Davidoff.
*/
set_translator_search_rules:
stsr:
     procedure;

/* automatic */

	declare command		 char (32);	/* what command this is */
	declare sl_info_ptr		 pointer;

/* builtin */

	declare null		 builtin;
	declare search		 builtin;
	declare substr		 builtin;

/* condition */

	declare cleanup		 condition;

/* internal static */

	declare LIST		 char (10) internal static options (constant) initial ("translator");

/* external static */

	declare error_table_$action_not_performed
				 fixed binary (35) external static;
	declare error_table_$badopt	 fixed binary (35) external static;

/* external entry */

	declare absolute_pathname_	 entry (char (*), char (*), fixed binary (35));
	declare com_err_		 entry options (variable);
	declare cu_$arg_count	 entry (fixed binary);
	declare cu_$arg_ptr		 entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed binary (35));
	declare get_system_free_area_	 entry () returns (pointer);
	declare hcs_$status_minf	 entry (char (*), char (*), fixed binary (1), fixed binary (2), fixed binary (24),
				 fixed binary (35));
	declare ioa_		 entry options (variable);
	declare search_paths_$get	 entry (char (*), bit (36), char (*), pointer, pointer, fixed binary, pointer,
				 fixed binary (35));
	declare search_paths_$set	 entry (char (*), pointer, pointer, fixed binary (35));

%include sl_info;

/* set_translator_search_rules */

	command = "set_translator_search_rules";
	sl_info_ptr = null;
	on cleanup
	     call cleanup_;
	call set_translator_search_rules_;
	call cleanup_;
	return;

print_translator_search_rules:
ptsr:
	entry;

	command = "print_translator_search_rules";
	sl_info_ptr = null;
	on cleanup
	     call cleanup_;
	begin;
	     declare code		      fixed binary (35);
	     declare pathx		      fixed binary;

	     call search_paths_$get (LIST, ""b, "", null, get_system_free_area_ (), sl_info_version_1, sl_info_ptr, code);
	     if code = 0
	     then do pathx = 1 to sl_info_ptr -> sl_info.num_paths;
		     call ioa_ ("^a", sl_info_ptr -> sl_info.paths (pathx).pathname);
		end;
	     else call com_err_ (code, command, LIST);
	end;
	call cleanup_;
	return;

set_translator_search_rules_:
     procedure;

	declare arg_count		 fixed binary;
	declare arg_length		 fixed binary (21);
	declare arg_ptr		 pointer;
	declare argx		 fixed binary;
	declare code		 fixed binary (35);
	declare default_sw		 bit (1);
	declare pathx		 fixed binary;

	declare arg_string		 char (arg_length) based (arg_ptr);

	call cu_$arg_count (arg_count);
	default_sw = "0"b;
	do argx = 1 to arg_count while ( ^default_sw);
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;
	     if arg_string = "-default"
	     then default_sw = "1"b;
	end;

	if default_sw
	then call create_sl_info (arg_count + 2, sl_info_ptr);
	else call create_sl_info (arg_count, sl_info_ptr);

	pathx = 0;
	do argx = 1 to arg_count;
	     pathx = pathx + 1;
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;
	     if arg_string = "-default"
	     then do;
		     sl_info_ptr -> sl_info.paths (pathx).type = WORKING_DIR;
		     sl_info_ptr -> sl_info.paths (pathx).pathname = "-working_dir";
		     call check_for_duplicates (sl_info_ptr, pathx, code);
		     if code ^= 0
		     then return;
		     pathx = pathx + 1;

		     sl_info_ptr -> sl_info.paths (pathx).type = UNEXPANDED_PATH;
		     sl_info_ptr -> sl_info.paths (pathx).pathname = ">udd>[user project]>include";
		     call check_for_duplicates (sl_info_ptr, pathx, code);
		     if code ^= 0
		     then return;
		     pathx = pathx + 1;

		     sl_info_ptr -> sl_info.paths (pathx).type = ABSOLUTE_PATH;
		     sl_info_ptr -> sl_info.paths (pathx).pathname = ">ldd>include";
		     call check_for_duplicates (sl_info_ptr, pathx, code);
		     if code ^= 0
		     then return;
		end;
	     else do;
		     call get_path_type (arg_string, sl_info_ptr -> sl_info.paths (pathx).type,
			sl_info_ptr -> sl_info.paths (pathx).pathname, code);
		     if code ^= 0
		     then return;

		     call check_for_duplicates (sl_info_ptr, pathx, code);
		     if code ^= 0
		     then return;
		end;
	end;

	call set_the_search_paths_of_a_search_list (sl_info_ptr, code);
	if code ^= 0
	then return;

	call check_paths_for_warnings (sl_info_ptr);
     end set_translator_search_rules_;

/* Allocate and initialize an sl_info structure */

create_sl_info:
     procedure (path_count, sl_info_ptr);

	declare path_count		 fixed binary;	/* (Input) number of search paths in sl_info */
	declare sl_info_ptr		 pointer;		/* (Output) pointer to sl_info */

	sl_info_ptr = null;
	if path_count ^= 0
	then do;
		sl_info_num_paths = path_count;
		allocate sl_info set (sl_info_ptr);

		sl_info_ptr -> sl_info.version = sl_info_version_1;
		sl_info_ptr -> sl_info.change_index_p = null;
		sl_info_ptr -> sl_info.change_index = 0;
		sl_info_ptr -> sl_info.pad1 (*) = ""b;
		sl_info_ptr -> sl_info.paths (*).code = 0;
		sl_info_ptr -> sl_info.paths (*).uid = ""b;
	     end;
     end create_sl_info;

/* Convert an argument into a search path type and pathname */

get_path_type:
     procedure (search_path, type, pathname, code);

	declare search_path		 char (*);	/* (Input) search path to convert */
	declare type		 fixed binary;	/* (Output) search path type */
	declare pathname		 char (*);	/* (Output) search pathname */
	declare code		 fixed binary (35); /* (Output) standard status code */

	type = 0;
	pathname = search_path;
	code = 0;
	if is_control_arg (search_path)
	then if search_path = "-home_dir"
	     then type = HOME_DIR;
	     else if search_path = "-referencing_dir"
	     then type = REFERENCING_DIR;
	     else if search_path = "-working_dir" | search_path = "-wd"
	     then do;
		     type = WORKING_DIR;
		     pathname = "-working_dir";
		end;
	     else do;
		     code = error_table_$badopt;
		     call com_err_ (code, command, "^a", search_path);
		end;
	else do;
		if search (search_path, "[]") = 0
		then type = ABSOLUTE_PATH;
		else type = UNEXPANDED_PATH;

		call absolute_pathname_ (search_path, pathname, code);
		if code ^= 0
		then call com_err_ (code, command, "^a", search_path);
	     end;
     end get_path_type;

/* Check for a duplicate entry in sl_info */

check_for_duplicates:
     procedure (sl_info_ptr, pathx, code);

	declare sl_info_ptr		 pointer;		/* (Input) pointer to sl_info */
	declare pathx		 fixed binary;	/* (Input) last used entry in sl_info */
	declare code		 fixed binary (35); /* (Output) non-standard status code */

	code = 0;
	if path_index (sl_info_ptr, sl_info_ptr -> sl_info.paths (pathx).pathname) >= pathx
	then return;

	call com_err_ (0, command, "Search path specified twice. ^a", sl_info_ptr -> sl_info.paths (pathx).pathname);
	code = 1;
     end check_for_duplicates;

/*	Check if an argument is a control-argument.

	A control-argument is defined for this procedure to be anything starting with a hyphen.
*/
is_control_arg:
     procedure (arg) returns (bit (1));

	declare arg		 char (*);	/* (Input) a command argument */

	if arg = ""
	then return ("0"b);
	else return (substr (arg, 1, 1) = "-");
     end is_control_arg;

/* Find the index of a search path in sl_info */

path_index:
     procedure (sl_info_ptr, pathname) returns (fixed binary);

	declare sl_info_ptr		 pointer;		/* (Input) pointer to sl_info */
	declare pathname		 char (*);	/* (Input) pathname to look for */

	declare pathx		 fixed binary;

	do pathx = 1 to sl_info_ptr -> sl_info.num_paths while (pathname ^= sl_info_ptr -> sl_info.paths (pathx).pathname);
	end;
	if pathx > sl_info_ptr -> sl_info.num_paths
	then return (0);
	else return (pathx);
     end path_index;

/*	Change a search list.

	Appropriate error and warning messages are printed.
*/
set_the_search_paths_of_a_search_list:
     procedure (sl_info_ptr, code);

	declare sl_info_ptr		 pointer;		/* (Updated) pointer to sl_info with the new search list */
	declare code		 fixed binary (35); /* (Output) standard status code */

	call search_paths_$set (LIST, null, sl_info_ptr, code);
	if code ^= 0
	then do;
		if code = error_table_$action_not_performed
		then do;				/* change to "begin;" when compiler bug 1789 is fixed in MR7.0 */
			declare pathx		 fixed binary;

			do pathx = 1 to sl_info_ptr -> sl_info.num_paths;
			     if sl_info_ptr -> sl_info.paths (pathx).code ^= 0
			     then call com_err_ (sl_info_ptr -> sl_info.paths (pathx).code, command, "^a",
				     sl_info_ptr -> sl_info.paths (pathx).pathname);
			end;
		     end;

		else call com_err_ (code, command, LIST);
	     end;

	if sl_info_ptr ^= null
	then do;
		free sl_info_ptr -> sl_info;
		sl_info_ptr = null;
	     end;
     end set_the_search_paths_of_a_search_list;

/* Warn the user if directories being added to the search list don't exist */

check_paths_for_warnings:
     procedure (sl_info_ptr);

	declare sl_info_ptr		 pointer;		/* (Output) pointer to allocate sl_info in */

	declare code		 fixed binary (35);

	call search_paths_$get (LIST, "1"b, "", null, get_system_free_area_ (), sl_info_version_1, sl_info_ptr, code);
	if sl_info_ptr ^= null
	then do;					/* change to "begin;" when compiler bug 1789 is fixed in MR7.0 */
		declare pathx		 fixed binary;

		do pathx = 1 to sl_info_ptr -> sl_info.num_paths;
		     if sl_info_ptr -> sl_info.paths (pathx).type = ABSOLUTE_PATH
			| sl_info_ptr -> sl_info.paths (pathx).type = UNEXPANDED_PATH
		     then do;			/* change to "begin;" when compiler bug 1789 is fixed in MR7.0 */
			     declare bit_count	      fixed binary (24);
			     declare dir_name	      char (168);
			     declare entry_type	      fixed binary (2);
			     declare entryname	      char (32);

			     call expand_pathname_ (sl_info_ptr -> sl_info.paths (pathx).pathname, dir_name, entryname,
				code);
			     call hcs_$status_minf (dir_name, entryname, 0, entry_type, bit_count, code);
			     if code ^= 0
			     then call com_err_ (code, command, "Warning. ^a",
				     sl_info_ptr -> sl_info.paths (pathx).pathname);
			end;
		end;

		free sl_info_ptr -> sl_info;
		sl_info_ptr = null;
	     end;
     end check_paths_for_warnings;

cleanup_:
     procedure;

	if sl_info_ptr ^= null
	then do;
		free sl_info_ptr -> sl_info;
		sl_info_ptr = null;
	     end;
     end cleanup_;

     end set_translator_search_rules;


		    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