<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">



		    decode_entryname_.pl1           11/04/82  2003.4rew 11/04/82  1630.7       15525



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


decode_entryname_:	procedure (cname, rname, ename);


/*

	This procedure, given an entryname of the form "a$b" will
	return the refname and entry portions separately, i.e. "a"
	and "b".  If no "$" is found in the input string, "a$a" is
	assumed.  If the input string is of the form "a$", "a" and
	"" are returned.

	P. Bos, May 1972

*/

     dcl	cname			char(*),		/* entryname, "a$b" */
	rname			char(32),		/* refname "a" */
	ename			char(32);		/* entry "b" */

     dcl (index, length, substr)	builtin;

     dcl (i, l)			fixed bin;


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


	l = length (cname);				/* get length of input string */
	i = index (cname, "$");			/* scan for delimiter */
	if i = 0 then do;				/* no "$", assume "a$a" */
	     rname, ename = cname;			/* set return values */
	     return;				/* and exit */
	     end;
	rname = substr (cname, 1, i-1);		/* extract "a" portion */
	if i &lt; l then				/* if "$" was not last char */
	     ename = substr (cname, i+1, l-i);		/* then extract "b" */
	else					/* input was "a$" */
	     ename = "";				/* give null string for entry */

	return;					/* exit */


	end decode_entryname_;
���



		    do.pl1                          10/15/86  1429.4rew 10/15/86  1407.9      362331



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

/****^		DO/EXECUTE_STRING/SUBSTITUTE_ARGUMENTS

      Command/requests to expand specified string by substituting
      arguments, and optionally executing the expansion.

      Created:  30 October 1973 by BLW.
      Modified: 31 December 1974 by Steve Herbst to remove string parameter.
      Modified: 16 December 1975 by Steve Herbst to add &amp;f and &amp;n.
      Modified: 3 March 1976 by Steve Herbst to add &amp;qf and &amp;rf.
      Modified: 3 August 1976 by Steve Herbst to accept any number of
	      mode-changing control arguments.
      Modified: 15 October 1976 by Steve Herbst to fix bug with &amp;f.
      Modified: 16 February 1982 by G. Palter to add ssu_do_request_ and
	      convert to use a standalone subsystem invocation.
      Modified: 28 April 1982 by G. Dixon to allow AF first arg to begin with
	      minus.
      Modified: 8 September 1982 by G. Palter to propagate subsystem/request
	      line aborts. */



/****^  HISTORY COMMENTS:
  1) change(86-08-11,JSLove), approve(86-08-12,MCR7520),
     audit(86-08-14,FCSmith), install(86-10-01,MR12.0-1170):
     Changed to permit control arguments and the control string in the same
     invocation. Added -control_string (-cs) option to permit control string to
     begin with a hyphen.  Added -inhibit_error and -no_inhibit_error as
     synonyms of -absentee and -interactive, respectively. Added -abort_line
     (-abl) mode for subsystem execution.  Improved expansion error
     diagnostics. Changed handling of &amp;r1&amp;r2 to eliminate spurious quote. Added
     &amp;control_string construct and handling of "zeroth" argument.
  2) change(86-08-11,JSLove), approve(86-08-12,MCR7519),
     audit(86-08-14,FCSmith), install(86-10-01,MR12.0-1170):
     Added execute_string and substitute_arguments entries. At this time,
     substantial changes were required to permit the expansion of the
     execute_string AF's -error_value.  Other changes were made for clarity,
     coding standards, performance, robustness and minimizing the stack frame
     size.   The complete set of changes amount to a substantial rewrite,
     including: Removed standalone subsystem invocation.  Changed to allocate
     expanded buffer rather than growing stack frame.  Changed to use PL/I "on"
     statement to set handlers rather than the condition_ subroutine.
  3) change(86-10-09,JSLove), approve(86-10-13,MCR7519),
     audit(86-10-13,Parisek), install(86-10-15,MR12.0-1186):
     Post-installation Bug Fix: changed error message associated with request
     line aborts to not report ssu_et_$request_line_aborted in brief mode.
                                                   END HISTORY COMMENTS */



/* format: style3,ifthenstmt,indcomtxt,indproc,idind30 */

do:
     procedure () options (variable);

declare	P_info_ptr		ptr parameter,	/* subsystem request -&gt; subsystem's internal data */
	P_sci_ptr			ptr parameter;	/* subsystem request -&gt; SCI of subsystem */

declare	(addcharno, addr, addwordno, binary, copy, divide, hbound, index, lbound, length, ltrim, maxlength, min, mod,
	null, rtrim, substr, verify)	builtin;

declare	(active_function_error, any_other, area, cleanup)
				condition;

declare	abort_line		bit (1) aligned,
	allocated_buffer_max_len	fixed bin (21),
	allocated_buffer_ptr	ptr,
	arg_count			fixed bin (17),
	arg_list_ptr		ptr,
	arg_offset		fixed bin (17),
	entrypoint		fixed bin (2),
	error_value_len		fixed bin (21),
	error_value_ptr		ptr,
	execute			bit (1) aligned,
	expansion_buffer		char (256) varying,
	expansion_max_len		fixed bin (21),
	expansion_ptr		ptr,
	inhibit_error		bit (1) aligned,
	rescan_type		fixed bin (17),
	return_value_max_len	fixed bin (21),
	return_value_ptr		ptr,
	sci_ptr			ptr,
	status			fixed bin (35),
	trace			bit (1) aligned,
	unique			char (15) aligned;

declare	allocated_buffer		char (allocated_buffer_max_len) varying based (allocated_buffer_ptr),
	command			char (length (expansion)) based (addwordno (addr (expansion), 1)),
	expansion			char (expansion_max_len) varying based (expansion_ptr),
	return_value		char (return_value_max_len) varying based (return_value_ptr),
	system_area		area based (get_system_free_area_ ());

declare	abort_line_mode		(2) bit (1) aligned static initial ((2) ("1"b)),
	execute_mode		(2) bit (1) aligned static initial ((2) ("1"b)),
	inhibit_error_mode		(2) bit (1) aligned static initial ((2) ("0"b)),
	trace_mode		(3) bit (1) aligned static initial ((3) ("0"b));

declare	AMPERSAND			char (1) static options (constant) initial ("&amp;"),
	BLANK			char (1) static options (constant) initial (" "),
	QUOTE			char (1) static options (constant) initial (""""),
	WHITE			char (5) static options (constant) initial ("
	 ");					/* FF VT NL HT SPACE				*/

declare	(
	DO_ENTRY			initial (1),
	EXECUTE_ENTRY		initial (2),
	SUBSTITUTE_ENTRY		initial (3)
	)			fixed bin (2) static options (constant);

declare	(
	ILLEGAL_CHARACTER		initial (1),
	ILLEGAL_END_CONTROL_STRING	initial (2),
	ILLEGAL_END_ERROR_VALUE	initial (3),
	ILLEGAL_INTEGER		initial (4),
	ILLEGAL_KEYWORD		initial (5),
	ILLEGAL_UNCLOSED		initial (6)
	)			fixed bin (3) static options (constant);

declare	(
	NO_QUOTE_MODIFIER		initial (1),
	PROTECT_QUOTES_MODIFIER	initial (2),
	REQUOTE_MODIFIER		initial (3)
	)			fixed bin (2) static options (constant);

declare	MY_NAME			(3) char (20) static options (constant)
				initial ("do", "execute_string", "substitute_arguments"),
	MY_SHORT_NAME		(3) char (4) varying static options (constant) initial ("do", "exs", "sbag");

declare	(
	PARSER_EXPLICIT_CONTROL_STRING
				initial (1),
	PARSER_FOUND_CONTROL_STRING	initial (2),
	PARSER_WANTS_CONTROL_STRING	initial (3),
	PARSER_WANTS_ERROR_VALUE	initial (4)
	)			fixed bin (3) static options (constant);

declare	REASONS			(6) char (85) varying static options (constant)
				initial ("An invalid character terminates substitution construct ^a.",
				"Substitution construct ^a is incomplete at the end of the control string.",
				"Substitution construct ^a is incomplete at the end of the error value.",
				"The parenthesized part of substitution construct ^a must be an unsigned integer.",
				"^a is not a valid substitution construct.",
				"There is no "")"" terminating substitution construct ^a.");

declare	SPECIAL_CONDITIONS		(5) char (24) varying static options (constant)
				initial ("alrm", "cput", "quit", "program_interrupt", "record_quota_overflow");

declare	(
	COMMAND_USAGE		char (39) initial ("{-control_args} {control_string {args}}"),
	EXS_AF_USAGE		char (37) initial ("{-control_args} control_string {args}"),
	SBAG_AF_USAGE		char (21) initial ("control_string {args}") char (21)
	)			static options (constant);

declare	NO_FROM_WARNING		char (95) static options (constant)
				initial ("""&amp;^[q^;r^]f&amp;n"" must be used instead of argument designator ^a.^[
	Type ""start"" to continue.^]");

declare	TRUNCATION_WARNING		char (127) static options (constant) initial ("
	Only the first ^d characters of the expanded ^[error value^;control string^]
	can be returned.^[  Type ""start"" to continue.^]");

declare	(
	error_table_$badopt,
	error_table_$command_line_overflow,
	error_table_$inconsistent,
	error_table_$noarg,
	error_table_$not_act_fnc,
	ssu_et_$null_request_line,
	ssu_et_$request_line_aborted,
	ssu_et_$subsystem_aborted
	)			fixed bin (35) external;

declare	iox_$error_output		ptr external;

declare	active_fnc_err_		entry () options (variable),
	active_fnc_err_$suppress_name entry () options (variable),
	com_err_			entry () options (variable),
	com_err_$suppress_name	entry () options (variable),
	condition_interpreter_	entry (ptr, ptr, fixed bin (17), fixed bin (17), ptr, char (*), ptr, ptr),
	continue_to_signal_		entry (fixed bin (35)),
	cu_$af_return_arg_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	cu_$arg_list_ptr		entry () returns (ptr),
	cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	cu_$cp			entry (ptr, fixed bin (21), fixed bin (35)),
	cu_$evaluate_active_string	entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)),
	find_condition_info_	entry (ptr, ptr, fixed bin (35)),
	get_system_free_area_	entry () returns (ptr),
	ioa_			entry () options (variable),
	ioa_$general_rs		entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
				bit (1) aligned),
	ioa_$ioa_switch		entry () options (variable),
	requote_string_		entry (char (*)) returns (char (*)),
	ssu_$abort_line		entry () options (variable),
	ssu_$abort_subsystem	entry () options (variable),
	ssu_$arg_ptr		entry (ptr, fixed bin (17), ptr, fixed bin (21)),
	ssu_$evaluate_active_string	entry (ptr, ptr, char (*), fixed bin (17), char (*) var, fixed bin (35)),
	ssu_$execute_line		entry (ptr, ptr, fixed bin (21), fixed bin (35)),
	ssu_$get_subsystem_and_request_name
				entry (ptr) returns (char (72) varying),
	ssu_$get_request_name	entry (ptr) returns (char (32)),
	ssu_$print_message		entry () options (variable),
	ssu_$return_arg		entry (ptr, fixed bin (17), bit (1) aligned, ptr, fixed bin (21)),
	unique_chars_		entry (bit (*) aligned) returns (char (15) aligned);
%page;
%include condition_info;
%page;
%include cp_active_string_types;
%page;
/* do: entry () options (variable); */

	entrypoint = DO_ENTRY;			/* Execute as command, Substitute as AF */

	go to STANDALONE;

exs:
execute_string:
     entry () options (variable);

	entrypoint = EXECUTE_ENTRY;

	go to STANDALONE;

sbag:
substitute_args:
substitute_arguments:
     entry () options (variable);

	entrypoint = SUBSTITUTE_ENTRY;

STANDALONE:
	sci_ptr = null ();

	go to COMMON;

ssu_do_request_:
     entry (P_sci_ptr, P_info_ptr);

	entrypoint = DO_ENTRY;

	go to SUBSYSTEM;

ssu_execute_string_request_:
     entry (P_sci_ptr, P_info_ptr);

	entrypoint = EXECUTE_ENTRY;

	go to SUBSYSTEM;

ssu_substitute_args_request_:
     entry (P_sci_ptr, P_info_ptr);

	entrypoint = SUBSTITUTE_ENTRY;

SUBSYSTEM:
	sci_ptr = P_sci_ptr;

	go to COMMON;
%page;
/* Actual work starts here */

COMMON:
	allocated_buffer_max_len, error_value_len = 0;
	allocated_buffer_ptr, arg_list_ptr, error_value_ptr = null ();
	expansion_max_len = maxlength (expansion_buffer);
	expansion_ptr = addr (expansion_buffer);
	trace = trace_mode (entrypoint);
	unique = "";

	on cleanup
	     begin;
		if allocated_buffer_ptr ^= null () then free allocated_buffer in (system_area);
	     end;

	if sci_ptr = null ()
	then call check_arguments (cu_$arg_list_ptr ());
	else call ssu_$return_arg (sci_ptr, arg_count, ("0"b), return_value_ptr, return_value_max_len);

	if return_value_ptr = null ()
	then go to COMMAND (entrypoint);
	else go to FUNCTION (entrypoint);

COMMAND (1):					/* "do" */
COMMAND (2):					/* "execute_string" */
	call execute_string_command ();

	if ^execute then go to EGRESS;

	if inhibit_error then on any_other call any_other_handler ();

	if sci_ptr = null ()
	then call cu_$cp (addr (command), length (command), status);
	else call ssu_$execute_line (sci_ptr, addr (command), length (command), status);

	revert any_other;

	if status ^= 0 then call execute_string_command_error ();

	go to EGRESS;

COMMAND (3):					/* "substitute_arguments" */
	call substitute_args_command ();

EGRESS:						/* Common exit and error abort point */
	revert active_function_error, any_other;

	if allocated_buffer_ptr ^= null () then free allocated_buffer in (system_area);

	return;
%page;
FUNCTION (1):					/* "do" */
FUNCTION (3):					/* "substitute_arguments" */
	call substitute_args_function ();

	go to EGRESS;

FUNCTION (2):					/* "execute_string" */
	call execute_string_function ();

	if error_value_ptr ^= null ()
	then do;
		if sci_ptr = null () then on active_function_error call active_function_error_handler ();
		if inhibit_error then on any_other call any_other_handler ();
	     end;

	if sci_ptr = null ()
	then call cu_$evaluate_active_string (null (), command, rescan_type, return_value, status);
	else call ssu_$evaluate_active_string (sci_ptr, null (), command, rescan_type, return_value, status);

	revert active_function_error, any_other;

	if status ^= 0 then call execute_string_function_error ();

	go to EGRESS;

SUBSTITUTE_ERROR_VALUE:
	revert active_function_error, any_other;

	call expand_error_value ();

	go to EGRESS;
%page;
/**** Handler for errors during execution of an active function.  Only
      errors reported by the active function are caught by this handler, as
      opposed to faults which might occur during its execution. */

active_function_error_handler:
     procedure ();

declare	1 CI			aligned like condition_info;

	if trace
	then do;
		CI.version = condition_info_version_1;
		call find_condition_info_ (null (), addr (CI), (0));
		call condition_interpreter_ (null (), null (), 0, 0, CI.mc_ptr, (CI.condition_name), CI.wc_ptr,
		     CI.info_ptr);
	     end;

	go to SUBSTITUTE_ERROR_VALUE;

     end active_function_error_handler;
%page;
/**** Handler for unexpected conditions during execution of the command,
      active function or request line.  Certain conditions are ignored
      (i.e., passed on to other handlers). */

any_other_handler:
     procedure ();

declare	conditionx		fixed bin (17);

declare	1 CI			aligned like condition_info;

	CI.version = condition_info_version_1;
	call find_condition_info_ (null (), addr (CI), (0));

	if length (CI.condition_name) &gt; length ("command_")
	then if substr (CI.condition_name, 1, length ("command_")) = "command_" then go to CONTINUE;

	do conditionx = lbound (SPECIAL_CONDITIONS, 1) to hbound (SPECIAL_CONDITIONS, 1);

	     if CI.condition_name = SPECIAL_CONDITIONS (conditionx) then go to CONTINUE;
	end;

	if return_value_ptr = null () | trace
	then call condition_interpreter_ (null (), null (), 0, 0, CI.mc_ptr, (CI.condition_name), CI.wc_ptr,
		CI.info_ptr);

	if error_value_ptr ^= null ()
	then go to SUBSTITUTE_ERROR_VALUE;
	else go to EGRESS;

CONTINUE:
	call continue_to_signal_ ((0));

	return;

     end any_other_handler;
%page;
/**** Get argument count and active function return value for non-SSU case. */

check_arguments:
     procedure (P_arg_list_ptr) options (non_quick);

declare	P_arg_list_ptr		ptr parameter;

	arg_list_ptr = P_arg_list_ptr;

	call cu_$af_return_arg_rel (arg_count, return_value_ptr, return_value_max_len, status, arg_list_ptr);
	if status = 0 then return;
	if status = error_table_$not_act_fnc then return;

	call com_err_ (status, MY_NAME (entrypoint), "Can't get argument count.");

	go to EGRESS;

     end check_arguments;
%page;
execute_string_command:
     procedure () options (non_quick);

declare	arg_len			fixed bin (21),
	arg_ptr			ptr,
	argx			fixed bin (17),
	control_string_len		fixed bin (21),
	control_string_ptr		ptr,
	parser			fixed bin (3),
	saved_parser		fixed bin (3);

declare	arg			char (arg_len) based (arg_ptr),
	control_string		char (control_string_len) based (control_string_ptr);

	if arg_count = 0 then call usage (COMMAND_USAGE);

	abort_line = abort_line_mode (entrypoint);
	execute = execute_mode (entrypoint);
	inhibit_error = inhibit_error_mode (entrypoint);
	parser = PARSER_WANTS_CONTROL_STRING;

	do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING);

	     call get_argument (argx);

	     if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING;
	     else if substr (arg, 1, min (1, length (arg))) = "-"
	     then if arg = "-abort_line" | arg = "-abl" then abort_line = "1"b;
		else if arg = "-brief" | arg = "-bf" then trace = "0"b;
		else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING;
		else if arg = "-go" then execute = "1"b;
		else if arg = "-inhibit_error" | arg = "-ihe" | arg = "-absentee" | arg = "-abs"
		then inhibit_error = "1"b;
		else if arg = "-long" | arg = "-lg" then trace = "1"b;
		else if arg = "-no_abort_line" | arg = "-nabl" then abort_line = "0"b;
		else if arg = "-no_go" | arg = "-nogo" then execute = "0"b;
		else if arg = "-no_inhibit_error" | arg = "-nihe" | arg = "-interactive" | arg = "-ia"
		then inhibit_error = "0"b;
		else go to BADOPT;
	     else parser = PARSER_FOUND_CONTROL_STRING;
	end;

	if parser = PARSER_WANTS_CONTROL_STRING
	then do;
		abort_line_mode (entrypoint) = abort_line;
		execute_mode (entrypoint) = execute;
		inhibit_error_mode (entrypoint) = inhibit_error;
		trace_mode (entrypoint) = trace;
		go to EGRESS;
	     end;

	if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG;

	arg_offset = argx - 1;

	call expand ();

	return;
%page;
execute_string_function:
     entry ();

	inhibit_error = "0"b;
	parser = PARSER_WANTS_CONTROL_STRING;
	rescan_type = ATOMIC_ACTIVE_STRING;

	do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING);

	     call get_argument (argx);

	     if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING;
	     else if parser = PARSER_WANTS_ERROR_VALUE
	     then do;
		     error_value_len = arg_len;
		     error_value_ptr = arg_ptr;
		     parser = saved_parser;
		end;
	     else if substr (arg, 1, min (1, length (arg))) = "-"
	     then if arg = "-brief" | arg = "-bf" then trace = "0"b;
		else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING;
		else if arg = "-error_value" | arg = "-erv"
		then do;
			saved_parser = parser;
			parser = PARSER_WANTS_ERROR_VALUE;
		     end;
		else if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = "1"b;
		else if arg = "-long" | arg = "-lg" then trace = "1"b;
		else if arg = "-no_inhibit_error" | arg = "-nihe" then inhibit_error = "0"b;
		else if arg = "-no_rescan" | arg = "-nrsc" then rescan_type = ATOMIC_ACTIVE_STRING;
		else if arg = "-rescan" | arg = "-rsc" then rescan_type = NORMAL_ACTIVE_STRING;
		else if arg = "-rescan_tokens" | arg = "-rsct" then rescan_type = TOKENS_ONLY_ACTIVE_STRING;
		else go to BADOPT;
	     else parser = PARSER_FOUND_CONTROL_STRING;
	end;

	if parser = PARSER_WANTS_CONTROL_STRING then call usage (EXS_AF_USAGE);

	if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG;

	if error_value_ptr = null () &amp; inhibit_error
	then call error (error_table_$inconsistent, "-inhibit_error without -error_value");

	if error_value_ptr ^= null () then inhibit_error = inhibit_error | inhibit_error_mode (entrypoint);

	arg_offset = argx - 1;

	call expand ();

	return;
%page;
execute_string_command_error:
     entry ();

	if sci_ptr = null ()
	then do;
		if status = 100 | ^trace then return;
	     end;
	else if status = ssu_et_$null_request_line then return;
	else if status = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr);
	else if status = ssu_et_$request_line_aborted &amp; ^trace
	then if abort_line
	     then call ssu_$abort_line (sci_ptr);
	     else return;

	if abort_line then call error (status, "Executing ^a.", requote_string_ (command));

	call warn (status, "Executing ^a.", requote_string_ (command));

	return;

execute_string_function_error:
     entry ();

	if error_value_ptr = null ()
	then do;
		if status = error_table_$command_line_overflow
		then do;
			call warn (status, "Result truncated to ^d characters^[ evaluating ^a^].",
			     return_value_max_len, trace, requote_string_ (command));
			return;
		     end;

		if sci_ptr ^= null ()
		then if status = ssu_et_$subsystem_aborted then call ssu_$abort_subsystem (sci_ptr);
		     else if status = ssu_et_$request_line_aborted &amp; ^trace then call ssu_$abort_line (sci_ptr);

		if trace then call error (status, "Evaluating ^a.", requote_string_ (command));

		return;
	     end;

expand_error_value:
     entry ();

	arg_len = error_value_len;
	arg_ptr = error_value_ptr;

	expansion_max_len = return_value_max_len;
	expansion_ptr = return_value_ptr;

	call expand ();

	return;
%page;
/**** This case is used only by the substitute_arguments command, and
      accepts fewer control arguments than the execute_string cases.  The
      substitute_arguments command and active function have only the
      long/brief mode, since the other modes relate to execution of the
      expansion. */

substitute_args_command:
     entry ();

	if arg_count = 0 then call usage (COMMAND_USAGE);

	parser = PARSER_WANTS_CONTROL_STRING;

	do argx = 1 to arg_count while (parser ^= PARSER_FOUND_CONTROL_STRING);

	     call get_argument (argx);

	     if parser = PARSER_EXPLICIT_CONTROL_STRING then parser = PARSER_FOUND_CONTROL_STRING;
	     else if substr (arg, 1, min (1, length (arg))) = "-"
	     then if arg = "-brief" | arg = "-bf" then trace = "0"b;
		else if arg = "-control_string" | arg = "-cs" then parser = PARSER_EXPLICIT_CONTROL_STRING;
		else if arg = "-long" | arg = "-lg" then trace = "1"b;
		else go to BADOPT;
	     else parser = PARSER_FOUND_CONTROL_STRING;
	end;

	if parser = PARSER_WANTS_CONTROL_STRING
	then do;
		trace_mode (entrypoint) = trace;
		go to EGRESS;
	     end;

	if parser ^= PARSER_FOUND_CONTROL_STRING then go to NOARG;

	arg_offset = argx - 1;

	call expand ();

	call ioa_ ("^a", expansion);

	return;
%page;
/**** This case is very simple.  No control arguments are accepted.  The
      command processor has already allocated a large but non-expandable
      buffer for the expanded string.  We check that we have at least the
      one required argument, and if so, we set up the environment for
      expansion appropriately, do the expansion, and return. */

substitute_args_function:
     entry ();

	if arg_count = 0 then call usage (SBAG_AF_USAGE);

	arg_offset, argx = 1;

	call get_argument (argx);

	expansion_max_len = return_value_max_len;
	expansion_ptr = return_value_ptr;

	call expand ();

	return;

BADOPT:
	call error (error_table_$badopt, "^a", requote_string_ (arg));

NOARG:
	call error (error_table_$noarg, "Following ^a.", requote_string_ (arg));
%page;
error:
	procedure () options (variable);

declare	arg_list_ptr		ptr,
	buffer			char (256),
	buffer_used		fixed bin (21),
	fatal			bit (1) aligned,
	status_ptr		ptr;

declare	buffer_overlay		char (buffer_used) based (addr (buffer)),
	status			fixed bin (35) based (status_ptr);

	     fatal = "1"b;

	     go to COMMON;

warn:
	entry () options (variable);

	     fatal = "0"b;

COMMON:
	     arg_list_ptr = cu_$arg_list_ptr ();
	     call cu_$arg_ptr_rel (1, status_ptr, (0), (0), arg_list_ptr);
	     call ioa_$general_rs (arg_list_ptr, 2, 3, buffer, buffer_used, "0"b, "0"b);

	     if sci_ptr = null ()
	     then do;
		     if return_value_ptr = null ()
		     then call com_err_ (status, MY_NAME (entrypoint), "^a", buffer_overlay);
		     else call active_fnc_err_ (status, MY_NAME (entrypoint), "^a", buffer_overlay);
		     if fatal then go to EGRESS;
		end;
	     else if fatal then call ssu_$abort_line (sci_ptr, status, "^a", buffer_overlay);
	     else call ssu_$print_message (sci_ptr, status, "^a", buffer_overlay);

	     return;

	end error;
%page;
/**** Expand the control string into the expansion.  For simplicity,
      expansion is a varying character string so that PL/I concatenation
      can be used.  The substitution constructs are mostly recognized a
      character at a time by indexing into lists of the characters which
      are presently valid and dispatching on the position of the current
      character in the list.  This is very efficient. */

expand:
	procedure ();

declare	buffer_overflow		bit (1) aligned,
	command_name		char (72) varying,
	construct_pos		fixed bin (21),
	control_string_pos		fixed bin (21),
	nstring			picture "zzzz9",
	from_sw			bit (1) aligned,
	parm_count		fixed bin (17),
	quote_multiplier		fixed bin (21),
	quote_scan_pos		fixed bin (21),
	requote_last		bit (1) aligned,
	requote_sw		fixed bin (2),
	skip			fixed bin (21),
	string_len		fixed bin (21),
	string_ptr		ptr;

declare	construct			char (control_string_pos - construct_pos)
				based (addcharno (addr (control_string), construct_pos)),
	string			char (string_len) based (string_ptr);

	     buffer_overflow, from_sw = "0"b;
	     control_string_len = arg_len;
	     control_string_pos, quote_scan_pos = 0;
	     control_string_ptr = arg_ptr;
	     expansion = "";
	     parm_count = arg_count - arg_offset;
	     quote_multiplier = 1;
	     requote_last = "0"b;
	     requote_sw = NO_QUOTE_MODIFIER;

	     do while (control_string_pos &lt; length (control_string));

		string_len = index (substr (control_string, control_string_pos + 1), AMPERSAND) - 1;
		if string_len &lt; 0 then string_len = length (control_string) - control_string_pos;

		if string_len &gt; 0
		then do;
			string_ptr = addcharno (control_string_ptr, control_string_pos);
			call add_string ();
			control_string_pos = control_string_pos + string_len;
		     end;

		if control_string_pos &gt;= length (control_string) then go to EXPANDED;

		construct_pos = control_string_pos;
		control_string_pos = control_string_pos + length (AMPERSAND) + 1;

		if control_string_pos &gt; length (control_string) then go to END;

		argx = index ("0123456789!(&amp;&amp;cfnqr", substr (control_string, control_string_pos, 1)) - 1;
		go to DISPATCH (argx);

DISPATCH (-1):					/* illegal -- character not in dispatch string */
		call illegal (ILLEGAL_CHARACTER);

DISPATCH (0):					/* A digit has been found.  The number of the */
DISPATCH (1):					/* parameter to be substituted is in argx. */
DISPATCH (2):					/* Here we handle the from_sw processing, and */
DISPATCH (3):					/* the requote_sw processing is handled in */
DISPATCH (4):					/* expand_arg. */
DISPATCH (5):
DISPATCH (6):
DISPATCH (7):
DISPATCH (8):
DISPATCH (9):
		if from_sw
		then do;
			if argx = 0 then argx = 1;	/* &amp;f0 =&gt; &amp;f1 */

			from_sw = "0"b;		/* Reset for next construct */

			do argx = argx to parm_count;

			     call expand_arg ();

			     if argx &lt; parm_count
			     then do;
				     string_len = length (BLANK);
				     string_ptr = addr (BLANK);
				     call add_string ();
				end;
			end;
		     end;
		else if argx &lt;= parm_count then call expand_arg ();

		requote_sw = NO_QUOTE_MODIFIER;	/* Reset for next expansion */

		go to SCAN_NEXT;

DISPATCH (10):					/* &amp;! -- Substitute a unique string */
		if unique = "" then unique = unique_chars_ (""b);
		string_len = length (unique);
		string_ptr = addr (unique);
		call add_string ();
		go to SCAN_NEXT;

DISPATCH (11):					/* &amp;( -- Begin a parenthesized parameter index */
		string_len = index (substr (control_string, control_string_pos + 1), ")") - 1;
		if string_len &lt; 0 then call illegal (ILLEGAL_UNCLOSED);
		string_ptr = addcharno (control_string_ptr, control_string_pos);
		control_string_pos = control_string_pos + string_len + length (")");

		string_len = length (rtrim (string, WHITE));
		if string_len = 0 then call illegal (ILLEGAL_INTEGER);

		skip = verify (string, WHITE) - 1;
		string_len = string_len - skip;
		string_ptr = addcharno (string_ptr, skip);
		if verify (string, "0123456789") ^= 0 then call illegal (ILLEGAL_INTEGER);
		if length (ltrim (string, "0")) &gt; 5
		then argx = parm_count + 1;
		else argx = binary (string, 17, 0);

		go to DISPATCH (0);

DISPATCH (12):					/* &amp;&amp; -- A literal ampersand */
		string_len = length (AMPERSAND);
		string_ptr = addr (AMPERSAND);
		call add_string ();

		go to SCAN_NEXT;

DISPATCH (13):					/* &amp;f&amp;, &amp;q&amp;, &amp;qf&amp;, &amp;r&amp;, &amp;rf&amp; -- The last parameter */
		if control_string_pos + length ("n") &gt; length (control_string) then go to END;
		control_string_pos = control_string_pos + length ("n");
		if substr (control_string, control_string_pos, length ("n")) ^= "n"
		then call illegal (ILLEGAL_CHARACTER);

		if ^from_sw
		then do;
			call warn (0, NO_FROM_WARNING, requote_sw = PROTECT_QUOTES_MODIFIER,
			     requote_string_ (construct), return_value_ptr ^= null () &amp; sci_ptr = null ());
			from_sw = "1"b;
		     end;

		argx = parm_count;

		go to DISPATCH (0);

DISPATCH (14):					/* &amp;c -- begins &amp;control_string */
		control_string_pos = control_string_pos + length ("ontrol_string");
		if control_string_pos &gt; length (control_string) then call illegal (ILLEGAL_KEYWORD);
		if substr (control_string, construct_pos + 2, length ("control_string")) ^= "control_string"
		then call illegal (ILLEGAL_KEYWORD);

		argx = 0;
		requote_sw = PROTECT_QUOTES_MODIFIER;

		go to DISPATCH (0);

DISPATCH (15):					/* &amp;f, &amp;qf and &amp;rf -- Substitute a range of parameters */
		from_sw = "1"b;

		if control_string_pos &gt;= length (control_string) then go to END;
		control_string_pos = control_string_pos + 1;

		argx = index ("01234567899((&amp;", substr (control_string, control_string_pos, 1)) - 1;
		go to DISPATCH (argx);

DISPATCH (16):					/* &amp;n -- Substitute the number of optional arguments */
		nstring = parm_count;
		string_len = verify (nstring, BLANK) - 1;
		string_ptr = addcharno (addr (nstring), string_len);
		string_len = length (nstring) - string_len;
		call add_string ();

		go to SCAN_NEXT;

DISPATCH (17):					/* &amp;q -- Protect quotes in the parameter */
		requote_sw = PROTECT_QUOTES_MODIFIER;
		go to AFTER_QUOTE_MODIFIER;

DISPATCH (18):					/* &amp;r -- Requote the parameter */
		requote_sw = REQUOTE_MODIFIER;

AFTER_QUOTE_MODIFIER:
		if control_string_pos &gt;= length (control_string) then go to END;
		control_string_pos = control_string_pos + 1;

		argx = index ("01234567899((&amp;&amp;f", substr (control_string, control_string_pos, 1)) - 1;
		go to DISPATCH (argx);

SCAN_NEXT:
	     end;


/**** Argument substitution is completed. */

EXPANDED:
	     if trace
	     then do;
		     if sci_ptr = null ()
		     then command_name = MY_NAME (entrypoint);
		     else command_name = ssu_$get_subsystem_and_request_name (sci_ptr);
		     call ioa_$ioa_switch (iox_$error_output, "^[[^a^[ -error_value^]]^;^a^s^]: (^d) ^a",
			return_value_ptr ^= null (), command_name,
			return_value_ptr = expansion_ptr &amp; entrypoint = EXECUTE_ENTRY, length (command),
			requote_string_ (command));
		end;

	     return;


/**** The end of the string beging expanded was found after an ampersand
      was encountered but before a valid substitution construct was
      completed. */

END:
	     if entrypoint = EXECUTE_ENTRY &amp; expansion_ptr = return_value_ptr
	     then call illegal (ILLEGAL_END_ERROR_VALUE);
	     else call illegal (ILLEGAL_END_CONTROL_STRING);
%page;
/**** These operations are gathered in a subroutine to reduce code size in
      exchange for a very slight performance penalty.  The overlay is used
      to add QUOTE characters to the string in order to avoid a stack
      extension. */

add_quotes:
	     procedure ();

declare	old_len			fixed bin (21);

declare	1 expansion_overlay		aligned based (expansion_ptr),
	  2 len			fixed bin (21),
	  2 str			char (0 refer (expansion_overlay.len));

		call check_buffer ();

		old_len = expansion_overlay.len;
		expansion_overlay.len = expansion_overlay.len + string_len;
		substr (expansion_overlay.str, old_len + 1, string_len) = copy (QUOTE, string_len);

		if buffer_overflow then go to EXPANDED;

		return;

add_string:
	     entry ();

		call check_buffer ();

		expansion = expansion || string;

		if buffer_overflow then go to EXPANDED;

		return;

	     end add_quotes;
%page;
/**** The expansion has become too large for the expansion buffer.
      Allocate a bigger buffer, and free the old one if it was allocated.
      The initial buffer is automatic, and must be not be freed. */

allocate_buffer:
	     procedure ();

declare	new_buffer_ptr		ptr,
	old_buffer_max_len		fixed bin (21);

		new_buffer_ptr = null ();
		old_buffer_max_len = allocated_buffer_max_len;

		on cleanup
		     begin;
			if new_buffer_ptr ^= null () &amp; new_buffer_ptr ^= allocated_buffer_ptr
			then free new_buffer_ptr -&gt; allocated_buffer in (system_area);
		     end;

		on area go to AREA_HANDLER;

		allocated_buffer_max_len =
		     maxlength (expansion) + string_len + length (control_string) + 8 * parm_count;

		allocate allocated_buffer in (system_area) set (new_buffer_ptr);

		new_buffer_ptr -&gt; allocated_buffer = expansion;
		expansion_max_len = allocated_buffer_max_len;

		if allocated_buffer_ptr ^= null ()
		then do;
			allocated_buffer_max_len = old_buffer_max_len;
			free allocated_buffer in (system_area);
		     end;

		allocated_buffer_ptr, expansion_ptr = new_buffer_ptr;

		return;

AREA_HANDLER:
		call error (0, "Can't allocate a buffer large enough to hold the expanded control string.");

	     end allocate_buffer;
%page;
/**** Ensure that there is sufficient space in the expansion buffer to
      permit the addition of string_len characters to the buffer.  If there
      is not, grow the buffer if possible.  The case where we can't try to
      grow the buffer is when the buffer is the active function return
      value.  Since the command processor can't accept a bigger value, we
      announce that the string was truncated and set string_len to what
      will actually fit.  Setting buffer_overflow will cause termination of
      the expansion after the characters have been appended.  Note that
      ssu_$print_message will only return for active functions after the
      user issues "start", but not for the subsystem active request case.
      The only cases where expansion is directlyt overlayed on the return
      value are the do/sbag active function and the -error_value for
      execute_string. */

check_buffer:
	     procedure ();

		if length (string) ^= 0 then requote_last = "0"b;

		if length (expansion) + length (string) &lt;= maxlength (expansion) then return;

		if expansion_ptr = return_value_ptr
		then do;
			buffer_overflow = "1"b;
			string_len = maxlength (expansion) - length (expansion);
			call warn (error_table_$command_line_overflow, TRUNCATION_WARNING, expansion_max_len,
			     entrypoint = EXECUTE_ENTRY, return_value_ptr ^= null () &amp; sci_ptr = null ());
			return;
		     end;

		call allocate_buffer ();		/* Make it bigger */

		return;

	     end check_buffer;
%page;
/**** Get the substitution parameter which is argx after the control
      string, and append it to the expansion with appropriate quote
      processing.  If no quote modifier was specified, then no special
      processing is required.  Otherwise, the string up to this point must
      be scanned to determine the current quote level.  Then the parameter
      is appended with optional requotinq and quotes doubled according to
      the quote level. */

expand_arg:
	     procedure ();

