



		    control_point_manager_call.pl1  11/04/86  1558.6rew 11/04/86  1031.4      489825



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

/* format: off */

/* Command interface to the Multics Control Point Manager */

/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Written to support control point management in March 1985 by G. Palter.
                                                   END HISTORY COMMENTS */

/* format: style3,linecom */

control_point_manager_call:
cpmc:
     procedure () options (variable);


dcl	return_value	character (return_value_lth) varying based (return_value_ptr);
dcl	return_value_ptr	pointer;
dcl	return_value_lth	fixed binary (21);
dcl	is_active_function	bit (1) aligned;

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

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

dcl	1 users_entry	aligned based (users_entry_ptr),
	  2 entry		entry (pointer) variable,
	  2 info_ptr	pointer;
dcl	users_entry_ptr	pointer;

dcl	command_line	character (4 * sys_info$max_seg_size - 4) varying based (command_line_ptr);
dcl	command_line_ptr	pointer;

dcl	pi_preferred	bit (1) aligned based (pi_preferred_ptr);
dcl	pi_preferred_ptr	pointer;

dcl	sci_ptr		pointer;

dcl	1 cpmc_info	aligned,
	  2 ssu_arg_ptr	entry (pointer, fixed binary, pointer, fixed binary (21)) variable,
	  2 operation_idx	fixed binary;

dcl	i		fixed binary;

dcl	code		fixed binary (35);

dcl	CONTROL_POINT_MANAGER_CALL
			character (32) static options (constant) initial ("control_point_manager_call");

dcl	CONTROL_POINT_MANAGER_CALL_VERSION
			character (32) static options (constant) initial ("1.0");

dcl	SSU_ARG_PTR	character (32) static options (constant) initial ("arg_ptr");
dcl	SSU_GET_SUBSYSTEM_AND_REQUEST_NAME
			character (32) static options (constant) initial ("get_subsystem_and_request_name");

dcl	WHITESPACE	character (5) static options (constant) initial ("
	 ");						/* NL, HT, SP, VT, FF */

/* format: off */
dcl	OPERATION_NAMES	dimension (0:21, 2) character (20) varying static options (constant) initial
	         ("",		     "",		/* (the command itself) */
		"enabled",	     "invoked",
		"id",		     "",
		"create",		     "cr",	/* ENTRY {INFO_PTR} {-control_args} */
		"destroy",	     "",		/* ID */
		"start",		     "sr",	/* ID */
		"wakeup",		     "",		/* ID */
		"stop",		     "",		/* ID */
		"scheduler",	     "",
		"generate_call",	     "gc",	/* ID ENTRY {INFO_PTR} {-control_args} */
		"list",		     "ls",	/* {ID} {-control_args} */
		"probe",		     "pb",	/* ID */
		"program_interrupt",     "pi",	/* ID {-control_arg} */
		"run",		     "",		/* {-control_args} COMMAND_LINE */
		"cl_intermediary",	     "",		/* ID */
		"set_cl_intermediary",   "",		/* ID {ENTRY} {-control_args} */
		"preferred",	     "",		
		"set_preferred",	     "",		/* ID */
		"push_preferred",	     "",		/* ID */
		"pop_preferred",	     "",		/* FLAG */
		"enable",		     "invoke",
		"select",		     "sl");	/* ID */

dcl	OPERATION_IS_COMMAND_ONLY
			dimension (21) bit (1) aligned static options (constant) initial
	         (( 2) ("0"b),			/* enabled, id */
	          (11) ("1"b),
		( 1) ("0"b),			/* cl_intermediary */
		( 1) ("1"b),
		( 1) ("0"b),			/* preferred */
		( 1) ("1"b),
		( 1) ("0"b),			/* push_preferred */
		( 3) ("1"b));

dcl	OPERATION_ENTRIES	dimension (21) entry () variable;

dcl	STATE_NAMES	dimension (0:3) character (12) varying initial
	         ("DESTROYED",	"STOPPED",	"BLOCKED",	"READY");

/* format: on */

dcl	(
	MICROSECONDS_PER_HOUR
			initial (3600000000),
	MICROSECONDS_PER_MINUTE
			initial (60000000),
	MICROSECONDS_PER_SECOND
			initial (1000000)
	)		fixed binary (71) static options (constant);

dcl	(
	cpm_et_$already_started,
	cpm_et_$control_point_not_found,
	error_table_$active_function,
	error_table_$bad_arg,
	error_table_$bad_conversion,
	error_table_$badopt,
	error_table_$inconsistent,
	error_table_$noarg,
	error_table_$too_many_args
	)		fixed binary (35) external;

dcl	sys_info$max_seg_size
			fixed binary (19) external;

dcl	active_fnc_err_$suppress_name
			entry () options (variable);
dcl	com_err_		entry () options (variable);
dcl	com_err_$suppress_name
			entry () options (variable);
dcl	cpm_initialize_	entry ();
dcl	cu_$cp		entry (pointer, fixed binary (21), fixed binary (35));
dcl	cv_dec_check_	entry (character (*), fixed binary (35)) returns (fixed binary (35));
dcl	cv_entry_		entry (character (*), pointer, fixed binary (35)) returns (entry);
dcl	cv_oct_check_	entry (character (*), fixed binary (35)) returns (bit (36) aligned);
dcl	cv_ptr_		entry (character (*), fixed binary (35)) returns (pointer);
dcl	cv_ptr_$terminate	entry (pointer);
dcl	get_system_free_area_
			entry () returns (pointer);
dcl	get_entry_name_	entry (pointer, character (*), fixed binary (18), character (8) aligned, fixed binary (35));
dcl	get_temp_segment_	entry (character (*), pointer, fixed binary (35));
dcl	hcs_$fs_get_path_name
			entry (pointer, character (*), fixed binary, character (*), fixed binary (35));
dcl	ioa_		entry () options (variable);
dcl	ioa_$rsnnl	entry () options (variable);
dcl	ioa_$rsnpnnl	entry () options (variable);
dcl	pathname_		entry (character (*), character (*)) returns (character (168));
dcl	probe$probe	entry () options (variable);
dcl	program_interrupt$program_interrupt
			entry () options (variable);
dcl	release_temp_segment_
			entry (character (*), pointer, fixed binary (35));
dcl	requote_string_	entry (character (*)) returns (character (*));
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_$get_info_ptr	entry (pointer) returns (pointer);
dcl	ssu_$get_procedure	entry (pointer, character (*), entry, fixed binary (35));
dcl	ssu_$print_message	entry () options (variable);
dcl	ssu_$return_arg	entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
dcl	ssu_$set_info_ptr	entry (pointer, pointer);
dcl	ssu_$set_procedure	entry (pointer, character (*), entry, fixed binary (35));
dcl	ssu_$standalone_invocation
			entry (pointer, character (*), character (*), pointer, entry, fixed binary (35));

dcl	cleanup		condition;

dcl	(addr, addwordno, baseptr, before, binary, codeptr, divide, environmentptr, float, hbound, index, lbound,
	length, mod, null, rtrim, stackbaseptr, string, substr)
			builtin;
%page;
/* control_point_manager_call: cpmc: entry () options (variable); */

	call ssu_$standalone_invocation (sci_ptr, CONTROL_POINT_MANAGER_CALL, CONTROL_POINT_MANAGER_CALL_VERSION,
	     null (), abort_control_point_manager_call, code);
	if code ^= 0
	then do;
		call com_err_ (code, CONTROL_POINT_MANAGER_CALL, "Creating a standalone invocation.");
		return;
	     end;

	on cleanup call ssu_$destroy_invocation (sci_ptr);

	cpmc_info.operation_idx = 0;			/* see commentary before operation_arg_ptr for details */
	cpmc_info.ssu_arg_ptr = cpm_$nulle;
	call ssu_$set_info_ptr (sci_ptr, addr (cpmc_info));

	call ssu_$return_arg (sci_ptr, n_arguments, is_active_function, return_value_ptr, return_value_lth);
	if n_arguments = 0
	then call display_usage_message_and_abort ("operation {operation_arguments}");

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

	do cpmc_info.operation_idx = lbound (OPERATION_ENTRIES, 1) to hbound (OPERATION_ENTRIES, 1);
	     do i = lbound (OPERATION_NAMES, 2) to hbound (OPERATION_NAMES, 2);
		if argument = OPERATION_NAMES (cpmc_info.operation_idx, i)
		then go to KNOWN_OPERATION;
	     end;
	end;

	call ssu_$abort_subsystem (sci_ptr, 0, "Unknown operation.  ""^a""", argument);


KNOWN_OPERATION:
	if is_active_function & OPERATION_IS_COMMAND_ONLY (cpmc_info.operation_idx)
	then call ssu_$abort_subsystem (sci_ptr, error_table_$active_function,
		"^/^-The ""^a"" keyword is not valid when used as an active function.",
		OPERATION_NAMES (cpmc_info.operation_idx, 1));

	call prepare_for_operation ();

	call OPERATION_ENTRIES (cpmc_info.operation_idx) ();
						/* perform the requested operation */

RETURN_FROM_CONTROL_POINT_MANAGER_CALL:
	call ssu_$destroy_invocation (sci_ptr);

	return;



/* Invoked by ssu_$abort_subsystem and ssu_$abort_line after printing an error message to terminate command execution */

abort_control_point_manager_call:
     procedure ();

	go to RETURN_FROM_CONTROL_POINT_MANAGER_CALL;

     end abort_control_point_manager_call;
%page;
/* Due to a bug in ssu_, the following procedures (operation_arg_ptr and get_command_and_operation_name) must be
   entrypoints directly into control_point_manager_call rather than internal procedures.  Therefore, they can only
   reference data which is made available through the subsystem's info_ptr. */

dcl	P_sci_ptr		pointer parameter;		/* common to both entrypoints */

dcl	1 based_cpmc_info	like cpmc_info aligned based (cpmc_info_ptr);
dcl	cpmc_info_ptr	pointer;



/* ssu_$arg_ptr replacement used by the individual operations */

operation_arg_ptr:
     entry (P_sci_ptr, P_argument_idx, P_argument_ptr, P_argument_lth);

dcl	P_argument_idx	fixed binary parameter;
dcl	P_argument_ptr	pointer parameter;
dcl	P_argument_lth	fixed binary (21) parameter;

	cpmc_info_ptr = ssu_$get_info_ptr (P_sci_ptr);

	call based_cpmc_info.ssu_arg_ptr (P_sci_ptr, (P_argument_idx + 1), P_argument_ptr, P_argument_lth);

	return;



/* ssu_$get_subsystem_and_request_name replacement used by the individual operations */

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

dcl	command_and_operation_name
			character (72) varying;

	cpmc_info_ptr = ssu_$get_info_ptr (P_sci_ptr);

	command_and_operation_name = rtrim (CONTROL_POINT_MANAGER_CALL);

	if based_cpmc_info.operation_idx > 0
	then do;					/* there's an operation in control at present */
		command_and_operation_name = command_and_operation_name || " (";
		command_and_operation_name =
		     command_and_operation_name || OPERATION_NAMES (based_cpmc_info.operation_idx, 1);
		command_and_operation_name = command_and_operation_name || ")";
	     end;

	return (command_and_operation_name);
%page;
/* This entrypoint is invoked by the create and generate_call operations in the other control point -- After invoking the
   user's entrypoint, this entrypint will then terminate the user's info_ptr as it was initiated by this command in the
   first place. */

run_users_entry:
     entry (P_users_entry_ptr);

dcl	P_users_entry_ptr	pointer parameter;

	users_entry_ptr = P_users_entry_ptr;

	on cleanup
	     begin;
		if users_entry.info_ptr ^= null ()
		then do;
			call cv_ptr_$terminate (users_entry.info_ptr);
			users_entry.info_ptr = null ();
		     end;
	     end;

	call users_entry.entry (users_entry.info_ptr);

	if users_entry.info_ptr ^= null ()
	then do;
		call cv_ptr_$terminate (users_entry.info_ptr);
		users_entry.info_ptr = null ();
	     end;

	return;



/* This entrypoint is invoked by the run operation in the new control point to invoke execute the command line and the
   release the temporary segment containing the command line. */

run_command_line:
     entry (P_command_line_ptr);

dcl	P_command_line_ptr	pointer parameter;

	command_line_ptr = P_command_line_ptr;

	on cleanup
	     begin;
		if command_line_ptr ^= null ()
		then call release_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, (0));
	     end;

	call cu_$cp (addwordno (addr (command_line), 1), length (command_line), (0));

	call release_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, (0));

	return;
%page;
/* This entrypoint is invoked by the program_interrupt operation in the target control point to actually signal
   program_interrupt -- The user can request that the control point be made the preferred control point before actually
   signalling program_interrupt.  Due to the interaction of cpm_$generate_call and the control point scheduler, setting
   the preferred control point must be deferred until we are running in the target control point. */

pi_signaller:
     entry (P_pi_preferred_ptr);

dcl	P_pi_preferred_ptr	pointer parameter;

	system_area_ptr = get_system_free_area_ ();

	pi_preferred_ptr = P_pi_preferred_ptr;

	on cleanup
	     begin;
		if pi_preferred_ptr ^= null ()
		then free pi_preferred in (system_area);
		pi_preferred_ptr = null ();
	     end;

	if pi_preferred
	then do;
		call cpm_$set_preferred_control_point (get_control_point_id_ (), code);
		if code ^= 0
		then call com_err_ (code, CONTROL_POINT_MANAGER_CALL,
			"Trying to make the control point ^12.3b preferred.", get_control_point_id_ ());
	     end;

	free pi_preferred in (system_area);		/* we don't need it anymore */
	pi_preferred_ptr = null ();

	call program_interrupt$program_interrupt ();	/* the command knows how to handle no handler */

	return;
%page;
/* Prepare to perform a specific operation */

prepare_for_operation:
     procedure ();

	n_arguments = n_arguments - 1;		/* operations don't count their name as an argument */


/* Replace ssu_$arg_ptr with a private procedure -- The private procedure will increment the requested argument index by
   one before calling the saved value of ssu_$arg_ptr.  In this way, the individual operations can be coded as if they
   were standalone commands as the private ssu_$arg_ptr will, effectively, make them ignore the existence of our real
   first argument -- the operation keyword. */

	call ssu_$get_procedure (sci_ptr, SSU_ARG_PTR, cpmc_info.ssu_arg_ptr, code);

	if code = 0				/* we have the reall ssu_$arg_ptr stashed away */
	then call ssu_$set_procedure (sci_ptr, SSU_ARG_PTR, operation_arg_ptr, code);

	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Attempting to replace ssu_$arg_ptr.");


/* Replace ssu_$get_subsystem_and_request_name with a private procedure -- The private procedure uses the operation's
   primary name as the "request" name. */

	call ssu_$set_procedure (sci_ptr, SSU_GET_SUBSYSTEM_AND_REQUEST_NAME, get_command_and_operation_name, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Attempting to replace ssu_$get_subsystem_and_request_name.");


/* Initialize the OPERATION_ENTRIES array -- Multics PL/I does not implement constant entry arrays. */

	OPERATION_ENTRIES (1) = is_cpm_enabled;
	OPERATION_ENTRIES (2) = get_id;
	OPERATION_ENTRIES (3) = create_control_point$create;
	OPERATION_ENTRIES (4) = destroy;
	OPERATION_ENTRIES (5) = start;
	OPERATION_ENTRIES (6) = wakeup;
	OPERATION_ENTRIES (7) = stop;
	OPERATION_ENTRIES (8) = scheduler;
	OPERATION_ENTRIES (9) = generate_call;
	OPERATION_ENTRIES (10) = list;
	OPERATION_ENTRIES (11) = probe;
	OPERATION_ENTRIES (12) = program_interrupt;
	OPERATION_ENTRIES (13) = create_control_point$run;
	OPERATION_ENTRIES (14) = get_cl_intermediary;
	OPERATION_ENTRIES (15) = set_cl_intermediary;
	OPERATION_ENTRIES (16) = get_preferred;
	OPERATION_ENTRIES (17) = set_preferred;
	OPERATION_ENTRIES (18) = push_preferred;
	OPERATION_ENTRIES (19) = pop_preferred;
	OPERATION_ENTRIES (20) = enable_cpm;
	OPERATION_ENTRIES (21) = select;

	return;

     end prepare_for_operation;
%page;
/* Display a usage message for the command or one of its operations and then abort the command */

display_usage_message_and_abort:
     procedure (p_arguments_description);

dcl	p_arguments_description
			character (*) parameter;

	if is_active_function
	then call active_fnc_err_$suppress_name (0, CONTROL_POINT_MANAGER_CALL, "Usage:  ^a^[ ^a^;^s^]^[ ^a^]",
		CONTROL_POINT_MANAGER_CALL, (cpmc_info.operation_idx > 0),
		OPERATION_NAMES (cpmc_info.operation_idx, 1), (length (p_arguments_description) > 0),
		p_arguments_description);
	else call com_err_$suppress_name (0, CONTROL_POINT_MANAGER_CALL, "Usage:  ^a^[ ^a^;^s^]^[ ^a^]",
		CONTROL_POINT_MANAGER_CALL, (cpmc_info.operation_idx > 0),
		OPERATION_NAMES (cpmc_info.operation_idx, 1), (length (p_arguments_description) > 0),
		p_arguments_description);

	call abort_control_point_manager_call ();	/* never returns */

     end display_usage_message_and_abort;



/* Abort the operation if it was given any arguments */

reject_any_arguments:
     procedure ();

	if n_arguments ^= 0
	then call ssu_$abort_subsystem (sci_ptr, 0, "No arguments may be given for this operation.");

	return;

     end reject_any_arguments;



/* Pickup a control argument's required argument */

fetch_next_argument:
     procedure (p_noarg_message);

dcl	p_noarg_message	character (*) parameter;

	if argument_idx = n_arguments
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, p_noarg_message);

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

	return;

     end fetch_next_argument;
%page;
/* Convert a character string into a control point ID -- Actually, this procedure sets cpd_ptr to locate the control point
   definition requested by the user.  A control point ID can be specified in one of two ways.  Either the entire ID must
   be given or only the first six digits (the stack segment number) must be supplied.  In either case, the ID must always
   be supplied as an octal number. */

cv_string_to_control_point_id:
     procedure ();

dcl	1 decoded_control_point_id			/* internal representation of a control point ID */
			aligned,
	  2 stack_segno	bit (18) unaligned,
	  2 unique_bits	bit (18) unaligned;

dcl	control_point_id	bit (36) aligned;
dcl	check_unique_bits	bit (1) aligned;

	control_point_id = cv_oct_check_ (argument, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion,
		"Control point IDs must be given as octal strings; not ""^a"".", argument);

	if control_point_id > "000000777777"b3		/* full ID given */
	then do;
		string (decoded_control_point_id) = control_point_id;
		check_unique_bits = "1"b;
	     end;
	else do;
		string (decoded_control_point_id) = substr (control_point_id, 19, 18) || "000000"b3;
		check_unique_bits = "0"b;
	     end;

	if cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0))
	then do;					/* the given ID does identify a valid stack */
		cpd_ptr = baseptr (decoded_control_point_id.stack_segno) -> stack_header.cpm_data_ptr;
		if check_unique_bits
		then if control_point_data.id = control_point_id
		     then return;
		     else ;			/* unique IDs don't match */
		else return;			/* caller only supplied the stack segno */
	     end;

	call ssu_$abort_subsystem (sci_ptr, cpm_et_$control_point_not_found, "^6.3b^[^6.3b^;xxxxxx^]",
	     decoded_control_point_id.stack_segno, check_unique_bits, decoded_control_point_id.unique_bits);

     end cv_string_to_control_point_id;
