



		    create_ips_mask_.pl1            11/11/89  1144.0rew 11/11/89  0803.3       19404



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

/* format: style3 */

/* DESCRIPTION:
   Creates an IPS mask given the names of the ips interrupts
   to be masked.
*/

/* HISTORY:
Written by Dan Bricklin, October 1970.
Modified:
06/08/72 by D. M. Wells:  To make it properly respect an invocation with
            lng = 0; that is, no mask is wanted.
07/16/84 by R. Michael Tague:  Make it use the include file ips_mask_data.
*/

create_ips_mask_:
     proc (p, lng, mask);

%include ips_mask_data;

dcl	p		ptr,
	lng		fixed bin (17),
	mask		bit (36) aligned,
	ips_names		(1) char (32) aligned based (p),
	create_ips_mask_err condition,
	(i, j)		fixed bin (17);

	mask = "0"b;				/* Initialize the mask */

	if lng <= 0
	then goto ret;				/* allow for the mask none case		*/

	if p -> ips_names (1) = "-all"
	then do;					/* return a mask of everything */
		do i = 1 to sys_info$ips_mask_data.count;
		     mask = mask | sys_info$ips_mask_data.mask.mask (i);
		end;
		go to ret;
	     end;

	do i = 1 to lng;				/* Look for each signal type in list */

	     do j = 1 to sys_info$ips_mask_data.count;	/* Look through all possible names */
		if p -> ips_names (i) = sys_info$ips_mask_data.mask.name (j)
		then do;
			mask = mask | sys_info$ips_mask_data.mask.mask (j);
			go to next;		/* when found, or in bit */
		     end;
	     end;

	     signal condition (create_ips_mask_err);
	     return;

next:
	end;

ret:
	mask = ^mask;				/* Mask is now an enable mask, so ^ it for
							a disable mask */
	return;

     end;




		    get_control_point_id_.alm       11/11/89  1144.0rew 11/11/89  0803.3       22788



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1986 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-09-19,Fawcett), approve(86-09-19,MCR7473),
"     audit(86-10-22,Farley), install(86-11-03,MR12.0-1206):
"     Written to support control point management.  This was actually done in
"     March 1985 by G. Palter in pl1 with 5 statements. Rewritten in alm to
"     eliminate the cost of pushing and popping the stack frame for such a
"     trivial task.
"                                                      END HISTORY COMMENTS

	name	get_control_point_id_

" This short routine is used by bound_cpm_ and bound_ipc_.  It's
" function is to return the control point id, this is defined as the
" baseno of the stack that control point runs on.  If control point
" management is not enabled then the baseno of the current stack is
" returned.

"
"  USAGE:
"
"  dcl get_control_point_id_ entry () returns (bit (36) aligned);
"
"  ID = get_control_point_id_ ();
"
	
	entry     get_control_point_id_
	
get_control_point_id_:

" First check to see if control point management is enabled.
" If stack_header.cpm_enabled is not zero then it is enabled.

          lxl7       sb|stack_header.cpm_enabled	" Lower half of word

 " transfer if control point is enabled (not zero)

          tnz       real_cp            

" not enabled (zero), the ID is this stack baseno placed in the A
" register by the Effective Pointer in the AQ register.

          epaq      sb|0

" AND a mask to the upper half of the A register. Thats where the epaq
" placed the segment number, in bits 3-17.

          ana       =o077777,du
	sta       ap|2,*		" return the ID to the caller.
          short_return		" short_return because no stack frame
				" was pushed.


real_cp:  

" Now that we KNOW that control point management is enabled, load the
" ID in the A register and return it to the caller.

          eax7	cpd.id
          lda	sb|stack_header.cpm_data_ptr,*7
          sta       ap|2,*		" return the ID to the caller.
          short_return		" short_return because no stack frame
				" was pushed.
          
%include cpm_control_point_data;
%include stack_header;

          end




		    ipc_.alm                        11/11/89  1144.0rew 11/11/89  0803.3       27729



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

name	ipc_

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"	This procedure is a transfer vector for the several pieces of IPC.
"
"	Originally coded by R. J. Feiertag on May 13, 1972.
"	Changed by E. Donner Jan 1981 for new ipc from rest_of_ipc_.alm
"	Modified by J. Bongiovanni Septemper 1981 for name ipc_, macro
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""


" HISTORY COMMENTS:
"  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
"     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
"     Modified to support control point management.  This change was actually
"     made in February 1985 by G. Palter.
"  2) change(86-08-12,Kissel), approve(86-08-12,MCR7479),
"     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
"     Added the create_event_channel and run_event_calls entries to support
"     asynch event channels.
"                                                      END HISTORY COMMENTS


"	The following is the normal transfer-vector macro
"	
"	ipc_tv	<entry in ipc_>,<seg$entry to transfer to>

	macro	ipc_tv
	segdef	&1
&1:
	tsx0	getlp
	tra	&2
	&end



"
"	The following subroutine calculate the lp for this procedure.
"

getlp:
	epaq	*		get ptr to ourselves
	lprplp	sb|stack_header.lot_ptr,*au get ptr to linkage from packed ptr
	tra	0,0		return
"
	%include	stack_header
"
	ipc_tv	block,ipc_fast_$block
	ipc_tv	create_ev_chn,ipc_real_$create_ev_chn
	ipc_tv	create_event_channel,ipc_real_$create_event_channel
	ipc_tv	cutoff,ipc_real_$cutoff
	ipc_tv	decl_ev_call_chn,ipc_real_$decl_ev_call_chn
	ipc_tv	decl_ev_wait_chn,ipc_real_$decl_ev_wait_chn
	ipc_tv	decl_event_call_chn,ipc_real_$decl_event_call_chn
	ipc_tv	delete_ev_chn,ipc_real_$delete_ev_chn
	ipc_tv	drain_chn,ipc_real_$drain_chn
	ipc_tv	mask_ev_calls,ipc_real_$mask_ev_calls
	ipc_tv	read_ev_chn,ipc_real_$read_ev_chn
	ipc_tv	reassign_call_channels,ipc_real_$reassign_call_channels
	ipc_tv	reconnect,ipc_real_$reconnect
	ipc_tv	reset_ev_call_chn,ipc_real_$reset_ev_call_chn
	ipc_tv	run_event_calls,ipc_real_$run_event_calls
	ipc_tv	set_call_prior,ipc_real_$set_call_prior
	ipc_tv	set_wait_prior,ipc_real_$set_wait_prior
	ipc_tv	unmask_ev_calls,ipc_real_$unmask_ev_calls
	ipc_tv	wait_for_an_event,ipc_real_$wait_for_an_event

"	This is an obsolete entry, from the days before IPC
"	used standard error codes. It is a no-op

	segdef	convert_ipc_code_
convert_ipc_code_:
	short_return


	end




		    ipc_data_.cds                   11/11/89  1144.0r w 11/11/89  0803.3       19539



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


/* format: style3 */
ipc_data_:
     proc;

/* Static values needed by user ring ipc - replaces an alm version */
/* These are used to implement fast channels efficiently by making it */
/* inexpensive to detect if a process has pending wakeups. */

/* Coded by E Donner Jan 1981 */
/* Modified September 1983 by Chris Jones to only count event calls pending */

/* automatic */

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

/* constants  */

dcl	MOI		char (9) static init ("ipc_data_") options (constant);

/* Builtins */

dcl	addr		builtin;
dcl	null		builtin;
dcl	size		builtin;
dcl	string		builtin;
dcl	unspec		builtin;

/* entries */

dcl	com_err_		entry options (variable);
dcl	create_data_segment_
			entry (ptr, fixed bin (35));


dcl	1 ipc_data_	aligned,
	  2 event_calls_pending
			fixed bin,		/* count of call events pending */
	  2 fast_channel_events
			bit (36);			/* special events pending */


	unspec (ipc_data_) = ""b;

/* Fill in arguments to cds before creating data base */


	cds_arguments.sections (2).p = addr (ipc_data_);
	cds_arguments.sections (2).len = size (ipc_data_);
	cds_arguments.sections (2).struct_name = MOI;

	cds_arguments.seg_name = MOI;
	cds_arguments.exclude_array_ptr = null;

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

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

%include cds_args;

     end ipc_data_;




		    ipc_fast_.pl1                   11/11/89  1144.0rew 11/11/89  0803.3       56700



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

/* format: style3 */

ipc_fast_$block:
     procedure (a_event_wait_list_ptr, a_event_wait_info_ptr, a_code);

/* This procedure is a fast call to block a process and is
   called as ipc_$block. It handles fast ipc channels only
   and calls the full ipc mechanism if channels other than
   fast channels are supplied. */

/* Rewritten for new ipc by E Donner Jan 1981 */
/* Modified September 1983 by Chris Jones to call the full IPC mechanism
      when there are call events pending, not when there are any events
      pending. */
/* Modified 1984-11-02 by E. Swenson for new ipc validation */


/****^  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):
     Changed to support control point management.  These changes were actually
     done in February 1985 by G. Palter.
                                                   END HISTORY COMMENTS */


/* parameters */

dcl	a_event_wait_list_ptr
			ptr parameter;
dcl	a_event_wait_info_ptr
			ptr parameter;
dcl	a_code		fixed bin (35);

/* automatic */

dcl	call_regular	bit (1) aligned;		/* indicates if full ipc should be called */
dcl	cur_ring		fixed bin (3);		/* current ring */
dcl	1 ev_chn_name	aligned like event_channel_name automatic;
dcl	loop		fixed bin;		/* index */
dcl	validation_level	fixed bin (3);		/* current validation level */

/* constants */

dcl	OFF		bit (1) aligned static options (constant) init ("0"b);
dcl	ON		bit (1) aligned static options (constant) init ("1"b);
dcl	TRUE		bit (1) aligned static options (constant) init ("1"b);

/* external static */

dcl	ipc_data_$event_calls_pending
			fixed bin ext;		/* number of event call wakeups pending */
dcl	ipc_data_$fast_channel_events
			bit (36) aligned ext;	/* fast events pending */
dcl	error_table_$bad_arg
			fixed bin (35) ext;
dcl	error_table_$invalid_channel
			fixed bin (35) ext;

/* external entries */

dcl	cu_$level_get	entry returns (fixed bin (3));
dcl	cu_$level_set	entry (fixed bin (3));
dcl	ipc_real_$full_block
			entry (ptr, ptr, fixed bin (35));
dcl	get_ring_		entry returns (fixed bin (3));
dcl	hcs_$fblock	entry (bit (36) aligned, bit (1) aligned);

/* Conditions */

dcl	cleanup		condition;

/* Builtin */

dcl	length		builtin;
dcl	stackbaseptr	builtin;
dcl	substr		builtin;
dcl	unspec		builtin;
%page;
/* Program */

	event_wait_list_ptr = a_event_wait_list_ptr;
	event_wait_info_ptr = a_event_wait_info_ptr;
	event_wait_list_n_channels = event_wait_list.n_channels;

	if event_wait_list_n_channels <= 0
	then do;
		a_code = error_table_$bad_arg;
		return;
	     end;

	if ipc_data_$event_calls_pending ^= 0		/* we have some call wakeups pending */
	then go to INVOKE_FULL_BLOCK;			/* call full block mechanism */

	cur_ring = get_ring_ ();
	validation_level = cu_$level_get ();		/* get validation level */

	do while (TRUE);

	     if have_multiple_control_points ()		/* more than one cotnrol point can be waiting ... */
	     then go to INVOKE_FULL_BLOCK;		/* ... on one of these channels */

	     do loop = 1 to event_wait_list_n_channels;	/* look for each channel */
		unspec (ev_chn_name) = unspec (event_wait_list.channel_id (loop));
						/* copy channel name into structured format */
		if ev_chn_name.type = REGULAR_CHANNEL_TYPE | ev_chn_name.ring ^= cur_ring
		then go to INVOKE_FULL_BLOCK;		/* if regular event channel or from another ring */

/* do validity check on channel name */
		if ev_chn_name.mbz ^= "0"b | ev_chn_name.unique_id <= 0
		     | ev_chn_name.unique_id > length (ipc_data_$fast_channel_events)
		then do;
			a_code = error_table_$invalid_channel;
			return;
		     end;

/* ascertained that this is fast channel in current ring */
		if substr (ipc_data_$fast_channel_events, ev_chn_name.unique_id, 1) = ON
		then do;				/* wakeup pending */
			substr (ipc_data_$fast_channel_events, ev_chn_name.unique_id, 1) = OFF;
						/* turn off event cell */

			unspec (event_wait_info) = "0"b;
			event_wait_info.channel_id = event_wait_list.channel_id (loop);
						/* return messge - channel name */
			event_wait_info.channel_index = loop;
						/* and index in input list */
			a_code = 0;		/* no error */
			return;
		     end;
	     end;

/* no fast events already processed */

	     on condition (cleanup) call cu_$level_set (validation_level);

	     if validation_level ^= cur_ring		/* set validation level to current ring */
	     then call cu_$level_set (cur_ring);

	     call hcs_$fblock (ipc_data_$fast_channel_events, call_regular);
						/* get events from ring 0 */
	     if validation_level ^= cur_ring		/* reset validation level */
	     then call cu_$level_set (validation_level);

	     revert cleanup;

	     if call_regular			/* wakeups for regular channels must be checked ... */
	     then go to INVOKE_FULL_BLOCK;		/* ... as they could be wakeups for call channels */
	end;


/* Control arrives here iff we must invoke the full blocking mechanism */

INVOKE_FULL_BLOCK:
	call ipc_real_$full_block (event_wait_list_ptr, event_wait_info_ptr, a_code);
	return;
%page;
/* Determines if more than one control point is defined in this process */

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

	if stackbaseptr () -> stack_header.cpm_enabled
	then return (cpm_data_$n_control_points > 1);
	else return ("0"b);

     end have_multiple_control_points;

/* format: off */
%page; %include ect_structures;
%page; %include event_channel_name;
%page; %include event_wait_info;
%page; %include event_wait_list;
%page; %include stack_header;
%page; %include cpm_data_;
/* format: on */

     end ipc_fast_$block;




		    ipc_real_.pl1                   11/11/89  1144.0rew 11/11/89  0803.3      591327



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


/* format: style3 */

/**** THE INTERPROCESS COMMUNICATION FACILITY. This procedure is resident in 
      all non-hardcore rings (1:7) to manipulate the event channels of those
      rings. Every ring has its own Event Channel Table (ECT) and Event
      Channel Index Table (ECIT) which is created dynamically when
      ipc_$create_ev_chn is invoked for the first time in that ring.

      IPC manipulates the ECT pointed to either by the validation ring number
      or by the event channel name. Only ipc_$block refers to its
      current-ring's ECT for event-call interrogation, all other calls to
      IPC manipulate the ECT in which the event channel given as argument is
      located, provided that it is not an inner ring. */

/* format: off */

/*
   IPC may return one of the following error codes:

   0 = no error

   error_table_$wrong_channel_ring
     = ring access violation (event channel resides in other than current ring)

   error_table_$invalid_channel
     = event channel not found in ECT (incorrect event channel name)

   error_table_$not_a_wait_channel
     = attempting to wait for event call channel

   error_table_$event_calls_not_masked
     = attempting to unmask event calls when event call already unmasked

   error_table_$event_channel_cutoff
     = attempting to read a channel or go blocked on a group of channels
       all of which have been cutoff 

   error_table_$event_channel_not_cutoff
     = attempting to reconnect a channel which has not been cutoff

   error_table_$bad_arg
     = erroneous argument
*/

/* format: on */

/* 
   Initially coded by the very hands of Michael J. Spier, August 26, 1968
   Rewritten for new ipc by Eleanor Donner Jan 1981 
   Modified September 1981 by J. Bongiovanni to fix the most obscure bug I've 
          ever seen
   Modified September 1983 by Chris Jones to count event calls pending, not all events pending.
   Modified 1984-11-02 by E. Swenson for new IPC event channel validation. 
*/


/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
     Changed to support control point management.  These changes were actually
     done in February 1985 by G. Palter.
  2) change(86-08-12,Kissel), approve(86-08-12,MCR7479),
     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
     Changed to add the create_event_channel and run_event_calls entries to
     support async event channels.
                                                   END HISTORY COMMENTS */


ipc_real_:
     procedure ();
	return;					/* not an entry */

/* Parameters */

dcl	P_create_arg_ptr	ptr parameter;
dcl	P_event_channel_name
			fixed bin (71) parameter;
dcl	P_event_channel_type
			fixed bin parameter;
dcl	P_code		fixed bin (35) parameter;
dcl	P_fast_channel_id	fixed binary (18) parameter;
dcl	P_procedure_ptr	ptr parameter;
dcl	P_event_wait_list_ptr
			ptr parameter;
dcl	P_datap		ptr parameter;
dcl	P_priority	fixed bin (17) parameter;
dcl	P_procedure_entry	entry (ptr) variable parameter;
dcl	P_old_control_point_id
			bit (36) aligned parameter;
dcl	P_new_control_point_id
			bit (36) aligned parameter;
dcl	P_found_event	fixed bin (17) parameter;
dcl	P_event_wait_info_ptr
			ptr parameter;
dcl	P_mask		bit (36) aligned parameter;

/* External Entries */

dcl	continue_to_signal_ entry (fixed bin (35));
dcl	cu_$level_get	entry returns (fixed bin (3));
dcl	cu_$level_set	entry (fixed bin (3));
dcl	cu_$make_entry_value
			entry (ptr, entry);
