



		    display_subsystem_usage.pl1     02/26/86  1011.8rew 02/26/86  1007.6      159633



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

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

/* Display the usage statistics recorded by ssu_ for a given subsystem */


/****^  HISTORY COMMENTS:
  1) change(81-09-01,Palter), approve(), audit(),
     install(86-02-26,MR12.0-1026):
     Initial coding: primitive version without selection cabalities on user names
  2) change(81-11-02,Sibert), approve(), audit(),
     install(86-02-26,MR12.0-1026):
     to change suffix to ".ssusage".
  3) change(82-01-21,Palter), approve(), audit(),
     install(86-02-26,MR12.0-1026):
     to use a reference name to find the usage segment in most cases, accept
     -first N and -user star_name, and remove the short command name (sigh).
  4) change(82-12-15,Pattin), approve(), audit(),
     install(86-02-26,MR12.0-1026):
     to add -version, version sort type, and improve totals processing.
  5) change(82-12-16,Palter), approve(), audit(),
     install(86-02-26,MR12.0-1026):
     to allow -totals to be used with -user and -version and to allow
     -first N to be used with -user.
  6) change(83-10-18,Palter), approve(), audit(),
     install(86-02-26,MR12.0-1026):
     to allow matching by starname for the version.
  7) change(86-02-12,Newcomb), approve(86-02-12,MCR7335),
     audit(86-02-13,Margolin), install(86-02-26,MR12.0-1026):
     Upgraded to use (initiate terminate)_file_ and date_time_$format.
                                                   END HISTORY COMMENTS */

%page;
display_subsystem_usage:
     procedure () options (variable);


dcl  argument character (argument_lth) based (argument_ptr);
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  1 field_ptrs aligned based (field_ptrs_ptr),
       2 n_ptrs fixed binary,
       2 ptr (usage_seg.count refer (field_ptrs.n_ptrs)) pointer unaligned;
dcl  field_ptrs_ptr pointer;

dcl  1 idxs aligned based (idxs_ptr),
       2 n_idxs fixed binary,
       2 idx (usage_seg.count refer (idxs.n_idxs)) fixed binary;
dcl  idxs_ptr pointer;

dcl  n_arguments fixed binary;

dcl  (have_usage_seg, found_by_refname, header, totals_only, sort_by_name, sort_by_count, sort_by_dtu, sort_by_version,
     reverse_sw) bit (1) aligned;

dcl  usage_seg_dirname character (168);
dcl  (subsystem_name, usage_seg_ename) character (32);

dcl  user_name character (32);
dcl  version_wanted character (32);
dcl  first_n fixed binary;
dcl  (selected_users, selected_count, selected_version_count) fixed binary;

dcl  code fixed binary (35);
dcl  idx fixed binary;

dcl  DISPLAY_SUBSYSTEM_USAGE character (32) static options (constant) initial ("display_subsystem_usage");

dcl  USAGE_SUFFIX character (7) static options (constant) initial ("ssusage");

dcl  HEADER_FORMAT character (76) static options (constant)
	initial ("^/^33tTotal^52tLast Version Used^/^11tUser^33tUsage^47tUsage^59tDate^70tID^/");
dcl  USER_FORMAT character (34) static options (constant) initial ("^24a^29t^9d^43t^9d^53t(^14a)^70t^a");
dcl  TOTALS_FORMAT character (68) static options (constant)
	initial ("^6tTotal (^d users):^29t^9d^[^43t^9d^;^s^]^[^vt^a^;^2s^]^[^70t^a^]^/");

/* format: off */
dcl (error_table_$badopt, error_table_$inconsistent, error_table_$noarg)
	fixed binary (35) external;
/* format: on */

dcl  check_star_name_$entry entry (character (*), fixed binary (35));
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  decode_clock_value_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
dcl  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl  hcs_$make_ptr entry (pointer, character (*), character (*), pointer, fixed binary (35));
dcl  initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
dcl  ioa_ entry () options (variable);
dcl  match_star_name_ entry (character (*), character (*), fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  sort_items_indirect_$bit entry (pointer, pointer, fixed binary (24));
dcl  sort_items_indirect_$char entry (pointer, pointer, fixed binary (24));
dcl  sort_items_indirect_$fixed_bin entry (pointer, pointer);
dcl  terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));

dcl  (addr, fixed, index, length, max, null, rtrim, search, substr, unspec) builtin;

dcl  cleanup condition;
%page;
/* display_subsystem_usage: entry () options (variable); */

	call cu_$arg_count (n_arguments, code);
	if code ^= 0 then do;			/* not called as a command */
	     call com_err_ (code, DISPLAY_SUBSYSTEM_USAGE);
	     return;
	end;

	if n_arguments = 0 then do;
PRINT_USAGE_MESSAGE:
	     call com_err_$suppress_name (0, DISPLAY_SUBSYSTEM_USAGE,
		"Usage:  display_subsystem_usage subsystem_name {-control_args}");
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	usage_seg_ptr,				/* for cleanup handler */
	     field_ptrs_ptr, idxs_ptr = null ();

	on condition (cleanup) call clean_up ();


/* Scan the arguments */

	have_usage_seg = "0"b;			/* no pathname yet */

	header = "1"b;				/* print header by default */
	totals_only = "0"b;				/* ... and dump all the users */
	sort_by_name, sort_by_count,			/* ... no sorting by default */
	     sort_by_dtu, sort_by_version = "0"b;
	reverse_sw = "0"b;				/* ... in the default order */
	version_wanted, user_name = "";		/* ... don't select any particular entries */
	first_n = -1;				/* ... and print all the entries */


	do idx = 1 to n_arguments;

	     call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));

	     if index (argument, "-") = 1 then
		if (argument = "-totals") | (argument = "-tt") then totals_only = "1"b;

		else if (argument = "-header") | (argument = "-he") then header = "1"b;

		else if (argument = "-no_header") | (argument = "-nhe") then header = "0"b;

		else if (argument = "-reverse") | (argument = "-rv") then reverse_sw = "1"b;

		else if (argument = "-no_reverse") | (argument = "-nrv") then reverse_sw = "0"b;

		else if argument = "-sort" then do;	/* sorting control: by name, count, version, date_time_used */
		     idx = idx + 1;			/* needs the sorting type */
		     if idx > n_arguments then do;
			call com_err_ (error_table_$noarg, DISPLAY_SUBSYSTEM_USAGE,
			     """-sort"" must be followed by ""name"", ""count"", ""date_time_used"", or ""version""")
			     ;
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));
		     if argument = "name" then sort_by_name = "1"b;
		     else if argument = "count" then sort_by_count = "1"b;
		     else if (argument = "date_time_used") | (argument = "dtu") then sort_by_dtu = "1"b;
		     else if argument = "version" then sort_by_version = "1"b;
		     else do;			/* unknown sort */
			call com_err_ (0, DISPLAY_SUBSYSTEM_USAGE,
			     """-sort"" must be followed by ""name"", ""count"", ""date_time_used"", or ""version""; not ""^a""",
			     argument);
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		end;

		else if argument = "-user" then do;	/* select entries by user name */
		     idx = idx + 1;
		     if idx > n_arguments then do;
			call com_err_ (error_table_$noarg, DISPLAY_SUBSYSTEM_USAGE,
			     """-user"" must be followed by a star name.");
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));
		     call check_star_name_$entry (argument, code);
		     if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
			call com_err_ (code, DISPLAY_SUBSYSTEM_USAGE, "-user ^a", argument);
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     user_name = argument;
		end;

		else if argument = "-version" then do;	/* print only those whose current version is selected */
		     idx = idx + 1;
		     if idx > n_arguments then do;
			call com_err_ (error_table_$noarg, DISPLAY_SUBSYSTEM_USAGE,
			     """-version"" must be followed by a version string.");
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));
		     call check_star_name_$entry (argument, code);
		     if (code ^= 0) & (code ^= 1) & (code ^= 2) then do;
			call com_err_ (code, DISPLAY_SUBSYSTEM_USAGE, "-version ^a", argument);
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     version_wanted = argument;
		end;

		else if (argument = "-first") | (argument = "-ft") then do;
						/* print only a subset of the entries */
		     idx = idx + 1;
		     if idx > n_arguments then do;
			call com_err_ (error_table_$noarg, DISPLAY_SUBSYSTEM_USAGE,
			     """-first"" must be followed by a number.");
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     call cu_$arg_ptr (idx, argument_ptr, argument_lth, (0));
		     first_n = cv_dec_check_ (argument, code);
		     if code ^= 0 then do;
BAD_FIRST_N_VALUE:
			call com_err_ (0, DISPLAY_SUBSYSTEM_USAGE,
			     """-first"" must be followed by a positive number; not ""^a"".", argument);
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     if first_n < 0 then go to BAD_FIRST_N_VALUE;
		end;

		else do;				/* invalid control argument */
		     call com_err_ (error_table_$badopt, DISPLAY_SUBSYSTEM_USAGE, """^a""", argument);
		     go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		end;

	     else					/* not a control argument: must identify the subsystem */
		if have_usage_seg then		/* ... but already have the segment */
		go to PRINT_USAGE_MESSAGE;

	     else do;				/* first subsystem name */
		have_usage_seg = "1"b;
		call expand_pathname_$add_suffix (argument, USAGE_SUFFIX, usage_seg_dirname, usage_seg_ename, code);
		if code ^= 0 then do;
		     call com_err_ (code, DISPLAY_SUBSYSTEM_USAGE, "^a", argument);
		     go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		end;
		subsystem_name =
		     substr (usage_seg_ename, 1, (length (rtrim (usage_seg_ename)) - length (USAGE_SUFFIX) - 1));
		if search (argument, "<>") ^= 0 then do;
		     found_by_refname = "0"b;		/* by pathname */
		     call initiate_file_ (usage_seg_dirname, usage_seg_ename, RW_ACCESS, usage_seg_ptr, (0) /* ignore bit count */, code);
		     if usage_seg_ptr = null () then do;
			call com_err_ (code, DISPLAY_SUBSYSTEM_USAGE, "^a",
			     pathname_ (usage_seg_dirname, usage_seg_ename));
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		end;
		else do;				/* a reference name */
		     found_by_refname = "1"b;
		     call hcs_$make_ptr (null (), usage_seg_ename, "", usage_seg_ptr, code);
		     if code ^= 0 then do;
			call com_err_ (code, DISPLAY_SUBSYSTEM_USAGE, "^a", usage_seg_ename);
			go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
		     end;
		     call hcs_$fs_get_path_name (usage_seg_ptr, usage_seg_dirname, (0), ((32)" "), (0));
		end;
	     end;
	end;

	if ^have_usage_seg then go to PRINT_USAGE_MESSAGE;

	if (fixed (sort_by_name, 1) + fixed (sort_by_dtu, 1) + fixed (sort_by_count, 1) + fixed (sort_by_version, 1))
	     > 1 then do;				/* just one type of sort, please */
	     call com_err_ (error_table_$inconsistent, DISPLAY_SUBSYSTEM_USAGE,
		"^[""-sort name"" and ^]^[""-sort count""^]^[ and ^]^[""-sort date_time_used""^]^[ and ^]^[""-sort version""^]",
		sort_by_name, sort_by_count, (sort_by_count & (sort_by_dtu | sort_by_version)), sort_by_dtu,
		(sort_by_dtu & sort_by_version), sort_by_version);
	     go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
	end;

	if totals_only & (sort_by_name | sort_by_count | sort_by_dtu | sort_by_version) then do;
						/* can't sort the totals */
	     call com_err_ (error_table_$inconsistent, DISPLAY_SUBSYSTEM_USAGE,
		"""-totals"" and ""-sort ^[name^]^[count^]^[date_time_used^]^[version^]""", sort_by_name,
		sort_by_count, sort_by_dtu, sort_by_version);
	     go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
	end;

	if totals_only & (first_n > 0) then do;		/* can't split the totals */
	     call com_err_ (error_table_$inconsistent, DISPLAY_SUBSYSTEM_USAGE, """-totals"" and ""-first ^d""",
		first_n);
	     go to RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE;
	end;

	if sort_by_count | sort_by_dtu then		/* invert the reverse flag to get largest counts ... */
	     reverse_sw = ^reverse_sw;		/* ... or most recent usage first by default */


/* Setup the array of indices into the segment used to control the order of individual entries printed and sort the array
   if requested */

	if ^totals_only then do;			/* don't bother if just giving total usage */

	     allocate field_ptrs in (system_area) set (field_ptrs_ptr);
	     allocate idxs in (system_area) set (idxs_ptr);

	     do idx = 1 to usage_seg.count;
		idxs.idx (idx) = idx;
		if sort_by_name then		/* sorting by name */
		     field_ptrs.ptr (idx) = addr (usage_seg.user (idx).name);
		else if sort_by_count then		/* sorting by count */
		     field_ptrs.ptr (idx) = addr (usage_seg.user (idx).total_count);
		else if sort_by_dtu then		/* sorting by last date-time used */
		     field_ptrs.ptr (idx) = addr (usage_seg.user (idx).last_time);
		else if sort_by_version then field_ptrs.ptr (idx) = addr (usage_seg.user (idx).version);
	     end;

	     if sort_by_name then
		call sort_items_indirect_$char (field_ptrs_ptr, idxs_ptr, length (usage_seg.user (1).name));
	     else if sort_by_count then call sort_items_indirect_$fixed_bin (field_ptrs_ptr, idxs_ptr);
	     else if sort_by_dtu then			/* (sigh): assumes no date/time used is negative ... */
		call sort_items_indirect_$bit (field_ptrs_ptr, idxs_ptr,
		     length (unspec (usage_seg.user (1).last_time)));
	     else if sort_by_version then
		call sort_items_indirect_$char (field_ptrs_ptr, idxs_ptr, length (usage_seg.user (1).version));
	end;


/* Print the header if desired */

	if header then do;
	     call ioa_ ("^/^-^a Usage (in directory ^a)^/", subsystem_name, usage_seg_dirname);
	     call ioa_ (HEADER_FORMAT);
	end;

	selected_users, selected_count, selected_version_count = 0;


/* Print the individual entries */

	if first_n = -1 then first_n = usage_seg.count;	/* user wants all the entries */

	if totals_only & ((user_name ^= "") | (version_wanted ^= "")) then do;
	     do idx = 1 to usage_seg.count;		/* count only the selected entries */
		call print_entry ("0"b, idx);
	     end;
	end;

	else if ^totals_only then			/* print the requested entries ... */
	     if reverse_sw then do;			/* ... in reverse order */
		do idx = usage_seg.count to 1 by -1;
		     call print_entry ((selected_users < first_n), idxs.idx (idx));
		end;
	     end;

	     else do;				/* ... in "normal" order */
		do idx = 1 to usage_seg.count;
		     call print_entry ((selected_users < first_n), idxs.idx (idx));
		end;
	     end;


/* Print the total usage */

	if ^totals_only then			/* a bit more whitespace please */
	     call ioa_ ("");


	if (user_name = "") & (version_wanted = "") then do;
	     selected_users = usage_seg.count;		/* no selection criteria: give totals for all users */
	     selected_count = usage_seg.all.total_count;
	end;

	call ioa_ (TOTALS_FORMAT, selected_users, selected_count, (version_wanted ^= ""), selected_version_count,
	     ^header, max (53, (70 - length (rtrim (subsystem_name)) - 1)), subsystem_name, (version_wanted ^= ""),
	     version_wanted);


RETURN_FROM_DISPLAY_SUBSYSTEM_USAGE:
	call clean_up ();

	return;
%page;
/* Print the usage data for a single user */

print_entry:
     procedure (print_switch, p_idx);

dcl  p_idx fixed binary parameter;
dcl  print_switch bit (1) aligned parameter;

dcl  1 use aligned based (usep) like usage_seg_entry;
dcl  usep pointer;
dcl  code fixed binary (35);

	usep = addr (usage_seg.user (p_idx));

	if version_wanted = "" then
	     code = 0;				/* match any version */
	else call match_star_name_ ((use.version), version_wanted, code);
	if code ^= 0 then return;

	if user_name = "" then
	     code = 0;				/* match any entry */
	else call match_star_name_ ((use.name), user_name, code);
	if code ^= 0 then return;

	selected_users = selected_users + 1;
	selected_count = selected_count + use.total_count;
	selected_version_count = selected_version_count + use.this_version_count;

	if print_switch then
	     call ioa_ (USER_FORMAT, use.name, use.total_count, use.this_version_count, decode_clock_value_$format ("^my/^dm/^yc ^Hd:^MH", use.last_time, "" /* per-process zone */, "" /* per-process language */),
		use.version);

	return;

     end print_entry;
%page;
/* Clean up after ourselves */

clean_up:
     procedure ();

	if usage_seg_ptr ^= null () then		/* only if we explicitly initiated it... */
	     if ^found_by_refname then call terminate_file_ (usage_seg_ptr, 0 /* not set */, TERM_FILE_TERM, (0));

	if field_ptrs_ptr ^= null () then free field_ptrs in (system_area);

	if idxs_ptr ^= null () then free idxs in (system_area);

	return;

     end clean_up;
%page;
%include "_ssu_usage_seg";
%page;
%include access_mode_values;
%page;
%include terminate_file;

     end display_subsystem_usage;




		    ssu_.alm                        01/16/85  1251.4r w 01/16/85  1251.3       55332



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


" SSU_ --- Transfer vector for accessing all of the subsystem utility functions

" Created:  3 May 1980 by W. Olin Sibert
" Modified: 24 July 1981 by Jay Pattin to add entries for ssu_ec_
" Modified: 17 November 1981 by Jay Pattin to add get/set_info_prefix
" Modified: 10 December 1981 by G. Palter to make arg_count, arg_ptr, return_arg, and
"    arg_list_ptr replaceable 
" Modified: February 1982 by G. Palter to add ssu_$standalone_invocation, rename the
"    exec_com entries, and reflect the movement of some entries to eliminate ssu_table_mgr_
" Modified: June 1982 by G. Palter to add (get set reset)_request_processor_options and
"    get_default_rp_options (all replaceable), add reset_procedure, make execute_line and
"    evaluate_active_string not go through the SCI but instead call setup procedures which
"    then transfer through the SCI, and rename ssu_execute_line_ to ssu_request_processor_
" Modified: 9 July 1982 by Jay Pattin to add execute_start_up
" Modified: 30 August 1982 by G. Palter to delete ssu_$set_default_procedure which was
"    replaced by ssu_$reset_procedure
" Modified: 6 November 1984 by G. Palter to make ssu_$get_subsystem_and_request_name a
"    replaceable procedure


	name	ssu_


" Macro to generate a call to an external entrypoint in the utilities

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end


" Macro to generate a call to a replaceable procedure

	macro	sci_transfer
	segdef	&1
&1:	epp1	ap|2,*		" PR1 <- addr (sci_ptr)
	epp1	pr1|0,*		" PR1 <- addr (sci)
	ife	&2,()
	tra	pr1|sci.&1,*
	ifend
	ine	&2,()
	tra	pr1|sci.&2,*
	ifend

	&end


" An entry which does nothing: used as default value of several replaceable procedures

	segdef	just_return

just_return:
	short_return


" Null label and entry variables (PL/I doesn't provide them in the language)

	segdef	null_label
	segdef	null_entry

	even
null_label:
null_entry:
	its	-1,1
	its	-1,1

" 

	sci_transfer	abort_line
	sci_transfer	abort_subsystem
	ext_transfer	add_info_dir,ssu_info_mgr_$add_info_dir
	ext_transfer	add_request_table,ssu_request_mgr_$add_request_table
	ext_transfer	apply_request_util,ssu_misc_requests_$apply_request_util
	sci_transfer	arg_count
	sci_transfer	arg_list_ptr
	sci_transfer	arg_ptr
	ext_transfer	cpescape,ssu_misc_procs_$cpescape
	ext_transfer	cpescape_disabled,ssu_misc_procs_$cpescape_disabled
	ext_transfer	create_invocation,ssu_invocation_$create
	ext_transfer	delete_info_dir,ssu_info_mgr_$delete_info_dir
	ext_transfer	delete_request_table,ssu_request_mgr_$delete_request_table
	ext_transfer	destroy_invocation,ssu_invocation_$destroy
	ext_transfer	evaluate_active_string,ssu_request_processor_$prepare_to_evaluate_string
	ext_transfer	execute_line,ssu_request_processor_$prepare_to_execute_line
	ext_transfer	execute_start_up,ssu_ec_$execute_start_up
	ext_transfer	execute_string,ssu_request_processor_$execute_string
	ext_transfer	get_abbrev_info,ssu_request_processor_$get_abbrev_info
	ext_transfer	get_area,ssu_temp_mgr_$get_area
	ext_transfer	get_debug_mode,ssu_misc_procs_$get_debug_mode
	ext_transfer	get_default_procedure,ssu_procedure_mgr_$get_default
	sci_transfer	get_default_rp_options
	ext_transfer	get_ec_search_list,ssu_ec_$get_ec_search_list
	ext_transfer	get_ec_subsystem_ptr,ssu_ec_$get_ec_subsystem_ptr
	ext_transfer	get_ec_suffix,ssu_ec_$get_ec_suffix
	ext_transfer	get_info_prefix,ssu_info_mgr_$get_info_prefix
	ext_transfer	get_info_ptr,ssu_invocation_$get_info_ptr
	ext_transfer	get_invocation_count,ssu_invocation_$get_invocation_count
	ext_transfer	get_level_n_sci_ptr,ssu_invocation_$get_level_n_sci_ptr
	ext_transfer	get_prev_sci_ptr,ssu_invocation_$get_prev_sci_ptr
	ext_transfer	get_procedure,ssu_procedure_mgr_$get
	ext_transfer	get_prompt,ssu_misc_procs_$get_prompt
	ext_transfer	get_prompt_mode,ssu_misc_procs_$get_prompt_mode
	ext_transfer	get_ready_mode,ssu_misc_procs_$get_ready_mode
	ext_transfer	get_request_name,ssu_invocation_$get_request_name
	sci_transfer	get_request_processor_options,get_rp_options
	sci_transfer	get_subsystem_and_request_name,get_subsys_and_request_name
	ext_transfer	get_subsystem_name,ssu_invocation_$get_subsystem_name
	ext_transfer	get_subsystem_version,ssu_invocation_$get_subsystem_version
	ext_transfer	get_temp_segment,ssu_temp_mgr_$get_segment
	sci_transfer	invoke_request
	ext_transfer	list_info_dirs,ssu_info_mgr_$list_info_dirs
	ext_transfer	list_request_tables,ssu_request_mgr_$list_request_tables
	sci_transfer	listen
	sci_transfer	locate_request
	ext_transfer	print_blast,ssu_usage_$print_blast
	sci_transfer	print_message
	ext_transfer	record_usage,ssu_usage_$record_usage
	ext_transfer	release_area,ssu_temp_mgr_$release_area
	ext_transfer	release_temp_segment,ssu_temp_mgr_$release_segment
	ext_transfer	reset_procedure,ssu_procedure_mgr_$set_default
	sci_transfer	reset_request_processor_options,reset_rp_options
	sci_transfer	return_arg
	ext_transfer	set_abbrev_info,ssu_request_processor_$set_abbrev_info
	ext_transfer	set_debug_mode,ssu_misc_procs_$set_debug_mode
	ext_transfer	set_info_dirs,ssu_info_mgr_$set_info_dirs
	ext_transfer	set_info_prefix,ssu_info_mgr_$set_info_prefix
	ext_transfer	set_info_ptr,ssu_invocation_$set_info_ptr
	ext_transfer	set_procedure,ssu_procedure_mgr_$set
	ext_transfer	set_prompt,ssu_misc_procs_$set_prompt
	ext_transfer	set_prompt_mode,ssu_misc_procs_$set_prompt_mode
	ext_transfer	set_ready_mode,ssu_misc_procs_$set_ready_mode
	sci_transfer	set_request_processor_options,set_rp_options
	ext_transfer	set_request_tables,ssu_request_mgr_$set_request_tables
	ext_transfer	set_ec_search_list,ssu_ec_$set_ec_search_list
	ext_transfer	set_ec_subsystem_ptr,ssu_ec_$set_ec_subsystem_ptr
	ext_transfer	set_ec_suffix,ssu_ec_$set_ec_suffix
	ext_transfer	standalone_invocation,ssu_invocation_$create_standalone
	sci_transfer	unknown_request

" 

	include	_ssu_sci

	end	ssu_




		    ssu_arglist_.pl1                08/05/87  0809.0r   08/04/87  1539.2       33390



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


/* Subsystem request argument processing functions: arg_count, arg_ptr, return_arg, arg_list_ptr */

/* Created:  3 May 1980 by W. Olin Sibert */
/* Modified: 13 February 1982 by G. Palter to make arg_ptr and arg_count abort when appropriate */

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


ssu_arglist_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;

dcl  P_arg_count fixed binary parameter;		/* arg_count, return_arg: # of arguments given to request */

dcl  P_arg_idx fixed binary parameter;			/* arg_ptr: index of the desired argument */
dcl  P_arg_ptr pointer parameter;			/* arg_ptr: set -> the desired argument */
dcl  P_arg_lth fixed binary (21) parameter;		/* arg_ptr: set to length of the argument */

dcl  P_af_sw bit (1) aligned parameter;			/* return_arg: set ON => invoked as an active request */
dcl  P_rv_ptr pointer parameter;			/* return_arg: set -> active request's return value */
dcl  P_rv_lth fixed binary (21) parameter;		/* return_arg: set to maximum length of return value */

dcl  P_arg_list_ptr pointer parameter;			/* arg_list_ptr: -> the request's argument list */


/* Remaining declarations */

dcl  error_table_$noarg fixed binary (35) external;
dcl  ssu_et_$not_af_request fixed binary (35) external;

dcl  cu_$arg_ptr_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  ssu_$abort_line entry () options (variable);

dcl  null builtin;

/**/

/* Returns the number of arguments to the request: aborts if the request was invoked as an active request */

arg_count:
     entry (P_sci_ptr, P_arg_count);

	call ssu_check_sci (P_sci_ptr);

	request_data_ptr = P_sci_ptr -> sci.request_data_ptr;

	if request_data.af_sw then
	     call ssu_$abort_line (P_sci_ptr, ssu_et_$not_af_request);
	else P_arg_count = request_data.arg_count;

	return;



/* Returns pointer/length of the requested argument: aborts if the argument doesn't exist */

arg_ptr:
     entry (P_sci_ptr, P_arg_idx, P_arg_ptr, P_arg_lth);

	call ssu_check_sci (P_sci_ptr);

	request_data_ptr = P_sci_ptr -> sci.request_data_ptr;

	if (P_arg_idx > request_data.arg_count) | (P_arg_idx < 1) then
	     call ssu_$abort_line (P_sci_ptr, error_table_$noarg);
	else call cu_$arg_ptr_rel (P_arg_idx, P_arg_ptr, P_arg_lth, (0), request_data.arg_list_ptr);

	return;

/**/

/* Returns the argument count, whether the request was invoked as an active request, and, if so, the return value */

return_arg:
     entry (P_sci_ptr, P_arg_count, P_af_sw, P_rv_ptr, P_rv_lth);

	call ssu_check_sci (P_sci_ptr);

	request_data_ptr = P_sci_ptr -> sci.request_data_ptr;

	P_arg_count = request_data.arg_count;

	if request_data.af_sw then do;		/* invoked as an active request */
	     P_rv_ptr = request_data.rv_ptr;
	     P_rv_lth = request_data.rv_lth;
	     P_af_sw = "1"b;
	end;

	else do;					/* not invoked as an active request */
	     P_rv_ptr = null ();
	     P_rv_lth = 0;
	     P_af_sw = "0"b;
	end;

	return;



/* Returns a pointer to the request's argument list */

arg_list_ptr:
     entry (P_sci_ptr, P_arg_list_ptr);

	call ssu_check_sci (P_sci_ptr);

	request_data_ptr = P_sci_ptr -> sci.request_data_ptr;

	P_arg_list_ptr = request_data.arg_list_ptr;

	return;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include "_ssu_request_data";

     end ssu_arglist_;




		    ssu_ec_.pl1                     10/24/88  1659.2r w 10/24/88  1400.0      121428



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


/* Subsystem exec_com processing including the exec_com request */

/* Created:  by Spencer Love & Jay Pattin */
/* Modified: 14 February 1982 by G. Palter for new calling sequence of exec_com_info.eval_string */
/* Modified: 8 July 1982 by Jay Pattin to add execute_start_up */

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


ssu_ec_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;

dcl  P_info_ptr pointer parameter;			/* exec_com: -> subsystem's internal data (not used) */

dcl  P_ec_suffix character (32) parameter;		/* set_suffix: the new suffix used to find exec_com's */

dcl  P_ec_search_list character (32) parameter;		/* set_search_list: the new search list used to find
						   exec_com's; a null string => no search list will be used */

dcl  P_subsystem_dir_ptr pointer parameter;		/* set_subsystem_ptr: new value to implement referencing dir
						   search rule in the subsystem's exec_com search path */


/* Remaining declarations */

dcl  based_code fixed binary (35) based (code_ptr);
dcl  code_ptr pointer;

dcl  based_pointer pointer based;

dcl  arg_count fixed binary;

dcl  arg character (arg_len) based (arg_ptr);
dcl  arg_len fixed binary (21);
dcl  (arg_list_ptr, arg_ptr) pointer;
dcl  (arg_type, arg_ndims, arg_size, arg_scale) fixed binary;
dcl  arg_packed bit (1) aligned;
dcl  exec_com_request bit (1) aligned;

dcl  1 ec_info aligned like exec_com_info;

dcl  ec_path character (256);
dcl  ready_enabled bit (1) aligned;
dcl  status fixed binary (35);

dcl  start_up_dirname character (168);
dcl  (start_up_ename, project_id) character (32);

dcl  SSU_EC_ character (32) static options (constant) initial ("ssu_ec_");

dcl  CHASE fixed binary (1) static options (constant) initial (1);

/* format: off */
dcl (error_table_$bad_arg, error_table_$noentry, ssu_et_$null_request_line, ssu_et_$subsystem_aborted)
	fixed binary (35) external;
/* format: on */

dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$arg_list_ptr entry (pointer);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$generate_call entry (entry, pointer);
dcl  decode_descriptor_
	entry (pointer, fixed binary, fixed binary, bit (1) aligned, fixed binary, fixed binary, fixed binary);
dcl  exec_com_ entry (character (*), character (*), character (*), pointer, fixed binary (35));
dcl  exec_com_$find_ec entry (character (*), character (*), character (*), pointer, character (*), fixed binary (35));
dcl  hcs_$status_minf
	entry (character (*), character (*), fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35));
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$abort_subsystem entry () options (variable);
dcl  ssu_$arg_list_ptr entry (pointer) returns (pointer);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$get_request_name entry (pointer) returns (character (32));
dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying);
dcl  ssu_$evaluate_active_string
	entry (pointer, pointer, character (*), fixed binary, character (*) varying, fixed binary (35));
