



		    initialize_process_.pl1         07/13/88  1120.8r w 07/13/88  0935.4      107712



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



/****^  HISTORY COMMENTS:
  1) change(85-11-27,Herbst), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Added static handler for system_message_.
  2) change(86-01-17,Swenson), approve(86-07-23,MCR7444), audit(86-07-24,Ex),
     install(86-08-06,MR12.0-1117):
     Changed to use the error code from the original iox_ call during stream
     attachment, rather than the one from the ios_ call, in the process
     termination structure.
                                                   END HISTORY COMMENTS */

/* format: style2 */

/* This is the first user ring program to run in an ordinary process,
     be it interactive, absentee, or daemon. It is responsable for

       1) Setting up iox_.
       2) Setting up the pl/1 runtime, by establishing the correct
          condition handlers.
       3) Setting up timer manager for the current ring.
       4) finding and calling the process overseer.

  When entered through the main entrypoint, a minimal stack frame is
  established from which the process overseer is called.


   Last Modified (date and reason):


-- Ancient History --

   Initial Coding 8/14/74 by S. Webber from real_init_admin_ of that time
   7/1/75	by S. Barr to convert to iox_.
   7/15/75	by S.Webber to add calls to set up static handlers.
   11/05/75 by R. Bratt for isot fault
   06/07/77 by M. Weaver to delete isot fault
   08/27/77 by S. Webber to add term handler
   01/09/79 by C. Hornig to remove tw_ to tty_ conversion
   03/05/79 by B. Margulies to remove restriction on pit pointers and to
   establish the working directory
   04/15/81 by B. Margulies for new iox initialization.
   1 July 1981 by B. Margulies for pl1 static handlers.

-- Modern History --

     November 1981 by Benson I. Margulies
       absentee special cases -> abs_io_
       default handler setup <- process overseer
       the rest from user_real_init_admin_.
     06/28/84 by Lee A. Newcomb:  added static handlers for
	dm_shutdown_warning_ and dm_user_shutdown_ IPS', moved
	all include files to the end, and put all PL/I entities
	in the main proc (e.g., conditions and builtins).
     07/22/84 by R. Michael Tague:  Changed the entry names of the two
                 Data Management static handlers.
     08/22/84 by R. Michael Tague:  Removed the static handlers for
                 dm_shutdown_warning_ and dm_user_shutdown_.  Added static
                 handlers for system_shutdown_scheduled_ and
                 dm_shutdown_scheduled_.
     10/05/84 by Steve Herbst: Changed to use absentee_listen_ instead of
	       listen_ for an absentee process.
*/
%page;
initialize_process_:
     procedure;


	declare listener		 entry (character (*) varying) variable;
	declare an_entry		 entry variable;
	declare process_overseer	 entry (pointer, bit (1) aligned, character (*) varying) variable;
	declare default_handler	 entry variable;
	declare pit_pointer		 pointer;
	declare code		 fixed bin (35);
	declare wdir_code		 fixed bin (35);
	declare initial_command_line	 character (256) varying;
	declare requested_call_to_listen_
				 bit (1) aligned;
	declare absentee_listen_	 entry (character (*) varying);
	declare com_err_		 entry options (variable);
	declare listen_		 entry (character (*) var);
	declare hcs_$fs_search_set_wdir
				 entry (char (*), fixed bin (35));
	declare system_message_handler_
				 entry ();

	declare error_table_$termination_requested
				 fixed bin (35) ext static;

	declare any_other		 condition;
	dcl     (addr, baseptr, length, null, pointer, substr)
				 builtin;
%page;
	on any_other call primitive_handler;

	code = 0;

	call get_pit_pointer (pit_pointer, code);
	if code ^= 0
	then call terminate ("init_error", "Can't find [pd]>pit.", code);

	wdir_code = 0;
	if pit_pointer -> pit.at.vinitproc
	then call hcs_$fs_search_set_wdir (pit_pointer -> pit.homedir, wdir_code);

	call find_default_handler (default_handler, code);
	if code ^= 0
	then call terminate ("init_error", "Can't find default_error_handler_$wall", code);

	on any_other call default_handler;

	call establish_static_handlers (code);
	if code ^= 0
	then call terminate ("init_error", "Can't establish static handlers", code);

	call init_iox (pit_pointer, code);
	if code ^= 0
	then call terminate ("io_attach", "Can't initialize I/O system.", code);

	call check_wdir_code;			/* We can talk now, so print the error */

	call find_process_overseer (pit_pointer, process_overseer, code);
	if code ^= 0
	then call terminate ("no_initproc", "Could not find process overseer.", code);

	requested_call_to_listen_ = "0"b;
	call process_overseer (pit_pointer, requested_call_to_listen_, initial_command_line);
	if requested_call_to_listen_
	then do;
		call enable_quits;
		if ^pit_pointer -> pit.at.vinitproc
		then do;
			an_entry = listen_;		/* find & initiate this before wdir=homedir */
			an_entry = absentee_listen_;	/* find & initiate this too */
			call hcs_$fs_search_set_wdir (pit_pointer -> pit.homedir, wdir_code);
			call check_wdir_code;
		     end;
		if pit_pointer -> pit.abs_queue = -1
		then /* interactive */
		     listener = listen_;
		else listener = absentee_listen_;

		call listener (initial_command_line);
	     end;

/* We should never return here */
	call terminate ("fatal_error", "Process overseer or listener returned.", error_table_$termination_requested);
%page;
worker_procedures:					/* Never Call at this entrypoint */
     procedure options (non_quick);

/* We declare all things used by the entries in this internal proc here */
/* (Note: some/many of these may be better off in the main proc, LAN */

/* Automatic */
	dcl     (
	        io_module		 character (32),
	        po_ptr		 ptr
	        )			 automatic;

/* Automatic Structures */
	dcl     1 term_structure	 aligned automatic, /* action to take upon process termination */
		2 version		 fixed bin init (0),/* version of structure */
		2 status_code	 fixed bin (35);	/* fatal error code */