dcl	get_ring_		entry returns (fixed bin (3));
dcl	hcs_$assign_channel entry (fixed bin (71), fixed bin (35));
dcl	hcs_$delete_channel ext entry (fixed bin (71), fixed bin (35));
dcl	hcs_$fblock	entry (bit (36) aligned, bit (1) aligned);
dcl	hcs_$read_events	entry (bit (36) aligned, bit (1) 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	ipc_util_$create_ect
			entry (ptr);
dcl	ipc_util_$delete_entry
			entry (ptr, ptr);
dcl	ipc_util_$ect_error_handler
			entry (fixed bin (35));
dcl	ipc_util_$make_entry
			entry (ptr, fixed bin (8), ptr, fixed bin (15));
dcl	ipc_util_$verify_channel
			entry (fixed bin (71), ptr, bit (1) aligned, fixed bin (35));
dcl	ipc_util_$verify_regular_channel
			entry (fixed bin (71), ptr, fixed bin (35));
dcl	ipc_validate_$encode_event_channel_name
			entry (fixed bin (18), fixed bin (35), bit (3) aligned, fixed bin (15), fixed bin (3),
			bit (1) aligned, fixed bin (18), fixed bin (71));

/* External Static */

dcl	error_table_$bad_arg
			fixed bin (35) ext;
dcl	error_table_$event_calls_not_masked
			fixed bin (35) ext;
dcl	error_table_$event_channel_cutoff
			fixed bin (35) ext;
dcl	error_table_$event_channel_not_cutoff
			fixed bin (35) ext;
dcl	error_table_$inconsistent_ect
			fixed bin (35) ext;
dcl	error_table_$not_a_wait_channel
			fixed bin (35) ext;
dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;
dcl	ipc_data_$fast_channel_events
			bit (36) aligned ext;
dcl	ipc_data_$event_calls_pending
			fixed bin ext;

/* Automatic */

dcl	added_to_waiting_lists
			bit (1) aligned;
dcl	block_val		fixed bin (3);
dcl	call_channel_procedure
			entry (ptr) variable;
dcl	1 call_info	aligned like event_call_info;
dcl	check_channels	bit (1) aligned;
dcl	cur_ring		fixed bin (3);
dcl	current_control_point_id
			bit (36) aligned;
dcl	ecit_idx		fixed bin (15);
dcl	entry_type	fixed bin (8);
dcl	1 entry_value	aligned,
	  2 ep_ptr	ptr,
	  2 env_ptr	ptr;
dcl	event_call_in_progress
			bit (1) aligned;
dcl	ev_chn_flags	bit (3) aligned;
dcl	event_channel_type	fixed bin;
dcl	fb71		fixed bin (71);
dcl	found_call_event	bit (1) aligned;
dcl	found_event	fixed bin;
dcl	found_wait_event	bit (1) aligned;
dcl	inhibit_count	fixed bin;
dcl	is_fast		bit (1) aligned;
dcl	last_ectep	ptr;
dcl	loop		fixed bin;
dcl	mask		bit (36) aligned;
dcl	msg_ptr		ptr;
dcl	saved_message_thread
			pointer;
dcl	temp_found_event	fixed bin;

/* Builtins */

dcl	addr		builtin;
dcl	codeptr		builtin;
dcl	environmentptr	builtin;
dcl	null		builtin;
dcl	stackbaseptr	builtin;
dcl	substr		builtin;
dcl	unspec		builtin;

/* Conditions */

dcl	any_other		condition;
dcl	cleanup		condition;

/* Constants */

dcl	(ON, YES, TRUE)	bit (1) aligned static options (constant) init ("1"b);
dcl	(OFF, NO)		bit (1) aligned static options (constant) init ("0"b);
%page;
create_ev_chn:
     entry (P_event_channel_name, P_code);

/****  This entry creates an event wait channel and returns the channel 
       name. */

	call find_ectp;				/* get pointer to ECT header for current ring  */

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

	call mask_ips_interrupts (mask);

	call ipc_util_$make_entry (ect_ptr, WAIT, ectep, ecit_idx);

/* set message and control point queue pointers to null values */

	wait_channel.first_ev_msgp, wait_channel.last_ev_msgp = null ();
	wait_channel.first_wcpp, wait_channel.last_wcpp = null ();

	ev_chn_flags = ""b;				/* we don't support anything else yet. */
	cur_ring = get_ring_ ();

	call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags, ecit_idx,
	     cur_ring, REGULAR_CHANNEL_TYPE, (ect_header.seed), fb71);
	ect_header.seed = ect_header.seed + 1;

/* put name in channel entry and return arg */

	wait_channel.name, unspec (P_event_channel_name) = unspec (fb71);

/* thread into list of wait channels */

	call thread_channel (WAIT);
	call unmask_ips_interrupts (mask);

	P_code = 0;
	return;
%page;
create_event_channel:
     entry (P_create_arg_ptr, P_event_channel_name, P_code);

/**** This entry creates an event channel of the specified type.  The procedure
      entry, data pointer, and priority arguments are ignored for wait type
      channels and used for call type channels. */

	ipc_create_arg_structure_ptr = P_create_arg_ptr;

	P_event_channel_name = 0;			/* Initialize the outputs. */
	P_code = 0;

	if ipc_create_arg_structure.version ^= ipc_create_arg_structure_v1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

/* Set up to create the event channel. */

	call find_ectp;				/* get pointer to ECT header for current ring  */

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

	call mask_ips_interrupts (mask);

	/*** Create a fast event wait channel. */

	if ipc_create_arg_structure.channel_type = FAST_EVENT_CHANNEL_TYPE
	then do;
		call hcs_$assign_channel (P_event_channel_name, P_code);
	     end;

	/*** Create a normal event wait channel. */

	else if ipc_create_arg_structure.channel_type = WAIT_EVENT_CHANNEL_TYPE
	then do;
		call ipc_util_$make_entry (ect_ptr, WAIT, ectep, ecit_idx);

		/*** Set message and control point queue pointers to null values. */

		wait_channel.first_ev_msgp, wait_channel.last_ev_msgp = null ();
		wait_channel.first_wcpp, wait_channel.last_wcpp = null ();

		ev_chn_flags = NORMAL_CHANNEL_FLAGS;
		cur_ring = get_ring_ ();

		call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags,
		     ecit_idx, cur_ring, REGULAR_CHANNEL_TYPE, (ect_header.seed), fb71);
		ect_header.seed = ect_header.seed + 1;

		/*** Put the name in the channel entry and the return argument. */

		wait_channel.name = unspec (fb71);
		unspec (P_event_channel_name) = unspec (fb71);

		/*** Thread into the list of wait channels. */

		call thread_channel (WAIT);
	     end;

	/*** Create a normal or IPS wkp_ event call channel. */

	else if ipc_create_arg_structure.channel_type = CALL_EVENT_CHANNEL_TYPE
	     | ipc_create_arg_structure.channel_type = ASYNC_CALL_EVENT_CHANNEL_TYPE
	then do;
		call ipc_util_$make_entry (ect_ptr, CALL, ectep, ecit_idx);

		/*** Set up the call channel structure. */

		call_channel.type = CALL;

		call_channel.first_ev_msgp, call_channel.last_ev_msgp = null ();

		call_channel.data_ptr = ipc_create_arg_structure.call_data_ptr;
		call_channel.procedure_ptr = codeptr (ipc_create_arg_structure.call_entry);
		call_channel.environment_ptr = environmentptr (ipc_create_arg_structure.call_entry);
		call_channel.priority = ipc_create_arg_structure.call_priority;
		call_channel.control_point_id = get_control_point_id_ ();
		call_channel.call_inhibit = OFF;

		/*** Set the flag that indicates what type of call channel this is. */
		/*** Since this information is also encoded in the channel name */
		/*** we only set this flag here and it remains the way we set it */
		/*** for the life of this entry. */

		if ipc_create_arg_structure.channel_type = CALL_EVENT_CHANNEL_TYPE
		then do;
			call_channel.flags.async_call = "0"b;
			ev_chn_flags = NORMAL_CHANNEL_FLAGS;
		     end;

		else do;
			call_channel.flags.async_call = "1"b;
			ev_chn_flags = SEND_IPS_WKP_CHANNEL_FLAGS;
		     end;

		cur_ring = get_ring_ ();

		call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags,
		     ecit_idx, cur_ring, REGULAR_CHANNEL_TYPE, (ect_header.seed), fb71);
		ect_header.seed = ect_header.seed + 1;

		/*** Put the name in the channel entry and the return argument. */

		call_channel.name = unspec (fb71);
		unspec (P_event_channel_name) = unspec (fb71);

		/*** Thread into the list of call channels. */

		call thread_channel (CALL);
	     end;

	/*** He wants some type we have never heard of. */

	else P_code = error_table_$bad_arg;

/* All done, unmask and return, the channel name and the code have been set. */

	call unmask_ips_interrupts (mask);

	return;
%page;
create_fast_ev_chn:
     entry (P_fast_channel_id, P_code);

/****  This entry creates a wait channel definition for a fast event channel.
       This wait channel definition is only used when control point management
       is enabled to track the control points which have blocked on the fast
       channel. */

	call find_ectp;				/* get pointer to ECT header for current ring  */

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

	call mask_ips_interrupts (mask);

	call ipc_util_$make_entry (ect_ptr, WAIT, ectep, ecit_idx);
	if P_fast_channel_id ^= ecit_idx
	then do;					/* fast channel's ECT index must match its ID */
		call ipc_util_$delete_entry (ect_ptr, ectep);
		call inconsistent_ect ();		/* ... will never return */
	     end;

	wait_channel.fast_channel = YES;		/* this is a fast channel ECT entry */
	wait_channel.fast_channel_id = P_fast_channel_id;

	wait_channel.first_ev_msgp, wait_channel.last_ev_msgp = null ();
	wait_channel.first_wcpp, wait_channel.last_wcpp = null ();

/* Create the channel's name */

	ev_chn_flags = NORMAL_CHANNEL_FLAGS;
	cur_ring = get_ring_ ();
	call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags, ecit_idx,
	     cur_ring, FAST_CHANNEL_TYPE, (P_fast_channel_id), fb71);
	wait_channel.name = unspec (fb71);

/* Thread into list of wait channels */

	call thread_channel (WAIT);
	call unmask_ips_interrupts (mask);

	P_code = 0;
	return;
%page;
decl_ev_call_chn:
     entry (P_event_channel_name, P_procedure_ptr, P_datap, P_priority, P_code);

	call find_ectp;

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

	call cu_$make_entry_value (P_procedure_ptr, call_channel_procedure);
	call MAKE_EVENT_CALL (call_channel_procedure);

	return;
%page;
decl_event_call_chn:
     entry (P_event_channel_name, P_procedure_entry, P_datap, P_priority, P_code);

	call find_ectp;

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

	call MAKE_EVENT_CALL (P_procedure_entry);

	return;
%page;
decl_ev_wait_chn:
     entry (P_event_channel_name, P_code);

/****
      This entry turns an event channel into a wait channel.  It works on
      asynchronous call channels as well as normal call channels.  If the
      channel was asynchronous, then the IPS "wkp_" will still be sent, but
      will essentially be a no-op.
****/

	call find_ectp;
	call ipc_util_$verify_channel (P_event_channel_name, ectep, is_fast, P_code);

/* return if unable to locate channel or if already a wait channel */
/* fast channels are considered to be wait channels */

	if (P_code ^= 0) | (is_fast = YES)
	then return;

	if (wait_channel.type = WAIT)
	then return;

/* On with the show. */

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

	call mask_ips_interrupts (mask);

/* Save the list of pending messages */

	call save_channel_message_thread (saved_message_thread);

/* Remove last vestiges of this channel being a call channel, but leave the
   flags alone just in case it becomes a call channel again. */

	call_channel.priority = 0;
	call_channel.call_inhibit = OFF;
	call unthread_channel;

/* Complete conversion into a wait channel */

	wait_channel.type = WAIT;
	wait_channel.first_wcpp, wait_channel.last_wcpp = null ();
	wait_channel.fast_channel_id, wait_channel.unused2 = 0;
	call thread_channel (WAIT);

/* Rethread any pending messages saved above */

	call rethread_channel_message_thread (saved_message_thread);

	call unmask_ips_interrupts (mask);

	return;
%page;
reset_ev_call_chn:
     entry (P_event_channel_name, P_code);

/**** This entry resets a call channel's inhibit flag */

	call find_ectp;
	call ipc_util_$verify_regular_channel (P_event_channel_name, ectep, P_code);

	if P_code ^= 0
	then return;

	if call_channel.type = CALL
	then call_channel.call_inhibit = OFF;

	return;
%page;
/* Reassigns ownership of all event call channels from one control point to
   another -- This entrypoint is called by the control point manager whenever
   it destroys a control point. */

reassign_call_channels:
     entry (P_old_control_point_id, P_new_control_point_id);

	call find_ectp ();

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

	call mask_ips_interrupts (mask);

	do ectep = ect_header.firstp (CALL) repeat (call_channel.next_chanp) while (ectep ^= null ());
	     if call_channel.type ^= CALL
	     then call inconsistent_ect ();
	     if call_channel.control_point_id = P_old_control_point_id
	     then call_channel.control_point_id = P_new_control_point_id;
	end;

	call unmask_ips_interrupts (mask);

	return;
%page;
delete_ev_chn:
     entry (P_event_channel_name, P_code);

/**** This entry deletes an event channel */

	call find_ectp;
	call ipc_util_$verify_channel (P_event_channel_name, ectep, is_fast, P_code);
	if P_code ^= 0
	then return;

	call decl_ev_wait_chn (P_event_channel_name, P_code);
						/* make it event-wait channel */
	if P_code ^= 0
	then return;

	call drain_chn (P_event_channel_name, P_code);	/* reset channel to zero */

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

	call mask_ips_interrupts (mask);

	call reset_channel_wcps ();			/* any waiting control points should now get an error */

	if is_fast = YES
	then call hcs_$delete_channel (P_event_channel_name, P_code);
	else do;
		call unthread_channel;
		call ipc_util_$delete_entry (ect_ptr, ectep);
		P_code = 0;
	     end;

	call unmask_ips_interrupts (mask);

	return;
%page;
drain_chn:
     entry (P_event_channel_name, P_code);

/**** Drains all currently waiting event messages from the channel. */

	found_event = 1;				/* set default values */
	P_code = 0;

	do loop = 1 to 2;
	     do while (found_event = 1 & P_code = 0);	/* read events until channel empty */
		call read_ev_chn (P_event_channel_name, found_event, addr (call_info), P_code);
	     end;

	     if loop = 1				/* drain channel even if it has been cutoff */
	     then if P_code ^= 0
		then if P_code = error_table_$event_channel_cutoff
		     then do;
			     call reconnect (P_event_channel_name, (0));
			     P_code = 0;
			end;
	end;
	return;
%page;
cutoff:
     entry (P_event_channel_name, P_code);

/**** Sets a flag to temporarily disable the channel for reading 
      purposes. */

	call find_ectp;
	call set_inhibit_switch (1);
	return;
%page;
reconnect:
     entry (P_event_channel_name, P_code);

/**** Resets the inhibit flag reactivating the channel. */

	call find_ectp;
	call set_inhibit_switch (-1);
	return;
%page;
set_call_prior:
     entry (P_code);

/**** For this ring, set priority so that event call channels are
      interrogated before event wait channels. */

	call find_ectp;
	call set_priority_switch (ON);
	return;
%page;
set_wait_prior:
     entry (P_code);

/**** For this ring, set priority so that event wait channels are
      interrogated before event call channels. */

	call find_ectp;
	call set_priority_switch (OFF);
	return;
%page;
mask_ev_calls:
     entry (P_code);

/**** Cause calls to ipc_$block ignore event call channels in this
      ring. */

	call find_ectp;
	call set_mask (1);
	return;
%page;
unmask_ev_calls:
     entry (P_code);

/**** Cause calls to ipc_$block to respond to event call channels
      again for this ring. */

	call find_ectp;
	call set_mask (-1);
	return;
%page;
read_ev_chn:
     entry (P_event_channel_name, P_found_event, P_event_wait_info_ptr, P_code);

/**** Read an event message out of an event channel */

	call find_ectp;
	inhibit_count, P_found_event = 0;

	call ipc_util_$verify_channel (P_event_channel_name, ectep, is_fast, P_code);
	if P_code ^= 0
	then return;

/* Only call ring-0 if the ECT does not already have any messages for this channel */

	block_val = cu_$level_get ();			/* for cleanup handler required by copy_itt_messages */
	cur_ring = get_ring_ ();
	on cleanup call cu_$level_set (block_val);

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

	if is_fast = YES
	then do;
		call read_fast_channel (P_event_channel_name, P_found_event, P_event_wait_info_ptr);
		if P_found_event = 0
		then do;				/* nothing known already: ask ring 0 */
			call copy_itt_messages (NO);
			call read_fast_channel (P_event_channel_name, P_found_event, P_event_wait_info_ptr);
		     end;
	     end;

	else do;					/* regular channel */
		if wait_channel.first_ev_msgp = null ()
		then call copy_itt_messages (NO);	/* nothing known already: ask ring 0 */
		call read_channel (inhibit_count, P_found_event, P_event_wait_info_ptr);
		if inhibit_count ^= 0		/* logical error, channel inhibited */
		then P_code = error_table_$event_channel_cutoff;
	     end;

	return;
%page;
/**** This entry waits for events to be signalled over event channels */

full_block:
     entry (P_event_wait_list_ptr, P_event_wait_info_ptr, P_code);

	call find_ectp ();

	event_wait_list_ptr = P_event_wait_list_ptr;
	event_wait_info_ptr = P_event_wait_info_ptr;
	event_wait_info.channel_index = 0;		/* reset channel-index to zero  */

	event_wait_list_n_channels = event_wait_list.n_channels;
						/* get number of channels to read  */

	if event_wait_list_n_channels <= 0
	then do;					/* erroneous argument  */
		P_code = error_table_$bad_arg;
		return;
	     end;

	block_val = cu_$level_get ();			/* for cleanup handler requried by copy_itt_messages ... */
	cur_ring = get_ring_ ();			/* ... and hardcore_block */

	event_call_in_progress = NO;			/* for cleanup handler required by check_call_channels */

	added_to_waiting_lists = NO;			/* for cleanup handler if there are multiple control points */

	on cleanup
	     begin;
		if added_to_waiting_lists = YES	/* this control point will no longer be waiting */
		then call delete_from_waiting_lists_caller (event_wait_list_ptr);
		if event_call_in_progress = YES	/* the event call has been aborted */
		then do;
			call_channel.call_inhibit = OFF;
			event_call_in_progress = NO;
		     end;
		call cu_$level_set (block_val);
	     end;

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

	current_control_point_id = get_control_point_id_ ();


/* Main loop of ipc_$full_block */

	do while (TRUE);

	     call copy_itt_messages (NO);		/* get pending ITT messages */

/* format: off */
	     check_channels =			/* we can only check for events if ... */
		(have_multiple_control_points () = NO) |/* ... there is only one control point or ... */
		(ect_header.wakeup_control_points = NO);/* ... all control points are in their proper state */
/* format: on */

/* Check the channels for a pending event to satisfy this block */

	     do while (check_channels = YES);

		if ect_header.call_priority = YES
		then do;				/* check call channels first */
			call check_call_channels (ANY_CALL_EVENT_CHANNEL_TYPE, found_call_event);
			if found_call_event = NO
			then do;
				call check_wait_channels (found_wait_event);
				if (found_wait_event = YES) | (P_code ^= 0)
				then go to RETURN_FROM_FULL_BLOCK;
			     end;
		     end;

		else do;				/* check the wait channels first */
			call check_wait_channels (found_wait_event);
			if (found_wait_event = YES) | (P_code ^= 0)
			then go to RETURN_FROM_FULL_BLOCK;
			call check_call_channels (ANY_CALL_EVENT_CHANNEL_TYPE, found_call_event);
		     end;

		check_channels =
		     (found_call_event = YES)
		     & ((have_multiple_control_points () = NO) | (ect_header.wakeup_control_points = NO));
	     end;