dcl  ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
dcl  sub_err_ entry () options (variable);
dcl  user_info_ entry (character (*), character (*), character (*));
dcl  user_info_$homedir entry (character (*));

dcl  (addr, null, substr) builtin;

/**/

/* Standard subsystem exec_com request */

exec_com:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;
	exec_com_request = "1"b;

	call ssu_$return_arg (sci_ptr, arg_count, ("0"b), (null ()), (0));
	if arg_count < 1 then
	     call ssu_$abort_line (sci_ptr, 0, "Usage is:  ^a filename {optional_args}",
		ssu_$get_request_name (sci_ptr));

	call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len);

	call exec_com_$find_ec (arg, sci.ec_suffix, sci.ec_search_list, sci.subsystem_dir_ptr, ec_path, status);
	if status ^= 0 then call ssu_$abort_line (sci_ptr, status, "^a", arg);

	ready_enabled = "0"b;

	ec_info.version = exec_com_info_version_1;
	ec_info.arg_list_ptr = ssu_$arg_list_ptr (sci_ptr);
	ec_info.first_arg = 2;
	ec_info.execute_line = cp_entry;
	ec_info.eval_string = af_entry;
	ec_info.ready = rdy_entry;
	ec_info.set_ready_mode = rdy_mode_entry;
	ec_info.error = error_entry;

	call exec_com_ (ec_path, " ", ssu_$get_subsystem_and_request_name (sci_ptr), addr (ec_info), status);
	if status ^= 0 then call ssu_$abort_line (sci_ptr, status, "^a", ec_path);

	return;

/**/

/* format: off */
/* Execute a subsystem's start_up exec_com: searches for the exec_com in the user's home directory, the project directory,
   and finally >site.  Calling sequence is:
	call ssu_$execute_start__up (sci_ptr, code, {start_up_arg_1 ... start_up_arg_N}); */
/* format: on */

execute_start_up:
     entry () options (variable);

	exec_com_request = "0"b;

	call cu_$arg_count (arg_count);
	if arg_count = 0 then call ssu_check_sci (null ());

	call cu_$arg_list_ptr (arg_list_ptr);


/* Pick up the sci_ptr (1st argument): must be an unpacked pointer */

	call cu_$arg_ptr (1, arg_ptr, (0), (0));

	call decode_descriptor_ (arg_list_ptr, 1, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);
	if arg_type ^= pointer_dtype | arg_packed ^= "0"b | arg_ndims ^= 0 then call ssu_check_sci (null ());

	sci_ptr = arg_ptr -> based_pointer;		/* got one */
	call ssu_check_sci (sci_ptr);


/* Find the error code (2nd argument): must be fixed binary (35) aligned */

	call cu_$arg_ptr (2, code_ptr, (0), (0));

	call decode_descriptor_ (arg_list_ptr, 2, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);
	if arg_type ^= real_fix_bin_1_dtype | arg_packed then do;
RESIGNAL_BAD_CODE:
	     call sub_err_ (error_table_$bad_arg, SSU_EC_, ACTION_CANT_RESTART, null (), (0),
		"The second argument must be declared fixed binary (35) aligned.");
	     go to RESIGNAL_BAD_CODE;
	end;


/* Try to locate the start_up exec_com */

	start_up_ename = "start_up." || sci.ec_info.ec_suffix;

	call user_info_$homedir (start_up_dirname);

	if ^exists (start_up_dirname, start_up_ename) then do;
	     call user_info_ (((32)" "), project_id, ((32)" "));
	     start_up_dirname = ">udd>" || project_id;

	     if ^exists (start_up_dirname, start_up_ename) then do;
		start_up_dirname = ">site";

		if ^exists (start_up_dirname, start_up_ename) then do;
		     status = error_table_$noentry;
		     go to RETURN_FROM_EXECUTE_START_UP;
		end;
	     end;
	end;


/* Control arrives here iff we found a start_up: execute it */

	ready_enabled = "0"b;

	ec_info.version = exec_com_info_version_1;
	ec_info.arg_list_ptr = arg_list_ptr;
	ec_info.first_arg = 3;
	ec_info.execute_line = cp_entry;
	ec_info.eval_string = af_entry;
	ec_info.ready = rdy_entry;
	ec_info.set_ready_mode = rdy_mode_entry;
	ec_info.error = error_entry;

	call exec_com_ (pathname_ (start_up_dirname, start_up_ename), " ",
	     ssu_$get_subsystem_and_request_name (sci_ptr), addr (ec_info), status);

RETURN_FROM_EXECUTE_START_UP:
	based_code = status;

	return;



/* Determines if a given branch exists */

exists:
     procedure (p_dirname, p_ename) returns (bit (1) aligned);

dcl  (p_dirname, p_ename) character (*) parameter;
dcl  type fixed binary (2);

	call hcs_$status_minf (p_dirname, p_ename, CHASE, type, (0), status);

	if (status = 0) & (type > 0) then
	     return ("1"b);
	else return ("0"b);

     end exists;

/**/

/* Converts exec_com_'s call to cu_$cp into a call to ssu_$execute_line */

cp_entry:
     procedure (p_com_line_ptr, p_com_line_len, p_status);

dcl  p_com_line_ptr pointer parameter;
dcl  p_com_line_len fixed binary (21) parameter;
dcl  p_status fixed binary (35) parameter;

	call ssu_$execute_line (sci_ptr, p_com_line_ptr, p_com_line_len, p_status);

	if p_status = ssu_et_$subsystem_aborted then
	     if exec_com_request then
		call ssu_$abort_subsystem (sci_ptr);
	     else do;
		status = p_status;
		go to RETURN_FROM_EXECUTE_START_UP;
	     end;

	if p_status = ssu_et_$null_request_line then p_status = 100;
						/* it thinks it's calling the command_processor_ */

	return;

     end cp_entry;



/* Converts exec_com_'s call to cu_$evaluate_active_string into a call to ssu_$evaluate_active_string */

af_entry:
     procedure (p_info_ptr, p_active_string, p_active_string_type, p_return_value, p_status);

dcl  p_info_ptr pointer parameter;
dcl  p_active_string character (*) parameter;
dcl  p_active_string_type fixed binary parameter;
dcl  p_return_value character (*) varying parameter;
dcl  p_status fixed binary (35) parameter;

	call ssu_$evaluate_active_string (sci_ptr, p_info_ptr, p_active_string, p_active_string_type, p_return_value,
	     p_status);

	if p_status = ssu_et_$subsystem_aborted then
	     if exec_com_request then
		call ssu_$abort_subsystem (sci_ptr);
	     else do;
		status = p_status;
		go to RETURN_FROM_EXECUTE_START_UP;
	     end;

	return;

     end af_entry;

/**/

/* Converts exec_com_'s call to cu_$ready_proc into a call to the subsystems ready procedure when ready messages are
   enabled from within the exec_com by "&ready on" (initially no ready messages are printed within exec_com's) */

rdy_entry:
     procedure ();

	if ready_enabled then call sci.entries.ready (sci_ptr);

	return;

     end rdy_entry;



/* Handles exec_com_'s call to cu_$set_ready_mode */

rdy_mode_entry:
     procedure (p_ready_mode);

dcl  p_ready_mode bit (36) aligned parameter;

	if substr (p_ready_mode, 1, 1) then
	     ready_enabled = "1"b;
	else ready_enabled = "0"b;

	return;

     end rdy_mode_entry;

/**/

/* Translates exec_com_'s call to com_err_ or active_fnc_err_ into a call to ssu_$abort_line */

error_entry:
     procedure () options (variable);

dcl  arg_list_ptr pointer;
dcl  display_present fixed binary;

dcl  ptr_desc bit (36) aligned static options (constant) initial ("464000000000"b3);

dcl  1 arg_list aligned based (arg_list_ptr),
       2 arg_count fixed binary (16) unaligned,
       2 code fixed binary (18) unaligned,
       2 desc_count fixed binary (16) unaligned,
       2 pad fixed binary (18) unaligned,
       2 arg_ptrs (arg_list.arg_count) pointer,
       2 display_ptr (display_present) pointer,
       2 desc_ptrs (arg_list.desc_count) pointer;

	call cu_$arg_list_ptr (arg_list_ptr);
	if arg_list.arg_count < 2 then call ssu_$abort_line (sci_ptr, 0, "Error entry called with too few arguments.");
	if arg_list.arg_count ^= arg_list.desc_count then
	     call ssu_$abort_line (sci_ptr, 0, "Error entry called with no descriptors.");

	if arg_list.code = 8 then
	     display_present = 1;
	else display_present = 0;

	begin;

dcl  1 auto_arg_list aligned like arg_list;

	     auto_arg_list = arg_list;
	     auto_arg_list.arg_ptrs (2) = auto_arg_list.arg_ptrs (1);
	     auto_arg_list.desc_ptrs (2) = auto_arg_list.desc_ptrs (1);
	     auto_arg_list.arg_ptrs (1) = addr (sci_ptr);
	     auto_arg_list.desc_ptrs (1) = addr (ptr_desc);

	     call cu_$generate_call (ssu_$abort_line, addr (auto_arg_list));
	end;

	return;					/* never executed */

     end error_entry;

/**/

/* Sets the suffix for subsystem exec_com segments: the default set at invocation creation time is the subsystem name */

set_ec_suffix:
     entry (P_sci_ptr, P_ec_suffix);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.ec_suffix = P_ec_suffix;

	return;



/* Returns the current subsystem exec_com suffix */

get_ec_suffix:
     entry (P_sci_ptr) returns (character (32));

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.ec_suffix);



/* Sets the name of the search list used to locate exec_com's for this subsystem: the default set at invocation creation
   time is to not use a search list */

set_ec_search_list:
     entry (P_sci_ptr, P_ec_search_list);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.ec_search_list = P_ec_search_list;

	return;



/* Returns the current exec_com search list */

get_ec_search_list:
     entry (P_sci_ptr) returns (character (32));

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.ec_search_list);



/* Sets the pointer used to implement the referencing_dir search path of the subsystem's exec_com search list: the pointer
   should locate any segment in the desired directory.  Eventually, this pointer will be used to implement the
   subsystem_dir search path (when subsystem_dir is implemented) */

set_ec_subsystem_ptr:
     entry (P_sci_ptr, P_subsystem_dir_ptr);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.ec_info.subsystem_dir_ptr = P_subsystem_dir_ptr;

	return;



/* Returns the current pointer used to implement the referencing_dir search path */

get_ec_subsystem_ptr:
     entry (P_sci_ptr) returns (pointer);

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.subsystem_dir_ptr);

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include exec_com_info;
%page;
%include std_descriptor_types;

%include sub_err_flags;

     end ssu_ec_;




		    ssu_error_.pl1                  10/24/88  1659.2r w 10/24/88  1400.0       77517



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


/* Standard procedures for printing error messages for subsystems: ssu_$print_message, ssu_$abort_line, ssu_$abort_system;
   for the abort_line and abort_subsystem entries, the appropriate non-local transfers are made */

/* Created:  3 May 1980 by W. Olin Sibert from subsystem_listen_ */
/* Modified: 14 February 1982 by G. Palter to support standalone invocations */
/* Modified: June 1982 by G. Palter to reflect reorganization of SCI */
/* Modified: 6 November 1984 by G. Palter to use ssu_$get_subsystem_and_request_name and to correct the order of arguments
   in the call to assign_ (subsystem_utilities error #0020) */

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


ssu_error_:
     procedure ();

	return;					/* not an entrypoint */


dcl  function fixed binary;

dcl  (arg_list_ptr, arg_ptr) pointer;
dcl  arg_count fixed binary;

dcl  arg_type fixed binary;
dcl  arg_packed bit (1) aligned;
dcl  arg_ndims fixed binary;
dcl  arg_size fixed binary;
dcl  arg_scale fixed binary;

dcl  based_pointer pointer aligned based;
dcl  based_fb35 fixed binary (35) aligned based;

dcl  error_code fixed binary (35);
dcl  error_message char (100) aligned;
dcl  (from_size, to_size) fixed bin (35);

dcl  caller_name character (72) varying;

dcl  output_message character (2048);
dcl  abort_label label variable;

dcl  error_table_$active_function fixed binary (35) external;
dcl  error_table_$not_act_fnc fixed binary (35) external;
dcl  ssu_et_$not_af_request fixed binary (35) external;
dcl  ssu_et_$not_command_request fixed binary (35) external;

dcl  iox_$error_output pointer external;
dcl  ssu_$null_label label variable external;

dcl  active_fnc_err_ entry () options (variable);
dcl  assign_ entry (pointer, fixed binary, fixed binary (35), pointer, fixed binary, fixed binary (35));
dcl  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
dcl  com_err_ entry () options (variable);
dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl  cu_$arg_list_ptr entry (pointer);
dcl  cu_$cl entry (bit (1) aligned);
dcl  decode_descriptor_
	entry (pointer, fixed binary, fixed binary, bit (1) aligned, fixed binary, fixed binary, fixed binary);
dcl  ioa_$general_rs
	entry (pointer, fixed binary, fixed binary, character (*), fixed binary, bit (1) aligned, bit (1) aligned);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying);
dcl  ssu_$print_message entry () options (variable);

dcl  PRINT_MESSAGE fixed binary static options (constant) initial (1);
dcl  ABORT_LINE fixed binary static options (constant) initial (2);
dcl  ABORT_SUBSYSTEM fixed binary static options (constant) initial (3);

dcl  (addr, binary, null, rtrim, substr, unspec) builtin;

/**/

/* Print an error message and continue execution */

print_message:
     entry () options (variable);

	function = PRINT_MESSAGE;
	go to COMMON;


/* Print an error message and then abort execution of the current request line (if any) */

abort_line:
     entry () options (variable);

	function = ABORT_LINE;
	go to COMMON;


/* Print an error message and then abort execution of the subsystem */

abort_subsystem:
     entry () options (variable);

	function = ABORT_SUBSYSTEM;
	go to COMMON;


/* Insure that the first argument is supplied and is an sci_ptr: if only that argument is present, print no message but
   perform any appropriate non-local transfers dependent on the entry invoked */

COMMON:
	call cu_$arg_count (arg_count);

	if arg_count = 0 then			/* there must be arguments */
	     call ssu_check_sci (null ());

	call cu_$arg_list_ptr (arg_list_ptr);

	call cu_$arg_ptr (1, arg_ptr, (0), (0));

	call decode_descriptor_ (arg_list_ptr, 1, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);

	if (arg_type ^= pointer_dtype) | (arg_packed ^= "0"b) | (arg_ndims ^= 0) then call ssu_check_sci (null ());
						/* not a pointer */

	sci_ptr = arg_ptr -> based_pointer;		/* got it */

	call ssu_check_sci (sci_ptr);			/* validate it */

	if arg_count = 1 then go to EXIT_AFTER_PRINTING;	/* no message to print: abort the line or subsystem */


/* Pick up the error code argument */

	call cu_$arg_ptr (2, arg_ptr, (0), (0));
	call decode_descriptor_ (arg_list_ptr, 2, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);

	if (arg_type = real_fix_bin_1_dtype) & (arg_packed = "0"b) then
	     error_code = arg_ptr -> based_fb35;	/* caller's code is a single-word fixed binary value */

	else do;					/* caller's code is something else: try to convert it */
	     if (arg_type >= bit_dtype) & (arg_type <= varying_char_dtype) then
		from_size = arg_size;
	     else from_size = (262144 * arg_scale) + arg_size;
	     to_size = 35;				/* target is fixed binary (35) */
	     call assign_ (addr (error_code), (2 * real_fix_bin_1_dtype), to_size, arg_ptr,
		(2 * arg_type + binary (arg_packed, 1)), from_size);
	end;

	if (error_code = 0) & (arg_count < 3) then	/* no error and no message: just abort as appropriate */
	     go to EXIT_AFTER_PRINTING;


/* Build the error message: convert the input status code, get the subsystem/request name, and process the caller's ioa_
   control string and arguments */

	if error_code ^= 0 then			/* get the error message */
	     call convert_status_code_ (error_code, (""), error_message);

	caller_name = ssu_$get_subsystem_and_request_name (sci_ptr);

	if arg_count >= 3 then			/* build the caller's message */
	     call ioa_$general_rs (arg_list_ptr, 3, 4, output_message, (0), ("1"b), ("0"b));
	else output_message = "";			/* no caller-supplied message */


/* Print the message: for standalone invocations, call com_err_ or active_fnc_err_ as appropriate, translating the
   not_af_request and not_command_request error codes to the appropiate error_table_ entries; additionally, the presence
   of these codes will cause the opposite entry to be called in order to achieve the correct behaviour */

	if sci.standalone_invocation then do;
	     request_data_ptr = sci.request_data_ptr;
	     if error_code = ssu_et_$not_af_request then error_code = error_table_$active_function;
	     if error_code = ssu_et_$not_command_request then error_code = error_table_$not_act_fnc;
	     if request_data.af_sw then		/* invoked as an active function */
		if error_code = error_table_$active_function then
		     call com_err_ (error_code, caller_name, "^a", output_message);
		else call active_fnc_err_ (error_code, caller_name, "^a", output_message);
	     else					/* invoked as a Multics command */
		if error_code = error_table_$not_act_fnc then
		call active_fnc_err_ (error_code, caller_name, "^a", output_message);
	     else call com_err_ (error_code, caller_name, "^a", output_message);
	end;

	else call ioa_$ioa_switch (iox_$error_output, "^a: ^[^a ^;^s^]^a", caller_name, (error_code ^= 0),
		error_message, output_message);


/* Post processing: for abort_line or abort_subsystem, perform the appropriate non-local transfer if not a standalone
   invocation; if a standalone invocation, call the caller's abort entry (which is expected not to return) */

EXIT_AFTER_PRINTING:
	if function = PRINT_MESSAGE then return;	/* simple exit */

	else if function = ABORT_LINE then abort_label = sci.request_processor_info.abort_line_label;

	else abort_label = sci.listener_info.abort_subsystem_label;
						/* anything we don't know about, just punt */

	if sci.debug_mode then do;			/* delay the inevitable, slightly */
	     call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl.");
	     call cu_$cl ("0"b);			/* if a start occurs, continue */
	end;

	if sci.standalone_invocation then		/* standalone invocation: call abort entry (and ... */
	     call sci.standalone_abort_entry ();	/* ... probably never return here) */

	else do;
	     if substr (unspec (abort_label), 31, 6) = "43"b3 then
		if abort_label ^= ssu_$null_label then go to abort_label;
	     call ssu_$print_message (sci_ptr, 0, "Cannot go to abort label; returning...");
	end;

	return;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include "_ssu_request_data";
%page;
%include std_descriptor_types;

     end ssu_error_;




		    ssu_et_.alm                     11/05/86  1305.7r w 11/04/86  1038.1       20250



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


" Subsystem Utilities Error Table
"
" Created:  3 May 1980 by W. Olin Sibert
" Modified: 15 February 1982 by G. Palter to add null_request_line and not_in_standalone_invocation
" Modified: 26 February 1982 by G. Palter to add program_interrupt
" Modified: 14 July 1982 by Jay Pattin to add exec_com_aborted


	include	et_macros


	et	ssu_et_

	ec	active_function_error,actfncer,
		 (An active function error occurred while executing a Multics AF request.)

	ec	blank_request_name,reqblank,
		 (Blank request name.)

	ec	cpescape_restricted,nocp,
		 (You may not execute Multics command lines via the '..' escape sequence.)

	ec	exec_com_aborted,ecabort,
		 (The exec_com has been aborted.)

	ec	invalid_request_table,badrqt,
		 (The specified request table is not a valid format.)

	ec	no_matching_requests,^matchrq,
		(No matching request names were found.)

	ec	not_af_request,^afreq,
		 (This request may not be invoked as an active function.)

	ec	not_command_request,^command,
		 (This request may not be invoked as a command.)

	ec	not_in_standalone_invocation,notstand,
		 (This function may not be invoked in a standalone subsystem invocation.)

	ec	null_request_line,nullrql,
		 (Null request line encountered.)

	ec	program_interrupt,progint,
		 (Request line execution aborted at the user's request.)

	ec	request_line_aborted,rqlabort,
		 (The request line has been aborted.)

	ec	request_name_too_long,reqlong,
		 (Request name too long.)

	ec	request_not_found,rqntfnd,
		 (The specified request was not found.)

	ec	request_table_not_found,^reqtabl,
		 (Specified request table not found.)

	ec	subsystem_aborted,ssabort,
		 (The subsystem invocation has been aborted.)

	ec	unavailable_request,reqlnker,
		 (This request is unavailable due to linkage_error.)

	ec	unimplemented_request,notimp,
		 (This request is not yet implemented.)

	ec	unknown_request,^request,
		 (Unknown request; type ? for a request list.)

	end




		    ssu_execute_.pl1                08/05/87  0809.0r   08/04/87  1539.2       56466



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


/* Invoke a subsystem request */

/* Created:  3 May 1980 by W. Olin Sibert */
/* Modified: 15 February 1982 by G. Palter to treat the continue_sw from unknown requests according to the documentation
   and to reflect the reorganization of the sci structure */

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


ssu_execute_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_request_name character (*) parameter;		/* name of the request to be incoked */
dcl  P_arg_list_ptr pointer parameter;			/* -> the arguments for the request */
dcl  P_code fixed binary (35) parameter;


/* Local copies of parameters */

dcl  code fixed bin (35);


/* Remaining declarations */

dcl  saved_request_data_ptr pointer;
dcl  saved_executing_request bit (1) aligned;

dcl  1 auto_request_data aligned like request_data automatic;

dcl  continue_sw bit (1) aligned;

dcl  iox_$error_output pointer external;

dcl  (
     ssu_et_$active_function_error,
     ssu_et_$not_command_request,
     ssu_et_$not_af_request,
     ssu_et_$unknown_request
     ) fixed binary (35) external;

dcl  cu_$af_return_arg_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  cu_$generate_call entry (entry, pointer);
dcl  find_condition_info_ entry (pointer, pointer, fixed binary (35));
dcl  ioa_$ioa_switch entry () options (variable);
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$locate_request entry (pointer, character (*), pointer, fixed binary (35));
dcl  ssu_$unknown_request entry (pointer, pointer, character (*), pointer, bit (1) aligned);
dcl  ssu_misc_procs_$unknown_request entry (pointer, pointer, character (*), pointer, bit (1) aligned);

dcl  (active_function_error, cleanup) condition;

dcl  (addr, null, length, substr) builtin;

/**/

/* Invokes a subsystem request: the default procedure reached by ssu_$invoke_request; also responsible for invoking
   Multics requests */

execute_request:
     entry (P_sci_ptr, P_request_name, P_arg_list_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	request_data_ptr = addr (auto_request_data);

	call ssu_$locate_request (sci_ptr, P_request_name, request_data_ptr, code);
	if code = ssu_et_$unknown_request then do;	/* not in the request table (or whatever) */
	     continue_sw = "0"b;
	     call ssu_$unknown_request (sci_ptr, sci.info_ptr, P_request_name, P_arg_list_ptr, continue_sw);
	     if continue_sw then			/* caller handled it and wants request line ... */
		P_code = 0;			/* ... to be completed normally */
	     else do;				/* caller wants request line aborted ... */
		call ssu_misc_procs_$unknown_request (sci_ptr, sci.info_ptr, P_request_name, P_arg_list_ptr,
		     continue_sw);
		P_code = code;
	     end;
	     return;
	end;

	else if code ^= 0 then			/* some other peculiar type of error */
	     call ssu_$abort_line (sci_ptr, code, """^a""", P_request_name);

	request_data.arg_list_ptr = P_arg_list_ptr;

	call cu_$af_return_arg_rel			/* fill in call_info substructure */
	     (request_data.arg_count, request_data.rv_ptr, request_data.rv_lth, code, request_data.arg_list_ptr);

	if code = 0 then				/* and set the AF flag */
	     request_data.af_sw = "1"b;
	else request_data.af_sw = "0"b;

	if (^request_data.af_sw) & (^request_data.flags.allow_command) then
	     call ssu_$abort_line (sci_ptr, ssu_et_$not_command_request, "^a", request_data.full_name);

	if request_data.af_sw & (^request_data.flags.allow_af) then
	     call ssu_$abort_line (sci_ptr, ssu_et_$not_af_request, "^a", request_data.full_name);

	P_code = 0;

	saved_request_data_ptr = sci.request_data_ptr;	/* save it for later... */
	saved_executing_request = sci.executing_request;	/* in case called from another request */

	on cleanup
	     begin;				/* restore state on an abort */
		sci.request_data_ptr = saved_request_data_ptr;
		sci.executing_request = saved_executing_request;
	     end;

	sci.request_data_ptr = request_data_ptr;	/* request_data is in our frame now, and will stick around */
	sci.executing_request = "1"b;			/* as long as necessary */

	if request_data.flags.multics_request then do;	/* invoke a Multics command/AF as a request ... */
	     on condition (active_function_error)	/* ... catch AF errors in order to print the message */
		call report_active_function_error ();
	     call cu_$generate_call (request_data.entry, request_data.arg_list_ptr);
	     revert condition (active_function_error);
	end;

	else call request_data.entry (sci_ptr, sci.info_ptr);
						/* an ordinary request */

	sci.request_data_ptr = saved_request_data_ptr;
	sci.executing_request = saved_executing_request;

	return;

/**/

/* Reports active function errors: prints the message that would have been printed by the default error handler and then
   aborts the active function's execution */

report_active_function_error:
     procedure ();

dcl  1 cond_info aligned automatic like condition_info;

dcl  1 afe_info aligned based (cond_info.info_ptr) like com_af_error_info;

dcl  code fixed binary (35);

	call find_condition_info_ ((null ()), addr (cond_info), code);
	if code ^= 0 then				/* can't happen */
	     call ssu_$abort_line (sci_ptr, code, "Unable to find active function error frame.");

	if cond_info.info_ptr = null () then
	     call ssu_$abort_line (sci_ptr, code, "Unable to find active function error frame.");

	call iox_$put_chars (iox_$error_output, afe_info.errmess_ptr, afe_info.errmess_lth, (0));

	call ssu_$abort_line (sci_ptr, ssu_et_$active_function_error);
						/* never returns (we hope) */

     end report_active_function_error;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include "_ssu_request_data";
%page;
%include condition_info;
%page;
%include com_af_error_info;

%include condition_info_header;

     end ssu_execute_;




		    ssu_info_directories_.cds       08/23/84  0835.3rew 08/23/84  0825.1       14886



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
ssu_info_directories_:
     procedure ();

/* This procedure creates the segment 'ssu_info_directories_' which contains
   the pathnames of directories containing info segs provided with the 
   subsystem utitlities.

   Written 84-06-22 by Paul W. Benjamin
*/

dcl 1 ssu_info_dir_data aligned,
    2 standard_requests char (168);

dcl 1 cds_data aligned like cds_args;

dcl  code fixed binary (35);

dcl  NAME character (32) static options (constant) 
     initial ("ssu_info_directories_");

dcl  com_err_ entry () options (variable);
dcl  create_data_segment_ entry (pointer, fixed binary (35));

dcl (addr, currentsize, null, string) builtin;

%include cds_args;


	ssu_info_dir_data.standard_requests 
	     = ">doc>subsystem>ssu_info_dirs>standard_requests";

	cds_data.sections (1).p = addr (ssu_info_dir_data);
	cds_data.sections (1).len = currentsize (ssu_info_dir_data);
	cds_data.sections (1).struct_name = "ssu_info_dir_data";

	cds_data.sections (2).p = null ();

	cds_data.seg_name = NAME;

	cds_data.num_exclude_names = 0;
	cds_data.exclude_array_ptr = null ();

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

/* Call create_data_segment_ */

	call create_data_segment_ (addr (cds_data), code);

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

	return;

     end ssu_info_directories_;




		    ssu_info_mgr_.pl1               10/24/88  1659.2r w 10/24/88  1400.0      230346



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




/****^  HISTORY COMMENTS:
  1) change(86-03-07,GDixon), approve(86-03-07,MCR7327),
     audit(86-03-10,Lippard), install(86-04-24,MR12.0-1048):
     Use help$ssu_help_request instead of calling help command.
                                                   END HISTORY COMMENTS */


/* Standard subsystem self-documentation facilities (except for request listing requests) */

/* Created:  10 May 1980 by W. Olin Sibert */
/* Modified: 21 May 1980 by G. Palter to fix (ugh) mail system bug #0312 -- list_help request doesn't work */
/* Modified: August 1981 by Jay Pattin to fix list_help again and to not require prefix in info seg name */
/* Modified: 7 November 1981 by Jay Pattin to make list_help look for break chars around topic name */
/* Modified: 17 November 1981 by Jay Pattin to use sci.info_prefix instead of subsystem name */
/* Modified: 17 December 1981 by G. Palter to provide more usefull information when the help request is used with no
   arguments and to no longer recognize "*" as a special case */
/* Modified: 1 February 1982 by G. Palter to make list_help case insensitive */
/* Modified: 11 February 1982 by G. Palter to rename to ssu_info_mgr_ and add entrypoints which manipulate the info
   directory list and info prefix */
/* Modified: 3 March 1982 by G. Palter to make list_help of no arguments not list the names in uppercase */
/* Modified: 8 June 1983 by G. C. Dixon to call help$ssu_help_request instead of calling help command. */

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


ssu_info_mgr_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_code fixed binary (35) parameter;

dcl  P_info_prefix character (32) parameter;		/* set_info_prefix: the new value of the prefix */

dcl  P_info_dirname character (*) parameter;		/* add_info_dir/delete_info_dir: the dir to add/delete */
dcl  P_position fixed binary parameter;			/* add_info_dir: where to place this dir in the list */

dcl  P_idl_ptr pointer parameter;			/* list_info_dirs/set_info_dirs */
dcl  P_callers_area_ptr pointer parameter;		/* list_info_dirs: -> area to use to list structure */
dcl  P_info_dirs_list_version fixed binary parameter;	/* list_info_dirs: version of structure callers expects */

dcl  P_info_ptr pointer parameter;			/* help/list_help requests */


/* The list of directories searched by the help and list_help requests to find an info segment */

dcl  1 info_dirs aligned based (sci.info_dirs_ptr),
       2 n_used fixed binary,
       2 n_allocated fixed binary,
       2 dirs (info_dirs_n_allocated refer (info_dirs.n_allocated)) like info_dirs_list.info_dirs;

dcl  info_dirs_n_allocated fixed binary;
dcl  new_info_dirs_ptr pointer;


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  info_dirname character (168);

dcl  position fixed binary;

dcl  callers_area area based (callers_area_ptr);
dcl  callers_area_ptr pointer;


/* Remaining declarations */

dcl  arg character (al) based (ap);
dcl  al fixed binary (21);
dcl  ap pointer;

dcl  uid bit (36) aligned;

dcl  old_nargs fixed binary;
dcl  (match, found_bad_dirname) bit (1) aligned;
dcl  topic_sw bit(1);
dcl  subsys_name character (32);
dcl  (request_name, help_request_name, lh_request_name) character (32);
dcl  intro_topic character (32);
dcl  info_name char(300) varying;
dcl  (code1, code2) fixed binary (35);
dcl  (idx, jdx, pos) fixed binary;
dcl  topic_array_size fixed binary;
dcl  total_topics fixed binary;

dcl  CHASE fixed binary (1) static options (constant) initial (1);
						/* chase links when validating info directories */

dcl  DELIMITERS char (5) static options (constant) initial (" .-_$");
						/* break chars for list_help topics */

dcl  (
     UPPERCASE initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
     LOWERCASE initial ("abcdefghijklmnopqrstuvwxyz")
     ) character (26) static options (constant);

dcl  (
     error_table_$badopt,
     error_table_$entlong,
     error_table_$no_dir,
     error_table_$noalloc,
     error_table_$noentry,
     error_table_$notadir,
     error_table_$nostars,
     error_table_$unimplemented_version,
     error_table_$zero_length_seg
     ) fixed binary (35) external;

dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), pointer, fixed bin (35));
dcl  hcs_$terminate_noname entry (pointer, fixed bin (35));
dcl  hcs_$star_ entry (char (*), char (*), fixed bin (3), pointer, fixed bin, pointer, pointer, fixed bin (35));
dcl  hcs_$status_long entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl  help$ssu_help_request entry (ptr, bit(1), entry);
dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (pointer, fixed binary);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$get_subsystem_name entry (pointer) returns (character (32));
dcl  ssu_request_mgr_$find_request_name entry (pointer, entry, character (*), fixed binary (35));