declare	arg_pos			fixed bin (21);

		call get_argument (argx + arg_offset);

		if requote_sw = NO_QUOTE_MODIFIER
		then do;
			string_len = arg_len;
			string_ptr = arg_ptr;
			call add_string ();
			return;
		     end;

		do while (quote_scan_pos &lt; length (expansion));

		     string_len = index (substr (expansion, quote_scan_pos + 1), QUOTE) - 1;
		     if string_len &lt; 0 then string_len = length (expansion) - quote_scan_pos;

		     quote_scan_pos = quote_scan_pos + string_len;
		     if quote_scan_pos &lt; length (expansion)
		     then do;
			     string_len = verify (substr (expansion, quote_scan_pos + 1), QUOTE) - 1;
			     if string_len &lt; 0 then string_len = length (expansion) - quote_scan_pos;
			     quote_scan_pos = quote_scan_pos + string_len;

			     if mod (string_len, quote_multiplier) = 0
			     then do while (mod (string_len, 2 * quote_multiplier) ^= 0);
				     string_len = string_len - quote_multiplier;
				     quote_multiplier = 2 * quote_multiplier;
				end;
			     else do while (string_len ^= 0);
				     quote_multiplier = divide (quote_multiplier, 2, 21, 0);
				     string_len = mod (string_len, quote_multiplier);
				end;
			end;
		end;

		if requote_sw = REQUOTE_MODIFIER
		then do;
			if requote_last
			then expansion = substr (expansion, 1, length (expansion) - quote_multiplier);
			else do;
				string_len = quote_multiplier;
				call add_quotes ();
			     end;
			quote_multiplier = 2 * quote_multiplier;
		     end;

		if quote_multiplier = 1
		then do;
			string_len = arg_len;
			string_ptr = arg_ptr;
			call add_string ();
		     end;
		else do;
			arg_pos = 0;

			do while (arg_pos &lt; length (arg));

			     string_len = index (substr (arg, arg_pos + 1), QUOTE) - 1;
			     if string_len &lt; 0 then string_len = length (arg) - arg_pos;
			     if string_len &gt; 0
			     then do;
				     string_ptr = addcharno (addr (arg), arg_pos);
				     call add_string ();
				     arg_pos = arg_pos + string_len;
				end;

			     if arg_pos &lt; length (arg)
			     then do;
				     string_len = verify (substr (arg, arg_pos + 1), QUOTE) - 1;
				     if string_len &lt; 0 then string_len = length (arg) - arg_pos;
				     arg_pos = arg_pos + string_len;

				     string_len = string_len * quote_multiplier;
				     call add_quotes ();
				end;
			end;
		     end;

		if requote_sw = REQUOTE_MODIFIER
		then do;
			string_len, quote_multiplier = divide (quote_multiplier, 2, 17, 0);
			call add_quotes ();
			requote_last = "1"b;	/* Remember ending quotes in case of &amp;r1&amp;r2 */
		     end;

		quote_scan_pos = length (expansion);	/* Don't let protected expansion affect quote depth */

		return;

	     end expand_arg;
%page;
/**** This routine is invoked if an illegal construct is found.  To keep
      the stack frame from becoming unreasonably large, the various control
      strings are stored in an array so that they can be passed by
      reference. */

illegal:
	     procedure (reason);

declare	reason			fixed bin (3) parameter;

		if control_string_pos &gt; length (control_string) then control_string_pos = length (control_string);

		expansion_buffer = requote_string_ (construct);

		call error (0, REASONS (reason), expansion_buffer);

	     end illegal;

	end expand;
%page;
/**** Get an argument from the argument list.  Note that SSU reserves the
      right to change the argument list format (the entry is replaceable),
      so we can't obtain a pointer to the SSU arglist and use the cu_
      entrypoints. */

get_argument:
	procedure (P_argx);

declare	P_argx			fixed bin (17) parameter;

	     if sci_ptr = null ()
	     then do;
		     call cu_$arg_ptr_rel (P_argx, arg_ptr, arg_len, status, arg_list_ptr);
		     if status ^= 0 then call error (status, "Can't get argument #^d.", P_argx);
		end;
	     else call ssu_$arg_ptr (sci_ptr, P_argx, arg_ptr, arg_len);

	     return;

	end get_argument;
%page;
/**** An error in usage has been detected, probably a missing control
      string.  This internal procedure replaces ssu_$abort_line for this
      purpose because the standard for usage messages for commands and
      active functions is to call the appropriate $suppress_name
      entrypoint.  It also permits the short names to be used in the usage
      messages for the command and active function cases.  For the
      subsystem cases, the standard action of ssu_$abort_line is used,
      because it is desirable to give the subsystem name.  Unfortunately,
      at this writing there is no easy way to get the short name of the
      request for use in the error message. */

usage:
	procedure (usage_string);

declare	usage_string		char (*) parameter;

	     expansion_buffer = "Usage:  ";
	     if return_value_ptr ^= null () then expansion_buffer = expansion_buffer || "[";
	     if sci_ptr = null ()
	     then expansion_buffer = expansion_buffer || MY_SHORT_NAME (entrypoint);
	     else expansion_buffer = expansion_buffer || rtrim (ssu_$get_request_name (sci_ptr));
	     expansion_buffer = expansion_buffer || BLANK;
	     expansion_buffer = expansion_buffer || usage_string;
	     if return_value_ptr ^= null () then expansion_buffer = expansion_buffer || "]";

	     if sci_ptr = null ()
	     then if return_value_ptr = null ()
		then call com_err_$suppress_name (0, MY_NAME (entrypoint), "^a", expansion_buffer);
		else call active_fnc_err_$suppress_name (0, MY_NAME (entrypoint), "^a", expansion_buffer);
	     else call ssu_$abort_line (sci_ptr, 0, "^a", expansion_buffer);

	     go to EGRESS;

	end usage;

     end execute_string_command;

     end do;
�



		    execute_epilogue_.pl1           11/05/86  1231.3r w 11/04/86  1033.6       30420



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


execute_epilogue_: proc (run_only);

/* coded 9/77 by Steve Webber */
/* modified 1/78 by Melanie Weaver to clean up list of run handlers as it is processed and to mask quits */
/* modified  7/78 by Melanie Weaver to fix loop bug */

/* Parameters */

dcl  a_entry entry;
dcl  run_only bit (1) aligned;			/* ON if only want run-unit cleanup */

/* Automatic */

dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  iocb_ptr ptr;
dcl  mask bit (36) aligned;

/*  Static */

dcl  num_handlers fixed bin static init (0);
dcl  epilogue_handlers (10) static entry variable;
dcl  num_run_handlers fixed bin static init (0);
dcl  run_epilogue_handlers (10) static entry variable;

/* External */

dcl  error_table_$action_not_performed fixed bin (35) ext;

/* Builtins, etc */

dcl  any_other condition;
dcl cleanup condition;
dcl (ptr, addr, hbound) builtin;

/* entries */

dcl  iox_$find_iocb_n entry (fixed bin, ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);


/*  */

/* Don't let quits keep handlers from finishing */

	mask = "0"b;
	on cleanup begin;
	     if mask then call hcs_$reset_ips_mask (mask, mask);
	end;
	call hcs_$set_ips_mask ("0"b, mask);

/* Always call the run handlers */

	do i = num_run_handlers to 1 by -1;
	     num_run_handlers = num_run_handlers - 1;	/* don't want this handler to be remembered after run unit is gone */
	     on any_other goto next0;
	     call run_epilogue_handlers (i) ();
next0:	end;


	if ^run_only then do;
	     do i = 1 to num_handlers;
		on any_other goto next;
		call epilogue_handlers (i) ();
next:	     end;

/* Now close all files */

	     call iox_$find_iocb_n (1, iocb_ptr, code);
	     do i = 2 to 2000 while (code = 0);		/* avoid infinite loop */
		on any_other goto nexti;
		call iox_$close (iocb_ptr, code);
nexti:		call iox_$find_iocb_n (i, iocb_ptr, code);
	     end;
	end;

	call hcs_$reset_ips_mask (mask, mask);

	return;

/*  */

add_epilogue_handler_: entry (a_entry) returns (fixed bin (35));


	if ptr (addr (i), 0) -&gt; stack_header.run_unit_depth &gt; 0 then do;
	     if num_run_handlers = hbound (run_epilogue_handlers, 1) then return (error_table_$action_not_performed);
	     do i = 1 to num_run_handlers;
		if run_epilogue_handlers (i) = a_entry then return (0);
	     end;
	     num_run_handlers = num_run_handlers + 1;
	     run_epilogue_handlers (num_run_handlers) = a_entry;
	end;
	else do;
	     if num_handlers = hbound (epilogue_handlers, 1) then return (error_table_$action_not_performed);
	     do i = 1 to num_handlers;
		if epilogue_handlers (i) = a_entry then return (0);
	     end;
	     num_handlers = num_handlers + 1;
	     epilogue_handlers (num_handlers) = a_entry;
	end;
	return (0);

/*  */

%include stack_header;
     end;




		    format_line.pl1                 11/04/82  2003.4rew 11/04/82  1610.0       78237



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
fl:
format_line: 
     procedure options (variable);			/* command/active function interface to ioa_	*/
						/* updated 03/08/82: change usage message to use  */
						/* the long name of the command by LAB.		*/

	who_am_i = "format_line";
	newline_sw = "1"b;
	go to COMMON;

flnnl:
format_line_nnl:
     entry options (variable);			/* interface to ioa_$nnl */

	who_am_i = "format_line_nnl";
	newline_sw = "0"b;
	go to COMMON;
%page;
declare	(addr, hbound, index, null, substr)
			builtin;

declare	cleanup		condition;

declare	active_function	bit (1),			/* mode of operation (how were we called?)	*/
	arg_count		fixed bin,		/* number of arguments we were passed.		*/
	arg_list_ptr	ptr,			/* ptr to argument list			*/
	idx		fixed bin,		/* an index temporary.			*/
	newline_sw	bit (1),			/* are we fl or flnnl?			*/
	overflow		bit (1),			/* for AF case:  is return arg too short?	*/
	return_max_len	fixed bin,		/* maximum length of our return value.		*/
	return_ptr	ptr,			/* ptr to our return value.			*/
	rs_idx		fixed bin (21),		/* index of first quote in return string	*/
	seg_ptr		ptr,			/* ptr to temp for requoting if too big for stack */
	status		fixed bin (35),		/* an error code variable.			*/
	who_am_i		char (32);		/* name for error messages			*/

declare	seg		char (rs.len - rs_idx + 1) based (seg_ptr);

declare	1 rs		based (return_ptr) aligned,	/* our return value.			*/
	  2 len		fixed bin (21),		/* its current length.			*/
	  2 first_quote	char (1) unaligned,		/* quote we put around it			*/
	  2 value		char (return_max_len refer (rs.len)) unal,
						/* its character-string value.		*/
	  2 last_quote	char (1) unaligned;		/* other quote we put around it		*/

declare	1 arg_list	aligned based (arg_list_ptr),
	  2 n_args	fixed bin (17) unal,
	  2 code		fixed bin (17) unal,
	  2 n_desc	fixed bin (17) unal,
	  2 mbz		fixed bin (17) unal,
	  2 arg_ptrs	(arg_count) ptr,
	  2 desc_ptrs	(arg_count) ptr;

declare	(
	active_fnc_err_,
	active_fnc_err_$af_suppress_name,
	com_err_,
	com_err_$suppress_name
	)		entry options (variable),
	cu_$af_return_arg	entry (fixed bin, ptr, fixed bin, fixed bin (35)),
	cu_$arg_list_ptr	entry () returns (ptr),
	cu_$generate_call	entry (entry, ptr),
	get_temp_segment_	entry (char (*), ptr, fixed bin (35)),
	ioa_		entry options (variable),
	ioa_$general_rs	entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned),
	ioa_$nnl		entry options (variable),
	release_temp_segment_
			entry (char (*), ptr, fixed bin (35));

declare	(
	error_table_$command_line_overflow,
	error_table_$not_act_fnc
	)		fixed bin (35) external;
%page;
/*	find out how many args we were passed, and get ptr to and max length of return arg.		*/

COMMON:
	call cu_$af_return_arg (arg_count, return_ptr, return_max_len, status);

	if status = 0 then active_function = "1"b;
	else if status = error_table_$not_act_fnc then active_function = "0"b;
	else do;
		call com_err_ (status, who_am_i);	/* error if called without arg descriptors.	*/
		return;
	     end;

	if arg_count = 0 then do;
		if active_function
		then call active_fnc_err_$af_suppress_name (0, who_am_i, "Usage:  [format_line^[_nnl^] control_string {args}]",
			^newline_sw);
		else call com_err_$suppress_name (0, who_am_i, "Usage:  format_line^[_nnl^] control_string {args}", ^newline_sw);
		return;
	     end;

	arg_list_ptr = cu_$arg_list_ptr ();

	if ^active_function then do;
		if newline_sw
		then call cu_$generate_call (ioa_, arg_list_ptr);
		else call cu_$generate_call (ioa_$nnl, arg_list_ptr);
		return;
	     end;

	return_max_len = return_max_len - 2;		/* leave room for our quotes			*/
	rs.len = return_max_len + 1;			/* be able to detect overlength line.		*/
%page;

/* Now, a new param list for the call to ioa_$general_rs must be constructed.
   This is necessary because the argument list we were passed contains an extra argument for
   the active function returns string. This argument may confuse ioa_ */

	begin;					/* this is to allocate the list		*/

