



		    check_info_segs.pl1             02/16/88  1500.9r w 02/16/88  1411.8      245331



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


/* Check directories for new info segments.

   This command remarks about any file in a directory in the "info_segments"
   search list or in user-supplied directories with the dtem greater than the
   last_time_looked.  The last_time_looked is kept in the user's default
   value segment.

   The active function returns the selected info seg names separated by spaces

   Rewritten 24-Oct-78 by Monte Davidoff.
   Modified February 1979 by Michael R. Jordan for unsigned changes to star_structures.incl.pl1. */
/* No_s bug obtaining dtcm's fixed 12/12/79 S. Herbst */
/* Implement [cis], -absolute_pathname, and fix bugs 06/11/80 S. Herbst */
/* Implement -time_checked Sept 1980  Marshall Presser */
/* Implement discarding of duplicates when same segment identified twice 81/02/11 Paul Benjamin */
/* Modified: 14 January 1982 by G. Palter to convert to using the default value segment */
/* Modified 08/08/83 by Jim Lippard to improve performance, make -brief without
   -call useful, and to not talk about zero length segs as having changed */
/* Modified 05/25/84 by Jim Lippard to fix bug in link checking and to make
   check_links just free star structures on cleanup rather than returning
   (which could result in the message "No changed info segments" being
   printed) */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */

check_info_segs:
cis:
     procedure () options (variable);

dcl  arg_count fixed binary;
dcl  arg_length fixed binary (21);
dcl  arg_ptr pointer;
dcl  argx fixed binary;
dcl  call_str_length fixed binary (21);
dcl  call_str_ptr pointer;
dcl  change_sw bit (1);
dcl  code fixed binary (35);
dcl  complain entry variable options (variable);
dcl  dir_name char (168);
dcl  duplicate bit (1);
dcl  entryname char (32);
dcl  last_time_looked fixed binary (71);
dcl  link_array_entry_length fixed binary;
dcl  link_array_ptr ptr;
dcl  return_len fixed binary (21);
dcl  return_ptr pointer;
dcl  target_dname char (168);
dcl  target_ename char (32);
dcl  temp_segment_ptr (2) ptr;
dcl  uid_list_count fixed binary;
dcl  uid_list_index fixed binary;
dcl  uid_list_ptr ptr;
dcl  1 link_array aligned based (link_array_ptr),
       2 n_links fixed bin (21),
       2 links (0 refer (link_array.n_links)),
         3 check_dname char (168) aligned,
         3 print_dname char (168) aligned,
         3 check_ename char (32) aligned,
         3 print_ename char (32) aligned,
         3 check bit (1) aligned,
         3 n_passes fixed bin;
dcl  1 sw,
       2 absp bit (1),
       2 af bit (1),
       2 brief bit (1),
       2 call bit (1),
       2 long bit (1),
       2 pathname bit (1),
       2 update bit (1),
       2 check_time bit (1);
dcl  time_checked char (24);
dcl  type fixed binary (2);
dcl  update_time fixed binary (71);

dcl  arg_string char (arg_length) based (arg_ptr);
dcl  return_arg char (return_len) varying based (return_ptr);
dcl  uid_list (uid_list_count) bit (36) based (uid_list_ptr) aligned;

dcl  (addr, binary, clock, currentsize, divide, empty, hbound, index, length, null, rtrim, substr, wordno) builtin;

dcl  (cleanup, program_interrupt) condition;

dcl  DEFAULT_VALUE_SEGMENT pointer static options (constant) initial (null ());
dcl  PERMANENT_VALUE bit (36) aligned static options (constant) initial ("01"b);
dcl  CIS_VALUE_NAME character (17) static options (constant) initial ("check_info_segs._");
dcl  TERMINATE_FILE bit (4) internal static options (constant) initial ("0010"b);
dcl  NO_CHASE fixed bin (1) int static options (constant) init (0);
dcl  TRUE bit (1) internal static options (constant) initial ("1"b);
dcl  FALSE bit (1) internal static options (constant) initial ("0"b);

dcl  command char (32) internal static options (constant) initial ("check_info_segs");

dcl  error_table_$badopt fixed binary (35) external static;
dcl  error_table_$no_dir fixed binary (35) external static;
dcl  error_table_$noentry fixed binary (35) external static;
dcl  error_table_$nomatch fixed binary (35) external static;
dcl  error_table_$not_act_fnc fixed binary (35) external static;
dcl  error_table_$oldnamerr fixed binary (35) external static;

dcl  active_fnc_err_ entry () options (variable);
dcl  active_fnc_err_$suppress_name entry () options (variable);
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  convert_date_to_binary_ entry (char (*), fixed binary (71), fixed binary (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  date_time_ entry (fixed binary (71), char (*));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$star_dir_list_
	entry (char (*), char (*), fixed binary (3), pointer, fixed binary, fixed binary, pointer, pointer,
	fixed binary (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  search_paths_$get entry (char (*), bit (36), char (*), pointer, pointer, fixed binary, pointer, fixed binary (35));
dcl  sort_items_indirect_$char entry (ptr, ptr, fixed bin (21));
dcl  sys_info$maxlinks ext fixed bin;
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  user_info_ entry (char (*));
dcl  user_info_$homedir entry (char (*));
dcl  value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35));
dcl  value_$get_path entry (char (*), fixed bin (35));
dcl  value_$set_data
	entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35));
dcl  value_$set_path entry (char (*), bit (1), fixed bin (35));

/**/

	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     sw.af = FALSE;
	     complain = com_err_;
	end;
	else do;
	     sw.af = TRUE;
	     complain = active_fnc_err_;
	     return_arg = "";
	end;

	link_array_ptr = null ();
	sl_info_p = null ();
	star_entry_ptr = null ();
	star_names_ptr = null ();
	uid_list_ptr = null ();

	on cleanup call cleanup_;

	last_time_looked = 0;			/* none yet supplied */
	sw.absp = FALSE;
	sw.brief = FALSE;
	sw.call = FALSE;
	sw.long = FALSE;
	sw.pathname = FALSE;
	sw.check_time = FALSE;
	sw.update = TRUE;
	change_sw = FALSE;
	call_str_length = 0;


	do argx = 1 to arg_count;

	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0 then do;
		call complain (code, command, "Fetching argument #^d.", argx);
		return;
	     end;

	     if arg_string = "-absolute_pathname" | arg_string = "-absp" then sw.absp = TRUE;

	     else if arg_string = "-brief" | arg_string = "-bf" then
		if sw.af then
		     go to BAD_OPT;
		else sw.brief = TRUE;

	     else if arg_string = "-call" then do;
		if sw.af then go to BAD_OPT;
		sw.call = TRUE;
		argx = argx + 1;
		call cu_$arg_ptr (argx, call_str_ptr, call_str_length, code);
		if code ^= 0 then do;
		     call complain (code, command, "Missing command line after -call.");
		     return;
		end;
	     end;

	     else if arg_string = "-date" | arg_string = "-dt" then do;
		sw.update = FALSE;
		argx = argx + 1;
		call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
		if code ^= 0 then do;
		     call complain (code, command, "Missing date after -date.");
		     return;
		end;

		call convert_date_to_binary_ (arg_string, last_time_looked, code);
		if code ^= 0 then do;
		     call complain (code, command, "^a", arg_string);
		     return;
		end;

		if last_time_looked > clock () then do;
		     call complain (0, command, "The date/time is in the future. ^a", arg_string);
		     return;
		end;
	     end;

	     else if arg_string = "-long" | arg_string = "-lg" then
		if sw.af then
		     go to BAD_OPT;
		else sw.long = TRUE;

	     else if arg_string = "-no_update" | arg_string = "-nud" then sw.update = FALSE;

	     else if arg_string = "-time_checked" | arg_string = "-tmck" then sw.check_time = TRUE;

	     else if arg_string = "-pathname" | arg_string = "-pn" then do;
		sw.pathname = TRUE;
		argx = argx + 1;
		call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
		if code ^= 0 then do;
		     call complain (code, command, "Missing star pathname after -pathname.");
		     return;
		end;

		call expand_pathname_ (arg_string, dir_name, entryname, code);
		if code ^= 0 then do;
		     call complain (code, command, "^a", arg_string);
		     return;
		end;
	     end;

	     else if is_control_arg (arg_string) then do;
BAD_OPT:
		call complain (error_table_$badopt, command, "^a", arg_string);
		return;
	     end;

	     else do;
		if sw.af then
		     call active_fnc_err_$suppress_name (0, command, "Usage:  [^a {-control_args}]", command);
		else call com_err_$suppress_name (0, command, "Usage:  ^a {-control_args}", command);
		return;
	     end;
	end;

	if sw.af & sw.check_time then
	     if arg_count > 1 then do;
		call complain (0, command, "The -time_checked control argument is incompatible with any others.");
		return;
	     end;

/**/

	if last_time_looked = 0 then			/* if user didn't supply a date/time on the command line */
	     call get_time (last_time_looked);

	if sw.check_time then do;
	     call date_time_ (last_time_looked, time_checked);
	     if sw.af then
		if last_time_looked = 0 then do;
		     call complain (0, command,
			"There is no initial date in the user profile on when info segments were last checked.");
		     return;
		end;
		else do;
		     return_arg = requote_string_ (time_checked);
		     return;
		end;

	     else do;
		if last_time_looked = 0 then do;
		     call complain (0, command,
			"There is no initial date in the user profile on when info segments were last checked.");
		     return;
		end;
		else call ioa_ ("Info segments were last checked on ^a", time_checked);
		if arg_count = 1 then return;
	     end;
	end;

	update_time = clock ();			/* avoids missing segments if -call is used */

	if sw.update & last_time_looked = 0 then do;
	     if ^sw.af then
		call ioa_ ("^a: ^a", command,
		     "Initializing date stored in default value segment on which info segments were last checked.");
	     call put_time (update_time);
	     return;
	end;

	call get_temp_segments_ (command, temp_segment_ptr, code);
	if code ^= 0 then do;
	     call complain (code, command);
	     call cleanup_;
	     return;
	end;

	uid_list_ptr = temp_segment_ptr (1);
	link_array_ptr = temp_segment_ptr (2);

	uid_list_count = 0;
	link_array.n_links = 0;

	if sw.pathname then do;
	     do argx = 1 to arg_count;

		call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
		if code = 0 then
		     if arg_string = "-pathname" | arg_string = "-pn" then do;
			argx = argx + 1;
			call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
			call expand_pathname_ (arg_string, dir_name, entryname, code);
			call check_directory (dir_name, entryname);
		     end;
		     else if arg_string = "-call" | arg_string = "-date" | arg_string = "-dt" then argx = argx + 1;
	     end;
	end;
	else do;
	     call search_paths_$get ("info_segments", sl_control_default, "", null (), get_system_free_area_ (),
		sl_info_version_1, sl_info_p, code);
	     if code ^= 0 then do;
		call complain (code, command, "info_segments");
		call cleanup_;
		return;
	     end;

	     do argx = 1 to sl_info.num_paths;
		call check_directory (sl_info.paths (argx).pathname, "**.info");
	     end;
	end;

	call check_links ();

	if ^change_sw & ^sw.brief & ^sw.af then call ioa_ ("No changed info segments.");

	if sw.update then call put_time (update_time);

RETURN_FROM_CHECK_INFO_SEGS:
	call cleanup_;

	return;

/**/

/* Check a directory for changed info segments */

check_directory:
     procedure (dir_name, star_name);

dcl  dir_name char (*);				/* (Input) directory to search */
dcl  star_name char (*);				/* (Input) star name of segments to check */

dcl  entryx fixed binary;


	on program_interrupt goto done_checking_dir;

	star_select_sw = star_ALL_ENTRIES_WITH_LINK_PATHS;
	call hcs_$star_dir_list_ (dir_name, star_name, star_select_sw, get_system_free_area_ (), star_branch_count,
	     star_link_count, star_list_branch_ptr, star_list_names_ptr, code);

	if code ^= 0 & code ^= error_table_$nomatch & code ^= error_table_$no_dir & ^sw.brief then
	     call complain (code, command, "^a", pathname_ (dir_name, star_name));
						/* in particular, >doc>iml_info may be empty or non-existent */

	else do entryx = 1 to hbound (star_links, 1);
	     if star_links (entryx).type = star_SEGMENT then
		call check_segment (dir_name, star_list_names (star_dir_list_branch (entryx).nindex), dir_name,
		     star_list_names (star_dir_list_branch (entryx).nindex), star_dir_list_branch (entryx).dtem);
	     else if star_links (entryx).type = star_LINK then do;
		if link_array.n_links > 1 then do;
		     if link_array.n_links = 2 then
			link_array_entry_length =
			     wordno (addr (link_array.links (2))) - wordno (addr (link_array.links (1)));
		     if currentsize (link_array) + link_array_entry_length > sys_info$max_seg_size then do;
			call complain ((0), command, "Too many links.");
			call cleanup_;
			return;
		     end;
		end;
		link_array.n_links = link_array.n_links + 1;
		star_linkx = entryx;
		call expand_pathname_ (star_link_pathname, target_dname, target_ename, (0));
		link_array.print_dname (link_array.n_links) = dir_name;
		link_array.print_ename (link_array.n_links) = star_list_names (star_dir_list_branch (entryx).nindex);
		link_array.check_dname (link_array.n_links) = target_dname;
		link_array.check_ename (link_array.n_links) = target_ename;
		link_array.check (link_array.n_links) = TRUE;
		link_array.n_passes (link_array.n_links) = 1;
	     end;
	end;

done_checking_dir:
	if star_list_names_ptr ^= null () then do;
	     free star_list_names;
	     star_list_names_ptr = null ();
	end;
	if star_list_branch_ptr ^= null () then do;
	     free star_links;
	     star_list_branch_ptr = null ();
	end;

	return;
     end check_directory;

/**/

/* Check if a segment has been modified */

check_segment:
     procedure (dir_name, entryname, print_dn, print_en, dtm);

dcl  dir_name char (*);				/* (Input) directory containing the segment */
dcl  entryname char (*);				/* (Input) entryname of the segment */
dcl  print_dn char (*);				/* (Input) directory name of link if link, or seg */
dcl  print_en char (*);				/* (Input) entryname of link if link, or seg */
dcl  dtm bit (36);					/* (Input) date-time modified */

dcl  name char (168);				/* name as printed */
dcl  pathname char (168);				/* absolute pathname */
dcl  date_time char (16);
dcl  modified_time fixed binary (71);

dcl  call_str char (call_str_length) based (call_str_ptr);
dcl  command_line char (call_str_length + 169) aligned;

dcl  1 branch like status_branch aligned;

	modified_time = binary (dtm || (16)"0"b, 71);
	if modified_time >= last_time_looked then do;

	     call hcs_$status_long (dir_name, entryname, NO_CHASE, addr (branch), null (), code);

	     modified_time = binary (dtcm || (16)"0"b, 71);
						/* make sure by checking dtcm */
	     if modified_time >= last_time_looked then do;

		duplicate = FALSE;

		do uid_list_index = 1 to uid_list_count while (^duplicate);
		     if uid_list (uid_list_index) = branch.uid then do;
			duplicate = TRUE;
			uid_list_index = uid_list_count;
		     end;
		end;
		if duplicate = FALSE then do;
		     uid_list_count = uid_list_count + 1;
		     uid_list (uid_list_count) = branch.uid;
		     if branch.bit_count ^= 0 then do;
			change_sw = TRUE;		/* something has actually changed */

			if sw.absp then
			     name = pathname_ (print_dn, print_en);
						/* return absolute pathnames */
			else name = print_en;
			if sw.af then do;
			     if return_arg ^= "" then return_arg = return_arg || " ";
			     if index (rtrim (name), " ") ^= 0 then
				return_arg = return_arg || requote_string_ (rtrim (name));
			     else return_arg = return_arg || rtrim (name);
			end;
			else if sw.long then do;
			     call date_time_ (modified_time, date_time);
			     call ioa_ ("^a ^a", date_time, name);
			end;
			else if ^sw.brief & ^sw.call then call ioa_ ("^a", name);
			if sw.call then do;
			     command_line = call_str || " " || pathname_ (print_dn, print_en);
			     call cu_$cp (addr (command_line), length (rtrim (command_line)), code);
			end;
		     end;
		end;
	     end;
	end;
	return;

     end check_segment;

/**/

/* Check the link array */

check_links:
     procedure;
dcl  (idx, jdx, kdx) fixed binary;
dcl  array_idx fixed binary (21);
dcl  num_links fixed binary (21);
dcl  found bit (1) aligned;
dcl  same_directory bit (1) aligned;
dcl  star_area_ptr ptr;
dcl  star_name char (32);
dcl  1 v aligned,
       2 n_items fixed bin (18),
       2 vector (link_array.n_links) ptr unaligned;
dcl  1 i aligned,
       2 n fixed bin (18),
       2 array (link_array.n_links) fixed bin (18);

	i.n = link_array.n_links;
	v.n_items = link_array.n_links;
	num_links = link_array.n_links;

	star_select_sw = star_ALL_ENTRIES_WITH_LINK_PATHS;
	star_area_ptr = get_system_free_area_ ();

	do idx = 1 to link_array.n_links;
	     v.vector (idx) = addr (link_array.check_dname (idx));
	end;

	on cleanup call free_star_structures;

	do while (num_links > 0);

	     call sort_items_indirect_$char (addr (v), addr (i), length (link_array.check_dname (1)));

	     same_directory = FALSE;
	     do idx = 1 to link_array.n_links;
		array_idx = i.array (idx);
		if link_array.check (array_idx) then do;
		     if ^same_directory then do;
			if idx ^= link_array.n_links then
			     if link_array.check_dname (array_idx) = link_array.check_dname (i.array (idx + 1)) then
				star_name = "**.info";
			     else star_name = link_array.check_ename (array_idx);
			else star_name = link_array.check_ename (array_idx);
			call free_star_structures (); /* in case it's left from last time through */
			call hcs_$star_dir_list_ ((link_array.check_dname (array_idx)), star_name, star_select_sw,
			     star_area_ptr, star_branch_count, star_link_count, star_list_branch_ptr,
			     star_list_names_ptr, code);
			if code ^= 0 then call check_for_noninfo ();
		     end;				/* getting star info */
		     if link_array.check (array_idx) then do;
			found = FALSE;
			do jdx = 1 to hbound (star_links, 1) while (^found);
			     do kdx = 1 to star_dir_list_branch (jdx).nnames while (^found);
				if link_array.check_ename (array_idx)
				     = star_list_names (star_dir_list_branch (jdx).nindex + (kdx - 1)) then do;
				     found = TRUE;
				     if star_links (jdx).type = star_SEGMENT then do;
					call check_segment ((link_array.check_dname (array_idx)),
					     (link_array.check_ename (array_idx)),
					     (link_array.print_dname (array_idx)),
					     (link_array.print_ename (array_idx)),
					     star_dir_list_branch (jdx).dtem);
					link_array.check (array_idx) = FALSE;
					num_links = num_links - 1;
				     end;		/* segment */
				     else if star_links (jdx).type = star_LINK then do;
					if link_array.n_passes (array_idx) >= sys_info$maxlinks then do;
					     link_array.check (array_idx) = FALSE;
					     num_links = num_links - 1;
					end;	/* too many links */
					else do;
					     star_linkx = jdx;
					     call expand_pathname_ (star_link_pathname, target_dname,
						target_ename, code);
					     if code ^= 0 then do;
						link_array.check (array_idx) = FALSE;
						num_links = num_links - 1;
					     end;
					     else do;
						link_array.check_dname (array_idx) = target_dname;
						link_array.check_ename (array_idx) = target_ename;
						link_array.n_passes (array_idx) =
						     link_array.n_passes (array_idx) + 1;
					     end; /* valid target pathname */
					end;	/* continue chasing link */
				     end;		/* link */
				     else found = FALSE;
				end;		/* match found */
			     end;			/* kdx loop */
			end;			/* jdx loop */
			if ^found then call check_for_noninfo ();
		     end;				/* code = 0 from hcs_ */
		     if idx ^= link_array.n_links then
			if link_array.check_dname (array_idx) = link_array.check_dname (i.array (idx + 1)) then
			     same_directory = TRUE;
			else same_directory = FALSE;
		     else ;
		end;				/* checking */
	     end;					/* idx loop */
	end;					/* while num_links > 0 */
done_checking_links:
	call free_star_structures ();
	return;

free_star_structures:
	procedure;
	     if star_list_names_ptr ^= null () then do;
		free star_list_names;
		star_list_names_ptr = null ();
	     end;
	     if star_list_branch_ptr ^= null () then do;
		free star_links;
		star_list_branch_ptr = null ();
	     end;
	end free_star_structures;

check_for_noninfo:
	procedure ();
	     if substr (link_array.check_ename (array_idx), length (rtrim (link_array.check_ename (array_idx))) - 4, 5)
		^= ".info" then do;
		call hcs_$status_minf ((link_array.check_dname (array_idx)), (link_array.check_ename (array_idx)),
		     NO_CHASE, type, (0), code);
		if code = 0 then do;
		     if type = Link then
			call hcs_$get_link_target ((link_array.check_dname (array_idx)),
			     (link_array.check_ename (array_idx)), target_dname, target_ename, code);
		     else do;
			target_dname = link_array.check_dname (array_idx);
			target_ename = link_array.check_ename (array_idx);
		     end;
		     if code = 0 then
			call check_segment (target_dname, target_ename, (link_array.print_dname (array_idx)),
			     (link_array.print_ename (array_idx)), (36)"1"b);
		end;
	     end;
	     link_array.check (array_idx) = FALSE;
	     num_links = num_links - 1;
	end check_for_noninfo;
     end check_links;

/**/

/* Check if an argument is a control arg */

is_control_arg:
     procedure (arg) returns (bit (1));

dcl  arg char (*);					/* (Input) command argument */

	if arg = "" then
	     return (FALSE);
	else return (index (arg, "-") = 1);

     end is_control_arg;

/**/

cleanup_:
     procedure ();

	if sl_info_p ^= null () then do;
	     free sl_info;
	     sl_info_p = null ();
	end;

	if star_names_ptr ^= null () then do;
	     free star_list_names;
	     star_names_ptr = null ();
	end;

	if star_entry_ptr ^= null () then do;
	     free star_links;
	     star_entry_ptr = null ();
	end;

	if uid_list_ptr ^= null () then call release_temp_segment_ (command, uid_list_ptr, code);
	if link_array_ptr ^= null () then call release_temp_segment_ (command, link_array_ptr, code);

	return;

     end cleanup_;

/**/

/* Fetch the date/time info segments were last check from the value segment: if the time isn't present in the value
   segment, check the abbrev profile for an old style date/time and copy it to the value segment */

get_time:
     procedure (p_date_time);

dcl  p_date_time fixed binary (71) parameter;

dcl  small_area area (256);
dcl  based_date_time fixed binary (71) based (date_time_ptr);
dcl  date_time_ptr pointer;

	call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (small_area), date_time_ptr,
	     (0), code);

	if (code = error_table_$oldnamerr) | (code = error_table_$noentry) then do;
	     call get_date_time_from_profile ();
	     call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (small_area),
		date_time_ptr, (0), code);
	end;

	if code ^= 0 then				/* couldn't find a date/time anywhere */
	     p_date_time = 0;
	else p_date_time = based_date_time;

	return;



/* Internal to get_time: check for an abbrev style profile and, if present, copy the date/time from it */

get_date_time_from_profile:
	procedure ();

dcl  home_dir character (168);
dcl  person_id character (24);
dcl  profile_ename character (32);

dcl  1 old_profile aligned based (profile_ptr),		/* abbrev profile */
       2 version fixed binary,
       2 pad (3) bit (36),
       2 check_info_time fixed binary (71);
dcl  profile_ptr pointer;

	     call user_info_$homedir (home_dir);
	     call user_info_ (person_id);
	     profile_ename = rtrim (person_id) || ".profile";

	     profile_ptr = null ();

	     on cleanup
		begin;				/* just in case (even with such a small window) */
		     if profile_ptr ^= null () then call terminate_file_ (profile_ptr, (0), TERMINATE_FILE, (0));
		     profile_ptr = null ();
		end;

	     call initiate_file_ (home_dir, profile_ename, R_ACCESS, profile_ptr, 0b, (0));

	     if profile_ptr ^= null () then do;		/* there is a profile */
		if old_profile.version = 1 then	/* only new style profile has the cis date/time */
		     call put_time (old_profile.check_info_time);
		call terminate_file_ (profile_ptr, (0), TERMINATE_FILE, (0));
	     end;

	     return;

	end get_date_time_from_profile;

     end get_time;

/**/

/* Put the updated date/time into the user's value segment */

put_time:
     procedure (p_date_time);

dcl  p_date_time fixed binary (71) parameter;

	call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (p_date_time),
	     currentsize (p_date_time), null (), (null ()), (0), code);

	if code = error_table_$noentry then do;		/* value segment not present: try to create it */
	     call create_default_value_segment ();
	     call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (p_date_time),
		currentsize (p_date_time), null (), (null ()), (0), code);
	end;

	if code ^= 0 then call com_err_ (code, command, "Attempting to update date/time in default value segment.");

	return;



/* Internal to put_time: create the default value segment (if possible) */

create_default_value_segment:
	procedure ();

dcl  value_segment_path character (168);

	     call value_$set_path ("", TRUE, code);

	     if code = 0 then do;			/* created it */
		call value_$get_path (value_segment_path, (0));
		call com_err_ (0, command, "Created ^a.", value_segment_path);
	     end;

	     return;

	end create_default_value_segment;

     end put_time;

/**/

%include access_mode_values;
%page;
%include sl_info;
%page;
%include sl_control_s;
%page;
%include star_structures;
%page;
%include status_structures;

     end check_info_segs;




		    help.pl1                        09/13/88  1348.5rew 09/13/88  1257.6      191061



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




/****^  HISTORY COMMENTS:
  1) change(86-03-05,LJAdams), approve(86-03-05,MCR7327),
     audit(86-03-10,Lippard), install(86-04-24,MR12.0-1048):
     There are three main programs used in help they are: help, help_, and
     help_rql_.
     
     Some of the changes made include:
     
        restructuring the programs to  use line parsing
     
        change the help command to use ssu_$create_standalone_invocation, and
        to be callable as a request from within ssu_
     
        withdraw support of old format info segs (those containing "\006" as
        paragraph indicators)
     
        make help -bf always return some information
     
        allow "List of" sections to have multiple consecutive list item lines
        starting in the left margin.  Item descriptions are no longer required
        but if present, must be indented three spaces
  2) change(87-04-27,LJAdams), approve(87-09-03,MCR7766),
     audit(88-08-07,GDixon), install(88-09-13,MR12.2-1109):
     Changed version to Vhelp_args_3.
     Added support for -cs (case_sensitive) and -ncs (non_case_sensitive).
  3) change(88-02-17,LJAdams), approve(88-03-07,MCR7857),
     audit(88-08-07,GDixon), install(88-09-13,MR12.2-1109):
     The cleanup procedure was not deleting all the temporary segments.
     Changed cleanup to use the help_args.help_data_ptr which points to a
     second help_args structure that is used only for the list_request
     operation.
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Name:	help								*/
/*									*/
/* This is the command interface to the Multics help facility.  It does the following.	*/
/*									*/
/* 1) call help_$init to obtain a help_args structure in which arguments and control	*/
/*    arguments can be stored.						*/
/* 2) process caller-supplied arguments, filling in the help_args structure.		*/
/* 3) call help_ with the help_args structure to actually find and print the info segs.	*/
/* 4) call help_$term to release the help_args structure.				*/
/*									*/
/* help searches for info segments (having a suffix of info) in the directories given in	*/
/* the search paths of the info_segments (info_segs or infos) search list, which	*/
/* is maintained by the Multics search facility.					*/
/*									*/
/* Status									*/
/*									*/
/* 0) Created:   November, 1969   by T. H. VanVleck				*/
/* 1) Modified:  February, 1975   by T. H. VanVleck - complete rewrite		*/
/* 2) Modified:  September,1976   by Steve Herbst - accept -pathname ctl_arg		*/
/* 3) Modified:  June, 1977	    by Paul Green - diagnose zero-length info segs	*/
/* 4) Modified:  October, 1978    by Gary Dixon - complete rewrite; split into help	*/
/*				command and separate help_ subroutine.		*/
/* 5) Modified:  June, 1983       by Gary Dixon - add ssu_help_request entrypoint.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* format: style2,ind2,ll131,dclind4,idind15,comcol41,linecom,ifthen */
help:
  procedure;

    dcl (Iarg, Iarg_end_ca, Iarg_end_scn, Iarg_start_ca, Iarg_start_scn, Iarg_start_srh, Ipath)
		   fixed bin,
        (Larg, Lop)	   fixed bin (21),
        Nargs	   fixed bin,
        Nctl_args	   fixed bin,
        (Parg, 
         Pop)	   ptr,
        Serror	   bit (1),
        Slist_requests bit (1),
        Stopics	   bit (1),
        Sstandalone_invocation
		   bit (1),
        (cleanup, conversion, size)
		   condition,
        code	   fixed bin (35),
        error_type	   fixed bin,
        j		   fixed bin,
        sci_ptr	   ptr;
    
    dcl arg	   char (Larg) based (Parg),
        op	   char (Lop) based (Pop);

    dcl (bin, convert, dim, index, maxlength, null, substr)
		   builtin;

    dcl com_err_	   entry options (variable),
        cu_$arg_count  entry (fixed bin, fixed bin (35)),
        ssu_$abort_line
		   entry () options (variable),
        ssu_$arg_count entry (ptr, fixed bin),
        ssu_$arg_ptr   entry (ptr, fixed bin, ptr, fixed bin (21)),
        ssu_$destroy_invocation
		   entry (ptr),
        ssu_$get_subsystem_and_request_name
		   entry (ptr) returns (char (72) var),
        ssu_$standalone_invocation
		   entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

    dcl (
        FALSE	   init ("0"b),
        TRUE	   init ("1"b)
        )		   bit (1) aligned int static options (constant),
        ctl_abbrev	   (14) char (6) varying int static options (constant) init ("-scn",
				/* 1 */
		   "-srh",	/* 2 */
		   "-bf",		/* 3 */
		   "-ca",		/* 4 */
		   "-ep",		/* 5 */
		   "-he",		/* 6 */
		   "-bfhe",	/* 7 */
		   "-pn",		/* 8 */
		   "-a",		/* 9 */
		   "-title",	/*10 */
		   "-topic",	/*11 ssu_ only */
                       "-lep",          /*12 */
                       "-cs",           /*13 */
                       "-ncs"),         /*14 */
        ctl_word	   (16) char (20) varying int static options (constant) init ("-section",
				/* 1 */
		   "-search",	/* 2 */
		   "-brief",	/* 3 */
		   "-control_arg",	/* 4 */
		   "-entry_point",	/* 5 */
		   "-header",	/* 6 */
		   "-brief_header", /* 7 */
		   "-pathname",	/* 8 */
		   "-all",	/* 9 */
		   "-titles",	/*10 */
		   "-topics",	/*11 ssu_ only */
		   "-list_entry_points",
		                    /*12 */
                       "-case_sensitive",
                                        /*13 */
                       "-non_case_sensitive",
                                        /*14 */
		   "-maxlines",	/*15 */
		   "-minlines"),	/*16 */
        ctl_obsolete   (2) char (3) varying int static options (constant) init ("-sc",
				/* 1 */
		   "-sh"),	/* 2 */
        (
        error_table_$active_function,
        error_table_$bad_arg,
        error_table_$badopt,
        error_table_$bigarg,
        error_table_$inconsistent,
        error_table_$noarg,
        error_table_$noentry,
        error_table_$unimplemented_version
        )		   fixed bin (35) ext static;

%include help_args_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


    call cu_$arg_count (Nargs, code);	/* help cannot be invoked as active function.	*/
    if code = error_table_$active_function then
      do;
        call com_err_ (code, "help");
        return;
      end;

    Sstandalone_invocation = TRUE;
    Slist_requests = FALSE;
    sci_ptr = null;
    Phelp_args = null;
    on cleanup call janitor ();	/* Cleanup help arg segment if help aborted.	*/

    call ssu_$standalone_invocation (sci_ptr, "help", "1", null, abort_help_command, code);
    if code ^= 0 then
      do;
        call com_err_ (code, "help", "Calling ssu_$standalone_invocation");
        return;
      end;
    go to COMMON;

ssu_help_request:
  entry (Asci_ptr, AStopics, find_subsystem_info_file);

    dcl Asci_ptr	   ptr,
        AStopics	   bit (1),
        find_subsystem_info_file
		   entry (ptr, char (*)) returns (char (300) var);

    sci_ptr = Asci_ptr;
    AStopics = FALSE;
    Sstandalone_invocation = FALSE;
    Phelp_args = null;
    on cleanup call janitor ();

COMMON:
    call help_$init (ssu_$get_subsystem_and_request_name (sci_ptr), "info_segments", "", Vhelp_args_3, Phelp_args, code);
    if Phelp_args = null then		/* get help input arguments.			*/
      go to ARG_STRUC_ERR;
    if help_args.version ^= Vhelp_args_3 then
      do;				/* check version of structure for validity.	*/
        code = error_table_$unimplemented_version;
        go to ARG_STRUC_ERR;
      end;
    help_args.sci_ptr = sci_ptr;

    call ssu_$arg_count (sci_ptr, Nargs);
				/* get count of input arguments.		*/
    Serror = FALSE;			/* Remember if error encountered in args.	*/
    Iarg_start_srh = Nargs + 1;	/* -search not encountered so far.		*/
    Iarg_start_ca = Nargs + 1;	/* Same for -control_arg.			*/
    Iarg_start_scn = Nargs + 1;	/* Same for -section			*/
    Iarg_end_ca = 0;
    Iarg_end_scn = 0;
    if Sstandalone_invocation then
      help_args.Sctl.he_pn = TRUE;	/* Output long heading by default.		*/
    help_args.Sctl.he_counts = TRUE;
    Stopics = FALSE;
    Nctl_args = 0;
    do Iarg = 1 to Nargs;		/* Process args.				*/
      call ssu_$arg_ptr (sci_ptr, Iarg, Parg, Larg);
      if index (arg, "-") = 1 then
        do;
	Nctl_args = Nctl_args + 1;
	do j = 1 to dim (ctl_abbrev, 1) while (arg ^= ctl_abbrev (j));
	end;
	if j > dim (ctl_abbrev, 1) then
	  do;
	    do j = 1 to dim (ctl_word, 1) while (arg ^= ctl_word (j));
	    end;
	    if j > dim (ctl_word, 1) then
	      do;
	        do j = 1 to dim (ctl_obsolete, 1) while (arg ^= ctl_obsolete (j));
	        end;
	        if j > dim (ctl_obsolete, 1) then
		do;
		  Serror = TRUE;
		  call ssu_$abort_line (sci_ptr, error_table_$badopt, arg);
		  go to NEXT_ARG;
		end;
	      end;
	  end;
	go to DO_ARG (j);

DO_ARG (1):
	if Iarg = Nargs then
	  go to NO_OPERAND;
	call ssu_$arg_ptr (sci_ptr, Iarg + 1, Pop, Lop);
	if Lop >= 1 then
	  if substr (op, 1, 1) = "-" then
	    go to NO_OPERAND;
	help_args.Sctl.scn = TRUE;
	Iarg = Iarg + 1;		/* -section:  next arg guaranteed part of         */
	Iarg_start_scn = Iarg;	/*   section name.                                */
	Iarg_end_scn = Iarg;
	do Iarg = Iarg + 1 to Nargs;	/* Remaining args not starting with - are part    */
				/*   of section name too.                         */
	  call ssu_$arg_ptr (sci_ptr, Iarg, Pop, Lop);
	  if Lop >= 1 then
	    if substr (op, 1, 1) = "-" then
	      do;
	        Iarg = Iarg - 1;
	        go to NEXT_ARG;
	      end;
	  Iarg_end_scn = Iarg;
	end;
	go to NEXT_ARG;

DO_ARG (2):
	if Iarg = Nargs then
	  go to NO_OPERAND;
	help_args.Sctl.srh = TRUE;	/* -search:  All remaining args are search        */
				/*   strings.  Last arg could be -cs/-ncs         */
	Iarg_start_srh = Iarg + 1;	/* Remember where search args begin.              */
	Iarg = Nargs;
	go to NEXT_ARG;

DO_ARG (3):
	help_args.Sctl.bf = TRUE;	/* -brief                                         */
	go to NEXT_ARG;

DO_ARG (4):
	if Iarg = Nargs then
	  go to NO_OPERAND;
	Iarg = Iarg + 1;		/* -control_arg:  args not starting with - are    */
				/*   control argument names.                      */
	Iarg_start_ca = Iarg;	/* Remember where ca names start.                 */
	Iarg_end_ca = Iarg;		/* Remember where last ca name is.		*/
	help_args.Sctl.ca = TRUE;	/* -ca					*/
	do Iarg = Iarg + 1 to Nargs;
	  call ssu_$arg_ptr (sci_ptr, Iarg, Pop, Lop);
	  if Lop >= 1 then
	    if substr (op, 1, 1) = "-" then
	      do;
	        Iarg = Iarg - 1;
	        go to NEXT_ARG;
	      end;
	  Iarg_end_ca = Iarg;
	end;
	go to NEXT_ARG;

DO_ARG (5):
	help_args.Sctl.ep = TRUE;	/* -entry_point				*/
	go to NEXT_ARG;

DO_ARG (6):
	help_args.Sctl.he_only = TRUE;/* -header (print only heading)		*/
	go to NEXT_ARG;

DO_ARG (7):
	help_args.Sctl.he_pn = FALSE; /* -brief_header (output brief headings)	*/
	go to NEXT_ARG;

DO_ARG (8):
	if Iarg = Nargs then
	  go to NO_OPERAND;		/* -pathname:  following arg is a pathname,	*/
	Iarg = Iarg + 1;		/*   no matter what it looks like.		*/
	call ssu_$arg_ptr (sci_ptr, Iarg, Pop, Lop);
	j = 1;
	if maxlength (help_args.path (j).value) < Lop then
	  do;
	    call ssu_$abort_line (sci_ptr, error_table_$bigarg, " ^a ^a", arg, op);
	    Serror = TRUE;
	  end;
	else
	  do;
	    help_args.Npaths, j = help_args.Npaths + 1;
	    help_args.path (j).S = "0"b;
	    help_args.path (j).S.pn_ctl_arg = TRUE;
	    help_args.path (j).value = op;
	    help_args.path (j).info_name = "";
	  end;
	go to NEXT_ARG;

DO_ARG (9):
	help_args.Sctl.all = TRUE;	/* -all					*/
	go to NEXT_ARG;

DO_ARG (10):
	help_args.Sctl.title = TRUE;	/* -title					*/
	go to NEXT_ARG;

DO_ARG (11):
	Stopics = TRUE;		/* -topics - This arg is allowed only in the	*/
	go to NEXT_ARG;		/*   ssu_ help request, not in help command.	*/
				/*   It supports obsolete function of listing	*/
				/*   all available subsystem info segs.  Proper	*/
				/*   method of doing this is list_help request.	*/

DO_ARG (12):
	help_args.Sctl.lep = TRUE;    /* -list_entrypoints                              */
	goto NEXT_ARG;
	
DO_ARG (13):
	help_args.Sctl.cs = TRUE;     /* -case_sensitive                                */
	goto NEXT_ARG;

DO_ARG (14):
	help_args.Sctl.cs = FALSE;    /* -non_case_sensitive                            */
          goto NEXT_ARG;

DO_ARG (15):
	if Iarg = Nargs then
	  go to NO_OPERAND;		/* -maxlines N				*/
	Iarg = Iarg + 1;
	call ssu_$arg_ptr (sci_ptr, Iarg, Pop, Lop);
	on conversion, size go to BAD_OPERAND;
	help_args.min_Lpgh = convert (help_args.min_Lpgh, op);
	revert conversion, size;
	if help_args.min_Lpgh < 1 | help_args.min_Lpgh > 50 then
	  go to BAD_OPERAND;
	go to NEXT_ARG;

DO_ARG (16):
	if Iarg = Nargs then
	  go to NO_OPERAND;		/* -minlines N				*/
	Iarg = Iarg + 1;
	call ssu_$arg_ptr (sci_ptr, Iarg, Pop, Lop);
	on conversion, size go to BAD_OPERAND;
	help_args.min_Lpgh = convert (help_args.min_Lpgh, op);
	revert conversion, size;
	if help_args.min_Lpgh < 1 | help_args.min_Lpgh > 50 then
	  go to BAD_OPERAND;
	go to NEXT_ARG;

NO_OPERAND:
	Serror = TRUE;		/* No operand given with -scn, -srh, -ca, -pn	*/
	call ssu_$abort_line (sci_ptr, error_table_$noarg, "No operand given following ^a.", arg);
	go to NEXT_ARG;

BAD_OPERAND:
	Serror = TRUE;		/* Bad numeric operand with -minlines.	*/
	call ssu_$abort_line (sci_ptr, error_table_$bad_arg, " ^a^/Operand of ^a must be integer from 1 to 50.", op, arg);
        end;
      else
        do;
	j = 1;
	if maxlength (help_args.path (j).value) < Larg then
	  do;
	    call ssu_$abort_line (sci_ptr, error_table_$bigarg, " ^a", arg);
	    Serror = TRUE;
	  end;
	else
	  do;
	    help_args.Npaths, j = help_args.Npaths + 1;
	    help_args.path (j).S = "0"b;
	    help_args.path (j).info_name = "";
	    if Sstandalone_invocation then
	      help_args.path (j).value = arg;
	    else help_args.path (j).value = find_subsystem_info_file (sci_ptr, arg);
	  end;
        end;
NEXT_ARG:
    end;

    if Stopics then
      do;
        if Nctl_args ^= 1 | help_args.Npaths ^= 0 then
	call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-topics and any other arguments");
        AStopics = TRUE;
        go to RETURN;
      end;

    if help_args.Sctl.bf then		/* Complain if other ctl_args given with -brief	*/
      if help_args.Sctl.title | help_args.Sctl.all | help_args.Sctl.lep then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
          "^/-brief may not be given with: ^[ -title^]^[ -all^]^[ -lep^].",
	     help_args.Sctl.title, help_args.Sctl.all, help_args.Sctl.lep);
        end;
    if help_args.Sctl.ca then		/* Complain if other ctl_args given with -ca	*/
      if help_args.Sctl.title | help_args.Sctl.all | help_args.Sctl.lep then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
          "^/-control_arg may not be given with: ^[ -title^]^[ -all^]^ -lep^].",
          help_args.Sctl.title, help_args.Sctl.all, help_args.Sctl.lep);
        end;
    if help_args.Sctl.he_only then
      if help_args.Sctl.title | help_args.Sctl.bf | help_args.Sctl.all | 
         help_args.Sctl.ca | help_args.Sctl.cs | help_args.Sctl.lep then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "
-header may not be given with: ^[ -brief^]^[ -title^]^[ -control_arg^]^[ -all^]^[ -cs^]^[ -lep^].",
          help_args.Sctl.bf, help_args.Sctl.title, help_args.Sctl.ca, 
          help_args.Sctl.all, help_args.Sctl.cs, help_args.Sctl.lep);
        end;
    if help_args.Sctl.cs then		/* complain if cs given without scn or srh	*/
      if ^help_args.Sctl.srh & ^help_args.Sctl.scn then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "
^[-cs^] may only be used with the -srh or -scn arguments.", help_args.Sctl.cs);
        end;
    if help_args.Sctl.lep then          /* Complain if scn or srh given with lep          */
      if help_args.Sctl.srh | help_args.Sctl.scn then
        do;
          Serror = TRUE;
          call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
          "-lep may not be given with : ^[ -srh^]^[ -scn^].",
          help_args.Sctl.srh, help_args.Sctl.scn);
        end;
    if help_args.Npaths = 0 then
      do;				/* Supply default pathname of help_system.gi.info.*/
        if Sstandalone_invocation then
	do;
	  help_args.Npaths = 1;
	  help_args.path (1).value = "help_system.gi.info";
				/* Give info for installed help command.	*/
	  help_args.path (1).info_name = "";
	  help_args.path (1).S = "0"b;
	end;
        else call ssu_$abort_line (sci_ptr, error_table_$noarg, "One or more topic names.");
      end;

    do Iarg = Iarg_start_ca to Iarg_end_ca;
				/* Add control arg names to arg structure.	*/
      call ssu_$arg_ptr (sci_ptr, Iarg, Parg, Larg);
      j = 1;
      if maxlength (help_args.ca (j)) < Larg then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$bigarg, " -ca ^a
Maximum length is ^d characters.", arg, maxlength (help_args.ca (j)));
        end;
      else
        do;
	help_args.Ncas, j = help_args.Ncas + 1;
	help_args.ca (j) = arg;
        end;
    end;
    do Iarg = Iarg_start_scn to Iarg_end_scn;
				/* Add -section substrings to arg structure.	*/
      call ssu_$arg_ptr (sci_ptr, Iarg, Parg, Larg);
      j = 1;
      if maxlength (help_args.scn (j)) < Larg then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$bigarg, " -scn ^a
Maximum length is ^d characters.", arg, maxlength (help_args.scn (j)));
        end;
      else
        do;
	help_args.Nscns, j = help_args.Nscns + 1;
	help_args.scn (j) = arg;
        end;
    end;
    do Iarg = Iarg_start_srh to Nargs;	/* Add -search args to control structure.	*/
      call ssu_$arg_ptr (sci_ptr, Iarg, Parg, Larg);
      j = 1;
      if maxlength (help_args.srh (j)) < Larg then
        do;
	Serror = TRUE;
	call ssu_$abort_line (sci_ptr, error_table_$bigarg, " -srh ^a
Maximum length is ^d characters.", arg, maxlength (help_args.srh (j)));
        end;
      else
        do;
          help_args.Nsrhs, j = help_args.Nsrhs + 1;
	help_args.srh (j) = arg;
        end;
    end;
    if Serror then
      do;
        call janitor ();
        return;
      end;

    call help_ (ssu_$get_subsystem_and_request_name (sci_ptr), Phelp_args, "info", error_type, code);
    go to ERROR (error_type);

ARG_STRUC_ERR:
ERROR (1):			/* bad help_args version.			*/
ERROR (2):			/* No pathnames given in help_args.		*/
    call ssu_$abort_line (sci_ptr, code, "^/Processing the argument structure used by help_.");
    call janitor ();
    return;

ERROR (3):			/* Error encountered in processing one or more	*/
				/* of the pathnames given in help_args.		*/
    do Ipath = 1 to help_args.Npaths;
      if help_args.path (Ipath).code ^= 0 then
        call ssu_$abort_line (sci_ptr, help_args.path (Ipath).code, " ^[-pn ^]^a", help_args.path (Ipath).S.pn_ctl_arg,
	   help_args.path (Ipath).value);
    end;
    call janitor ();
    return;

ERROR (5):			/* If a nonzero error code is returned, it means	*/
				/* than -section and -search failed to find any	*/
				/* matching info segs to print.  This error must	*/
				/* be reported to the user.			*/
    if code ^= 0 then
      call ssu_$abort_line (sci_ptr, error_table_$noentry, "
Looking for infos matching info_name^[s^]^[^; and -search criteria^; and -section criteria^;" ||
", plus -section and -search criteria^].",
	 (help_args.Npaths > 1), (1 + 2 * bin (help_args.Sctl.scn, 1) + bin (help_args.Sctl.srh, 1)));

ERROR (4):			/* No fatal errors encountered.  Most nonfatal	*/
RETURN:				/*   errors have been reported by help_.	*/
    call janitor ();
    return;

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


abort_help_command:
  procedure ();

    go to RETURN;

  end abort_help_command;

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


janitor:
  procedure;

dcl Acode                 fixed bin (35);

    if Phelp_args ^= null then
       call help_$term (ssu_$get_subsystem_and_request_name (sci_ptr), Phelp_args, Acode);
    if Sstandalone_invocation then
       call ssu_$destroy_invocation (sci_ptr);

  end janitor;

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

  end help;




		    help_.pl1                       09/13/88  1348.5rew 09/13/88  1306.3      483084



/****^  ***********************************************************
        *                                                         *
        * 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(86-03-05,LJAdams), approve(86-03-05,MCR7327),
     audit(86-04-17,Lippard), install(86-04-24,MR12.0-1048):
     Changed routines to use line parsing.
  2) change(86-05-08,LJAdams), approve(86-05-14,MCR7416),
     audit(86-06-06,Gilcrease), install(86-06-12,MR12.0-1074):
     Changed sort so that the ep identifier is included.  This is so that
     separate infos are maintained for each entry_point is given on the
     command line.
  3) change(86-09-04,LJAdams), approve(86-09-04,MCR7506),
     audit(86-10-29,GDixon), install(86-10-30,MR12.0-1203):
     Moved error messages for no match on srh/section and entry point not
     found here to avoid printing duplicate error messages per info seg
     found in search path.
  4) change(87-01-20,LJAdams), approve(87-09-03,MCR7766),
     audit(88-08-14,GDixon), install(88-09-13,MR12.2-1109):
     Changed to version Vhelp_args_3.
  5) change(88-02-17,LJAdams), approve(88-03-07,MCR7857),
     audit(88-08-14,GDixon), install(88-09-13,MR12.2-1109):
     Changed to check the help_args.help_data_ptr to determine if it is a
     list_request operation.  This is because when checking the validity of
     names the lr operation must allow the (. .. ?) symbols.
  6) change(88-03-14,LJAdams), approve(88-06-01,MCR7873),
     audit(88-08-14,GDixon), install(88-09-13,MR12.2-1109):
     Changed VPDinfo_seg_1 to VPDinfo_seg_2.  Changed sort to eliminate
     duplicates from sorting 360 bits to sorting 396 bits. (phx21111)
                                                   END HISTORY COMMENTS */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Name:  help_								*/
/*									*/
/* This subroutine implements the help command.  It performs the following functions.	*/
/*									*/
/* 1) Finds info segments.							*/
/* 2) Selects particular infos within multi-info segments.				*/
/* 3) Sorts the list of infos to be processed.					*/
/* 4) Processes each info, implementing all help control arguments and query responses.	*/
/*									*/
/* The subroutine may also be used to implement a help-style information facility in	*/
/* other subsystems.  Information segments (with an info suffix or another suffix) are	*/
/* selected and printed, based upon information given primarily in a help_args structure,	*/
/* which is declared in help_args_.incl.pl1.					*/
/*									*/
/* Usage									*/
/*									*/
/* The help_ subroutine must be invoked by a sequence of calls.			*/
/*									*/
/* 1) call help_$init to get temp segment containing help_args structure and stores the 	*/
/*    current info_segments search rules in the structure.				*/
/* 2) call help_ one or more times to select and print info segments                      */
/* 3) call help_$term to release the temp segment.				*/
/*									*/
/* Entry:  help_$check_info_segs						*/
/*									*/
/* This subroutine generates the list of info segments to be processed by the 		*/
/* check_info_segs command.  It finds info segments modified since a given date, sorts	*/
/* the list and returns it for check_info_segs to process.				*/
/*									*/
/* Usage									*/
/*									*/
/* 1) call help_$init to get temp segment containing help_args and the output list.	*/
/* 2) call help_$check_info_segs to build and sort the list of segments to be processed.	*/
/* 3) call help_$term to release the temp segment.				*/
/*									*/

/* Status									*/
/*									*/
/* 0) Created:   November, 1969   by T. H. VanVleck				*/
/* 1) Modified:  February, 1975   by T. H. VanVleck - complete rewrite		*/
/* 2) Modified:  September,1976   by Steve Herbst - accept -pathname ctl_arg		*/
/* 3) Modified:  June, 1977	    by Paul Green - diagnose zero-length info segs	*/
/* 4) Modified:  October, 1978    by Gary Dixon - complete rewrite; split into help	*/
/*				command and separate help_ subroutine.		*/
/*				Add support for check_info_segs.		*/
/* 5) Modified:  April, 1985      by L. Adams - rewrote parsing routines to use line logic*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* format: style2,ind2,ll131,dclind4,idind15,comcol41,linecom,ifthen */
help_:	
  procedure (procedure_name, Phelp_args, suffix, progress, Acode);

    dcl				/*	Parameters			*/
        procedure_name char (*),	/* Caller of help_ and help_$init.		*/
				/*   1) Owns temp segment help_args are stored in.*/
				/*   2) Name used in error messages.		*/
/*      Phelp_args	   ptr, */          /* ptr to argument struc at base of temp seg.	*/
				/* This is really declared in include seg.	*/
        suffix	   char (*),	/* Suffix on segs to be processed. Normally "info"*/
				/* but may be some other suffix or "" to omit	*/
				/* suffix processing.			*/
        progress	   fixed bin,	/* =1: bad help_args version			*/
				/* =2: no pathnames given.			*/
				/* =3: evaluating pathnames.			*/
				/* =4: finding help segs.			*/
				/* =5: -section/-search & printing help segs.	*/
        Acode	   fixed bin (35),	/* Return code.				*/
        APPDinfo_seg   ptr;		/* Ptr to output structures returned by		*/
				/* help_$check_info_segs			*/

    dcl Lseg	   fixed bin (21),	/* Length of info.				*/
        Ninfos_printed fixed bin,	/* Number of infos for which something has printed*/
        Nlast_info_cross_ref
		   fixed bin,	/* Last info with Scross_ref on.		*/
        Nlast_info_no_brief_data
		   fixed bin,	/* Last info not containing Syntax section,	*/
				/* which get_brief_data encountered.		*/
        PI_LABEL	   label variable,
        PDeps	   ptr,
        PDinfo	   ptr,
        Pinit_assoc_mem
		   ptr,
        Pnext_free_space
		   ptr,		/* ptr to next free word location in temp	*/
				/*   seg containing help_args.		*/
        Pquery_answers ptr,		/* ptr to formatted list of help responses.	*/
        Pseg	   ptr,
        Ptemp	   ptr,
        Sprint_inhibit bit (1) aligned, /* on if printing stopped by program_interrupt.	*/
        Sstandalone_invocation
		   bit (1),
        cleanup	   condition,
        code	   fixed bin (35),
        fcn	   fixed bin,	/* Function to be performed by this invocation.	*/
        (
        HELP	   init (0),	/*   help_				*/
        CIS	   init (1)
        )				/*   check_info_segs			*/
		   fixed bin int static options (constant),
        (i, j)	   fixed bin,
        offset	   fixed bin (35),
        program_interrupt
		   condition;

    dcl 1 Dinfo	   aligned based (PDinfo),
	2 N	   fixed bin,
	2 seg	   (0 refer (Dinfo.N)) like Dinfo_seg;
				/* Information about each log. info to be printed.*/

    dcl 1 init_assoc_mem
		   aligned based (Pinit_assoc_mem),
				/* Associative memory in which initiated segments	*/
	2 N	   fixed bin,	/* are stored.				*/
	2 seg	   (50),		/* Allow up to 50 initiated segments at once.	*/
	  3 dir	   char (168) unal,
	  3 ent	   char (32) unal,
	  3 uid	   bit (36),
	  3 pad	   fixed bin,
	  3 P	   ptr;

    dcl 1 LIST	   aligned based,	/* structure used to format list of things to be	*/
	2 header,			/* output in columns.			*/
	  3 N	   fixed bin,	/*   number of list elements.			*/
	  3 Nreal	   fixed bin,	/*   number of filled list elements.		*/
	  3 Npghs	   fixed bin,	/*   number of filled paragraphs of formatted out.*/
	  3 Nrows	   fixed bin,	/*   number of rows in formatted output.	*/
	  3 Ncols	   fixed bin,	/*   number of columns in formatted output.	*/
	  3 ML	   (6) fixed bin,	/*   length of longest element in each column.	*/
	  3 title	   char (80) varying,
				/*   title of output list.			*/
	  3 Iunit	   fixed bin,	/*   unit no of pgh containing list elements.	*/
	2 group	   (0 refer (LIST.N)),
	  3 arg	   char (88) varying,
				/*   the argument.				*/
	  3 Snot_found
		   fixed bin;	/*   = 1 if no match found for the argument.	*/

    dcl 1 query_answers
		   aligned based (Pquery_answers),
	2 header	   like LIST.header,
	2 group	   (0 refer (query_answers.N)) like LIST.group;

    dcl responses	   (25) char (50) var int static options (constant) init (" yes, y",
				/* List of allowed responses to questions asked	*/
				/*   by help_.				*/
		   " rest {-scn} {-all_entrypoints} {-entrypoints}", 
                       "    r {-scn} {-aep} {-ep}",
                       " no, n",
                       " quit, q",
                       " top, t",
                       " header, he",
		   " title {-top}",
                       " section {STRs} {-case_sensitive} {-top},", 
                       "    scn  {STRs} {-cs} {-top}",
		   " search  {STRs} {-case_sensitive} {-top},", 
                       "    srh  {STRs} {-cs} {-top}",
		   " skip {-scn} {-seen} {-rest} {-ep},",
                       "    s {-scn} {-seen} {-rest} {-ep}",
                       " brief, bf",
		   " control_arg STRs, ca STRs",
                       " entry_point {EP_NAME},",
                       "    ep {EP_NAME}",
                       " list_entry_points",
		   "    lep",
                       " list_requests,",
                       "    lr",
                       " ?",
                       " .",
                       " ..");

    dcl bit36	   bit (36) aligned based,
        bit360	   bit (360) aligned based;
  
    dcl (addr, addrel, binary, char, currentsize, dim, dimension, divide, empty, hbound, index, lbound, length, ltrim, mod,
        null, ptr, rel, reverse, rtrim, search, string, substr, unspec, verify)
		   builtin;


    dcl com_err_	   entry options (variable),
        convert_date_to_binary_
		   entry (char (*), fixed bin (71), fixed bin (35)),
        get_temp_segment_
		   entry (char (*), ptr, fixed bin (35)),
        hcs_$get_uid_seg
		   entry (ptr, bit (36) aligned, fixed bin (35)),
        hcs_$initiate  entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
        hcs_$terminate_noname
		   entry (ptr, fixed bin (35)),
        hcs_$truncate_seg
		   entry (ptr, fixed bin, fixed bin (35)),
        help_rql_	   entry (char(*), char(*), ptr, fixed bin, fixed bin, fixed bin(24),
				     fixed bin, fixed bin, ptr, ptr, ptr, ptr, label, bit(1) aligned,
				     fixed bin(35)),
        match_star_name_
		   entry (char (*), char (*), fixed bin (35)),
        pathname_$component
		   entry (char (*), char (*), char (*)) returns (char (194)),
        release_temp_segment_
		   entry (char (*), ptr, fixed bin (35)),
        search_paths_$get
		   entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35)),
        (
        sort_items_$bit,
        sort_items_$char
        )		   entry (ptr, fixed bin),
        ssu_$destroy_invocation
		   entry (ptr),
        ssu_$print_message
		   entry () options (variable),
        ssu_$standalone_invocation
		   entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

    dcl (
        FALSE	   init ("0"b),
        TRUE	   init ("1"b)
        )		   bit (1) int static options (constant),
        HT_SP	   char (2) init ("	 ") int static options (constant),
				/* Horizontal-tab followed by space.		*/
        NL	   char (1) int static options (constant) init ("
"),
        (
        error_table_$badsyntax,
        error_table_$inconsistent,
        error_table_$incorrect_access,
        error_table_$moderr,
        error_table_$no_s_permission,
        error_table_$noarg,
        error_table_$noentry,
        error_table_$no_info,
        error_table_$nomatch,
        error_table_$unimplemented_version,
        error_table_$zero_length_seg
        )		   fixed bin (35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

    fcn = HELP;			/* Perform a help function.			*/
    go to COMMON;


check_info_segs:
  entry (procedure_name, Phelp_args, suffix, progress, Acode, APPDinfo_seg);

    fcn = CIS;			/* Perform a check_info_segs function.		*/

COMMON:

    progress = 1;

    if help_args.version = 1 | help_args.version = 2 then
      do;				/* Version 1 and version 2 are upwards-compatible with 3.	*/
        help_args.version = Vhelp_args_3;
        help_args.sci_ptr = null;
        help_args.Sctl.inhibit_errors = FALSE;
      end;
    if help_args.version ^= Vhelp_args_3 then
      do;				/* Validate structure version.		*/
        Acode = error_table_$unimplemented_version;
        return;
      end;

    progress = 2;
    if help_args.Npaths ^> 0 then
      do;				/* Make sure info file names were given.	*/
        Acode = error_table_$noarg;
        return;
      end;
    Acode = 0;
    progress = 3;
    do i = 1 to help_args.Npaths;	/* validate input paths.			*/
      call evaluate_path (help_args.path (i), suffix);
      if Acode = 0 then
        Acode = help_args.path.code (i);
    end;
    if Acode ^= 0 then
      return;

    progress = 4;
    call get_temp_segment_ (procedure_name, Pquery_answers, Acode);
    if Acode ^= 0 then
      return;			/* Get space for format list of help responses.	*/
				/* Problem with size of query answers overlaping	*/
				/* next list so put it in a separate temp seg	*/
    query_answers.N = 2 * hbound (responses, 1);
				/* Copy allowed responses into the list.	*/
    query_answers.Nreal = query_answers.N;
    query_answers.Nrows = 0;		/* This indicates that list isn't formatted yet.	*/
    query_answers.title = "List of Responses";
    do i = lbound (responses, 1) to hbound (responses, 1);
      query_answers.group (i).arg = responses (i);
    end;
    do i = i to query_answers.N;	/* Struc must be two * size of response array	*/
      query_answers.group (i).arg = ""; /*   to allow for extension during formatting.	*/
    end;				/*   Set added elements to null strings.	*/

    Pinit_assoc_mem, Pnext_free_space = set_space_used (Phelp_args, currentsize (help_args));
				/* Get space in temp seg for associative memory	*/
				/* used to reduce calls to hcs_$initiate.	*/
    Sstandalone_invocation = FALSE;
    init_assoc_mem.N = 0;
    on cleanup call janitor ();	/* Establish cleanup on unit.			*/

    PDinfo, Pnext_free_space = set_space_used (Pnext_free_space, currentsize (init_assoc_mem));
    Dinfo.N = 0;			/* Obtain space for list of info segs to be read.	*/
    do i = 1 to help_args.Npaths;	/* Convert input paths to list of info segs.	*/
      if help_args.path (i).S.less_greater then
        call get_info_seg_list (procedure_name, suffix, fcn, help_args.path (i).dir (*), help_args.path (i), PDinfo);
      else call get_info_seg_list (procedure_name, suffix, fcn, help_args.search_dirs (*), help_args.path (i), PDinfo);
    end;
    if Dinfo.N <= 0 then
      do;				/* Stop if no matching segs found.		*/
        Acode = error_table_$nomatch;	/*   get_info_seg_list has already complained.	*/
        call janitor ();
        return;
      end;

    progress = 5;			/* Infos selected by starname.  Any other errors	*/
				/* reported via Acode describe info selection by	*/
				/* -search and -seciton criteria.		*/
    PPDinfo_seg, Pnext_free_space = set_space_used (Pnext_free_space, currentsize (Dinfo));
    PDinfo_seg.version = VPDinfo_seg_2;
    PDinfo_seg.N = Dinfo.N;
    do i = 1 to Dinfo.N;		/* Sort listed infos thrice:			*/
      PDinfo_seg.P (i) = addr (Dinfo.seg (i).uid);
      Dinfo.seg (i).X = i;		/*   1st:  sort on  Dinfo.seg.uid/.I/.E combo     */
    end;				/* 	 to eliminate duplicate infos.	*/
				/*   2nd:  sort on Dinfo.seg.ent to identify	*/
				/* 	 versions of info seg in different dirs.*/
    if Dinfo.N > 1 then
      do;				/*   3rd:  sort on Dinfo.seg.Scross_ref/dir/.ent	*/
        call sort_items_$bit (addr (PDinfo_seg.N), 396);
				/*	 combination to alphabetize output.	*/
        offset = binary (rel (addr (Dinfo.seg (1).ent))) - binary (rel (addr (Dinfo.seg (1).uid)));
				/* Compute negative offset to adjust ptrs to	*/
				/* Dinfo.seg.uid to point back to Dinfo.seg.ent.	*/

        do i = 1 to Dinfo.N while (PDinfo_seg.P (i) -> bit360 = "0"b);
	PDinfo_seg.P (i) = addrel (PDinfo_seg.P (i), offset);
        end;			/* Allow duplicate .uid/.I combos for infos	*/
				/* in which errors were encountered.  These errors*/
				/* must be reported.  get_info_seg_list has set	*/
				/* .uid/.I combo to "0"b in these cases.	*/
        j = i - 1;
        if i > Dinfo.N then		/* if all info segs are in error, skip the	*/
	go to SKIP_ELIMINATION;	/* elimination of duplicates.			*/
        go to CHECK (fcn);


CHECK (0):
        do i = i to Dinfo.N - 1;	/* Eliminate duplicate .uid/.I combos.		*/
	if PDinfo_seg.P (i) -> bit360 ^= PDinfo_seg.P (i + 1) -> bit360 then
	  do;
	    j = j + 1;		/*   (Only retain unique .uid/.I combos.)	*/
	    PDinfo_seg.P (j) = addrel (PDinfo_seg.P (i), offset);
	  end;
	else PDinfo_seg.P (i + 1) = PDinfo_seg.P (i);
				/*   (Retain info found earliest in search rules).*/
        end;
        go to END_CHECK;

CHECK (1):
        do i = i to Dinfo.N - 1;	/* Eliminate duplicate .uid combos.		*/
	if PDinfo_seg.P (i) -> bit36 ^= PDinfo_seg.P (i + 1) -> bit36 then
	  do;
	    j = j + 1;		/*   (Only retain unique .uid combos.)		*/
	    PDinfo_seg.P (j) = addrel (PDinfo_seg.P (i), offset);
	  end;
	else PDinfo_seg.P (i + 1) = PDinfo_seg.P (i);
				/*   (Retain info found earliest in search rules).*/
        end;

END_CHECK:
        j = j + 1;			/*   (Always retain the last entry in the list.)	*/
        PDinfo_seg.P (j) = addrel (PDinfo_seg.P (i), offset);
        PDinfo_seg.N = j;
      end;
    else PDinfo_seg.P (1) = addr (Dinfo.seg (1).ent);

SKIP_ELIMINATION:
    if PDinfo_seg.N > 1 then
      do;				/* Sort alphabetically by ent to identify info 	*/
        call sort_items_$char (addr (PDinfo_seg.N), 32);
				/* segments appearing in more than one search dir.*/
        offset = binary (rel (addr (Dinfo.seg (1).Scross_ref))) - binary (rel (addr (Dinfo.seg (1).ent)));
				/* Compute negative offset to adjust ptrs from	*/
				/* Dinfo.seg.ent to point to Dinfo.seg.Scross_ref.*/
        PDinfo_seg.P (1) = addrel (PDinfo_seg.P (1), offset);
        do i = 1 to Dinfo.N - 1;	/* Check for entry of same name in different dirs.*/
	PDinfo_seg.P (i + 1) = addrel (PDinfo_seg.P (i + 1), offset);
	if PDinfo_seg.P (i) -> Dinfo_seg.ent = PDinfo_seg.P (i + 1) -> Dinfo_seg.ent
	     & PDinfo_seg.P (i) -> Dinfo_seg.uid ^= PDinfo_seg.P (i + 1) -> Dinfo_seg.uid
	     & PDinfo_seg.P (i) -> Dinfo_seg.uid ^= "0"b & "0"b ^= PDinfo_seg.P (i + 1) -> Dinfo_seg.uid then
	  do;
	    if binary (rel (PDinfo_seg.P (i)), 18) < binary (rel (PDinfo_seg.P (i + 1)), 18) then
	      do;
	        Ptemp = PDinfo_seg.P (i);
				/* Mark all but entry found earliest in search	*/
	        PDinfo_seg.P (i) = PDinfo_seg.P (i + 1);
	        PDinfo_seg.P (i + 1) = Ptemp;
				/* rules with a cross reference flag.		*/
	      end;
	    PDinfo_seg.P (i) -> Dinfo_seg.Scross_ref = TRUE;
	  end;
        end;
      end;
    else PDinfo_seg.P (1) = addr (Dinfo.seg (1).Scross_ref);

    if PDinfo_seg.N > 1 then		/* Sort alphabetically by Scross_ref/dir/ent combo*/
      call sort_items_$char (addr (PDinfo_seg.N), 204);
				/* 4 + 168 + 32                                   */
    if fcn = CIS then
      do;
        call term_assoc_mem ();
        APPDinfo_seg = PPDinfo_seg;
        return;
      end;

    PDeps, Pnext_free_space = set_space_used (Pnext_free_space, currentsize (PDinfo_seg));
				/* Get space for entry point info descriptors.	*/
    Nlast_info_no_brief_data = -1;	/* No info processed yet.			*/
    Nlast_info_cross_ref = -1;

    PI_LABEL = PROCESS;		/* Establish pi handler.			*/
    on program_interrupt
      begin;
        Sprint_inhibit = TRUE;
        go to PI_LABEL;
      end;

PROCESS:
    Ninfos_printed = 0;
    code = 0;

    do i = 1 to PDinfo_seg.N while (code = 0);
				/* Process each listed info in alphabetical order.*/
      PI_LABEL = NEXT_INFO;
      PDinfo_seg_ = PDinfo_seg.P (i);
      if Dinfo_seg_.code ^= 0 then
        do;			/* Print any error encountered while finding seg.	*/
INIT_ERROR:
	call error (help_args.sci_ptr, Dinfo_seg_.code, "For ^[link^;segment^;directory^]: ^a^[>^]^a^[
Looking for an info matching ^a^].", binary (Dinfo_seg_.segment_type, 2) + 1, Dinfo_seg_.dir, Dinfo_seg_.dir ^= ">",
	     Dinfo_seg_.ent, (Dinfo_seg_.info_name ^= ""), Dinfo_seg_.info_name);
	go to NEXT_INFO;
        end;
      call initiate (Dinfo_seg_.dir, Dinfo_seg_.ent, Dinfo_seg_.uid, Pseg, code);
      if Pseg = null then
        go to INIT_ERROR;		/* Initiate the info segment.			*/
      Lseg = Dinfo_seg_.L;		/* Address all/only log info we are printing.	*/
      if Lseg = 0 then
        do;
	code = error_table_$zero_length_seg;
	go to INIT_ERROR;
        end;

      call help_rql_ (procedure_name, suffix, Phelp_args, i, Ninfos_printed, PDinfo_seg.N, Nlast_info_no_brief_data,
	 Nlast_info_cross_ref, PDinfo_seg_, Pseg, PDeps, Pquery_answers, PI_LABEL, Sprint_inhibit, code);
      if ^help_args.Sctl.inhibit_errors & code = error_table_$noentry then
        call error (help_args.sci_ptr, code, "^/Looking for entry point ^a in^/^5x^a", Dinfo_seg_.ep,
	   pathname_$component (Dinfo_seg_.dir, Dinfo_seg_.ent, ""));

NEXT_INFO:
    end;
EXIT_LOOP:
    if Ninfos_printed = 0 then	/* -section and -search didn't find any match.	*/
      Acode = error_table_$nomatch;
QUIT:
    call janitor ();
    return;

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


abort_help_subr:
  procedure;

    go to QUIT;

  end abort_help_subr;

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


error:
  procedure options (variable);

    dcl code	   fixed bin(35);
    dcl cu_$arg_list_ptr
		   entry returns (ptr),
        cu_$generate_call
		   entry (entry, ptr);
    dcl EMPTY_ARG_LIST fixed bin(71) int static options(constant) init(0);

    if help_args.Sctl.inhibit_errors then
        return;

    if help_args.sci_ptr = null then
        do;
        Sstandalone_invocation = TRUE;
        call ssu_$standalone_invocation (help_args.sci_ptr, procedure_name, ltrim (char (Vhelp_args_3)),
	   addr(EMPTY_ARG_LIST), abort_help_subr, code);
        if code ^= 0 then
	call com_err_ (code, procedure_name, "Calling ssu_$standalone_invocation.");
        end;

    if help_args.sci_ptr ^= null then
        call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ());

  end error;

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


evaluate_path:
  procedure (info_path, suffix);

    dcl 1 info_path	   aligned like help_args.path,
        suffix	   char (*);

    dcl i		   fixed bin;

    dcl check_star_name_$entry
		   entry (char (*), fixed bin (35)),
        expand_pathname_$add_suffix
		   entry (char (*), char (*), char (*), char (*), fixed bin (35));

    info_path.dir (1) = "";		/* Initialize to unset so caller can depend on	*/
    info_path.ent = "";		/* these values.				*/
    info_path.ep = "";
    info_path.S.less_greater = (search (info_path.value, "<>") > 0);
				/* see if user gave more than just an entryname.	*/
    i = index (reverse (info_path.value), "$");
				/* see if user gave a subr entry point name.	*/
    if info_path.S.less_greater then	/*   Must allow $ in entry names forming dir	*/
				/*   part of pathname.			*/
      if search (reverse (info_path.value), "<>") < i then
        i = 0;
    if i > 0 then			/* save entry point name given by user in his	*/
      info_path.ep = substr (info_path.value, length (info_path.value) - i + 2);
    else info_path.ep = "";		/*   pathname argument.			*/
    call expand_pathname_$add_suffix (substr (info_path.value, 1, length (info_path.value) - i), suffix, info_path.dir (1),
         info_path.ent, info_path.code);
    if info_path.code ^= 0 then	/* separate pathname into dir/ent parts, add info	*/
      return;			/*   suffix.				*/
    if info_path.S.pn_ctl_arg then	/* if -pn given, assume relative pathname follows	*/
      info_path.S.less_greater = TRUE;	/*   (Note we've already expanded path on this	*/
				/*    assumption.)				*/
    if info_path.info_name = "" then
      do;
        info_path.S.separate_info_name = FALSE;
				/* info_name usually = entryname w/o suffix.	*/
        if suffix = "" then
	info_path.info_name = info_path.ent;
        else info_path.info_name =
	        substr (info_path.ent, 1, 32 - length (suffix) - index (reverse (info_path.ent), reverse (suffix) || "."));
      end;
    else info_path.S.separate_info_name = TRUE;
    call check_star_name_$entry (info_path.ent, info_path.code);
    if info_path.code = 0 then
      do;				/* if no starname given, -ep ctl arg allowed.	*/
        info_path.S.starname_ent = FALSE;
        if help_args.Sctl.ep & info_path.ep = "" then
				/* Default ep name = entryname w/o suffix.	*/
	if suffix = "" then
	  info_path.ep = info_path.ent;
	else info_path.ep =
	  substr (info_path.ent, 1, 32 - length (suffix) - index (reverse (info_path.ent), reverse (suffix) || "."));
      end;
    else if info_path.code = 1 |	/* forbid -ep if starname was given.		*/
         info_path.code = 2 then
      do;
        info_path.code = 0;
        info_path.S.starname_ent = TRUE;
        if help_args.Sctl.ep | (info_path.ep ^= "") then
	info_path.code = error_table_$inconsistent;
      end;

    if info_path.code ^= 0 then
      return;
    if info_path.S.separate_info_name then
      do;				/* Check star-ness of user-supplied info_name.	*/
        if info_path.S.info_name_not_starname then
	info_path.S.starname_info_name = FALSE;
        else
	do;
	  call check_star_name_$entry (info_path.info_name, info_path.code);
	  if info_path.code = 1 | info_path.code = 2 then
	    do;
	      info_path.code = 0;
	      info_path.S.starname_info_name = TRUE;
	    end;
	  else info_path.S.starname_info_name = FALSE;
	end;
      end;
    else info_path.S.starname_info_name = info_path.S.starname_ent;

  end evaluate_path;

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


get_info_seg_list:
  procedure (procedure_name, suffix, fcn, dirs, info_path, PDinfo_) options (non_quick);
				/* non_quick so that the large area won't stay around	*/
				/*   all the while help active and take up stack frame	*/
				/*   space.					*/

    dcl procedure_name char (*),
        suffix	   char (*),
        fcn	   fixed bin,
        dirs	   (*) char (168) unaligned,
        1 info_path	   aligned like help_args.path,
        PDinfo_	   ptr;

    dcl I		   fixed bin,
        Lline	   fixed bin,
        Lseg	   fixed bin (21),
        Nstart	   fixed bin,
        Pseg	   ptr,
        Ptemp	   ptr,
        area	   area (25000) init (empty ()),
        code	   fixed bin (35),
        (i, j, k)	   fixed bin,
        l		   fixed bin (21),
        line	   char (Lline) based (Pseg),
        linfo_name	   char (32),	/* info name without the suffix.		*/
        sinfo_name	   char (32),	/* info name with the suffix.			*/
        saved_date	   fixed bin (71);

    dcl 1 Dinfo_	   aligned based (PDinfo_),
	2 N	   fixed bin,
	2 seg	   (0 refer (Dinfo_.N)) like Dinfo_seg;

    dcl seg	   char (Lseg) based (Pseg),
				/* The info segment.  Pseg must be declared in	*/
				/* the external procedure so its on unit	*/
				/* (janitor) can terminate the segment.		*/
        seg_char	   (Lseg) char (1) based (Pseg);

    dcl hcs_$star_dir_list_
		   entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)),
        hcs_$status_long
		   entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));

    Nstart = Dinfo_.N;		/* Remember count of info segs found before we	*/
				/*   start.  Then we'll know if we find any.	*/
    do i = lbound (dirs, 1) to hbound (dirs, 1);
				/* Apply info path to each dir to be searched.	*/
      star_select_sw = star_ALL_ENTRIES;
      call hcs_$star_dir_list_ (dirs (i), info_path.ent, star_select_sw, addr (area), star_branch_count, star_link_count,
	 star_list_branch_ptr, star_list_names_ptr, code);
      if code = 0 then
        do;
	do j = 1 to star_branch_count + star_link_count;
				/* process entries found in this directory.	*/
	  k, Dinfo_.N = Dinfo_.N + 1;
	  Dinfo_.seg (k).Scross_ref = FALSE;
	  Dinfo_.seg (k).dir = dirs (i);
	  Dinfo_.seg (k).ent = star_list_names (star_dir_list_branch (j).nindex);
	  Dinfo_.seg (k).info_name = "";
	  Dinfo_.seg (k).ep = info_path.ep;
	  Dinfo_.seg (k).E = info_path.ep;
	  Dinfo_.seg (k).segment_type = star_dir_list_branch (j).type;

/* Process each entry according to its type.	*/
	  if star_dir_list_branch (j).type = star_SEGMENT then
	    do;
	      Dinfo_.seg (k).L = divide (star_dir_list_branch (j).bit_count, 9, 24, 0);
	      Dinfo_.seg (k).date = numeric_date (star_dir_list_branch (j).dtem);
	      Dinfo_.seg (k).mode = substr (star_dir_list_branch (j).mode, 2, 3);
				/* extract "rew" mode bits from "trewa".			*/
	      Dinfo_.seg (k).code = 0;
	      if Dinfo_.seg (k).L = 0 then
	        Dinfo_.seg (k).code = error_table_$zero_length_seg;
	      else if star_dir_list_branch (j).bit_count - 9 * Dinfo_.seg (k).L > 0 then
	        Dinfo_.seg (k).code = error_table_$badsyntax;
	    end;
	  else if star_dir_list_branch (j).type = star_LINK then
	    do;			/* Links must be chased, and target examined.	*/
	      call hcs_$status_long (Dinfo_.seg (k).dir, Dinfo_.seg (k).ent, 1, addr (branch), null (), code);
	      if (code = 0) | (code = error_table_$no_s_permission) then
	        do;
		if branch.type = Segment then
		  do;
		    Dinfo_.seg (k).L = divide (binary (branch.bit_count, 24), 9, 24, 0);
		    Dinfo_.seg (k).date = numeric_date (branch.dtem);
		    Dinfo_.seg (k).mode = substr (branch.mode, 2, 3);
		    Dinfo_.seg (k).code = 0;
		    if Dinfo_.seg (k).L = 0 then
		      Dinfo_.seg (k).code = error_table_$zero_length_seg;
		    else if binary (branch.bit_count, 24) - 9 * Dinfo_.seg (k).L > 0 then
		      Dinfo_.seg (k).code = error_table_$badsyntax;
		  end;
		else if branch.type = Link then
		  do;
		    Dinfo_.seg (k).L = 0;
		    Dinfo_.seg (k).date = 0;
		    Dinfo_.seg (k).mode = "0"b;
		    Dinfo_.seg (k).code = error_table_$noentry;
		  end;
		else
		  do;		/* Skip matching directories.			*/
		    Dinfo_.N = Dinfo_.N - 1;
		    go to SKIP_ENTRY;
				/*   Forget everything we've done for this entry.	*/
		  end;
	        end;
	      else
	        do;		/* Don't have access to the link target.	*/
		Dinfo_.seg (k).L = 0;
		Dinfo_.seg (k).date = 0;
		Dinfo_.seg (k).mode = "0"b;
		Dinfo_.seg (k).code = code;
	        end;
	    end;
	  else
	    do;			/* Skip matching directories.			*/
	      Dinfo_.N = Dinfo_.N - 1;
	      go to SKIP_ENTRY;
	    end;
	  if Dinfo_.seg (k).code = 0 then
	    if (Dinfo_.seg (k).mode & "100"b) then
	      if help_args.min_date_time ^< Dinfo_.seg (k).date then
	        Dinfo_.N = Dinfo_.N - 1;
	      else ;
	    else Dinfo_.seg (k).code = error_table_$moderr;
				/* report error if user can't access info seg.	*/
SKIP_ENTRY:
	end;

	free star_list_names in (area),
				/* free found entry structures.		*/
	     star_dir_list_branch in (area);
        end;

      else if (code = error_table_$incorrect_access | code = error_table_$no_info) & ^info_path.S.starname_ent then
        do;			/* If user does not have "s" permission to dir,	*/
				/* look for a specific help seg.		*/
	call hcs_$status_long (dirs (i), info_path.ent, 1, addr (branch), null (), code);
	if (code = error_table_$no_s_permission) | (code = 0) then
	  do;
	    if branch.type ^= Directory then
	      do;
	        k, Dinfo_.N = Dinfo_.N + 1;
	        Dinfo_.seg (k).Scross_ref = FALSE;
	        Dinfo_.seg (k).dir = dirs (i);
	        Dinfo_.seg (k).ent = info_path.ent;
	        Dinfo_.seg (k).info_name = "";
	        Dinfo_.seg (k).ep = info_path.ep;
	        Dinfo_.seg (k).E = info_path.ep;
	        Dinfo_.seg (k).segment_type = branch.type;
	        if branch.type = Segment then
		do;
		  Dinfo_.seg (k).L = divide (binary (branch.bit_count, 24), 9, 24, 0);
		  Dinfo_.seg (k).date = numeric_date (branch.dtem);
		  Dinfo_.seg (k).mode = substr (branch.mode, 2, 3);
		  if Dinfo_.seg (k).mode & "100"b then
		    Dinfo_.seg (k).code = 0;
		  else Dinfo_.seg (k).code = error_table_$moderr;
		  if Dinfo_.seg (k).L = 0 then
		    Dinfo_.seg (k).code = error_table_$zero_length_seg;
		  else if binary (branch.bit_count, 24) - 9 * Dinfo_.seg (k).L > 0 then
		    Dinfo_.seg (k).code = error_table_$badsyntax;
		  else if code = 0 then
		    if help_args.min_date_time ^< Dinfo_.seg (k).date then
		      Dinfo_.N = Dinfo_.N - 1;
		end;
	        else
		do;		/* Give error for link target being a link.	*/
		  Dinfo_.seg (k).L = 0;
		  Dinfo_.seg (k).date = 0;
		  Dinfo_.seg (k).mode = "0"b;
		  Dinfo_.seg (k).code = error_table_$noentry;
		end;
	      end;
	  end;
	else if code = error_table_$noentry then
	  ;
	else go to DIR_ERROR;
        end;
      else if code = error_table_$nomatch then
        ;
      else
        do;			/* Fatal error looking in this dir.		*/
DIR_ERROR:
	call error (help_args.sci_ptr, code, "^/Looking for info segments in ^a.", dirs (i));
	if dim (dirs, 1) = 1 then
	  return;			/* Avoid getting nomatch error in addition to 	*/
        end;			/* this one when only 1 dir to look into.	*/
    end;

    if fcn = CIS then
      do;
        do i = Nstart + 1 to Dinfo_.N;
	if Dinfo_.seg (i).code ^= 0 then
	  do;
	    Dinfo_.seg (i).uid = "0"b;
	    Dinfo_.seg (i).I = 0;
	    Dinfo_.seg (i).E = "";
	  end;
        end;
        return;
      end;
    else if Dinfo_.N = Nstart then
      do;
        if info_path.S.starname_ent then
	code = error_table_$nomatch;
        else code = error_table_$noentry;
        call error (help_args.sci_ptr, code, "^[-pn ^]^a", info_path.S.pn_ctl_arg, info_path.value);
      end;
    else
      do i = Nstart + 1 to Dinfo_.N;	/* Look for :Info: info dividers.		*/
        if Dinfo_.seg (i).code = 0 then
	do;
	  Dinfo_.seg (i).uid = "0"b;	/* We don't know seg's uid yet.		*/
	  call initiate (Dinfo_.seg (i).dir, Dinfo_.seg (i).ent, Dinfo_.seg (i).uid, Pseg, code);
	  if Pseg ^= null then
	    do;
	      Lseg = Dinfo_.seg (i).L;
	      Dinfo_.seg (i).I = 1;	/* Fill in substring index of 1st		*/
				/* char of physical info seg.			*/
	      I = verify (seg, "	 
");
	      if I > 1 then
	        do;		/* Strip HT SP NL from start of info seg.	*/
		Pseg = addr (seg_char (I));
		Lseg = Lseg - (I - 1);
	        end;
	      if Lseg > 8 then	/* See if info seg begins with :Info:		*/
				/*   (8 = length(":Info:C:"), C is any char.	*/
	        if substr (seg, 1, 6) = ":Info:" | substr (seg, 1, 10) = ":Internal:" then
		do;		/* Internal is for help vis			*/
		  if substr (seg, 1, 6) = ":Info:" then
		    do;
		      Pseg = addr (seg_char (7));
		      Lseg = Lseg - 6;
		    end;
		  else
		    do;
		      Pseg = addr (seg_char (11));
		      Lseg = Lseg - 10;
		    end;
		  k = i;
		  Dinfo_.seg (k).info_name = info_path.info_name;
				/* save info_name used to find infos for use in	*/
				/* error messages  (without suffix).		*/
		  saved_date = Dinfo_.seg (k).date;
				/* save date assoc with phys info seg in case	*/
				/* some log. infos don't have date in their header*/
		end;
	        else Lseg, k = 0;
	      else Lseg, k = 0;

	      do while (Lseg > 0);	/* It does contain :Info:.  Look for info(s)	*/
	        Lline = index (seg, NL);
				/* which match user-supplied entryname.		*/
	        if Lline = 0 then
		Lline = Lseg;
	        linfo_name = find_info_name (line, I);
	        do while (I > 0);
		if info_path.S.starname_info_name then
		  do;
		    call match_star_name_ (linfo_name, info_path.info_name, code);
		    if code ^= 0 then
		      go to NO_MATCH;
		  end;
		else if linfo_name ^= info_path.info_name then
		  go to NO_MATCH;

		if ^info_path.S.separate_info_name then
		  do;		/* POTENTIAL BUG:  Use of assoc. memory for 	*/
				/* initiated segs may subvert test to see if 	*/
				/* info_name really a name on phys. info seg.	*/
				/* Subsequent attempt to reinitiate may succeed 	*/
				/* by uid found in assoc mem, rather than by name	*/
				/* being found on phys. info seg.		*/
		    if suffix ^= "" then
		      sinfo_name = rtrim (linfo_name) || "." || suffix;
		    else sinfo_name = linfo_name;

/* Test now to see if log info_name is on seg.	*/
		    if info_path.S.starname_ent then
		      do;
		        call hcs_$initiate (Dinfo_.seg (k).dir, sinfo_name, "", 0, 0, Ptemp, code);
		        if Ptemp = null then
			go to NO_MATCH;
		      end;
		    Dinfo_.seg (k).ent = sinfo_name;
		  end;		/* This info matches.  Include it in output list.	*/
		j = Lline - index (reverse (line), ":") + 2;
		Dinfo_.seg (k).I = rel_char (addr (seg_char (j))) + 1;
				/* get index of first char of this info.	*/
				/* 1 is added to the char offset returned by 	*/
				/* rel_char to get a char index.		*/
		l = index (seg, "


:Info:");				/* get info length by finding next info.	*/
		if l = 0 then	/* need for help vis			*/
		  l = index (seg, "


:Internal:");			/* get info length by finding next info.	*/
		if l > 0 then
		  Dinfo_.seg (k).L = l - (j - 1);
		else Dinfo_.seg (k).L = Lseg - (j - 1);
		Pseg = addr (seg_char (j));
		Lseg = Lseg - (j - 1);
		Lline = Lline - (j - 1);
		j = verify (seg, "	 
");
		if j > 1 then
		  do;		/* Remove leading HT SP NL from log info.	*/
		    Pseg = addr (seg_char (j));
		    Lseg = Lseg - (j - 1);
		    Lline = index (seg, NL);
		    if Lline = 0 then
		      Lline = Lseg;
		  end;
		if Lseg >= Lline + 1 then
				/* Store date assoc with log info.		*/
		  if seg_char (Lline + 1) = NL then
		    do;		/* Date comes from 1st field of heading line of	*/
				/* log info, which must be followed by blank line.*/
		      Lline = Lline - 1;
		      j = search (line, "	 ");
		      if j = 0 then
		        j = Lline;
		      else
		        do;
			call convert_date_to_binary_ (substr (line, 1, j), Dinfo_.seg (k).date, code);
			if code ^= 0 then
			  Dinfo_.seg (k).date = saved_date;
		        end;
		    end;
		  else Dinfo_.seg (k).date = saved_date;
		else Dinfo_.seg (k).date = saved_date;
		I = 0;		/* Stop processing this :Info: line (this info).	*/
		if ^(info_path.S.starname_info_name | info_path.S.separate_info_name) then
		  Lseg = 0;	/* If not a starname or separate info_name, 	*/
				/* we've found one & only matching log. info	*/
		if help_args.min_date_time ^< Dinfo_.seg (k).date then
		  go to MATCH;	/* Info modified before min date; skip it	*/
		Dinfo_.seg (k).info_name = linfo_name;
				/* Save info_name for use in headings.		*/
		k, Dinfo_.N = Dinfo_.N + 1;
		Dinfo_.seg (k) = Dinfo_.seg (i);
		go to MATCH;

NO_MATCH:
		Pseg = addr (seg_char (I + 1));
		Lseg = Lseg - I;	/* Look for another name on this info, since	*/
		Lline = Lline - I;	/* previous names on it don't match user wants.	*/
		linfo_name = find_info_name (line, I);
MATCH:
	        end;

	        I = index (seg, "


:Info:");
	        if I > 0 then
		do;
		  Pseg = addr (seg_char (I + 9));
		  Lseg = Lseg - (I + 8);
		end;
	        else
		do;		/* need for help vis			*/
		  I = index (seg, "


:Internal:");
		  if I > 0 then
		    do;
		      Pseg = addr (seg_char (I + 13));
		      Lseg = Lseg - (I + 10);
		    end;
		  else Lseg = 0;
		end;
	      end;
	      if k = 0 then
	        ;			/* No :Info: in phys info seg.		*/
	      else if k = i then	/* No matching info in phys info seg.		*/
	        if info_path.S.starname_info_name then
		Dinfo_.seg (i).code = error_table_$nomatch;
	        else Dinfo_.seg (i).code = error_table_$noentry;
	      else Dinfo_.N = Dinfo_.N - 1;
				/* Matching info found.  We always get one more	*/
				/* Dinfo_.seg than we can use.		*/
	    end;
	  else Dinfo_.seg (i).code = code;
				/* Failed to initiate physical info seg.	*/
	end;
        if Dinfo_.seg (i).code ^= 0 then
	do;
	  Dinfo_.seg (i).uid = "0"b;	/* If error occurred during processing, mark	*/
	  Dinfo_.seg (i).I = 0;	/* info to cause error message to be printed.	*/
	  Dinfo_.seg (i).E = "";
	end;
      end;

find_info_name:
  proc (Aline, Iline) returns (char (32));

    dcl Aline	   char (*),	/* unprocessed part of :Info: line (incl NL).	*/
        Iline	   fixed bin,	/* amount processed while finding this info name. */
        info_name	   char (32) varying;
				/* the info_name which was found.		*/

    dcl (Icolon, Inon_space, Iquote, Iquote_quote)
		   fixed bin,
        Lline	   fixed bin,
        Pline	   ptr;

    dcl (
        QUOTE	   char (1) init (""""),
        QUOTE_QUOTE	   char (2) init ("""""")
        )		   int static options (constant);

    dcl line	   char (Lline) based (Pline),
        line_char	   (Lline) char (1) based (Pline);

    Pline = addr (Aline);
    Lline = length (Aline);
    Inon_space = verify (line, HT_SP);	/* Remove leading white space from info name.	*/
    if Inon_space > 1 then
      do;
        Pline = addr (line_char (Inon_space));
        Lline = Lline - (Inon_space - 1);
      end;
    else if Inon_space = 0 then
      do;				/* Remainder of line is empty.		*/
ERROR:
        Iline = length (Aline);
        return ("");
      end;

    if line_char (1) = QUOTE then
      do;				/* Look for quoted info name.			*/
        Pline = addr (line_char (length (QUOTE) + 1));
				/*   Skip the opening quote.			*/
        Lline = Lline - length (QUOTE);
        Iquote = index (line, QUOTE);	/*   Search for trailing quote.		*/
        if Iquote = 0 | Iquote + 2 > Lline then
				/*   Trailing quote is missing.		*/
	go to ERROR;
        Iquote_quote = index (line, QUOTE_QUOTE);
				/*   Check for doubled quotes.		*/
        if Iquote ^= Iquote_quote then	/*   There are none.			*/
	info_name = substr (line, 1, Iquote - 1);
        else
	do;			/*   Doubled quotes must be undoubled in info name*/
	  info_name = "";
	  do while (Iquote = Iquote_quote);
	    info_name = info_name || substr (line, 1, Iquote);
	    Pline = addr (line_char (Iquote + length (QUOTE_QUOTE)));
	    Lline = Lline - (Iquote + length (QUOTE_QUOTE) - 1);
	    Iquote = index (line, QUOTE);
	    if Iquote = 0 | Iquote + 2 > Lline then
	      go to ERROR;
	    Iquote_quote = index (line, QUOTE_QUOTE);
	  end;
	  info_name = info_name || substr (line, 1, Iquote - 1);
	end;
        Pline = addr (line_char (Iquote + length (QUOTE)));
        Lline = Lline - (Iquote + length (QUOTE) - 1);
        Inon_space = verify (line, HT_SP);
				/* Remove trailing white space.		*/
        if Inon_space > 1 then
	do;
	  Pline = addr (line_char (Inon_space));
	  Lline = Lline - (Inon_space - 1);
	end;
        else if Inon_space = 0 then
	go to ERROR;		/* No trailing colon.  Skip last name.		*/
        if line_char (1) = ":" then	/* info name found in correct format.		*/
	Iline = length (Aline) - (Lline - 1);
        else go to ERROR;		/* No trailing colon.  That's bad;		*/
      end;
    else
      do;				/* Info name is not quoted.			*/
        Icolon = index (line, ":");
        if Icolon = 0 then
	go to ERROR;		/*   No trailing colon.			*/
        info_name = rtrim (substr (line, 1, Icolon - 1));
        Iline = length (Aline) - (Lline - Icolon);
      end;
    return (info_name);

  end find_info_name;

%include star_structures;

%include status_structures;

    dcl 1 branch	   aligned like status_branch;

  end get_info_seg_list;

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


initiate:
  procedure (dir, ent, uid, Pseg, code);/* Provide an associative memory for info segs	*/
				/* to reduce amt. of double initiating each seg.	*/

    dcl dir	   char (168) unal,
        ent	   char (32) unal,
        uid	   bit (36) aligned,
        Pseg	   ptr,
        code	   fixed bin (35);

    dcl i		   fixed bin;
    dcl Iempty	   fixed bin;

    Iempty = 0;			/* No empty slots in assoc. mem so far.		*/
    code = 0;
    Pseg = null;
    do i = 1 to init_assoc_mem.N while (Pseg = null);
				/* Look for seg to be initiated in assoc. mem.	*/
      if init_assoc_mem.seg (i).uid ^= "0"b then
        do;			/*   Zero uid?  No, we must check the cell.	*/
	if uid ^= "0"b then		/*   Can't check if we don't know segs uid.	*/
	  if uid = init_assoc_mem.seg (i).uid then
	    Pseg = init_assoc_mem.seg (i).P;
				/*   Found seg in assoc mem. Got off cheap!	*/
	  else ;
	else if dir = init_assoc_mem.seg (i).dir & ent = init_assoc_mem.seg (i).ent then
	  do;			/*   Check segs dir/ent with assoc mem.		*/
	    uid = init_assoc_mem.seg (i).uid;
	    Pseg = init_assoc_mem.seg (i).P;
	  end;
        end;
      else if Iempty = 0 then		/* Remember first empty cell in  case seg not	*/
        Iempty = i;			/* found in assoc. mem.			*/
    end;
    if Pseg ^= null then
      return;			/* See found in assoc. All done!		*/

    call hcs_$initiate (dir, ent, "", 0, 0, Pseg, code);
    if Pseg = null then
      return;			/* Have to initiate the segment.		*/
    call hcs_$get_uid_seg (Pseg, uid, code);
				/* Complain if error.  Otherwise, get seg's uid.	*/
    do i = 1 to init_assoc_mem.N while (init_assoc_mem.seg (i).uid ^= uid);
    end;				/* make sure uid doesn't appear in assoc memory	*/
    if i <= init_assoc_mem.N then
      return;			/* under another name.  If so, don't add again.	*/
    if Iempty = 0 then		/* If no empty cells, must make one.		*/
      if init_assoc_mem.N < dimension (init_assoc_mem.seg, 1) then
        do;
	init_assoc_mem.N = init_assoc_mem.N + 1;
	Iempty = init_assoc_mem.N;	/* Add new cell to the table, if room.		*/
        end;
      else
        do;			/* Must terminate cell member to make room for new*/
	Iempty = init_assoc_mem.N;	/* seg in assoc. mem.			*/
	call hcs_$terminate_noname (init_assoc_mem.seg (Iempty).P, code);
        end;
    init_assoc_mem.seg (Iempty).dir = dir;
    init_assoc_mem.seg (Iempty).ent = ent;
    init_assoc_mem.seg (Iempty).uid = uid;
    init_assoc_mem.seg (Iempty).P = Pseg;

  end initiate;

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


janitor:
  procedure;			/* terminate known info segs;  truncate temp seg.	*/

    call term_assoc_mem ();
    call hcs_$truncate_seg (Phelp_args, currentsize (help_args), 0);

    if Sstandalone_invocation then
      if help_args.sci_ptr ^= null then
        do;
	call ssu_$destroy_invocation (help_args.sci_ptr);
	help_args.sci_ptr = null;
        end;

    if Pquery_answers ^= null then
      call release_temp_segment_ (procedure_name, Pquery_answers, code);

  end janitor;

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


numeric_date:
  procedure (bit_date) returns (fixed bin (71));
				/* This procedure converts a file system date	*/
				/* to a numeric clock value.  A file system date	*/
				/* is the high-order 36 bits of a 52 bit clock	*/
				/* value.					*/

    dcl bit_date	   bit (36) unal,
        num_date	   fixed bin (71);


    num_date = 0;
    substr (unspec (num_date), 21, 36) = bit_date;
    return (num_date);

  end numeric_date;

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


rel_char:
  proc (P) returns (fixed bin (21));	/* This procedure converts a pointer value into	*/
				/* a character offset from base of segment	*/
				/* pointed to.  We need a PL/I bif to do this.	*/
    dcl P		   ptr;

    dcl I		   fixed bin (21),
        P1	   ptr,
        i		   fixed bin;

    dcl char_offset	   (0:3) char (1) based (P1);

    P1 = ptr (P, rel (P));
    I = 4 * binary (rel (P));
    do i = 0 to 3 while (addr (char_offset (i)) ^= P);
    end;
    I = I + i;
    return (I);

  end rel_char;

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


set_space_used:
  procedure (Pcurrent_space, size_current_space) returns (ptr);
				/* This procedure returns pointer to next free	*/
				/* word of storage in help_args temp segment.	*/
    dcl Pcurrent_space ptr,		/* ptr to last space allocated in the seg.	*/
        size_current_space
		   fixed bin (21),	/* amount of space used in structure last alloc.	*/
        Pnext_space	   ptr;		/* ptr to next free space.			*/

    Pnext_space = addrel (Pcurrent_space, size_current_space + mod (size_current_space, 2));
    return (Pnext_space);

  end set_space_used;

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


term_assoc_mem:
  procedure;			/* terminate known info segs.			*/

    do init_assoc_mem.N = init_assoc_mem.N to 1 by -1;
      if init_assoc_mem.seg (init_assoc_mem.N).uid ^= "0"b then
        call hcs_$terminate_noname (init_assoc_mem.seg (init_assoc_mem.N).P, 0);
    end;
  end term_assoc_mem;

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


init:
  entry (procedure_name, search_list_name, search_list_ref_dir, Vrequired, Phelp_args, Acode);

    dcl search_list_name
		   char (*),	/* Name of search list used in finding infos.	*/
				/*   (input)				*/
        search_list_ref_dir
		   char (*),	/* Referencing dir used in  search rules.	*/
				/*   (input)				*/
        Vrequired	   fixed bin;	/* Required version of help_args structure.	*/
				/*   (input)				*/

    dcl Parea	   ptr,
        area	   area (25000) based (Parea);

    if Vrequired ^= Vhelp_args_3 & Vrequired ^= 2 & Vrequired ^= 1 then
      do;
        Acode = error_table_$unimplemented_version;
        return;
      end;
    call get_temp_segment_ (procedure_name, Phelp_args, Acode);
    if Acode ^= 0 then		/* Obtain a temporary segment.		*/
      Phelp_args = null;
    else
      do;
        help_args.version = Vrequired;	/* Initialize the help argument structure.	*/
        help_args.help_data_ptr = null;
        help_args.sci_ptr = null;
        string (help_args.Sctl) = "0"b;
        help_args.min_Lpgh = 4;
        help_args.max_Lpgh = 15;
        help_args.Lspace_between_infos = 2;
        help_args.min_date_time = -1;
        help_args.Npaths = 0;
        help_args.Ncas = 0;
        help_args.Nsrhs = 0;
        if search_list_name ^= "" then
	do;
	  help_args.Nsearch_dirs = 1000;
				/* Allow room for up to 1000 search dirs.	*/
	  Parea = set_space_used (Phelp_args, currentsize (help_args));
	  area = empty ();
	  call search_paths_$get (search_list_name, sl_control_default, search_list_ref_dir, null, Parea, sl_info_version_1,
	       sl_info_p, Acode);
	  if Acode = 0 then
	    do;
	      help_args.Nsearch_dirs = sl_info.num_paths;
	      if help_args.Nsearch_dirs > 0 then
	        help_args.search_dirs (*) = sl_info.paths (*).pathname;
	    end;
	  else help_args.Nsearch_dirs = 0;
	end;
        else help_args.Nsearch_dirs = 0;
        call hcs_$truncate_seg (Phelp_args, currentsize (help_args), 0);
      end;
    return;


%include sl_info;

%include sl_control_s;

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


term:
  entry (procedure_name, Phelp_args, Acode);

    if Phelp_args ^= null then
      do;
        if unspec(help_args.help_data_ptr) = ""b then;	/* check for case where interruption	  */
						/*  occurred before help_$init could	  */
						/*  complete its initialization of	  */
						/*  the help_args structure.  Otherwise,  */
						/*  the reference to help_data_ptr could  */
						/*  cause a seg_fault referencing dseg	  */
						/*  (segment 0|0).			  */
        else if help_args.help_data_ptr ^= null then
           call help_$term (procedure_name, help_args.help_data_ptr, Acode);
        call release_temp_segment_ (procedure_name, Phelp_args, Acode);
      end;
    
    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include arg_list;

%include help_args_;

%include help_cis_args_;

    dcl 1 Dinfo_seg_   aligned like Dinfo_seg based (PDinfo_seg_),
        PDinfo_seg_	   ptr;

  end help_;




		    help_rql_.pl1                   09/13/88  1348.5rew 09/13/88  1310.6     1544436



/****^  ***********************************************************
        *                                                         *
        * 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(86-04-17,LJAdams), approve(86-04-17,MCR7327),
     audit(86-04-17,Lippard), install(86-04-24,MR12.0-1048):
     First installation of new module.
  2) change(86-04-24,LJAdams), approve(86-04-17,MCR7327),
     audit(86-04-25,Gilcrease), install(86-04-25,MR12.0-1049):
     PBF to Installation ID 1048.  Put heading on info seg
     display only if there are multiple info segs with
     the same name.
  3) change(86-05-08,LJAdams), approve(86-05-14,MCR7416),
     audit(86-05-28,Gilcrease), install(86-06-12,MR12.0-1074):
     Changed the algorithm in get_title_list to split lines properly.  For
     subroutine info segments, if -bf is requested, print a message indicating
     that no brief information is available and ask the user if detail info is
     wanted.  If the answer is no return to command level, if the answer is
     yes print the introductory paragraph.
  4) change(86-07-24,LJAdams), approve(86-07-31,MCR7506),
     audit(86-10-29,GDixon), install(86-10-30,MR12.0-1203):
     Fixed problem with help -title improperly displaying lines.
     
     Fixed problem with entry point lists not being displayed in groups of
     15 (format_list Mpgs = 1 then list.Npghs = 1).
     
     Fixed problem with extra blank line being displayed on More help? line.
     
     If ep foo$bar has been requested help will now immediately begin printing
     the ep description without first asking the user if he wants to see it.
     (phx0717)
     
     Fixed problem that typing scn with no arguments would remain at the same
     section instead of searching for the next match. (phx09952, phx06043)
     
     help -search will now include the section titles in the text being
     searched.
     
     help time_format.gi.info -bf should work (phx18720).
  5) change(87-01-06,LJAdams), approve(87-01-06,PBF7506),
     audit(87-01-06,GDixon), install(87-01-07,MR12.0-1262):
     Fixed problem in format_list that when the max array bounds had been met
     and more data still needed to be formatted the remaining data was
     ignored.  Array bounds are now being recomputed in this situation.
  6) change(87-01-19,LJAdams), approve(87-09-03,MCR7766),
     audit(88-09-03,GDixon), install(88-09-13,MR12.2-1109):
     Fixed problem with -bf not properly display List of... lines that started
     with a 1 or 2.
     
     Added to the rest response -all_entrypoints (-aep) which will print the
     rest of the remaining entrypoints. (phx05455, phx11988)
     
     The total length of entrypoints (:Entry:) was being miscalculated by one
     character.
     
     Added a -case_sensitive (-cs) and -non_case_sensitive (-ncs) to the
     section and search requests.  (phx09975)
     
     Added the -list_entry_points (lep) argument/response.
     (phx02785, phx03662, phx05841, phx08613)
     
     Added the list_requests (lr) option to help.
     
     Changed version to Vhelp_args_3.
  7) change(88-02-17,LJAdams), approve(88-03-07,MCR7857),
     audit(88-09-03,GDixon), install(88-09-13,MR12.2-1109):	
     Changed to use the help_args.help_data_ptr which points to a second
     help_args structure that is used for the list_request operation.
     
     format_list was improperly formatting data if the terminal had a
     line length set to >80.  Lengthened line buffer to
     MAX_HELP_LINE_SIZE.
                                                   END HISTORY COMMENTS */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Name:  help_rql_								*/
/*									*/
/* This subroutine implements the help command's request loop.			*/
/*									*/
/* Status									*/
/*									*/
/* 0) Created:  June 1983 by G C Dixon - by dividing help_ into subroutines.		*/
/* 1) Modified: April 1985 by L. Adams - rewrote parsing routines to
                       */
/*              use line logic.                                                           */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* format: style2,ind2,ll131,dclind4,idind15,comcol41,linecom,ifthen */
help_rql_:
  procedure (procedure_name, suffix, Phelp_args, Iinfo, Ninfos_printed, Ninfos, Nlast_info_no_brief_data, 
       Nlast_info_cross_ref, PDinfo_seg_, APseg, PDeps, Pquery_answers, PI_LABEL, Sprint_inhibit, Acode);

    dcl procedure_name char (*),
        suffix	   char (*),
        Iinfo	   fixed bin,	/* Number of the info being processed.		*/
        Ninfos_printed fixed bin,	/* Number of infos for which something has printed*/
        Ninfos	   fixed bin (24),	/* Number of infos handled during this invocation	*/
        Nlast_info_no_brief_data
		   fixed bin,	/* Last info processed not containing Syntax sect.*/
        Nlast_info_cross_ref
		   fixed bin,	/* Last info processed with Scross_ref on.	*/
				/* as diagnosed by get_brief_data.		*/
        PDinfo_seg_	   ptr,		/* ptr to structure describing the info.	*/
        APseg	   ptr,		/* ptr to base of seg containing the info.	*/
        PDeps	   ptr,		/* ptr to Deps structure.			*/
        Pquery_answers ptr,		/* ptr to list of allowed responses.		*/
        PI_LABEL	   label variable,	/* label to go to upon program interrupt.	*/
        Sprint_inhibit bit (1) aligned,
        Acode	   fixed bin (35);

    dcl Iep	   fixed bin,	/* subscript of current entry point or info	*/
				/*   (logical info segment) being processed.	*/
        Iunit	   fixed bin,	/* subscript of current unit (paragraph).	*/
        Iunit_end	   fixed bin,
        Iunit_search   fixed bin,	/* searching begins with this unit.		*/
        Iunit_syntax   (10) fixed bin,	/* indices of syntax units.			*/
        Lcount	   fixed bin,
        Linfo_name	   fixed bin,
        list_of	   bit (1),	/* indicates if list is a list of items           */
        Loutput	   fixed bin,
        Loutput_line   fixed bin,	/* Length of terminal user's output line.	*/
        Lpgh	   fixed bin,
        Lseg	   fixed bin (21),
        (Ncommon_units, Nconsecutive_bad_ops, Nuncommon_units, Nprint_units)
		   fixed bin,
        (Nlines, Nlines_titles)
		   fixed bin,
        (Nlists_of_args, Nlists_of_bf_args)
		   fixed bin,
        No_list_elements		/* number of list elements in the entry point list*/
		   fixed bin,
        Nep_pghs	   fixed bin,	/* number of pghs in entry point list		*/
        Nunit_bf_prt   fixed bin,	/* number of brief units to print.		*/
        (Plist, Plist_of_titles, Plist_of_cas)
		   ptr,
        Pcommon_units  ptr,
        PDlinfo	   ptr,
        Pep_list	   ptr,		/* ptr to the entry point list		*/
        Plist_base	   ptr,
        Plists_of_args (18) ptr,
        Pnext_free_space
		   ptr,		/* ptr to next free word location in temp	*/
				/*   seg containing help_args.		*/
        Poutput	   ptr,
        Ppgh	   ptr,
        Pseg	   ptr,
        save_title	   char (80) varying,
        Scase_sensitive
		   bit (1),
        Sdescription_present
		   bit (1),
        Sep_list_printed
		   bit (1),
        Sfirst_time	   bit (1),
        Sfirst_pgh	   bit (1),
        Sfound	   bit (1) aligned,
        Sremove_line   bit (1),
        Syntax_section bit (1),
        Sprt_args	   bit (1),
        Sprt_bf_heading
		   bit (1),
        Sprt_list_of   bit (1),
        Sprt_entry_pts bit (1),
        Sprt_one_paragraph
		   bit (1),
        Sloop	   bit (1) aligned,
        (Snl1, Snl2)   bit (1) aligned, /* Switches used to compute if NL should be output.*/
        ISnl3	   fixed bin,
        Ssearch	   bit (1) aligned, /* on if -section/-search searching to be done.	*/
        Sseen	   bit (1) aligned, /* on if pgh already seen by user.		*/
        answer	   char (500) varying,
        code	   fixed bin (35),
        ct_lines	   fixed bin,
        ep_name	   char (65) varying,
        (i, j)	   fixed bin,
        match_result   fixed bin,
        new_section	   char (88) varying,
				/* title of new section in which match pgh found	*/
        op	   fixed bin,
        query	   char (200) varying,
        query_type	   fixed bin,
        ref_name	   char (32) varying,
		        yes_sw	   bit (1);


    dcl 1 Deps	   aligned based (PDeps),
				/* structure defining all entry points in log info*/
	2 Nlines	   fixed bin,	/*   number of lines in log info.		*/
	2 N	   fixed bin,	/*   total number of entry points in log info.	*/
	2 linfo	   (0:0 refer (Deps.N)),
				/*   description of each entry point.		*/
	  3 date	   fixed bin (71),	/*     binary date assoc with entry point.	*/
	  3 Nep_names
		   fixed bin,	/*     number of entry point names.		*/
	  3 ep_name  (20) char (32) var,
				/*     name of the entry point.		*/
	  3 PDlinfo  ptr,		/*     ptr to paragraph descriptors for this info.*/
	  3 Pstart   ptr,		/*     first character of entry point info.	*/
	  3 L	   fixed bin,	/*     length (in chars) of entry point info.	*/
	  3 header   char (88) varying,
				/*     its heading line.			*/
	  3 Nlines   fixed bin,	/*     number of lines in entry point info.	*/
	  3 S,			/*     switches:				*/
	  ( 4 seen_by_user,		/*       this entry point seen by the user.	*/
	    4 old_format
	    )	   bit (1) unal,	/*       this entry point contains \006 chars.	*/
	    4 pad1   bit (34) unal;

    dcl 1 Dlinfo	   aligned based (PDlinfo),
				/* structure defining all paragraphs (units) in	*/
				/*   an entry point (misnamed linfo).		*/
	2 Nunits	   fixed bin,	/*   number of units in this ep.		*/
	2 Nsections  fixed bin,	/*   number of units beginning a section.	*/
	2 unit	   (0 refer (Dlinfo.Nunits)),
				/*   unit (paragraph) descriptors.		*/
	  3 Pstart   ptr,		/*     ptr to first char of unit (excl. title).	*/
	  3 title	   char (80) varying,
				/*     title of the unit.			*/
	  3 L	   fixed bin (21),	/*     length of the unit (in chars).		*/
	  3 Nlines   fixed bin,	/*     number of lines in the unit.		*/
	  3 S	   aligned,	/*     switches.				*/
	  ( 4 scn,		/*       unit begins a new section.		*/
	    4 seen_by_user,		/*       unit has been seen by user.		*/
	    4 ep_list,		/*       unit is an entry point list, to be 	*/
				/*       generated by help_.			*/
	    4 arg_list,		/*       unit is Arguments or Control args.	*/
	    4 syntax_list,		/*       unit is Syntax                           */
	    4 list_of_list
	    )	   bit (1) unal,	/*       unit is a list of itemsor examples.      */
	    4 pad1   bit (12) unal,
	  3 Icommon_unit
		   fixed bin (17) unal;
				/*     Index of common pgh in common_units.	*/

    dcl 1 LIST	   aligned based,	/* structure used to format list of things to be	*/
	2 header,			/* output in columns.			*/
	  3 N	   fixed bin,	/*   number of list elements.			*/
	  3 Nreal	   fixed bin,	/*   number of filled list elements.		*/
	  3 Npghs	   fixed bin,	/*   number of filled paragraphs of formatted out.*/
	  3 Nrows	   fixed bin,	/*   number of rows in formatted output.	*/
	  3 Ncols	   fixed bin,	/*   number of columns in formatted output.	*/
	  3 ML	   (6) fixed bin,	/*   length of longest element in each column.	*/
	  3 title	   char (80) varying,
				/*   title of output list.			*/
	  3 Iunit	   fixed bin,	/*   unit no of pgh containing list elements.	*/
	2 group	   (0 refer (LIST.N)),
	  3 arg	   char (88) varying,
				/*   the argument.				*/
	  3 Snot_found
		   fixed bin,	/*   = 1 if no match found for the argument.	*/
	2 print_array
		   (0 refer (LIST.Npghs), 0 refer (LIST.Nrows)),
	  3 line_out char (MAX_HELP_LINE_SIZE);
				/* Array of lines to be output to the screen.     */


    dcl 1 ca	   aligned,	/* current control_arg STRs.			*/
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group;

    dcl 1 lr	   aligned,	/* list_request structure			*/
	2 N	   fixed bin,
	2 ca	   (100) char (32) varying;

    dcl 1 common_units (Ncommon_units) aligned like Dlinfo.unit based (Pcommon_units);

    dcl 1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;
				/*struc containing lists of things to be output.	*/

    dcl 1 list_base	   aligned based (Plist_base),
				/* struc locating lists of things to be output.	*/
	2 N	   fixed bin,	/*   number of output lists now allocated.	*/
	2 Nmax	   fixed bin,	/*   max number of list ptrs allocatable.	*/
	2 Ispace_used_set
		   fixed bin,	/*   index of last list on which space used set.	*/
	2 Plists	   (0 refer (list_base.Nmax)) ptr;
				/*   ptrs to allocated lists.			*/

    dcl output	   char (Loutput) based (Poutput);

    dcl pgh	   char (Lpgh) based (Ppgh);

    dcl 1 query_answers
		   aligned based (Pquery_answers),
	2 header	   like LIST.header,
	2 group	   (0 refer (query_answers.N)) like LIST.group;

%include query_info;

    dcl 1 scn	   aligned,	/* current section STRs.			*/
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group;

    dcl seg_char	   (Lseg) char (1) based (Pseg);

    dcl 1 srh	   aligned,	/* current search STRs.			*/
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group;

    dcl (addr, addrel, addcharno, currentsize, dim, dimension, divide, hbound, index, length, ltrim, 
         max, maxlength, min, mod, null, reverse, rtrim, search, substr, sum, translate, verify)
		   builtin;

    dcl command_query_ entry options (variable),
        command_query_$yes_no
		   entry () options (variable),
        convert_date_to_binary_
		   entry (char (*), fixed bin (71), fixed bin (35)),
        get_line_length_$switch
		   entry (ptr, fixed bin (35)) returns (fixed bin),
        (
        ioa_,
        ioa_$nnl,
        ioa_$rsnnl
        )		   entry options (variable),
        iox_$control   entry (ptr, char (*), ptr, fixed bin (35)),
        iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)),
        ipc_$block	   entry (ptr, ptr, fixed bin (35));

   dcl CONSC_LINE_ARG_ID
		   char (1) int static options (constant) init (""),
				/* consecutive line arguments = \022		*/
        FALSE	   bit (1) int aligned static options (constant) init ("0"b),
        HELP_LINE_SIZE fixed bin int static options (constant) init (79),
        HT	   char (1) int static options (constant) init ("	"),
        HT_SP	   char (2) int static options (constant) init ("	 "),
        HT_SP_NL	   char (3) int static options (constant) init (" 
"),
        HT_SP_NL_VT	   char (4) int static options (constant) init ("	 
"),
        MAX_HELP_LINE_SIZE
		   fixed bin int static options (constant) init (136),
        ME	   char (4) int static options (constant) init ("help"),
        MULTI_LINE_ARG_ID
		   char (1) int static options (constant) init (""),
				/* multiple line arguments = \021		*/
        NL	   char (1) int static options (constant) init ("
"),
        NL_NL	   char (2) int static options (constant) init ("

"),
        OLD_HELP_PGH_CHAR
		   char (1) aligned int static options (constant) init (""),
				/* \006  */
        SPACES	   char (MAX_HELP_LINE_SIZE) aligned int static options (constant) init (" "),
        SP	   char (1) int static options (constant) init (" "),
        SP_SP	   char (2) int static options (constant) init ("  "),
        SP_SP_SP	   char (3) int static options (constant) init ("   "),
        TRUE	   bit (1) int aligned static options (constant) init ("1"b),
        colon	   char (1) int static options (constant) init (":"),
       (ep_list	   init (5),
        normal	   init (1),
        new_entry	   init (4),
        return_from_list_requests
		   init (6),
        search_unseen  init (3),
        some_unseen	   init (2)) fixed bin int static options(constant),
       (error_table_$fatal_error,
        error_table_$noentry,
        error_table_$nomatch)
        		   fixed bin (35) ext static,
       (exact_match	   init (2),
        match	   init (1),
        no_match	   init (0)) fixed bin int static options (constant),
        iox_$user_output
		   ptr ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Parse up the physical info segment into entry point pieces.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Acode = 0;
    PI_LABEL = RETURN;		/* Before any output starts, a pi skips to next	*/
				/* info.					*/

    query_info.version = query_info_version_6;
				/* initialize query info values		*/
    query_info.yes_or_no_sw = FALSE;
    query_info.suppress_name_sw = TRUE;
    query_info.query_code = 0;

    call initialize_switches;

    Loutput_line = min (MAX_HELP_LINE_SIZE, get_line_length_$switch (iox_$user_output, code));
    if code ^= 0 then
      Loutput_line = HELP_LINE_SIZE;	/* Get user's terminal line size.		*/

    Sprint_inhibit = FALSE;		/* Printing is not inhibited yet.		*/
    ca.N, scn.N, srh.N = 0;		/* No control_arg, search or section args done.	*/
    ref_name = "";			/* No entry point reference name set yet.	*/
    Pseg = APseg;
    Lseg = Dinfo_seg_.I;		/* Address first char of logical info.		*/
    Pseg = addr (seg_char (Dinfo_seg_.I));
    Lseg = Dinfo_seg_.L;		/* Address all/only log info we are printing.	*/
    call info$init (Pseg, Lseg);
    call parse_info_into_entry_points (Pseg, Lseg, PDeps);
				/* Parse up the log info into entry points.	*/



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Various kinds of output (arguments and control arguments, section titles, 		*/
/* entry point names, etc) are output in columnar lists.  More than one list		*/
/* may exist at a time.  Initialize array of list pointers to keep track of them.	*/
/* The lists themselves are appended to the end of the segment containing		*/
/* the help_args structure, as are all of the variable size structures used in help_.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Pnext_free_space = addrel (PDeps, currentsize (Deps));
				/* reuse space for lists, etc each time that	*/
				/* process_info_seg is called.		*/
    Plist_base = get_list_base (Pnext_free_space, currentsize (Deps), 30);
				/* get space for gen'l purpose list of lists.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 1) Get space for the descriptor of the paragraphs (units) in the common (or only) part	*/
/*     of the logical info.  Parse this common part into pgh units.			*/
/* 2) If there are other entry point descriptions in the log info, then		*/
/*    get space for their paragraph descriptors.					*/
/*    Parse them up into pghs, and append to their descriptors the common units		*/
/*    (paragraphs included in all entry points) obtained from the common info		*/
/*    descriptors created in step 1 above.					*/
/*    All entry point parts must be parsed now to get line count of entire info right.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Ncommon_units = 0;		/* No common info has been found yet.		*/
    Pep_list = null;		/* Initialize entry point list ptr		*/
    PDlinfo = Pnext_free_space;	/* get space for paragraph descriptions of common	*/
				/* or only part of logical info.		*/
    call parse_entry_point_into_units (Deps.linfo (0), Pcommon_units, Ncommon_units, PDlinfo);
    Pnext_free_space = set_space_used (PDlinfo, currentsize (Dlinfo));
    if Deps.N > 0 then
      do;				/* handle log. info w/ several entry point parts.	*/
        do Nuncommon_units = 2 to Dlinfo.Nunits while (^Dlinfo.unit (Nuncommon_units).S.scn);
				/* Find paragraphs in common part which are	*/
				/* shared by (common to) all entry point parts.	*/
        end;
        Nuncommon_units = Nuncommon_units - 1;
        Ncommon_units = Dlinfo.Nunits - Nuncommon_units;
        if (Ncommon_units = 0) & (Nuncommon_units = 1) then
	if length (Dlinfo.unit (1).title) > length ("Entry points in") then
	  if substr (Dlinfo.unit (1).title, 1, length ("Entry points in ")) = "Entry points in " then
	    do;
	      Nuncommon_units = 0;
	      Ncommon_units = 1;
	    end;
        if Ncommon_units > 0 then
	do;
	  Pcommon_units = addr (Dlinfo.unit (Nuncommon_units + 1));
	end;
        else Pcommon_units = PDlinfo;
        do i = 1 to Ncommon_units;	/* Find section of common part containing	*/
				/*   help-generated list of entry points in info.	*/
	if length (common_units (i).title) > 15 then
				/* 15 = length("Entry points in ").	*/
	  if substr (common_units (i).title, 1, 15) = "Entry points in " then
	    do;
	      common_units (i).S.ep_list = TRUE;
	      j = i;
	      do i = i to Ncommon_units;
				/* Remove any pghs following this special one	*/
				/*   from the common part of the info.		*/
	        Deps.linfo (0).Nlines = Deps.linfo (0).Nlines - common_units (i).Nlines - 2;
	      end;		/* Subtract line count of pghs following the	*/
				/* "Entry points in " section.		*/
	      Ncommon_units = j;	/* "Entry points in " is last pgh of info.	*/
	      Dlinfo.Nunits = Nuncommon_units + Ncommon_units;
	    end;
        end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
/* First we build an entry point list to determine how many paragraphs */
/* it will consist of.  Once we know how big we are going to have to   */
/* grow our original list we adjust the size of the original and then  */
/* rebuild ep_list so that we can save the formatted output (print)    */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

        if Ncommon_units > 0 then
	if common_units (Ncommon_units).S.ep_list then
	  do;
	    Plist = get_list (Plist_base);
	    save_title = common_units (Ncommon_units).title;
	    if ref_name = "" then
	      if suffix = "" then
	        ref_name = rtrim (Dinfo_seg_.ent);
	      else ref_name =
		      substr (Dinfo_seg_.ent, 1,
		      32 - length (suffix) - index (reverse (Dinfo_seg_.ent), reverse (suffix) || "."));
	    call get_ep_list (ref_name, PDeps, Plist);
	    No_list_elements = list.N;/* save for possible use in -bf		*/
	    call format_list (Plist, divide (No_list_elements, 5, 17, 0) + 1, 0);
	    Ncommon_units = Ncommon_units - 1;
	    Dlinfo.Nunits = Nuncommon_units + Ncommon_units + list.Npghs;
	    call give_list_back (Plist_base, Plist);
	    Pnext_free_space = set_space_used (PDlinfo, currentsize (Dlinfo));
	    Plist = get_list (Plist_base);
				/* Build entry point list pghs in temp seg.	*/
	    list.title = save_title;
	    call get_ep_list (ref_name, PDeps, Plist);
	    call format_list (Plist, divide (list.N, 5, 17, 0) + 1, 0);
	    call set_list_size (Plist_base, Plist);
	    Pep_list = Plist;
	    Nep_pghs = list.Npghs;
	    Poutput, Pnext_free_space = set_space_used (Plist, currentsize (list));
              Deps.linfo (0).Nlines = Deps.linfo (0).Nlines + 2 * Ncommon_units;
                                        /* Add non-ep list heading lines                  */
	    do i = 1 to list.Npghs;	/* Create new entry point list pghs.		*/
	      call output_list (Plist, i, Poutput, Loutput, Nlines);

	      j, Ncommon_units = Ncommon_units + 1;
	      common_units (j).Pstart = Poutput;
				/*   Add new pghs to end of common units.	*/
	      common_units (j).L = Loutput;
	      common_units (j).Nlines = Nlines;
	      common_units (j).S = FALSE;
	      if i = 1 then
	        do;		/*   Include section title for 1st pgh of ep list.*/
		common_units (j).title = list.title;
		common_units (j).S.scn = TRUE;
	        end;
	      else
	        do;		/*   No section title for subsequent pghs.	*/
		common_units (j).title = "";
	        end;
	      common_units (j).S.ep_list = TRUE;
				/*   Remember how pghs got there (for debugging).	*/
	      Poutput, Pnext_free_space = set_space_used (Poutput, currentsize (output));
	    end;			/*   Get space for next pgh.			*/
	    Dlinfo.Nunits = Nuncommon_units + Ncommon_units;
	    call give_list_back (Plist_base, Plist);
				/* Discard list containing entry point names.	*/
	  end;
        do i = 1 to Ncommon_units;	/* Mark all common units by number.		*/
	common_units (i).Icommon_unit = i;
				/* This will help avoid seeing common units in	*/
        end;			/* every entry point info.			*/
        PDlinfo = Pnext_free_space;
        do i = 1 to Deps.N;		/* Parse all other entry points to count lines.	*/
	call parse_entry_point_into_units (Deps.linfo (i), Pcommon_units, Ncommon_units, PDlinfo);
	PDlinfo, Pnext_free_space = set_space_used (PDlinfo, currentsize (Dlinfo));
        end;			/* Common pghs added to other entries when parsed.*/
      end;
    else
      do;
        Pcommon_units = PDlinfo;
        Ncommon_units = 0;
      end;
    if Deps.N >= 0 then		/* Deps.N will be less than 0 if info seg is blank*/
      Deps.Nlines = sum (Deps.linfo.Nlines);
				/* Count lines in total info.			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
/*                                                                           */
/*  List entry point names                                                   */
/*                                                                           */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

    if help_args.Sctl.lep & Pep_list ^= null & ^Sep_list_printed then
      do;
        Sprt_entry_pts = TRUE;
        Nlines = Nlines + 2;  /* Add count for header of entry pt list */
        call print_header ();
        call print_list (Pep_list, Sprint_inhibit);
      end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Copy -section and -search control arguments.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if help_args.Sctl.scn then
      do;				/* Copy -section args to local storage.		*/
        do i = 1 to min (help_args.Nscns, dim (scn.arg, 1));
	scn.arg (i) = help_args.scn (i);
        end;
        scn.N = i - 1;
      end;
    if help_args.Sctl.srh then
      do;				/* Copy -search args to local storage.		*/
        do i = 1 to min (help_args.Nsrhs, dim (srh.arg, 1));
	srh.arg (i) = help_args.srh (i);
        end;
        srh.N = i - 1;
      end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Find the correct logical info segment (info), if any was requested by user.		*/
/* If desired info was not found, then any searching required for the			*/
/* -section and -search control arguments cannot and will not be done, though the	*/
/* operands given with these control arguments are stored as the default values to be 	*/
/* used with the section and search requests if first issued without operands.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if Dinfo_seg_.ep = "" then
      do;				/* if no entry point requested,		*/
        if help_args.min_date_time ^= -1 then
	do;			/*   process 1st newer than given date/time	*/
	  do Iep = 0 to Deps.N while (help_args.min_date_time ^< Deps.linfo (Iep).date);
	  end;			/*   iff a nonzero date/time selector was given.	*/
	  if Iep > Deps.N then
	    Iep = 0;
	end;
        else if help_args.Sctl.scn | help_args.Sctl.srh then
	do;
	  Scase_sensitive = help_args.Sctl.cs;
	  Ssearch = FALSE;		/*   process 1st entry containing matches for	*/
	  Iunit = 1;		/*   -section and/or -search  ctl_args.		*/
	  if help_args.Sctl.scn & help_args.Sctl.srh then
	    do;
	      do Iep = 0 to Deps.N while (^Ssearch);
	        match_result = find_section (Deps.linfo (Iep).PDlinfo, scn, Scase_sensitive, Iunit);
	        if match_result ^= no_match then
		Ssearch = find_pgh (Deps.linfo (Iep).PDlinfo, srh, Iunit, Scase_sensitive,
		  new_section);
	      end;
	    end;
	  else if help_args.Sctl.scn then
	    do;
	      do Iep = 0 to Deps.N while (^Ssearch);
	        match_result = find_section (Deps.linfo (Iep).PDlinfo, scn, Scase_sensitive, Iunit);
	        Ssearch = (match_result ^= no_match);
	      end;
	    end;
	  else
	    do;
	      do Iep = 0 to Deps.N while (^Ssearch);
	        Ssearch = find_pgh (Deps.linfo (Iep).PDlinfo, srh, Iunit, Scase_sensitive,
		  new_section);
	      end;
	    end;
	  if ^Ssearch then
	    do;
	      Acode = error_table_$nomatch;
	      return;
	    end;
	  Iep = Iep - 1;
	end;
        else Iep = 0;		/* otherwise, process general description.	*/
        Ssearch = TRUE;
      end;

    else
      do;				/* else search for requested entry point.	*/
        Sfound = FALSE;
        do Iep = 1 to Deps.N while (^Sfound);
	do i = 1 to Deps.linfo (Iep).Nep_names while (^Sfound);
	  if Dinfo_seg_.ep = Deps.linfo (Iep).ep_name (i) then
	    Sfound = TRUE;
	end;
        end;
        if Sfound then
	do;
	  Iep = Iep - 1;
	  Ssearch = TRUE;		/* Do -section/-search matching if user asked.	*/
	end;
        else
	do;			/*   requested ep not found.			*/
	  if Dinfo_seg_.info_name = "" then
	    Linfo_name = 0;
	  else Linfo_name = length (rtrim (Dinfo_seg_.info_name)) + length (" ()");
	  if ^help_args.Sctl.inhibit_errors then
	    do;
	      Acode = error_table_$noentry;
	      return;
	    end;
	  Ssearch = FALSE;		/* Don't do -section/-search matching.		*/
	  Iep = 0;
	end;
      end;
    PDlinfo = Deps.linfo (Iep).PDlinfo; /* Address entry point user wants first.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* When -header is given without other control arguments, generate a heading line	*/
/* containing full pathname of physical info segment, title line from logical		*/
/* info segment, line count of logical info segment, and count of logical info segments	*/
/* (infos) in physical info seg (excluding common portion at the beginning).		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    Ninfos_printed = Ninfos_printed + 1;/* Beyond this point, something must get printed.	*/
    if Dinfo_seg_.Scross_ref then
      do;				/* Just remark about existence of other versions	*/
				/* of an info.				*/
        if Ninfos_printed = 1 then
	do;
	  call ioa_ ("^a: No infos matching -section and -search control arguments were found.", procedure_name);
	  call ioa_ ("However, several infos appear more than once in the search paths.");
	  call ioa_ ("The following secondary info(s) match -section and -search control arguments.");
	end;
        else if Nlast_info_cross_ref ^= Iinfo - 1 then
	do;
	  call ioa_ ("^v/^a: Other versions of the info^[s^] above were found.  See also:", help_args.Lspace_between_infos,
	       procedure_name, Ninfos_printed > 2);
	end;
        call ioa_ ("  ^a^[>^]^a", Dinfo_seg_.dir, Dinfo_seg_.dir ^= ">", Dinfo_seg_.ent);
        Nlast_info_cross_ref = Iinfo;
        go to RETURN;
      end;
    else if help_args.Sctl.he_only then
      do;				/* When -header is given without other ctl_args	*/
				/*   output the header and return.		*/
        call print_header_only ();
        go to RETURN;
      end;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The -brief control argument requests that the "Syntax" section (or "Usage" section of	*/
/* old format info segs) be output in full, along with a list of arguments and control	*/
/* arguments from the "Arguments" and "Control arguments" sections.			*/
/* 1) Find "Syntax" or "Usage" sections, and count lines in these sections.		*/
/* 2) Find "Arguments" and "Control arguments" sections, and build lists of arguments.	*/
/*    Count output lines in each list.						*/
/* 3) Output a header line, optionally given full pathname of physical info seg (-header)	*/
/*    as well as number of lines in the brief output, total lines in the info, and	*/
/*    count of (other) infos in this physical info seg.				*/
/* 4) Output the "Syntax" or "Usage" section.					*/
/* 5) Output the columnar lists of "Arguments" and "Control arguments".		*/
/* 6) Stop processing this physical info segment, and move on to the next specified	*/
/*    by user (if any).							*/
/*									*/
/* When -control_arg is given, output description of all args/ctl_args whose name lines	*/
/* contain match for substring identifier(s) given as operands by the user.		*/
/* 1) Find "Argument" and "Control argument" name lines which contain one of the	*/
/*    substrings given by the user after -control_arg.				*/
/* 2) Store those argument description lines in a list.				*/
/* 3) Print the argument description lines in the list after an appropriate heading.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if help_args.Sctl.bf | help_args.Sctl.ca then
      do;				/* Print argument descriptions when -ca given.	*/
        Nlines = 1;			/* Count lines to be output.			*/
				/*   Add 1 line for heading line.		*/

        Nunit_bf_prt = 0;		/* Initialize number of syntax units              */

        if help_args.Sctl.bf then
	do;
	  call get_brief_data (Deps.linfo (Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo, Plist_base, Dinfo_seg_.dir,
                Dinfo_seg_.ent, Nlast_info_no_brief_data, Iinfo, Ninfos_printed, Iunit_syntax, Nunit_bf_prt,
                Nlists_of_bf_args, Nlines);
	  if Nunit_bf_prt = 0 then
	    go to RETURN;
	  if Ninfos > 1 then
	    call print_header ();
	end;
        else
	do;
	  Nunit_bf_prt = 0;
	  Nlists_of_bf_args = 0;
	end;

        if help_args.Sctl.ca & ^Sep_list_printed then
	do;			/* Get control argument descriptions.		*/
	  if Ninfos > 1 then
	    call print_header ();
	  Plist, Plist_of_cas = get_list (Plist_base);
	  list.N = help_args.Ncas;	/*   Begin by copying user-supplied arg names.	*/
	  list.arg = help_args.ca;
	  list.title = "-control_arg";/*   Get one list for each section with ctl args.	*/
	  call get_arg_descriptions (Plist_of_cas, PDlinfo, Plist_base, Deps.linfo (Iep).S.old_format, Plists_of_args,
	       Nlists_of_args);
	  do i = 1 to Nlists_of_args; /*   Count output lines in each list.  Lists are	*/
	    Plist = Plists_of_args (i);
				/*   separated by 2 1 line, with 1 line for	*/
	    Nlines = Nlines + list.N + 2;
				/*   title of section containing the args.	*/
	  end;
	end;

        if length (Deps.linfo (Iep).header) = 0 then
	do;
	  Nlines = Nlines - 2;	/* No title?  Remove its line count.		*/
	  if Nlines <= 0 then
	    Nlines = 1;
	end;

        Sprt_bf_heading = TRUE;	/* Being requested as an external ca               */
        call print_brief_data (PDlinfo, Plist_base, Iunit_syntax, Nunit_bf_prt, Nlists_of_bf_args, Nlines);

        if help_args.Sctl.ca then
	do;			/* Print ctl arg descriptions, section by sect.	*/
	  do j = 1 to Nlists_of_args;
	    Plist = Plists_of_args (j);
	    call ioa_ ("^[^/^]^a:", (j > 1 | Ninfos > 1 | (help_args.Sctl.bf & help_args.Sctl.ca)), list.title);
	    do i = 1 to list.N;
	      call ioa_ ("^a", list.arg (i));
	    end;
	  end;
	end;
        go to RETURN;		/*   Stop when -brief or -control_arg given.	*/
      end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* When -title is given, output a heading line and titles of paragraph sections.	*/
/* The heading line contains:							*/
/* 1) The full pathname of the info segment (if -header was given).			*/
/* 2) The primary title line from the info selected by the user.			*/
/* 3) The count of section title lines to be output.				*/
/* 4) Count of total lines in logical info segment.				*/
/* 5) Count of (other) infos in this physical info segment.				*/
/* Output a list of section titles in columnar form.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    PI_LABEL = QUERY;		/* once printing starts, pi skips to next query.	*/
    Iunit = 0;			/* No pghs printed so far.			*/
    if (print_pgh_titles ()) then
      do;				/* Print pgh titles when -title is given only if 	*/
				/* more than one title will be printed.		*/
        if length (Deps.linfo (Iep).header) > 0 then
	Nlines = 1;
        else Nlines = -1;
        Plist_of_titles = get_list (Plist_base);
        call get_title_list (PDlinfo, Plist_of_titles, 0);
        call format_list (Plist_of_titles, divide (Dlinfo.Nsections, 7, 17, 0) + 1, 1);
        Nlines = Nlines + Plist_of_titles -> list.Nrows + 1;
        if help_args.Sctl.all then
	do;
	  Nlines = Nlines + Deps.linfo (Iep).Nlines + 2;
	  if length (Deps.linfo (Iep).header) > 0 then
	    Nlines = Nlines - 2;
	end;
        call print_header ();
        call print_list (Plist_of_titles, Sprint_inhibit);
        Pnext_free_space = Plist_of_titles;
        list_base.N = list_base.N - 1;	/* Free list of titles.			*/
        if help_args.Sctl.all then
	do;
	  do Iunit = 1 to Dlinfo.Nunits;
	    call print_pgh_2nl (Dlinfo.unit (Iunit), Sprint_inhibit);
	  end;
	  go to QUERY;
	end;
      end;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* When -title not given, begin printing paragraphs.  Normally start with first pgh.	*/
/* However, if -section  is given, search for section whose title contains		*/
/* user-specified substrings.  Print first pgh of this section if found.		*/
/* If -search is given, search for pgh containing user-specified substrings.		*/
/* Start with first matching pgh.  If both -section and -search are given, position to	*/
/* matching section before searching more matching pgh.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    else if ^Sep_list_printed then	/* If entrypoint list was printed do not print  	*/
      do;
        Iunit = 1;			/* Start searching in first unit.		*/
        new_section = "";
        if ^help_args.Sctl.all then
	if ^help_args.Sctl.title then
	  if help_args.Sctl.scn | help_args.Sctl.srh then
				/* Select pgh when -section given.		*/
	    do;			/* Select pgh when -search  given.		*/
	      Scase_sensitive = help_args.Sctl.cs;
	      if help_args.Sctl.scn then
	        do;		/* Search all section titles for one containing	*/
		match_result = find_section (PDlinfo, scn, Scase_sensitive, Iunit);
		if match_result = no_match then
		  return;
	        end;
	      if help_args.Sctl.srh then
	        do;		/* Search subsequent pghs for one containing	*/
		Ssearch = find_pgh (PDlinfo, srh, Iunit, Scase_sensitive, new_section);
		if ^Ssearch then
		  return;
	        end;
	    end;

        if help_args.Sctl.all then
	do;
	  Nlines = Deps.linfo (Iep).Nlines;
	  Nprint_units = Dlinfo.Nunits;
	end;
        else
	do;
	  Nlines = Dlinfo.unit (Iunit).Nlines + 2;
				/*   Add 2 for entry point heading.		*/
	  if length (Deps.linfo (Iep).header) = 0 then
	    Nlines = Nlines - 2;	/*   However, if no heading, subtract the 2 lines.*/
	  if new_section ^= "" then
	    if ^Dlinfo.unit (Iunit).S.scn then
	      Nlines = Nlines + 1;	/* Add 1 line for section title of matched pgh.	*/
	  Nprint_units = 1;		/* Print one pgh.  If -section and -search were	*/
				/* not given, print more pghs as well so long	*/
				/* as total lines fewer than help_args.max_Lpgh	*/
				/* and additional pghs shorter than min_Lpgh.	*/
                                        /* Do NOT add in the entry point list pgh         */
	  if ^(help_args.Sctl.scn | help_args.Sctl.srh) then
	    do while (Nlines_less_Lpgh () &
                ^Dlinfo.unit (Iunit + Nprint_units).ep_list);
	      Nlines = Dlinfo.unit (Iunit + Nprint_units).Nlines + 1 + Nlines;
	      Nprint_units = Nprint_units + 1;
	    end;
	end;
        call print_header ();

        if (new_section_nscn ()) then	/* new section - not seen			*/
	do;
	  call ioa_ ("^/^a:", new_section);
	  call print_pgh_nnl (Dlinfo.unit (Iunit), Sprint_inhibit);
	end;
        else if (prt_pgh_nnl ()) then	/* ^Sctl.he.pn & ^Sctl.he_info_name & 		*/
				/* ^Sctl.he_counts & length header = 0		*/
	call print_pgh_nnl (Dlinfo.unit (Iunit), Sprint_inhibit);
        else call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);

        Sfirst_time = TRUE;

        do Iunit = Iunit + 1 to Iunit + Nprint_units - 1;
	if Dlinfo.unit (Iunit - 1).Nlines = 1 then
				/* if prior unit only had 1 line then print 2 blks*/
	  if ^Sfirst_time then
	    call print_pgh_2nl (Dlinfo.unit (Iunit), Sprint_inhibit);
	  else call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
	else call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
        end;
        Iunit = Iunit - 1;
      end;

QUERY:
    Nconsecutive_bad_ops = 0;		/* No errors in responses so far.		*/
    Ssearch = FALSE;		/* no searching for matching section/pgh underway.*/
    Sloop = TRUE;			/* Loop through all paragraphs of info.		*/
    Iunit = Iunit + 1;		/* Beginning with the next one.		*/
    if Sep_list_printed then		/* Entry list printed			*/
      query_type = ep_list;
    else query_type = normal;		/* Print normal section/pgh messages for now.	*/

    do while (Sloop);		/* Print remaining pghs under user control.	*/
      PI_LABEL = ASK;		/* Recompute query after most program_interrupt's.*/
      if Iunit > Dlinfo.Nunits then	/* Detect end_of_info and handle specially, but 	*/
        go to END_OF_INFO;		/* still remain within do group.		*/
      if Dlinfo.unit (Iunit).ep_list & Sep_list_printed then
         goto CONTINUE;		/* If entry pts list already printed dont reprint */

      if Dlinfo.unit (Iunit).ep_list & ^Sprt_entry_pts then
        do;	          	/* Print entry pts list only if requested         */
         Sep_list_printed = TRUE;
         goto CONTINUE;
        end;
     
      if Dlinfo.unit (Iunit).ep_list & No_list_elements = 1 then
                                        /* If entry pts list has only 1 element dont print.*/
         goto RETURN;
ASK:
      if query_type = normal | query_type = some_unseen | query_type = search_unseen |
         query_type = return_from_list_requests | query_type = ep_list then
        do;
	Sseen = seen_pgh (Dlinfo.unit (Iunit));
				/* Tell user in query if he's already seen pgh.	*/
	Nlines = Dlinfo.unit (Iunit).Nlines;
	Nprint_units = 1;		/* Normally print one pgh at a time.		*/
	query = "";
	if Dlinfo.unit (Iunit).S.scn | Iunit = 1 | query_type = return_from_list_requests |
            query_type = ep_list then
	  do;			/* However, if pgh begins a section and following	*/
	    if Iunit = 1 then
                do;
	       if ^Dlinfo.unit (1).S.scn then
	         query = "UNTITLED";
	       else query = Dlinfo.unit (Iunit).title;
                 if query_type = ep_list then
                                        /* Increment Nlines for ep list header             */
                   Nlines = Nlines + 2;
                end;
	    else if ^Dlinfo.unit (Iunit).S.scn then do;
	      do Iunit_search = Iunit-1 to 1 by -1 while(^Dlinfo.unit (Iunit_search).S.scn);
	        end;
	      if Iunit_search = 0 then
	        query = "UNTITLED";
	      else query = Dlinfo.unit (Iunit_search).title;
	      end;
	    else query = Dlinfo.unit (Iunit).title;
				/* pghs are shorter than min_Lpgh, print them	*/
				/* as well, until max_Lpgh lines are aggregated.	*/
	    do i = Iunit + Nprint_units to hbound(Dlinfo.unit,1)
	      while (ck_conditions (i));
	      Nlines = Nlines + Dlinfo.unit (i).Nlines + 2;
				/*   Must skip 2 lines between pghs to keep line	*/
				/*   count of total info equal to count of all	*/
				/*   printed lines.				*/
	      if Dlinfo.unit (i).S.scn then
	        do;
		query = query || "  &  ";
		if length (query) + length (Dlinfo.unit (i).title) + 12 > Loutput_line then
		  query = query || NL;
				/* 12 = length ( "(nnn lines)." )		*/
		query = query || Dlinfo.unit (i).title;
	        end;
	      Nprint_units = Nprint_units + 1;
	    end;			/*ck_conditions*/
	  end;			/*Iunit=1*/
	else
	  do;			/* If pgh doesn't begin a section, we can only	*/
				/* aggregate pghs in the current section.	*/
	    do i = Iunit + Nprint_units to hbound(Dlinfo.unit,1)
	      while (ck_more_conditions (i));
	      Nlines = Nlines + Dlinfo.unit (i).Nlines + 2;
	      Nprint_units = Nprint_units + 1;
	    end;
	  end;
        end;

      else if query_type = new_entry then
        do;
	call ct_pgh_lines;
	if Nlines + 2 < Deps.linfo (Iep).Nlines then
	  Lcount = length ("Entry:(99 lines follow;  999 lines in entry point)  More help?");
	else Lcount = length ("Entry:(999 lines in entry point)  More help?");
	Snl1 = (Lcount + 2 + length (Deps.linfo (Iep).header) + 3 > Loutput_line);
        end;
RE_ASK:
      Ssearch = FALSE;		/* searching for matching section/pgh is done.	*/
      PI_LABEL = ASK;		/* Routines branching here set PI_LABEL. Reset it.*/
      Sprint_inhibit = FALSE;
      if query_type = normal then
        do;
	call command_query_ (addr (query_info), answer, procedure_name,
	     "^[^/^]^[^a (^d line^[s^]).^[^/^;  ^]^2s^;^4s^d more line^[s^].  ^]^[Review^;More help^]?",
	     Dlinfo.unit (Iunit).S.scn & Dlinfo.unit (Iunit).Icommon_unit = 1 & Sseen, Dlinfo.unit (Iunit).S.scn,
	     query, Nlines, Nlines > 1, (length (query) + 24 > Loutput_line), Nlines, Nlines > 1, Sseen);
        end;
      else if query_type = some_unseen then
        call command_query_ (addr (query_info), answer, procedure_name,
	   "End of info.  Some paragraphs unseen.^/^[^a^;In:  ^a^] (^d line^[s^]).^[^/^;  ^]More help?",
	   Dlinfo.unit (Iunit).S.scn, query, Nlines, Nlines > 1, length (query) + 30 > Loutput_line);
      else if query_type = search_unseen then
        call command_query_ (addr (query_info), answer, procedure_name,
	   "^[^[^a^;In:  ^a^] (^d line^[s^])^;^2s^d more line^[s^]^].^[^/^;  ^]More help?", query ^= "",
	   Dlinfo.unit (Iunit).S.scn, query, Nlines, Nlines > 1, length (query) + 30 > Loutput_line);
      else if query_type = return_from_list_requests then do;
        if length(Deps.linfo(Iep).header) > 0 then
	new_section = Deps.linfo(Iep).header;
        else if length(rtrim(Dinfo_seg_.info_name)) > 0 then
	new_section = rtrim(Dinfo_seg_.info_name);
        else new_section = rtrim(Dinfo_seg_.ent);
        call command_query_ (addr (query_info), answer, procedure_name,
	"Returning to:  ^a^/^a (^d line^[s^]):^[^/^;  ^]^[Review^;More help^]?",
	new_section, query, Nlines, Nlines > 1, length (query) + 25 > Loutput_line, Sseen);
        query_type = normal;
        end;
      else if query_type = new_entry then
        call command_query_ (addr (query_info), answer, procedure_name,
	   "Entry:  ^a^[^/^;   ^](^[^d lines follow;  ^;^s^]^d lines in entry point).  ^[Review^;More help^]?",
	   Deps.linfo (Iep).header, Snl1, (Nlines + 2 < Deps.linfo (Iep).Nlines), Nlines, 
	   Deps.linfo (Iep).Nlines - 2, Sseen);
      else if query_type = ep_list then
        do;     
          if length(Deps.linfo(Iep).header) > 0 then
	  new_section = Deps.linfo(Iep).header;
          else if length(rtrim(Dinfo_seg_.info_name)) > 0 then
                 new_section = rtrim(Dinfo_seg_.info_name);
          else new_section = rtrim(Dinfo_seg_.ent);
          call command_query_ (addr (query_info), answer, procedure_name,
            "Returning to:  ^a^/^a (^d line^[s^]):^[^/^;  ^]^[Review^;More help^]?",
	  new_section, query, Nlines, Nlines > 1, length (query) + 25 > Loutput_line, Sseen);
          query_type = normal;
          Nprint_units = 1;
        end;

PARSE:
      call parse_answer (answer, op, ep_name, ca, scn, srh, lr);
      if op = hbound (do, 1) + 1 then
        do;			/* Count consecutive errors user makes in answer.	*/
	Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
	go to ERROR;
        end;
      else Nconsecutive_bad_ops = 0;
      go to do (op);		/* Process request at user's beck and call.	*/

YES:
do (1):				/* yes					*/
      Iunit_end = Iunit + Nprint_units - 1;
      PI_LABEL = YES_END;		/* go to pgh user said, even if he pi's.	*/
      call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
      do Iunit = Iunit + 1 to Iunit + Nprint_units - 1;
        call print_pgh_2nl (Dlinfo.unit (Iunit), Sprint_inhibit);
      end;
YES_END:
      Iunit = Iunit_end;
      go to CONTINUE;

do (2):				/* no					*/
      go to RETURN;

do (3):				/* quit					*/
      go to QUIT;

do (4):				/* top					*/
      Iunit = 0;
      if length (Deps.linfo (Iep).header) > 0 then
        call ioa_ ("^a", Deps.linfo (Iep).header);
      go to CONTINUE;

do (5):				/* rest					*/
      Nlines_titles = Dlinfo.unit (Iunit).Nlines;
      do Iunit_end = Iunit + 1 to Dlinfo.Nunits;
        Nlines_titles = Nlines_titles + Dlinfo.unit (Iunit_end).Nlines + 2;
      end;
      Iunit_end = Iunit_end - 1;
REST:
      PI_LABEL = REST_END;
      call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles > 1);
      call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
      do Iunit = Iunit + 1 to Iunit_end;
        call print_pgh_2nl (Dlinfo.unit (Iunit), Sprint_inhibit);
      end;
REST_END:
      Iunit = Iunit_end;
      go to CONTINUE;

do (6):				/* rest -scn				*/
      Nlines_titles = Dlinfo.unit (Iunit).Nlines;
      do Iunit_end = Iunit + 1 to Dlinfo.Nunits while (^Dlinfo.unit (Iunit_end).S.scn);
        Nlines_titles = Nlines_titles + Dlinfo.unit (Iunit_end).Nlines + 2;
      end;
      Iunit_end = Iunit_end - 1;
      go to REST;

do (7):				/* rest -aep				*/
      if Deps.N = 0 then
        do;			/* No entry points found			*/
	call ioa_ ("No entrypoint names were found.");
	goto ERROR;
        end;

      if Iep = Deps.N then
        do;			/* No more entry points exist			*/
	call ioa_ ("There are no remaining entrypoints to display.");
	goto ERROR;
        end;

      do Iep = Iep + 1 to Deps.N;
        PDlinfo = Deps.linfo (Iep).PDlinfo;
        Iunit = 1;
        Nlines = Dlinfo.unit (Iunit).Nlines + 2;
        call ct_pgh_lines;
        call ioa_ ("^/Entry:  ^a^[^/^;   ^](^[^d lines follow;  ^;^s^]^d lines in entry point).",
	   Deps.linfo (Iep).header, Snl1, (Nlines + 2 < Deps.linfo (Iep).Nlines), Nlines, 
	   Deps.linfo (Iep).Nlines - 2);
        do Iunit = 1 to Dlinfo.Nunits;
	if ^Dlinfo.unit (Iunit).ep_list then
	  call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
        end;
      end;

      goto CONTINUE;

do (8):				/* rest -ep				*/
      if Deps.N = 0 then
        do;			/* No entry points found			*/
	call ioa_ ("No entrypoint names were found.");
	goto ERROR;
        end;

      if Iep = Deps.N then
        do;			/* No more entry points exist			*/
	call ioa_ ("There are no remaining entrypoints to display.");
	goto ERROR;
        end;

      if Deps.linfo (Iep,1).ep_name = "" then 
        do;                             /* This is not an entry point                     */
          call ioa_ ("^a is not an entry point", query);
          goto ERROR;
        end;
     
      PDlinfo = Deps.linfo (Iep).PDlinfo;
      Iunit = 1;
      Nlines = Dlinfo.unit (Iunit).Nlines + 2;

      do Iunit = 1 to Dlinfo.Nunits;
        if ^Dlinfo.unit (Iunit).ep_list then
           call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
      end;

      goto RE_ASK;
      

do (9):				/* skip					*/
      go to CONTINUE;

do (10):				/* skip -scn				*/
      do Iunit = Iunit + 1 to Dlinfo.Nunits while (^Dlinfo.unit (Iunit).S.scn);
      end;
      Iunit = Iunit - 1;
      go to CONTINUE;

do (11):				/* skip -ep				*/
do (12):				/* skip -rest				*/
      do Iunit = 1 to Dlinfo.Nunits while (^seen_pgh (Dlinfo.unit (Iunit)));
      end;			/* Has user seen any pgh of this entry?		*/
      if Iunit > Dlinfo.Nunits then	/* No.					*/
        Sseen = FALSE;
      else Sseen = TRUE;		/* If so, by skip -ep, he's saying he's seen all	*/
      go to CHECK_OTHER_ENTRIES;	/* he wants to of this entry.			*/

do (13):				/* skip -seen				*/
      new_section = "";
      Sfound = FALSE;
      do Iunit = Iunit + 1 to Dlinfo.Nunits while (^Sfound);
        if Dlinfo.unit (Iunit).S.scn then
	new_section = Dlinfo.unit (Iunit).title;
        Sfound = ^seen_pgh (Dlinfo.unit (Iunit));
      end;
      Iunit = Iunit - 1;
      if Sfound then
        do;
	query = new_section;
	query_type = search_unseen;
	go to ASK;
        end;
      else go to END_OF_INFO;

do (14):				/* title					*/
      Iunit_search = Iunit - 1;
TITLE:
      PI_LABEL = RE_ASK;
      Plist_of_titles = get_list (Plist_base);
      call get_title_list (PDlinfo, Plist_of_titles, Iunit_search);
      call format_list (Plist_of_titles, divide (Plist_of_titles -> list.N, 7, 17, 0) + 1, 1);
      Nlines_titles = Plist_of_titles -> list.Nrows;
      call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles > 1);
      call print_list (Plist_of_titles, Sprint_inhibit);
      Pnext_free_space = Plist_of_titles;
      list_base.N = list_base.N - 1;
      go to RE_ASK;

do (15):				/* title -top				*/
      Iunit_search = 0;
      go to TITLE;

do (16):				/* entry_point {ep_name} 			*/
      if ref_name = "" then
        if suffix = "" then
	ref_name = rtrim (Dinfo_seg_.ent);
        else ref_name =
	   substr (Dinfo_seg_.ent, 1, 32 - length (suffix) - index (reverse (Dinfo_seg_.ent), reverse (suffix) || "."));
      if ep_name = "" then		/* Look for main entry point (eg, ioa_$ioa_)	*/
        ep_name = ref_name;
      else
        do;
	i = index (ep_name, "$");	/* Look for hcs_$initiate rather than initiate	*/
	if i > 1 then
	  do;			/* Validate given reference name.		*/
	    if substr (ep_name, 1, i - 1) ^= ref_name then
	      do;
	        call ioa_ ("Reference name  ^a  invalid.  Entry point names must be of the form:
	^a$ENTRY_POINT_NAME
or just:	ENTRY_POINT_NAME", substr (ep_name, 1, i - 1), ref_name);
	        Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
	        go to ERROR;
	      end;
	  end;
	if i > 0 then
	  if i < length (ep_name) then
	    ep_name = substr (ep_name, i + 1);
	  else ep_name = ref_name;
        end;
      Sfound = FALSE;		/* Find the requested entry point.		*/
      do i = 1 to Deps.N while (^Sfound);
        do j = 1 to Deps.linfo (i).Nep_names while (^Sfound);
	if ep_name = Deps.linfo (i).ep_name (j) then
	  Sfound = TRUE;
        end;
      end;
      if Sfound then
        do;
	Deps.linfo (Iep).S.seen_by_user = TRUE;
				/* user has seen all he wants of this entry point.*/
	Iep = i - 1;
	PDlinfo = Deps.linfo (Iep).PDlinfo;
	Iunit = 1;
	Nlines = Dlinfo.unit (Iunit).Nlines + 2;
	call ct_pgh_lines;
	call ioa_ ("Entry:  ^a^[^/^;   ^](^[^d lines follow;  ^;^s^]^d lines in entry point).", 
	     Deps.linfo (Iep).header, Snl1, (Nlines + 2 < Deps.linfo (Iep).Nlines), Nlines,
	     Deps.linfo (Iep).Nlines - 2);
	goto YES;
        end;
      else
        do;
	call ioa_ ("Entry point  ^a$^a  not found.", ref_name, ep_name);
	go to RE_ASK;
        end;

do (17):				/* section			          */
				/* section -ncs				*/
      Iunit_search = Iunit;
      Scase_sensitive = FALSE;
      goto SECTION;
do (18):				/* section -cs				*/
      Iunit_search = Iunit;
      Scase_sensitive = TRUE;
      goto SECTION;
do (19):				/* section -top				*/
				/* section -top -ncs                              */
      Iunit_search = 1;
      Scase_sensitive = FALSE;
      goto SECTION;      
do (20):                                /* section -top -cs                               */
      Iunit_search = 1;
      Scase_sensitive = TRUE;
SECTION:
      if scn.N = 0 then
        do;
	call ioa_$nnl ("No search strings given for section request.  ");
	Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
	go to ERROR;
        end;
      if Dlinfo.unit (Iunit_search).S.scn then
        Iunit_search = Iunit_search + 1;
      match_result = find_section (PDlinfo, scn, Scase_sensitive, Iunit_search);
      if match_result = exact_match then
        do;
	Iunit = Iunit_search;
	Nprint_units = 1;
	call ioa_ ("(^d ^[lines follow^;line follows^])", Dlinfo.unit (Iunit).Nlines, Dlinfo.unit (Iunit).Nlines > 1);
	go to YES;
        end;
      else if match_result = match then
        do;
	Iunit = Iunit_search;	/* When found, don't aggregate paragraphs.	*/
	Ssearch = TRUE;
	query_type = normal;
	goto ASK;
        end;
      else
        do;			/* Search failed?  Paragraphs can be aggregated	*/
	call ioa_ ("No matching section found.");
	go to RE_ASK;		/* based upon user's next response.		*/
        end;

do (21):				/* search					*/
				/* search -ncs				*/
      Iunit_search = Iunit;
      Scase_sensitive = FALSE;
      goto SEARCH;
do (22):				/* search -cs				*/
      Iunit_search = Iunit;
      Scase_sensitive = TRUE;
      goto SEARCH;
do (23):				/* search -top				*/
				/* search -top -ncs                               */
      Iunit_search = 1;
      Scase_sensitive = FALSE;
      goto SEARCH;
do (24):                                /* search -top -cs                                */
      Iunit_search = 1;
      Scase_sensitive = TRUE;
SEARCH:
      if srh.N = 0 then
        do;
	call ioa_$nnl ("No search strings given for search request.  ");
	Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
	go to ERROR;
        end;
      Ssearch = find_pgh (PDlinfo, srh, Iunit_search, Scase_sensitive, new_section);
      if Ssearch then
        do;			/* Found matching pgh?  Print it.		*/
	Iunit = Iunit_search;
	Ssearch = FALSE;
	Nlines = Dlinfo.unit (Iunit).Nlines;
	if new_section ^= "" & ^Dlinfo.unit (Iunit).S.scn then
	  do;
	    Nlines = Nlines + 1;
	    call ioa_ ("(^d lines follow)^2/^a:", Nlines, new_section);
	    call print_pgh_nnl (Dlinfo.unit (Iunit), Sprint_inhibit);
	  end;
	else
	  do;
	    call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines, Nlines > 1);
	    call print_pgh (Dlinfo.unit (Iunit), Sprint_inhibit);
	  end;
	go to CONTINUE;
        end;
      else
        do;
	call ioa_ ("No matching paragraph found.");
	go to RE_ASK;
        end;


do (25):				/* brief					*/
      Nlines_titles = -1;
      call get_brief_data (Deps.linfo (Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo, Plist_base, Dinfo_seg_.dir,
	 Dinfo_seg_.ent, Nlast_info_no_brief_data, Iinfo, Ninfos_printed, Iunit_syntax, Nunit_bf_prt, Nlists_of_bf_args,
	 Nlines_titles);
      if Nlines_titles > 0 then
        do;
	call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles > 1);
	Sprt_bf_heading = FALSE;	/* Internal bf request                          */
	call print_brief_data (PDlinfo, Plist_base, Iunit_syntax, Nunit_bf_prt, Nlists_of_bf_args, Nlines);
        end;
      else call ioa_ ("No brief data avaiable");
      go to RE_ASK;

do (26):				/* control_arg				*/
      Nlines_titles = -1;
      ca.title = "control_arg";
      call get_arg_descriptions (addr (ca), PDlinfo, Plist_base, Deps.linfo (Iep).S.old_format, Plists_of_args, Nlists_of_args);
      if Nlists_of_args > 0 then
        do;
	do i = 1 to Nlists_of_args;
	  Plist = Plists_of_args (i);
	  Nlines_titles = Nlines_titles + list.N + 2;
	end;
	call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles > 1);
	do j = 1 to Nlists_of_args;
	  Plist = Plists_of_args (j);
	  call ioa_ ("^/^a:", list.title);
	  do i = 1 to list.N;
	    call ioa_ ("^a", list.arg (i));
	  end;
	end;
	Pnext_free_space = Plists_of_args (1);
	list_base.N = 0;
        end;
      else call ioa_ ("No matching control arguments.");
      go to RE_ASK;

do (27):				/* . (= print name of caller)			*/
      call ioa_ ("^a", procedure_name);
      go to RE_ASK;

do (28):				/* ? (= list responses)			*/
      if query_answers.Nrows = 0 then
        call format_list (addr (query_answers), 5, 1);
      call print_list (addr (query_answers), Sprint_inhibit);
      go to RE_ASK;

do (29):				/* header					*/
      call print_header_only ();
      go to RE_ASK;

do (30):				/* list_entry_points			*/
      if Pep_list ^= null then
        do;
          Sprt_entry_pts = TRUE;
          Sep_list_printed = FALSE;
	call print_list (Pep_list, Sprint_inhibit);
	query_type = ep_list;
          goto ASK;
        end;
      else
        do;
	call ioa_ ("There are no entry points in this info segment.");
	goto ERROR;
        end;

do (31):				/* list_requests				*/
do (32):				/* help					*/
      call list_requests;
      query_type = return_from_list_requests;
      goto ASK;

ERROR:
      if Nconsecutive_bad_ops = 1 then
        do;			/* For first error, omit acceptable response	*/
				/* list, and just print mini query.		*/
	call command_query_ (addr (query_info), answer, procedure_name,
	     "^[^d ^[lines follow^;line follows^].^;^2s^]  ^[Review^;More help^]?", Nlines > 0, Nlines, Nlines > 1, Sseen);
	go to PARSE;
        end;
      call ioa_ ("Type ? for a list of allowed responses.");
				/* But if user errs more than once for given query*/
				/* tell user how to print responses		*/
      if Nconsecutive_bad_ops > 2 then
        go to RE_ASK;		/* If more than 2 consecutive errors, the user	*/
				/* may have forgotten original question.	*/
				/* Repeat it in  its entirety.		*/
      else call command_query_ (addr (query_info), answer, procedure_name,
	      "^[^d ^[lines follow^;line follows^].  ^;^2s^]^[Review^;More help^]?", Nlines > 0, Nlines, Nlines > 1, Sseen);
      go to PARSE;


END_OF_INFO:
      Sseen = TRUE;			/* Examine all pghs looking for unseen pgh.	*/
      new_section = "UNTITLED";	/* Remember section titles as we examine them.	*/

      if Dlinfo.Nunits > 0 then do Iunit = 1 to Dlinfo.Nunits while (Sseen);
        if Dlinfo.unit (Iunit).S.scn then
	new_section = Dlinfo.unit (Iunit).title;
        if Sep_list_printed & Dlinfo.unit (Iunit).S.ep_list 
           then ;
        else Sseen = seen_pgh (Dlinfo.unit (Iunit));
      end;			/* Look for unseen paragraphs.		*/
      if ^Sseen then
        do;			/* Some were found?				*/
	Iunit = Iunit - 1;		/* do group always increments 1 too many.	*/
	query = new_section;
	query_type = some_unseen;
	go to ASK;
        end;
      Sseen = TRUE;			/* This entry point has been seen.		*/

CHECK_OTHER_ENTRIES:
      if Deps.N = 0 then
        go to RETURN;		/* Only 1 part in log info?  We're done. 	*/
      else
        do;			/* Many entry points.			*/
	Deps.linfo (Iep).S.seen_by_user = Sseen;
				/* Mark whether or not we've seen this entry.	*/
	do i = Iep + 1 to Deps.N while (Deps.linfo (i).S.seen_by_user | help_args.min_date_time ^< Deps.linfo (i).date);
	end;			/* Look for unseen entries.			*/
	if i > Deps.N then
	  do;			/* All entries seen?			*/
	    do i = 1 to Iep - 1 while (Deps.linfo (i).S.seen_by_user | help_args.min_date_time ^< Deps.linfo (i).date);
	    end;
	    if Deps.linfo (i).S.seen_by_user | help_args.min_date_time ^< Deps.linfo (i).date then
	      go to RETURN;
	  end;
	Iep = i;			/* ith one is unseen.			*/
	PDlinfo = Deps.linfo (Iep).PDlinfo;
				/* access its paragraph descriptors.		*/
	Iunit = 1;
	if help_args.Sctl.all then
	  do;
	    Lcount = length ("Entry:(999 lines in entry point)");
	    Snl1 = (Lcount + 2 + length (Deps.linfo (Iep).header) + 3 > Loutput_line);
	    call ioa_ ("^v/Entry:  ^a^[^/^;   ^](^d lines in entry point)", help_args.Lspace_between_infos,
	         Deps.linfo (Iep).header, Snl1, Deps.linfo (Iep).Nlines - 2);
	    Nprint_units = Dlinfo.Nunits;
	    go to YES;
	  end;
	query_type = new_entry;
	go to ASK;
        end;

CONTINUE:
      Iunit = Iunit + 1;		/* Must implement looping ourselves because	*/
      Sloop = (Iunit <= Dlinfo.Nunits + 1);
				/* Dlinfo.Nunits will change when we switch to a	*/
      query_type = normal;		/* new entry point.  Loop would be:		*/


    end;				/*	do Iunit = Iunit+1 to Dlinfo.Nunits;	*/

RETURN:
    Acode = 0;
    return;

QUIT:
    Acode = error_table_$fatal_error;
    return;


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


find_pgh:
  procedure (PDlinfo_, Srh, Iunit, Scase_sensitive, new_section) returns (bit (1) aligned);

    dcl PDlinfo_	   ptr parm;	/* ptr to descriptors for this log info seg. (In)	*/
    dcl 1 Srh	   aligned parm,	/* Paragraph search args. (In)		*/
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group;
    dcl Iunit	   fixed bin;	/* Pgh to start searching (In)		*/
    dcl Scase_sensitive
		   bit(1) parm;	/* on if searching in case-sensitive fashion. (In)*/
    dcl new_section	   char (88) varying;
				/* Title of new section in which pgh occurs.	*/
				/* Pgh found. (Out)				*/

    dcl 1 Dlinfo_	   aligned based (PDlinfo_),
	2 Nunits	   fixed bin,	/* number of units (pghs) in this log info seg.	*/
	2 Nsections  fixed bin,	/* number of units having section title.	*/
	2 unit	   (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;
    dcl Ssearch	   bit (1) aligned;
    dcl (i, j)	   fixed bin;
    dcl PPgh	   ptr,
        LPgh	   fixed bin,
        Pgh	   char (LPgh) based (PPgh);

    if Srh.N = 0 then
      return (FALSE);		/* If nothing to search for, forget it.		*/
    j = 0;			/* Find length of longest pgh we will examine	*/
    do i = Iunit to Dlinfo_.Nunits;	/* so we can create temp storage into which	*/
      j = max (j, Dlinfo_.unit (i).L);	/* each pgh can be translated into lowercase.	*/
    end;

BLOCK:
    begin;
      dcl pgh	     char (j) varying;
      dcl srh	     (Srh.N) char (88) varying;
				/* translated paragraph search args.		*/

      do i = 1 to Srh.N;		/* translate search args to lower case.		*/
        if Scase_sensitive then
	srh (i) = Srh.arg (i);
        else srh (i) = translate (Srh.arg (i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
      end;

      Ssearch = FALSE;		/* Search until matching section title found	*/
      new_section = "";

      do Iunit = Iunit to Dlinfo_.Nunits while (^Ssearch);
        if Dlinfo_.unit (Iunit).S.scn then
	new_section = Dlinfo_.unit (Iunit).title;
        if help_args.Sctl.srh & found_in_title () then
	Ssearch = TRUE;
        else
	do;
	  PPgh = Dlinfo_.unit (Iunit).Pstart;
	  LPgh = Dlinfo_.unit (Iunit).L;
	  if Scase_sensitive then
	    pgh = Pgh;
	  else pgh = translate (Pgh, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
				/* translate pgh to lower case.		*/
	  Ssearch = FALSE;		/* Assume title matches until proven otherwise.	*/
	  do i = 1 to dimension (srh, 1) while (^Ssearch);
	    j = index (pgh, srh (i));
	    if index (pgh, srh (i)) > 0 then
	      Ssearch = TRUE;
	  end;
	end;
      end;

      if Ssearch then		/* Match found?				*/
        Iunit = Iunit - 1;		/* do-group always increments one too many.	*/
      return (Ssearch);

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

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

    dcl title_search   char (80) varying;
				/* translated title to be searched		*/

    if Scase_sensitive then
      title_search = Dlinfo_.unit (Iunit).title;
    else title_search = translate (Dlinfo_.unit (Iunit).title, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
				/* translate title to lower case.		*/
    Ssearch = FALSE;		/* Assume title matches until proven otherwise.	*/
    do i = 1 to dimension (srh, 1) while (^Ssearch);
      if index (title_search, srh (i)) > 0 then
        Ssearch = TRUE;
    end;

    return (Ssearch);

  end found_in_title;

    end BLOCK;

  end find_pgh;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


find_section:
  procedure (PDlinfo_, Scn, Scase_sensitive, Iunit) returns (fixed bin);

    dcl PDlinfo_	   ptr parm;	/* ptr to `descriptors for this log info seg. (In)*/
    dcl 1 Scn	   aligned parm,	/* Section title search args.	(In)		*/
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group;
    dcl Scase_sensitive
		   bit(1) parm;	/* on if searching in case-sensitive fashion. (In)*/
    dcl Iunit	   fixed bin parm;	/* Pgh to start searching (In)		*/
				/* Pgh found. (Out)				*/

    dcl 1 Dlinfo_	   aligned based (PDlinfo_),
	2 Nunits	   fixed bin,	/* number of units (pghs) in this log info seg.	*/
	2 Nsections  fixed bin,	/* number of units having section title.	*/
	2 unit	   (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;

    dcl scn	   (Scn.N) char (88) varying;
				/* translated section title search args.	*/
    dcl Ssearch	   bit (1) aligned;
    dcl i		   fixed bin;
    dcl result	   fixed bin;
    dcl temp	   char (88) varying;
    dcl title	   char (88) varying;

    if Scn.N = 0 then
      return (no_match);		/* if nothing to search for, forget it.		*/
    do i = 1 to Scn.N;		/* translate search args to lower case.		*/
      if Scase_sensitive then
        scn (i) = Scn.arg (i);
      else scn (i) = translate (Scn.arg (i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
    end;
    Ssearch = FALSE;		/* Search until matching section title found	*/
    do Iunit = Iunit to Dlinfo_.Nunits while (^Ssearch);
      if Dlinfo_.unit (Iunit).S.scn then
        do;
	if Scase_sensitive then
	  title = Dlinfo_.unit (Iunit).title;
	else title = translate (Dlinfo_.unit (Iunit).title, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
				/* translate title to lower case.		*/
	Ssearch = TRUE;		/* Assume title matches until proven otherwise.	*/
	do i = 1 to dimension (scn, 1) while (Ssearch);
	  if index (title, scn (i)) = 0 then
	    Ssearch = FALSE;
	end;
        end;
    end;
    if Ssearch then
      do;				/* Match found?				*/
        Iunit = Iunit - 1;		/* do-group always increments one too many.	*/
        temp = scn (1);
        do i = 2 to Scn.N;
	temp = temp || " ";
	temp = temp || scn (i);
        end;
        if temp = title then		/* check for exact match (except for letter case).*/
	result = exact_match;
        else result = match;
      end;
    else result = no_match;
    return (result);

  end find_section;

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


format_list:
  procedure (Plist, Mcols, Mpghs);	/* This procedure formats a list of values.	*/

    dcl Plist	   ptr,		/* ptr to argument list to be printed.		*/
        Mcols	   fixed bin,	/* maximum number of columns to be used in format.*/
        Mpghs	   fixed bin,	/* maximum pghs to be used. 0 means no limit.	*/
        Sprint_inhibit bit (1) aligned; /* on if printing suppressed by pi.		*/


    dcl (Icol, Ipgh, Irow)
		   fixed bin,
        Pspaces	   ptr,
        Continued_arg  bit (1) aligned,
        long_line	   bit (1),
        Smultiple_words
		   bit (1),
        one_line_paragraph
		   bit (1),
        one_line_list  bit (1),
        Sdoes_not_fit  bit (1) aligned,
        No_args	   fixed bin (24),
        last_line	   fixed bin,
        length_args	   fixed bin (24),
        i		   fixed bin,
        j		   fixed bin,
        save_N	   fixed bin;


    dcl 1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;

    dcl line_position  fixed bin (24);



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Format the arguments in as many columns as possible to reduce the output lines.	*/
/* However, if the output fits in 2 or more rows, the number of rows is chosen so that	*/
/* all columns but the final one are full.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    Sdoes_not_fit = TRUE;
    long_line = FALSE;
    Smultiple_words = FALSE;
    one_line_paragraph = FALSE;
    one_line_list = FALSE;

    if Mcols < 1 then		/* Allow caller to limit number of columns.	*/
      list.Ncols = dimension (list.ML, 1);
    else list.Ncols = min (Mcols, dimension (list.ML, 1));

    save_N = list.N;		/* If arguments are combined then total number of */
				/* elements must be reduced for row calculation.  */

    do list.Ncols = list.Ncols to 1 by -1 while (Sdoes_not_fit);
      list.Nrows = divide (save_N + list.Ncols - 1, list.Ncols, 17, 0);
				/* Compute how many rows are required to display	*/
				/*   the args in list.Ncols columns.		*/

ROW_RETURN:			/* Row array bounds exceeded - recompute bounds   */
      if Mpghs = 1 then		/* compute how many paragraphs are needed.	*/
        list.Npghs = 1;
      else
        do;
	list.Npghs = divide (list.Nrows + help_args.max_Lpgh - 2, help_args.max_Lpgh - 1, 17, 0);
	list.Nrows = divide (list.Nrows + list.Npghs - 1, list.Npghs, 17, 0);
        end;

      do i = 1 to list.Npghs;
        do j = 1 to list.Nrows;
	list.print_array (i, j).line_out = SPACES;
        end;
      end;

      ct_lines = 0;
      No_args = 0;
      list.ML (*) = 0;
      line_position = 0;
      length_args = 0;
      Continued_arg = FALSE;
      one_line_paragraph = FALSE;
      long_line = FALSE;
      Smultiple_words = FALSE;

      do Ipgh = 1 to list.Npghs;
        do Icol = 1 to list.Ncols;
	if Icol = 1 then
	  line_position = 1;
	else line_position = line_position + list.ML (Icol - 1) + 3;
	do Irow = 1 to list.Nrows;
	  if No_args < list.N then
	    do;
	      No_args = No_args + 1;
	      list.ML (Icol) = max (list.ML (Icol), length (list.arg (No_args)));
	      if sum (list.ML) + (list.Ncols - 1) * 3 > Loutput_line then
	        goto line_to_long;
	      if Icol = 1 then	/*Clear row before using*/
	        print_array (Ipgh, Irow).line_out = "";

	      if length(list.arg (No_args)) >= length(CONSC_LINE_ARG_ID) then
	      if substr (list.arg (No_args), 1, 1) = CONSC_LINE_ARG_ID | substr (list.arg (No_args), 1, 1) = MULTI_LINE_ARG_ID
		 then
	        goto check_args;


	      if list.N <= 3 then
	        do;		/*If multiple words in arg and total number of args < 3*/
				/*then put in one column*/
		if multiple_words () then
		  do;
		    line_position = 1;
		    list.Nrows = list.N;
		    do i = No_args to list.N;
		      print_array (Ipgh, Irow).line_out = SPACES;
		      substr (print_array (Ipgh, Irow).line_out, line_position) = list.arg (No_args);
		      if line_position = 1 then
		        ct_lines = ct_lines + 1;
		      No_args = No_args + 1;
		      Irow = Irow + 1;
		    end;
		    No_args = No_args - 1;
				/* decrement No_args			*/
		  end;
	        end;

	      if list.Nrows > 1 then
	        if list.Ncols = 1 then/*If one col max and line is < Loutput then print entire*/
				/*line on the same line - dont fold.                    */
		if No_args + 1 <= list.N then
		  if length (list.arg (No_args + 1)) >= 2 then
                        if  substr (list.arg (No_args + 1), 1, 2) = SP_SP then
		    if length (list.arg (No_args)) - 1 + length (list.arg (No_args + 1)) <= Loutput_line then
		      do;
		        length_args = length (list.arg (No_args)) - 1 + length (list.arg (No_args + 1));
		        line_position = 1;
		        if substr (list.arg (No_args + 1), 3, 1) = "-" then
			substr (print_array (Ipgh, Irow).line_out, line_position, length_args + 1) =
			     list.arg (No_args) || substr (list.arg (No_args + 1), 2);
		        else substr (print_array (Ipgh, Irow).line_out, line_position, length_args + 1) =
			        list.arg (No_args) || substr (list.arg (No_args + 1), 3);
		        No_args = No_args + 1;
		        save_N = save_N - 1;
		        if line_position = 1 then
			ct_lines = ct_lines + 1;
		      end;

	      if ^Smultiple_words then
	        do;
		substr (print_array (Ipgh, Irow).line_out, line_position, length (list.arg (No_args))) = list.arg (No_args);
		if line_position = 1 then
		  ct_lines = ct_lines + 1;
	        end;

	      if No_args + 1 <= list.N then
	        if length (list.arg (No_args + 1)) >= 2 then
                    if substr (list.arg (No_args + 1), 1, 2) = SP_SP then
		if Irow = list.Nrows then
		  Continued_arg = TRUE;

check_args:
	      if length(list.arg (No_args)) >= length(MULTI_LINE_ARG_ID) then
	        if substr (list.arg (No_args), 1, 1) = MULTI_LINE_ARG_ID then
		do;		/* Multi line arguments*/
		  if list.N = 2 then
		    one_line_paragraph = TRUE;
		  else one_line_paragraph = FALSE;

		  if No_args + 1 <= list.N then
		    if length (list.arg (No_args)) - 1 + length (list.arg (No_args + 1)) < 
                           Loutput_line then
		      do;
		        length_args = length (list.arg (No_args)) - 1 + length (list.arg (No_args + 1));
		        if length_args ^> list.ML (Icol) | one_line_paragraph then
			do;	/*Combine arg lines if length permits*/
			  if ^one_line_paragraph then
			    if substr (list.arg (No_args + 1), 3, 1) = "-" then
			      substr (print_array (Ipgh, Irow).line_out, line_position, length_args + 1) =
				 substr (list.arg (No_args), 2) || substr (list.arg (No_args + 1), 2);

			    else substr (print_array (Ipgh, Irow).line_out, line_position, length_args) =
				    substr (list.arg (No_args), 2) || substr (list.arg (No_args + 1), 3);
			  else substr (print_array (Ipgh, Irow).line_out, line_position, length_args) =
				  substr (list.arg (No_args), 2) || substr (list.arg (No_args + 1), 3);
			  list.ML (Icol) = max (list.ML (Icol), length (list.arg (No_args)));
			  if sum (list.ML) + (list.Ncols - 1) * 3 > Loutput_line then
			    goto line_to_long;
			  No_args = No_args + 1;
			  save_N = save_N - 1;
			  if line_position = 1 then
			    ct_lines = ct_lines + 1;
			end;
		        else
			do;
			  substr (print_array (Ipgh, Irow).line_out, line_position, length (list.arg (No_args))) =
			       substr (list.arg (No_args), 2) || SP;
			  if Irow = list.Nrows then
			    Continued_arg = TRUE;
			  if line_position = 1 then
			    ct_lines = ct_lines + 1;
			end;
		      end;
		    else
		      do;
		        substr (print_array (Ipgh, Irow).line_out, line_position, length (list.arg (No_args))) =
			   substr (list.arg (No_args), 2) || SP;
		        if Irow = list.Nrows then
			Continued_arg = TRUE;
		        if line_position = 1 then
			ct_lines = ct_lines + 1;
		      end;
		end;

	      if length(list.arg (No_args)) >= length(CONSC_LINE_ARG_ID) then
	        if substr (list.arg (No_args), 1, 1) = CONSC_LINE_ARG_ID then
		do;		/* Consecutive line argument*/
		  substr (print_array (Ipgh, Irow).line_out, line_position, length (list.arg (No_args))) =
		       substr (list.arg (No_args), 2) || SP;
		  if line_position = 1 then
		    ct_lines = ct_lines + 1;
		  if Irow = list.Nrows then
		    Continued_arg = TRUE;
		end;

	      do while (Continued_arg);
	        No_args = No_args + 1;
	        list.ML (Icol) = max (list.ML (Icol), length (list.arg (No_args)));
	        if sum (list.ML) + (list.Ncols - 1) * 3 > Loutput_line then
		goto line_to_long;

	        Irow = Irow + 1;
	        if Irow > list.Nrows then
		do;
		  list.Nrows = list.Nrows + 1;
		  print_array (Ipgh, Irow).line_out = "";
		end;

	        if Icol = 1 then	/*Clear row initially*/
		print_array (Ipgh, Irow).line_out = "";
	        if print_array (Ipgh, Irow).line_out = "" then
		ct_lines = ct_lines + 1;
				/*A continued arg does not necessarily begin in col 1*/
	        substr (print_array (Ipgh, Irow).line_out, line_position, length (list.arg (No_args))) = list.arg (No_args);
	        if No_args = dim (list.arg, 1) then
		Continued_arg = FALSE;
	        else if length (list.arg (No_args + 1)) >= 2 & substr (list.arg (No_args + 1), 1, 2) ^= SP_SP then
		Continued_arg = FALSE;
	      end;

	      if No_args = list.N & Ipgh = list.Npghs & Icol = 1 then
	        do while (Irow < list.Nrows);
				/*More rows defined than there are actual arguments for last pgh*/
		Irow = Irow + 1;
		print_array (Ipgh, Irow).line_out = SPACES;
	        end;

	    end;			/*No_args<list.N*/
	end;			/*Irow*/
        end;			/*Icol*/
      end;			/*Ipgh*/

      if Irow > list.Nrows & No_args < list.N then
        do;
	list.Nrows = list.Nrows + 1;
	goto ROW_RETURN;
        end;

      Sdoes_not_fit = FALSE;
line_to_long:
    end;				/*Sdoes_not_fit*/

    list.Ncols = list.Ncols + 1;	/* do group decrements one too many */

    return;

multiple_words:
  proc returns (bit (1));
    Smultiple_words = FALSE;
    do i = No_args to list.N;
      j = verify (list.arg (i), SP);	/* Find 1st none blank character of string	*/
      if index (substr (list.arg (i), j), ",") = 0 & index (substr (list.arg (i), j), SP) ^= 0 then
        Smultiple_words = TRUE;
      if length(list.arg (i)) >= length(CONSC_LINE_ARG_ID) then
      if substr (list.arg (i), 1, 1) = CONSC_LINE_ARG_ID | substr (list.arg (i), 1, 1) = MULTI_LINE_ARG_ID then
        do;
	Smultiple_words = FALSE;
	return (Smultiple_words);
        end;
    end;
    return (Smultiple_words);

  end multiple_words;

print_list_nnl:
  entry (Plist, Sprint_inhibit);

    if Sprint_inhibit then
      return;
    Pspaces = addr (SPACES);
    if length (list.title) > 0 then
      call ioa_ ("^a:", list.title);
    go to PRINT_LIST;



print_list:
  entry (Plist, Sprint_inhibit);	/* This entry point prints a list and its title.	*/

    if Sprint_inhibit then
      return;
    Pspaces = addr (SPACES);
    if length (list.title) > 0 then
      do;
        if one_line_pgh & ^multiple_syntax & bf_no_ARG_dsp & Sfirst_time then
	call ioa_ ("^a:", list.title);
        else call ioa_ ("^/^a:", list.title);
      end;
    else if one_line_pgh then
      do;
        if bf_no_ARG_dsp & ^multiple_syntax & Sfirst_time then
	;
        else call iox_$put_chars (iox_$user_output, addr (NL), length (NL), 0);
      end;
    else if ^multiple_syntax & Sfirst_time then
      ;
    else call iox_$put_chars (iox_$user_output, addr (NL), length (NL), 0);

    Sfirst_time = FALSE;


find_end_array:			/*Find end of actual data so extraneous blank lines are not output*/
    Ipgh = list.Npghs;
    do Irow = list.Nrows to 1 by -1 while (print_array (Ipgh, Irow).line_out = SPACES);
    end;
    last_line = Irow;


PRINT_LIST:
    if Sprt_entry_pts then
       goto PRINT_EP_LIST;

    do Ipgh = 1 to list.Npghs;	/* Output paragraphs, one at a time.		*/
      if Ipgh > 1 then
        call out (NL);
      if Ipgh = list.Npghs then	/* Set last line of actual data.                  */
        list.Nrows = last_line;
      do Irow = 1 to list.Nrows;	/* Output rows, one at a time.		*/
        call ioa_ ("^a", print_array (Ipgh, Irow).line_out);
      end;
      Irow = Irow - 1;                  /* Loop increments 1 past hbound		*/
    end;
    return;

PRINT_EP_LIST:			/* Print ep list given on command line				*/
    help_args.Sctl.lep = FALSE;
    Sprt_entry_pts = FALSE;
    Sep_list_printed = TRUE;

    do Ipgh = 1 to list.Npghs;	/* Output paragraphs, one at a time.		*/
      if Ipgh > 1 then do;
        if Ipgh = list.Npghs then
	call command_query_$yes_no (yes_sw, 0, procedure_name,
           "Do you want to continue printing the entry point list?", "^d more lines.  More entrypoints?", last_line);
        else call command_query_$yes_no (yes_sw, 0, procedure_name,
           "Do you want to continue printing the entry point list?", "^d more lines.  More entrypoints?", list.Nrows);
        if ^yes_sw then
             return;
      end;

      if Ipgh ^= list.Npghs then        /* Output rows, one at a time.		*/
        do Irow = 1 to list.Nrows;
          call ioa_ ("^a", print_array (Ipgh, Irow).line_out);
        end;
      else do Irow = 1 to last_line;    /* Only print non-blank rows                      */
             call ioa_ ("^a", print_array (Ipgh, Irow).line_out);
           end;

      Irow = Irow - 1;                  /* Loop increments 1 past hbound		*/
    end;
    return;

output_list:
  entry (Plist, Apgh, Poutput, Loutput, Nlines);
				/* output 1 pgh of multipgh list into a string.	*/

    dcl Apgh	   fixed bin,	/* Number of pgh to output.			*/
        Poutput	   ptr,		/* ptr to output string.			*/
        Loutput	   fixed bin,	/* length of output string.			*/
        output	   char (Loutput) based (Poutput),
        Nlines	   fixed bin;	/* Lines in the output.			*/

    Nlines = 0;
    Loutput = 0;
    Pspaces = addr (SPACES);
    Ipgh = Apgh;
    if Ipgh = 1 then		/* Output NL which would follow section title	*/
      if length (list.title) > 0 then
        do;			/* in a regular (non-made-up) section.		*/
	call out (NL);
	Nlines = Nlines + 1;
        end;
    do Irow = 1 to list.Nrows;
      if Ipgh = list.Npghs & print_array (Ipgh, Irow).line_out = " " then
        return;
      call out ((print_array (Ipgh, Irow).line_out));
      call out (NL);
      Nlines = Nlines + 1;
    end;
    return;


out:
  proc (str);

    dcl str	   char (*);

    Loutput = Loutput + length (str);
    substr (output, Loutput - length (str) + 1, length (str)) = str;

  end out;


  end format_list;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

    dcl line_text	   char (Lline_text) based (Pline_text),
        Pline_text	   ptr,
        Lline_text	   fixed bin (21),
        line_text_arr  (Lline_text) char (1) based (Pline_text),
        line	   char (Lline) based (Pline),
        Pline	   ptr,
        Lline	   fixed bin (21),
        line_arr	   (Lline) char (1) based (Pline),
        Lparg	   fixed bin (21),
        bf_no_ARG_dsp  bit (1) init ("0"b),
        new_paragraph  bit (1) init ("0"b),
        one_line_paragraph
		   bit (1) init ("0"b),
        multiple_syntax
		   bit (1) init ("0"b),
        one_line_pgh   bit (1),
        Number_lines   fixed bin,
        Sconsecutive_arg_lines
		   bit (1);


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


get_arg_descriptions:
  procedure (Plist_cas, PDlinfo_, Plist_base, Sreally_old_format, Plists_of_args, Nlists_of_args);
				/* This procedure builds a list of argument	*/
				/* descriptions which match user-given arg names.	*/

    dcl (Plist_cas, PDlinfo_, Plist_base)
		   ptr,
        Sreally_old_format
		   bit (1),
        Plists_of_args (*) ptr,
        Nlists_of_args fixed bin;

    dcl 1 list_cas	   aligned based (Plist_cas),
	2 header	   like LIST.header,
	2 group	   (0 refer (list_cas.N)) like LIST.group;
    dcl 1 Dlinfo_	   aligned based (PDlinfo_),
				/* structure defining all paragraphs (units) in	*/
				/*   an entry point (logical info seg - linfo).	*/
	2 Nunits	   fixed bin,	/*   number of units in this ep.		*/
	2 Nsections  fixed bin,	/*   number of units beginning a section.	*/
	2 unit	   (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;

    dcl 1 list_base	   aligned based (Plist_base),
				/* struc locating lists of things to be output.	*/
	2 N	   fixed bin,	/*   number of output lists now allocated.	*/
	2 Nmax	   fixed bin,	/*   max number of list ptrs allocatable.	*/
	2 Ispace_used_set
		   fixed bin,	/*   index of last list on which space used set.	*/
	2 Plists	   (0 refer (list_base.Nmax)) ptr;
				/*   ptrs to allocated lists.			*/
				/*   unit (paragraph) descriptors.		*/
    dcl 1 list_args	   aligned based (Plist_args),
	2 header	   like LIST.header,
	2 group	   (0 refer (list_args.N)) like LIST.group;
    dcl Plist_args	   ptr,
        args	   char (Lline) based (Pline);

    dcl Iunit	   fixed bin,
        k		   fixed bin,
        save_args	   char(200) varying;		/* no lines longer than 200 allowed. 	  */

    Nlists_of_args = 0;
    list_cas.Snot_found (*) = 1;

    do Iunit = 1 to Dlinfo_.Nunits;
      if Dlinfo_.unit (Iunit).S.arg_list then
        do;
	if Dlinfo_.unit (Iunit).S.scn then
	  do;
	    if Nlists_of_args > 0 then
	      if list_args.N = 0 then
	        list_args.title = Dlinfo_.unit (Iunit).title;
	      else go to NEXT_LIST;
	    else
	      do;
NEXT_LIST:
	        if Nlists_of_args >= dimension (Plists_of_args, 1) then
		;
	        else
		do;
		  Nlists_of_args = Nlists_of_args + 1;
		  Plist_args, Plists_of_args (Nlists_of_args) = get_list (Plist_base);
		  list_args.title = Dlinfo_.unit (Iunit).title;
		end;
	      end;
	  end;
	Pline_text = Dlinfo_.unit (Iunit).Pstart;
	Lline_text = Dlinfo_.unit (Iunit).L;
	call line$skip_blanks;	/* strip off leading blanks if existant*/
	do while (Lline_text > 0);	/* Search pgh for arguments.			*/
	  if line$next () then
	    do;
	      if line$blank () | line$HT_SP () then
	        do;
		Sconsecutive_arg_lines = FALSE;
	        end;
	      else
	        do;		/* find arg				*/
		call line$args;
		save_args = args;
		do k = 1 to list_cas.N;
		  if search (list_cas.arg (k), "ABCDEFGHIJKMNOPQRSTUVWXYZ") = 0 then
		    if ^Scase_sensitive then
		      save_args = translate (save_args, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
		  if index (save_args, list_cas.arg (k)) > 0 then
		    do;
		      list_cas.Snot_found (k) = 0;
		      list_args.N = list_args.N + 1;
		      list_args.arg (list_args.N) = args;
				/*get the argument      */
		      do while (line$desc ());
		        list_args.N = list_args.N + 1;
		        list_args.arg (list_args.N) = args;
		      end;	/*get desc*/
		    end;		/*found arg*/
		end;		/*k=1 to list_cas.N*/
END_LOOP:
	        end;		/*find arg*/
	    end;			/*line$next*/
	end;			/*Lline_text>0*/
        end;			/*arg list*/
    end;				/*Iunit=1 to Dlinfo.Nunits*/
    if Nlists_of_args > 0 then	/* May have unused list.  If so, free it.	*/
      if list_args.N = 0 then
        do;
	list_base.N = list_base.N - 1;
	Nlists_of_args = Nlists_of_args - 1;
        end;
    if sum (list_cas.Snot_found) > 0 then
      do;				/* Any control arg names given by user unmatched?	*/
        if Nlists_of_args = 0 then
	do;
	  Nlists_of_args = Nlists_of_args + 1;
	  Plist_args, Plists_of_args (Nlists_of_args) = get_list (Plist_base);
	  list_args.title = "NO MATCH FOR " || list_cas.title || " STRINGS";
	end;
        else
	do;
	  list_args.N = list_args.N + 1;
	  list_args.arg (list_args.N) = "";
	  list_args.N = list_args.N + 1;
	  list_args.arg (list_args.N) = "NO MATCH FOR " || list_cas.title || " STRINGS:";
	end;
        do k = 1 to list_cas.N;
	if list_cas.Snot_found (k) > 0 then
	  do;
	    list_args.N = list_args.N + 1;
	    list_args.arg (list_args.N) = "  ";
	    list_args.arg (list_args.N) = list_args.arg (list_args.N) || list_cas.arg (k);
	  end;
        end;
      end;

  end get_arg_descriptions;

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


get_arg_list:
  procedure (unit, Plist, Sreally_old_format);
				/* This procedure builds a list of arguments.	*/

    dcl 1 unit	   aligned like Dlinfo.unit,
        Plist	   ptr;		/* ptr to space for arg list.			*/

    dcl 1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;

    dcl Sreally_old_format
		   bit (1),
        args	   char (Lline) based (Pline),
				/*contains the control argument  */
        (i, j, k)	   fixed bin (24),
        remove_N	   fixed bin;


    j = 0;
    Sfirst_time = TRUE;
    Sremove_line = FALSE;
    Pline_text = unit.Pstart;		/* address the paragraph.			*/
    Lline_text = unit.L;
    call line$skip_blanks;
    do while (Lline_text > 0);	/* search pgh for arguments.			*/
      if line$next () then
        do;
	if line = "" | line = "" then
	  Sconsecutive_arg_lines = FALSE;
	else
	  do;
	    i = index (HT_SP, line_arr (1));
				/*Check to see if line begins with a HT_SP*/
	    if i > 0 then
	      Sconsecutive_arg_lines = FALSE;
	    else
	      do;
	        list.N = list.N + 1;
	        if list_of & line$list_items () then
				/*List of items with no descriptions*/
		list.arg (list.N) = line;
	        else
		do;
		  call line$args;

		  if Sremove_line & Sfirst_time then
		    do;		/*Can only remove text following section title or*/
				/*extraneous text at the end of the pgh.         */
		      Sfirst_time = FALSE;
		      if Sdescription_present & list.N ^= 2 then
		        Sremove_line = FALSE;
		      if ^Sdescription_present & list_of then
		        Sremove_line = FALSE;
		      if Sremove_line then
		        remove_N = list.N;
		    end;

		  if Lline > maxlength (list.arg (list.N)) then
		    call long_lines;
		  else list.arg (list.N) = args;
		end;

	        if list_of & ^Sconsecutive_arg_lines then
		call list_of_lines;
	        else if Sconsecutive_arg_lines then
		call consecutive_lines;
	        else if length (list.arg (list.N)) > 18 & index (list.arg (list.N), " ") ^= 0 then
		call multi_line_arg;
	      end;
	  end;
        end;			/*line$next*/
    end;				/*Lline_text > 0*/

    if Sremove_line then
      do;
        if remove_N = 2 then
	do;
	  k = remove_N + 1;
	  do j = k to list.N while (substr (list.arg (j), 1, 2) = SP_SP);
	    list.arg (2) = substr (list.arg (j), 3);
	  end;
	  do i = 3 to list.N while (j <= list.N);
	    list.arg (i) = list.arg (j);
	    j = j + 1;
	  end;
	  list.N = i - 1;
	end;
        else if ^Sdescription_present then
				/*Eliminate extraneous text at end of pgh      */
	list.N = remove_N - 1;
      end;


list_of_lines:
  proc;

    if length (list.arg (list.N)) < 36 then
      do;
        if list.N > 1 then
	if substr (reverse (list.arg (list.N - 1)), 1, 1) = "," then
				/* if prior line ends in a comma assume this is a	*/
				/* continued line				*/
	  list.arg (list.N) = SP_SP || list.arg (list.N);
        return;
      end;
    list.N = list.N + 1;
    i = index (substr (list.arg (list.N - 1), 25, 12), ",");
				/* first position > 25 and <= 36 with a comma*/
    if i > 0 then
      i = 25 + i - 1;
    else
      do;				/* last position < 36 with a comma*/
        i = index (reverse (substr (list.arg (list.N - 1), 1, 36)), ",");
        if i > 0 then
	i = 36 - i + 1;
      end;
    if i = 0 then
      do;				/* closest word boundary*/
        i = index (reverse (substr (list.arg (list.N - 1), 1, 36)), SP);
        if i > 0 then
	i = 36 - i + 1;
      end;
    if i = 0 then
      i = index (substr (list.arg (list.N - 1), 36), SP);

    if i = 0 then
      i = 36;			/* if all else fails use length of 36 */
    list.arg (list.N) = SP_SP || ltrim (substr (list.arg (list.N - 1), i + 1));
    list.arg (list.N - 1) = MULTI_LINE_ARG_ID || substr (list.arg (list.N - 1), 1, i);
  end list_of_lines;


consecutive_lines:
  proc;

    j = index (list.arg (list.N), NL);
    if j > 0 then
      do;				/*Set up header line*/
        list.N = list.N + 1;
        list.arg (list.N) = SP_SP || substr (list.arg (list.N - 1), j + 1);
        list.arg (list.N - 1) = CONSC_LINE_ARG_ID || substr (list.arg (list.N - 1), 1, j - 1);

        k = index (list.arg (list.N - 1), HT_SP);
				/*Strip off trailing spaces/HT*/
        if k > 0 then
	list.arg (list.N - 1) = substr (list.arg (list.N - 1), 1, k - 1);
      end;

    j = index (list.arg (list.N), NL);	/*Multiple detail lines*/
    do while (j > 0);
      list.N = list.N + 1;
      list.arg (list.N) = SP_SP || substr (list.arg (list.N - 1), j + 1);
      list.arg (list.N - 1) = substr (list.arg (list.N - 1), 1, j - 1);
      k = index (list.arg (list.N - 1), HT_SP);
				/*strip off trailing spaces/HT*/
      if k > 0 then
        list.arg (list.N - 1) = substr (list.arg (list.N - 1), 1, k - 1);

      j = index (list.arg (list.N), NL);
    end;

  end consecutive_lines;


multi_line_arg:
  proc;				/*Multi line argument*/
    j = index (list.arg (list.N), "-"); /*find 1st argument*/
    i = index (substr (list.arg (list.N), 18), "-");
				/*find argument starting in position > 18*/

    if i ^= 0 then			/*add offset - 1*/
      i = i + 17;
    else
      do;				/*find 2nd argument in position < 18*/
        i = index (substr (list.arg (list.N), j + 1), "-");
        if i = 0 then
	do;
	  i = index (substr (list.arg (list.N), 18), ",");
				/*1st position > 18 with a comma or length of prior arg if >*/
	  if i ^= 0 then
	    i = i + 17;
	  else
	    do;
	      i = index (substr (list.arg (list.N), 18), " ");
				/*1st position > 18 with a blank*/
	      if i ^= 0 then
	        i = i + 17;
	      else
	        do;
		i = index (list.arg (list.N), " ");
		if i >= 18 then
		  i = 18;
	        end;
	    end;
	end;
      end;

    list.N = list.N + 1;
    list.arg (list.N) = SP_SP || substr (list.arg (list.N - 1), i);
    list.arg (list.N - 1) = MULTI_LINE_ARG_ID || substr (list.arg (list.N - 1), 1, i - 1);

    k = length (list.arg (list.N - 1));
    j = verify (reverse (list.arg (list.N - 1)), HT_SP);
				/*strip off trailing spaces/HT*/
    if j > 1 then
      list.arg (list.N - 1) = substr (list.arg (list.N - 1), 1, k - j + 1);

  end multi_line_arg;

long_lines:
  proc;
    j = index (line, NL);
    if j > 0 then
      do;				/*Set up header line*/
        list.arg (list.N) = CONSC_LINE_ARG_ID || substr (line, 1, j);
        if Lline - j > 0 then
	Pline = addr (line_arr (j + 1));
        Lline = Lline - j;
      end;

    do while (Lline > 0);		/*Set up detail lines*/
      j = index (line, NL);
      if j > 0 then
        do;
	list.N = list.N + 1;
	list.arg (list.N) = SP_SP || substr (line, 1, j);
	if Lline - j > 0 then
	  Pline = addr (line_arr (j + 1));
	Lline = Lline - j;
        end;
      else
        do;
	list.N = list.N + 1;
	list.arg (list.N) = SP_SP || line;
	Lline = 0;
        end;
    end;
  end long_lines;

  end get_arg_list;

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


get_brief_data:
  proc (Sold_format, Sheader, PDlinfo_, Plist_base, dir, ent, Nlast_info_no_brief_data, Iinfo, Ninfos_printed, Iunit_syntax,
       Nunit_bf_prt, Nlists_of_bf_args, Nlines);

    dcl Sold_format	   bit (1) unal,	/* on if log info contains \006 chars.		*/
        Sheader	   bit (1) unal,	/* on if -header required.			*/
        PDlinfo_	   ptr,		/* ptr to pgh descriptors of log info.		*/
        Plist_base	   ptr,		/* ptr to list of lists.			*/
        dir	   char (168) unal, /* dir part of phys info seg's path.		*/
        ent	   char (32) unal,	/* ent part of phys info seg's path.		*/
        Nlast_info_no_brief_data
		   fixed bin,	/* Last info processed not containing Syntax sect.*/
        Iinfo	   fixed bin,	/* number of the info seg being processed.	*/
        Ninfos_printed fixed bin,	/* number of infos for which something printed.	*/
        Iunit_syntax   (10) fixed bin,	/* indices of Syntax sections.		*/
        Nunit_bf_prt   fixed bin,	/* count of brief sections to print.		*/
        Nlists_of_bf_args
		   fixed bin,	/* count of sections containing args/ctl_args.	*/
        Nlines	   fixed bin,
        save_lines	   fixed bin;

    dcl 1 Dlinfo_	   aligned based (PDlinfo_),
	2 Nunits	   fixed bin,	/* number of units (pghs) in this log info seg.	*/
	2 Nsections  fixed bin,	/* number of units having section title.	*/
	2 unit	   (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;

    dcl Iunit	   fixed bin,
        Plist	   ptr,
        (i, j, k)	   fixed bin;

    dcl 1 list_base	   aligned based (Plist_base),
	2 N	   fixed bin,	/* number of lists in this list ptr structure.	*/
	2 Nmax	   fixed bin,	/* max possible number of lists in structure.	*/
	2 Ispace_used_set
		   fixed bin,	/* index of last list on which space used was set.*/
	2 Plists	   (0 refer (list_base.Nmax)) ptr;
				/* pointers to list structures.		*/

    dcl 1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;

    dcl store_arg	   char (88) varying;

    Syntax_section, Sprt_list_of, Sprt_one_paragraph, Sprt_bf_heading = FALSE;
    Nunit_bf_prt = 0;
    save_lines = 0;


    do Iunit = 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.syntax_list);
    end;				/*   Search for the "Syntax" section.             */
    if Iunit <= Dlinfo.Nunits then
      do;
        Syntax_section = TRUE;
        do i = 1 to dimension (Iunit_syntax, 1) while (Iunit <= Dlinfo_.Nunits);
	Iunit_syntax (i) = Iunit;	/* Find & record location of syntax sections.     */
	Nunit_bf_prt = i;
	do Iunit = Iunit, Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.scn);
	  Nlines = Nlines + Dlinfo_.unit (Iunit).Nlines + 1;
	end;			/* Count lines in each pgh of Syntax section.     */
				/* Add 1 line for blank line preceding each pgh.  */


	if ^Sold_format then
	  do Iunit = Iunit to Dlinfo_.Nunits
	       while (substr (Dlinfo_.unit (Iunit).title, 1, min (6, length (Dlinfo_.unit (Iunit).title))) ^= "Syntax");
	  end;
	else Iunit = Dlinfo_.Nunits + 1;
        end;
      end;

    save_lines = save_lines + Nlines;

    if ^Syntax_section then
      do;
        do Iunit = 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.arg_list);
        end;
        if Iunit <= Dlinfo_.Nunits then
	do;
	  Sprt_args = TRUE;
	  Nunit_bf_prt = 1;
	  goto end_ck;
	end;

        do Iunit = 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.list_of_list);
        end;
        if Iunit <= Dlinfo_.Nunits then
	do;
	  Sprt_list_of = TRUE;
	  Nunit_bf_prt = 1;
	  goto end_ck;
	end;

        Sprt_one_paragraph = TRUE;

end_ck:
      end;


    Iunit = 1;
    do while (Iunit <= Dlinfo_.Nunits); /* Search for "Arguments" & "Control arguments" & "List of  */
				/*   paragraphs to summarize these arguments.     */
      if Sprt_args | Syntax_section then
        do Iunit = Iunit to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.arg_list);
        end;

      if Sprt_list_of then
        do Iunit = Iunit to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.list_of_list);
				/* Search for List of                            */
        end;


      if Iunit <= Dlinfo_.Nunits then
        do;
	Plist = get_list (Plist_base);
	if Plist = null () then
	  Iunit = Dlinfo_.Nunits + 1;
	else
	  do;

	    if Sprt_one_paragraph then
	      do;
	        Nlines = Dlinfo_.unit (Iunit).Nlines;
	        Nlists_of_bf_args = list_base.N;
	        Nunit_bf_prt = 1;
	        return;
	      end;

	    list.title = Dlinfo_.unit (Iunit).title;
	    list.Iunit = Iunit;
	    if length (list.title) <= 17 then
	      do;
	        list.N = 1;
	        list.arg (1) = list.title;
	        list.arg (1) = list.arg (1) || ":";
	      end;		/* Put title on same line as arg names, unless	*/
				/* title is too long.			*/


	    do Iunit = Iunit, Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.scn);
	      list_of = Dlinfo_.unit (Iunit).S.list_of_list;
				/* Switch to indicate unit is a list of items or examples*/
	      call get_arg_list (Dlinfo_.unit (Iunit), Plist, Sold_format);
	    end;
	    if Syntax_section & list.N > 0 & list.title = "Arguments" then
	      do;			/* Suppress Arguments list if all arg names	*/
				/* appear in Syntax section.			*/
	        if list.arg (1) = "Arguments:" then
		i = 2;
	        else i = 1;
	        Sfound = TRUE;
	        bf_no_ARG_dsp = FALSE;
	        do i = i to list.N while (Sfound);
		do j = 1 to Nunit_bf_prt while (Sfound);
		  Ppgh = Dlinfo_.unit (Iunit_syntax (j)).Pstart;
		  Lpgh = Dlinfo_.unit (Iunit_syntax (j)).L;
		  if list.arg (i) ^= "," then
		    store_arg = rtrim (list.arg (i), "])0123456789, ");
		  else store_arg = rtrim (list.arg (i), "])0123456789 ");
		  store_arg = ltrim (store_arg, "[(");
		  k = index (pgh, store_arg);
		  if k = 0 then
		    Sfound = FALSE;
		  else j = Nunit_bf_prt;
				/*Dont continue looking if found arg*/
		end;
	        end;
	        if Sfound then
		do;
		  list.N = 0;
		  bf_no_ARG_dsp = TRUE;
		end;
	      end;

	    if list.N = 1 then
	      if list.title = substr (list.arg (1), 1, length (list.arg (1)) - 1) then
	        list.N = 0;


	    if list.N > 0 then
	      do;
	        if list.title = substr (list.arg (1), 1, length (list.arg (1)) - 1) then
		list.title = "";
	        call format_list (Plist, 0, 1);
	        save_lines = save_lines + ct_lines + 1;
				/*One line for blank line preceeding pgh*/
	        if length (list.title) > 0 then
		save_lines = save_lines + 1;
	      end;
	    else list_base.N = list_base.N - 1;
	  end;
        end;
    end; 
    Nlists_of_bf_args = list_base.N;
    Nlines = save_lines;
    return;


print_brief_data:
  entry (PDlinfo_, Plist_base, Iunit_syntax, Nunit_bf_prt, Nlists_of_bf_args, Nlines);


    if Sprt_one_paragraph then
      do;
        if Sprt_bf_heading then
	do;
	  Nlines = Dlinfo_.unit (Iunit).Nlines + 2;
	  call print_header ();
	end;
        else Nlines = Dlinfo_.unit (Iunit).Nlines;
        call print_pgh (Dlinfo_.unit (Iunit), Sprint_inhibit);
        Nlists_of_bf_args = list_base.N;
        return;
      end;

    Iunit = 0;
    j = 1;			/* For -brief, print Syntax section and list of	*/
    do i = 1 to Nunit_bf_prt;		/* ctl args in order that their sections appear	*/
PRINT_NEXT_LIST:
      if j <= Nlists_of_bf_args then
        do;			/* in the info.				*/
	Plist = list_base.Plists (j); /*   Print lists of args.			*/
	if list.Iunit < Iunit_syntax (i) then
	  do;
	    call print_list (Plist, FALSE);
	    j = j + 1;
	    go to PRINT_NEXT_LIST;
	  end;
        end;

      Sfirst_time = TRUE;

      if Syntax_section then
        do Iunit = Iunit_syntax (i), Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (Iunit).S.scn);
	if Iunit = Iunit_syntax (1) then
	  multiple_syntax = FALSE;
	else multiple_syntax = TRUE;

	call print_pgh (Dlinfo_.unit (Iunit), FALSE);
        end;			/* Print syntax sections.			*/

      if ^multiple_syntax then
        Sfirst_time = FALSE;
    end;

    if Iunit > 1 then
      if Dlinfo_.unit (Iunit - 1).Nlines = 1 then
        one_line_pgh = TRUE;
      else one_line_pgh = FALSE;
    else one_line_pgh = FALSE;


    do j = j to Nlists_of_bf_args;	/* Print remaining lists of ctl args.		*/
      call print_list (list_base.Plists (j), FALSE);
    end;


    if Nlists_of_bf_args > 0 then
      do;
        Pnext_free_space = list_base.Plists (1);
        list_base.N = 0;
      end;
    return;

  end get_brief_data;

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


get_ep_list:
  procedure (ref_name, PDeps_, Plist);	/* Create list of entry points in this phys. seg.	*/

    dcl ref_name	   char (32) varying,
        (PDeps_, Plist)
		   ptr;

    dcl 1 Deps_	   aligned based (PDeps_),
	2 Nlines	   fixed bin,
	2 N	   fixed bin,
	2 linfo	   (0:0 refer (Deps_.N)) like Deps.linfo;
    dcl 1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;

    dcl (i, j, k)	   fixed bin;

    do i = 1 to Deps.N;		/* Build list of all entry point info headers.	*/
      k, list.N = list.N + 1;
      if length (Deps_.linfo (i).header) > 0 then
        do;			/* If header already exists, use it.		*/
	list.arg (k) = Deps_.linfo (i).header;
	if length (list.arg (k)) > 21 then
	  do;			/* Split a long heading into several lines.	*/
	    j = 20 + index (substr (list.arg (k), 21), SP);
	    do while (j > 20);
	      k, list.N = list.N + 1;
	      list.arg (k) = "   ";
	      j = j + verify (substr (list.arg (k - 1), j), SP) - 1;
	      list.arg (k) = list.arg (k) || substr (list.arg (k - 1), j);
	      list.arg (k - 1) = rtrim (substr (list.arg (k - 1), 1, j - 1));
	      if length (list.arg (k)) > 21 then
	        j = 20 + index (substr (list.arg (k), 21), SP);
	      else j = 0;
	    end;
	  end;
        end;
      else
        do;			/* If doesn't exist, make one up.		*/
	list.arg (k) = ref_name;
	list.arg (k) = list.arg (k) || "$";
	list.arg (k) = list.arg (k) || Deps_.linfo (i).ep_name (1);
	do j = 2 to Deps_.linfo (i).Nep_names;
	  list.arg (k) = list.arg (k) || ",";
	  k, list.N = list.N + 1;
	  list.arg (k) = "   ";
	  list.arg (k) = list.arg (k) || ref_name;
	  list.arg (k) = list.arg (k) || "$";
	  list.arg (k) = list.arg (k) || Deps_.linfo (i).ep_name (j);
	end;
	Deps_.linfo (i).header = list.arg (k);
				/* Apply fruits of our labor by using header	*/
				/* in entry point info as well.		*/
        end;
    end;

  end get_ep_list;

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


get_list:
  procedure (Plist_base) returns (ptr); /* This procedure allocates a new list in	*/
				/*   the help_args segment.			*/

    dcl Plist_base	   ptr;

    dcl 1 list_base	   aligned based (Plist_base),
	2 N	   fixed bin,	/* number of lists in this list ptr structure.	*/
	2 Nmax	   fixed bin,	/* max possible number of lists in structure.	*/
	2 Ispace_used_set
		   fixed bin,	/* index of last list on which space used was set.*/
	2 Plists	   (0 refer (list_base.Nmax)) ptr,
				/* pointers to list structures.		*/
        Plist	   ptr,
        1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;


    if list_base.N = dimension (list_base.Plists, 1) then
      return (null);		/* list of lists full.  Oops!			*/
    if list_base.Ispace_used_set > list_base.N then
      list_base.Ispace_used_set = 0;
    if list_base.Ispace_used_set < list_base.N - 1 then
      return (null);		/* someone forgot to set space used for a list	*/
				/* other than the last in  list of lists.	*/
    if list_base.Ispace_used_set = list_base.N - 1 then
      do;
        Plist = list_base.Plists (list_base.N);
				/* set space used for last list.		*/
        Pnext_free_space = set_space_used (Pnext_free_space, currentsize (list));
        list_base.Ispace_used_set = list_base.N;
      end;
    list_base.N = list_base.N + 1;	/* get new list.				*/
    Plist = Pnext_free_space;
    list_base.Plists (list_base.N) = Plist;
    list.N = 0;
    list.Nreal = 0;
    list.title = "";
    return (Plist);


set_list_size:
  entry (Plist_base, Plist);		/* This procedure sets the size of the current list*/

    if list_base.N = dimension (list_base.Plists, 1) then
      Plist = null;			/* list of lists full.  Oops!			*/
    if list_base.Ispace_used_set > list_base.N then
      list_base.Ispace_used_set = 0;
    if list_base.Ispace_used_set < list_base.N - 1 then
      Plist = null;			/* someone forgot to set space used for a list	*/
				/* other than the last in  list of lists.	*/
    if list_base.Ispace_used_set = list_base.N - 1 then
      do;
        Plist = list_base.Plists (list_base.N);
				/* set space used for last list.		*/
        Pnext_free_space = set_space_used (Pnext_free_space, currentsize (list));
        list_base.Ispace_used_set = list_base.N;
      end;
    return;


give_list_back:			/*return current list*/
  entry (Plist_base, Plist);

    if Plist ^= list_base.Plists (list_base.N) then
      do;
        call ioa_ ("help logic error");
        return;
      end;
    list_base.N = list_base.N - 1;
    Plist = null;
    return;

  end get_list;


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


get_list_base:
  procedure (Pnext_free_space, space_used, Nmax) returns (ptr);

    dcl Pnext_free_space
		   ptr,		/* ptr to next free word of space in temp seg.	*/
        space_used	   fixed bin (21),	/* number of words used at that free word loc.	*/
        Nmax	   fixed bin,	/* number of lists to maintain in list of lists.	*/
        Plist_base	   ptr;		/* ptr to creates list of lists.		*/

    dcl 1 list_base	   aligned based (Plist_base),
	2 N	   fixed bin,	/* number of lists in this list ptr structure.	*/
	2 Nmax	   fixed bin,	/* max possible number of lists in structure.	*/
	2 Ispace_used_set
		   fixed bin,	/* index of last list on which space used was set.*/
	2 Plists	   (0 refer (list_base.Nmax)) ptr;
				/* pointers to list structures.		*/

    if space_used ^= 0 then		/* set space used by previous allocation.	*/
      Pnext_free_space = set_space_used (Pnext_free_space, space_used);
    Plist_base = Pnext_free_space;	/* get list of lists.			*/
    list_base.N = 0;		/* No lists listed yet.			*/
    list_base.Ispace_used_set = 0;
    list_base.Nmax = Nmax;
    if Nmax > 0 then		/* Size known?  Set space used.		*/
      Pnext_free_space = set_space_used (Pnext_free_space, currentsize (list_base));
    return (Plist_base);

  end get_list_base;

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


get_title_list:
  procedure (PDlinfo_, Plist, Iunit_start);
				/* This entry builds a list of titles.		*/

    dcl PDlinfo_	   ptr,
        Plist	   ptr,
        Iunit_start	   fixed bin;	/* Current unit number.  Get title of following	*/
				/* units.					*/

    dcl Iunit	   fixed bin,
        Nlines	   fixed bin,
        Nlines_pic	   pic "zzzzz9",
        (i, j, k)	   fixed bin;
    dcl 1 Dlinfo_	   aligned based (PDlinfo_),
				/* structure defining all paragraphs (units) in	*/
				/*   an entry point (logical info seg - linfo).	*/
	2 Nunits	   fixed bin,	/*   number of units in this ep.		*/
	2 Nsections  fixed bin,	/*   number of units beginning a section.	*/
	2 unit	   (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;
				/*   unit (paragraph) descriptors.		*/
    dcl 1 list	   aligned based (Plist),
	2 header	   like LIST.header,
	2 group	   (0 refer (list.N)) like LIST.group,
	2 print_array
		   (0 refer (list.Npghs), 0 refer (list.Nrows)) like LIST.print_array;

    do Iunit = Iunit_start + 1 to Dlinfo_.Nunits;
      if (get_title ()) then
        do;
	k, list.N = list.N + 1;
	if Iunit = 1 then
	  if ^Dlinfo_.unit (1).S.scn then
	    list.arg (k) = "UNTITLED";
	  else list.arg (k) = Dlinfo_.unit (Iunit).title;
	else list.arg (k) = Dlinfo_.unit (Iunit).title;
	if length (list.arg (k)) > 21 then
	  do;			/* Split a long section title into several lines.	*/
	    j = 20 + index (substr (list.arg (k), 21), SP);
	    do while (j > 20);
	      k, list.N = list.N + 1;
	      list.arg (k) = "   ";
	      j = j + verify (substr (list.arg (k - 1), j), SP) - 1;
	      list.arg (k) = list.arg (k) || substr (list.arg (k - 1), j);
	      list.arg (k - 1) = MULTI_LINE_ARG_ID || rtrim (substr (list.arg (k - 1), 1, j - 1));
	      if length (list.arg (k)) > 21 then
	        j = 20 + index (substr (list.arg (k), 21), SP);
	      else j = 0;
	    end;
	  end;
	Nlines = Dlinfo_.unit (Iunit).Nlines;
				/* Count lines in  section.			*/
	do i = Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit (i).S.scn);
	  Nlines = Nlines + Dlinfo_.unit (i).Nlines + 2;
	end;
	Iunit = i - 1;
	Nlines_pic = Nlines;
	list.arg (k) = list.arg (k) || " (";
	list.arg (k) = list.arg (k) || ltrim (Nlines_pic);
	list.arg (k) = list.arg (k) || ")";
        end;
    end;

get_title:
  proc returns (bit (1));

    if Dlinfo_.unit (Iunit).S.ep_list then
      return (FALSE);
    else if Dlinfo_.unit (Iunit).S.scn then
      return (TRUE);
    else if Iunit = 1 then
      return (TRUE);
    else return (FALSE);

  end get_title;

    if list.N = 0 then
      do;
        list.N = 1;
        list.arg (1) = "NO MORE TITLES";
      end;

  end get_title_list;

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

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

dcl     Phelp_requests ptr;

list_requests:
  proc;

    dcl error_type	   fixed bin,
        code	   fixed bin (35);

    dcl 1 help_requests
		   aligned based (Phelp_requests) like help_args;

    Phelp_requests = help_args.help_data_ptr;

    if Phelp_requests = null then 
      do;
        call help_$init (ME, "info", "", Vhelp_args_3, help_args.help_data_ptr, code);
        if code ^= 0 then 
          do;
            call ioa_ ("Unable to initiate help_ for list request.");
            goto QUIT;
          end;
        Phelp_requests = help_args.help_data_ptr;
      end;
    
    help_requests.Npaths = 1;
    help_requests.path(1).value = ">doc>info>help_responses";
    help_requests.path(1).info_name = "";

    if lr.N > 0 then do;
      do i = 1 to lr.N;
        help_requests.Npaths = i;
        if i > 1 then
	help_requests.path (i).value = help_requests.path(1).value;
        if lr.ca (i) = "." | lr.ca (i) = "?" | lr.ca (i) = ".." then
	help_requests.path(i).S.info_name_not_starname = TRUE;
        help_requests.path (i).info_name = lr.ca (i);
      end;
      call ioa_ ("^/----------HELP RESPONSE^[S^;-^]---------", lr.N>1);
    end;
    else
    call ioa_ ("^/---------------------------------");

    call help_ (ME, Phelp_requests, "info", error_type, code);

    help_requests.Npaths = 0;
    call ioa_ ("---END OF RESPONSE DESCRIPTION---");
    return;

  end list_requests;

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


parse_answer:
  proc (answer, op, ep_name, ca, scn, srh, lr);

    dcl answer	   char (500) varying,
        op	   fixed bin,	/* Operation specified by the answer.		*/
        ep_name	   char (65) varying,
				/* Name of entry point given  in ep request.	*/
        1 ca	   aligned,
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group,
        1 scn	   aligned,
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group,
        1 srh	   aligned,
	2 header	   like LIST.header,
	2 group	   (100) like LIST.group,
        1 lr	   aligned,
	2 N	   fixed bin,
	2 ca	   (100) char (32) varying;

    dcl (i, j, k)	   fixed bin,
        operation	   char (12) varying,
        operand	   char (89) varying;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The tables below define the following combinations of answers and control args.	*/
/*									*/
/*    OP_CODE OPERATION   OP_CODE OPERATION   OP_CODE OPERATION  OP_CODE OPERATION	*/
/*	 1  yes, y	 5  rest, r	 9  skip, s        14  title		*/
/*	 2  no, n		 6  rest -scn       10  skip -scn	   titles		*/
/*	 3  quit, q	 7  rest -aep 	11  skip -ep       15  title -top	*/
/*	 4  top, t	 8  rest -ep	12  skip -rest	   titles -top	*/
/*					13  skip -seen     16  entry_point {STR}*/
/*							   ep {STR}	*/
/*									*/
/*	17  section {STRs}			21  search {STRs}			*/
/*	    scn     {STRs}			    srh    {STRs}			*/
/*	    section {STRs} -ncs		    search {STRs} -ncs		*/
/*	    scn     {STRs} -ncs		    srh    {STRs} -ncs		*/
/*	18  section {STRs} -cs     		22  search {STRs} -cs     		*/
/*	    scn     {STRs} -cs       		    srh    {STRs} -cs     		*/
/*	19  section {STRs} -top		23  search {STRs} -top		*/
/*	    scn     {STRs} -top		    srh    {STRs} -top		*/
/*	    section {STRs} -top -ncs		    search {STRs} -top -ncs		*/
/*	    scn     {STRs} -top -ncs		    srh    {STRs} -top -ncs		*/
/*	20  section {STRs} -top -cs  		24  search {STRs} -top -cs  		*/
/*	    scn     {STRs} -top -cs  		    srh    {STRs} -top -cs  		*/
/*									*/
/*	25  brief				30  list_entry_points		*/
/*	    bf				    lep   			*/
/*	26  control_arg STRs		31  list_requests {STRs}		*/
/*	    ca STRs			    lr            {STRs}     		*/
/*	27  .				32  help                                */
/*	28  ?				    h                                   */
/*	29  header							*/
/*	    he								*/
/*									*/
/* -scn is the short name for -section.  Both are accepted.				*/
/* sc is obsolete short name for section.  It is still accepted, but -sc is not accept	*/
/*	as control arg in help requests.  It is accepted in command line, however.	*/
/* sh is obsolete short name for search.   It is still accepted.			*/
/* titles is in error, but is a common error for the title request.  Accept it anyway.	*/
/* -ep  is the short name for -entry_point.  Both are accepted.			*/
/* list_request and help both return help on a help response.                             */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl defined_ops	   (36) char (20) varying int static options (constant) init (
		      "yes", "y", "no", "n",		/*  1 to  4 */
		      "quit", "q", "top", "t",	/*  5 to  8 */
		      "rest", "r", "skip", "s",	/*  9 to 12 */
		      "title", "titles",		/* 13 &  14 */
		      "entry_point", "ep",		/* 15 &  16 */
		      "section", "scn", "sc",		/* 17 to 19 */
		      "search", "srh", "sh",		/* 20 to 22 */
		      "brief", "bf",		/* 23 &  24 */
		      "control_arg", "ca",		/* 25 &  26 */
		      ".", "?", "header", "he",	/* 27 to 30 */
		      "list_entry_points", "lep",	/* 31 to 32 */
		      "list_requests", "lr",		/* 33 to 34 */
		      "help", "h"),			/* 35 to 36 */
        op_code	   (36) fixed bin int static options (constant) init (
		   /* "yes", "y", "no", "n",		*/  1,  1,  2,  2, 
		   /* "quit", "q", "top", "t",	*/  3,  3,  4,  4, 
		   /* "rest", "r", "skip", "s",	*/  5,  5,  9,  9, 
		   /* "title", "titles",		*/ 14, 14, 
		   /* "entry_point", "ep",		*/ 16, 16, 
		   /* "section", "scn", "sc",		*/ 17, 17, 17, 
		   /* "search", "srh", "sh",		*/ 21, 21, 21,
		   /* "brief", "bf",		*/ 25, 25,
		   /* "control_arg", "ca",		*/ 26, 26, 
		   /* ".", "?", "header", "he",	*/ 27, 28, 29, 29,
		   /* "list_entry_points", "lep",	*/ 30, 30,
		   /* "list_requests", "lr",		*/ 31, 31, 
		   /* "help", "h"),			*/ 32, 32);

    dcl prev_operand   fixed bin;
    dcl (OPERAND_NCS   init (0),        /* 0           -ncs    */
         OPERAND_CS	   init (1),        /* 1           -cs    */
         OPERAND_TOP   init (2))        /* 2           -top    */
		   fixed bin int static options(constant);

    k = 0;			/* No search  or section operands processed yet.	*/
    ca.N = 0;			/* Control_args must be given  with every ca req.	*/
    lr.N = 0;
    ep_name = "";
    i = search (answer, HT_SP);	/* Find end of request name in answer.		*/
    if i = 0 then
      i = length (answer) + 1;
    operation = substr (answer, 1, i - 1);
				/* Request name is our operation.		*/
    if length (operation) > maxlength (defined_ops (1)) then
      do;
RESPONSE_UNKNOWN:
        call ioa_$nnl ("Response unknown:  ^a.  ", substr (answer, 1, i - 1));
ERROR:
        op = hbound (parse_operand, 1) + 1;
				/* Error op code.				*/
        return;
      end;
    else if length (operation) = 0 then
      go to ERROR;			/* Just reask question for blank lines.		*/
    do j = 1 to dimension (defined_ops, 1) while (operation ^= defined_ops (j));
    end;				/* See if operation defined.			*/
    if j > dimension (defined_ops, 1) then
      go to RESPONSE_UNKNOWN;		/* No?  Report the error.			*/


    op = op_code (j);
    if i >= length (answer) then	/* Remainder of answer is operands.		*/
      answer = "";
    else answer = ltrim (substr (answer, i), HT_SP);
				/* Trim leading SP HT from operands.		*/
    do while (length (answer) > 0);	/* Process operands.			*/
      i = search (answer, HT_SP);
      if i = 0 then
        i = length (answer) + 1;
      operand = substr (answer, 1, i - 1);
      go to parse_operand (op);

parse_operand (1):			/* yes					*/
parse_operand (2):			/* no					*/
parse_operand (3):			/* quit					*/
parse_operand (4):			/* top					*/
      go to NO_OPERANDS;

parse_operand (5):			/* rest					*/
parse_operand (6):			/* rest -scn				*/
parse_operand (7):			/* rest -aep				*/
parse_operand (8):                      /* rest -ep                                       */
      if operand = "-section" | operand = "-scn" then
        op = op_code(j) + 1;
      else if operand = "-all_entrypoints" | operand = "-aep" then
        op = op_code(j) + 2;
      else if operand = "-entrypoint" | operand = "-ep" then
        op = op_code(j) + 3;
      else go to BAD_OPERAND;
      go to NEXT_OPERAND;

parse_operand (9):			/* skip					*/
parse_operand (10):			/* skip -scn				*/
parse_operand (11):			/* skip -ep				*/
parse_operand (12):			/* skip -rest				*/
parse_operand (13):			/* skip -seen				*/
      if operand = "-section" | operand = "-scn" then
        op = op_code(j) + 1;
      else if operand = "-entry_point" | operand = "-ep" then
        op = op_code(j) + 2;
      else if operand = "-rest" | operand = "-r" then
        op = op_code(j) + 3;
      else if operand = "-seen" then
        op = op_code(j) + 4;
      else go to BAD_OPERAND;
      go to NEXT_OPERAND;

parse_operand (14):			/* title					*/
parse_operand (15):			/* title -top				*/
      if operand = "-top" | operand = "-t" then
        op = op_code(j) + 1;
      else go to BAD_OPERAND;
      go to NEXT_OPERAND;

parse_operand (16):			/* entry_point or ep			*/
      if k > 0 then
        do;
	call ioa_ ("Only one entry point name can be given in  ^a  response.", operation);
	go to ERROR;
        end;
      if length (operand) > maxlength (ep_name) then
        do;
	call ioa_ ("Entry point name  ^a  is too long.", operand);
	go to ERROR;
        end;
      ep_name = operand;
      k = 1;
      go to NEXT_OPERAND;

parse_operand (17):			/* section				*/
				/* section -ncs				*/
parse_operand (18):			/* section -cs				*/
parse_operand (19):			/* section -top				*/
				/* section -top -ncs                              */
parse_operand (20):                     /* section -top -cs                               */
      if operand = "-non_case_sensitive" | operand = "-ncs" then
        do;
          prev_operand = op - op_code(j);
	if prev_operand >= OPERAND_TOP then
	  op = op_code(j) + OPERAND_NCS + OPERAND_TOP;
	else
	  op = op_code(j) + OPERAND_NCS;
        end;
      else if operand = "-case_sensitive" | operand = "-cs" then
        do;
          prev_operand = op - op_code(j);
	if prev_operand >= OPERAND_TOP then
	  op = op_code(j) + OPERAND_CS + OPERAND_TOP;
	else
	  op = op_code(j) + OPERAND_CS;
        end;
      else if operand = "-top" | operand = "-t" then
        do;
          prev_operand = op - op_code(j);
	if mod(prev_operand,OPERAND_TOP) = OPERAND_CS then
	  op = op_code(j) + OPERAND_TOP + OPERAND_CS;
	else
	  op = op_code(j) + OPERAND_TOP + OPERAND_NCS;
        end;
      else
        do;
	if length (operand) > maxlength (scn.group (1).arg) then
	  do;
	    Lcount = length("Operand    of    response is too long.");
	    Snl1 = (Lcount + i + length (operation) > Loutput_line);
	    call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ",
	         substr (answer, 1, i - 1), Snl1, operation);
	    go to ERROR;
	  end;
	if k = dimension (scn.group, 1) then
	  do;
	    call ioa_$nnl ("More than ^d substrings given with  ^a  response.  ",
	      dimension (scn.group, 1), operation);
	    go to ERROR;
	  end;
	k, scn.N = k + 1;
	scn.arg (k) = operand;
        end;
      go to NEXT_OPERAND;

parse_operand (21):			/* search					*/
				/* search -ncs				*/
parse_operand (22):			/* search -cs				*/
parse_operand (23):			/* search -top				*/
				/* search -top -ncs                               */
parse_operand (24):                     /* search -top -cs                                */
      if operand = "-non_case_sensitive" | operand = "-ncs" then
        do;
          prev_operand = op - op_code(j);
	if prev_operand >= OPERAND_TOP then
	  op = op_code(j) + OPERAND_NCS + OPERAND_TOP;
	else
	  op = op_code(j) + OPERAND_NCS;
        end;
      else if operand = "-case_sensitive" | operand = "-cs" then
        do;
          prev_operand = op - op_code(j);
	if prev_operand >= OPERAND_TOP then
	  op = op_code(j) + OPERAND_CS + OPERAND_TOP;
	else
	  op = op_code(j) + OPERAND_CS;
        end;
      else if operand = "-top" | operand = "-t" then
        do;
          prev_operand = op - op_code(j);
	if mod(prev_operand,OPERAND_TOP) = OPERAND_CS then
	  op = op_code(j) + OPERAND_TOP + OPERAND_CS;
	else
	  op = op_code(j) + OPERAND_TOP + OPERAND_NCS;
        end;
      else
        do;
	if length (operand) > maxlength (srh.group (1).arg) then
	  do;
	    Lcount = 38;		/* 38 = length("Operand    of    response is too long.");	*/
	    Snl1 = (Lcount + i + length (operation) > Loutput_line);
	    call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ",
	         substr (answer, 1, i - 1), Snl1, operation);
	    go to ERROR;
	  end;
	if k = dimension (srh.group, 1) then
	  do;
	    call ioa_$nnl ("More than ^d substrings given with  ^a  response.  ", dimension (srh.group, 1), operation);
	    go to ERROR;
	  end;
	k, srh.N = k + 1;
	srh.arg (k) = operand;
        end;
      go to NEXT_OPERAND;

parse_operand (25):			/* brief					*/
      go to NO_OPERANDS;

parse_operand (26):			/* control_arg STRs				*/
    dcl CONTROL_ARG_OP init(26) fixed bin int static options(constant);
      if length (operand) > maxlength (ca.group (1).arg) then
        do;
	Lcount = 38;		/* 38 = length("Operand    of    response is too long.");	*/
	Snl1 = (Lcount + i + length (operation) > Loutput_line);
	call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ", substr (answer, 1, i - 1), Snl1, operation);
	go to ERROR;
        end;
      if k = dimension (ca.group, 1) then
        do;
	call ioa_$nnl ("More than  ^d  substrings given with  ^a  response.  ", dimension (ca.group, 1), operation);
	go to ERROR;
        end;
      k, ca.N = k + 1;
      ca.arg (k) = operand;
      go to NEXT_OPERAND;

parse_operand (27):			/* . (= print "help")			*/
parse_operand (28):			/* ? (= list requests)			*/
parse_operand (29):			/* header					*/
parse_operand (30):			/* list_entry_points			*/
      go to NO_OPERANDS;

parse_operand (31):			/* list_requests				*/
parse_operand (32):                     /* help request				*/
      lr.N = 0;
      if length (operand) > maxlength (lr.ca (1)) then
        do;
	Lcount = 38;		/* 38 = length("Operand    of    response is too long.");	*/
	Snl1 = (Lcount + i + length (operation) > Loutput_line);
	call ioa_$nnl ("Operand  ^a^[^/^]  of  ^a  response is too long.  ", substr (answer, 1, i - 1), Snl1, operation);
	go to ERROR;
        end;
      if k = dimension (lr.ca, 1) then
        do;
	call ioa_$nnl ("More than  ^d  substrings given with  ^a  response.  ", dimension (lr.ca, 1), operation);
	go to ERROR;
        end;
      k, lr.N = k + 1;
      lr.ca (k) = operand;
      go to NEXT_OPERAND;

NO_OPERANDS:
      call ioa_$nnl ("^a  response does not allow operands.  ", operation);
      go to ERROR;

BAD_OPERAND:
      call ioa_$nnl ("Operand  ^a  invalid for  ^a  operation.  ", operand, operation);
      go to ERROR;

NEXT_OPERAND:
      if i >= length (answer) then
        answer = "";
      else answer = ltrim (substr (answer, i), HT_SP);
    end;				/* Strip leading HT SP from next operand.	*/

    if op = CONTROL_ARG_OP then	/* control_arg STRs				*/
      if ca.N = 0 then
        do;
	call ioa_$nnl ("Substrings must be given with the  ^a  response.  ", operation);
	op = hbound (parse_operand, 1) + 1;
        end;

  end parse_answer;

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


parse_entry_point_into_units:
  procedure (linfo, Pcommon_units, Ncommon_units, PDlinfo_);
				/* This procedure parses an entry point (logical 	*/
				/*   info segment) into units (paragraphs).	*/

    dcl 1 linfo	   aligned like Deps.linfo,
        Pcommon_units  ptr,
        Ncommon_units  fixed bin,
        PDlinfo_	   ptr;		/* ptr to descriptors for this log info seg.	*/

    dcl 1 Dlinfo_	   aligned based (PDlinfo_),
	2 Nunits	   fixed bin,	/* number of units (pghs) in this log info seg.	*/
	2 Nsections  fixed bin,	/* number of units having section title.	*/
	2 unit	   (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;

    dcl 1 common_units (Ncommon_units) aligned based (Pcommon_units) like Dlinfo.unit;

    dcl (i, j)	   fixed bin (24),
        new_paragraph  bit (1) init ("0"b),
        save_length	   fixed bin (21);

    Dlinfo_.Nunits = 0;
    Dlinfo_.Icommon_unit = 0;
    Dlinfo_.Nsections = 0;
    list_of = FALSE;
    linfo.PDlinfo = PDlinfo_;
    Pline_text, Pline = linfo.Pstart;
    Lline_text = linfo.L;
    save_length = 0;
    Lline = 0;
    Lparg = 0;
    Number_lines = 0;
    j = 0;			/*init counter */
    Dlinfo_.Nunits = 0;

    call line$skip_blanks;

    if ^line$skip_blank () then
      do;
        call ioa_ ("Empty info segment: ^a^[>^]^a", Dinfo_seg_.dir, Dinfo_seg_.dir ^= ">", Dinfo_seg_.ent);
        Ninfos_printed = 1;		/* Do not want no match error displayed upon return to help_ */
        goto RETURN;
      end;

    call line$generated;		/* strip off "List generated line..."		*/

    Sfirst_pgh = TRUE;		/* do not want to increment line ptr lst time	*/

    new_paragraph = TRUE;

    do while (line$next ());
      if Sfirst_pgh then
        Sfirst_pgh = FALSE;
      if new_paragraph then
        do;
	j = j + 1;
	Dlinfo_.Nunits = Dlinfo_.Nunits + 1;
	Dlinfo_.unit (j).title = "";
	Dlinfo_.unit (j).Pstart = Pline;
	Dlinfo_.unit (j).S = FALSE;
	Dlinfo_.unit (j).Icommon_unit = 0;
	Number_lines = 1;
	Lparg = Lline;

	if line$contains (colon) then
	  current_line_begins_section = TRUE;
	else current_line_begins_section = FALSE;

	if current_line_begins_section then
	  do;
	    Dlinfo_.unit (j).title = line$title ();

	    list_of = FALSE;
	    if length (Dlinfo_.unit (j).title) >= 8 then
	      if substr (Dlinfo_.unit (j).title, 1, 8) = "List of " then
	        list_of = TRUE;

	    if length (Dlinfo_.unit (j).title) >= 6 then
	      if substr (Dlinfo_.unit (j).title, 1, 6) = "Syntax" then
	        Dlinfo_.unit (j).S.syntax_list = TRUE;

	    Dlinfo_.unit (j).S.list_of_list = list_of;
	    Dlinfo_.unit (j).S.arg_list = section$arg_list (Dlinfo_.unit (j).title);

	    Dlinfo_.unit (j).Pstart = Pline;
	    Dlinfo_.unit (j).S.scn = TRUE;
	    Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
	  end;

	else if j > 1 then
	  do;			/* propagate arg_list findings to all paragraphs  */
				/* of section				*/
	    if Dlinfo_.unit (j - 1).S.arg_list then
	      Dlinfo_.unit (j).S.arg_list = TRUE;
	    Dlinfo_.unit (j).S.list_of_list = list_of;
	  end;
        end;			/*new paragraph*/

      new_paragraph = line$new_pgh ();
      if new_paragraph then
        do;
	Dlinfo_.unit (j).L = Lparg + length (NL);
	Dlinfo_.unit (j).Nlines = Number_lines;
	call line$skip_blank_lines;	/* strip off blank lines			*/
        end;
    end;				/*line next*/

    Dlinfo_.unit (j).L = Lparg + length (NL);

    Dlinfo_.unit (j).Nlines = Number_lines;

    if Ncommon_units > 0 then
      do;				/* Add common units onto end of entry point part.	*/
        i = Dlinfo_.Nunits + 1;
        Dlinfo_.Nunits = Dlinfo_.Nunits + Ncommon_units;
        addr (Dlinfo_.unit (i)) -> common_units = common_units;
      end;

                      
    do i = 1 to Dlinfo_.Nunits;          /* Compute line count of entry point part.	*/
       if ^Dlinfo_.unit(i).ep_list then  /* Do not add in ep list lines                   */
         linfo.Nlines = linfo.Nlines + Dlinfo_.unit(i).Nlines;
    end;
 
    if length (linfo.header) > 0 then
      linfo.Nlines = linfo.Nlines + 2;

  end parse_entry_point_into_units;

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


parse_info_into_entry_points:
  procedure (Aptr, LAline, PDeps_);	/* Parse logical info into 1 or more entry points	*/

    dcl Aptr	   ptr,
        LAline	   fixed bin (21),
        PDeps_	   ptr;

    dcl Lline1	   fixed bin (21),
        code	   fixed bin (35),
        i		   fixed bin (21),
        (j, k)	   fixed bin;

    dcl line1	   char (Lline1) based (Pline);

    dcl 1 Deps_	   aligned based (PDeps_),
	2 Nlines	   fixed bin,
	2 N	   fixed bin,
	2 linfo	   (0:0 refer (Deps_.N)) like Deps.linfo;

    Pline_text = Aptr;
    Lline_text = LAline;
    Deps_.N = -1;			/* At least 1 entry point will be found.	*/
    Deps_.Nlines = 0;		/* No lines counted yet in logical info.	*/
				/* Search for 1st log info seg divider.		*/
    do while (^line$end_of_info ());	/* record info about log. info seg.		*/
      Pline = Pline_text;
      Deps_.N, j = Deps_.N + 1;
      Deps_.linfo (j).Nep_names = 0;
      if ^line$entry () & (j = 0) then
        do;			/* This info has no :Entry: lines.		*/
	if line$blank () then
	  do;			/* Strip off leading SP HT NL chars.		*/
	    Deps_.N = Deps_.N - 1;	/* Empty entry.				*/
	    go to END_ENTRIES;
	  end;
        end;

      else
        do;
	Lline1 = index (line, NL);
	if Lline1 = 0 then
	  do;			/* This is last entry point in the info.          */
	    Deps_.N = Deps_.N - 1;
	    if Deps_.N = 0 then
	      do;
	        if Deps_.linfo.header (Deps_.N) = "" then
		Deps_.linfo (Deps_.N).L = LAline;
	        else Deps_.linfo (Deps_.N).L = Deps_.linfo (Deps_.N).L - length (NL);
	      end;
	    else Deps_.linfo (Deps_.N).L = Deps_.linfo (Deps_.N).L - length (NL_NL);
				/* Do not include ending info NLs as part of      */
				/*   length of entry			*/
	    go to END_ENTRIES;
	  end;
	i = index (line1, ":");	/* look for : ending first entry point name.	*/
	do while (i > 0);		/* Sample line looks like:			*/
				/* :Entry: rs: rsnnl: 05/25/78 ioa_$rs, ioa_$rsnnl*/
	  k, Deps_.linfo (j).Nep_names = Deps_.linfo (j).Nep_names + 1;
	  if k <= dim (Deps_.linfo.ep_name, 2) then
	    Deps_.linfo (j).ep_name (k) = ltrim (rtrim (substr (line, 1, i), "	 :"), "	 ");
	  if Lline - i > 0 then
	    Pline = addr (line_arr (i + 1));
	  Lline = Lline - i;
	  Lline1 = Lline1 - i;
	  i = index (line1, ":");
	end;
	if (j > 0) & (Deps_.linfo (j).Nep_names = 0) then
	  do;
	    Deps_.N = Deps_.N - 1;	/* All but common info must have entry point	*/
	    go to NEXT_ENTRY;	/* names.  But look!			*/
	  end;			/* No names!  Can never read this info via help	*/
	if line$blank () then
	  do;			/* Strip off HT SP NL from start of info	*/
	    Deps_.N = Deps_.N - 1;
	    go to NEXT_ENTRY;
	  end;
        end;

      i = verify (line, HT_SP_NL_VT);	/* Skip leading white space 			*/
      Pline = addr (line_arr (i));
      Lline = Lline - i + 1;

      Deps_.linfo (j).Pstart = Pline;
      Deps_.linfo (j).L = Lline;
      Deps_.linfo (j).Nlines = 0;
      Deps_.linfo (j).S = FALSE;
      Lline1 = index (line, NL);	/* header is first line of log. info seg.	*/
      if Lline1 >= Lline then
        do;			/* header is only line of file.		*/
	Deps_.linfo (j).header = "";
	Deps_.linfo (j).date = 0;
        end;
      else if Lline1 + 1 <= Lline then
        if line_arr (Lline1 + 1) = NL then
	do;			/* header line must be followed by 1 blank line, at  least.	*/
	  Deps_.linfo (j).header = ltrim (substr (line, 1, Lline1 - 1));
				/* Remainder should be an entry point name.	*/
	  Deps_.linfo (j).Pstart = addr (line_arr (Lline1 + 1));
	  Deps_.linfo (j).L = Lline - length (Deps_.linfo (j).header);
				/* Remove header from logical info.		*/
	  i = search (substr (line, 1, Lline1), "	 ");
	  if i = 0 then
	    Deps_.linfo (j).date = 0;
	  else
	    do;
	      call convert_date_to_binary_ (substr (line, 1, i - 1), Deps_.linfo (j).date, code);
	      if code ^= 0 then	/* No date!				*/
	        Deps_.linfo (j).date = 0;
	    end;
	end;
        else
	do;
	  Deps_.linfo (j).header = "";
	  Deps_.linfo (j).date = 0;
	end;
      if index (line1, OLD_HELP_PGH_CHAR) > 0 then
				/* check old format info segs with \006 chars	*/
        Deps_.linfo (j).S.old_format = TRUE;
NEXT_ENTRY:
      i = index (line_text, "


:Entry:");
    end;


END_ENTRIES:
  end parse_info_into_entry_points;


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

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

/*    F U N C T I O N S                                                      */

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

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


ck_conditions:
  proc(i) returns (bit (1));

    dcl i		    fixed bin parm;

    if Dlinfo.unit (i).ep_list = TRUE & No_list_elements = 1 then 
                                        /*   Do aggregate an ep list if it only contains  */
                                        /*    one element                                 */
       return (FALSE);   

    if i <= Dlinfo.Nunits then	/*   When aggregating sections, include all	*/
      if ^Ssearch then		/*   section titles in the query.		*/
        if Sseen = seen_pgh (Dlinfo.unit (i)) then
	if Dlinfo.unit (i).Nlines < help_args.min_Lpgh then
	  if Dlinfo.unit (i).Nlines + 2 + Nlines <= help_args.max_Lpgh then
	    return (TRUE);

    return (FALSE);

  end ck_conditions;

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

ck_more_conditions:
  proc(i) returns (bit (1));

    dcl i		    fixed bin parm;

    if i <= Dlinfo.Nunits then	/* Note that, here and above, if current pgh	*/
      if ^Dlinfo.unit (i).S.scn then	/* has already been seen, then can only aggregate	*/
        if ^Ssearch then		/* following pgh if it has been seen as well.	*/
	if Sseen = seen_pgh (Dlinfo.unit (i)) then
	  if Dlinfo.unit (i).Nlines < help_args.min_Lpgh then
	    if Dlinfo.unit (i).Nlines + 2 + Nlines <= help_args.max_Lpgh then
	      return (TRUE);

    return (FALSE);

  end ck_more_conditions;


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


ct_pgh_lines:
  proc;

    Sseen = Deps.linfo (Iep).S.seen_by_user;
    Nlines = Dlinfo.unit (Iunit).Nlines;
    Nprint_units = 1;
    do while (Nlines_less_Lpgh ());	/* Iunit+Nprint_units<=Dlinfo.Nunits		*/
				/* Nlines < Lpgh				*/
      Nlines = Dlinfo.unit (Iunit + Nprint_units).Nlines + 2 + Nlines;
      Nprint_units = Nprint_units + 1;
    end;

  end ct_pgh_lines;

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

Nlines_less_Lpgh:
  proc returns (bit (1));

    if Iunit + Nprint_units <= Dlinfo.Nunits then
      if Dlinfo.unit (Iunit + Nprint_units).Nlines < help_args.min_Lpgh then
        if Dlinfo.unit (Iunit + Nprint_units).Nlines + 2 + Nlines <= help_args.max_Lpgh then
	return (TRUE);

    return (FALSE);

  end Nlines_less_Lpgh;

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

new_section_nscn:
  proc returns (bit (1));

    if new_section ^= "" then
      if ^Dlinfo.unit (Iunit).S.scn then
        return (TRUE);

    return (FALSE);

  end new_section_nscn;

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

print_pgh_titles:
  proc returns (bit (1));
    if help_args.Sctl.title then
      do;				/* print pgh titles when -title is given only if	*/
				/* more than one title will be printed		*/
        if (Dlinfo.Nsections > 1) then
	return (TRUE);
        else if Dlinfo.Nsections = 1 then
	if ^Dlinfo.unit (1).S.scn then
	  return (TRUE);
      end;

    return (FALSE);

  end print_pgh_titles;

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

prt_pgh_nnl:
  proc returns (bit (1));

    if ^help_args.Sctl.he_pn then
      if ^help_args.Sctl.he_info_name then
        if ^help_args.Sctl.he_counts then
	if length (Deps.linfo (Iep).header) = 0 then
	  return (TRUE);

    return (FALSE);

  end prt_pgh_nnl;

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


    dcl Linfo_seg	   fixed bin (21),
        Pinfo_seg	   ptr;


info$init:
  proc (APseg, ALseg);

    dcl ALseg	   fixed bin (21),
        APseg	   ptr;

    Linfo_seg = ALseg;
    Pinfo_seg = APseg;
    call line$init (APseg, ALseg);

  end info$init;

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

initialize_switches:
  proc;

    Sdescription_present = FALSE;
    Sep_list_printed = FALSE;
    Sfirst_time = FALSE;
    Sfirst_pgh = FALSE;
    Sremove_line = FALSE;
    Syntax_section = FALSE;
    Sprt_args = FALSE;
    Sprt_bf_heading = FALSE;
    Sprt_list_of = FALSE;
    Sprt_entry_pts = FALSE;
    Sprt_one_paragraph = FALSE;
    Scase_sensitive = FALSE;

  end initialize_switches;

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

line$args:
  proc;

    dcl Iline	   fixed bin (24),
        continue_line  bit (1) init ("0"b);

    if line ^= "," & substr (reverse (line), 1) = "," | (index (HT_SP, line_text_arr (1)) = 0 & index (NL, line_text_arr (1)) = 0)
         then			/* When line=comma - comma is being used as an arg*/
      continue_line = TRUE;
    else
      do;
        if list_of then		/*List of items*/
	return;
        Iline = index (line, SP_SP);
        if Iline = 0 then
	Iline = index (line, HT);
        if Iline ^= 0 then
	Lline = Iline - 1;
        return;
      end;

    if continue_line then
      do;				/*Determine if there are any consecutive arg*/
				/*lines other than the 1st set that do not  */
				/*end in a comma.                           */
        if Sfirst_time & substr (reverse (line), 1) ^= "," then
	Sremove_line = TRUE;
        else if Sremove_line & substr (reverse (line), 1) ^= "," then
	Sremove_line = FALSE;
      end;

    do while (continue_line & Lline_text > 0);
				/*Control arg continued on next line*/
      Sconsecutive_arg_lines = TRUE;
      Iline = index (line_text, NL);
      if Iline > 0 then
        do;
	if Lline_text - Iline > 0 then
	  Pline_text = addr (line_text_arr (Iline + 1));
	Lline_text = Lline_text - Iline;
	Lline = Lline + Iline;
        end;
      else
        do;
	Lline = Lline + Lline_text;
	Lline_text = 0;
	continue_line = FALSE;
        end;
      if substr (reverse (line), 1, 1) = "," | index (HT_SP, line_text_arr (1)) = 0 then
        ;
      else
        do;
	if Sremove_line & substr (line_text, 1, 3) = SP_SP_SP then
	  Sdescription_present = TRUE;
	else Sdescription_present = FALSE;
	continue_line = FALSE;
        end;
    end;

    return;

  end line$args;

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

line$blank:
  proc returns (bit (1));
    dcl Iline	   fixed bin (24);


    Iline = verify (line, HT_SP_NL);
    if Iline = 0 then
      return (TRUE);
    if Iline > 1 then
      do;
        Pline = addr (line_arr (Iline));
        Lline = Lline - (Iline - 1);
      end;
    return (FALSE);

  end line$blank;

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

line$contains:
  proc (t1) returns (bit (1));

    dcl Iline	   fixed bin (24),
        t1	   char (*);

    Iline = index (line, t1);
    if Iline = 0 then
      return (FALSE);
    return (TRUE);

  end line$contains;

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

line$desc:
  proc returns (bit (1));

    dcl Iline	   fixed bin (24);

    if Lline_text ^> 0 then
      return (FALSE);

    Iline = index (line_text, NL);	/*Find length of current line*/
    Pline = Pline_text;

    if Iline = 0 then
      do;
        Lline = Lline_text;
        Lline_text = 0;
        return (TRUE);
      end;

    if index (HT_SP, line_text_arr (1)) = 0 & index (NL, line_text_arr (1)) = 0 then
      return (FALSE);

    if Iline + 2 <= Lline_text then	/* check for end of pgh			*/
      if index (line_text_arr (Iline + 1), NL) > 0 & index (line_text_arr (Iline + 2), NL) > 0 then
        do;
	Lline = Iline - 1;
	Lline_text = 0;
	return (TRUE);
        end;


    Lline = Iline - 1;
    if Lline_text - Iline > 0 then
      Pline_text = addr (line_text_arr (Iline + 1));
				/* Find start point of next line		*/
    Lline_text = Lline_text - Iline;
    return (TRUE);

  end line$desc;

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


line$end_of_info:
  proc returns (bit (1));

    if length (line_text) + length (line) = 0 then
      return (TRUE);
    else return (FALSE);

  end line$end_of_info;

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

line$entry:
  proc returns (bit (1));

    dcl Iline	   fixed bin (24);



    Iline = index (line_text, "


:Entry:");
    if Iline = 0 then
      do;
        Lline = Lline_text;
        Lline_text = 0;
        return (FALSE);
      end;
    else
      do;
        Lline = Iline - 1;
        if Lline_text - (Iline + 9) > 0 then
	Pline_text = addr (line_text_arr (Iline + 10));
        Lline_text = Lline_text - (Iline + 9);
        return (TRUE);
      end;

  end line$entry;


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

line$HT_SP:
  proc returns (bit (1));

    dcl Iline	   fixed bin (24);

    Iline = index (HT_SP, line_arr (1));
    if Iline > 0 then
      return (TRUE);
    return (FALSE);

  end line$HT_SP;

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

line$generated:
  proc;

    dcl Ibreak	   fixed bin (21),
        Inonwhite	   fixed bin (21),
        Iskip	   fixed bin (21),
        Lword_text	   fixed bin (21),
        Pword_text	   ptr;

    dcl word_text	   char (Lword_text) based (Pword_text),
        word_text_arr  (Lword_text) char (1) based (Pword_text),
        word	   (7) char (80) var,
        Nwords	   fixed bin;

    dcl WORD_BREAKS	   char (4) int static options (constant) init ("	 ()");
				/* HT SP ( and )				*/

    dcl Ptext	   ptr,		/* save ptr to where text starts so can adjust Pline_text*/
        Ltext	   fixed bin;

    Pword_text = Pline_text;
    Lword_text = Lline_text;

    do while (Lword_text > 0 & index (line_text, NL) = 1);
				/* skip any blank lines before text		*/
      if Lword_text - 1 > 0 then
        Pword_text = addr (word_text_arr (2));
      Lword_text = Lword_text - 1;
    end;

    Ptext = Pword_text;
    Ltext = Lword_text;

    Lword_text = index (line_text, NL);
    if Lword_text = 0 then
      Lword_text = length (line_text);
    Nwords = 0;
    word (*) = "";

    Inonwhite = verify (word_text, HT_SP);
				/* skip over white space			*/
    if Inonwhite = 0 then
      Lword_text = 0;
    else if Inonwhite > 1 then
      do;
        Pword_text = addr (word_text_arr (Inonwhite));
        Lword_text = length (word_text) - (Inonwhite - 1);
      end;

    do while (Lword_text > 0 & Nwords < dim (word, 1));
      Ibreak = search (word_text, WORD_BREAKS);
      if Ibreak = 0 then
        Ibreak = length (word_text) + 1;
      if Ibreak > 1 then
        do;
	Nwords = Nwords + 1;
	if Nwords <= dimension (word, 1) then
	  word (Nwords) = substr (word_text, 1, Ibreak - 1);
	if Lword_text - (Ibreak - 1) > 0 then
	  Pword_text = addr (word_text_arr (Ibreak));
	Lword_text = length (word_text) - (Ibreak - 1);
        end;
      Iskip = verify (word_text, WORD_BREAKS);
				/* skip over all consecutive breaks chars	*/
      if Iskip > 0 then
        do;
	Pword_text = addr (word_text_arr (Iskip));
	Lword_text = length (word_text) - (Iskip - 1);
        end;
      else Lword_text = 0;		/* nothing but break characters remain		*/
    end;

    if word (1) = "List" & word (2) = "is" & word (3) = "generated" & word (4) = "by" & word (5) = "the" & word (6) = "help"
         & word (7) = "command" then
      do;
        Pline_text = Ptext;
        Lline_text = Ltext;
        i = index (line_text, NL);
        if i = 0 then
	Lline_text = 0;
        else
	do;
	  if Lline_text - i > 0 then
	    Pline_text = addr (line_text_arr (i + 1));
	  Lline_text = Lline_text - i;
	end;
      end;

    return;

  end line$generated;


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

line$init:
  proc (APseg, ALseg);

    dcl ALseg	   fixed bin (21),
        APseg	   ptr;

    Lline_text = ALseg;
    Pline_text = APseg;
    Number_lines = 0;
    call section$assert_line_begins_a_section (FALSE);

  end line$init;

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

line$list_items:
  proc returns (bit (1));
    dcl Iline	   fixed bin (24);


    Iline = index (line_text, NL);
    if Iline = 1 then		/* blank line				*/
      return (TRUE);

    if Iline > 1 then
      if substr (line_text, 1, Iline - 1) = SP then
        return (TRUE);

    if length (line_text) >= 3 then	/* no description				*/
      if substr (line_text, 1, 3) ^= SP_SP_SP then
        return (TRUE);

    return (FALSE);

  end line$list_items;

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

line$new_pgh:
  proc returns (bit (1));

    dcl Iline	   fixed bin (24);


    if length (line_text) = 0 then	/* on last line				*/
      return (FALSE);

    Iline = index (line_text, NL_NL);	/* looking for NL_NL for total of NL_NL_NL which  */
				/* indicates new pgh			*/
    if Iline = 1 then
      do;				/* found NL_NL_NL				*/

        if Lline_text - 2 > 0 then
	Pline_text = addr (line_text_arr (Iline + 2));
        Lline_text = (length (line_text) - 2);
        return (TRUE);
      end;
    return (FALSE);

  end line$new_pgh;

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

line$next:
  proc returns (bit (1));

    dcl Iline	   fixed bin (24);

    if Sfirst_pgh then		/* do not increment line 1st time through	*/
				/* for procedure parse_entry_point_into_units	*/
      return (TRUE);

    if length (line_text) = 0 | verify (line_text, NL) = 0 then
      return (FALSE);

    Iline = index (line_text, NL);
    if Iline = 0 then
      do;
        Pline = addr (line_text);
        Lline, Iline = length (line_text);
        Lline_text = 0;
      end;
    else
      do;
        Pline = addr (line_text);
        Lline = Iline - 1;
        if Lline_text - Iline > 0 then
	Pline_text = addr (line_text_arr (Iline + 1));
        Lline_text = Lline_text - Iline;
      end;
    Number_lines = Number_lines + 1;
    Lparg = Lparg + Iline;
    return (TRUE);

  end line$next;


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

line$skip_blank:
  proc returns (bit (1));

    do while (line = "");
      if ^line$next () then
        return (FALSE);
    end;
    return (TRUE);

  end line$skip_blank;

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


line$skip_blank_lines:
  proc;

    dcl blk_line	   char (Lblk_line) based (Pblk_line),
        Pblk_line	   ptr,
        Lblk_line	   fixed bin,
        Sblk_line	   bit;

    Sblk_line = TRUE;

    do while (Sblk_line & Lline_text > 0);
      Pblk_line = Pline_text;
      Lblk_line = index (line_text, NL);
      if Lblk_line = 0 then
        do;
	Lblk_line = Lline_text;
	Lline_text = 0;
        end;
      if blk_line = "" then
        do;
	if Lline_text - Lblk_line > 0 then
	  Pline_text = addr (line_text_arr (Lblk_line + 1));
	Lline_text = Lline_text - Lblk_line;
        end;
      else Sblk_line = FALSE;
    end;

    return;

  end line$skip_blank_lines;


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


line$skip_blanks:
  proc;

    dcl Iline	   fixed bin (24);

    Iline = verify (line_text, "  ");
    if Iline = 0 then
      return;
    do while (Iline > 0);
      if line_text_arr (Iline) = NL then
        do;
	if Lline_text - Iline > 0 then
	  Pline_text = addr (line_text_arr (Iline + 1));
	Lline_text = Lline_text - Iline;
	Iline = verify (line_text, "  ");
        end;
      else Iline = 0;
    end;

    return;

  end line$skip_blanks;

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

line$title:
  proc returns (char (200) varying);

    dcl Iline	   fixed bin (24),
        text	   char (200) varying;

    Iline = index (reverse (line), ":");/* need everything prior to last colon on line	*/
    if Iline = 0 then
      text = "";
    else
      do;
        Iline = Lline - (Iline - 1);	/* get char index of last colon in line		*/
        Lparg = Lparg - Iline;
        text = ltrim (substr (line, 1, Iline - 1));
				/* dont include colon			*/

        if Lline - Iline > 0 then
	do;
	  Pline = addr (line_arr (Iline + 1));
	  Lline = Lline - Iline;
	end;
        else
	do;
	  Pline = addcharno (addr (line_arr (Iline)), 1);
	  Lline = 0;
	end;
      end;
    return (text);


  end line$title;

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

section$arg_list:
  proc (name) returns (bit (1));

    dcl name	   char (*) varying;

    if length (name) >= 16 then	/* Is section an arg_list section?*/
      if substr (name, 1, 16) = "Control argument" | substr (name, 1, 16) = "Control Argument" | 
         substr (name, 1, 8) = "Argument" | substr (name, 1, 8) = "List of " then
        return (TRUE);
      else ;
    else if length (name) >= 8 then
      if substr (name, 1, 8) = "Argument" | substr (name, 1, 8) = "List of " then
        return (TRUE);

    return (FALSE);

  end section$arg_list;

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

    dcl current_line_begins_section
		   bit (1);

section$assert_line_begins_a_section:
  proc (setting);

    dcl setting	   bit (1) aligned;

    current_line_begins_section = setting;

  end section$assert_line_begins_a_section;

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

print_header:
  proc ();			/* This procedure prints a regular heading line.	*/

    dcl Lcount	   fixed bin,
        Linfo_name	   fixed bin,
        Lpath	   fixed bin;
    dcl case	   fixed bin;
    dcl line	   char (256) varying;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Output heading line before other info.  The heading spans at least 2 lines, and has 	*/
/* the form:								*/
/*	pathname   (line counts)						*/
/*	info_name:  info_title						*/
/*									*/
/* where all parts but the info_title are optional.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if help_args.Sctl.he_counts then
      do;				/* Do following only if line/entry counts wanted.	*/
        if Deps.N = 0 then		/*   No subroutine entry points.		*/
	if Nlines >= Deps.linfo (0).Nlines then
				/*     Only 1 paragraph.			*/
	  case = 1;
	else case = 2;		/*     Multiple paragraphs.			*/
        else
	do;			/*   Subroutine entry points.			*/
	  if Iep = 0 then		/*     Subroutine introduction.		*/
	    if Nlines >= Deps.linfo (0).Nlines then
	      case = 3;		/*       Only 1 paragraph.			*/
	    else case = 4;		/*       Multiple paragraphs.			*/
	  else			/*     A subroutine entry point.		*/
	       if Deps.N = 1 then	/*       Only 1 entry point.			*/
	    if Nlines >= Deps.linfo (Iep).Nlines then
	      case = 5;		/* 	 Only 1 paragraph.			*/
	    else case = 6;		/*	 Multiple paragraphs.		*/
	  else			/*       Multiple entry points.		*/
	       if Nlines >= Deps.linfo (Iep).Nlines then
	    case = 7;		/*	 Only 1 paragraph.			*/
	  else case = 8;		/*	 Multiple paragraphs.		*/
	end;
        go to FORM (case);

FORM (1):
        call ioa_$rsnnl ("^d line^[s^] in info", line, 0, Nlines, (Nlines > 1));
        if Nlines <= 0 then
	Nlines = 1;

        go to END_FORM;

FORM (2):
        call ioa_$rsnnl ("^d ^[lines follow^;line follows^];  ^d in info", line, 0, Nlines, (Nlines > 1),
	   Deps.linfo (Iep).Nlines);
        go to END_FORM;

FORM (3):
        call ioa_$rsnnl ("^d line^[s^] in introduction;  ^d lines, ^d entry point^[s^] in info",
           line, 0, Nlines, (Nlines > 1), Deps.Nlines, Deps.N, (Deps.N > 1));
        go to END_FORM;

FORM (4):
        call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in introduction;  ^d lines, ^d entry point^[s^] in info",
	   line, 0, Nlines, (Nlines > 1), Deps.linfo (Iep).Nlines, Deps.Nlines, Deps.N, (Deps.N > 1));
        go to END_FORM;

FORM (5):
        call ioa_$rsnnl ("^d line^[s^] in entry point", line, 0, Nlines, (Nlines > 1));
        go to END_FORM;

FORM (6):
        call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in entry point", line, 0, Nlines, (Nlines > 1),
	   Deps.linfo (Iep).Nlines);
        go to END_FORM;

FORM (7):
        call ioa_$rsnnl ("^d line^[s^] in entry point;  ^d lines, ^d other entry point^[s^] in info", line, 0, Nlines,
	   (Nlines > 1), Deps.Nlines, (Deps.N - 1), (Deps.N - 1 > 1));
        go to END_FORM;

FORM (8):
        call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in entry point;  ^d lines, ^d other entry point^[s^] in info",
	   line, 0, Nlines, (Nlines > 1), Deps.linfo (Iep).Nlines, Deps.Nlines, (Deps.N - 1), (Deps.N - 1 > 1));

END_FORM:
        Lcount = length (line);
      end;
    else Lcount = 0;

    if help_args.Sctl.he_pn then
      do;				/* Compute length of pathname for heading.	*/
        Lpath = length (rtrim (Dinfo_seg_.dir)) + length (rtrim (Dinfo_seg_.ent)) + length ("   ");
        if Dinfo_seg_.dir ^= ">" then
	Lpath = Lpath + 1;
      end;
    else Lpath = 0;

    if help_args.Sctl.he_info_name then
      do;				/* If info_name to be output, compute its length	*/
        Linfo_name = length (rtrim (Dinfo_seg_.info_name));
        if Linfo_name > 0 then	/* + colon + 2 spaces.			*/
	Linfo_name = Linfo_name + length (":  ");
      end;
    else Linfo_name = 0;

    if Lpath > 0 & Lcount > 0 then
      if Lpath + Lcount <= Loutput_line then
        ISnl3 = 2;
      else ISnl3 = 1;
    else ISnl3 = 3;

    if Lpath + Lcount > 0 then
      Snl1 = TRUE;
    else Snl1 = FALSE;

    if Linfo_name + length (Deps.linfo (Iep).header) >= 0 then
      Snl2 = TRUE;
    else Snl2 = FALSE;

    call ioa_$nnl ("^[^v/^;^s^]^[^a^[>^]^a^;^3s^]^[^/^;   ^;^]^[(^a)^;^s^]^[^/^]^[^a:  ^;^s^]^[^a^]^[^/^]",
         (Ninfos_printed > 1),	/* For all but the first info printed,		*/
         help_args.Lspace_between_infos,/*   output spaces between infos.		*/
         help_args.Sctl.he_pn,	/* Put pathname into heading.			*/
         Dinfo_seg_.dir, (Dinfo_seg_.dir ^= ">"), Dinfo_seg_.ent, ISnl3, help_args.Sctl.he_counts,
				/* Put line/entry point count into heading.	*/
         line,			/*   Description formulated above.		*/
         Snl1, (Linfo_name > 0),	/*Put info_name into heading.			*/
         Dinfo_seg_.info_name, (^Sprt_entry_pts), Deps.linfo (Iep).header,
				/* Heading line of info or entry point.		*/
         Snl2);

    return;

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


print_header_only:
  entry;				/* Print header for an info.			*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Output a special-format info heading line when only heading lines are being output.	*/
/* The idea is for the headings to occupy as few lines as possible.			*/
/*									*/
/* The heading line has the form:						*/
/*	pathname   info_name:  info_title   (line counts)				*/
/*									*/
/* where all fields but info_title are optional.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    if help_args.Sctl.he_pn then
      do;
        Lpath = length (rtrim (Dinfo_seg_.dir)) + length (rtrim (Dinfo_seg_.ent)) + length ("   ");
        if Dinfo_seg_.dir ^= ">" then
	Lpath = Lpath + 1;
      end;			/* If pathname to be output, compute length of	*/
    else Lpath = 0;			/* path + 3 spaces.				*/

    if help_args.Sctl.he_info_name then
      do;				/* If info_name to be output, compute length of	*/
        Linfo_name = length (rtrim (Dinfo_seg_.info_name));
        if Linfo_name > 0 then	/* info_name + colon + 2 spaces.		*/
	Linfo_name = Linfo_name + length (":  ");
      end;
    else Linfo_name = 0;

    if help_args.Sctl.he_counts then
      do;				/* If line/entry point counts to be output,	*/
        if Dinfo_seg_.Scross_ref then	/* compute length of appropriate format + 3 spaces*/
	Lcount = length ("   (another version)");
        else if Deps.N = 0 then
	Lcount = length ("   (9999 lines in info)");
        else if Iep = 0 then
	Lcount = length ("   (9999 lines, 999 entries in info)");
        else Lcount = length ("   (9999 lines, 999 other entries in info)");
      end;
    else Lcount = 0;

    if Lpath + Linfo_name + length (Deps.linfo (Iep).header) + Lcount <= Loutput_line then
      do;
        Snl1 = FALSE;		/* Compute if heading must be broken into several	*/
        Snl2 = FALSE;		/* lines.  Break points are after pathname and	*/
      end;			/* before line/entry counts.			*/
    else if Lpath + Linfo_name + length (Deps.linfo (Iep).header) <= Loutput_line then
      do;
        Snl1 = FALSE;
        Snl2 = TRUE;
      end;
    else if Linfo_name + length (Deps.linfo (Iep).header) + Lcount <= Loutput_line then
      do;
        Snl1 = TRUE;
        Snl2 = FALSE;
      end;
    else
      do;
        Snl1 = (Lpath > 0);
        Snl2 = (Lcount > 0);
      end;

    call ioa_ ("^[^a^[>^]^a^;^3s^]^[^/^]   ^[^a:  ^;^s^]^a^[
^]^[   ^[(another version)^;(^d line^[s^]^[, ^[^d^s^;^s^d other^] ^[entries^;entry^]^;^4s^] in info)^]^]",
				/* Output long heading line.			*/
         help_args.Sctl.he_pn, Dinfo_seg_.dir, Dinfo_seg_.dir ^= ">", Dinfo_seg_.ent, Snl1, 
         Linfo_name > 0, Dinfo_seg_.info_name,
         Deps.linfo (Iep).header,	/* Output the  entry point heading.		*/
         Snl2, help_args.Sctl.he_counts, Dinfo_seg_.Scross_ref,
				/* Second occurence of info in another dir.	*/
         Deps.Nlines, (Deps.Nlines > 1),/* Output line count for all entry points.	*/
         ((Deps.N > 0) & (Iep = 0)) | (Deps.N > 1),
				/* Output count of entry points.		*/
         (Iep = 0),			/*   Looking at common part.  Output info about	*/
				/*   all entry points.			*/
         Deps.N, Deps.N - 1,		/*   Looking at entry point.  Output info about	*/
				/*   other entry points.			*/
         ((Iep = 0) & (Deps.N > 1)) | (Deps.N - 1 > 1));

  end print_header;

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


print_pgh_2nl:
  procedure (unit, Sprint_inhibit);	/* This procedure prints a paragraph.		*/

    dcl 1 unit	   aligned like Dlinfo.unit,
        Sprint_inhibit bit (1) aligned;

    dcl code	   fixed bin (35);


    dcl 1 event_info   aligned,
	2 ev_chan	   fixed bin (71),
	2 message	   fixed bin (71),
	2 sender	   bit (36),
	2 origin,
	  3 dev_signal
		   bit (18) unal,
	  3 ring	   bit (18) unal,
	2 chan_index fixed bin;

    dcl 1 wait_list	   aligned int static,
	2 N	   fixed bin,
	2 ev_chan	   (1) fixed bin (71);

    dcl 1 write_status aligned int static,
	2 ev_chan	   fixed bin (71) init (0),
	2 output_pending
		   bit (1);

    if Sprint_inhibit then
      return;
    call ioa_ ("^/");
    go to PRINT_PGH;


print_pgh:
  entry (unit, Sprint_inhibit);

    if Sprint_inhibit then
      return;
    call ioa_ ("");


print_pgh_nnl:
  entry (unit, Sprint_inhibit);

    if Sprint_inhibit then
      return;
PRINT_PGH:
    if unit.ep_list then
      if Sep_list_printed then
        return;
      else Sep_list_printed = TRUE;

    if unit.S.scn then		/* Print section title, if any.		*/
      call ioa_$nnl ("^a:", unit.title);
    call iox_$put_chars (iox_$user_output, unit.Pstart, unit.L, code);
    call iox_$control (iox_$user_output, "write_status", addr (write_status), code);
    if (code = 0) & (write_status.output_pending) then
      do;				/* Wait until output on user's terminal before	*/
        wait_list.N = 1;		/* marking pgh seen.			*/
        wait_list.ev_chan (1) = write_status.ev_chan;
        call ipc_$block (addr (wait_list), addr (event_info), code);
      end;
    unit.S.seen_by_user = TRUE;	/* Keep track of what we've seen.		*/
    if unit.Icommon_unit > 0 then
      common_units (unit.Icommon_unit).S.seen_by_user = TRUE;

  end print_pgh_2nl;

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


seen_pgh:
  proc (unit) returns (bit (1) aligned);/* Returns TRUE if pgh has been seen by user.	*/

    dcl 1 unit	   aligned like Dlinfo.unit,
        Sseen	   bit (1) aligned;

    if unit.Icommon_unit > 0 then
      Sseen = common_units (unit.Icommon_unit).S.seen_by_user;
    else Sseen = unit.S.seen_by_user;
    return (Sseen);

  end seen_pgh;

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


set_space_used:
  procedure (Pcurrent_space, size_current_space) returns (ptr);
				/* This procedure returns pointer to next free	*/
				/* word of storage in help_args temp segment.	*/
    dcl Pcurrent_space ptr,		/* ptr to last space allocated in the seg.	*/
        size_current_space
		   fixed bin (21),	/* amount of space used in structure last alloc.	*/
        Pnext_space	   ptr;		/* ptr to next free space.			*/

    Pnext_space = addrel (Pcurrent_space, size_current_space + mod (size_current_space, 2));
    return (Pnext_space);

  end set_space_used;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

%include help_args_;

%include help_cis_args_;

    dcl 1 Dinfo_seg_   aligned like Dinfo_seg based (PDinfo_seg_);

  end help_rql_;




		    list_help.pl1                   02/16/88  1500.9r w 02/16/88  1411.8      144702



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


/****^  HISTORY COMMENTS:
  1) change(74-06-01,Dean), approve(), audit(), install():
     Written June 1974 by John W. Dean III MITIPC
  2) change(78-10-01,Greenberg), approve(), audit(), install():
     Modified October 1978 by Bernie S. Greenberg for new search facility etc.
  3) change(80-06-11,Herbst), approve(), audit(), install():
     Modified 06/11/80 by S. Herbst to implement [list_help] and add
      -absolute_pathname.
  4) change(81-09-01,GJohnson), approve(), audit(), install():
     Modified September, 1981 by Gary E. Johnson:
      - increase printed output limit to 4092 characters
      - no error message when empty dir encountered
      - ignore ".info" suffix
      - allow multiple -pn arguments
      - allow -brief on active function invocation
      - implement case insensitivity
      - add -long control argument
  5) change(83-12-01,Spitzer), approve(), audit(), install():
     Modified December 1983 by C. Spitzer:
      - add -sort control argument
  6) change(85-01-25,Lippard), approve(85-01-23,MCR7158),
     audit(85-10-04,RBarstad), install(85-12-17,MR12.0-1001):
     Modified January 1985 by Jim Lippard:
      - not complain about info segs to which user doesn't have access
                                                   END HISTORY COMMENTS */


list_help:
lh:  procedure;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/*             Command to list names of "help" files:				*/
/*                  if no args are given, a usage message is printed,			*/
/*                  arguments are taken as "topics" to be searched for,		*/
/*                  only names which contain one of the topics will be listed		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*   LIST OF AUTOMATIC VARIABLES    */


declare  absp_sw bit (1),				/* -absolute_pathname specified */
         af_sw bit (1),				/* invoked as an active function */
        (alp, eptr, nptr) pointer,
         arglen fixed binary (21),
        (argptr, return_ptr) ptr,
         arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr) variable,
         brief bit (1),				/* controls output format */
         complain entry variable options (variable),
         code fixed bin (35),				/* general code variable */
         ecount fixed bin,
         entryname char (32) varying,
         xentryname char (32) varying,

        (numpath, return_len) fixed binary,
         found bit (1),				/* topic found in file name */
        (i, iname, narg, nargs, nentry, nname) fixed bin,
         list_all bit (1),				/* -all option */
         link_target_type fixed binary (2),
         ndir fixed bin,				/* directory counter */
         ntopics fixed bin,				/* number of topics given as arguments */
         number_printed fixed bin,			/* number of files listed */
         outstring char (4092) varying,
         pn_flag bit (1),				/* user has specified the dir */
         sort_sw bit (1) aligned,			/* want sorting on output */
         sort_stringsl fixed bin (21),
         tempp (4) ptr,
         (sort_strings_arrayp, ptr_arrayp, index_arrayp, length_arrayp) ptr;

/* LIST OF BASED VARIABLES  */

declare  area area based (areap),
         arg char (arglen) based (argptr),
         return_arg char (return_len) varying based (return_ptr);

declare 1 ptr_array based (ptr_arrayp) aligned,
        2 n fixed bin (18),
        2 ptr (ptr_array.n) ptr unaligned;

declare 1 length_array based (length_arrayp) aligned,
        2 n fixed bin (18),
        2 length (length_array.n) fixed bin (18);

declare 1 index_array based (index_arrayp) aligned,
        2 n fixed bin (18),
        2 index (index_array.n) fixed bin (21);

declare sort_strings char (sort_stringsl) based (sort_strings_arrayp);
declare sort_strings_array (sort_stringsl) char (1) unaligned based (sort_strings_arrayp);

declare 1 entry (ecount) aligned based (eptr),
        2 type bit (2) unaligned,
        2 nnames fixed bin (15) unaligned,
        2 nindex fixed bin (17) unaligned,
         names (iname) char (32) based (nptr);

/*  LIST OF CONDITIONS */

declare  cleanup condition;

declare  absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
         active_fnc_err_ entry options (variable),
         com_err_ entry options (variable),
         check_star_name_$path entry (char (*), fixed bin (35)),
         cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
         cu_$arg_list_ptr entry (pointer),
         cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
         cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
         get_system_free_area_ entry returns (pointer),
         hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
         hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
         fixed bin (35)),
         ioa_ entry options (variable),
         pathname_ entry (char(*), char(*)) returns(char(168)),
         sort_items_indirect_$adj_char entry (ptr, ptr, ptr),
        (get_temp_segments_, release_temp_segments_) entry (char(*), (*) ptr, fixed bin(35)),
         search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));


/*	    LIST OF STATIC VARIABLES          */

declare  areap ptr int static init (null),
         error_table_$badopt fixed bin (35) external,	/* illegal control argument */
         error_table_$inconsistent fixed bin (35) external,
         error_table_$incorrect_access fixed bin (35) external,
         error_table_$noentry fixed bin(35) ext static,
         error_table_$no_info fixed bin(35) ext static,
         error_table_$nomatch fixed bin (35) external,
         error_table_$nostars fixed bin (35) external,
         error_table_$wrong_no_of_args fixed bin (35) external,
         myname char (32) options (constant) static init ("list_help"),
         sys_info$max_seg_size fixed bin(35) ext static,
        (upper_case char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
         lower_case char (26) init ("abcdefghijklmnopqrstuvwxyz")) static options (constant);


declare (addr, divide, index, length, null, rtrim, substr, translate, unspec) builtin;

/* initialization and argument handling */


	call cu_$af_return_arg (nargs, return_ptr, return_len, code);
	if code ^= 0 then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     arg_ptr = cu_$arg_ptr_rel;
	end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     return_arg = "";
	     arg_ptr = cu_$af_arg_ptr_rel;
	end;

	call cu_$arg_list_ptr (alp);

BLOCK:	begin;
declare  user_dir (divide (nargs, 2, 17, 0)) char (168);	/* for user specified directory */
declare  topic (nargs) char (32) varying;		/* can't be more topics than arguments */

	     numpath = 0;				/* for pathname count */
	     list_all = "0"b;
	     number_printed = 0;
	     ntopics = 0;
	     absp_sw = "0"b;
	     pn_flag = "0"b;
	     sort_sw = "0"b;
	     brief = af_sw;
	     do narg = 1 to nargs;
		call arg_ptr (narg, argptr, arglen, code, alp);
		if index (arg, "-") = 1 then do;
		     if arg = "-long" | arg = "-lg" then brief = "0"b;
		     else if arg = "-brief" | arg = "-bf" then brief = "1"b;
		     else if arg = "-a" | arg = "-all" then list_all = "1"b;
		     else if arg = "-absolute_pathname" | arg = "-absp" then absp_sw = "1"b;
		     else if arg = "-sort" then sort_sw = "1"b;
		     else if arg = "-no_sort" then sort_sw = "0"b;
		     else if arg = "-pathname" | arg = "-pn" then do;
			pn_flag = "1"b;
			narg = narg + 1;
			call arg_ptr (narg, argptr, arglen, code, alp);
						/* get user specified dir path */

			if code ^= 0 then do;
			     call complain (code, myname, "
The -pn control argument must be followed by a pathname.");
			     return;
			end;


			numpath = numpath + 1;
			call absolute_pathname_ (arg, user_dir (numpath), code);
						/* get absolute path of dir */
			if code ^= 0 then do;
			     call complain (code, myname, "^a", arg);
			     return;
end_path:			end;
			call check_star_name_$path (user_dir (numpath), code);
			if code ^= 0 then do;
			     if code = 1 | code = 2 then code = error_table_$nostars;
			     else call complain (code, myname, "^a", arg);
			     return;
			end;
		     end;
		     else do;
BAD_OPT:			call complain (error_table_$badopt, myname, """^a""", arg);
			return;
		     end;
		end;

		else do;
		     ntopics = ntopics+1;
		     topic (ntopics) = translate (arg, lower_case, upper_case);
		end;


	     end;					/* of arg getting loop */

	     if ntopics > 0 then do;			/* both topics and -all in same command */
		if list_all then do;
		     call complain (error_table_$inconsistent, myname, "
Topics cannot be specified with -all.");
		     return;
		end;
	     end;
	     if af_sw then if ^brief then do;
		call complain (error_table_$badopt, myname, "
The -long control arg is not accepted for active function.");
		return;
	     end;

	     if ntopics = 0 then do;			/* ntopics=0 and -all not specified is wrong */
		if ^list_all then do;
		     call complain (error_table_$wrong_no_of_args, myname, "
You must specify topics or use the -all control_arg.  For details, type,

     help lh");
		     return;
		end;
	     end;


	     areap = get_system_free_area_ ();		/* for allocating star info */
	     sl_info_p = null;
	     eptr, nptr = null;
	     tempp (*) = null;
	     on cleanup call clean_up;

	     if ^pn_flag then do;
		call search_paths_$get ("info_segments", sl_control_default,
		     "", null, areap, sl_info_version_1, sl_info_p, code);
		if code ^= 0 then do;
		     call complain (code, myname, "Getting search list for info segments.");
		     return;
		end;
	     end;


/* searching and printing of file names */

	     if pn_flag then do ndir = 1 to numpath;	/* specified by -pn option */
		call scan_dir (user_dir (ndir));
	     end;
						/* default directories */
	     else do ndir = 1 to sl_info.num_paths;
		call scan_dir (sl_info.pathname (ndir));
	     end;

	     if number_printed = 0 & ^af_sw then call ioa_ ("No files found.");
	     else if sort_sw
		then do;
		     unspec (index_array) = "0"b;
		     call sort_items_indirect_$adj_char (ptr_arrayp, index_arrayp, length_arrayp);
		     do i = 1 to ptr_array.n;
			argptr = ptr_array.ptr (index_array.index (i));
			arglen = length_array.length (index_array.index (i));
			if af_sw
			then return_arg = return_arg || arg;
			else call ioa_ ("^a", arg);
			end;
		     end;

	     call clean_up;

	     goto RETURN;
	     					/* internal proc to do searching and listing */

scan_dir:	     procedure (dirname);

declare  dirname char (168) parameter;
declare  strip_info_suffix bit (1) aligned;

		call hcs_$star_ (dirname, "**.info", 3, areap, ecount, eptr, nptr, code);
						/* use "**" to avoid duplication of effort */
						/* get all segs and links in specified dir */
		if code ^= 0 then do;		/* problem getting info */
		     if code ^= error_table_$nomatch then do;
			call complain (code, myname, "Listing files in ^a.", dirname);

			return;
		     end;
		end;


		do nentry = 1 to ecount;		/* scan all entries */
		     if entry.type (nentry) = "10"b then go to NEXT_ENTRY; /* ignore directories */
		     iname = entry.nindex (nentry);
		     if entry.type (nentry) = "00"b then do;
			call hcs_$status_minf (dirname, names(iname), 1, link_target_type,
			     0, code);
			if code = error_table_$noentry then go to NEXT_ENTRY;
			else if code = error_table_$incorrect_access then go to NEXT_ENTRY;
			else if code = error_table_$no_info then go to NEXT_ENTRY;
			else if code ^= 0 then do;
			     call complain (code, myname, "^a",
				pathname_ (dirname, names (iname)));
			     go to NEXT_ENTRY;
			end;
			if link_target_type = 00b | link_target_type = 10b then go to NEXT_ENTRY;
		     end;
		     nname = 1;			/* nname is the number+1 of names with ".info" */
		     found = list_all;		/* no topics matched for this seg yet */
		     strip_info_suffix = "0"b;
		     do nname = 1 to entry.nnames (nentry);
						/* go through all names */
			entryname = rtrim (names (iname));

			if substr (entryname, length (entryname) - length (".info") + 1) = ".info" then do;
			     entryname = substr (entryname, 1, length (entryname) - length (".info"));
			     strip_info_suffix = "1"b;
			     xentryname = translate (entryname, lower_case, upper_case);
			end;
			else go to NEXT_ENTRY;

			if ^found then do;		/* topics specified and not matched yet */
			     do i = 1 to ntopics
				     while (index (xentryname, topic (i)) = 0);
			     end;
			     found = (i <= ntopics);
			end;

			if nname = 1 then do;	/* first name */
			     if absp_sw then do;
				outstring = rtrim (pathname_ ((dirname), (entryname)));
				if strip_info_suffix then outstring = outstring || ".info";
				end;
			     else outstring = entryname;
			end;


			if ^brief & nname > 1 then do; /* additional names */
			     if nname = 2 then outstring = outstring || " (";
			     else outstring = outstring || ", ";
			     outstring = outstring || entryname;
			end;

			iname = iname+1;
		     end;				/* end of loop for names of one entry */

		     if found then do;		/* there is something to print */
			if ^brief & nname > 2 then	/* add closing paren */
			     outstring = outstring||")";

			if sort_sw then call add_to_sort_data (outstring);
			else if af_sw then do;
				if number_printed > 0 then return_arg = return_arg || " ";
				return_arg = return_arg || outstring;
			     end;
			     else call ioa_ ("^a", outstring);

			number_printed = number_printed+1;
		     end;

NEXT_ENTRY:
		end;				/* end of processing for one entry */

		if nptr ^= null () then do; free names in (area); nptr = null (); end;
		if eptr ^= null () then do; free entry in (area); eptr = null (); end;

	     end scan_dir;				/* end of processing for one directory */

	end BLOCK;				/*  end of begin block for topic allocation */

RETURN:
	return;

add_to_sort_data:
     proc (in);

dcl  in char (*) varying parameter;
dcl  len fixed bin (21);

	if tempp (1) = null then do;
	     call get_temp_segments_ (myname, tempp, code);
	     if code ^= 0 then do;
		call complain (code, myname, "Getting temp segments.");
		goto RETURN;
		end;
	     ptr_arrayp = tempp (1);
	     index_arrayp = tempp (2);
	     length_arrayp = tempp (3);
	     sort_strings_arrayp = tempp (4);
	     length_array.n, ptr_array.n, index_array.n = 0;
	     sort_stringsl = 0;
	     end;

	len = length (in);
	if sort_stringsl + len + 1 > sys_info$max_seg_size * 4 then do;
	     call complain (0, myname, "Attempt to sort too much data.");
	     goto RETURN;
	     end;

	ptr_array.n = ptr_array.n + 1;
	ptr_array.ptr (ptr_array.n) = addr (sort_strings_array (sort_stringsl+1));

	length_array.n = length_array.n + 1;
	length_array.length (length_array.n) = len;

	substr (sort_strings, sort_stringsl+1, len) = in;
	sort_stringsl = sort_stringsl + len;

	return;
	end add_to_sort_data;

/* procedure to free things allocated by hcs_$star_ */

clean_up:	proc;
	     if nptr ^= null () then do; free names in (area); nptr = null (); end;
	     if eptr ^= null () then do; free entry in (area); eptr = null (); end;
	     if sl_info_p ^= null () then do; free sl_info in (area); sl_info_p = null (); end;
	     if tempp (1) ^= null () then call release_temp_segments_ (myname, tempp, (0));

	end clean_up;


%include sl_info;
%include sl_control_s;
     end;




		    list_ref_names.pl1              02/07/84  1249.5re  02/07/84  1248.5       90657



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


list_ref_names: lrn: proc;

/* This command lists the reference names of segments */
/* initially coded Jan 1971 by Dan Bricklin */
/* last modified by Dan B. March 1971 */
/* Fixed to abort for invalid -from and -to, Steve Herbst 11/8/77 */
/* Fixed to not make copy in [pd] if copy switch is on 03/20/80 S. Herbst */
/* Changed to always print segno, path, and refnames 12/13/83 S. Herbst */
/* Fixed to rtrim the refnames it prints 12/14/83 S. Herbst */

dcl
    (i, alen, from_seg, to_seg, argno, seg_no, num_null) fixed bin,
     code fixed bin (35),
     error_table_$badopt fixed bin (35) ext,
     error_table_$segknown fixed bin (35) ext,
    (aptr, segptr) ptr,
    (brief, prt, allsw, no_zero) bit (1) aligned,
     which char (16) init ("list_ref_names") int static aligned,
     dirname char (168) aligned,
     ename char (32) aligned,
     arg char (alen) based (aptr),
     ret label init (end_loop),
     plural char (1) aligned,

     1 p aligned,
     2 ignore char (31) unaligned,
     2 rname char (32) unaligned,
     2 nl char (1) unaligned,

     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cv_oct_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     expand_pathname_ ext entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
     hcs_$initiate ext entry (char (*)aligned, char (*)aligned, char (*)aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     com_err_ ext entry options (variable),
     ioa_ ext entry options (variable),
     hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
     hcs_$fs_get_path_name ext entry (ptr, char (*)aligned, fixed bin, char (*)aligned, fixed bin (35)),
     hcs_$high_low_seg_count ext entry (fixed bin, fixed bin),
     hcs_$fs_get_ref_name ext entry (ptr, fixed bin, char (*), fixed bin (35)),
     ring0_get_$name ext entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35)),
     iox_$user_output ptr ext;

dcl (addr, baseno, baseptr, fixed, length, substr) builtin;

	allsw, brief, no_zero = "0"b;			/* assume print ring-0, and not all and brief options */
	nl = "
";						/* set nl equal to a newline char */
	argno = 1;				/* start with first argument */

	do i = 1 by 1;				/* look at all arguments */
	     call cu_$arg_ptr (i, aptr, alen, code);	/* for the -all and -brief options */
	     if code ^= 0 then go to next;		/* end of argument list */
	     if arg = "-brief" | arg = "-bf" then brief = "1"b; /* found a brief option */
	     if arg = "-all" | arg = "-a" then allsw = "1"b; /* found an all option, so set switch to remember */
	end;

next:	from_seg = 0;				/* default from segment number is zero */

	call cu_$arg_ptr (argno, aptr, alen, code);	/* get next argument */

	if code ^= 0 then do;			/* end of argument list */
	     if argno = 1 | argno = 2 & brief then do;	/* if nothing was given, print all non-ring zero */
		no_zero = "1"b;			/* don't print ring zero ones */
		go to all;
	     end;
	     return;				/* else return to caller */
	end;

	if arg = "-to" then do;			/* if the -to option is encountered, do */
	     argno = argno + 1;			/* look at next argument */
to_sec:	     call cu_$arg_ptr (argno, aptr, alen, code);
	     if code ^= 0 then do;			/* if not there then it is an error */
error:		call com_err_ (code, which);		/* print message */
		return;				/* end of arg list, so return */
	     end;

	     to_seg = cv_oct_check_ (arg, code);	/* convert to number */

	     if code ^= 0 | to_seg < 0 then do;
		call com_err_ (0, which, "Invalid -to argument ^a", arg);
		return;
	     end;

got_to:	     if from_seg>to_seg then do;		/* if lower bound > upper bound then error */
		call com_err_ (0, which, "Lower segment number bound ^o greater than upper bound ^o",
		     from_seg, to_seg);
		return;
	     end;

num_print:					/* given segment number, print info */
	     prt = "0"b;				/* nothing printed yet */

	     do seg_no = from_seg to to_seg;		/* do for each segment number in range */

		call hcs_$fs_get_path_name (baseptr (seg_no), dirname, i, ename, code); /* get path name */
		if code ^= 0 then do;		/* if unable then try the following */
		     if no_zero then go to end_loop;	/* if no ring-0 ones to be printed, don't even check */
		     call ring0_get_$name (dirname, ename, baseptr (seg_no), code); /* is it in ring 0 ? */
		     if code ^= 0 then go to end_loop;	/* if not, then ignore it for now */

		     if dirname = "" then call ioa_ ("   ^o ^a (ring 0)", seg_no, ename); /* no dir */

		     else do;

			if dirname = ">" then dirname = ""; /* don't have two >'s on root */

			call ioa_ ("   ^o ^a>^a (ring 0)", seg_no, dirname, ename); /* print info */

		     end;

		     prt = "1"b;

		     go to printed;			/* skip around regular print routine */
		end;

		if i = 1 then dirname = "";		/* if name is only >, then remove it, since we have one */

		prt = "1"b;			/* we printed something */

		call ioa_ ("^/   ^o ^a>^a", seg_no, dirname, ename); /* print number and path */

printed:		if ^brief then do;			/* print reference names, if not brief */

		     ret = end_loop;		/* pseudo call */

		     go to ref_print;

		end;

end_loop:	     end;					/* end of loop for each segment number */

	     if ^prt then
		if to_seg = from_seg then call com_err_ (0, which, "Invalid segment number ^o", from_seg);
		else call com_err_ (0, which, "Invalid segment numbers ^o and ^o", from_seg, to_seg);

	     argno = argno + 1;
	     go to next;
	end;

	if arg = "-from" | arg = "-fm" then do;		/* if -from option encountered */
	     argno = argno + 1;			/* look for number after it */
	     call cu_$arg_ptr (argno, aptr, alen, code);
	     if code ^= 0 then go to error;		/* not found is an error */

	     from_seg = cv_oct_check_ (arg, code);	/* make it a number */

	     if code ^= 0 | from_seg < 0 then do;
		call com_err_ (0, which, "Invalid -from argument ^a", arg);
		return;
	     end;

	     call cu_$arg_ptr (argno + 1, aptr, alen, code); /* look for a "-to" after the from number */


all:	     call hcs_$high_low_seg_count (to_seg, i);	/* get last allocated segment number */
	     to_seg = to_seg + i;			/* by adding high hc to number after hardcore */
	     if from_seg>to_seg then do;		/* starting after last seg */
		call com_err_ (0, which, "Lower bound ^o greater than highest segment number ^o.",
		     from_seg, to_seg);

		return;

	     end;

	     if code = 0 then if arg = "-to" then do;
		     argno = argno + 2;
		     go to to_sec;
		end;


	     go to got_to;


	end;

	if arg = "-name" | arg = "-nm" then do;		/* if name option */
	     argno = argno + 1;			/* get next argument */
	     call cu_$arg_ptr (argno, aptr, alen, code);	/* and treat it as a character string */
	     if code = 0 then go to no_num;		/* regardless of how it looks */
	     else go to error;			/* if none there, then error */
	end;

	if arg = "-brief" | arg = "-bf" then do;	/* ignore brief options since we already processed it */
	     argno = argno + 1;
	     go to next;
	end;

	if allsw then do;				/* if all option was present */
	     from_seg = 0;				/* simulate -from 0 */
	     go to all;
	end;

	if substr (arg, 1, 1) = "-" then do;		/* look for option type args which we can't identify */
	     call com_err_ (error_table_$badopt, which, "^a", arg);
	     return;
	end;

	seg_no = cv_oct_check_ (arg, code);		/* see if argument can be seen as a number */

	if code = 0 then do;			/* if so, then do */
	     to_seg, from_seg = seg_no;		/* pretend that it is: -from num -to num */
	     go to num_print;			/* go to numbered segment printing routine */
	end;

no_num:	call expand_pathname_ (arg, dirname, ename, code);
	if code ^= 0 then go to error;

	call hcs_$initiate (dirname, ename, "", 0, 1, segptr, code); /* see if it is there already and where */

	if code = 0 then do;			/* wasn't known in advance, no good */
	     call com_err_ (0, which, "Segment not known. ^a^[>^]^a", dirname, dirname ^= ">", ename);
	     call hcs_$terminate_noname (segptr, code);	/* terminate the reference */
	     argno = argno + 1;			/* try next argument */
	     go to next;
	end;

	if code ^= error_table_$segknown then do;	/* if it wasn't known, another error */
	     call com_err_ (code, which, "^a^[>^]^a", dirname, dirname ^= ">", ename);
	     argno = argno + 1;			/* try again */
	     go to next;
	end;

	seg_no = fixed (baseno (segptr));		/* get segment number part of pointer */

	call hcs_$terminate_noname (segptr, code);	/* this reference dosn't count, so end it */

	call ioa_ ("^/   ^o ^a>^a", seg_no, dirname, ename);  /* print number and path */

	argno = argno + 1;				/* get ready for next argument */

	if brief then go to next;			/* skip ref name printing */

	ret = next;				/* pseudo call */

ref_print:
	num_null = 0;				/* no null reference names found so far for this segment */

	do i = 1 by 1;				/* look at all reference names */
	     call hcs_$fs_get_ref_name (baseptr (seg_no), i, p.rname, code); /* get reference names from this entry */
	     if code ^= 0 then go to fin;		/* when ended, then go to fin */

/* if not null, write structure with it and newline */
	     if p.rname ^= "" then
		call ioa_ ("^a", p.rname);

	     else num_null = num_null + 1;		/* else count number of null refs */

	end;

fin:	if num_null>0 then do;			/* print number of null refs if > zero */
	     if num_null = 1 then plural = " ";		/* de-pluralize word */
	     else plural = "s";			/* pluralize word */
	     call ioa_ ("^d null reference name^a", num_null, plural);
	end;

	go to ret;				/* pseudo return */


     end;




		    print_motd.pl1                  01/12/88  1315.2rew 01/12/88  1245.0      164241



/****^  ***********************************************************
        *                                                         *
        * 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-03-17,Blair), approve(87-03-17,MCR7638),
     audit(87-03-20,Gilcrease), install(87-04-03,MR12.1-1021):
     Implement 5 control arguments to allow printing of project motds, and all
     or new portions of the project or system motds.  The CAs are: -system,
     -project, -all_text, -new_text, -current_project.  Change code not to
     call com_err_ when a value_seg is created for the user by default.
  2) change(87-04-06,Blair), approve(87-04-06,PBF7638), audit(87-04-06,GWMay),
     install(87-04-08,MR12.1-1022):
     Suppress printing the header when the bit_count of the motd is 0 and don't
     print an error message when the default project doesn't exist.
  3) change(87-05-04,Blair), approve(87-05-08,MCR7688),
     audit(87-05-19,Gilcrease), install(87-05-26,MR12.1-1037):
     Banner will be suppressed when the change amounts to deletion of lines
     from the original.
  4) change(87-12-15,Blair), approve(88-01-07,MCR7824),
     audit(88-01-07,LJAdams), install(88-01-12,MR12.2-1012):
     Ignore the error message when the motd segment doesn't exist in all cases.
     TR 20986.
                                                   END HISTORY COMMENTS */

/* Prints all lines in the message-of-the-day (MOTD) segment which have been changed or added since the user last used
   this command */

/* Created:  28 July 1971 by Peter R. Bos */
/* Modified: 14 December 1972 by R. Mullen to convert to version 2 PL/I */
/* Modified: 29 March 1977 by S. Herbst to convert to iox_ */
/* Modified: 14 July 1978 by S. Herbst to use Person_id.motd rather than anonymous.motd for anonymous users */
/* Modified: 12 December 1979 by S. Herbst to fix no_s_permission bug when obtaining date-time-contents-modified */
/* Modified: 23 March 1982 by G. Palter to convert to use the user's value segment */

/* format: style4,delnl,insnl,ifthenstmt,ifthen */


print_motd:
pmotd:
     procedure () options (variable);


/* DECLARATIONS */

dcl  1 user_motd aligned based (user_motd_ptr),
       2 dtcm fixed binary (71),
       2 lth fixed binary (21),
       2 motd character (user_motd_lth refer (user_motd.lth));
dcl  user_motd_ptr pointer;
dcl  user_motd_lth fixed binary (21);

dcl  system_motd character (system_motd_lth) based (system_motd_ptr);
dcl  system_motd_lth fixed binary (21);
dcl  system_motd_ptr pointer;
dcl  system_motd_dtcm fixed binary (71);

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;
dcl  user_info_$whoami entry (char(*), char(*));
dcl  code fixed binary (35);

dcl  (used, next_nl) fixed binary (21);

dcl  n_arguments fixed binary;

dcl  PRINT_MOTD character (32) static options (constant) initial ("print_motd");

dcl  NL character (1) static options (constant) initial ("
");

dcl  CHASE fixed binary (1) static options (constant) initial (1);
dcl  DELETE_OR_UNLINK bit (6) static options (constant) initial ("010110"b);

dcl  SYSTEM_CONTROL_DIR character (168) static /* options (constant) */ initial (">system_control_dir");
dcl  MOTD_ENAME character (32) static options (constant) initial ("message_of_the_day");

dcl  DEFAULT_VALUE_SEGMENT pointer static options (constant) initial (null ());
dcl  PERMANENT_VALUE bit (36) aligned static options (constant) initial ("01"b);

dcl  error_table_$action_not_performed fixed binary (35) external;
dcl  error_table_$badopt fixed binary (35) external static;
dcl  error_table_$no_s_permission fixed binary (35) external;
dcl  error_table_$noentry fixed binary (35) external;
dcl  error_table_$oldnamerr fixed binary (35) external;

dcl  iox_$user_output pointer external;
dcl  ioa_ entry() options(variable);
dcl  ioa_$nnl entry() options(variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  com_err_ entry () options (variable);
dcl  delete_$path entry (character (*), character (*), bit (6), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$status_ entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl  user_info_ entry (character (*));
dcl  user_info_$homedir entry (character (*));
dcl  value_$get_data
	entry (pointer, bit (36) aligned, character (*), pointer, pointer, fixed binary (18), fixed binary (35));
dcl  value_$get_path entry (character (*), fixed binary (35));
dcl  value_$set_data
	entry (pointer, bit (36) aligned, character (*), pointer, fixed binary (18), pointer, pointer,
	fixed binary (18), fixed binary (35));
dcl  value_$set_path entry (character (*), bit (1), fixed binary (35));

dcl  cleanup condition;

dcl  (addr, currentsize, divide, index, null, rtrim, length, substr, unspec) builtin;
dcl  (some_type_specified_sw, need_project, curr_pj_sw, all_sw, new_sw, already_printed, have_project) bit (1) aligned init ("0"b);
dcl  arg_ptr ptr;
dcl  arg_len fixed bin (21);
dcl  arg character (arg_len) based (arg_ptr);
dcl  administrator_ename char (32);
dcl  idx fixed bin;
dcl  person char (22);
dcl  pmotd_value_name character (32);
dcl  proj char (9);
dcl  my_project char (9);
dcl  project_dir character (168);
/**/

	call cu_$arg_count (n_arguments, code);		/* insure we are invoked properly */
	if code ^= 0 then do;
	     call com_err_ (code, PRINT_MOTD);
	     return;
	end;

	call user_info_$whoami (person, proj);
	my_project = proj;

	if n_arguments = 0 then do;
	     call psmotd;
	     call ppmotd;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();
	do idx = 1 to n_arguments;
	     call cu_$arg_ptr (idx, arg_ptr, arg_len, code);
	     if substr (arg,1,1) = "-" then do;
		if need_project  & ^have_project then do;
		     call com_err_ (error_table_$badopt, PRINT_MOTD, "^a, missing PROJECT", arg);
		     return;
		     end;	     
		else if arg = "-sys" | arg = "-system"
		     then do;
		     some_type_specified_sw = "1"b;
		     need_project = "0"b;
		     end;
		else if arg = "-all_text" | arg = "-all" | arg = "-a" 
		     then do;
			all_sw = "1"b;
			new_sw ="0"b;
			need_project = "0"b;
			end;
		else if arg = "-new_text" | arg = "-new" 
		     then do;
			new_sw = "1"b;
			all_sw = "0"b;
			need_project = "0"b;
			end;
		else if arg = "-project" | arg = "-pj" 
		     then if idx = n_arguments then do;
			call com_err_ (error_table_$badopt, PRINT_MOTD, "missing PROJECT following ^a" , arg);
			return;
			end;
		     else do;
			some_type_specified_sw = "1"b;
			need_project = "1"b;
			have_project = "0"b;
			end;
		else if arg = "-current_project" | arg = "-cpj"
		     then do;
			curr_pj_sw = "1"b;
			need_project = "0"b;
			some_type_specified_sw = "1"b;
			end;
		else do;
		     call com_err_ (error_table_$badopt, PRINT_MOTD, "^a", arg);
		     return;
		     end;
				
		end;                /* arg didn't begin with "-" */
	     else if ^need_project then do;
		call com_err_ (error_table_$badopt, PRINT_MOTD, "^a", arg);
		return;
		end;
	     else have_project = "1"b;
	end;                                   /* no more arguments to process */
     
	if n_arguments ^= 0 & ^some_type_specified_sw then do;      /* only -new or -all */
	     call psmotd;
	     call ppmotd;
	     return;
	     end;

	idx = 1;
	do while (idx <= n_arguments);
	     call cu_$arg_ptr (idx, arg_ptr, arg_len, code);
	    if arg = "-all_text" | arg = "-all" | arg = "-a" | arg = "-new_text" | arg = "-new" then idx = idx + 1;  /* skip over these */
	    else if arg = "-sys" | arg = "-system" then do;
		    idx = idx + 1;
		    call psmotd;
		    end;
	     else if arg = "-current_project" | arg = "-cpj" then do;
		     idx = idx + 1;
		     call ppmotd;
		     end;
	     else do;  /* arg must be a project */
		idx = idx + 1;
		if  idx <= n_arguments then do;
		     call cu_$arg_ptr (idx, arg_ptr, arg_len, code);
		     do while ((substr (arg, 1, 1) ^= "-") & (idx <= n_arguments)); /* loop through all the projects */
			proj = arg;
			call ppmotd;
			idx = idx +1;
			if idx <= n_arguments then
			     call cu_$arg_ptr (idx, arg_ptr, arg_len, code);
		     end;
		end;
		end;
	     end;
	     return;
/* INTERNAL SUBROUTINES */

psmotd:
     procedure ();
	project_dir = ">sc1";
	pmotd_value_name = "print_motd._";
	administrator_ename = MOTD_ENAME;
	call main_body;
     end psmotd;


ppmotd:
     procedure ();
	project_dir = ">udd>" || proj;
	pmotd_value_name = "project_motd." || rtrim (proj) || "._";
	administrator_ename = rtrim (proj) || ".motd";
	if proj = my_project & already_printed then;
	else call main_body;
	if proj = my_project then already_printed = "1"b;
     end ppmotd;

main_body:
          procedure ();
dcl  banner_printed bit (1) aligned;

	system_area_ptr = get_system_free_area_ ();
	user_motd_ptr, system_motd_ptr = null ();	/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if user_motd_ptr ^= null () then free user_motd in (system_area);
		if system_motd_ptr ^= null () then call terminate_file_ (system_motd_ptr, 0, TERM_FILE_TERM, (0));
	     end;

	call get_system_motd ();			/* "fetch" system's MOTD data */

	call get_user_motd ();			/* fetch user's MOTD data from the value segment */

	if user_motd.dtcm >= system_motd_dtcm & ^all_sw then go to RETURN_FROM_PRINT_MOTD;
						/* nothing new added to system MOTD yet */

/* System MOTD has changed since this user last checked it: print any lines which do not appear in the old MOTD */

	banner_printed = "0"b;

	if system_motd_lth > 0 then			/* don't bother if there's nothing in it */
	     if user_motd.lth = 0 | all_sw then do;		/* ... user hasn't seen any of it yet */
		call ioa_ ("^[All messages^;New messages^] in ^a:^/", all_sw, administrator_ename);
		call iox_$put_chars (iox_$user_output, system_motd_ptr, system_motd_lth, (0));
		call ioa_$nnl ("^/");
		end;
	     
	     else do;
		used = 0;
		do while (used < system_motd_lth);
		     begin;
dcl  rest_of_system_motd character (system_motd_lth - used) unaligned defined (system_motd) position (used + 1);
			next_nl = index (rest_of_system_motd, NL);
			if next_nl = 0 then		/* use reset of segment */
			     next_nl = length (rest_of_system_motd);
			begin;
dcl  system_motd_line character (next_nl) unaligned defined (system_motd) position (used + 1);
			     if index (user_motd.motd, system_motd_line) = 0 then do;
				if ^banner_printed then do;
				     call ioa_ ("Changed messages in ^a:^/", administrator_ename);
				     banner_printed = "1"b;
				     end;
				call iox_$put_chars (iox_$user_output, addr (system_motd_line),
				     length (system_motd_line), (0));
				end;
			end;
			used = used + next_nl;
		     end;
		end;
		if substr (system_motd, system_motd_lth, 1) ^= NL then call ioa_ ("^/");
		else call ioa_$nnl ("^/");
	     end;


/* Update user's MOTD to be a copy of the current system MOTD */

	free user_motd in (system_area);		/* get rid of current one */

	user_motd_lth = system_motd_lth;
	allocate user_motd in (system_area) set (user_motd_ptr);

	user_motd.dtcm = system_motd_dtcm;
	user_motd.motd = system_motd;

	call put_user_motd ();			/* put it back into the value segment */

RETURN_FROM_PRINT_MOTD:
	if user_motd_ptr ^= null () then free user_motd in (system_area);

	if system_motd_ptr ^= null () then call terminate_file_ (system_motd_ptr, 0, TERM_FILE_TERM, (0));

	return;

/**/

/* Get the system's MOTD */

get_system_motd:
     procedure ();

dcl  1 short_status aligned like status_branch.short;
dcl  system_motd_bc fixed binary (24);

	call initiate_file_ (project_dir, administrator_ename, R_ACCESS, system_motd_ptr, system_motd_bc, code);
	if code = error_table_$noentry then goto RETURN_FROM_PRINT_MOTD;
	if code ^= 0 then do;
	     call com_err_ (code, PRINT_MOTD, "^a", pathname_ (project_dir, administrator_ename));
	     go to RETURN_FROM_PRINT_MOTD;
	end;
     	if system_motd_bc = 0 then goto RETURN_FROM_PRINT_MOTD; /* segment exists, but no messages */
	
	call hcs_$status_ (project_dir, administrator_ename, CHASE, addr (short_status), null (), code);
	if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
	     call com_err_ (code, PRINT_MOTD, "Determining date-time modified of ^a.",
		pathname_ (project_dir, administrator_ename));
	     go to RETURN_FROM_PRINT_MOTD;
	end;

	system_motd_lth = divide ((system_motd_bc + 8), 9, 21, 0);
	system_motd_dtcm = cv_fs_time (short_status.dtcm);

	return;

     end get_system_motd;



/* Convert a file-system date/time to a normal clock reading */

cv_fs_time:
     procedure (p_time_bits) returns (fixed binary (71));

dcl  p_time_bits bit (36) parameter;
dcl  time fixed binary (71);

	unspec (time) = (20)"0"b || p_time_bits || (16)"0"b;

	return (time);

     end cv_fs_time;

/**/

/* Get the user's MOTD data from the value segment */

get_user_motd:
     procedure ();

	call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, pmotd_value_name, system_area_ptr, user_motd_ptr,
	     (0), code);

	if (code = error_table_$oldnamerr) | (code = error_table_$noentry) then do;
	     call convert_motd_segment ();
	     call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, pmotd_value_name, system_area_ptr,
		user_motd_ptr, (0), code);
	end;

	if code ^= 0 then do;			/* couldn't find it anywhere: first use of print_motd */
	     user_motd_lth = 0;
	     allocate user_motd in (system_area) set (user_motd_ptr);
	     user_motd.dtcm = 0;
	end;

	return;

/**/

/* Internal to get_user_motd: converts from the old mechanism used to store per-user MOTD data to the value segment.  The
   old mechanism was a segment named Person_id.motd in the user's home directory which contained the text of the last MOTD
   seen; the DTCM of the segment was used to compare against that of the system MOTD */

convert_motd_segment:
	procedure ();

dcl  1 short_status aligned like status_branch.short;

dcl  home_dir character (168);
dcl  person_id character (24);

dcl  old_user_motd character (user_motd_lth) based (old_user_motd_ptr);
dcl  old_user_motd_bc fixed binary (24);
dcl  old_user_motd_ptr pointer;
dcl  old_user_motd_ename character (32);


	     call user_info_$homedir (home_dir);
	     call user_info_ (person_id);
	     old_user_motd_ename = rtrim (person_id) || ".motd";

	     old_user_motd_ptr = null ();		/* for cleanup handler */

	     on condition (cleanup)
		begin;
		     if old_user_motd_ptr ^= null () then
			call terminate_file_ (old_user_motd_ptr, 0, TERM_FILE_TERM, (0));
		end;

	     call initiate_file_ (home_dir, old_user_motd_ename, R_ACCESS, old_user_motd_ptr, old_user_motd_bc, code);
	     if code ^= 0 then return;		/* no old-style MOTD segment */

	     call hcs_$status_ (home_dir, old_user_motd_ename, CHASE, addr (short_status), null (), code);
	     if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
		call com_err_ (code, PRINT_MOTD, "Determining date-time modified of ^a.",
		     pathname_ (home_dir, old_user_motd_ename));
		short_status.dtcm = ""b;		/* assume it's very old */
	     end;

	     user_motd_lth = divide ((old_user_motd_bc + 8), 9, 21, 0);

	     allocate user_motd in (system_area) set (user_motd_ptr);
	     user_motd.dtcm = cv_fs_time (short_status.dtcm);
	     user_motd.motd = old_user_motd;

	     call put_user_motd ();			/* returns only if OK */

	     call delete_$path (home_dir, old_user_motd_ename, DELETE_OR_UNLINK, PRINT_MOTD, code);
	     if code = 0 then old_user_motd_ptr = null ();/* no longer exists */
	     else if code = error_table_$action_not_performed then
		call com_err_ (0, PRINT_MOTD, "^a is no longer used by this command and should be deleted.",
		     pathname_ (home_dir, old_user_motd_ename));
	     else call com_err_ (code, PRINT_MOTD, "Deleting ^a.", pathname_ (home_dir, old_user_motd_ename));

	     return;

	end convert_motd_segment;

     end get_user_motd;

/**/

/* Put the updated MOTD data into the user's value segment */

put_user_motd:
     procedure ();

	call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, pmotd_value_name, user_motd_ptr,
	     currentsize (user_motd), null (), (null ()), (0), code);

	if code = error_table_$noentry then do;		/* value segment not present: try to create it */
	     call create_default_value_segment ();
	     call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, pmotd_value_name, user_motd_ptr,
		currentsize (user_motd), null (), (null ()), (0), code);
	end;

	if code ^= 0 then do;			/* abort the whole thing if this fails */
	     call com_err_ (code, PRINT_MOTD,
		"Attempting to update message-of-the-day information in default value segment.");
	     go to RETURN_FROM_PRINT_MOTD;
	end;

	return;



/* Internal to put_user_motd: create the default value segment (if possible) */

create_default_value_segment:
	procedure ();

dcl  value_segment_path character (168);

	     call value_$set_path ("", "1"b, code);

	     if code = 0 then do;			/* created it */
		call value_$get_path (value_segment_path, (0));
		call ioa_ ("^a:  Created ^a.", PRINT_MOTD, value_segment_path);
	     end;

	     return;

	end create_default_value_segment;

     end put_user_motd;

/**/

%include access_mode_values;

%include terminate_file;
%page;
%include status_structures;

     end main_body;
     end;




		    resource_usage.pl1              07/13/88  1114.1r w 07/13/88  0935.5      152253



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



/* RESOURCE_USAGE - Procedure to print user's monthly (to date) resource usage and resource limits.
   This procedure gets this info from the user's PIT, where cpg_ put it.

   This procedure is called in any of four modes:

   1) long mode (specify the control_arg -long or -lg);
   this prints the month-to-date charges, resource limits, interactive usage for all shifts,
   absentee usage in all queues, and io daemon usage in all queues.

   2) default mode (called with no control_arg)
   this lists the month-to-date charge, the resource limit, the interactive usage for all shifts, and the
   absentee and io daemon usage for all queues.

   3) brief mode (called specifying the control_arg -brief or -bf)
   this lists the month-to-date charge, the resource limit, and totals for interactive,
   absentee and io daemon usage.

   4) totals mode (called specifying the control_arg -totals or -tt )
   this lists just the month-to-date charge and the resource limit.
*/



/****^  HISTORY COMMENTS:
  1) change(86-02-01,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
     To make these first comments hcom-acceptible. J. Phillipps and THVV  -
     June 1972 J. Phillipps - revised and upgraded for version 2 PL/1 September
     1972 . - revised for memory and virtual cpu charging on 6180 March 1973 .
     - updated headers and added absolute limit reporting a la sipb April 1976.
     
     T. Casey  - August 1977  - to only print nonzero device charges and to
     print some new ones. C. Hornig - June 1979  - to print usage even if
     charge was zero. E. N. Kittlitz   - June 1981  - UNCA rate structure
     changes
  2) change(86-02-01,Gilcrease), approve(86-05-19,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
               Add 'weekly' to cutoff table array.
                                                   END HISTORY COMMENTS */


resource_usage: ru: procedure;

dcl  crashes char (8) aligned,
     answer char (46) varying,
     answer1 char (47) varying,
     answer2 char (29) varying,
     answer3 char (18) varying,
     j fixed bin,
     logins char (7) aligned,
     datestr char (16) aligned,
     pit_name char (32) int static init ("pit"),
     reset char (16) aligned;				/* formatted string for time last reset PDT */


dcl  an fixed bin init (1),
     al fixed bin (21),
     nargs fixed bin,
     absolute bit (1) init ("0"b),
     cutoff bit (1) init ("0"b),
     month bit (1) init ("0"b),
     ec fixed bin (35),
    (i, ii) fixed bin,
     mode fixed bin init (3),
     temp float bin init (0e0);

dcl (pp, ap) ptr;

dcl  bchr char (al) unaligned based (ap);

dcl  dev_usage_buffer char (160);			/* stuff for printing device usage */
dcl  dub_array (160) char (1) unal based (addr (dev_usage_buffer));
dcl  dubp ptr;
dcl  dubl fixed bin;
dcl  based_dub char (dubl) based (dubp);
dcl (dubi, retlen) fixed bin;
dcl  devh char (8) varying;
dcl  dusw (16) bit (1) aligned;
dcl  rs_name char (32) aligned;
dcl  max_rs_number fixed bin;

dcl  ndevices fixed bin;
dcl 1 dvt (16) aligned,
    2 device_id char (8),
    2 device_price (0:7) float bin;

dcl  MILLION fixed bin (35) internal static init (1000000),
     prettybigfloat float bin int static init (1e36);

dcl  increment (0:6) char (12) aligned initial
    ("never", "daily", "monthly", "yearly", "calendar_yr", "fiscal_yr", "weekly");

dcl (addr, divide, float, length, mod, null, rtrim, substr) builtin;

/* procedures called by this program */

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cu_$arg_count entry (fixed bin, fixed bin (35)),
     date_time_ entry (fixed bin (71), char (*) aligned),
     get_pdir_ entry () returns (char (168)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     ioa_ entry options (variable),
     ioa_$rsnnl entry options (variable);		/* ctl,retstr,retlen,args */
dcl  system_info_$device_prices entry (fixed bin, ptr);
dcl  system_info_$rs_name entry (fixed bin, char (*) aligned, fixed bin (35));
dcl  system_info_$max_rs_number entry (fixed bin);

dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$too_many_args fixed bin (35) ext;


%include user_attributes;
%include pit;



/* ====================================================== */

	call system_info_$max_rs_number (max_rs_number);

	call hcs_$initiate ((get_pdir_ ()), pit_name, "", 0, 1, pp, ec); /* get ptr to PIT in process dir */
	if pp = null then do;
	     call com_err_ (ec, "resource_usage", "pit");
	     return;
	end;
	call cu_$arg_count (nargs, ec);
	if ec ^= 0 then go to argerr;
	if nargs > 1 then do;
	     call com_err_ (error_table_$too_many_args, "resource_usage", "This command only takes one argument.");
	     return;
	end;

	do an = 1 to nargs;
	     call cu_$arg_ptr (an, ap, al, ec);		/* see which option was specified */
	     if ec ^= 0 then go to argerr;
						/* default mode = 3 */
	     else if bchr = "-long" then mode = 2;	/* if arg specifies long option, set mode */
	     else if bchr = "-lg" then mode = 2;
	     else if bchr = "-brief" then mode = 1;	/* if arg specifies brief option, set mode accordingly */
	     else if bchr = "-bf" then mode = 1;
	     else if bchr = "-tt" | bchr = "-totals" | bchr = "-total" then mode = 0;
						/* if no arg, default mode is an expanded form of brief */
	     else do;
		call com_err_ (error_table_$badopt, "resource_usage", """^a""", bchr);
		return;
	     end;
	end;

	if mode = 0 then do;			/* total mode is specified */
	     call ioa_$rsnnl ("Month-to-Date: $^9.2f; Limit: $^9a; ",
		answer, j, pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
						/* if cutoff set by proj administrator, print it also */
	     if substr ((cv_limit (pp -> pit.absolute_limit)), 6) = "open" then do;
		call ioa_$rsnnl ("Total: $^9.2f;", answer3, j, pp -> pit.absolute_spent);
		call ioa_ ("^/^a", answer || answer3);
	     end;
	     else do;
		call ioa_$rsnnl ("Total: $^9.2f; Absolute Limit: $^9a; ",
		     answer1, j, pp -> pit.absolute_spent, (cv_limit (pp -> pit.absolute_limit)));
		call date_time_ (pp -> pit.absolute_cutoff, datestr);
		call ioa_$rsnnl ("Reset: ^a, ^a;",
		     answer2, j, substr (datestr, 1, 8), increment (pp -> pit.absolute_increm));
		call ioa_ ("^/^a", answer);
		call ioa_ (answer1 || answer2);
	     end;
	     goto endit1;

	end;
	call date_time_ (pp -> pit.proc_creation_time, datestr); /* usage from beginning of mo. to time process created */
	call date_time_ (pp -> pit.time_last_reset, reset); /* format time last reset PDT */
	call ioa_ ("^/^a.^a  Report from ^a to ^a", pp -> pit.login_name, pp -> pit.project, reset, datestr);
	if max_rs_number > 0 then do;
	     call system_info_$rs_name ((pp -> pit.rs_number), rs_name, ec);
	     if ec ^= 0 then call com_err_ (ec, "resource_usage",
		"For rate structure ^d.  Contact your system administrator.", pp -> pit.rs_number);
	     call ioa_ ("^5xRate Structure -- ^a", rs_name);
	end;

quick:
	if mode = 2 then do;			/* long mode */
	     if substr ((cv_limit (pp -> pit.absolute_limit)), 6) = "open" then do;
		call ioa_$rsnnl ("Month-to-Date: $^9.2f; Limit: $^9a; ",
		     answer, j, pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
		call ioa_$rsnnl ("Total: $^9.2f;", answer3, j, pp -> pit.absolute_spent);
		call ioa_ (answer || answer3);
	     end;
	     else do;
		call ioa_$rsnnl ("Total: $^9.2f, Absolute Limit: $^9a; ",
		     answer1, j, pp -> pit.absolute_spent, (cv_limit (pp -> pit.absolute_limit)));
		call date_time_ (pp -> pit.absolute_cutoff, datestr);
		call ioa_$rsnnl ("Reset: ^a, ^a;",
		     answer2, j, substr (datestr, 1, 8), increment (pp -> pit.absolute_increm));
		call ioa_ (answer1 || answer2);
	     end;
	end;

	else do;
	     call ioa_ ("Month-To-Date: $^9.2f;  Limit: $^9a;",
		pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
	end;
	do i = 1 to 7, 0;				/* sum interactive charge */
	     temp = temp + pp -> pit.interactive (i).charge;
	end;
	if temp = 0e0 then do;			/* if no usage, don't print header */
	     call ioa_ ("^/Interactive Usage: none;");
	     go to abstee;
	end;

/*    P R I N T  H E A D E R S  */

	if pp -> pit.crashes = 1 then
	     crashes = "crash.  ";			/* do singular and plural parse */
	else crashes = "crashes.";
	if pp -> pit.logins = 1 then
	     logins = "login, ";
	else logins = "logins,";
	if mode = 2 then do;			/* long mode header for interactive usage */
	     call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
		temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
	     call ioa_ ("^4xshift^2x$charge^4x$limit^8xvcpu^4xconnect^4xterminal i/o^2xmemory/kmu");
	end;
	else if mode = 1 then do;			/* brief mode header for interactive usage */
	     call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
		temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
	     go to abstee;
	end;
	else if mode = 3 then do;			/* default mode */
	     call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
		temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
	     call ioa_ ("^4xshift^2x$charge^4x$limit");
	end;
	temp = 0e0;				/* clear temp */


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


/* print out resource usage */

	do i = 1 to 7, 0;
	     if pp -> pit.shift_limit (i) > prettybigfloat
	     then if pp -> pit.interactive (i).charge = 0e0
		& pp -> pit.interactive (i).cpu = 0
		& pp -> pit.interactive (i).connect = 0
		& pp -> pit.interactive (i).core = 0
		& pp -> pit.interactive (i).io_ops = 0
		then goto skip;			/* don't print useless lines */
	     if mode = 2 then do;			/* long mode */
		call ioa_ ("^5x^1d^4x^8.2f^1x^9a^3x^9a^2x^9a^5x^11.1f^1x^11.1f", i,
		     pp -> pit.interactive (i).charge, (cv_limit (pp -> pit.shift_limit (i))),
		     (cv_time (pp -> pit.interactive (i).cpu)), (cv_time (pp -> pit.interactive (i).connect)),
		     float (pp -> pit.interactive (i).io_ops/1e3), float (pp -> pit.interactive (i).core/1e6));
	     end;
	     else if mode = 3 then do;		/* default mode */
		call ioa_ ("^5x^1d^4x^8.2f^1x^9a", i, pp -> pit.interactive (i).charge,
		     (cv_limit (pp -> pit.shift_limit (i))));
skip2:	     end;
skip:	end;

abstee:	temp = 0e0;				/* clear temp */
	do ii = 1 to 4;				/* scan for absentee usage */
	     temp = temp + pp -> pit.absentee (ii).charge;
	end;
	if temp = 0e0 then do;
	     call ioa_ ("^/Absentee Usage:    none;");
	     go to iod;
	end;
	else call ioa_ ("^/Absentee Usage:    $^8.2f;", temp);
	if mode = 1 then go to iod;			/* brief mode exit here */
	else if mode = 3 then do;			/* default mode */
	     call ioa_ ("^4xqueue^2x$charge^6xjobs");
	     do ii = 1 to 4;
		if pp -> pit.absentee (ii).charge = 0e0 then go to next;
		call ioa_ ("^5x^1d^4x^8.2f^6x^4d", ii, pp -> pit.absentee (ii).charge, pp -> pit.absentee (ii).jobs);
next:	     end;
	end;
	if mode = 2 then do;			/* long mode */
	     call ioa_ ("^4xqueue^2x$charge^6xjobs^8xvcpu^2xmemory/kmu");

	     do ii = 1 to 4;
		if pp -> pit.absentee (ii).charge = 0e0 then go to skip3;
		call ioa_ ("^5x^1d^4x^8.2f^6x^4d^3x^9a^2x^10.1f", ii, pp -> pit.absentee (ii).charge,
		     pp -> pit.absentee (ii).jobs, cv_time (pp -> absentee (ii).cpu),
		     float (pp -> pit.absentee (ii).memory/1e6));
skip3:	     end;
	end;
iod:	temp = 0e0;
	do ii = 1 to 4;
	     temp = temp + pp -> pit.iod (ii).charge;
	end;
	if temp = 0e0 then do;
	     call ioa_ ("^/IO Daemon Usage:   none;");
	     go to device;
	end;
	else call ioa_ ("^/IO Daemon Usage:   $^8.2f;", temp);
	if mode = 1 then go to device;		/* brief mode exit here */
	else if mode = 3 then do;			/* default mode */
	     call ioa_ ("^4xqueue^2x$charge^6xlines");
	     do ii = 1 to 4;
		if pp -> pit.iod (ii).charge = 0e0 then go to next2;
		call ioa_ ("^4x^1x^1d^4x^8.2f^x^10d",
		     ii, pp -> pit.iod (ii).charge, pp -> pit.iod (ii).lines);
next2:	     end;
	end;
	if mode = 2 then do;			/* long mode */
	     call ioa_ ("^4xqueue^2x$charge^4xpieces^7xpages^8xlines");
	     do ii = 1 to 4;
		if pp -> pit.iod (ii).charge = 0e0 then go to skip4;
		call ioa_ ("^4x^1x^1d^4x^8.2f^6x^4d^3x^9d^x^12d",
		     ii, pp -> pit.iod (ii).charge, pp -> pit.iod (ii).pieces,
		     pp -> pit.iod (ii).pages, pp -> pit.iod (ii).lines);
skip4:	     end;
	end;
device:	temp = 0e0;				/* clear temp */
	do ii = 1 to 16;				/* scan for device usage */
	     if pp -> pit.devices (ii) = 0e0
	     then dusw (ii) = ""b;
	     else dusw (ii) = "1"b;
	     temp = temp + pp -> pit.devices (ii);
	end;
	if temp = 0e0 then do;
	     if mode = 2 then
		call ioa_ ("^/Device Usage:   none;");	/* only print in long mode */
	end;
	else do;
	     call ioa_ ("^/Device Usage:      $^8.2f;", temp);

/* The purpose of the following code is to print a column only for devices with nonzero usage. */

	     call system_info_$device_prices (ndevices, addr (dvt)); /* get device names and prices (but only use names) */
	     dev_usage_buffer = "";			/* clear buffer before making heading */
	     dubi = 1;				/* set index to first character position in buffer */
	     do i = 1 to 16;			/* put each device name in heading */
		if dusw (i) then do;		/* but only if it has nonzero usage */
		     devh = rtrim (device_id (i));	/* copy name and see how long it really is */
		     dubi = dubi + 9 - length (devh);	/* compute how far to skip to right-adjust name */
		     substr (dev_usage_buffer, dubi, 1) = "$"; /* put in leading dollar sign */
		     substr (dev_usage_buffer, dubi+1, length (devh)) = devh; /* put in the name */
		     dubi = dubi + 1 + length (devh);	/* advance char index past name */
		end;
	     end;
	     call ioa_ ("^a", dev_usage_buffer);	/* print the heading */

	     dev_usage_buffer = "";			/* clear buffer before formatting usage figures */
	     dubl = length (dev_usage_buffer);		/* initialize char counters */
	     dubi = 1;
	     do i = 1 to 16;			/* print usage for each device */
		if dusw (i) then do;		/* only if it is nonzero */
		     dubp = addr (dub_array (dubi));	/* get addr of where to put next usage field */
		     call ioa_$rsnnl ("^3x^7.2f", based_dub, retlen, pp -> pit.devices (i)); /* format the usage figure */
		     dubl = dubl - retlen;		/* decrement remaining length of buffer */
		     dubi = dubi + retlen;		/* advance index to next available character position */
		end;
	     end;
	     call ioa_ ("^a", dev_usage_buffer);	/* print the usage figures */
	end;
endit:	call ioa_ ("");
endit1:	call hcs_$terminate_noname (pp, ec);
	return;

argerr:	call com_err_ (ec, "resource_usage");
	return;


/* =========================================================== */



cv_time:	procedure (time) returns (char (9) aligned);

/* procedure to convert from fixed bin (71) to a nice formatted string of hrs: mins: secs */



dcl  time fixed bin (71),
     j fixed bin,
     hours fixed bin,
     minutes fixed bin,
     seconds fixed bin,
     answer char (9) aligned;


	     seconds = divide (time, MILLION, 35, 0);
	     minutes = divide (seconds, 60, 35, 0);
	     seconds = mod (seconds, 60);		/* get rid of the remainder */
	     hours = divide (minutes, 60, 35, 0);
	     minutes = mod (minutes, 60);		/* get rid of the remainder */

	     call ioa_$rsnnl ("^3d:^2d:^2d", answer, j, hours, minutes, seconds);
	     if substr (answer, 5, 1) = " " then substr (answer, 5, 1) = "0";
	     if substr (answer, 8, 1) = " " then substr (answer, 8, 1) = "0";

	     return (answer);
	end;




/* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = */

cv_limit:	procedure (limit) returns (char (9) aligned);

/* procedure to convert a float bin $limit into either the string, "open", if $limit is >= 1e37,
   or to convert a float bin $limit into an integer $limit  */

dcl  limit float bin,
     lim char (9) aligned,
     jj fixed bin,
     itemp fixed bin;


	     if limit >= prettybigfloat then do;
		lim = "     open";
		go to char;
	     end;
	     else do;
		itemp = limit;
		call ioa_$rsnnl ("^6d.00", lim, jj, itemp);
	     end;
char:	     return (lim);
	end;



test_ru:	entry (xpit);				/* enter here if using an experimental PIT */

dcl  xpit char (*);

	pit_name = xpit;



     end resource_usage;




		    ring0_get_.pl1                  11/20/86  1406.1r w 11/20/86  1145.0       52470



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


ring0_get_: proc;

/* "Adjusted" by Bernard Greenberg, for hc def seg 07/22/76 */

dcl (sltp1, names_ptr1, defs_ptr1) ptr static init (null),
    (names_ptr2, defs_ptr2) ptr,
    (a_defsp, a_sltp, a_namep, defp, defsp) ptr,
    (i, j) fixed bin,
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin),
     get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin);

dcl  based_bit18 bit (18) aligned based dim (0:511);
dcl  a_defname char (*),
     a_offset fixed bin (18),
     a_type fixed bin;



dcl (error_table_$no_defs, error_table_$noentry) fixed bin (35) ext;
dcl  error_table_$invalidsegno fixed bin (35) ext;

dcl  segptr ptr,
     code fixed bin,
     entryptr ptr,
     dir char (*),
     entry char (*);

dcl  SLDIR char (55) init (">system_library_1") static options (constant);


dcl (addr, addrel, baseno, baseptr, fixed, length, null, reverse, verify) builtin;


/*  */

segptr:	entry (dir, entry, segptr, code);		/* entry to return segment pointer */

	call get_static_ptrs ("0"b);
	segptr = get_segptr ();
	return;


name:	entry (dir, entry, segptr, code);		/* entry to return segment name */

	call get_static_ptrs ("0"b);
	call get_name (segptr, "0"b);			/* 0 => one */
	return;

names:	entry (dir, entryptr, segptr, code);		/* entry to return pointer to names */

	call get_static_ptrs ("0"b);
	call get_name (segptr, "1"b);			/* 1 => many */
	return;

definition: entry (segptr, entry, a_defname, a_offset, a_type, code);

	call get_static_ptrs ("1"b);			/* 1 => get defs ptr */
	if segptr = null then segptr = get_segptr ();
	call get_definition (segptr);
	return;



/* The following entries are the same as the above except that the caller
   supplies a pointer to the SLT and NAME TABLE to use */

segptr_given_slt: entry (dir, entry, segptr, code, a_sltp, a_namep);

	call get_param_ptrs ("0"b);
	segptr = get_segptr ();
	return;

name_given_slt: entry (dir, entry, segptr, code, a_sltp, a_namep);

	call get_param_ptrs ("0"b);
	call get_name (segptr, "0"b);
	return;


definition_given_slt: entry (segptr, entry, a_defname, a_offset, a_type, code, a_sltp, a_namep, a_defsp);

	call get_param_ptrs ("1"b);
	if segptr = null then segptr = get_segptr ();	/* Look up entry if needed */
	call get_definition (segptr);
	return;

/*  */
get_static_ptrs: proc (we_want_defs);

dcl  we_want_defs bit (1) aligned;			/* T => call for defs */

	     code = 0;
	     if we_want_defs & defs_ptr1 = null then call init_static_ptrs;
	     else if names_ptr1 = null then call init_static_ptrs;
	     if code ^= 0 then go to error;
	     sltp = sltp1;
	     names_ptr2 = names_ptr1;
	     defs_ptr2 = defs_ptr1;
	     return;

init_static_ptrs: proc;
		call hcs_$initiate (SLDIR, "slt", "", 0, 1, sltp1, code);
		if sltp1 = null then return;
		call hcs_$initiate (SLDIR, "name_table", "", 0, 1, names_ptr1, code);
		if names_ptr1 = null then return;
		if we_want_defs then do;
		     call hcs_$initiate (SLDIR, "definitions_", "", 0, 1, defs_ptr1, code);
		     if defs_ptr1 = null then return;
		end;
		code = 0;				/* Let's hear it for hcs_$initiate! */
	     end init_static_ptrs;
	end get_static_ptrs;

get_param_ptrs: proc (we_want_defs);

dcl  we_want_defs bit (1) aligned;			/* We want definitions */
	     sltp = a_sltp;
	     names_ptr2 = a_namep;
	     if we_want_defs then defs_ptr2 = a_defsp;
	end get_param_ptrs;

get_segptr: procedure returns (ptr);


	     do i = slt.first_sup_seg to slt.last_sup_seg; /* loop through sup segs searching */
		sltep = addr (slt.seg (i));		/* get pointer to SLT entry */
		namep = addrel (names_ptr2, slte.names_ptr); /* get pointer to names for this segment */
		do j = 1 to namep -> segnam.count;	/* search all names */
		     if entry = namep -> segnam.names (j).name then do; /* found it */
			code = 0;
			return (baseptr (i));
		     end;
		end;
	     end;

	     code = error_table_$noentry;
	     go to error_segptr;
	end get_segptr;

get_name:	procedure (sp, many);

dcl  many bit (1) aligned, sp ptr;

	     i = bin (baseno (sp));			/* get input segment number */
	     if i > slt.last_sup_seg | i < slt.first_sup_seg then do; /* bad input segment number */
		code = error_table_$invalidsegno;
		return;
	     end;

	     sltep = addr (slt.seg (i));		/* get pointer to SLT entry */
	     pathp = addrel (names_ptr2, slte.path_ptr);
	     namep = addrel (names_ptr2, slte.names_ptr);
	     if pathp ^= names_ptr2 then dir = pathp -> path.name; else dir = ""; /* return path name */
	     if many then entryptr = namep;
	     else entry = namep -> segnam.names (1).name; /* return only one name */
	     code = 0;
	end get_name;

get_definition: procedure (textp);
dcl  textp ptr;

	     code = 0;
	     i = bin (baseno (textp));
	     if i < 4 | i > 511 then code = error_table_$no_defs;
	     else do;
		defsp = addrel (defs_ptr2, defs_ptr2 -> based_bit18 (i));
		if defsp = defs_ptr2 then code = error_table_$no_defs;
		else do;
		     call get_definition_ (defsp, entry, a_defname, defp, code);
		     if code = 0 then do;
			a_type = fixed (defp -> definition.class, 3);
			a_offset = fixed (defp -> definition.value, 18);
		     end;
		end;
	     end;

	end get_definition;

error_segptr: segptr = null;
error:	return;
						/*  */
% include slt;
% include slte;
% include definition;
     end;




		    system_info_.pl1                07/13/88  1114.1r w 07/13/88  0935.5      190773



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

system_info_: proc;

/* SYSTEM_INFO_ - return various information to user about Multics.

   The information is obtained from the header of "whotab"
   or from "installation_parms" or from the correct "rate_structure_x" seg.

   See AG93 (Multics Subroutines and Input/Output Modules) for documentation
   of the following entries:

   $id (installation_id)
   $sysid (sysid)
   $version_id
   $session (session_type)
   $titles (company, dept, companyds, deptds)
   $users (maxusers, nusers, maxunits, nunits)
   $timeup (time)
   $prices (cpu, log, process, core, disk, registration)
   $prices_rs (rs_number, cpu, log, process, core, disk, registration)
   $device_prices (ndevices, addr (dvt))
   $device_prices_rs (rs_number, ndevices, addr (dvt))
   $abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits)
   $abs_prices (farray)
   $default_absentee_queue (default_queue)
   $abs_prices_rs (rs_number, farray)
   $io_prices (farray)
   $io_prices_rs (rs_number, farray)
   $next_shutdown (time, reason, until)
   $last_shutdown (time, erfno)
   $shift_table (stt)
   $access_ceiling (access_ceiling)
   $level_names (long_names, short_names)
   $category_names (long_names, short_names)
   $log_threshold (state, npages)
   $next_shift_change (cur_shift, change_time, new_shift, start_time)
   $ARPANET_host_number (host_num)
   $resource_price (price_name, price, code)
   $resource_price_rs (rs_number, price_name, price, code)
   $rs_name (rs_number, rs_name, code)
   $rs_number (rs_name, rs_number, code)
   $max_rs_number (rs_count)

   See AN-66 (AS PLM) for documentation of the following internal interfaces:

   $abs_chn (evchn, pid)
   $request_chn (pid, event_channel, mseg_dname, mseg_ename)

   Written by THVV
   Modified 741231 by PG to add entries for new AIM fields.
   Modified 750324 by PG to rename $dial_chn to $request_chn.
   Modified 750912 by PG to give request facility its own process id.
   Modified 751103 by PG to complain if can't initiate whotab/installation_parms.
   Modified April 1976 by T. Casey to return shift start time as fourth argument to next_shift_change entry point.
   Modified 761229 by D. M. Wells to add $ARPANET_host_number entry point.
   Modified May 1978 by T. Casey to add resource_price entry point.
   Modified November 1978 by T. Casey for MR7.0 to add arguments to abs_limits entry point.
   Modified July 1979 by J. N. R. Barnecut for MR8.0 to add rate_structure entry points. (UNCA)
   Modified Feb 1980 by M. B. Armstrong for further changes re rate_structure. (UNCA)
   Modified 17 September 1980 by G. Palter to add default_absentee_queue entrypoint.
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures.
   Modified May 1983 by Art Beattie to add version_id entry.
   Modified 1984-06-19 BIM to make ARPA return -1 all the time.
                           to add trusted_path_flags entrypoint.
   Modified 840619 for session entry and to use initiate_file_ and friends... -E. A. Ranzenbach
*/

/****^  HISTORY COMMENTS:
  1) change(85-10-24,Spitzer), approve(85-10-24,MCR7280),
     audit(85-12-05,Lippard), install(85-12-16,MR12.0-1001):
     Return "shutdown" rather than the null string if the system was shutdown
     rather than crashed.
  2) change(87-04-28,GDixon), approve(87-07-23,MCR7741),
     audit(87-07-24,Brunelle), install(87-08-04,MR12.1-1055):
     Updated for change to user_table_entry.incl.pl1.
  3) change(88-06-03,Parisek), approve(88-06-10,MCR7920),
     audit(88-06-23,Hunter), install(87-07-05,MR12.2-1053):
     Change reference of pitmsg.incl.pl1 to pit.incl.pl1 as the
     pitmsg.incl.pl1 name was removed from pit.incl.pl1 in MR12.1.
                                                   END HISTORY COMMENTS */
	return;

/* parameters */

dcl  rs_number fixed bin,
     rs_name char (*),
     ndev fixed bin,
     devp ptr;

/* entries */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  active_all_rings_data$version_id ext char (8);
dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  datebin_$next_shift_change entry (fixed bin (71), fixed bin (71), fixed bin, fixed bin);
dcl  get_pdir_ entry () returns (char (168));
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));

/* automatic */

dcl  ap ptr,					/* ptr to arg */
     al fixed bin,					/* lth of arg */
     arg_offset fixed bin,
     cur_rs_ptr ptr init (null),
     ec fixed bin (35),
     nargs fixed bin,
    (i, j) fixed bin,
     t71 fixed bin (71),
    (t1, t2) fixed bin;

/* based */

dcl  bchr char (al) based (ap),			/* character arg */
     bfix fixed bin (35) based (ap),			/* fixed bin arg */
     bflo float bin (27) based (ap),			/* float bin arg */
     b71 fixed bin (71) based (ap),			/* dbl prec arg */
     b36 bit (36) aligned based (ap),			/* bit (36) arg */
     bfa (0: 7) float bin (27) based (ap),		/* float array arg */
     based_fixed_array (4) fixed bin (35) based (ap),	/* fixed array arg */
     based_shift_queue_array (0:7, 4) fixed bin (35) based (ap); /* array arg for per-shift-and-queue absentee parms */

/* internal static */

dcl (whoptr, pp) ptr int static init (null);
dcl  rs_ptrs (0:9) ptr int static init ((10) null);
dcl  ip ptr defined (rs_ptrs (0));
dcl  sysdir char (168) int static init (">system_control_1");

/* builtins */

dcl (char, clock, fixed, hbound, ltrim, max, null, string) builtin;

/* include files */

%include access_mode_values;

%include installation_parms;
%include rate_structure;
%include trusted_path_flags;
%include whotab;

%include pit;

%include terminate_file;

%include user_attributes;

%include user_table_entry;

/* ======================================================== */

installation_id: entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);		/* Get ptr to string argument. */
	if ec ^= 0 then return;
	bchr = installation_parms.installation_id;

	return;

/* -------------------------------------------------------- */

sysid:	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	bchr = whotab.sysid;

	return;


/* -------------------------------------------------------- */

version_id:
	entry;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	bchr = active_all_rings_data$version_id;

	return;

/* -------------------------------------------------------- */

session:
	entry;

	if whoptr = null then call setup ();

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	bchr = whotab.session;

	return;

/* -------------------------------------------------------- */

titles:	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	bchr = installation_parms.company;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then return;
	bchr = installation_parms.department;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0 then return;
	bchr = installation_parms.companyds;
	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0 then return;
	bchr = installation_parms.departmentds;

	return;

/* -------------------------------------------------------- */

users:	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	bfix = whotab.mxusers;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then return;
	bfix = whotab.n_users;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0 then return;
	bfix = whotab.mxunits;
	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0 then return;
	bfix = whotab.n_units;

	return;

/* -------------------------------------------------------- */

timeup:	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	b71 = whotab.timeup;

	return;

/* -------------------------------------------------------- */

next_shutdown: entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	b71 = whotab.nextsd;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then return;
	if whotab.why < "" then bchr = "";
	else bchr = whotab.why;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0 then return;
	b71 = whotab.until;

	return;

/* -------------------------------------------------------- */

last_shutdown: entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	b71 = whotab.lastsd;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then return;
	bchr = whotab.erfno;
	if bchr = "" then bchr = "shutdown";

	return;

/* -------------------------------------------------------- */

rates:
prices:	entry;

	call setup_user_rs;
	arg_offset = 0;

rates_join:
	call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
	if ec ^= 0 then return;
	do i = 0 to 7;
	     bfa (i) = rate_structure.cpu_price (i);
	end;
	call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
	if ec ^= 0 then return;
	do i = 0 to 7;
	     bfa (i) = rate_structure.log_base_price (i);
	end;
	call cu_$arg_ptr (arg_offset + 3, ap, al, ec);
	if ec ^= 0 then return;
	do i = 0 to 7;
	     bfa (i) = rate_structure.io_ops_price (i);
	end;
	call cu_$arg_ptr (arg_offset + 4, ap, al, ec);
	if ec ^= 0 then return;
	do i = 0 to 7;
	     bfa (i) = rate_structure.core_price (i);
	end;
	call cu_$arg_ptr (arg_offset + 5, ap, al, ec);
	if ec ^= 0 then return;
	bflo = rate_structure.disk_price;
	call cu_$arg_ptr (arg_offset + 6, ap, al, ec);
	if ec ^= 0 then return;
	bflo = rate_structure.registration_price;

	return;

/* -------------------------------------------------------- */

rates_rs:
prices_rs: entry (rs_number);

	call setup_rs (rs_number);
	arg_offset = 1;
	go to rates_join;

/* -------------------------------------------------------- */

device_rates:
device_prices: entry (ndev, devp);

dcl 1 dvt (16) aligned based,
    2 device_id char (8),
    2 device_price (0: 7) float bin;

	call setup_user_rs;
	arg_offset = 0;

device_rates_join:
	ndev = rate_structure.ndevices;
	call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
	if ec ^= 0 then return;
	if devp ^= null then do i = 1 to rate_structure.ndevices;
	     devp -> dvt.device_id (i) = rate_structure.devtab.device_id (i);
	     do j = 0 to 7;
		devp -> dvt.device_price (i, j) = rate_structure.devtab.device_price (i, j);
	     end;
	end;

	return;

/* -------------------------------------------------------- */

device_rates_rs:
device_prices_rs: entry (rs_number, ndev, devp);

	call setup_rs (rs_number);
	arg_offset = 1;
	go to device_rates_join;

/* -------------------------------------------------------- */

/* dcl system_info_$abs_limits ((4) fixed bin (35), fixed bin (35), (0:7,4) fixed bin (35));
   call system_info_$abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits); */


abs_limits:
	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;

	based_fixed_array (*) = installation_parms.abs_cpu_default_limit (*);

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then return;

	bfix = installation_parms.foreground_cpu_default_limit;

	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0 then return;

	based_shift_queue_array (*, *) = installation_parms.abs_cpu_max_limit (*, *);

	return;

/* -------------------------------------------------------- */

default_absentee_queue: entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;

	bfix = installation_parms.default_absentee_queue;

	return;

/* -------------------------------------------------------- */

abs_prices: entry;

	call setup_user_rs;
	arg_offset = 0;

abs_prices_join:
	call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
	if ec ^= 0 then return;
	do i = 1 to 4;
	     bfa (i-1) = rate_structure.abs_cpu_price (i);
	end;
	call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
	if ec ^= 0 then return;
	do i = 1 to 4;
	     bfa (i-1) = rate_structure.abs_mem_price (i);
	end;

	return;

/* -------------------------------------------------------- */

abs_prices_rs: entry (rs_number);

	call setup_rs (rs_number);
	arg_offset = 1;
	go to abs_prices_join;

/* -------------------------------------------------------- */

io_prices: entry;

	call setup_user_rs;
	arg_offset = 0;

io_prices_join:
	call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
	if ec ^= 0 then return;
	do i = 1 to 4;
	     bfa (i-1) = rate_structure.iod_rec_price (i);
	end;

	return;

/* --------------------------------------------------------- */

io_prices_rs: entry (rs_number);

	call setup_rs (rs_number);
	arg_offset = 1;
	go to io_prices_join;

/* ------------------------------------------------------- */

abs_chn:	entry (ev, pid);

dcl  ev fixed bin (71), pid bit (36);

	if whoptr = null then call setup;

	call cu_$arg_count (nargs);

	ev = whotab.abs_event;
	if nargs > 1 then pid = whotab.abs_procid;

	return;

/* ------------------------------------------------------ */

next_shift_change: entry (curshft, shftime, newshft, starttime);

dcl (curshft, newshft) fixed bin, (shftime, starttime) fixed bin (71);

	call cu_$arg_count (nargs);

	call datebin_$next_shift_change ((clock ()), t71, t1, t2);
	curshft = t1;
	if nargs > 1 then shftime = t71;
	if nargs > 2 then newshft = t2;
	if nargs > 3 then do;
	     if whoptr = null then call setup;
	     starttime = whotab.last_shift_change_time;
	end;

	return;

/* -------------------------------------------------------- */

shift_table: entry (stt);

dcl  stt (336) fixed bin;

	if whoptr = null then call setup;

	do i = 1 to 336;
	     stt (i) = fixed (installation_parms.shifttab (i), 3);
	end;

	return;

/* -------------------------------------------------------- */

request_chn:
	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	b36 = whotab.request_process_id;

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0 then return;
	b71 = whotab.request_channel;

	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0 then return;
	bchr = sysdir;

	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0 then return;
	bchr = "as_request.ms";

	return;

/* -------------------------------------------------------- */

access_ceiling:
	entry (access_ceiling);

dcl  access_ceiling bit (72) aligned;

	if whoptr = null then call setup;

	access_ceiling = installation_parms.access_authorization_ceiling;
	return;

/* -------------------------------------------------------- */

log_threshold:
	entry;

dcl (state char (al), npages fixed bin) based (ap);

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;

	i = installation_parms.syserr_log_copy_threshold;

	if i < 0 then state = "off";
	else if i = 0 then state = "default";
	else state = "on";

	call cu_$arg_ptr (2, ap, al, ec);
	if ec = 0 then npages = max (i, 0);

	return;

/* -------------------------------------------------------- */

level_names:
	entry;

dcl (long_level_names char (32), short_level_names char (8)) dim (0:7) based (ap);

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	long_level_names (*) = installation_parms.level_names (*);

	call cu_$arg_ptr (2, ap, al, ec);
	if ec = 0 then short_level_names (*) = installation_parms.short_level_names (*);

	return;

/* -------------------------------------------------------- */

category_names:
	entry;

dcl (long_category_names char (32), short_category_names char (8)) dim (18) based (ap);

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	long_category_names (*) = installation_parms.category_names (*);

	call cu_$arg_ptr (2, ap, al, ec);
	if ec = 0 then short_category_names (*) = installation_parms.short_category_names (*);

	return;

/* -------------------------------------------------------- */

ARPANET_host_number:
	entry;

	if whoptr = null then call setup;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	bfix = -1;

	return;

/* -------------------------------------------------------- */

resource_price: entry (a_price_name, a_price, a_code);

dcl  a_price_name char (*);
dcl  a_price float bin;
dcl  a_code fixed bin (35);

dcl  error_table_$noentry ext fixed bin (35);

	call setup_user_rs;

resource_price_join:
	do i = 1 to rate_structure.nrscp;
	     if a_price_name = rate_structure.resource (i).name then do;
		a_price = rate_structure.resource (i).price;
		a_code = 0;
		return;
	     end;
	end;
	a_code = error_table_$noentry;
	a_price = 0;
	return;

/* -------------------------------------------------------- */

resource_price_rs: entry (rs_number, a_price_name, a_price, a_code);

	call setup_rs (rs_number);
	go to resource_price_join;

/* -------------------------------------------------------- */

rs_name:	entry (rs_number, rs_name, a_code);

	if whoptr = null then call setup;

	if rs_number < 0 | rs_number > whotab.n_rate_structures then do;
	     a_code = error_table_$noentry;
	     rs_name = " INVALID_RS_" || ltrim (char (rs_number)); /* leading space so it won't match any name */
	end;
	else do;
	     a_code = 0;
	     rs_name = installation_parms.rate_structures (rs_number);
	end;
	return;

/* --------------------------------------------------------- */

rs_number: entry (rs_name, rs_number, a_code);

	if whoptr = null then call setup;

	do i = 0 to whotab.n_rate_structures;
	     if installation_parms.rate_structures (i) = rs_name then do;
		rs_number = i;
		a_code = 0;
		return;
	     end;
	end;

	a_code = error_table_$noentry;
	rs_number = 0;
	return;

/* --------------------------------------------------------- */

max_rs_number: entry (rs_count);

dcl  rs_count fixed bin;

	if whoptr = null then call setup;
	rs_count = whotab.n_rate_structures;
	return;

/* --------------------------------------------------------- */

trusted_path_flags:
	entry (stp);

dcl  stp bit (36) aligned;

	if whoptr = null then call setup;
	trusted_path_flags = "0"b;
	trusted_path_flags.login = installation_parms.trusted_path_login;
	stp = string (trusted_path_flags);
	return;

/* --------------------------------------------------------- */

setup:	proc;

dcl  ec fixed bin (35);

	     call initiate_file_  (sysdir, "whotab", R_ACCESS, whoptr, 0, ec);
	     if whoptr = null
	     then call com_err_ (ec, "system_info_", "^a>whotab", sysdir);

	     call initiate_file_ (sysdir, "installation_parms", R_ACCESS, ip, 0, ec);
	     if ip = null
	     then call com_err_ (ec, "system_info_", "^a>installation_parms", sysdir);
	end setup;

/* --------------------------------------------- */

setup_rs:	proc (rsnum);

dcl  ec fixed bin (35);
dcl  rsnum fixed bin;
dcl  rsn fixed bin;
dcl  en char (32);

	     if whoptr = null then call setup;

	     if rsnum < 0 | rsnum > whotab.n_rate_structures then do;
		call com_err_ (0, "system_info_", "Invalid rate_structure number ^d. Default rates will be used.", rsnum);
		rsn = 0;
	     end;
	     else rsn = rsnum;

	     if rs_ptrs (rsn) = null then do;
		en = "rate_structure_" || ltrim (char (rsn));
		call initiate_file_ (sysdir, en, R_ACCESS, rs_ptrs (rsn), 0, ec);
		if rs_ptrs (rsn) = null then do;
		     call com_err_ (ec, "system_info_", "^a>^a.  Default rates will be used.", sysdir, en);
		     rsn = 0;			/* user loses if rsn already 0 */
		end;
	     end;
	     cur_rs_ptr = rs_ptrs (rsn);

	end setup_rs;

/* --------------------------------------------- */

setup_user_rs: proc;

dcl  ec fixed bin (35);
dcl  rsn fixed bin;

	     if pp = null then call initiate_file_ (get_pdir_ (), "pit", R_ACCESS, pp, 0, ec);
	     if pp = null then do;
		call com_err_ (ec, "system_info_", "pit");
		rsn = 0;
	     end;
	     else rsn = pp -> pit.rs_number;
	     call setup_rs (rsn);

	end setup_user_rs;

/* --------------------------------------------- */

test_system_info: entry (xdirn);

dcl  xdirn char (*) parameter;
dcl  nsd char (168);

	call absolute_pathname_ (xdirn, nsd, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, "system_info_$test_system_info", xdirn);
	     return;
	end;
	sysdir = nsd;
	if whoptr ^= null then			/* need to cleanup? */
	     call terminate_file_ (whoptr, 0, TERM_FILE_TERM, ec);
	whoptr = null;				/* re-initiate whotab and installation_parms */
	do i = 0 to hbound (rs_ptrs, 1);		/* more tidying? */
	     if rs_ptrs (i) ^= null then do;
		call terminate_file_ (rs_ptrs (i), 0, TERM_FILE_TERM, ec);
		rs_ptrs (i) = null;
	     end;
	end;

	return;

     end system_info_;




		    user_info_.pl1                  07/13/88  1114.1rew 07/13/88  0905.2      162018



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* format: style2 */

user_info_:
     proc;

/* USER_INFO_ - procedure to return selected information from the PIT

   The information returned was put there by the procedure "cpg_"
   when the process was created.

   The following entries exist:

   .	user_info_$user_info_ (name, proj, acct)
   .	user_info_$whoami (name, proj, acct)
   .	user_info_$login_data (name, proj, acct, anon, stby, weight, time_login, login_word)
   .	user_info_$usage_data (n_processes, cputime_old_procs, time_login, time_proc_create,core_old_procs,io_old_procs)
   .	user_info_$homedir (home_directory)
   .	user_info_$responder (login_responder)
   .	user_info_$tty_data (terminal_id, terminal_type, channel_id, line_type)
   .	user_info_$terminal_data (terminal_id, terminal_type_name, channel_id, line_type, charge_type)
   .      user_info_$service_type (service_type)
   .      user_info_$process_type (process_type)
   .	user_info_$logout_data (logout_channel, logout_processid)
   .	user_info_$login_line (login_string)
   .	user_info_$absentee_queue (q)
   .	user_info_$absin (path)
   .	user_info_$absout (path)
   .	user_info_$outer_module (om)
   .	user_info_$load_ctl_info (group, sb, bumpclock, weight)
   .      user_info_$authorization_range (range)
   .	user_info_$attributes (att)
   .	user_info_$limits (mlim, clim, cdate, crf, shlim, msp, csp, shsp)
   .	user_info_$rs_name (rs_name)
   .	user_info_$rs_number (rs_number)
   .	user_info_$absentee_request_id (request_id)
   .	user_info_$absout_truncation (truncate_bit)
   .	user_info_$absentee_restarted (restarted_bit)
   .      user_info_$ring_range (range)

   If an entry which takes multiple arguments is called with too few arguments,
   only those supplied will be set.

   THVV 9/70   */


/****^  HISTORY COMMENTS:
  1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370),
     audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082):
     1st comment for hcom.
        Modified 761229 by D. M. Wells to add $service_type and $process_type entry
     points, to add line_type parameter to $tty_data, and to get info for
     $tty_data from PIT rather than the user_i/o IOSIM.
     Modified 6/20/77 by J. Stern to add $terminal_data (obsoletes $tty_data)
     Modified April 1979 by T. Casey to return correct information in foreground absentee jobs.
     Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
     Modified June 1981 by E. N. Kittlitz for UNCA rate structures.
     Modified December 1981 by E. N. Kittlitz for login_arg_ptr, login_arg_count.
     Modified 11/81 by B. Margulies for sub_err_ vs. com_err_.
     Modified 10/82 by E. N. Kittlitz for absentee_request_id.
     Modified 1984-07-26 BIM for user_info_$authorization_range
  2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370),
     audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082):
     Add the entries absout_truncation & absentee_restarted for -truncate absout, SCP6297.
  3) change(86-11-11,Gilcrease), approve(86-11-11,PBF7370),
     audit(86-11-12,Fawcett), install(86-11-12,MR12.0-1214):
     PBF: sub_err_ called with wrong arguments in fillpp procedure.
  4) change(87-11-20,Parisek), approve(88-02-11,MCR7849),
     audit(88-03-07,Lippard), install(88-07-13,MR12.2-1047):
     Added the ring_range entry which returns low & high ring authorizations.
     SCP6367.
                                                   END HISTORY COMMENTS */


	dcl     arg_infop		 pointer;
	dcl     arg_offset		 fixed bin;
	dcl     (pp, whoptr)	 pointer,
	        i			 fixed bin,
	        ii		 fixed bin,
	        hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35)),
                  current_validation     fixed bin (3),
   	        hcs_$level_set         entry (fixed bin (3)),
     	        hcs_$level_get         entry (fixed bin (3)),
     	        get_ring_		 entry() returns(fixed bin(3)),
	        get_pdir_		 entry returns (char (168)),
	        format_attributes_	 entry (ptr, char (*) var),
	        ec		 fixed bin (35),
	        sub_err_		 entry options (variable),
	        sysdir		 char (64) int static init (">system_control_dir") options (constant),
	        system_info_$device_prices
				 entry (fixed bin, ptr),
	        system_info_$rs_name	 entry (fixed bin, char (*), fixed bin (35)),
	        cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));

	dcl     error_table_$noarg	 fixed bin (35) ext static;

	dcl     1 dvt		 (16),
		2 device_id	 char (8),
		2 device_price	 (0:7) float bin;

	dcl     ndev		 fixed bin;

	dcl     ap		 ptr,
	        al		 fixed bin,
	        bbit		 bit (1) based (ap),
	        bchr		 char (al) based (ap) unaligned,
	        bfix		 fixed bin (35) based (ap),
	        bf17		 fixed bin based (ap),
	        bf21		 fixed bin (21) based (ap),
	        bf71		 fixed bin (71) based (ap),
	        bflt		 float bin based (ap),
	        bb36		 bit (36) based (ap),
	        bptr		 ptr based (ap),
	        tvcs		 char (512) var,
	        bftary		 (0:7) float bin based (ap);
	dcl     (addr, before, null,  max, ptr, substr)
				 builtin;


%include pit;
%include user_attributes;

%include whotab;

%page;

fillpp:
     proc;					/* internal proc to fill in PIT ptr on first call */

	declare whotab_$		 bit (36) aligned external static;
	declare linkage_error	 condition;

	on linkage_error				/* AS12.0 INSTALLATION KLUGE */
	     begin;				/* to be removed after hardcore is installed */

	          call hcs_$level_get (current_validation);
     	          call hcs_$level_set (get_ring_ ());
		call hcs_$initiate ((get_pdir_ ()), "pit", "pit_", 0, 1, pp, ec);
		call hcs_$level_set (current_validation);
		if pp = null
		then call sub_err_ (ec, "user_info_", "s", null (), (0), "pit");
	     end;					/* END OF KLUGE */

	pp = addr (pit_$);				/* we depend on this refname being in the environment */
	on linkage_error
	     begin;

	          call hcs_$level_get (current_validation);
     	          call hcs_$level_set (get_ring_ ());
		call hcs_$initiate (sysdir, "whotab", "whotab_", 0, 1, whoptr, ec);
		call hcs_$level_set (current_validation);
		if whoptr = null
		then call sub_err_ (ec, "user_info_", "s", null (), (0), "whotab");
	     end;

	whoptr = addr (whotab_$);

     end fillpp;

%page;

whoami:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.login_name;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.project;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.account;

	return;

login_data:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.login_name;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.project;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.account;
	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.anonymous;
	call cu_$arg_ptr (5, ap, al, ec);
	if ec ^= 0
	then return;
	i = pp -> pit.whox;				/* use current data from whotab */
	if i = 0
	then bfix = pp -> pit.standby;		/* oof. unlisted users */
	else bfix = whotab.e (i).stby;		/* user may have been promoted since login */
	call cu_$arg_ptr (6, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.user_weight;
	call cu_$arg_ptr (7, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.login_time;
	call cu_$arg_ptr (8, ap, al, ec);
	if ec ^= 0
	then return;
	if pp -> pit.anonymous = 1
	then bchr = "enter";
	else bchr = "login";

	return;

usage_data:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.n_processes;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.old_proc_cpu;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.login_time;
	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.proc_creation_time;
	call cu_$arg_ptr (5, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.old_proc_core;
	call cu_$arg_ptr (6, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.old_proc_io_ops;

	return;

homedir:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.homedir;

	return;

responder:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.login_responder;

	return;

tty_data:
     entry;

	call fillpp;

	if pp -> pit.process_type = 2
	then do;
		call cu_$arg_ptr (1, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = "abs";
		call cu_$arg_ptr (2, ap, al, ec);
		if ec ^= 0
		then return;
		bfix = pp -> pit.tty_type;
		call cu_$arg_ptr (3, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.tty;
		call cu_$arg_ptr (4, ap, al, ec);
		if ec ^= 0
		then return;
		bfix = pp -> pit.line_type;
	     end;

	else do;
		call cu_$arg_ptr (1, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.tty_answerback;
		call cu_$arg_ptr (2, ap, al, ec);
		if ec ^= 0
		then return;
		bfix = pp -> pit.tty_type;
		call cu_$arg_ptr (3, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.tty;
		call cu_$arg_ptr (4, ap, al, ec);
		if ec ^= 0
		then return;
		bfix = pp -> pit.line_type;
	     end;

	return;

terminal_data:
     entry;

	call fillpp;

	if pp -> pit.process_type = 2
	then do;
		call cu_$arg_ptr (1, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = "abs";
		call cu_$arg_ptr (2, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.term_type_name;
		call cu_$arg_ptr (3, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.tty;
		call cu_$arg_ptr (4, ap, al, ec);
		if ec ^= 0
		then return;
		bfix = pp -> pit.line_type;
		call cu_$arg_ptr (5, ap, al, ec);
		if ec ^= 0
		then return;
		if pp -> pit.charge_type = 0
		then bchr = "none";
		else do;
			call system_info_$device_prices (ndev, addr (dvt));
			bchr = dvt (pp -> pit.charge_type).device_id;
		     end;
	     end;

	else do;
		call cu_$arg_ptr (1, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.tty_answerback;
		call cu_$arg_ptr (2, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.term_type_name;
		call cu_$arg_ptr (3, ap, al, ec);
		if ec ^= 0
		then return;
		bchr = pp -> pit.tty;
		call cu_$arg_ptr (4, ap, al, ec);
		if ec ^= 0
		then return;
		bfix = pp -> pit.line_type;
		call cu_$arg_ptr (5, ap, al, ec);
		if ec ^= 0
		then return;
		if pp -> pit.charge_type = 0
		then bchr = "none";
		else do;
			call system_info_$device_prices (ndev, addr (dvt));
			bchr = dvt (pp -> pit.charge_type).device_id;
		     end;
	     end;

	return;

service_type:
     entry ();

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.service_type;

	return;

process_type:
     entry ();

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.process_type;

	return;

logout_data:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.logout_channel;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;
	bb36 = pp -> pit.logout_pid;

	return;


login_line:
     entry;
	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.login_line;

	return;

absentee_queue:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	if pp -> pit.process_type = 2
	then bfix = pp -> pit.abs_queue;
	else bfix = -1;

	return;

load_ctl_info:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.group;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;

	i = pp -> pit.whox;				/* use current data from whotab */
	if i = 0
	then do;					/* unlisted user? */
		bfix = pp -> pit.standby;
		call cu_$arg_ptr (3, ap, al, ec);
		if ec ^= 0
		then return;
		bf71 = pp -> pit.cant_bump_until;
	     end;
	else do;
		bfix = whotab.e (i).stby;
		call cu_$arg_ptr (3, ap, al, ec);
		if ec ^= 0
		then return;
		bf71 = whotab.e (i).cant_bump_until;
	     end;
	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.user_weight;
	return;

authorization_range:
	entry (a_auth_range);

dcl  a_auth_range (2) bit (72) aligned;

	call fillpp;
	a_auth_range = pp -> pit.authorization_range;
	return;

attributes:
     entry (atts);

	dcl     atts		 char (*) var;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	call format_attributes_ (addr (pp -> pit.at), tvcs);
	atts = tvcs;

	return;

absin:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;

	if pp -> pit.process_type ^= 2
	then bchr = "";
	else bchr = pp -> pit.input_seg;

	return;

absout:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;

	if pp -> pit.process_type ^= 2
	then bchr = "";
	else do;
		if pp -> pit.output_seg = ""
		then do;
			bchr = before (pp -> pit.input_seg, ".absin") || ".absout";
		     end;
		else bchr = pp -> pit.output_seg;
	     end;

	return;

outer_module:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bchr = pp -> pit.outer_module;

	return;

limits:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bflt = pp -> pit.dollar_limit;
	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;
	bflt = pp -> pit.absolute_limit;
	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0
	then return;
	bf71 = pp -> pit.absolute_cutoff;
	call cu_$arg_ptr (4, ap, al, ec);
	if ec ^= 0
	then return;
	bfix = pp -> pit.absolute_increm;
	call cu_$arg_ptr (5, ap, al, ec);
	if ec ^= 0
	then return;
	do i = 0 to 7;
	     bftary (i) = pp -> pit.shift_limit (i);
	end;
	call cu_$arg_ptr (6, ap, al, ec);
	if ec ^= 0
	then return;
	bflt = pp -> pit.dollar_charge;
	call cu_$arg_ptr (7, ap, al, ec);
	if ec ^= 0
	then return;
	bflt = pp -> pit.absolute_spent;
	call cu_$arg_ptr (8, ap, al, ec);
	if ec ^= 0
	then return;
	do i = 0 to 7;
	     bftary (i) = pp -> pit.interactive (i).charge;
	end;
	return;

rs_name:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	call system_info_$rs_name ((pp -> pit.rs_number), bchr, ec);
	if ec ^= 0
	then call sub_err_ (ec, "user_info_", "s", null (), (0), "Rate structure ^d invalid.
Contact your system administrator.", pp -> pit.rs_number);
	return;

rs_number:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	bf17 = pp -> pit.rs_number;
	return;

login_arg_count:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	if pp -> pit.arg_info_ptr = 0
	then /* no login arguments */
	     bf17 = 0;
	else bf17 = ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_count;

	call cu_$arg_ptr (2, ap, al, ec);
	if ec ^= 0
	then return;

	bf21 = 0;
	if pp -> pit.arg_info_ptr = 0
	then return;
	else do ii = 1 to ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_count;
		bf21 = max (ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_lengths (ii), bf21);
	     end;

	call cu_$arg_ptr (3, ap, al, ec);
	if ec ^= 0
	then return;

	if pp -> pit.arg_info_ptr = 0
	then bf21 = 0;
	else bf21 = ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.ln_args;
	return;


login_arg_ptr:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0
	then return;
	i = bf17;					/* get argument number */
	call cu_$arg_ptr (2, ap, al, ec);		/* argument pointer */
	if ec ^= 0
	then return;

	if pp -> pit.arg_info_ptr = 0
	then do;
		arg_infop = null;
		i = -1;
	     end;
	else arg_infop = ptr (pp, pp -> pit.arg_info_ptr);
	if i < 1
	then bptr = null;
	else if i > arg_infop -> arg_info.arg_count
	then do;
		bptr = null;
		i = -1;
	     end;
	else do;
		arg_offset = 1;
		do ii = 1 to i - 1;
		     arg_offset = arg_offset + arg_infop -> arg_info.arg_lengths (ii);
		end;
		bptr = addr (substr (arg_infop -> arg_info.args, arg_offset, 1));
						/* illegal pl1 */
	     end;
	call cu_$arg_ptr (3, ap, al, ec);		/* argument length */
	if ec ^= 0
	then return;
	if i < 0
	then bf21 = 0;
	else bf21 = arg_infop -> arg_info.arg_lengths (i);
	call cu_$arg_ptr (4, ap, al, ec);		/* return code */
	if ec ^= 0
	then return;
	if i < 0
	then bfix = error_table_$noarg;
	else bfix = 0;
	return;


absentee_request_id:
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec = 0
	then bf71 = pp -> pit.request_id;
	return;

absout_truncation:				/* truncate .absout bit */
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	if pp -> pit.process_type = 2 then bbit = pp -> pit.truncate_absout;
	else bbit = "0"b;
	return;

absentee_restarted:			/* restarted bit */
     entry;

	call fillpp;

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then return;
	if pp -> pit.process_type ^= 2 then bbit = "0"b;
	else bbit = pp -> pit.restarted;
	return;

ring_range:					/* get low and high allowed login ring level */
	entry (a_ring_range);
	
dcl  a_ring_range (2) fixed bin;
	
	call fillpp;
	a_ring_range (1) = pp -> pit.min_ring;		/* lowest allowed */
	a_ring_range (2) = pp -> pit.max_ring;		/* highest allowed */
	return;

     end user_info_;




		    where.pl1                       11/20/86  1406.1rew 11/20/86  1148.8      164025



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




/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-09-04,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to find object MSFs when searching manually and to properly
     display pathnames for MSF targets.
                                                   END HISTORY COMMENTS */


where: wh: procedure options (variable);

/* This command prints the primary pathname of the first segment or
   entry point with a given name found using the object segment search rules.

   Usage:
   where names -control_args-

   where control_args are:

   -all, -a	    list all segments or entry points in the search path.
   -inhibit_error, -ihe supress error message when segment not found and returns null string as AF.
   -entry_point, -ep    look for name$name when name does not contain a $.
   -segment, -sm, -file look for the file named name even if name contains a $.

   The default is to look for an entry point if name contains a $, file otherwise.

   Usage as an active function:

   [where name -control_arg-]

   where control_arg is either -entry_point (-ep) or -file (-segment, -sm).
*/
/* Written 3/5/76 by Steve Herbst */
/* Entry point feature added 12/3/76 by S. Herbst */
/* fixed to show orig not copy if uninitiated seg has copysw on 03/20/80 S. Herbst */
/* Modified: 06/06/80, W. Olin Sibert, to add where -brief */
/* Fixed to work on gates 07/15/81 S. Herbst */
/* Fixed bugs and made -brief -all work 10/06/82 S. Herbst */


%include access_mode_values;

%include branch_status;

%include object_info;
dcl 1 obj_info like object_info;

dcl  refnames (32) char (168);

dcl 1 search_rules aligned,				/* from hcs_$get_search_rules */
    2 rule_count fixed bin,
    2 rule (21) char (168);

dcl 1 search_dirs (21),				/* directories to search through */
    2 dir char (168),
    2 uid bit (36),
    2 rule_number fixed bin;

dcl  area area based (area_ptr);

dcl  arg char (arg_len) based (arg_ptr);
dcl  return_arg char (return_len) varying based (return_ptr); /* if called as active function */
dcl  primary_name char (32) aligned based;
dcl (dn, entry_point_name, name) char (168);
dcl (en, unique_name) char (32);
dcl  out_str char (256);
dcl  type fixed bin (2);

dcl (af_sw, all_sw, brief_sw, long_sw, all_entry_points, all_segments, entry_point, inhibit_error, printed_sw,
     search_manually, some_output, some_segs, terminate, try_initiated_segs, dir_found) bit (1) aligned;

dcl (area_ptr, arg_ptr, entry_point_ptr, names_ptr, return_ptr, seg_ptr) ptr;

dcl  fmode fixed bin (5);
dcl (arg_count, arg_len, dir_count, refname_count, return_len) fixed bin;
dcl (argno, dir_idx, idx, refname_idx, uid_idx) fixed bin;
dcl  bit_count fixed bin (24);
dcl  code fixed bin (35);

dcl (error_table_$badopt,
     error_table_$inconsistent,
     error_table_$dirseg,
     error_table_$no_dir,
     error_table_$no_s_permission,
     error_table_$noentry,
     error_table_$entlong,
     error_table_$not_act_fnc) fixed bin (35) external static;

dcl  complain entry variable options (variable);		/* com_err_ or active_fnc_err_ */
dcl  get_arg variable entry (fixed bin, ptr, fixed bin, fixed bin (35));

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl  get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  get_wdir_ entry returns (char (168));
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl  hcs_$get_search_rules entry (ptr);
dcl  hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl  hcs_$status_mins entry (ptr, fixed bin(2), fixed bin(24), fixed bin(35));
dcl  hcs_$terminate_name entry (char (*), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

dcl  WHOAMI char (32) internal static options (constant) init ("where");

dcl  cleanup condition;

dcl (addr, bit, char, hbound, index, length, null, ptr, rtrim, substr) builtin;

/*  */

	all_sw, all_entry_points, all_segments, brief_sw = "0"b;
	inhibit_error, long_sw, search_manually, some_output = "0"b;
	names_ptr = null ();
	area_ptr = get_system_free_area_ ();

	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     get_arg = cu_$arg_ptr;
	end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     get_arg = cu_$af_arg_ptr;
	     return_arg = "";
	end;

	if arg_count = 0 then do;
USAGE:	     if af_sw then call active_fnc_err_ (0, WHOAMI, "Usage:  [^a refname {-control_args}]", WHOAMI);
	     else call com_err_ (0, WHOAMI, "Usage:  ^a refnames {-control_args}", WHOAMI);
	     goto MAIN_RETURN;
	end;

	on condition (cleanup) call clean_up;

	refname_count = 0;

	do argno = 1 to arg_count;
	     call get_arg (argno, arg_ptr, arg_len, code);

	     if char (arg, 1) ^= "-" then do;		/* a refname we should locate */
		refname_count = refname_count+1;
		if refname_count > hbound (refnames, 1) then do;
		     call complain (0, WHOAMI, "Too many reference names specified. Max is ^d.",
			hbound (refnames, 1));
		     goto MAIN_RETURN;
		end;

		refnames (refname_count) = arg;
	     end;

	     else if (arg = "-all" | arg = "-a") then
		if af_sw then do;
AF_BAD_OPT:
		     call complain (0, WHOAMI, "Control arg not allowed for the active function.  ^a", arg);
		     return;
		end;
		else all_sw = "1"b;

	     else if (arg = "-long" | arg = "-lg") then
		if af_sw then go to AF_BAD_OPT;
		else do;
		     long_sw = "1"b;
		     brief_sw = "0"b;
		end;

	     else if (arg = "-brief" | arg = "-bf") then
		if af_sw then go to AF_BAD_OPT;
		else do;
		     brief_sw = "1"b;
		     long_sw = "0"b;
		end;

	     else if (arg = "-entry_point") | (arg = "-ep") then all_entry_points = "1"b;
	     else if (arg = "-file") | (arg = "-segment") | (arg = "-sm") then all_segments = "1"b;

	     else if (arg = "-inhibit_error") | (arg = "-ihe") then inhibit_error = "1"b;
	     else if (arg = "-no_inhibit_error") | (arg = "-nihe") then inhibit_error = "0"b;
	     else do;
		call complain (error_table_$badopt, WHOAMI, "^a", arg);
		goto MAIN_RETURN;
	     end;
	end;

	if refname_count = 0 | (af_sw & refname_count > 1) then
	     goto USAGE;

	if all_entry_points & all_segments then do;
	     call complain (error_table_$inconsistent, WHOAMI, "-segment and -entry_point");
	     goto MAIN_RETURN;
	end;

	if all_sw & ^brief_sw then long_sw = "1"b;

	if long_sw | all_sw then do;			/* must get search rules, to locate manually */

	     search_manually = "1"b;

	     call hcs_$get_search_rules (addr (search_rules));
	     dir_count = 0;
	     try_initiated_segs = "0"b;

	     do idx = 1 to rule_count;			/* find all the genuine directories */
		if rule (idx) = "initiated_segments" then try_initiated_segs = "1"b;
		else if rule (idx) ^= "referencing_dir" then do;
		     dir_count = dir_count + 1;
		     if rule (idx) = "working_dir" then dir (dir_count) = get_wdir_ ();
		     else dir (dir_count) = rule (idx);
		     rule_number (dir_count) = idx;
		     end;
	     end;
	end;

/*  */

	do refname_idx = 1 to refname_count;		/* Now, decide what to do with each of out reference name */

	     name = refnames (refname_idx);

	     idx = index (name, "$");
	     if (idx ^= 0) & ^all_segments then do;	/* name$entry */
		entry_point_name = substr (name, idx + 1);
		name = substr (name, 1, idx - 1);
		if entry_point_name = "" then entry_point = "0"b;
		else entry_point = "1"b;
	     end;

	     else if all_entry_points then do;		/* -entry_point specified */
		entry_point = "1"b;
		entry_point_name = name;
	     end;

	     else do;
		entry_point = "0"b; 		/* reference name */
		entry_point_name = "";
	     end;

	     if length (rtrim (name)) > 32 then do;
		call complain (error_table_$entlong, WHOAMI, "^a", name);
		goto NEXT;
	     end;

	     else if length (rtrim (entry_point_name)) > 32 then do;
		call complain (error_table_$entlong, WHOAMI, "^a", entry_point_name);
		goto NEXT;
	     end;

/*  */

	     if ^search_manually then do;		/* locate by the usual (linker) mechanism */

		terminate = "0"b;
		call hcs_$fs_get_seg_ptr (name, seg_ptr, code); /* already initiated? */
		if seg_ptr = null then do;
		     terminate = "1"b;
		     call hcs_$make_ptr (null (), name, "", seg_ptr, code);
		     if code ^= 0 then do;
			if ^inhibit_error then call complain (code, WHOAMI, "^a", name);
			goto NEXT;
		     end;
		end;

		call get_pathname (seg_ptr, dn, en, code);
		if code ^= 0 then do;
		     call complain (code, WHOAMI, "^a", name);
		     goto NEXT;
		end;

		if entry_point then do;

		     call find_entry_point;

		     if terminate then call hcs_$terminate_name (name, (0));
		     if code ^= 0 then do;
			call complain (code, WHOAMI, "^a$^a", pathname_ (dn, en), entry_point_name);
			goto NEXT;
		     end;
		end;

		else if terminate then call hcs_$terminate_name (name, code);

		call ioa_$rsnnl ("^a^[$^a^;^s^]", out_str, (0),
		     pathname_ (dn, en), entry_point, entry_point_name);

		if af_sw then do;			/* just assign it to the return arg, and punt */
		     return_arg = out_str;
		     goto MAIN_RETURN;
		end;

		else call ioa_ ("^a", out_str);
	     end;					/* of searching non-manually (via hcs_$make_ptr) */

/*  */

	     else do;				/* we must search for the segment manually */
						/* Note that this is never done for an AF. */
		if (idx > 1) & some_output & all_sw then	/* separate -all outputs by a blank line */
		     call ioa_ ("");

		some_output, some_segs = "0"b;

		if try_initiated_segs then do;	/* search rules contained "initiated_segments" */
		     dir_idx = 0;
		     call hcs_$fs_get_seg_ptr (name, seg_ptr, code);
		     if seg_ptr ^= null () then do;
			some_segs = "1"b;
			call get_pathname (seg_ptr, dn, en, code);
			if code ^= 0 then call complain (code, WHOAMI, "^a", name);

			else do;
			     if entry_point then call find_entry_point ();

			     if code ^= 0 then call complain (code, WHOAMI,
				"^a$^a  Search rule ""initiated_segments""",
				pathname_ (dn, en), entry_point_name);

			     else call print_pathname ();

			     if ^all_sw then go to NEXT;
			end;
		     end;				/* of successfully finding segment by refname */
		end;	 			/* of trying "initiated_segments" */

		do dir_idx = 1 to dir_count;		/* try to initiate in each of the dirs in the search rules */
		     dir_found = "0"b;
		     call hcs_$initiate (dir (dir_idx), name, "", 0, 1, seg_ptr, code);
INITIATED:	     if seg_ptr ^= null then do;
			some_segs = "1"b;
			call get_pathname (seg_ptr, dn, en, code);
			if code ^= 0 then do;
			     code = 0;
			     dn = dir (dir_idx);
			     en = substr (name, 1, 32);
			end;

			if entry_point then call find_entry_point ();
			if code ^= 0 then call complain (code, WHOAMI, "^a$^a (Search rule ""^a"")",
			     pathname_ (dn, en), entry_point_name, rule (rule_number (dir_idx)));

			else call print_pathname ();

			call hcs_$terminate_noname (seg_ptr, (0));
			if ^all_sw then go to NEXT;
		     end;				/* end of case for being able to initiate segment */

		     else if code = error_table_$dirseg & ^dir_found then do;
			call hcs_$status_minf (dir (dir_idx), name, 1, type, bit_count, code);
			if code = 0 & type = 2 & bit_count > 0 then do;
			     dn = pathname_ (dir (dir_idx), name);
			     en = "0";
			     dir_found = "1"b;
			     call hcs_$initiate (dn, en, "", 0, 0, seg_ptr, code);
			     goto INITIATED;
			end;
		     end;				/* end of MSF indirection */
		     
		     else if code ^= error_table_$noentry & code ^= error_table_$no_dir &
		       code ^= error_table_$dirseg then do;

			some_output, some_segs = "1"b;

			if entry_point then call complain (code, WHOAMI, "^a (Search rule ""^a"")",
			     pathname_ (dir (dir_idx), name), rule (rule_number (dir_idx)));

			else do;
			     if brief_sw & all_sw then do;
				call hcs_$status_long (dir (dir_idx), name, 1, addr (branch_status), null, code);
				uid (dir_idx) = branch_status.unique_id;
				printed_sw = "0"b;
				do uid_idx = 1 to dir_idx - 1;	  /* print each path only once */
				     if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
				end;
				if ^printed_sw then call ioa_ ("^a", pathname_ (dir (dir_idx), name));
			     end;
			     else do;
				call hcs_$status_ (dir (dir_idx), name, 1, addr (branch_status), area_ptr, code);
				if code = 0 then do;	/* print formatted line */
				     names_ptr = ptr (area_ptr, branch_status.names_rel_pointer);
				     if long_sw then call ioa_ ("^a (^a) Search rule ""^a""",
					pathname_ (dir (dir_idx), (names_ptr -> primary_name)),
					get_mode_letters (branch_status.mode), rule (rule_number (dir_idx)));
				     else call ioa_ ("^a", pathname_ (dir (dir_idx), name));

				     if ^all_sw then go to NEXT;
				end;

				else if code = error_table_$no_s_permission then
				     call complain (0, WHOAMI,
					"No status permission on ^a (Search rule ""^a"")",
					dir (dir_idx), rule (rule_number (dir_idx)));

				else if code ^= error_table_$noentry then
				     call complain (code, WHOAMI, "^a (Search rule ""^a"")",
					dir (dir_idx), rule (rule_number (dir_idx)));

				else some_output = "0"b;
			     end;
			end;
		     end;				/* of case for unable to initiate segment */
		end;	 			/* of loop through dirs in search rules */

		if ^some_output & ^inhibit_error then
		     if entry_point & some_segs then call complain (0, WHOAMI, "Entry point not found.  ^a$^a",
			name, entry_point_name);
		     else call complain (0, WHOAMI, "Segment not found. ^a", name);

	     end;					/* of case for searching manually */
NEXT:	end;	 				/* end of refname loop */

MAIN_RETURN:
	call clean_up;
	return;

/*  */


clean_up:	proc;

	if names_ptr ^= null then free names_ptr -> primary_name in (area);

end clean_up;


get_pathname: proc (seg_ptr, dn, en, code);

dcl  seg_ptr ptr parameter;
dcl  dn char (*) parameter;
dcl  en char (*) parameter;
dcl  code fixed bin (35) parameter;
dcl  cdn char (168);
dcl  cen char (32);
dcl  type fixed bin (2);
dcl  bc fixed bin (24);

/* This internal procedure gets the pathname of a segment found.  If	*/
/* the segment is an MSF component, it backs up 1 level.		*/
	
	call hcs_$fs_get_path_name (seg_ptr, dn, (0), en, code);
	if code ^= 0
	  then return;
	call hcs_$status_minf (dn, "", 1, type, bc, code);
	if type = 2 & bc > 0 & code = 0
	  then do;
	    call expand_pathname_ (dn, cdn, cen, code);
	    dn = cdn;
	    en = cen;
	  end;
	  
end get_pathname;


find_entry_point: proc;

/* This internal procedure looks for an external definition. */

	call hcs_$fs_get_mode (seg_ptr, fmode, code);
	if fmode < R_ACCESS_BIN then do;		/* inner ring seg: gate? */
						/* make sure make_ptr finds this one */
	     unique_name = unique_chars_ ("0"b);
	     call hcs_$initiate (dn, en, unique_name, 0, 1, seg_ptr, code);
	     call hcs_$make_ptr (null, unique_name, entry_point_name, entry_point_ptr, code);
	     call hcs_$terminate_name (unique_name, 0);
	end;
	else do;
	     call hcs_$status_mins (seg_ptr, (0), bit_count, code);
	     call object_info_$brief (seg_ptr, bit_count, addr (obj_info), code);
	     if code ^= 0 then return;
	     call get_definition_ (obj_info.defp, name, entry_point_name, null, code);
	end;

end find_entry_point;


print_pathname: proc;

	some_output = "1"b;
	call hcs_$fs_get_mode (seg_ptr, fmode, code);
	if code ^= 0 then fmode = 0;

	if long_sw then do;
	     call ioa_$nnl ("^a^[$^a^;^s^] (^a) Search rule ",
		pathname_ (dn, en), entry_point, entry_point_name, get_mode_letters (bit (fmode)));
	     if dir_idx = 0 then call ioa_ ("""initiated_segments""");
	     else call ioa_ ("""^a""", rule (rule_number (dir_idx)));
	end;
	else do;
	     call hcs_$status_long (dn, en, 1, addr (branch_status), null, code);
	     uid (dir_idx) = branch_status.unique_id;
	     printed_sw = "0"b;
	     do uid_idx = 1 to dir_idx-1;		/* only print each path once */
		if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
	     end;
	     if ^printed_sw then call ioa_ ("^a", pathname_ (dn, en));
	end;

end print_pathname;


get_mode_letters: proc (mode_bits) returns (char (4)varying);

dcl  mode_bits bit (5);
dcl  amode char (4) varying;

	amode = "";
	if substr (mode_bits, 2, 1) ^= "0"b then amode = "r";
	if substr (mode_bits, 3, 1) ^= "0"b then amode = amode||"e";
	if substr (mode_bits, 4, 1) ^= "0"b then amode = amode||"w";
	if amode = "" then amode = "null";
	return (amode);

end get_mode_letters;

end where;




		    who.pl1                         08/05/87  0814.9r   08/04/87  1539.1      148248



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


/* format: style4 */
who: procedure;

/* WHO - print information about who's on Multics.

   HMU, HOW_MANY_USERS - give header lines with nusers and load.

   This command types out the userid's of listed logged-in users
   from the segment "whotab", which is maintained by the answering service
   program "lg_ctl_". The possible arguments are as follows:

   .      -bf       suppress header  (not allowed for af)
   .	-lg	print "long who"  (not allowed for af)
   .	-nm	sort lines on user name
   .	-pj	sort lines on project id
   .		(the default sort is by time logged in)
   .	-as	print information on absentee users
   .	-ia	print information on interactive users
   .	-dmn	print information on daemon users
   .		(default is -as -ia if none of -as -ia -dmn given)
   .      -all      -as, -ia -dmn
   .	Name	list only users with person name "Name"
   .	.Proj	list only users with project name "Proj"
   .	Name.Proj	list only users with person name "Name" and project "Proj"

   Initial coding by THVV, 9/6/70 */
/* changed for absentee by EDS 7/71 */
/* various changes by RBR 7/72      */
/* error messages changed 09/15/78 S. Herbst */
/* Modified May 1979 by T. Casey and S. Herbst for MR7.0a to add -interactive and -daemon,
   and to list foreground absentee users correctly */
/* who active function added 01/12/81 S. Herbst */
/* 12/24/81 E. N. Kittlitz.  whotab changes */
/* 9/82 BIM -all, no daemons by default */
/* 11/82 E. N. Kittlitz. list daemons if name explicitly given, do selection for af call */
/* 06/84 J A Falksen. Utilize date_time_$format("date_time"|"^<date>!!^<time>"... */

dcl  return_arg char (return_len) varying based (return_ptr);
dcl  return_ptr ptr;
dcl  return_len fixed bin;
dcl  af_sw bit (1);


dcl  argno fixed bin init (1),			/* number of argument */
     arg_count fixed bin,
     ap ptr,					/* ptr to argument */
     al fixed bin,					/* lth of argument */
     ec fixed bin (35),				/* file-system error code */
     (f1, f2) float bin,				/* conversion temps */
     sort fixed bin init (0),				/* type of sort. 0=date, 1=name, 2=proj */
     hmucnt fixed bin init (0),			/* number of names|projects in */
     abscnt fixed bin init (0),			/* hmucnt as absentee users */
     long bit (1) aligned init ("0"b),			/* 1 if long who wanted */
     abs bit (1) aligned init ("0"b),			/* 1 if listing absentee users */
     only_abs bit (1) aligned init ("0"b),		/* if only listing absentees */
     daemon bit (1) aligned init ("0"b),		/* if listing daemon users */
     interactive bit (1) aligned init ("0"b),		/* if listing interactive users */
     brief bit (1) aligned init ("0"b),			/* 1 for no heading at all */
     hmuflg bit (1) aligned init ("0"b),		/* selective hmu flag */
     selx fixed bin init (0),				/* if particular users wanted */
     dotl fixed bin,				/* location of dot in arg */
     nm (50) char (24) aligned,			/* user names wanted */
     pj (50) char (12) aligned,			/* user projs wanted */
     caller char (14) varying,			/* name of caller to com_err */
     why char (128) aligned,				/* reason for shutdown */
     arg char (al) unaligned based (ap),		/* pickup for args */
     sort_arg char (32) init (""),
     whoptr ptr int static init (null),			/* ptr to whotab */
     ip ptr int static init (null),			/* ptr to installation_parms */
     sysdir char (64) aligned int static init (">system_control_1"), /* name of dir in which who table resides */
     date_l fixed bin,
     j fixed bin,					/* index */
     d fixed bin,					/* distance between sorted elems */
     last fixed bin,				/* highest index in whotab */
     swap fixed bin,				/* 1 if a swap was done */
     ajd fixed bin,					/* temp for sort, ary(j+d) */
     sss char (1) aligned init ("s"),			/* pretty for user-not-on */
     (time, time1) char (64)var init (""),		/* ASCII time */
     aj fixed bin,					/* temp, ary(j) */
     did fixed bin init (0),				/* count of lines printed */
     mark char (3) aligned,				/* denotation of absentee user if = "*" */
     k fixed bin;					/* index */

%include whotab;

%include installation_parms;

dcl  complain entry variable options (variable);

dcl  ioa_ ext entry options (variable),			/* library procedures */
     active_fnc_err_ entry options (variable),
     com_err_ ext entry options (variable),
     date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     hcs_$initiate ext entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     requote_string_ entry (char (*)) returns (char (*));

dcl  (after, before, divide, hbound, index, null, rtrim, substr) builtin;
dcl  (error_table_$badopt,
     error_table_$not_act_fnc,
     error_table_$too_many_args) ext fixed bin;

/* - - - - - - - - - - */

	caller = "who";				/* set name of caller to com_err_ */
	go to join;

how_many_users: hmu: entry;

	caller = "how_many_users";
	hmuflg = "1"b;

join:
	call cu_$af_return_arg (arg_count, return_ptr, return_len, ec);
	if ec = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	end;
	else if caller = "how_many_users" then do;
	     call active_fnc_err_ (0, caller, "Cannot be called as an active function.");
	     return;
	end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	end;

	do argno = 1 to arg_count;
	     call cu_$arg_ptr (argno, ap, al, ec);	/* get nth argument */

	     if arg = "-absentee" | arg = "-as" then abs = "1"b;
	     else if arg = "-daemon" | arg = "-dmn" then daemon = "1"b;
	     else if arg = "-interactive" | arg = "-ia" then interactive = "1"b;
	     else if arg = "-all" | arg= "-a" then interactive, daemon, abs = "1"b;
	     else if arg = "-name" | arg = "-nm" then sort = 1;
	     else if arg = "-project" | arg = "-pj" then sort = 2;

	     else if arg = "-brief" | arg = "-bf" then
		if af_sw then do;
BAD_AF_OPT:	     call active_fnc_err_ (0, caller, "Invalid active function control arg ^a", arg);
		     return;
		end;
		else brief = "1"b;
	     else if arg = "-long" | arg = "-lg" then
		if af_sw then go to BAD_AF_OPT;
		else long = "1"b;

	     else if substr (arg, 1, 1) = "-" then do;	/* then it must be a name or project */
bad_opt:		call complain (error_table_$badopt, caller, "^a", arg);
		return;
	     end;
	     else do;				/* save Name | .Project */
		selx = selx + 1;			/* up index in select array */
		if selx > hbound (nm, 1) then do;
		     call complain (error_table_$too_many_args, caller);
		     return;
		end;
		nm (selx), pj (selx) = "";		/* blank selectors */
		dotl = index (arg, ".");		/* where's the dot? */
		if dotl = 0 then nm (selx) = arg;	/* no dot. is user name. */
		else if dotl = 1 then pj (selx) = substr (arg, 2, al - 1);
		else do;				/* dot in middle, is name.proj */
		     nm (selx) = substr (arg, 1, dotl - 1); /* get name */
		     pj (selx) = substr (arg, dotl + 1, al - dotl);
		end;
	     end;
	     if sort ^= 0 & hmuflg then go to bad_opt;
	end;

	if ^interactive & ^abs & ^daemon then do;	/* if process type not specified */
	     interactive, abs = "1"b;			/* default is to list abs and ia */
	     if selx > 0 then daemon = "1"b;		/* but if name/proj given, list everything */
	end;
	only_abs = abs & ^interactive & ^daemon;	/* see if abs only */

go:	if whoptr = null then do;			/* is this the first call? */
	     call hcs_$initiate (sysdir, "whotab", "", 0, 1, whoptr, ec);
	     if whoptr = null then do;
		call complain (ec, caller, "^a>whotab", sysdir);
		return;
	     end;
	end;

	if ^brief & ^af_sw then do;			/* suppress header */
	     if hmuflg then go to head;		/* always a header for hmu, except after brief */
	     if selx = 0 then do;			/* no header with who select */
		if only_abs			/* what type absentee header if any */
		then if long
		     then go to print_long_abs_totals;
		     else go to print_abs_totals;
head:		f1 = whotab.n_units / 10.0e0;		/* format up units */
		f2 = whotab.mxunits / 10.0e0;		/* ... */
		j = whotab.n_users - whotab.abs_users - whotab.fg_abs_users - whotab.n_daemons; /* compute interactive users */

		if long then do;			/* long who? */
		     if ip = null then do;
			call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, ec);
			if ip = null then do;
			     call complain (ec, caller, "Insufficient access for -long option");
			     return;
			end;
		     end;
		     time = date_time_$format ("date_time", whotab.timeup, "", ""); /* yup. make heading */
		     call ioa_ ("^/Multics ^a; ^a", whotab.sysid, installation_parms.installation_id);
		     call ioa_ ("Load = ^.1f out of ^.1f units; users = ^d, ^d interactive, ^d daemons.",
			f1, f2, whotab.n_users, j, whotab.n_daemons);
		     if (whotab.abs_users + whotab.max_abs_users) ^= 0
		     then				/* ! */
print_long_abs_totals:	call ioa_ ("^[^/^]Absentee users = ^d background^[, ^d foreground^;^s^]; Max background absentee users = ^d^[^/^]",
			     only_abs, whotab.abs_users, (whotab.fg_abs_users > 0), whotab.fg_abs_users, whotab.max_abs_users, only_abs);
		     if only_abs then go to check_hmu;
		     call ioa_ ("System up since ^a", time);
		     if whotab.nextsd ^= 0 then do;
			why = whotab.why;
			if why < "" then why = "";
			time = date_time_$format ("date_time", whotab.nextsd, "", "");
			if whotab.until = 0 then call ioa_ ("Scheduled shutdown at ^a ^a", time, why);
			else do;
			     time1 = date_time_$format ("date_time", whotab.until, "", "");
			     call ioa_ ("Scheduled shutdown from ^a to ^a ^a", time, time1, why);
			end;
		     end;
		     time = date_time_$format ("date_time", whotab.lastsd, "", "");
		     if whotab.erfno = "crash" then call ioa_ ("Last crash was at ^a^/", time);
		     else if whotab.lastsd = 0 then call ioa_ ("");
		     else if whotab.erfno = "" then call ioa_ ("Last shutdown was at ^a^/", time);
		     else call ioa_ ("Last crash (ERF ^a) was at ^a^/", whotab.erfno, time);
		     if hmuflg then if selx = 0 then return;
			else go to shell_sort;
		     call ioa_ ("^4xLogin at^6xTTY  Load^3xUser ID^/");
		end;
		else do;				/* short who. */
		     call ioa_ ("^/Multics ^a, load ^.1f/^.1f; ^d users, ^d interactive, ^d daemons.",
			whotab.sysid, f1, f2, whotab.n_users, j, whotab.n_daemons);
		     if (whotab.max_abs_users + whotab.abs_users) ^= 0
		     then				/* print absentee totals under certain conditions */
print_abs_totals:		call ioa_
			     ("^[^/^]Absentee users ^d/^d^[^x(+^d FG)^;^s^]^[^/^]",
			     only_abs, whotab.abs_users, whotab.max_abs_users, (whotab.fg_abs_users > 0), whotab.fg_abs_users, only_abs);
		     if ^abs then call ioa_ ("");
		end;
	     end;
	end;
check_hmu:
	if hmuflg & selx = 0			/* if a simple hmu entry then finished */
	then return;

shell_sort: last = whotab.laste;			/* save high limit on whotab */
	if hmuflg then go to count;			/* go to selective hmu counting */

	begin;

dcl  sort_array (last) fixed bin;

	     do j = 1 to last;			/* set up sort array */
		sort_array (j) = j;			/* ... */
	     end;

	     d = last;				/* set up for Shell sort */
pass:	     d = divide (d + 1, 2, 17, 0);		/* ... */
	     swap = 0;				/* ... */
	     do j = 1 to last - d;			/* comparison loop */
		aj = sort_array (j);		/* make temps */
		ajd = sort_array (j + d);		/* ... */
		if sort = 0 then if whotab.timeon (aj) > whotab.timeon (ajd) then go to ic;
		if sort = 1 then if whotab.person (aj) > whotab.person (ajd) then go to ic;
		if sort = 2 then if whotab.project (aj) > whotab.project (ajd) then go to ic;
		     else if whotab.project (aj) = whotab.project (ajd) then if whotab.person (aj)
			     > whotab.person (ajd) then do; /* Are items in order? */
ic:			     sort_array (j) = ajd;	/* No. Swap entries */
			     sort_array (j + d) = aj; /* ... */
			     swap = swap + 1;	/* remember a swap */
			end;
	     end;
	     if swap > 0 then go to pass;		/* if out of order do it again */
	     if d > 1 then go to pass;		/* ... */



	     time1 = "%%%%";			/* make sure it won't match (time) later on. */
	     if af_sw then return_arg = "";

	     do j = 1 to last;			/* now the print loop */
		aj = sort_array (j);		/* set up speed temp */
		if whotab.active (aj) = 0 then go to skip; /* skip deads */
		if selx = 0 then go to print;		/* any users selected? */
		do k = 1 to selx;			/* check for selected users */
		     if nm (k) = whotab.person (aj) then if pj (k) = "" then go to print;
			else if pj (k) = whotab.project (aj) then go to print;
		     if nm (k) = "" then if pj (k) = whotab.project (aj) then go to print;
		end;
		go to skip;			/* user not in selected group */

print:
		if whotab.proc_type (aj) = 1 & ^interactive
		     | whotab.proc_type (aj) = 2 & ^abs
		     | whotab.proc_type (aj) = 3 & ^daemon
		then goto skip;

		if af_sw then do;
		     if return_arg ^= "" then return_arg = return_arg || " ";
		     return_arg = return_arg ||
			requote_string_ (rtrim (whotab.person (aj)) || "." || rtrim (whotab.project (aj)));
		     go to skip;
		end;

		if whotab.proc_type (aj) ^= 2 then	/* if not absentee */
		     mark = "";			/* clear absentee flag */
		else if whotab.fg_abs (aj) then	/* if foreground absentee */
		     mark = "*FG";			/* flag it as such */
		else mark = "*";			/* else flag it as background absentee */

		did = did + 1;			/* remember we did one */
		if long then do;			/* long who? */
		     time = date_time_$format ("^<date>!! ^<time>", whotab.timeon (aj), "", "");
/****		     Suppress date if it's the same as last printed date */
		     date_l = index (time, "!!")-1;
		     if substr (time, 1, date_l) = substr (time1, 1, date_l)
		     then substr (time, 1, date_l) = " ";
		     else time1 = time;
		     f1 = whotab.units (aj) / 10.0e0;	/* get nice units */
		     call ioa_ ("^va ^a  ^4a ^4.1f^3x^a.^a^a^x^[D^]^[S^]",
			date_l, before (time, "!!"), after (time, "!!"),
		          whotab.idcode (aj), f1, whotab.person (aj), whotab.project (aj),
			mark, whotab.disconnected (aj), whotab.suspended (aj));
		end;
		else do;				/* short who. */
		     call ioa_ ("^a.^a^a^x^[D^]^[S^]", whotab.person (aj), whotab.project (aj), mark,
			whotab.disconnected (aj), whotab.suspended (aj));
		end;

skip:	     end;

	end;

	if ^af_sw then do;
	     if ^brief then

		if did = 0 then do;			/* if printed nobody */
		     if selx = 1 then if nm (1) ^= "" then sss = "";
		     call ioa_ ("User^a not logged in.", sss);
		end;

	     call ioa_ ("");			/* extra CR */
	end;

	return;					/* done. */

/* - - - - - - - - */


count:	do j = 1 to selx;				/* selective hmu counting */
	     hmucnt = 0;				/* reset counters */
	     abscnt = 0;

	     if nm (j) = "" then do;			/* selected project counting */
		do aj = 1 to last;
		     if pj (j) = whotab.project (aj) then
			if whotab.proc_type (aj) ^= 2
			then hmucnt = hmucnt + 1;
			else abscnt = abscnt + 1;
		end;
		call ioa_ (".^a = ^d + ^d*", pj (j), hmucnt, abscnt);
	     end;

	     if nm (j) ^= "" then
		if pj (j) ^= ""			/* selected name.project counting */
		then do;
		     do aj = 1 to last;
			if nm (j) = whotab.person (aj)
			then if pj (j) = whotab.project (aj)
			     then if whotab.proc_type (aj) ^= 2
				then hmucnt = hmucnt + 1;
				else abscnt = abscnt + 1;
		     end;
		     call ioa_ ("^a.^a = ^d + ^d*", nm (j), pj (j), hmucnt, abscnt);
		end;
		else do;				/* selected name counting */
		     do aj = 1 to last;

			if nm (j) = whotab.person (aj) then
			     if whotab.proc_type (aj) ^= 2
			     then hmucnt = hmucnt + 1;
			     else abscnt = abscnt + 1;
		     end;
		     call ioa_ ("^a = ^d + ^d*", nm (j), hmucnt, abscnt);
		end;
	end;
	return;

who_init: entry (system_directory);			/* entry used for testing who command */

dcl  system_directory char (*);

	sysdir = system_directory;			/* copy name of directory containing who table */

	whoptr = null;				/* set pointer to null */

	return;

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