/* Control arrives here iff we have to block until an event arrives -- If there
   are multiple control points in the process, this control point will now
   relinquish control of the process to someone else.  If there's only one
   control point, we can call ring 0 to block the process directly. */

	     if have_multiple_control_points () = YES
	     then do;
		     if added_to_waiting_lists = NO	/* put this control point on each channel's waiting list */
		     then do;
			     call add_to_waiting_lists ();
			     if P_code ^= 0
			     then go to RETURN_FROM_FULL_BLOCK;
			end;
		     call block_if_no_pending_events ();/* mark us blocked unless there are available events */
		     if P_code ^= 0
		     then go to RETURN_FROM_FULL_BLOCK;
		     if ect_header.wakeup_control_points = YES
		     then call wakeup_blocked_control_points ();
		     call cpm_$scheduler ();		/* find a control point to run */
		end;

	     else call hardcore_block ();
	end;


/* Control arrives here when it's time to return to our caller and we might
   have passed through the main loop at least once */

RETURN_FROM_FULL_BLOCK:
	if added_to_waiting_lists = YES
	then call delete_from_waiting_lists ();

	return;
%page;
/* This entrypoint is called by the control point scheduler when there are
   no control points in the ready state.  The purpose of this entrypoint is
   to wait for any IPC event (fast or regular) to occur and to then notify
   the control points waiting for those events.  The notification will place
   said control points into the ready state and the scheduler will then
   select the one with the highest priority to process its wakeup. */

wait_for_an_event:
     entry ();

	call find_ectp ();

	block_val = cu_$level_get ();			/* for cleanup handler requried by copy_itt_messages ... */
	cur_ring = get_ring_ ();			/* ... and hardcore_block */
	on cleanup call cu_$level_set (block_val);

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

	call copy_itt_messages (YES);			/* pick up any events that have already arrived */

	if ect_header.wakeup_control_points = YES
	then call wakeup_blocked_control_points ();	/* inform the waiting control points if we found anything */
	else call hardcore_block ();			/* otherwise, wait for something to happen */

	return;
%page;
run_event_calls:
     entry (P_event_channel_type, P_code);

/*
   * This entry causes any pending event calls of the specified type to be run.
   * It makes one pass through the chains of pending events instead of scanning
   * from the beginning of the chain after each event is processed (like
   * full_block).  The major reason for this entry is for use by the wkp_ IPS
   * signal, whose contract is to run any pending event calls in the process.
*/

	event_channel_type = P_event_channel_type;

	if event_channel_type ^= CALL_EVENT_CHANNEL_TYPE & event_channel_type ^= ASYNC_CALL_EVENT_CHANNEL_TYPE
	     & event_channel_type ^= ANY_CALL_EVENT_CHANNEL_TYPE
	then do;
		P_code = error_table_$bad_arg;
		return;
	     end;

	call find_ectp ();

	block_val = cu_$level_get ();			/* Save the validation ring number. */
	cur_ring = get_ring_ ();			/* Get the current ring number for calls to ring 0. */

	event_call_in_progress = NO;			/* Triggers cleanup action. */
						/* Prevents check_call_channels procedure from being non-quick. */
	on cleanup
	     begin;
		if event_call_in_progress = YES
		then do;
			call_channel.call_inhibit = OFF;
			event_call_in_progress = NO;
		     end;

		call cu_$level_set (block_val);
	     end;

/* Set up an any_other handler for copy_itt_messages and current_control_point_id for check_call_channels. */

	mask = ""b;
	on any_other call any_other_handler ();

	current_control_point_id = get_control_point_id_ ();

/*
   * Calling copy_itt_messages once will get the pending events.  As long as
   * we don't call it again we won't get any more events in the ECT.  This is
   * how we guarantee that only the events that were pending when we are called
   * will be handled even though check_call_channels starts from the beginning
   * of the event messages each time we call it.
*/

	call copy_itt_messages (NO);

	found_call_event = YES;			/* Do the loop at least once. */

	do while (found_call_event);			/* Loop until no more. */
	     call check_call_channels (P_event_channel_type, found_call_event);
	end;

	return;
%page;
find_ectp:
     procedure ();

/**** Internal procedure to get a pointer to the ECT for this ring.
      If there is none, one will be created. */

	ect_ptr = stackbaseptr () -> stack_header.ect_ptr;
	if ect_ptr = null
	then call ipc_util_$create_ect (ect_ptr);

     end find_ectp;
%page;
/* Pickup any new event messages which have arrived since we last blocked */

copy_itt_messages:
     procedure (p_set_wcp);

dcl	p_set_wcp		bit (1) aligned parameter;

dcl	an_ectep		pointer;
dcl	1 a_call_channel	like call_channel aligned based (an_ectep);
dcl	1 a_wait_channel	like wait_channel aligned based (an_ectep);
dcl	channel_id	fixed binary;
dcl	code		fixed bin (35);


/* Check with ring 0 if there are no ITT messages already in the ECT */

	if ect_header.firstp (ITT_MESSAGE) = null
	then do;
		if block_val ^= cur_ring
		then call cu_$level_set (cur_ring);
		call hcs_$read_events (ipc_data_$fast_channel_events, ("0"b));
		if block_val ^= cur_ring
		then call cu_$level_set (block_val);
	     end;


/* Record newly arrived fast events if multiple control points are present
   in this process as more than one such control point may be blocked on a
   fast channel */

	if (p_set_wcp = YES) | (have_multiple_control_points () = YES)
	then do;

		do an_ectep = ect_header.firstp (WAIT) repeat (a_wait_channel.next_chanp) while (an_ectep ^= null ());
		     if a_wait_channel.type ^= WAIT
		     then call inconsistent_ect ();
		     if a_wait_channel.fast_channel = YES
		     then do;
			     channel_id = a_wait_channel.fast_channel_id;
			     if (substr (ipc_data_$fast_channel_events, channel_id, 1) = YES)
				& (substr (ect_header.last_fast_channel_events, channel_id, 1) = NO)
			     then do;		/* this is a fresh event */
				     a_wait_channel.wakeup_control_points = YES;
				     ect_header.wakeup_control_points = YES;
				end;
			end;
		end;

		ect_header.last_fast_channel_events = ipc_data_$fast_channel_events;
	     end;					/* remember the new events */


/* Process the ITT messages */

	call mask_ips_interrupts (mask);

	do msg_ptr = ect_header.firstp (ITT_MESSAGE) repeat (ect_header.firstp (ITT_MESSAGE)) while (msg_ptr ^= null);

	     ect_header.firstp (ITT_MESSAGE) = msg_ptr -> itt_message.next_itt_msgp;
	     if ect_header.lastp (ITT_MESSAGE) = msg_ptr
	     then ect_header.lastp (ITT_MESSAGE) = null;
	     ect_header.count (ITT_MESSAGE) = ect_header.count (ITT_MESSAGE) - 1;

	     call ipc_util_$verify_regular_channel (msg_ptr -> itt_message.channel_id, an_ectep, code);

	     if code = 0
	     then do;

/* This ITT message is intended for an existing channel -- add it to the appropriate queues */

		     msg_ptr -> event_message.chanp = an_ectep;

		     if (p_set_wcp = YES) | (have_multiple_control_points () = YES)
		     then ect_header.wakeup_control_points, a_wait_channel.wakeup_control_points = YES;
						/* must notify all control points in the process */

		     if a_call_channel.type = CALL
		     then do;
			     msg_ptr -> event_message.priority = a_call_channel.priority;
			     call insert_event_call_message (msg_ptr);
			     ect_header.total_call_wakeups = ect_header.total_call_wakeups + 1;
			end;
		     else do;
			     call insert_event_wait_message (msg_ptr);
			     ect_header.total_wait_wakeups = ect_header.total_wait_wakeups + 1;
			end;

		     ect_header.total_wakeups = ect_header.total_wakeups + 1;
		     a_wait_channel.wakeup_count = a_wait_channel.wakeup_count + 1;
		end;


	     else do;

/* This ITT message is not intended for an existing channel -- throw it away */

		     call ipc_util_$delete_entry (ect_ptr, msg_ptr);
		     ect_header.ittes_tossed = ect_header.ittes_tossed + 1;
		end;

	end;

	call unmask_ips_interrupts (mask);

	return;

     end copy_itt_messages;
%page;
/* Scans the list of outstanding event messages for call channels -- If a
   message is found for a channel which is not inhibited and which was declared
   a call channel by this control point, and the channel is the right type,
   the message is removed from the queue and the call handler is invoked. */

check_call_channels:
     procedure (P_event_channel_type, P_found_call_event);

dcl	P_event_channel_type
			fixed bin parameter;
dcl	P_found_call_event	bit (1) aligned parameter;

dcl	call_msgp		ptr;
dcl	ev_chn_flags	bit (3) aligned;
dcl	got_message	fixed bin;
dcl	is_fast		bit (1) aligned;
dcl	rcode		fixed bin (35);
dcl	saved_channel_name	fixed bin (71);


	P_found_call_event = NO;			/* assume failure */

	if ect_header.mask_call_count > 0		/* all event calls are shut off */
	then return;


/* Scan the list of call event messages */

	got_message = 0;

	do call_msgp = ect_header.firstp (EV_CALL_MESSAGE) repeat (call_msgp)
	     while ((call_msgp ^= null ()) & (got_message = 0));

	     ectep = call_msgp -> event_message.chanp;	/* find the channel which owns this message */
	     if call_channel.type ^= CALL
	     then call inconsistent_ect ();

	     if call_channel.control_point_id = current_control_point_id
	     then do;				/* It is for this control point. */
		     if (^call_channel.flags.async_call
			& (P_event_channel_type = CALL_EVENT_CHANNEL_TYPE
			| P_event_channel_type = ANY_CALL_EVENT_CHANNEL_TYPE))
			| (call_channel.flags.async_call
			& (P_event_channel_type = ASYNC_CALL_EVENT_CHANNEL_TYPE
			| P_event_channel_type = ANY_CALL_EVENT_CHANNEL_TYPE))
		     then call read_channel ((0), got_message, addr (call_info));
		     else ;			/* This one is not for us. */
		end;

	     call_msgp = call_msgp -> event_message.next_ev_msgp;
	end;

	if got_message = 0				/* nothing found */
	then return;


/* An acceptable message was found -- Invoke the call channel's procedure */

	unspec (saved_channel_name) = unspec (call_channel.name);

	entry_value.ep_ptr = call_channel.procedure_ptr;
	entry_value.env_ptr = call_channel.environment_ptr;
	unspec (call_channel_procedure) = unspec (entry_value);

	call_info.data_ptr = call_channel.data_ptr;

	event_call_in_progress = YES;			/* inform full_block's cleanup handler */

	call_channel.call_inhibit = ON;		/* prevent recursive invocations of this channel's handler */


	/*** Call the user's program */
	if have_multiple_control_points () = YES	/* must always use cpm_ to insure our I/O switches are OK */
	then call cpm_$generate_call_preferred (current_control_point_id, call_channel_procedure, addr (call_info), (0))
		;
	else call call_channel_procedure (addr (call_info));

	call ipc_util_$verify_regular_channel (saved_channel_name, (null ()), rcode);
	if rcode = 0				/* channel wasn't deleted by the handler ... */
	then call_channel.call_inhibit = OFF;		/* ... so we can allow subsequent wakeups */

	event_call_in_progress = NO;			/* full_block's cleanup handler need not worry about it */

	P_found_call_event = YES;			/* keep checking channels */

	return;

     end check_call_channels;
%page;
check_wait_channels:
     procedure (P_found_event_wait);

dcl	P_found_event_wait	bit (1) aligned parameter;

dcl	temp_channel_name	fixed bin (71);
dcl	1 message_info	aligned like event_wait_info;
dcl	loop		fixed bin;

	P_found_event_wait = NO;
	inhibit_count = 0;

	do loop = 1 to event_wait_list_n_channels;

	     temp_channel_name = event_wait_list.channel_id (loop);

	     call ipc_util_$verify_channel (temp_channel_name, ectep, is_fast, P_code);
	     if P_code ^= 0
	     then return;

	     if is_fast = YES
	     then call read_fast_channel (temp_channel_name, temp_found_event, addr (message_info));
	     else do;
		     if wait_channel.type ^= WAIT
		     then do;
			     P_code = error_table_$not_a_wait_channel;
			     return;
			end;
		     call read_channel (inhibit_count, temp_found_event, addr (message_info));
		end;
	     if temp_found_event ^= 0
	     then do;
		     event_wait_info.channel_id = message_info.channel_id;
		     event_wait_info.message = message_info.message;
		     event_wait_info.sender = message_info.sender;
		     event_wait_info.dev_signal = message_info.dev_signal;
		     event_wait_info.ring = message_info.ring;
		     event_wait_info.channel_index = loop;
		     P_found_event_wait = YES;
		     return;
		end;
	end;

	if inhibit_count = event_wait_list_n_channels
	then do;
		P_code = error_table_$event_channel_cutoff;
		return;
	     end;

     end check_wait_channels;
%page;
read_channel:
     proc (P_inhibit_count, P_found_event, P_event_wait_info_ptr);

/**** Internal procedure to read one event message out of a channel. */

dcl	P_inhibit_count	fixed bin parameter;
dcl	P_found_event	fixed bin parameter;
dcl	P_event_wait_info_ptr
			ptr parameter;

dcl	msg_ptr		ptr;

	P_found_event = 0;				/* set default return values */

	if call_channel.type = CALL & call_channel.call_inhibit = YES
	then return;				/*  event call procedure being called */

	if wait_channel.inhibit_count ^= 0		/* channel inhibited, must not be read  */
	then do;
		P_inhibit_count = P_inhibit_count + 1;	/* increment count of inhibited channels */
		return;				/* ignore inhibited channel */
	     end;

/* having reached this point, we know that we have the right to try
   and read the event channel.				*/

	call mask_ips_interrupts (mask);

	msg_ptr = wait_channel.first_ev_msgp;
	if msg_ptr ^= null ()			/* there's a message waiting */
	then do;
		call unthread_event_message (msg_ptr);	/* remove it from the queue */
		if wait_channel.first_ev_msgp = null () /* don't notify other control points if no events are left */
		then wait_channel.wakeup_control_points = NO;

		P_event_wait_info_ptr -> event_wait_info = msg_ptr -> event_message.message_data, by name;
						/* return message to caller of ipc_$block */

		P_found_event = 1;			/* set indicator = successful  */

		call ipc_util_$delete_entry (ect_ptr, msg_ptr);
						/* delete the message entry  */
	     end;

	call unmask_ips_interrupts (mask);

     end read_channel;
%page;
read_fast_channel:
     proc (P_channel_name, P_found_event, P_event_wait_info_ptr);

dcl	P_channel_name	fixed bin (71) parameter;
dcl	P_found_event	fixed bin parameter;
dcl	P_event_wait_info_ptr
			ptr parameter;

dcl	channel_index	fixed bin;
dcl	unspec		builtin;

dcl	1 ev_chn_name	aligned like event_channel_name automatic;

	P_found_event = 0;
	unspec (ev_chn_name) = unspec (P_channel_name);
	if ev_chn_name.type = REGULAR_CHANNEL_TYPE
	then return;

	channel_index = ev_chn_name.unique_id;
	if substr (ipc_data_$fast_channel_events, channel_index, 1) = NO
	then return;

/**** Indicate we've read the event out. */

	substr (ipc_data_$fast_channel_events, channel_index, 1) = NO;

	wait_channel.wakeup_control_points = NO;	/* don't notify other control points about this channel now */
	substr (ect_header.last_fast_channel_events, channel_index, 1) = NO;
						/* ... but be sure later events will notify */

/**** And fill in return info */

	P_event_wait_info_ptr -> event_wait_info.channel_id = P_channel_name;
	P_event_wait_info_ptr -> event_wait_info.message = 0;
	P_event_wait_info_ptr -> event_wait_info.sender, P_event_wait_info_ptr -> event_wait_info.dev_signal = ""b;
	P_event_wait_info_ptr -> event_wait_info.ring = ev_chn_name.ring;

	P_found_event = 1;

	return;

     end read_fast_channel;
%page;
/* Insert the given message into the event call queue based on its priority */

insert_event_call_message:
     procedure (p_msg_ptr);

dcl	p_msg_ptr		pointer parameter;

dcl	1 next_event_message
			like event_message aligned based (next_msg_ptr);
dcl	next_msg_ptr	pointer;
dcl	1 p_event_message	like event_message aligned based (p_msg_ptr);
dcl	prev_msg_ptr	pointer;

	p_event_message.type = EV_CALL_MESSAGE;

	prev_msg_ptr = null ();			/* assume it goes at the beginning of the queue */

	do next_msg_ptr = ect_header.firstp (EV_CALL_MESSAGE) repeat (next_event_message.next_ev_msgp)
	     while (next_msg_ptr ^= null ());
	     if next_event_message.chanp -> call_channel.type ^= CALL
	     then call inconsistent_ect ();
	     if next_event_message.priority > p_event_message.priority
	     then go to INSERT_THE_MESSAGE;
	     else prev_msg_ptr = next_msg_ptr;
	end;

INSERT_THE_MESSAGE:
	call thread_event_message (p_msg_ptr, prev_msg_ptr);

	return;

     end insert_event_call_message;



/* Insert the given message onto the tail of the event wait queue */

insert_event_wait_message:
     procedure (p_msg_ptr);

dcl	p_msg_ptr		pointer parameter;

	p_msg_ptr -> event_message.type = EV_WAIT_MESSAGE;

	call thread_event_message (p_msg_ptr, ect_header.lastp (EV_WAIT_MESSAGE));

	return;

     end insert_event_wait_message;
%page;
/* Thread an event message into the list of active messages after the
   specified message */

thread_event_message:
     procedure (p_msg_ptr, p_prev_msg_ptr);

dcl	p_msg_ptr		pointer parameter;
dcl	p_prev_msg_ptr	pointer parameter;

dcl	message_type	fixed binary;
dcl	1 next_event_message
			like event_message aligned based (next_msg_ptr);
dcl	next_msg_ptr	pointer;
dcl	owning_chanp	pointer;
dcl	1 p_event_message	like event_message aligned based (p_msg_ptr);
dcl	1 prev_event_message
			like event_message aligned based (prev_msg_ptr);