declare	1 auto_arg_list	like arg_list aligned automatic;

	     auto_arg_list.n_args = 2 * arg_count;
	     auto_arg_list.n_desc = 2 * arg_count;
	     auto_arg_list.code = 4;
	     auto_arg_list.mbz = 0;

	     if arg_list.code = 8
	     then arg_count = arg_count + 2;		/* if extra pointer supplied			*/
	     else arg_count = arg_count + 1;		/* else just skip return argument		*/
	     do idx = 1 to hbound (auto_arg_list.arg_ptrs, 1);
		auto_arg_list.arg_ptrs (idx) = arg_list.arg_ptrs (idx);
		auto_arg_list.desc_ptrs (idx) = arg_list.desc_ptrs (idx);
	     end;

	     call ioa_$general_rs (addr (auto_arg_list), 1, 2, rs.value, rs.len, "0"b, "0"b);
	end;

	overflow = "0"b;
	rs_idx = index (rs.value, """");		/* embedded quotes?				*/
	if rs_idx &gt; 0
	then if rs.len - rs_idx &gt; 4095 then do;		/* If we take up more than a page don't use stack */
		     seg_ptr = null ();
		     on cleanup call release_temp_segment_ (who_am_i, seg_ptr, (0));
		     call get_temp_segment_ (who_am_i, seg_ptr, status);
		     if status ^= 0 then do;
			     call active_fnc_err_ (status, who_am_i, "Getting temp segment.");
			     return;
			end;
		     seg = substr (rs.value, rs_idx);
		     call double_quotes (seg);
		     call release_temp_segment_ (who_am_i, seg_ptr, (0));
		end;
	     else call double_quotes (substr (rs.value, rs_idx));
	else if rs.len &gt; return_max_len then do;
		rs.len = return_max_len;
		overflow = "1"b;
	     end;

	rs.first_quote, rs.last_quote = """";		/* put quotes around result			*/
	rs.len = rs.len + 2;			/* include room for the two quotes we're adding.	*/

	if overflow
	then call active_fnc_err_ (error_table_$command_line_overflow, who_am_i,
		"Type ""start"" to continue with truncated string.");

	return;
%page;
double_quotes:
     procedure (copy);				/* procedure to double any quotes appearing in	*/
						/* the variable, arg.			*/

declare	copy		char (*);

declare	arg_len		fixed bin,		/* length of arg				*/
	arg_ptr		ptr,			/* ptr to arg				*/
	arg		char (arg_len) based (arg_ptr),
	clen		fixed bin (21),		/* current string length.			*/
	quote_idx		fixed bin (21),		/* another index temporary.			*/
	slen		fixed bin (21);		/* a string length temporary.			*/

	arg_ptr = addr (substr (rs.value, rs_idx));	/* set ptr to copy back into at first quote	*/
	arg_len = rs.len - rs_idx + 1;		/* adjust length accordingly			*/
	return_max_len = return_max_len - rs_idx + 1;	/* set max length down accordingly		*/
	rs.len = rs_idx - 1;			/* set current length down to point so far valid	*/
	clen = 0;					/* set index to start scanning copy for quotes	*/

	do while ("1"b);
	     return_max_len = return_max_len - 1;	/* we're going to add a second quote after one	*/
						/* we've found in copy. Exclude this quote from	*/
						/* the length of arg.  Instead shift ptr to	*/
						/* arg 1 char to the right.  Then, index values	*/
						/* have the same meaning in arg and copy.	*/
	     if clen &gt;= return_max_len then do;		/* punt if there's no room left for two quotes	*/
		     overflow = "1"b;
		     return;
		end;
	     substr (arg, clen + 1, 2) = """""";	/* add double quote to end of arg.		*/
	     rs.len = rs.len + 2;			/* update length of return value to reflect the	*/
						/* double quote.				*/
	     arg_ptr = addr (substr (arg, 2));		/* move ptr to arg 1 char to the right		*/
	     clen = clen + 1;			/* look at chars after the quote we've doubled.	*/
	     quote_idx = index (substr (copy, clen + 1), """") - 1;
						/* find next quote in these chars.		*/
	     if quote_idx &lt; 0
	     then slen = arg_len - clen;		/* No quotes, so get length of rest of string	*/
	     else slen = quote_idx;			/* length of stuff before quote		*/
	     if clen + slen &gt; return_max_len then do;	/* if too long to fit, truncate it here		*/
		     slen = return_max_len - clen;
		     quote_idx = -1;		/* stop search and exit (fake "no more quotes")	*/
		     overflow = "1"b;		/* report error				*/
		end;
	     if slen &gt; 0 then substr (arg, clen + 1, slen) = substr (copy, clen + 1, slen);
						/* append this substr to end of arg.		*/
	     rs.len = rs.len + slen;			/* add length of substr to length of ret value.	*/
	     if quote_idx &lt; 0 then return;		/* if we didn't find a quote, then all done.	*/
	     clen = clen + quote_idx;			/* set index of quote we found, and loop.	*/
	end;

     end double_quotes;

     end format_line;

���



		    general_ready.pl1               09/15/88  1346.3rew 09/15/88  1340.6      428463



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


/****^  HISTORY COMMENTS:
  1) change(69-01-01,Goldman), approve(), audit(),
     install(86-05-22,MR12.0-1057):
     Written by Jay Goldman.  (Don't know when, the date in the change
      field is just to satisfy history_comment. -jjl)
  2) change(83-08-09,Lippard), approve(), audit(),
     install(86-05-22,MR12.0-1057):
     Modified by Jim Lippard to remove reporting of bulk store reads
      and to use the clock builtin.
  3) change(84-02-14,Lippard), approve(), audit(),
     install(86-05-22,MR12.0-1057):
     Modified by Jim Lippard to add -total_xxx and -inc_xxx for
      sf, bf, vr, vw, pft, rcpu and to add the short name -lev to -level.
  4) change(84-04-11,Lippard), approve(), audit(),
     install(86-05-22,MR12.0-1057):
     Modified by Jim Lippard to turn off -call when certain conditions
      occur and to add -active_string (-astr).
  5) change(84-07-31,Lippard), approve(), audit(),
     install(86-05-22,MR12.0-1057):
     Modified by Jim Lippard to add -time_format (-tfmt) and to use the
      user's default date/time, date, and time formats.
  6) change(84-12-05,Lippard), approve(85-01-09,MCR7121),
     audit(85-10-22,Dupuis), install(85-12-16,MR12.0-1001):
     Modified by Jim Lippard to not disable -call or -astr when
      command_question is signalled.
  7) change(85-08-01,Lippard), approve(85-08-26,MCR7262),
     audit(85-10-22,Dupuis), install(85-12-16,MR12.0-1001):
     Modified by Jim Lippard to not set time_format when the argument
      supplied to -tfmt is invalid.
  8) change(86-03-06,Lippard), approve(86-04-21,MCR7385),
     audit(86-05-15,Dickson), install(86-05-22,MR12.0-1057):
     Modified to add short name -fr to -frame.
  9) change(88-08-29, TLNguyen), approve(88-08-08, MCR7961),
     audit(88-09-13, Parisek):
     (a) "general_ready -reset" should work as documented.
     (b) "general_ready -set -astr program_interrupt" should ignore the
         program_interrupt condition.
                                                   END HISTORY COMMENTS */


general_ready:
gr:
     procedure options (variable);

dcl  whoami char (32) static initial ("general_ready") options (constant);

dcl (level_flag,
     frame_flag,
     time_flag,
     date_flag,
     date_time_flag,
     time_format_flag,
     total_flag,
     temp_ready_flag,
     set_level_flag,
     af_flag,
     inc_flag) bit (1) aligned;

dcl (static_arg_list_ptr static,
     cur_arg_list,
     arg_list_ptr,
     temp_argument_ptr,
     temp_argument_descr_ptr) pointer;

dcl 1 arg_list_header aligned based (arg_list_ptr),
    2 twice_arg_count fixed bin (17) unaligned,
    2 code fixed bin (17) unaligned,
    2 twice_desc_count fixed bin (17) unaligned,
    2 pad fixed bin (17) unaligned;

dcl 1 ioa_arg_list static aligned,
    2 header fixed bin (71),
    2 arg_list_ptrs (80) pointer;

dcl 1 arg_list based (arg_list_ptr) aligned,
    2 header fixed bin (71),
    2 arg_ptrs (number_of_data) pointer,
    2 descr_ptrs (number_of_data) pointer;

dcl (
     vcpu_rate,
     real_rate,
     online_rate,
     new_online_rate,
     process_hour_rate,
     milli_mu_rate,
     kmu_rate
     ) float bin internal static;
dcl (
     new_vcpu_rate,
     new_real_rate,
     new_process_hour_rate,
     new_kmu_rate,
     new_milli_mu_rate
     ) float bin automatic;

dcl  dollars_fudge float bin (20) int static initial (0e0);
dcl  login_time fixed bin (71);
dcl  first_time_flag bit (1) aligned int static init ("1"b);

dcl  old_cl char (132) aligned static initial ("");
dcl  old_cll fixed bin static initial (132);
dcl  old_cl_ptr ptr static init (null ());
dcl  based_old_cl char (old_cll) based (old_cl_ptr);

dcl  cl_ptr ptr;
dcl  based_cl char (temp_cll) aligned based;

dcl  sys_area area based (area_ptr);
dcl  area_ptr ptr;
dcl (old_cl_flag,
     old_level_flag,
     old_frame_flag,
     old_total_flag,
     old_time_flag,
     old_date_flag,
     old_date_time_flag,
     old_time_format_flag,
     old_inc_flag) bit (1) aligned static initial ("0"b);

dcl  get_system_free_area_ entry returns (ptr);
dcl  now fixed bin (71);
dcl  next_shift fixed bin (71);
dcl (addr, addrel, after, bin, bit, clock, dim, fixed, float) builtin;
dcl (hbound, length, lbound, max, min, null, substr) builtin;
dcl (ioa_$nnl, ioa_$rsnpnnl) ext entry options (variable);
dcl  ioa_ptr pointer;
dcl  cu_$cp ext entry (ptr, fixed bin, fixed bin (35));
dcl  cu_$gen_call ext entry (ptr, ptr);
dcl  cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$decode_entry_value ext entry (entry, ptr, ptr);
dcl  cu_$evaluate_active_string entry (ptr, char(*), fixed bin, char(*) var, fixed bin(35));
dcl  max_length fixed bin;
dcl  return_ptr ptr;
dcl  user_info_$usage_data ext entry (fixed bin, fixed bin (71),
     fixed bin (71), fixed bin (71), fixed bin (71));
dcl  gr_get_rates_ ext entry (float bin, float bin, float bin, float bin, fixed bin (71));

dcl  cu_$set_ready_proc ext entry (pointer);
dcl  timer_manager_$alarm_call ext entry (fixed bin (71), bit (2) aligned, entry);
dcl  timer_manager_$reset_alarm_call ext entry (entry);
dcl  first_time fixed bin (71) int static init (0);
dcl  hcs_$get_process_usage ext entry (ptr, fixed bin (35));
dcl  error_table_$badopt ext static fixed bin (35);
dcl  error_table_$noarg ext static fixed bin (35);
dcl  error_table_$inconsistent ext static fixed bin (35);

dcl  (any_other, sub_error_) condition;

dcl  find_condition_info_ entry (ptr, ptr, fixed bin(35));
dcl  continue_to_signal_ entry (fixed bin(35));

dcl  sub_err_ entry() options(variable);

dcl  1 ci aligned like condition_info;

dcl 1 ready_mode_flags aligned,
    2 ready_sw bit (1) unaligned,
    2 pad bit (35) unaligned;

dcl 1 new aligned static like process_usage;
dcl 1 old aligned static like new;
dcl 1 last aligned static like new;

dcl  date_time_string char (250) aligned int static;	/* for -date_time */
dcl  date_string char (250) aligned int static;		/* for -date */
dcl  time_string char (250) aligned int static;		/* for -time */
dcl  time_format_string char (250) aligned int static;	/* for -time_format */
dcl  old_time_format char (60) int static;		/* input string for -time_format */
dcl  temp_time_format char (60);
dcl  time_format char (60);

dcl  dt char (24) int static aligned;			/* mm/dd/yy__hhmm.m_zzz_www */
dcl  dt_chars (0:23) char (1) unaligned based (addr (dt));

dcl 1 dt_descr (3) int static,
    2 flag bit (1) initial ((3) (1) "1"b),
    2 type bit (6) initial ((3) (1) "010101"b),		/* character string */
    2 packed bit (1) initial ((3) (1) "1"b),
    2 number_dims bit (4) initial ((3) (1) "0000"b),
    2 size bit (24) initial (
     "000000000000000000000010"b,			/* minute, hour, month, day, year */
     "000000000000000000000011"b,			/* day_name or zone */
     "000000000000000011111010"b);			/* any time string from date_time_$format */

dcl (arg_index,
     dt_offset_index,
     idx) fixed bin;

dcl  dt_incr_string (10) char (4) varying static initial (
     " ^a", " ^a", "^a", " ^a", " ^a", " ^a", " ^a", " ^a", "^a", "^a");

dcl  dt_offset (10) fixed bin static initial (
     10, 10, 12, 0, 17, 21, 0, 0, 3, 6);

dcl  dt_descr_index (10) fixed bin static initial (
     3, 1, 1, 3, 2, 2, 3, 1, 1, 1);

dcl  real_index (30) fixed bin static initial		/* one entry per format option */
    (11, 1, 2, 7, 7, 13, 12, 16,			/* values &lt;= 10 are indices in dt arrays */
     6, 5, 1, 3, 15, 4, 8, 9, 10, 17, 16, 18,		/* maps index in format_args into */
     19, 20, 21, 22, 23, 24, 24, 25, 25, 17);		/* index in dt_* and temp_flag array */

dcl 1 temp_flag (1:25) aligned,
    2 (inc, total) bit (1);

dcl  control_args (4) char (7) static aligned initial ("-set", "-revert", "-call", "-reset");

dcl  prefix_args (2) char (8) static aligned initial ("-string", "-control");

dcl  format_args (30) aligned static char (14) varying initial
    ("vcpu", "-time", "-hour", "-date", "-dt", "mem_units", "cost", "-level",
     "-day_name", "-zone", "-tm", "-minute", "pf", "-date_time", "-month",
     "-day", "-year", "-frame", "-lev", "pft", "sf", "bf", "vr", "vw", "rcpu",
     "-active_string", "-astr", "-time_format", "-tfmt", "-fr");

dcl  format_sw (30) bit (1) static aligned initial
    ("0"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b,	/* indicate if arg must match format_arg */
     "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b,	/* exactly or may have leading -inc_ or -total_ */
     "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b,
     "0"b, "1"b, "1"b, "1"b, "1"b, "1"b);

dcl  date_time_ ext entry (fixed bin (71), char (*)aligned);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*))
     returns (char (250) varying);
dcl  default_ioa_string char (32) varying int static initial (
     "^a ^.3f ^d^a^2/");

dcl  default_sw bit (1) static init ("0"b);

dcl (level_no, frame_no) fixed bin;
dcl  level_string char (16) aligned static;
dcl  level_ioa_string char (34) static initial (" ^[level ^d^;frame ^s^]^[,^]^[^d^]");
dcl  listen_$get_level ext entry (fixed bin, fixed bin);
dcl  ioa_$rsnnl ext entry options (variable);

dcl 1 level_descr int static,
    2 flag bit (1) init ("1"b),
    2 type bit (6) init ("010101"b),
    2 packed bit (1) init ("0"b),
    2 number_dims bit (4) init ("0000"b),
    2 size bit (24) init ("000000000000000000010000"b);

dcl  ioa_string char (132) aligned int static;

dcl 1 ioa_string_descr int static,
    2 flag bit (1) initial ("1"b),
    2 type bit (6) initial ("010101"b),
    2 packed bit (1) initial ("0"b),
    2 number_dims bit (4) initial ("0000"b),
    2 size bit (24) initial ("000000000000000000001100"b);

dcl 1 float_descr int static,
    2 flag bit (1) initial ("1"b),
    2 type bit (6) initial ("000011"b),
    2 packed bit (1) initial ("0"b),
    2 number_dims bit (4) initial ("0000"b),
    2 scale bit (12) initial ("000000000000"b),
    2 precision bit (12) initial ("000000010100"b);

dcl 1 integer_descr int static,
    2 flag bit (1) initial ("1"b),
    2 type bit (6) initial ("000001"b),
    2 packed bit (1) initial ("0"b),
    2 number_dims bit (4) initial ("0000"b),
    2 scale bit (12) initial ("000000000000"b),
    2 precision bit (12) initial ("000000100011"b);

dcl (total_dollars,
     inc_dollars,
     new_dollars,
     old_dollars,
     last_dollars,
     total_mem_units,
     inc_mem_units,
     total_vcpu_time,
     inc_vcpu_time,
     total_rcpu_time,
     inc_rcpu_time) float bin (20) int static;

dcl (total_pd_faults,
     total_page_faults,
     total_seg_faults,
     total_bounds_faults,
     total_vtoc_reads,
     total_vtoc_writes,
     inc_pd_faults,
     inc_page_faults,
     inc_seg_faults,
     inc_bounds_faults,
     inc_vtoc_reads,
     inc_vtoc_writes) fixed bin (35) int static;

dcl  ZERO_BS fixed bin (35) int static options (constant) init (0);

dcl  arg char (arglen) unal based (arg_ptr);
dcl (arglen, temp_cll) fixed bin;
dcl (arg_ptr, temp_clp) ptr;
dcl  temp_cl char (temp_cll) based (temp_clp);

dcl  temp_ioa_string char (132) aligned varying;

dcl  bvs_ptr pointer;
dcl 1 temp_ioa_bvss aligned based,
    2 length fixed bin,
    2 string char (132);

dcl 1 based_descr based like temp_ioa_string_descr;
dcl 1 af_return_descr like temp_ioa_string_descr unaligned;
dcl  vs_type bit (6) static initial ("010110"b);

dcl 1 temp_ioa_string_descr unaligned,
    2 flag bit (1),
    2 type bit (6),
    2 packed bit (1),
    2 number_dims bit (4),
    2 size bit (24);

dcl 1 temp_ioa_arg_list aligned like ioa_arg_list;

dcl (argument_ptr (24),
     argument_descr_ptr (24)) pointer;

dcl (argnumber,
     af_offset,
     string_length,
     number_of_data) fixed bin;

dcl  old_number_of_data fixed bin internal static;

dcl (first_args_flag,
     total_format_flag,
     values_set_flag,
     temp_total_flag,
     temp_inc_flag,
     temp_level_flag,
     temp_frame_flag,
     temp_set_flag,
     temp_revert_flag, temp_reset_flag,
     temp_date_flag,
     temp_time_flag,
     temp_date_time_flag,
     temp_time_format_flag,
     doing_dollars,
     incr_string_flag) bit (1) aligned;

dcl  incr_string char (32) varying;

dcl 1 active_string based,
      2 next_active_string_ptr ptr,
      2 descriptor like active_string_descr_const,
      2 num_of_data fixed bin,
      2 input_string_len fixed bin,
      2 input_string char (input_string_length refer (active_string.input_string_len));

dcl input_string_length fixed bin(21);

dcl old_active_string_ptr ptr int static;
dcl (active_string_ptr, temp_active_string_ptr) ptr;

dcl old_last_active_string_ptr ptr int static;
dcl temp_last_active_string_ptr ptr;

dcl  (n_active_strings,
      temp_n_active_strings) fixed bin (21);
dcl  old_n_active_strings fixed bin (21) int static;

dcl  1 active_string_descr_const,
       2 flag bit (1) initial ("1"b),
       2 type bit (6) initial ("010101"b),
       2 packed bit (1) initial ("0"b),
       2 number_dims bit (4) initial ("0000"b),
       2 size bit (24) initial ((24) "0"b);

dcl (cu_$arg_ptr, cu_$af_arg_ptr) ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  get_arg_ptr_ entry (fixed bin, ptr, fixed bin, fixed bin (35)) variable;
dcl  code fixed bin (35) static;
dcl (com_err_, active_fnc_err_) ext entry options (variable);
dcl  err_ entry options (variable) variable;
%page;
%include process_usage;
%page;
%include cp_active_string_types;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include sub_err_flags;
%page;
%include sub_error_info;
%page;
						/*  */
	new.number_wanted = 9;
	go to decode_arg_list;

/* the code for the message and change_shift entry points
   is put at the beginning of the program to insure
   that the code for these entries lies on a single page of
   the object segment */

message:	entry (ready_mode_flags);

	if old_cl_flag then do;
	     if old_cl_ptr = null then old_cl_ptr = addr (old_cl);
	     begin;
dcl  cl_copy char (length (based_old_cl)) aligned;
		cl_copy = based_old_cl;

		on any_other begin;			/* Handle nasty conditions and turn off -call */
		     on sub_error_ system;	/* avoid those loops */
		     ci.version = condition_info_version_1;
		     call find_condition_info_ (null(), addr (ci), code);
		     if code ^= 0 then do;		/* no condition frame */
			call sub_err_ (code, whoami, ACTION_DEFAULT_RESTART, null (), (0), "-call disabled.");
			old_cl_flag = "0"b;
			return;
		     end;
		     if ci.condition_name = "alrm" |
			ci.condition_name = "command_question" |
			ci.condition_name = "cput" |
			ci.condition_name = "finish" |
			ci.condition_name = "quit" |
			ci.condition_name = "sus_" |
			ci.condition_name = "trm_" then;
		     else do;
			if old_cl_flag then /* avoid complaining twice */
			     call sub_err_ ((0), whoami, ACTION_DEFAULT_RESTART, null (), (0),
				"Condition ^a signalled, -call disabled.", ci.condition_name);
			old_cl_flag = "0"b;
		     end;
		     call continue_to_signal_ ((0));
		end;

		call cu_$cp (addr (cl_copy), (old_cll), code);

		revert any_other;
	     end;
	end;
	if ^ready_mode_flags.ready_sw then return;
	temp_ready_flag = "0"b;			/* this is from static arg list */

	if first_time_flag then do;
	     call setup_ready;
	     if code ^= 0 then return;
	end;

do_ready:
	if temp_ready_flag then do;			/* if general_ready invoked only once */
	     if temp_clp ^= null () then begin;		/* and  -call was specified */
dcl  temp_cl_copy char (temp_cll) init (temp_cl);
		call cu_$cp (addr (temp_cl_copy), length (temp_cl_copy), code);
	     end;
	     if af_flag then ioa_ptr = addr (ioa_$rsnpnnl);
	     else ioa_ptr = addr (ioa_$nnl);
	     total_flag = temp_total_flag;
	     inc_flag = temp_inc_flag;
	     cur_arg_list = arg_list_ptr;
	     level_flag = temp_level_flag;
	     frame_flag = temp_frame_flag;
	     time_flag = temp_time_flag;
	     date_flag = temp_date_flag;
	     date_time_flag = temp_date_time_flag;
	     time_format_flag = temp_time_format_flag;
	     time_format = temp_time_format;
	     n_active_strings = temp_n_active_strings;
	     active_string_ptr = temp_active_string_ptr;
	end;
	else do;
	     ioa_ptr = addr (ioa_$nnl);
	     total_flag = old_total_flag;
	     inc_flag = old_inc_flag;
	     level_flag = old_level_flag;
	     frame_flag = old_frame_flag;
	     time_flag = old_time_flag;
	     date_flag = old_date_flag;
	     date_time_flag = old_date_time_flag;
	     time_format_flag = old_time_format_flag;
	     time_format = old_time_format;
	     cur_arg_list, arg_list_ptr = static_arg_list_ptr;
	     n_active_strings = old_n_active_strings;
	     active_string_ptr = old_active_string_ptr;
	     number_of_data = old_number_of_data;
	     temp_n_active_strings = 0;
	     af_flag = "0"b;
	end;

	now = clock ();
	call hcs_$get_process_usage (addr (new), code);
	if code ^= 0 then do;
got_pu_err:
	     call err_ (code, whoami, "error in hcs_$get_process_usage.");
	     return;
	end;
	new_dollars = float (new.virtual_cpu_time, 20)*vcpu_rate
	     + float (now-first_time, 20)*online_rate
	     + float (new.paging_measure*milli_mu_rate, 20)
	     - dollars_fudge;

	new.virtual_cpu_time = new.virtual_cpu_time + old.virtual_cpu_time;	/* add cpu from previous processes */
	new.paging_measure = new.paging_measure + old.paging_measure;

	call date_time_ (now, dt);
	if time_flag then time_string = date_time_$format ("time", now, "", "");
	if date_flag then date_string = date_time_$format ("date", now, "", "");
	if date_time_flag then date_time_string = date_time_$format ("date_time", now, "", "");
	if time_format_flag then time_format_string = date_time_$format (time_format, now, "", "");

	if total_flag then do;
	     total_dollars = new_dollars;
	     total_pd_faults = new.pd_faults;
	     total_page_faults = new.page_faults;
	     total_seg_faults = new.segment_faults;
	     total_bounds_faults = new.bounds_faults;
	     total_vtoc_reads = new.vtoc_reads;
	     total_vtoc_writes = new.vtoc_writes;
	     total_vcpu_time = float (new.virtual_cpu_time, 20)/1e6;
	     total_mem_units = float (new.paging_measure, 20)/1e3;
	     total_rcpu_time = float (new.cpu_time, 20)/1e6;
	end;

	if inc_flag then do;
	     inc_dollars = new_dollars - last_dollars;
	     inc_vcpu_time = float (new.virtual_cpu_time-last.virtual_cpu_time, 20)/1e6;
	     inc_rcpu_time = float (new.cpu_time-last.cpu_time, 20)/1e6;
	     inc_mem_units = float (new.paging_measure-last.paging_measure, 20)/1e3;
	     inc_pd_faults = new.pd_faults - last.pd_faults;
	     inc_page_faults = new.page_faults - last.page_faults;
	     inc_seg_faults = new.segment_faults - last.segment_faults;
	     inc_bounds_faults = new.bounds_faults - last.bounds_faults;
	     inc_vtoc_reads = new.vtoc_reads - last.vtoc_reads;
	     inc_vtoc_writes = new.vtoc_writes - last.vtoc_writes;
	end;

	last_dollars = new_dollars;
	last.paging_measure = new.paging_measure;
	last.virtual_cpu_time = new.virtual_cpu_time;
	last.cpu_time = new.cpu_time;
	last.pd_faults = new.pd_faults;
	last.page_faults = new.page_faults;
	last.segment_faults = new.segment_faults;
	last.bounds_faults = new.bounds_faults;
	last.vtoc_reads = new.vtoc_reads;
	last.vtoc_writes = new.vtoc_writes;

	if default_sw then
	     time_string = date_time_$format ("time", clock (), "", "");

/* if ready message is to contain listener level info, then get it */
	if level_flag | frame_flag then do;
	     call listen_$get_level (level_no, frame_no);
	     if level_no = 1 then level_string = "";
	     else call ioa_$rsnnl (level_ioa_string, level_string, length (level_string), level_flag, level_no,
			(level_flag &amp; frame_flag), frame_flag, frame_no);
	     set_level_flag = "0"b;
	end;
	else level_string = "";

	begin;		/* begin block for active strings */
	     dcl active_string_output (n_active_strings) char (256) varying;
	     if ^af_flag then af_offset = 0;
	     else af_offset = 2;
	     do idx = 1 to n_active_strings;
		active_string_output (idx) = "";

		if ^temp_ready_flag then
		on any_other begin;			/* Handle nasty conditions and turn off active string */
		     on sub_error_ system;	/* avoid those loops */
		     ci.version = condition_info_version_1;
		     call find_condition_info_ (null(), addr (ci), code);
		     if code ^= 0 then do;		/* no condition frame */
			call sub_err_ (code, whoami, ACTION_DEFAULT_RESTART, null (), (0), "Active string ""^a"" disabled.", active_string_ptr -&gt; active_string.input_string);
			active_string_ptr -&gt; active_string.input_string = "";
			return;
		     end;
		     if ci.condition_name = "alrm" |
			ci.condition_name = "command_question" |
			ci.condition_name = "cput" |
			ci.condition_name = "finish" |
			ci.condition_name = "program_interrupt" |
			ci.condition_name = "quit" |
			ci.condition_name = "sus_" |
			ci.condition_name = "trm_" then;
		     else do;
			if active_string_ptr -&gt; active_string.input_string ^= "" then /* avoid complaining twice */
			     call sub_err_ ((0), whoami, ACTION_DEFAULT_RESTART, null (), (0),
				"Condition ^a signalled, active string ""^a"" disabled.", ci.condition_name, active_string_ptr -&gt; active_string.input_string);
			active_string_ptr -&gt; active_string.input_string = "";
		     end;
		     call continue_to_signal_ ((0));
		end;

		if active_string_ptr -&gt; active_string.input_string ^= "" then
		     call cu_$evaluate_active_string (null(), active_string_ptr -&gt; active_string.input_string,
			DEFAULT_ACTIVE_STRING, active_string_output (idx), code);

		revert any_other;

		if code ^= 0 then do;
		     call sub_err_ (code, whoami, ACTION_DEFAULT_RESTART, null (), (0), "Error evaluating active string ""^a"", active string evaluation disabled.", active_string_ptr -&gt; active_string.input_string);
		     active_string_ptr -&gt; active_string.input_string = "";
		end;

		arg_list.arg_ptrs (active_string_ptr -&gt; active_string.num_of_data + af_offset) =
			addr (substr (active_string_output (idx), 1));
		arg_list.descr_ptrs (active_string_ptr -&gt; active_string.num_of_data + af_offset) =
			addr (active_string_ptr -&gt; active_string.descriptor);
		active_string_ptr -&gt; active_string.size = bit (length (active_string_output (idx)));
		active_string_ptr = active_string_ptr -&gt; active_string.next_active_string_ptr;
	     end;
	     call cu_$gen_call (ioa_ptr, cur_arg_list);

	     /* free temp active strings */
	     do idx = 1 to temp_n_active_strings;
		active_string_ptr = temp_active_string_ptr;
		temp_active_string_ptr = active_string_ptr -&gt; active_string.next_active_string_ptr;
		free active_string_ptr -&gt; active_string;
	     end;

	end;

	return;					/* end of message code */

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

change_shift: entry;

	call hcs_$get_process_usage (addr (new), code);
	if code ^= 0 then go to got_pu_err;
	now = clock ();
	call gr_get_rates_ (new_vcpu_rate, new_real_rate, new_process_hour_rate,
	     new_kmu_rate, next_shift);

	new_vcpu_rate = new_vcpu_rate/3.6e9;
	new_real_rate = new_real_rate/3.6e9;
	new_process_hour_rate = new_process_hour_rate/3.6e9;
	new_online_rate = new_real_rate + new_process_hour_rate;
	new_milli_mu_rate = new_kmu_rate/1e6;

	dollars_fudge = new.virtual_cpu_time * (new_vcpu_rate-vcpu_rate)
	     + new.paging_measure * (new_milli_mu_rate-milli_mu_rate)
	     + (now-first_time) * (new_online_rate-online_rate)
	     + dollars_fudge;

	vcpu_rate = new_vcpu_rate;
	real_rate = new_real_rate;
	process_hour_rate = new_process_hour_rate;
	online_rate = real_rate + process_hour_rate;
	milli_mu_rate = new_milli_mu_rate;

	if next_shift &gt; now then call timer_manager_$alarm_call (next_shift, "00"b, change_shift);
	return;

/* end of message and change_shift code */

decode_arg_list:					/* general_ready entrypoint gets here */

	if first_time_flag then call setup_ready;

	call cu_$af_return_arg (argnumber, return_ptr, max_length, code);
	if code = 0 then do;
	     af_flag = "1"b;
	     err_ = active_fnc_err_;
	     get_arg_ptr_ = cu_$af_arg_ptr;
	end;
	else do;
	     af_flag = "0"b;
	     err_ = com_err_;
	     get_arg_ptr_ = cu_$arg_ptr;
	end;

	temp_ioa_string = "r";
	argnumber = 0;
	number_of_data = 1;				/* first arg to ioa is ioa control string */
	temp_n_active_strings = 0;
	temp_active_string_ptr, temp_last_active_string_ptr = null ();
	set_level_flag = "0"b;

	first_args_flag = "1"b;
	do arg_index = lbound (temp_flag, 1) to hbound (temp_flag, 1);
	     temp_flag.inc (arg_index) = "0"b;
	     temp_flag.total (arg_index) = "0"b;
	end;

	values_set_flag,
	     temp_total_flag,
	     temp_inc_flag,
	     temp_revert_flag,
	     temp_reset_flag,
	     temp_set_flag
	     = "0"b;
	doing_dollars = "0"b;
	incr_string_flag = "1"b;
	temp_clp = null ();
	temp_level_flag, temp_frame_flag = "0"b;
	temp_time_flag, temp_date_flag, temp_date_time_flag, temp_time_format_flag = "0"b;
	go to read_loop;

repeated_option:
	call err_ (0, whoami, "repeated control arg ^a.", arg);
	return;
read_loop:
	argnumber = argnumber +1;

	call get_arg_ptr_ (argnumber, arg_ptr, arglen, code);
	if code ^= 0 then do;			/* done with arg list, now
						   to setup arglist */

end_of_read_loop:
	     if incr_string_flag then temp_ioa_string = temp_ioa_string||"^/";
	     temp_ioa_string_descr.type = "010101"b;
	     temp_ioa_string_descr.packed = "0"b;
	     temp_ioa_string_descr.number_dims = "0000"b;
	     temp_ioa_string_descr.flag = "1"b;
	     string_length = length (temp_ioa_string);
	     temp_ioa_string_descr.size = bit (bin (string_length, 24), 24); /* set size field */

	     if ^values_set_flag &amp; ^first_args_flag then do; /* i.e., we got only a non-keyword */
		call err_ (error_table_$noarg, whoami, "No values specified for other than default ready message.");
		return;
	     end;

	     if temp_revert_flag then do;		/* process -revert */
		if temp_set_flag then do;		/* -set and -revert are incompatible */
		     call err_ (error_table_$inconsistent, whoami, "-set and -revert");
		     return;
		end;
		if old_cl_ptr ^= null &amp; old_cl_ptr ^= addr (old_cl) then free based_old_cl in (sys_area);
		call cu_$set_ready_proc (null ());
		call timer_manager_$reset_alarm_call (change_shift);
		/* free active strings */
		do idx = 1 to old_n_active_strings;
		     active_string_ptr = old_active_string_ptr;
		     old_active_string_ptr = active_string_ptr -&gt; active_string.next_active_string_ptr;
		     free active_string_ptr -&gt; active_string;
		end;
		if ^values_set_flag &amp; ^temp_reset_flag then return; /* if no values, just revert */
						/* will allow both -revert and -reset */
	     end;
	     if temp_reset_flag then do;		/* reset incremental if -reset */
		now = clock ();
		call hcs_$get_process_usage (addr (new), code);
		if code ^= 0 then go to got_pu_err;
		last_dollars = float (new.virtual_cpu_time, 20)*vcpu_rate
		     + float (now - first_time, 20)*online_rate
		     + float (new.paging_measure*milli_mu_rate, 20)
		     - dollars_fudge;
		last.virtual_cpu_time = new.virtual_cpu_time + old.virtual_cpu_time;
		last.cpu_time = new.cpu_time + old.cpu_time;
		last.paging_measure = new.paging_measure + old.paging_measure;
		last.pd_faults = new.pd_faults;
		last.page_faults = new.page_faults;
		last.segment_faults = new.segment_faults;
		last.bounds_faults = new.bounds_faults;
		last.vtoc_reads = new.vtoc_reads;
		last.vtoc_writes = new.vtoc_writes;

	          date_flag = temp_date_flag;
		time_flag = temp_time_flag;
		date_time_flag = temp_date_time_flag;
		time_format_flag = temp_time_format_flag;

		call date_time_ (now, dt);

		if date_flag then date_string = date_time_$format ("date", now, "", "");
		if time_flag then time_string = date_time_$format ("time", now, "", "");
		if date_time_flag then date_time_string = date_time_$format ("date_time", now, "", "");
		if time_format_flag then time_format_string = date_time_$format (time_format, now, "", "");
		if ^values_set_flag then return;	/* if only -reset (or -revert -reset) just return w/o msg */
	     end;

	     if ^temp_set_flag			/* one time only */
	     then do;
		arg_list_ptr = addr (temp_ioa_arg_list);
		bvs_ptr = addr (temp_ioa_string);
		argument_ptr (1) = addr (bvs_ptr -&gt; temp_ioa_bvss.string);
		argument_descr_ptr (1) = addr (temp_ioa_string_descr);
	     end;
	     else do;
		argument_ptr (1) = addr (ioa_string);
		argument_descr_ptr (1) = addr (ioa_string_descr);
		ioa_string_descr = temp_ioa_string_descr;
		ioa_string = temp_ioa_string;
		if temp_clp ^= null () then do;
		     if old_cl_ptr = null () then string_length = length (old_cl);
		     else string_length = length (based_old_cl);
		     if temp_cll &gt; string_length then do; /* we need more space */
			if old_cl_ptr ^= null () &amp; old_cl_ptr ^= addr (old_cl) then free based_old_cl in (sys_area);
			else area_ptr = get_system_free_area_ ();
			allocate based_cl in (sys_area) set (cl_ptr);
		     end;
		     else if old_cl_ptr = null then cl_ptr = addr (old_cl);
		     else cl_ptr = old_cl_ptr;
		     old_cll = max (string_length, temp_cll);
		     old_cl_flag = "1"b;
		     old_cl_ptr = cl_ptr;
		     based_old_cl = temp_cl;
		end;
		else old_cl_flag = "0"b;
		old_inc_flag = temp_inc_flag;
		old_total_flag = temp_total_flag;
		old_level_flag = temp_level_flag;
		old_frame_flag = temp_frame_flag;
		old_time_flag = temp_time_flag;
		old_date_flag = temp_date_flag;
		old_date_time_flag = temp_date_time_flag;
		old_time_format_flag = temp_time_format_flag;
		old_time_format = temp_time_format;
		static_arg_list_ptr, arg_list_ptr = addr (ioa_arg_list);

		/* free old active strings */
		do idx = 1 to old_n_active_strings;
		     active_string_ptr = old_active_string_ptr;
		     old_active_string_ptr = active_string_ptr -&gt; active_string.next_active_string_ptr;
		     free active_string_ptr -&gt; active_string;
		end;

		old_n_active_strings = temp_n_active_strings;
		old_active_string_ptr = temp_active_string_ptr;
		old_number_of_data = number_of_data;
	     end;

	     if incr_string_flag &amp; temp_ioa_string = "r^/" then do; /* Wants default ready message */
		default_sw = "1"b;
		temp_ioa_string = "r^x" || default_ioa_string;
		call set_default_arg_list;
	     end;
	     else do;
		default_sw = "0"b;
		af_offset = 0;
		do argnumber = 1 to number_of_data;
		     if argnumber = 1 then if af_flag then number_of_data = number_of_data+2;
		     arg_list.arg_ptrs (argnumber+af_offset) = argument_ptr (argnumber);
		     arg_list.descr_ptrs (argnumber+af_offset) = argument_descr_ptr (argnumber);
		     if argnumber = 1 then if af_flag then af_offset = 2;
		end;

		arg_list_header.twice_desc_count,
		     arg_list_header.twice_arg_count = 2 * number_of_data;
		arg_list_header.code = 4;
		arg_list_header.pad = 0;
	     end;

	     temp_ready_flag = "1"b;			/* if we wind up going to do_ready the temp vbls should be used */
	     if af_flag then do;			/* fill in af return arguments */
		arg_list.arg_ptrs (2) = addrel (return_ptr, 1); /* ptr to af return arg */
		arg_list.arg_ptrs (3) = return_ptr;	/* ptr to length word of return arg */
		arg_list.descr_ptrs (3) = addr (integer_descr);
		arg_list.descr_ptrs (2) = addr (af_return_descr);
		af_return_descr.flag = "1"b;
		af_return_descr.type = vs_type;
		af_return_descr.packed = ""b;
		af_return_descr.number_dims = ""b;
		af_return_descr.size = bit (bin (max_length, 17), 24);
		goto do_ready;			/* do a ready msg */
	     end;
	     else if temp_set_flag then do;		/* process -set */
		call cu_$decode_entry_value (message, return_ptr, null ());
		call cu_$set_ready_proc (return_ptr);
	     end;
	     else goto do_ready;			/* no -set */

	     return;				/* ready message is set up or printed */
	end;


/* first_args: */
	if first_args_flag then do;

	     do arg_index = 1 to dim (prefix_args, 1);
		if arg = prefix_args (arg_index) then go to do_prefix (arg_index);
	     end;
	end;					/* end of processing for first args */
	else do;

check_format:
						/* check for a format option */

	     do arg_index = 1 to dim (format_args, 1);
		if format_sw (arg_index) then if format_args (arg_index) = arg then do;
			arg_index = real_index (arg_index);
			if temp_flag.inc (arg_index) then go to repeated_option;
			temp_flag.inc (arg_index) = "1"b;
		     end;
		     else go to next_format_arg;

		else do;
		     if (substr (arg, 1, min (arglen, 7)) = "-total_") &amp;
		     (after (arg, "-total_") = format_args (arg_index)) then do;
			total_format_flag = "1"b;
			arg_ptr = addr (substr (arg, 8, 1));
			arglen = max (arglen-7, 0);
		     end;
		     else if (substr (arg, 1, min (arglen, 5)) = "-inc_") &amp;
		     (after (arg, "-inc_") = format_args (arg_index)) then do;
			total_format_flag = "0"b;
			arg_ptr = addr (substr (arg, 6, 1));
			arglen = max (arglen-5, 0);
		     end;
		     else go to next_format_arg;

		     arg_index = real_index (arg_index); /* consolidate multiply named options */
		     if total_format_flag then if temp_flag.total (arg_index) then go to repeated_option;
			else do;
			     temp_flag.total (arg_index) = "1"b;
			     temp_total_flag = "1"b;
			end;

		     else if temp_flag.inc (arg_index) then go to repeated_option;
		     else do;
			temp_flag.inc (arg_index) = "1"b;
			temp_inc_flag = "1"b;
		     end;
		end;

		go to do_format (arg_index);
next_format_arg:

	     end;
	end;

/* check for control args */

	do arg_index = 1 to dim (control_args, 1);
	     if arg = control_args (arg_index) then
		if af_flag then do;
		     call err_ (error_table_$badopt, whoami,
			"^a not allowed when active function", arg);
		     return;
		end;
		else goto do_control_arg (arg_index);
	end;

	if incr_string_flag then do;
	     if arglen = 0 then go to read_loop;
	     if substr (arg, 1, 1) ^= "-" then do;
		first_args_flag = "0"b;
		temp_ioa_string = temp_ioa_string || arg;
		go to read_loop;
	     end;
	end;

	if first_args_flag then do;			/* if we haven't checked if arg is a format arg go do it now */
	     first_args_flag = "0"b;
	     go to check_format;
	end;


	call err_ (error_table_$badopt, whoami, "^a.", arg);
EXIT_RETURN:
	return;

/* code to execute each format option */

do_format (11):					/* -vcpu */

	if total_format_flag then temp_argument_ptr = addr (total_vcpu_time);
	else temp_argument_ptr = addr (inc_vcpu_time);
	call add_floating_arg;
	go to read_loop;

do_format (13):					/* mem_units */

	if total_format_flag then temp_argument_ptr = addr (total_mem_units);
	else temp_argument_ptr = addr (inc_mem_units);
	call add_floating_arg;
	go to read_loop;

do_format (16):					/* -level */

	temp_level_flag = "1"b;
	if ^set_level_flag then do;
	incr_string = "^a";
	temp_argument_ptr = addr (level_string);
	temp_argument_descr_ptr = addr (level_descr);
	call add_data_arg;
	set_level_flag = "1"b;
	end;
	go to read_loop;

do_format (17):                                            /* -frame */

	temp_frame_flag = "1"b;
	if ^set_level_flag then do;
	incr_string = "^a";
	temp_argument_ptr = addr (level_string);
	temp_argument_descr_ptr = addr (level_descr);
	call add_data_arg;
	set_level_flag = "1"b;
	end;
	go to read_loop;

do_format (15):					/* pf (page faults) */

	temp_argument_descr_ptr = addr (integer_descr);
	incr_string = " ^d";
	if total_format_flag then do;
	     temp_argument_ptr = addr (ZERO_BS);
	     call add_data_arg;
	     temp_argument_ptr = addr (total_page_faults);
	end;
	else do;
	     temp_argument_ptr = addr (ZERO_BS);
	     call add_data_arg;
	     temp_argument_ptr = addr (inc_page_faults);
	end;

	incr_string = "+^d";
	call add_data_arg;
	go to read_loop;

do_format (18):					/* pft (page faults) */

	temp_argument_descr_ptr = addr (integer_descr);
	if total_format_flag then do;
	     temp_argument_ptr = addr (total_page_faults);
	end;
	else do;
	     temp_argument_ptr = addr (inc_page_faults);
	end;

	incr_string = " ^d";
	call add_data_arg;
	go to read_loop;

do_format (19):					/* sf (segment faults) */

	temp_argument_descr_ptr = addr (integer_descr);
	incr_string = " ^d";
	if total_format_flag then
	     temp_argument_ptr = addr (total_seg_faults);
	else temp_argument_ptr = addr (inc_seg_faults);
	call add_data_arg;
	go to read_loop;

do_format (20):					/* bf (bounds faults) */

	temp_argument_descr_ptr = addr (integer_descr);
	incr_string = " ^d";
	if total_format_flag then
	     temp_argument_ptr = addr (total_bounds_faults);
	else temp_argument_ptr = addr (inc_bounds_faults);
	call add_data_arg;
	go to read_loop;

do_format (21):					/* vr (vtoc reads) */

	temp_argument_descr_ptr = addr (integer_descr);
	incr_string = " ^d";
	if total_format_flag then
	     temp_argument_ptr = addr (total_vtoc_reads);
	else temp_argument_ptr = addr (inc_vtoc_reads);
	call add_data_arg;
	go to read_loop;

do_format (22):					/* vw (vtoc writes) */

	temp_argument_descr_ptr = addr (integer_descr);
	incr_string = " ^d";
	if total_format_flag then
	     temp_argument_ptr = addr (total_vtoc_writes);
	else temp_argument_ptr = addr (inc_vtoc_writes);
	call add_data_arg;
	go to read_loop;

do_format (23):					/* rcpu (real cpu) */

	if total_format_flag then
	     temp_argument_ptr = addr (total_rcpu_time);
	else temp_argument_ptr = addr (inc_rcpu_time);
	call add_floating_arg;
	go to read_loop;

do_format (24):					/* -active_string */

	incr_string = " ^a";
	temp_flag.inc (24) = "0"b;			/* may be repeated */
	temp_n_active_strings = temp_n_active_strings + 1;
	argnumber = argnumber + 1;
	call get_arg_ptr_ (argnumber, arg_ptr, arglen, code);
	if code ^= 0 then do;
	     call err_ (code, whoami, "An active string must be specified following -active_string.");
	     return;
	end;
	call add_active_string;
	go to read_loop;

do_format (12):					/* -dollars */

	if total_format_flag then temp_argument_ptr = addr (total_dollars);
	else temp_argument_ptr = addr (inc_dollars);

	doing_dollars = "1"b;
	call add_floating_arg;
	doing_dollars = "0"b;
	go to read_loop;

do_format (4):					/* -date_time */
	temp_date_time_flag = "1"b;
	temp_argument_ptr = addr (date_time_string);
	go to ADD_DATE;

do_format (7):					/* -date, -dt */
	temp_date_flag = "1"b;
	temp_argument_ptr = addr (date_string);
	go to ADD_DATE;

do_format (1):					/* -time, -tm */
	temp_time_flag = "1"b;
	temp_argument_ptr = addr (time_string);
	go to ADD_DATE;

do_format (2):					/* -hour */
do_format (3):					/* -minute */
do_format (5):					/* -zone */
do_format (6):					/* -day_name */
do_format (8):					/* -month */
do_format (9):					/* -day */
do_format (10):					/* -year */

	temp_argument_ptr = addr (dt_chars (dt_offset (arg_index)));

ADD_DATE:
	dt_offset_index = dt_descr_index (arg_index);
	temp_argument_descr_ptr = addr (dt_descr (dt_offset_index));
	incr_string = dt_incr_string (arg_index);
	call add_data_arg;
	go to read_loop;

do_format (25):					/* -time_format */
	argnumber = argnumber + 1;
	call get_arg_ptr_ (argnumber, arg_ptr, arglen, code);
	if code ^= 0 then do;
	     call err_ (code, whoami, "A time format string must be specified following -time_format.");
	     return;
	end;
	if arglen &gt; length (time_format) then do;
	     call err_ ((0), whoami, "Time format strings must be ^d characters or fewer in length. ^a", length (time_format), arg);
	     return;
	end;
	temp_time_format = arg;
	on sub_error_ begin;
	     call find_condition_info_ (null (), addr (ci), code);
	     if code ^= 0 then
		call err_ ((0), whoami, "Invalid time format string. ^a", temp_time_format);
	     else do;
		sub_error_info_ptr = ci.info_ptr;
		call com_err_ (sub_error_info.status_code, whoami, "^a", sub_error_info.info_string);
	     end;
	     go to EXIT_RETURN;
	end;
	time_format_string = date_time_$format (temp_time_format, clock (), "", "");
	revert sub_error_;
	temp_time_format_flag = "1"b;
	temp_argument_ptr = addr (time_format_string);
	temp_argument_descr_ptr = addr (dt_descr (3));
	incr_string = " ^a";
	call add_data_arg;
	go to read_loop;

/* control arg stuff, not allowed if invoked as active function */

do_control_arg (1):					/* set */
	temp_set_flag = "1"b;
	go to read_loop;

do_control_arg (2):					/* -revert */

	temp_revert_flag = "1"b;
	go to read_loop;

do_control_arg (3):					/* -call */

	argnumber = argnumber +1;
	call get_arg_ptr_ (argnumber, arg_ptr, arglen, code);
	if code ^= 0 then go to no_sub_arg;

	temp_clp = arg_ptr;
	temp_cll = arglen;				/* save ptr and length */
	values_set_flag = "1"b;
	go to read_loop;

do_control_arg (4):					/* -reset */
	temp_reset_flag = "1"b;
	go to read_loop;


/* end of control args */

/* prefix args */

do_prefix (2):					/* -control */

	incr_string_flag = "0"b;

do_prefix (1):					/* -string */

	argnumber = argnumber + 1;
	call get_arg_ptr_ (argnumber, arg_ptr, arglen, code);
	if code ^= 0 then do;
no_sub_arg:
	     call err_ (code, whoami, "no argument to ^a", arg);
	     return;
	end;
	temp_ioa_string = arg;
	values_set_flag = "1"b;
	go to read_loop;

/* end of control arg code */

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

add_data_arg: proc;
						/* internal procedure to add ptrs to argument_ptr(number_of_data)
						   and argument_descr_ptr(number_of_data) and update
						   num data when temp_argument_descr has been set
						   to proper descr.
						   */
	     number_of_data = number_of_data +1;
	     values_set_flag = "1"b;
	     argument_ptr (number_of_data) = temp_argument_ptr;
	     argument_descr_ptr (number_of_data) = temp_argument_descr_ptr;
	     if incr_string_flag then temp_ioa_string = temp_ioa_string || incr_string;
	end add_data_arg;


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

add_floating_arg: proc;

	     temp_argument_descr_ptr = addr (float_descr);
	     incr_string = " ^.3f";			/* assume default precision for now */
	     argnumber = argnumber +1;
	     call get_arg_ptr_ (argnumber, arg_ptr, arglen, code);
	     if code = 0

	     then if (arglen = 1 &amp; arg &gt;= "1" &amp; arg &lt;= "9") | arglen = 0
		then incr_string = " ^." || arg || "f";
		else go to no_precision;
	     else do;
no_precision:
		if doing_dollars then substr (incr_string, 4, 1) = "2";
		argnumber = argnumber - 1;		/* arg is keyword */
	     end;

	     if doing_dollars then do;
		incr_string = " $" || substr (incr_string, 2);
	     end;
	     call add_data_arg;

	end add_floating_arg;

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

add_active_string: procedure;			/* this procedure sets up an active string */
	     number_of_data = number_of_data + 1;
	     argument_ptr (number_of_data) = null ();
	     argument_descr_ptr (number_of_data) = null ();
	     values_set_flag = "1"b;
	     if incr_string_flag then temp_ioa_string = temp_ioa_string || incr_string;
	     input_string_length = arglen;
	     if temp_last_active_string_ptr = null () then do;
		allocate active_string set (temp_last_active_string_ptr);
		temp_active_string_ptr = temp_last_active_string_ptr;
	     end;
	     else do;
		allocate active_string set (temp_last_active_string_ptr -&gt; active_string.next_active_string_ptr);
		temp_last_active_string_ptr = temp_last_active_string_ptr -&gt; active_string.next_active_string_ptr;
	     end;
	     temp_last_active_string_ptr -&gt; active_string.descriptor = active_string_descr_const;
	     temp_last_active_string_ptr -&gt; active_string.num_of_data = number_of_data;
	     temp_last_active_string_ptr -&gt; active_string.input_string_len = input_string_length;
	     temp_last_active_string_ptr -&gt; active_string.input_string = arg;
	     temp_last_active_string_ptr -&gt; active_string.next_active_string_ptr = null ();
end add_active_string;

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

/*  these internal subroutines should be called with arguments and
   via decode_descriptor or directly copying manage to encode
   descriptors for upwards compatibility with desc change.
   */

setup_ready: proc;

	     old.virtual_cpu_time, last.page_faults, last.pd_faults, old.paging_measure, old.page_faults, old.pd_faults,
	     old.cpu_time, old.segment_faults, old.bounds_faults, old.vtoc_reads, old.vtoc_writes = 0;
	     last_dollars, dollars_fudge = 0e0;

	     call user_info_$usage_data ((0), old.virtual_cpu_time, login_time, first_time,
		old.paging_measure);
	     call gr_get_rates_ (vcpu_rate, real_rate, process_hour_rate, kmu_rate, next_shift);
	     vcpu_rate = vcpu_rate/3.6e9;
	     real_rate = real_rate/3.6e9;
	     process_hour_rate = process_hour_rate/3.6e9;;
	     milli_mu_rate = kmu_rate/1e6;
	     online_rate = real_rate + process_hour_rate;
	     last.virtual_cpu_time = old.virtual_cpu_time;	/* make incremental work first time */
	     last.paging_measure = old.paging_measure;
	     old_dollars = float (last.virtual_cpu_time, 20)*vcpu_rate+
		float (last.paging_measure, 20)*milli_mu_rate +
		float (first_time-login_time, 20)*online_rate;
	     last_dollars = old_dollars;
	     dollars_fudge = -old_dollars;
						/* at present there is no way to obtain the value of
						   demand pages
						   for a previous process during same login. Thus these values
						   are zeroed.  Eventually Multics
						   will provide this information and
						   this program can be updated. */

	     old_n_active_strings = 0;
	     old_active_string_ptr, old_last_active_string_ptr = null ();
	     static_arg_list_ptr, arg_list_ptr = addr (ioa_arg_list);
	     temp_set_flag = "1"b;			/* want to set static values */
	     af_flag = "0"b;
	     temp_ioa_string = "r^x" || default_ioa_string;
	     call set_default_arg_list;

	     first_time_flag = "0"b;
	     if next_shift &gt; 0 then call timer_manager_$alarm_call (next_shift, "00"b, change_shift);
	     return;
	end setup_ready;

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

set_default_arg_list: proc;
	     af_offset = 2*fixed (af_flag, 17, 0);
	     number_of_data = 5+af_offset;
	     arg_list_header.twice_arg_count,
		arg_list_header.twice_desc_count = 2*number_of_data;
	     arg_list_header.code = 4;
	     arg_list_header.pad = 0;

	     if temp_set_flag then do;
		ioa_string = temp_ioa_string;
		arg_ptrs (1) = addr (ioa_string);
		descr_ptrs (1) = addr (ioa_string_descr);
		descr_ptrs (1) -&gt; based_descr.size = bit (bin (length (temp_ioa_string), 24), 24);
		old_inc_flag = "1"b;
		old_level_flag = "1"b;
		old_time_flag = "1"b;
	     end;
	     else do;
		arg_ptrs (1) = addr (addr (temp_ioa_string) -&gt; temp_ioa_bvss.string);
		descr_ptrs (1) = addr (temp_ioa_string_descr);
		temp_ioa_string_descr.type = "010101"b;
		temp_ioa_string_descr.packed = "0"b;
		temp_ioa_string_descr.number_dims = "0000"b;
		temp_ioa_string_descr.flag = "1"b;
		string_length = length (temp_ioa_string);
		temp_ioa_string_descr.size = bit (bin (string_length, 24), 24);
		temp_inc_flag = "1"b;
		temp_level_flag = "1"b;
		temp_time_flag = "1"b;
	     end;

	     arg_ptrs (2+af_offset) = addr (time_string);
	     descr_ptrs (2+af_offset) = addr (dt_descr (3));

	     arg_ptrs (3+af_offset) = addr (inc_vcpu_time);
	     descr_ptrs (3+af_offset) = addr (float_descr);
	     arg_ptrs (4+af_offset) = addr (inc_page_faults);
	     descr_ptrs (4+af_offset) = addr (integer_descr);

	     arg_ptrs (5+af_offset) = addr (level_string);
	     descr_ptrs (5+af_offset) = addr (level_descr);

	end set_default_arg_list;

     end general_ready;
�



		    get_shortest_path_.pl1          03/29/84  1510.0r   03/15/84  0819.2       97236



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

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

get_shortest_path_:
     proc (P_path) returns (char (168));

/* DESCRIPTION:

	Replaces every directory component it has access to with the
     shortest name on the directory.  If for any component multiple
     shortest names are found, three steps are taken to give what is
     hopefully the optimum name for the user.  First, try to get rid of
     any names with upper case characters in them and reduce the list
     of candidate names to this set.  If multiple names still exist,
     take the first char. of the primary name and take the first short
     name whose first char. matches it case independently.  If this fails,
     return the first shortest name found.
*/

/* HISTORY:

Written by S. Herbst, 10/01/81.
Modified:
11/16/82 by S. Herbst:  Added cleanup handler and made it replace names
	  of links to dirs.
09/13/83 by Lee A. Newcomb:  made to give precidence to names without upper
	  case chars, then names matching 1st char of primary name.  Also
	  made status_branch an automatic structure, and fixed bug where
	  status_entry_names structure was never freed.
01/30/84 by L. A. Newcomb:  fixed bug in freeing the status_entry_names
	  structure if the pathname supplied is a link (i.e., the last
	  pathname component is a link, but we don't care about the other
	  directory components of the pathname).
*/
%page;
/* START OF DECLARATIONS */
/* Parameter */
dcl
     P_path		        char (*)		/* path to get shortest_path of */
			        parameter;

/* Automatic */
dcl  (
     code			        fixed bin (35),	/* status/error code */
     ename		        char (32),		/* used in hcs_$status_ to get all enames */
     entry_names_p		        ptr,		/* for getting to (status_)entry_names faster */
     i			        fixed bin (21),	/* used in indexing into orginal_path */
     input_path		        char (528) varying,	/* 528 max. for paths */
     original_path		        char (528),		/* after being pased through absolute_pathname_ */
     output_path		        char (528) varying,	/* we build it as we go */
     start		        fixed bin (21)	/* for walking through the given name */
     )			        automatic;

/* Automatic Structures */
dcl
     1 local_status_branch	        like status_branch aligned
			        automatic;

/* CONSTANTS */
dcl  (
     LOWER_CHARS		        char (26) init ("abcdefghijklmnopqrstuvwxyz"),
     NO_CHASE		        fixed bin (1) init (0),
     UPPER_CHARS		        char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     )			        internal static options (constant);

/* Based */
dcl
     entry_names		        aligned char (32)	/* like status_entry_names */
			        dim (status_branch.nnames) based (entry_names_p),
     status_area		        area based (status_area_ptr);

/* Entries */
dcl
     absolute_pathname_	        entry (char (*), char (*), fixed (35)),
     get_system_free_area_	        entry returns (ptr),
     hcs_$status_		        entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35));

/* Builtins &amp; Conditions */
dcl
     (addr, index, length,
     null, pointer, rtrim,
     search, substr, translate)       builtin,
     cleanup		        condition;

/* END OF DECLARATIONS */
%page;
	call absolute_pathname_ (P_path, original_path, code); /* get the complete pathname string */
	if code ^= 0 then				/* failure, can only return input data */
	     return (P_path);

	if original_path = "&gt;" then			/* the ROOT is kind of short to start with */
	     return ("&gt;");

	input_path = rtrim (original_path);		/* copy to varying string */
	output_path = "&gt;";				/* always start at the ROOT */
	start = 2;				/* ignore first "&gt;" in path */
	status_area_ptr = get_system_free_area_ ();	/* where to allocate status_names */
	status_ptr = addr (local_status_branch);	/* use auto storage for the basic structure */
	status_branch.names_relp = ""b;		/* for cleanup */
	entry_names_p = null ();			/* for safety in cleanup */

	on cleanup begin;
		if status_branch.names_relp ^= ""b then
		     if entry_names_p ^= null () then	/* take care of window between setting names_relp and ptr */
			free entry_names in (status_area); /* so we don't free twice */
	     end;

	do while (start &lt;= length (input_path));	/* main loop, go until nothing left */
						/* get next ename to shorten */
	     i = index (substr (input_path, start), "&gt;");
	     if i ^= 0 then
		ename = substr (input_path, start, i - 1);
	     else do;
		ename = substr (input_path, start);
		i = length (input_path) + 1;		/* to stop loop */
	     end;

	     call hcs_$status_ ((output_path), ename, NO_CHASE, status_ptr, status_area_ptr, code);
	     if code = 0 then			/* make freeing work */
		entry_names_p = pointer (status_area_ptr, status_branch.names_relp);

	     if code = 0 &amp;
		(status_branch.type = Directory |	/* replace only directory names */
		(status_branch.type = Link &amp; i &lt;= length (input_path))) then     /* and names of links to dirs */
		ename = select_shortest_entry_name ();	/* possibly replace original name */


	     if code = 0 then do;			/* must free names struct. */
		status_branch.names_relp = ""b;	/* to prevent multiple frees by cleanup handler */
		free entry_names in (status_area);	/* and use our version of the structure for freeing */
		entry_names_p = null ();		/* so ptr is null between relp setting and ptr calculation */
	     end;

						/* ename still holds name to use */
	     if length (output_path) &gt; 1 then		/* most common case */
		output_path = output_path || "&gt;" || rtrim (ename);
	     else output_path = "&gt;" || rtrim (ename);	/* don't double up the first "&gt;" */
	     start = start + i;			/* update loop control */
	end;


	return ((output_path));

/*   end get_shortest_path_; */
%page;
select_shortest_entry_name:
     proc () returns (char (32));

/* This procedure selects the shortest name in the currently available */
/* status_entry_names array.  For efficiency and ease of programming,  */
/* the entry_names array has been declared and given an explicit ptr.  */
/* The necessity for this procedure is to allocate the name index      */
/* as we have no idea at the time get_shortest_path_'s stack frame is  */
/* laid down what the max size required will be.                       */

/* START OF DECLARATIONS */
/* Automatic */
dcl  (
     curr_shortest_length	        fixed bin (21),	/* shortest entryname length at any point in selection */
     name_idx		        fixed bin,		/* for walking throught status_names struct. */
     n_lower_names		        fixed bin,		/* # of entrynames of the same length with no upper */
						/* case chars; must be &lt;= n_shortest_names */
     n_shortest_names	        fixed bin,		/* # of shortest entrynames of same length */
     primary_ename_fchar	        char (1) aligned,	/* 1st char. of primary entryname for selecting */
						/* between multiple shortest names of same length */
     shortest_name_idxs	        fixed bin dim (status_branch.nnames) /* for getting the SHORTEST entrynames */
						/* dcl'd this way to not have to program */
						/* for a staticly dcl'd array overflow */
     )			        automatic;

/* END OF DECLARATIONS */

	n_shortest_names = 1;			/* to start */
	shortest_name_idxs (1) = 1;
	curr_shortest_length = length (rtrim (entry_names (1)));

	do name_idx = 2 to status_branch.nnames;

	     if length (rtrim (entry_names (name_idx))) &lt; curr_shortest_length then do;
						/* new shortest length */
		curr_shortest_length = length (rtrim (entry_names (name_idx)));
		n_shortest_names = 1;		/* must restart list */
		shortest_name_idxs (1) = name_idx;
	     end;

	     else if length (rtrim (entry_names (name_idx))) = curr_shortest_length then do;
						/* add to current list */
		n_shortest_names = n_shortest_names + 1;
		shortest_name_idxs (n_shortest_names) = name_idx;
	     end;

	     else ;				/* name too long ==&gt; uninteresting */
	end;

/* if only one name is left, we have our answer */

	if n_shortest_names = 1 then			/* done */
	     return (entry_names (shortest_name_idxs (1)));
%page;
/* More work needed:  all names we have saved indices of are of the same  */
/* length see if any are all lower case or valid non-alpha chars.  We     */
/* will share the current index array if any names show up not containing */
/* any upper case characters.					    */

	n_lower_names = 0;				/* we share the current index array */
	do name_idx = 1 to n_shortest_names;

	     if search (entry_names (shortest_name_idxs (name_idx)), UPPER_CHARS) = 0 then do;

		n_lower_names = n_lower_names + 1;	/* no upper case chars */
		shortest_name_idxs (n_lower_names) = shortest_name_idxs (name_idx);
	     end;
	end;

/* If one non-upper name was found, we return it */

	if n_lower_names = 1 then			/* done */
	     return (entry_names (shortest_name_idxs (1)));

/* We know we need to do compare with first char of primary name case */
/* independently.  First, we make sure we have that char in lower     */
/* if it is upper case. */

	primary_ename_fchar = translate (substr (entry_names (1), 1, 1), LOWER_CHARS, UPPER_CHARS);

/* If we know only non-upper case names are around, do small optimization */

	if n_lower_names &gt; 1 then do;

	     do name_idx = 1 to n_lower_names;		/* will break out of loop on a match */

		if primary_ename_fchar = substr (entry_names (shortest_name_idxs (name_idx)), 1, 1) then
		     return (entry_names (shortest_name_idxs (name_idx)));	/* done */
	     end;
						/* no match, return 1st non-upper name */
	     return (entry_names (shortest_name_idxs (1)));    /* done */
	end;

/* If there were no non-upper case names, we must do a translation for   */
/* the fchar compare.  This is the only effective difference between the */
/* previous compare loop and the following one. */

	do name_idx = 1 to n_shortest_names;

	     if primary_ename_fchar = translate (substr (entry_names (
		shortest_name_idxs (name_idx)), 1, 1), LOWER_CHARS, UPPER_CHARS) then

		return (entry_names (shortest_name_idxs (name_idx)));	/* done */
	end;

/* no first char match on multiple names of same shortest length. */
/* We just return the first shortest name found */

	return (entry_names (shortest_name_idxs (1)));	/* done */

     end select_shortest_entry_name;
%page;%include status_structures;

     end get_shortest_path_;




		    gr_get_rates_.pl1               11/04/82  2003.4rew 11/04/82  1630.8       28215



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


gr_get_rates_: proc (cpu_rate, real_rate, io_ops_rate, kmu_rate, next_shift);

dcl  next_shift fixed bin (71);
dcl (dv_index, number_of_devices) fixed bin;
dcl  tty_charge_type char (8);
dcl (cpu_rate,
     real_rate,
     io_ops_rate,
     kmu_rate) float bin;
dcl  ip ptr;
dcl  ec fixed bin;
dcl  shift_index fixed bin;
dcl  abs_queue fixed bin;
dcl  part_of_week fixed bin (71);
dcl  time fixed bin (71);
dcl  s fixed bin;
dcl  shift fixed bin;
dcl  shift_tab (336) fixed bin;
dcl (cpu (0:7),
     log (0:7),
     io_ops (0:7),
     cor (0:7),
     dsk,
     reg,
     abs_cpu_rate (4),
     abs_kmu_rate (4)) float bin;
dcl  user_info_$terminal_data ext entry (char(*), char(*), char(*), fixed bin, char(*));
dcl  system_info_$device_prices ext entry options (variable);
dcl  user_info_$absentee_queue ext entry (fixed bin);
dcl  system_info_$shift_table ext entry ((336) fixed bin);
dcl  system_info_$next_shift_change ext entry (fixed, fixed bin (71));
dcl  system_info_$prices ext entry ((0:7) float bin, (0:7) float bin, (0:7) float bin, (0:7) float bin, float bin, float bin);
dcl  system_info_$abs_prices ext entry ((4) float bin, (4) float bin);
dcl  sys_info$time_delta fixed bin (35) ext static;
dcl (fixed,
     divide,
     mod) builtin;



	call user_info_$absentee_queue (abs_queue);
						/* are we executing in an absentee process and if so, what queue are we in? */
	if abs_queue &gt; 0 then do;
	     call system_info_$abs_prices (abs_cpu_rate, abs_kmu_rate);
	     cpu_rate = abs_cpu_rate (abs_queue);
	     kmu_rate = abs_kmu_rate (abs_queue);
	     real_rate, io_ops_rate = 0.;
	     next_shift = 0;
	end;
	else do;
	     call system_info_$prices (cpu, log, io_ops, cor, dsk, reg); /* get prices for various things for each shift */
	     call system_info_$next_shift_change (s, next_shift); /* this may differ from static system data */

/* return prices */
	     cpu_rate = cpu (s);
	     io_ops_rate = io_ops (s);
	     kmu_rate = cor (s);
	     real_rate = log (s);			/* get connect time base price */
						/* now determine surcharge on login rate */

	     call user_info_$terminal_data ("", "", "", 0, tty_charge_type);
	     call system_info_$device_prices (number_of_devices);
	     begin;

dcl 1 dvt (number_of_devices) aligned,
    2 id char (8),
    2 prices (0:7) float bin (27);

		call system_info_$device_prices ((0), addr (dvt));
		do dv_index = 1 to number_of_devices;
		     if tty_charge_type = dvt.id (dv_index) then do;
			real_rate = real_rate + dvt.prices (dv_index, s);
						/* add in surcharge */
			dv_index = number_of_devices;
		     end;
		end;
	     end;

	end;

     end;
�



		    hex.pl1                         11/04/82  2003.4rew 11/04/82  1630.8       41571



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


hexadecimal: hex: proc;

/* Implements the hexadecimal, decimal, octal and binary commands/afs.
   Written 03/09/81 S. Herbst */


/* Based */

dcl  arg char (arg_len) based (arg_ptr);
dcl  return_arg char (return_len) varying based (return_ptr);


/* Automatic */

dcl  ME char (32);
dcl  val_str char (72) varying;

dcl  af_sw bit (1) aligned;

dcl (arg_ptr, return_ptr) ptr;

dcl  char8 char (8);
dcl  float59 float dec (59);
dcl  fixed71 fixed bin (71);
dcl (arg_len, return_len) fixed bin (21);
dcl (digit_val, input_base) fixed bin (5);
dcl (arg_count, arg_index, base, i, point_count) fixed bin;
dcl  code fixed bin (35);

dcl  error_table_$bad_conversion fixed bin (35) ext;
dcl  error_table_$not_act_fnc fixed bin (35) ext;

dcl  complain entry variable options (variable);

dcl (active_fnc_err_, active_fnc_err_$af_suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl (ioa_, ioa_$nnl) entry options (variable);
dcl  numeric_to_ascii_base_ entry (float dec (59), fixed bin, fixed bin) returns (char (72) varying);

dcl (convert, decimal, index, low, substr, unspec) builtin;

dcl (conversion, overflow, underflow) condition;
%page;

	ME = "hexadecimal";
	base = 16;
	go to START;

decimal: dec: entry;

	ME = "decimal";
	base = 10;
	go to START;

octal: oct: entry;

	ME = "octal";
	base = 8;
	go to START;

binary: bin: entry;

	ME = "binary";
	base = 2;
	go to START;


START:
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     if arg_count = 0 then do;
		call com_err_$suppress_name (0, ME, "Usage:  ^a num_args", ME);
		return;
	     end;
	     af_sw = "0"b;
	     complain = com_err_;
	end;
	else if code = 0 then do;
	     if arg_count = 0 then do;
		call active_fnc_err_$af_suppress_name (0, ME, "Usage:  [^a num_args]", ME);
		return;
	     end;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     return_arg = "";
	end;
	else do;
	     call active_fnc_err_ (code, ME);
	     return;
	end;

	on conversion, overflow, underflow go to BAD_NUM;

	do arg_index = 1 to arg_count;

	     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);

	     if arg_len = 0 then float59 = 0;
	     else do;

		i = index ("bqox", substr (arg, arg_len, 1));
		if i ^= 0 then do;
		     input_base = 2 ** i;
		     float59 = 0;
		     point_count = -1;		/* scanning for decimal point */

		     do i = 1 to arg_len - 1;

			if substr (arg, i, 1) = "." then do;
			     if point_count &gt;= 0 then do;
BAD_NUM:				call complain (error_table_$bad_conversion, ME, "^a", arg);
				return;
			     end;
			     point_count = 0;
			end;
			else do;
			     digit_val = index ("0123456789ABCDEFabcdef", substr (arg, i, 1)) - 1;
			     if digit_val &lt; 0 then go to BAD_NUM;
			     if digit_val &gt; 15 then digit_val = digit_val - 6; /* lowercase abcdef */
			     if digit_val &gt;= input_base then go to BAD_NUM;

			     if point_count &gt;= 0 then point_count = point_count + 1; /* after the decimal point */

			     float59 = float59 * decimal (input_base, 2) + decimal (digit_val, 2);
			end;
		     end;

		     if point_count &gt; 0 then		/* decimal point in the input */
			float59 = float59 / decimal (input_base ** point_count);
		end;
		else if substr (arg, arg_len, 1) = "u" then do; /* unspec */
		     arg_len = arg_len - 1;
		     if arg_len &gt; 8 then do;
			call complain (0, ME, """u"" conversion only allows 8 characters.  ^au", arg);
			return;
		     end;
		     char8 = low (8 - arg_len) || arg;
		     unspec (fixed71) = unspec (char8);
		     float59 = fixed71;
		end;
		else float59 = convert (float59, arg);
	     end;

	     val_str = numeric_to_ascii_base_ (float59, 0, base);
APPEND:
	     if af_sw then do;
		if return_arg ^= "" then return_arg = return_arg || " ";
		return_arg = return_arg || val_str;
	     end;
	     else call ioa_$nnl ("^a ", val_str);
	end;

	if ^af_sw then call ioa_ ("");

     end hexadecimal;
�



		    if.pl1                          11/04/82  2003.4rew 11/04/82  1610.0      126864



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


/* Conditionally executes one of two command/request lines; as an active function/request, conditionally returns one of
   two strings */

/* Created:  September 1970 by THVV */
/* Modified: 27 April 1976 by Steve Herbst to accept keys "true" and "false" */
/* Modified: 17 February 1982 by G. Palter to add ssu_if_request_ and convert to use a standalone subsystem invocation */
/* Modified: 8 September 1982 by G. Palter to propogate subsystem/request line aborts */

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


if:
     procedure () options (variable);


dcl  P_sci_ptr pointer parameter;			/* ssu_if_request_: -&gt; SCI of subsystem */
dcl  P_info_ptr pointer parameter;			/* ssu_if_request_: -&gt; subsystem's internal data */

dcl  sci_ptr pointer;
dcl  standalone_invocation bit (1) aligned;

dcl  active_function bit (1) aligned;
dcl  nargs fixed binary;

dcl  return_string char (rl) varying based (rp);
dcl  rl fixed binary (21);
dcl  rp pointer;

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

dcl  second_argument character (cl) based (cp);
dcl  cl fixed binary (21);
dcl  cp pointer;

dcl  key character (8);
dcl  an fixed binary;

dcl  notsw bit (1) aligned;
dcl  thenloc fixed binary;
dcl  elseloc fixed binary;

dcl  ec fixed binary (35);

dcl  i fixed binary;
dcl  (first_number, second_number) fixed binary (35);

dcl  chase fixed binary (1);
dcl  type fixed binary (2);
dcl  bc fixed binary (24);
dcl  dn character (168);
dcl  en character (32);

dcl  timestr character (24);

dcl  yes_no_sw bit (1);

dcl  error_table_$bad_conversion fixed binary (35) external;
dcl  error_table_$noarg fixed binary (35) external;
dcl  ssu_et_$null_request_line fixed binary (35) external;
dcl  ssu_et_$subsystem_aborted fixed binary (35) external;

dcl  active_fnc_err_ entry () options (variable);
dcl  com_err_ entry () options (variable);
dcl  command_query_$yes_no entry () options (variable);
dcl  cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35));
dcl  cu_$arg_list_ptr entry () returns (pointer);
dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl  date_time_ entry (fixed binary (71), character (*));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  hcs_$status_minf
	entry (character (*), character (*), fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35));