%page;
/* Enable control point management */

enable_cpm:
     procedure ();

	call reject_any_arguments ();

	if stackbaseptr () -> stack_header.cpm_enabled
	then call ssu_$abort_subsystem (sci_ptr, 0, "Control point management is already enabled.");
	else call cpm_initialize_ ();

	return;

     end enable_cpm;


/* Determine whether control point management is enabled */

is_cpm_enabled:
     procedure ();

dcl	cpm_is_enabled	bit (1) aligned;

	call reject_any_arguments ();

	cpm_is_enabled = (stackbaseptr () -> stack_header.cpm_enabled ^= ""b);

	if is_active_function			/* return it into the command line */
	then if cpm_is_enabled
	     then return_value = "true";
	     else return_value = "false";

	else call ioa_ ("Control point management is^[ not^] enabled.", ^cpm_is_enabled);

	return;

     end is_cpm_enabled;



/* Determine the current control point's unique ID */

get_id:
     procedure ();

dcl	id_string		character (12);

	call reject_any_arguments ();

	call ioa_$rsnnl ("^12.3b", id_string, (0), get_control_point_id_ ());

	if is_active_function			/* return it into the command line */
	then return_value = id_string;

	else call ioa_ ("Current control point ID is ^a.", id_string);

	return;

     end get_id;
%page;
/* The "create" and "run" operations */

create_control_point:
     procedure ();
	return;					/* not used */

dcl	1 ccpi_header	like create_control_point_info.header aligned;

dcl	atd_argument	character (atd_argument_lth) based (atd_argument_ptr);
dcl	atd_argument_ptr	pointer;
dcl	atd_argument_lth	fixed binary (21);

dcl	control_point_id	bit (36) aligned;

dcl	users_entry_entrypoint_name
			character (256);
dcl	users_entry_ename	character (32);

dcl	(create_operation, run_operation, in_command_line, have_users_entry, have_users_info_ptr, display_the_id,
	start_the_control_point, prefer_the_control_point, prefer_the_control_point_given)
			bit (1) aligned;



/* Create a new control point -- This operation is pratically a direct interface to cpm_$create.  However, rather than
   invoking the user's initial procedure immediately in the new control point, we supply a private initial procedure whose
   sole purpose is to insure that the user's info_ptr is properly terminated. */

create_control_point$create:
     entry ();

	if n_arguments = 0
	then call display_usage_message_and_abort ("ENTRY {INFO_PTR} {-control_args}");

	create_operation = "1"b;
	run_operation = "0"b;

	go to CREATE_CONTROL_POINT;



/* Create a new control point to execute the supplied command line */

create_control_point$run:
     entry ();

	if n_arguments = 0
	then call display_usage_message_and_abort ("{-control_args} COMMAND_LINE");

	create_operation = "0"b;
	run_operation = "1"b;

	go to CREATE_CONTROL_POINT;



/* The actual code for both the "create" and "run" operations */

CREATE_CONTROL_POINT:
	system_area_ptr = get_system_free_area_ ();

	users_entry_ptr,				/* for cleanup handler */
	     command_line_ptr, ccpi_ptr = null ();
	have_users_entry, have_users_info_ptr = "0"b;

	on cleanup
	     begin;
		if create_operation
		then do;
			if users_entry_ptr ^= null ()
			then do;
				if have_users_info_ptr
				then do;
					call cv_ptr_$terminate (users_entry.info_ptr);
					have_users_info_ptr = "0"b;
				     end;
				free users_entry in (system_area);
				users_entry_ptr = null ();
			     end;
		     end;
		else /*** if run_operation then */
		     do;
			if command_line_ptr ^= null ()
			then call release_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, (0));
		     end;
		if ccpi_ptr ^= null ()
		then do;
			free create_control_point_info in (system_area);
			ccpi_ptr = null ();
		     end;
	     end;


/* Setup appropriate defaults for the new control point */

	display_the_id = "1"b;			/* tell the user what happened */

	if create_operation
	then do;
		allocate users_entry in (system_area) set (users_entry_ptr);
		ccpi_header.initproc.entry = run_users_entry;
		ccpi_header.initproc.info_ptr = users_entry_ptr;
		start_the_control_point = "0"b;	/* the user must explicitly start this control point ... */
		prefer_the_control_point = "0"b;	/* ... and explicitly give it control */
	     end;

	else /*** if run_operation then */
	     do;
		call get_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, code);
		if code ^= 0
		then call ssu_$abort_subsystem (sci_ptr, code, "Unable to obtain space for the command line.");
		command_line = "";			/* initialize the command line to empty */
		ccpi_header.initproc.entry = run_command_line;
		ccpi_header.initproc.info_ptr = command_line_ptr;
		start_the_control_point = "1"b;	/* have execution begin as soon as possible ... */
		prefer_the_control_point = "1"b;	/* ... and let it have real control */
	     end;

	ccpi_header.version = CREATE_CONTROL_POINT_INFO_VERSION_1;
	ccpi_header.comment = "";
	ccpi_header.priority = 1;
	string (ccpi_header.flags) = ""b;
	ccpi_header.independent = "1"b;


/* Parse the arguments which define the new control point */

	in_command_line = "0"b;			/* for run: we haven't seen the command line yet */
	prefer_the_control_point_given = "0"b;

	do argument_idx = 1 to n_arguments;

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

	     if ^in_command_line & (index (argument, "-") = 1)
	     then					/*  a control argument */
		if (argument = "-long") | (argument = "-lg")
		then display_the_id = "1"b;
		else if (argument = "-brief") | (argument = "-bf")
		then display_the_id = "0"b;

		else if (argument = "-start") | (argument = "-sr")
		then start_the_control_point = "1"b;
		else if (argument = "-no_start") | (argument = "-nsr")
		then start_the_control_point = "0"b;

		else if argument = "-preferred"
		then prefer_the_control_point, prefer_the_control_point_given = "1"b;
		else if argument = "-not_preferred"
		then do;
			prefer_the_control_point = "0"b;
			prefer_the_control_point_given = "1"b;
		     end;

		else if argument = "-priority"
		then do;
			call fetch_next_argument ("A number after ""-priority"".");
			ccpi_header.priority = cv_dec_check_ (argument, code);
			if code ^= 0
			then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion, "-priority ""^a""",
				argument);
		     end;

		else if (argument = "-comment") | (argument = "-com")
		then do;
			call fetch_next_argument ("A string after ""-comment"".");
			ccpi_header.comment = argument;
		     end;

		else if argument = "-independent"
		then ccpi_header.independent = "1"b;
		else if argument = "-dependent"
		then ccpi_header.independent = "0"b;

		else if argument = "-cl_intermediary"
		then do;
			call fetch_next_argument ("An entry after ""-cl_intermediary"".");
			ccpi_header.user_cl_intermediary = cv_entry_ (argument, null (), code);
			if code ^= 0
			then call ssu_$abort_subsystem (sci_ptr, code, "-cl_intermediary ""^a""", argument);
			ccpi_header.user_cl_intermediary_given = "1"b;
		     end;
		else if argument = "-default_cl_intermediary"
		then ccpi_header.user_cl_intermediary_given = "0"b;

		else if (argument = "-separate_io_switches") | (argument = "-sepios")
		then do;
			ccpi_header.separate_standard_iocbs = "1"b;
			ccpi_header.user_io_attach_desc_given = "0"b;
			if argument_idx < n_arguments
			then do;			/* check for an optional attach description */
				call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), atd_argument_ptr,
				     atd_argument_lth);
				if index (atd_argument, "-") ^= 1
				then do;
					ccpi_header.user_io_attach_desc_given = "1"b;
					argument_idx = argument_idx + 1;
				     end;
			     end;
		     end;
		else if (argument = "-shared_io_switches") | (argument = "-shios")
		then ccpi_header.separate_standard_iocbs, ccpi_header.user_io_attach_desc_given = "0"b;

		else if run_operation & ((argument = "-string") | (argument = "-str"))
		then do;
			if argument_idx = n_arguments
			then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
				"A command line after ""-string"".");
			in_command_line = "1"b;
		     end;

		else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument);

	     else					/* not a control argument: depends on the operation */
		if create_operation
	     then do;
		     if ^have_users_entry
		     then do;
			     users_entry.entry = cv_entry_ (argument, null (), code);
			     if code ^= 0
			     then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument);
			     have_users_entry = "1"b;
			end;

		     else if ^have_users_info_ptr
		     then do;
			     users_entry.info_ptr = cv_ptr_ (argument, code);
			     if code ^= 0
			     then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument);
			     have_users_info_ptr = "1"b;
			end;

		     else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument);
		end;

	     else /*** if run_operation then */
		do;
		     if length (command_line) > 0
		     then command_line = command_line || " ";
		     command_line = command_line || argument;
		     in_command_line = "1"b;
		end;
	end;

	if create_operation
	then do;
		if ^have_users_entry		/* there must be an initial procedure */
		then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
			"An initial procedure must be specified.");
		if ^have_users_info_ptr		/* ... but its info_ptr is optional */
		then users_entry.info_ptr = null ();
	     end;

	else /*** if run_operation then */
	     do;
		if length (command_line) = 0
		then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A command line to be executed.");
	     end;

	if prefer_the_control_point_given & ^start_the_control_point
	then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent,
		"""-no_start"" and ""-^[not_^;^]preferred"".", ^prefer_the_control_point);

	if ccpi_header.comment = ""
	then do;					/* supply a reasonable "name" for the control point */
		if create_operation
		then do;
			call hcs_$fs_get_path_name (codeptr (users_entry.entry), ((168)" "), (0), users_entry_ename,
			     (0));
			call get_entry_name_ (codeptr (users_entry.entry), users_entry_entrypoint_name, (0),
			     ((8)" "), (0));
			ccpi_header.comment = rtrim (users_entry_ename) || "$" || users_entry_entrypoint_name;
		     end;
		else /*** if run_operation then */
		     ccpi_header.comment = before (command_line, WHITESPACE);
	     end;


/* Create and, optionally, start the control point and mark it as preferred */

	if ccpi_header.user_io_attach_desc_given
	then ccpi_user_io_attach_desc_length = atd_argument_lth;
	else ccpi_user_io_attach_desc_length = 1;	/* PL/I abhors zero-length strings */

	allocate create_control_point_info in (system_area) set (ccpi_ptr);

	create_control_point_info.header = ccpi_header;
	create_control_point_info.user_io_attach_desc_length = ccpi_user_io_attach_desc_length;

	if create_control_point_info.user_io_attach_desc_given
	then create_control_point_info.user_io_attach_desc = atd_argument;

	call cpm_$create (ccpi_ptr, control_point_id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Creating the control point.");

	revert cleanup;				/* it's the new control point's responsibility to cleanup */

	free create_control_point_info in (system_area);	/* we don't need it anymore */

	if start_the_control_point
	then do;
		call cpm_$start (control_point_id, code);
		if code = 0
		then				/* it started: mark it preferred if requested */
		     if prefer_the_control_point
		     then do;
			     call cpm_$set_preferred_control_point (control_point_id, code);
			     if code ^= 0
			     then call ssu_$print_message (sci_ptr, code,
				     "Trying to make the control point ^12.3b preferred.", control_point_id);
			end;
		     else ;
		else call ssu_$print_message (sci_ptr, code, "Trying to start the control point ^12.3b.",
			control_point_id);
	     end;

	if display_the_id
	then call ioa_ ("Control point ^12.3b created^[^[, started, and marked preferred^; and started^]^].",
		control_point_id, start_the_control_point, prefer_the_control_point);

	return;

     end create_control_point;
%page;
/* Destroy the specified control point */

destroy:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$destroy (control_point_data.id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to destroy the control point ^12.3b.",
		control_point_data.id);

	return;

     end destroy;



/* Start the specified control point if it is in the STOPPED state */

start:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$start (control_point_data.id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to start the control point ^12.3b.",
		control_point_data.id);

	return;

     end start;
%page;
/* Wakeup the specified control point if it is in the BLOCKED state */

wakeup:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$wakeup (control_point_data.id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to wakeup the control point ^12.3b.",
		control_point_data.id);

	return;

     end wakeup;



/* Stop the specified control point if it is in the READY or BLOCKED state */

stop:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$stop (control_point_data.id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to stop the control point ^12.3b.",
		control_point_data.id);

	return;

     end stop;
%page;
/* Select the specified control point for preferred treatment -- If the control point is STOPPED, start it.  In any event,
   try to make it the preferred control point. */

select:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$start (control_point_data.id, code);
	if (code ^= 0) & (code ^= cpm_et_$already_started)
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to start the control point ^12.3b.",
		control_point_data.id);

	call cpm_$set_preferred_control_point (control_point_data.id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to make the control point ^12.3b preferred.",
		control_point_data.id);

	return;

     end select;



/* Block the current control point and invoke the control point scheduler */

scheduler:
     procedure ();

	call reject_any_arguments ();

	call cpm_$block ();
	call cpm_$scheduler ();

	return;

     end scheduler;
%page;
/* Generate a call to the given entrypoint in another control point */

generate_call:
     procedure ();

dcl	(have_control_point_id, have_users_entry, have_users_info_ptr, immediate, preferred, preferred_given)
			bit (1) aligned;

	if n_arguments = 0
	then call display_usage_message_and_abort ("ID ENTRY {INFO_PTR} {-control_args}");

	system_area_ptr = get_system_free_area_ ();

	users_entry_ptr = null ();			/* for cleanup handler */
	have_control_point_id, have_users_entry, have_users_info_ptr = "0"b;

	on cleanup
	     begin;
		if users_entry_ptr ^= null ()
		then do;
			if have_users_info_ptr
			then do;
				call cv_ptr_$terminate (users_entry.info_ptr);
				have_users_info_ptr = "0"b;
			     end;
			free users_entry in (system_area);
			users_entry_ptr = null ();
		     end;
	     end;

	allocate users_entry in (system_area) set (users_entry_ptr);


/* Parse our arguments */

	immediate = "1"b;				/* run the other control point right away */
	preferred, preferred_given = "0"b;		/* ... but do not make it the preferred control point */

	do argument_idx = 1 to n_arguments;

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

	     if index (argument, "-") = 1
	     then					/* a control argument */
		if (argument = "-immediate") | (argument = "-im")
		then immediate = "1"b;
		else if (argument = "-defer_until_ready") | (argument = "-dur")
		then immediate = "0"b;

		else if argument = "-preferred"
		then preferred, preferred_given = "1"b;
		else if argument = "-not_preferred"
		then do;
			preferred = "0"b;
			preferred_given = "1"b;
		     end;

		else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument);

	     else					/* a non-control argument */
		if ^have_control_point_id
	     then do;
		     call cv_string_to_control_point_id ();
		     have_control_point_id = "1"b;
		end;

	     else if ^have_users_entry
	     then do;
		     users_entry.entry = cv_entry_ (argument, null (), code);
		     if code ^= 0
		     then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument);
		     have_users_entry = "1"b;
		end;

	     else if ^have_users_info_ptr
	     then do;
		     users_entry.info_ptr = cv_ptr_ (argument, code);
		     if code ^= 0
		     then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument);
		     have_users_info_ptr = "1"b;
		end;

	     else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument);
	end;

	if ^have_control_point_id			/* we must have someplace to execute the entrypoint */
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A control point ID must be specified.");

	if ^have_users_entry			/* ... and there must be an entrypoint */
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "An entrypoint must be specified.");

	if ^have_users_info_ptr			/* ... but its info_ptr is optional */
	then users_entry.info_ptr = null ();

	if ^immediate & preferred_given
	then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent,
		"""-defer_until_ready"" and ""-^[not_^]preferred"".", ^preferred);


/* Make the call */

	if immediate
	then if preferred
	     then call cpm_$generate_call_preferred (control_point_data.id, run_users_entry, users_entry_ptr, code);
	     else call cpm_$generate_call (control_point_data.id, run_users_entry, users_entry_ptr, code);
	else call cpm_$generate_call (control_point_data.id, run_users_entry, users_entry_ptr, code);

	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to generate a call into the control point ^12.3b.",
		control_point_data.id);

	return;

     end generate_call;
%page;
/* List the specified (or all) control points with optional metering data */

list:
     procedure ();

dcl	cpd_ptr_list	dimension (n_arguments) pointer based (cpd_ptr_list_ptr);
dcl	cpd_ptr_list_ptr	pointer;
dcl	n_control_points	fixed binary;

dcl	(list_all, display_meters)
			bit (1) aligned;
dcl	i		fixed binary;

	if n_arguments = 0
	then call display_usage_message_and_abort ("{IDs} {-control_args}");

	if stackbaseptr () -> stack_header.cpm_enabled = ""b
	then call ssu_$abort_subsystem (sci_ptr, 0, "Control point management is not enabled.");

	system_area_ptr = get_system_free_area_ ();

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

	on cleanup
	     begin;
		if cpd_ptr_list_ptr ^= null ()
		then do;
			free cpd_ptr_list in (system_area);
			cpd_ptr_list_ptr = null ();
		     end;
	     end;

	allocate cpd_ptr_list in (system_area) set (cpd_ptr_list_ptr);


/* Parse our arguments */

	list_all = "0"b;				/* caller must either supply IDs or "-all" */
	n_control_points = 0;

	display_meters = "0"b;			/* no meters unless explicitly requested */

	do argument_idx = 1 to n_arguments;

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

	     if index (argument, "-") = 1
	     then					/* a control argument */
		if (argument = "-all") | (argument = "-a")
		then list_all = "1"b;

		else if argument = "-meters"
		then display_meters = "1"b;
		else if argument = "-no_meters"
		then display_meters = "0"b;

		else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument);

	     else					/* a non-control argument: must be a control point ID */
		do;
		     call cv_string_to_control_point_id ();
		     do i = 1 to n_control_points;	/* ... don't list a control point more than once */
			if cpd_ptr_list (i) = cpd_ptr
			then go to PARSE_NEXT_ARGUMENT;
		     end;
		     n_control_points = n_control_points + 1;
		     cpd_ptr_list (n_control_points) = cpd_ptr;
		end;

PARSE_NEXT_ARGUMENT:
	end;

	if list_all & (n_control_points > 0)
	then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-all"" and control point IDs.");

	else if ^list_all & (n_control_points = 0)
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg,
		"At least one control point ID or ""-all"" must be specified.");


/* Now display the requested control points */

	if display_meters & (list_all | (n_control_points > 1))
	then do;					/* display scheduler meters if multiple control points */
		call ioa_ ("Scheduler overhead:");
		call display_metering_data (addr (cpm_data_$global_meters.overhead));
	     end;

	if list_all | (n_control_points > 1)
	then do;					/* display a header for multiple control points */
		call ioa_ ("^4tID^12t(Long ID)^25tDepth^33tState^51tComment");
		call ioa_ ("");
	     end;

	if list_all				/* list all control points */
	then call list_all_control_points (addr (cpm_data_$root_control_point_data), 0);

	else					/* list only the ones specificly requested */
	     do i = 1 to n_control_points;
		call list_control_point (cpd_ptr_list (i), -1);
	     end;

	free cpd_ptr_list in (system_area);		/* cleanup */
	cpd_ptr_list_ptr = null ();

	return;



/* List all control points recursively */

list_all_control_points:
     procedure (p_cpd_ptr, p_depth) recursive;

dcl	1 p_cpd		like control_point_data aligned based (p_cpd_ptr);
dcl	p_cpd_ptr		pointer;

dcl	p_depth		fixed binary parameter;