/* Entries */
	dcl     cu_$make_entry_value	 entry (ptr, entry);
	dcl     dm_misc_util_$shutdown_handler
				 entry ();
	dcl     find_command_$fc_no_message
				 entry (ptr, fixed bin, ptr, fixed bin (35));
	dcl     get_pdir_		 entry () returns (char (168));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     hcs_$make_entry	 entry (ptr, char (*), char (*), entry, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     iox_$init_standard_iocbs
				 entry;
	dcl     pl1_resignaller_$establish_handlers
				 entry;
	dcl     sct_manager_$set	 entry (fixed bin, entry, fixed bin (35));
	dcl     sus_signal_handler_	 entry;
	dcl     system_shutdown_handler_
				 entry ();
	dcl     term_signal_handler_	 entry;
	dcl     terminate_process_	 ext entry (char (*), ptr);
	dcl     timer_manager_$alarm_interrupt
				 entry;
	dcl     timer_manager_$cpu_time_interrupt
				 entry;
	dcl     wkp_signal_handler_	 entry;

/* Entry (variable) */
	dcl     entry		 entry variable;
	dcl     po		 entry variable;	/* for find_process_overseer */

/* Parameters */
	dcl     (
	        code		 fixed bin (35),
	        fatal_code		 fixed bin (35),	/* code indicating fatal error */
	        pit_ptr		 pointer,
	        real_why		 character (*),	/* debugging info on stack */
	        sys_why		 char (*)		/* arg for terminate_process */
	        )			 parameter;

find_default_handler:
     entry (entry, code);

	call hcs_$make_entry (null (), "default_error_handler_", "wall", entry, code);
	return;
%page;
establish_static_handlers:
     entry (code);

	code = 0;
	call pl1_resignaller_$establish_handlers;
	call sct_manager_$set (cput_sct_index, timer_manager_$cpu_time_interrupt, (0));
	call sct_manager_$set (alrm_sct_index, timer_manager_$alarm_interrupt, (0));
	call sct_manager_$set (term_sct_index, term_signal_handler_, (0));
	call sct_manager_$set (wkp_sct_index, wkp_signal_handler_, (0));
	call sct_manager_$set (susp_sct_index, sus_signal_handler_, (0));
	call sct_manager_$set (system_shutdown_scheduled_sct_index, system_shutdown_handler_, (0));
	call sct_manager_$set (dm_shutdown_scheduled_sct_index, dm_misc_util_$shutdown_handler, (0));
	call sct_manager_$set (system_message_sct_index, system_message_handler_, (0));
	return;
%page;
get_pit_pointer:
     entry (pit_ptr, code);


	pit_ptr = null ();
	code = 0;

/* We leave the pit in the address space to avoid the need for multiple
   initiations/static pointers in user info */

	call hcs_$initiate (get_pdir_ (), "pit", "pit_", (0), (0), pit_ptr, code);
						/* get pointer to the PIT */
	if pit_ptr ^= null ()
	then code = 0;
	return;
%page;
init_iox:
     entry (pit_ptr, code);

	call iox_$init_standard_iocbs;		/* will terminate process if it cant do */

	code = 0;
	io_module = pit_ptr -> pit.outer_module;	/* Get DIM name */

	call iox_$attach_ptr (iox_$user_io, io_module || " -login_channel", null (), code);
	if code = 0
	then call iox_$open (iox_$user_io, Stream_input_output, "0"b, code);
	return;
%page;
find_process_overseer:
     entry (pit_ptr, po, code);

/* Use find_command_ cause cv_entry is not on the tape */

	call find_command_$fc_no_message (addr (pit_ptr -> pit.login_responder),
	     length (pit_ptr -> pit.login_responder), po_ptr, code);
	if code ^= 0
	then do;
		call ioa_ ("Could not find specified initial procedure: ^a", pit_ptr -> pit.login_responder);
		return;
	     end;
	call cu_$make_entry_value (po_ptr, po);
	return;
%page;
terminate:
     entry (sys_why, real_why, fatal_code);

	term_structure.status_code = fatal_code;	/* transmit code to terminate routine */
	call terminate_process_ (sys_why, addr (term_structure));
						/* terminate the process */

/* terminate must fall through to enable_quits */

enable_quits:
     entry;
	call iox_$control (iox_$user_io, "quit_enable", null (), (0));
	return;
     end worker_procedures;
%page;
primitive_handler:
     procedure options (non_quick);			/* Before DEH */

	dcl     find_condition_info_	 entry (pointer, pointer, fixed binary (35));
	dcl     1 CI		 aligned like condition_info;
	dcl     code		 fixed bin (35);

	on any_other call terminate_minus_2;

	call find_condition_info_ (null (), addr (CI), code);
	if code ^= 0
	then call terminate ("init_error", "Mysterious Fault", code);

	if CI.mc_ptr ^= null ()
	then call terminate ("init_error", (CI.condition_name), (CI.mc_ptr -> mc.errcode));
	else call terminate ("init_error", (CI.condition_name), (0));
	call terminate_minus_2;			/* What else do to? */

     end primitive_handler;

terminate_minus_2:
     procedure options (non_quick);

	dcl     sptr		 pointer;
	dcl     shiva		 bit (36) aligned based (sptr);
						/* "... death, the destroyer of worlds..." */

	sptr = pointer (baseptr (-2), -2);
	shiva = "666666"b3;				/* A beastly fate */
     end terminate_minus_2;

check_wdir_code:
     procedure;

	if wdir_code ^= 0
	then call com_err_ (wdir_code, "initialize_process_", "Could not set working directory to home directory ^a.",
		pit_pointer -> pit.homedir);
     end check_wdir_code;
%page;
%include condition_info;
%page;
%include iox_entries;
%page;
%include iox_modes;
%page;
%include mc;
%page;
%include pit;
%page;
%include static_handlers;
%page;
%include user_attributes;

     end initialize_process_;




		    print_abs_msg_.pl1              10/15/84  1047.7rew 10/15/84  1024.0       34704



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


/* format: style2 */
/* First thusly manifested at some unknown time, courtesy of some masked (and wired) man -- probably BIM. */
/* Fixed to rtrim its control strings, to prevent trailing space in absouts 09/15/82 S. Herbst */
/* Modified October 1982 by E. N. Kittlitz to print absentee request id */
/* Modified June 1984 by J A Falksen to utilize date_time_$format("date_time",... */

print_abs_msg_:
print_abs_logout_msg_:
     procedure;					/* synonym for logout */


	dcl     request_id		 fixed bin (71);
	dcl     time		 char (64)var;
	dcl     person		 char (22);
	dcl     project		 char (9);
	dcl     login_time		 fixed bin (71);
	dcl     (mins, secs)	 fixed bin (35);
	dcl     minstring		 char (16);
	dcl     anonymous		 fixed bin;	/* = 1 if this is an anonymous process */

	dcl     date_time_$format	 entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
	dcl     (
	        ioa_$ioa_switch,
	        ioa_$rsnnl
	        )			 entry options (variable);
	dcl     hcs_$get_process_usage entry (ptr, fixed bin (35));
	dcl     request_id_ entry (fixed bin(71)) returns(char(19));
	dcl     user_info_$absentee_request_id entry (fixed bin (71));
	dcl     user_info_$login_data	 entry options (variable);

	dcl     logout_control	 char (120) aligned static options (constant)
				 init (
				 "^/^[A^;Anonymous a^]bsentee user ^a ^a logged out ^a^/CPU usage ^a, memory usage ^.1f units"
				 );

	dcl     login_control	 char (120) aligned static options (constant)
				 init ("^/^[A^;Anonymous a^]bsentee user ^a ^a logged in: ^a, request_id: ^a");

	dcl     1 data,				/* filled in by hcs_$get_process_usage */
		2 wanted		 fixed bin,
		2 can_get		 fixed bin,
		2 cpu_usage	 fixed bin (71),
		2 memory		 fixed bin (71),
		2 demand_page	 fixed bin (35),
		2 pre_page	 fixed bin (35),
		2 virtual_cpu	 fixed bin (71);

dcl  iox_$user_io ptr ext static;

dcl (addr, clock, divide, float, mod, rtrim) builtin;
%page;
logout:
     entry;
	call user_info_$login_data (person, project, (""), anonymous);
	data.wanted = 5;
	call hcs_$get_process_usage (addr (data), (0));	/* get data for logout message */
	secs = float (data.virtual_cpu, 63) / 1e6 + .5e0; /* convert microseconds to seconds, rounded */
	data.memory = float (data.memory, 63) / 1e3;	/* convert memory units to kilomemory units */
	if secs >= 60
	then do;					/* must print out minutes */
		mins = divide (secs, 60, 35, 0);	/* calculate minutes */
		secs = mod (secs, 60);		/* calculate remaining seconds */
		call ioa_$rsnnl ("^d min ^d sec", minstring, (0), mins, secs);
	     end;
	else do;					/* need seconds only */
		call ioa_$rsnnl ("^d sec", minstring, (0), secs);
	     end;
	time = date_time_$format ("date_time",clock (),"","");   /* get time */
	call ioa_$ioa_switch (iox_$user_io, rtrim (logout_control), (anonymous ^= 1), person, project, time, minstring, data.memory);  
						/* print absentee logout message */

	return;

login:
     entry;

	call user_info_$login_data (person, project, "", anonymous, (0), (0), login_time);
	call user_info_$absentee_request_id (request_id);

	time = date_time_$format ("date_time",login_time,"","");
	call ioa_$ioa_switch (iox_$user_io, rtrim (login_control), (anonymous ^= 1), person, project, time, request_id_ (request_id));
						/* recurse to put out the chars */
	return;

     end print_abs_logout_msg_;




		    process_overseer_.pl1           07/13/88  1120.8r w 07/13/88  0935.4       69309



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

/* format: style2 */
process_overseer_:
     procedure (a_pit_ptr, call_listen_, initial_command_line);


/* Completely rewritten as part of the redesign of user ring process initialization
   and the standard command environment by V. Voydock on November 1, 1970 */

/* Modified to be upward compatible with new pit format on January 4, 1970 by R. J. Feiertag */
/* Modified to pass to start_up.ec an argument indicating whether process is interactive or absentee */
/* by E. Stone May 25, 1971 */
/* Modified to not put quotes around homedir in initial command line by V. Voydock
   in June 1971 */
/* Modified to have option to not restore io attachments after a "start" command, and to
   reset the mode of user_i/o to the default after a quit or unclaimed signal
   by V. Voydock in July 1971 */
/* Modified by R. J. Feiertag on February 4, 1972 to add default handlers, saving of IO devices
   other than syn, and checking the brief and no_startup flags. */
/* Modified by V. Voydock in May 1972 to complete installation of default handlers, and
   (for efficienty) change program to accept a pointer to the pit as an arg, and
   to do all its work in internal procedures to minimize permanent stack storage */
/*	Modified by E. Stone 5/74 to convert to version 2 */
/*	6/75	by S. Webber to remove code which sets up handlers for "cput" and "alrm" */
/*        3/77      by D. M. Wells to also distinguish interactive and initializer processes */
/*	8/77	by S. Webber to change standard_default_handler_ to default_error_handler_$wall */
/*       11/78      by J. Davis to do MCR3388: handler for mme2 calls debug,. Also remove unused vars */
/*	11/78	by W. Olin Sibert to add call to command_query_$set_cp_escape_enable 
	4/79	by B. Margulies to search for start_up, flush motd, and generally clean up
	12/81	by E. N. Kittlitz to call sus_signal_handler_$reconnect_ec_enable.
          12/81     by B. Margulies for new initialize_process_ calling sequence
		of process overseers; the call_listen_ flag replaces
		the need to stay on the stack and call listen_.
*/

/*

process_overseer_ is the standard process overseer on the system. It has four
responsibilities:
setting up an unclaimed signal handler, otherwise known as an any_other 
handler. This handler catched otherwise uncaught conditions. The supplied
handler, default_error_handler_$wall prints any message provided for
the error condition, establishes a condition wall, and calls the listener to
get a new listener level. A condition wall is just another any_other handler;
this intercepts conditions that might otherwise be caught by other 
handlers present on the stack. 

setting up a static handler for the mme2 condition. The mme2 condition
is raised when the mme2 instruction is executed. It is used by debug to 
establish breakdots. The handler  transfers control to debug when
the condition is signalled.

allowing the ".." excape to command query. This is enabled by calling 
command_query_$set_cp_excape with the appropriate bits.

finding the start_up.ec. It looks in the homedir, projectdir, and finally 
>sc1 to try to find it. It ends by calling listen_ with "ec start_upName"
as the initial command line.

The code is written for time rather than space efficiency, so that
operations that might look prettier in a do loop are done with inline code.
*/

/* Parameters */

	dcl     initial_command_line	 char (*) varying;
	dcl     a_pit_ptr		 ptr;
	dcl     call_listen_	 bit (1) aligned;


/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     bc		 fixed bin (24);
	dcl     entry_type		 fixed bin (2);
	dcl     first_process	 bit (1);

/* Constants */

	dcl     process_type	 (0:3) character (12) varying internal static options (constant)
				 initial ("initializer", "interactive", "absentee", "daemon");
	dcl     down_sc1		 char (4) internal static options (constant) init (">sc1");
	dcl     start_up_dot_ec	 char (11) internal static options (constant) init ("start_up.ec");

/* Entries */

	dcl     condition_		 entry (char (*), entry);
	dcl     command_query_$set_cp_escape_enable
				 entry (bit (1) aligned, bit (1) aligned);
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     sct_manager_$set	 entry (fixed bin, ptr, fixed bin (35));
	dcl     process_overseer_$mme2_fault_handler_
				 entry (ptr, char (*), ptr, ptr, bit (1));
	dcl     sus_signal_handler_$reconnect_ec_enable
				 entry;

/* External variables */

	dcl     iox_$user_output	 ptr ext;

/* Builtins */

	dcl     (codeptr, divide, null, rtrim)
				 builtin;

%include pit;
%include static_handlers;
%include user_attributes;

	pit_ptr = a_pit_ptr;
	initial_command_line = "";			/* turn on ".." */

	call command_query_$set_cp_escape_enable ("1"b, (""b));

	first_process = (pit_ptr -> pit.n_processes = 1); /* see if new_proc or login */

	if ^pit_ptr -> pit.at.nostartup
	then do;					/* start_up is allowed */
		initial_command_line = "exec_com ";

/* First try homedir */

		call hcs_$status_minf (pit.homedir, start_up_dot_ec, 1, entry_type, bc, code);

/* note that we assume any error is cause to look elsewhere to give best chance
    of success */

		if code = 0 & entry_type = 1
		then initial_command_line = initial_command_line || rtrim (pit_ptr -> pit.homedir);

/* now try projectdir */

		else do;
			call hcs_$status_minf (">udd>" || rtrim (pit_ptr -> pit.project), start_up_dot_ec, 1,
			     entry_type, bc, code);

			if code = 0 & entry_type = 1
			then initial_command_line =
				initial_command_line || ">udd>" || rtrim (pit_ptr -> pit.project);
			else do;
				call hcs_$status_minf (down_sc1, start_up_dot_ec, 1, entry_type, bc, code);
				if code = 0 & entry_type = 1
				then initial_command_line = initial_command_line || down_sc1;
				else goto no_start_up;
			     end;
		     end;

		initial_command_line = initial_command_line || ">";
		initial_command_line = initial_command_line || start_up_dot_ec;
						/* the piecemeal assemble makes faster code */

		if first_process
		then initial_command_line = initial_command_line || " login ";
		else initial_command_line = initial_command_line || " new_proc ";

		initial_command_line = initial_command_line || process_type (pit_ptr -> pit.process_type);
	     end;					/* the block that checked pit.nostart*/

no_start_up:					/* set up the mme2 handler */
						/* this is done here rather than in initialize_process_ so that process
   overseers for limited subsystems can leave it out */
	call sct_manager_$set (mme2_sct_index, codeptr (process_overseer_$mme2_fault_handler_), code);
	call sus_signal_handler_$reconnect_ec_enable;

	call_listen_ = "1"b;			/* let initialize_process_ do the work */

	return;
%page;

mme2_fault_handler_:
     entry (mcp, cname, cop, infop, cont);
	dcl     (
	        mcp		 ptr,		/* to machine conditions */
	        cname		 char (*),	/* name of condition being signalled */
	        cop		 ptr,
	        infop		 ptr,
	        cont		 bit (1)
	        )			 parameter;

	dcl     debug$mme2_fault	 entry (ptr);

	call debug$mme2_fault (mcp);
	cont = "0"b;				/* do not continue searching for handlers */
	return;
     end process_overseer_;




		    project_start_up_.pl1           07/13/88  1120.8r w 07/13/88  0935.4       68958



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


/* format: style2 */
project_start_up_:
     procedure (a_pit_ptr, just_call_listen_, initial_command_line);
	dcl     a_pit_ptr		 ptr;
	dcl     just_call_listen_	 bit (1) aligned;
	dcl     initial_command_line	 character (*) varying;

/* 
Coded 4/79 by B. Margulies; diverged from process_overseer_
Modified 7/11/79 B. Margulies to revert the command_error handler *blush*
Modified May 1981 B. Margulies for argument bug fix. 
Modified 1 August 1981 B. Margolin [sic] & J. Pattin to fix any_other handler.
Modified 11 August 1981 by B Margulies for missing rtrim of project dir 
Modified 12/81 B Margulies for new calling seq, uninitialized initial command line */


	dcl     terminate_process_	 entry (char (*), ptr);
	dcl     hcs_$fs_search_set_wdir
				 entry (char (*), fixed bin (35));
	dcl     com_err_		 entry () options (variable);
	dcl     ioa_$ioa_switch	 entry options (variable);


%page;
%include iox_dcls;


/* Automatic */

	dcl     saved_cl_intermediary	 entry variable;
	dcl     project_dir		 char (168);
	dcl     mme2_handler	 ptr;
	dcl     saved_mme2_handler	 ptr;
	dcl     ps_ec_cl		 character (256) aligned;
	dcl     code		 fixed bin (35);
	dcl     bc		 fixed bin (24);
	dcl     entry_type		 fixed bin (2);
	dcl     first_process	 bit (1);
	dcl     (first_ec_arg, second_ec_arg)
				 char (12);

/* Constants */

	dcl     process_type	 (0:3) character (12) internal static options (constant)
				 initial ("initializer", "interactive", "absentee", "daemon");
	dcl     down_sc1		 char (19) internal static options (constant) init (">system_control_dir");
	dcl     start_up_dot_ec	 char (11) internal static options (constant) init ("start_up.ec");

/* Entries */

	dcl     cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));
	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
	dcl     command_query_$set_cp_escape_enable
				 entry (bit (1) aligned, bit (1) aligned);

	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     sct_manager_$set	 entry (fixed bin, ptr, fixed bin (35));
	dcl     sct_manager_$get	 entry (fixed bin, ptr, fixed bin (35));
	dcl     process_overseer_$mme2_fault_handler_
				 entry (ptr, char (*), ptr, ptr, bit (1));
	dcl     cu_$set_cl_intermediary
				 entry (entry);
	dcl     cu_$get_cl_intermediary
				 entry (entry);