dcl  ssu_$abort_line entry () options (variable);
dcl  ssu_$abort_subsystem entry () options (variable);
dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
dcl  ssu_$destroy_invocation entry (pointer);
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_$get_request_name entry (pointer) returns (character (32));
dcl  ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
dcl  ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35));

dcl  cleanup condition;

dcl  (clock, null, substr) builtin;

/**/

/* Multics if command/active-function */

/* if: entry () options (variable); */

	standalone_invocation = "1"b;			/* must create a standalone subsystem to do this */
	call ssu_$standalone_invocation (sci_ptr, "if", "1.0", cu_$arg_list_ptr (), abort_if_command, ec);
	if ec ^= 0 then do;				/* please forgive the following, but ... */
	     if cu_$af_return_arg (0, (null ()), (0)) = 0 then
		call active_fnc_err_ (ec, "if", "Can not establish standalone subsystem invocation.");
	     else call com_err_ (ec, "if", "Can not establish standalone subsystem invocation.");
	     return;
	end;
	go to COMMON;


/* Standard subsystem if request */

ssu_if_request_:
     entry (P_sci_ptr, P_info_ptr);

	standalone_invocation = "0"b;			/* caller supplied the subsystem */
	sci_ptr = P_sci_ptr;
	go to COMMON;


/* Actual work starts here */

COMMON:
	on condition (cleanup)
	     begin;
		if standalone_invocation then call ssu_$destroy_invocation (sci_ptr);
	     end;

	call ssu_$return_arg (sci_ptr, nargs, active_function, rp, rl);

	if nargs = 0 then				/* abort_line never returns */
PRINT_USAGE_MESSAGE:
	     if active_function then
		call ssu_$abort_line (sci_ptr, 0, "Usage:  [^a key -then {value1} {-else value2}]",
		     ssu_$get_request_name (sci_ptr));
	     else call ssu_$abort_line (sci_ptr, 0,
		     "Usage:  ^a key -then {^[command^;request^]1} {-else ^[command^;request^]2}",
		     ssu_$get_request_name (sci_ptr), standalone_invocation, standalone_invocation);

	an = 2;					/* index of first argument after the key */
	notsw = "0"b;				/* do not invert the test */
	thenloc, elseloc = 0;			/* no -then or -else yet */
	chase = 1;				/* chase links by default */


/* Get the keyword */

	call ssu_$arg_ptr (sci_ptr, 1, ap, al);
	key = argument;

	if key = "-not" then do;			/* users wishes to invert the test */
	     notsw = "1"b;
	     an = an + 1;				/* next argument is the keyword */
	     call ssu_$arg_ptr (sci_ptr, 2, ap, al);
	     key = argument;
	end;

	else if substr (key, 1, 1) = "^" then do;	/* users wises to invert the test */
	     key = substr (key, 2, 7);
	     notsw = "1"b;
	end;


/* Locate then and else clauses (if any) and validate command/request syntax */

	do i = an to nargs;

	     call ssu_$arg_ptr (sci_ptr, i, ap, al);

	     if argument = "-then" then do;
		if thenloc ^= 0 then go to PRINT_USAGE_MESSAGE;
		thenloc = i;			/* remember location of "-then" */
	     end;

	     else if argument = "-else" then do;
		if elseloc ^= 0 then go to PRINT_USAGE_MESSAGE;
		elseloc = i;			/* remember location of "-else" */
	     end;
	end;

	if thenloc = 0 then go to PRINT_USAGE_MESSAGE;	/* -then must be supplied */

	if elseloc &gt; 0 then do;			/* -else must follow -then with, at most, one ... */
	     if elseloc &lt; thenloc then go to PRINT_USAGE_MESSAGE;
	     if elseloc &gt; (thenloc + 2) then go to PRINT_USAGE_MESSAGE;
	     if (elseloc + 1) ^= nargs then go to PRINT_USAGE_MESSAGE;
	end;					/* ... intervening argument and must be followed by one */

	else do;					/* -then alone: it may be followed by no more than one arg */
	     if nargs &gt; (thenloc + 1) then go to PRINT_USAGE_MESSAGE;
	end;


/* Determine results of the key (execution/no-execution) */

	if key = "true" then go to RESULT_IS_TRUE;	/* key was an active string */

	if key = "false" then go to RESULT_IS_FALSE;	/* key was an active string */

	if key = "is" then do;			/* check that a branch (seg/MSF/dir) exists */
CHECK_ENTRY_EXISTENCE:
	     if an = thenloc then			/* no pathname was supplied */
		call ssu_$abort_line (sci_ptr, error_table_$noarg, "Pathname after ""^a"".", key);
	     call ssu_$arg_ptr (sci_ptr, an, ap, al);
	     call expand_pathname_ (argument, dn, en, ec);
	     if ec ^= 0 then go to STATUS_MINF_CALL_FAILS;/* bad pathname: same as no entry */
	     if key = "islink" then chase = 0;		/* look for a link */
	     if key = "isfile" then chase = 0;		/* look for a segment */
	     if key = "isdir" then chase = 0;		/* look for a directory */
	     call hcs_$status_minf (dn, en, chase, type, bc, ec);
	     if ec ^= 0 then
STATUS_MINF_CALL_FAILS:				/* entry does not exist */
		if key = "isnt" then
		     go to RESULT_IS_TRUE;
		else go to RESULT_IS_FALSE;
	     if key = "is" then go to RESULT_IS_TRUE;	/* entry is there */
	     if key = "isnt" then go to RESULT_IS_FALSE;	/* entry is there: asked if it wasn't */
	     if key = "isdir" then			/* looking for a directory */
		if type = 2 then go to RESULT_IS_TRUE;
	     if key = "islink" then			/* looking for a link */
		if type = 0 then go to RESULT_IS_TRUE;
	     if key = "isfile" then			/* looking for a segment */
		if type = 1 then go to RESULT_IS_TRUE;
	     if key = "isnzf" then			/* looking for a non-zero length segment */
		if (type = 1) &amp; (bc &gt; 0) then go to RESULT_IS_TRUE;
	     go to RESULT_IS_FALSE;			/* here iff test failed */
	end;

	else if key = "isnt" then go to CHECK_ENTRY_EXISTENCE;
						/* check for non-existence of a branch */
	else if key = "isfile" then go to CHECK_ENTRY_EXISTENCE;
						/* check for existence of a segment */
	else if key = "isdir" then go to CHECK_ENTRY_EXISTENCE;
						/* check for existence of a directory */
	else if key = "islink" then go to CHECK_ENTRY_EXISTENCE;
						/* check for existence of a link */
	else if key = "isnzf" then go to CHECK_ENTRY_EXISTENCE;
						/* check for existence of a non-zero length segment */

	else if key = "arg" then			/* check for an argument after the key and before -then */
	     if an = thenloc then
		go to RESULT_IS_FALSE;
	     else go to RESULT_IS_TRUE;

	else if key = "noarg" then			/* check that no argument follows key */
	     if an = thenloc then
		go to RESULT_IS_TRUE;
	     else go to RESULT_IS_FALSE;

	else if key = "day" then do;			/* check the date: arg after key is day name or day of month */
	     if an = thenloc then go to RESULT_IS_FALSE;
	     call ssu_$arg_ptr (sci_ptr, an, ap, al);
	     call date_time_ (clock (), timestr);	/* read the clock */
	     if substr (argument, 1, 1) &gt; "A" then	/* alphabetic: check day of week */
		if substr (argument, 1, 3) = substr (timestr, 22, 3) then
		     go to RESULT_IS_TRUE;
		else go to RESULT_IS_FALSE;
	     else if argument = substr (timestr, 4, 2) then go to RESULT_IS_TRUE;
	     else go to RESULT_IS_FALSE;
	end;

	else if key = "argeq" then do;		/* check two arguments after key for equality */
	     if an = thenloc then go to RESULT_IS_TRUE;	/* ... neither given */
	     if an = (thenloc - 1) then go to RESULT_IS_FALSE;
						/* ... only one is given: can't be equal */
	     call ssu_$arg_ptr (sci_ptr, an, ap, al);
	     call ssu_$arg_ptr (sci_ptr, (an + 1), cp, cl);
	     if argument = second_argument then
		go to RESULT_IS_TRUE;
	     else go to RESULT_IS_FALSE;
	end;

	else if key = "ask" then do;			/* ask a question */
	     if an = thenloc then			/* ... question was already typed */
		call command_query_$yes_no (yes_no_sw, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "", "?");
	     else do;				/* ... pickup question after the key */
		call ssu_$arg_ptr (sci_ptr, an, ap, al);
		call command_query_$yes_no (yes_no_sw, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "", argument)
		     ;
	     end;
	     if yes_no_sw then
		go to RESULT_IS_TRUE;
	     else go to RESULT_IS_FALSE;
	end;

	else if key = "less" then do;			/* numerical checks */
NUMERICAL_COMPARISONS:
	     if an = thenloc then go to RESULT_IS_FALSE;	/* both arguments must be there */
	     if an = (thenloc - 1) then go to RESULT_IS_FALSE;
	     call ssu_$arg_ptr (sci_ptr, an, ap, al);
	     first_number = cv_dec_check_ (argument, ec);
	     if ec ^= 0 then
NON_NUMERIC_ARGUMENT:
		call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^a", argument);
	     call ssu_$arg_ptr (sci_ptr, (an + 1), ap, al);
	     second_number = cv_dec_check_ (argument, ec);
	     if ec ^= 0 then go to NON_NUMERIC_ARGUMENT;
	     if first_number &lt; second_number then
		if key = "less" then
		     go to RESULT_IS_TRUE;
		else go to RESULT_IS_FALSE;
	     else if first_number &gt; second_number then
		if key = "less" then
		     go to RESULT_IS_FALSE;
		else go to RESULT_IS_TRUE;
	     else go to RESULT_IS_FALSE;		/* no check for equality on numbers */
	end;

	else if (key = "greater") | (key = "grt") then go to NUMERICAL_COMPARISONS;

	else if key = "number" then do;		/* check that argument after key is a number */
	     if an = thenloc then go to RESULT_IS_FALSE;	/* ... not there */
	     call ssu_$arg_ptr (sci_ptr, an, ap, al);
	     first_number = cv_dec_check_ (argument, ec);
	     if ec = 0 then
		go to RESULT_IS_TRUE;
	     else go to RESULT_IS_FALSE;
	end;

	else call ssu_$abort_line (sci_ptr, 0, "Unknown keyword ""^a"".", key);


/* Result of the test was false */

RESULT_IS_FALSE:
	if notsw then go to RESULT_IS_REALLY_TRUE;	/* sense of test was reversed */

RESULT_IS_REALLY_FALSE:
	if elseloc = 0 then go to RETURN_FROM_IF;	/* no else clause */
	an = elseloc + 1;				/* find where else clause is */
	go to EXECUTE_OR_RETURN_STRING;


/* Result of the test was true */

RESULT_IS_TRUE:
	if notsw then go to RESULT_IS_REALLY_FALSE;	/* sense of the test was reversed */

RESULT_IS_REALLY_TRUE:
	an = thenloc + 1;				/* argument index of then clause (if present) */
	if an = elseloc then go to RETURN_FROM_IF;	/* a null then clause */


/* Execute/return the selected string */

EXECUTE_OR_RETURN_STRING:
	if an &gt; nargs then go to RETURN_FROM_IF;	/* clause is not present */

	call ssu_$arg_ptr (sci_ptr, an, ap, al);

	if active_function then			/* active function/request: return the string */
	     return_string = argument;
	else do;					/* command/request: execute it */
	     if al &gt; 0 then call ssu_$execute_line (sci_ptr, ap, al, ec);
	     if ^standalone_invocation &amp; (ec ^= 0) &amp; (ec ^= ssu_et_$null_request_line) then
		if ec = ssu_et_$subsystem_aborted then
		     call ssu_$abort_subsystem (sci_ptr);
		else call ssu_$abort_line (sci_ptr);
	end;


/* Clean up */

RETURN_FROM_IF:
	if standalone_invocation then			/* we created the invocation */
	     call ssu_$destroy_invocation (sci_ptr);

	return;



/* Internal procedure invoked by ssu_$abort_line when if was invoked as a Multics command/active function */

abort_if_command:
     procedure ();

	go to RETURN_FROM_IF;			/* message has been printed: now we can punt */

     end abort_if_command;

     end if;




		    index_set.pl1                   03/01/89  1410.1rew 03/01/89  1357.1      178722



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


	

/****^  HISTORY COMMENTS:
  1) change(89-01-16,TLNguyen), approve(89-01-27,MCR8053),
     audit(89-02-23,RBarstad), install(89-03-01,MR12.3-1018):
     1. Modify "Syntax" portion in comment lines stated at the beginning
        of the source program to provide more information for usage.
     
     2. Fix stringrange condition raised at the run time during testing
        period.
     
     3. Fix the bug occured when given L &lt;= U and -I.  For examples:
        index_set 1 1 -1; index_set -7 -5 -2
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* index_set active function &amp; command						*/
	/*									*/
	/* Function:  returns/prints one or more sets of numbers.  Numbers are separated from	*/
	/* one another by a space.  Each set contains numbers in the sequence:		*/
	/*									*/
	/*	L, L+I, L+2I, L+3I, ... L+kI						*/
	/*									*/
	/* where k is the largest integer such that  L+kI&lt;=U.  L, U, and I are integers (either	*/
	/* positive or negative) representing the lowest number of each set,  an upper bound	*/
	/* on set elements, and an increment between numbers of the set.			*/
	/*									*/
	/* Syntax:                                                                                */
          /*       case 1:	[index_set U]   is equivalent to   [index_set 1 U 1]		*/
          /*                                                                                        */
	/*       case 2:    [index_set L U]                                                       */
          /*                                  is equivalent to   [index_set L U 1]  if L &lt;= U       */
          /*                                  is equivalent to   [index_set L U -1] if L &gt; U        */
                
          /*                                                                                        */
          /*       case 3:    [index_set L U -I]                                                    */
          /*                                  is treated as      [index_set L U I]  if L &lt;= U       */
          /*                                                                                        */
          /*       case 4:    [index_set L U I]                                                     */
          /*                                  is treated as      [index_set L U -I]  if L &gt; U       */
          /*                                                                                        */
          /*       case 5:	[index_set L1 U1 I1 ... Ln Un In]				*/
	/*									*/
	/* Status:								*/
	/* 0) Recoded by  Gary Dixon,  June 1978.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* Fixed to handle "index_set 0 0" and reject increments of 0 - 07/07/81 S. Herbst */