dcl  (
     ssu_requests_$help,
     ssu_requests_$list_help,
     ssu_requests_$list_requests,
     ssu_requests_$summarize_requests
     ) entry ();

dcl  (area, cleanup) condition;

dcl  (addr, char, hbound, index, length, maxlength, null, rtrim, search, substr, translate) builtin;

/**/

/* Set the prefix used to find info files */

set_info_prefix:
     entry (P_sci_ptr, P_info_prefix);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.info_prefix = P_info_prefix;

	return;



/* Return the prefix used to find info files */

get_info_prefix:
     entry (P_sci_ptr) returns (character (32));

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.info_prefix);



/* Initialize the list of info directories (called by ssu_invocation_) */

init_info_dirs:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	info_dirs_n_allocated = 3;			/* enough to start */
	allocate info_dirs in (sci_parent_area) set (sci.info_dirs_ptr);

	info_dirs.n_used = 0;			/* nothing in the list yet */

	return;



/* Release the info directories list (invoked from ssu_invocation_) */

term_info_dirs:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.info_dirs_ptr ^= null () then free info_dirs in (sci_parent_area);

	sci.info_dirs_ptr = null ();

	return;

/**/

/* Add a directory to the list of directories searched by the help and list_help requests */

add_info_dir:
     entry (P_sci_ptr, P_info_dirname, P_position, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	P_code = 0;				/* assume success */

	call validate_info_dir (P_info_dirname, info_dirname, uid, code);
	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;

	if sci.info_dirs_ptr = null () then		/* no info directories list??? */
	     call init_info_dirs (sci_ptr);

	if (info_dirs.n_used >= info_dirs.n_allocated) & (info_dirs.n_allocated ^= 0) then do;
						/* need to expand the table */
	     info_dirs_n_allocated = 2 * info_dirs.n_allocated;
	     allocate info_dirs in (sci_parent_area) set (new_info_dirs_ptr);
	     new_info_dirs_ptr -> info_dirs.n_used = info_dirs.n_used;
	     do idx = 1 to info_dirs.n_used;
		new_info_dirs_ptr -> info_dirs.dirs (idx) = info_dirs.dirs (idx);
	     end;
	     free info_dirs in (sci_parent_area);	/* free the full one */
	     sci.info_dirs_ptr = new_info_dirs_ptr;
	end;

	if P_position > info_dirs.n_used then position = info_dirs.n_used + 1;
						/* add to the end of the list */
	else if P_position <= 0 then position = 1;	/* add to the beginning */
	else position = P_position;			/* add in an explicit place */

	info_dirs.n_used = info_dirs.n_used + 1;

	do idx = info_dirs.n_used to (position + 1) by -1;
	     info_dirs.dirs (idx) = info_dirs.dirs (idx - 1);
	end;

	info_dirs.dirs (position).info_dirname = info_dirname;
	info_dirs.dirs (position).info_dir_valid = "1"b;
	info_dirs.dirs (position).uid = uid;

	return;

/**/

/* Delete a directory from the list of info directories for this subsystem */

delete_info_dir:
     entry (P_sci_ptr, P_info_dirname, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call validate_info_dir (P_info_dirname, info_dirname, uid, code);

	match = "0"b;				/* find a matching directory */

	if (code = 0) then				/* can search by uid */
	     do idx = 1 to info_dirs.n_used while (^match);
	     if info_dirs.dirs (idx).uid = uid then match = "1"b;
	end;

	else do idx = 1 to info_dirs.n_used while (^match);
						/* must search by pathname */
	     if info_dirs.dirs (idx).info_dirname = info_dirname then match = "1"b;
	end;

	if match then do;				/* found it: idx identifies next entry in list */
	     do jdx = idx to info_dirs.n_used;
		info_dirs.dirs (jdx - 1) = info_dirs.dirs (jdx);
	     end;
	     info_dirs.n_used = info_dirs.n_used - 1;
	     P_code = 0;				/* success */
	end;

	else P_code = error_table_$noentry;

	return;

/**/

/* Return the list of info directories used by this subsystem */

list_info_dirs:
     entry (P_sci_ptr, P_callers_area_ptr, P_info_dirs_list_version, P_idl_ptr, P_code);

	if P_info_dirs_list_version ^= INFO_DIRS_LIST_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	callers_area_ptr = P_callers_area_ptr;

	on condition (area)
	     begin;
		P_code = error_table_$noalloc;
		go to RETURN_FROM_LIST_INFO_DIRS;
	     end;

	info_dirs_list_n_info_dirs = info_dirs.n_used;

	allocate info_dirs_list in (callers_area) set (idl_ptr);

	info_dirs_list.version = INFO_DIRS_LIST_VERSION_1;

	do idx = 1 to info_dirs.n_used;
	     info_dirs_list.info_dirs (idx) = info_dirs.dirs (idx);
	end;

	P_idl_ptr = idl_ptr;
	P_code = 0;				/* success */

RETURN_FROM_LIST_INFO_DIRS:
	return;

/**/

/* Replace the list of info directories with that supplied by the caller */

set_info_dirs:
     entry (P_sci_ptr, P_idl_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	idl_ptr = P_idl_ptr;

	if info_dirs_list.version ^= INFO_DIRS_LIST_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;


/* Validate the caller's directory names */

	found_bad_dirname = "0"b;			/* assume user's list is OK */

	do idx = 1 to info_dirs_list.n_info_dirs;
	     info_dirs_list.info_dirs (idx).info_dir_valid = "1"b;
	     call validate_info_dir (info_dirs_list.info_dirs (idx).info_dirname,
		info_dirs_list.info_dirs (idx).info_dirname, info_dirs_list.info_dirs (idx).uid, code);
	     if code ^= 0 then do;			/* a bad directory pathname */
		if ^found_bad_dirname then P_code = code;
		found_bad_dirname = "1"b;		/* remember reason for the first bad directory */
		info_dirs_list.info_dirs (idx).info_dir_valid = "0"b;
	     end;
	end;

	if found_bad_dirname then return;		/* return code is already set */


/* All directories are valid: create a new internal list, copies the user's data, then release the old internal list */

	info_dirs_n_allocated = info_dirs_list.n_info_dirs;

	allocate info_dirs in (sci_parent_area) set (new_info_dirs_ptr);

	new_info_dirs_ptr -> info_dirs.n_used = info_dirs_list.n_info_dirs;

	do idx = 1 to new_info_dirs_ptr -> info_dirs.n_used;
	     new_info_dirs_ptr -> info_dirs.dirs (idx) = info_dirs_list.info_dirs (idx);
	end;

	if sci.info_dirs_ptr ^= null () then		/* get rid of the old one */
	     free sci.info_dirs_ptr -> info_dirs in (sci_parent_area);

	sci.info_dirs_ptr = new_info_dirs_ptr;		/* now have the new list */

	P_code = 0;				/* success */

	return;

/**/

/* Validates an info directory supplied by the caller */

validate_info_dir:
     procedure (p_info_dirname, p_absolute_info_dirname, p_uid, p_code);

dcl  p_info_dirname character (*) parameter;
dcl  p_absolute_info_dirname character (*) parameter;
dcl  p_uid bit (36) aligned parameter;
dcl  p_code fixed binary (35);

dcl  1 branch_status aligned like status_branch;
dcl  dirname character (168);
dcl  ename character (32);

	call expand_pathname_ (p_info_dirname, dirname, ename, p_code);
	if p_code ^= 0 then return;

	call hcs_$status_long (dirname, ename, CHASE, addr (branch_status), null (), p_code);
	if p_code ^= 0 then return;

	if branch_status.type ^= Directory then do;
	     p_code = error_table_$notadir;
	     return;
	end;

	p_uid = branch_status.uid;
	p_absolute_info_dirname = pathname_ (dirname, ename);
	p_code = 0;

	return;

     end validate_info_dir;

/**/

/* Standard subsystem help request: scans its argument list and converts any apparent topic names into the appropriate
   pathnames by searching the subsystem' info directories; control arguments or explicit pathnames are passed directly;
   a -brief_header control argument is added to the transformed argument list and the standard help command is invoked */

help:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, old_nargs);	/* aborts if an active request */

	subsys_name = ssu_$get_subsystem_name (sci_ptr);

	if old_nargs = 0 then do;			/* explain what to do */
	     call ssu_request_mgr_$find_request_name (sci_ptr, ssu_requests_$help, help_request_name, code2);
	     if code2 = 0 then do;			/* look for introductory information */
		intro_topic = "general_information";
		call find_info_file_no_abort (intro_topic, ((168)" "), code1);
		if code1 ^= 0 then do;
		     intro_topic = "overview";
		     call find_info_file_no_abort (intro_topic, ((168)" "), code1);
		end;
		if code1 = 0 then
		     call ioa_ ("Type ""^a ^a"" for an overview of the ^a subsystem.", help_request_name, intro_topic,
			subsys_name);
	     end;
	     call ssu_request_mgr_$find_request_name (sci_ptr, ssu_requests_$summarize_requests, request_name, code1);
	     if code1 = 0 then call ioa_ ("Type ""^a"" for a list of available requests.", request_name);
	     call ssu_request_mgr_$find_request_name (sci_ptr, ssu_requests_$list_requests, request_name, code1);
	     if code1 = 0 then call ioa_ ("Type ""^a"" for a short description of the requests.", request_name);
	     call ssu_request_mgr_$find_request_name (sci_ptr, ssu_requests_$list_help, lh_request_name, code1);
	     if (code1 = 0) & (code2 = 0) then
		call ioa_ ("Type ""^a"" for a list of topics available to the ^a request.", lh_request_name,
		     help_request_name);
	     else if (code1 ^= 0) & (code2 = 0) then
		call ioa_ ("Type ""^a -topics"" for a list of available topics.", help_request_name);
	     if code2 = 0 then
		call ioa_ ("Type ""^a TOPIC"" for more information on a given topic.", help_request_name);
	     call ssu_$abort_line (sci_ptr, 0);		/* punt rest of line as user might be confused */
	end;

	call help$ssu_help_request (sci_ptr, topic_sw, find_subsystem_info_file);
	if topic_sw then				/* handle specially */
	     goto HANDLE_HELP_LIST_TOPICS;
	return;					/* end of code for standard path through help request */

/**/

/* Lists all available info files for the subsystem: used by both list_help and help */

HANDLE_HELP_LIST_TOPICS:
	total_topics = 0;

	do idx = 1 to info_dirs.n_used;
	     if info_dirs.dirs (idx).info_dir_valid then do;
		call list_topics (info_dirs.dirs (idx).info_dirname, "0"b, (""));
	     end;
	end;

	if total_topics = 0 then
	     call ssu_$abort_line (sci_ptr, 0, "There are no info topics available for this subsystem.");

	return;

/**/

/* Standard subsystem list_help request: lists all names in the info directories that match any of its arguments */

list_help:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, old_nargs);	/* aborts if an active request */

	subsys_name = ssu_$get_subsystem_name (sci_ptr);

	if old_nargs = 0 then			/* handle it like help handles help * */
	     goto HANDLE_HELP_LIST_TOPICS;

	topic_array_size = old_nargs;

	begin;					/* otherwise, make a topic list and list selectively */

dcl  topic_names (topic_array_size) char (32) varying;

	     topic_array_size = 0;			/* use them up one at a time now */

	     do idx = 1 to old_nargs;
		call ssu_$arg_ptr (sci_ptr, idx, ap, al);

		if char (arg, 1) = "-" then call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", arg);

		topic_array_size = topic_array_size + 1;
		topic_names (topic_array_size) = translate (rtrim (arg), UPPERCASE, LOWERCASE);
	     end;

	     total_topics = 0;			/* keep this up to date */

	     do idx = 1 to info_dirs.n_used;		/* now, list them */
		if info_dirs.dirs (idx).info_dir_valid then do;
		     call list_topics (info_dirs.dirs (idx).info_dirname, "1"b, topic_names);
		end;
	     end;

	     if total_topics = 0 then			/* found none */
		call ssu_$abort_line (sci_ptr, 0, "No matching info topics were found.");

	end;					/* begin block */

	return;					/* end of code for $list_help */

/**/

/* Entry point passed to help$ssu_help_request.  It calls this entry point to find subsystem info segs. */

find_subsystem_info_file:
	entry (P_sci_ptr, AP_topic) returns (char(300) varying);

dcl  AP_topic character(*) parameter;
	
	sci_ptr = P_sci_ptr;
	call find_info_file (AP_topic, info_name);
	return (info_name);


/* Search for a specific info file: abort the request line if it isn't not found */

find_info_file:
     procedure (P_topic, P_path);

dcl  P_topic character (*) parameter;
dcl  P_path character (*) varying parameter;
dcl  P_code fixed binary (35) parameter;

dcl  no_abort bit (1) aligned;
dcl  ename character (32) varying;
dcl  topic character (32) varying;
dcl  info_dirname character (168);
dcl  info_ename character (32);
dcl  info_ptr pointer;
dcl  info_bc fixed binary (24);
dcl  code fixed binary (35);
dcl  idx fixed binary (35);

	no_abort = "0"b;
	go to FIND_INFO_FILE_COMMON;


/* Search for a specific info file: do not abort the request line if it isn't not found */

find_info_file_no_abort:
     entry (P_topic, P_path, P_code);

	P_code = 0;				/* assume success */
	no_abort = "1"b;


FIND_INFO_FILE_COMMON:
	if (search (P_topic, "*?") ^= 0) then
	     if no_abort then do;
		P_code = error_table_$nostars;
		return;
	     end;
	     else call ssu_$abort_line (sci_ptr, error_table_$nostars, "^a", P_topic);

	if length (P_topic) > 5 then
	     if substr (P_topic, (length (P_topic) - 4), 5) = ".info" then
		topic = substr (P_topic, 1, (length (P_topic) - 5));
	     else topic = rtrim (P_topic);
	else topic = rtrim (P_topic);

	if (length (topic) + length ("info") + 1) > maxlength (ename) then
INFO_FILE_NAME_TOO_LONG:
	     if no_abort then do;
		P_code = error_table_$entlong;
		return;
	     end;
	     else call ssu_$abort_line (sci_ptr, error_table_$entlong, "^a", P_topic);

	ename = topic || ".info";
	if sci.info_prefix ^= "" then do;
	     if (length (ename) + length (rtrim (sci.info_prefix)) + 1) > maxlength (ename) then
		go to INFO_FILE_NAME_TOO_LONG;
	     ename = "." || ename;
	     ename = rtrim (sci.info_prefix) || ename;
	end;
	info_ename = ename;

	do idx = 1 to info_dirs.n_used;
	     if info_dirs.dirs (idx).info_dir_valid then do;
		info_dirname = info_dirs.dirs (idx).info_dirname;
		call hcs_$initiate_count (info_dirname, info_ename, "", info_bc, 1, info_ptr, code);
		if info_ptr ^= null () then goto FOUND_ONE;
		if (code ^= error_table_$noentry) & (code ^= error_table_$no_dir) then
		     if no_abort then do;
			P_code = code;
			return;
		     end;
		     else call ssu_$abort_line (sci_ptr, code, "^a>^a", info_dirname, info_ename);
	     end;
	end;

	if no_abort then do;
	     P_code = error_table_$noentry;
	     return;
	end;
	else call ssu_$abort_line (sci_ptr, 0, "No info found for ^a.", P_topic);

FOUND_ONE:
	call hcs_$terminate_noname (info_ptr, (0));
	if info_bc ^= 0 then do;
	     P_path = rtrim (info_dirname);
	     P_path = P_path || ">";
	     P_path = P_path || info_ename;
	     return;				/* let our caller have it */
	end;

	else if no_abort then do;
	     P_code = error_table_$zero_length_seg;
	     return;
	end;

	else call ssu_$abort_line (sci_ptr, error_table_$zero_length_seg, "^a>^a", info_dirname, info_ename);

	return;

     end find_info_file;

/**/


/* List the info topics for the subsystem in a particular directory which optionally match the given topics */

list_topics:
     procedure (P_dname, P_select_sw, P_topics);

dcl  P_dname character (*) parameter;
dcl  P_select_sw bit (1) aligned parameter;
dcl  P_topics (*) character (*) varying parameter;

dcl  1 entries (entries_count) aligned based (entries_ptr),
       2 type bit (2) unaligned,
       2 n_names fixed binary (15) unaligned,
       2 name_idx fixed binary (17) unaligned;
dcl  entries_ptr pointer;
dcl  entries_count fixed binary;

dcl  names (1) character (32) aligned based (names_ptr);
dcl  names_ptr pointer;

dcl  n_names fixed binary;
dcl  topic_name character (32) varying;
dcl  topic_ename character (32);
dcl  gi_topic_ename character (32);
dcl  (n_topics, idx, jdx, kdx) fixed binary;
dcl  code fixed binary (35);


	names_ptr = null ();
	entries_ptr = null ();

	on condition (cleanup)
	     begin;
		if names_ptr ^= null () then free names in (sci_parent_area);
		if entries_ptr ^= null () then free entries in (sci_parent_area);
	     end;

	topic_ename = "**.info";
	gi_topic_ename = rtrim (subsys_name) || ".gi.info";

	call hcs_$star_ (P_dname, topic_ename, 11b, addr (sci_parent_area), entries_count, entries_ptr, names_ptr, code)
	     ;
	if code ^= 0 then				/* let our caller figure out that nothing got listed */
	     return;

	n_topics = 0;				/* count number of entries */

	do idx = 1 to entries_count;
	     n_names = 0;

	     if ^P_select_sw then do;			/* skip SUBSYS.gi.info by default */
		do jdx = 1 to entries (idx).n_names;
		     if names (entries (idx).name_idx + jdx - 1) = gi_topic_ename then goto SKIP_THIS_TOPIC;
		end;
	     end;

	     do jdx = 1 to entries (idx).n_names;
		topic_name = get_topic_name (names (entries (idx).name_idx + jdx - 1));

		if topic_name = "" then		/* punt if this is not a valid topic name */
		     goto SKIP_TO_NEXT_NAME;

		if P_select_sw then do;		/* see if it matches anything */
		     topic_name = translate (topic_name, UPPERCASE, LOWERCASE);
		     do kdx = 1 to hbound (P_topics, 1);
			pos = index (topic_name, P_topics (kdx));
			match = "0"b;
			if pos ^= 0 then
			     if pos = 1 then match = "1"b;
			     else if pos = length (topic_name) - length (P_topics (kdx)) + 1 then match = "1"b;
			     else if index (DELIMITERS, substr (topic_name, pos - 1, 1)) ^= 0 then match = "1"b;
			     else if index (DELIMITERS, substr (topic_name, pos + length (P_topics (kdx)), 1)) ^= 0
			     then match = "1"b;
			if match then do;		/* matches: print the real name */
			     topic_name = get_topic_name (names (entries (idx).name_idx + jdx - 1));
			     call add_topic_name ();
			     goto SKIP_TO_NEXT_NAME;
			end;
		     end;
		end;

		else call add_topic_name ();		/* just output all the names */

SKIP_TO_NEXT_NAME:
	     end;

	     if n_names = 1 then			/* finish the output process */
		call ioa_ ("");
	     else if n_names > 1 then call ioa_ (")");

SKIP_THIS_TOPIC:
	end;					/* of first loop through names */

	total_topics = total_topics + n_topics;		/* update the total count */

	if names_ptr ^= null () then free names in (sci_parent_area);
	if entries_ptr ^= null () then free entries in (sci_parent_area);

	return;

/**/

/* Internal to list_topics: output a single, matching topic name */

add_topic_name:
	procedure ();

	     if n_names = 0 then			/* increment topic count when we output first name */
		n_topics = n_topics + 1;

	     if (n_names = 0) & (n_topics = 1) & (total_topics = 0) then
						/* print heading first time through */
		call ioa_ ("Topics available for ^a:^/", subsys_name);

	     if n_names = 0 then			/* output first topic name */
		call ioa_$nnl ("^a", topic_name);

	     else if n_names = 1 then call ioa_$nnl ("^x(^a", topic_name);

	     else call ioa_$nnl (",^x^a", topic_name);

	     n_names = n_names + 1;

	     return;

	end add_topic_name;

/**/

get_topic_name:
	procedure (P_ename) returns (character (32) varying);

dcl  P_ename character (32) aligned;
dcl  (idx, jdx) fixed binary;

	     if sci.info_prefix ^= "" then do;		/* check for the prefix */
		idx = length (rtrim (sci.info_prefix)); /* prepare to strip off prefix and .info suffix */
		if substr (P_ename, 1, idx) ^= rtrim (sci.info_prefix) then return ("");
		idx = idx + 1;			/* room for the "." */
		if substr (P_ename, idx, 1) ^= "." then return ("");
	     end;
	     else idx = 0;

	     jdx = length (rtrim (P_ename));
	     jdx = jdx - 5;				/* length of ".info" */
	     if jdx < (idx + 1) then			/* no room? */
		return ("");
	     if substr (P_ename, jdx + 1, 5) ^= ".info" then return ("");
	     jdx = jdx - idx;

	     return (substr (P_ename, idx + 1, jdx));

	end get_topic_name;

     end list_topics;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include ssu_info_dirs_list;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
%page;
%include status_structures;

     end ssu_info_mgr_;




		    ssu_invocation_.pl1             08/05/87  0809.0r   08/04/87  1539.3      212355



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


/* Subsystem invocation manager */

/* Created:  by W. Olin Sibert */
/* Modified: 15 February 1982 by G. Palter to add create_standalone and manage invocation lists without requiring the
   caller to supply an invocation_list_ptr */
/* Modified: 25 February 1982 by G. Palter to insure create_invocation is invoked with the proper number of arguments */
/* Modified: 26 May 1982 by G. Palter to manage request processor options */
/* Modified: August 1982 by Jay Pattin to setup temporaries manager before request table manager */
/* Modified: 6 November 1984 by G. Palter for version 3 SCIs */

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


ssu_invocation_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;

dcl  P_code fixed binary (35) parameter;		/* create, standalone_invocation */

dcl  P_subsystem_name character (*) parameter;		/* create: name of subsystem */
dcl  P_subsystem_version character (*) parameter;		/* create: version # of subsystem */
dcl  P_info_ptr pointer parameter;			/* create, set_info_ptr: -> subsystem's internal data */
dcl  P_request_table_ptr pointer parameter;		/* create: -> initial request table (if any) */
dcl  P_info_dir character (*) parameter;		/* create: initial info directory (if any) */

dcl  P_command_name character (*) parameter;		/* create_standalone: name of command/AF */
dcl  P_command_version character (*) parameter;		/* create_standalone: version # of the command/AF */
dcl  P_arg_list_ptr pointer parameter;			/* create_standalone: -> the command/AF's argument list */
dcl  P_abort_procedure entry () variable parameter;	/* create_standalone: entry to call on ssu_$abort_* */

dcl  P_this_level fixed binary parameter;		/* get_invocation_count: set to level of this invocation */
dcl  P_max_level fixed binary parameter;		/* get_invocation_count: set to maximum level used */

dcl  P_new_sci_ptr pointer parameter;			/* get_level_n_sci_ptr: set -> SCI of requested level */
dcl  P_new_info_ptr pointer parameter;			/* get_level_n_sci_ptr: set -> requested level's info */


/* Active subsystem invocation lists known by the utilties: invocations are grouped by subsystem name and version */

dcl  1 ilie aligned based (ilie_ptr),			/* a single active subsystem's invocation list */
       2 subsystem_name character (32) unaligned,
       2 subsystem_version character (32) unaligned,
       2 first_sci_ptr pointer,			/* -> SCI of first invocation of this subsystem */
       2 last_sci_ptr pointer,			/* -> SCI of last invocation of this subsystem */
       2 max_level fixed binary,			/* level # of last invocation */
       2 pad bit (36);
dcl  ilie_ptr pointer;

dcl  1 static_ili aligned internal static,		/* room for 16 invocation lists without having to allocate */
       2 header,
         3 n_ilies fixed binary initial (16),
         3 pad bit (36) initial (""b),
       2 ilies (16) like ilie;

dcl  1 ili aligned based (ili_ptr),			/* references are made to this structure, however */
       2 header like static_ili.header,
       2 ilies (ili_n_ilies refer (ili.n_ilies)) like ilie;
dcl  ili_ptr pointer internal static initial (null ());
dcl  ili_n_ilies fixed binary;


/* Local copies of parameters */

dcl  arg_list_ptr pointer;

dcl  code fixed binary (35);


/* Remaining declarations */

dcl  system_area area based (system_area_ptr);
dcl  system_area_ptr pointer;

dcl  n_arguments fixed binary;

dcl  next_sci_ptr pointer;

dcl  return_name character (72) varying;

dcl  SSU_CREATE_INVOCATION character (32) static options (constant) initial ("ssu_$create_invocation");
dcl  CANT_RESTART character (1) static options (constant) initial ("s");

dcl  error_table_$badcall fixed binary (35) external;
dcl  error_table_$wrong_no_of_args fixed binary (35) external;

dcl  ssu_$null_entry entry () variable external;
dcl  ssu_$null_label label variable external;

dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$af_return_arg_rel entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl  hcs_$fs_get_seg_ptr entry (character (*), pointer, fixed binary (35));
dcl  hcs_$initiate
	entry (character (*), character (*), character (*), fixed binary (1), fixed binary (2), pointer,
	fixed binary (35));
dcl  ssu_$add_info_dir entry (pointer, character (*), fixed binary, fixed binary (35));
dcl  ssu_$add_request_table entry (pointer, pointer, fixed binary, fixed binary (35));
dcl  ssu_info_mgr_$init_info_dirs entry (pointer);
dcl  ssu_info_mgr_$term_info_dirs entry (pointer);
dcl  ssu_procedure_mgr_$set_all_default entry (pointer);
dcl  ssu_request_mgr_$init_request_tables entry (pointer);
dcl  ssu_request_mgr_$term_request_tables entry (pointer);
dcl  ssu_request_processor_$init_rp_options entry (pointer);
dcl  ssu_request_processor_$term_rp_options entry (pointer);
dcl  ssu_temp_mgr_$release_everything entry (pointer);
dcl  sub_err_ entry () options (variable);
dcl  term_$single_refname entry (character (*), fixed binary (35));

dcl  (addr, codeptr, null, pointer, rtrim, stackframeptr, string) builtin;
%page;
create:
     entry (P_subsystem_name, P_subsystem_version, P_info_ptr, P_request_table_ptr, P_info_dir, P_sci_ptr, P_code);

	call cu_$arg_count (n_arguments);		/* check for old-style call */
	if n_arguments ^= 7 then do;
RESIGNAL_WRONG_NO_OF_ARGS:
	     call sub_err_ (error_table_$wrong_no_of_args, SSU_CREATE_INVOCATION, CANT_RESTART, null (), (0),
		"^a expects 7 arguments; ^d were supplied.", SSU_CREATE_INVOCATION, n_arguments);
	     go to RESIGNAL_WRONG_NO_OF_ARGS;
	end;

	if P_subsystem_name = "" then do;		/* you've got to be kidding */
	     P_code = error_table_$badcall;
	     return;
	end;

	P_sci_ptr = null ();

	system_area_ptr = get_system_free_area_ ();

	call switch_ssu_refnames ();			/* make sure we get proper version of everything */

	allocate sci in (system_area) set (sci_ptr);

	sci.version = SCI_VERSION_3;			/* make it appear legitimate */
	sci.parent_area_ptr = system_area_ptr;		/* for possible later allocation and freeing */

	sci.subsystem_name = P_subsystem_name;
	sci.subsystem_version = P_subsystem_version;
	sci.info_ptr = P_info_ptr;			/* copy info from parameters */
	sci.standalone_abort_entry = ssu_$null_entry;
	string (sci.global_info.flags) = ""b;		/* this is right */

	sci.temp_info_ptr = null ();			/* no temporaries yet */

	call ssu_request_mgr_$init_request_tables (sci_ptr);
	if P_request_table_ptr ^= null () then do;	/* user supplied an initial request table */
	     call ssu_$add_request_table (sci_ptr, P_request_table_ptr, 1, P_code);
	     if P_code ^= 0 then do;
		call ssu_request_mgr_$term_request_tables (sci_ptr);
		free sci in (system_area);
		return;
	     end;
	end;

	call ssu_request_processor_$init_rp_options (sci_ptr);

	sci.request_processor_info.abort_line_label = ssu_$null_label;
	sci.request_data_ptr = null ();		/* no request running yet */

	sci.prompt = "^/" || rtrim (P_subsystem_name) || "^[ (^d)^]:^2x";
						/* standard prompt */
	string (sci.prompt_mode) = ""b;		/* default prompting */
	sci.ready_enabled = "0"b;			/* no ready messages by default */

	sci.listener_info.abort_subsystem_label = ssu_$null_label;
	sci.listener_info.temp_seg_ptr = null ();	/* initialize to use automatic buffer */


	sci.info_prefix = "";			/* defaults to any info segment name */

	call ssu_info_mgr_$init_info_dirs (sci_ptr);
	if P_info_dir ^= "" then do;			/* user supplied an initial info directory */
	     call ssu_$add_info_dir (sci_ptr, P_info_dir, 1, P_code);
	     if P_code ^= 0 then do;
		call ssu_info_mgr_$term_info_dirs (sci_ptr);
		call ssu_request_processor_$term_rp_options (sci_ptr);
		call ssu_request_mgr_$term_request_tables (sci_ptr);
		free sci in (system_area);
		return;
	     end;
	end;

	sci.ec_info.ec_suffix = sci.subsystem_name;
	sci.ec_info.ec_search_list = "";
	sci.subsystem_dir_ptr = null ();

	call ssu_procedure_mgr_$set_all_default (sci_ptr);/* setup all the entry variables to default states */

	call find_ilie ();				/* find appropriate invocation list */

	sci.recursion_info.previous_sci_ptr = ilie.last_sci_ptr;
	sci.recursion_info.next_sci_ptr = null ();	/* this is the last invocation */
	ilie.last_sci_ptr = sci_ptr;

	if ilie.first_sci_ptr = null () then		/* first invocation of this subsystem */
	     ilie.first_sci_ptr = sci_ptr;
	else sci.recursion_info.previous_sci_ptr -> sci.recursion_info.next_sci_ptr = sci_ptr;

	ilie.max_level, sci.recursion_info.level = ilie.max_level + 1;

	P_sci_ptr = sci_ptr;
	P_code = 0;				/* success */

	return;
%page;
/* Finds an invocation_list_info entry (ilie) for this subsystem name/version combination: grows the ili if necessary,
   starts a new invocation list if necessary, and sets sci.invocation_data_idx */

find_ilie:
     procedure ();

dcl  (free_ilie_idx, idx) fixed binary;
dcl  new_ili_ptr pointer;

	if ili_ptr = null () then do;			/* first time in this process */
	     ili_ptr = addr (static_ili);		/* ... use the internal one */
	     do idx = 1 to ili.n_ilies;
		ili.ilies (idx).subsystem_name = "";	/* ... mark all entries as free */
	     end;
	end;

	free_ilie_idx = 0;

	do idx = 1 to ili.n_ilies;
	     ilie_ptr = addr (ili.ilies (idx));
	     if (ilie.subsystem_name = sci.subsystem_name) & (ilie.subsystem_version = sci.subsystem_version) then do;
		sci.invocation_data_idx = idx;	/* found it */
		return;
	     end;
	     else if (ilie.subsystem_name = "") & (free_ilie_idx = 0) then free_ilie_idx = idx;
	end;					/* remember first free entry */


/* Here iff this is the first active invocation for this subsystem */

	if free_ilie_idx = 0 then do;			/* no free slots: grow the ili ... */
	     ili_n_ilies = 2 * ili.n_ilies;
	     allocate ili in (system_area) set (new_ili_ptr);
	     do idx = 1 to ili.n_ilies;		/* copy current lists */
		new_ili_ptr -> ili.ilies (idx) = ili.ilies (idx);
	     end;
	     free_ilie_idx = ili.n_ilies + 1;		/* use first free slot */
	     do idx = (ili.n_ilies + 1) to new_ili_ptr -> ili.n_ilies;
		new_ili_ptr -> ili.ilies (idx).subsystem_name = "";
	     end;					/* mark the rest free */
	     if ili_ptr ^= addr (static_ili) then	/* free old structure */
		free ili in (system_area);
	     ili_ptr = new_ili_ptr;			/* zap */
	end;

	ilie_ptr = addr (ili.ilies (free_ilie_idx));

	ilie.subsystem_name = sci.subsystem_name;
	ilie.subsystem_version = sci.subsystem_version;
	ilie.first_sci_ptr, ilie.last_sci_ptr = null ();
	ilie.max_level = 0;				/* haven't used any yet */

	sci.invocation_data_idx = free_ilie_idx;

	return;

     end find_ilie;
%page;
/* Create a standalone invocation:  Standalone invocations are used by procedures which are coded to work both as Multics
   command/AFs and as subsystem requests; the standalaone invocation is created when the procedure is invoked from
   Multics.  All references to ssu_$print_message, ssu_$abort_line, and ssu_$abort_subsystem in a standalone invocation
   are converted to appropriate calls to com_err_/active_fnc_err_; after the message is printed for the abort entries, the
   procedure's abort entry is invoked which is expected to perform a non-local goto back to the cleanup code of the
   procedure.  Calls to ssu_$execute_line and ssu_$evaluate_active_string are translated into calls to cu_$cp and
   cu_$evaluate_active_string, respectively */

create_standalone:
     entry (P_sci_ptr, P_command_name, P_command_version, P_arg_list_ptr, P_abort_procedure, P_code);

	if P_arg_list_ptr = null () then		/* get the caller's argument list */
	     arg_list_ptr = stackframeptr () -> stack_frame.prev_sp -> stack_frame.arg_ptr;
	else arg_list_ptr = P_arg_list_ptr;

	if arg_list_ptr = null () then do;		/* couldn't get the argument list pointer */
	     P_code = error_table_$badcall;
	     return;
	end;

	system_area_ptr = get_system_free_area_ ();

	allocate sci in (system_area) set (sci_ptr);

	sci.version = SCI_VERSION_3;			/* setup the data structure */
	sci.parent_area_ptr = system_area_ptr;

	sci.subsystem_name = P_command_name;
	sci.subsystem_version = P_command_version;
	sci.info_ptr = null ();			/* none needed for a Multics command/AF */
	sci.standalone_abort_entry = P_abort_procedure;
	string (sci.global_info.flags) = ""b;
	sci.standalone_invocation = "1"b;
	sci.executing_request = "1"b;			/* causes most other procedures to react properly */

	sci.recursion_info.invocation_data_idx = 0;	/* no invocation lists are kept for standalone invocations */
	sci.recursion_info.level = 1;
	sci.recursion_info.previous_sci_ptr, sci.recursion_info.next_sci_ptr = null ();

	sci.request_tables_ptr = null ();		/* no request tables: can't execute requests */
	sci.rp_options_ptr = null ();			/* no request processor: will never use options */
	sci.request_processor_info.abort_line_label = ssu_$null_label;
	allocate request_data in (system_area) set (sci.request_data_ptr);

	sci.prompt = "";				/* no listener loop allowed: no prompts or ready messages */
	string (sci.prompt_mode) = ""b;
	sci.ready_enabled = "0"b;

	sci.listener_info.abort_subsystem_label = ssu_$null_label;
	sci.listener_info.temp_seg_ptr = null ();	/* no listener either */

	sci.temp_info_ptr = null ();			/* no temporary segments/areas yet */

	sci.info_dirs_ptr = null ();			/* no help/list_help requests */
	sci.info_prefix = "";

	sci.ec_suffix, sci.ec_search_list = "";		/* no exec_com request either */
	sci.ec_info.subsystem_dir_ptr = null ();

	call ssu_procedure_mgr_$set_all_default (sci_ptr);


/* Create a fake executing request which is acutally the Multics command/AF */

	request_data_ptr = sci.request_data_ptr;

	request_data.full_name = P_command_name;	/* so the procedure can use get_request_name */

	request_data.entry = ssu_$null_entry;		/* nothing will ever call this anyway */
	string (request_data.flags) = ""b;
	request_data.name_list_ptr = null ();		/* don't bother to make up a fake name list ... */
	request_data.info_string.ptr = null ();		/* ... or documentation string */
	request_data.info_string.lth = 0;

	request_data.call_info.arg_list_ptr = arg_list_ptr;

	call cu_$af_return_arg_rel (request_data.arg_count, request_data.rv_ptr, request_data.rv_lth, code,
	     request_data.arg_list_ptr);		/* get argument count and return string (if any) */

	if code = 0 then				/* a Multics active function */
	     request_data.af_sw = "1"b;
	else request_data.af_sw = "0"b;		/* a Multics command */

	P_sci_ptr = sci_ptr;			/* all done */
	P_code = 0;

	return;
%page;
/* Destroy a subsystem invocation: removes the invocation from the list of active invocations of the subsystem */

destroy:
     entry (P_sci_ptr);

	if P_sci_ptr = null () then			/* protect against confused cleanup handlers */
	     return;

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	P_sci_ptr = null ();			/* prevent multiple attempts to destroy this invocation */

	if ^sci.standalone_invocation then do;		/* pop a level */
	     ilie_ptr = addr (ili.ilies (sci.invocation_data_idx));
	     if ilie.last_sci_ptr = sci_ptr then	/* was the last active invocation */
		ilie.last_sci_ptr = sci.recursion_info.previous_sci_ptr;
	     else sci.recursion_info.next_sci_ptr -> sci.previous_sci_ptr = sci.previous_sci_ptr;
	     if ilie.first_sci_ptr = sci_ptr then	/* was the first active invocation */
		ilie.first_sci_ptr = sci.recursion_info.next_sci_ptr;
	     else sci.recursion_info.previous_sci_ptr -> sci.next_sci_ptr = sci.next_sci_ptr;
	     if ilie.last_sci_ptr = null () then	/* no longer any active invocations */
		ilie.max_level = 0;
	     else ilie.max_level = ilie.last_sci_ptr -> sci.recursion_info.level;
	end;					/* make sure highest active invocation level is correct */

	system_area_ptr = sci.parent_area_ptr;

	call ssu_temp_mgr_$release_everything (sci_ptr);	/* free all temporaries ... */
	call ssu_info_mgr_$term_info_dirs (sci_ptr);	/* ... and any tables acquired by utility procedures */
	call ssu_request_processor_$term_rp_options (sci_ptr);
	call ssu_request_mgr_$term_request_tables (sci_ptr);

	if sci.standalone_invocation & (sci.request_data_ptr ^= null ()) then do;
	     free sci.request_data_ptr -> request_data in (system_area);
	     sci.request_data_ptr = null ();
	end;

	free sci in (system_area);			/* get rid of the structure */

	return;
%page;
/* Returns a pointer to the subsystem's internal data */

get_info_ptr:
     entry (P_sci_ptr) returns (pointer);

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.info_ptr);