dcl	1 child_cpd	like control_point_data aligned based (child_cpd_ptr);
dcl	child_cpd_ptr	pointer;

	call list_control_point (p_cpd_ptr, p_depth);	/* display this control point's definition */

	do child_cpd_ptr = p_cpd.first_child repeat (child_cpd.next_peer) while (child_cpd_ptr ^= null ());
	     call list_all_control_points (child_cpd_ptr, (p_depth + 1));
	end;

	return;

     end list_all_control_points;



/* List a single control point */

list_control_point:
     procedure (p_cpd_ptr, p_depth);

dcl	1 p_cpd		like control_point_data aligned based (p_cpd_ptr);
dcl	p_cpd_ptr		pointer;

dcl	p_depth		fixed binary parameter;

dcl	1 parent_cpd	like control_point_data aligned based (parent_cpd_ptr);
dcl	parent_cpd_ptr	pointer;
dcl	depth		fixed binary;

dcl	1 cpma		like control_point_meters_argument aligned;

	if p_depth = -1
	then do;					/* caller has asked us to compute it */
		depth = 0;
		do parent_cpd_ptr = p_cpd.parent repeat (parent_cpd.parent) while (parent_cpd_ptr ^= null ());
		     depth = depth + 1;
		end;
	     end;

	else depth = p_depth;			/* caller has supplied it */

	call ioa_ ("^[*^; ^]^6.3b^9t(^12.3b)^27t^3d^33t^a^46t^a", (p_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr),
	     p_cpd.id, p_cpd.id, depth, STATE_NAMES (p_cpd.state), p_cpd.comment);

	if display_meters & (p_cpd.state > CPM_DESTROYED)
	then do;					/* ask cpm_ for the meters to insure they're up-to-date */
		cpma.version = CONTROL_POINT_METERS_ARGUMENT_VERSION_1;
		call cpm_$get_control_point_meters (p_cpd.id, addr (cpma), (0));
		call display_metering_data (addr (cpma.meters));
	     end;

	return;

     end list_control_point;



/* Display the supplied metering data */

display_metering_data:
     procedure (p_meters_ptr);

dcl	1 p_meters	like control_point_meters aligned based (p_meters_ptr);
dcl	p_meters_ptr	pointer;

	call ioa_ ("^11tRuns - ^6d^46tElapsed time - ^a", p_meters.n_schedules, format_time (p_meters.real_time));

	call ioa_ ("^11tCPU time - ^a^46tPage Faults - ^6d", format_time (p_meters.virtual_cpu_time),
	     p_meters.page_faults);

	call ioa_ ("^11tSegment Faults - ^6d^46tBounds Faults - ^6d", p_meters.segment_faults, p_meters.bounds_faults);

	call ioa_ ("^11tVTOC reads - ^6d^46tVTOC writes - ^6d", p_meters.vtoc_reads, p_meters.vtoc_writes);

	call ioa_ ("");

	return;

     end display_metering_data;



/* Format an elapsed time reading as HHH:MM:SS.SSSSSS */

format_time:
     procedure (p_time) returns (character (16));

dcl	p_time		fixed binary (71) parameter;

dcl	1 formatted_time	aligned,
	  2 hours		picture "999" unaligned,
	  2 colon_1	character (1) unaligned,
	  2 minutes	picture "99" unaligned,
	  2 colon_2	character (1) unaligned,
	  2 seconds	picture "99v.999999" unaligned;

dcl	(hours_value, minutes_value, seconds_value)
			fixed binary (71);

	seconds_value = mod (p_time, MICROSECONDS_PER_MINUTE);
	minutes_value = mod ((p_time - seconds_value), MICROSECONDS_PER_HOUR);
	hours_value = p_time - (minutes_value + seconds_value);

	string (formatted_time) = "000:00:00.000000";
	formatted_time.hours = divide (hours_value, MICROSECONDS_PER_HOUR, 10, 0);
	formatted_time.minutes = divide (minutes_value, MICROSECONDS_PER_MINUTE, 7, 0);
	formatted_time.seconds = float (seconds_value) / float (MICROSECONDS_PER_SECOND);

	return (string (formatted_time));

     end format_time;

     end list;
%page;
/* Invoke probe in the specified control point */

probe:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$generate_call_preferred (control_point_data.id, probe_caller, null (), code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to invoke probe in the control point ^12.3b.",
		control_point_data.id);

	return;

     end probe;



/* Invoked by the above internal procedure in the desired control point to actually invoke probe */

probe_caller:
     entry ();

	call probe$probe ();

	return;
%page;
/* Signal program_interrupt in the specified control point */

program_interrupt:
     procedure ();

	if n_arguments = 0
	then call display_usage_message_and_abort ("ID {-control_arg}");

	system_area_ptr = get_system_free_area_ ();

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

	on cleanup
	     begin;
		if pi_preferred_ptr ^= null ()
		then free pi_preferred in (system_area);
		pi_preferred_ptr = null ();
	     end;

	allocate pi_preferred in (system_area) set (pi_preferred_ptr);


/* Parse our arguments */

	cpd_ptr = null ();				/* no ID yet */
	pi_preferred = "1"b;			/* the target should become preferred */

	do argument_idx = 1 to n_arguments;

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

	     if index (argument, "-") = 1
	     then					/* a control argument */
		if argument = "-preferred"
		then pi_preferred = "1"b;
		else if argument = "-not_preferred"
		then pi_preferred = "0"b;

		else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument);

	     else					/* a non-control argument: must be a control point ID */
		if cpd_ptr = null ()
	     then call cv_string_to_control_point_id ();	/* sets cpd_ptr or aborts */

	     else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument);
	end;

	if cpd_ptr = null ()
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A control point ID must be specified.");


/* Push a call to signal program_interrupt onto the target control point's stack */

	revert cleanup;				/* pi_preferred now belongs to the other control point */

	call cpm_$generate_call (control_point_data.id, pi_signaller, pi_preferred_ptr, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code,
		"Trying to signal program_interrupt in the control point ^12.3b.", control_point_data.id);

	return;

     end program_interrupt;
%page;
/* Determine the user CL intermediary for a specific control point */

get_cl_intermediary:
     procedure ();

dcl	cl_intermediary	entry (bit (1) aligned) variable;
dcl	cl_intermediary_name
			character (1024) varying;
dcl	cl_intermediary_entrypoint_name
			character (256);
dcl	cl_intermediary_dirname
			character (168);
dcl	cl_intermediary_ename
			character (32);

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$get_user_cl_intermediary (control_point_data.id, cl_intermediary, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to get the CL intermediary of the control point ^12.3b",
		control_point_data.id);

	call hcs_$fs_get_path_name (codeptr (cl_intermediary), cl_intermediary_dirname, (0), cl_intermediary_ename, (0))
	     ;
	call get_entry_name_ (codeptr (cl_intermediary), cl_intermediary_entrypoint_name, (0), ((8)" "), (0));

	call ioa_$rsnpnnl ("(^a$^a, ^p)", cl_intermediary_name, (0),
	     pathname_ (cl_intermediary_dirname, cl_intermediary_ename), cl_intermediary_entrypoint_name,
	     environmentptr (cl_intermediary));

	if is_active_function			/* return it into the command line */
	then return_value = requote_string_ ((cl_intermediary_name));

	else call ioa_ ("The CL intermediary for the control point ^12.3b is ^a.", control_point_data.id,
		cl_intermediary_name);

	return;

     end get_cl_intermediary;
%page;
/* Set the user CL intermediary for a specific control point */

set_cl_intermediary:
     procedure ();

dcl	cl_intermediary	entry (bit (1) aligned) variable;
dcl	cl_intermediary_name
			character (1024) varying;
dcl	(have_control_point_id, have_cl_intermediary, use_default_cl_intermediary)
			bit (1) aligned;

	if n_arguments = 0
	then call display_usage_message_and_abort ("ID {ENTRY} {-control_arg}");

	have_control_point_id, have_cl_intermediary, use_default_cl_intermediary = "0"b;

	do argument_idx = 1 to n_arguments;

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

	     if index (argument, "-") = 1
	     then					/* a control argument */
		if (argument = "-default") | (argument = "-dft")
		then use_default_cl_intermediary = "1"b;

		else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument);

	     else					/* a non-control argument */
		if ^have_control_point_id
	     then do;
		     call cv_string_to_control_point_id ();
		     have_control_point_id = "1"b;
		end;

	     else if ^have_cl_intermediary
	     then do;
		     cl_intermediary = cv_entry_ (argument, null (), code);
		     if code ^= 0
		     then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument);
		     have_cl_intermediary = "1"b;
		     cl_intermediary_name = argument;
		end;

	     else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument);
	end;

	if ^have_control_point_id
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A control point ID must be specified.");

	if have_cl_intermediary & use_default_cl_intermediary
	then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-default"" and ""^a"".",
		cl_intermediary_name);

	else if ^have_cl_intermediary & ^use_default_cl_intermediary
	then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "An entrypoint or ""-default"" must be specified.")
		;

	if have_cl_intermediary
	then call cpm_$set_user_cl_intermediary (control_point_data.id, cl_intermediary, code);

	else /*** if use_default_cl_intermediary then */
	     call cpm_$set_user_cl_intermediary (control_point_data.id, cpm_$nulle, code);

	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code,
		"Trying to set the CL intermediary of the control point ^12.3b to ^[""^a""^;its default value^].",
		control_point_data.id, have_cl_intermediary, cl_intermediary_name);

	return;

     end set_cl_intermediary;
%page;
/* Determine the unique ID of the preferred control point (if any) */

get_preferred:
     procedure ();

dcl	preferred_control_point_id
			bit (36) aligned;
dcl	id_string		character (12);

	call reject_any_arguments ();

	preferred_control_point_id = cpm_$get_preferred_control_point ();

	if is_active_function			/* return it into the command line */
	then if preferred_control_point_id = ""b
	     then return_value = "none";
	     else do;
		     call ioa_$rsnnl ("^12.3b", id_string, (0), preferred_control_point_id);
		     return_value = id_string;
		end;

	else if preferred_control_point_id = ""b
	then call ioa_ ("There is no preferred control point.");
	else call ioa_ ("Preferred control point ID is ^12.3b.", preferred_control_point_id);

	return;

     end get_preferred;



/* Set the preferred control point */

set_preferred:
     procedure ();

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$set_preferred_control_point (control_point_data.id, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code, "Trying to make the control point ^12.3b preferred.",
		control_point_data.id);

	return;

     end set_preferred;
%page;
/* Set the preferred control point and push the previous one onto the preferred control point stack */

push_preferred:
     procedure ();

dcl	pushed_ok		bit (1) aligned;

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("ID");

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

	call cv_string_to_control_point_id ();		/* sets cpd_ptr or aborts */

	call cpm_$push_preferred_control_point (control_point_data.id, pushed_ok, code);
	if code ^= 0
	then call ssu_$abort_subsystem (sci_ptr, code,
		"Trying to push the preferred stack and make the control point ^12.3b preferred.",
		control_point_data.id);

	if is_active_function			/* return an indication of success into the command line */
	then if pushed_ok
	     then return_value = "true";
	     else return_value = "false";

	return;

     end push_preferred;
%page;
/* Pop the top entry off the preferred control point stack and make it preferred */

pop_preferred:
     procedure ();

dcl	was_pushed	bit (1) aligned;

	if n_arguments ^= 1
	then call display_usage_message_and_abort ("FLAG");

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

	if index (argument, "-") = 1
	then call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument);

	else if argument = "true"
	then was_pushed = "1"b;
	else if argument = "false"
	then was_pushed = "0"b;

	else call ssu_$abort_subsystem (sci_ptr, error_table_$bad_arg, """^a""", argument);

	call cpm_$pop_preferred_control_point (was_pushed);

	return;

     end pop_preferred;

/* format: off */
%page; %include cpm_entries;
%page; %include cpm_internal_data;
%page; %include cpm_control_point_data;
%include cpm_ctrl_pt_meters;
%include process_usage;
%page; %include cpm_create_ctrl_pt_info;
%page; %include stack_header;
/* format: on */

     end control_point_manager_call;




		    cpm_.pl1                        11/04/86  1557.5rew 11/04/86  1031.4      506115



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

/* format: off */

/* Multics Control Point Manager -- The control point manager provides a simple form of mulitasking within a process.
   Each control point is given a separate stack and, optionally, a separate of set the standard I/O switches.  Once given
   control, a control point will continue to run until it either kills itself or attempts to block on an IPC event
   channel.  This module implements the primitive operations of the control point manager. */

/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Written to support control point management in March 1985 by G. Palter
     based on C. Hornig's task_ctl_.
                                                   END HISTORY COMMENTS */

/* format: style3,linecom */

cpm_:
     procedure ();

ERROR_RETURN_FROM_CPM_:
	return;					/* not an entrypoint */


/* Parameters */

dcl	P_control_point_id	bit (36) aligned parameter;
dcl	P_code		fixed binary (35) parameter;

dcl	P_ccpi_ptr	pointer parameter;		/* create: -> description of the new control point */

dcl	P_user_cl_intermediary			/* *user_cl_intermediary: the user's CL intermediary */
			entry (bit (1) aligned) variable parameter;

dcl	P_userproc				/* generate_call*: the entrypoint to be called */
			entry (pointer) variable parameter;
dcl	P_userproc_info_ptr pointer parameter;		/* generate_call*: the argument to the user's entrypoint */

dcl	P_pushed_preferred_control_point		/* (push pop)_preferred_control_point: set ON => we ... */
			bit (1) aligned parameter;	/* ... pushed the preferred control point */

dcl	P_cpma_ptr	pointer parameter;		/* get_*_meters: -> the meters */

dcl	P_cpd_ptr		pointer parameter;		/* update_state_caller: -> the control point */
dcl	P_new_state	fixed binary parameter;	/* update_state_caller: new state for the control point */

dcl	P_mask		bit (36) aligned parameter;	/* *mask_ips_interrupts_caller: the current IPS mask */


/* Remaining declarations */

dcl	1 current_control_point_data			/* the current control point's definition */
			like control_point_data aligned based (current_cpd_ptr);
dcl	current_cpd_ptr	pointer;

dcl	1 parent_control_point_data			/* the identified control point's parent's definition */
			like control_point_data aligned based (control_point_data.parent);

dcl	1 io_switches	like control_point_data.io_switches aligned based (ios_ptr);
dcl	ios_ptr		pointer;

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

dcl	1 decoded_control_point_id
			aligned,
	  2 stack_segno	bit (18) unaligned,
	  2 unique_bits	bit (18) unaligned;

dcl	1 userproc_arg_list aligned,
	  2 header	like arg_list.header,
	  2 arg_ptrs	(1) pointer;

dcl	generate_call_flags bit (36) aligned;
dcl	prior_state	fixed binary;
dcl	target_cpd_ptr	pointer;

dcl	stack_idx		fixed binary;

dcl	mask		bit (36) aligned;

dcl	(
	cpm_et_$already_started,
	cpm_et_$already_stopped,
	cpm_et_$cant_destroy_root,
	cpm_et_$cant_stop_root,
	cpm_et_$cant_wakeup_when_stopped,
	cpm_et_$control_point_not_found,
	cpm_et_$preferred_cant_be_stopped,
	cpm_et_$preferred_stack_overflow,
	cpm_et_$wakeup_ignored,
	error_table_$badcall,
	error_table_$out_of_sequence,
	error_table_$unimplemented_version
	)		fixed binary (35) external;

dcl	(
	sys_info$all_valid_ips_mask,
	sys_info$comm_privilege,
	sys_info$dir_privilege,
	sys_info$ipc_privilege,
	sys_info$rcp_privilege,
	sys_info$ring1_privilege,
	sys_info$seg_privilege,
	sys_info$soos_privilege
	)		bit (36) aligned external;

dcl	continue_to_signal_ entry (fixed binary (35));
dcl	(
	cpm_alm_$call_overseer,
	cpm_alm_$call_generate_call
	)		entry ();
dcl	cpm_alm_$switch_stacks
			entry (pointer);
dcl	cpm_initialize_	entry ();
dcl	cpm_overseer_$cl_intermediary
			entry (bit (36) aligned);
dcl	cpm_overseer_$generate_call
			entry (pointer, entry (pointer), pointer);
dcl	(
	cu_$get_cl_intermediary,
	cu_$set_cl_intermediary
	)		entry (entry (bit (36) aligned));
dcl	get_privileges_	entry () returns (bit (36) aligned);
dcl	get_system_free_area_
			entry () returns (pointer);
dcl	get_temp_segment_	entry (character (*), pointer, fixed binary (35));
dcl	hcs_$get_process_usage
			entry (pointer, fixed binary (35));
dcl	hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$set_ips_mask	entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$set_stack_ptr	entry (pointer);
dcl	ioa_$rsnnl	entry () options (variable);
dcl	ipc_$reassign_call_channels
			entry (bit (36) aligned, bit (36) aligned);
dcl	ipc_$wait_for_an_event
			entry ();
dcl	release_temp_segment_
			entry (character (*), pointer, fixed binary (35));
dcl	sub_err_		entry () options (variable);
dcl	(
	system_privilege_$comm_priv_on,
	system_privilege_$comm_priv_off,
	system_privilege_$dir_priv_on,
	system_privilege_$dir_priv_off,
	system_privilege_$ipc_priv_on,
	system_privilege_$ipc_priv_off,
	system_privilege_$rcp_priv_on,
	system_privilege_$rcp_priv_off,
	system_privilege_$ring1_priv_on,
	system_privilege_$ring1_priv_off,
	system_privilege_$seg_priv_on,
	system_privilege_$seg_priv_off,
	system_privilege_$soos_priv_on,
	system_privilege_$soos_priv_off
	)		entry (fixed binary (35));

dcl	(addr, addwordno, baseno, baseptr, binary, bit, bool, clock, codeptr, currentsize, hbound, length, mod, null,
	stackbaseptr, string, substr, unspec)
			builtin;

dcl	(any_other, cleanup)
			condition;
%page;
/* Create a new control point which is left in the STOPPED state */

create:
     entry (P_ccpi_ptr, P_control_point_id, P_code);

	if stackbaseptr () -> stack_header.cpm_enabled = ""b
	then do;					/* first time in the process */
		call cpm_initialize_ ();
		current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;
	     end;

	ccpi_ptr = P_ccpi_ptr;			/* copy input parameter for the internal procedure */

	system_area_ptr = get_system_free_area_ ();

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	cpd_ptr = null ();				/* for cleanup handler */
	on cleanup
	     begin;
		if cpd_ptr ^= null ()
		then call destroy_control_point (cpd_ptr);
	     end;

	call create_control_point ();			/* does most of the work */

	call push_call_frame (cpm_alm_$call_overseer, unspec (create_control_point_info),
	     create_control_point_info.initproc.entry, create_control_point_info.initproc.info_ptr);

	P_control_point_id = control_point_data.id;
	P_code = 0;				/* success */

	return;


/* Control arrives here iff an error occured while creating the control point */

ERROR_RETURN_FROM_CPM_$CREATE:
	if cpd_ptr ^= null ()
	then call destroy_control_point (cpd_ptr);
	return;					/* create_failure procedure has already set P_code */
%page;
/* Destroy the specified control point -- This entrypoint queues a call to cpm_$call_self_destruct onto the target control
   point's stack and then forces the scheduler to run that control point. */

destroy:
     entry (P_control_point_id, P_code);

	call check_initialization ("cpm_$destroy");	/* aborts if not initialized */

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */
	if cpd_ptr = addr (cpm_data_$root_control_point_data)
	then do;					/* the root control point is sacred */
		P_code = cpm_et_$cant_destroy_root;
		return;
	     end;

	call generate_call (P_control_point_id, call_self_destruct, null (), P_code);

	return;