index_set: procedure;				/* This active function returns a string of no.	*/

     dcl (Larg, Lret, Ls)		fixed bin(21),
         (Nargs, Ngroups)		fixed bin,
         (Parg, Parg_list,  Pret)	ptr,
	Scommand			bit(1) aligned,
	code			fixed bin(35),
         (conversion, size)		condition,
	err			entry options(variable) variable,
	get_arg			entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr) variable,
         (i, j, k)			fixed bin,
	Npic			pic "---------9";

     dcl	arg			char(Larg) based(Parg),
	ret			char(Lret) varying based(Pret);

     dcl (abs, addr, convert, divide, length, log10, ltrim, maxlength, mod, substr)
				builtin;

     dcl (active_fnc_err_,
	com_err_)			entry options(variable),
         (cu_$af_arg_ptr_rel,
	cu_$arg_ptr_rel)		entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$arg_list_ptr		entry returns(ptr),
	iox_$put_chars		entry (ptr, ptr, fixed bin(21), fixed bin(35));

     dcl (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) aligned int static options(constant),
	NL			char(1) aligned int static options(constant) init("
"),
         (error_table_$bad_conversion,
	error_table_$not_act_fnc,
	error_table_$out_of_bounds,
	error_table_$wrong_no_of_args)	fixed bin(35) ext static,
	iox_$user_output		ptr ext static;

	call cu_$af_return_arg (Nargs, Pret, Lret, code);	/* See if invoked as command of af. Get af ret.	*/
	if code = error_table_$not_act_fnc then  do;	/* Invoked as a command.			*/
	     err = com_err_;
	     get_arg = cu_$arg_ptr_rel;		/*   Report errors/get args accordingly.	*/
	     Scommand = TRUE;
	     Lret = 100000;				/*   Limit printed output to 100000 chars.	*/
	     end;					/*   per invocation of the command.		*/
	else if code = 0 then do;			/* Invoked as an active function.		*/
	     err = active_fnc_err_;
	     get_arg = cu_$af_arg_ptr_rel;
	     Scommand = FALSE;
	     end;
	else go to BAD_INVOKE;			/* Invoked without argument descriptors.	*/

	if Nargs = 0 then go to WNOA;			/* Must be called with 1, 2, or 3 args, or	*/
	else if Nargs &lt; 3 then;			/* with a multiple of three args.		*/
	else if mod(Nargs,3) ^= 0 then go to WNOA;

	if Nargs &lt; 3 then				/* When called with 3 or less args, output only	*/
	     Ngroups = 1;				/* one set of numbers.			*/
	else Ngroups = divide(Nargs,3,17,0);		/* Otherwise output one set or group per triplet	*/
	Parg_list = cu_$arg_list_ptr();		/* of input args.  Remember args before entering	*/
						/* begin block to get space for set boundaries.	*/

     begin;					/* Start of BEGIN BLOCK for group boundary store	*/

     dcl	1 group (Ngroups),				/* space for set boundaries.			*/
	  2 (lb, ub, incr)		fixed bin(34),	/*   lower bound, upper bound, increment.	*/
	vector (3 * Ngroups)	fixed bin(34) based(addr(group));

	on conversion, size go to BAD_BOUND;
	if Nargs = 1 then do;			/* If only 1 arg, fake a lower bound of 1.	*/
	     group(1).lb = 1;
	     group(1).incr = 1;
	     i = 2;				/*   1st arg is the upper bound.		*/
	     call get_arg (1, Parg, Larg, 0, Parg_list);	/*   get 1st arg and store it.		*/
	     group(1).ub = convert(group(1).ub, arg);
	     if abs(group(1).ub) &gt; 1000000000 then	/*   All lower/upper bounds &lt;= one billion.	*/
		go to BAD_BOUND;
	     end;
	else do;					/* More than 1 arg.  Process in triplets.	*/
	     if Nargs = 2 then			/* If only 2 args, fake third arg of 1 for incr.	*/
		group(1).incr = 1;
	     j = 0;				/* Initialize triplet counter.		*/
	     do i = 1 to Nargs;			/* 1st args of triplet is L; 2nd is U; 3rd is I.	*/
		call get_arg (i, Parg, Larg, 0, Parg_list);
	    	vector(i) = convert(vector(i), arg);
		if abs(vector(i)) &gt; 1000000000 then	/*   All lower/upper bounds &lt;= one billion.	*/
		     go to BAD_BOUND;
		j = j + 1;
		if j = 3 then  do;			/* Triplet complete?  */
		     if vector (i) = 0 then do;         /* increment value cannot be zero. */
			call err (error_table_$bad_conversion, "index_set",
			     "Increment cannot be zero (Argument ^d)", i);
			return;
		     end;
		     else if vector(i) &gt; 1000000 then	/*     Increments &lt;= one million.		*/
			go to BAD_BOUND;
		     else;                              /* otherwise, either negative or position increment value is ok */

		     j = 0;			/* reset triplet counter; prepare for next triple.*/
		     end;
		end;
	     end;
	revert conversion;

	Ls = 0;					/* Compute length of string needed to return all	*/
	do i = 1 to Ngroups;			/* sets of numbers.				*/
	     Ls = Ls + s_length(group(i));
	     end;
	if Ls &gt; Lret then do;			/* Complain if return string is too long.	*/
	     call err (error_table_$out_of_bounds, "index_set",
"Return string of ^d chars is longer than ^d.",
		Ls, Lret);
	     go to RETURN;
	     end;

	if ^Scommand then Ls = 0;                         /* If invoked as active function, use af return   */
                                                            /* arg to hold string; as command, allocate       */
                                                            /* storage via begin block (below) to hold string.*/
     
	

     begin;					/* Start of BEGIN BLOCK for result string storage.*/

     dcl	s char (Ls) varying;                              /* the returned integers are hold in an automatic character string */
	

	if Scommand then do;
	     Pret = addr (s);
	     Lret = maxlength (s);
	end;

	ret = "";

	do i = 1 to Ngroups;			/* For each set (group) of numbers to be returned,*/
	     if group(i).lb &lt;= group(i).ub then do;	/* if L &lt; = U and I is negative, then I is assumed to be positive */
		if group (i).incr &lt; 0 then
		     group (i).incr = abs (group (i).incr);
	     end;
	     else do;                                     /* if L &gt; U and I is positive, then I is assumed to be negative */
		if group (i).incr &gt; 0 then
		     group (i).incr = - (group (i).incr);
	     end;

	     do j = group(i).lb to group(i).ub by group(i).incr;
		Npic = j;				/*   compute group elements; store in result str.	*/

		if (i = 1) &amp; (j = group (i).lb) then    /* if this is the first time in both loops */
		     ret = ltrim (Npic);                /* then get the returned integer */
		else ret = ret || ltrim(Npic);          /* append the returned integer to the already string of returned integers */

		ret = ret || " ";                      /* each returned integer is separated by a white space */
		end;
	     end;
	if Scommand then do;			/* Print result string when invoked as a command  */
	     substr(ret, length (ret), 1) = NL;           /* add the Newline character in place of a white space at the end */

	     call iox_$put_chars (iox_$user_output, addr (substr (ret, 1)), length (ret), code);
	     end;
	else ret = substr (ret, 1, length (ret) - 1);     /* Return af result (except for extra space	*/
						/* at end of string).			*/


	end;					/* End of BEGIN BLOCK for result string storage.	*/

s_length: procedure (g) returns (fixed bin(21));		/* This internal proc computes APPROXIMATE length	*/
						/* of result string needed for 1 group (set) of	*/
						/* numbers.  The guess is always guaranteed to be	*/
						/* &gt;= the storage actually required.		*/

     dcl	1 g,
	  2 (l, u, i)		fixed bin(34),
         (lb, ub)			fixed bin(34),
         (i, j)			fixed bin,
	len			fixed bin(71);


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* A set of numbers is defined by a triplet (L U I) where L is lower bound, U is upper	*/
	/* bound, I is increment between numbers.					*/
	/*									*/
	/* s_length(L U I) can be found by the following procedure:				*/
	/* 1) Start out by assuming an increment of 1 (L U 1).				*/
	/* 2) Break apart (L U 1) into one or more intervals, each of whose L is 1, -1, or 0.	*/
	/*    For example,								*/
	/*	(1 10 1) ==&gt; stays unbroken						*/
	/*	(5 10 1) ==&gt; (1 10 1) - (1 4 1) (ie, {1 2 3 4 5 6 7 8 9 10} - {1 2 3 4}	*/
	/*	(-7 -1 1)==&gt; (-1 -7 1)						*/
	/*	(-4 5 1) ==&gt; (-1 -4 1) + (0 0 1) + (1 5 1)				*/
	/* 3) s_length(0 0 1) is 2.							*/
	/* 4) s_length(-|L| -|U| 1) = s_length(|L| |U| 1) + n_elements(|L| |U| 1)		*/
	/*    For example, s_length(-1 -7 1) = s_length(1 7 1) + 7, because a - sign precedes	*/
	/*    each element of (-1 -7 1).						*/
	/* 5) At this point, any s_length(L U 1) can be computed as sum or difference of some	*/
	/*    s_length(1 Ui 1).							*/
	/*									*/
	/* To compute s_length(1 U 1), do the following.					*/
	/* 6) Determine how many chars required to output U followed by a space.		*/
	/*   	n_chars(U) = log10(U)+2						*/
	/*    In all uses of log10(U) in this algorithm, we are interested only in the integer	*/
	/*    part of the value.  For example, log10(250) = 2 and 4 chars are req'd to output 250.*/
	/*    These are the longest numbers of the set.					*/
	/* 7) Determine how many of these longest numbers there are.			*/
	/*	n_longest(U) = U - (10**log10(U) - 1)					*/
	/*    For example, n_longest(110) = 110 - (10**log10(110) - 1)			*/
	/*			    = 110 - (10**2 - 1) = 110 - 99 = 11			*/
	/*    The table subtrahend(0:8) contains the values of (10**log10(U) - 1) for values of	*/
	/*    log10(U) from 0 to 8.							*/
	/* 8) From (6) and (7) we have:						*/
	/*	s_length( 10**log10(U)  U  1) = n_chars(U) * n_longest(U)			*/
	/*    For example, s_length(100 110 1) = n_chars(110)    *  n_longest(110)		*/
	/*			         = (log10(110)+2)  *  (110 - 99)		*/
	/*			         =       4         *      11        = 44		*/
	/* 9) Since  s_length(1 U 1)  =  s_length(1  10**log10(U)-1  1)  +  			*/
	/*			   s_length(10**log10(U)  U  1)			*/
	/*    we can compute s_length(1 U 1) from (8) above and s_length(1  10**log10(U)-1  1).	*/
	/*    s_length(1  10**log10(U)-1   1)  is stored in the addend(0:8) table below for 	*/
	/*    values of log10(U) from 0 to 8.  Values of s_length(-1  -(10**log10(U)-1)  1)  are	*/
	/*    stored in neg_addend(0:8) below.						*/

	/* Thus, we have from the above:						*/
	/*	s_length(1 U 1) = s_length(10**log10(U) U 1) + s_length(1 10**log10(U)-1 1)	*/
	/*		      = n_chars(U) * n_longest(U)  + addend(log10(U))		*/
	/*		      = log10(U)+2 * (U - subtrahend(log10(U))) + addend(log10(U))	*/
	/* and    s_length(-1 -|U| 1) =						*/
	/*		      = log10(|U|)+3 * (|U| - subtrahend(log10(|U|))) +		*/
	/*		        neg_addend(log10(|U|))				*/
	/*									*/
	/* At this point, we can compute s_length(L U 1) for any integer L and U.		*/
	/* The value computed by the above formula is exact!  We provide the following 		*/
	/* approximation for handling integer increments &gt; 1.				*/
	/* s_length(1 U I) =							*/
	/*					log10(U)				*/
	/*					________				*/
	/*					\				*/
	/*					 \				*/
	/*		   s_length(1 U 1)		  \				*/
	/*		   ---------------	+	   &gt;	(k+2)			*/
	/*			I		  /				*/
	/*					 /				*/
	/*					/________				*/
	/*					  k = 0				*/
	/* The rational is that only every Ith number of the set will be output, so the		*/
	/* result string need be only 1/I as long, approximately.  The approximation comes from	*/
	/* the fact that I probably does not evenly divide the number of elements of any given	*/
	/* length in the set of numbers.  To compensate, we add room for one number of each length*/
	/* to the result string (the summation does this).  If for shorthand we write the	*/
	/* summation above as sum(k+2, k=0 to log10(U)), then we have			*/
	/* s_length(-1 -|U| |I|) = s_length(-1 -|U| 1) / I   +   sum(k+3, k = 0 to log10(|U|))	*/
	/*									*/
	/* By the rules of algebra, we have						*/
	/*	sum(k+2, k = 0 to log10(U))  =  sum(k, k = 0 to log10(U)) + 2*(log10(U)+1)	*/
	/*			         =  (log10(U)*(log10(U)+1)) / 2  +  2*(log10(U)+1)	*/
	/* This result is used in the equations below.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


     dcl	addend (0:8)		fixed bin(71) int static options(constant) init(
					    0,
					   18,
					  288,
					 3888,
					48888,
				         588888,
				        6888888,
				       78888888,
				      888888888),
	neg_addend (0:8)		fixed bin(71) int static options(constant) init(
					    0,
					   27,
					  387,
					 4887,
					58887,
				         688887,
				        7888887,
				       88888887,
				      988888887),
	subtrahend (0:8)		fixed bin(71) int static options(constant) init(
					    0,
				   	    9,
					   99,
					  999,
					 9999,
					99999,
				         999999,
				        9999999,
				       99999999);

	if g.l &gt; g.u then do;			/* Treat (12 5 1) as (5 12 1), etc.		*/
	     lb = g.u;				/*   Swap upper and lower bounds.		*/
	     ub = g.l;
	     end;
	else do;					/* Copy upper and lower bounds without swap.	*/
	     lb = g.l;
	     ub = g.u;
	     end;
	if (lb&gt;=0) &amp; (ub&gt;=0) then do;			/* All numbers in set are nonnegative.		*/
	     if ub = 0 then i = 0;
	     else i = log10(ub);			/*   This number is used everywhere.		*/

	     len = addend(i) + (i+2)*(ub-subtrahend(i));	/*   compute s_length(1 U 1).			*/

	     if lb = 1 then;
	     else if lb = 0 then			/*   add 2 to handle "0 " if present.		*/
		len = len + 2;
	     else do;				/*   s_length(L U 1) = s_length(1 U 1) -	*/
		lb = lb - 1;			/*	s_length(1 L-1 1)			*/
		if lb = 0 then j = 0;
		else j = log10(lb);

		len = len - (addend(j) + (j+2)*(lb-subtrahend(j)));
		end;

	     if g.i ^= 1 then			/*   s_length(L U I) = s_length(L U 1)/I +	*/
						/*	sum(k+2, k = 0 to i)		*/
		len = divide (len, abs (g.i), 35, 0) + divide (i * (i + 1), 2, 35, 0) + 2 * (i + 1);
	     end;
	else if (lb&lt;=0) &amp; (ub&lt;=0) then do;		/* All numbers of set are nonpositive.		*/
	     k  = lb;				/*   Treat (-5 -2 1) as (2 5 1) from counting	*/
	     lb = -ub;				/*     standpoint.				*/
	     ub = -k;
	     if ub = 0 then i = 0;
	     else i = log10(ub);			/*   Compute s_length(1 |U| 1)		*/

	     len = neg_addend(i) + (i+3)*(ub-subtrahend(i));

	     if lb = 1 then;
	     else if lb = 0 then			/*   add 2 to handle "0 " if present.		*/
		len = len + 2;
	     else do;				/*   s_length(|L| |U| 1) = s_length(1 |U| 1) -	*/
		lb = lb - 1;			/*	s_length(1 |L|-1 1)			*/
		if lb = 0 then j = 0;
		else j = log10(lb);

		len = len - (neg_addend(j) + (j+3)*(lb-subtrahend(j)));
		end;

	     if g.i ^= 1 then			/*   s_length(L U I) = s_length(L U 1)/I +	*/
						/* 	sum(k+3, k = 0 to i)		*/
		len = divide (len, abs (g.i), 35, 0) + divide (i * (i + 1), 2, 35, 0) + 3 * (i + 1);
	     end;
	else do;					/* Sets contains both positive and negative numbers*/
						/* so use a combination of 2 cases above.	*/
	     lb = -lb;				/* lb &lt; 0; invert its sign.			*/
	     if lb = 0 then i = 0;
	     else i = log10(lb);

	     len = neg_addend(i) + (i+3)*(lb-subtrahend(i));
	     len = len + 2;				/* Account for the 0 between neg. lower bound	*/
						/* and pos. upper bound.			*/

	     if ub = 0 then j = 0;
	     else j = log10(ub);

	     len = len + (addend(j) + (j+2)*(ub-subtrahend(j)));

	     if g.i ^= 1 then
		len = divide (len, abs (g.i), 35, 0) + divide ((i + j) * (i + j + 1), 2, 35, 0) + 3 * (i + 1) + 2 * (j + 1);
	     end;

	if len &gt; Lret then do;			/* If return string too long, report it now when	*/
	     call err (error_table_$out_of_bounds, "index_set", "
String needed to return numbers from ^d to ^d is too long.", g.l, g.u);
	     go to RETURN;				/* we know which set is too big.		*/
	     end;					/* Check for sum of all sets is done by caller.	*/

	return (len);

	end s_length;


     end;						/* End of BEGIN BLOCK for group boundary store.	*/


RETURN:	return;

WNOA:	call err (error_table_$wrong_no_of_args, "index_set",
"^/Usage:	^[^;[^]index_set  first1 bound1 increment1 ... firstN boundN incrementN^[^;]^]
or:	^[^;[^]index_set  first  bound^[^;]^]
or:	^[^;[^]index_set  bound^[^;]^]", Scommand, Scommand, Scommand, Scommand, Scommand, Scommand);

	return;

BAD_BOUND:
	call err (error_table_$bad_conversion, "index_set", " ^a is an invalid ^[increment^;first number^;bound^].
Argument must satisfy the condition:
  ^[-1000000^;-1000000000^;-1000000000^] &lt;= ^[increment^;first number^;bound^] &lt;= ^[1000000^;1000000000^;1000000000^]",
 	     arg, mod(i,3)+1, mod(i,3)+1, mod(i,3)+1, mod(i,3)+1);

	return;

BAD_INVOKE:
	call active_fnc_err_ (code,  "index_set");

	return;

     end index_set;
��



		    login_args.pl1                  11/04/82  2003.4rew 11/04/82  1610.0       73404



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


/* format: style4 */

/* Written  81-12-03 E. N. Kittlitz. */
/* Modified 82-06-04 E. N. Kittlitz. make [login_args -ct] return "0", not "". */

login_arg:
login_args:
     proc;


/* command/active-function to return login arguments, specified either
   to enter_abs_request (absentee processes) or to the login request (daemon
   or interactive processes) using the -arguments control argument.

   Syntax: login_arg {argument_number} {-control_args}

   where:

   argument_number
   may be a postive non-zero decimal number,
   the number of the argument whose value is required.

   CONTROL ARGUMENTS:

   -count, -ct
   count of login arguments supplied to login request or enter_abs_request.

   -from argument_number, -fm argument_number
   number of first argument to return.  All succeeding defined arguments
   are also returned.  (one per line if this is a command invocation,
   or separated by a space for active function use.)

   -no_requote
   prevents the requoting of each argument.

   -quote
   causes each quote in the argument to be doubled.  The same as -requote
   except that the string is not enclosed in quotation marks.

   -requote
   causes each argument to be requoted. This is the default.
*/

dcl  ME char (10) init ("login_args") static options (constant);
dcl  NO_REQUOTE fixed bin init (0) static options (constant);

dcl  FORMAT char (14) int static options (constant) init ("^[^d) ^;^s^]^a");
dcl  QUOTE fixed bin init (1) static options (constant);
dcl  REQUOTE fixed bin init (2) static options (constant);

dcl  argn fixed bin;				/* current command argument number */
dcl  argp ptr;					/* ptr to command argument */
dcl  argument_number fixed bin (35);			/* which argument the user wants */
dcl  count_sw bit (1) aligned;			/* true if -count specified */
dcl  from_sw bit (1) aligned;				/* true if -from specified */
dcl  i fixed bin;
dcl  quote_option fixed bin;

dcl  (null, substr, ltrim, char) builtin;

dcl  error_proc entry options (variable) variable;	/* procedure called to indicate an error */
dcl  arg_proc entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable;
						/* procedure called to obtain a command argument */
dcl  argc fixed bin;				/* number of command arguments */
dcl  arg char (argl) based (argp);			/* command argument */
dcl  argl fixed bin (21);				/* length of command argument */
dcl  lg_argp ptr;					/* ptr to login argument */
dcl  lg_argc fixed bin;				/* number of login arguments */
dcl  lg_arg char (lg_argl) based (lg_argp);		/* login argument */
dcl  lg_argl fixed bin (21);				/* length of login argument */
dcl  af_sw bit (1) aligned;				/* "1"b if invoked as active function */
dcl  af_argp ptr;					/* pointer to af return argument */
dcl  af_argl fixed bin (21);				/* max length of af return argument */
dcl  af_arg char (af_argl) based (af_argp) varying;	/* af return argument */
dcl  code fixed bin (35);

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  requote_string_$quote_string entry (char (*)) returns (char (*));
dcl  user_info_$login_arg_count entry (fixed bin, fixed bin (21), fixed bin (21));
dcl  user_info_$login_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));

dcl  error_table_$not_act_fnc fixed bin (35) ext static;
dcl  error_table_$badopt fixed bin (35) ext static;
dcl  error_table_$inconsistent fixed bin (35) ext static;

%page;
	call cu_$af_return_arg (argc, af_argp, af_argl, code);
	if code = 0 then do;
	     arg_proc = cu_$af_arg_ptr;
	     error_proc = active_fnc_err_;
	     af_sw = "1"b;
	     af_arg = "";				/* initialize output string */
	end;
	else do;
	     error_proc = com_err_;
	     arg_proc = cu_$arg_ptr;
	     af_sw = "0"b;
	     af_argp = null;
	     af_argl = 0;
	     if code ^= error_table_$not_act_fnc then go to no_info_error;
	end;

	argument_number = -1;			/* defaults for any case */
	from_sw = "0"b;				/* not explicit or implicit -from */
	quote_option = REQUOTE;			/* default quoting */
	count_sw = "0"b;				/* -count not specified */

process_arguments:
	do argn = 1 to argc;			/* one by one */
	     call arg_proc (argn, argp, argl, code);
	     if code ^= 0 then go to no_info_error;	/* couldn't get that argument */
	     if arg = "-count" | arg = "-ct" then do;
		if argc ^= 1 then do;
		     call error_proc (error_table_$inconsistent, ME,
			"-count may not be specified with any other control argument.");
		     return;
		end;
		count_sw = "1"b;
	     end;
	     else if arg = "-from" | arg = "-fm" then do;
		from_sw = "1"b;
		argn = argn + 1;
		call arg_proc (argn, argp, argl, code);
		if code ^= 0 then do;
		     call error_proc (code, ME, "argument_number expected following -from.");
		     return;
		end;
try_for_argument_number:
		if argument_number &gt; 0 then do;
		     call error_proc (0, ME, "argument_number specified more than once.");
		     return;
		end;
		argument_number = cv_dec_check_ (arg, code);
		if code ^= 0 | argument_number &lt; 1 then do;
		     call error_proc (0, ME, "^a must be an integer number greater than zero.", arg);
		     return;
		end;
	     end;
	     else if arg = "-no_requote" then quote_option = NO_REQUOTE;
	     else if arg = "-quote" then quote_option = QUOTE;
	     else if arg = "-requote" then quote_option = REQUOTE;
	     else if substr (arg, 1, 1) = "-" then do;
		call error_proc (error_table_$badopt, ME, "^a", arg);
		return;
	     end;
	     else go to try_for_argument_number;
	end process_arguments;

	call user_info_$login_arg_count (lg_argc, (0), (0)); /* first, get number of login arguments */

	if lg_argc = 0 then do;
	     if ^af_sw then
		call error_proc (0, ME, "There are no login arguments.");
	     else if count_sw then
		af_arg = "0";			/* -count: return a number */
	     return;
	end;

	if count_sw then do;			/* only want the count? */
	     if af_sw then
		af_arg = ltrim (char (lg_argc));
	     else call ioa_ (ltrim (char (lg_argc)));
	     return;
	end;

	if argument_number &lt; 0 then do;
	     argument_number = 1;			/* use default if we must */
	     from_sw = "1"b;
	end;

	if argument_number &gt; lg_argc then do;		/* we don't go as high as user asked */
	     if ^af_sw then
		call error_proc (0, ME,
		     "argument_number ^d exceeds the number of login arguments (^d).",
		     argument_number, lg_argc);
	     return;
	end;

make_result:
	do i = argument_number to lg_argc while (from_sw | i = argument_number);
	     call user_info_$login_arg_ptr (i, lg_argp, lg_argl, code);
	     if code ^= 0 then do;
		call error_proc (code, ME, "While obtaining login argument ^d.", i);
		return;
	     end;
	     if af_sw then
		if i &gt; argument_number then af_arg = af_arg || " ";
	     if quote_option = REQUOTE then
		if af_sw then
		     af_arg = af_arg || requote_string_ (lg_arg);
		else call ioa_ (FORMAT, from_sw, i, requote_string_ (lg_arg));
	     else if quote_option = QUOTE then
		if af_sw then
		     af_arg = af_arg || requote_string_$quote_string (lg_arg);
		else call ioa_ (FORMAT, from_sw, i, requote_string_$quote_string (lg_arg));
	     else if af_sw then
		af_arg = af_arg || lg_arg;
	     else call ioa_ (FORMAT, from_sw, i, lg_arg);
	end make_result;

	return;


no_info_error:
	call error_proc (code, ME);
	return;

     end login_args;




		    picture.pl1                     10/22/86  1528.3rew 10/22/86  1526.3       91386



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





/****^  HISTORY COMMENTS:
  1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7560),
     audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1195):
     Correct an usage message.
                                                   END HISTORY COMMENTS */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/* Created: Mar 78	J Falksen					       */
/* Updated: Aug 78  J Falksen					       */
/*   added conversion handler					       */
/*   fixed error message					       */
/*   added valid_pictured_data entry				       */
/*   removed quotes from command output				       */
/*   made command use NL separator when multiple output values	       */
/* Updated: Aug 80  J Falksen					       */
/*   cleanup for installation and format_pl1			       */
/* Updated: Oct. 86 Tai L. Nguyen                                            */
/*   corrected an usage message                                              */

/* Syntax:  pic pic_string values {-control_arg}			       */
/*							       */
/* Function: returns one or more values processed through a specified	       */
/* PL/I picture.						       */
/*							       */
/* Arguments:						       */
/* pic_string						       */
/*    is a valid PL/I picture as defined in the PL/I Reference Manual and    */
/*    the PL/I Language Specification.				       */
/* values							       */
/*    are strings having data appropriate for editing into the picture.      */
/*    Each value must be convertible to the type implied by the picture      */
/*    specified.  If multiple values are presented, the results are	       */
/*    separated by single spaces.  Any resulting value that contains a       */
/*    space is quoted.					       */
/*							       */
/* Control argument:					       */
/* -strip							       */
/*    removes leading spaces from edited picture values; removes trailing    */
/*    zeros following a decimal point; removes a decimal point if it would   */
/*    have been the last character of a returned value.		       */
/*							       */
/*							       */
/* Syntax as active function:  [pic pic_string values {-control_arg}]	       */

/* Syntax:  [vpd pic_string values]				       */
/*							       */
/* Function: Returns "true" if all values can be formatted via pic_string.   */
/* Otherwise returns "false".					       */
/*							       */
/*							       */
/* Arguments:						       */
/* pic_string						       */
/*    is a valid PL/I picture.				       */
/* value							       */
/*    is a string to be edited into the picture.			       */
/*							       */
/*							       */
/* Notes:  For more information on PL/I picture and picture strings, see     */
/* the PL/I Reference Manual, Order No.  AM83 or the PL/I Language	       */
/* Specification, Order No. AG94.				       */

pic: picture: proc;			/* edit a value into a picture       */

      testing = "0"b;
      me = "picture";
      goto start;

valid_pictured_data: vpd: entry;	/* see if value will edit into pic   */

      testing = "1"b;
      me = "valid_pictured_data";
      goto start;

start:
      strip_sw = "0"b;		/* dont strip leading/trailing       */
      call cu_$af_arg_count (argct, code);
      if (code ^= 0)		/* called as command?	       */
      then do;			/* ...YES			       */
         retval_p = null ();		/* no return string		       */
         error = com_err_;		/* set error message routine	       */
         arg_ptr = cu_$arg_ptr;
      end;
      else do;			/* ...NO			       */
         call cu_$af_return_arg (argct, retval_p, retval_l, code);
				/* get return string	       */
         retval = "";
         error = active_fnc_err_;	/* set error message routine	       */
         arg_ptr = cu_$af_arg_ptr;
      end;
      if (argct &lt; 2)
      then do;			/* tsk, tsk		       */
         if (me = "picture")
         then call error (error_table_$noarg, me,
	       "Usage:^-pic pic_str {-strip} value ...");
         else call error (error_table_$noarg, me,
	       "Usage:^-vpd pic_str value ...");
         return;
      end;
      call arg_ptr (1, argp, argl, code); /* get the picture string	       */
      if (argl = 0)			/* he wants the default	       */
      then do;
         the_picture = default;
         picp = addr (default);
         picl = length (default);	/* which include NO extraneous       */
         strip_sw = "1"b;		/*  spaces or blanks	       */
dcl default	char (13) int static options (constant)
		init ("(15)-9v.(15)9");
      end;
      else do;			/* use his picture  (SMILE!)	       */
         the_picture = arg;
         picp = argp;
         picl = argl;
      end;

      call picture_info_ ((picv), addr (buff), code);
				/* let PL/I routine process it       */
      if (code ^= 0)		/* Oh,			       */
      then do;			/* ...you didnt like that one!       */
         call error (0, me,
	  "^[Normalized picture &gt; 64 char" ||
	  "^;Scale factor not in range -128:+127" ||
	  "^;Syntax error^]. ^a",
	  sign (code - 434) + 2,	/* That's right, they return a FUNNY */
	  the_picture);		/*  code!			       */
         return;
      end;
      do argno = 2 to argct while (^strip_sw);
         call arg_ptr (argno, argp, argl, code);
         if (arg = "-strip")
         then strip_sw = "1"b;
      end;

      on condition (conversion)	/* just in case he blows it	       */
         begin;
	  Cond = "Conversion";
	  goto err_exit;
         end;
      on condition (size)		/* just in case he blows it	       */
         begin;
	  Cond = "Size";
	  goto err_exit;
         end;
      do argno = 2 to argct;
         call arg_ptr (argno, argp, argl, code);
         if (arg ^= "-strip")
         then do;

/* let somebody do it who UNDERSTANDS all these things		       */
	  temp_length = addr (buff) -&gt; picture_image.prec
	     + 262144 * (addr (buff) -&gt; picture_image.scale
	     - addr (buff) -&gt; picture_image.scalefactor);

	  call assign_ (addr (temp),
	     map_type (addr (buff) -&gt; picture_image.type),
	     temp_length, argp, 42, (argl));
	  call pack_picture_ (addr (target) -&gt; bit1, buff, temp);

	  if ^testing		/* not valid_pictured_data	       */
	  then do;
	     pictured
	        = substr (target, 1, addr (buff) -&gt; picture_image.varlength);
	     if strip_sw		/* should we dump the extras?	       */
	     then do;
	        pictured = ltrim (pictured);
	        if (index (pictured, ".") ^= 0)
	        then do;
		 pictured = rtrim (pictured, "0");
		 if (substr (pictured, length (pictured), 1) = ".")
		 then pictured
		         = substr (pictured, 1, length (pictured) - 1);
	        end;
	     end;
	     if (retval_p = null ())
	     then call ioa_ ("^a", pictured);
	     else do;
	        j = index (pictured, " ");
	        if (length (retval) &gt; 0)
	        then retval = retval || " ";
	        if (j &gt; 0)
	        then retval = retval || """";
	        retval = retval || pictured;
	        if (j &gt; 0)
	        then retval = retval || """";
	     end;
	  end;
         end;
      end;
      if testing
      then do;
         if (retval_p = null ())	/* command?		       */
         then call ioa_ ("true");	/* yes. print it		       */
         else retval = "true";	/* no. return it		       */
      end;

      return;

err_exit:
      if testing
      then do;
         if (retval_p = null ())	/* command?		       */
         then call ioa_ ("false");	/* yes. print it		       */
         else retval = "false";	/* no. return it		       */
      end;
      else call error (0, me,
	    "^a condition occurred while editing ""^a"" thru ""^a""",
	    Cond, arg, the_picture);
      return;

dcl active_fnc_err_ entry options (variable);
dcl arg		char (argl) based (argp);
dcl argct		fixed bin;
dcl argl		fixed bin (21);
dcl argno		fixed bin;
dcl argp		ptr;
dcl assign_	entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin,
		fixed bin (35));
dcl bit1		bit (1) unaligned based;
dcl buff		(20) fixed binary;
dcl code		fixed bin (35);
dcl Cond		char (12);
dcl com_err_	entry options (variable);
dcl conversion	condition;
dcl cu_$af_arg_count entry (fixed bin, fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35))
		automatic;
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl error		entry options (variable) automatic;
dcl error_table_$noarg fixed bin (35) ext static;
dcl ioa_		entry options (variable);
dcl j		fixed bin;
dcl me		char (32);
dcl pack_picture_	options (variable);
dcl picl		fixed bin;
dcl picp		ptr;
dcl picture_info_	entry (char (*) aligned, ptr, fixed bin (35));
dcl pictured	char (256) var;
dcl picv		char (picl) based (picp);
dcl retval	char (retval_l) var based (retval_p);
dcl retval_l	fixed bin (21);
dcl retval_p	ptr;
dcl size		condition;
dcl strip_sw	bit (1);
dcl target	char (128);
dcl temp		(128) char (1) unaligned;
dcl temp_length	fixed bin (35);
dcl testing	bit (1);
dcl the_picture	char (100) var;

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

%include picture_image;
dcl map_type	(24:28) fixed bin int static init (
		42,		/* character		       */
		18,		/* real fixed dec		       */
		22,		/* cplx fixed dec		       */
		20,		/* real float dec		       */
		24);		/* cplx float dec		       */
   end picture;
��



		    query.pl1                       01/12/88  1314.5rew 01/12/88  1245.0      122742



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


query: procedure options (variable);


/*
   Record of Change:

   Created by Gary C. Dixon  on November 23, 1972
   Control arguments -non_null and -accept added by Txom McGary April 1977.
   Modified 6/81 by M.R. Jordan to add control arguments.
   Modified 9/81 by M.R. Jordan to get the defaults for question and answer IOCB pointers right.
   Modified 06/14/84 by S. Herbst to always write on specified IOCB, never on error_output.
   
   Name:  query

   An active function which asks the user a yes-or-no question.  If the user
   answers "yes", then query returns "true".  If the user answers "no", query
   returns "false".

   Usage

   [query question-text {-control_args}]

   1) question-text (Input)

   is a character string which forms the text of the question which the
   user is asked.

   2) control_arg (Input)

   is one of the following:

   -brief, -bf

   supresses the newline before and spaces after the question.

   -disable_cp_escape, -dcpe

   disables the command processor escape sequence .. as a response.

   -enable_cp_escape, -ecpe

   enables the command processor escape sequence .. as a response.

   -input_switch STR, -isw STR

   specifies the I/O switch over which input is to be requested.

   -long, -lg

   adds leading newline and 3 spaces to question to be asked.

   -output_switch STR, -osw STR

   specifies the I/O switch over which the question is to be output.

   -repeat DT, -rp DT

   repeats teh question every DT is the user does not answer.
   
   Name:  response

   An active function which asks any question of the user, and returns the
   user's response as the value of the active function.

   Usage

   [response question-text {-control_args}]

   1) question-text (Input) is as above.

   2) control_arg may be one of the control arguments listed above for query
   or one of the following:

   -non_null

   specifies that a null response is not allowed.

   -accept STR1 ... STRn

   specifies allowable responses.


   Example

   Assume that the user's start_up.ec contained the following lines:

   &amp;command_line off
   &amp;print Beginning start_up.
   abbrev
   &amp;if [query "start_up:  Do you wish to continue?"] &amp;then &amp;else &amp;quit
   mail
   check_info_segs
   .
   .

   Then the following dialogue would cause the start_up.ec to terminate
   execution after the query:

   Beginning start_up.
   start_up.ec:  Do you wish to continue?   !no
   r 1722  25.797  402+625

*/


/****^  HISTORY COMMENTS:
  1) change(87-12-17,Gilcrease), approve(88-01-06,MCR7827),
     audit(88-01-08,Parisek), install(88-01-12,MR12.2-1012):
               Add the -trim, -no_trim control arguments.
                                                   END HISTORY COMMENTS */


/*		CONSTANTS			*/

dcl  NAME (2) char (8) static options (constant) init ("query", "response");
dcl  QUERY fixed bin static options (constant) init (1);
dcl  RESPONSE fixed bin static options (constant) init (2);

/*		AUTOMATIC			*/

dcl  accept_null bit (1);
dcl  arg_len fixed bin;
dcl  arg_list_ptr ptr;
dcl  arg_ptr ptr;
dcl  argn fixed bin;
dcl  called_as_active_function bit (1);
dcl  code fixed bin (35);
dcl  entry_point fixed bin;
dcl  error entry options (variable) variable;
dcl  error_has_occured bit (1);
dcl  first_acceptable_arg fixed bin;
dcl  get_arg entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr) variable;
dcl  max_length fixed bin;
dcl  nargs fixed bin;
dcl  no_trim bit (1);
dcl  print_iocbp ptr;
dcl  question_len fixed bin;
dcl  question_ptr ptr;
dcl  rtn_string_ptr ptr;
dcl  temp_string char (512) varying;

dcl 1 my_query_info like query_info;

/*		BASED			*/

dcl  answer char (max_length) varying based (rtn_string_ptr);
dcl  arg char (arg_len) based (arg_ptr);
dcl  question char (question_len) based (question_ptr);

dcl 1 open_descrip aligned based,
    2 length fixed bin (17),
    2 string char (0 refer (open_descrip.length));

/*		ERROR CODES		*/

dcl  error_table_$bad_arg fixed bin (35) static ext;
dcl  error_table_$badopt fixed bin (35) static ext;
dcl  error_table_$noarg fixed bin (35) static ext;
dcl  error_table_$not_act_fnc fixed bin (35) static ext;
dcl  error_table_$not_open fixed bin (35) static ext;

/*		EXTERNAL ENTRIES		*/

dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  cu_$af_arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_switch ext entry options (variable);
dcl  iox_$look_iocb entry (char (*), ptr, fixed bin (35));
dcl  iox_$user_io ptr ext;

/*		BUILTIN FUNCTIONS		*/

dcl  addr builtin;
dcl  clock builtin;
dcl  divide builtin;
dcl  maxlength builtin;
dcl  null builtin;
dcl  substr builtin;

%include iocb;

%include query_info;

	entry_point = QUERY;
	go to COMMON;


response:	entry options (variable);

	entry_point = RESPONSE;


COMMON:

	call cu_$af_arg_count (nargs, code);
	if code = error_table_$not_act_fnc
	then do;
	     called_as_active_function = "0"b;
	     rtn_string_ptr = addr (temp_string);
	     max_length = maxlength (temp_string);
	     get_arg = cu_$arg_ptr_rel;
	     error = com_err_;
	end;
	else if code = 0
	then do;
	     called_as_active_function = "1"b;
	     call cu_$af_return_arg (nargs, rtn_string_ptr, max_length, code);
	     if code ^= 0
	     then do;
		call active_fnc_err_ (code, (NAME (entry_point)));
		return;
	     end;
	     get_arg = cu_$af_arg_ptr_rel;
	     error = active_fnc_err_;
	end;
	else do;
	     error = active_fnc_err_;


USAGE:

	     call error (code, (NAME (entry_point)),
		"^/Usage: ^[[^]^a question {-control_args}^[]^]",
		called_as_active_function, (NAME (entry_point)),
		called_as_active_function);
	     return;
	end;
	if nargs &lt; 1
	then do;
	     code = error_table_$noarg;
	     goto USAGE;
	end;


	call cu_$arg_list_ptr (arg_list_ptr);


	call get_arg (1, question_ptr, question_len, code, arg_list_ptr);
	if code ^= 0
	then do;
	     call error (code, (NAME (entry_point)),
		"Referencing first argument.");
	     return;
	end;

	accept_null = "1"b;
	answer = "";
	error_has_occured = "0"b;
	first_acceptable_arg = 0;
	no_trim = "0"b;


	my_query_info.version = query_info_version_5;
	my_query_info.switches.yes_or_no_sw = (entry_point = QUERY);
	my_query_info.switches.suppress_name_sw = "1"b;
	my_query_info.switches.cp_escape_control = "00"b;
	my_query_info.switches.suppress_spacing = "0"b;
	my_query_info.switches.padding = ""b;
	my_query_info.status_code = 0;
	my_query_info.query_code = 0;
	my_query_info.question_iocbp = null ();
	my_query_info.answer_iocbp = null ();
	my_query_info.repeat_time = 0;
	my_query_info.explanation_ptr = null ();
	my_query_info.explanation_len = 0;


	call Process_Control_Args (2);
	if error_has_occured
	then return;

	print_iocbp = my_query_info.question_iocbp;
	if print_iocbp = null then print_iocbp = iox_$user_io;


ASK:

	if no_trim then call command_query_ (addr (my_query_info), answer, (NAME (entry_point)),
	     "^va", question_len, question);
	else call command_query_ (addr (my_query_info), answer, (NAME (entry_point)),
	     "^a", question);
	goto PROCESS (entry_point);


PROCESS (1):					/* QUERY */

	if answer = "yes"
	then answer = "true";
	else answer = "false";


EXIT:

	if ^called_as_active_function
	then call ioa_ ("^a", answer);
	return;


PROCESS (2):					/* RESPONSE */

	if ^accept_null &amp; answer = ""
	then do;
	     call ioa_$ioa_switch (print_iocbp,
		"^a:  Null response not allowed, please retype.",
		(NAME (entry_point)));
	     goto ASK;
	end;

	if first_acceptable_arg = 0
	then goto EXIT;

	do argn = first_acceptable_arg to nargs by 1;
	     call Get_Arg (argn, "");
	     if answer = arg
	     then goto EXIT;
	end;
	call ioa_$ioa_switch (print_iocbp,
	     "^a:  '^a' is not an acceptable answer.^/Acceptable answers are:",
	     (NAME (entry_point)), answer);
	do argn = first_acceptable_arg to nargs;
	     call Get_Arg (argn, "");
	     call ioa_$ioa_switch (print_iocbp, "^-'^a'", arg);
	end;
	goto ASK;

Process_Control_Args: procedure (first_argn);


dcl  first_argn fixed bin;
dcl  argn fixed bin;


	     do argn = first_argn repeat argn+1 while (argn &lt;= nargs);

		call Get_Arg (argn, "");

		if arg = "-accept" &amp; entry_point = RESPONSE
		then do;
		     first_acceptable_arg = argn+1;
		     if first_acceptable_arg &gt; nargs
		     then do;
			call error (error_table_$noarg, (NAME (entry_point)),
			     "Missing argument(s) following -accept.");
			error_has_occured = "1"b;
		     end;
		     argn = nargs;
		end;

		else if arg = "-brief" | arg = "-bf"
		then my_query_info.switches.suppress_spacing = "1"b;

		else if arg = "-no_trim" then no_trim = "1"b;

		else if arg = "-trim" then no_trim = "0"b;

		else if arg = "-disable_cp_escape" | arg = "-dcpe"
		then my_query_info.switches.cp_escape_control = "10"b;

		else if arg = "-enable_cp_escape" | arg = "-ecpe"
		then my_query_info.switches.cp_escape_control = "11"b;

		else if arg = "-input_switch" | arg = "-isw"
		then do;
		     call Get_Arg (argn+1,
			"Missing I/O switch name following " || arg);
		     if addr (arg) ^= null ()
		     then my_query_info.answer_iocbp = IOCBp (arg, "1"b);
		     argn = argn+1;
		end;

		else if arg = "-long" | arg = "-lg"
		then my_query_info.switches.suppress_spacing = "0"b;

		else if arg = "-non_null" &amp; entry_point = RESPONSE
		then accept_null = "0"b;

		else if arg = "-output_switch" | arg = "-osw"
		then do;
		     call Get_Arg (argn+1,
			"Missing I/O switch name following " || arg);
		     if addr (arg) ^= null ()
		     then my_query_info.question_iocbp = IOCBp (arg, "0"b);
		     argn = argn+1;
		end;

		else if arg = "-repeat" | arg = "-rp"
		then do;
		     call Get_Arg (argn+1,
			"Missing repeat interval following " || arg);
		     if addr (arg) ^= null ()
		     then my_query_info.repeat_time = Date_Time (arg);
		     argn = argn+1;
		end;

		else do;
		     call error (error_table_$badopt, (NAME (entry_point)),
			"^a", arg);
		     error_has_occured = "1"b;
		end;

	     end;


	     return;

IOCBp:	     procedure (switch_name, input_flag) returns (ptr);


dcl  input_flag bit (1);
dcl  iocbp ptr;
dcl  switch_name char (*);


		call iox_$look_iocb (switch_name, iocbp, code);
		if code ^= 0
		then do;
		     call error (code, (NAME (entry_point)), "^a", switch_name);
		     error_has_occured = "1"b;
		     return (null ());
		end;

		if iocbp -&gt; iocb.open_descrip_ptr = null ()
		then do;
		     call error (error_table_$not_open, (NAME (entry_point)),
			"^a", switch_name);
		     error_has_occured = "1"b;
		     return (null ());
		end;

		if substr (iocbp -&gt; iocb.open_descrip_ptr -&gt; open_descrip.string, 1, 19) = "stream_input_output"
		then return (iocbp);
		if substr (iocbp -&gt; iocb.open_descrip_ptr -&gt; open_descrip.string, 1, 12) = "stream_input" &amp; input_flag
		then return (iocbp);
		if substr (iocbp -&gt; iocb.open_descrip_ptr -&gt; open_descrip.string, 1, 13) = "stream_output" &amp; ^input_flag
		then return (iocbp);


		call error (0, (NAME (entry_point)),
		     "I/O switch ^a not open for stream_^[input^;output^] or stream_input_output.",
		     switch_name, input_flag);
		error_has_occured = "1"b;
		return (null ());


	     end IOCBp;

Date_Time:     procedure (date_time_string) returns (fixed bin (71));


dcl  current_date_time fixed bin (71);
dcl  date_time fixed bin (71);
dcl  date_time_string char (*);


		current_date_time = clock ();
		call convert_date_to_binary_$relative (date_time_string,
		     date_time, current_date_time, code);
		date_time = divide ((date_time-current_date_time), 1000000, 71, 0);

		if code ^= 0
		then do;
		     call error (code, (NAME (entry_point)),
			"Converting ""^a"" to binary date/time.",
			date_time_string);
		     error_has_occured = "1"b;
		     return (0);
		end;
		else if date_time &lt; 30		/* 30 seconds */
		then do;
		     call error (error_table_$bad_arg, (NAME (entry_point)),
			"Specified date/time is not ^[far enough ^]in the future.  ^a",
			(date_time &gt; 0), date_time_string);
		     error_has_occured = "1"b;
		     return (0);
		end;


		return (date_time);


	     end Date_Time;


	end Process_Control_Args;

Get_Arg:	procedure (argn, mess);


dcl  argn fixed bin;
dcl  mess char (*);


	     call get_arg (argn, arg_ptr, arg_len, code, arg_list_ptr);
	     if code = 0
	     then return;


	     call error (code, (NAME (entry_point)),
		"^[Refencing argument ^d^s^;^s^a^].",
		(mess = ""), argn, mess);


	     arg_ptr = null ();
	     arg_len = 0;
	     error_has_occured = "1"b;


	     return;


	end Get_Arg;


     end query;
��



		    rank.pl1                        02/07/84  1052.5r   02/07/84  1050.5       48780



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


/* format: style2 */
rank:
     procedure;