dcl	prev_msg_ptr	pointer;

	message_type = p_event_message.type;
	owning_chanp = p_event_message.chanp;

	if ((message_type = EV_WAIT_MESSAGE) & (owning_chanp -> wait_channel.type ^= WAIT))
	     | ((message_type = EV_CALL_MESSAGE) & (owning_chanp -> call_channel.type ^= CALL))
	then call inconsistent_ect ();

/* First add the message to the end of the per-channel thread */

	if owning_chanp -> wait_channel.first_ev_msgp = null ()
	then do;					/* this is the first message for the channel */
		if owning_chanp -> wait_channel.last_ev_msgp ^= null ()
		then call inconsistent_ect ();
		owning_chanp -> wait_channel.first_ev_msgp = p_msg_ptr;
		p_event_message.prev_chan_msgp = null ();
	     end;
	else do;					/* the per-channel thread already has something on it */
		if owning_chanp -> wait_channel.last_ev_msgp = null ()
		then call inconsistent_ect ();
		if owning_chanp -> wait_channel.last_ev_msgp -> event_message.next_chan_msgp ^= null ()
		then call inconsistent_ect ();
		owning_chanp -> wait_channel.last_ev_msgp -> event_message.next_chan_msgp = p_msg_ptr;
		p_event_message.prev_chan_msgp = owning_chanp -> wait_channel.last_ev_msgp;
	     end;

	owning_chanp -> wait_channel.last_ev_msgp = p_msg_ptr;
	p_event_message.next_chan_msgp = null ();

/* Now add the message to the per-type thread */

	prev_msg_ptr = p_prev_msg_ptr;		/* this parameter could be ect_header.lastp (type) and, since
						   its passed by reference, the value would change as we set
						   ect_header.lastp (type) when adding to end of the queue */

	if prev_msg_ptr = null ()
	then do;					/* add it to the beginning */
		next_msg_ptr = ect_header.firstp (message_type);
		ect_header.firstp (message_type) = p_msg_ptr;
	     end;
	else do;					/* add it to the middle or the end */
		if prev_event_message.type ^= message_type
		then call inconsistent_ect ();
		next_msg_ptr = prev_event_message.next_ev_msgp;
		prev_event_message.next_ev_msgp = p_msg_ptr;
	     end;

	if next_msg_ptr = null ()
	then do;					/* add it to the end */
		if ect_header.lastp (message_type) ^= prev_msg_ptr
		then call inconsistent_ect ();
		ect_header.lastp (message_type) = p_msg_ptr;
	     end;
	else do;					/* add it to the beginning or the middle */
		if next_event_message.type ^= message_type
		then call inconsistent_ect ();
		next_event_message.prev_ev_msgp = p_msg_ptr;
	     end;

	p_event_message.prev_ev_msgp = prev_msg_ptr;
	p_event_message.next_ev_msgp = next_msg_ptr;

/* Update the appropriate counters */

	ect_header.count (message_type) = ect_header.count (message_type) + 1;
	if message_type = EV_CALL_MESSAGE		/* let ipc_fast_ know */
	then ipc_data_$event_calls_pending = ipc_data_$event_calls_pending + 1;

	return;

     end thread_event_message;
%page;
/* Unthread an event message from the list of active messages */

unthread_event_message:
     procedure (p_msg_ptr);

dcl	p_msg_ptr		pointer parameter;

dcl	message_type	fixed binary;
dcl	owning_chanp	pointer;
dcl	1 p_event_message	like event_message aligned based (p_msg_ptr);

	message_type = p_event_message.type;
	owning_chanp = p_event_message.chanp;

	if ((message_type = EV_WAIT_MESSAGE) & (owning_chanp -> wait_channel.type ^= WAIT))
	     | ((message_type = EV_CALL_MESSAGE) & (owning_chanp -> call_channel.type ^= CALL))
	then call inconsistent_ect ();

/* First remove this message from the per-channel thread */

	if p_event_message.prev_chan_msgp = null ()
	then do;					/* this is the first message for the channel */
		if owning_chanp -> wait_channel.first_ev_msgp ^= p_msg_ptr
		then call inconsistent_ect ();
		owning_chanp -> wait_channel.first_ev_msgp = p_event_message.next_chan_msgp;
	     end;
	else do;					/* this is in the middle of the channel's thread */
		if p_event_message.prev_chan_msgp -> event_message.next_chan_msgp ^= p_msg_ptr
		then call inconsistent_ect ();
		p_event_message.prev_chan_msgp -> event_message.next_chan_msgp = p_event_message.next_chan_msgp;
	     end;

	if p_event_message.next_chan_msgp = null ()
	then do;					/* this is the last message for the channel */
		if owning_chanp -> wait_channel.last_ev_msgp ^= p_msg_ptr
		then call inconsistent_ect ();
		owning_chanp -> wait_channel.last_ev_msgp = p_event_message.prev_chan_msgp;
	     end;
	else do;					/* this is in the middle of the channel's thread */
		if p_event_message.next_chan_msgp -> event_message.prev_chan_msgp ^= p_msg_ptr
		then call inconsistent_ect ();
		p_event_message.next_chan_msgp -> event_message.prev_chan_msgp = p_event_message.prev_chan_msgp;
	     end;

	p_event_message.prev_chan_msgp, p_event_message.next_chan_msgp = null ();

/* Now remove this message from the per-type thread */

	if p_event_message.prev_ev_msgp = null ()
	then do;					/* this is the first message for the type */
		if ect_header.firstp (message_type) ^= p_msg_ptr
		then call inconsistent_ect ();
		ect_header.firstp (message_type) = p_event_message.next_ev_msgp;
	     end;
	else do;					/* this is in the middle of the type's thread */
		if p_event_message.prev_ev_msgp -> event_message.next_ev_msgp ^= p_msg_ptr
		then call inconsistent_ect ();
		p_event_message.prev_ev_msgp -> event_message.next_ev_msgp = p_event_message.next_ev_msgp;
	     end;

	if p_event_message.next_ev_msgp = null ()
	then do;					/* this is the last message for the type */
		if ect_header.lastp (message_type) ^= p_msg_ptr
		then call inconsistent_ect ();
		ect_header.lastp (message_type) = p_event_message.prev_ev_msgp;
	     end;
	else do;					/* this is in the middle of the type's thread */
		if p_event_message.next_ev_msgp -> event_message.prev_ev_msgp ^= p_msg_ptr
		then call inconsistent_ect ();
		p_event_message.next_ev_msgp -> event_message.prev_ev_msgp = p_event_message.prev_ev_msgp;
	     end;

	p_event_message.prev_ev_msgp, p_event_message.next_ev_msgp = null ();

/* Update the appropriate counters */

	ect_header.count (message_type) = ect_header.count (message_type) - 1;
	if message_type = EV_CALL_MESSAGE		/* let ipc_fast_ know */
	then ipc_data_$event_calls_pending = ipc_data_$event_calls_pending - 1;

	return;

     end unthread_event_message;
%page;
/* Save the list of pending messages for the "current" channel -- The messages
   are unthreaded from the "active" messages */

save_channel_message_thread:
     procedure (p_saved_message_thread);

dcl	p_saved_message_thread
			pointer parameter;
dcl	(msg_ptr, prev_msg_ptr, next_msg_ptr)
			pointer;

	p_saved_message_thread, prev_msg_ptr = null ();

	do msg_ptr = wait_channel.first_ev_msgp repeat (next_msg_ptr) while (msg_ptr ^= null ());
	     next_msg_ptr = msg_ptr -> event_message.next_chan_msgp;
	     call unthread_event_message (msg_ptr);
	     if prev_msg_ptr = null ()
	     then p_saved_message_thread = msg_ptr;	/* this is the first message in the list */
	     else prev_msg_ptr -> event_message.next_chan_msgp = msg_ptr;
	     prev_msg_ptr = msg_ptr;
	end;

	return;

     end save_channel_message_thread;



/* Rethread the list of pending messages for the "current" channel */

rethread_channel_message_thread:
     procedure (p_saved_message_thread);

dcl	p_saved_message_thread
			pointer parameter;
dcl	next_msg_ptr	pointer;

	do msg_ptr = p_saved_message_thread repeat (next_msg_ptr) while (msg_ptr ^= null ());
	     next_msg_ptr = msg_ptr -> event_message.next_chan_msgp;
	     if msg_ptr -> event_message.chanp ^= ectep
	     then call inconsistent_ect ();
	     if wait_channel.type = WAIT
	     then call insert_event_wait_message (msg_ptr);
	     else do;
		     msg_ptr -> event_message.priority = call_channel.priority;
		     call insert_event_call_message (msg_ptr);
		end;
	end;

	return;

     end rethread_channel_message_thread;
%page;
thread_channel:
     proc (P_entry_type);

dcl	P_entry_type	fixed bin (8) parameter;

	last_ectep = ect_header.lastp (P_entry_type);

/* list is empty */

	if last_ectep = null
	then do;					/* thread in at beginning of list */
		ect_header.firstp (P_entry_type) = ectep;
		wait_channel.prev_chanp = null;
	     end;
	else do;					/* thread in at end of list */
		wait_channel.prev_chanp = last_ectep;
		last_ectep -> wait_channel.next_chanp = ectep;
	     end;

/* fill in forward thread and tail of list */

	wait_channel.next_chanp = null;
	ect_header.lastp (P_entry_type) = ectep;

	ect_header.count (P_entry_type) = ect_header.count (P_entry_type) + 1;

     end thread_channel;
%page;
unthread_channel:
     procedure ();

	entry_type = wait_channel.type;		/* save type of ect entry */

/* if first channel adjust head of list */

	if wait_channel.prev_chanp = null
	then ect_header.firstp (entry_type) = wait_channel.next_chanp;

/* otherwise thread out back pointer */
	else wait_channel.prev_chanp -> wait_channel.next_chanp = wait_channel.next_chanp;

/* if last channel in list adjust tail of list*/
	if wait_channel.next_chanp = null
	then ect_header.lastp (entry_type) = wait_channel.prev_chanp;

/* otherwise thread out forward pointer */
	else wait_channel.next_chanp -> wait_channel.prev_chanp = wait_channel.prev_chanp;

/* set threads to null in entry */
	wait_channel.next_chanp, wait_channel.prev_chanp = null;

	ect_header.count (entry_type) = ect_header.count (entry_type) - 1;

     end unthread_channel;
%page;
MAKE_EVENT_CALL:
     procedure (P_call_procedure);

/**** This internal procedure is called to turn the specified event
      channel into an event call channel.  The channel must be valid
      and not be a special (i.e. fast) channel.  Implicit parameters are 
      P_event_channel_name, P_datap, P_priority, and P_code. */

dcl	P_call_procedure	entry (ptr) variable;

	call ipc_util_$verify_regular_channel (P_event_channel_name, ectep, P_code);
	if P_code ^= 0				/* do not allow fast channels */
	then return;

	call mask_ips_interrupts (mask);

/* Save the list of any pending messages -- If the channel is already a call
   channel, we may still have to rethread it as its priority may be changed.
   In either case, leave the flag indicating whether it is an async call
   channel alone, since it was set when the channel was created, and should
   not be changed (since it is also encoded in the channel name). */

	call save_channel_message_thread (saved_message_thread);

/* Convert it into a call channel */

	if wait_channel.type = WAIT
	then do;
		call reset_channel_wcps ();		/* any waiting control points should now get an error */
		call unthread_channel;
		call_channel.type = CALL;
		call thread_channel (CALL);
	     end;

	call_channel.data_ptr = P_datap;
	call_channel.procedure_ptr = codeptr (P_call_procedure);
	call_channel.environment_ptr = environmentptr (P_call_procedure);
	call_channel.priority = P_priority;
	call_channel.control_point_id = get_control_point_id_ ();
	call_channel.call_inhibit = OFF;

/* Rethread any pending messages for this channel */

	call rethread_channel_message_thread (saved_message_thread);

	call unmask_ips_interrupts (mask);

     end MAKE_EVENT_CALL;
%page;
set_inhibit_switch:
     procedure (P_inhibit_value);

dcl	P_inhibit_value	fixed bin (17) parameter;

	call ipc_util_$verify_regular_channel (P_event_channel_name, ectep, P_code);
	if P_code ^= 0
	then return;

	wait_channel.inhibit_count = wait_channel.inhibit_count + P_inhibit_value;

	if wait_channel.inhibit_count < 0
	then do;
		wait_channel.inhibit_count = 0;
		P_code = error_table_$event_channel_not_cutoff;
	     end;

     end set_inhibit_switch;
%page;
set_priority_switch:
     procedure (P_priority_switch);

dcl	P_priority_switch	bit (1) aligned parameter;

	P_code = 0;
	ect_header.flags.call_priority = P_priority_switch;

     end set_priority_switch;
%page;
set_mask:
     procedure (P_mask_value);

dcl	P_mask_value	fixed bin;

	P_code = 0;
	ect_header.mask_call_count = ect_header.mask_call_count + P_mask_value;

	if ect_header.mask_call_count < 0		/* logical error, unpaired mask/unmask */
	then do;
		ect_header.mask_call_count = 0;	/* reset mask to 0 */
		P_code = error_table_$event_calls_not_masked;
						/* code = logical error in use of IPC */
	     end;

     end set_mask;
%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;



/* 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) = ON
	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. */

unmask_ips_interrupts_caller:
     entry (P_mask);

	call unmask_ips_interrupts (P_mask);
	return;
%page;
/* Report that the ECT is inconsistent -- This procedure will never return as
   ipc_util_$ect_error_handler generates a fatal process error */

inconsistent_ect:
     procedure ();

	call unmask_ips_interrupts (mask);
	call ipc_util_$ect_error_handler (error_table_$inconsistent_ect);

     end inconsistent_ect;



/* 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;
hardcore_block:
     procedure ();

/**** This procedure merely calls hardcore to block the process (or not,
      if there are new event wakeups).  It makes sure that the validation
      level is set to the current ring before doing so. */

	if cur_ring ^= block_val
	then call cu_$level_set (cur_ring);

	call hcs_$fblock (ipc_data_$fast_channel_events, ("0"b));

	if cur_ring ^= block_val
	then call cu_$level_set (block_val);

	return;

     end hardcore_block;
%page;
/* Determines if more than one control point is defined in this process */

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

	if stackbaseptr () -> stack_header.cpm_enabled
	then return (cpm_data_$n_control_points > 1);
	else return (NO);

     end have_multiple_control_points;
%page;
/* Adds the current control point to the list of control points waiting for
   an event to be signalled on each of the channels in a call to ipc_$block */

add_to_waiting_lists:
     procedure ();

dcl	loop		fixed binary;

	do loop = 1 to event_wait_list_n_channels;	/* insure that all the channels are OK first */
	     call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), P_code);
	     if P_code ^= 0
	     then return;
	     if wait_channel.type ^= WAIT
	     then do;
		     P_code = error_table_$not_a_wait_channel;
		     return;
		end;
	end;

	call mask_ips_interrupts (mask);

	do loop = 1 to event_wait_list_n_channels;

	     call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), (0));

	     do wcpp = wait_channel.first_wcpp repeat (waiting_control_point.next_wcpp) while (wcpp ^= null ());
		if waiting_control_point.control_point_id = current_control_point_id
		then do;				/* this control point is already blocked on this channel */
			waiting_control_point.block_count = waiting_control_point.block_count + 1;
			go to PROCESS_NEXT_CHANNEL;
		     end;
	     end;

	     /*** Current control point not already blocked on this channel
		-- Setup another waiting_control_point for the channel */

	     call ipc_util_$make_entry (ect_ptr, WAITING_CP, wcpp, (0));
	     waiting_control_point.control_point_id = current_control_point_id;
	     waiting_control_point.block_count = 1;

	     if wait_channel.first_wcpp = null ()
	     then do;				/* first control point for this channel */
		     if wait_channel.last_wcpp ^= null ()
		     then call inconsistent_ect ();
		     wait_channel.first_wcpp = wcpp;
		     waiting_control_point.prev_wcpp = null ();
		end;
	     else do;				/* add to the end of the list for this channel */
		     if wait_channel.last_wcpp = null ()
		     then call inconsistent_ect ();
		     if wait_channel.last_wcpp -> waiting_control_point.next_wcpp ^= null ()
		     then call inconsistent_ect ();
		     wait_channel.last_wcpp -> waiting_control_point.next_wcpp = wcpp;
		     waiting_control_point.prev_wcpp = wait_channel.last_wcpp;
		end;

	     wait_channel.last_wcpp = wcpp;		/* this control point is now the tail of the list */
	     waiting_control_point.next_wcpp = null ();

PROCESS_NEXT_CHANNEL:
	end;

	added_to_waiting_lists = YES;

	call unmask_ips_interrupts (mask);

     end add_to_waiting_lists;
%page;
/* Make the current control point BLOCKED -- If, however, there are either wait
   or call events pending which are destined for this control point, we must
   not enter the BLOCKED state.  If we did block, we would remain blocked
   until another event arrived which could possibly never happen. */

block_if_no_pending_events:
     procedure ();

dcl	loop		fixed binary;


/* First check the channels on which we are blocked */

	do loop = 1 to event_wait_list_n_channels;

	     call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), P_code);
	     if P_code ^= 0
	     then return;
	     if wait_channel.type ^= WAIT
	     then do;
		     P_code = error_table_$not_a_wait_channel;
		     return;
		end;

	     if wait_channel.fast_channel = YES
	     then if substr (ipc_data_$fast_channel_events, wait_channel.fast_channel_id, 1) = YES
		then return;
		else ;

	     else /*** if wait_channel.fast_channel = NO then */
		if wait_channel.first_ev_msgp ^= null ()
	     then return;
	     else ;
	end;


/* No events for any of the above channels -- Check all call channels */

	do ectep = ect_header.firstp (CALL) repeat (call_channel.next_chanp) while (ectep ^= null ());

	     if call_channel.type ^= CALL
	     then call inconsistent_ect ();

	     if call_channel.control_point_id = current_control_point_id
	     then if call_channel.first_ev_msgp ^= null ()
		then return;
	end;


/* Control arrives here iff there are no events already present for
   this control point -- Block. */

	call cpm_$block ();

	return;

     end block_if_no_pending_events;
%page;
/* Removes the current control point from the above lists --
   A non-quick version of this procedure follows on the next page*/