/* Sets the pointer to the subsystem's internal data: allows a subsystem to postpone creation of its internal data until
   it knows that the subsystem invocation was successfully created */

set_info_ptr:
     entry (P_sci_ptr, P_info_ptr);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.info_ptr = P_info_ptr;

	return;
%page;
/* Returns the subsystem's name */

get_subsystem_name:
     entry (P_sci_ptr) returns (character (32));

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.subsystem_name);



/* Returns the version number of the subsystem */

get_subsystem_version:
     entry (P_sci_ptr) returns (character (32));

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.subsystem_version);



/* Returns the name of the subsystem request being executed (if any): for standalone invocations, returns the name of
   Multics command/AF which created the invocation */

get_request_name:
     entry (P_sci_ptr) returns (character (32));

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.executing_request then
	     return (sci.request_data_ptr -> request_data.full_name);

	else return ("");



/* Returns the subsystem's and current request's names in the form with the request name enclosed in parentheses */

get_subsystem_and_request_name:
     entry (P_sci_ptr) returns (character (72) varying);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	return_name = rtrim (sci.subsystem_name);

	if sci.executing_request & ^sci.standalone_invocation then do;
	     return_name = return_name || " (";
	     return_name = return_name || rtrim (sci.request_data_ptr -> request_data.full_name);
	     return_name = return_name || ")";
	end;

	return (return_name);
%page;
/* Returns the level # of this subsystem invocation and the # of the highest active invocation of the subsystem */

get_invocation_count:
     entry (P_sci_ptr, P_this_level, P_max_level);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.standalone_invocation then		/* shouldn't ask, but ... */
	     P_this_level, P_max_level = 1;

	else do;
	     ilie_ptr = addr (ili.ilies (sci.invocation_data_idx));
	     P_this_level = sci.recursion_info.level;
	     P_max_level = ilie.max_level;
	end;

	return;
%page;
/* Returns a pointer to the SCI and subsystem's internal database for the requested invocation of the subsystem */

get_level_n_sci_ptr:
     entry (P_sci_ptr, P_this_level, P_new_sci_ptr, P_new_info_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.standalone_invocation then		/* shouldn't ask for this, but ... */
	     if P_this_level = 1 then do;		/* ... only 1 level for standalone invocations */
		P_new_sci_ptr = sci_ptr;
		P_new_info_ptr = sci.info_ptr;
	     end;
	     else P_new_sci_ptr, P_new_info_ptr = null ();

	else do;
	     P_new_sci_ptr, P_new_info_ptr = null ();	/* assume failure */
	     ilie_ptr = addr (ili.ilies (sci.invocation_data_idx));
	     do next_sci_ptr = ilie.first_sci_ptr repeat (next_sci_ptr -> sci.next_sci_ptr)
		while (next_sci_ptr ^= null ());
		if next_sci_ptr -> sci.recursion_info.level = P_this_level then do;
		     P_new_sci_ptr = next_sci_ptr;
		     P_new_info_ptr = next_sci_ptr -> sci.info_ptr;
		end;
	     end;
	end;

	return;
%page;
/* Return a pointer to the SCI and subsystem's internal database for the previous active invocation of this subsystem */

get_prev_sci_ptr:
     entry (P_sci_ptr, P_new_sci_ptr, P_new_info_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.previous_sci_ptr ^= null () then do;	/* there is a previous invocation */
	     P_new_sci_ptr = sci.recursion_info.previous_sci_ptr;
	     P_new_info_ptr = sci.recursion_info.previous_sci_ptr -> sci.info_ptr;
	end;

	else do;					/* no previous invocation */
	     P_new_sci_ptr = null ();
	     P_new_info_ptr = null ();
	end;

	return;
%page;
/* Insures that the reference names ssu_et_, ssu_requests_, and ssu_request_tables_ are on the same object segment as
   ssu_: If this is not done, references to either of the other two names from user programs could reference the wrong
   (older or newer) versions of these segments which can cause problems -- for ssu_et_, the error codes would be unequal
   as this segment's references to them are bound away and always reference the codes in this segment; for ssu_requests_,
   the older/newer versions of the requests might have different ideas as to the nature of the SCI structure; for
   ssu_request_tables_, the older/newer versions of the tables might have different requests */

switch_ssu_refnames:
     procedure ();

dcl  dirname character (168);
dcl  ename character (32);
dcl  other_ssu_ptr pointer;

	call hcs_$fs_get_seg_ptr ("ssu_et_", other_ssu_ptr, code);
	if (code ^= 0) then do;			/* didn't find the refname at all */
SWITCH_SSU_ET_REFNAME:
	     call term_$single_refname ("ssu_et_", (0));	/* terminate it, whether initiated or not */
	     call hcs_$fs_get_path_name (codeptr (ssu_invocation_), dirname, (0), ename, (0));
	     call hcs_$initiate (dirname, ename, "ssu_et_", 0, 0, (null ()), (0));
	end;
	else if pointer (other_ssu_ptr, 0) ^= pointer (codeptr (ssu_invocation_), 0) then go to SWITCH_SSU_ET_REFNAME;
						/* wrong object segment */

	call hcs_$fs_get_seg_ptr ("ssu_requests_", other_ssu_ptr, code);
	if (code ^= 0) then do;			/* didn't find the refname at all */
SWITCH_SSU_REQUESTS_REFNAME:
	     call term_$single_refname ("ssu_requests_", (0));
						/* terminate it, whether initiated or not */
	     call hcs_$fs_get_path_name (codeptr (ssu_invocation_), dirname, (0), ename, (0));
	     call hcs_$initiate (dirname, ename, "ssu_requests_", 0, 0, (null ()), (0));
	end;
	else if pointer (other_ssu_ptr, 0) ^= pointer (codeptr (ssu_invocation_), 0) then
	     go to SWITCH_SSU_REQUESTS_REFNAME;		/* wrong object segment */

	call hcs_$fs_get_seg_ptr ("ssu_request_tables_", other_ssu_ptr, code);
	if (code ^= 0) then do;			/* didn't find the refname at all */
SWITCH_SSU_REQUEST_TABLES_REFNAME:
	     call term_$single_refname ("ssu_request_tables_", (0));
						/* terminate it, whether initiated or not */
	     call hcs_$fs_get_path_name (codeptr (ssu_invocation_), dirname, (0), ename, (0));
	     call hcs_$initiate (dirname, ename, "ssu_request_tables_", 0, 0, (null ()), (0));
	end;
	else if pointer (other_ssu_ptr, 0) ^= pointer (codeptr (ssu_invocation_), 0) then
	     go to SWITCH_SSU_REQUEST_TABLES_REFNAME;	/* wrong object segment */

	return;

     end switch_ssu_refnames;
%page;
%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include "_ssu_request_data";
%page;
%include stack_frame;

     end ssu_invocation_;




		    ssu_listen_.pl1                 08/08/88  1548.3r w 08/08/88  1409.5       84861



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


/* format: off */

/* Default subsystem listener: reads request lines from the requested I/O switch and executes them via a call to
   ssu_$execute_line */

/* Created:  3 May 1980 by W. Olin Sibert from the old system_listen_ */
/* Modified: 8 May 1980 by W. Olin Sibert to handle error_table_$long_record */
/* Modified: 2 November 1981 by W. Olin Sibert to not prompt if input is pending and to prompt after a blank line, error
      sequence (ssu 4) */
/* Modified: 15 February 1982 by G. Palter to support new prompt modes, recognize ssu_et_$null_request_line, reject use
      from within standalone invocations, reflect the reorganization of the sci structure, and correct a bug where prompts
      would forever be turned off */
/* Modified: June 1982 by G. Palter to not trap calls to ssu_$abort_line as it is now always handled by
      ssu_$execute_line (ssu 12) and to properly handle all return codes from ssu_$execute_line */

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


ssu_listen_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_iocb_ptr pointer parameter;			/* -> I/O switch from which input is read */
dcl  P_code fixed binary (35) parameter;


/* Local copies of parameters */

dcl  iocb_ptr pointer;
dcl  code fixed binary (35);


/* Remaining declarations */

dcl  1 saved_listener_info aligned like sci.listener_info;
dcl  (saved_in_listener, saved_executing_request) bit (1) aligned;

dcl  request_line character (request_line_lth) based (request_line_ptr);
dcl  request_line_lth fixed binary (21);
dcl  request_line_ptr pointer;

dcl  line_buffer character (line_buffer_lth) based (line_buffer_ptr);
dcl  line_buffer_lth fixed binary (21);
dcl  line_buffer_ptr pointer;

dcl  automatic_line_buffer character (4096);

dcl  new_ptr pointer;
dcl  new_read_ptr pointer;
dcl  new_read_lth fixed binary (21);

dcl  last_line_blank bit (1) aligned;
dcl  (print_prompt, force_prompt, last_prompt_suppressed_by_typeahead) bit (1) aligned;
dcl  suppress_ready bit (1) aligned;

dcl  1 read_status_info aligned like tty_read_status_info automatic;

dcl  iox_$user_input pointer external;
dcl  iox_$user_output pointer external;

dcl  sys_info$max_seg_size fixed binary (19) external;

/* format: off */
dcl (error_table_$long_record, ssu_et_$not_in_standalone_invocation, ssu_et_$null_request_line,
     ssu_et_$request_line_aborted, ssu_et_$subsystem_aborted)
	fixed binary (35) external;
/* format: on */

dcl  ioa_$nnl entry () options (variable);
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$get_line entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  ssu_$abort_subsystem entry () options (variable);
dcl  ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  ssu_$get_temp_segment entry (pointer, character (*), pointer);
dcl  ssu_$release_temp_segment entry (pointer, pointer);

dcl  (program_interrupt, cleanup) condition;

dcl  (addr, maxlength, null, substr) builtin;

/**/

/* The Listener */

listen:
     entry (P_sci_ptr, P_iocb_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.standalone_invocation then do;		/*  commands simulating subsystems have no request loops */
	     P_code = ssu_et_$not_in_standalone_invocation;
	     return;
	end;

	if P_iocb_ptr = null () then			/* default I/O switch is user_input */
	     iocb_ptr = iox_$user_input;
	else iocb_ptr = P_iocb_ptr;

	saved_listener_info = sci.listener_info;	/* allow recursive listener loops */
	saved_in_listener = sci.in_listener;
	saved_executing_request = sci.executing_request;

	sci.listener_info.abort_subsystem_label = RETURN_FROM_LISTENER;

	on condition (cleanup)
	     begin;
		if sci.listener_info.temp_seg_ptr ^= null () then
		     call ssu_$release_temp_segment (sci_ptr, sci.listener_info.temp_seg_ptr);
		sci.listener_info = saved_listener_info;
		sci.in_listener = saved_in_listener;
		sci.executing_request = saved_executing_request;
	     end;

	sci.in_listener = "1"b;			/* the listener is running */

	line_buffer_ptr = addr (automatic_line_buffer);	/* start out with a "small" buffer */
	line_buffer_lth = maxlength (automatic_line_buffer);

	on condition (program_interrupt)
	     begin;
		call sci.entries.program_interrupt (sci_ptr);
						/* call the program_interrupt procedure */
		suppress_ready = "1"b;		/* no ready message, please */
		force_prompt = "1"b;		/* prompt if enabled */
		go to READ_REQUEST_LINE;
	     end;


/* The Listener Loop: only exit is via a call to ssu_$abort_subsystem */

	suppress_ready = "1"b;			/* no ready message first time through */
	force_prompt = "1"b;			/* print a prompt if enabled */
	last_line_blank, last_prompt_suppressed_by_typeahead = "0"b;

	code = 0;					/* make us do something initially */

	do while (code ^= ssu_et_$subsystem_aborted);

READ_REQUEST_LINE:
	     if suppress_ready then			/* no ready message this time through */
		suppress_ready = "0"b;
	     else if sci.ready_enabled & ^last_line_blank then call sci.entries.ready (sci_ptr);
						/* otherwise, only give ready message after non-blank lines */

	     call sci.entries.pre_request_line (sci_ptr);

	     if sci.dont_prompt then			/* never, ever prompt */
		print_prompt = "0"b;
	     else if force_prompt then do;		/* unconditonally prompt */
		print_prompt = "1"b;
		force_prompt = "0"b;
	     end;
	     else if last_line_blank then		/* previous line was null ... */
		if sci.prompt_after_null_lines | last_prompt_suppressed_by_typeahead then
		     print_prompt = "1"b;		/* ... but that shouldn't stop a prompt here */
		else print_prompt = "0"b;		/* ... and no reason to prompt after it */
	     else if sci.dont_prompt_if_typeahead then do;/* don't prompt if user already typed a request line */
		call iox_$control (iocb_ptr, "read_status", addr (read_status_info), code);
		if code = 0 then
		     if read_status_info.input_pending then do;
			print_prompt = "0"b;	/* ... something's waiting */
			last_prompt_suppressed_by_typeahead = "1"b;
		     end;				/* ... overrides blank line check */
		     else print_prompt = "1"b;	/* ... no typeahead */
		else print_prompt = "1"b;		/* ... can't check: assume prompt is OK */
	     end;
	     else print_prompt = "1"b;		/* go ahead and prompt */

	     if print_prompt then do;
		call iox_$control (iox_$user_output, "reset_more", (null ()), (0));
		call ioa_$nnl (sci.prompt, (sci.recursion_info.level ^= 1), sci.recursion_info.level);
		last_prompt_suppressed_by_typeahead = "0"b;
	     end;

	     request_line_ptr = line_buffer_ptr;	/* this is where the request ends up, of course */
	     last_line_blank = "0"b;			/* leave it off until we *** successfully *** execute */

	     call iox_$get_line (iocb_ptr, addr (line_buffer), maxlength (line_buffer), request_line_lth, code);

	     if code = error_table_$long_record then do;	/* switch to big buffer, and finish reading */
		if sci.listener_info.temp_seg_ptr ^= null () then
		     call ssu_$abort_subsystem (sci_ptr, code, "Listener already using large buffer.");
		call ssu_$get_temp_segment (sci_ptr, "listener", sci.listener_info.temp_seg_ptr);
		new_ptr = sci.listener_info.temp_seg_ptr;
						/* prepare to move what's already been read */
		new_read_ptr = addr (substr (new_ptr -> line_buffer, (request_line_lth + 1), 1));
						/* addr of next char in buffer */
		substr (new_ptr -> line_buffer, 1, request_line_lth) = substr (line_buffer, 1, request_line_lth);
						/* copy the existing data */
		line_buffer_ptr = new_ptr;		/* now, update the line buffer info */
		line_buffer_lth = 4 * sys_info$max_seg_size;
		call iox_$get_line (iocb_ptr, new_read_ptr, (line_buffer_lth - request_line_lth), new_read_lth, code);
		if code ^= 0 then			/* goodness */
		     call ssu_$abort_subsystem (sci_ptr, code, "Reading first large request line.");
		request_line_ptr = line_buffer_ptr;
		request_line_lth = request_line_lth + new_read_lth;
	     end;

	     else if code ^= 0 then			/* any other error is probably serious */
		call ssu_$abort_subsystem (sci_ptr, code, "Reading line from ^a", iocb_ptr -> iocb.name);

	     call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_lth, code);

	     last_line_blank = (code = ssu_et_$null_request_line);
						/* to control the prompt */

	     if (code ^= ssu_et_$subsystem_aborted) & (code ^= ssu_et_$request_line_aborted) then
		call sci.entries.post_request_line (sci_ptr);
	end;					/* only call user after successfully executed lines */


/* Come here after a call to ssu_$abort_subsystem */

RETURN_FROM_LISTENER:
	if sci.listener_info.temp_seg_ptr ^= null () then
	     call ssu_$release_temp_segment (sci_ptr, sci.listener_info.temp_seg_ptr);

	sci.listener_info = saved_listener_info;
	sci.in_listener = saved_in_listener;
	sci.executing_request = saved_executing_request;

	P_code = ssu_et_$subsystem_aborted;

	return;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include iocb;
%page;
%include tty_read_status_info;

     end ssu_listen_;




		    ssu_misc_procs_.pl1             08/05/87  0809.0r   08/04/87  1539.3       49158



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


/* Miscellaneous subsystem utilities */

/* Created:  by W. Olin Sibert */
/* Modified: 17 Novenber 1981 by Jay Pattin to add set/get_info_prefix */
/* Modified: February 1982 by G. Palter to move info_prefix entries to ssu_info_mgr_ */
/* Modified: June 1982 by G. Palter to move (get set)_abbrev_info to ssu_request_processor_ */

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


ssu_misc_procs_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;

dcl  P_line_ptr pointer parameter;			/* cpescape, cpescape_disabled: -> the Multics command line */
dcl  P_line_lth fixed binary (21);			/* cpescape, cpescape_disabled: length of the command line */
dcl  P_code fixed binary (35) parameter;		/* cpescape, cpescape_disabled */

dcl  P_info_ptr pointer parameter;			/* unknown_request: -> per subsystem database */
dcl  P_request_name character (*) parameter;		/* unknown_request: the request name which isn't recognized */
dcl  P_arg_list_ptr pointer parameter;			/* unknown_request: -> the arguments for the request */
dcl  P_continue_sw bit (1) aligned parameter;		/* unknown_request: set ON => continue execution of request
						   line; set OFF => abort the line */

dcl  P_prompt character (64) varying parameter;		/* set_prompt: the new ioa_ control string for prompting */

dcl  P_prompt_mode bit (*) parameter;			/* set_prompt_mode: the new prompt control flags */

dcl  P_ready_mode bit (1) aligned parameter;		/* set_ready_mode: ON => print ready messages */

dcl  P_debug_mode bit (1) aligned parameter;		/* set_debug_mode: ON => enable debugging features */


/* Remaining declarations */

dcl  sr_request_name character (32);
dcl  code fixed binary (35);

dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  cu_$ready_proc entry ();
dcl  ssu_$abort_line entry options (variable);
dcl  ssu_request_mgr_$find_request_name entry (pointer, entry, character (*), fixed binary (35));

dcl  ssu_requests_$summarize_requests entry ();

dcl  ssu_et_$cpescape_restricted fixed binary (35) external;

dcl  string builtin;

/**/

/* Default subsystem Multics command line escape processor */

cpescape:
     entry (P_sci_ptr, P_line_ptr, P_line_lth, P_code);

	call ssu_check_sci (P_sci_ptr);

	call cu_$cp (P_line_ptr, P_line_lth, (0));

	P_code = 0;				/* always successfull */

	return;



/* Procedure to use if a subsystem wishes to disallow the Multics command line escape sequence */

cpescape_disabled:
     entry (P_sci_ptr, P_line_ptr, P_line_lth, P_code);

	call ssu_check_sci (P_sci_ptr);

	P_code = ssu_et_$cpescape_restricted;
	call ssu_$abort_line (P_sci_ptr, P_code);

	return;

/**/

/* Standard processor for unknown requests */

unknown_request:
     entry (P_sci_ptr, P_info_ptr, P_request_name, P_arg_list_ptr, P_continue_sw);

	call ssu_check_sci (P_sci_ptr);

	call ssu_request_mgr_$find_request_name (P_sci_ptr, ssu_requests_$summarize_requests, sr_request_name, code);

	call ssu_$abort_line (P_sci_ptr, 0, "Unknown request ""^a"".^[  Type ""^a"" for a request list.^]",
	     P_request_name, (code = 0), sr_request_name);

	P_continue_sw = "0"b;			/* abort the request line ... */

	return;



/* Standard subsystem ready message procedure */

ready_proc:
     entry (P_sci_ptr);

	call ssu_check_sci (P_sci_ptr);

	call cu_$ready_proc ();

	return;

/**/

/* Returns the ioa_ control string used to generate the prompt for request lines */

get_prompt:
     entry (P_sci_ptr) returns (character (64) varying);

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.prompt);



/* Sets the prompt string */

set_prompt:
     entry (P_sci_ptr, P_prompt);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.prompt = P_prompt;

	return;



/* Returns the flags which control when (and if) prompts for request lines should be issued */

get_prompt_mode:
     entry (P_sci_ptr) returns (bit (36) aligned);

	call ssu_check_sci (P_sci_ptr);

	return (string (P_sci_ptr -> sci.prompt_mode));



/* Sets the prompt control flags */

set_prompt_mode:
     entry (P_sci_ptr, P_prompt_mode);

	call ssu_check_sci (P_sci_ptr);

	string (P_sci_ptr -> sci.prompt_mode) = P_prompt_mode;

	return;

/**/

/* Returns true if ready messages are to be printed after each request line */

get_ready_mode:
     entry (P_sci_ptr) returns (bit (1) aligned);

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.ready_enabled);