/* **********************************************************************
   *  Active function/command to implement the PL/I builtin functions   *
   *  rank and byte.                                                    *
   *                                                                    *
   *  Written August 1981 by Warren Johnson.                            *
   *  Modified as per MCR for installation, November 1981, Benson I.    *
   *					         Margulies    *
   *  Modified to fix NNo and other problems, BIM, 10/82                *
   *  Modified to fix "byte 32" and "byte 34" (i.e. to use requote_     *
   *    before calling ioa_), June 1983, Chris Jones		  *
   *  Modified to fix arg processing errors, 1 Nov 1983 C Spitzer	  *
   ********************************************************************** */

	dcl     active_fnc_err_	 entry options (variable);
	dcl     com_err_		 entry options (variable);
	dcl     cu_$af_return_arg	 entry (fixed, ptr, fixed (21), fixed (35));
	dcl     cu_$arg_ptr		 entry (fixed, ptr, fixed (21), fixed (35));
	dcl     cv_dec_check_	 entry (char (*), fixed (35)) returns (fixed (35));
	dcl     cv_oct_check_	 entry (char (*), fixed (35)) returns (fixed (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     requote_string_	 entry (char (*)) returns (char (*));

	dcl     (rank, byte, rtrim, substr, length, before, index)
				 builtin;

	dcl     error_table_$badopt	 fixed (35) external;
	dcl     error_table_$bigarg	 fixed (35) external;
	dcl     error_table_$noarg	 fixed (35) external;
	dcl     error_table_$not_act_fnc
				 fixed (35) external;
	dcl     error_table_$too_many_args
				 fixed (35) external;

	dcl     error_table_$smallarg	 fixed bin (35) ext static;
	dcl     error_table_$bad_conversion
				 fixed bin (35) ext static;

	dcl     gripe		 entry variable options (variable);

	dcl     (nargs, i)		 fixed;
	dcl     (rsl, argl)		 fixed (21);
	dcl     (rv, code)		 fixed (35);

	dcl     (argp, rsp)		 ptr;

	dcl     rs		 char (rsl) varying based (rsp);
	dcl     arg		 char (argl) based (argp);
	dcl     cname		 char (4);
	dcl     have_main_arg	 bit (1) aligned;
	dcl     main_arg		 char (32);

	dcl     (command, octal_sw)	 bit (1);
%page;
	cname = "rank";
	go to JOIN;

byte:
     entry;

	cname = "byte";

JOIN:
	octal_sw = "0"b;
	call cu_$af_return_arg (nargs, rsp, rsl, code);
	if code = error_table_$not_act_fnc
	then do;					/* called as a command */
		command = "1"b;
		gripe = com_err_;
	     end;
	else if code = 0
	then do;					/* active function */
		command = "0"b;
		gripe = active_fnc_err_;
	     end;
	else do;
		call com_err_ (code, cname);
		return;
	     end;

	if nargs = 0
	then do;					/* one input arg required, one optional */
USAGE:
		call gripe (error_table_$noarg, cname, "^/Usage is: ^[[^]^a ^[CHAR^;NO^] {-control_args}^[]^]",
		     ^command, cname, cname = "rank", ^command);
		return;
	     end;

	have_main_arg = "0"b;

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, argl, (0));

	     if ^(length (arg) &gt; 1 &amp; char (arg, 1) = "-")
	     then do;
		     if have_main_arg
		     then do;
			     call com_err_ (error_table_$too_many_args, cname,
				"Only one character may be specified. ^a is the second.", arg);
			     return;
			end;
		     have_main_arg = "1"b;
		     main_arg = arg;		/* so, it can be truncated */
		end;

	     else if (arg = "-octal" | arg = "-oc") &amp; cname = "rank"
						/* not on byte */
	     then octal_sw = "1"b;
	     else if (arg = "-decimal" | arg = "-dec") &amp; cname = "rank"
	     then octal_sw = "0"b;			/* allow defaulting */
	     else do;
		     call gripe (error_table_$badopt, cname, arg);
		     return;
		end;
	end;

	if ^have_main_arg
	then go to USAGE;

	if cname = "rank"				/* RANK */
	then do;
		if length (rtrim (main_arg)) &gt; 1
		then do;
			call gripe (error_table_$bigarg, cname,
			     "Only one character may be given. ""^a"" is too long.", main_arg);
			return;
		     end;


		rv = rank (char (main_arg, 1));
		if octal_sw
		then if command
		     then call ioa_ ("^o", rv);
		     else call ioa_$rsnnl ("^o", rs, (rsl), rv);
		else if command
		then call ioa_ ("^d", rv);
		else call ioa_$rsnnl ("^d", rs, (rsl), rv);
	     end;

	else do;					/* BYTE */
		if character (reverse (rtrim (main_arg)), 1) = "o"
		then rv = cv_oct_check_ (before (main_arg, "o"), code);
		else rv = cv_dec_check_ (main_arg, code);
		if code ^= 0
		then do;
			call gripe (error_table_$bad_conversion, cname, "Invalid number: ^a.", main_arg);
			return;
		     end;
		else if rv &lt; 0 | rv &gt; 511
		then do;
			call gripe (0, cname, "Number out of range: ^a.", main_arg);
			return;
		     end;
		else if command
		then call ioa_ ("^a", requote_string_ (byte (rv)));
		else rs = byte (rv);
	     end;

	if ^command
	then rs = requote_string_ ((rs));

	return;

     end rank;




		    run.pl1                         11/04/82  2003.4rew 11/04/82  1630.2       72756



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


run:
     proc;

/* This procedure is the run command.  The syntax is:
   run {-control_structure} {main_program} {program_args}
   If no exec_com is specified and -no_exec_com is not specified, main_program.run.ec in the main program's
   directory is used.
*/
/* coded by Melanie Weaver August 1977 */
/* modified June 1979 by Melanie Weaver */

	dcl     (i, j, k, m, alng, nargs, nprogargs, ref_name_spec_count)
				 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     type		 fixed bin (2);
	dcl     bit_cnt		 fixed bin (24);

	dcl     me		 char (3) init ("run") static options (constant);
	dcl     arg		 char (alng) based (aptr);
	dcl     (main_dir, arg_ec_name)
				 char (168);
	dcl     ec_name		 char (168) var;
	dcl     main_ename		 char (32);

	dcl     (no_ec, have_main)	 bit (1) aligned;

	dcl     (aptr, arglist_ptr, new_arglist_ptr, sys_areap)
				 ptr;

	dcl     (error_table_$noarg, error_table_$badopt)
				 fixed bin (35) ext;

	dcl     system_area		 area based (sys_areap);

	dcl     1 control_structure	 aligned like run_control_structure;

	dcl     1 char_desc		 aligned,
		2 flag		 bit (1) unal init ("1"b),
		2 type		 fixed bin (5) unal init (21),
		2 packed		 bit (1) unal init ("1"b),
		2 number_dims	 bit (4) unal init ("0"b),
		2 size		 fixed bin (23) unal;

	dcl     1 old_arglist	 aligned based (arglist_ptr),
		2 (arg_count, code)	 fixed bin (17) unal,
		2 (desc_count, mbz)	 fixed (17) unal,
		2 args		 (nargs) ptr,
		2 descs		 (nargs) ptr;

	dcl     1 new_arglist	 aligned based (new_arglist_ptr),
		2 (arg_count, code)	 fixed bin (17) unal,
		2 (desc_count, mbz)	 fixed bin (17) unal,
		2 args		 (nprogargs) ptr,
		2 descs		 (nprogargs) ptr;

	dcl     (addr, hbound, length, null, rtrim, substr, unspec)
				 builtin;

	dcl     main_entry		 entry variable;

	dcl     cu_$arg_count	 entry () returns (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry () returns (ptr);
	dcl     com_err_		 entry options (variable);
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     hcs_$make_entry	 entry (ptr, char (*), char (*), entry, fixed bin (35));
	dcl     cv_entry_		 entry (char (*), ptr, fixed bin (35)) returns (entry);
	dcl     run_		 entry (entry, ptr, ptr, fixed bin (35));
	dcl     get_wdir_		 entry () returns (char (168));
	dcl     get_system_free_area_	 entry () returns (ptr);


%include run_control_structure;

	unspec (control_structure) = "0"b;
	control_structure.version = run_control_structure_version_1;
	no_ec = "0"b;
	ref_name_spec_count = 0;

	nargs = cu_$arg_count ();

	do i = 1 to nargs;				/* find all control args */

	     call cu_$arg_ptr (i, aptr, alng, code);
	     if code ^= 0
	     then do;
		     if code = error_table_$noarg
		     then goto no_main;
		     call com_err_ (code, me);
		     return;
		end;

	     if (arg = "-exec_com") | (arg = "-ec")
	     then do;
		     i = i + 1;
		     control_structure.flags.ec = "1"b;
		     no_ec = "0"b;
		     call cu_$arg_ptr (i, aptr, alng, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, me, "exec_com name");
			     return;
			end;
		     ec_name = arg;
		end;

	     else if (arg = "-no_exec_com") | (arg = "-nec")
	     then do;
		     control_structure.flags.ec = "0"b;
		     no_ec = "1"b;
		end;

	     else if (arg = "-limit") | (arg = "-li")
	     then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, aptr, alng, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, me, "time limit");
			     return;
			end;
		     control_structure.time_limit = cv_dec_check_ (arg, code);
		     if code ^= 0
		     then do;
			     call com_err_ (0, me, "Invalid time limit specification ^a.", arg);
			     return;
			end;
		end;

	     else if (arg = "-copy_reference_names") | (arg = "-crn")
	     then do;
		     control_structure.reference_name_switch = COPY_REFERENCE_NAMES;
		     ref_name_spec_count = ref_name_spec_count + 1;
		end;

	     else if (arg = "-old_reference_names") | (arg = "-orn")
	     then do;
		     control_structure.reference_name_switch = OLD_REFERENCE_NAMES;
		     ref_name_spec_count = ref_name_spec_count + 1;
		end;

	     else if (arg = "-new_reference_names") | (arg = "-nrn")
	     then do;
		     control_structure.reference_name_switch = NEW_REFERENCE_NAMES;
		     ref_name_spec_count = ref_name_spec_count + 1;
		end;

	     else if substr (arg, 1, 1) = "-"
	     then do;
		     call com_err_ (error_table_$badopt, me, arg);
		     return;
		end;

	     else do;				/* main program name */

		     if ^control_structure.flags.ec
		     then do;			/* need to know dir of main program */
			     call expand_pathname_ (arg, main_dir, main_ename, code);
			     if code ^= 0
			     then do;
				     call com_err_ (code, me, arg);
				     return;
				end;
			end;
		     have_main = "1"b;
		     goto setup_entry_var;
		end;

	end;

no_main:
	have_main = "0"b;

setup_entry_var:
	if ref_name_spec_count &gt; 1
	then do;
		call com_err_ (0, me, "Only one reference name control argument may be specified.");
		return;
	     end;

	if control_structure.flags.ec
	then if no_ec
	     then do;
		     call com_err_ (0, me, "Incompatible exec_com arguments specified.");
		     return;
		end;

	if ^control_structure.flags.ec
	then if ^no_ec
	     then do;				/* look for main_program.run.ec */
		     if ^have_main
		     then do;
			     call com_err_ (0, me, "No exec_com or main program specified.");
			     return;
			end;
		     call hcs_$status_minf (main_dir, rtrim (main_ename) || ".run.ec", 1, type, bit_cnt, code);
		     if code = 0
		     then do;
			     control_structure.flags.ec = "1"b;
			     ec_name = rtrim (main_dir) || "&gt;" || rtrim (main_ename) || ".run.ec";
			end;
		end;

	if control_structure.flags.ec
	then do;					/* this is not an else clause because flag
						   could have been reset */
		call hcs_$make_entry (null, "exec_com", "exec_com", main_entry, code);
		if code ^= 0
		then do;
			call com_err_ (code, me, "exec_com");
			return;
		     end;
		i = i - 1;			/* must pass ec name to ec */
	     end;

	else do;					/* no exec_com; i is index of main */
		i = i + 1;			/* don't pass name of main to main */
		main_entry = cv_entry_ (arg, null, code);
		if code ^= 0
		then do;
			call com_err_ (code, me, arg);
			return;
		     end;
	     end;

	if i &gt; nargs
	then nprogargs = 0;
	else nprogargs = nargs - i + 1;

	sys_areap = get_system_free_area_ ();
	allocate new_arglist in (sys_areap -&gt; system_area) set (new_arglist_ptr);

	arglist_ptr = cu_$arg_list_ptr ();

	new_arglist.arg_count, new_arglist.desc_count = nprogargs * 2;
	new_arglist.code = 4;
	if control_structure.flags.ec
	then do;					/* set up ec_name arg */
		m = 2;
		arg_ec_name = ec_name;		/* can't pass varying string in command arglist */
		new_arglist.args (1) = addr (arg_ec_name);
		char_desc.size = length (ec_name);
		new_arglist.descs (1) = addr (char_desc);
	     end;
	else m = 1;				/* first arg is from original arg list */

	do j = m to nprogargs;
	     k = j + i - 1;
	     new_arglist.args (j) = old_arglist.args (k);
	     new_arglist.descs (j) = old_arglist.descs (k);
	end;

	call run_ (main_entry, new_arglist_ptr, addr (control_structure), code);

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

	free new_arglist_ptr -&gt; new_arglist;

	return;

     end;




		    run_.pl1                        07/05/88  1442.9rew 07/05/88  1426.2      321327



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




/****^  HISTORY COMMENTS:
  1) change(86-06-24,DGHowe), approve(86-06-24,MCR7396),
     audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222):
     null variable node seg ptr in cleanup_old_linkage_section
  2) change(88-05-03,Farley), approve(88-05-26,MCR7901), audit(88-06-07,GWMay),
     install(88-07-05,MR12.2-1053):
     Changed RNT area manipulation code to use stack_header.rnt_ptr directly,
     instead of copying to the automatic rntp variable.  The RNT area can move
     and using the stack_header is the only sure way of referencing the correct
     location.  Also inhibit interrupts during this period.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
run_:
     proc (main_entry, arglist_ptr, ca_ptr, code);

/* coded December 1977 by Melanie Weaver */
/* modified June 1979 by Melanie Weaver to add -old_reference_names handling */
/* modified February 1983 by Melanie Weaver to clean up vla segments */

/* Parameters */

dcl	main_entry	entry variable;
dcl	arglist_ptr	ptr;
dcl	ca_ptr		ptr;
dcl	code		fixed bin (35);

/* Static */

dcl	in_run		bit (1) aligned static init ("0"b);
						/* init important for stop_run */
dcl	run_sp		ptr static init (null);
dcl	static_abort_label	label static;
dcl	1 saved_ptrs	aligned static like env_ptrs;
dcl	saved_vla_flag	bit (1) aligned static;	/* Automatic */

dcl	(i, j, old_cur_lot_size, old_rnt_size, rnt_size, nwords, linkage_lng, static_lng, hcscnt, highseg)
			fixed bin;
dcl	xcode		fixed bin (35);
dcl	mask		bit (36) aligned;
dcl	timer_set		bit (1) aligned;
dcl	Its_mod		bit (6) aligned static options (constant) init ("100011"b);
dcl	perprocess_array	(4096) bit (1) unaligned;
dcl	(new_lot_ptr, new_isot_ptr, new_sct_ptr, area_ptr, new_rnt_areap, tss_ptr, old_rntp, new_rntp, linkp, run_stp,
	stp, tp, np, link_ptr, temp_ptr, table_ptr)
			ptr;
dcl	(outer_env_linkage_ptr, run_unit_linkage_ptr)
			ptr unaligned;
dcl	search_rule_entry_var
			entry (ptr, fixed bin (35)) variable;
dcl	1 search_rules	aligned,
	  2 number	fixed bin,
	  2 name		(21) char (168) aligned;

dcl	1 auto_run_control_structure
			aligned like run_control_structure;

dcl	1 ainfo		aligned like area_info;

dcl	1 finish_info	aligned,
	  2 header	aligned like condition_info_header,
	  2 type		char (8);

dcl	1 cond_info	aligned like condition_info;

/* Based */

dcl	sct_array		(128) bit (36) aligned based;
dcl	based_array	(nwords) fixed bin (35) based;
dcl	based_area	area based;
dcl	based_bit		bit (72) aligned based;
dcl	rnt_area		area (rnt_size) based;
dcl	old_rnt_area	area (old_rnt_size) based;
dcl	linkage_section	(linkage_lng) fixed bin (35) based;
dcl	static_section	(static_lng) fixed bin (35) based;
dcl	1 control_args	aligned based (ca_ptr),
	  2 flags		aligned,
	    3 ec		bit (1) unaligned,
	    3 crn		bit (1) unaligned,
	    3 pad		bit (34) unaligned,
	  2 time_limit	fixed bin (35);
dcl	1 temp_seg_struc	aligned based (tss_ptr),
	  2 ntemps	fixed bin,
	  2 segno		(2000) fixed bin;


/* Builtins */

dcl	(addr, addrel, baseno, baseptr, bin, empty, hbound, lbound, null, stackbaseptr, stackframeptr)
			builtin;
dcl	(ptr, rel, size, string, unspec)
			builtin;

/* Conditions */

dcl	(any_other, cleanup, finish, command_abort_)
			condition;

/* externals */

dcl	sys_info$max_seg_size
			ext fixed bin (19);
dcl	error_table_$run_unit_not_recursive
			external fixed bin (35);

dcl	(get_temp_segment_, release_temp_segment_)
			entry (char (*), ptr, fixed bin (35));
dcl	define_area_	entry (ptr, fixed bin (35));
dcl	hcs_$high_low_seg_count
			entry (fixed bin, fixed bin);
dcl	hcs_$initiate_search_rules
			entry (ptr, fixed bin (35));
dcl	find_command_$clear entry ();
dcl	(
	hcs_$set_ips_mask,
	hcs_$reset_ips_mask
	)		entry (bit (36) aligned, bit (36) aligned);
dcl	timer_manager_$cpu_call
			entry (fixed bin (71), bit (2), entry);
dcl	timer_manager_$reset_cpu_call
			entry (entry);
dcl	cu_$generate_call	entry (entry, ptr);
dcl	execute_epilogue_	entry (bit (1) aligned);
dcl	get_temp_segments_$list_segnos
			entry (ptr);
dcl	hcs_$terminate_seg	entry (ptr, fixed bin (1), fixed bin (35));
dcl	link_unsnap_	entry (ptr, ptr, ptr, fixed bin, fixed bin);
dcl	release_area_	entry (ptr);
dcl	find_condition_info_
			entry (ptr, ptr, fixed bin (35));
dcl	continue_to_signal_ entry (fixed bin (35));
dcl	signal_		entry (char (*), ptr, ptr);
dcl	hcs_$get_search_rules
			entry (ptr);
dcl	fortran_storage_manager_$get_vla_segnos
			entry ((4096) bit (1) unaligned);
dcl	fortran_storage_manager_$free
			entry (ptr);

	if in_run
	then do;					/* do not allow recursive invocation because it won't work */
	     code = error_table_$run_unit_not_recursive;
	     return;
	end;

	code = 0;
	area_ptr = null;
	temp_ptr = null;

	if ca_ptr -&gt; run_control_structure.version = run_control_structure_version_1
	then run_cs_ptr = ca_ptr;			/* caller used include file */
	else do;					/* copy items into standard structure */
	     run_cs_ptr = addr (auto_run_control_structure);
	     run_control_structure.flags.ec = control_args.flags.ec;
	     if control_args.flags.crn
	     then run_control_structure.reference_name_switch = COPY_REFERENCE_NAMES;
	     else run_control_structure.reference_name_switch = NEW_REFERENCE_NAMES;
	     run_control_structure.time_limit = control_args.time_limit;
	end;

	mask = "0"b;
	on cleanup
	     begin;
		if temp_ptr ^= null
		then call release_temp_segment_ ("run_", temp_ptr, code);
		if mask
		then call hcs_$reset_ips_mask (mask, mask);
	     end;

	call get_temp_segment_ ("run_", temp_ptr, code);
	if code ^= 0
	then return;

	call hcs_$set_ips_mask ("0"b, mask);

	run_sp = stackframeptr;			/* save for environment_info entry point */
	sb = stackbaseptr;
	new_lot_ptr = temp_ptr;
	old_cur_lot_size = sb -&gt; stack_header.cur_lot_size;
	new_isot_ptr, new_sct_ptr = addrel (new_lot_ptr, old_cur_lot_size);
	lotp = sb -&gt; stack_header.lot_ptr;
	isotp = sb -&gt; stack_header.isot_ptr;

/* 	fill in run unit lot */
/* WARNING:  If this code is changed to combine new linkage sections for perprocess static segments
   (copying active static sections), stack_header.trans_op_tv_ptr must be pushed,
   since it must point to the actual links being used.
   This assumes that operator_pointers_ is still perprocess static. */

	call hcs_$high_low_seg_count (highseg, hcscnt);
	do i = hcscnt to hcscnt + highseg;
	     if baseno (lotp -&gt; lot.lp (i)) = "0"b
	     then do;				/* either 0 or lot fault; just copy entry */
		unspec (new_lot_ptr -&gt; lot.lp (i)) = unspec (lotp -&gt; lot.lp (i));
						/* use bit copy to avoid possible fault */
		unspec (new_isot_ptr -&gt; isot.isp (i)) = unspec (isotp -&gt; isot.isp (i));
	     end;
	     else if ^lotp -&gt; lot.lp (i) -&gt; linkage_header_flags.perprocess_static
	     then unspec (new_lot_ptr -&gt; lot.lp (i)) = lot_fault;
	     else do;				/* perprocess static; use same linkage and static */
		new_lot_ptr -&gt; lot.lp (i) = lotp -&gt; lot.lp (i);
						/* this should combine if there was a lot fault */
		new_isot_ptr -&gt; isot.isp (i) = isotp -&gt; isot.isp (i);
						/* we want any isot faults to handled at this time
						   so static will be in the right place */
	     end;
	end;

	new_isot_ptr -&gt; sct_array = isotp -&gt; sct_array;	/* copy static condition table */

/* set up the area for linkage sections, etc. */

	ainfo.version = area_info_version_1;
	ainfo.size = sys_info$max_seg_size - 2 * old_cur_lot_size;
						/* everything except lot annd isot */
	area_ptr, ainfo.areap = addrel (new_isot_ptr, old_cur_lot_size);
	string (ainfo.control) = "0"b;
	ainfo.control.extend = "1"b;
	ainfo.control.zero_on_free = "1"b;
	ainfo.control.system = "1"b;
	ainfo.owner = "run_";

	call define_area_ (addr (ainfo), code);
	if code ^= 0
	then do;
	     call release_temp_segment_ ("run_", temp_ptr, xcode);
	     call hcs_$reset_ips_mask (mask, mask);
	     return;
	end;

/* allocate new rnt area and initialize rnt if necessary */

	if run_control_structure.reference_name_switch ^= OLD_REFERENCE_NAMES
	then do;					/* set up new name space */
allocate_new_rnt:
	     rnt_size = sb -&gt; stack_header.rnt_ptr -&gt; rnt.rnt_area_size;
	     allocate rnt_area in (area_ptr -&gt; based_area) set (new_rnt_areap);
	     if run_control_structure.reference_name_switch = COPY_REFERENCE_NAMES
	     then do;				/* copy whole area and update ptrs in rnt */
		new_rnt_areap -&gt; rnt_area = empty;
		new_rnt_areap -&gt; rnt_area = sb -&gt; stack_header.rnt_ptr -&gt; rnt.areap -&gt; rnt_area;
		if rnt_size ^= sb -&gt; stack_header.rnt_ptr -&gt; rnt.rnt_area_size
		then do;				/* Has RNT grown/moved during the copy? */
		     free new_rnt_areap -&gt; rnt_area;	/* remove the new area */
		     goto allocate_new_rnt;		/* and try again */
		end;
		new_rntp =
		     addrel (new_rnt_areap,
		     (bin (rel (sb -&gt; stack_header.rnt_ptr), 18)
		     - bin (rel (sb -&gt; stack_header.rnt_ptr -&gt; rnt.areap), 18)));
		new_rntp -&gt; rnt.srulep =
		     addrel (new_rnt_areap,
		     (bin (rel (sb -&gt; stack_header.rnt_ptr -&gt; rnt.srulep), 18)
		     - bin (rel (sb -&gt; stack_header.rnt_ptr -&gt; rnt.areap), 18)));
	     end;
	     else do;				/* initialize rnt and set up to init search rules */
		ainfo.control.extend = "0"b;		/* other control settings are ok */
		ainfo.owner = "rnt";
		ainfo.size = rnt_size;
		ainfo.areap = new_rnt_areap;
		call define_area_ (addr (ainfo), code);
		if code ^= 0
		then do;
		     call release_temp_segment_ ("run_", temp_ptr, xcode);
		     call hcs_$reset_ips_mask (mask, mask);
		     return;
		end;
		allocate rnt in (new_rnt_areap -&gt; based_rnt_area) set (new_rntp);
		new_rntp -&gt; rnt.name_hash_table (*) = null;
		new_rntp -&gt; rnt.segno_hash_table (*) = null;
		new_rntp -&gt; rnt.srulep = null;
		call hcs_$get_search_rules (addr (search_rules));
						/* use existing rules by default */
		search_rule_entry_var = hcs_$initiate_search_rules;
						/* must snap link before entering run environment */
	     end;

	     new_rntp -&gt; rnt.areap = new_rnt_areap;	/* same for both cases */
	     new_rntp -&gt; rnt.rnt_area_size = rnt_size;

	end;
	else new_rntp = sb -&gt; stack_header.rnt_ptr;	/* no net change when keep same name space */


/* save current environment pointers in static */

	saved_ptrs.version = 1;
	saved_ptrs.pad = 0;
	saved_ptrs.lot_ptr = lotp;
	saved_ptrs.isot_ptr = isotp;
	saved_ptrs.clr_ptr = sb -&gt; stack_header.clr_ptr;
	saved_ptrs.combined_stat_ptr = sb -&gt; stack_header.combined_stat_ptr;
	saved_ptrs.user_free_ptr = sb -&gt; stack_header.user_free_ptr;
	saved_ptrs.sys_link_info_ptr = sb -&gt; stack_header.sys_link_info_ptr;
	saved_ptrs.rnt_ptr = sb -&gt; stack_header.rnt_ptr;
	saved_ptrs.sct_ptr = sb -&gt; stack_header.sct_ptr;
	saved_vla_flag = sb -&gt; stack_header.have_static_vlas;

/* set up condition handlers */

	on finish
	     begin;
dcl	1 based_finish_info aligned based like finish_info;

		call find_condition_info_ (null, addr (cond_info), xcode);
		if cond_info.info_ptr = null
		then call continue_to_signal_ (xcode);
		else if cond_info.info_ptr -&gt; based_finish_info.type ^= "run"
		then call continue_to_signal_ (xcode);	/* stop signalling if finish is just for run */
	     end;
	on any_other system;			/* set up wall */

	run_sp -&gt; stack_frame_flags.run_unit_manager = "1"b;
						/* mark stack frame for PL/I options (main) */

	call find_command_$clear;			/* reset command processor's associative memory */

	on cleanup
	     begin;
		call restore_environment;
		if temp_ptr ^= null
		then call release_temp_segment_ ("run_", temp_ptr, code);
		if mask
		then call hcs_$reset_ips_mask (mask, mask);
	     end;

/* change to run environment */

	sb -&gt; stack_header.lot_ptr = new_lot_ptr;
	sb -&gt; stack_header.isot_ptr, sb -&gt; stack_header.sct_ptr = new_isot_ptr;
	sb -&gt; stack_header.clr_ptr = area_ptr;
	sb -&gt; stack_header.combined_stat_ptr = area_ptr;
	sb -&gt; stack_header.user_free_ptr = area_ptr;
	sb -&gt; stack_header.sys_link_info_ptr = null;
	sb -&gt; stack_header.rnt_ptr = new_rntp;
	sb -&gt; stack_header.have_static_vlas = "0"b;

	if run_control_structure.reference_name_switch = NEW_REFERENCE_NAMES
						/* fill in search rules without snapping links */
	then call search_rule_entry_var (addr (search_rules), code);

	call hcs_$reset_ips_mask (mask, mask);		/* unmask now */

	timer_set = "0"b;
	on cleanup call Clean_up;

	if run_control_structure.time_limit &gt; 0
	then do;
	     timer_set = "1"b;			/* doesn't hurt to set it ahead of time */
	     call timer_manager_$cpu_call ((run_control_structure.time_limit), "11"b, interrupt_run);
	end;

	static_abort_label = abort;
	in_run = "1"b;
	sb -&gt; stack_header.main_proc_invoked = 0;	/* be sure this is set correctly */
	sb -&gt; stack_header.run_unit_depth = 1;

	call cu_$generate_call (main_entry, arglist_ptr); /* start running */

abort:
	on cleanup call quick_cleanup;		/* be sure critical environment changing is done */
	call Clean_up;

	return;

Clean_up:
     proc;

	if timer_set
	then call timer_manager_$reset_cpu_call (interrupt_run);


	if in_run
	then do;					/* probably did something before stopping */
	     call execute_epilogue_ ("1"b);		/* just run epilogue_ handlers */
	     if old_cur_lot_size &lt; sb -&gt; stack_header.cur_lot_size
	     then do;				/* lot has grown; grow the outer env lot also */

/*	This code is similar to that in link_man$grow_lot, which cannot be used here
   .	because  it updates the stack header itself, which has already been done within the run unit. */

		nwords = 2 * sb -&gt; stack_header.max_lot_size;
		allocate based_array in (saved_ptrs.clr_ptr -&gt; based_area) set (saved_ptrs.lot_ptr);
						/* allocate new lot and isot */
		saved_ptrs.isot_ptr = addrel (saved_ptrs.lot_ptr, sb -&gt; stack_header.max_lot_size);
		nwords = old_cur_lot_size;
		saved_ptrs.lot_ptr -&gt; based_array = lotp -&gt; based_array;
						/* copy old lot and isot */
		saved_ptrs.isot_ptr -&gt; based_array = isotp -&gt; based_array;
		lotp = saved_ptrs.lot_ptr;
		isotp = saved_ptrs.isot_ptr;
		old_cur_lot_size = sb -&gt; stack_header.max_lot_size;

		new_lot_ptr = sb -&gt; stack_header.lot_ptr;
						/* update run copies also */

		new_isot_ptr = sb -&gt; stack_header.isot_ptr;

	     end;

/*	Now, if VLA external variables have been used, we must check
	all the external variables and free any attached VLA segments.
	We do not need to free the variables themselves because they
	will go away anyway.
*/

	     table_ptr = sb -&gt; stack_header.sys_link_info_ptr;
	     if table_ptr ^= null
	     then if table_ptr -&gt; variable_table_header.flags.have_vla_variables
		then call free_vla_common ();

	     call hcs_$high_low_seg_count (highseg, hcscnt);
						/* find current range of segment numbers */

	     if run_control_structure.reference_name_switch ^= OLD_REFERENCE_NAMES
	     then do;				/* terminate segs initiated only in run unit
						   and adjust outer environment LOT */

/*	obtain list of non-procedure perprocess_segments */

		string (perprocess_array) = "0"b;

		call find_area_components (saved_ptrs.clr_ptr);
						/* find all extensions of outer clr area */

		if saved_ptrs.combined_stat_ptr ^= saved_ptrs.clr_ptr
		then call find_area_components (saved_ptrs.combined_stat_ptr);

		if (sb -&gt; stack_header.system_free_ptr ^= saved_ptrs.clr_ptr)
		     &amp; (sb -&gt; stack_header.system_free_ptr ^= saved_ptrs.combined_stat_ptr)
		then call find_area_components (sb -&gt; stack_header.system_free_ptr);

		if (saved_ptrs.user_free_ptr ^= saved_ptrs.clr_ptr)
		     &amp; (saved_ptrs.user_free_ptr ^= saved_ptrs.combined_stat_ptr)
		     &amp; (saved_ptrs.user_free_ptr ^= sb -&gt; stack_header.system_free_ptr)
		then call find_area_components (saved_ptrs.user_free_ptr);

		call find_area_components (area_ptr);	/* note components in own area; they  should
						   be terminated and deleted  later by release_area_
						   if they are not temp segments */

		call get_temp_segments_$list_segnos (tss_ptr);
						/* find all the temp segs */
		do i = 1 to temp_seg_struc.ntemps;
		     perprocess_array (temp_seg_struc.segno (i)) = "1"b;
		end;
		free tss_ptr -&gt; temp_seg_struc;

		if sb -&gt; stack_header.have_static_vlas
		then call fortran_storage_manager_$get_vla_segnos (perprocess_array);
						/* Note segments used in VLAs so they won't
					   be terminated prematurely.
					   fsm$free wants to truncate them first. */

/* The following code updates the outer environment LOT with the permanent changes that
   have taken place during the run unit.  This comment explains what the possibilities
   are and what actions are taken for each case.


   .				Run Unit
   .				Environment

   .		                  0       lot fault  linkage ptr
   .		            ____________________________________
   .		          0 | no change |    *1     |    *2     |
   . Outer	            _|____________|____________|___________|
   . Environment	  lot fault |    *5     | no change |    *3     |
   .		            _|____________|____________|____________|
   . 		linkage ptr |    *4     | no change |    *6     |
   .		            _|____________|____________|____________|

   .	*1   lot fault if non object perprocess segment; otherwise terminate

   .	*2   if perprocess, allocate linkage in outer, copy virgin linkage, copy static from run unit,
   .		and update outer lot; if not perprocess, terminate

   .	*3   if perprocess, same as *2 perprocess; otherwise do not change

   .	*4   (segment terminated during run unit) do everything term_ does except terminating,
   .		before environment is restored (don't risk reuse of segno in meantime)

   .	*5   (segment terminated during run unit) zero LOT entry and unsnap links to seg in outer

   .	*6   if perprocess, unsnap all links snapped during run unit because some are
		invalid; otherwise (shouldn't be possible) do not change

*/

		do i = hcscnt to hcscnt + highseg;
		     unspec (outer_env_linkage_ptr) = unspec (lotp -&gt; lot.lp (i));
		     unspec (run_unit_linkage_ptr) = unspec (new_lot_ptr -&gt; lot.lp (i));
		     if unspec (outer_env_linkage_ptr) = unspec (run_unit_linkage_ptr)
		     then do;
			if baseno (outer_env_linkage_ptr)
						/* had linkage ptr in outer env */
			then if outer_env_linkage_ptr -&gt; linkage_header_flags.perprocess_static
						/* superfluous; wouldn't be = if not perprocess */
			     then call unsnap_links_in_outer_pps_linkage (i);
		     end;

		     else if unspec (outer_env_linkage_ptr) = "0"b
		     then do;			/* seg not  known before run unit */
			if unspec (run_unit_linkage_ptr) = lot_fault
			then do;			/* no active linkage section */
			     if perprocess_array (i)
			     then unspec (lotp -&gt; lot.lp (i)) = lot_fault;
						/* don't forget about temp segs, etc. */
			     else call hcs_$terminate_seg (baseptr (i), 0, code);
			end;
			else do;			/* segment with linkage section */
			     if run_unit_linkage_ptr -&gt; linkage_header_flags.perprocess_static
			     then call copy_linkage (i);
			     else do;
				if run_unit_linkage_ptr -&gt; linkage_header_flags.static_vlas
				then call fortran_storage_manager_$free ((run_unit_linkage_ptr));
				call hcs_$terminate_seg (baseptr (i), 0, code);
			     end;
			end;
		     end;

		     else if unspec (outer_env_linkage_ptr) = lot_fault
		     then do;			/* segment initiated before run unit but no linkage in outer */
			if unspec (run_unit_linkage_ptr) = "0"b
			then do;
			     call link_unsnap_ (lotp, isotp, addrel (baseptr (i), -1), hcscnt, highseg);
						/* indicate no linkage section by offset of -1 */
			     lotp -&gt; lot.lp (i) = baseptr (0);
						/* indicate termination in outer env */
			end;
			else do;			/* seg has linkage section in run unit only */
			     if run_unit_linkage_ptr -&gt; linkage_header_flags.perprocess_static
			     then call copy_linkage (i);
			     else if run_unit_linkage_ptr -&gt; linkage_header_flags.static_vlas
			     then call fortran_storage_manager_$free ((run_unit_linkage_ptr));
						/* leave a lot fault but free "attached" VLAs
						   before throwing away linkage section from run unit */
			end;
		     end;
		     else do;			/* seg with linkage section in outer environment */
			if unspec (run_unit_linkage_ptr) = "0"b
			then call cleanup_old_linkage_section (i);
						/* seg has since been terminated; clean up outer env */
			else if unspec (run_unit_linkage_ptr) ^= lot_fault
						/* non-pps linkage section in run unit;
						   free "attached" VLAs before throwing it away */
			then if run_unit_linkage_ptr -&gt; linkage_header_flags.static_vlas
			     then call fortran_storage_manager_$free ((run_unit_linkage_ptr));
		     end;

		end;

	     end;					/* of new_name_space cleanup */

	     else do;				/* same name space case -- same RNT is used
						   and segs are not terminated */
		if sb -&gt; stack_header.rnt_ptr ^= saved_ptrs.rnt_ptr
		then do;				/* RNT got reallocated (grown) in run unit's area;
						   copy it back into outer environment */

		     call hcs_$set_ips_mask ("0"b, mask);
reallocate_new_rnt:
		     rnt_size = sb -&gt; stack_header.rnt_ptr -&gt; rnt.rnt_area_size;
		     allocate rnt_area in (saved_ptrs.clr_ptr -&gt; based_area) set (new_rnt_areap);
						/* allocate new RNT in outer environment */
		     new_rnt_areap -&gt; rnt_area = empty; /* PL/I areas must be initiaslized
						   before being used in any way */
		     new_rnt_areap -&gt; rnt_area = sb -&gt; stack_header.rnt_ptr -&gt; rnt.areap -&gt; rnt_area;
						/* copy it out */
		     if rnt_size ^= sb -&gt; stack_header.rnt_ptr -&gt; rnt.rnt_area_size
		     then do;			/* Has RNT grown/moved during the copy? */
			free new_rnt_areap -&gt; rnt_area;
						/* remove the new area */
			goto reallocate_new_rnt;	/* and try again */
		     end;
		     new_rntp =
			addrel (new_rnt_areap,
			bin (rel (sb -&gt; stack_header.rnt_ptr), 18)
			- bin (rel (sb -&gt; stack_header.rnt_ptr -&gt; rnt.areap), 18));
						/* locate copy of RNT within area */
		     new_rntp -&gt; rnt.areap = new_rnt_areap;
		     new_rntp -&gt; rnt.srulep =
			addrel (new_rnt_areap,
			bin (rel (sb -&gt; stack_header.rnt_ptr -&gt; rnt.srulep), 18)
			- bin (rel (sb -&gt; stack_header.rnt_ptr -&gt; rnt.areap), 18));
						/* must relocate search rule ptr in new area */
		     old_rntp = sb -&gt; stack_header.rnt_ptr;
		     old_rnt_size = sb -&gt; stack_header.rnt_ptr -&gt; rnt.rnt_area_size;
		     sb -&gt; stack_header.rnt_ptr = new_rntp;
		     free old_rntp -&gt; rnt.areap -&gt; old_rnt_area;
		     call hcs_$reset_ips_mask (mask, mask);
		end;

/* The following code updates the outer environment LOT with the permanent changes that
   have taken place during the run unit.  This comment explains what the possibilities
   are and what actions are taken for each case.


   .				Run Unit
   .				Environment

   .		                  0       lot fault  linkage ptr
   .		            ____________________________________
   .		          0 | no change | lot fault |    *1     |
   . Outer	            _|____________|____________|___________|
   . Environment	  lot fault |    *2     | no change |    *1     |
   .		            _|____________|____________|____________|
   .		linkage ptr |    *3     | no change |    *4     |
   .		            _|____________|____________|____________|

	*1    if perprocess, allocate linkage in outer, copy virgin linkage, copy static from run unit,
		and update outer LOT; if not perprocess, set lot fault

	*2    (segment terminated during run unit) zero LOT entry and unsnap links to segment in outer

	*3    (segment terminated during run unit) do everything term_ does except terminating,
		before environment is restored

   .	*4   if perprocess, unsnap all links snapped during run unit because some are
		invalid; otherwise (shouldn't be possible) do not change

*/

		do i = hcscnt to hcscnt + highseg;
		     unspec (outer_env_linkage_ptr) = unspec (lotp -&gt; lot.lp (i));
		     unspec (run_unit_linkage_ptr) = unspec (new_lot_ptr -&gt; lot.lp (i));

		     if unspec (outer_env_linkage_ptr) = unspec (run_unit_linkage_ptr)
		     then do;
			if baseno (outer_env_linkage_ptr)
						/* had linkage ptr in outer env */
			then if outer_env_linkage_ptr -&gt; linkage_header_flags.perprocess_static
						/* superfluous; wouldn't be = if not perprocess */
			     then call unsnap_links_in_outer_pps_linkage (i);
		     end;

		     else if unspec (outer_env_linkage_ptr) = "0"b
		     then do;			/* segment was not known before run unit */
			if unspec (run_unit_linkage_ptr) = lot_fault
			then unspec (lotp -&gt; lot.lp (i)) = lot_fault;
			else do;
			     if run_unit_linkage_ptr -&gt; linkage_header_flags.perprocess_static
			     then call copy_linkage (i);
			     else do;
				if run_unit_linkage_ptr -&gt; linkage_header_flags.static_vlas
				then call fortran_storage_manager_$free ((run_unit_linkage_ptr));
				unspec (lotp -&gt; lot.lp (i)) = lot_fault;
			     end;
			end;
		     end;

		     else if unspec (outer_env_linkage_ptr) = lot_fault
		     then do;			/* segment was initiated before run unit but
						   had no linkage in outer */
			if unspec (run_unit_linkage_ptr) = "0"b
			then do;
			     call link_unsnap_ (lotp, isotp, addrel (baseptr (i), -1), hcscnt, highseg);
						/* indicate no linkage section by offset of -1 */
			     lotp -&gt; lot.lp (i) = baseptr (0);
						/* indicate termination in outer environment */
			end;
			else do;
			     if run_unit_linkage_ptr -&gt; linkage_header_flags.perprocess_static
			     then call copy_linkage (i);
			     else if run_unit_linkage_ptr -&gt; linkage_header_flags.static_vlas
			     then call fortran_storage_manager_$free ((run_unit_linkage_ptr));
			end;
		     end;

		     else do;			/* segment with linkage section in outer environment */
			if unspec (run_unit_linkage_ptr) = "0"b
			then call cleanup_old_linkage_section (i);
						/* segment has since been terminated;
						   clean up outer environment */
			else if unspec (run_unit_linkage_ptr) ^= lot_fault
						/* non-pps linkage section in run unit;
						   free "attached" VLAs before throwing it away */
			then if run_unit_linkage_ptr -&gt; linkage_header_flags.static_vlas
			     then call fortran_storage_manager_$free ((run_unit_linkage_ptr));
		     end;

		end;				/* of LOT entry comparison loop */

	     end;					/* of code to cleanup same name space case */

	end;					/* of stuff done when in_run is on */

/*		now restore the outer environment */


	call quick_cleanup;

	code = 0;					/* just in case */
     end;

interrupt_run:
     proc (mcptr, cname);

/* This is the routine called by timer_manager_ when the user specifies a time limit. */

dcl	mcptr		ptr;
dcl	cname		char (*);
dcl	answer		char (10) varying;
dcl	command_query_	entry options (variable);
dcl	1 query_info	aligned,
	  2 version	fixed bin init (2),
	  2 yes_or_no_sw	bit (1) unaligned init ("1"b),
	  2 suppress_name_sw
			bit (1) unaligned init ("0"b),
	  2 code		fixed bin (35) init (0),
	  2 query_code	fixed bin (35) init (0);

	call command_query_ (addr (query_info), answer, "run",
	     "Time limit reached.  Do you want to continue the program?  ");
	if answer = "no"
	then goto abort;
	call timer_manager_$cpu_call ((run_control_structure.time_limit), "11"b, interrupt_run);

     end;

quick_cleanup:
     proc;

/* this procedure does the most essential cleaning up of the environment and static variables */

	sb -&gt; stack_header.run_unit_depth = 0;
	sb -&gt; stack_header.main_proc_invoked = 0;
	mask = "0"b;
	on cleanup
	     begin;
		if mask
		then call hcs_$reset_ips_mask (mask, mask);
	     end;

	call hcs_$set_ips_mask ("0"b, mask);
	call restore_environment;
	in_run = "0"b;
	call hcs_$reset_ips_mask (mask, mask);

	run_sp = null;
	call find_command_$clear;			/* clear command processor assoc. memory again */

     end;

restore_environment:
     proc;

/* restore original stack header variables and release temp seg */

	sb -&gt; stack_header.lot_ptr = saved_ptrs.lot_ptr;
	sb -&gt; stack_header.isot_ptr = saved_ptrs.isot_ptr;
	sb -&gt; stack_header.clr_ptr = saved_ptrs.clr_ptr;
	sb -&gt; stack_header.combined_stat_ptr = saved_ptrs.combined_stat_ptr;
	sb -&gt; stack_header.user_free_ptr = saved_ptrs.user_free_ptr;
	sb -&gt; stack_header.sys_link_info_ptr = saved_ptrs.sys_link_info_ptr;
	sb -&gt; stack_header.sct_ptr = saved_ptrs.sct_ptr;
	if run_control_structure.reference_name_switch ^= OLD_REFERENCE_NAMES
	then sb -&gt; stack_header.rnt_ptr = saved_ptrs.rnt_ptr;
	sb -&gt; stack_header.have_static_vlas = saved_vla_flag;

	if area_ptr ^= null
	then call release_area_ (area_ptr);		/* clean up any area extensions */
	if temp_ptr ^= null
	then call release_temp_segment_ ("run_", temp_ptr, code);

     end;

copy_linkage:
     proc (segno);

/* copy original linkage section and static section from run unit into outer environment */

dcl	segno		fixed bin;


	linkage_lng = bin (run_unit_linkage_ptr -&gt; header.stats.block_length, 18);
	allocate linkage_section in (saved_ptrs.clr_ptr -&gt; based_area) set (linkp);
	linkp -&gt; linkage_section = run_unit_linkage_ptr -&gt; header.original_linkage_ptr -&gt; linkage_section;
						/* copy virgin linkage into outer env */
	linkage_lng = size (header);
	linkp -&gt; linkage_section = run_unit_linkage_ptr -&gt; linkage_section;
						/* copy active header stuff */
	static_lng = bin (linkp -&gt; header.stats.static_length, 18);
	if static_lng &gt; 0
	then do;					/* have a static section */
	     run_stp = new_isot_ptr -&gt; isot.isp (segno);
	     if run_stp ^= run_unit_linkage_ptr		/* separate static */
	     then allocate static_section in (saved_ptrs.combined_stat_ptr -&gt; based_area) set (stp);
	     else do;
		stp = addrel (linkp, size (header));
		run_stp = addrel (run_stp, size (header));
	     end;
	     stp -&gt; static_section = run_stp -&gt; static_section;
						/* copy static */
	     if new_isot_ptr -&gt; isot.isp (segno) = run_unit_linkage_ptr
	     then stp = linkp;
	end;
	else stp = linkp;				/* no static; isote = lote by default */

	saved_ptrs.lot_ptr -&gt; lot.lp (segno) = linkp;	/* update original lot, isot */
	saved_ptrs.isot_ptr -&gt; isot.isp (segno) = stp;

     end;

unsnap_links_in_outer_pps_linkage:
     proc (segno);

/* This procedure unsnaps all links in a perprocess segment that were snapped during the run unit
   because they may have been snapped to segments being terminated.  This wouldn't be necessary
   if perprocess segments also got new linkage sections during run units.
*/

declare	segno		fixed bin;

	linkp = lotp -&gt; lot.lp (segno);
	do j = bin (linkp -&gt; header.stats.begin_links, 18) to bin (linkp -&gt; header.stats.block_length, 18) - 1 by 2;
	     link_ptr = addrel (linkp, j);
	     if link_ptr -&gt; link.ft2 = Its_mod		/* snapped link */
	     then if link_ptr -&gt; link.run_depth &gt; 0	/* snapped during run unit */
		then link_ptr -&gt; based_bit = addrel (linkp -&gt; header.original_linkage_ptr, j) -&gt; based_bit;
	end;

	return;

     end;

cleanup_old_linkage_section:
     proc (segno);

/* This procedure does what term_ does but in the outer environment (except terminating). */

dcl	segno		fixed bin;

	call link_unsnap_ (lotp, isotp, (outer_env_linkage_ptr), hcscnt, highseg);
	if saved_ptrs.sys_link_info_ptr ^= null
	then do;					/* there are *system links */
	     tp = saved_ptrs.sys_link_info_ptr;
	     do j = lbound (tp -&gt; variable_table_header.hash_table, 1)
		to hbound (tp -&gt; variable_table_header.hash_table, 1);
		do np = tp -&gt; variable_table_header.hash_table (j) repeat np -&gt; variable_node.forward_thread
		     while (np ^= null);
		     if bin (baseno (np -&gt; variable_node.init_ptr), 15) = i
		     then do;			/* zap init ptrs to terminated seg */
			np -&gt; variable_node.init_ptr = null;
			np -&gt; variable_node.seg_ptr = null;
		     end;

		end;
	     end;
	end;

/*		now free static and linkage */
	if isotp -&gt; isot.isp (segno) ^= outer_env_linkage_ptr
	then if isotp -&gt; isot1 (segno).flags.fault ^= "11"b
	     then do;				/* have separate static section to free */
		free isotp -&gt; isot.isp (segno) -&gt; static_section;
	     end;
	unspec (isotp -&gt; isot.isp (segno)) = "0"b;	/* 0 the isot slot to be discarded */
	free outer_env_linkage_ptr -&gt; linkage_section;
	unspec (lotp -&gt; lot.lp (segno)) = "0"b;

	return;

     end /* cleanup_old_linkage_section */;

find_area_components:
     proc (a_area_ptr);

/* this subroutine turns on a bit in the perprocess array for each segment
   contained in the given area. */

dcl	(a_area_ptr, area_ptr)
			ptr;
dcl	ii		fixed bin;

	area_ptr = a_area_ptr;
	do ii = 1 to 500 while (area_ptr ^= null);	/* set limit to avoid infinite loop */
	     perprocess_array (bin (baseno (area_ptr), 15)) = "1"b;
	     if area_ptr -&gt; area_header.extend_info
	     then area_ptr = addrel (area_ptr, area_ptr -&gt; area_header.extend_info) -&gt; extend_block.next_area;
	     else area_ptr = null;
	end;

     end;

free_vla_common:
     proc ();

dcl	node_ptr		ptr;
dcl	hash_index	fixed bin;

	if table_ptr -&gt; variable_table_header.cur_num_of_variables &lt; 1
	then return;

	do hash_index = lbound (table_ptr -&gt; variable_table_header.hash_table, 1)
	     to hbound (table_ptr -&gt; variable_table_header.hash_table, 1);

	     node_ptr = table_ptr -&gt; variable_table_header.hash_table (hash_index);
	     do while (node_ptr ^= null);
		if node_ptr -&gt; variable_node.vbl_size &gt; sys_info$max_seg_size
		then call fortran_storage_manager_$free (node_ptr);
		node_ptr = node_ptr -&gt; variable_node.forward_thread;
	     end;
	end;

	return;
     end;

environment_info:
     entry (asp, ep, ecode);

/* This entry returns stack header information which is relevant for a given stack frame */

dcl	(asp, ep)		ptr;
dcl	ecode		fixed bin (35);

	ecode = 0;

	if in_run &amp; (bin (rel (asp), 18) &lt; bin (rel (run_sp), 18))
	then do;
	     ep -&gt; env_ptrs = saved_ptrs;
	end;

	else do;					/* in run unit; return current info */
	     sb = ptr (addr (sb), 0);
	     ep -&gt; env_ptrs.lot_ptr = sb -&gt; stack_header.lot_ptr;
	     ep -&gt; env_ptrs.isot_ptr = sb -&gt; stack_header.isot_ptr;
	     ep -&gt; env_ptrs.clr_ptr = sb -&gt; stack_header.clr_ptr;
	     ep -&gt; env_ptrs.combined_stat_ptr = sb -&gt; stack_header.combined_stat_ptr;
	     ep -&gt; env_ptrs.user_free_ptr = sb -&gt; stack_header.user_free_ptr;
	     ep -&gt; env_ptrs.sys_link_info_ptr = sb -&gt; stack_header.sys_link_info_ptr;
	     ep -&gt; env_ptrs.rnt_ptr = sb -&gt; stack_header.rnt_ptr;
	     ep -&gt; env_ptrs.sct_ptr = sb -&gt; stack_header.sct_ptr;
	end;

	return;

stop_run:
     entry;

/* This entry is a command and is also called by the PL/I and fortran stop statements */

	if in_run
	then do;					/* set up structure for signalling finish */
	     finish_info.header.length = size (finish_info);
	     finish_info.header.version = 1;
	     string (finish_info.header.action_flags) = "0"b;
	     finish_info.header.default_restart = "1"b;
	     finish_info.header.info_string = "";
	     finish_info.header.status_code = 0;
	     finish_info.type = "run";
	     call signal_ ("finish", null, addr (finish_info));

	     goto static_abort_label;
	end;

	else do;
	     signal command_abort_;
	     return;
	end;

%include run_control_structure;

%include env_ptrs;


%include lot;

%include area_info;


%include area_structures;

%include rnt;

%include stack_header;

%include linkdcl;






%include system_link_names;

%include stack_frame;



%include condition_info_header;

%include condition_info;





     end;
�



		    set_fortran_common.pl1          11/20/86  1359.8rew 11/20/86  1142.5      191673



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



/****^  HISTORY COMMENTS:
  1) change(86-06-24,DGHowe), approve(86-06-24,MCR7420),
     audit(86-08-21,Schroth), install(86-11-20,MR12.0-1222):
     changed calling sequence for list_init_
  2) change(86-08-06,Elhard), approve(86-08-06,MCR7457),
     audit(86-08-22,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to look in all components of object MSFs for external links and
     to ignore external variables with deferred initialization.
                                                   END HISTORY COMMENTS */


/* format: style3,^indnoniterdo */
set_fortran_common:
sfc:
     proc;

/* This program finds the links to common blocks in the specified segments and obtains the
   initialization info from them.  If there are multiple initializations for the same
   common block, they are combined, with the longest length being used.    Then all the common
   blocks are initialized with the specified init info (allocated first if necessary).
*/
/* coded October 18, 1977 by Melanie Weaver */
/* modified December , 1977 by Melanie Weaver to increase dimensions and handle stat_ */
/* Modified: November 12, 1982 - T Oke, to handle Very Large Array COMMON.            */
/* modified January 1983 by Melanie Weaver to handle variables occupying a whole segment */
/* Modified November 1 1984 by M. Mabey to explicitly zero any variable that is          */
/*	reinitialized with list templates.				         */

/* AUTOMATIC */

dcl	(nargs, alng, i, j, nblocks)
			fixed bin;
dcl	(new_vsize, variable_size)
			fixed bin (35);
dcl	bitcnt		fixed bin (24);
dcl	type		fixed bin (18);
dcl	code		fixed bin (35);

dcl	(longsw, fatalsw, found_sw)
			bit (1) aligned;
dcl	block_end		bit (18) aligned;
dcl	dummy_init_info	bit (72) aligned;
dcl	k		fixed bin;
dcl	sys_areap		ptr;
dcl	sys_area		area based (sys_areap);
dcl	n_segs		fixed bin;
dcl	msf_sw		bit (1);

dcl	(aptr, seg_ptr, p, type_ptr, segnp, node_ptr, ext_ptr)
			ptr;
dcl	viptr		(2) ptr;


dcl	ext_name		char (65);
dcl	dir		char (168);
dcl	ent		char (32);
dcl	component_generator char (8);

dcl	1 seg_info	(1000) aligned based (viptr (2)),
	  2 pathname	char (168),
	  2 segp		ptr,
	  2 bc		fixed bin (24);

dcl	1 var_info	(10000) aligned based (viptr (1)),
	  2 init_ptr	ptr,
	  2 vsize		fixed bin (35),
	  2 init_owner	fixed bin,
	  2 name		char (65) unaligned;

dcl	1 oi		aligned like object_info;

/* CONSTANTS */

dcl	me		char (18) init ("set_fortran_common") static options (constant);
dcl	Fault_Tag_2	bit (6) aligned init ("100110"b) static options (constant);

/* EXTERNALS */

dcl	(addr, addrel, baseno, bin, bit, clock, divide, empty, 
	fixed, index, rel, max, null, ptr, substr, unspec)
			builtin;

dcl	cleanup		condition;

dcl	(
	error_table_$badopt,
	error_table_$bad_link_target_init_info
	)		ext fixed bin (35);
dcl	sys_info$max_seg_size
			ext fixed bin (35);
dcl	pl1_operators_$VLA_words_per_seg_
			fixed bin (19) external;

dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35));
dcl	(com_err_, ioa_)	entry options (variable);
dcl	get_system_free_area_
			entry () returns (ptr);