/* Conditions */

	dcl     command_error	 condition;


/* Builtins */

	dcl     (addr, codeptr, length, null, rtrim, unspec)
				 builtin;

%include pit;
%include user_attributes;
%include static_handlers;


	initial_command_line = "";
	pit_ptr = a_pit_ptr;

	project_dir = ">user_dir_dir>" || rtrim (pit_ptr -> pit.project);



/* the handler is saved to make the code independent of the representation
of a nonexistant handler. It is checked at all so that project start ups can
set up a handler that doesnt call debug */

	call sct_manager_$get (mme2_sct_index, saved_mme2_handler, (0));

	call hcs_$status_minf (project_dir, "project_start_up.ec", 1, entry_type, bc, code);
	if ^(entry_type = 1 & code = 0)
	then call abort_handler (rtrim (project_dir) || ">project_start_up.ec was not found or is not a segment.", code)
		;


	call hcs_$fs_search_set_wdir (project_dir, code);
	if code ^= 0
	then call abort_handler ("Could not set working directory to project directory.", code);

	first_process = (pit_ptr -> pit.n_processes = 1); /* see if new_proc or login */

	if first_process
	then first_ec_arg = "login";
	else first_ec_arg = "new_proc";		/* since the strings arent quoted, the leading and trailing spaced shouldnt bother
the exec_com */

	second_ec_arg = process_type (pit_ptr -> pit.process_type);