/* This entrypoint is called by cpm_$destroy on the stack of the control point which is to be destroyed.  It does a
   non-local goto to the control point's destroy label which has been initialized to cpm_$self_destruct.  The non-local
   goto will unwind the entire stack allowing any cleanup handlers to be run. */

call_self_destruct:
     entry ();

	cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;

	if codeptr (control_point_data.destroy) = codeptr (self_destruct)
	then go to control_point_data.destroy;		/* transfer to the self_destruct entrypoint */
	else call sub_err_ (cpm_et_$cant_destroy_root, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0);



/* This entrypoint is not actually called but, rather, is the target of the non-local goto performed above by
   cpm_$call_self_destruct.  This entrypoint will update the control point's state to DEAD and then invoke the scheduler
   to find something else to do. */

self_destruct:
     entry ();

	current_cpd_ptr, cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	call update_state (CPM_DESTROYED);		/* this control point is ready for destruction */

	do while ("1"b);				/* find something else to do */
	     call scheduler$find_runnable ();
	end;
%page;
/* Start the specified control point -- Places the control point into the READY state if it was STOPPED */

start:
     entry (P_control_point_id, P_code);

	call check_initialization ("cpm_$start");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if control_point_data.state = CPM_STOPPED
	then do;
		call update_state (CPM_READY);
		P_code = 0;			/* success */
	     end;

	else P_code = cpm_et_$already_started;		/* it's already running or blocked */

	return;



/* Stop the specified control point -- Places the control point into the STOPPED state if it was READY or BLOCKED */

stop:
     entry (P_control_point_id, P_code);

	call check_initialization ("cpm_$stop");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */
	if cpd_ptr = addr (cpm_data_$root_control_point_data)
	then do;					/* the root control point is sacred */
		P_code = cpm_et_$cant_stop_root;
		return;
	     end;

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if (control_point_data.state = CPM_READY) | (control_point_data.state = CPM_BLOCKED)
	then do;
		call update_state (CPM_STOPPED);
		P_code = 0;			/* success */
	     end;

	else P_code = cpm_et_$already_stopped;		/* it was stopped earlier */

	return;
%page;
/* Block the current control point */

block:
     entry ();

	call check_initialization ("cpm_$block");	/* sets current_cpd_ptr */
	cpd_ptr = current_cpd_ptr;

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if control_point_data.state = CPM_READY
	then call update_state (CPM_BLOCKED);

	return;



/* Wakeup the specified control point -- Places the control point into the READY state if it was BLOCKED */

wakeup:
     entry (P_control_point_id, P_code);

	call check_initialization ("cpm_$wakeup");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if control_point_data.state = CPM_BLOCKED
	then do;
		call update_state (CPM_READY);
		P_code = 0;			/* success */
	     end;

	else if control_point_data.state = CPM_READY	/* it's already awake */
	then P_code = cpm_et_$wakeup_ignored;

	else P_code = cpm_et_$cant_wakeup_when_stopped;	/* it's stopped and must be started first */

	return;
%page;
/* Run the scheduler to find the highest priority ready control point and give control to said control point */

scheduler:
     entry ();

	call check_initialization ("cpm_$scheduler");

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	call scheduler$find_runnable ();

	return;
%page;
/* Return the user CL intermediary for a given control point -- The user CL intermediary is invoked by
   cpm_cl_intermediary_ (the control point CL intermediary) before actually establishing a new command level or stopping
   the control point.  The user's intermediary can take whatever actions it desires and then inform the control point's
   intermediary either to return to the caller of cu_$cl (i.e., a "start" command) or to continue with the standard CL
   intermediary operation. */

get_user_cl_intermediary:
     entry (P_control_point_id, P_user_cl_intermediary, P_code);

	call check_initialization ("cpm_$get_user_cl_intermediary");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */

	P_user_cl_intermediary = control_point_data.user_cl_intermediary;

	P_code = 0;				/* success */

	return;



/* Set the user CL intermediary for a given control point -- See the get_user_cl_intermediary entrypoint for a description
   of this feature. */

set_user_cl_intermediary:
     entry (P_control_point_id, P_user_cl_intermediary, P_code);

	call check_initialization ("cpm_$set_user_cl_intermediary");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */

	control_point_data.user_cl_intermediary = P_user_cl_intermediary;

	P_code = 0;				/* success */

	return;



/* A "null" entry variable which should never be called -- Used as the initial value for user's CL intermediarys */

nulle:
     entry () options (variable);

	call sub_err_ (error_table_$badcall, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0,
	     "The ""null"" entry value can not be invoked.");
%page;
/* Generate a call to the supplied user program in another control point */

generate_call:					/* ... run it immediately */
     entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code);

	generate_call_flags = CPM_GC_FORCE_READY;
	go to BEGIN_GENERATE_CALL;


generate_call_preferred:				/* ... run it immediately as the preferred control point */
     entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code);

	generate_call_flags = CPM_GC_FORCE_READY | CPM_GC_PUSH_PREFERRED;
	go to BEGIN_GENERATE_CALL;


generate_call_when_ready:				/* ... run it when it next becomes READY */
     entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code);

	generate_call_flags = ""b;
	go to BEGIN_GENERATE_CALL;


BEGIN_GENERATE_CALL:
	call check_initialization ("cpm_$generate_call");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the call entirely */

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();


	if current_cpd_ptr = cpd_ptr
	then do;

/* The call is to take place in this control point -- Invoke the user's program directly but first place the control point
   into the same state as it would be in after releasing control via the scheduler.  This action is necessary to insure
   that cpm_overseer_$generate_call will operate correctly.  See the internal procedure switch_control_points for an
   explanation of the various operations performed here. */

		call mask_ips_interrupts (mask);	/* can't be interrupted */
		current_control_point_data.ips_mask = mask;

		current_control_point_data.privileges = get_privileges_ ();
		call cu_$get_cl_intermediary (current_control_point_data.cl_intermediary);

		if current_control_point_data.swapped_switches
		     | different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
		then call save_io_switches ();	/* save when cpm_overseer_$generate_call expects to restore */

		if trace_$transaction_begin (1)	/* disable tracing temporarily */
		then ;

		unspec (userproc_arg_list.header) = ""b;/* setup the argument list for the user's procedure */
		userproc_arg_list.header.call_type = Interseg_call_type;
		userproc_arg_list.header.arg_count = 1;
		userproc_arg_list.arg_ptrs (1) = addr (P_userproc_info_ptr);

		call cpm_overseer_$generate_call (addr (generate_call_flags), P_userproc, addr (userproc_arg_list));
						/* make the call */

		if trace_$transaction_end (1)		/* turn tracing back on */
		then ;

		if current_control_point_data.swapped_switches
		     | different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
		then call restore_io_switches ();	/* restore our switches if we saved them above */

		call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary);
		call restore_privileges ();		/* put our privileges and CL intermediary back */

		mask = current_control_point_data.ips_mask;
		call unmask_ips_interrupts (mask);	/* allow IPS interrupts again */
	     end;


	else do;

/* The call is to take place in some other control point -- Push the necessary frame on its stack and run it immediately
   if requested.  If we do schedule it immediately, we must also temporarily change this control point's state to READY so
   that, after the other control point finishes or blocks, this control point will be able to run and clean up the stack
   frames associated with this generate_call. */

		call push_call_frame (cpm_alm_$call_generate_call, generate_call_flags, P_userproc,
		     P_userproc_info_ptr);

		if generate_call_flags & CPM_GC_FORCE_READY
		then do;				/* run the other control point right now */
			prior_state = current_control_point_data.state;

			if current_control_point_data.state ^= CPM_READY
			then do;			/* ... must make the current control point READY */
				target_cpd_ptr = cpd_ptr;
				cpd_ptr = current_cpd_ptr;
				call update_state (CPM_READY);
				cpd_ptr = target_cpd_ptr;
			     end;

			/*** A cleanup handler to restore the current control point state isn't necessary because,
			     if a non-local goto occurs, it can only have happened while this control point was
			     ready and, if we were blocked, we are about to punt the call to ipc_$block which put us
			     into that state. */

			call scheduler$run_specific_control_point ();

			if prior_state ^= CPM_READY
			then do;			/* ... put the current control point back */
				cpd_ptr = current_cpd_ptr;
				call update_state (prior_state);
			     end;
		     end;
	     end;

	P_code = 0;				/* success */

	return;
%page;
/* Return the identity of the currently preferred control point -- The preferred control point is always given priority
   over all others whenever it is ready.  In addition, cu_$cl will actually only invoke a new control point when called in
   the preferred control point. */

get_preferred_control_point:
     entry () returns (bit (36) aligned);

	call check_initialization ("cpm_$get_preferred_control_point");

	if cpm_data_$preferred_control_point ^= null ()
	then return (cpm_data_$preferred_control_point -> control_point_data.id);
	else return ((36)"0"b);			/* none at present */



/* Set the preferred control point to the specified control point iff it isn't STOPPED */

set_preferred_control_point:
     entry (P_control_point_id, P_code);

	call check_initialization ("cpm_$set_preferred_control_point");

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the entire call */
	if control_point_data.state = CPM_STOPPED
	then do;
		P_code = cpm_et_$preferred_cant_be_stopped;
		return;
	     end;

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if cpm_data_$preferred_control_point ^= cpd_ptr
	then do;					/* actually switching control points */
		call mask_ips_interrupts (mask);
		call switch_preferred_control_points ();
		call unmask_ips_interrupts (mask);
	     end;

	P_code = 0;				/* success */

	return;
%page;
/* Push the preferred control point -- Saves the current preferred control point on the top of the stack and makes the
   specified control point preferred.  If a control point is actually pushed, the P_pushed_preferred_control_point
   parameter will be set.  That parameter must be used in subsequent calls to pop the stack. */

push_preferred_control_point:
     entry (P_control_point_id, P_pushed_preferred_control_point, P_code);

	call check_initialization ("cpm_$push_preferred_control_point");

	P_pushed_preferred_control_point = "0"b;	/* initialize this parameter for cleanup handlers */

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the entire call */
	if control_point_data.state = CPM_STOPPED
	then do;
		P_code = cpm_et_$preferred_cant_be_stopped;
		return;
	     end;

	if cpm_data_$preferred_control_point_stack.stack_depth
	     = hbound (cpm_data_$preferred_control_point_stack.cpd_ptr_stack, 1)
	then do;					/* the stack is already full */
		P_code = cpm_et_$preferred_stack_overflow;
		return;
	     end;

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if cpm_data_$preferred_control_point ^= cpd_ptr
	then do;					/* we're actually switching preferred control points */

		call mask_ips_interrupts (mask);

		cpm_data_$preferred_control_point_stack.stack_depth, stack_idx =
		     cpm_data_$preferred_control_point_stack.stack_depth + 1;

		cpm_data_$preferred_control_point_stack.cpd_ptr_stack (stack_idx) = cpm_data_$preferred_control_point;

		call switch_preferred_control_points ();

		P_pushed_preferred_control_point = "1"b;

		call unmask_ips_interrupts (mask);
	     end;

	P_code = 0;				/* success */

	return;
%page;
/* Pop the preferred control point stack by making the top of the stack the new preferred control point if and only if
   the P_pushed_preferred_control_point parameter is "1"b. */

pop_preferred_control_point:
     entry (P_pushed_preferred_control_point);

	call check_initialization ("cpm_$pop_preferred_control_point");

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	if P_pushed_preferred_control_point		/* the caller did push it */
	then do;

		call mask_ips_interrupts (mask);

		P_pushed_preferred_control_point = "0"b;/* once is enough, thank you */

		if cpm_data_$preferred_control_point_stack.stack_depth > 0
		then do;				/* and there's something on the stack */
			stack_idx = cpm_data_$preferred_control_point_stack.stack_depth;
			cpm_data_$preferred_control_point_stack.stack_depth = stack_idx - 1;

			cpd_ptr = cpm_data_$preferred_control_point_stack.cpd_ptr_stack (stack_idx);

			call switch_preferred_control_points ();
		     end;

		call unmask_ips_interrupts (mask);
	     end;

	return;
%page;
/* Return the usage meters recorded for a given control point */

get_control_point_meters:
     entry (P_control_point_id, P_cpma_ptr, P_code);

	call check_initialization ("cpm_$get_control_point_meters");

	cpma_ptr = P_cpma_ptr;
	if control_point_meters_argument.version ^= CONTROL_POINT_METERS_ARGUMENT_VERSION_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call find_control_point (P_control_point_id);	/* sets cpd_ptr or aborts the entire call */

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	call update_meters (current_control_point_data.meters, (0));
						/* insure that all usage values are up-to-date */

	control_point_meters_argument.meters = control_point_data.meters;
	control_point_meters_argument.number_wanted, control_point_meters_argument.number_can_return =
	     MAX_NUMBER_OF_METERS;

	P_code = 0;				/* success */

	return;



/* Return the usage meters recorded for the control point scheduler */

get_scheduler_meters:
     entry (P_cpma_ptr, P_code);

	call check_initialization ("cpm_$get_scheduler_meters");

	cpma_ptr = P_cpma_ptr;
	if control_point_meters_argument.version ^= CONTROL_POINT_METERS_ARGUMENT_VERSION_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	control_point_meters_argument.meters = cpm_data_$global_meters.overhead;
	control_point_meters_argument.number_wanted, control_point_meters_argument.number_can_return =
	     MAX_NUMBER_OF_METERS;

	P_code = 0;				/* success */

	return;
%page;
/* Validate that control point management is enabled */

check_initialization:
     procedure (p_entrypoint_name);

dcl	p_entrypoint_name	character (*) parameter;

	if stackbaseptr () -> stack_header.cpm_enabled	/* we are on: find the current control point's definition */
	then current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;

	else call sub_err_ (error_table_$out_of_sequence, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0,
		"At least one call to cpm_$create must preceed any call to ^a.", p_entrypoint_name);

	return;

     end check_initialization;



/* Find the control_point_data for the request control point or abort the call completely */

find_control_point:
     procedure (p_control_point_id);

dcl	p_control_point_id	bit (36) aligned parameter;

	string (decoded_control_point_id) = p_control_point_id;

	if cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0))
	then do;					/* the given ID does identify a valid stack */
		cpd_ptr = baseptr (decoded_control_point_id.stack_segno) -> stack_header.cpm_data_ptr;
		if control_point_data.id = p_control_point_id
		then return;			/* and the stack does indeed belong to that control point */
	     end;

	/*** Control arrives here iff the supplied control point ID is invalid */
	P_code = cpm_et_$control_point_not_found;
	go to ERROR_RETURN_FROM_CPM_;

     end find_control_point;
%page;
/* Mask all IPS interrupts */

mask_ips_interrupts:
     procedure (p_mask);

dcl	p_mask		bit (36) aligned parameter;

	call hcs_$set_ips_mask (""b, p_mask);

     end mask_ips_interrupts;


/* Invoke mask_ips_interrupts -- This entrypoint exists to prevent making the mask_ips_interrupts internal procedure
   non-quick by invoking it from within an on unit or other non-quick procedure. */

mask_ips_interrupts_caller:
     entry (P_mask);

	call mask_ips_interrupts (P_mask);
	return;



/* Restore the IPS mask to its state prior to calling mask_ips_interrupts */

unmask_ips_interrupts:
     procedure (p_mask);

dcl	p_mask		bit (36) aligned parameter;

	if substr (p_mask, 36, 1) = "1"b
	then call hcs_$reset_ips_mask (p_mask, p_mask);

     end unmask_ips_interrupts;


/* Invoke unmask_ips_interrupts -- This entrypoint exists to prevent making the unmask_ips_interrupts internal procedure
   non-quick by invoking it from within an on unit or other non-quick procedure. */

unmask_ips_interrupts_caller:
     entry (P_mask);

	call unmask_ips_interrupts (P_mask);
	return;



/* The any_other handler established whenever we have masked IPS signals */

any_other_handler:
     procedure ();

	call unmask_ips_interrupts_caller (mask);

	call continue_to_signal_ ((0));		/* be sure the error gets through */

     end any_other_handler;
%page;
/* Restore the current control point's system privileges -- We need not worry about access to system_privilege_ as we only
   call it when we actually discover that a privilege has changed and the only way to change privileges is to use the
   system_privilege_ gate itself. */

restore_privileges:
     procedure ();

dcl	current_privileges	bit (36) aligned;

	current_privileges = get_privileges_ ();

	if current_control_point_data.privileges = current_privileges
	then return;				/* privileges are already correct */

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$comm_privilege
	then if current_control_point_data.privileges & sys_info$comm_privilege
	     then call system_privilege_$comm_priv_on ((0));
	     else call system_privilege_$comm_priv_off ((0));

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$dir_privilege
	then if current_control_point_data.privileges & sys_info$dir_privilege
	     then call system_privilege_$dir_priv_on ((0));
	     else call system_privilege_$dir_priv_off ((0));

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$ipc_privilege
	then if current_control_point_data.privileges & sys_info$ipc_privilege
	     then call system_privilege_$ipc_priv_on ((0));
	     else call system_privilege_$ipc_priv_off ((0));

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$rcp_privilege
	then if current_control_point_data.privileges & sys_info$rcp_privilege
	     then call system_privilege_$rcp_priv_on ((0));
	     else call system_privilege_$rcp_priv_off ((0));

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$ring1_privilege
	then if current_control_point_data.privileges & sys_info$ring1_privilege
	     then call system_privilege_$ring1_priv_on ((0));
	     else call system_privilege_$ring1_priv_off ((0));

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$seg_privilege
	then if current_control_point_data.privileges & sys_info$seg_privilege
	     then call system_privilege_$seg_priv_on ((0));
	     else call system_privilege_$seg_priv_off ((0));

	if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$soos_privilege
	then if current_control_point_data.privileges & sys_info$soos_privilege
	     then call system_privilege_$soos_priv_on ((0));
	     else call system_privilege_$soos_priv_off ((0));

	return;

     end restore_privileges;
%page;
/* Save the current control point's standard I/O switches -- Always called with all IPS signals masked */

save_io_switches:
     procedure ();

	if current_control_point_data.swapped_switches
	then ios_ptr = addr (cpm_data_$root_control_point_data.io_switches);
	else ios_ptr = addr (current_control_point_data.io_switches);

	call iox_$move_attach (iox_$user_io, io_switches.user_io, (0));
	call iox_$move_attach (iox_$user_input, io_switches.user_input, (0));
	call iox_$move_attach (iox_$user_output, io_switches.user_output, (0));
	call iox_$move_attach (iox_$error_output, io_switches.error_output, (0));

	return;

     end save_io_switches;


/* Restore the current control point's standard I/O switches -- Always called with all IPS signals masked */

restore_io_switches:
     procedure ();

	if current_control_point_data.swapped_switches
	then ios_ptr = addr (cpm_data_$root_control_point_data.io_switches);
	else ios_ptr = addr (current_control_point_data.io_switches);

	call iox_$move_attach (io_switches.user_io, iox_$user_io, (0));
	call iox_$move_attach (io_switches.user_input, iox_$user_input, (0));
	call iox_$move_attach (io_switches.user_output, iox_$user_output, (0));
	call iox_$move_attach (io_switches.error_output, iox_$error_output, (0));

	return;

     end restore_io_switches;



/* Determines if the two specified control points use different sets of standard I/O switches */

different_switches:
     procedure (p_cpd_1_ptr, p_cpd_2_ptr) returns (bit (1) aligned);