dcl	object_lib_$initiate
			entry (char (*), char (*), char (*), bit (1), ptr, fixed bin (24), bit (1), fixed bin (35));
dcl	object_lib_$get_component_info
			entry (ptr, ptr, char (8), char (*), ptr, fixed bin (35));
dcl	pathname_		entry (char (*), char (*)) returns (char (168));
dcl	object_info_$brief	entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl	set_ext_variable_	entry (char(*), ptr, ptr, bit(1) aligned,
		          ptr, fixed bin(35));
dcl	hcs_$terminate_noname
			entry (ptr, fixed bin (35));
dcl	(get_temp_segments_, release_temp_segments_)
			entry (char (*), (*) ptr, fixed bin (35));
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	unique_chars_	entry (bit (36)) returns (char (15));
dcl	list_init_	entry (ptr, ptr, fixed bin (35), ptr , ptr,
			fixed bin(35));
dcl	list_init_$variable_already_zero
			entry (ptr, ptr, fixed bin (35), ptr, ptr,
			fixed bin(35));

dcl	fortran_storage_manager_$alloc
			entry (fixed bin, ptr, ptr);
dcl	fortran_storage_manager_$free
			entry (ptr);


/* BASED */

dcl	arg		char (alng) based (aptr);
dcl	new_init_info	(new_vsize) fixed bin (35) based;
dcl	based_area	area (variable_size) based;
dcl	variable		(variable_size) bit (36) based;



dcl	1 acc_name	aligned based,
	  2 nsize		fixed bin (8) unal,
	  2 string	char (0 refer (acc_name.nsize)) unaligned;


/*  */
	nblocks = 0;
	n_segs = 0;
	longsw = "0"b;
	fatalsw = "0"b;
	sb = ptr (addr (sb), 0);
	lotp = sb -&gt; stack_header.lot_ptr;

	call cu_$arg_count (nargs);

	if nargs = 0
	then do;
	     call com_err_ (0, me, "Usage is:  set_fortran_common paths {-long}");
	     return;
	end;

	sys_areap = get_system_free_area_ ();

	viptr (1) = null;
	comp_infop = null;
	on cleanup
	     begin;
		if viptr (1) ^= null then do;
		     do i = 1 to n_segs;
			if seg_info (i).segp ^= null
			then call hcs_$terminate_noname (seg_info (i).segp, code);
		     end;
		     call release_temp_segments_ (me, viptr, code);
		end;
		if comp_infop ^= null
		then free component_info in (sys_area);
	     end;

	call get_temp_segments_ (me, viptr, code);

	do i = 1 to nargs;				/* first loop to find control args */
	     call cu_$arg_ptr (i, aptr, alng, code);
	     if (arg = "-long") | (arg = "-lg")
	     then do;
		longsw = "1"b;
		goto end_arg_loop;
	     end;
	     else if substr (arg, 1, 1) = "-"
	     then do;
		call com_err_ (error_table_$badopt, me, arg);
		fatalsw = "1"b;
	     end;
	     call expand_pathname_ (arg, dir, ent, code);
	     if code ^= 0
	     then do;
error1:
		call com_err_ (code, me, arg);
		fatalsw = "1"b;
		goto end_arg_loop;
	     end;

	     call object_lib_$initiate (dir, ent, "", "1"b, seg_ptr, bitcnt, msf_sw, code);
	     if code ^= 0
	     then do;
error2:
		call com_err_ (code, me, "^a&gt;^a", dir, ent);
		fatalsw = "1"b;
		goto end_arg_loop;
	     end;
	     seg_info (n_segs+1).segp = null;		/* initialize variable for cleanup handler. */
	     n_segs = n_segs + 1;

	     do j = 1 to n_segs - 1;			/* see if this arg is a duplicate */
		if seg_info (j).segp = seg_ptr
		then do;				/* already have this one */
		     n_segs = n_segs - 1;
		     goto end_arg_loop;
		end;
	     end;
	     seg_info (n_segs).segp = seg_ptr;
	     seg_info (n_segs).bc = bitcnt;
	     seg_info (n_segs).pathname = pathname_ (dir, ent);

	     if msf_sw
	     then do;
		call object_lib_$get_component_info (seg_ptr, sys_areap, component_info_version_1, "none", comp_infop, code);
		if code ^= 0
		then goto error2;

		do j = 1 to component_info.max;
		     seg_info (n_segs+1).segp = null;	/* initialize variable for cleanup handler. */
		     n_segs = n_segs + 1;

		     do k = 1 to n_segs - 1;		/* see if this arg is a duplicate */
			if seg_info (k).segp = component_info.comp (j).segp
			then do;			/* already have this one */
			     n_segs = n_segs - 1;
			     free component_info in (sys_area);
			     comp_infop = null;
			     goto end_arg_loop;
			end;
		     end;
		     seg_info (n_segs).segp = component_info.comp (j).segp;
		     seg_info (n_segs).bc = component_info.comp (j).bc;
		     seg_info (n_segs).pathname = pathname_ (dir, ent);
		end;

		free component_info in (sys_area);
		comp_infop = null;
	     end;

end_arg_loop:
	end;

	if fatalsw
	then goto terminate;

	do i = 1 to n_segs;				/* get object info and check for non fortran */

	     oi.version_number = object_info_version_2;
	     call object_info_$brief (seg_info (i).segp, seg_info (i).bc, addr (oi), code);
	     if code ^= 0
	     then goto error2;

/*
   .	     call get_bound_seg_info_ (seg_ptr, bitcnt, addr (oi), bmp, binder_sblkp, code);
   .	     if code ^= 0 then do;
   .		if code ^= error_table_$not_bound then goto error2;
   .		if (oi.compiler = "fortran") | (oi.compiler = "fortran2") then goto has_fortran;
   .	     end;
   .	     else do j = 1 to bmp -&gt; bindmap.n_components;
   .	          component_generator = addrel (oi.symbp, bmp -&gt; bindmap.component (j).symb_start)
   .	     	     -&gt; std_symbol_header.generator;
   .		if (component_generator = "fortran") | (component_generator = "fortran2")
   .		then goto has_fortran;
   .	     end;
   .
   .	     fatalsw = "1"b;
   .	     if code = 0 then call com_err_ (0, me, "^a does not have a fortran component.", arg);
   .	     else call com_err_ (0, me, "^a was not compiled by fortran.", arg);
   .
   .	     goto end_arg_loop;
   .
   .has_fortran:
*/
/* look through links for common */
	     if oi.linkp -&gt; virgin_linkage_header.defs_in_link = "010000"b
	     then block_end = rel (addrel (oi.linkp, oi.linkp -&gt; virgin_linkage_header.def_offset));
	     else block_end = rel (addrel (oi.linkp, oi.linkp -&gt; virgin_linkage_header.linkage_section_lng));

	     do p = addrel (oi.linkp, oi.linkp -&gt; header.stats.begin_links) repeat (addrel (p, 2))
		while (rel (p) &lt; block_end);

		if p -&gt; link.ft2 = Fault_Tag_2
		then do;				/* see if it is to common */
		     type_ptr = addrel (oi.defp, (addrel (oi.defp, p -&gt; link.exp_ptr) -&gt; exp_word.type_ptr));
		     type = bin (type_ptr -&gt; type_pair.type, 18);
		     if type = 5
		     then do;
			if bin (type_ptr -&gt; type_pair.seg_ptr, 18) = 5
						/* *system */
			then ext_name = addrel (oi.defp, type_ptr -&gt; type_pair.ext_ptr) -&gt; acc_name.string;
			else goto next_link;
		     end;
		     else if type = 6
		     then do;
			segnp = addrel (oi.defp, type_ptr -&gt; type_pair.seg_ptr);
			ext_ptr = addrel (oi.defp, type_ptr -&gt; type_pair.ext_ptr);
			if ext_ptr -&gt; acc_name.nsize = 0
			then do;
			     j = index (segnp -&gt; acc_name.string, ".com");
			     if (j = 0) | (j &lt; (segnp -&gt; acc_name.nsize - 3))
			     then goto next_link;
			     ext_name = substr (segnp -&gt; acc_name.string, 1, j - 1);
			     if ext_name = "b_"
			     then ext_name = "blnk*com";
			end;
			else if segnp -&gt; acc_name.string = "stat_"
			then ext_name = ext_ptr -&gt; acc_name.string;
			else if segnp -&gt; acc_name.string = "cobol_fsb_"
			then ext_name = "cobol_fsb_" || ext_ptr -&gt; acc_name.string;
			else goto next_link;
		     end;
		     else goto next_link;
		end;
		else goto next_link;		/* not a link */

		if type_ptr -&gt; type_pair.trap_ptr = "0"b
		then goto next_link;		/* no init info */
		init_info_ptr = addrel (oi.defp, type_ptr -&gt; type_pair.trap_ptr);

		do j = 1 to nblocks;		/* see if name is on list; if not, add it */
		     if ext_name = var_info (j).name
		     then do;			/* we do have name */
			if init_info_ptr -&gt; init_info.type &gt; NO_INIT
			     &amp; init_info_ptr -&gt; init_info.type ^= INIT_DEFERRED
			then do;			/* we have an init template */
			     if var_info (j).init_ptr -&gt; init_info.type = NO_INIT
			     then do;		/* now we have init template to use */
				var_info (j).init_ptr = init_info_ptr;
				var_info (j).init_owner = i;
			     end;
			     else if var_info (j).init_ptr -&gt; init_info.size &lt; init_info_ptr -&gt; init_info.size
			     then do;		/* have a larger template to use */
				call ioa_ (
				     "^a:  Initialization for common block ^a defined in subprogram ^a^/^-replacing initialization defined in subprogram ^a because it is longer.",
				     me, ext_name, seg_info (i).pathname,
				     seg_info (var_info (j).init_owner).pathname);
				var_info (j).init_ptr = init_info_ptr;
				var_info (j).init_owner = i;
			     end;
			     else do;		/* new template is same or smaller size */
				if unspec (var_info (j).init_ptr -&gt; init_info.init_template)
				     ^= unspec (init_info_ptr -&gt; init_info.init_template)
				then call ioa_ (
					"^a:  Initialization for common block ^a defined in subprogram ^a is ignored; ^/^-using initialization defined in subprogram ^a.",
					me, ext_name, seg_info (i).pathname,
					seg_info (var_info (j).init_owner).pathname);
			     end;
			end;
			var_info (j).vsize = max (var_info (j).vsize, init_info_ptr -&gt; init_info.size);
			goto next_link;
		     end;
		end;
		nblocks = nblocks + 1;

		var_info (nblocks).init_ptr = init_info_ptr;
		var_info (nblocks).vsize = init_info_ptr -&gt; init_info.size;
		var_info (nblocks).init_owner = i;
		var_info (nblocks).name = ext_name;
next_link:
	     end;
	end;

	if fatalsw
	then goto terminate;			/* we have gone as far as we can go */
	if nblocks = 0
	then do;
	     call ioa_ ("^a:  None of the specified programs have any common blocks.", me);
	     goto terminate;
	end;

/* now allocate/initialize all common blocks */

	do i = 1 to nblocks;
	     new_vsize = 0;
	     if var_info (i).vsize &gt; var_info (i).init_ptr -&gt; init_info.size
	     then do;				/* must make temp init info with correct size */
		if var_info (i).init_ptr -&gt; init_info.type = TEMPLATE_INIT
		then do;				/* must copy template */
		     new_vsize = var_info (i).vsize + 2;
		     allocate new_init_info in (sb -&gt; stack_header.user_free_ptr -&gt; based_area) set (init_info_ptr);
		     init_info_ptr -&gt; init_info.size = var_info (i).vsize;
		     init_info_ptr -&gt; init_info.type = TEMPLATE_INIT;
		     unspec (init_info_ptr -&gt; init_info.init_template) =
			unspec (var_info (i).init_ptr -&gt; init_info.init_template);
		end;
		else if var_info (i).init_ptr -&gt; init_info.type = LIST_TEMPLATE_INIT
		then do;				/* copy list template */
		     new_vsize = var_info (i).init_ptr -&gt; list_init_info.list_size + 3;
		     allocate new_init_info in (sb -&gt; stack_header.user_free_ptr -&gt; based_area) set (init_info_ptr);
		     unspec (init_info_ptr -&gt; list_init_info) = unspec (var_info (i).init_ptr -&gt; list_init_info);
		     init_info_ptr -&gt; init_info.size = var_info (i).vsize;
		end;
		else do;
		     init_info_ptr = addr (dummy_init_info);
		     init_info_ptr -&gt; init_info.size = var_info (i).vsize;
		     init_info_ptr -&gt; init_info.type = var_info (i).init_ptr -&gt; init_info.type;
		end;
	     end;
	     else init_info_ptr = var_info (i).init_ptr;	/* can use program's init info directly */

	     call set_ext_variable_ (var_info (i).name, init_info_ptr, sb,
		found_sw, node_ptr, code);
	     if code ^= 0
	     then if ^found_sw
		then do;
init_error:
		     call com_err_ (code, me, "Initializing common block ^a", var_info (i).name);
		     if new_vsize &gt; 0
		     then free init_info_ptr -&gt; new_init_info;
		     goto terminate;
		end;

	     if ^found_sw
	     then goto next_block;			/* allocated as specified */

	     if node_ptr -&gt; variable_node.vbl_size &lt; init_info_ptr -&gt; init_info.size
	     then do;				/* must reallocate and unsnap links */
		if longsw
		then call ioa_ (
			"^a:  Common block ^a is already in use with a smaller block length.^/^-The old version will be deleted.",
			me, var_info (i).name);
		call delete_it (node_ptr);
		variable_size = init_info_ptr -&gt; init_info.size;

		if variable_size &gt; sys_info$max_seg_size
		then do;
		     if (init_info_ptr -&gt; init_info.type ^= NO_INIT)
			&amp; (init_info_ptr -&gt; init_info.type ^= LIST_TEMPLATE_INIT)
		     then do;			/* multi-seg variable can't have template or area */
			code = error_table_$bad_link_target_init_info;
			go to init_error;
		     end;
		     call fortran_storage_manager_$alloc (
			divide (variable_size + pl1_operators_$VLA_words_per_seg_ - 1,
			pl1_operators_$VLA_words_per_seg_, 17), node_ptr, node_ptr -&gt; variable_node.vbl_ptr);
		end;
		else if variable_size &gt; (sys_info$max_seg_size - 50)
		then do;
		     call hcs_$make_seg ("", unique_chars_ (""b) || "linker", "", 01110b,
			node_ptr -&gt; variable_node.vbl_ptr, code);
		     if code ^= 0
		     then go to init_error;
		end;
		else allocate variable in (sb -&gt; stack_header.user_free_ptr -&gt; based_area)
			set (node_ptr -&gt; variable_node.vbl_ptr);

		node_ptr -&gt; variable_node.vbl_size = variable_size;
		node_ptr -&gt; variable_node.time_allocated = clock ();
		sb -&gt; stack_header.sys_link_info_ptr -&gt; variable_table_header.total_allocated_size =
		     sb -&gt; stack_header.sys_link_info_ptr -&gt; variable_table_header.total_allocated_size
		     + variable_size;
	     end;

/* reinitialize the variable; not worth checking to see if it's already OK */

	     variable_size = node_ptr -&gt; variable_node.vbl_size;

	     if init_info_ptr -&gt; init_info.type = NO_INIT
	     then call list_init_ (node_ptr -&gt; variable_node.vbl_ptr, 
		     null (), variable_size, null(), null(), code);

	     else if init_info_ptr -&gt; init_info.type = EMPTY_AREA_INIT
						/* this would not be a fortran link */
	     then node_ptr -&gt; variable_node.vbl_ptr -&gt; based_area = empty;

	     else if init_info_ptr -&gt; init_info.type = LIST_TEMPLATE_INIT
						/* list_template init */
	     then do;
		call list_init_ (node_ptr -&gt; variable_node.vbl_ptr,
		     null (), variable_size, null(), null(), code);
		call list_init_$variable_already_zero (
		     node_ptr -&gt; variable_node.vbl_ptr,
		     addr (init_info_ptr -&gt; list_init_info.template), 
		     variable_size, null(), null(), code);
	     end;
	     else unspec (node_ptr -&gt; variable_node.vbl_ptr -&gt; variable) =
		     unspec (init_info_ptr -&gt; init_info.init_template);


/* now check for possible errors from list init and set_ext_var */

               if code ^= 0 then
                 do;
                 call com_err_ (code,me, " while referencing ^a",
		  node_ptr-&gt;variable_node.name);
	       goto terminate;
                 end;

	     node_ptr -&gt; variable_node.init_type = init_info_ptr -&gt; init_info.type;

next_block:
	     node_ptr -&gt; variable_node.init_ptr = var_info (i).init_ptr;
						/* fill in with permanent address */
	     if new_vsize &gt; 0
	     then free init_info_ptr -&gt; new_init_info;
	end;

/* now terminate noname everything that was known before the command was invoked */

terminate:
	do i = 1 to n_segs;
	     if seg_info (i).segp ^= null
	     then call hcs_$terminate_noname (seg_info (i).segp, code);
	end;


	if viptr (1) ^= null
	then call release_temp_segments_ (me, viptr, code);

	return;

/*  */
delete_it:
     proc (np);

/* This procedure unsnaps the links to an external variable and then frees it */

dcl	(np, headptr, defstartptr, linkstartptr, itsptr, vlp, lptr, vptr)
			ptr;
dcl	based_ptr		ptr based;
dcl	based_double	bit (72) aligned based;
dcl	(segno, hcscnt, high_seg)
			fixed bin;
dcl	vsize		fixed bin (35);
dcl	old_variable	(vsize) bit (36) based;
dcl	hcs_$high_low_seg_count
			entry (fixed bin, fixed bin);
dcl	delete_$ptr	entry (ptr, bit (6), char (*), fixed bin (35));

	vptr = np -&gt; variable_node.vbl_ptr;		/* get value links would have */

	call hcs_$high_low_seg_count (high_seg, hcscnt);

	do segno = hcscnt + 1 to hcscnt + high_seg;
	     if rel (lotp -&gt; lot.lp (segno)) ^= "0"b
	     then do;
		headptr = lotp -&gt; lot.lp (segno);
		defstartptr = headptr -&gt; header.def_ptr;/* pointer to beginning of def section */
		linkstartptr = addrel (headptr, headptr -&gt; header.stats.begin_links);

/* check for defs in linkage section and compute end of links */

		if (baseno (linkstartptr) = baseno (defstartptr))
		     &amp; (fixed (rel (defstartptr), 18) &gt; fixed (rel (linkstartptr), 18))
		then block_end = rel (defstartptr);	/* end of links before end of block if defs follow links */

		else block_end = rel (addrel (headptr, headptr -&gt; header.stats.block_length));
						/* end of links and of block are the same */

		do itsptr = linkstartptr repeat (addrel (itsptr, 2)) /* loop through all links */
		     while (rel (itsptr) &lt; block_end);
		     if itsptr -&gt; its.its_mod = "100011"b
		     then do;			/* snapped link */
			lptr = itsptr -&gt; based_ptr;	/* copy to pick up any indirection */
			if lptr = vptr
			then do;			/* have a link pointing to the variable; unsnap */
			     vlp = headptr -&gt; header.original_linkage_ptr;
			     itsptr -&gt; based_double =
				addrel (vlp, bit (bin (bin (rel (itsptr), 18) - bin (rel (headptr), 18), 18)))
				-&gt; based_double;
			end;
		     end;
		end;
	     end;
	end;

/* now free the variable */

	vsize = np -&gt; variable_node.vbl_size;

	if vsize &gt; sys_info$max_seg_size
	then call fortran_storage_manager_$free (np);

	else if rel (np -&gt; variable_node.vbl_ptr) = "0"b	/* separate seg was created outside area */
	then call delete_$ptr (np -&gt; variable_node.vbl_ptr, "010100"b, me, code);

	else free np -&gt; variable_node.vbl_ptr -&gt; old_variable;

	np -&gt; variable_node.vbl_ptr = null;
	sb -&gt; stack_header.sys_link_info_ptr -&gt; variable_table_header.total_allocated_size =
	     sb -&gt; stack_header.sys_link_info_ptr -&gt; variable_table_header.total_allocated_size - vsize;

	return;

     end;						/* of delete_it */


%page;
/* Include Files */
%include system_link_names;
%page;
%include system_link_init_info;
%page;
%include object_info;
%page;
%include linkdcl;
%page;
%include stack_header;
%page;
%include lot;
%page;
%include its;
%page;
%include std_symbol_header;
%page;
%include object_lib_defs;

     end;
���



		    string.pl1                      11/04/82  2003.4rew 11/04/82  1630.9       48816



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



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* string		an active function which returns its input arguments, strung together	*/
	/*		in a quoted character string and separated by blanks.  An arbitrary	*/
	/*		number of input arguments can be handled (0 to infinite).  The only	*/
	/* 		bound on their number of length is the maximum command line size.	*/
	/*		When invoked as a command, string has the effect of:		*/
	/*			ioa_ [string ...]					*/
	/*									*/
	/* U__s_a_g_e									*/
	/*									*/
	/* 	[string arg1_ ... arg_n]						*/
	/* or      string arg1_ ... arg_n						*/
	/*									*/
	/* 1) arg_i	are optional input arguments which are returned as a single quoted	*/
	/*		string.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/* TR7417, call iox_$put_chars only once for command invocation  10/31/80 S. Herbst */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