/* set up the standard any other handler. use make_entry with null refptr
 so that project can have own default error handler */

	call cu_$get_cl_intermediary (saved_cl_intermediary);
	call cu_$set_cl_intermediary (error_handler);

	on command_error call com_err_handler;		/* die on com_err */

	ps_ec_cl =
	     "exec_com " || rtrim (project_dir) || ">project_start_up " || rtrim (first_ec_arg) || " "
	     || rtrim (second_ec_arg);
	call cu_$cp (addr (ps_ec_cl), length (rtrim (ps_ec_cl)), (0));

	revert command_error;

	call cu_$set_cl_intermediary (saved_cl_intermediary);

	if pit_ptr -> pit.at.vinitproc
	then call hcs_$fs_search_set_wdir (pit_ptr -> pit.homedir, (0));

/* enable ".."*/
	call command_query_$set_cp_escape_enable ("1"b, (""b));



	if ^pit_ptr -> pit.at.nostartup
	then do;					/* start_up is allowed */
		initial_command_line = "exec_com ";

/* First try homedir */

		call hcs_$status_minf (pit.homedir, start_up_dot_ec, 1, entry_type, bc, code);

/* note that we assume any error is cause to look elsewhere to give best chance
    of success */

		if code = 0 & entry_type = 1
		then initial_command_line = initial_command_line || rtrim (pit.homedir);