dcl	1 cpd_1		like control_point_data aligned based (p_cpd_1_ptr);
dcl	1 cpd_2		like control_point_data aligned based (p_cpd_2_ptr);
dcl	(p_cpd_1_ptr, p_cpd_2_ptr)
			pointer parameter;

	if cpd_1.swapped_switches & cpd_2.swapped_switches
	then return ("0"b);				/* both control points are using the root's switches */

	else if cpd_1.group_id = cpd_2.group_id		/* same group: they use the same switches ... */
	then return (cpd_1.swapped_switches ^= cpd_2.swapped_switches);
						/* ... unless one is using the root's but not the other */

	else if (cpd_1.swapped_switches & (cpd_2.group_id = cpm_data_$root_control_point_data.group_id))
	     | (cpd_2.swapped_switches & (cpd_1.group_id = cpm_data_$root_control_point_data.group_id))
	then return ("0"b);				/* different groups: but one is swapped to the other */

	else return ("1"b);				/* different groups really using different switches */

     end different_switches;
%page;
/* The control point scheduler */

scheduler:
     procedure ();
	return;					/* not used */


/* Run the control point at the top of the ready queue -- If there are no ready control points, wait for an IPC event to
   make one or more control points eligible. */

scheduler$find_runnable:
     entry ();

	call update_meters (current_control_point_data.meters, cpm_data_$global_meters.overhead.n_schedules);

	if cpm_data_$ready_queue.first = null ()
	then do;					/* nothing ready at present */
		if (current_cpd_ptr ^= cpm_data_$preferred_control_point)
		     & (cpm_data_$preferred_control_point ^= null ())
		then if cpm_data_$preferred_control_point -> control_point_data.state = CPM_BLOCKED
		     then do;			/* ... preferred is blocked: better to hcs_$block in it */
			     cpd_ptr = cpm_data_$preferred_control_point;
			     call switch_control_points ();
			end;
		do while (cpm_data_$ready_queue.first = null ());
		     call ipc_$wait_for_an_event ();	/* ... we are preferred or he's not blocked: hcs_$block */
		end;
	     end;

	cpd_ptr = cpm_data_$ready_queue.first;		/* run whoever's on top */

	call switch_control_points ();		/* THUNK! */

	if cpm_data_$gc_control_points		/* there are control points we can eliminate */
	then call gc_dead_control_points ();

	call update_meters (cpm_data_$global_meters.overhead, current_control_point_data.meters.n_schedules);

	return;



/* Run the selected control point */

scheduler$run_specific_control_point:
     entry ();

	call update_meters (current_control_point_data.meters, cpm_data_$global_meters.overhead.n_schedules);

	call switch_control_points ();		/* THUNK! */

	if cpm_data_$gc_control_points		/* there are control points we can eliminate */
	then call gc_dead_control_points ();

	call update_meters (cpm_data_$global_meters.overhead, current_control_point_data.meters.n_schedules);

	return;
%page;
/* Actual code to switch from one control point to another */

switch_control_points:
     procedure ();

	if current_cpd_ptr = cpd_ptr			/* asked to run ourselves -- nothing to do */
	then return;

	call mask_ips_interrupts (mask);		/* can't be interrupted during this process */


/* Save the present IPS mask, system privileges, and CL intermediary in the control point's definition -- Each control
   point is permitted to manipulate these per-process values as if it were the only control point in the process.
   Therefore, we must save and restore these values whenever we switch control points to insure that each control point's
   settings of these mechansims will be undisturbed by other control points */

	current_control_point_data.ips_mask = mask;

	current_control_point_data.privileges = get_privileges_ ();

	call cu_$get_cl_intermediary (current_control_point_data.cl_intermediary);


/* Save our standard I/O switches if they are not the same set as used by the control point about to be run */

	if different_switches (current_cpd_ptr, cpd_ptr)
	then call save_io_switches ();


/* Switch Stacks -- We must inform inform ring-0 of the change so it will properly signal faults, IPS interrupts, etc. */

	cpm_data_$previous_control_point = current_cpd_ptr;

	if trace_$transaction_begin (1)		/* disable tracing -- let the new control point ... */
	then ;					/* ... reenable it if appropriate */

	call hcs_$set_stack_ptr (control_point_data.stack_ptr);

	call cpm_alm_$switch_stacks (control_point_data.stack_ptr);

	/*** Immediately after the above call, control returns to this point in the new control point we chose to run.
	     Consequently, current_control_point_data now refers to the control point referenced above as
	     control_point_data and the control point referenced above as current_control_point_data is now referenced
	     through cpm_data_$previous_control_point. */

	if trace_$transaction_end (1)			/* reenable tracing if it was running in this control point */
	then ;


/* Restore our I/O switches */

	if different_switches (current_cpd_ptr, cpm_data_$previous_control_point)
	then call restore_io_switches ();


/* Restore our saved CL intermediary, system privileges, and IPS mask */

	call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary);

	call restore_privileges ();

	mask = current_control_point_data.ips_mask;
	call unmask_ips_interrupts (mask);		/* let IPS through again */

	return;

     end switch_control_points;
%page;
/* Finish the destruction of any dead control points */

gc_dead_control_points:
     procedure ();

	system_area_ptr = get_system_free_area_ ();	/* needed by destroy_control_point */

	call gc_worker (addr (cpm_data_$root_control_point_data));

	cpm_data_$gc_control_points = "0"b;		/* we've done all we can for now */

	return;



/* Actually walks the tree of control points looking for those which can be eliminated */

gc_worker:
     procedure (p_cpd_ptr) recursive;

dcl	1 p_control_point_data
			like control_point_data aligned based (p_cpd_ptr);
dcl	p_cpd_ptr		pointer parameter;

dcl	1 a_control_point_data
			like control_point_data aligned based (a_cpd_ptr);
dcl	a_cpd_ptr		pointer;

dcl	next_cpd_ptr	pointer;

	/*** Walk the control point's list of children and flush any of them that are dead */
	do a_cpd_ptr = p_control_point_data.first_child repeat (next_cpd_ptr) while (a_cpd_ptr ^= null ());
	     next_cpd_ptr = a_control_point_data.next_peer;
	     call gc_worker (a_cpd_ptr);
	end;

	/*** If this control point is dead and has no children, eliminate it */
	if (p_control_point_data.state = CPM_DESTROYED) & (p_control_point_data.first_child = null ())
	then call destroy_control_point (p_cpd_ptr);

	return;

     end gc_worker;

     end gc_dead_control_points;

     end scheduler;
%page;
/* Update the meters for a given control point or for the scheduler itself */

update_meters:
     procedure (p_meters, p_n_schedules);

dcl	1 p_meters	like control_point_meters aligned parameter;
dcl	p_n_schedules	fixed binary parameter;

dcl	1 local_usage	like process_usage aligned;
dcl	local_real_time	fixed binary (71);

	local_real_time = clock ();			/* to compute real-time change */

	local_usage.number_wanted = MAX_NUMBER_OF_METERS; /* get all the meters */
	call hcs_$get_process_usage (addr (local_usage), (0));

	call mask_ips_interrupts (mask);		/* update them uniterruptably */

	p_n_schedules = p_n_schedules + 1;		/* count the scheduling */

	p_meters.real_time = p_meters.real_time + local_real_time - cpm_data_$global_meters.last_meters.real_time;
	p_meters.usage = p_meters.usage + local_usage - cpm_data_$global_meters.last_meters.usage;

	cpm_data_$global_meters.last_meters.real_time = local_real_time;
	cpm_data_$global_meters.last_meters.usage = local_usage;

	call unmask_ips_interrupts (mask);

	return;

     end update_meters;
%page;
/* Changes the state of a control point */

update_state:
     procedure (p_new_state);

dcl	p_new_state	fixed binary parameter;

	if p_new_state = control_point_data.state	/* the control point is already in the requested state */
	then return;

	call mask_ips_interrupts (mask);

	if control_point_data.preferred & ((p_new_state = CPM_DESTROYED) | (p_new_state = CPM_STOPPED))
	then do;					/* only READY or BLOCKED control points can be preferred */
		call set_preferred_control_point (cpm_data_$root_control_point_data.id, (0));
	     end;					/* ... so try to switch it to the root control point */

	if control_point_data.state = CPM_READY		/* it's about to become not ready: remove it from the queue */
	then call remove_from_ready_queue ();

	control_point_data.state = p_new_state;

	if control_point_data.state = CPM_READY		/* it's been made ready: stick it into the ready queue */
	then call insert_into_ready_queue ();

	else if control_point_data.state = CPM_DESTROYED	/* it's been killed */
	then do;
		call ipc_$reassign_call_channels (control_point_data.id, parent_control_point_data.id);
		string (decoded_control_point_id) = control_point_data.id;
		cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) = "0"b;
		cpm_data_$gc_control_points = "1"b;	/* ... we need to cleanup when next possible */
		cpm_data_$n_control_points = cpm_data_$n_control_points - 1;
	     end;

	call unmask_ips_interrupts (mask);

	return;

     end update_state;



/* Invoke update_state -- Called by cpm_overseer_$generate_call */

update_state_caller:
     entry (P_cpd_ptr, P_new_state);

	mask = ""b;				/* for any_other handler */
	on any_other call any_other_handler ();

	cpd_ptr = P_cpd_ptr;

	call update_state (P_new_state);

	return;
%page;
/* Sets the preferred control point -- Rethreads the ready queue to reflect the change in priority of the old and new
   preferred control points */

switch_preferred_control_points:
     procedure ();

dcl	old_preferred_cpd_ptr
			pointer;

	control_point_data.preferred = "1"b;		/* this control point is now preferred */

	if control_point_data.state = CPM_READY
	then do;					/* it's ready: rethread it to the top of the queue */
		call remove_from_ready_queue ();
		call insert_into_ready_queue ();
	     end;


/* Actually switch preferred control points */

	old_preferred_cpd_ptr = cpm_data_$preferred_control_point;

	cpm_data_$preferred_control_point = cpd_ptr;	/* establish the new preferred control point */

	cpd_ptr = old_preferred_cpd_ptr;


/* control_point_data now refers to the old preferred control point */

	control_point_data.preferred = "0"b;		/* it's no longer special */

	if control_point_data.state = CPM_READY
	then do;					/* rethread to reflect its lowered priority */
		call remove_from_ready_queue ();
		call insert_into_ready_queue ();
	     end;

	return;

     end switch_preferred_control_points;
%page;
/* Inserts a control point into the ready queue -- This procedure expects its caller to have masked IPS interrupts. */

insert_into_ready_queue:
     procedure ();

dcl	(prev_cpd_ptr, next_cpd_ptr)
			pointer;

	prev_cpd_ptr = null ();			/* assume it goes at the beginning of the queue */
	next_cpd_ptr = cpm_data_$ready_queue.first;

	if control_point_data.preferred		/* it should always have first priority */
	then go to INSERT_INTO_THE_LIST;

	do next_cpd_ptr = cpm_data_$ready_queue.first repeat (next_cpd_ptr -> control_point_data.next_ready)
	     while (next_cpd_ptr ^= null ());
	     if (next_cpd_ptr -> control_point_data.priority > control_point_data.priority)
		& ^next_cpd_ptr -> control_point_data.preferred
	     then go to INSERT_INTO_THE_LIST;		/* next one is lower priority and not preferred */
	     else prev_cpd_ptr = next_cpd_ptr;
	end;					/* add to the end of the queue if we fall through */

INSERT_INTO_THE_LIST:
	if prev_cpd_ptr = null ()			/* put it at the top of the queue */
	then cpm_data_$ready_queue.first = cpd_ptr;
	else prev_cpd_ptr -> control_point_data.next_ready = cpd_ptr;

	if next_cpd_ptr = null ()			/* put it at the end of the queue */
	then cpm_data_$ready_queue.last = cpd_ptr;
	else next_cpd_ptr -> control_point_data.prev_ready = cpd_ptr;

	control_point_data.prev_ready = prev_cpd_ptr;
	control_point_data.next_ready = next_cpd_ptr;

	return;

     end insert_into_ready_queue;



/* Removes a control point from the ready queue -- This procedure expects its caller to have masked IPS interrupts. */

remove_from_ready_queue:
     procedure ();

	if control_point_data.prev_ready = null ()	/* we are at the top of the queue */
	then cpm_data_$ready_queue.first = control_point_data.next_ready;
	else control_point_data.prev_ready -> control_point_data.next_ready = control_point_data.next_ready;

	if control_point_data.next_ready = null ()	/* we are at the bottom of the queue */
	then cpm_data_$ready_queue.last = control_point_data.prev_ready;
	else control_point_data.next_ready -> control_point_data.prev_ready = control_point_data.prev_ready;

	control_point_data.ready_queue = null ();	/* complete the removal process */

	return;

     end remove_from_ready_queue;
%page;
/* Creates a new control point */

create_control_point:
     procedure () options (non_quick);

dcl	code		fixed binary (35);

	if create_control_point_info.version ^= CREATE_CONTROL_POINT_INFO_VERSION_1
	then call create_failure (error_table_$unimplemented_version);

	call mask_ips_interrupts_caller (mask);		/* avoid interrupts until we can clean up properly */

	allocate control_point_data in (system_area) set (cpd_ptr);
	control_point_data.stack_ptr, control_point_data.parent, control_point_data.peers = null ();

	call unmask_ips_interrupts_caller (mask);	/* the cleanup handler will now work OK */

	call get_temp_segment_ (cpm_data_$subsystem_name, control_point_data.stack_ptr, code);
	if code ^= 0
	then call create_failure (code);


/* Setup most of the control point's data */

	decoded_control_point_id.stack_segno = baseno (control_point_data.stack_ptr);
	decoded_control_point_id.unique_bits = substr (bit (clock (), 71), 54, 18);
	control_point_data.id = string (decoded_control_point_id);

	control_point_data.state = CPM_STOPPED;		/* the user must start it */

	control_point_data.priority = create_control_point_info.priority;
	control_point_data.preferred = "0"b;		/* it's an ordinary control point */

	control_point_data.last_frame_ptr = null ();	/* cpm_alm_$switch_stacks hasn't been used yet */

	if create_control_point_info.independent
	then control_point_data.parent = addr (cpm_data_$root_control_point_data);
	else control_point_data.parent = stackbaseptr () -> stack_header.cpm_data_ptr;

	control_point_data.peers,			/* we haven't threaded it into any lists yet */
	     control_point_data.children, control_point_data.ready_queue = null ();

	if create_control_point_info.user_cl_intermediary_given
	then control_point_data.user_cl_intermediary = create_control_point_info.user_cl_intermediary;
	else control_point_data.user_cl_intermediary = nulle;

	control_point_data.comment = create_control_point_info.comment;

	control_point_data.ips_mask = sys_info$all_valid_ips_mask;
	substr (control_point_data.ips_mask, 36) = "1"b;	/* start with all IPS interrupts enabled */

	control_point_data.privileges = ""b;		/* start with no privileges */

	control_point_data.cl_intermediary = cpm_overseer_$cl_intermediary;
						/* start with the "standard" CL intermediary */

	control_point_data.io_switches = parent_control_point_data.io_switches;
	control_point_data.group_id = parent_control_point_data.group_id;
						/* we'll share our parent's switches until we've run once */

	control_point_data.meters = 0;		/* hasn't been used yet */


/* Initialize the new control point's stack by copying its parent's stack header */

	call mask_ips_interrupts_caller (mask);		/* the rest of this operation must not be interrupted */

	if trace_$transaction_begin (1)
	then ;					/* new stack should have standard operator pointers */

	control_point_data.stack_ptr -> stack_header = parent_control_point_data.stack_ptr -> stack_header;
	control_point_data.stack_ptr -> stack_header.stack_begin_ptr,
	     control_point_data.stack_ptr -> stack_header.stack_end_ptr =
	     addwordno (control_point_data.stack_ptr, currentsize (control_point_data.stack_ptr -> stack_header));

	control_point_data.stack_ptr -> stack_header.cpm_data_ptr = cpd_ptr;
	control_point_data.stack_ptr -> stack_header.cpm_enabled = substr(control_point_data.id,1,length(stack_header.cpm_enabled));

	unspec (control_point_data.stack_ptr -> stack_header.trace) = ""b;

	if trace_$transaction_end (1)
	then ;

	control_point_data.destroy = cv_entry_to_label_ (self_destruct);


/* Thread this control point into its parent's children chain */

	if parent_control_point_data.first_child = null ()
	then do;					/* new control point is the parent's first child */
		parent_control_point_data.first_child = cpd_ptr;
		control_point_data.prev_peer = null ();
	     end;
	else do;					/* parent has several other children already */
		parent_control_point_data.last_child -> control_point_data.next_peer = cpd_ptr;
		control_point_data.prev_peer = parent_control_point_data.last_child;
	     end;

	control_point_data.next_peer = null ();
	parent_control_point_data.last_child = cpd_ptr;

	cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) = "1"b;
	cpm_data_$n_control_points = cpm_data_$n_control_points + 1;

	call unmask_ips_interrupts_caller (mask);

	return;



/* Reports an error during control point creation to our caller */

create_failure:
     procedure (p_code);

dcl	p_code		fixed binary (35) parameter;

	P_code = p_code;
	go to ERROR_RETURN_FROM_CPM_$CREATE;

     end create_failure;



/* Converts an entry variable into a label variable which will unwind the stack */

cv_entry_to_label_:
     procedure (p_entry) returns (label variable);

dcl	p_entry		entry variable parameter;

dcl	a_label		label variable;
dcl	1 a_label_decoded	aligned based (addr (a_label)),
	  2 code_ptr	pointer,
	  2 environment_ptr pointer;

	a_label_decoded.code_ptr = codeptr (p_entry);
	a_label_decoded.environment_ptr = control_point_data.stack_ptr -> stack_header.stack_begin_ptr;
						/* will unwind the stack to its first frame */

	return (a_label);

     end cv_entry_to_label_;

     end create_control_point;
%page;
/* Destroys an old control point -- This procedure is only called after all the control point's children have been
   destroyed.  It is also called during the creation of a control point if an error occurs after the control point is
   partially created. */

destroy_control_point:
     procedure (p_cpd_ptr);

dcl	p_cpd_ptr		pointer parameter;

dcl	1 p_control_point_data
			like control_point_data aligned based (p_cpd_ptr);
dcl	1 p_parent_control_point_data
			like control_point_data aligned based (p_control_point_data.parent);


/* Remove the dead control point from its parent's children chain */

	if p_control_point_data.parent ^= null ()
	then do;					/* there's a parent defined */
		p_parent_control_point_data.meters = p_parent_control_point_data.meters + p_control_point_data.meters;

		call mask_ips_interrupts_caller (mask); /* prevent interrupts while rechaining */

		/*** Check that the parent knows of the control point before rechaining -- This check is only
		     necessary if the control point's peer chain pointers are null as this could indicate that the
		     control point hadn't been chained before it was destroyed. */

		if p_control_point_data.prev_peer = null ()
		then do;				/* it might be the parent's first child */
			if p_parent_control_point_data.first_child = p_cpd_ptr
			then p_parent_control_point_data.first_child = p_control_point_data.next_peer;
		     end;
		else p_control_point_data.prev_peer -> control_point_data.next_peer = p_control_point_data.next_peer;

		if p_control_point_data.next_peer = null ()
		then do;				/* it might be the parent's last child */
			if p_parent_control_point_data.last_child = p_cpd_ptr
			then p_parent_control_point_data.last_child = p_control_point_data.prev_peer;
		     end;
		else p_control_point_data.next_peer -> control_point_data.prev_peer = p_control_point_data.prev_peer;

		p_control_point_data.parent, p_control_point_data.peers = null ();
		call unmask_ips_interrupts_caller (mask);
	     end;					/* the parent no longers knows about us */