delete_from_waiting_lists:
     procedure ();

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

	call mask_ips_interrupts (mask);

	do loop = 1 to event_wait_list_n_channels;

	     call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), code);
	     if code ^= 0				/* the channel is no longer OK: skip it */
	     then go to PROCESS_NEXT_CHANNEL;
	     if wait_channel.type ^= WAIT		/* the channel is no longer a wait channel: skip it */
	     then go to PROCESS_NEXT_CHANNEL;

	     do wcpp = wait_channel.first_wcpp repeat (waiting_control_point.next_wcpp) while (wcpp ^= null ());

		if waiting_control_point.control_point_id = current_control_point_id
		then do;				/* found the proper entry */

			if waiting_control_point.block_count = 1
			then do;			/* this is the only time we were waiting on this channel */
				if waiting_control_point.prev_wcpp = null ()
				then do;		/* this was the first control point for this channel */
					if wait_channel.first_wcpp ^= wcpp
					then call inconsistent_ect ();
					wait_channel.first_wcpp = waiting_control_point.next_wcpp;
				     end;
				else do;		/* remove this control point from the middle of the list */
					if waiting_control_point.prev_wcpp -> waiting_control_point.next_wcpp
					     ^= wcpp
					then call inconsistent_ect ();
					waiting_control_point.prev_wcpp -> waiting_control_point.next_wcpp =
					     waiting_control_point.next_wcpp;
				     end;
				if waiting_control_point.next_wcpp = null ()
				then do;		/* this is the last control point for this channel */
					if wait_channel.last_wcpp ^= wcpp
					then call inconsistent_ect ();
					wait_channel.last_wcpp = waiting_control_point.prev_wcpp;
				     end;
				else do;		/* remove this control point from the middle of the list */
					if waiting_control_point.next_wcpp -> waiting_control_point.prev_wcpp
					     ^= wcpp
					then call inconsistent_ect ();
					waiting_control_point.next_wcpp -> waiting_control_point.prev_wcpp =
					     waiting_control_point.prev_wcpp;
				     end;
				call ipc_util_$delete_entry (ect_ptr, wcpp);
			     end;

			else waiting_control_point.block_count = waiting_control_point.block_count - 1;
						/* this control point is still waiting on this channel */

			go to PROCESS_NEXT_CHANNEL;
		     end;
	     end;

	     call inconsistent_ect ();		/* we aren't on the channel's list but we should be */

PROCESS_NEXT_CHANNEL:
	end;

	added_to_waiting_lists = NO;

	call unmask_ips_interrupts (mask);

     end delete_from_waiting_lists;



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

delete_from_waiting_lists_caller:
     entry (P_event_wait_list_ptr);

	call find_ectp ();

	event_wait_list_ptr = P_event_wait_list_ptr;
	event_wait_list_n_channels = event_wait_list.n_channels;

	current_control_point_id = get_control_point_id_ ();

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

	call delete_from_waiting_lists ();

	return;
%page;
/* Wakeup blocked control points -- If a control point is blocked on an event
   wait channel, it must be notified when a message arrives on that channel.
   Further, if a message arrives for an event call channel, the control point
   which "owns" that channel must be notified. */

wakeup_blocked_control_points:
     procedure ();

dcl	1 a_wait_channel	like wait_channel aligned based (an_ectep);
dcl	1 a_call_channel	like call_channel aligned based (an_ectep);
dcl	an_ectep		pointer;

	do an_ectep = ect_header.firstp (WAIT) repeat (a_wait_channel.next_chanp) while (an_ectep ^= null ()),
	     ect_header.firstp (CALL) repeat (a_call_channel.next_chanp) while (an_ectep ^= null ());
	     if a_wait_channel.wakeup_control_points = YES
	     then call wakeup_channel_control_points (an_ectep);
	end;

	ect_header.wakeup_control_points = NO;

	return;

     end wakeup_blocked_control_points;



/* Wakeup the control points waiting on a single channel */

wakeup_channel_control_points:
     procedure (p_ectep);

dcl	p_ectep		pointer parameter;

dcl	1 p_call_channel	like call_channel aligned based (p_ectep);
dcl	1 p_wait_channel	like wait_channel aligned based (p_ectep);

	if p_wait_channel.type = WAIT
	then do;					/* a wait channel */
		do wcpp = p_wait_channel.first_wcpp repeat (waiting_control_point.next_wcpp) while (wcpp ^= null ());
		     call cpm_$wakeup (waiting_control_point.control_point_id, (0));
		end;
		p_wait_channel.wakeup_control_points = NO;
	     end;

	else do;					/* a call channel */
		call cpm_$wakeup (p_call_channel.control_point_id, (0));
		p_call_channel.wakeup_control_points = NO;
	     end;

	return;

     end wakeup_channel_control_points;
%page;
/* Resets a channel's waiting control points -- Any control points blocked on
   the channel are sent wakeups so that they may run and find that the channel
   has either been deleted or converted to an event call channel.  The list of
   waiting control points is then deleted from the ECT. */

reset_channel_wcps:
     procedure ();

dcl	next_wcpp		pointer;

	if (have_multiple_control_points () = YES) & (wait_channel.wakeup_control_points = YES)
	then call wakeup_channel_control_points (ectep);

	if wait_channel.first_wcpp ^= null ()
	then do;
		do wcpp = wait_channel.first_wcpp repeat (next_wcpp) while (wcpp ^= null ());
		     next_wcpp = waiting_control_point.next_wcpp;
		     call ipc_util_$delete_entry (ect_ptr, wcpp);
		end;
		wait_channel.first_wcpp, wait_channel.last_wcpp = null ();
	     end;

	return;

     end reset_channel_wcps;

/* format: off */
%page; %include ect_structures;
%page; %include event_call_info;
%page; %include event_channel_name;
%page; %include event_wait_info;
%page; %include event_wait_list;
%page; %include ipc_create_arg;
%page; %include stack_header;
%page; %include cpm_entries;
%page; %include cpm_data_;
/* format: on */

     end ipc_real_;




		    ipc_util_.pl1                   11/11/89  1144.0rew 11/11/89  0803.3      171819



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

/* format: style3 */

/* IPC_UTIL_:  This is a collection of primitives used by the Interprocess
   Communication Facility (IPC).  These are internal interfaces and not
   intended to be called by any modules outside of IPC.  The entries
   within ipc_util_ include those to create, retrieve, and delete event
   channels as well as those to validate, encode, and decode the 
   event channel names. */

/*
   Rewritten from ipcprm_ for new ipc by E Donner Jan l981
   Modified 1984-10-28 by E. Swenson for new IPC validation.
*/


/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
     Changed to support control point management.  These changes were actually
     made in February 1985 by G. Palter.
  2) change(86-08-12,Kissel), approve(86-08-12,MCR7479),
     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
     Changed entry_type to fixed bin (8) and changed the code to verify the
     encoded flags in an event channel name.  All this to support async event
     channels.
                                                   END HISTORY COMMENTS */


ipc_util_:
     procedure ();
	return;					/* not an entry */

/* Automatic */

dcl	code		fixed bin (35);
dcl	ecit_idx		fixed bin (15) unsigned;	/* Index into ECIT */
dcl	ect_area_ptr	ptr;
dcl	ect_area_size	fixed bin (19);
dcl	entry_type	fixed bin (8);
dcl	1 info_for_area	like area_info aligned;
dcl	system_area_ptr	ptr;

/* Based */

dcl	ect_area		area (ect_area_size) based (ect_area_ptr);
dcl	system_area	area based (system_area_ptr);

/* Constants */

dcl	AREA_OVERHEAD	fixed bin (17) initial (36) internal static options (constant);
						/* area header + extend block */
dcl	BLOCK_OVERHEAD	fixed bin (17) initial (2) internal static options (constant);
						/* for each allocation */
dcl	DEFAULT_N_ECT_ENTRIES
			fixed bin (17) initial (64) internal static options (constant);
						/* default number used in calculating initial area size */
dcl	INITIAL_SEED	fixed bin (33) initial (1) internal static options (constant);
dcl	ON		bit (1) aligned static options (constant) init ("1"b);
dcl	NO		bit (1) aligned static options (constant) init ("0"b);
dcl	ALLOW_FAST_CHANNELS bit (1) aligned initial ("1"b) internal static options (constant);
dcl	DO_NOT_ALLOW_FAST_CHANNELS
			bit (1) aligned initial ("0"b) internal static options (constant);

/* External Entries */

dcl	define_area_	entry (ptr, fixed bin (35));
dcl	get_ring_		entry returns (fixed bin (3));
dcl	get_system_free_area_
			entry returns (ptr);
dcl	hcs_$get_ipc_operands
			entry (fixed bin (18), fixed bin (35));
dcl	ipc_real_$create_fast_ev_chn
			entry (fixed binary (18), fixed binary (35));
dcl	ipc_validate_$decode_event_channel_name
			entry (fixed bin (18), fixed bin (35), fixed bin (71), bit (3) aligned, fixed bin (15),
			fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (35));

/* External Static */

dcl	error_table_$ect_already_initialized
			fixed bin (35) external;
dcl	error_table_$ect_full
			fixed bin (35) external;
dcl	error_table_$inconsistent_ect
			fixed bin (35) external;
dcl	error_table_$invalid_channel
			fixed bin (35) external;
dcl	error_table_$special_channel
			fixed bin (35) external;
dcl	error_table_$wrong_channel_ring
			fixed bin (35) external;
dcl	ipc_data_$fast_channel_events
			bit (36) aligned external;
dcl	sys_info$max_seg_size
			fixed bin (19) external;

/* Conditions */

dcl	area		condition;

/* Builtins */

dcl	addr		builtin;
dcl	binary		builtin;
dcl	empty		builtin;
dcl	length		builtin;
dcl	mod		builtin;
dcl	null		builtin;
dcl	size		builtin;
dcl	stackbaseptr	builtin;
dcl	string		builtin;
dcl	substr		builtin;
dcl	unspec		builtin;
%page;
create_ect:
     entry (a_ect_ptr);

/**** Entry to create the Event Channel Table for the current ring.  It
      initializes the ECT header and creates the Event Channel Index
      Table. */

dcl	a_ect_ptr		ptr parameter;

	on area call ect_error_handler (error_table_$ect_full);
	call CREATE_ECT ();
	a_ect_ptr = ect_ptr;
	return;
%page;
create_single_seg_ect:
     entry (a_code);

/**** This entry creates an Event Channel Table for the current ring that
      is not located in the system area, but is located in a segment
      dedicated to the ECT. */

dcl	a_code		fixed bin (35) parameter;

	if stackbaseptr () -> stack_header.ect_ptr ^= null
	then do;					/* ect has been created before */
		a_code = error_table_$ect_already_initialized;
		return;
	     end;

	a_code = 0;
	ect_area_size = sys_info$max_seg_size;
	ect_area_ptr = null;			/* This causes define_area_ to create new seg */

	on area call ect_error_handler (error_table_$ect_full);

	call initialize_ect;

	return;
%page;
make_entry:
     entry (a_ect_ptr, a_type, a_ectep, a_ecit_idx);

/**** This entry creates a fresh ECTE.  The type created (WAIT or CALL)
      is specified in the parameter a_type.  It returns a pointer to this
      ECTE in a_ectep.  Currently this entry is only used to create WAIT
      and CALL ECTEs.  If it is ever used to create other types (e.g.
      EV_WAIT_MESSAGE, etc.), then care must be taken to avoid setting up an
      ECITE for the ECTE.  delete_entry must be made aware of these changes
      as well.  This entry returns the ECIT index for use in event
      channel name manipulation.  The modularization here should be
      changed to maintain the ECIT index as an internal value to ipc_util_,
      but this can be done at a later time. */

dcl	a_ectep		ptr parameter;
dcl	a_type		fixed bin (8) parameter;
dcl	a_ecit_idx	fixed bin (15);

	call SETUP ();

	entry_type = a_type;

/* check for inconsistency before creating new entry */

	call check_ect_consistency;

/* allocate new entry - assume that entries of all types are the same size */

	ect_area_size = ect_header.ect_area_size;
	on area call ect_error_handler (error_table_$ect_full);
	allocate wait_channel in (ect_header.ect_areap -> ect_area) set (ectep);
	unspec (wait_channel) = ""b;
	wait_channel.type = entry_type;

/* make an entry in the event_channel_index table */

	ecit_idx = 0;
	if entry_type = CALL | entry_type = WAIT
	then do;
		ecit_idx = FIND_ECIT_ENTRY ();
		if ecit_idx = 0
		then /* Should never happen */
		     call ect_error_handler (error_table_$ect_full);

		ecit.ecte_ptr (ecit_idx) = ectep;
	     end;

/* update count in ect header */
	ect_header.count (TOTAL) = ect_header.count (TOTAL) + 1;
	if entry_type = WAITING_CP
	then ect_header.count (WAITING_CP) = ect_header.count (WAITING_CP) + 1;

	a_ectep = ectep;
	a_ecit_idx = ecit_idx;
	return;
%page;
delete_entry:
     entry (a_ect_ptr, a_ectep);

/**** This entry will delete an ECTE entry.  It is used to delete entries
      like WAIT and CALL entries as well as EV_WAIT_MESSAGE and other entry
      types.  Care must be taken to "do the right thing" with respect
      to the ECITEs. */

	call SETUP ();
	ectep = a_ectep;
	entry_type = wait_channel.type;

/**** Remove the event channel index table entry from use.  Note that
      delete_entry is called to delete entries which are other than
      CALL or WAIT (e.g., EV_CALL_MESSAGE or WAITING_CP).
      Therefore, since we only set up ECIT entries for WAITs or CALLs,
      we mustn't try to search for the ECITE for other types. */

	if entry_type = WAIT | entry_type = CALL
	then do;
		ecit_idx = GET_ECIT_IDX (ectep);
		if ecit_idx = 0
		then /* Should never happen */
		     call ect_error_handler (error_table_$inconsistent_ect);
		else ecit.ecte_ptr (ecit_idx) = null ();
	     end;

/* update count in header */
	if entry_type = WAITING_CP
	then ect_header.count (WAITING_CP) = ect_header.count (WAITING_CP) - 1;
	ect_header.count (TOTAL) = ect_header.count (TOTAL) - 1;

/* free entry */
	free wait_channel;

	call check_ect_consistency;

	a_ectep = null;
	return;
%page;
verify_channel:
     entry (P_event_channel_name, P_ectep, P_fast_channel, P_code);

/**** This entrypoint verifies a given event channel name.  P_code
      can be error_table_$invalid_channel_ring, error_table_$invalid_channel,
      or 0.  P_fast_channel is set to "1"b if the channel is a fast channel, 
      otherwise it is set to "0"b. */

dcl	P_event_channel_name
			fixed binary (71) parameter;
dcl	P_ectep		pointer parameter;
dcl	P_fast_channel	bit (1) aligned parameter;
dcl	P_code		fixed binary (35) parameter;

	on area call ect_error_handler (error_table_$ect_full);
	call FIND_ECTP ();
	call VERIFY_CHANNEL (ALLOW_FAST_CHANNELS);
	return;
%page;
verify_regular_channel:
     entry (P_event_channel_name, P_ectep, P_code);

/**** This entrypoint verifies a given event channel name.  If the 
      event channel name is invalid, P_code is set to 
      error_table_$invalid_channel.  If the event channel name specifies
      a fast channel, P_code is set to error_table_$special_channel. 
      Otherwise P_ectep will point to a valid ECTE describing the
      channel. */

	on area call ect_error_handler (error_table_$ect_full);
	call FIND_ECTP ();
	call VERIFY_CHANNEL (DO_NOT_ALLOW_FAST_CHANNELS);
	return;
%page;
ect_error_handler:
     entry (a_status_code);

/**** This entry is called when some fatal situation is detected in
      the ECT structures.  It destroys the process with an appropriate
      error message. */

dcl	a_status_code	fixed bin (35) parameter;

dcl	1 term_structure	aligned,
	  2 version	fixed bin,
	  2 fatal_code	fixed bin (35);

dcl	terminate_process_	entry (char (*), ptr);

	term_structure.version = 0;
	term_structure.fatal_code = a_status_code;

	call terminate_process_ ("fatal_error", addr (term_structure));

	return;
%page;
check_ect_consistency:
     procedure ();

/**** This internal procedure attempts to check the consistency of the
      counts in the ECT header. */

	if ect_header.count (TOTAL)
	     ^= ect_header.count (WAIT) + ect_header.count (CALL) + ect_header.count (ITT_MESSAGE)
	     + ect_header.count (EV_CALL_MESSAGE) + ect_header.count (EV_WAIT_MESSAGE) + ect_header.count (WAITING_CP)
	then call ect_error_handler (error_table_$inconsistent_ect);

     end check_ect_consistency;
%page;
initialize_ect:
     procedure ();

/**** This internal procedure is called if no ECT exists for the current
      ring.  It initializes the ECT. */

dcl	ev_chn_unique_id	fixed binary (18);
dcl	code		fixed binary (35);

/* now define characteristics of ect area  */
	info_for_area.version = area_info_version_1;
	info_for_area.owner = "ipc";
	info_for_area.size = ect_area_size;
	info_for_area.areap = ect_area_ptr;
	string (info_for_area.control) = "0"b;
	info_for_area.control.extend = ON;
	info_for_area.control.zero_on_free = ON;
	info_for_area.control.system = ON;
	call define_area_ (addr (info_for_area), code);
	if code ^= 0
	then call ect_error_handler (code);

	ect_area_ptr = info_for_area.areap;		/* may have been set by define_area_ */

/* allocate header in new ect area */
/* and set initial values */
	allocate ect_header in (ect_area) set (ect_ptr);
	unspec (ect_header) = ""b;
	ect_header.firstp (*), ect_header.lastp (*) = null;
	ect_header.ect_area_size = ect_area_size;
	ect_header.ect_areap = ect_area_ptr;
	ect_header.seed = INITIAL_SEED;

/* Allocate the Event Channel Index Table */

	call ALLOCATE_ECIT (DEFAULT_N_ECT_ENTRIES);
	ect_header.ecit_ptr = ecit_ptr;
	ect_header.ecit_lth = ecit_lth;

/**** Retrieve the IPC validation operands from the APTE.  These values
      were initialized at process creation time and are used to validate
      event channel wakeups destined for this process.  They are also 
      used to decode the event channel name and to extract the ECIT
      index from the event channel name. */

	call hcs_$get_ipc_operands (ect_header.r_offset, ect_header.r_factor);

/* set ect_ptr in stack header */

	stackbaseptr () -> stack_header.ect_ptr = ect_ptr;


/* Create WAIT channel definitions for all possible fast channels.  These
   entries are only used when control point management is enabled to track the
   control points which have blocked on the fast channels. */

		do ev_chn_unique_id = 1 to length (ipc_data_$fast_channel_events);
		     call ipc_real_$create_fast_ev_chn (ev_chn_unique_id, code);
		     if code ^= 0
		     then call ect_error_handler (code);
		end;

	return;

     end initialize_ect;