string:	procedure;				/* active function which returns its input args,	*/
						/* separated by blanks, as a quoted string.	*/

     dcl						/*	automatic variables			*/
	Larg			fixed bin (21),	/* length of an input arg.			*/
	Lmax			fixed bin (21),	/* max estimate for string to print 		*/
	Lret			fixed bin (21),	/* maximum length of our return value.		*/
	Nargs			fixed bin,	/* number of arguments we were passed.		*/
	Parg			ptr,		/* ptr to an input argument.			*/
	Parg_list			ptr,		/* ptr to the argument list 			*/
	Pret			ptr,		/* ptr to our return value.			*/
	code			fixed bin (35),	/* an error code value.			*/
	i			fixed bin;	/* a do-group index.			*/


     dcl						/*	based variables			*/
	arg			char(Larg) based (Parg),
						/* an input argument.			*/
	ret			char(Lret) varying based (Pret);
						/* overlay for portions of our return value.	*/


     dcl (addr, addrel, length, search)	builtin;


     dcl						/*	entries				*/
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin (21), fixed bin(35)),
         (cu_$af_arg_ptr,
	cu_$arg_ptr)		entry (fixed bin, ptr, fixed bin (21), fixed bin(35)),
	cu_$arg_list_ptr		entry (ptr),
	cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	iox_$put_chars		entry (ptr, ptr, fixed bin, fixed bin(35));


     dcl						/*	static variables			*/
	NL			char(1) int static init ("
"),
	SPACE			char(1) int static init (" "),
	iox_$user_output		ptr ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	call cu_$af_return_arg (Nargs, Pret, Lret, code);	/* see how we were called.			*/
	if code = 0 then do;			/* as an active function.			*/
	     if Nargs = 0 then do;			/* no input args.  Return a null string.	*/
		ret = """""";
		return;
		end;
	     ret = """";
	     call cu_$af_arg_ptr (1, Parg, Larg, code);	/* add first argument to return string.		*/
	     if search (arg, """") &gt; 0 then
		ret = ret || double_quotes (arg);
	     else ret = ret || arg;
	     do i = 2 to Nargs;			/* add remaining args to return string.		*/
		ret = ret || " ";
		call cu_$af_arg_ptr (i, Parg, Larg, code);
		if search (arg, """") &gt; 0 then
		     ret = ret || double_quotes (arg);
		else ret = ret || arg;
		end;
	     ret = ret || """";
	     end;
	else do;					/* command merely output's its args, separated by	*/
	     Lmax = 1;				/* allow for NL always */
	     do i = 1 to Nargs;
		call cu_$arg_ptr (i, Parg, Larg, code);
		Lmax = Lmax + Larg + 1;
	     end;

	     call cu_$arg_list_ptr (Parg_list);
begin;

dcl the_string char (Lmax) varying;
dcl i fixed bin;

	     the_string = "";
	     do i = 1 to Nargs;
		call cu_$arg_ptr_rel (i, Parg, Larg, code, Parg_list);
		if i ^= 1 then the_string = the_string || SPACE;
		the_string = the_string || arg;
	     end;
	     the_string = the_string || NL;
	     call iox_$put_chars (iox_$user_output, addrel (addr (the_string), 1), length (the_string), code);
end;
	     end;

double_quotes:	procedure (string) returns (char(*) varying);
						/* internal procedure to double all quotes in	*/
						/* a "to be quoted" string.			*/

     dcl	string			char(*);

     dcl (i, j)			fixed bin;


     dcl	copied_string		char(length(string)*2) varying;

     dcl	string_begin		char(i-1) based (addr(string_array(j))),
	string_end		char(length(string)-(j-1)) based(addr(string_array(j))),
	string_array (length(string))	char(1) based (addr(string));

	i = search(string,"""");
	if i = 0 then return(string);
	j = 1;
	copied_string = "";
	do while (i &gt; 0);
	     copied_string = copied_string || string_begin;
	     copied_string = copied_string || """""";
	     j = i+j;
	     i = search (string_end, """");
	     end;
	copied_string = copied_string || string_end;
	return (copied_string);


	end double_quotes;


	end string;




		    system.pl1                      06/09/89  1257.9rew 06/09/89  1255.3      119340



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




/****^  HISTORY COMMENTS:
  1) change(89-04-28,Vu), approve(89-04-28,MCR8100), audit(89-05-05,Lee),
     install(89-06-09,MR12.3-1057):
     use the process date_time format rather than the concatenation of the
     process date and time format for all keywords starting with date_time_**.
                                                   END HISTORY COMMENTS */


system: proc;

/*
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.(UNCA)
   Changed to requote return string 03/19/80 S. Herbst
   Modified June 1981 by E. N. Kittlitz for UNCA rate structures

   Modified Sept 1982 by Linda Pugh to add date_time_XXX and default_absentee_queue
   keys.  The following key words are obsolete and are no longer documented;
   however, they are retained for compatibility (time_up, next_down_time,
   down_until time, shift_change_time, date_up, next_down_date, last_down_time,
   last_down date, shift_change_date, down_until_date)

   Modified May 1983 by Art Beattie to add version_id key word.
   Modified 10/3/83 by C Spitzer to add all keyword, printed in sorted list
			   make last_down_reason return  ERFnn instead of just nn.
   Modified 06/19/84 by J A Falksen to utilize date_time_$format with keywords
			   "date", "time", and "date_time".
   Modified 840619 for session_type keyword, and to make ERF DUMP... -E. A. Ranzenbach
   Modified 841113 to put back BIM's trusted_path_login keyword that was mistakenly backed out
   by the date_time_$format installation...
*/

dcl  ap ptr,					/* ptr to argument */
     al fixed bin (21),				/* lth of argument */
     bchr char (al) based (ap) unal,			/* argument */
     answer char (al) varying based (ap);		/* return argument */

dcl  time fixed bin (71),
     nactsw bit (1),
     all_switch bit (1) aligned,
     stp_sw bit (36) aligned,
     switch fixed bin,
     host_num fixed binary (16),
     ec fixed bin (35),
     rs_number fixed bin,
     rs_name char (32),
     tli fixed bin (71),
     wd char (9) aligned,
     dn char (168),
     j fixed bin,
    (t1, t2) fixed bin,
     i35 fixed bin (35),
     string char (300) varying init ("");
dcl  max_rs_number fixed bin;
dcl  default_q fixed bin;

dcl  error entry options (variable) variable;
dcl  get_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable;

dcl  inarg char (32) aligned;


dcl  item (38) char (32) aligned int static options (constant) init (
     "ARPANET_host_number",				/* case 1 */
     "company",					/* case 2 */
     "date_time_last_down",				/* case 3 */
     "date_time_last_up",				/* case 4 */
     "date_time_next_down",				/* case 5 */
     "date_time_next_up",				/* case 6 */
     "date_time_shift_change",			/* case 7 */
     "date_up",					/* case 8 */
     "default_absentee_queue",			/* case 9 */
     "department",					/* case 10 */
     "down_until_date",				/* case 11 */
     "down_until_time",				/* case 12 */
     "ds_company",					/* case 13 */
     "ds_department",				/* case 14 */
     "installation_id",				/* case 15 */
     "last_down_date",				/* case 16 */
     "last_down_reason",				/* case 17 */
     "last_down_time",				/* case 18 */
     "max_rate_structure_number",			/* case 19 */
     "max_units",					/* case 20 */
     "max_users",					/* case 21 */
     "n_units",					/* case 22 */
     "n_users",					/* case 23 */
     "next_down_date",				/* case 24 */
     "next_down_time",				/* case 25 */
     "next_shift",					/* case 26 */
     "rate_structure_name",				/* case 27 */
     "rate_structure_number",				/* case 28 */
     "reason_down",					/* case 29 */
     "shift",					/* case 30 */
     "shift_change_date",				/* case 31 */
     "shift_change_time",				/* case 32 */
     "sysid",					/* case 33 */
     "time_up",					/* case 34 */
     "version_id",					/* case 35 */
     "session_type",				/* case 36 */
     "trusted_path_login",				/* case 37 */
     "all");					/* MUST BE LAST */

dcl  error_table_$badopt fixed bin (35) ext,
     error_table_$bad_arg fixed bin (35) ext,
     error_table_$not_act_fnc fixed bin (35) ext;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     active_fnc_err_ entry options (variable),
     com_err_ entry options (variable),
     ioa_ entry options (variable),
     date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
     requote_string_ entry (char (*)) returns (char (*)),
     system_info_$installation_id entry (char (*)),
     system_info_$sysid entry (char (*)),
     system_info_$session entry (char (*)),
     system_info_$trusted_path_flags entry (bit(36) aligned),
     system_info_$version_id entry (char (*)),
     system_info_$titles entry options (variable),
     system_info_$users entry options (variable),
     system_info_$timeup entry (fixed bin (71)),
     system_info_$next_shutdown entry options (variable),
     system_info_$next_shift_change entry options (variable),
     system_info_$last_shutdown entry options (variable),
     system_info_$ARPANET_host_number entry (fixed bin (16)),
     system_info_$rs_number entry (char (*), fixed bin, fixed bin (35)),
     system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)),
     system_info_$max_rs_number entry (fixed bin),
     system_info_$default_absentee_queue entry (fixed bin),
     ioa_$rsnnl entry options (variable);

dcl (hbound, ltrim, rtrim) builtin;

/* ======================================================= */

	call cu_$af_arg_ptr (1, ap, al, ec);
	if ec = error_table_$not_act_fnc then do;
	     error = com_err_;
	     get_arg = cu_$arg_ptr;
	     call get_arg (1, ap, al, ec);
	     nactsw = "1"b;
	end;
	else do;
	     error = active_fnc_err_;
	     get_arg = cu_$af_arg_ptr;
	     nactsw = "0"b;
	end;
	if ec ^= 0 then do;
er:	     call error (ec, "system");
	     return;
	end;
	inarg = bchr;

	all_switch = "0"b;
	do switch = 1 to hbound (item, 1);
	     if inarg = item (switch) then go to have_good_item;
	end;
	call error (error_table_$badopt, "system", """^a""", inarg);
	return;

have_good_item:
	if switch = hbound (item, 1)
	then if nactsw
	     then do;
		all_switch = "1"b;
		switch = 1;
		end;
	     else do;
		call error (error_table_$bad_arg, "system", "^a", inarg);
		end;

ok:	go to case (switch);

case (15):					/* installation_id */
	call system_info_$installation_id (dn);
rtrim_string:
	string = rtrim (dn);
	go to exit;
case (33):					/* sysid */
	call system_info_$sysid (dn);
	go to rtrim_string;
case (37): 					/* trusted_path_login */
	call system_info_$trusted_path_flags (stp_sw);
	if stp_sw then dn = "true";
	else dn = "false";
	go to rtrim_string;

case (36):					/* session_type */
	call system_info_$session (dn);
	go to rtrim_string;
case (2):						/* company */
	call system_info_$titles (dn, wd, wd, wd);
	go to rtrim_string;
case (10):					/* department */
	call system_info_$titles (wd, dn, wd, wd);
	go to rtrim_string;
case (13):					/* ds_company */
	call system_info_$titles (wd, wd, dn, wd);
	go to rtrim_string;
case (14):					/* ds_department */
	call system_info_$titles (wd, wd, wd, dn);
	go to rtrim_string;
case (21):					/* max_users */
	call system_info_$users (t1, t2, t2, t2);
cv_num:
	call ioa_$rsnnl ("^d", string, j, t1);
	go to exit;
case (23):					/* n_users */
	call system_info_$users (t2, t1, t2, t2);
	go to cv_num;
case (20):					/* max_units */
	call system_info_$users (t2, t2, t1, t2);
cv_float:
	call ioa_$rsnnl ("^.1f", string, j, t1*1e-1);
	go to exit;
case (22):					/* n_units */
	call system_info_$users (t2, t2, t2, t1);
	go to cv_float;
case (34):					/* time_up */
	call system_info_$timeup (tli);
cv_time:
	string = date_time_$format ("time",tli,"","");
	go to exit;
case (25):					/* next_down_time */
	call system_info_$next_shutdown (tli);
	if tli = 0 then do;
notime:	     string = "none";
	     go to exit;
	end;
	go to cv_time;
case (12):					/* down_until_time */
	call system_info_$next_shutdown (time, dn, tli);
	if time = 0 then go to notime;
	if tli = 0 then go to notime;
	go to cv_time;
case (29):					/* reason_down */
	call system_info_$next_shutdown (tli, dn);
	if tli = 0 then go to notime;
	go to rtrim_string;
case (30):					/* shift */
	call system_info_$next_shift_change (t1, tli, t2);
	go to cv_num;
case (32):					/* shift_change_time */
	call system_info_$next_shift_change (t1, tli, t2);
	go to cv_time;
case (26):					/* next_shift */
	call system_info_$next_shift_change (t2, tli, t1);
	go to cv_num;
case (8):						/* date_up */
	call system_info_$timeup (tli);
cv_date:
	string = date_time_$format ("date",tli,"","");
	go to exit;
case (24):					/* next_down_date */
	call system_info_$next_shutdown (tli);
	if tli = 0 then go to notime;
	go to cv_date;
case (11):					/* down_until_date */
	call system_info_$next_shutdown (time, dn, tli);
	if time = 0 then go to notime;
	if tli = 0 then go to notime;
	go to cv_date;
case (31):					/* shift_change_date */
	call system_info_$next_shift_change (t1, tli, t2);
	go to cv_date;
case (18):					/* last_down_time */
	call system_info_$last_shutdown (tli);
	go to cv_time;
case (16):					/* last_down_date */
	call system_info_$last_shutdown (tli);
	go to cv_date;
case (17):					/* last_down_reason */
	call system_info_$last_shutdown (tli, dn);
	go to rtrim_string;
case (1):						/* ARPANET_host_number */
	call system_info_$ARPANET_host_number (host_num);
	t1 = host_num;
	go to cv_num;
case (28):					/* rate_structure_number */
	string = "";
	call get_arg (2, ap, al, ec);
	if ec ^= 0
	then if all_switch
	     then goto exit;
	     else go to er;
	call system_info_$rs_number (bchr, rs_number, ec);
	if ec ^= 0 then do;
	     call error (ec, "system", "Rate structure name ""^a"".", bchr);
	     if all_switch then goto exit;
	     else return;
	end;
	t1 = rs_number;
	go to cv_num;
case (27):					/* rate_structure_name */
	call system_info_$max_rs_number (max_rs_number);
	string = "";
	call get_arg (2, ap, al, ec);
	if ec = 0 then do;
	     i35 = cv_dec_check_ (bchr, ec);
	     if ec ^= 0 then do;
rs_nm_error:	ec = error_table_$bad_arg;
		call error (ec, "system", "Rate structure number ^a.", bchr);
		if all_switch then goto exit;
		else return;
	     end;
	     if i35 &lt; 0 | i35 &gt; max_rs_number then go to rs_nm_error; /* outside capbility of rs_number? */
	     rs_number = i35;
	     call system_info_$rs_name (rs_number, rs_name, ec);
	     if ec ^= 0 then goto rs_nm_error;
	     string = rtrim (ltrim (rs_name));
	end;
	else do rs_number = 0 to max_rs_number;
	     call system_info_$rs_name (rs_number, rs_name, ec);
	     if ec ^= 0 then go to exit;
	     if string ^= "" then string = string || " ";
	     string = string || rtrim (rs_name);
	end;
	go to exit;
case (19):					/* max_rate_structure_number */
	call system_info_$max_rs_number (rs_number);
	t1 = rs_number;
	go to cv_num;
case (4):						/* date_time_last_up */
	call system_info_$timeup (tli);
cv_date_time:

/**** vp: phx19051; use the process date_time format rather than the
      concatenation of the process date and time for all keywords 
      starting with date_time_**                                      ****/

          string = date_time_$format ("date_time",tli,"","");
	go to exit;
case (5):						/* date_time_next_down */
	call system_info_$next_shutdown (tli);
	if tli = 0 then go to notime;
	go to cv_date_time;
case (6):						/* date_time_next_up */
	call system_info_$next_shutdown (time, dn, tli);
	if time = 0 then go to notime;
	if tli = 0 then go to notime;
	go to cv_date_time;
case (3):						/* date_time_last_down */
	call system_info_$last_shutdown (tli);
	go to cv_date_time;
case (7):						/* date_time_shift_change */
	call system_info_$next_shift_change (t1, tli, t2);
	go to cv_date_time;
case (9):						/* default_absentee_queue */
	call system_info_$default_absentee_queue (default_q);
	t1 = default_q;
	go to cv_num;
case (35):					/* version_id */
	call system_info_$version_id (dn);
	go to rtrim_string;

exit:	if all_switch then do;
	     if string ^= "" then call ioa_ ("^a:^28t^a", item (switch), string);
	     switch = switch + 1;
	     if switch = hbound (item, 1) then return;
	     else goto ok;
	     end;
	else if nactsw then do;
		call ioa_ ("^a", string);
		return;
	     end;
	call cu_$af_return_arg (j, ap, al, ec);
	if ec ^= 0 then go to er;
	answer = requote_string_ ((string));

     end;




		    user.pl1                        07/13/88  1113.9rew 07/13/88  0905.4      195984



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


/* format: style4 */
user: procedure options (variable);

/* USER - active function to return user parameters */


/****^  HISTORY COMMENTS:
  1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370),
     audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082):
     First comment for hcom.
     
     Modified April 1979 by T. Casey for MR7.0a to return "foreground" from [user abs_queue] in foreground job
     initial_term_(id type) added and term_(id type) changed to return current info. 09/12/79 S. Herbst
     Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA).
     Modified June 1981 by E. N. Kittlitz for UNCA rate structures
     Modified Augues 30 1981 by William M. York to add accounting keywords
     (limit, monthly_limit, cutoff_date, shift_limit, spending, monthly_spending,
     shift_spending, and limit_type), to clean up the code, and add comments
     to each action
     Modified October 1982 by E. N. Kittlitz for request_id
     Added 256K (256k) keyword 07/14/83 S. Herbst
     Added all keyword, printed in sorted list  10/3/83 C Spitzer
     Modified 1984-07-28 BIM to implement all in maintainable way,
     add auth_range, min_auth.
     Modified 1984-09-13 by JAFalksen, to utilize date_time_$format("date"|"time"|"date_time"
     Modified 1984-12-05 BIM: fixed dcl of user_info_$attributes
     Modified 1984-12-05 C Spitzer. fix subscriptrange errors
  2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370),
     audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082):
     Add the keywords absout_truncation, absentee_restarted for -truncate
     absout, SCP6297.
  3) change(87-11-30,Parisek), approve(88-02-11,MCR7849),
     audit(88-03-07,Lippard), install(88-07-13,MR12.2-1047):
     Added the min_ring, max_ring, &amp; ring_range keywords. SCP6367
                                                   END HISTORY COMMENTS */


dcl  alp pointer;
dcl  ap ptr,					/* ptr to argument */
     al fixed bin (21),				/* lth of argument */
     all_switch bit (1) aligned,
     bchr char (al) based (ap) unal,			/* argument */
     answer char (al) varying based (ap);		/* return argument */

dcl  time fixed bin (71),
     nactsw bit (1),
     (got_login_data, got_auth, got_limits) bit (1) aligned,
     term_id_sw bit (1),
     K256_switch bit (2) aligned,
     switch fixed bin,
     ec fixed bin (35),
     attr char (300) varying,
     (nm, pj, ac, grp) char (32),
     f float bin,
     (an, sb, wt) fixed bin,
     (tli, ocpu) fixed bin (71),
     wd char (9),
     dn char (168),
     id char (8),
     (np, pf, pp) fixed bin,
     tt char (32),
     (i, n) fixed bin,
     b36 bit (36),
     (auth, max_auth) bit (72) aligned,
     auth_range (2) bit (72) aligned,
     rs_number fixed bin,
     string char (300) varying,
     auth_string char (644),
     (absolute_limit, absolute_spending, monthly_limit, monthly_spending) float bin,
     (shift_limits, shift_spendings) dimension (0:7) float bin,
     cutoff_date fixed bin (71),
     limit_type fixed bin,
     current_shift fixed bin,
     fb71 fixed bin (71),
     char19 char (19),
     (truncate, restarted) bit (1),
     rg_range (2) fixed bin,
     ring_string char (3);

dcl  process_type (0:3) char (12) static options (constant)
	init ("initializer", "interactive", "absentee", "daemon");

dcl  service_type (0:7) char (8) static options (constant)
	init ("unknown", "login", "FTP", "MC", "slave", "type5", "autocall", "inactive");

%include line_types;
%include iocbx;

dcl  1 terminal_info aligned,
       2 version fixed bin init (1),
       2 id char (4) unaligned,
       2 term_type char (32) unaligned,
       2 line_type fixed bin,
       2 baud_rate fixed bin,
       2 reserved (4) fixed bin;

dcl  inarg char (24);

/* The following 3 arrays MUST all be dimensioned at the same size.
ITEM_ALPHA_ORDER indicates what order each data item is printed in when we find
the "all" keyword (use a 0 for a place holder if it is not to be printed for
"all"). item is the array of implemented keywords in no special order. New
ones may be added on the end of the list. user_data indicates which of the 3
types of user_info_ data must be retrieved to implement the keyword. If none
of them are correct, use a 0 as a place holder. */

dcl  ITEM_ALPHA_ORDER (58) fixed bin int static options (constant) init (1, 2, 3, 4, 54, 5, 6, 7, 55, 8, 9, 0, 11, 12, 0, 53, 56, 57, 58, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 0, 28, 29, 0, 51, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49);
dcl  item (58) char (24) aligned int static options (constant) init (
	"256k_switch",				/* case 1  */
	"abs_queue",				/* case 2  */
	"absentee",				/* case 3  */
	"absentee_request_id",			/* case 4  */
	"absin",					/* case 5  */
	"absout",					/* case 6  */
	"account",				/* case 7  */
	"anonymous",				/* case 8  */
	"attributes",				/* case 9  */
	"auth",					/* case 10 */
	"auth_long",				/* case 11 */
	"brief_bit",				/* case 12 */
	"charge_type",				/* case 13 */
	"cpu_secs",				/* case 14 */
	"cutoff_date",				/* case 15 */
	"device_channel",				/* case 16 */
	"group",					/* case 17 */
	"initial_term_id",				/* case 18 */
	"initial_term_type",			/* case 19 */
	"limit",					/* case 20 */
	"limit_type",				/* case 21 */
	"line_type",				/* case 22 */
	"log_time",				/* case 23 */
	"login_date",				/* case 24 */
	"login_time",				/* case 25 */
	"login_word",				/* case 26 */
	"max_auth",				/* case 27 */
	"max_auth_long",				/* case 28 */
	"monthly_limit",				/* case 29 */
	"monthly_spending",				/* case 30 */
	"n_processes",				/* case 31 */
	"name",					/* case 32 */
	"outer_module",				/* case 33 */
	"preemption_time",				/* case 34 */
	"process_id",				/* case 35 */
	"process_overseer",				/* case 36 */
	"process_type",				/* case 37 */
	"project",				/* case 38 */
	"protected",				/* case 39 */
	"rate_structure_name",			/* case 40 */
	"rate_structure_number",			/* case 41 */
	"secondary",				/* case 42 */
	"service_type",				/* case 43 */
	"shift_limit",				/* case 44 */
	"shift_spending",				/* case 45 */
	"spending",				/* case 46 */
	"term_id",				/* case 47 */
	"term_type",				/* case 48 */
	"weight",					/* case 49 */
	"min_auth",				/* case 50 */
	"min_auth_long",				/* case 51 */
	"auth_range",				/* case 52 */
	"auth_range_long",				/* case 53 */
	"absentee_restarted",			/* case 54 */
	"absout_truncation",			/* case 55 */
          "min_ring",				/* case 56 */
          "max_ring",				/* case 57 */
          "ring_range");				/* case 58 */

dcl  user_data (58) fixed bin int static options (constant) init
	((6) 0, 1, 1, 0, 2, 2, 0, 0, 0, 3, (4) 0, 3, 3, 0, (4) 1, 2, 2,
	3, 3, 0, 1, (5) 0, 1, 0, 0, 0, 1, 0, 0, 3, 3, 0, 0, 1, (4) 0, 0, 0,
          0, 0, 0);

dcl  item_synonyms (3) char (24) int static options (constant) init
	("abs_rqid", "256k", "256K");
dcl  item_synonyms_position (3) fixed bin int static options (constant) init (4, 1, 1);

dcl  error_table_$not_act_fnc fixed bin (35) ext;
dcl  error_table_$badopt fixed bin(35) ext static;

dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  get_process_id_ entry () returns (bit (36));
dcl  cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  active_fnc_err_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$user_io ptr external;
dcl  date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  user_info_$authorization_range entry ((2) bit (72) aligned);
dcl  user_info_$login_data entry options (variable);
dcl  user_info_$absin entry (char (*));
dcl  user_info_$absout entry (char (*));
dcl  (user_info_$absout_truncation, user_info_$absentee_restarted) entry (bit(1));
dcl  user_info_$outer_module entry (char (*));
dcl  user_info_$attributes entry (char (*) varying);
dcl  user_info_$service_type entry (fixed bin);
dcl  user_info_$process_type entry (fixed bin);
dcl  user_info_$terminal_data entry options (variable);
dcl  user_info_$responder entry (char (*));
dcl  user_info_$usage_data entry options (variable);
dcl  user_info_$load_ctl_info entry options (variable);
dcl  user_info_$absentee_queue entry (fixed bin);
dcl  user_info_$rs_name entry (char (*));
dcl  user_info_$rs_number entry (fixed bin);
dcl  user_info_$limits entry (float bin, float bin, fixed bin (71), fixed bin,
	(0:7) float bin, float bin, float bin, (0:7) float bin);
dcl  user_info_$absentee_request_id entry (fixed bin (71));
dcl  user_info_$ring_range entry ((2) fixed bin);
dcl  system_info_$next_shift_change entry (fixed bin, fixed bin (71), fixed bin, fixed bin (71));
dcl  hcs_$get_usage_values entry (fixed bin, fixed bin (71), fixed bin);
dcl  hcs_$get_authorization entry (bit (72) aligned, bit (72) aligned);
dcl  hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35));
dcl  convert_access_class_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_range entry ((2) bit (72) aligned, character (*), fixed binary (35));
dcl  convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, character (*),
	fixed binary (35));
dcl  request_id_ entry (fixed bin (71)) returns (char (19));
dcl  ioa_$rsnnl entry options (variable);

dcl  (addr, clock, hbound, index, ltrim, rtrim) builtin;

/* ======================================================= */

	all_switch, nactsw, got_limits, got_auth, got_login_data = "0"b;
	call cu_$arg_list_ptr (alp);
	call cu_$af_arg_ptr (1, ap, al, ec);
	if ec = error_table_$not_act_fnc then do;
	     call cu_$arg_ptr (1, ap, al, ec);
	     nactsw = "1"b;
	end;
	if ec ^= 0 then do;
er:	     if nactsw then call com_err_ (ec, "user", "");
	     else call active_fnc_err_ (ec, "user", "");
	     return;
	end;
	inarg = bchr;

	if inarg = "all" then all_switch = "1"b;
	else do;
	     do switch = 1 to hbound (item, 1);
		if inarg = item (switch) then go to have_good_item;
	     end;
	     do switch = 1 to hbound (item_synonyms, 1);
		if inarg = item_synonyms (switch) then do;
		     switch = item_synonyms_position (switch);
		     goto have_good_item;
		end;
	     end;
	     if nactsw then call com_err_ (0, "user", "Invalid keyword: ^a", inarg);
	     else call active_fnc_err_ (0, "user", "Invalid keyword: ^a", inarg);
	     return;
	end;

have_good_item:
	if all_switch &amp; ^nactsw then do;
	     call active_fnc_err_ (error_table_$badopt, "user", "The ""all"" keyword is invalid in an active function invocation.");
	     return;
	end;

	if all_switch then
	     do i = 1 to 3;
	     call get_user_data (i);
	end;
	else
	     call get_user_data (user_data (switch));


	if all_switch then do i = 1 to hbound (ITEM_ALPHA_ORDER, 1);
	     if ITEM_ALPHA_ORDER (i) ^= 0 then call process_one_item (ITEM_ALPHA_ORDER (i));
	end;
	else call process_one_item (switch);
	return;


get_user_data:
     proc (type);

dcl  type fixed bin;

	if type = 1 then call user_info_$login_data (nm, pj, ac, an, sb, wt, tli, wd);
	else if type = 2 then call hcs_$get_authorization (auth, max_auth);
	else if type = 3 then call user_info_$limits (monthly_limit, absolute_limit, cutoff_date,
		limit_type, shift_limits, monthly_spending, absolute_spending, shift_spendings);

	return;
     end get_user_data;

process_one_item:
     procedure (switch) options (non_quick);
declare  switch fixed bin;
declare  i fixed bin;

	go to case (switch);

case (32):					/* name */
	dn = nm;
	go to j1;

case (38):					/* project */
	dn = pj;
	go to j1;

case (7):						/* account */
	dn = ac;
	go to j1;

case (25):					/* login_time */
j3:	string = date_time_$format ("time", tli, "", "");
	go to exit;

case (24):					/* login_date */
	string =  date_time_$format ("date", tli, "", "");
	go to exit;

case (8):						/* anonymous */
	if an = 1 then string = "true";
	else string = "false";
	go to exit;

case (42):					/* secondary */
	if sb = 1 then string = "true";
	else string = "false";
	go to exit;

case (49):					/* weight */
	f = wt / 1e1;
	go to j2;

case (26):					/* login_word */
	dn = wd;
	go to j1;

case (23):					/* log_time */
	time = clock () - tli;
	f = time / 60e6;
	go to j2;

case (36):					/* process_overseer */
	call user_info_$responder (dn);
	go to j1;

case (18):					/* initial_term_id */
iterm_id:
	call user_info_$terminal_data (id, tt);
	dn = id;
	go to j1;

case (19):					/* initial_term_type */
	call user_info_$absentee_queue (n);
	if n ^= -1 then do;
	     string = "Absentee";
	     go to exit;
	end;
iterm_type:
	call user_info_$terminal_data (id, tt);
	string = rtrim (tt);
	go to exit;

case (14):					/* cpu_secs */
	call user_info_$usage_data (np, ocpu);
	call hcs_$get_usage_values (pf, time, pp);
	time = time + ocpu;
	f = time / 1e6;
j2:	call ioa_$rsnnl ("^.1f", string, i, f);
	go to exit;

case (16):					/* device_channel */
	call user_info_$terminal_data (id, tt, dn);	/* get channel name */
j1:	string = rtrim (dn);
	go to exit;

case (31):					/* n_processes */
	call user_info_$usage_data (np, ocpu);
	call ioa_$rsnnl ("^d", string, i, np);
	go to exit;

case (3):						/* absentee */
	call user_info_$absentee_queue (n);
	if n = -1 then string = "false";
	else string = "true";
	go to exit;

case (2):						/* abs_queue */
	call user_info_$absentee_queue (n);
	if n = -1 then string = "interactive";
	else if n = 0 then string = "foreground";
	else call ioa_$rsnnl ("^d", string, i, n);
	go to exit;

case (39):					/* protected */
	call user_info_$load_ctl_info (grp, sb, tli);
	string = "false";
	if sb = 0 then if tli &gt; clock () then string = "true";
	go to exit;

case (12):					/* brief_bit */
	call user_info_$attributes (attr);
	if index (attr, "brief") = 0 then string = "false";
	else string = "true";
	go to exit;

case (17):					/* group */
	call user_info_$load_ctl_info (grp);
	dn = grp;
	go to j1;

case (34):					/* preemption_time */
	call user_info_$load_ctl_info (grp, sb, tli);
	go to j3;

case (9):						/* attributes */
	call user_info_$attributes (string);
	go to exit;

case (5):						/* absin */
	call user_info_$absin (dn);
	go to j1;

case (6):						/* absout */
	call user_info_$absout (dn);
	go to j1;

case (33):					/* outer_module */
	call user_info_$outer_module (dn);
	go to j1;

case (35):					/* process_id */
	b36 = get_process_id_ ();
	call ioa_$rsnnl ("^w", string, i, b36);
	go to exit;

case (10):					/* auth */
	call convert_access_class_$to_string_short (auth, auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then string = "system_low";
	else string = rtrim (auth_string);
	go to exit;

case (11):					/* auth_long */
	call convert_access_class_$to_string (auth, auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then string = "system_low";
	else string = rtrim (auth_string);
	go to exit;

case (27):					/* max_auth */
	call convert_access_class_$to_string_short (max_auth, auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then string = "system_low";
	else string = rtrim (auth_string);
	go to exit;

case (28):					/* max_auth_long */
	call convert_access_class_$to_string (max_auth, auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then string = "system_low";
	else string = rtrim (auth_string);
	go to exit;

case (50):					/* min_auth */
	call user_info_$authorization_range (auth_range);
	call convert_access_class_$to_string_short (auth_range (1), auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then auth_string = "system_low";
	string = rtrim (auth_string);
	go to exit;

case (51):					/* min_auth */
	call user_info_$authorization_range (auth_range);
	call convert_access_class_$to_string (auth_range (1), auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then auth_string = "system_low";
	string = rtrim (auth_string);
	go to exit;

case (52):					/* auth_range */
	call user_info_$authorization_range (auth_range);
	call convert_access_class_$to_string_range_short (auth_range, auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then auth_string = "system_low";
	string = rtrim (auth_string);
	go to exit;

case (53):					/* auth_range_long */
	call user_info_$authorization_range (auth_range);
	call convert_access_class_$to_string_range (auth_range, auth_string, ec);
	if ec ^= 0 then go to er;
	if auth_string = "" then auth_string = "system_low";
	string = rtrim (auth_string);
	go to exit;

case (22):					/* line_type */
	call user_info_$terminal_data ((""), (0), (""), i);
	dn = line_types (i);
	goto j1;

case (43):					/* service_type */
	call user_info_$service_type (i);
	dn = service_type (i);
	goto j1;

case (37):					/* process_type */
	call user_info_$process_type (i);
	dn = process_type (i);
	goto j1;

case (13):					/* charge_type */
	call user_info_$terminal_data ((""), (""), (""), (0), dn);
	go to j1;

case (47):					/* term_id */
	term_id_sw = "1"b;
get_term: call user_info_$process_type (i);
	if i &gt; 1 then				/* absentee or daemon process */
	     if term_id_sw then go to iterm_id;
	     else if i = 2 then do;
		string = "Absentee";
		go to exit;
	     end;
	     else go to iterm_type;

/* Interactive or initializer process */

	call iox_$control (iox_$user_io, "terminal_info", addr (terminal_info), ec);
	if ec ^= 0 then do;
	     if term_id_sw then go to iterm_id;
	     else go to iterm_type;
	end;
	if term_id_sw then string = rtrim (terminal_info.id);
	else string = rtrim (terminal_info.term_type);
	go to exit;

case (48):					/* term_type */
	term_id_sw = "0"b;
	go to get_term;

case (40):					/* rate_structure_name */
	call user_info_$rs_name (nm);
	string = nm;
	go to exit;

case (41):					/* rate_structure_number */
	call user_info_$rs_number (rs_number);
	call ioa_$rsnnl ("^d", string, i, rs_number);
	go to exit;

case (20):					/* limit */
	call ioa_$rsnnl ("^.2f", string, i, absolute_limit);
	goto exit;

case (15):					/* cutoff_date */
	string = date_time_$format ("date_time", cutoff_date, "", "");
	goto exit;

case (29):					/* monthly_limit */
	call ioa_$rsnnl ("^.2f", string, i, monthly_limit);
	goto exit;

case (44):					/* shift_limit */
	call system_info_$next_shift_change (current_shift, (0), (0), (0));
	call ioa_$rsnnl ("^.2f", string, i, shift_limits (current_shift));
	goto exit;

case (46):					/* spending */
	call ioa_$rsnnl ("^.2f", string, i, absolute_spending);
	goto exit;

case (30):					/* monthly_spending */
	call ioa_$rsnnl ("^.2f", string, i, monthly_spending);
	goto exit;

case (45):					/* shift_spending */
	call system_info_$next_shift_change (current_shift, (0), (0), (0));
	call ioa_$rsnnl ("^.2f", string, i, shift_spendings (current_shift));
	goto exit;

case (21):					/* limit_type */
	if limit_type = 0
	then string = "absolute";
	else if limit_type = 1
	then string = "day";
	else if limit_type = 2
	then string = "month";
	else if limit_type = 3
	then string = "year";
	else if limit_type = 4
	then string = "calendar_year";
	else if limit_type = 5
	then string = "fiscal_year";
	goto exit;

case (4):						/* absentee_request_id */ /* abs_rqid */
	call user_info_$absentee_request_id (fb71);
	if fb71 ^= 0 then do;
	     char19 = request_id_ (fb71);
	     string = char19;
	end;
	else string = "0";
	go to exit;

case (1):						/* 256k_switch (allow 256K segments) */ /* 256k */ /* 256K */
	call hcs_$set_256K_switch ("00"b, K256_switch, (0));
	if K256_switch = "11"b then string = "true";
	else string = "false";
	go to exit;

case (54):					/* absentee_restarted */
	call user_info_$absentee_restarted (restarted);
	if restarted then string = "true";
	else string = "false";
	go to exit;

case (55):					/* absout_truncation */
	call user_info_$absout_truncation (truncate);
	if truncate then string = "true";
	else string = "false";

case (56):					/* min_ring */
	call user_info_$ring_range (rg_range);
	call ioa_$rsnnl ("^d", ring_string, (0), rg_range (1));
	string = rtrim(ring_string);
	go to exit;
	
case (57):					/* max ring */
	call user_info_$ring_range (rg_range);
	call ioa_$rsnnl ("^d", ring_string, (0), rg_range (2));
	string = rtrim(ring_string);
	go to exit;
	
case (58):					/* ring range (lowest and highest) */
	call user_info_$ring_range (rg_range);
	call ioa_$rsnnl ("^d:^d", ring_string, (0), rg_range (1), rg_range (2));
	string = rtrim(ring_string);
	go to exit;
	

/* End of moby CASE statement */

/* Common return point for many actions */

exit:	if all_switch then do;
	     if string ^= ""
	     then call ioa_ ("^a:^24t^a", item (switch), ltrim (string));
	end;
	else if nactsw then
	     call ioa_ ("^a", string);
	else do;
	     call cu_$af_return_arg_rel (i, ap, al, (0), alp);
	     answer = requote_string_ ((string));
	end;
	return;
     end process_one_item;
     end user;




		    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
</pre></body></html>