/* Destroy the dead control point's stack */

	if p_control_point_data.stack_ptr ^= null ()
	then do;					/* its stack exists */
		call release_temp_segment_ (cpm_data_$subsystem_name, p_control_point_data.stack_ptr, (0));
		p_control_point_data.stack_ptr = null ();
	     end;


/* Complete the destruction of the control point */

	free p_control_point_data in (system_area);
	p_cpd_ptr = null ();			/* its destroyed */

	return;

     end destroy_control_point;
%page;
/* Creates a stack frame on the given stack to call the specified entrypoint --

   The stack frame is initialized appropriately so that, when cpm_alm_$switch_stacks returns on the new stack, the
   entrypoint specified by the p_caller parameter will be invoked.  As this entrypoint is invoked by a return with its
   stack frame already extant, it must be an ALM routine which then calls the actual PL/I caller entrypoint.  The
   correspondence between the ALM and PL/I procedures follows:

		      ALM entrypoint		      PL/I entrypoint
		cpm_alm_$call_overseer		cpm_overseer_$overseer
		cpm_alm_$call_generate_call		cpm_overseer_$generate_call

   The PL/I entrypoint prepares the environment according to the data in the p_caller_info parameter
   and then invokes the entrypoint specified as the p_callee parameter passing it the p_callee_info_ptr parameter as its
   single parameter.  When the callee entrypoint returns, the PL/I entrypoint returns to the ALM entrypoint.  The
   cpm_alm_$call_cpm_overseer_ entrypoint will then transfer to cpm_$self_destruct to destroy the control point; the
   cpm_alm_$call_cpm_generate_call_ entrypoint will then return to the prior stack frame on the stack which is normally a
   frame owned by cpm_$scheduler. */

push_call_frame:
     procedure (p_caller, p_caller_info, p_callee, p_callee_info_ptr) options (non_quick);

dcl	p_caller		entry () variable parameter;
dcl	p_caller_info	bit (*) aligned parameter;
dcl	p_callee		entry (pointer) variable parameter;
dcl	p_callee_info_ptr	pointer parameter;

dcl	1 call_frame	aligned based (sp),		/* the stack frame for p_caller */
	  2 header	like stack_frame aligned,	/* ... standard stack frame header */
	  2 arguments,				/* ... arguments to either p_callee or p_caller's PL/I */
	    3 caller_info_ptr
			pointer,
	    3 callee	entry (pointer) variable,
	    3 callee_arg_list_ptr
			pointer,
	    3 callee_info_ptr
			pointer,
	  2 caller_arg_list,			/* ... the argument list for p_caller's PL/I counterpart */
	    3 header	like arg_list.header,
	    3 arg_ptrs	(3) pointer,
	  2 callee_arg_list,			/* ... the argument list for p_callee */
	    3 header	like arg_list.header,
	    3 arg_ptrs	(1) pointer,
	  2 caller_info	bit (length (p_caller_info)) aligned;

	call mask_ips_interrupts_caller (mask);		/* creating the frame must not be interrupted */

	sb = control_point_data.stack_ptr;		/* find the target stack ... */
	sp = stack_header.stack_end_ptr;		/* ... and the place to lay down the caller frame */

	stack_frame.return_ptr = codeptr (p_caller);	/* where to begin execution after cpm_alm_$switch_stacks */
	stack_frame.translator_id = TRANSLATOR_ID_ALM;

	call_frame.caller_info = p_caller_info;		/* copy the parameters into the frame */
	call_frame.caller_info_ptr = addr (call_frame.caller_info);
	call_frame.callee = p_callee;
	call_frame.callee_info_ptr = p_callee_info_ptr;

	stack_frame.arg_ptr = addr (call_frame.caller_arg_list);
						/* record where this frame's argument list may be found */

	unspec (call_frame.caller_arg_list.header) = ""b; /* setup the caller's argument list */
	call_frame.caller_arg_list.header.call_type = Interseg_call_type;
	call_frame.caller_arg_list.header.arg_count = 3;	/* caller_flags, callee, callee_info_ptr */
	call_frame.caller_arg_list.arg_ptrs (1) = addr (call_frame.caller_info_ptr);
	call_frame.caller_arg_list.arg_ptrs (2) = addr (call_frame.callee);
	call_frame.caller_arg_list.arg_ptrs (3) = addr (call_frame.callee_arg_list_ptr);

	call_frame.callee_arg_list_ptr = addr (call_frame.callee_arg_list);
						/* record where the callee's argument list can be found */

	unspec (call_frame.callee_arg_list.header) = ""b; /* setup the callee's argument list */
	call_frame.callee_arg_list.header.call_type = Interseg_call_type;
	call_frame.callee_arg_list.header.arg_count = 1;
	call_frame.callee_arg_list.arg_ptrs (1) = addr (call_frame.callee_info_ptr);

	stack_frame.prev_sp = control_point_data.last_frame_ptr;
						/* when this call is done: return to the scheduler */

	control_point_data.last_frame_ptr = sp;		/* have cpm_alm_$switch_stacks return to this new frame */

	stack_frame.next_sp,			/* "push" the frame into existence */
						/* Note that we guarantee that the next stack frame */
						/* goes on a mod 16-word boundary. */
	     stack_header.stack_end_ptr =
	     addwordno (sp, (currentsize (call_frame) + 16 - mod (currentsize (call_frame), 16)));

	call unmask_ips_interrupts_caller (mask);

	return;

     end push_call_frame;

/* format: off */
%page; %include cpm_data_;
%page; %include cpm_internal_data;
%page; %include cpm_control_point_data;
%include cpm_ctrl_pt_meters;
%include process_usage;
%page; %include cpm_create_ctrl_pt_info;
%page; %include cpm_generate_call_flags;
%page; %include stack_header;
%page; %include stack_frame;
%page; %include arg_list;
%page; %include iox_dcls;
%page; %include sub_err_flags;
%page; %include trace_interface;
/* format: on */

     end cpm_;




		    cpm_alm_.alm                    11/04/86  1557.5rew 11/04/86  1031.4       33966



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

" ALM utilities used by the Control Point Manager

" HISTORY COMMENTS:
"  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
"     audit(86-10-22,Fawcett), install(86-11-03,MR12.0-1206):
"     Written to support control point management in March 1985 by G. Palter
"     based on C. Hornig's task_alm_.
"                                                      END HISTORY COMMENTS

	name	cpm_alm_



" Switch execution to the specified stack -- Control on the new stack is given
"    to the program which owns the last frame of said stack as saved in
"    its control_point_data at the point identified in the frame's return_ptr

" dcl  cpm_alm_$switch_stacks entry (pointer);
" call cpm_alm_$switch_stacks (new_stack_base_ptr);

	segdef	switch_stacks

switch_stacks:
	inhibit	on		"<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+>

	epbp7	pr6|0			" pr7 <- stackbaseptr ()

	epp2	pr7|stack_header.cpm_data_ptr,*	" pr2 <- addr (current control_point_data)
	spri6	pr2|cpd.last_frame_ptr	" remember where to resume control later

	epp2	pr0|2,*			" pr7 <- new_stack_base_ptr
	epbp7	pr2|0,*			"  ...

	epp2	pr7|stack_header.cpm_data_ptr,*	" pr2 <- addr (new control_point_data)

	epp6	pr2|cpd.last_frame_ptr,*	" pr6 <- addr (last frame in new ctrl pt)

	inhibit	off		"<-><-><-><-><-><-><-><-><-><-><-><-><-><-><-><-><->

	short_return			" and give up control to the new stack

" 

" Invoke cpm_overseer_$overseer -- This entrypoint is the first one invoked in a new control
"    point.  It completes the setup of this stack frame and then calls cpm_overseer_ to
"    complete the setup of the control point's environment and to start the user's initial
"    procedure.  When the user's initial procedure returns to cpm_overseer_$overseer, it
"    returns to this entrypoint which then transfers to cpm_$self_destruct to destroy this
"    control point.

	entry	overseer
	segdef	call_overseer

overseer:
call_overseer:
	getlp				" save our linkage pointer
	spri4	pr6|stack_frame.lp_ptr

	epp2	overseer			" claim that we are cpm_alm_$overseer
	spri2	pr6|stack_frame.entry_ptr

	epp0	pr6|stack_frame.arg_ptr,*	" find cpm_caller_'s argument list

	epbp7	pr6|0			" set the stack base

	short_call cpm_overseer_$overseer	" run the initial procedure

	tra	cpm_$self_destruct		" kill this control point

" 

" Invoke cpm_overseer_$generate_call -- This entrypoint is the first one invoked to execute
"    an entrypoint in this control point as requested by another control point.  This
"    entrypoint completes the setup of this stack frame and then calls
"    cpm_overseer_$generate_call to actually invoke the user's entrypoint.  When the user's
"    entrypoint returns to cpm_overseer_$generate_call, it returns to this entrypoint which
"    then returns to the previous frame on this stack.  That frame usually belongs to
"    cpm_$scheduler which causes the scheduling of control points to continue.

	entry	generate_call
	segdef	call_generate_call

generate_call:
call_generate_call:
	getlp				" save our linkage pointer
	spri4	pr6|stack_frame.lp_ptr

	epp2	generate_call		" claim that we are cpm_alm_$generate_call
	spri2	pr6|stack_frame.entry_ptr

	epp0	pr6|stack_frame.arg_ptr,*	" find cpm_caller_'s argument list

	epbp7	pr6|0			" set the stack base

	short_call cpm_overseer_$generate_call	" invoke the procedure

	return				" return to the scheduler (most likely)

" 
	include	stack_header
" 
	include	stack_frame
" 
	include	cpm_control_point_data

	end




		    cpm_data_.cds                   11/04/86  1557.5rew 11/04/86  1031.4       29700



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

/* format: off */

/* Control Point Manager constants and static data */

/* HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Written to support control point management in March 1985 by G. Palter
     based on C. Hornig's task_init_.
                                                   END HISTORY COMMENTS */

/* format: style3,linecom */

cpm_data_:
     procedure () options (variable);

dcl	1 cds_arguments	like cds_args aligned;
dcl	code		fixed binary (35);

dcl	CPM_DATA_		character (32) static options (constant) initial ("cpm_data_");

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

dcl	(addr, currentsize, null, string, unspec)
			builtin;


/* Constants (see cpm_internal_data.incl.pl1 for explanations) */

dcl	1 cpm_constants	aligned,
	  2 subsystem_name	character (32) unaligned;


/* Static data (see cpm_internal_data.incl.pl1 for explanations) */

dcl	1 cpm_static	aligned,
	  2 root_control_point_data
			like control_point_data aligned,
	  2 n_control_points
			fixed binary,
	  2 gc_control_points
			bit (1) aligned,
	  2 saved_cl_intermediary
			entry (bit (36) aligned) variable,
	  2 preferred_control_point
			pointer,
	  2 preferred_control_point_stack
			aligned,
	    3 stack_depth	fixed binary,
	    3 pad		bit (36) aligned,
	    3 cpd_ptr_stack (16) pointer,
	  2 ready_queue	aligned,
	    3 first	pointer,
	    3 last	pointer,
	  2 previous_control_point
			pointer,
	  2 valid_control_points
			aligned,
	    3 map		(0:4095) bit (1) unaligned,
	  2 global_meters	aligned,
	    3 overhead	like control_point_data.meters,
	    3 last_meters	like control_point_data.meters;
%page;
/* Define the constants */

	cpm_constants.subsystem_name = "Control point manager";


/* Initialize the static data as best as possible */

	unspec (cpm_static) = ""b;			/* cpm_initialize_ will actually set this stuff up */
	cpm_static.n_control_points = 1;		/* ... except this value should always be valid */


/* Invoke create_data_segment_ */

	cds_arguments.sections (1).p = addr (cpm_constants);
	cds_arguments.sections (1).len = currentsize (cpm_constants);
	cds_arguments.sections (1).struct_name = "cpm_constants";

	cds_arguments.sections (2).p = addr (cpm_static);
	cds_arguments.sections (2).len = currentsize (cpm_static);
	cds_arguments.sections (2).struct_name = "cpm_static";

	cds_arguments.seg_name = CPM_DATA_;

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

	string (cds_arguments.switches) = ""b;
	cds_arguments.have_text = "1"b;
	cds_arguments.have_static = "1"b;

	call create_data_segment_ (addr (cds_arguments), code);
	if code ^= 0
	then call com_err_ (code, CPM_DATA_);

	return;

/* format: off */
%page; %include cpm_control_point_data;
%include cpm_ctrl_pt_meters;
%include process_usage;
%page; %include cds_args;
/* format: on */

     end cpm_data_;




		    cpm_et_.alm                     11/04/86  1557.6rew 11/04/86  1031.4       13941



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

" Error table for control point management

" HISTORY COMMENTS:
"  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
"     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
"     Written to support control point management in March 1985 by G. Palter.
"                                                      END HISTORY COMMENTS


	name	cpm_et_
	
	include	et_macros

	et	cpm_et_


ec   already_started,started,
	(The specified control point has already been started.)

ec   already_stopped,stopped,
	(The specified control point has already been stopped.)

ec   cant_destroy_root,rootctpt,
	(The root control point can not be destroyed.)

ec   cant_stop_root,rootctpt,
	(The root control point can not be stopped.)

ec   cant_wakeup_when_stopped,stopped,
	(A wakeup can not be sent to a stopped control point.)

ec   control_point_not_found,noctrlpt,
	(The requested control point does not exist in this process.)

ec   preferred_cant_be_stopped,stopped,
	(A stopped control point can not be selected to be the preferred control point.)

ec   preferred_stack_overflow,nopush,
	(The stack of preferred control points is full.)

ec   wakeup_ignored,started,
	(The wakeup was ignored as the control point is currently ready.)

	end




		    cpm_initialize_.pl1             07/05/88  1441.2rew 07/05/88  1426.2       91413



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/* format: off */

/* Per-process initialization of the Multics Control Point Manager (cpm_) */

/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Written to support control point management in March 1985 by G. Palter
     based on C. Hornig's task_init_.
  2) change(88-04-25,Farley), approve(88-05-26,MCR7901), audit(88-06-07,GWMay),
     install(88-07-05,MR12.2-1053):
     Changed RNT area expansion 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,linecom */

cpm_initialize_:
     procedure ();

dcl	1 local_ai	aligned like area_info;

dcl	control_point_id_string
			character (12);

dcl	code		fixed binary (35);

dcl	new_rnt_area	area (local_ai.size) based (local_ai.areap);
dcl	old_rnt_area	area (old_area_size) based (old_areap);
dcl	rnt_area		area (stack_header.rnt_ptr -> rnt.rnt_area_size) based (stack_header.rnt_ptr -> rnt.areap);
dcl	new_rntp		pointer;
dcl	old_areap		pointer;
dcl	old_area_size	fixed bin (18);

dcl	old_mask		bit (36) aligned;

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

dcl	sys_info$max_seg_size
			fixed binary (19) external;

dcl	cpm_$nulle	entry () options (variable);
dcl	cpm_overseer_$cl_intermediary
			entry (bit (36) aligned);
dcl	(
	cu_$get_cl_intermediary,
	cu_$set_cl_intermediary
	)		entry (entry (bit (36) aligned));
dcl	define_area_	entry (pointer, fixed binary (35));
dcl	get_privileges_	entry () returns (bit (36) aligned);
dcl	get_ring_		entry () returns (fixed binary (3));
dcl	get_system_free_area_
			entry () returns (pointer);
dcl	hcs_$get_ips_mask	entry (bit (36) aligned);
dcl	hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$set_ips_mask	entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$grow_lot	entry (fixed binary (3));
dcl	ioa_$rsnnl	entry () options (variable);
dcl	sub_err_		entry () options (variable);
dcl	user_info_$usage_data
			entry (fixed binary, fixed binary (71), fixed binary (71), fixed binary (71),
			fixed binary (71), fixed binary (71));

dcl	(addr, addwordno, baseno, binary, empty, length, null, stackbaseptr, string, substr, unspec, wordno)
			builtin;

dcl	cleanup		condition;
%page;
/* cpm_initialize_: entry (); */

	sb = stackbaseptr ();
	system_area_ptr = get_system_free_area_ ();


/* Grow the LOT to its maximum size -- Otherwise, when ring 0 grows the LOT, it will only update the LOT and ISOT pointers
   in the header of the stack which happens to be running at the time.  The stacks of the other control points would, as a
   result, contain incorrect LOT and ISOT pointers and the process would not be long for the world */

	if stack_header.cur_lot_size < stack_header.max_lot_size
	then call hcs_$grow_lot (get_ring_ ());


/* Grow the RNT to a full segment for the same reasons as above */

	if stack_header.rnt_ptr -> rnt.rnt_area_size < sys_info$max_seg_size
	then do;

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

		local_ai.version = area_info_version_1;
		string (local_ai.control) = ""b;
		local_ai.zero_on_free = "1"b;		/* set control flags expected by ring 0 */
		local_ai.system = "1"b;
		local_ai.owner = "RNT";
		local_ai.size = sys_info$max_seg_size;
		local_ai.areap = null ();		/* let define_area_ find us a segment */

		call define_area_ (addr (local_ai), code);
		if code ^= 0
		then call sub_err_ (code, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0,
			"Growing the RNT.");

		old_area_size = stack_header.rnt_ptr -> rnt.rnt_area_size;
		new_rnt_area = rnt_area;		/* copy the RNT contents to its new area */

		if old_area_size ^= stack_header.rnt_ptr -> rnt.rnt_area_size
		then do;				/* Ooops, the RNT grew/moved while copying */
			new_rnt_area = empty;
			new_rnt_area = rnt_area;
		     end;

		new_rntp =
		     addwordno (local_ai.areap, relwordno (stack_header.rnt_ptr, stack_header.rnt_ptr -> rnt.areap));
		new_rntp -> rnt.srulep =
		     addwordno (local_ai.areap,
		     relwordno (stack_header.rnt_ptr -> rnt.srulep, stack_header.rnt_ptr -> rnt.areap));
		new_rntp -> rnt.areap = local_ai.areap;
		new_rntp -> rnt.rnt_area_size = local_ai.size;

		old_areap = stack_header.rnt_ptr -> rnt.areap;
		old_area_size = stack_header.rnt_ptr -> rnt.rnt_area_size;

		stack_header.rnt_ptr = new_rntp;	/* switch to the new RNT ... */
		free old_rnt_area in (system_area);	/* ... and get rid of the old one */

		call hcs_$reset_ips_mask (old_mask, old_mask);
		revert cleanup;
	     end;


/* Setup the definition of the root control point -- The root control point is the control point which uses the "normal"
   stack in the current ring */

	cpd_ptr = addr (cpm_data_$root_control_point_data);

	control_point_data.id,			/* generate the standard unique ID */
	     control_point_data.group_id = baseno (sb);

	control_point_data.state = CPM_READY;		/* it must be ready -- we're using it now */

	string (control_point_data.flags) = ""b;
	control_point_data.preferred = "1"b;		/* this control point "owns" the terminal, etc. */

	control_point_data.priority = 1;		/* "standard" priority */

	control_point_data.stack_ptr = sb;		/* the current stack belongs to the root */
	control_point_data.last_frame_ptr = null ();	/* no place for control to resume as we haven't left yet */