%page;
ALLOCATE_ECIT:
     procedure (size);

/**** This procedure allocates and initializes an Event Channel Index
      Table (ECIT) in the current ECT area. */

dcl	size		fixed bin (17) parameter;

	ecit_ptr = null ();				/* Nullify this global variable */
	ecit_lth = size;

/**** Already have a handler for the "area" condition */

	allocate ecit in (ect_header.ect_areap -> ect_area) set (ecit_ptr);
	ecit.ecte_ptr (*) = null ();
	return;
     end ALLOCATE_ECIT;
%page;

FIND_ECIT_ENTRY:
     procedure () returns (fixed bin (15) unsigned);

/**** This procedure searches through the current event channel index table
      for a free entry.  If one is found, the index of this entry is returned.
      If none is available, then a new ECIT is allocated, the old ECIT entries
      copied into the new table and the old table freed.*/

dcl	ecit_idx		fixed bin (15) unsigned;

dcl	old_ecit_ptr	ptr;
dcl	old_ecit_lth	fixed bin (17);

dcl	1 old_ecit	aligned based (old_ecit_ptr),
	  2 ecte_ptr	(old_ecit_lth) ptr unaligned;

	do ecit_idx = 1 to ecit_lth;
	     if ecit.ecte_ptr (ecit_idx) = null ()
	     then return (ecit_idx);			/* found a free slot */
	end;

/**** There are no free entries in the current ECIT table.  For the time
      being, until we come up with a better algorithm, allocate a new
      table twice the size of the current table. */

	old_ecit_ptr = ecit_ptr;
	old_ecit_lth = ecit_lth;

	call ALLOCATE_ECIT (ecit_lth * 2);
	ect_header.ecit_ptr = ecit_ptr;
	ect_header.ecit_lth = ecit_lth;

/**** Copy old table into the new table */

	do ecit_idx = 1 to old_ecit_lth;
	     ecit.ecte_ptr (ecit_idx) = old_ecit.ecte_ptr (ecit_idx);
	end;

	free old_ecit;				/* Free up the old table */

	return (old_ecit_lth + 1);			/* one past end of old data */

     end FIND_ECIT_ENTRY;
%page;
GET_ECIT_IDX:
     procedure (P_ectep) returns (fixed bin (15) unsigned);

/**** This internal procedure returns the ECIT index given a pointer to
      the event channel entry. */

dcl	P_ectep		ptr parameter;
dcl	1 ev_chn_name	aligned like event_channel_name automatic;
dcl	ecit_idx		fixed bin (15) unsigned;
dcl	temp		fixed bin (71);
dcl	encoded_index_binary
			fixed bin (18) unsigned;
dcl	1 encoded_index	structure aligned automatic,
	  2 flags		bit (3) unaligned,
	  2 index		fixed bin (15) unsigned unaligned;

	unspec (ev_chn_name) = unspec (P_ectep -> wait_channel.name);
	temp = binary (ev_chn_name.encoded_index, 18);
	encoded_index_binary = mod (temp - ect_header.r_offset, 262144);
	unspec (encoded_index) = substr (unspec (encoded_index_binary), 19, 18);
	ecit_idx = encoded_index.index;
	if ecit_idx > ect_header.ecit_lth
	then ecit_idx = 0;
	return (ecit_idx);
     end GET_ECIT_IDX;
%page;
VERIFY_CHANNEL:
     procedure (allow_fast_channels);

/**** This internal procedure uses the implicit arguments from the
      verify_channel and verify_regular_channel entrypoints. */

dcl	allow_fast_channels bit (1) aligned parameter;

dcl	code		fixed bin (35);
dcl	ecit_idx		fixed bin (15) unsigned;
dcl	ev_chn_flags	bit (3) aligned;
dcl	ev_chn_index	fixed bin (15);
dcl	ev_chn_ring	fixed bin (3);
dcl	ev_chn_type	bit (1) aligned;
dcl	ev_chn_unique_id	fixed bin (18);
dcl	event_channel_name	fixed bin (71);

	P_ectep = null ();
	P_code = 0;

	event_channel_name = P_event_channel_name;
	call ipc_validate_$decode_event_channel_name (ect_header.r_offset, ect_header.r_factor, event_channel_name,
	     ev_chn_flags, ev_chn_index, ev_chn_ring, ev_chn_type, ev_chn_unique_id, code);
	if code ^= 0
	then do;
		P_code = code;
		return;
	     end;

	if ev_chn_flags ^= NORMAL_CHANNEL_FLAGS & ev_chn_flags ^= SEND_IPS_WKP_CHANNEL_FLAGS
	then
INVALID_CHANNEL:
	     do;
		P_code = error_table_$invalid_channel;
		return;
	     end;

	if ev_chn_ring ^= get_ring_ ()
	then do;
		P_code = error_table_$wrong_channel_ring;
		return;
	     end;

	if ev_chn_type = FAST_CHANNEL_TYPE		/* claims to be a fast channel */
	then if ev_chn_unique_id > length (ipc_data_$fast_channel_events)
	     then goto INVALID_CHANNEL;

	ecit_idx = ev_chn_index;

	if ecit_idx > ecit_lth
	then goto INVALID_CHANNEL;

	ectep = ecit.ecte_ptr (ecit_idx);
	if ectep = null ()
	then goto INVALID_CHANNEL;

	if ectep -> wait_channel.name ^= unspec (event_channel_name)
	then goto INVALID_CHANNEL;

/**** Things look ok, give caller what he/she wanted. */

	if allow_fast_channels
	then P_fast_channel = (ev_chn_type = FAST_CHANNEL_TYPE);
	else if ev_chn_type = FAST_CHANNEL_TYPE
	then do;					/* a fast channel and the caller doesn't want one */
		P_code = error_table_$special_channel;
		return;
	     end;

	P_ectep = ectep;

	return;

     end VERIFY_CHANNEL;
%page;
FIND_ECTP:
     procedure ();

/**** Internal procedure to get a pointer to the ECT for this ring.
      If there is none, one will be created. */

	ect_ptr = stackbaseptr () -> stack_header.ect_ptr;
	if ect_ptr = null ()
	then call CREATE_ECT ();
	ecit_ptr = ect_header.ecit_ptr;
	ecit_lth = ect_header.ecit_lth;
	return;

     end FIND_ECTP;
%page;
SETUP:
     procedure ();

/**** This internal procedure copies the parameter a_ect_ptr into
      ect_ptr and gets the ECIT variables necessary to reference
      the ECIT. */

	ect_ptr = a_ect_ptr;
	ecit_ptr = ect_header.ecit_ptr;
	ecit_lth = ect_header.ecit_lth;
	return;
     end SETUP;
%page;
CREATE_ECT:
     procedure ();

/* The ect is an extensible area which is allocated in system free area */
/* it is an area so that header and ect entries will be clustered */

	system_area_ptr = get_system_free_area_ ();

/* calculate room for reasonable number of ectes, ect header and extend block */
	ect_area_size =
	     AREA_OVERHEAD + size (ect_header) + DEFAULT_N_ECT_ENTRIES * size (wait_channel)
	     + (DEFAULT_N_ECT_ENTRIES + 2) * BLOCK_OVERHEAD + DEFAULT_N_ECT_ENTRIES + BLOCK_OVERHEAD;
						/* one word for each entry in ecit */

	allocate ect_area in (system_area) set (ect_area_ptr);

	call initialize_ect;
	return;
     end CREATE_ECT;

/* format: off */
%page; %include area_info;
%page; %include ect_structures;
%page; %include event_channel_name;
%page; %include stack_header;
/* format: on */
     end ipc_util_;




		    set_lock_.pl1                   11/11/89  1144.0rew 11/11/89  0803.3       81432



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

/* format: off */

/* set_lock_ -- This procedure allows a user to guarantee that two processes
   will not simultaneously execute the same critical section of code.  A user
   provided lock word can be set to the lock identifier of only one process at
   a time thereby guaranteeing, assuming the proper conventions are followed,
   that only this process can be currently executing in the critical section of
   code.

   Originally coded by R. J. Feiertag on November 5, 1971
   Modified on April 6, 1972 by R. J. Feiertag to work in all rings.
   Fixed by THVV 10/75 to work even if alrm is masked
   Modified by M. Pierret 03/80 , adding no_write_permission condition
    handler, stacq and clock builtins, and avoiding clock on waittime=0
    and on 04/24/80 not_in_write_bracket condition. */

/****^  HISTORY COMMENTS:
  1) change(71-11-05,Feiertag), approve(), audit(), install():
     Written by R. J. Feiertag.
  2) change(72-04-06,Feiertag), approve(), audit(), install():
     Modified by R. J. Feiertag to work in all rings.
  3) change(75-10-01,VanVleck), approve(), audit(), install():
     Modified by THVV 10/75 to work even if alrm is masked
  4) change(80-04-24,Pierret), approve(), audit(), install():
     Modified by M. Pierret 03/80, adding no_write_permission condition
      handler, stacq and clock builtins, and avoiding clock on waittime=0
      and on 04/24/80, not_in_write_bracket condition handler
  5) change(85-01-09,Lippard), approve(85-01-30,MCR7159),
     audit(85-11-07,Spitzer), install(86-02-21,MR12.0-1024):
     Modified by Jim Lippard to add no_write_permission condition handler
      to set_lock_$unlock.
  6) change(86-08-12,Kissel), approve(86-08-12,MCR7473),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Changed to support control point management.  These changes were actually
     done in April 1985 by G. Palter.  The main change was to always use
     timer_manager_$sleep as that entrypoint was updated in 1979 to work in
     any ring regardless of the state of the alrm IPS signal.  This change had
     to be made as the old code herein did not work with multiple control
     points.
                                                   END HISTORY COMMENTS */

/* format: style3,linecom */

set_lock_:
     procedure ();

	return;					/* not an entrypoint */


/* Parameters */

dcl	lock		bit (36) aligned parameter;	/* lock word */

dcl	wait_time		fixed binary parameter;	/* time in seconds to wait for lock to be unlocked */

dcl	status		fixed binary (35) parameter;


/* Static data -- Initialized once per ring */

dcl	first_invocation	bit (1) aligned static initial ("1"b);

dcl	lock_id		bit (36) aligned static;	/* our process lock ID */


/* Remaining declarations */

dcl	failure_time	fixed binary (71);
dcl	sleep_time	fixed binary (71);
dcl	ttul_code		fixed binary;

dcl	(
	error_table_$invalid_lock_reset,
	error_table_$lock_not_locked,
	error_table_$lock_wait_time_exceeded,
	error_table_$locked_by_other_process,
	error_table_$locked_by_this_process,
	error_table_$no_w_permission
	)		fixed binary (35) external;

dcl	get_lock_id_	entry (bit (36) aligned);
dcl	hcs_$try_to_unlock_lock
			entry (pointer, fixed binary);
dcl	timer_manager_$sleep
			entry (fixed binary (71), bit (2));

dcl	(addr, clock, min, stacq)
			builtin;

dcl	(no_write_permission, not_in_write_bracket)
			condition;

dcl	AVERY_LONG_TIME	fixed bin (71)		/* (2**52) microseconds) */
			init (10000000000000000000000000000000000000000000000000000b) static options (constant);

dcl	ONE_SEC_MICRO	fixed bin (35) init (1000000) static options (constant);

dcl	IN_MICRO		bit (2) init ("10"b) static options (constant);
%page;
/* format: off */

/* set_lock_$lock -- This entry attempts to set the lock word to the lock
   identifier of the calling process.  If the lock is already set by some other
   existing process then it waits for some given period of time for the lock to
   be unlocked.  If the lock is not unlocked in the given time then set_lock_
   gives up and returns.

      dcl  set_lock_$lock entry (bit(36) aligned, fixed binary, fixed binary (35));
      call set_lock_$lock (lock, wait_time, status);

   where:

      lock	(Input/Output)
	     is the lock word.

      wait_time	(Input)
	     is the number of seconds to wait for the lock to be unlocked.
	     If wait_time is zero, set_lock_$lock will never wait if the
	     lock is already locked.  If wait_time is negative,
	     set_lock_$lock will wait forever for the lock to be unlocked.

      status	(Output)
	     is a standard system status code.  It may take on one of the
	     following values:

	     0	the lock was successfully locked and was not previously
		locked.
	     error_table_$lock_wait_time_exceeded
		the lock was validly locked, we waited the requested
		period but the lock was not unlocked.
	     error_table_$locked_by_this_process
		the lock was already locked by this process.
	     error_table_$invalid_lock_reset
		the lock was successfully locked but was previously locked
		with an invalid lock ID.  (E.g., a dead process)
	     error_table_$no_w_permission
		the caller does not have the necessary access (write) to
		lock the supplied lock.
   */
/* format: on */

set_lock_$lock:
     entry (lock, wait_time, status);

	if first_invocation				/* first time in this ring */
	then call initialize_set_lock ();

	on no_write_permission, not_in_write_bracket
	     begin;
		status = error_table_$no_w_permission;
		go to RETURN_FROM_SET_LOCK;
	     end;

	failure_time = 0;

	do while ("1"b);				/* forever */

	     if stacq (lock, lock_id, "0"b)		/* try the lock */
	     then call return_from_set_lock (0);	/* ... got it */

	     call hcs_$try_to_unlock_lock (addr (lock), ttul_code);
	     if ttul_code = 3			/* ring 0 reset an invalid lock and relocked it for us */
	     then call return_from_set_lock (error_table_$invalid_lock_reset);

	     if ttul_code ^= 2
	     then do;				/* it's locked by a live process */

		     if lock = lock_id		/* already locked by this process */
		     then call return_from_set_lock (error_table_$locked_by_this_process);

		     if wait_time = 0
		     then sleep_time = 0;		/* caller does not want to wait */

		     else do;			/* either wait forever or for the requested time */
			     if failure_time = 0	/* ... determine when to give up */
			     then if wait_time < 0
				then failure_time = AVERY_LONG_TIME;
						/* ... wait forever (2**52 microseconds) */
				else failure_time = clock () + wait_time * ONE_SEC_MICRO;
						/* ... wait the specified number of seconds */
			     sleep_time = failure_time - clock ();
			end;			/* ... compute how long to sleep */

		     if sleep_time <= 0		/* we've waited long enough */
		     then call return_from_set_lock (error_table_$lock_wait_time_exceeded);

		     /*** We need to sleep before trying the lock again --
			As of 1979, timer_manager_$sleep will work in any
			ring and will also work when the alrm IPS signal
			is masked. */

		     call timer_manager_$sleep (min (sleep_time, ONE_SEC_MICRO), IN_MICRO);
		end;
	end;
%page;
/* set_lock_$unlock -- This entry unlocks a lock word that is set to the
   calling process's lock identifier.

      dcl  set_lock_$unlock entry (bit(36) aligned, fixed binary (35));
      call set_lock_$unlock (lock, status);

   where:

      lock	(Input/Output)
	     is the lock word.
   
      status	(Output)
	     is a standard system status code.
   */

set_lock_$unlock:
     entry (lock, status);

	if first_invocation				/* first time in this ring */
	then call initialize_set_lock ();

	if stacq (lock, "0"b, lock_id)
	then call return_from_set_lock (0);		/* we unlocked it */

	else if lock = ""b				/* it wasn't locked */
	then call return_from_set_lock (error_table_$lock_not_locked);

	else call return_from_set_lock (error_table_$locked_by_other_process);
%page;
/* Set the status code and return to our caller */

return_from_set_lock:
     procedure (p_status);

dcl	p_status		fixed binary (35) parameter;

	status = p_status;
	go to RETURN_FROM_SET_LOCK;

     end return_from_set_lock;


RETURN_FROM_SET_LOCK:
	return;



/* Initialize the set_lock_ mechanism in this this ring */

initialize_set_lock:
     procedure ();

	call get_lock_id_ (lock_id);

	first_invocation = "0"b;

	return;

     end initialize_set_lock;

     end set_lock_;




		    timer_manager_.pl1              11/11/89  1144.0rew 11/11/89  0803.5      317016



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

/* format: style4,insnl,delnl,ifthendo */

timer_manager_:
     proc;
	return;

/* This procedure provides to a user process the ability to schedule timers as
   if there were an infinite number of hardware timers available, by keeping a
   list of scheduled timers and intercepting all timer wakeups and interrupts.

   Dedicated to Peter Bishop, who did the best he could with the tools he had.

   LINES MARKED "DEBUG" and commented out should REMAIN commented out
   in the production version.  They are only decommented for debugging.

   Entirely rewritten 12/03/79 by C. D. Tavares.
   Also added ability to sleep in inner ring and examine list of timers
   scheduled to occur in the process. */

/* Changed by E. Donner Jan 1981 to change calls to full_ipc_$ to ipc_$ for new ipc changes */
/* Modified by Benson I. Margulies, September 1981, for condition wall an alarm_call calls. */
/* Modified September 8, 1982 by Richard Lamson to add data pointer argument	     */
/* Modified by BIM, November 1982 to take condition wall back out. */


/****^  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):
     Changed to support control point management.  These changes were actually
     done in February 1985 by G. Palter.
  2) change(86-12-10,Fawcett), approve(86-12-17,MECR0003),
     audit(86-12-15,GDixon), install(86-12-17,MR12.0-1250):
     Changed to fix the problem in Initializer use of timer_manager_.
     system_startup_ (Initializer ring 1 command level) calls
     timer_manager_$sleep in ring 1, causing initial_ring (in timer_manager_'s
     ring 1 internal static) to be set to 1 (since Initializer hasn't crossed
     out into ring 4 yet).  After crossing to ring 4, when the Initializer
     calls into ring_1 to a function that requires timer_manager_$sleep, ring 1
     internal static still thinks initial_ring is 1, rather than 4.  It
     therefore uses the login_ring sleep protocol rather than the inner ring
     protocol, goes blocked in ring 1 and never awakens. The fix is to always
     call the internal proc initialize. In this proc a check is made for
     initial_ring = 1 and then if this is Initializer, then set the
     initialized_mechanisum to Uninitialized (0) and reinit in this ring.
  3) change(87-01-13,Fawcett), approve(87-01-13,MCR7601),
     audit(87-01-13,GJohnson), install(87-01-13,MR12.0-1270):
     This closes MECR0003.
  4) change(87-01-13,Lippard), approve(86-11-24,MCR7577),
     audit(87-01-14,Dickson), install(87-03-30,MR12.1-1018):
     Change actually made 86-10-29, bogus date is to satisfy hcom.
     Make timer_manager_$sleep unschedule timer in cleanup handler.
                                                   END HISTORY COMMENTS */