/* now try projectdir */

		else do;
			call hcs_$status_minf (project_dir, start_up_dot_ec, 1, entry_type, bc, code);

			if code = 0 & entry_type = 1
			then initial_command_line = initial_command_line || rtrim (project_dir);
			else do;
				call hcs_$status_minf (down_sc1, start_up_dot_ec, 1, entry_type, bc, code);
				if code = 0 & entry_type = 1
				then initial_command_line = initial_command_line || rtrim (down_sc1);
				else do;
					initial_command_line = "";
					goto no_start_up;
				     end;
			     end;
		     end;

		initial_command_line = initial_command_line || ">";
		initial_command_line = initial_command_line || start_up_dot_ec;
						/* the piecemeal assemble makes faster code */

		initial_command_line = initial_command_line || " " || first_ec_arg;

		initial_command_line = initial_command_line || " " || second_ec_arg;
	     end;					/* the block that checked pit.nostart*/

no_start_up:					/* set up the mme2 handler */
	call sct_manager_$get (mme2_sct_index, mme2_handler, (0));
	if mme2_handler = saved_mme2_handler
	then call sct_manager_$set (mme2_sct_index, codeptr (process_overseer_$mme2_fault_handler_), code);

	just_call_listen_ = "1"b;

	return;


com_err_handler:
     procedure;
%include condition_info_header;
%include condition_info;
%include com_af_error_info;

	declare 1 CI		 aligned like condition_info;
	declare find_condition_info_	 entry (pointer, pointer, fixed binary (35));
	declare code		 fixed bin (35);

	unspec (CI) = ""b;

	call find_condition_info_ (null (), addr (CI), code);
	if code ^= 0
	then call abort_handler ("Can't get error message.", code);
	call ioa_$ioa_switch (iox_$error_output, "^a", CI.info_ptr -> com_af_error_info.info_string);
	call abort_handler ("Error in project start up.", 0);
     end;

abort_handler:
     proc (reason, code) options (non_quick);

	dcl     code		 fixed bin (35);
	dcl     reason		 char (*);
	dcl     1 term_structure	 aligned,
		2 version		 fixed bin init (0),
		2 status_code	 fixed bin (35);

	status_code = code;
	call ioa_$ioa_switch (iox_$error_output, reason);
	call terminate_process_ ("init_error", addr (term_structure));
     end;

error_handler:
     entry;
	call abort_handler ("Error in project_start_up ec.", 0);

     end project_start_up_;




		    sus_signal_handler_.pl1         08/29/88  0938.9rew 08/29/88  0856.3      139347



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

/****^  HISTORY COMMENTS:
  1) change(86-01-17,Swenson), approve(86-07-31,MCR7443), audit(86-07-31,Wong),
     install(86-08-21,MR12.0-1137):
     Changed to allow the IPC wakeup which kicks the process into execution
     after a suspension to come from any process.  This is required so that the
     login server process can send the wakeup.  Since process suspension can be
     arbitrarily spoofed and replaced anyway, this presents no security
     problem.
  2) change(87-10-09,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
      A) Changed to call the term_signal_handler_ entrypoint of logout,
         rather than the logout entrypoint, when the no_save_on_disconnect
         command has been issued by the user.  Use of this command should
         cause terminal disconnections to be indistinguishable from the case
         in which the process does not have the save_on_disconnect attribute.
         In that case, dialup_ signals trm_ (instead of sus_) which invokes
         the term_signal_handler_.
                                                   END HISTORY COMMENTS */

/* format: style2 */
sus_signal_handler_:
     procedure;

/* Handler for ips signal "sus_". A process receiving this signal
   must suspend itself until the initializer signals it that it may run again.
   If it fails to respond within a site-settable real time interval, or
   uses more than a site-settable amount of cpu time while it is suspended,
   it will be destroyed.

   Throughout this procedure, we ignore all nonzero return codes, because we
have no way to report them.  If we're non-absentee, we most likely have no
terminal to print output on, and an error message would either go into the
bit bucket or cause a fatal I/O error in the process.  And whatever our
process type, we have a limited quota of cpu time to use while suspended, and
it would be unwise to waste it in calls to com_err_.

   Written by T. Casey, February 1979.
   Modified July 1979 by T. Casey for MR8.0 for suspension of interactive 
     processes whose terminals have hung up.
   Modified December 1980 by Benson I. Margulies to extend reconnection to 
     other io modules.
   Modified November 1981 by E. N. Kittlitz for terminal_reconnect.ec.
   Modified December 1983 by Jon A. Rochlis to try the "reconnection" control
     order on the -login_channel switch, and to put back the call to 
     user_info_$outer_module, removing special casing for tty_ and netd_.

   */

/* DECLARATIONS */

/* Internal static */

	dcl     all_name		 (1) char (32) int static options (constant) init ("-all");
						/* to turn on all ips's before signalling QUIT */
	dcl     reconnect_ec_entry	 char (32) int static options (constant) init ("reconnect.ec");

	dcl     trm_name		 (1) char (32) int static options (constant) init ("trm_");
						/* to mask off everything but trm_ */
	dcl     nosave_switch	 bit (1) aligned int static init (""b);

	dcl     ec_reconnect_switch	 bit (1) aligned int static init (""b);