CANT_DESTROY_ROOT:
	control_point_data.destroy = CANT_DESTROY_ROOT;	/* a label which prevents destruction */

	control_point_data.parent,			/* this is the only control point */
	     control_point_data.peers, control_point_data.children, control_point_data.ready_queue = null ();

	control_point_data.user_cl_intermediary = cpm_$nulle;

	control_point_data.comment = "Root Control Point";

	call hcs_$get_ips_mask (control_point_data.ips_mask);
	substr (control_point_data.ips_mask, 36) = "1"b;	/* construct a mask suitable for use by hcs_$reset_ips_mask */

	control_point_data.privileges = get_privileges_ ();
	control_point_data.cl_intermediary = cpm_overseer_$cl_intermediary;

	call ioa_$rsnnl ("^12.3b", control_point_id_string, (0), control_point_data.id);
	call find_iocb ("user_i/o", control_point_data.user_io);
	call find_iocb ("user_input", control_point_data.user_input);
	call find_iocb ("user_output", control_point_data.user_output);
	call find_iocb ("error_output", control_point_data.error_output);

	control_point_data.meters = 0;
	control_point_data.meters.n_schedules = 1;	/* it's been scheduled to run once when the process started */

	stack_header.cpm_data_ptr = cpd_ptr;		/* the definition is now complete */


/* Setup global data */

	cpm_data_$n_control_points = 1;		/* there's just one active control point */
	cpm_data_$gc_control_points = "0"b;		/* ...and there's no garbage to be cleaned up */

	cpm_data_$preferred_control_point = cpd_ptr;	/* this is the prefeered control point ... */
	cpm_data_$preferred_control_point_stack.stack_depth = 0;
						/* ... and the stack of prior ones is empty */

	cpm_data_$ready_queue.first,			/* this is the only ready control point */
	     cpm_data_$ready_queue.last = cpd_ptr;

	cpm_data_$previous_control_point = cpd_ptr;	/* claim we ran previously to make cpm_$generate_call happy */

	unspec (cpm_data_$valid_control_points) = ""b;	/* only this control point is valid */
	cpm_data_$valid_control_points.map (binary (baseno (sb), 18, 0)) = "1"b;

	cpm_data_$global_meters = 0;			/* no meters yet but make sure real time computed OK */
	call user_info_$usage_data ((0), (0), (0), cpm_data_$global_meters.last_meters.real_time, (0), (0));


/* Control point management is now enabled */

	stack_header.cpm_enabled = substr (control_point_data.id, 1, length (stack_header.cpm_enabled));
						/* Place the stack number from the upper half of the id  into stack_header.cpm_enabled (non-zero) */

	call cu_$get_cl_intermediary (cpm_data_$saved_cl_intermediary);
	call cu_$set_cl_intermediary (cpm_overseer_$cl_intermediary);
						/* switch to our special CL intermediary */

	return;
%page;
/* Creates an unattached I/O switch which can be used to save one of the control point's standard attachments when it
   stops running */

find_iocb:
     procedure (p_switch_name, p_switch_iocb);

dcl	p_switch_name	character (*) parameter;
dcl	p_switch_iocb	pointer parameter;

dcl	switch_name	character (32) varying;

	switch_name = control_point_id_string;
	switch_name = switch_name || ".";
	switch_name = switch_name || p_switch_name;

	call iox_$find_iocb ((switch_name), p_switch_iocb, code);

	if code ^= 0
	then call sub_err_ (code, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0, "Creating an IOCB for ^a.",
		switch_name);

	return;

     end find_iocb;



/* Returns the word offset of one pointer relative to another */

relwordno:
     procedure (p_ptr, p_base_ptr) returns (fixed binary (18));

dcl	p_ptr		pointer parameter;
dcl	p_base_ptr	pointer parameter;

	return (wordno (p_ptr) - wordno (p_base_ptr));

     end relwordno;

/* format: off */
%page; %include cpm_data_;
%page; %include cpm_internal_data;
%page; %include cpm_control_point_data;
%include cpm_ctrl_pt_meters;
%include process_usage;
%page; %include stack_header;
%page; %include rnt;
%page; %include area_info;
%page; %include sub_err_flags;
%page; %include iox_dcls;
/* format: on */

     end cpm_initialize_;




		    cpm_overseer_.pl1               11/04/86  1557.6rew 11/04/86  1031.4      330129



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

/* format: off */

/* Control Point Management -- Entrypoints which manage the environment of a control point */

/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Written to support control point management in March 1985 by G. Palter.
                                                   END HISTORY COMMENTS */

/* format: style3,linecom */

cpm_overseer_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	P_ccpi_ptr	pointer parameter;		/* overseer: -> describes how to create the control point */
dcl	P_initproc				/* overseer: first user program to run in the control point */
			entry (pointer) variable parameter;
dcl	P_initproc_arg_list_ptr			/* overseer: -> the above program's argument list */
			pointer parameter;

dcl	P_gcf_ptr		pointer parameter;		/* generate_call: -> generate_call_flags (see include file) */
dcl	P_userproc				/* generate_call: the user program to be executed */
			entry (pointer) variable parameter;
dcl	P_userproc_arg_list_ptr			/* generate_call: -> the above program's argument list */
			pointer parameter;

dcl	P_cl_flags	bit (36) aligned parameter;	/* cl_intermediary: flags which control new command level */


/* Parameters for entrypoints used to prevent non-quick procedures */

dcl	P_cpd_ptr		pointer parameter;

dcl	P_old_cpd_ptr	pointer parameter;
dcl	P_new_cpd_ptr	pointer parameter;
dcl	P_cpd_swapped_switches
			bit (1) unaligned parameter;
dcl	P_new_swapped_switches_setting
			bit (1) aligned parameter;

dcl	P_new_mask	bit (36) aligned parameter;
dcl	P_old_mask	bit (36) aligned parameter;


/* Remaining declarations */

dcl	1 parent_control_point_data
			like control_point_data aligned based (control_point_data.parent);

dcl	based_generate_call_flags
			bit (36) aligned based;

dcl	old_mask		bit (36) aligned;

dcl	generate_call_flags bit (36) aligned;
dcl	pushed_preferred_state
			bit (1) aligned;
dcl	prior_state	fixed binary;
dcl	return_from_intermediary
			bit (1) aligned;
dcl	saved_swapped_switches
			bit (1) aligned;

dcl	(
	sys_info$comm_privilege,
	sys_info$dir_privilege,
	sys_info$ipc_privilege,
	sys_info$rcp_privilege,
	sys_info$ring1_privilege,
	sys_info$seg_privilege,
	sys_info$soos_privilege
	)		bit (36) aligned external;

dcl	continue_to_signal_ entry (fixed binary (35));
dcl	cpm_$call_self_destruct
			entry ();
dcl	cpm_$update_state_caller
			entry (pointer, fixed binary);
dcl	cu_$arg_list_ptr	entry () returns (pointer);
dcl	cu_$generate_call	entry (entry, pointer);
dcl	(
	cu_$get_cl_intermediary,
	cu_$set_cl_intermediary
	)		entry (entry (bit (36) aligned));
dcl	default_error_handler_$wall
			entry ();
dcl	default_error_handler_$wall_ignore_pi
			entry ();
dcl	get_privileges_	entry () returns (bit (36) aligned);
dcl	hcs_$get_ips_mask	entry (bit (36) aligned);
dcl	hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl	hcs_$set_ips_mask	entry (bit (36) aligned, bit (36) aligned);
dcl	ioa_$ioa_switch	entry () options (variable);
dcl	ioa_$rsnnl	entry () options (variable);
dcl	sub_err_		entry () options (variable);
dcl	(
	system_privilege_$comm_priv_on,
	system_privilege_$comm_priv_off,
	system_privilege_$dir_priv_on,
	system_privilege_$dir_priv_off,
	system_privilege_$ipc_priv_on,
	system_privilege_$ipc_priv_off,
	system_privilege_$rcp_priv_on,
	system_privilege_$rcp_priv_off,
	system_privilege_$ring1_priv_on,
	system_privilege_$ring1_priv_off,
	system_privilege_$seg_priv_on,
	system_privilege_$seg_priv_off,
	system_privilege_$soos_priv_on,
	system_privilege_$soos_priv_off
	)		entry (fixed binary (35));

dcl	any_other		condition;
dcl	cleanup		condition;

dcl	(addr, bool, null, stackbaseptr, substr)
			builtin;
%page;
/* The initial procedure for a new control point -- This entrypoint is responsible for completing the creation of an
   environment for the new control point.  This responsibility includes establishing the standard I/O switches for this
   control point if they are to be different from our parent's control point. */

/* NOTE: This entrypoint is always called with all IPS signals masked. */

overseer:
     entry (P_ccpi_ptr, P_initproc, P_initproc_arg_list_ptr);

	on any_other call error_handler$catch_all ();	/* setup our unclaimed signal handler */

	cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;/* get our definitions */
	ccpi_ptr = P_ccpi_ptr;

	if trace_$transaction_end (1)			/* setup tracing according to our stack */
	then ;

	call cu_$set_cl_intermediary (control_point_data.cl_intermediary);
						/* set our initial CL intermediary ($cl_intermediary below) */

	call restore_privileges ();			/* set our initial privileges (all OFF) */

	call mask_ips_interrupts (control_point_data.ips_mask, old_mask);
						/* unmask all IPS interrupts (most likely) */

	on cleanup call issue_root_start_order_caller (cpd_ptr);

	if create_control_point_info.separate_standard_iocbs
	then do;					/* setup our I/O switches */
		call create_control_point_switches ();
		on cleanup
		     begin;			/* ... and be sure to get rid of them on explicit destroy */
			call destroy_control_point_switches_caller (cpd_ptr, ccpi_ptr, old_mask);
			call issue_root_start_order_caller (cpd_ptr);
		     end;
	     end;

	call cu_$generate_call (P_initproc, P_initproc_arg_list_ptr);
						/* start the control point running */

	if create_control_point_info.separate_standard_iocbs
	then call destroy_control_point_switches (old_mask);
						/* we're done with these switches */

	/*** We must leave all IPS signals unmasked when we return.  Otherwise, cpm_$self_destruct will call the
	     scheduler with all IPS signals masked and, if there are no ready control points, we will call hardcore to
	     block with all signals masked which is clearly wrong. */

RETURN_FROM_OVERSEER:
	call issue_root_start_order ();		/* kick the root */

	return;					/* complete the control point's destruction */
%page;
/* The portion of cpm_$generate_call which executes in the target control point -- This entrypoint is responsible for
   readying the control point's environment before executing the user program requested by the call to cu_$generate_call.
   If cpm_$generate_call or cpm_$generate_call_preferred were used, this entrypoint will force the control point into the
   READY state and restore it to its prior state when execution is completed.  If cpm_$generate_call_preferred was used,
   this entrypoint will push the preferred control point, make this control point preferred, and restore the preferred
   control point when execution is completed.  In addition, if this control point uses a different set of standard I/O
   switches than the previously executing control point, this entrypoint must restore the switches before executing the
   user's program and then save them upon completion.  This action is required as the scheduler will have saved our
   switches before running any control point with different switches and will expect to restore them when it regains
   control in this control point which will occur after we return. */

/* NOTE: This entrypoint is always invoked with all IPS signals masked. */

generate_call:
     entry (P_gcf_ptr, P_userproc, P_userproc_arg_list_ptr);

	cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;/* get our definition */
	generate_call_flags = P_gcf_ptr -> based_generate_call_flags;

	if trace_$transaction_end (1)			/* setup tracing according to our stack */
	then ;

	pushed_preferred_state = "0"b;		/* for cleanup handler */

	on cleanup				/* in case the user's program aborts */
	     begin;
		/*** On a non-local goto, we must not restore the IPS mask.  If we did, the control point would
		     continue execution with all IPS signals masked which would, eventually, cause problems when it
		     tries to block.  In addition, we do not restore the prior state as, if we were blocked, we are
		     about to release past the scheduler and the ipc_$block call which caused us to become blocked in
		     the first place.  If we had been stopped, we are about to release past the cu_$cl call which
		     place us in that state.  Finally, we do not save our I/O switches as we are not going to return
		     to our caller (the scheduler) which would restore them. */
		call cpm_$pop_preferred_control_point (pushed_preferred_state);
		call issue_start_orders_caller (cpd_ptr);
	     end;

	if generate_call_flags & CPM_GC_FORCE_READY	/* cpm_$generate_call or cpm_$generate_call_preferred ... */
	then do;					/* ... so make sure this control point is READY */
		prior_state = control_point_data.state;
		if control_point_data.state ^= CPM_READY
		then call cpm_$update_state_caller (cpd_ptr, CPM_READY);
	     end;

	if generate_call_flags & CPM_GC_PUSH_PREFERRED	/* cpm_$generate_call_preferred: make us temporarily "it" */
	then call cpm_$push_preferred_control_point (control_point_data.id, pushed_preferred_state, (0));

	saved_swapped_switches = control_point_data.swapped_switches;
	control_point_data.swapped_switches = "0"b;	/* don't use the root's switches during a generate_call */

	if different_switches (cpd_ptr, cpm_data_$previous_control_point)
	then call restore_io_switches ();		/* we need to get our switches back */

	call cu_$set_cl_intermediary (control_point_data.cl_intermediary);
						/* restore our control point's CL intermediary */

	call restore_privileges ();			/* restore our system privileges */

	call mask_ips_interrupts (control_point_data.ips_mask, old_mask);
						/* restore our control point's IPS mask */

	call cu_$generate_call (P_userproc, P_userproc_arg_list_ptr);
						/* run the user's procedure */

	call issue_start_orders ();			/* in case the user's procedure did I/O */

	call hcs_$get_ips_mask (control_point_data.ips_mask);
	substr (control_point_data.ips_mask, 36) = "1"b;	/* construct possible new IPS mask for this control point */

	call unmask_ips_interrupts (old_mask);		/* restore the IPS mask */

	control_point_data.privileges = get_privileges_ ();
						/* preceeding call may permanently affect our privileges */

	call cu_$get_cl_intermediary (control_point_data.cl_intermediary);
						/* it may also permanently change the CL intermediary */

	if different_switches (cpd_ptr, cpm_data_$previous_control_point)
	then call save_io_switches ();		/* put our switches back where the scheduler will find them */

	control_point_data.swapped_switches = saved_swapped_switches;

	call cpm_$pop_preferred_control_point (pushed_preferred_state);
						/* restore the previous preferred control point if pushed */

	if generate_call_flags & CPM_GC_FORCE_READY	/* cpm_$generate_call or cpm_$generate_call_preferred ... */
	then if prior_state ^= CPM_READY		/* ... so reset our state if it wasn't READY */
	     then call cpm_$update_state_caller (cpd_ptr, prior_state);

	if trace_$transaction_begin (1)		/* disbale tracing until we're in another control point */
	then ;

	return;					/* return to the scheduler ... */
%page;
/* The command level intermediary used by Control Point Management */

cl_intermediary:
     entry (P_cl_flags);

	cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;


/* If we were invoked by default_error_handler_, our standard I/O switches will have been swapped with those belonging to
   the root control point.  Before reaching command level, we must be sure to be using the proper set of switches. */

	saved_swapped_switches = control_point_data.swapped_switches;
						/* we must remember whether to restore the switches */

	old_mask = ""b;				/* used by swap_switches */

	on cleanup
	     begin;				/* in case of a release ... */
		call issue_start_orders_caller (cpd_ptr);
		if saved_swapped_switches & ^control_point_data.swapped_switches
		then call swap_switches_caller (cpd_ptr, addr (cpm_data_$root_control_point_data),
			control_point_data.swapped_switches, "1"b);
	     end;					/* ... put things back the way the error_handler expects them */

	if control_point_data.swapped_switches		/* restore the control point's native switches */
	then call swap_switches (addr (cpm_data_$root_control_point_data), cpd_ptr, control_point_data.swapped_switches,
		"0"b, "0"b);


/* Invoke the user's CL intermediary if defined for this control point -- On return, if it requests, simply return without
   getting a new command level as if a "start" command had been issued. */

	if control_point_data.user_cl_intermediary ^= cpm_$nulle
	then do;

		return_from_intermediary = "0"b;	/* in case the user's CL intermediary doesn't set it */

		call control_point_data.user_cl_intermediary (return_from_intermediary);

		if return_from_intermediary
		then go to RETURN_FROM_CL_INTERMEDIARY;
	     end;


/* Now get to command level -- If we are the root control point, we can invoke the saved intermediary to get a new
   listener level.  Otherwise, we must stop this control point and let some other control point run; however, before we
   stop, we will try to print a message that we have stopped this control point. */

	if cpd_ptr = addr (cpm_data_$root_control_point_data)
	then call cpm_data_$saved_cl_intermediary (P_cl_flags);

	else do;
		on any_other			/* fault occured trying to write the following message ... */
		     call cpm_$call_self_destruct ();
		call ioa_$ioa_switch (iox_$error_output, "^a: Control point ^12.3b^[ (^a)^] stopped.",
		     cpm_data_$subsystem_name, control_point_data.id, (control_point_data.comment ^= ""),
		     control_point_data.comment);

		on any_other call error_handler$ignore_pi ();
						/* setup a condition wall */

		call issue_root_start_order ();	/* kick the root */

		call cpm_$stop (control_point_data.id, (0));
		call cpm_$scheduler ();		/* find something to do */

		revert any_other;			/* we've been restarted ... */
	     end;


/* Return to the caller of cu_$cl -- Reswap the standard switches if needed and issue a "start" control order on both our
   own user_i/o and the root's user_i/o to avoid possible lost wakeups. */

RETURN_FROM_CL_INTERMEDIARY:
	call issue_start_orders ();

	if saved_swapped_switches			/* put things back the way the error_handler expects them */
	then call swap_switches (cpd_ptr, addr (cpm_data_$root_control_point_data), control_point_data.swapped_switches,
		"1"b, "0"b);

	return;
%page;
/* The unclaimed signal (any_other) handler for any control point other than the root --  Before actually processing the
   signal, we first swap the current control point's I/O switches with those belonging to the root control point.  Thus,
   any messages printed by default_error_handler_ will be displayed on the original login terminal as opposed to whatever
   connection the control point might be using.  Of course, we must be certain to put things back after processing is
   completed. */

error_handler:
     procedure ();
	return;					/* not used */

dcl	real_error_handler	entry () variable;
dcl	must_swap_switches	bit (1) aligned;
dcl	our_arg_list_ptr	pointer;


error_handler$catch_all:				/* catch everything including program_interrupt */
     entry ();
	real_error_handler = default_error_handler_$wall;
	go to ERROR_HANDLER;


error_handler$ignore_pi:				/* catch everything but program_interrupt and a few others */
     entry ();
	real_error_handler = default_error_handler_$wall_ignore_pi;
	go to ERROR_HANDLER;


ERROR_HANDLER:
	our_arg_list_ptr = cu_$arg_list_ptr ();

	must_swap_switches = ^control_point_data.swapped_switches;

	on cleanup
	     begin;
		if must_swap_switches & control_point_data.swapped_switches
		then call swap_switches_caller (addr (cpm_data_$root_control_point_data), cpd_ptr,
			control_point_data.swapped_switches, "0"b);
	     end;

	if must_swap_switches
	then call swap_switches_caller (cpd_ptr, addr (cpm_data_$root_control_point_data),
		control_point_data.swapped_switches, "1"b);

	call cu_$generate_call (real_error_handler, our_arg_list_ptr);

	if must_swap_switches & control_point_data.swapped_switches
	then call swap_switches_caller (addr (cpm_data_$root_control_point_data), cpd_ptr,
		control_point_data.swapped_switches, "0"b);

	return;

     end error_handler;
%page;
/* Setup the control point's I/O switches when separate switches are requested -- Four uniquely named switches are created
   to represent the new control point's standard switches.  If an attach description for user_i/o is provided, it is used
   to create an independent attachment for the new control point; otherwise, the new control point's user_i/o is syn_'ed
   to its parent's user_i/o.  If any switch can not be setup, sub_err_ is used to inform the user. */