dcl  a_time fixed bin (71) parameter,			/* desired time of event */
     a_flags bit (2) parameter,			/* 0=abs/1=rel; 0=usec/1=sec */
     a_routine entry variable parameter,		/* routine to call when timer goes off */
     a_channel fixed bin (71) parameter;		/* channel to wakeup over when timer goes off */

dcl  area_ptr pointer parameter,			/* get_schedule entry: pointer to user area */
     a_code fixed bin (35) parameter;

dcl  a_mc_ptr pointer parameter,			/* interrupt entries: machine conditions ptr pointer */
     a_condition_name char (*) parameter,		/* alrm or cput */
     a_hc_mc_ptr pointer parameter,			/* hardcore machine conditions ptr */
     io_ptr pointer,				/* we don't use this */
     a_continue bit (1) aligned;			/* resignal condition if we turn it on */

dcl  a_call_timer_info_ptr pointer parameter;		/* invoke_users_routine: data set by other control point */

dcl  data_ptr pointer,
     data_ptr_provided bit (1) aligned;

dcl  call_timer_info_ptr pointer,
     call_timer_info_condition_name_lth fixed binary (21);

/* static */

dcl  (
     allow_all_mask bit (36) aligned initial ((36)"1"b),
     alrm_cput_mask bit (36) aligned initial (""b),
     alrm_cput_quit_mask bit (36) aligned initial (""b),
     alrm_disabled_mask bit (36) aligned initial (""b),
     my_group_id char (32) initial (""),     
     initial_ring fixed bin initial (-2),
     initialized_mechanism fixed bin initial (0),
     my_processid bit (36) initial (""b),
     start_alarm_list_ptr pointer initial (null),
     start_cpu_list_ptr pointer initial (null),
     free_bead_list_ptr pointer initial (null),
     saved_channel_array (5) fixed binary (71) initial ((5) - 1),
     saved_channel_count fixed binary initial (0),
     sys_areap pointer initial (null),
     this_ring fixed bin initial (-1)
     ) static;

/* external static */

dcl  error_table_$invalid_channel fixed bin (35) external static,
     error_table_$noalloc fixed bin (35) external static,
     sys_info$max_seg_size fixed bin (35) ext static;

/* constants */

dcl  (
     Alarm bit (1) aligned initial ("1"b),
     CPU bit (1) aligned initial (""b),
     Initializer char (23) initial ("Initializer.SysDaemon.z"),
     Inhibit bit (1) aligned initial ("1"b),
     No_inhibit bit (1) aligned initial (""b),
     Call bit (1) aligned initial ("1"b),
     Wakeup bit (1) aligned initial (""b),
     Limited fixed bin initial (1),
     Full fixed bin initial (2),
     Uninitialized fixed bin initial (0),
     Absolute_setting fixed bin initial (2),
     Million fixed bin (35) initial (1f6),
     Forever fixed bin (71) initial (1f70b),
     All_IPS (1) char (32) aligned initial ("-all"),
     IPS_names (3) char (32) aligned initial ("alrm", "cput", "quit")
     ) static options (constant);

/* entries */

dcl  create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)),
     ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)),
     get_group_id_ entry () returns (char (32)),
     get_initial_ring_ entry returns (fixed bin),
     get_process_id_ entry returns (bit (36) aligned),
     get_ring_ entry returns (fixed bin),
     get_system_free_area_ entry returns (pointer),
     hcs_$assign_channel entry (fixed bin (71), fixed bin (35)),
     hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned),
     hcs_$get_alarm_timer entry (fixed bin (71), fixed bin (71)),
     hcs_$set_alarm_timer entry (fixed bin (71), fixed bin, fixed bin (71)),
     hcs_$set_automatic_ips_mask entry (bit (36) aligned, bit (36) aligned),
     hcs_$set_cpu_timer ext entry (fixed bin (71), fixed bin, fixed bin (71)),
     hcs_$get_ips_mask ext entry (bit (36) aligned),
     hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned),
     hcs_$wakeup entry (bit (36), fixed bin (71), char (8) aligned, fixed bin (35)),
     ipc_$block entry (pointer, pointer, fixed bin (35));

/* based */

dcl  1 bead aligned based,
       2 next_ptr pointer,
       2 info like schedule.timer;

dcl  1 call_timer_info aligned based (call_timer_info_ptr),
       2 routine entry (pointer, character (*), pointer, pointer) variable,
       2 condition_name_lth fixed binary (21),
       2 pad bit (36) aligned,
       2 mc_ptr pointer,
       2 hc_mc_ptr pointer,
       2 data_ptr pointer,
       2 condition_name
	  character (call_timer_info_condition_name_lth refer (call_timer_info.condition_name_lth)) unaligned;

dcl  sys_area area (sys_info$max_seg_size) based (sys_areap);

/* builtins and conditions */

dcl  (addr, bool, clock, hbound, length, null, stackbaseptr, substr, unspec, vclock) builtin;

dcl  (area, cleanup) condition,
     timer_manager_err condition;

/* format: off */
%page; %include timer_manager_schedule;
%page; %include mc;
%page; %include stack_header;
%page; %include cpm_data_;
%page; %include cpm_entries;
/* format: on */
%page;
alarm_call:
     entry (a_time, a_flags, a_routine);

	call set_data_ptr (4, data_ptr, data_ptr_provided);
	call schedule_timer (abs_time (a_time, a_flags, Alarm), Alarm, No_inhibit, Call, 0, a_routine, data_ptr,
	     data_ptr_provided);
	return;
%skip (2);
alarm_call_inhibit:
     entry (a_time, a_flags, a_routine);

	call set_data_ptr (4, data_ptr, data_ptr_provided);
	call schedule_timer (abs_time (a_time, a_flags, Alarm), Alarm, Inhibit, Call, 0, a_routine, data_ptr,
	     data_ptr_provided);
	return;
%skip (2);
cpu_call:
     entry (a_time, a_flags, a_routine);

	call set_data_ptr (4, data_ptr, data_ptr_provided);
	call schedule_timer (abs_time (a_time, a_flags, CPU), CPU, No_inhibit, Call, 0, a_routine, data_ptr,
	     data_ptr_provided);
	return;
%skip (2);
cpu_call_inhibit:
     entry (a_time, a_flags, a_routine);

	call set_data_ptr (4, data_ptr, data_ptr_provided);
	call schedule_timer (abs_time (a_time, a_flags, CPU), CPU, Inhibit, Call, 0, a_routine, data_ptr,
	     data_ptr_provided);
	return;
%skip (2);
alarm_wakeup:
     entry (a_time, a_flags, a_channel);

	call schedule_timer (abs_time (a_time, a_flags, Alarm), Alarm, No_inhibit, Wakeup, a_channel,
	     signal_timer_manager_err, null, "0"b);
	return;
%skip (2);
cpu_wakeup:
     entry (a_time, a_flags, a_channel);

	call schedule_timer (abs_time (a_time, a_flags, CPU), CPU, No_inhibit, Wakeup, a_channel,
	     signal_timer_manager_err, null, "0"b);
	return;
%skip (2);
sleep:
     entry (a_time, a_flags);

	call sleep (abs_time (a_time, a_flags, Alarm), "0"b);
	return;
%skip (2);
sleep_lss:
     entry (a_time, a_flags);

	call sleep (abs_time (a_time, a_flags, Alarm), "1"b);
	return;
%skip (2);
reset_alarm_call:
     entry (a_routine);

	call set_data_ptr (2, data_ptr, data_ptr_provided);
	call unschedule_timer (Alarm, Call, 0, a_routine, data_ptr, data_ptr_provided);
	return;
%skip (2);
reset_alarm_wakeup:
     entry (a_channel);

	call unschedule_timer (Alarm, Wakeup, a_channel, signal_timer_manager_err, null, "0"b);
	return;
%skip (2);
reset_cpu_call:
     entry (a_routine);

	call set_data_ptr (2, data_ptr, data_ptr_provided);
	call unschedule_timer (CPU, Call, 0, a_routine, data_ptr, data_ptr_provided);
	return;
%skip (2);
reset_cpu_wakeup:
     entry (a_channel);

	call unschedule_timer (CPU, Wakeup, a_channel, signal_timer_manager_err, null, "0"b);
	return;
%skip (2);
get_schedule:
     entry (area_ptr, schedule_ptr, a_code);

	call get_schedule (area_ptr, schedule_ptr, a_code);
	return;
%skip (2);

/* The following two entries are entries called by the system when timers go off */

alarm_interrupt:
     entry (a_mc_ptr, a_condition_name, a_hc_mc_ptr, io_ptr, a_continue);

	call process_interrupt (Alarm, a_mc_ptr, a_condition_name, a_hc_mc_ptr, a_continue);
	return;
%skip (2);
cpu_time_interrupt:
     entry (a_mc_ptr, a_condition_name, a_hc_mc_ptr, io_ptr, a_continue);

	call process_interrupt (CPU, a_mc_ptr, a_condition_name, a_hc_mc_ptr, a_continue);
	return;
%skip (10);
invoke_users_routine:
     entry (a_call_timer_info_ptr);

	call_timer_info_ptr = a_call_timer_info_ptr;

	on cleanup
	     begin;
	     if call_timer_info_ptr ^= null ()
	     then free call_timer_info in (sys_area);
	     call_timer_info_ptr = null ();
	end;

	call call_timer_info
	     .
	     routine (call_timer_info.mc_ptr, call_timer_info.condition_name, call_timer_info.hc_mc_ptr,
	     call_timer_info.data_ptr);

	free call_timer_info in (sys_area);
	call_timer_info_ptr = null ();

	return;
%skip (10);
set_data_ptr:
     proc (arg_number, a_data_ptr, a_data_ptr_provided);

	call cu_$arg_ptr (arg_number, p_ptr, p_len, x_code);
	if x_code = 0 then do;
	     a_data_ptr = p_ptr -> based_ptr;
	     a_data_ptr_provided = "1"b;
	end;
	else do;
	     a_data_ptr = null ();
	     a_data_ptr_provided = "0"b;
	end;
	return;

declare  arg_number fixed binary parameter;
declare  a_data_ptr pointer parameter;
declare  a_data_ptr_provided bit (1) aligned;

declare  p_ptr pointer;
declare  p_len fixed binary (21);
declare  x_code fixed binary (35);
declare  based_ptr pointer based;

     end;
%page;
schedule_timer:
     proc (time, type, inhibit, action, channel, routine, data_ptr, data_ptr_provided);

dcl  (
     time fixed bin (71),
     type bit (1) aligned,
     inhibit bit (1) aligned,
     action bit (1) aligned,
     channel fixed bin (71),
     routine entry variable,
     data_ptr_provided bit (1) aligned,
     data_ptr pointer
     ) parameter;

dcl  bead_ptr pointer,
     found bit (1) aligned,
     next_bead_ptr pointer,
     prev_bead_ptr pointer,
     saved_mask bit (36) aligned,
     start_list_ptr pointer;


	call initialize (Full);

/* Mask down so we won't be bothered by asynchronous processing or unexpected recursion */

	saved_mask = "0"b;

	on cleanup
	     begin;
	     if substr (saved_mask, 36, 1) = "1"b
	     then call hcs_$reset_ips_mask (saved_mask, saved_mask);
	end;

	call hcs_$set_ips_mask (alrm_cput_quit_mask, saved_mask);
						/* disable alrm, cput, quit */


/* Search down appropriate list and sort in alarm by time */

	found = "0"b;
	prev_bead_ptr = null;
	if type = Alarm
	then start_list_ptr = start_alarm_list_ptr;
	else start_list_ptr = start_cpu_list_ptr;

	do bead_ptr = start_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null & ^found);
	     if time < bead_ptr -> bead.time
	     then found = "1"b;
	     else prev_bead_ptr = bead_ptr;
	end;

/* At this point, prev_bead_ptr points to the bead after which we want to sort in the new timer */
	if free_bead_list_ptr = null ()
	then allocate bead in (sys_area) set (bead_ptr);
	else do;
	     bead_ptr = free_bead_list_ptr;
	     free_bead_list_ptr = bead_ptr -> bead.next_ptr;
	end;
/**** DEBUG  	     if debugging then call ioa_ ("Allocated bead at ^p.", bead_ptr); /* DEBUG */

	bead_ptr -> bead.time = time;
	bead_ptr -> bead.alarm = (type = Alarm);
	bead_ptr -> bead.cpu = (type = CPU);
	bead_ptr -> bead.inhibit = (inhibit = Inhibit);
	bead_ptr -> bead.call = (action = Call);
	bead_ptr -> bead.wakeup = (action = Wakeup);
	bead_ptr -> bead.data_ptr_provided = data_ptr_provided;
	bead_ptr -> bead.channel = channel;
	bead_ptr -> bead.routine = routine;
	bead_ptr -> bead.data_ptr = data_ptr;
	bead_ptr -> bead.control_point_id = get_control_point_id_ ();

	if prev_bead_ptr = null then do;		/* The new bead was placed at the head of the list */
	     bead_ptr -> bead.next_ptr = start_list_ptr;
	     start_list_ptr = bead_ptr;
	     if type = Alarm
	     then start_alarm_list_ptr = start_list_ptr;
	     else start_cpu_list_ptr = start_list_ptr;

/* Since the new bead is now the first scheduled to occur, we must (re)set the appropriate timer to the new time. */

	     call set_next_timer;
	end;

	else do;
	     bead_ptr -> bead.next_ptr = prev_bead_ptr -> bead.next_ptr;
	     prev_bead_ptr -> bead.next_ptr = bead_ptr;
	end;

/**** DEBUG  	     if debugging_chain then call display_chain (start_list_ptr); /* DEBUG */
	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;
%skip (5);
unschedule_timer:
     entry (type, action, channel, routine, data_ptr, data_ptr_provided);

dcl  removed_first bit (1) aligned;

	call initialize (Full);

/* Mask down so we won't be bothered by asynchronous processing or unexpected recursion */

	saved_mask = "0"b;

	on cleanup
	     begin;
	     if substr (saved_mask, 36, 1) = "1"b
	     then call hcs_$reset_ips_mask (saved_mask, saved_mask);
	end;

	call hcs_$set_ips_mask (alrm_cput_quit_mask, saved_mask);
						/* disable alrm, cput, quit */


/* Search down appropriate list and get rid of matching entries */

	if type = Alarm
	then start_list_ptr = start_alarm_list_ptr;
	else start_list_ptr = start_cpu_list_ptr;

	removed_first = ""b;
	prev_bead_ptr = null;

	do bead_ptr = start_list_ptr repeat (next_bead_ptr) while (bead_ptr ^= null);
	     next_bead_ptr = bead_ptr -> bead.next_ptr;

	     if action = Wakeup
	     then if bead_ptr -> bead.channel = channel
		then call remove_bead (bead_ptr, prev_bead_ptr);
		else prev_bead_ptr = bead_ptr;
	     else if bead_ptr -> bead.routine = routine
	     then if data_ptr_provided
		then if data_ptr = bead_ptr -> bead.data_ptr
		     then call remove_bead (bead_ptr, prev_bead_ptr);
		     else prev_bead_ptr = bead_ptr;
		else call remove_bead (bead_ptr, prev_bead_ptr);
	     else prev_bead_ptr = bead_ptr;
	end;

	if removed_first
	then call set_next_timer;

	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;
%skip (2);
process_interrupt:
     entry (type, mc_ptr, condition_name, hc_mc_ptr, continue);

dcl  (
     mc_ptr pointer,
     condition_name char (*),
     hc_mc_ptr pointer,
     continue bit (1) aligned
     ) parameter;

dcl  code fixed bin (35),
     temp_mask bit (36) aligned,
     wakeup_message char (8) aligned;

dcl  1 auto_bead automatic,
       2 next_ptr pointer,
       2 info like schedule.timer;

/**** DEBUG  	     if debugging then do;			/* DEBUG */
/**** DEBUG  		call ioa_ ("Processing interrupt for ^a", condition_name); /* DEBUG */
/**** DEBUG  		call hcs_$set_ips_mask ((36)"1"b, ""b); /* DEBUG */
/**** DEBUG  	     end;					/* DEBUG */

	if type = Alarm
	then start_list_ptr = start_alarm_list_ptr;
	else start_list_ptr = start_cpu_list_ptr;

/* First, check if the timer that went off was expected.  Unexpected timers can
   occur in three ways.  One, somebody may be fiddling around with the hardcore
   timers (naughty).  Two, a timer may have gone off right while we were masked
   and busy removing the very same timer from the list (via the reset entries).
   Three, there is presently a minor problem in hardcore that causes CPU timers
   to go off a bit too early (the timer is rung with respect to a CPU time that
   includes page fault time, whereas the real virtual CPU time doesn't).  Since
   we can't tell the difference in order to slap anyone's wrists, if we get any
   unscheduled timers, we just grin and swallow them.  In addition, we re-force
   the correct (expected) timer back into hardcore. */

	if start_list_ptr = null then do;		/* didn't expect ANY such timer */
	     call set_next_timer;			/* turn off HC timer */
	     return;
	end;

	if type = Alarm
	then if start_list_ptr -> bead.time > clock () then do;
/**** DEBUG  		     if debugging then call ioa_ ("Unexpected alrm, rescheduling."); /* DEBUG */
		call set_next_timer;
		return;
	     end;
	     else ;
	else if start_list_ptr -> bead.time > vclock () then do;
/**** DEBUG  		if debugging then call ioa_ ("Unexpected cput, rescheduling."); /* DEBUG */
	     call set_next_timer;
	     return;
	end;

	unspec (auto_bead) = unspec (start_list_ptr -> bead);

	call remove_bead (start_list_ptr, null);
	call set_next_timer;

	if auto_bead.call then do;
/**** DEBUG  		if debugging then call ioa_ ("Processing the call."); /* DEBUG */
	     if ^auto_bead.inhibit
	     then call hcs_$set_ips_mask (allow_all_mask, "0"b);

	     else on cleanup
		     begin;			/* restore mask if fault and release while inhibited */
		     if mc_ptr ^= null then do;
			temp_mask = mc_ptr -> mc.ips_temp;
			if substr (temp_mask, 36, 1)
			then call hcs_$reset_ips_mask (temp_mask, "0"b);
		     end;
		end;

	     if have_multiple_control_points ()		/* must always use cpm_ to insure I/O switches are OK */
	     then call call_routine_in_other_control_point ();
	     else call auto_bead.routine (mc_ptr, condition_name, hc_mc_ptr, auto_bead.data_ptr);
	end;

	else if auto_bead.wakeup then do;