%include condition_info;
%include condition_info_header;
%include quit_info;

	dcl     1 quit_info_struc	 aligned like quit_info;

	dcl     error_table_$unable_to_do_io
				 ext static fixed bin (35);

/* Automatic */

	dcl     all_mask		 bit (36) aligned;
	dcl     code		 fixed bin (35);
	dcl     logout_channel	 fixed bin (71);
	dcl     logout_pid		 bit (36);
	dcl     old_mask		 bit (36) aligned;	/* to save old ips mask, to put back when we unsuspend */
	dcl     process_type	 fixed bin (35);
	dcl     reconnect_ec_dir	 char (168);
	dcl     reconnect_command_line char (256);
	dcl     trm_mask		 bit (36) aligned;

%include event_wait_channel;
%include event_wait_info;

	dcl     1 auto_event_wait_info automatic aligned like event_wait_info;

	dcl     ec_entry_type	 fixed bin (2);

/* Ext Entries */

	dcl     create_ips_mask_	 entry (ptr, fixed bin, bit (36) aligned);
	dcl     cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));
	dcl     default_error_handler_$wall_ignore_pi
				 entry options (variable);
	dcl     hcs_$reset_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     hcs_$wakeup		 entry (bit (36), fixed bin (71), fixed bin (71), fixed bin (35));
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     ipc_$block		 entry (ptr, ptr, fixed bin (35));
	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$mask_ev_calls	 entry (fixed bin (35));
	dcl     ipc_$unmask_ev_calls	 entry (fixed bin (35));

	dcl     signal_		 entry () options (variable);
	dcl     term_signal_handler_	 entry options(variable);
	dcl     terminate_process_	 entry (char (*), ptr);
	dcl     user_info_		 entry (char (*), char (*), char (*));
	dcl     user_info_$homedir	 entry (char (*));
	dcl     user_info_$logout_data entry (fixed bin (71), bit (36));
	dcl     user_info_$process_type
				 entry (fixed bin (35));
	dcl     user_info_$outer_module
				 entry (char (*));

/* arg list is shortened to last interesting datum */
%page;
%include iox_entries;
%include iox_modes;
%page;
/* Conditions */

	dcl     any_other		 condition;

/* Builtins */

	dcl     (addr, codeptr, index, length, null, rtrim, size, string)
				 builtin;

/* PROCEDURE */

/* If user changed his mind about -save, we'll log out when we get the sus_ signal. */

	if nosave_switch
	then call term_signal_handler_();

/* Get our attach description for reattachment */

/* Mask off all ips signals except trm_ (this allows a suspended process that gets bumped to signal finish). */

	call create_ips_mask_ (addr (trm_name), (1), trm_mask);
						/* this makes a mask that disables only trm_ */
	trm_mask = ^trm_mask;			/* turn it into a mask that enables only trm_ */
	call hcs_$set_ips_mask (trm_mask, old_mask);

/* Mask off ipc event call wakeups */

	call ipc_$mask_ev_calls (code);

/* Create an event channel to block on */

	call ipc_$create_ev_chn (event_wait_channel.channel_id (1), code);

/* Tell answering service the channel id so it can wake us when it's ok to run again */

	call user_info_$logout_data (logout_channel, logout_pid);
						/* get channel and process id over which to signal a.s. */
	call hcs_$wakeup (logout_pid, logout_channel, event_wait_channel.channel_id (1), code);
						/* wakeup message is channel id */

/* Now, go blocked on that channel until the answering service says we may run again */

	auto_event_wait_info.sender = ""b;		/* so we can tell who sends the wakeup */
	call ipc_$block (addr (event_wait_channel), addr (auto_event_wait_info), code);

/* We returned from being blocked. We may run again. */

	call ipc_$delete_ev_chn (event_wait_channel.channel_id (1), code);
						/* clean up our ECT */

	on any_other call REAL_FAILURE (error_table_$unable_to_do_io, "Fault or error reconnecting terminal.");

/* What we do next depends on what kind of process we are. */

	call user_info_$process_type (process_type);	/* find out */

/* If we are absentee, we just return, to resume running. */

	if process_type = 2
	then do;
		call unmask_all;			/* unmask ips signals and ipc event call wakeups */
		return;
	     end;

/* Interactive or daemon */

/* Can't be daemon because the MR8.0 answering service never sends sus_ to
daemons.  So must be interactive.*/

/* Simulate the user hitting QUIT. */

/* We have a difficult problem here.  We would like to set a QUIT signal to
be pending, then unmask everything, and let the QUIT and any other signals or
wakeups go off in whatever order the system wants them to.  But if we unmask
ips signals first, we are very likely to get one before we can signal QUIT.
Or, if we signal QUIT with a signal statement first, we will probably get to
command level with ips signals and ipc event call wakeups masked off, which
is not a good environment in which to leave the user.  Since ipc wakeups will
not happen until we go blocked, it is safe to unmask them just before
signalling QUIT.  And, since the ips signals most likely to occur are cput
and alrm, it is probably ok to let them happen before we signal QUIT.  So, we
unmask and then immediately signal QUIT, and hope for the best.  But first,
take care of a few details.  */


	call reattach_user_channel;			/* redo iox_ attachments */

/* Turn on the new terminal's QUIT button, while we still have control */

	call iox_$control (iox_$user_io, "quit_enable", null (), code);

	call ioa_$ioa_switch (iox_$user_io, "Wait for QUIT.");
						/* tell user not to get impatient */
	quit_info_struc.length = size (quit_info_struc);	/* set up QUIT info structure */
	quit_info_struc.version = 1;
	quit_info_struc.action_flags = ""b;		/* no special action */
	quit_info_struc.info_string = "";
	quit_info_struc.status_code = 0;
	string (quit_info_struc.switches) = ""b;	/* ips_quit, reset_write = "0"b */
	quit_info_struc.switches.reconnection_quit = "1"b;/* but this is... */