create_control_point_switches:
     procedure ();

dcl	1 local_io_switches like control_point_data.io_switches aligned;

dcl	an_iocb_ptr	pointer;
dcl	id_string		character (12);
dcl	parents_user_io	character (21);
dcl	our_user_io	character (21);
dcl	code		fixed binary (35);

	local_io_switches = null ();			/* for proper error recovery */

	call ioa_$rsnnl ("^12.3b", id_string, (0), control_point_data.id);
	our_user_io = id_string || ".user_i/o";		/* construct the name of our user_i/o switch */

	if create_control_point_info.user_io_attach_desc_given
	then do;					/* new control point has its own user_i/o */
		call iox_$attach_name (our_user_io, local_io_switches.user_io,
		     create_control_point_info.user_io_attach_desc, null (), code);
		if code ^= 0
		then call attach_failure (our_user_io, create_control_point_info.user_io_attach_desc, code);
		call iox_$open (local_io_switches.user_io, Stream_input_output, "0"b, code);
		if code ^= 0
		then call open_failure (our_user_io, code);
	     end;

	else do;					/* new control point is to share its parent's user_i/o */
		call ioa_$rsnnl ("^12.3b.user_i/o", parents_user_io, (0), parent_control_point_data.id);
		call attach_syn ("user_i/o", parents_user_io, "", local_io_switches.user_io);
	     end;

	/*** Attach user_input, user_output, and error_output as synonyms of user_i/o.  These switches are not syn_'ed
	     to the control point's private user_i/o because, if they were, they will always be syn_'ed to that switch
	     even after it is moved to the real user_i/o. */

	call attach_syn ("user_input", "user_i/o", "put_chars", local_io_switches.user_input);
	call attach_syn ("user_output", "user_i/o", "get_chars get_line", local_io_switches.user_output);
	call attach_syn ("error_output", "user_i/o", "get_chars get_line", local_io_switches.error_output);

	call unmask_ips_interrupts (old_mask);		/* prevent interrupts while updating control_point_data */

	control_point_data.io_switches = local_io_switches;
	control_point_data.group_id = control_point_data.id;
						/* we've now created the switches */

	if cpm_data_$previous_control_point -> control_point_data.swapped_switches
	then call swap_switches (addr (cpm_data_$root_control_point_data), cpd_ptr, control_point_data.swapped_switches,
		"0"b, "1"b);
	else call swap_switches (cpm_data_$previous_control_point, cpd_ptr, control_point_data.swapped_switches, "0"b,
		"1"b);

	call mask_ips_interrupts (control_point_data.ips_mask, old_mask);

	return;


/* Control arrives here iff an error occurs while trying to create the control point's standard switches */

ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES:
	do an_iocb_ptr = local_io_switches.user_input, local_io_switches.user_output, local_io_switches.error_output;
	     if an_iocb_ptr ^= null ()
	     then do;
		     call iox_$detach_iocb (an_iocb_ptr, (0));
		     call iox_$destroy_iocb (an_iocb_ptr, (0));
		end;
	end;

	if local_io_switches.user_io ^= null ()
	then do;
		if create_control_point_info.user_io_attach_desc_given
		then call iox_$close (local_io_switches.user_io, (0));
		call iox_$detach_iocb (local_io_switches.user_io, (0));
		call iox_$destroy_iocb (local_io_switches.user_io, (0));
	     end;

	go to RETURN_FROM_OVERSEER;



/* Attaches an I/O switch as a synonym to the supplied target switch */

attach_syn:
     procedure (p_switch_name, p_target_switch_name, p_inhibits, p_switch_iocb);

dcl	p_switch_name	character (*) parameter;
dcl	p_target_switch_name
			character (*) parameter;
dcl	p_inhibits	character (*) parameter;
dcl	p_switch_iocb	pointer parameter;

dcl	switch_name	character (32) varying;
dcl	attach_description	character (128) varying;

	switch_name = id_string;			/* construct the switch's name */
	switch_name = switch_name || ".";
	switch_name = switch_name || p_switch_name;

	attach_description = "syn_ ";			/* now construct the attach description */
	attach_description = attach_description || p_target_switch_name;
	attach_description = attach_description || " -inhibit close ";
	if p_inhibits ^= ""
	then attach_description = attach_description || p_inhibits;

	call iox_$attach_name ((switch_name), p_switch_iocb, (attach_description), null (), code);
	if code ^= 0
	then call attach_failure (switch_name, attach_description, code);

	return;

     end attach_syn;



/* Reports an error while attaching one of the control point's standard I/O switches */

/* format: off */
dcl	attach_failure	generic (
		attach_failure_nonvarying
			when (character (*) nonvarying, character (*) nonvarying, fixed binary (35)),
		attach_failure_varying
			when (character (*) varying, character (*) varying, fixed binary (35)));
/* format: on */


attach_failure_nonvarying:				/* ... with nonvarying parameters */
     procedure (p_switch_name, p_attach_desc, p_code);

dcl	p_switch_name	character (*) parameter;
dcl	p_attach_desc	character (*) parameter;
dcl	p_code		fixed binary (35) parameter;

	call sub_err_ (p_code, cpm_data_$subsystem_name, ACTION_DEFAULT_RESTART, null (), 0,
	     "Trying to attach ^a using the attach description -^/^-^a", p_switch_name, p_attach_desc);

	go to ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES;

     end attach_failure_nonvarying;


attach_failure_varying:				/* ... with varying parameters */
     procedure (p_switch_name, p_attach_desc, p_code);

dcl	p_switch_name	character (*) varying parameter;
dcl	p_attach_desc	character (*) varying parameter;
dcl	p_code		fixed binary (35) parameter;

	call sub_err_ (p_code, cpm_data_$subsystem_name, ACTION_DEFAULT_RESTART, null (), 0,
	     "Trying to attach ^a using the attach description -^/^-^a", p_switch_name, p_attach_desc);

	go to ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES;

     end attach_failure_varying;



/* Reports an error while trying to open one of the control point's standard I/O switches */

open_failure:					/* ... while trying to open a switch */
     procedure (p_switch_name, p_code);

dcl	p_switch_name	character (*) parameter;
dcl	p_code		fixed binary (35) parameter;

	call sub_err_ (p_code, cpm_data_$subsystem_name, ACTION_DEFAULT_RESTART, null (), 0, "Trying to open ^a.",
	     p_switch_name);

	go to ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES;

     end open_failure;

     end create_control_point_switches;
%page;
/* Destroy the control point's standard I/O switches setup by a prior call to create_control_point_switches */

destroy_control_point_switches:
     procedure (p_old_mask);

dcl	p_old_mask	bit (36) aligned parameter;

dcl	1 local_io_switches like control_point_data.io_switches aligned;
dcl	an_iocb_ptr	pointer;

	call unmask_ips_interrupts (p_old_mask);	/* prevent interrupts while updating control_point_data */

	if parent_control_point_data.swapped_switches	/* revert to our parent's switches or the root's if swapped */
	then call swap_switches (cpd_ptr, addr (cpm_data_$root_control_point_data), control_point_data.swapped_switches,
		"1"b, "1"b);
	else call swap_switches (cpd_ptr, control_point_data.parent, control_point_data.swapped_switches, "0"b, "1"b);

	local_io_switches = control_point_data.io_switches;
						/* work on local copies so we're never without switches */

	control_point_data.group_id = parent_control_point_data.group_id;
	control_point_data.io_switches = parent_control_point_data.io_switches;
						/* switch back to our parent's switches */

	call mask_ips_interrupts (control_point_data.ips_mask, p_old_mask);

	do an_iocb_ptr = local_io_switches.user_input, local_io_switches.user_output, local_io_switches.error_output;
	     if an_iocb_ptr ^= null ()
	     then do;				/* one of the always syn_'ed switches exists */
		     call iox_$detach_iocb (an_iocb_ptr, (0));
		     call iox_$destroy_iocb (an_iocb_ptr, (0));
		end;
	end;

	if local_io_switches.user_io ^= null ()
	then do;					/* it's user_i/o switch exists */
		if create_control_point_info.user_io_attach_desc_given
		then call iox_$close (local_io_switches.user_io, (0));
		call iox_$detach_iocb (local_io_switches.user_io, (0));
		call iox_$destroy_iocb (local_io_switches.user_io, (0));
	     end;

	return;

     end destroy_control_point_switches;



/* Invoke destroy_control_point_switches -- This entrypoint exists to prevent making destroy_control_point_switches
   non-quick by invoking it from within an on unit or other non-quick procedure. */

destroy_control_point_switches_caller:
     entry (P_cpd_ptr, P_ccpi_ptr, P_old_mask);

	cpd_ptr = P_cpd_ptr;
	ccpi_ptr = P_ccpi_ptr;

	call destroy_control_point_switches (P_old_mask);

	return;
%page;
/* Swap the standard I/O switches in force from the old control point's switches to those of a new control point */

swap_switches:
     procedure (p_old_cpd_ptr, p_new_cpd_ptr, p_cpd_swapped_switches, p_new_swapped_switches_setting, p_caller_is_masked);

dcl	1 old_cpd		like control_point_data aligned based (p_old_cpd_ptr);
dcl	p_old_cpd_ptr	pointer parameter;

dcl	1 new_cpd		like control_point_data aligned based (p_new_cpd_ptr);
dcl	p_new_cpd_ptr	pointer parameter;

dcl	p_cpd_swapped_switches			/* a control point's swapped_switches flag ... */
			bit (1) unaligned parameter;
dcl	p_new_swapped_switches_setting		/* ... and the above flag's new setting */
			bit (1) aligned parameter;

dcl	p_caller_is_masked	bit (1) aligned parameter;	/* ON => the caller has already masked IPS interrupts */

	if old_cpd.group_id = new_cpd.group_id		/* they are using the same switches: this is a no-op */
	then return;

	if ^p_caller_is_masked			/* prevent interrupts while playing with the switches */
	then call mask_ips_interrupts (""b, old_mask);

	call iox_$move_attach (iox_$user_io, old_cpd.io_switches.user_io, (0));
	call iox_$move_attach (iox_$user_input, old_cpd.io_switches.user_input, (0));
	call iox_$move_attach (iox_$user_output, old_cpd.io_switches.user_output, (0));
	call iox_$move_attach (iox_$error_output, old_cpd.io_switches.error_output, (0));

	call iox_$move_attach (new_cpd.io_switches.user_io, iox_$user_io, (0));
	call iox_$move_attach (new_cpd.io_switches.user_input, iox_$user_input, (0));
	call iox_$move_attach (new_cpd.io_switches.user_output, iox_$user_output, (0));
	call iox_$move_attach (new_cpd.io_switches.error_output, iox_$error_output, (0));

	p_cpd_swapped_switches = p_new_swapped_switches_setting;

	if ^p_caller_is_masked			/* it's safe now */
	then call unmask_ips_interrupts (old_mask);

	return;

     end swap_switches;



/* Invoke swap_switches -- This entrypoint exists to prevent making swap_switches
   non-quick by invoking it from an on unit or other non-quick procedure. */

swap_switches_caller:
     entry (P_new_cpd_ptr, P_old_cpd_ptr, P_cpd_swapped_switches, P_new_swapped_switches_setting);

	old_mask = ""b;				/* for any_other handler */
	on any_other
	     begin;
		if substr (old_mask, 36, 1) = "1"b
		then call unmask_ips_interrupts_caller (old_mask);
		call continue_to_signal_ ((0));	/* ... let the error get through */
	     end;

	call swap_switches (P_new_cpd_ptr, P_old_cpd_ptr, P_cpd_swapped_switches, P_new_swapped_switches_setting, "0"b);

	return;
%page;
/* Issue "start" control orders on the appropriate user_i/o switches -- This procedure is invoked after any operation
   which may have caused asynchronous I/O to prevent lost wakeups.  A "start" order is issued on the current control
   point's user_i/o and also on the user_i/o associated with the root control point (i.e., the user's terminal) if it is
   different from the current control point's user_i/o. */

issue_start_orders:
     procedure ();

	call iox_$control (iox_$user_io, "start", null (), (0));

	if control_point_data.swapped_switches		/* user_i/o above is the root's: must also start our's */
	then call iox_$control (control_point_data.user_io, "start", null (), (0));

	else					/* user_i/o above was our's: check the root's */
	     if control_point_data.group_id ^= cpm_data_$root_control_point_data.group_id
	then call iox_$control (cpm_data_$root_control_point_data.user_io, "start", null (), (0));

	return;

     end issue_start_orders;



/* Invoke issue_start_orders -- This entrypoint exists to prevent making the issue_start_orders internal procedure
   non-quick by invoking it from within an on unit or other non-quick procedure. */

issue_start_orders_caller:
     entry (P_cpd_ptr);

	cpd_ptr = P_cpd_ptr;

	call issue_start_orders ();

	return;
%page;
/* Issue a "start" control order on the root control point's user_i/o switch -- This procedure is invoked whenever the
   current control point is about to be stopped or destroyed.  If the root control point was blocked for input on its
   user_i/o, any I/O performed to that switch by another control point would be considered asynchronous I/O and, without a
   "start" order, could leave the root control point blocked forever for an event that will never occur. */

issue_root_start_order:
     procedure ();

	if different_switches (cpd_ptr, addr (cpm_data_$root_control_point_data))
	then call iox_$control (cpm_data_$root_control_point_data.user_io, "start", null (), (0));

	else call iox_$control (iox_$user_io, "start", null (), (0));
						/* this control point shares its switches with the root */

	return;

     end issue_root_start_order;



/* Invoke issue_root_start_order -- This entrypoint exists to prevent making the issue_root_start_order internal procedure
   non-quick by invoking it from within an on unit or other non-quick procedure. */

issue_root_start_order_caller:
     entry (P_cpd_ptr);

	cpd_ptr = P_cpd_ptr;

	call issue_root_start_order ();

	return;
%page;
/* Restore the standard I/O switches assigned to this control point */

restore_io_switches:
     procedure ();

	call iox_$move_attach (control_point_data.user_io, iox_$user_io, (0));
	call iox_$move_attach (control_point_data.user_input, iox_$user_input, (0));
	call iox_$move_attach (control_point_data.user_output, iox_$user_output, (0));
	call iox_$move_attach (control_point_data.error_output, iox_$error_output, (0));

	return;

     end restore_io_switches;



/* Save the standard I/O switches assigned to this control point */

save_io_switches:
     procedure ();

	call iox_$move_attach (iox_$user_io, control_point_data.user_io, (0));
	call iox_$move_attach (iox_$user_input, control_point_data.user_input, (0));
	call iox_$move_attach (iox_$user_output, control_point_data.user_output, (0));
	call iox_$move_attach (iox_$error_output, control_point_data.error_output, (0));

	return;

     end save_io_switches;



/* Determines if the two specified control points use different sets of standard I/O switches */

different_switches:
     procedure (p_cpd_1_ptr, p_cpd_2_ptr) returns (bit (1) aligned);

dcl	1 cpd_1		like control_point_data aligned based (p_cpd_1_ptr);
dcl	1 cpd_2		like control_point_data aligned based (p_cpd_2_ptr);
dcl	(p_cpd_1_ptr, p_cpd_2_ptr)
			pointer parameter;

	if cpd_1.swapped_switches & cpd_2.swapped_switches
	then return ("0"b);				/* both control points are using the root's switches */

	else if cpd_1.group_id = cpd_2.group_id		/* same group: they use the same switches ... */
	then return (cpd_1.swapped_switches ^= cpd_2.swapped_switches);
						/* ... unless one is using the root's but not the other */

	else if (cpd_1.swapped_switches & (cpd_2.group_id = cpm_data_$root_control_point_data.group_id))
	     | (cpd_2.swapped_switches & (cpd_1.group_id = cpm_data_$root_control_point_data.group_id))
	then return ("0"b);				/* different groups: but one is swapped to the other */

	else return ("1"b);				/* different groups really using different switches */

     end different_switches;
%page;
/* Restore the current control point's system privileges -- We need not worry about access to system_privilege_ as we only
   call it when we actually discover that a privilege has changed and the only way to change privileges is to use the
   system_privilege_ gate itself. */

restore_privileges:
     procedure ();

dcl	current_privileges	bit (36) aligned;

	current_privileges = get_privileges_ ();

	if control_point_data.privileges = current_privileges
	then return;				/* privileges are already correct */

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$comm_privilege
	then if control_point_data.privileges & sys_info$comm_privilege
	     then call system_privilege_$comm_priv_on ((0));
	     else call system_privilege_$comm_priv_off ((0));

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$dir_privilege
	then if control_point_data.privileges & sys_info$dir_privilege
	     then call system_privilege_$dir_priv_on ((0));
	     else call system_privilege_$dir_priv_off ((0));

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$ipc_privilege
	then if control_point_data.privileges & sys_info$ipc_privilege
	     then call system_privilege_$ipc_priv_on ((0));
	     else call system_privilege_$ipc_priv_off ((0));

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$rcp_privilege
	then if control_point_data.privileges & sys_info$rcp_privilege
	     then call system_privilege_$rcp_priv_on ((0));
	     else call system_privilege_$rcp_priv_off ((0));

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$ring1_privilege
	then if control_point_data.privileges & sys_info$ring1_privilege
	     then call system_privilege_$ring1_priv_on ((0));
	     else call system_privilege_$ring1_priv_off ((0));

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$seg_privilege
	then if control_point_data.privileges & sys_info$seg_privilege
	     then call system_privilege_$seg_priv_on ((0));
	     else call system_privilege_$seg_priv_off ((0));

	if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$soos_privilege
	then if control_point_data.privileges & sys_info$soos_privilege
	     then call system_privilege_$soos_priv_on ((0));
	     else call system_privilege_$soos_priv_off ((0));

	return;

     end restore_privileges;
%page;
/* Mask the specified IPS interrupts */

mask_ips_interrupts:
     procedure (p_new_mask, p_old_mask);

dcl	p_new_mask	bit (36) aligned parameter;
dcl	p_old_mask	bit (36) aligned parameter;

	call hcs_$set_ips_mask (p_new_mask, p_old_mask);

     end mask_ips_interrupts;



/* Invoke mask_ips_interrupts -- This entrypoint exists to prevent making the mask_ips_interrupts internal procedure
   non-quick by invoking it from within an on unit or other non-quick procedure. */

mask_ips_interrupts_caller:
     entry (P_new_mask, P_old_mask);

	call mask_ips_interrupts (P_new_mask, P_old_mask);
	return;



/* Restore the IPS mask to its state prior to calling mask_ips_interrupts */

unmask_ips_interrupts:
     procedure (p_old_mask);

dcl	p_old_mask	bit (36) aligned parameter;

	if substr (p_old_mask, 36, 1) = "1"b
	then call hcs_$reset_ips_mask (p_old_mask, p_old_mask);

     end unmask_ips_interrupts;



/* Invoke unmask_ips_interrupts -- This entrypoint exists to prevent making the unmask_ips_interrupts internal procedure
   non-quick by invoking it from within an on unit or other non-quick procedure. */

unmask_ips_interrupts_caller:
     entry (P_old_mask);

	call unmask_ips_interrupts (P_old_mask);
	return;

/* format: off */
%page; %include cpm_internal_data;
%page; %include cpm_control_point_data;
%include cpm_ctrl_pt_meters;
%include process_usage;
%page; %include cpm_create_ctrl_pt_info;
%page; %include cpm_entries;
%page; %include cpm_generate_call_flags;
%page; %include stack_header;
%page; %include iox_dcls;
%page; %include iox_modes;
%page; %include sub_err_flags;
%page; %include trace_interface;
/* format: on */

     end cpm_overseer_;






		    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