/**** DEBUG  		if debugging then call ioa_ ("Processing the wakeup."); /* DEBUG */
	     if type = Alarm
	     then wakeup_message = "alarm___";
	     else wakeup_message = "cpu_time";
	     call hcs_$wakeup (my_processid, auto_bead.channel, wakeup_message, code);
	     if code ^= 0
	     then if code ^= error_table_$invalid_channel
		then call signal_timer_manager_err;	/* only acceptable error is user destroyed his channel */
	end;

	return;
%skip (5);
have_multiple_control_points:
	procedure () returns (bit (1) aligned);

	     if stackbaseptr () -> stack_header.cpm_enabled
	     then return (cpm_data_$n_control_points > 1);
	     else return ("0"b);

	end have_multiple_control_points;
%skip (5);
call_routine_in_other_control_point:
	procedure ();

	     call_timer_info_condition_name_lth = length (condition_name);
	     allocate call_timer_info in (sys_area) set (call_timer_info_ptr);

	     call_timer_info.routine = auto_bead.routine;
	     call_timer_info.mc_ptr = mc_ptr;
	     call_timer_info.hc_mc_ptr = hc_mc_ptr;
	     call_timer_info.data_ptr = auto_bead.data_ptr;
	     call_timer_info.condition_name = condition_name;

	     call cpm_$generate_call_preferred (auto_bead.control_point_id, invoke_users_routine, call_timer_info_ptr,
		code);

	     return;

	end call_routine_in_other_control_point;
%skip (5);
remove_bead:
	proc (a_bead_ptr, prev_bead_ptr);

dcl  (a_bead_ptr, prev_bead_ptr) pointer parameter;

dcl  bead_ptr pointer,
     next_bead_ptr pointer;

	     bead_ptr = a_bead_ptr;

	     if prev_bead_ptr = null then do;

		removed_first = "1"b;
		start_list_ptr = bead_ptr -> bead.next_ptr;

		if type = Alarm
		then start_alarm_list_ptr = start_list_ptr;
		else start_cpu_list_ptr = start_list_ptr;
	     end;

	     else prev_bead_ptr -> bead.next_ptr = bead_ptr -> bead.next_ptr;

	     next_bead_ptr = bead_ptr -> bead.next_ptr;

/**** DEBUG  		if debugging then			/* DEBUG */
/**** DEBUG 		     call ioa_ ("Removed bead at ^p^[; was first bead^;^].", bead_ptr, removed_first); /* DEBUG */
	     bead_ptr -> bead.next_ptr = free_bead_list_ptr;
	     free_bead_list_ptr = bead_ptr;


	     a_bead_ptr = next_bead_ptr;
/**** DEBUG  		if debugging_chain then call display_chain (start_list_ptr); /* DEBUG */
	     return;

	end remove_bead;
%skip (2);
set_next_timer:
	proc;

	     if type = Alarm
	     then if start_alarm_list_ptr ^= null then do;
/**** DEBUG  			if debugging then do;	/* DEBUG */
/**** DEBUG  			     call date_time_ (start_alarm_list_ptr -> bead.time, junk_string); /* DEBUG */
/**** DEBUG  			     call ioa_ ("Setting HC alarm for ^a (^d) from ^p.", junk_string, /* DEBUG */
/**** DEBUG  				start_alarm_list_ptr -> bead.time, start_alarm_list_ptr); /* DEBUG */
/**** DEBUG  			end;			/* DEBUG */

		     call hcs_$set_alarm_timer (start_alarm_list_ptr -> bead.time, Absolute_setting, 0);
		end;
		else do;
/**** DEBUG  			if debugging then call ioa_ ("Turning HC alarm off."); /* DEBUG */
		     call hcs_$set_alarm_timer (Forever, Absolute_setting, 0);
						/* Hardcore interprets a number this big as "shut up" */
		end;
	     else if start_cpu_list_ptr ^= null then do;
/**** DEBUG  		     if debugging then call ioa_ ("Setting HC CPU timer to ^6.3f from ^p.", /* DEBUG */
/**** DEBUG 			start_cpu_list_ptr -> bead.time / 1e6, /* DEBUG */
/**** DEBUG  			start_cpu_list_ptr);	/* DEBUG */
		call hcs_$set_cpu_timer (start_cpu_list_ptr -> bead.time, Absolute_setting, 0);
	     end;
	     else do;
/**** DEBUG  		     if debugging then call ioa_ ("Turning HC CPU timer off."); /* DEBUG */
		call hcs_$set_cpu_timer (0, Absolute_setting, 0);
						/* pxss, on the other hand, likes zeroes for that purpose */
	     end;

	     return;
	end set_next_timer;
%page;
get_schedule:
     entry (area_ptr, schedule_ptr, a_code);

dcl  (
     area_ptr pointer,
     schedule_ptr pointer parameter,
     a_code fixed bin (35)
     ) parameter;

dcl  timer_idx fixed bin;

dcl  user_area area (sys_info$max_seg_size) based (area_ptr);

	saved_mask = ""b;

	on cleanup
	     begin;
	     if substr (saved_mask, 36, 1)
	     then call hcs_$reset_ips_mask (saved_mask, saved_mask);
	end;

	schedule_ptr = null;

	call hcs_$set_ips_mask (alrm_cput_mask, saved_mask);

/* Count the outstanding scheduled timers */

	N_Timers = 0;

	do bead_ptr = start_alarm_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null),
	     start_cpu_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null);
	     N_Timers = N_Timers + 1;
	end;

	on area
	     begin;
	     a_code = error_table_$noalloc;
	     goto return_hard;
	end;

	allocate schedule in (user_area) set (schedule_ptr);

	revert area;

	schedule_ptr -> schedule.version = timer_manager_schedule_version_3;

	timer_idx = 0;
	do bead_ptr = start_alarm_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null),
	     start_cpu_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null);
	     timer_idx = timer_idx + 1;
	     call fill_slot (bead_ptr);
	end;

	a_code = 0;

return_hard:
	call hcs_$reset_ips_mask (saved_mask, saved_mask);

	return;
%skip (2);
fill_slot:
	proc (bead_ptr);

dcl  bead_ptr pointer parameter;

	     unspec (schedule_ptr -> schedule.timer (timer_idx)) = unspec (bead_ptr -> bead.info);
	     return;
	end fill_slot;
     end schedule_timer;
%page;
sleep:
     proc (time, lss);

dcl  time fixed bin (71) parameter,
     lss bit (1) aligned parameter;

dcl  1 wait_list aligned,
       2 number_of_channels fixed bin,
       2 sleep_channel fixed bin (71);

dcl  1 block_message aligned,
       2 channel_id fixed bin (71),
       2 message fixed bin (71),
       2 sender_processid bit (36),
       2 origin,
         3 device bit (18) unaligned,
         3 ring fixed bin (18) unaligned unsigned,
       2 channel_index fixed bin;

dcl  code fixed bin (35),
     cur_mask bit (36) aligned,
     old_channel fixed bin (71),
     old_timer fixed bin (71);

	call initialize (Limited);			/* if we need any more, someone else will do it */


	wait_list.number_of_channels = 1;
	sleep_channel = -1;

	on cleanup
	     begin;
	     if sleep_channel ^= -1
	     then do;
		call ipc_$delete_ev_chn (sleep_channel, code);
		call unschedule_timer (Alarm, Wakeup, sleep_channel, signal_timer_manager_err, null(), "0"b);
		sleep_channel = -1;
	     end;
	end;

/*	     call hcs_$assign_channel (sleep_channel, code); /* HC bug causes fast channels to fail right now. */
/*	     if code ^= 0 then			/* maybe no fast channels left */
	if saved_channel_count > 0 then do;
	     saved_channel_count = saved_channel_count - 1;
	     sleep_channel = saved_channel_array (saved_channel_count + 1);
	end;
	else do;
	     call ipc_$create_ev_chn (sleep_channel, code);
	     if code /* still */ ^= 0
	     then call signal_timer_manager_err;
	end;

	call hcs_$get_ips_mask (cur_mask);

/**** DEBUG  	     if debugging then do;			/* DEBUG */
/**** DEBUG  		call date_time_ (time, junk_string);	/* DEBUG */
/**** DEBUG  		call ioa_ ("Sleeping until ^a (^d).", junk_string, time); /* DEBUG */
/**** DEBUG  	     end;					/* DEBUG */

	if (lss | (this_ring ^= initial_ring) | (bool (cur_mask, alrm_disabled_mask, "1000"b) ^= ""b))
	then begin;

/* Here, we either want to or have to do the whole thing manually.  If this is
   as LSS nap, we don't want any other interrupts to occur.  If alrms are
   masked, they CAN'T occur-- and neither can our own.  If we are executing in
   an inner ring (or other ring than initial ring) we can't take advantage of
   the timer-queuing properties of schedule_timer anyway. */

/**** DEBUG  		if debugging then call ioa_ ("Sleeping the hard way."); /* DEBUG */

	     old_channel = -1;

	     on cleanup
		begin;
		if old_channel ^= -1
		then call hcs_$set_alarm_timer (old_timer, Absolute_setting, old_channel);
	     end;

	     call hcs_$get_alarm_timer (old_timer, old_channel);
/**** DEBUG  		if debugging then call ioa_ ("Old timer was ^d on channel ^o.", old_timer, old_channel); /* DEBUG */

	     call hcs_$set_alarm_timer (time, Absolute_setting, sleep_channel);
/**** DEBUG  		if debugging then do;		/* DEBUG */
/**** DEBUG  		     call hcs_$get_alarm_timer (junk_time, junk_channel); /* DEBUG */
/**** DEBUG  		     call ioa_ ("HC verifies new timer as ^d on channel ^o.", junk_time, junk_channel); /* DEBUG */
/**** DEBUG  		end;				/* DEBUG */

	     call ipc_$block (addr (wait_list), addr (block_message), code);
	     if code ^= 0
	     then call signal_timer_manager_err;

/**** DEBUG  		if debugging then call ioa_ ("Returned from block."); /* DEBUG */

	     call hcs_$set_alarm_timer (old_timer, Absolute_setting, old_channel);
	     old_channel = -1;
	end;

	else do;					/* normal case, use queuing mechanism */
/**** DEBUG  		if debugging then call ioa_ ("Sleeping the easy way."); /* DEBUG */

	     call schedule_timer (time, Alarm, No_inhibit, Wakeup, sleep_channel, signal_timer_manager_err, null (),
		"0"b);

	     call ipc_$block (addr (wait_list), addr (block_message), code);
	     if code ^= 0
	     then call signal_timer_manager_err;

/**** DEBUG  		if debugging then call ioa_ ("Returned from block."); /* DEBUG */

	end;

	if saved_channel_count >= hbound (saved_channel_array, 1) then do;
	     call ipc_$delete_ev_chn (sleep_channel, code);
	     if code ^= 0
	     then call signal_timer_manager_err;
	     return;
	end;
	else do;
	     saved_channel_array (saved_channel_count + 1) = sleep_channel;
	     saved_channel_count = saved_channel_count + 1;
	     return;
	end;

     end sleep;
%page;
abs_time:
     proc (time, flags, type) returns (fixed bin (71));
dcl  time fixed bin (71) parameter,
     flags bit (2) parameter,
     type bit (1) aligned parameter;

dcl  abstime fixed bin (71);

/* Compute the absolute time from the given time according to the flags the user indicated */

	abstime = time;

	if substr (flags, 2, 1)
	then abstime = abstime * Million;		/* change seconds to microseconds */

	if substr (flags, 1, 1)
	then if type = CPU
	     then abstime = abstime + vclock ();
	     else abstime = abstime + clock ();

	if abstime <= 0
	then abstime = 1;				/* go off right away */

	return (abstime);

     end abs_time;
%page;
initialize:
     proc (necessary_mechanism);

dcl  necessary_mechanism fixed bin parameter;

dcl  alrm_cput_auto_mask bit (36) aligned,
     old_auto_ips_mask bit (36) aligned,
     old_ips_mask bit (36) aligned;

	if initial_ring = 1
	then if my_group_id = Initializer
	     then initialized_mechanism = Uninitialized;

	goto step (initialized_mechanism);

step (0):						/* initialize limited mechanism */
/**** The limited mechanism suffices for timer_manager_$sleep in inner rings */
	this_ring = get_ring_ ();
	initial_ring = get_initial_ring_ ();
          my_group_id = get_group_id_ ();
	my_processid = get_process_id_ ();
	sys_areap = get_system_free_area_ ();

	call create_ips_mask_ (addr (IPS_names), 1, alrm_disabled_mask);
	substr (alrm_disabled_mask, 36, 1) = "1"b;

	call create_ips_mask_ (addr (IPS_names), 3, alrm_cput_quit_mask);
	call create_ips_mask_ (addr (All_IPS), 1, allow_all_mask);
	allow_all_mask = ^allow_all_mask;

	initialized_mechanism = Limited;

step (1):
	if initialized_mechanism >= necessary_mechanism
	then return;


/**** The mechanism set up by this section will only work in the process'
      initial ring.  This is because the list of timers is kept in per-ring
      static, and therefore, any given ring can not know what timers are
      outstanding in other rings.  Since there is only one REAL timer, this
      would be terminally confusing.  Therefore, we limit ourselves to
      operation in the user ring. */
	if this_ring ^= initial_ring
	then call signal_timer_manager_err;


/* Now we want to diddle the automatic IPS mask.  Not precisely a mask, this is
   really a set of indicators corresponding to IPS interrupts.  Whenever an IPS
   interrupt indicated in the mask occurs, hardcore automatically masks ALL IPS
   interrupts off before handling it.  It is the job of the handler to remember
   to reset the IPS mask back to what it was.  The old mask can be found in the
   machine conditions. */


	call create_ips_mask_ (addr (IPS_names), 2, alrm_cput_mask);
	alrm_cput_auto_mask = ^alrm_cput_mask;

	old_auto_ips_mask, old_ips_mask = ""b;

	on cleanup
	     begin;
	     if substr (old_auto_ips_mask, 36, 1)
	     then call hcs_$set_automatic_ips_mask (old_auto_ips_mask, old_auto_ips_mask);

	     if substr (old_ips_mask, 36, 1)
	     then call hcs_$set_ips_mask (old_ips_mask, old_ips_mask);
	end;

	call hcs_$set_ips_mask (""b, old_ips_mask);	/* mask down while diddling auto mask */

	call hcs_$set_automatic_ips_mask (""b, old_auto_ips_mask);
						/* get current auto mask */

	old_auto_ips_mask = alrm_cput_auto_mask | old_auto_ips_mask;
						/* carry forward any indicators anyone else might have set */

	call hcs_$set_automatic_ips_mask (old_auto_ips_mask, ""b);

	old_auto_ips_mask = ""b;

	call hcs_$reset_ips_mask (old_ips_mask, old_ips_mask);

	initialized_mechanism = Full;
step (2):
	return;

     end initialize;
%skip (5);
signal_timer_manager_err:
     proc;

	do while ("1"b);
	     signal timer_manager_err;
	end;
     end signal_timer_manager_err;
%page;
/**** DEBUG  display_chain: proc (lp);			/* DEBUG */
/**** DEBUG  dcl (lp, bp) pointer;			/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  dcl 1 auto_bead automatic,			/* DEBUG */
/**** DEBUG      2 next_ptr pointer,			/* DEBUG */
/**** DEBUG      2 info like schedule.timer;		/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  dcl  sysprint stream;			/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  	     put data (lp); put skip (2);		/* DEBUG */
/**** DEBUG  	     do bp = lp repeat (bp -> bead.next_ptr) while (bp ^= null); /* DEBUG */
/**** DEBUG  		put data (bp); put skip;		/* DEBUG */
/**** DEBUG  		unspec (auto_bead) = unspec (bp -> bead); /* DEBUG */
/**** DEBUG  		put data (auto_bead); put skip (2);	/* DEBUG */
/**** DEBUG  	     end;					/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  	     return;				/* DEBUG */
/**** DEBUG  	end display_chain;				/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  debug:	entry;				/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  dcl (debugging, debugging_chain) bit (1) aligned static initial (""b); /* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  dcl  ioa_ ext entry options (variable),		/* DEBUG */
/**** DEBUG       junk_time fixed bin (71),			/* DEBUG */
/**** DEBUG       junk_channel fixed bin (71),		/* DEBUG */
/**** DEBUG       junk_string char (24),			/* DEBUG */
/**** DEBUG       date_time_ ext entry (fixed bin (71), char (*)); /* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  	debugging = "1"b;				/* DEBUG */
/**** DEBUG  	debugging_chain = ""b;			/* DEBUG */
/**** DEBUG  	return;					/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  nodebug:	entry;				/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  	debugging, debugging_chain = ""b;		/* DEBUG */
/**** DEBUG  	return;					/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  debug_chain: entry;				/* DEBUG */
/**** DEBUG 						/* DEBUG */
/**** DEBUG  	debugging, debugging_chain = "1"b;		/* DEBUG */
/**** DEBUG  	return;					/* DEBUG */

     end timer_manager_;




		    wkp_signal_handler_.pl1         11/11/89  1144.0rew 11/11/89  0803.5       24516



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


/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */

wkp_signal_handler_:
     procedure;

/*****************************************************************************/
/*							       */
/*   This is the default handler for the "wkp_" IPS signal.  Its job is to   */
/*   make one pass through the pending IPC events, and run any event call    */
/*   handlers that have wakeups.				       */
/*							       */
/*****************************************************************************/

/* Written by C. Hornig, January 1979. (to do nothing) */


/****^  HISTORY COMMENTS:
  1) change(86-08-12,Kissel), approve(86-08-12,MCR7479),
     audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206):
     Modified to do its thing to support async event channels.
                                                   END HISTORY COMMENTS */


dcl  quit_signalled		       bit (1) aligned;

dcl  ipc_$run_event_calls	       entry (fixed bin, fixed bin (35));

dcl  quit			       condition;

/*
   If any of the call handlers that are run during this time signal quit, we
   will remember it, and signal it ourself when they are all done.  This is
   because ipc_ currently has a flag which prevents event call handlers from
   being run recursively.  In particular, for DSA this means that we can't have
   two quits in a row because it is the event call handler which signals quit.
   If there are ever event call handlers that want to signal other things, this
   code should be changed to catch those conditions and signal them later as
   well.
*/

	quit_signalled = "0"b;

	on quit quit_signalled = "1"b;

/* Just run the handlers for any asynchronous type of event call channels which have pending wakeups. */

	call ipc_$run_event_calls (ASYNC_CALL_EVENT_CHANNEL_TYPE, (0));

/* Signal quit if anyone wanted us to, but revert first to avoid self-flagellation. */

	revert quit;

	if quit_signalled then signal quit;

	return;

%include ipc_create_arg;

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