/* Finally, we'll unmask and signal QUIT.
   In case the hangup happened while a nonstandard mask was in effect, we'll mask everything on
   before going to command level. This might cause problems in some rare cases, but it would be
   a lot worse to put a user at command level with all ips signals masked off. If he
   released in those circumstances, the ips signals would never get masked on again. */

	call create_ips_mask_ (addr (all_name), (1), all_mask);
						/* get mask that disables all ips signals */
	all_mask = ^all_mask;			/* turn it into one that enables all ips signals */
	call unmask_all;				/* for ipc and crit bit */
	call hcs_$set_ips_mask (all_mask, (""b));

	if ec_reconnect_switch
	then do;
		call user_info_$homedir (reconnect_ec_dir);
		call hcs_$status_minf (reconnect_ec_dir, reconnect_ec_entry, 1, ec_entry_type, (0), code);
		if code ^= 0 | ec_entry_type ^= 1
		then do;
			call user_info_ ((""), reconnect_ec_dir, (""));
			reconnect_ec_dir = ">udd>" || rtrim (reconnect_ec_dir);
			call hcs_$status_minf (reconnect_ec_dir, reconnect_ec_entry, 1, ec_entry_type, (0), code);
			if code ^= 0 | ec_entry_type ^= 1
			then do;
				reconnect_ec_dir = ">system_control_dir";
				call hcs_$status_minf (reconnect_ec_dir, reconnect_ec_entry, 1, ec_entry_type,
				     (0), code);
				if code ^= 0 | ec_entry_type ^= 1
				then go to no_reconnect_ec;
			     end;
		     end;
		on any_other call default_error_handler_$wall_ignore_pi;
		reconnect_command_line = "exec_com " || rtrim (reconnect_ec_dir) || ">" || reconnect_ec_entry;
		call cu_$cp (addr (reconnect_command_line), length (reconnect_command_line), code);
		if code ^= 0
		then call ioa_$ioa_switch (iox_$user_io, "sus_signal_handler_: Unable to invoke ^a.",
			reconnect_ec_entry);
	     end;

no_reconnect_ec:
	revert any_other;
	call signal_ ("quit", null (), addr (quit_info_struc), null ());

/* If the QUIT handler returns, the user probably said start. So we'll return to the procedure
   that was interrupted by the sus_ signal. */


	call iox_$control (iox_$user_io, "start", null (), code);
						/* in case it hung up while we were in the tty_ dim */

	call hcs_$reset_ips_mask (old_mask, (""b));	/* put back mask that was in effect at time of hangup */

	return;


unmask_all:
     proc;					/* to unmask ipc event calls and ips signals */

	call ipc_$unmask_ev_calls (code);
	call hcs_$reset_ips_mask (old_mask, (""b));	/* tell hardcore that we have stopped changing the mask */
	return;

     end unmask_all;


/* The following two entry points allow a user who specified -save at login time (or who gets -save by default)
   to change his mind, repeatedly. Note that a user who doesn't log in with -save can not change his mind. */

no_save_on_disconnect:
     entry;

	nosave_switch = "1"b;
	return;

save_on_disconnect:
     entry;

	nosave_switch = ""b;
	return;


/* The following four entry points are used to control the execution
   of an exec_com following reconnection.  The process may disable/enable
   the execution of the exec_com, and may establish the any_other handler
   which will be used when the exec_com is being interpreted. */


reconnect_ec_disable:
     entry;

	ec_reconnect_switch = "0"b;
	return;


reconnect_ec_enable:
     entry;

	ec_reconnect_switch = "1"b;
	return;


/* Brains of this act. This procedure reconnects switches attached
   with -login_channel */

reattach_user_channel:
     procedure;

%include iocb;
	declare 1 IOCB		 aligned based (iocbp) like iocb;
	declare iocbp		 pointer;
	declare 1 atd		 aligned based (IOCB.attach_descrip_ptr),
		2 len		 fixed bin (21),
		2 attach_description char (0 refer (atd.len));
	declare outer_module	 char (32);
	declare ix		 fixed bin;
	declare code		 fixed bin (35);
	declare new_atd		 char (64);


/* all attachments must be -login_channel to be noticed by this code */

	outer_module = "";
	call user_info_$outer_module (outer_module);

	new_atd = rtrim (outer_module) || " -login_channel";

	code = 0;

	do ix = 1 repeat (1 + ix);			/* checkout all switches */
	     code = 0;
	     call iox_$find_iocb_n (ix, iocbp, code);
	     if code ^= 0
	     then goto NO_MORE_SWITCHES;
	     if iocbp = IOCB.actual_iocb_ptr
	     then if IOCB.attach_descrip_ptr ^= null ()
		then do;
			if index (attach_description, "-login_channel") > 0
			then do;
				call iox_$control (iocbp, "reconnection", null (), code);
						/* for touchier io modules, ala window_io_/tc_io_ */
				if code = 0
				then goto RECONNECTED;
				call iox_$close (iocbp, code);
				if code ^= 0
				then call REAL_FAILURE (code, "Closing switch " || IOCB.name);
				call iox_$detach_iocb (iocbp, code);
				if code ^= 0
				then call REAL_FAILURE (code, "Detaching switch " || IOCB.name);
				call iox_$attach_ptr (iocbp, rtrim (new_atd), codeptr (sus_signal_handler_), code)
				     ;
				if code ^= 0
				then call REAL_FAILURE (code,
					"Reattaching switch " || IOCB.name || " " || rtrim (new_atd));
				call iox_$open (iocbp, Stream_input_output, ""b, code);
				if code ^= 0
				then call REAL_FAILURE (code, "Opening switch " || IOCB.name);
				go to RECONNECTED;
			     end;
		     end;
	end;

NO_MORE_SWITCHES:					/* we hope for the best */
RECONNECTED:
	return;
     end reattach_user_channel;

REAL_FAILURE:
     procedure (code, reason) options (non_quick);

	dcl     code		 fixed bin (35);
	dcl     reason		 char (*);
	dcl     1 terminate_info	 aligned,
		2 version		 fixed bin,
		2 fatal_code	 fixed bin (35);

	terminate_info.version = 0;
	terminate_info.fatal_code = code;
	call terminate_process_ ("fatal_error", addr (terminate_info));
     end REAL_FAILURE;

     end sus_signal_handler_;




		    system_message_handler_.pl1     08/04/87  1531.6rew 08/04/87  1221.5       68220



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

/****^  HISTORY COMMENTS:
  1) change(85-11-27,Herbst), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     New program.
  2) change(85-12-19,Herbst), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Fixed to free all read messages, moved asum handle to
     user_message_handles.incl.pl1
  3) change(87-01-27,Brunelle), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Changed to use user_message_$read_message instead of
     as_user_message_$user_read_message.  Changed to send messages to the user
     via the message facility if at all possible.  Also to send message to
     initializer if an INACTIVITY message was received.
  4) change(87-04-20,Brunelle), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Add call to iox_$control to "start" I/O on the channel again.
  5) change(87-04-22,Brunelle), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Removed all use of message facility, instead, just sending message
     directly to user_i/o.
  6) change(87-07-23,Brunelle), approve(87-07-23,MCR7697),
     audit(87-07-23,GDixon), install(87-08-04,MR12.1-1055):
     Remove window in the freeing of message in cleanup handler and general
     minor cleanup.
                                                   END HISTORY COMMENTS */