/* Sets/reset printing of ready messages after request lines */

set_ready_mode:
     entry (P_sci_ptr, P_ready_mode);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.ready_enabled = P_ready_mode;

	return;



/* Returns whether debugging features are enabled in this subsystem */

get_debug_mode:
     entry (P_sci_ptr) returns (bit (1) aligned);

	call ssu_check_sci (P_sci_ptr);

	return (P_sci_ptr -> sci.debug_mode);



/* Sets/resets subsystem debug mode */

set_debug_mode:
     entry (P_sci_ptr, P_debug_mode);

	call ssu_check_sci (P_sci_ptr);

	P_sci_ptr -> sci.debug_mode = P_debug_mode;

	return;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";

     end ssu_misc_procs_;




		    ssu_misc_requests_.pl1          08/05/87  0809.0r   08/04/87  1539.3      160893



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


/* Standard subsystem requests quit, self_identify (.), subsystem_name, subsystem_version, abbrev, ready, ready_on,
   ready_off, and execute; also a utility to make implementation of the apply request simpler */

/* Created:  11 May 1980 by W. Olin Sibert */
/* Modified: 14 September 1980 by W. Olin Sibert to fix bug in quit request (not copying sci_ptr) */
/* Modified: 23 July 1982 by Jay Pattin to add abbrev request */
/* Modified: 16 December 1981 by Jay Pattin to add summarize_requests and implement new definition of list_requests */
/* Modified: 12 February 1982 by G. Palter to move summarize_requests and list_requests to ssu_request_mgr_ and changed to
   call cu_$evaluate_active_string rather than cu_$af */
/* Modified: 24 February 1982 by G. Palter to add subsystem_name and subsystem_version */
/* Modified: 19 June 1982 by G. Palter to make the self_identify request work as advertised */
/* Modified: 30 July 1982 by G. Palter to make the abbrev request work as an active request by returning true/false if
   request line expansion is enabled/disabled, respectively */

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


ssu_misc_requests_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;

dcl  P_info_ptr pointer parameter;			/* all requests */

dcl  P_first_argument fixed binary parameter;		/* apply_request_util: first argument of the command line */
dcl  P_seg_ptr pointer parameter;			/* apply_request_util: -> data being manipulated */
dcl  P_input_lth fixed binary (21) parameter;		/* apply_request_util: >0 => set bit count before call */
dcl  P_output_lth fixed binary (21) parameter;		/* apply_request_util: length of data returned by call */


/* Remaining declarations  */

dcl  argument character (argument_lth) based (argument_ptr);
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  af_sw bit (1) aligned;
dcl  return_string character (return_string_lth) varying based (return_string_ptr);
dcl  return_string_lth fixed binary (21);
dcl  return_string_ptr pointer;

dcl  (arg_idx, n_arguments) fixed binary;

dcl  command_line_buffer character (2048);
dcl  command_line char (command_line_lth) based (command_line_ptr);
dcl  (command_line_lth, command_line_max_lth) fixed binary (21);
dcl  command_line_ptr pointer;

dcl  code fixed binary (35);

dcl  level fixed binary;

dcl  abbrev_switch bit (1) aligned;
dcl  (default_profile_ptr, profile_ptr) pointer;

dcl  ready_procedure entry (pointer) variable;
dcl  ready_mode bit (1) aligned;

dcl  temp_seg_ptr pointer;
dcl  temp_seg_comment character (32);

dcl  dirname character (168);
dcl  ename character (32);
dcl  pathname character (204);

dcl  seg_ptr pointer;
dcl  (old_seg_bc, new_seg_bc) fixed binary (24);

/* format: off */
dcl (error_table_$badopt, error_table_$command_line_overflow, error_table_$fatal_error, error_table_$noarg)
	fixed binary (35) external;
/* format: on */

%include cp_active_string_types;

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  cu_$evaluate_active_string entry (pointer, character (*), fixed binary, character (*) varying, fixed binary (35));
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35));
dcl  hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl  hcs_$set_bc_seg entry (pointer, fixed binary (24), fixed binary (35));
dcl  hcs_$status_mins entry (pointer, fixed binary (2), fixed binary (24), fixed binary (35));
dcl  initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl  ioa_ entry () options (variable);
dcl  pathname_ entry (character (*), character (*)) returns (character (168));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$abort_subsystem entry () options (variable);
dcl  ssu_$arg_count entry (pointer, fixed binary);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$get_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned);
dcl  ssu_$get_invocation_count entry (pointer, fixed binary, fixed binary);
dcl  ssu_$get_procedure entry (pointer, character (*), entry, fixed binary (35));
dcl  ssu_$get_request_name entry (pointer) returns (character (32));
dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying);
dcl  ssu_$get_subsystem_name entry (pointer) returns (character (32));
dcl  ssu_$get_subsystem_version entry (pointer) returns (character (32));
dcl  ssu_$get_temp_segment entry (pointer, character (*), pointer);
dcl  ssu_$release_temp_segment entry (pointer, pointer);
dcl  ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
dcl  ssu_$set_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned);
dcl  ssu_$set_debug_mode entry (pointer, bit (1) aligned);
dcl  ssu_$set_ready_mode entry (pointer, bit (1) aligned);
dcl  sub_err_ entry () options (variable);

dcl  CANT_RESTART character (1) static options (constant) initial ("s");

dcl  LONG_PDD_NAME character (32) varying static options (constant) initial (">process_dir_dir>");

dcl  cleanup condition;

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

/**/

NO_ARGS_EXIT:
	call ssu_$abort_line (sci_ptr, 0, "No arguments may be given.");



/* Abort the current subsystem */

quit:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);
	if n_arguments ^= 0 then go to NO_ARGS_EXIT;

RETRY_QUIT:
	call ssu_$abort_subsystem (sci_ptr, 0);

	call sub_err_ (error_table_$fatal_error, ssu_$get_subsystem_and_request_name (sci_ptr), CANT_RESTART, null (),
	     (0), "Attempt to abort subsystem failed.");

	go to RETRY_QUIT;				/* in case he somehow restarts */



/* Standard self-identification request */

self_identify:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);
	if n_arguments ^= 0 then go to NO_ARGS_EXIT;

	call ssu_$get_abbrev_info (sci_ptr, (null ()), (null ()), abbrev_switch);
	call ssu_$get_invocation_count (sci_ptr, level, (0));

	call ioa_ ("^a ^a^[ (abbrev)^]^[ (level ^d)^]", ssu_$get_subsystem_name (sci_ptr),
	     ssu_$get_subsystem_version (sci_ptr), abbrev_switch, (level > 1), level);

	return;

/**/

/* Standard subsystem_name request: prints/returns the name of the current subsystem */

subsystem_name:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$return_arg (sci_ptr, n_arguments, af_sw, return_string_ptr, return_string_lth);
	if n_arguments ^= 0 then go to NO_ARGS_EXIT;

	if af_sw then
	     return_string = rtrim (ssu_$get_subsystem_name (sci_ptr));
	else call ioa_ ("^a", ssu_$get_subsystem_name (sci_ptr));

	return;



/* Standard subsystem_version request: prints/returns the version of the current subsystem */

subsystem_version:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$return_arg (sci_ptr, n_arguments, af_sw, return_string_ptr, return_string_lth);
	if n_arguments ^= 0 then go to NO_ARGS_EXIT;

	if af_sw then
	     return_string = rtrim (ssu_$get_subsystem_version (sci_ptr));
	else call ioa_ ("^a", ssu_$get_subsystem_version (sci_ptr));

	return;

/**/

/* Standard abbrev request/active request:  As a request, allows the user to enable/disable abbreviation processing and
   set the profile; as an active request, returns true/false if request line expansion is enabled/disabled respectively */

abbrev:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$return_arg (sci_ptr, n_arguments, af_sw, return_string_ptr, return_string_lth);

	if af_sw then do;				/* tell user is abbrev is enabled/disabled */
	     if n_arguments ^= 0 then go to NO_ARGS_EXIT;
	     call ssu_$get_abbrev_info (sci_ptr, (null ()), (null ()), abbrev_switch);
	     if abbrev_switch then return_string = "true";
	     else return_string = "false";
	     return;
	end;

	abbrev_switch = "1"b;			/* default is to turn on abbrev with current profile */
	call ssu_$get_abbrev_info (sci_ptr, default_profile_ptr, profile_ptr, ("0"b));

	do arg_idx = 1 to n_arguments;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, argument_ptr, argument_lth);
	     if index (argument, "-") = 1 then do;
		if (argument = "-off") then abbrev_switch = "0"b;
		else if (argument = "-on") then abbrev_switch = "1"b;
		else if (argument = "-profile") then do;
		     abbrev_switch = "1"b;
		     arg_idx = arg_idx + 1;
		     call get_profile ();
		end;
		else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument);
	     end;
	     else call ssu_$abort_line (sci_ptr, 0, "Usage:  ^a {-control_args}", ssu_$get_request_name (sci_ptr));
	end;

	call ssu_$set_abbrev_info (sci_ptr, default_profile_ptr, profile_ptr, abbrev_switch);

	return;


/* Pickup and initiate the desired profile segment */

get_profile:
     procedure ();

dcl  profile_dirname character (168);
dcl  profile_ename character (32);

	if arg_idx > n_arguments then
	     call ssu_$abort_line (sci_ptr, error_table_$noarg, "Profile pathname after ""-profile"".");

	call ssu_$arg_ptr (sci_ptr, arg_idx, argument_ptr, argument_lth);

	call expand_pathname_$add_suffix (argument, "profile", profile_dirname, profile_ename, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, argument);

	call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, profile_ptr, (0), code);
	if code ^= 0 then
	     call ssu_$abort_line (sci_ptr, code, "Initiating ^a.", pathname_ (profile_dirname, profile_ename));

	return;

     end get_profile;

/**/

/* Standard request to print a ready message (actually invoke the ready procedure) */

ready:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);
	if n_arguments ^= 0 then go to NO_ARGS_EXIT;

	call ssu_$get_procedure (sci_ptr, "ready", ready_procedure, code);

	if code = 0 then				/* found the ready procedure all right */
	     call ready_procedure (sci_ptr);
	else call ssu_$abort_line (sci_ptr, code, "Attempting to invoke the ready procedure.");

	return;



/* Standard request to enable printing of ready messages after executing request lines */

ready_on:
     entry (P_sci_ptr, P_info_ptr);

	ready_mode = "1"b;
	go to READY_ON_OFF_COMMON;


/* Standard request to disable printing of ready messages after executing request lines */

ready_off:
     entry (P_sci_ptr, P_info_ptr);

	ready_mode = "0"b;
	go to READY_ON_OFF_COMMON;

READY_ON_OFF_COMMON:
	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);
	if n_arguments ^= 0 then go to NO_ARGS_EXIT;

	call ssu_$set_ready_mode (sci_ptr, ready_mode);

	return;

/**/

/* Standard request to enable/disable debug mode */

debug_mode:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);

	if n_arguments ^= 1 then
	     call ssu_$abort_line (sci_ptr, 0, "Usage: ^a [on | off]", ssu_$get_request_name (sci_ptr));

	call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth);

	if (argument = "on") | (argument = "-on") then call ssu_$set_debug_mode (sci_ptr, "1"b);
	else if (argument = "off") | (argument = "-off") then call ssu_$set_debug_mode (sci_ptr, "0"b);
	else call ssu_$abort_line (sci_ptr, 0, "Usage: ^a [on | off]", ssu_$get_request_name (sci_ptr));

	return;

/**/

/* Standard execute request: executes a Multics command line; as an active request, evaluates a Multics active string and
   returns the result to the request line processor */

execute:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$return_arg (sci_ptr, n_arguments, af_sw, return_string_ptr, return_string_lth);

	if af_sw & (n_arguments = 0) then
	     call ssu_$abort_line (sci_ptr, 0, "The ^a active request must have at least one argument.",
		ssu_$get_request_name (sci_ptr));

	command_line_ptr = addr (command_line_buffer);	/* prepare to construct it in automatic storage */
	command_line_lth = 0;
	command_line_max_lth = maxlength (command_line_buffer);

	temp_seg_ptr = null ();			/* for cleanup handler */
	temp_seg_comment = ssu_$get_request_name (sci_ptr);

	on condition (cleanup)
	     begin;
		if temp_seg_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, temp_seg_ptr);
	     end;

	do arg_idx = 1 to n_arguments;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, argument_ptr, argument_lth);

	     call add_to_command_line (argument);
	end;

	if af_sw then				/* now, do it! */
	     call cu_$evaluate_active_string (null (), command_line, NORMAL_ACTIVE_STRING, return_string, code);
	else call cu_$cp (command_line_ptr, command_line_lth, code);

	if temp_seg_ptr ^= null () then		/* if we got one, get rid of it */
	     call ssu_$release_temp_segment (sci_ptr, temp_seg_ptr);

	if code = 100 then				/* and ignore this one */
	     code = 0;

	if code ^= 0 then				/* punt the request line if it failed */
	     call ssu_$abort_line (sci_ptr, code);

	return;

/**/

/* Utility for implementing subsystem apply requests: it constructs the command line (or active string) starting with the
   specified argument, catenates the pahtname of the segment (identified by P_seg_ptr) to the line, and executes the
   command line or evaluates the active string.  If requested, the bit count of the segment will be set before execution
   and restored on completion; the character count of the segment after executing the command line will be returned */