/* format: style4 */

system_message_handler_: proc ();

/* Static handler for all system messages, those accompanied by the
   system_message_ IPS signal.  This program reads all pending system
   messages from the user_message_ facility and performs an appropriate
   action for each.

   Currently, there are two kinds of system messages supported, both from
   the Answering Service: warning and inactivity messages.

   Each is displayed on user_i/o.
*/

/* External */

dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$user_io ptr external;

/* Entries */

dcl  get_group_id_ entry () returns (char (32));
dcl  get_process_id_ entry () returns (bit (36));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ioa_$ioa_switch entry options (variable);
dcl  ioa_$rsnpnnl entry () options (variable);
dcl  user_info_$logout_data entry options (variable);
dcl  user_message_$read_message entry (ptr, ptr, fixed bin (35));

dcl  cleanup condition;

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

/* Internal Static */

dcl  system_area_ptr ptr int static init (null);

/* Based */

dcl  event_message_string char (8) aligned based (event_message_ptr); /* char string variable for event message */
dcl  system_area area based (system_area_ptr);

/* Automatic */

dcl  code fixed bin (35);				/* general error code */
dcl  event_message fixed bin (71);			/* event message for answering service */
dcl  event_message_ptr ptr;				/* ptr to event message */
dcl  inactivity_msg_rcvd bit (1);			/* set on if we process an inactivity warn message */
dcl  logout_channel fixed bin (71);			/* logout channel to initializer */
dcl  logout_pid bit (36) aligned;			/* process ID if initializer */
dcl  output_message char (1024);			/* message to user */
dcl  output_message_length fixed bin (21);		/* and length of same */

dcl  1 auto_asum_info aligned like as_user_message_info;
%page;
	if system_area_ptr = null then
	     system_area_ptr = get_system_free_area_ ();

	system_message_ptr = null;
	inactivity_msg_rcvd = "0"b;

	unspec (auto_asum_info) = "0"b;
	auto_asum_info.version = AS_USER_MESSAGE_INFO_VERSION_1;
	auto_asum_info.message_handle = SYSTEM_MESSAGE_HANDLE;
	auto_asum_info.destination_info.group_id = get_group_id_ ();
	auto_asum_info.destination_info.process_id = get_process_id_ ();

	on cleanup begin;
	     if auto_asum_info.message_ptr ^= null then
		call FREE_MESSAGE ();
	     if inactivity_msg_rcvd then
		call SEND_RESPONSE_TO_INITIALIZER ();
	end;

	do while ("1"b);

	     call GET_MESSAGE ();

	     if system_message.type = SYSTEM_MESSAGE_TYPE_AS_WARN then do;
		call ioa_$rsnpnnl ("^[^a: ^;^s^]^a",
		     output_message, output_message_length,
		     warn_system_message.caller ^= "", warn_system_message.caller,
		     warn_system_message.text);
	     end;
	     else if system_message.type = SYSTEM_MESSAGE_TYPE_AS_INACTIVITY then do;
		inactivity_msg_rcvd = "1"b;		/* remember we have to respond */
		call ioa_$rsnpnnl ("^[^a: ^;^s^]^a",
		     output_message, output_message_length,
		     inactivity_system_message.caller ^= "", inactivity_system_message.caller,
		     inactivity_system_message.text);
	     end;
	     else if system_message.type = SYSTEM_MESSAGE_TYPE_DM_SHUT then do;
						/* not currently used */
		call ioa_$rsnpnnl ("^[^a: ^;^s^]^a",
		     output_message, output_message_length,
		     dm_shut_system_message.caller ^= "", dm_shut_system_message.caller,
		     dm_shut_system_message.text);
	     end;

	     call FREE_MESSAGE ();

/* display message on user's screen */
	     call ioa_$ioa_switch (iox_$user_io,
		substr (output_message, 1, output_message_length));
	end;
RETURN:

/* make sure we restart all I/O again */
	call iox_$control (iox_$user_io, "start", null (), code);

/* if any of the messages were for inactivity, inform Initializer we are done */
	if inactivity_msg_rcvd then do;
	     call SEND_RESPONSE_TO_INITIALIZER ();
	end;

	return;
%page;
FREE_MESSAGE: proc;

dcl  based_message (auto_asum_info.message_length) fixed bin (35) based (auto_asum_info.message_ptr);

	free based_message in (system_area);
	auto_asum_info.message_ptr = null;

     end FREE_MESSAGE;
%page;
GET_MESSAGE: proc ();

	do while ("1"b);

	     auto_asum_info.message_ptr = null;
	     call user_message_$read_message (system_area_ptr, addr (auto_asum_info), code);
	     if code ^= 0 then go to RETURN;

	     system_message_ptr = auto_asum_info.message_ptr;

	     if system_message.version = SYSTEM_MESSAGE_VERSION_1 then do;

		if system_message.type = SYSTEM_MESSAGE_TYPE_AS_WARN then do;
		     if system_message.type_version = SYSTEM_MESSAGE_AS_WARN_V1 then return;
		end;

		else if system_message.type = SYSTEM_MESSAGE_TYPE_AS_INACTIVITY then do;
		     if system_message.type_version = SYSTEM_MESSAGE_AS_INACTIVITY_V1 then return;
		end;

		else if system_message.type = SYSTEM_MESSAGE_TYPE_DM_SHUT then do;
		     if system_message.type_version = SYSTEM_MESSAGE_DM_SHUT_V1 then return;
		end;
	     end;

	     else call FREE_MESSAGE ();
	end;

     end GET_MESSAGE;
%page;
SEND_RESPONSE_TO_INITIALIZER: proc ();

	event_message_ptr = addr (event_message);
	event_message_string = "inacrcvd";
	call user_info_$logout_data (logout_channel, logout_pid); /* get logout information */
	call hcs_$wakeup (logout_pid, logout_channel, event_message, code); /* send message to answering service */

     end SEND_RESPONSE_TO_INITIALIZER;
%page; %include as_user_message_info;
%page; %include system_message;
%page; %include user_message_handles;

     end system_message_handler_;




		    system_shutdown_handler_.pl1    10/04/84  0901.1rew 10/03/84  0935.4        7938



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

/* DESCRIPTION:
This is the default handler for the system_shutdown_scheduled_ IPS signal.
Currently this handler does nothing, it just returns.

This handler is used by both initialize_process_ for a normal user's
process and by sc_init_ for the Initializer's process.  If you change
this handler to actually do something you may want to make seperate
handlers for these two cases.
*/

/* HISTORY:
Written by R. Michael Tague, 8/23/84.
Modified:
*/

/* format: style5 */

system_shutdown_handler_:
     procedure ();
     return;

end system_shutdown_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