apply_request_util:
     entry (P_sci_ptr, P_first_argument, P_seg_ptr, P_input_lth, P_output_lth);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	seg_ptr = P_seg_ptr;

	call ssu_$return_arg (sci_ptr, n_arguments, af_sw, return_string_ptr, return_string_lth);

	command_line_ptr = addr (command_line_buffer);	/* prepare to construct it in automatic storage */
	command_line_lth = 0;
	command_line_max_lth = maxlength (command_line_buffer);
	temp_seg_ptr = null ();
	temp_seg_comment = ssu_$get_request_name (sci_ptr);

	on condition (cleanup)
	     begin;
		if temp_seg_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, temp_seg_ptr);
	     end;

	call hcs_$fs_get_path_name (seg_ptr, dirname, (0), ename, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot determine pathname of temporary segment.");

	pathname = pathname_ (dirname, ename);
	if substr (pathname, 1, length (LONG_PDD_NAME)) = LONG_PDD_NAME then
	     pathname = ">pdd>" || substr (pathname, length (LONG_PDD_NAME) + 1);

	if P_input_lth >= 0 then do;			/* set the bitcount of the segment before going on */
	     call hcs_$status_mins (seg_ptr, (0), old_seg_bc, code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot get original bitcount of ^a.", pathname);
	     call hcs_$set_bc_seg (seg_ptr, (9 * P_input_lth), code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot set bitcount of ^a.", pathname);
	end;

	do arg_idx = P_first_argument to n_arguments;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, argument_ptr, argument_lth);

	     call add_to_command_line (argument);
	end;

	call add_to_command_line (pathname);		/* and add the pathname, too */

	if af_sw then				/* now, do it! */
	     call cu_$evaluate_active_string (null (), command_line, NORMAL_ACTIVE_STRING, return_string, code);
	else call cu_$cp (command_line_ptr, command_line_lth, code);

	if temp_seg_ptr ^= null () then		/* if we got one, get rid of it */
	     call ssu_$release_temp_segment (sci_ptr, temp_seg_ptr);

	if code = 100 then				/* and ignore this one */
	     code = 0;

	if code ^= 0 then				/* punt the request line if it failed */
	     call ssu_$abort_line (sci_ptr, code);

	call hcs_$status_mins (seg_ptr, (0), new_seg_bc, code);
	if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot determine bitcount of ^a.", pathname);

	P_output_lth = divide (new_seg_bc, 9, 21, 0);	/* return the new length */

	if P_input_lth >= 0 then do;			/* now, re-set the bitcount of the segment before returning */
	     call hcs_$set_bc_seg (seg_ptr, old_seg_bc, code);
	     if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot restore old bitcount of ^a.", pathname);
	end;

	return;

/**/

/* Add the string to the command line expanding into a temporary segment if necessary */

add_to_command_line:
     procedure (p_string);

dcl  p_string character (*) parameter;
dcl  str_lth fixed binary (21);

	str_lth = length (p_string);

	if (command_line_lth + str_lth + 1) > command_line_max_lth then do;
	     if temp_seg_ptr ^= null () then call ssu_$abort_line (sci_ptr, error_table_$command_line_overflow);
	     call ssu_$get_temp_segment (sci_ptr, temp_seg_comment, temp_seg_ptr);

	     temp_seg_ptr -> command_line = command_line; /* copy what we already have */
	     command_line_ptr = temp_seg_ptr;		/* and then update the command_line_XXX values */
	     command_line_max_lth = 4 * sys_info$max_seg_size;
	end;

	if command_line_lth > 0 then do;		/* put a space between tokens */
	     command_line_lth = command_line_lth + 1;
	     substr (command_line, command_line_lth, 1) = " ";
	end;

	substr (command_line, command_line_lth + 1, str_lth) = p_string;
	command_line_lth = command_line_lth + str_lth;	/* copy in the argument */

	return;

     end add_to_command_line;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include access_mode_values;

     end ssu_misc_requests_;




		    ssu_procedure_mgr_.pl1          08/05/87  0809.0r   08/04/87  1539.3      113328



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


/* Manages the subsystem utilities (ssu_) replaceable procedures */

/* Created:  by W. Olin Sibert */
/* Modified: 10 December 1981 by G. Palter to make arg_count, arg_ptr, return_arg, and arg_list_ptr replaceable */
/* Modified: 14 February 1982 by G. Palter to rename eval_string to evaluate_active_string */
/* Modified: 8 June 1982 by G. Palter to add (get set reset)_request_processor_options and get_default_rp_options */
/* Modified: 6 November 1984 by G. Palter to add get_subsystem_and_request_name */

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


ssu_procedure_mgr_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_proc_name character (*) parameter;
dcl  P_entry_variable entry variable parameter;
dcl  P_code fixed binary (35) parameter;


/* Remaining declarations */

dcl  proc_idx fixed binary;

dcl  error_table_$noentry fixed binary (35) external;

/* format: off */

dcl (ssu_error_$abort_line, ssu_error_$abort_subsystem, ssu_error_$print_message, ssu_misc_procs_$cpescape,
     ssu_misc_procs_$unknown_request, ssu_listen_$listen, ssu_request_processor_$execute_line,
     ssu_request_processor_$evaluate_active_string, ssu_execute_$execute_request, ssu_request_mgr_$locate_request,
     ssu_$just_return, ssu_misc_procs_$ready_proc, ssu_arglist_$arg_count, ssu_arglist_$arg_ptr, ssu_arglist_$return_arg,
     ssu_arglist_$arg_list_ptr, ssu_request_processor_$get_default_rp_options, ssu_request_processor_$get_rp_options,
     ssu_request_processor_$reset_rp_options, ssu_request_processor_$set_rp_options,
     ssu_invocation_$get_subsystem_and_request_name)
	entry () options (variable);

dcl  PROC_NAME (23) character (32) static options (constant) initial (
	"abort_line",	     "abort_subsystem",	     "print_message",	     "program_interrupt",
	"pre_request_line",	     "post_request_line",	     "ready",		     "cpescape",
	"unknown_request",	     "listen",		     "execute_line",	     "evaluate_active_string",
	"invoke_request",	     "locate_request",	     "arg_count",		     "arg_ptr",
	"return_arg",	     "arg_list_ptr",	     "get_default_rp_options",     "get_request_processor_options",
	"reset_request_processor_options",		     "set_request_processor_options",
	"get_subsystem_and_request_name");

/* format: on */

dcl  hbound builtin;

/**/

/* Returns the entry which would be invoked by the specified replaceable ssu_ entry */

get:
     entry (P_sci_ptr, P_proc_name, P_entry_variable, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call lookup_proc_name (P_proc_name, proc_idx, P_code);
	if P_code ^= 0 then return;			/* not found */

	call get_or_set_entry (proc_idx, "0"b, P_entry_variable);

	return;



/* Sets the entry to be invoked by the specified replaceable ssu_ entry */

set:
     entry (P_sci_ptr, P_proc_name, P_entry_variable, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call lookup_proc_name (P_proc_name, proc_idx, P_code);
	if P_code ^= 0 then return;			/* not found */

	call get_or_set_entry (proc_idx, "1"b, P_entry_variable);

	return;

/**/

/* Returns the default entry for the specified replaceable ssu_ entry */

get_default:
     entry (P_sci_ptr, P_proc_name, P_entry_variable, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call lookup_proc_name (P_proc_name, proc_idx, P_code);
	if P_code ^= 0 then return;			/* not found */

	P_entry_variable = get_default_entry (proc_idx);

	return;



/* Sets the specified ssu_ replaceable entry to its default value */

set_default:
     entry (P_sci_ptr, P_proc_name, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call lookup_proc_name (P_proc_name, proc_idx, P_code);
	if P_code ^= 0 then return;			/* not found */

	call get_or_set_entry (proc_idx, "1"b, get_default_entry (proc_idx));

	return;



/* Sets all replaceable entries to the default values (called during initialization only) */

set_all_default:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	do proc_idx = 1 to hbound (PROC_NAME, 1);	/* loop through them all */
	     call get_or_set_entry (proc_idx, "1"b, get_default_entry (proc_idx));
	end;

	return;

/**/

/* Validates that the caller's procedure name is valid and returns its index */

lookup_proc_name:
     procedure (p_name, p_idx, p_code);

dcl  p_name character (*) parameter;
dcl  p_idx fixed binary parameter;
dcl  p_code fixed binary (35) parameter;

dcl  idx fixed binary;
dcl  proc_name character (32);

	proc_name = p_name;

	do idx = 1 to hbound (PROC_NAME, 1);
	     if proc_name = PROC_NAME (idx) then do;
		p_code = 0;			/* found it */
		p_idx = idx;
		return;
	     end;
	end;

	p_idx = -1;
	p_code = error_table_$noentry;

	return;

     end lookup_proc_name;

/**/

/* Returns the default entry variable for handling the specified operation */

get_default_entry:
     procedure (p_index) returns (entry () options (variable) variable);

dcl  p_index fixed binary parameter;
dcl  return_entry entry () options (variable) variable;

	go to GET_DEFAULT (p_index);			/* do it */


GET_DEFAULT_DONE:					/* and "return" here when done. Oh, if only we had subscripted */
	return (return_entry);			/* internal procedures..... */


GET_DEFAULT (1):					/* individual handlers */
	return_entry = ssu_error_$abort_line;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (2):					/* abort_subsystem */
	return_entry = ssu_error_$abort_subsystem;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (3):					/* print_message */
	return_entry = ssu_error_$print_message;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (4):					/* program_interrupt */
	return_entry = ssu_$just_return;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (5):					/* pre_request_line */
	return_entry = ssu_$just_return;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (6):					/* post_request_line */
	return_entry = ssu_$just_return;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (7):					/* ready */
	return_entry = ssu_misc_procs_$ready_proc;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (8):					/* cpescape */
	return_entry = ssu_misc_procs_$cpescape;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (9):					/* unknown_request */
	return_entry = ssu_misc_procs_$unknown_request;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (10):					/* listen */
	return_entry = ssu_listen_$listen;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (11):					/* execute_line */
	return_entry = ssu_request_processor_$execute_line;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (12):					/* evaluate_active_string */
	return_entry = ssu_request_processor_$evaluate_active_string;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (13):					/* invoke_request */
	return_entry = ssu_execute_$execute_request;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (14):					/* locate_request */
	return_entry = ssu_request_mgr_$locate_request;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (15):					/* arg_count */
	return_entry = ssu_arglist_$arg_count;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (16):					/* arg_ptr */
	return_entry = ssu_arglist_$arg_ptr;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (17):					/* return_arg */
	return_entry = ssu_arglist_$return_arg;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (18):					/* arg_list_ptr */
	return_entry = ssu_arglist_$arg_list_ptr;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (19):					/* get_default_rp_options */
	return_entry = ssu_request_processor_$get_default_rp_options;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (20):					/* get_request_processor_options */
	return_entry = ssu_request_processor_$get_rp_options;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (21):					/* reset_request_processor_options */
	return_entry = ssu_request_processor_$reset_rp_options;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (22):					/* set_request_processor_options */
	return_entry = ssu_request_processor_$set_rp_options;
	go to GET_DEFAULT_DONE;

GET_DEFAULT (23):					/* get_subsystem_and_request_name */
	return_entry = ssu_invocation_$get_subsystem_and_request_name;
	go to GET_DEFAULT_DONE;

     end get_default_entry;

/**/

/* Get or set the specified replaceable entry */

get_or_set_entry:
     proc (p_index, p_set_sw, p_entry_variable);

dcl  p_index fixed binary parameter;
dcl  p_set_sw bit (1) aligned parameter;
dcl  p_entry_variable entry () options (variable) variable parameter;

	go to GET_OR_SET (p_index);

GET_OR_SET_DONE:					/* "return" to here */
	return;


GET_OR_SET (1):					/* individual handlers */
	if p_set_sw then
	     sci.entries.abort_line = p_entry_variable;
	else p_entry_variable = sci.entries.abort_line;
	go to GET_OR_SET_DONE;

GET_OR_SET (2):
	if p_set_sw then
	     sci.entries.abort_subsystem = p_entry_variable;
	else p_entry_variable = sci.entries.abort_subsystem;
	go to GET_OR_SET_DONE;

GET_OR_SET (3):
	if p_set_sw then
	     sci.entries.print_message = p_entry_variable;
	else p_entry_variable = sci.entries.print_message;
	go to GET_OR_SET_DONE;

GET_OR_SET (4):
	if p_set_sw then
	     sci.entries.program_interrupt = p_entry_variable;
	else p_entry_variable = sci.entries.program_interrupt;
	go to GET_OR_SET_DONE;

GET_OR_SET (5):
	if p_set_sw then
	     sci.entries.pre_request_line = p_entry_variable;
	else p_entry_variable = sci.entries.pre_request_line;
	go to GET_OR_SET_DONE;

GET_OR_SET (6):
	if p_set_sw then
	     sci.entries.post_request_line = p_entry_variable;
	else p_entry_variable = sci.entries.post_request_line;
	go to GET_OR_SET_DONE;

GET_OR_SET (7):
	if p_set_sw then
	     sci.entries.ready = p_entry_variable;
	else p_entry_variable = sci.entries.ready;
	go to GET_OR_SET_DONE;

GET_OR_SET (8):
	if p_set_sw then
	     sci.entries.cpescape = p_entry_variable;
	else p_entry_variable = sci.entries.cpescape;
	go to GET_OR_SET_DONE;

GET_OR_SET (9):
	if p_set_sw then
	     sci.entries.unknown_request = p_entry_variable;
	else p_entry_variable = sci.entries.unknown_request;
	go to GET_OR_SET_DONE;

GET_OR_SET (10):
	if p_set_sw then
	     sci.entries.listen = p_entry_variable;
	else p_entry_variable = sci.entries.listen;
	go to GET_OR_SET_DONE;

GET_OR_SET (11):
	if p_set_sw then
	     sci.entries.execute_line = p_entry_variable;
	else p_entry_variable = sci.entries.execute_line;
	go to GET_OR_SET_DONE;

GET_OR_SET (12):
	if p_set_sw then
	     sci.entries.evaluate_active_string = p_entry_variable;
	else p_entry_variable = sci.entries.evaluate_active_string;
	go to GET_OR_SET_DONE;

GET_OR_SET (13):
	if p_set_sw then
	     sci.entries.invoke_request = p_entry_variable;
	else p_entry_variable = sci.entries.invoke_request;
	go to GET_OR_SET_DONE;

GET_OR_SET (14):
	if p_set_sw then
	     sci.entries.locate_request = p_entry_variable;
	else p_entry_variable = sci.entries.locate_request;
	go to GET_OR_SET_DONE;

GET_OR_SET (15):
	if p_set_sw then
	     sci.entries.arg_count = p_entry_variable;
	else p_entry_variable = sci.entries.arg_count;
	go to GET_OR_SET_DONE;

GET_OR_SET (16):
	if p_set_sw then
	     sci.entries.arg_ptr = p_entry_variable;
	else p_entry_variable = sci.entries.arg_ptr;
	go to GET_OR_SET_DONE;

GET_OR_SET (17):
	if p_set_sw then
	     sci.entries.return_arg = p_entry_variable;
	else p_entry_variable = sci.entries.return_arg;
	go to GET_OR_SET_DONE;

GET_OR_SET (18):
	if p_set_sw then
	     sci.entries.arg_list_ptr = p_entry_variable;
	else p_entry_variable = sci.entries.arg_list_ptr;
	go to GET_OR_SET_DONE;

GET_OR_SET (19):
	if p_set_sw then
	     sci.entries.get_default_rp_options = p_entry_variable;
	else p_entry_variable = sci.entries.get_default_rp_options;
	go to GET_OR_SET_DONE;

GET_OR_SET (20):
	if p_set_sw then
	     sci.entries.get_rp_options = p_entry_variable;
	else p_entry_variable = sci.entries.get_rp_options;
	go to GET_OR_SET_DONE;

GET_OR_SET (21):
	if p_set_sw then
	     sci.entries.reset_rp_options = p_entry_variable;
	else p_entry_variable = sci.entries.reset_rp_options;
	go to GET_OR_SET_DONE;

GET_OR_SET (22):
	if p_set_sw then
	     sci.entries.set_rp_options = p_entry_variable;
	else p_entry_variable = sci.entries.set_rp_options;
	go to GET_OR_SET_DONE;

GET_OR_SET (23):
	if p_set_sw then
	     sci.entries.get_subsys_and_request_name = p_entry_variable;
	else p_entry_variable = sci.entries.get_subsys_and_request_name;
	go to GET_OR_SET_DONE;

     end get_or_set_entry;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";

     end ssu_procedure_mgr_;




		    ssu_request_mgr_.pl1            08/05/87  0809.0r   08/04/87  1539.3      407601



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


/* Subsystem request table management: includes entries to manipulate the list of request tables used by the subsystem,
   entries to search the request tables, and the summarize_requests and list_requests request */

/* Created:  3 May 1980 by W. Olin Sibert from subsystem_request_mgr_ */
/* Modified: 16 December 1981 by Jay Pattin for new list_requests and to add summarize_requests and find_request_name */
/* Modified: 12 February 1982 by G. Palter to merge in the actual code of the list/summarize_requests requests which were
   moved from ssu_misc_requests */
/* Modified: 28 February 1982 by G. Palter for new output format for list_requests and the dont_summarize and dont_list
   request table flags */
/* Modified: 2 August 1982 by Jay Pattin for unknown requests and to eliminate the listing of duplicate request names
   in list_requests and summarize_requests */
/* Modified: 22 August 1982 by Jay Pattin to make request tables into a hash table */

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


ssu_request_mgr_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_code fixed binary (35) parameter;

dcl  P_rqt_ptr pointer parameter;			/* add_request_table, delete_request_table: -> the table */
dcl  P_position fixed binary parameter;			/* add_request_table: where to place the table in the list */

dcl  P_rtl_ptr pointer parameter;			/* list_request_tables, set_requests_tables: -> the list */
dcl  P_callers_area_ptr pointer parameter;		/* list_request_tables: -> area where list is allocated */
dcl  P_request_tables_list_version fixed binary parameter;	/* list_request_tables: version of the list user expects */

dcl  P_request_name character (*) parameter;		/* locate_request, find_request_name: a request name */
dcl  P_request_data_ptr pointer parameter;		/* locate_request: -> request_data structure to be filled in */
dcl  P_request_entry entry variable parameter;		/* find_request_name: the request whose name is desired */

dcl  P_info_ptr pointer parameter;			/* summarize_requests, list_requests */


/* The list of request tables being used by this subsystem */

dcl  1 request_tables aligned based (sci.request_tables_ptr),
       2 n_tables fixed binary,
       2 pad bit (36),
       2 hash_table_ptr pointer,
       2 tables (request_tables_n_tables refer (request_tables.n_tables)) like request_tables_list.tables;

dcl  1 hash_table aligned based (request_tables.hash_table_ptr),
       2 n_slots fixed binary,
       2 chains (2000) fixed binary,			/* the actual hash table: first slot in each chain */
       2 slots (0 refer (hash_table.n_slots)),
         3 name character (32),
         3 rq_data_ptr pointer,
         3 first_name_switch bit (1) aligned,		/* ON => first unique name for this request */
         3 next_slot fixed binary;

dcl  request_tables_n_tables fixed binary;
dcl  new_request_tables_ptr pointer;


/* Local copies of parameters */

dcl  code fixed binary (35);

dcl  position fixed binary;

dcl  callers_area area based (callers_area_ptr);
dcl  callers_area_ptr pointer;

dcl  request_name character (32);


/* Remaining declarations */

dcl  1 summary_info aligned based (summary_info_ptr),
       2 total_lines fixed binary,
       2 print_line (0 refer (summary_info.total_lines)),
         3 continuation bit (1) aligned,
         3 line char (36) varying;
dcl  summary_info_ptr ptr;

dcl  1 entry_variable aligned,			/* internal representation of an entry variable */
       2 code_ptr pointer,
       2 env_ptr pointer;

dcl  1 fdo aligned like format_document_options;

dcl  output_buffer character (4 * sys_info$max_seg_size) based (output_buffer_ptr);
dcl  output_buffer_ptr pointer;

dcl  (lh_request_name, help_request_name) character (32);

dcl  code2 fixed binary (35);

dcl  (n_arguments, max_request_strings) fixed binary;

dcl  (entry1, entry2) entry variable;

dcl  (rqt_idx, rq_idx, idx, jdx) fixed binary;
dcl  (one_name_size, two_name_size, max_name_size) fixed binary;
dcl  line_length fixed binary;

dcl  (columns, col_len, this_line, lines_per_col) fixed binary;
dcl  col_offset (0:5) fixed binary;

dcl  (match, found_bad_table) bit (1) aligned;

dcl  SUMMARIZE_REQUESTS character (32) static options (constant) initial ("summarize_requests");
dcl  LIST_REQUESTS character (32) static options (constant) initial ("list_request");
dcl  SSU_REQUEST_MGR_ character (32) static options (constant) initial ("ssu_request_mgr_");

dcl  WHITESPACE character (2) static options (constant) initial (" 	");

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

dcl  DELIMITERS character (5) static options (constant) initial (" .-_$");
						/* break chars for request name matching */

dcl  sys_info$max_seg_size fixed binary (19) external;

/* format: off */
dcl (error_table_$badopt, error_table_$inconsistent, error_table_$noalloc, error_table_$noarg,
     error_table_$unimplemented_version, ssu_et_$blank_request_name, ssu_et_$no_matching_requests,
     ssu_et_$invalid_request_table, ssu_et_$request_name_too_long, ssu_et_$request_not_found,
     ssu_et_$request_table_not_found, ssu_et_$unimplemented_request, ssu_et_$unknown_request)
	fixed binary (35) external;
/* format: on */

dcl  iox_$user_output pointer external;

dcl  format_document_$string entry (character (*), character (*), fixed binary (21), pointer, fixed binary (35));
dcl  get_line_length_$switch entry (pointer, fixed binary (35)) returns (fixed binary);
dcl  get_ring_ entry () returns (fixed binary (3));
dcl  hash_index_ entry (pointer, fixed binary, fixed binary, fixed binary) returns (fixed binary);
dcl  hcs_$combine_linkage entry (pointer, fixed binary (3), fixed binary (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$nnl entry () options (variable);
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$arg_count entry (pointer, fixed binary);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$get_default_procedure entry (pointer, character (*), entry, fixed binary (35));
dcl  ssu_$get_procedure entry (pointer, character (*), entry, fixed binary (35));
dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying);
dcl  ssu_$get_temp_segment entry (pointer, character (*), pointer);
dcl  ssu_$print_message entry () options (variable);
dcl  ssu_$release_temp_segment entry (pointer, pointer);

/* format: off */
dcl (ssu_requests_$help, ssu_requests_$list_help, ssu_requests_$list_requests)
	entry ();
/* format: on */

dcl  (area, cleanup, linkage_error) condition;

dcl  (addr, addrel, baseno, binary, codeptr, divide, environmentptr, index, length, ltrim, max, maxlength, min, mod, null,
     pointer, rtrim, stackframeptr, substr, unspec, verify) builtin;
%page;
/* Initialize the list of request tables (invoked by ssu_invocation_) */

init_request_tables:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	sci.request_tables_ptr = null ();

	return;



/* Release the request tables list (invoked from ssu_invocation_) */

term_request_tables:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.request_tables_ptr ^= null () then do;
	     if request_tables.hash_table_ptr ^= null () then
		call ssu_$release_temp_segment (sci_ptr, request_tables.hash_table_ptr);
	     free request_tables in (sci_parent_area);
	end;

	sci.request_tables_ptr = null ();

	return;
%page;
/* Add a request table to the list used by this subsystem */

add_request_table:
     entry (P_sci_ptr, P_rqt_ptr, P_position, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	P_code = 0;				/* assume success */

	call validate_request_table (P_rqt_ptr, code);
	if code ^= 0 then do;
	     P_code = code;
	     return;
	end;

	if sci.request_tables_ptr = null () then
	     request_tables_n_tables = 1;
	else request_tables_n_tables = request_tables.n_tables + 1;

	new_request_tables_ptr = null ();		/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if new_request_tables_ptr ^= null () then
		     free new_request_tables_ptr -> request_tables in (sci_parent_area);
	     end;

	allocate request_tables in (sci_parent_area) set (new_request_tables_ptr);

	if sci.request_tables_ptr = null () then position = 1;
						/* first table */
	else if P_position > request_tables.n_tables then position = request_tables.n_tables + 1;
						/* add to the end of the list */
	else if P_position <= 0 then position = 1;	/* add to the beginning */
	else position = P_position;			/* add in an explicit place */

	do idx = 1 to position - 1;
	     new_request_tables_ptr -> request_tables.tables (idx) = request_tables.tables (idx);
	end;
	new_request_tables_ptr -> request_tables.tables (position).table_ptr = P_rqt_ptr;
	new_request_tables_ptr -> request_tables.tables (position).table_valid = "1"b;

	do idx = position + 1 to new_request_tables_ptr -> request_tables.n_tables;
	     new_request_tables_ptr -> request_tables.tables (idx) = request_tables.tables (idx - 1);
	end;

	call build_hash_table ();			/* this will swap rtl_ptr in sci and free old copy */

	return;
%page;
/* Delete a request table from the list used by this subsystem */

delete_request_table:
     entry (P_sci_ptr, P_rqt_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	match = "0"b;				/* haven't found it yet */

	if sci.request_tables_ptr = null () then
	     P_code = ssu_et_$request_table_not_found;

	else do;
	     do idx = 1 to request_tables.n_tables while (^match);
		if request_tables.tables (idx).table_ptr = P_rqt_ptr then match = "1"b;
	     end;

	     if match then do;			/* found it: idx identifies next entry in list */
		if request_tables.n_tables = 1 then do;
		     if request_tables.hash_table_ptr ^= null () then
			call ssu_$release_temp_segment (sci_ptr, request_tables.hash_table_ptr);
		     free request_tables in (sci_parent_area);
		     sci.request_tables_ptr = null ();
		end;
		else do;
		     new_request_tables_ptr = null ();

		     on condition (cleanup)
			begin;
			     if new_request_tables_ptr ^= null () then
				free new_request_tables_ptr -> request_tables in (sci_parent_area);
			end;

		     request_tables_n_tables = request_tables.n_tables - 1;
		     allocate request_tables in (sci_parent_area) set (new_request_tables_ptr);
		     do jdx = 1 to idx - 2;
			new_request_tables_ptr -> request_tables.tables (jdx) = request_tables.tables (jdx);
		     end;
		     do jdx = idx to request_tables.n_tables;
			new_request_tables_ptr -> request_tables.tables (jdx - 1) = request_tables.tables (jdx);
		     end;

		     call build_hash_table ();	/* recompute hash table */
		end;
		P_code = 0;			/* success */
	     end;
	     else P_code = ssu_et_$request_table_not_found;
	end;

	return;
%page;
/* Return the list of request tables used by this subsystem */

list_request_tables:
     entry (P_sci_ptr, P_callers_area_ptr, P_request_tables_list_version, P_rtl_ptr, P_code);

	if P_request_tables_list_version ^= REQUEST_TABLES_LIST_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	callers_area_ptr = P_callers_area_ptr;

	on condition (area)
	     begin;
		P_code = error_table_$noalloc;
		go to RETURN_FROM_LIST_REQUEST_TABLES;
	     end;

	if sci.request_tables_ptr ^= null () then
	     request_tables_list_n_tables = request_tables.n_tables;
	else request_tables_list_n_tables = 0;		/* there are no request tables: return an empty list */

	allocate request_tables_list in (callers_area) set (rtl_ptr);

	request_tables_list.version = REQUEST_TABLES_LIST_VERSION_1;

	if sci.request_tables_ptr ^= null () then
	     do idx = 1 to request_tables.n_tables;
	     request_tables_list.tables (idx) = request_tables.tables (idx);
	end;

	P_rtl_ptr = rtl_ptr;
	P_code = 0;				/* success */

RETURN_FROM_LIST_REQUEST_TABLES:
	return;
%page;
/* Replace the list of request tables with that supplied by the caller */

set_request_tables:
     entry (P_sci_ptr, P_rtl_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	rtl_ptr = P_rtl_ptr;

	if request_tables_list.version ^= REQUEST_TABLES_LIST_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	found_bad_table = "0"b;			/* assume user's list is OK */

	do idx = 1 to request_tables_list.n_tables;
	     request_tables_list.tables (idx).table_valid = "1"b;
	     call validate_request_table (request_tables_list.tables (idx).table_ptr, code);
	     if code ^= 0 then do;			/* not a request table */
		if ^found_bad_table then P_code = code;
		found_bad_table = "1"b;		/* remember reason for the first bad table */
		request_tables_list.tables (idx).table_valid = "0"b;
	     end;
	end;

	if found_bad_table then return;		/* return code is already set */

	request_tables_n_tables = request_tables_list.n_tables;

	new_request_tables_ptr = null ();

	on condition (cleanup)
	     begin;
		if new_request_tables_ptr ^= null () then
		     free new_request_tables_ptr -> request_tables in (sci_parent_area);
	     end;

	allocate request_tables in (sci_parent_area) set (new_request_tables_ptr);

	do idx = 1 to new_request_tables_ptr -> request_tables.n_tables;
	     new_request_tables_ptr -> request_tables.tables (idx) = request_tables_list.tables (idx);
	end;

	call build_hash_table ();

	P_code = 0;				/* success */

	return;
%page;
/* Validate that the caller has a real request table */

validate_request_table:
     procedure (p_rqt_ptr, p_code);

dcl  p_rqt_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

	if (substr (unspec (p_rqt_ptr), 31, 6) ^= "43"b3) then p_code = ssu_et_$invalid_request_table;

	else if (p_rqt_ptr = null ()) then p_code = ssu_et_$invalid_request_table;

	else if (p_rqt_ptr -> rqt.version ^= RQT_VERSION_4) then p_code = ssu_et_$invalid_request_table;

	else p_code = 0;				/* it passes */

	return;

     end validate_request_table;
%page;
/* Makes a hash table of all the request names for fast lookup */

build_hash_table:
     procedure ();

dcl  (old_request_tables_ptr, new_hash_table_ptr) pointer;
dcl  first_name_switch bit (1) aligned;

	new_hash_table_ptr = null ();			/* for cleanup handler */

	on condition (cleanup)
	     begin;
		if new_hash_table_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, new_hash_table_ptr);
	     end;

	call ssu_$get_temp_segment (sci_ptr, SSU_REQUEST_MGR_, new_hash_table_ptr);

	do rqt_idx = 1 to new_request_tables_ptr -> request_tables.n_tables;
	     if new_request_tables_ptr -> request_tables.tables (rqt_idx).table_valid then do;
		rqt_ptr = new_request_tables_ptr -> request_tables.tables (rqt_idx).table_ptr;
		do rq_idx = 1 to rqt.n_requests;
		     rq_data_ptr = addr (rqt.requests (rq_idx));
		     request_name_list_ptr = pointer (rqt_ptr, rq_data.namelist_loc);
		     first_name_switch = "1"b;
		     do idx = 1 to request_name_list.n_names;
			call check_one_name (request_name_list.name (idx));
		     end;
		end;
	     end;
	end;

	old_request_tables_ptr = sci.request_tables_ptr;

	new_request_tables_ptr -> request_tables.hash_table_ptr = new_hash_table_ptr;
	sci.request_tables_ptr = new_request_tables_ptr;	/* switch to new tables */
	new_request_tables_ptr, new_hash_table_ptr = null ();
						/* don't let the cleanup handlers at now permanent tables */

	if old_request_tables_ptr ^= null () then do;	/* get rid of old request tables list */
	     if old_request_tables_ptr -> request_tables.hash_table_ptr ^= null then
		call ssu_$release_temp_segment (sci_ptr, old_request_tables_ptr -> request_tables.hash_table_ptr);
	     free old_request_tables_ptr -> request_tables in (sci_parent_area);
	end;

	return;
%page;
/* Internal to build_hash_table: checks the given name */

check_one_name:
	procedure (this_name);

dcl  this_name character (32);
dcl  (chain_idx, slot_idx) fixed binary;

	     chain_idx = hash_index_ (addr (this_name), length (rtrim (this_name)), 0, 2000) + 1;

	     do slot_idx = new_hash_table_ptr -> hash_table.chains (chain_idx)
		repeat new_hash_table_ptr -> hash_table.slots.next_slot (slot_idx) while (slot_idx ^= 0);
		if new_hash_table_ptr -> hash_table.slots (slot_idx).name = this_name then return;
	     end;

	     new_hash_table_ptr -> hash_table.n_slots, slot_idx = new_hash_table_ptr -> hash_table.n_slots + 1;
						/* here iff its unique */

	     new_hash_table_ptr -> hash_table.slots (slot_idx).name = this_name;
	     new_hash_table_ptr -> hash_table.slots (slot_idx).rq_data_ptr = rq_data_ptr;
	     new_hash_table_ptr -> hash_table.slots (slot_idx).first_name_switch = first_name_switch;
	     first_name_switch = "0"b;		/* have definitely made first entry for this request */

	     new_hash_table_ptr -> hash_table.slots (slot_idx).next_slot =
		new_hash_table_ptr -> hash_table.chains (chain_idx);
	     new_hash_table_ptr -> hash_table.chains (chain_idx) = slot_idx;

	     return;

	end check_one_name;

     end build_hash_table;
%page;
/* Lookup a request and return all available information on it from the request table */

locate_request:
     entry (P_sci_ptr, P_request_name, P_request_data_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	request_name = P_request_name;
	request_data_ptr = P_request_data_ptr;

	rq_data_ptr = lookup_request (request_name);	/* find name in request tables */

	if code ^= 0 then do;			/* couldn't find it */
	     P_code = code;
	     return;
	end;

	request_name_list_ptr = pointer (rq_data_ptr, rq_data.namelist_loc);
						/* copy all the so-called "permanent" info */
	request_data.full_name = request_name_list.name (1);
	request_data.name_list_ptr = request_name_list_ptr;

	request_data.info_string.ptr = pointer (rq_data_ptr, rq_data.info_string.loc);
	request_data.info_string.lth = rq_data.info_string.lth;

	request_data.flags = rq_data.flags;
	unspec (request_data.pad) = ""b;

	request_data.call_info.arg_list_ptr = null ();	/* fill this in as blank */
	request_data.call_info.arg_count = 0;
	request_data.call_info.af_sw = "0"b;
	request_data.call_info.rv_ptr = null ();
	request_data.call_info.rv_lth = 0;

	if rq_data.unknown then			/* catch unknown requests */
	     P_code = ssu_et_$unknown_request;
	else if rq_data.unimplemented then		/* catch unimplemented requests */
	     P_code = ssu_et_$unimplemented_request;

	else do;					/* see if we can actually access it */
	     entry_variable.code_ptr = pointer (rq_data_ptr, rq_data.code_loc);
						/* find the procedure */
	     entry_variable.env_ptr = null ();		/* always an external procedure */
	     unspec (request_data.entry) = unspec (entry_variable);
	     P_code = 0;				/* success */
	end;

	return;
%page;
/* Scans the list of request tables for the specified request name */

lookup_request:
     procedure (request_name) returns (pointer);

dcl  request_name character (32);
dcl  (chain_idx, slot_idx) fixed binary;

	if sci.request_tables_ptr = null () then do;	/* no request tables: can't have any requests */
	     code = ssu_et_$unknown_request;
	     return (null ());
	end;

	if length (ltrim (rtrim (request_name, WHITESPACE), WHITESPACE)) > 32 then do;
	     code = ssu_et_$request_name_too_long;
	     return (null ());
	end;

	if verify (request_name, WHITESPACE) = 0 then do;
	     code = ssu_et_$blank_request_name;
	     return (null ());
	end;

	chain_idx = hash_index_ (addr (request_name), length (rtrim (request_name)), 0, 2000) + 1;

	do slot_idx = hash_table.chains (chain_idx) repeat hash_table.slots.next_slot (slot_idx) while (slot_idx ^= 0);
	     if hash_table.slots (slot_idx).name = request_name then do;
		code = 0;
		return (hash_table.slots (slot_idx).rq_data_ptr);
	     end;
	end;

	code = ssu_et_$unknown_request;		/* didn't find it */
	return (null ());

     end lookup_request;
%page;
/* Given an entry variable, returns the primary name of the request which that entry represents (if any) */

find_request_name:
     entry (P_sci_ptr, P_request_entry, P_request_name, P_code);

	sci_ptr = P_sci_ptr;

	call find_request_name_subr (P_request_entry, P_request_name, P_code);

	return;



/* Internal procedure which does all the work (called from the summarize_requests and list_requests requests) */

find_request_name_subr:
     procedure (p_request_entry, p_request_name, p_code);

dcl  p_request_entry entry variable parameter;
dcl  p_request_name character (*) parameter;
dcl  p_code fixed binary (35) parameter;

	if sci.request_tables_ptr = null () then do;	/* no request tables */
	     p_request_name = "";
	     p_code = ssu_et_$request_not_found;
	     return;
	end;

	do rqt_idx = 1 to request_tables.n_tables;	/* loop through all tables */
	     if request_tables.tables (rqt_idx).table_valid then do;
						/* ... it's a good table */
		rqt_ptr = request_tables.tables (rqt_idx).table_ptr;
		if find_request_name_in_table (p_request_entry, p_request_name) then do;
		     p_code = 0;			/* found a match here */
		     return;
		end;
	     end;
	end;

	p_request_name = "";			/* here iff the request wasn't found anywhere */
	p_code = ssu_et_$request_not_found;

	return;
%page;
/* Internal to find_request_name_subr: search a single request table for the given entry variable */

/* format: off */

/* Each request table entry contains the offset of a code sequence of the form:
	epaq	*
	lprp4	7|stack_header.lot_ptr,*au
	call6	4|link_offset,*

   If the request procedure and the request table have been bound together, the last instruction above will be simply:
      call6	procedure_offset

   In order to compare the caller's entry variable, we need to look at the link (which we might snap when we reference it)
   as it is the link that is the actual entry invoked.  In order to look at the link, we need a pointer to the linkage of
   the request table; if necessary, we will combine the request table's linkage.  Ugh! */

/* format: on */

find_request_name_in_table:
	procedure (p_request_entry, p_request_name) returns (bit (1) aligned);

dcl  p_request_entry entry variable parameter;
dcl  p_request_name character (*) parameter;

dcl  1 lot aligned based (stack_header.lot_ptr),		/* the LOT */
       2 lot_pointers (0:stack_header.cur_lot_size - 1) pointer unaligned;

dcl  1 lot_pointer aligned based (lot_pointer_ptr),	/* have to check for lot faults ... */
       2 lot_fault bit (3) unaligned,
       2 mbz bit (27) unaligned;
dcl  lot_pointer_ptr pointer;
dcl  linkage_ptr pointer;

dcl  1 code_sequence aligned based (cs_ptr),
       2 epaq_lprp4 bit (72),				/* don't actually reference these two */
       2 call6,
         3 link_offset bit (18) unaligned,
         3 op_code_and_modifiers bit (18) unaligned;
dcl  cs_ptr pointer;

dcl  (
     CALL6_ABSOLUTE initial ("713000"b3),		/* call6 offset */
     CALL6_PR4_STAR initial ("713120"b3)		/* call6 pr4|offset,* */
     ) bit (18) static options (constant);

dcl  word bit (36) aligned;
dcl  based_word based bit (36) aligned;
dcl  the_entry pointer based (the_entry_ptr);
dcl  the_entry_ptr pointer;
dcl  test_rq_data_ptr pointer;

	     if environmentptr (p_request_entry) ^= null () then return ("0"b);
						/* only external entries in the request table */

	     sb = pointer (stackframeptr (), 0);
	     lot_pointer_ptr = addr (lot.lot_pointers (binary (baseno (rqt_ptr), 18, 0)));

	     if (lot_pointer.lot_fault = "111"b) & (lot_pointer.mbz = ""b) then do;
		call hcs_$combine_linkage (rqt_ptr, get_ring_ (), code);
		if code ^= 0 then			/* couldn't combine the linkage (sigh) ... */
		     return ("0"b);			/* ... so claim it's not there */
	     end;

	     linkage_ptr = lot.lot_pointers (binary (baseno (rqt_ptr), 18, 0));

	     do rq_idx = 1 to rqt.n_requests;
		rq_data_ptr = addr (rqt.requests (rq_idx));
		request_name_list_ptr = pointer (rqt_ptr, rq_data.namelist_loc);
		if ^rq_data.flags.unimplemented & ^rq_data.flags.unknown then do;
		     cs_ptr = pointer (rqt_ptr, rq_data.code_loc);
		     if (code_sequence.op_code_and_modifiers = CALL6_ABSOLUTE) then do;
						/* bound segment: get entry directly from the instruction */
			the_entry_ptr = pointer (rqt_ptr, code_sequence.link_offset);
			if codeptr (p_request_entry) = the_entry_ptr then do;
FOUND_THE_REQUEST:
			     do idx = 1 to request_name_list.n_names;
						/* If the name is in the hash table, it isn't a duplicate */
				test_rq_data_ptr = lookup_request (request_name_list.name (idx));
				if test_rq_data_ptr = rq_data_ptr then do;
				     p_request_name = request_name_list.name (idx);
				     return ("1"b);
				end;
			     end;
			end;
		     end;
		     else if (code_sequence.op_code_and_modifiers = CALL6_PR4_STAR) then do;
						/* unbound segment: must indirect through linkage */
			the_entry_ptr = addrel (linkage_ptr, "000"b || substr (code_sequence.link_offset, 4, 15));
			on condition (linkage_error)	/* in case we can't find what it references ... */
			     go to SKIP_THIS_REQUEST;
			word = the_entry -> based_word;
						/* reference through it to snap the link if necessary */
			revert condition (linkage_error);
			if codeptr (p_request_entry) = the_entry then go to FOUND_THE_REQUEST;
						/* found it! */
		     end;
		end;
SKIP_THIS_REQUEST:
	     end;

	     return ("0"b);				/* didn't find it */

	end find_request_name_in_table;

     end find_request_name_subr;
%page;
/* Standard summarize_requests request: prints a multi-columnar listing of all requests available to the subsystem which
   have non-null documentation strings */

summarize_requests:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);
	if n_arguments ^= 0 then call ssu_$abort_line (sci_ptr, 0, "No arguments may be given.");

	if sci.request_tables_ptr = null () then	/* eh? */
	     call ssu_$abort_line (sci_ptr, 0, "There are no ^a requests.", sci.subsystem_name);

	call ioa_ ("Available ^a requests:^/", sci.subsystem_name);


/* Compute the number of columns to use in the summary: use the longest single request name with a gutter of 4 spaces */

	call compute_request_name_widths ("1"b, "0"b);	/* get length of longest name */

	line_length = get_line_length_$switch (iox_$user_output, code);
	if code ^= 0 then line_length = 72;		/* enforce the "standard" */

	columns = divide (line_length, (one_name_size + 4), 17, 0);
						/* how many columns will fit */
	if columns > 5 then columns = 5;		/* let's be arbitrary here, too many doesn't look nice */

	col_len = divide (line_length, columns, 17, 0) - 4;


/* Build the line fragments which will form the content of the columns */

	summary_info_ptr = null ();			/* for cleanup handler */
	on condition (cleanup)
	     begin;
		if summary_info_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, summary_info_ptr);
	     end;

	call ssu_$get_temp_segment (sci_ptr, SUMMARIZE_REQUESTS, summary_info_ptr);

	summary_info.total_lines = 0;

	idx = 1;
	do while (idx <= hash_table.n_slots);
	     rq_data_ptr = hash_table.slots (idx).rq_data_ptr;
	     request_name_list_ptr = pointer (rq_data_ptr, rq_data.namelist_loc);
	     if ^rq_data.flags.unimplemented & ^rq_data.flags.dont_summarize & ^rq_data.flags.unknown then
		call add_request_to_list ();
	     else idx = idx + 1;
	end;


/* Find the first line fragment to be printed in each column */

	lines_per_col = divide (summary_info.total_lines, columns, 17, 0);
						/* approximate number of lines in each column */

	col_offset (0) = 0;
	col_offset (columns) = summary_info.total_lines;

	do idx = 1 to columns - 1;
	     col_offset (idx) = idx * lines_per_col;
	end;

	jdx = mod (summary_info.total_lines, columns);	/* distribute the leftover lines evenly */
	do idx = 1 to columns - 1;
	     col_offset (idx) = col_offset (idx) + min (idx, jdx);
	end;


/* Print the lines */

	do rq_idx = 1 to col_offset (1);
	     do idx = 0 to columns - 1;
		this_line = rq_idx + col_offset (idx);
		if this_line <= col_offset (idx + 1) then
		     call ioa_$nnl ("^a^[^s^;^vt^]", summary_info.line (this_line), (idx = columns - 1), col_len + 5);
	     end;
	     call ioa_ ();
	end;

	call ssu_$release_temp_segment (sci_ptr, summary_info_ptr);


/* If the subsystem defines the list_requests request, point the user at it (using the proper name) */

	call find_request_name_subr (ssu_requests_$list_requests, request_name, code);
	if code = 0 then call ioa_ ("^/Type ""^a"" for a short description of the requests.", request_name);

	return;
%page;
/* Put the names of this request into the list of line fragments splitting the names where constrained by column width */

add_request_to_list:
     procedure ();

dcl  (name_idx, name_lth) fixed binary;
dcl  name_string character (80) varying;
dcl  this_name character (32) varying;

	name_string = rtrim (hash_table.slots (idx).name);

	do idx = (idx + 1) repeat (idx + 1)
	     while ((idx <= hash_table.n_slots) & ^hash_table.slots (idx).first_name_switch);
	     this_name = rtrim (hash_table.slots (idx).name);
	     name_lth = length (this_name) + 2;		/* extra two is for the ', ' */

	     if length (name_string) + name_lth > col_len then do;
						/* won't fit on this line */
		summary_info.total_lines = summary_info.total_lines + 1;
		summary_info.line (summary_info.total_lines) = name_string || ",";
		name_string = "   " || this_name;
	     end;

	     else do;
		if length (name_string) ^= 0 then name_string = name_string || ", ";
		name_string = name_string || this_name;
	     end;
	end;

	if name_string ^= "" then do;			/* be sure to output the remainder */
	     summary_info.total_lines = summary_info.total_lines + 1;
	     summary_info.line (summary_info.total_lines) = name_string;
	end;

	return;

     end add_request_to_list;
%page;
/* Standard list_requests request: lists the names and brief descriptions of all requests or of those requests whose name
   contains any of a given set of strings */

list_requests:
     entry (P_sci_ptr, P_info_ptr);

	sci_ptr = P_sci_ptr;

	call ssu_$arg_count (sci_ptr, n_arguments);

	if sci.request_tables_ptr = null () then	/* eh? */
	     call ssu_$abort_line (sci_ptr, 0, "There are no ^a requests.", sci.subsystem_name);

	max_request_strings = max (1, n_arguments);	/* PL/I doesn't like zero-length arrays */


LIST_REQUESTS_BODY:
	begin;

dcl  request_strings (max_request_strings) character (32) varying;
dcl  matched_request_string (max_request_strings) bit (1) aligned;
dcl  n_request_strings fixed binary;			/* the actual number present */

dcl  list_all_requests bit (1) aligned;			/* ON => also show requests without documentation strings */
dcl  exact_matches_only bit (1) aligned;

dcl  argument character (argument_lth) based (argument_ptr);
dcl  argument_lth fixed binary (21);
dcl  argument_ptr pointer;

dcl  (listed_a_request, didnt_find_a_request) bit (1) aligned;
dcl  arg_idx fixed binary;


	     n_request_strings = 0;			/* haven't seen any yet */

	     list_all_requests, exact_matches_only = "0"b;

	     do arg_idx = 1 to n_arguments;
		call ssu_$arg_ptr (sci_ptr, arg_idx, argument_ptr, argument_lth);
		if index (argument, "-") = 1 then do;
		     if (argument = "-all") | (argument = "-a") then list_all_requests = "1"b;
		     else if (argument = "-exact") then exact_matches_only = "1"b;
		     else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument);
		end;
		else do;				/* a string to be matched */
		     if argument_lth > maxlength (request_strings (1)) then
			call ssu_$abort_line (sci_ptr, ssu_et_$request_name_too_long, "^a", argument);
		     n_request_strings = n_request_strings + 1;
		     request_strings (n_request_strings) = argument;
		end;
	     end;

	     if exact_matches_only & (n_request_strings = 0) then
		call ssu_$abort_line (sci_ptr, error_table_$noarg, "Request names must be given with ""-exact"".");


/* Print generally usefull information when listing all requests */

	     if n_request_strings = 0 then do;

		call ioa_ ("Summary of ^a requests:^/", sci.subsystem_name);

		call ssu_$get_procedure (sci_ptr, "cpescape", entry1, (0));
		call ssu_$get_default_procedure (sci_ptr, "cpescape", entry2, (0));
		if entry1 = entry2 then call ioa_ ("Use "".. COMMAND_LINE"" to escape a command line to Multics.");

		call find_request_name_subr (ssu_requests_$list_help, lh_request_name, code);
		call find_request_name_subr (ssu_requests_$help, help_request_name, code2);
		if (code = 0) & (code2 = 0) then
		     call ioa_ ("Type ""^a"" for a list of topics available to the ^a request.", lh_request_name,
			help_request_name);
		else if (code ^= 0) & (code2 = 0) then
		     call ioa_ ("Type ""^a -topics"" for a list of available topics.", help_request_name);
		if code2 = 0 then
		     call ioa_ ("Type ""^a TOPIC"" for more information on a given topic.", help_request_name);

		if (entry1 = entry2) | (code = 0) | (code2 = 0) then call ioa_ ("");
	     end;					/* separate usefull info from the actual list */


/* Pass through all the request tables and list all request which match the selection criteria */

	     output_buffer_ptr = null ();		/* for cleanup handler */
	     on condition (cleanup)
		begin;
		     if output_buffer_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, output_buffer_ptr);
		end;

	     call ssu_$get_temp_segment (sci_ptr, LIST_REQUESTS, output_buffer_ptr);

	     line_length = get_line_length_$switch (iox_$user_output, code);
	     if code ^= 0 then line_length = 72;	/* enforce the "standard" */

	     fdo.version_number = format_document_version_1;
	     string (fdo.switches) = ""b;		/* fill in constant parts */
	     fdo.literal_sw = "1"b;			/* no embedded controls */
	     fdo.galley_sw = "1"b;			/* no page breaks */
	     if exact_matches_only then do;		/* one request per string ... */
		fdo.indentation = 3;		/* ... description indented under names ... */
		fdo.line_length = line_length;	/* ... and uses full terminal width */
	     end;
	     else do;				/* multiple requests ... */
		fdo.indentation = 0;		/* ... description to right of names ... */
		fdo.line_length = 0;		/* ... line length varies (see below) ... */
		call compute_request_name_widths ("0"b, list_all_requests);
		if one_name_size < (two_name_size - 6) then
		     max_name_size = one_name_size + 3;
		else max_name_size = two_name_size + 3;
	     end;					/* ... and space for names also varies */

	     listed_a_request = "0"b;
	     matched_request_string (*) = "0"b;

	     if exact_matches_only then
		do idx = 1 to n_request_strings;
		rq_data_ptr = lookup_request ((request_strings (idx)));
		if rq_data_ptr ^= null () then do;
		     request_name_list_ptr = pointer (rq_data_ptr, rq_data.namelist_loc);
		     listed_a_request, matched_request_string (idx) = "1"b;
		     call list_single_request ();
		end;
	     end;

	     else do idx = 1 to hash_table.n_slots;
		if hash_table.slots (idx).first_name_switch then do;
		     rq_data_ptr = hash_table.slots (idx).rq_data_ptr;
		     request_name_list_ptr = pointer (rq_data_ptr, rq_data.namelist_loc);

		     if (list_all_requests | (^rq_data.flags.unimplemented & ^rq_data.flags.dont_list))
			& ^rq_data.flags.unknown then do;

			request_info_string_ptr = pointer (rq_data_ptr, rq_data.info_string.loc);
			request_info_string_lth = rq_data.info_string.lth;
			if matching_name () then do;
			     listed_a_request = "1"b;
			     call list_single_request ();
			end;
		     end;
		end;
	     end;

	     call ssu_$release_temp_segment (sci_ptr, output_buffer_ptr);
	     output_buffer_ptr = null ();

	     if exact_matches_only then do;
		didnt_find_a_request = "0"b;
		do idx = 1 to n_request_strings;
		     if ^matched_request_string (idx) then do;
			didnt_find_a_request = "1"b;
			call ssu_$print_message (sci_ptr, 0, "Unknown request ""^a"".", request_strings (idx));
		     end;
		end;
		if didnt_find_a_request then		/* rest of the request line may be disastrous */
		     call ssu_$abort_line (sci_ptr, 0);
	     end;

	     else if ^listed_a_request then call ssu_$abort_line (sci_ptr, ssu_et_$no_matching_requests);
%page;
/* Internal to list_requests begin block: returns true if any of this request's names meets the selection criteria.  If
   exact matches are being sought, check all names (rather than stopping on first match) to insure that any request
   matching more than one of the user's names properly marks all those strings as matched */

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

dcl  (name_idx, idx, position) fixed binary;
dcl  found_some_matches bit (1) aligned;
dcl  test_rq_data_ptr pointer;

	if n_request_strings = 0 then			/* listing all requests */
	     return ("1"b);

	found_some_matches = "0"b;

	do name_idx = 1 to request_name_list.n_names;
	     request_name = rtrim (request_name_list.name (name_idx));
	     test_rq_data_ptr = lookup_request (request_name);
	     if rq_data_ptr = test_rq_data_ptr then do;
		do idx = 1 to n_request_strings;
		     position = index (request_name, request_strings (idx));
		     if (position ^= 0) then
			if (position = 1) then return ("1"b);
			else if (position = length (request_name) - length (request_strings (idx)) + 1) then
			     return ("1"b);
			else if (index (DELIMITERS, substr (request_name, (position - 1), 1)) ^= 0) then
			     return ("1"b);
			else if (index (DELIMITERS,
				substr (request_name, (position + length (request_strings (idx))), 1)) ^= 0) then
			     return ("1"b);
		end;
	     end;
	end;

	return (found_some_matches);

     end matching_name;
%page;
/* Internal to list_requests begin block: shows a single request */

list_single_request:
     procedure ();

dcl  (output_buffer_used, formatted_name_list_position, formatted_name_list_lth, formatted_info_string_position,
     formatted_info_string_lth, name_start, name_lth, info_start, info_lth) fixed binary (21);
dcl  idx fixed binary;
dcl  test_rq_data_ptr pointer;
dcl  (first_line, have_names, have_info) bit (1) aligned;


/* Construct the list of request names */

	output_buffer_used = 0;

	do idx = 1 to request_name_list.n_names;
	     request_name = rtrim (request_name_list.name (idx));
	     test_rq_data_ptr = lookup_request (request_name);
	     if rq_data_ptr = test_rq_data_ptr then do;
		if output_buffer_used > 0 then do;	/* ... a comma separated list */
		     substr (output_buffer, (output_buffer_used + 1), 2) = ", ";
		     output_buffer_used = output_buffer_used + 2;
		end;
		name_lth = length (rtrim (request_name));
		substr (output_buffer, (output_buffer_used + 1), name_lth) = rtrim (request_name);
		output_buffer_used = output_buffer_used + name_lth;
	     end;
	end;

	if output_buffer_used = 0 then return;		/* No names found */


/* Only one request matches each string: display at least two lines; the first line contains all the request names; the
   second and subsequent lines contains the brief description slightly indented */

	if exact_matches_only then do;

	     call ioa_ ("^a^[^2x(unimplemented)^]", substr (output_buffer, 1, output_buffer_used),
		rq_data.flags.unimplemented);

	     if length (request_info_string) = 0 then
		call ioa_ ("^3x(No brief description available.)");

	     else do;
		call format_document_$string (request_info_string, output_buffer, output_buffer_used, addr (fdo), (0))
		     ;
		begin;
dcl  formatted_string character (output_buffer_used) defined (output_buffer) position (1);
		     output_buffer_used = length (rtrim (formatted_string, NL));
		end;				/* format_document_ doesn't always add 1 newline */
		begin;
dcl  formatted_string character (output_buffer_used) defined (output_buffer) position (1);
		     call ioa_ ("^a", formatted_string);
		end;
	     end;
	end;


/* More than one request matches each string (if any): display the request names and descriptions on a single line if
   possible; otherwise, split the appropriate strings and indent subsequent lines by a small amount */

	else do;

	     formatted_name_list_position = output_buffer_used + 1;
	     begin;				/* now format it */
dcl  unformatted_name_list character (output_buffer_used) defined (output_buffer) position (1);
dcl  rest_of_output_buffer character (length (output_buffer) - output_buffer_used) unaligned
	defined (output_buffer) position (output_buffer_used + 1);
		fdo.line_length = max_name_size - 3;	/* ... insure there's room for the overflow */
		call format_document_$string (unformatted_name_list, rest_of_output_buffer, formatted_name_list_lth,
		     addr (fdo), (0));
	     end;
	     begin;
dcl  name_list character (formatted_name_list_lth) unaligned defined (output_buffer)
	position (formatted_name_list_position);
		formatted_name_list_lth = length (rtrim (name_list, NL)) + 1;
		substr (name_list, formatted_name_list_lth, 1) = NL;
	     end;					/* format_document_ sometimes doesn't add trailing newlines */

	     output_buffer_used = output_buffer_used + formatted_name_list_lth;
	     formatted_info_string_position = output_buffer_used + 1;
	     begin;				/* format the documentation string */
dcl  rest_of_output_buffer character (length (output_buffer) - output_buffer_used) unaligned
	defined (output_buffer) position (output_buffer_used + 1);
		fdo.line_length = line_length - max_name_size - 6;
		if fdo.line_length < 21 then		/* don't let it get too short ... */
		     fdo.line_length = 131071;	/* ... so don't split the documentation string */
		call format_document_$string (request_info_string, rest_of_output_buffer, formatted_info_string_lth,
		     addr (fdo), (0));
	     end;
	     begin;
dcl  info_string character (formatted_info_string_lth) unaligned defined (output_buffer)
	position (formatted_info_string_position);
		formatted_info_string_lth = length (rtrim (info_string, NL)) + 1;
		substr (info_string, formatted_info_string_lth, 1) = NL;
	     end;					/* format_document_ sometimes doesn't add trailing newlines */

	     begin;				/* output the results ... */

dcl  name_list character (formatted_name_list_lth) unaligned defined (output_buffer)
	position (formatted_name_list_position);
dcl  info_string character (formatted_info_string_lth) unaligned defined (output_buffer)
	position (formatted_info_string_position);

		first_line, have_names = "1"b;	/* requests have to have some names */
		have_info = (info_string ^= NL);	/* info string might have been empty */
		name_start, info_start = 1;

		do while (have_names | have_info);
		     if have_names then name_lth = index (substr (name_list, name_start), NL) - 1;
		     if have_info then info_lth = index (substr (info_string, info_start), NL) - 1;
		     if have_names & have_info then
			call ioa_ ("^[^3x^]^a^vt^[^3x^]^a", ^first_line, substr (name_list, name_start, name_lth),
			     (max_name_size + 3), ^first_line, substr (info_string, info_start, info_lth));
		     else if have_names then do;
			call ioa_ ("^[^3x^]^a", ^first_line, translate (substr (name_list, name_start), SP, NL));
			name_lth = length (name_list);/* all the remaining names are on this line */
		     end;
		     else call ioa_ ("^vt^[^3x^]^a", (max_name_size + 3), ^first_line,
			     substr (info_string, info_start, info_lth));
		     name_start = name_start + name_lth + 1;
		     info_start = info_start + info_lth + 1;
		     have_names = (name_start < length (name_list));
		     have_info = (info_start < length (info_string));
		     first_line = "0"b;
		end;
	     end;
	end;

	return;

     end list_single_request;

	end LIST_REQUESTS_BODY;

	return;
%page;
/* Computes the amount of room needed for the longest primary request name and the longest combination of a primary
   request name and its first short name */

compute_request_name_widths:
     procedure (p_summarize, p_include_all);

dcl  (p_summarize, p_include_all) bit (1) aligned parameter;
dcl  exclude bit (1) aligned;

	one_name_size = 0;
	two_name_size = 0;

	do idx = 1 to hash_table.n_slots;
	     rq_data_ptr = hash_table.slots (idx).rq_data_ptr;

	     if p_summarize then
		exclude = rq_data.flags.dont_summarize;
	     else exclude = rq_data.flags.dont_list;

	     if (p_include_all | (^rq_data.flags.unimplemented & ^exclude)) & ^rq_data.flags.unknown then do;
		request_name_list_ptr = pointer (rq_data_ptr, rq_data.namelist_loc);

		if request_name_list.n_names >= 2 then
		     two_name_size =
			max (two_name_size,
			length (rtrim (request_name_list.name (1))) + length (rtrim (request_name_list.name (2)))
			+ 2);

		else two_name_size = max (two_name_size, length (rtrim (request_name_list.name (1))));

		one_name_size = max (one_name_size, length (rtrim (request_name_list.name (1))));
	     end;
	end;

	return;

     end compute_request_name_widths;
%page;
%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include "_ssu_request_table";
%page;
%include "_ssu_request_data";
%page;
%include ssu_request_tables_list;
%page;
%include stack_header;
%page;
%include format_document_options;

     end ssu_request_mgr_;




		    ssu_request_processor_.pl1      08/05/87  0809.0r   08/04/87  1539.3      189396



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


/* format: off */

/* Default subsystem request line processor and active string evaluator */

/* Created:  3 May 1980 by W. Olin Sibert */
/* Modified: 15 February 1982 by G. Palter to support standalone invocations, rename eval_string to evaluate_active_string
      and correct its calling sequence, return ssu_et_$null_request_line rather than 100, and reflect the reorganization
      of the sci structure */
/* Modified: 26 February 1982 by G. Palter to make execute_line handle program_interrupt when there is no active listener
      in this subsystem invocation */
/* Modified: June 1982 by G. Palter to split execute_line and evaluate_active_string into part which is always executed
      and part which is replaceable (ssu 14), to always trapping calls to ssu_$abort_line (ssu 12), to pass along request
      processor options to the Multics command processor (which does most of the work for subsystems), and to add
      (set get)_abbrev_info and (get free set reset)_request_processor_options and get_default_rp_options entries (ssu 6)
      */

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

ssu_request_processor_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_code fixed binary (35) parameter;

dcl  P_rp_options_ptr pointer parameter;		/* evaluate_active_string, (get get_default set)_rp_options */

dcl  P_request_line_ptr pointer parameter;		/* execute_line: -> the request line */
dcl  P_request_line_lth fixed binary (21) parameter;	/* execute_line: length of said string */

dcl  P_request_string character (*) parameter;		/* execute_string: the request line to execute */

dcl  P_active_string character (*) parameter;		/* evaluate_active_string: the active string (no []'s) */
dcl  P_active_string_type fixed binary parameter;		/* evaluate_active_string: type of string supplied */
dcl  P_return_value character (*) varying parameter;	/* evaluate_active_string: results of evaluation */

dcl  P_rp_options_version character (8) parameter;	/* (get get_default)_rp_options: which version to return */

dcl  P_default_profile_ptr pointer parameter;		/* get_abbrev_info, set_abbrev_info: -> default profile */
dcl  P_profile_ptr pointer parameter;			/* get_abbrev_info, set_abbrev_info: -> current profile */
dcl  P_abbrev_mode bit (1) aligned parameter;		/* get_abbrev_info, set_abbrev_info: ON => enable abbrevs */


/* Local copies of parameters */

dcl  request_line character (request_line_lth) based (request_line_ptr);
dcl  request_line_lth fixed binary (21);
dcl  request_line_ptr pointer;

dcl  code fixed binary (35);


/* Internal representation of the subsystem's current request processor options */

dcl  1 irpo aligned based (sci.rp_options_ptr),
       2 cp_subsys_info like cp_subsys_info,		/* command language definition */
       2 abbrev_info,
         3 abbrev_enabled bit (1),			/* ON => expand request lines before execution */
         3 default_profile_ptr pointer,			/* -> default profile (used if profile_ptr is null) */
         3 profile_ptr pointer;			/* -> current profile */


/* Remaining declarations */

dcl  1 lcsi aligned like cp_subsys_info;

dcl  (saved_abort_subsystem_label, saved_abort_line_label) label variable;
dcl  (saved_in_listener, saved_executing_request) bit (1) aligned;

dcl  (idx, jdx) fixed binary (21);

dcl  WHITESPACE character (5) static options (constant) initial ("
	 ");						/* NL, HT, SP, VT, FF */

dcl  1 cp_data_$standard_language aligned external,	/* standard Multics command language definition */
       2 character_types (0:511) fixed binary (9) unaligned unsigned;

dcl  error_table_$unimplemented_version fixed binary (35) external;

/* format: off */
dcl (ssu_et_$null_request_line, ssu_et_$program_interrupt, ssu_et_$request_line_aborted, ssu_et_$subsystem_aborted)
	fixed binary (35) external;
/* format: on */

dcl  abbrev_$subsys_process_line
	entry (character (*), pointer, entry, pointer, entry, pointer, pointer, character (*), fixed binary (35));
dcl  command_processor_$subsys_execute_line
	entry (character (*), pointer, entry, pointer, character (*), fixed binary (35));
dcl  command_processor_$subsys_eval_string
	entry (character (*), pointer, entry, pointer, character (*), fixed binary, character (*) varying,
	fixed binary (35));
dcl  command_processor_$validate_cp_subsys_info entry (pointer, fixed binary (35));
dcl  cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl  cu_$evaluate_active_string entry (pointer, character (*), fixed binary, character (*) varying, fixed binary (35));
dcl  hcs_$terminate_noname entry (pointer, fixed binary (35));
dcl  ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying);
dcl  ssu_$invoke_request entry () options (variable);

dcl  (cleanup, program_interrupt) condition;

dcl  (addr, index, length, null, substr, unspec, verify) builtin;

/**/

/* Initialize the subsystem's request processor options */

init_rp_options:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	allocate irpo in (sci_parent_area) set (sci.rp_options_ptr);

	irpo.cp_subsys_info.version = CP_SUBSYS_INFO_VERSION_1;
	irpo.cp_subsys_info.non_standard_language = "0"b;

	irpo.abbrev_info.abbrev_enabled = "0"b;
	irpo.abbrev_info.default_profile_ptr, irpo.abbrev_info.profile_ptr = null ();

	return;



/* Release the subsystem's request processor options (called by ssu_$destroy_invocation) */

term_rp_options:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.rp_options_ptr = null () then return;	/* nothing there anyway */

	call maybe_terminate_profiles (null (), null ()); /* terminate the profiles */

	free irpo in (sci_parent_area);
	sci.rp_options_ptr = null ();			/* all gone */

	return;

/**/

/* Prepares to call the execute_line procedure: if in a standalone invocation, transfers directly to cu_$cp; otherwise,
   sets up the label used by ssu_$abort_line and then invokes the actual replaceable execute_line procedure.  This entry
   is called by the ssu_$execute_line transfer vector */

prepare_to_execute_line:
     entry (P_sci_ptr, P_request_line_ptr, P_request_line_lth, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.standalone_invocation then do;		/* a Multics command/AF simulating a subsystem ... */
	     call cu_$cp (P_request_line_ptr, P_request_line_lth, P_code);
	     if P_code = 100 then P_code = ssu_et_$null_request_line;
	     return;
	end;

	saved_in_listener = sci.in_listener;
	saved_executing_request = sci.executing_request;	/* in case this is called by a request */
	saved_abort_line_label = sci.request_processor_info.abort_line_label;

	sci.request_processor_info.abort_line_label = LINE_ABORT_RETURN;

	if ^sci.in_listener then do;			/* no listener: trap subsystem abort and program interrupt */
	     saved_abort_subsystem_label = sci.listener_info.abort_subsystem_label;
	     sci.listener_info.abort_subsystem_label = SUBSYSTEM_ABORT_RETURN;
	     on condition (program_interrupt)
		begin;
		     call sci.entries.program_interrupt (sci_ptr);
		     P_code = ssu_et_$program_interrupt;/* let caller know it wasn't a clean execution */
		     go to RETURN_FROM_EXECUTE_LINE;
		end;
	end;

	on condition (cleanup)
	     begin;
		sci.in_listener = saved_in_listener;
		sci.executing_request = saved_executing_request;
		if ^sci.in_listener then sci.listener_info.abort_subsystem_label = saved_abort_subsystem_label;
		sci.request_processor_info.abort_line_label = saved_abort_line_label;
	     end;

	call sci.entries.execute_line (sci_ptr, P_request_line_ptr, P_request_line_lth, code);

	if code = 100 then				/* translate null line code to appropriate value */
	     P_code = ssu_et_$null_request_line;
	else P_code = 0;				/* error messages have already been printed */

RETURN_FROM_EXECUTE_LINE:
	sci.in_listener = saved_in_listener;		/* restore state */
	sci.executing_request = saved_executing_request;
	if ^sci.in_listener then sci.listener_info.abort_subsystem_label = saved_abort_subsystem_label;
	sci.request_processor_info.abort_line_label = saved_abort_line_label;

	return;


SUBSYSTEM_ABORT_RETURN:				/* user/program asked to abort the subsystem */
	P_code = ssu_et_$subsystem_aborted;
	go to RETURN_FROM_EXECUTE_LINE;

LINE_ABORT_RETURN:					/* user/program asked to abort the request line */
	P_code = ssu_et_$request_line_aborted;
	go to RETURN_FROM_EXECUTE_LINE;

/**/

/* Execute a subsystem request line: this is the default procedure invoked by prepare_to_execute_line which is called
   externally as ssu_$execute_line */

execute_line:
     entry (P_sci_ptr, P_request_line_ptr, P_request_line_lth, P_code);

	sci_ptr = P_sci_ptr;

	request_line_ptr = P_request_line_ptr;
	request_line_lth = P_request_line_lth;

	if request_line_lth > 2 then do;		/* implement ".." escape here */
	     idx = index (request_line, "..");
	     if idx ^= 0 then do;			/* ... seems to be one */
		if idx > 1 then			/* ... insure only white space preceeds it */
		     jdx = verify (substr (request_line, 1, idx - 1), WHITESPACE);
		else jdx = 0;			/* ... just a ".." somewhere in the middle of the line */
		if jdx = 0 then do;			/* ... a true escape: do it */
						/* format: off */
		     call sci.entries.cpescape
			     (sci_ptr, addr (substr (request_line, idx + 2, 1)), request_line_lth - (idx + 1),
			      P_code);		/* format: on */
		     if P_code = 100 then P_code = 0;	/* ... censor null lines as the line isn't really blank */
		     return;
		end;
	     end;
	end;

	if irpo.abbrev_info.abbrev_enabled then		/* user wants abbreviations expanded */
	     call abbrev_$subsys_process_line (ssu_$get_subsystem_and_request_name (sci_ptr), sci_ptr,
		ssu_$invoke_request, addr (irpo.cp_subsys_info), command_processor_$subsys_execute_line,
		irpo.abbrev_info.default_profile_ptr, irpo.abbrev_info.profile_ptr, request_line, P_code);

	else call command_processor_$subsys_execute_line (ssu_$get_subsystem_and_request_name (sci_ptr), sci_ptr,
		ssu_$invoke_request, addr (irpo.cp_subsys_info), request_line, P_code);

	return;



/* Allows for execution of constant request strings: simply calls ssu_$execute_line so that replacement of that procedure
   will properly affect this one */

execute_string:
     entry (P_sci_ptr, P_request_string, P_code);

	call ssu_$execute_line (P_sci_ptr, addr (substr (P_request_string, 1, 1)), length (P_request_string), P_code);

	return;

/**/

/* Prepares to invoke the evaluate_active_string procedure: if in a standalone invocation, transfers directly to
   cu_$evaluate_active_string; otherwise, sets up the labels used by ssu_$abort_line and then invokes the actual
   replaceable evaluate_active_string procedure.  This entry is called by the ssu_$evaluate_active_string transfer
   vector */

prepare_to_evaluate_string:
     entry (P_sci_ptr, P_rp_options_ptr, P_active_string, P_active_string_type, P_return_value, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.standalone_invocation then do;		/* a Multics command/AF simulating a subsystem ... */
	     call cu_$evaluate_active_string (null (), P_active_string, P_active_string_type, P_return_value, P_code);
	     return;
	end;

	saved_in_listener = sci.in_listener;
	saved_executing_request = sci.executing_request;	/* in case this is called by a request */
	saved_abort_line_label = sci.request_processor_info.abort_line_label;

	sci.request_processor_info.abort_line_label = LINE_ABORT_RETURN;

	if ^sci.in_listener then do;			/* no listener: trap subsystem aborts */
	     saved_abort_subsystem_label = sci.listener_info.abort_subsystem_label;
	     sci.listener_info.abort_subsystem_label = SUBSYSTEM_ABORT_RETURN;
	end;

	on condition (cleanup)
	     begin;
		sci.in_listener = saved_in_listener;
		sci.executing_request = saved_executing_request;
		if ^sci.in_listener then sci.listener_info.abort_subsystem_label = saved_abort_subsystem_label;
		sci.request_processor_info.abort_line_label = saved_abort_line_label;
	     end;

/* format: off */
	call sci.entries.evaluate_active_string
		(P_sci_ptr, P_rp_options_ptr, P_active_string, P_active_string_type, P_return_value, P_code);
						/* format: on */

	sci.in_listener = saved_in_listener;
	sci.executing_request = saved_executing_request;
	if ^sci.in_listener then sci.listener_info.abort_subsystem_label = saved_abort_subsystem_label;
	sci.request_processor_info.abort_line_label = saved_abort_line_label;

	return;

/**/

/* Evaluate a subsystem active string: this is the default procedure invoked by prepare_to_evaluate_string which is called
   externally as ssu_$evaluate_active_string */

evaluate_active_string:
     entry (P_sci_ptr, P_rp_options_ptr, P_active_string, P_active_string_type, P_return_value, P_code);

	sci_ptr = P_sci_ptr;

	if P_rp_options_ptr ^= null () then do;		/* caller wishes to override subsystem's default options */
	     rp_options_ptr = P_rp_options_ptr;
	     if rp_options.version ^= RP_OPTIONS_VERSION_1 then do;
		P_code = error_table_$unimplemented_version;
		return;				/* ... but we don't understand it */
	     end;
	     cp_subsys_info_ptr = addr (lcsi);		/* ... validate that these options are OK */
	     lcsi.version = CP_SUBSYS_INFO_VERSION_1;
	     lcsi.non_standard_language = rp_options.non_standard_language;
	     unspec (lcsi.full_tct_table) = unspec (rp_options.character_types);
	     call command_processor_$validate_cp_subsys_info (cp_subsys_info_ptr, P_code);
	     if P_code ^= 0 then return;		/* ... there's something wrong with them */
	end;
	else cp_subsys_info_ptr = sci.rp_options_ptr;	/* use the subsystem's current options */

	call command_processor_$subsys_eval_string (ssu_$get_subsystem_and_request_name (sci_ptr), sci_ptr,
	     ssu_$invoke_request, cp_subsys_info_ptr, P_active_string, P_active_string_type, P_return_value, P_code);

	return;

/**/

/* Returns the request processor options presently in effect in this subsystem */

get_rp_options:
     entry (P_sci_ptr, P_rp_options_version, P_rp_options_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	rp_options_ptr = P_rp_options_ptr;

	if P_rp_options_version ^= RP_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;				/* we only support this version at present */
	end;

	if sci.rp_options_ptr = null () then call init_rp_options (sci_ptr);
						/* be sure there's something to look at */

	rp_options.version = RP_OPTIONS_VERSION_1;	/* it's the only version we have */

	rp_options.non_standard_language = irpo.cp_subsys_info.non_standard_language;
	if irpo.cp_subsys_info.non_standard_language then /* be sure caller sees proper language definition */
	     unspec (rp_options.character_types) = unspec (irpo.cp_subsys_info.full_tct_table);
	else unspec (rp_options.character_types) = unspec (cp_data_$standard_language);

	rp_options.expand_request_lines = irpo.abbrev_info.abbrev_enabled;
	rp_options.default_profile_ptr = irpo.abbrev_info.default_profile_ptr;
	rp_options.profile_ptr = irpo.abbrev_info.profile_ptr;

	P_code = 0;				/* success */

	return;

/**/

/* Returns the default request processor options for a subsystem */

get_default_rp_options:
     entry (P_sci_ptr, P_rp_options_version, P_rp_options_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	rp_options_ptr = P_rp_options_ptr;

	if P_rp_options_version ^= RP_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;				/* we only support this version at present */
	end;

	rp_options.version = RP_OPTIONS_VERSION_1;	/* it's the only version we have */

	rp_options.non_standard_language = "0"b;	/* default is the standard language */
	unspec (rp_options.character_types) = unspec (cp_data_$standard_language);

	rp_options.expand_request_lines = "0"b;		/* abbrev is off by default */
	rp_options.default_profile_ptr, rp_options.profile_ptr = null ();

	P_code = 0;				/* success */

	return;

/**/

/* Sets the request processor options to be used in this subsystem */

set_rp_options:
     entry (P_sci_ptr, P_rp_options_ptr, P_code);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	rp_options_ptr = P_rp_options_ptr;

	if rp_options.version ^= RP_OPTIONS_VERSION_1 then do;
	     P_code = error_table_$unimplemented_version;
	     return;				/* we only support this version at present */
	end;

	if sci.rp_options_ptr = null () then call init_rp_options (sci_ptr);
						/* be sure there's something to look at */

	lcsi.version = CP_SUBSYS_INFO_VERSION_1;	/* validate the caller's request language definition */
	lcsi.non_standard_language = rp_options.non_standard_language;
	unspec (lcsi.full_tct_table) = unspec (rp_options.character_types);
	call command_processor_$validate_cp_subsys_info (addr (lcsi), P_code);
	if P_code ^= 0 then return;			/* ... it's illegal */

	irpo.cp_subsys_info = lcsi;			/* OK: set the options */

	call maybe_terminate_profiles (rp_options.default_profile_ptr, rp_options.profile_ptr);

	irpo.abbrev_info.abbrev_enabled = rp_options.expand_request_lines;
	irpo.abbrev_info.default_profile_ptr = rp_options.default_profile_ptr;
	irpo.abbrev_info.profile_ptr = rp_options.profile_ptr;

	P_code = 0;				/* success */

	return;

/**/

/* Resets the request processor options in use by this subsystem to their default state */

reset_rp_options:
     entry (P_sci_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;
	if sci.rp_options_ptr = null () then call init_rp_options (sci_ptr);
						/* be sure there's something to look at */

	irpo.cp_subsys_info.version = CP_SUBSYS_INFO_VERSION_1;
	irpo.cp_subsys_info.non_standard_language = "0"b; /* but you already knew that */

	call maybe_terminate_profiles (null (), null ()); /* terminate the profile segments if needed */
	irpo.abbrev_info.abbrev_enabled = "0"b;		/* no abbrev expansion */
	irpo.abbrev_info.default_profile_ptr, irpo.abbrev_info.profile_ptr = null ();

	return;

/**/

/* Returns all data related to abbreviation processing of request lines in this subsystem */

get_abbrev_info:
     entry (P_sci_ptr, P_default_profile_ptr, P_profile_ptr, P_abbrev_mode);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;			/* need to check that options were setup */
	if sci.rp_options_ptr = null () then call init_rp_options (sci_ptr);

	P_default_profile_ptr = irpo.abbrev_info.default_profile_ptr;
	P_profile_ptr = irpo.abbrev_info.profile_ptr;
	P_abbrev_mode = irpo.abbrev_info.abbrev_enabled;

	return;



/* Sets all data related to abbreviation processing */

set_abbrev_info:
     entry (P_sci_ptr, P_default_profile_ptr, P_profile_ptr, P_abbrev_mode);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;			/* need to check that options were setup */
	if sci.rp_options_ptr = null () then call init_rp_options (sci_ptr);

	call maybe_terminate_profiles (P_default_profile_ptr, P_profile_ptr);

	irpo.abbrev_info.default_profile_ptr = P_default_profile_ptr;
	irpo.abbrev_info.profile_ptr = P_profile_ptr;
	irpo.abbrev_info.abbrev_enabled = P_abbrev_mode;

	return;

/**/

/* Conditionally terminate the current subsystem profile segments: never terminates a segment if one of the other
   pointers (old or new) references it and never terminates a segment more than once.  Some subsystems only initiate their
   profile segment once even though they set it as the default and current profiles; therefore, it isn't safe to just
   terminate the old profile segments */

maybe_terminate_profiles:
     procedure (p_new_default_profile_ptr, p_new_profile_ptr);

dcl  (p_new_default_profile_ptr, p_new_profile_ptr) pointer parameter;
dcl  (old_default_profile_ptr, old_profile_ptr) pointer;

	old_default_profile_ptr = irpo.abbrev_info.default_profile_ptr;
	old_profile_ptr = irpo.abbrev_info.profile_ptr;

	if old_default_profile_ptr ^= null () then	/* may not be using the default profile any longer */
	     if ((old_default_profile_ptr ^= p_new_default_profile_ptr)
		& (old_default_profile_ptr ^= p_new_profile_ptr)) then
		call hcs_$terminate_noname (old_default_profile_ptr, (0));

	if old_profile_ptr ^= null () then		/* may not be using the current profile any longer */
	     if old_profile_ptr ^= old_default_profile_ptr then
		if ((old_profile_ptr ^= p_new_default_profile_ptr) & (old_profile_ptr ^= p_new_profile_ptr)) then
		     call hcs_$terminate_noname (old_profile_ptr, (0));

	return;

     end maybe_terminate_profiles;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include ssu_rp_options;
%page;
%include "_cp_subsys_info";


     end ssu_request_processor_;




		    ssu_request_tables_.alm         11/05/86  1305.7r w 11/04/86  1038.1       34911



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

" Standard subsystem request tables

" Created:  April 1982 by G. Palter
" Modified: 30 July 1982 by G. Palter to allow abbrev to be used as an active
"	  request.



" HISTORY COMMENTS:
"  1) change(86-08-12,JSLove), approve(86-08-12,MCR7519),
"     audit(86-08-18,Parisek), install(86-10-01,MR12.0-1170):
"     Added the execute_string and substitute_arguments requests.
"                                                      END HISTORY COMMENTS




	include	ssu_request_macros

	name	ssu_request_tables_

" 

" ssu_request_tables_$standard_requests -- A request table containing all
"   standard subsystem requests;" it should be added as the last request
"   table by subsystems which implement all standard requests

	begin_table standard_requests

	request	.,
		 ssu_requests_$self_identify,
		 (),
		 (Identify the subsystem.)

	request	?,
		 ssu_requests_$summarize_requests,
		 (),
		 (Produce a list of the most commonly used requests.),
		 flags.allow_command+flags.dont_summarize

	request	abbrev,
		 ssu_requests_$abbrev,
		 (ab),
		 (Enable/disable abbreviation processing of request lines.),
		 flags.allow_both

	request	answer,
		 ssu_requests_$answer,
		 (),
		 (Provide preset answers to another request line.)

	request	debug_mode,
		 ssu_requests_$debug_mode,
		 (),
		 (Enable/disable subsystem debugging facilities.),
		 flags.allow_command+flags.dont_summarize+flags.dont_list

	request	do,
		 ssu_requests_$do,
		 (),
		 (Perform substitution into a control string and execute or return the expansion.),
		 flags.allow_both

	request	exec_com,
		 ssu_requests_$exec_com,
		 (ec),
		 (Execute a file containing request lines with parameter substitution.),
		 flags.allow_both

	request	execute,
		 ssu_requests_$execute,
		 (e),
		 (Execute a Multics command line.),
		 flags.allow_both

	request	execute_string,
		 ssu_requests_$execute_string,
		 (exs),
		 (Perform substitution into a control string and execute the expansion.),
		 flags.allow_both

	request	help,
		 ssu_requests_$help,
		 (),
		 (Obtain detailed information on the subsystem.)

	request	if,
		 ssu_requests_$if,
		 (),
		 (Conditionally execute one of two request lines.),
		 flags.allow_both

	request	list_help,
		 ssu_requests_$list_help,
		 (lh),
		 (List topics for which help is available.)

	request	list_requests,
		 ssu_requests_$list_requests,
		 (lr),
		 (List brief information on subsystem requests.)

	request	quit,
		 ssu_requests_$quit,
		 (q),
		 (Leave the subsystem.)

	request	ready,
		 ssu_requests_$ready,
		 (rdy),
		 (Print a ready message.),
		 flags.allow_command+flags.dont_summarize+flags.dont_list

	request	ready_off,
		 ssu_requests_$ready_off,
		 (rdf),
		 (Disable printing ready messages after each request line.),
		 flags.allow_command+flags.dont_summarize+flags.dont_list

	request	ready_on,
		 ssu_requests_$ready_on,
		 (rdn),
		 (Enable printing ready messages after each request line.),
		 flags.allow_command+flags.dont_summarize+flags.dont_list

	request	substitute_arguments,
		 ssu_requests_$substitute_arguments,
		 (substitute_args,sbag),
		 (Perform substitution into a control string and print or return the expansion.),
		 flags.allow_both

	request	subsystem_name,
		 ssu_requests_$subsystem_name,
		 (),
		 (Return the name of this subsystem.),
		 flags.allow_both+flags.dont_summarize+flags.dont_list

	request	subsystem_version,
		 ssu_requests_$subsystem_version,
		 (),
		 (Return the version number of this subsystem.),
		 flags.allow_both+flags.dont_summarize+flags.dont_list

	end_table standard_requests

	end




		    ssu_requests_.alm               10/01/86  1450.4rew 10/01/86  1353.9       21339



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

" SSU_REQUESTS_ --- Transfer vector for accessing all of the standard	requests
"		provided by the subsystem utilities

" Created:  9 May 1980 by W. Olin Sibert
" Modified: 24 July 1982 by Jay Pattin to add abbrev and exec_com
" Modified: 11 December 1981 by G. Palter to change ssu_help_request_ to
"	  ssu_info_requests_
" Modified: 16 December 1981 by Jay Pattin to add summarize_requests
" Modified: Februrary 1982 by G. Palter to move the self-documenting requests
"	  and add answer
" Modified: 24 February 1982 by G. Palter to add subsystem_name and
"	  subsystem_version



" HISTORY COMMENTS:
"  1) change(86-08-12,JSLove), approve(86-08-12,MCR7519),
"     audit(86-08-18,Parisek), install(86-10-01,MR12.0-1170):
"     Added execute_string and substitute_arguments requests.
"                                                      END HISTORY COMMENTS




	name	ssu_requests_


" Macro to generate a call to an external entrypoint in the utilities

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end


	ext_transfer	abbrev,ssu_misc_requests_$abbrev
	ext_transfer	answer,answer$ssu_answer_request_
	ext_transfer	debug_mode,ssu_misc_requests_$debug_mode
	ext_transfer	do,do$ssu_do_request_
	ext_transfer	exec_com,ssu_ec_$exec_com

	ext_transfer	execute,ssu_misc_requests_$execute
	ext_transfer	execute_string,do$ssu_execute_string_request_
	ext_transfer	help,ssu_info_mgr_$help
	ext_transfer	if,if$ssu_if_request_
	ext_transfer	list_help,ssu_info_mgr_$list_help

	ext_transfer	list_requests,ssu_request_mgr_$list_requests
	ext_transfer	quit,ssu_misc_requests_$quit
	ext_transfer	ready,ssu_misc_requests_$ready
	ext_transfer	ready_off,ssu_misc_requests_$ready_off
	ext_transfer	ready_on,ssu_misc_requests_$ready_on

	ext_transfer	self_identify,ssu_misc_requests_$self_identify
	ext_transfer	substitute_arguments,do$ssu_substitute_args_request_
	ext_transfer	subsystem_name,ssu_misc_requests_$subsystem_name
	ext_transfer	subsystem_version,ssu_misc_requests_$subsystem_version
	ext_transfer	summarize_requests,ssu_request_mgr_$summarize_requests

	end




		    ssu_temp_mgr_.pl1               08/05/87  0809.0r   08/04/87  1539.3       84690



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


/* Associates temporary segments and areas with a subsystem invocation so they may all be freed at once when the
   invocation is destroyed */

/* Created:  8 May 1980 by W. Olin Sibert */
/* Modified: 2 November 1981 by W. Olin Sibert to fix area release bug (phx10462) */

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


ssu_temp_mgr_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl  P_sci_ptr pointer parameter;

dcl  P_comment character (*) parameter;			/* get_segment, get_area: additional info about what part of
						   the subsystem wants this segment/area */

dcl  P_seg_ptr pointer parameter;			/* get_segment, release_segment: set -> the segment acquired
						   for get; -> segment to release for release */

dcl  P_area_infop pointer parameter;			/* get_area: -> optional area_info setup by caller */

dcl  P_area_ptr pointer parameter;			/* get_area, release_area: set -> the area acquired for get;
						   for release, -> segment to release */


/* Data describing all temporary segments and areas acquired for this subsystem */

dcl  1 temp_info aligned based (temp_info_ptr),		/* describes a single segment/area */
       2 type fixed binary,				/* unused/segment/area */
       2 ptr pointer,
       2 name character (32) unaligned;
dcl  temp_info_ptr pointer;

dcl  NO_TYPE fixed binary static options (constant) initial (1);
dcl  SEGMENT_TYPE fixed binary static options (constant) initial (2);
dcl  AREA_TYPE fixed binary static options (constant) initial (3);

dcl  1 temp_info_array aligned based (sci.temp_info_ptr),
       2 size fixed binary,
       2 element (alloc_temp_info_array_size refer (temp_info_array.size)) like temp_info;

dcl  alloc_temp_info_array_size fixed binary;


/* Remaining declarations */

dcl  1 area_info_automatic like area_info aligned automatic;

dcl  code fixed binary (35);
dcl  idx fixed binary;
dcl  old_ptr pointer;

dcl  sys_info$max_seg_size fixed binary (19) external;

dcl  error_table_$area_too_small fixed binary (35) external;
dcl  error_table_$badcall fixed binary (35) external;

dcl  define_area_ entry (pointer, fixed binary (35));
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  release_area_ entry (pointer);
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  ioa_$rsnnl entry () options (variable);
dcl  ssu_$abort_line entry () options (variable);

dcl  (addr, currentsize, null, unspec) builtin;

/**/

/* Acquire a temporary segment: on failure, aborts the request line (shouldn't ever fail anyway) */

get_segment:
     entry (P_sci_ptr, P_comment, P_seg_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call get_temp_info_ptr ();			/* get a pointer to an empty temp_info */

	temp_info.type = SEGMENT_TYPE;
	call ioa_$rsnnl ("^a.^d^[ (^a)^]", temp_info.name, (0), sci.subsystem_name, sci.recursion_info.level,
	     (P_comment ^= ""), P_comment);		/* construct the name it will be allocated with */

	call get_temp_segment_ (temp_info.name, temp_info.ptr, code);

	if code ^= 0 then				/* try to punt... */
	     call ssu_$abort_line (sci_ptr, code, "Unable to get temporary segment.");

	P_seg_ptr = temp_info.ptr;

	return;

/**/

/* Acquires an area in a temporary segment */

get_area:
     entry (P_sci_ptr, P_area_infop, P_comment, P_area_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	call get_temp_info_ptr ();			/* get one */

	temp_info.type = AREA_TYPE;
	call ioa_$rsnnl ("^a.^d^[ (^a)^]", temp_info.name, (0), sci.subsystem_name, sci.recursion_info.level,
	     (P_comment ^= ""), P_comment);		/* construct the name it will be allocated with */

	if P_area_infop = null () then do;		/* get an area with default characteristics */
	     unspec (area_info_automatic) = ""b;
	     area_info_automatic.control.extend = "1"b;
	     if sci.debug_mode then			/* make it non-freeing */
		area_info_automatic.control.dont_free = "1"b;
	     else area_info_automatic.control.zero_on_free = "1"b;
	end;					/* normally, zero when freeing */

	else unspec (area_info_automatic) = unspec (P_area_infop -> area_info);
						/* copy the caller's area_info */

	area_infop = addr (area_info_automatic);

	area_info.version = area_info_version_1;	/* and set a few things therein */
	area_info.areap = null ();
	area_info.owner = temp_info.name;
	area_info.size = sys_info$max_seg_size;		/* the entire segment, please */

	call define_area_ (area_infop, code);		/* get it! */

	if code ^= 0 then				/* try to punt... */
	     call ssu_$abort_line (sci_ptr, code, "Unable to define area.");

	temp_info.ptr = area_info.areap;
	P_area_ptr = area_info.areap;			/* return the area pointer */

	return;

/**/

/* Releases a temporary segment */

release_segment:
     entry (P_sci_ptr, P_seg_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.temp_info_ptr = null () then		/* none even allocated yet! */
	     return;

	do idx = 1 to temp_info_array.size;
	     temp_info_ptr = addr (temp_info_array.element (idx));

	     if temp_info.type = SEGMENT_TYPE then
		if temp_info.ptr = P_seg_ptr then do;
		     P_seg_ptr = null ();		/* so caller doesn't try again */
		     call release_temp_segment_ (temp_info.name, temp_info.ptr, (0));

		     temp_info.type = NO_TYPE;	/* and free up this entry */
		     temp_info.ptr = null ();
		     temp_info.name = "";

		     return;			/* all done */
		end;
	end;					/* of loop looking */

	return;					/* even if we didn't find it */

/**/

/* Release an area */

release_area:
     entry (P_sci_ptr, P_area_ptr);

	call ssu_check_sci (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.temp_info_ptr = null () then		/* none even allocated yet! */
	     return;

	do idx = 1 to temp_info_array.size;
	     temp_info_ptr = addr (temp_info_array.element (idx));

	     if temp_info.type = AREA_TYPE then
		if temp_info.ptr = P_area_ptr then do;
		     P_area_ptr = null ();		/* so caller doesn't try again */
		     call release_area_ (temp_info.ptr);

		     temp_info.type = NO_TYPE;	/* and free up this entry */
		     temp_info.ptr = null ();
		     temp_info.name = "";

		     return;			/* all done */
		end;
	end;					/* of loop looking */

	return;					/* even if we didn't find it */

/**/

/* Release all segments and area acquired by this subsystem: called by ssu_$destroy_invocation */

release_everything:
     entry (P_sci_ptr);

	sci_ptr = P_sci_ptr;

	if sci.temp_info_ptr = null () then return;	/* no temporaries allocated */

	do idx = 1 to temp_info_array.size;
	     temp_info_ptr = addr (temp_info_array.element (idx));

	     if temp_info.type = AREA_TYPE then call release_area_ (temp_info.ptr);

	     else if temp_info.type = SEGMENT_TYPE then call release_temp_segment_ (temp_info.name, temp_info.ptr, (0));

	     temp_info.type = NO_TYPE;		/* and free up this entry */
	     temp_info.ptr = null ();
	     temp_info.name = "";
	end;					/* of loop releasing */

	old_ptr = sci.temp_info_ptr;			/* null pointer first to avoid trying to free it twice */
	sci.temp_info_ptr = null ();

	free old_ptr -> temp_info_array in (sci_parent_area);

	return;

/**/

/* Finds a empty temp_info element: expands the array of temp_info's if necessary */

get_temp_info_ptr:
     procedure ();

dcl  idx fixed binary;
dcl  new_ptr pointer;

	if sci.temp_info_ptr = null () then do;
	     alloc_temp_info_array_size = 10;		/* start out with ten */
	     allocate temp_info_array in (sci_parent_area) set (sci.temp_info_ptr);
	     temp_info_array.size = alloc_temp_info_array_size;
	     do idx = 1 to temp_info_array.size;	/* initialize them */
		temp_info_array (idx).type = NO_TYPE;
		temp_info_array (idx).ptr = null ();
		temp_info_array (idx).name = "";
	     end;
	end;

	do idx = 1 to temp_info_array.size;		/* look for a free one */
	     if temp_info_array (idx).type = NO_TYPE then do;
		temp_info_ptr = addr (temp_info_array.element (idx));
		return;				/* got one */
	     end;
	end;

	old_ptr = sci.temp_info_ptr;			/* no free slots: make it bigger */
	alloc_temp_info_array_size = 3 * temp_info_array.size;

	allocate temp_info_array in (sci_parent_area) set (new_ptr);

	new_ptr -> temp_info_array.size = alloc_temp_info_array_size;

	do idx = 1 to old_ptr -> temp_info_array.size;	/* copy all the existing ones */
	     new_ptr -> temp_info_array.element (idx) = old_ptr -> temp_info_array.element (idx);
	end;

	do idx = (old_ptr -> temp_info_array.size + 1) to new_ptr -> temp_info_array.size;
	     new_ptr -> temp_info_array (idx).type = NO_TYPE;
	     new_ptr -> temp_info_array (idx).ptr = null ();
	     new_ptr -> temp_info_array (idx).name = "";
	end;					/* and initialize all the new ones */

	sci.temp_info_ptr = new_ptr;			/* new one is now ready */

	temp_info_ptr = addr (new_ptr -> temp_info_array.element (old_ptr -> temp_info_array.size + 1));
						/* first new */

	free old_ptr -> temp_info_array in (sci_parent_area);

	return;

     end get_temp_info_ptr;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include area_info;

     end ssu_temp_mgr_;




		    ssu_usage_.pl1                  08/05/87  0809.0r   08/04/87  1539.4       59841



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


/* Manages the SUBSYSTEM.ssusage segments, which are used to record usage of the subsystem, as well as to keep track of
   blast messages */

/* Created:  15 May 1980 by W. Olin Sibert */
/* Modified: 4 November 1981 by W. Olin Sibert to change the suffix of usage segments to ".ssusage" */
/* Modified: 5 November 1981 by G. Palter to properly count usage of the latest subsystem version */

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


ssu_usage_:
     procedure ();


/* Parameters */

dcl  P_sci_ptr pointer parameter;
dcl  P_code fixed binary (35) parameter;

dcl  P_ref_ptr pointer parameter;			/* implements referencing_dir to find the usage segment */

dcl  P_threshold fixed binary parameter;		/* print_blast: maximum number of times to print the blast */
dcl  P_blast_message character (*) varying parameter;	/* print_blast: a message to users of the subsystem */


/* Local copies of parameters */

dcl  ref_ptr pointer;

dcl  code fixed binary (35);


/* Remaining declarations */

dcl  silent_sw bit (1) aligned;			/* ON => print the blast message */

dcl  user_name character (24);
dcl  (idx, jdx) fixed binary;
dcl  usage_seg_name character (32);

dcl  continue_to_signal_ entry (fixed binary (35));
dcl  find_condition_info_ entry (pointer, pointer, fixed binary (35));
dcl  hcs_$make_ptr entry (pointer, character (*), character (*), pointer, fixed binary (35));
dcl  hcs_$set_bc_seg entry (pointer, fixed binary (24), fixed binary (35));
dcl  ioa_ entry () options (variable);
dcl  user_info_$whoami entry (character (*), character (*), character (*));

dcl  error_table_$fatal_error fixed binary (35) external;
dcl  error_table_$action_not_performed fixed binary (35) external;

dcl  (cleanup, any_other) condition;

dcl  (addr, clock, currentsize, hbound, length, maxlength, null, rtrim, substr) builtin;

/**/

/* Record a use of the subsystem and print a blast message if this user has not seen it P_threshold times */

print_blast:
     entry (P_sci_ptr, P_ref_ptr, P_threshold, P_blast_message, P_code);

	sci_ptr = P_sci_ptr;
	ref_ptr = P_ref_ptr;
	silent_sw = "0"b;
	go to COMMON;


/* Record a use of the subsystem */

record_usage:
     entry (P_sci_ptr, P_ref_ptr, P_code);

	sci_ptr = P_sci_ptr;
	ref_ptr = P_ref_ptr;
	silent_sw = "1"b;
	go to COMMON;


COMMON:
	call ssu_check_sci (sci_ptr);

	usage_seg_name = rtrim (sci.subsystem_name) || ".ssusage";

	call hcs_$make_ptr (ref_ptr, usage_seg_name, (""), usage_seg_ptr, code);
	if code ^= 0 then do;
PUNT_FOR_GOOD:					/* come here if we decide that it's hopeless */
	     P_code = error_table_$fatal_error;
	     return;
	end;

	on condition (any_other)			/* set up to catch faults */
	     call signal_handler ();

	usage_seg.write_word = 1713359;		/* see if we can write to it */

	call user_info_$whoami (user_name, (""), (""));

	call lookup_user_entry (idx);			/* see if we can find the right one */

	usage_seg.user (idx).last_time = clock ();	/* now, update the info in the segment */
	usage_seg.user (idx).total_count = usage_seg.user (idx).total_count + 1;

	usage_seg.all.last_time = clock ();
	usage_seg.all.total_count = usage_seg.all.total_count + 1;

	if usage_seg.user (idx).version ^= sci.subsystem_version then do;
	     usage_seg.user (idx).version = sci.subsystem_version;
	     usage_seg.user (idx).this_version_count = 1;
	     usage_seg.user (idx).this_version_blast = 0;
	end;
	else usage_seg.user (idx).this_version_count = usage_seg.user (idx).this_version_count + 1;

	if ^silent_sw then do;			/* should we print the blast? */
	     if usage_seg.user (idx).this_version_blast < P_threshold then do;
		usage_seg.user (idx).this_version_blast = usage_seg.user (idx).this_version_blast + 1;
		call ioa_ ("^a ^a^[: ^a^]", sci.subsystem_name, sci.subsystem_version, (length (P_blast_message) > 0),
		     P_blast_message);
	     end;
	end;

	P_code = 0;

	return;					/* all done */

/**/

/* Handles any faults which occur while referencing the usage segment */

signal_handler:
     procedure ();

dcl  1 cond_info aligned like condition_info automatic;
dcl  idx fixed binary;
dcl  code fixed binary (35);
dcl  name character (32);

dcl  GOOD_CONDITIONS (9) character (32) static options (constant)
	initial ("alrm", "cput", "finish", "mme2", "program_interrupt", "quit", "trm_", "sus_", "wkp_");

	cond_info.version = 1;

	call find_condition_info_ ((null ()), addr (cond_info), code);
	if code ^= 0 then goto PUNT_FOR_GOOD;

	if substr (cond_info.condition_name, 1, 8) = "command_" then do;
	     call continue_to_signal_ ((0));
	     return;
	end;

	do idx = 1 to hbound (GOOD_CONDITIONS, 1);
	     if cond_info.condition_name = GOOD_CONDITIONS (idx) then do;
		call continue_to_signal_ ((0));
		return;
	     end;
	end;

	go to PUNT_FOR_GOOD;			/*  can't reference the usage segment */

     end signal_handler;

/**/

/* Looks up the user's entry in the usage segment, creating an entry if necessary */

lookup_user_entry:
     procedure (p_idx);

dcl  p_idx fixed binary parameter;
dcl  idx fixed binary;

	if usage_seg.count >= USAGE_SEG_MAX_ENTRIES then	/* something wrong here */
	     go to PUNT_FOR_GOOD;

	if usage_seg.version ^= USAGE_SEG_VERSION_1 then do;
	     usage_seg.count = 0;			/* either transhed or needs to be initialized */
	     usage_seg.version = USAGE_SEG_VERSION_1;
	end;

	do idx = 1 to usage_seg.count;
	     if usage_seg.user (idx).name = user_name then do;
		p_idx = idx;			/* found it */
		return;
	     end;
	end;

	usage_seg.count = usage_seg.count + 1;		/* update the count */
	idx = usage_seg.count;			/* this could race, but not harmfully */

	usage_seg.user (idx).name = user_name;		/* fill it in */
	usage_seg.user (idx).first_time = clock ();
	usage_seg.user (idx).last_time = 0;
	usage_seg.user (idx).version = "<NONE>";
	usage_seg.user (idx).total_count = 0;
	usage_seg.user (idx).this_version_count = 0;
	usage_seg.user (idx).this_version_blast = 0;
	usage_seg.user (idx).hash_thread = 0;
	usage_seg.user (idx).pad1 (*) = ""b;

	call hcs_$set_bc_seg (usage_seg_ptr, (36 * currentsize (usage_seg)), (0));
						/* update the bitcount to reflect the new entry */

	p_idx = idx;

	return;

     end lookup_user_entry;

/**/

%include "_ssu_check_sci";
%page;
%include "_ssu_sci";
%page;
%include "_ssu_usage_seg";
%page;
%include condition_info;

     end ssu_usage_;






		    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
