



		    display_mc_anstbl.pl1           08/04/87  1456.8rew 08/04/87  1428.4      100143



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

/* 82-10-26 Written  E. N. Kittlitz */
/* Modified for oper info... -E. A. Ranzenbach */
/* Modified for iox_ BIM 1984-10-30 */

/****^  HISTORY COMMENTS:
  1) change(86-03-31,MSharpe), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek):
     Modified to recognize new mc_acte structure; to accept -pending & -p to
     print pending entries; to print pending entries, as well as active ones,
     by default.
  2) change(87-02-05,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek):
     Modified for change to mc_anstbl.incl.pl1.
                                                   END HISTORY COMMENTS */

/* format: style2 */
display_mc_anstbl:
     procedure options (variable);

	dcl     argc		 fixed bin;
	dcl     argl		 fixed bin (21);
	dcl     argn		 fixed bin;
	dcl     argp		 ptr;
	dcl     code		 fixed bin (35);
	dcl     dn		 char (168);
	dcl     en		 char (32);
	dcl     found_a_channel	 bit (1) aligned;
	dcl     header_sw		 bit (1) aligned;
	dcl     header_only_sw	 bit (1) aligned;
	dcl     mode		 fixed bin init (1);
	dcl     name_count		 fixed bin;
	dcl     name_error_printed_sw	 bit (1) aligned;
	dcl     names		 (100) char (32);
	dcl     octal_sw		 bit (1) aligned;
	dcl     path		 char (168);
	dcl     prev_argl		 fixed bin (21);
	dcl     prev_argp		 ptr;

	dcl     ME		 char (32) init ("display_mc_anstbl") static options (constant);

	dcl     arg		 char (argl) based (argp) unaligned;
	dcl     prev_arg		 char (prev_argl) based (prev_argp) unaligned;

	dcl     (addr, null, char, codeptr, environmentptr, hbound, rtrim, unspec)
				 builtin;

	dcl     cleanup		 condition;

	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     date_time_$format	 entry (character (*), fixed binary (71), character (*), character (*))
				 returns (character (250) var);
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     match_star_name_	 entry (char (*), char (*), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));

	dcl     error_table_$noarg	 fixed bin (35) ext static;
%page;
	mc_ansp = null;
	header_sw = "1"b;
	octal_sw = "0"b;
	header_only_sw = "0"b;
	path = "";
	mode = 1;
	name_error_printed_sw = "0"b;
	name_count = 0;

	on cleanup call clean_up;

	call cu_$arg_count (argc, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		go to exit;
	     end;

	do argn = 1 to argc;
	     call cu_$arg_ptr (argn, argp, argl, code);
	     if char (arg, 1) = "-"
	     then do;
		     if arg = "-all"
		     then mode = 0;
		     else if arg = "-a"
		     then mode = 0;
		     else if arg = "-pending"
		     then mode = 3;
		     else if arg = "-p"
		     then mode = 3;
		     else if arg = "-octal"
		     then octal_sw = "1"b;
		     else if arg = "-oc"
		     then octal_sw = "1"b;
		     else if arg = "-no_octal" | arg = "-noc"
		     then octal_sw = "0"b;
		     else if arg = "-no_header"
		     then header_sw = "0"b;
		     else if arg = "-nhe"
		     then header_sw = "0"b;
		     else if arg = "-header" | arg = "-he"
		     then header_sw = "1"b;
		     else if arg = "-header_only"
		     then header_only_sw = "1"b;
		     else if arg = "-pathname" | arg = "-pn"
		     then do;
			     if path ^= ""
			     then do;
				     call com_err_ (0, ME, "^a specified more than once.", arg);
				     return;
				end;
			     prev_argp = argp;
			     prev_argl = argl;
			     argn = argn + 1;
			     if argn > argc
			     then do;
missing_arg:
				     call com_err_ (error_table_$noarg, ME, "Following: ^a.", prev_arg);
				     return;
				end;
			     call cu_$arg_ptr (argn, argp, argl, code);
			     if char (arg, 1) = "-"
			     then go to missing_arg;
			     path = arg;
			end;
		     else if arg = "-active"
		     then mode = 1;
		     else if arg = "-entire"
		     then mode = 2;
		end;				/* -control_arg */
	     else do;				/* no leading -, call it a tty name */
		     if name_count >= hbound (names, 1)
		     then do;
			     if ^name_error_printed_sw
			     then do;
				     name_error_printed_sw = "1"b;
				     call com_err_ (0, ME,
					"More than ^d channel names specified. Starting with ""^a"", channel names ignored.",
					hbound (names, 1), arg);
				end;
			end;			/* too many names */
		     else do;			/* add name */
			     name_count = name_count + 1;
			     names (name_count) = arg;
			end;			/* add name */
		end;				/* non -control_arg */
	end;					/* argument processing loop */

	if path = ""
	then path = ">system_control_1>mc_anstbl";
	call expand_pathname_ (path, dn, en, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME, "^a", path);
		go to exit;
	     end;
	call initiate_file_ (dn, en, R_ACCESS, mc_ansp, (0), code);
	if mc_ansp = null
	then do;
		call com_err_ (code, ME, "^a", pathname_ (dn, en));
		go to exit;
	     end;

	call do_dump;

	if ^header_only_sw & ^found_a_channel
	then call com_err_ (0, ME, "No MC terminals ^[matched selection criteri^[on^;a^]^;found^].", (name_count > 0),
		(name_count = 1));

exit:
	call clean_up;
	return;


clean_up:
     proc;
	if mc_ansp ^= null
	then call terminate_file_ (mc_ansp, 0, TERM_FILE_TERM, (0));
     end clean_up;

%page;
do_dump:
     proc;

	dcl     i			 fixed bin;
	dcl     j			 fixed bin;
	dcl     limit		 fixed bin;
	dcl     mcode		 fixed bin (35);

	found_a_channel = "0"b;
	call ioa_ ("^/DUMP OF ^a", pathname_ (dn, en));
	if header_sw | header_only_sw
	then do;
		call ioa_ ("max_size: ^21t^d", mc_anstbl.max_size);
		call ioa_ ("current_size: ^21t^d", mc_anstbl.current_size);
		call ioa_ ("mc_procid:^21t^w", mc_anstbl.mc_procid);
		call ioa_ ("sysdir:^21t^a", mc_anstbl.sysdir);
		call ioa_ ("mrtp:^21t^p", mc_anstbl.mrtp);
		call ioa_ ("vconsp:^21t^p", mc_anstbl.vconsp);
		call ioa_ ("cons_cont_proc:^21t^p, ^p", codeptr (mc_anstbl.cons_cont_proc),
		     environmentptr (mc_anstbl.cons_cont_proc));
		call ioa_ ("con_rec");
		call ioa_ ("  mc_ate_ptr:^21t^p", mc_anstbl.mc_ate_ptr);
		call ioa_ ("  ec_id:^21t^24.3b", unspec (mc_anstbl.ec_id));
		call ioa_ ("  seq_num:^21t^d", mc_anstbl.seq_num);
		call ioa_ ("  offset:^21t^oo", mc_anstbl.offset);
		call ioa_ ("  flags");
		call ioa_ ("    enabled:^21t^[on^;off^]", mc_anstbl.con_rec.flags.enabled);
		call ioa_ ("    active:^21t^[on^;off^]", mc_anstbl.con_rec.flags.active);
		call ioa_ ("n_sources:^21t^d", mc_anstbl.n_sources);
		call ioa_ ("max_sources:^21t^d", mc_anstbl.max_sources);
		call ioa_ ("current_time:^21t^a", date_time_$format ("date_time", mc_anstbl.current_time, "", ""));
	     end;					/* header_sw */
	if header_only_sw
	then go to done_dump;

	if mode = 2
	then limit = mc_anstbl.max_size;
	else limit = mc_anstbl.current_size;
	do i = 1 to limit;
	     mc_atep = addr (mc_anstbl.entry (i));
	     if ^mc_ate.pending & mode = 3
	     then goto next_ate;
	     else if ^(mc_ate.pending | mc_ate.active) & mode = 1
	     then go to next_ate;
	     if name_count > 0
	     then do;				/* must match a specified name */
		     mcode = -1;			/* no match yet */
		     do j = 1 to name_count while (mcode ^= 0);
						/* scan the entire list */
			call match_star_name_ ((mc_ate.real_tty_name), names (j), mcode);
			if mcode ^= 0		/* may have specified the vchn name */
			then call match_star_name_ ((mc_ate.virtual_tty_name), names (j), mcode);
		     end;
		     if mcode ^= 0
		     then go to next_ate;
		end;
	     found_a_channel = "1"b;
	     call ioa_ ("^/ENTRY AT ^p", mc_atep);
	     call ioa_ ("virtual_tty_name:^21t^a", rtrim (mc_ate.virtual_tty_name, ""));
	     call ioa_ ("real_tty_name:^21t^a", rtrim (mc_ate.real_tty_name, ""));
	     call ioa_ ("flags:");
	     call ioa_ ("  active:^21t^[on^;off^]", mc_ate.active);
	     call ioa_ ("  virtual:^21t^[on^;off^]", mc_ate.virtual);
	     call ioa_ ("  pending:^21t^[on^;off^]", mc_ate.pending);
	     call ioa_ ("  the_system_console:^21t^[on^;off^]", mc_ate.flags.the_system_console);
	     call ioa_ ("  a_system_console:^21t^[on^;off^]", mc_ate.flags.a_system_console);
	     call ioa_ ("  signed_on:^21t^[on^;off^]", mc_ate.flags.signed_on);
	     call ioa_ ("  reply_restricted:^21t^[on^;off^]", mc_ate.flags.reply_restricted);
	     call ioa_ ("  broadcast:^21t^[on^;off^]", mc_ate.flags.broadcast);
	     call ioa_ ("  broadcast_all:^21t^[on^;off^]", mc_ate.flags.broadcast_all);
	     call ioa_ ("  vchn_requires_accept:^21t^[on^;off^]", mc_ate.flags.vchn_requires_accept);

	     call ioa_ ("oper_info:");
	     call ioa_ ("^2xpersonid:^21t""^a""", rtrim (mc_ate.oper_info.personid, ""));
	     call ioa_ ("^2xlast_input_time:^21t^a",
		date_time_$format ("date_time", mc_ate.oper_info.last_input_time, "", ""));
	     call ioa_ ("cdte_ptr:^21t^p", mc_ate.cdtep);
	     call ioa_ ("restrict_reply:^21t^a", rtrim (mc_ate.restrict_reply, ""));
	     call ioa_ ("n_casts:^21t^d", mc_ate.n_casts);
	     call ioa_$nnl ("cast:^21t");
	     do j = 1 to hbound (mc_ate.cast, 1) - 1;
		call ioa_$nnl ("^a, ", rtrim (mc_ate.cast (j), ""));
	     end;
	     call ioa_ ("^a", rtrim (mc_ate.cast (j), ""));
	     call ioa_ ("sci_ptr:^21t^p", mc_ate.sci_ptr);
	     call ioa_ ("iocb:^21t^p", mc_ate.iocb);
	     call ioa_ ("tra_vec:^21t^d", mc_ate.tra_vec);
	     call ioa_ ("queue_ptr:^21t^p", mc_ate.queue_ptr);
	     call ioa_ ("queue_event:^21t^24.3b", unspec (mc_ate.queue_event));
	     call ioa_ ("event:^21t^24.3b", unspec (mc_ate.event));

	     call ioa_ ("ls_procid:^21t^w", mc_ate.ls_procid);
	     call ioa_ ("ls_term_ev_chn:^21t^24.3b", unspec (mc_ate.ls_term_ev_chn));
	     call ioa_ ("ls_resp_ev_chn:^21t^24.3b", unspec (mc_ate.ls_resp_ev_chn));
	     call ioa_ ("ls_handle:^21t^2w", unspec (mc_ate.ls_handle));
	     call ioa_ ("authority");
	     call ioa_ ("  privilege:^21t^w", mc_ate.privilege);
	     call ioa_ ("control");
	     call ioa_ ("  inhibit:^21t^[on^;off^]", mc_ate.control.inhibit);
	     call ioa_ ("  output_wait:^21t^[on^;off^]", mc_ate.control.output_wait);
	     call ioa_ ("  output_pending:^21t^[on^;off^]", mc_ate.control.output_pending);
next_ate:
	end;					/* do over mc_anstbl ate's */

done_dump:
	call ioa_ ("^/END DUMP OF ^a", pathname_ (dn, en));

     end do_dump;
%page;
%include access_mode_values;
%page;
%include mc_anstbl;
%page;
%include terminate_file;

     end display_mc_anstbl;




		    dump_devq.pl1                   02/07/85  0954.7r w 02/06/85  1403.7       29754



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


dump_devq: proc;

dcl  char32 char (32) aligned,
     dn char (168) aligned init (">system_control_dir"),
     en char (32) aligned,
     c1 char (1) aligned,
     alrm char (1) aligned,
    (i, j, k, l, m, n) fixed bin,
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35),
     qp ptr;

dcl 1 xxx based aligned,
    2 w1 fixed bin (35),
    2 w2 fixed bin (35);

dcl (addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs) builtin;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     ioa_$nnl entry options (variable),
     com_err_ entry options (variable);

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     hcs_$wakeup entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35));

%include device_queue;

/* ------------------------- */

	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then do;
er1:	     call com_err_ (ec, "dump_devq", "");
	     return;
	end;
	if bchr = "-pn" then do;
	     call cu_$arg_ptr (2, ap, al, ec);
	     if ec ^= 0 then go to er1;
	     call expand_path_ (ap, al, addr (dn), addr (en), ec);
	     if ec ^= 0 then do;
er:		call com_err_ (ec, "dump_devq", "^a", bchr);
		return;
	     end;
	end;
	else en = bchr;
	if index (en, ".queue") = 0 then do;
	     i = index (en, " ");
	     substr (en, i) = ".queue";
	end;

	call hcs_$initiate (dn, en, "", 0, 1, qp, ec);
	if qp = null then do;
	     call com_err_ (ec, "dump_devq", "^a>^a", dn, en);
	     return;
	end;
	call ioa_ ("^/DEVICE QUEUE - ^a", device_queue.device_name);
	call ioa_ ("mc_atep:^9x^p", device_queue.mc_atep);
	call ioa_ ("channel:^9x^w^w",
	     addr (device_queue.channel) -> w1, addr (device_queue.channel) -> w2);
	call ioa_ ("no_of_messages:^2x^d", device_queue.no_of_messages);
	call ioa_ ("top_of_queue:^4x^d", device_queue.top_of_queue);
	call ioa_ ("end_of_queue:^4x^d", device_queue.end_of_queue);
	call ioa_ ("free_top:^8x^d", device_queue.free_top);
	call ioa_ ("next_free:^7x^d", device_queue.next_free);

	call ioa_ ("^/NUM  NEXT   OFF   LTH SC MESSAGE^/");
	do i = 1 to device_queue.next_free;
	     if device_queue.line (i).not_done then c1 = "+"; else c1 = " ";
	     if device_queue.line (i).alarm then alrm = "*"; else alrm = " ";
	     call ioa_$nnl ("^3d^1a^5d^6d^6d^3d^1a^a", i, c1,
		device_queue.line (i).next_line, device_queue.line (i).offset, device_queue.line (i).line_length,
		device_queue.line (i).source,
		alrm, device_queue.line (i).string);
	end;
	call ioa_ ("");
	call hcs_$terminate_noname (qp, ec);

     end;




		    dump_mrt.pl1                    02/07/85  0954.7r w 02/06/85  1403.7       46089



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


dump_mrt: proc;

/* DUMP_MRT - dump message routing table

   THVV */

dcl (path, dn) char (168) aligned,
     en char (32) aligned,
     srch (10) char (32) aligned,
     line char (120) aligned,
     datstr char (16) aligned,
     vstr char (64) aligned,
     vconst char (33) aligned,
    (i, j, k, l, m, n) fixed bin,
    (time, fb71) fixed bin (71),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35),
    (p, q) ptr;

dcl (addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs) builtin;

dcl  clock_ entry () returns (fixed bin (71)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     com_err_ entry options (variable);

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35));

%include mess_route_table;

dcl  mrtp ptr;
dcl  streamp ptr;

/* ------------------------------------------------------- */

	m = 0;
	l = 0;
	k = 2;
	path = ">system_control_1>MRT";
	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to mrt1;
	path = bchr;
arglp:	call cu_$arg_ptr (k, ap, al, ec);		/* See if optional args */
	if ec ^= 0 then go to mrt1;
	m = m + 1;				/* count selectors */
	if m > 10 then go to mrt1;
	if bchr = "*" then l = m;
	srch (m) = bchr;
	k = k + 1;
	go to arglp;

mrt1:	i = index (path, " ");
	call expand_path_ (addr (path), i, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "dump_mrt", "^a", path);
	     return;
	end;
	call hcs_$initiate (dn, en, "", 0, 1, mrtp, ec);
	if mrtp = null then go to er;

	if m = 0 then do;				/* Header only if no selected args. */
	     call date_time_ ((clock_ ()), datstr);
	     call ioa_ ("^/Message Routing Table - ^a^/", datstr);

	     call ioa_ ("lock:^15x^w", MRT.lock);
	     call ioa_ ("no_of_sources:^6x^d", MRT.no_of_sources);
	     call ioa_ ("flags:^14x^w", MRT.flags);
	end;

	if l ^= 0 then do;				/* want to list star entry */
	     srch (m) = "";
	     go to pss;
	end;
	if m = 0 then do;
pss:	     call ioa_ ("^/SOURCE: ^a^/", MRT.star_entry.source);
	     call ioa_ ("no_of_streams:^6x^d", MRT.star_entry.no_of_streams);
	     call pstream (addr (MRT.star_entry.stream));
	end;

	do i = 1 to MRT.no_of_sources;
	     if ^MRT.source (i).flags.valid then go to skip;
	     if m = 0 then go to pss1;
	     do n = 1 to m;
		if MRT.source (i).source = srch (n) then do;
		     srch (n) = "";
		     go to pss1;
		end;
	     end;
	     go to skip;

pss1:	     call ioa_ ("^/SOURCE: ^a^/", MRT.source (i).source);
	     call ioa_ ("hismess:^12x^p", MRT.source (i).hismess);
	     call ioa_ ("no_of_streams:^6x^d", MRT.source (i).no_of_streams);
	     vstr = "valid";
	     if MRT.source (i).flags.init then vstr = vstr || ", init";
	     call ioa_ ("flags:^14x^a", vstr);

	     do j = 1 to MRT.source (i).no_of_streams;

		if MRT.source (i).stream (j).flags.valid then
		call pstream (addr (MRT.source (i).stream (j)));

	     end;

skip:	end;

	if m = 0 then call ioa_ ("^/End^/");
	else do i = 1 to m;
	     if srch (i) ^= "" then call ioa_ ("source ""^a"" not in MRT", srch (i));
	end;
	call hcs_$terminate_noname (mrtp, ec);
	return;

pstream:	proc (sp);

dcl  sp ptr;

dcl  k fixed bin,
     vstr char (64) varying,
     sourcet char (32) aligned;

	     streamp = sp;
	     call ioa_ ("^/^5xSTREAM: ^a^/", stream.stream);
	     if substr (stream.source, 1, 1) < " " then sourcet = "*";
	     else sourcet = stream.source;
	     call ioa_ ("^5xsource:^8x^a", sourcet);
	     vstr = "valid";
	     if stream.flags.read then vstr = vstr || ", read";
	     if stream.flags.write then vstr = vstr || ", write";
	     if stream.flags.active then vstr = vstr || ", active";
	     call ioa_ ("^5xflags:^9x^a", vstr);
	     call ioa_ ("^5xourmess:^7x^p", stream.ourmess);
	     call ioa_ ("^5xhismess:^7x^p", stream.hismess);
	     call ioa_ ("^5xsource_index:^2x^d", stream.source_index);
	     call ioa_ ("^5xstream_index:^2x^d", stream.stream_index);
	     call ioa_ ("^5xno_of_vcons:^3x^d^/", stream.no_of_vcons);
	     do k = 1 to stream.no_of_vcons;

		if substr (stream.flags.alarm, k, 1) then vconst = "*" || stream.vcons (k);
		else vconst = stream.vcons (k);	/* Star means alarm flag will be in message */
		call ioa_ ("^10xvcons ^d:  ^3d ^a", k, stream.vcons_index (k), vconst);

	     end;

	end pstream;

     end dump_mrt;




		    dump_syscon_mseg.pl1            09/03/87  1221.9rew 09/03/87  1221.4       71982



/****^  ***********************************************************
        *                                                         *
        * 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(87-09-02,Parisek), approve(87-09-03,MECR0005),
     audit(87-09-02,GDixon), install(87-09-03,MR12.1-1098):
     Expand the quit_bits display to include all possible 504 bits. (phx20974)
                                                   END HISTORY COMMENTS */


dump_syscon_mseg:
dump_msg: proc;

/* automatic */

dcl  argl fixed bin,				/* Length of current argument */
     argno fixed bin,				/* Number of current argument */
     code fixed bin,				/* For errors */
     i fixed bin,					/* A temporary index */
     j fixed bin,					/* Another */
     k fixed bin,					/* Another */
     n_blocks fixed bin,
     highest_quit_bits fixed bin(24),			/* quit_bits to display */
    (temp_stream, temp_source) char (32);
	

declare
         argp pointer,				/* Pointer to current argument */
         messp pointer,				/* Pointer to current block */
         msegp pointer;				/* Pointer to the message segment */

declare
         barg char (argl) based (argp),			/* For getting arguments */
         date_string char (25),
         dirname char (168),
         entname char (32),
         flagn_arr (4) char (16) varying int static init ("continue, ", "introduction, ", "farewell, ", "sentinel, "),
         list char (64) varying;			/* For printing bit names &c */

declare
         addr builtin,
         length builtin,
         null builtin,
         rel builtin,
         string builtin,	
         substr builtin,
         unspec builtin;

declare
         com_err_ entry options (variable),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
         date_time_$hundredths entry (fixed bin (71), char (*)),
         expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
         find_bit_$last_on entry (bit (*) aligned) returns (fixed bin (24)),
         hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin),
         ioa_ entry options (variable);

/* include files */

%include syscon_mseg;

/* program */


/* This program dumps a "message" segment of the message routing facility */

/* First get the pathname of the seg from the command line */
	argno = 1;
	call cu_$arg_ptr (argno, argp, argl, code);
	if code ^= 0 then do;
	     call com_err_ (code, "dump_msg", "Pathname of message segment");
	     return;
	end;

	call expand_path_ (argp, argl, addr (dirname), addr (entname), code);
	if code ^= 0 then do;
	     call com_err_ (code, "dump_msg", "^a", barg);
	     return;
	end;

	call hcs_$initiate (dirname, entname, "", 0, 1, msegp, code);
	if msegp = null then do;
	     call com_err_ (code, "dump_msg", "^a>^a", dirname, entname);
	     return;
	end;

	call ioa_ ("lock:^2-^12.3b^/locked_by_pid:^-^12.3b",
	     msegp -> syscon_mseg.mlock, msegp -> syscon_mseg.locked_by_pid);

	call ioa_ ("process_id:^-^12.3b", msegp -> syscon_mseg.current_process_id);

	call ioa_ ("regular channel:^-^72.3b", unspec (msegp -> syscon_mseg.ipc_el.channel));

	call ioa_ ("protocol channel:^-^72.3b", unspec (msegp -> syscon_mseg.proto_el.channel));

/* Prepare list of flags that are on & print it */
	list = "";
	highest_quit_bits = find_bit_$last_on (msegp->syscon_mseg.quit_bits);
	if msegp -> syscon_mseg.flags.test_mode then
	     list = "test_mode, ";
	if msegp -> syscon_mseg.flags.receiver_woken then
	     list = list || "receiver_woken, ";
	if list ^= ""
	then call ioa_ ("flags:^2-^a", substr (list, 1, length (list) - 2));

	call ioa_ ("first_free_buffer:^-^d", msegp -> syscon_mseg.first_free_buffer);
	call ioa_ ("last_assigned_buffer:^-^d", msegp -> syscon_mseg.last_assigned_buffer);
	call ioa_ ("no_of_streams:^-^d", msegp -> syscon_mseg.no_of_streams);

	call ioa_ ("quit bits:^-^.3b", substr (msegp -> syscon_mseg.quit_bits, 1, highest_quit_bits));
	call ioa_ ("mescount:^2-^d", msegp -> syscon_mseg.mescount);
	call ioa_ ("output_wait:^-^[ON^;OFF^]", msegp -> syscon_mseg.output_wait);

	n_blocks = msegp -> syscon_mseg.last_assigned_buffer;

	begin;					/* allocate space to hold trace flags */

dcl  already_printed bit (n_blocks) unaligned;

	     already_printed = "0"b;

	     call print_chain ("protocol", msegp -> syscon_mseg.first_proto);
	     call print_chain ("regular", msegp -> syscon_mseg.first_message);
	     call print_chain ("free", msegp -> syscon_mseg.first_free_buffer);

	     if (^already_printed) ^= ""b then do;
		call ioa_ ("Not in any chain:");
		do k = 1 to n_blocks;
		     if substr (already_printed, k, 1) = "0"b
		     then call print_block (k);
		end;
	     end;

	     return;


print_chain:   proc (chain_name, chain_head);

declare
         chain_name char (*),
         chain_head fixed bin,
         chainlen fixed bin,
         this_message fixed bin;

		chainlen = 0;
		this_message = chain_head;

		do while (this_message ^= 0);		/* find out how long chain is */
		     if ^substr (already_printed, this_message, 1)
		     then do;
			substr (already_printed, this_message, 1) = "1"b;
			chainlen = chainlen + 1;
			this_message = msegp -> syscon_mseg.message (this_message).next_message;
		     end;
		     else this_message = 0;		/* quit because we've looped back */
		end;
		call ioa_ ("There are ^d blocks in the ^a chain", chainlen, chain_name);

		if chainlen = 0 then return;		/* No chain to print */

		call ioa_ ("OFFSET  # NEXT SOURCE     STREAM       INDICES TIME        FLAGS");

pb:		this_message = chain_head;
		do i = 1 to chainlen;
		     messp = addr (msegp -> syscon_mseg.message (this_message));

		     if messp -> debug_info.flag = -1 then do; /* debugging info block */
			call ioa_ ("^6.3b ^3d  DEBUG INFO:", rel (messp), this_message);
			call date_time_$hundredths (messp -> debug_info.time, date_string);
			call ioa_ ("^-time:^-^a", date_string);
			call ioa_ ("^-last_pid:^-^12.3b", messp -> debug_info.last_pid);
			call ioa_ ("^-first_msg:^-^d", messp -> debug_info.first_msg);
			call ioa_ ("^-last_msg:^-^d", messp -> debug_info.last_msg);
			call ioa_ ("^-first_pro:^-^d", messp -> debug_info.first_pro);
			call ioa_ ("^-last_pro:^-^d", messp -> debug_info.last_pro);
			call ioa_ ("^-free_chain:^-^d", messp -> debug_info.free_chain);
			go to next_block;
		     end;

		     list = "";
		     do j = 1 to 4;
			if substr (string (message_block.flags), j, 1) then
			     list = list || flagn_arr (j);
		     end;

		     if list ^= ""
		     then list = substr (list, 1, length (list) -2);

		     call date_time_$hundredths (message_block.time_sent, date_string);
		     if unspec (message_block.from_source) = ""b
		     then temp_source = "(unset)";
		     else temp_source = message_block.from_source;

		     if unspec (message_block.from_stream) = ""b
		     then temp_stream = "(unset)";
		     else temp_stream = message_block.from_stream;

		     call ioa_ ("^6.3b ^3d ^3d ^10a ^10a ^3d ^3d ^a ^a",
			rel (messp),
			this_message,
			message_block.next_message,
			temp_source,
			temp_stream,
			message_block.source_index,
			message_block.stream_index,
			date_string, list);
		     call ioa_ ("^3d ^a", message_block.length,
			substr (message_block.message_body, 1, message_block.length));
		     this_message = message_block.next_message;

next_block:
		end;
		return;

print_block:	entry (chain_head);
		chainlen = 1;
		goto pb;

	     end print_chain;

	end;
     end dump_syscon_mseg;




		    dump_vct.pl1                    02/07/85  0954.7r w 02/06/85  1403.7       35316



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


dump_vct: proc;

/* DUMP_VCT - dump virtual console table

   THVV */

dcl (path, dn) char (168) aligned,
     en char (32) aligned,
     srch (10) char (32) aligned,
     line char (120) aligned,
     datstr char (16) aligned,
     vstr char (64) aligned,
    (i, j, k, l, m, n) fixed bin,
    (time, fb71) fixed bin (71),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35),
    (p, q) ptr;

dcl (addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs) builtin;

dcl  clock_ entry () returns (fixed bin (71)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     date_time_ entry (fixed bin (71), char (*) aligned),
     com_err_ entry options (variable);

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35));

%include vcons_tab;

dcl  vconsp ptr;
dcl  vcep ptr;

dcl  typer (3) char (4) aligned int static init ("tty", "log", "sink");

/* ------------------------------------------------------- */

	m = 0;
	l = 0;
	k = 2;
	path = ">system_control_1>vcons_tab";
	call cu_$arg_ptr (1, ap, al, ec);
	if ec ^= 0 then go to vct1;
	path = bchr;
arglp:	call cu_$arg_ptr (k, ap, al, ec);
	if ec ^= 0 then go to vct1;
	m = m + 1;
	if m > 10 then go to vct1;
	if bchr = "*" then l = m;
	srch (m) = bchr;
	k = k + 1;
	go to arglp;

vct1:	i = index (path, " ");
	call expand_path_ (addr (path), i, addr (dn), addr (en), ec);
	if ec ^= 0 then do;
er:	     call com_err_ (ec, "dump_vct", "^a", path);
	     return;
	end;
	call hcs_$initiate (dn, en, "", 0, 1, vconsp, ec);
	if vconsp = null then go to er;

	if m = 0 then do;
	     call date_time_ ((clock_ ()), datstr);
	     call ioa_ ("^/Virtual Console Table - ^a^/", datstr);

	     call ioa_ ("lock:^15x^w", vcons_tab.lock);
	     call ioa_ ("no_of_vcons:^8x^d", vcons_tab.no_of_vcons);
	     call ioa_ ("flags:^14x^w", vcons_tab.flags);
	end;

	if l ^= 0 then do;
	     srch (l) = "";
	     go to pvv;
	end;
	if m = 0 then do;
pvv:	     call ioa_ ("^/VIRTUAL CONSOLE: ^a^/", vcons_tab.star_entry.vcons);
	     call pvcons (addr (vcons_tab.star_entry));
	end;

	do i = 1 to vcons_tab.no_of_vcons;
	     if ^vcons_tab.vcons (i).flags.inuse then go to skip;
	     if m = 0 then go to pvv1;
	     do n = 1 to m;
		if vcons_tab.vcons (i).vcons = srch (n) then do;
		     srch (n) = "";
		     go to pvv1;
		end;
	     end;
	     go to skip;

pvv1:	     call ioa_ ("^/VIRTUAL CONSOLE: ^a^/", vcons_tab.vcons (i).vcons);
	     call pvcons (addr (vcons_tab.vcons (i)));

skip:	end;

	if m = 0 then call ioa_ ("^/End^/");
	else do i = 1 to m;
	     if srch (i) ^= "" then call ioa_ ("vcons ""^a"" not in vcons_tab", srch (i));
	end;
	call hcs_$terminate_noname (vconsp, ec);
	return;

pvcons:	proc (sp);

dcl  sp ptr;

dcl  k fixed bin,
     vstr char (64) varying,
     vconst char (32) aligned;

	     vcep = sp;
	     vstr = "inuse";
	     call ioa_ ("^5xflags:^9x^a", vstr);
	     call ioa_ ("^5xno_of_dest:^4x^d^/", vcons.no_of_dest);
	     do k = 1 to vcons.no_of_dest;

		call ioa_ ("^10xdest ^d:^3x^4a ^a ^p", k,
		typer (vcons.dest (k).type), vcons.dest (k).dest, vcons.dest (k).queue_seg_ptr);

	     end;

	end pvcons;

     end dump_vct;




		    mc_check_access_.pl1            08/05/87  0801.2r   08/04/87  1540.6       24714



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* mc_check_access_ -- access control for Message Coordinator */
/* format: style2 */

mc_check_access_:
     procedure;

/**** Modification History:
      Created 1985-01-07, BIM. */


	declare P_SSI_ptr		 pointer;
	declare P_source_name	 char (*);
	declare P_code		 fixed bin (35);
	declare P_user_name		 char (*);


	declare mc_check_acs_$reply	 entry (character (*), fixed binary (3), character (*), fixed binary (35));
	declare mc_check_acs_$quit	 entry (character (*), fixed binary (3), character (*), fixed binary (35));
	declare mc_check_acs_$log_daemon_in
				 entry (character (*), fixed binary (3), character (*), fixed binary (35));
	declare mc_check_acs_$log_daemon_out
				 entry (character (*), fixed binary (3), character (*), fixed binary (35));
	declare mc_check_acs_$new_proc_daemon
				 entry (character (*), fixed binary (3), character (*), fixed binary (35));
	declare mc_check_acs_$log_in_as_daemon
				 entry (character (*), fixed binary (3), character (*), fixed binary (35));

	declare DEFAULT_RING	 fixed bin (3) init (4) int static options (constant);


reply:
     entry (P_SSI_ptr, P_source_name, P_code);


	sc_subsystem_info_ptr = P_SSI_ptr;
	call mc_check_acs_$reply (sc_subsystem_info.access_control_name, DEFAULT_RING, P_source_name, P_code);
	return;

quit:
     entry (P_SSI_ptr, P_source_name, P_code);

          sc_subsystem_info_ptr = P_SSI_ptr;
	call mc_check_acs_$quit (sc_subsystem_info.access_control_name, DEFAULT_RING, P_source_name, P_code);
	return;

log_daemon_in:
     entry (P_SSI_ptr, P_source_name, P_code);

          sc_subsystem_info_ptr = P_SSI_ptr;
	call mc_check_acs_$log_daemon_in (sc_subsystem_info.access_control_name, DEFAULT_RING, P_source_name, P_code);
	return;

log_daemon_out:
     entry (P_SSI_ptr, P_source_name, P_code);

          sc_subsystem_info_ptr = P_SSI_ptr;
	call mc_check_acs_$log_daemon_out (sc_subsystem_info.access_control_name, DEFAULT_RING, P_source_name, P_code);
	return;

new_proc_daemon:
     entry (P_SSI_ptr, P_source_name, P_code);

          sc_subsystem_info_ptr = P_SSI_ptr;
	call mc_check_acs_$new_proc_daemon (sc_subsystem_info.access_control_name, DEFAULT_RING, P_source_name, P_code);
	return;

log_in_as_daemon:
     entry (P_user_name, P_source_name, P_code);
	call mc_check_acs_$log_in_as_daemon (P_user_name, DEFAULT_RING, P_source_name, P_code)
	     ;
	return;

%include sc_subsystem_info_;


     end mc_check_access_;




		    mc_check_acs_.pl1               08/04/87  1456.8rew 08/04/87  1221.8       53757



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

/* mc_check_acs_ -- access control for Message Coordinator */
/* format: style2 */

mc_check_acs_:
     procedure;

/**** Modification History:
      Created 1984-12-26, BIM.
      Modified 1985-01-29 by E. Swenson to add auditing
*/


/****^  HISTORY COMMENTS:
  1) change(87-02-23,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Correct coding standard violations.  Add copyright notice.
                                                   END HISTORY COMMENTS */


/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* NOTES ON AUDITING:					       */
/*							       */
/* This procedure is responsible for access checks and auditing in the       */
/* usual manner. If the redundancy level gets out of hand (in terms of       */
/* duplicate messages) then a solution will have to be found.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	declare P_source_name	 char (*);
	declare P_user_name		 char (*);
	declare P_code		 fixed bin (35);
	declare P_ring		 fixed bin (3);

	declare global_access_op	 bit (36) aligned;
	declare modes		 bit (36) aligned;

	declare rtrim		 builtin;

	declare convert_access_operation_
				 entry (bit (36) aligned) returns (char (50));
	declare hcs_$get_user_access_modes
				 entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				 bit (36) aligned, fixed bin (35));
	declare sys_log_		 entry options (variable);

	declare (
	        GRANT		 initial ("1"b),
	        DENY		 initial ("0"b)
	        )			 bit (1) aligned internal static options (constant);

	declare (
	        access_operations_$daemon_daemon_login,
	        access_operations_$daemon_reply,
	        access_operations_$daemon_login,
	        access_operations_$daemon_logout,
	        access_operations_$daemon_quit
	        )			 ext static bit (36) aligned;

	declare (
	        error_table_$mc_no_c_permission,
	        error_table_$mc_no_d_permission,
	        error_table_$mc_no_q_permission,
	        error_table_$mc_no_r_permission
	        )			 fixed bin (35) ext static;



reply:
     entry (P_user_name, P_ring, P_source_name, P_code);

	call setup (access_operations_$daemon_reply);	/* returns non-locally if checking is disabled */

	call hcs_$get_user_access_modes (sc_stat_$mc_acs_dir, rtrim (P_source_name) || ".mcacs", P_user_name, (P_ring),
	     (""b), modes, P_code);
	if P_code = 0
	then if (modes & MCACS_R_ACCESS) = ""b
	     then P_code = error_table_$mc_no_r_permission;

	if P_code = 0
	then call AUDIT (GRANT);
	else call AUDIT (DENY);
	return;

quit:
     entry (P_user_name, P_ring, P_source_name, P_code);

	call setup (access_operations_$daemon_quit);	/* returns non-locally if checking is disabled */

	call hcs_$get_user_access_modes (sc_stat_$mc_acs_dir, rtrim (P_source_name) || ".mcacs", P_user_name, (P_ring),
	     (""b), modes, P_code);
	if P_code = 0
	then if (modes & MCACS_Q_ACCESS) = ""b
	     then P_code = error_table_$mc_no_q_permission;

	if P_code = 0
	then call AUDIT (GRANT);
	else call AUDIT (DENY);
	return;

log_daemon_in:
     entry (P_user_name, P_ring, P_source_name, P_code);

	call setup (access_operations_$daemon_login);	/* returns non-locally if checking is disabled */
	go to CONTROL_COMMON;

log_daemon_out:
     entry (P_user_name, P_ring, P_source_name, P_code);

	call setup (access_operations_$daemon_logout);	/* returns non-locally if checking is disabled */
	go to CONTROL_COMMON;

new_proc_daemon:
     entry (P_user_name, P_ring, P_source_name, P_code);

	call setup (access_operations_$daemon_quit);	/* returns non-locally if checking is disabled */

CONTROL_COMMON:
	call hcs_$get_user_access_modes (sc_stat_$mc_acs_dir, rtrim (P_source_name) || ".mcacs", P_user_name, (P_ring),
	     (""b), modes, P_code);
	if P_code = 0
	then if (modes & MCACS_C_ACCESS) = ""b
	     then P_code = error_table_$mc_no_c_permission;

	if P_code = 0
	then call AUDIT (GRANT);
	else call AUDIT (DENY);
	return;

log_in_as_daemon:
     entry (P_user_name, P_ring, P_source_name, P_code);

	call setup (access_operations_$daemon_daemon_login);
						/* returns non-locally if checking is disabled */
	call hcs_$get_user_access_modes (sc_stat_$mc_acs_dir, rtrim (P_source_name) || ".mcacs", P_user_name, (P_ring),
	     (""b), modes, P_code);
	if P_code = 0
	then if (modes & MCACS_D_ACCESS) = ""b
	     then P_code = error_table_$mc_no_d_permission;

	if P_code = 0
	then call AUDIT (GRANT);
	else call AUDIT (DENY);
	return;

setup:
     procedure (access_op);
	declare access_op		 bit (36) aligned;

	P_code = 0;
	global_access_op = access_op;
	if ^installation_parms.validate_daemon_commands
	then go to EXIT_NONLOCAL;

	return;

     end setup;

EXIT_NONLOCAL:
	return;

AUDIT:
     procedure (P_grant_sw);

/**** This procedure is responsible for auditing all message coordinator
      access.  P_grant_sw indicates if the access check resulted in a 
      GRANT of DENY. */

	dcl     P_grant_sw		 bit (1) aligned parameter;

	call sys_log_ (SL_LOG_SILENT, "Audit: ^[GRANTED^;DENIED^] ^a for ^a Level=^d to ^a", P_grant_sw,
	     convert_access_operation_ (global_access_op), P_user_name, P_ring, P_source_name);
	return;

     end AUDIT;

%include as_data_;

%include installation_parms;
	declare ip		 pointer defined (as_data_$rs_ptrs (0));

%include mcacs_access_modes;

%include sc_stat_;

%include sys_log_constants;
     end mc_check_acs_;




		    mc_commands_.pl1                11/14/88  1010.2rew 11/14/88  1005.9      655587



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


/* format: style4 */

mc_commands_: proc;

/* This procedure is part of the message coordinator.
   It contains entries that support all of the message coordinator commands.
   *
   The message coordinator was originally created by Dennis Capps
   with advice from TH VanVleck in October of 1972.
   "mc_commands_" originally created by Bill Silver in May, 74.
   modified by D. M. Wells, July 1976, to understand about FTP channels
   modified by Robert Coren, August 1976, to use CDT
   Modified June 1981 by T. Casey for MR9.0 for new wakeup priorities.
   Modified January 1982 by E. N. Kittlitz to check for intty before searching cdt.
   *	84-11-16, W. Olin Sibert: Changed to call mc_con_rec_$check correctly
   1984-11-??, BIM: changes for iox_.
   1985-03-22, E. Swenson: to eliminate extra NL at end of messages and
   to log operator logout upon dropping a mc terminal.
   1985-04-05, E. Swenson: Fixed to handle dropping/substty on accepted
   channels whose multiplexer has not yet been loaded.
   1985-04-17, E. Swenson: To not attempt to sign out a terminal not signed
   on.
*/


/****^  HISTORY COMMENTS:
  1) change(85-12-19,MSharpe), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     The following modules were changed so that DSA channels could be used as
     MC terminals: new_tty, KILL_TTY, ATTACH_ATE, SEARCH_MC_ANSTBL. A new
     module, mc_login, was added for the same purpose.  It supports
     "login Person_id -operator -vchannel"; after the answering service has
     validated this user to be eligible for logging in as an operator, this
     routine is called to fill in the actual_channel_name of the pre-accepted
     virtual channel specified, and to attach the iocb for it.
     CDD-3/28/86: to clear out login server id in KILL_TTY
  2) change(87-02-05,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     Modified for change to mc_anstbl.incl.pl1.  Entrypoint which reference
     mc_anstbl must now explicitly set mc_ansp from sc_stat_$mc_ansp.
     CDD-4/10/86: to set virtual and realy tty_name correctly.
  3) change(87-02-13,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     Correct problem in mc_commands_$substty where target terminal is otw_ (the
     system console).  A previous substty operation (substty otw_ XXX)
     destroyed the ssu_ subsystem associated with the console; an attempt to
     substitute I/O back to the system console (substty XXX otw_) then assumes
     the ssu_ subsystem still exists.  Avoid the destroy operation for the
     system console. (phx20406)
  4) change(87-04-06,Parisek), approve(87-05-01,MCR7690),
     audit(87-07-17,Beattie), install(87-08-04,MR12.1-1055):
     Commented in the error_table_$(bad_vchannel vchn_active vchn_not_found)
     error assignments.
  5) change(87-04-23,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     Fill in login_server_operator_response.process_group_id so message
     coordinator channels will have proper group id in connection list.
  6) change(87-05-04,Parisek), approve(87-05-01,MCR7690),
     audit(87-07-17,Beattie), install(87-08-04,MR12.1-1055):
     A. Set mc_atep for the valid otw_ mc_anstbl entry instead of leaving it
        null for returning to caller.
     B. Initialize the mc_ate.oper_info.personid.
  7) change(87-05-18,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     Use revised calling sequence for uc_send_ls_response_.
  8) change(87-05-27,Parisek), approve(87-05-01,MCR7690),
     audit(87-07-17,Beattie), install(87-08-04,MR12.1-1055):
     A. If by chance the returned cdte pointer from DROP_CDT_TERMINAL is null,
        I added a call sys_log_ call to document the error.
     B. Removed FIND_CDTE internal procedure for locating the cdtep, and
        instead use the value of mc_ate.cdtep which is the cdtep previously
        set when the channel was originally attached.
     C. Pass the mc_atep (mc_anstbl entry pointer) as the parameter to
        DROP_CDT_TERMINAL instead of the tty name so the cdt entry pointer
        can be determined faster.
  9) change(87-06-12,Parisek), approve(87-05-01,MCR7690),
     audit(87-07-17,Beattie), install(87-08-04,MR12.1-1055):
     Added the P_utep parameter for mc_login so we can set the ute.proc_id to
     that of the target process which is needed in case the process is bumped.
 10) change(87-06-18,Parisek), approve(87-05-01,MCR7690),
     audit(87-07-17,Beattie), install(87-08-04,MR12.1-1055):
     Do not reference mc_ate.cdte for otw_ since otw_ has no cdt entry.  This
     corrects a null pointer fault problem when doing a substty of otw_ for
     another channel.
 11) change(87-06-26,Parisek), approve(87-06-26,MCR7690),
     audit(87-07-17,Beattie), install(87-08-04,MR12.1-1055):
      A. Add the access_class_range parameter to mc_login passed by it's caller.
      B. Check allowable access_class_range for dialed user.
      C. Add internal procs ABORT_DIALIN and DIALIN_OK for sending audit data.
      D. Call ABORT_DIALIN or DIALIN_OK where necessary in mc_login entry.
 12) change(87-08-07,Parisek), approve(87-08-07,MCR7690),
     audit(87-08-07,GDixon), install(87-08-07,MR12.1-1073):
     Change the audit action value for successful dialins to a positive
     (accepted) value from a negative (rejected) value.
 13) change(88-11-04,Parisek), approve(87-06-26,MCR7690), 
     audit(88-11-10,Beattie), install(88-11-14,MR12.2-1211):
     Check for a valid cdte pointer (mc_ate.cdtep) for a terminal dialed
     to the MC (DROP_CDT_TERMINAL internal proc) before attempting to reset
     the cdte information for that terminal.  Reestablished the FIND_CDTE
     internal proc for locating the cdtep for the dialed terminal in the
     case where mc_atep or mc_ate.cdtep is null.
                                                   END HISTORY COMMENTS */


declare  P_access_class (2) bit (72) aligned;
declare  P_cdtp ptr parameter;
declare  P_cdte_flag bit (1) aligned parameter;
declare  P_drop_terminal bit (1) aligned parameter;
declare  P_ls_handle bit (72) parameter;
declare  P_ls_procid bit (36) parameter;
declare  P_ls_term_ev_chn fixed bin (71) parameter;
declare  P_ls_resp_ev_chn fixed bin (71) parameter;
declare  P_mpx_name char (*) parameter;
declare  P_mc_ansp ptr parameter;
declare  P_mc_atep ptr parameter;
declare  P_mcmp ptr parameter;
declare  P_message_ptr ptr parameter;
declare  P_temp_SDBp ptr parameter;
declare  P_vchannel char (*) parameter;
declare  P_utep ptr parameter;

declare  inttyp ptr parameter;			/* (OUTPUT) ptr to mc_ate  */
declare  code fixed bin (35) parameter;			/* error code */

declare  Message_ptr pointer parameter;			/* used in reply and intercom */
declare  Message_length fixed bin (21) parameter;		/* ditto */

declare  insc char (*) parameter;			/* A source to route */
declare  instream char (*) parameter;			/* A stream for us to route */
declare  intty char (*) parameter;			/* A console for us to use */
declare  invc char (*) parameter;			/* Virt Cons   */
declare  param1 char (*) parameter;			/* A new target. */
declare  type char (*) parameter;			/* type of destination */


/* Declarations of POINTERS  */
declare
         bufferp2 ptr,				/* Addr of buffer2 */
         iutep ptr,					/* ptr to Initializer ute entry */
         mcmp ptr int static init (null),		/* to message seg for message coordinator */
         messp ptr int static init (null),
         mrtp ptr int static init (null),		/* to Message Routing Table */
         p ptr,					/* A temporary pointer used by substty */
         qp ptr,					/* to queue of lines to be typed on a device */
         streamp ptr,				/* to a stream entry in MRT */
         temp_SDBp ptr int static init (null),		/* to temp_SDB */
         vcep ptr,					/* to an entry in virtual console table */
         vconsp ptr int static init (null),		/* to Virtual CONSole table */
         wakeup_data_ptr ptr;

/* Fixed binary quantities */
declare
         autocode fixed bin (35) init (0),		/* error code in automatic storage */
         ls_status_code fixed bin (35) init (0),		/* ditto */
         dest fixed bin,				/* Index when looping thru phys devices in vcons_tab */
         fbtype fixed bin,				/* type of destination,1=>tty 2=>log 3=>sink */
         i fixed bin,				/* a temporary index */
         j fixed bin,				/* another temporary index */
         jj fixed bin,
         k fixed bin,				/* loop counter for protocol and router */
         lng fixed bin,				/* Length of formatted string for output */
         ls_event_channel fixed bin (71),		/* login server event channel; used for drop */
         mrt_source fixed bin,			/* Index of source entry in MRT */
         mrt_stream fixed bin,			/* Index of stream entry in source entry in MRT */
         nt fixed bin,				/* No of characters actually typed */
         state fixed bin,				/* 0 -- end of data, 1-- more to message */
         this_line fixed bin,				/* Current link in q of lines to be typed */
         vc fixed bin,				/* Index when looping thru vcons in MRT */
         vce fixed bin,				/* Index of Virtual Console table Entry */
         wakeup_data_len fixed bin (18);		/* length of mc_ate; passed to LS for dial wakeup */

/* Character strings */

declare  Destination char (*) varying;
declare  Message char (*);
dcl  old_operator_name char (32);			/* operator currently signed on */
declare  mpx_starname char (32);			/* star name that matches subchannels of mpx */

declare  message char (Message_length) based (Message_ptr);

declare  1 ls_operator_resp aligned like login_server_operator_response;
declare  1 ls_term_resp aligned like login_server_termination_response;
declare  1 CAI structure aligned like channel_audit_info automatic;

declare  buffer2 char (132);
declare  char32 char (32);				/* automatic intty */
declare  insca char (32);				/* automatic insc */
declare  instreama char (32);				/* automatic instream */
declare  iocb_name char (32);
declare  recipient char (32);				/* the source to which a reply is directed */
declare  tempdest char (32);				/* A temporary */
declare  vchannel char (32);				/* automatic P_vchannel */

/* BIT strings */
declare
         access_class_range (2) bit (72) aligned,		/* dialed aim class */
         authority bit (36),				/* Parameter Privileges for this console */
         created_seg (8) bit (1) init ((8) (1)"0"b),	/* In case we want to write messages */
         dont_log bit (1) init ("0"b),			/* "1"b=>Sentinel-- Needn't be logged */
         cdte_flag bit (1) aligned,			/* ""b=> channel not defined in cdt */
         ls_handle bit (72) aligned,			/* login server handle for channel; used for drop */
         ls_process_id bit (36) aligned,		/* login server process id; used for drop */
         must_send_operator_response bit (1),		/* "1"b=> respond to login server's operator request */
         new_vchn_flag bit (1),
         op_ok bit (1),				/* ""b => channel must be accepted by oprator */
         sendalarm bit (1),				/* TRUE if alarm message; at distribute */
         virtual_flag bit (1) aligned,			/* "1"b if intty in new_tty is a vchn name */
         zerobits bit (72) init (""b);			/* used for sending operator response */

/* BUILTIN FUNCTIONS */
declare
         addr builtin,
         clock builtin,
         index builtin,
         length builtin,
         null builtin,
         search builtin,
         size builtin,
         string builtin,
         substr builtin,
         unspec builtin,
         codeptr builtin,
         rtrim builtin;

/* CONSTANTS */

declare  (TRUE init ("1"b),
         FALSE init (""b)) bit (1) aligned int static options (constant);

/* EXTERNAL ENTRIES */

declare  aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
declare  as_access_audit_$channel entry (ptr, ptr, ptr, fixed bin, ptr, char (*));
declare  astty_$tty_event entry (ptr, fixed bin (35));
declare  ioa_$ioa_switch entry () options (variable);
declare  cdt_mgr_$find_cdt_channel entry (pointer, character (32), fixed binary, bit (1) aligned, fixed binary (35));
declare  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
declare  get_group_id_ entry () returns (char (32));
declare  get_process_access_class_ entry () returns (bit (72) aligned);
declare  get_process_id_ entry () returns (bit (36));
declare  get_ring_ entry () returns (fixed bin (3));
declare  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
declare  hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35));
declare  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
declare  hphcs_$ips_wakeup entry (bit (*) aligned, char (*));
declare  ioa_ entry options (variable);
declare  ioa_$rs entry options (variable);
declare  ioa_$rsnnl entry options (variable);
declare  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
declare  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
declare  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
declare  lg_ctl_$logout_operator entry (ptr, char (*), char (*));
declare  lg_ctl_$logout_channel entry (ptr, char (*));
declare  log_write_$open entry (character (*), character (*), bit (1) aligned, pointer, fixed binary (35));
declare  log_write_$close entry (pointer, fixed binary (35));
declare  match_star_name_ entry (char (*), char (*), fixed bin (35));
declare  mc_con_rec_$check entry ();
declare  mc_util_$get_seg entry (char (*), ptr, fixed bin (35));
declare  mc_util_$mrt_source entry (char (*), fixed bin, fixed bin (35));
declare  mc_util_$mrt_stream entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
declare  mc_util_$queue entry (ptr, bit (1), ptr, fixed bin, fixed bin, fixed bin (35));
declare  mc_wakeups_$typer_out entry;
declare  mrd_util_$write entry (ptr, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
declare  sc_create_sci_ entry (pointer, fixed binary (35));
declare  sc_create_sci_$destroy entry (pointer);
declare  ssu_$get_info_ptr entry (ptr) returns (ptr);
declare  sys_log_$command_error entry options (variable);
declare  sys_log_ entry options (variable);
declare  uc_send_ls_response_ entry (ptr, fixed bin (18), bit (36) aligned,
	    bit (72) aligned, fixed bin (71), ptr, char (32) aligned,
	    fixed bin (35), fixed bin (35));
declare  unique_chars_ entry (bit (*)) returns (char (15));

/* EXTERNAL constants */
declare  as_error_table_$dialnotup fixed bin (35) ext static;
declare  (error_table_$action_not_performed,
         error_table_$ai_out_range,
         error_table_$bad_vchannel,
         error_table_$invalid_device,
         error_table_$io_no_permission,
         error_table_$ioname_not_active,
         error_table_$ioname_not_found,
         error_table_$ionmat,
         error_table_$noentry,
         error_table_$notalloc,
         error_table_$typename_not_found,
         error_table_$vchn_active,
         error_table_$vchn_not_found) fixed bin (35) ext static;

declare  cleanup condition;

%page;
init: entry (P_mc_ansp, P_cdtp, P_temp_SDBp, P_mcmp, P_message_ptr);

/* This entry is called by mc_util_$init.  It sets up all of the internal static
   variables needed by the other entries.
*/

	mc_ansp, sc_stat_$mc_ansp = P_mc_ansp;
	temp_SDBp = P_temp_SDBp;
	mcmp = P_mcmp;
	messp = P_message_ptr;

	mrtp = mc_anstbl.mrtp;
	vconsp = mc_anstbl.vconsp;

	return;
%page;

/* This is the reply command. */

reply_command: entry (Destination, Message_ptr, Message_length, inttyp, code);

	code = 0;
	recipient = Destination;
	mc_atep = inttyp;
	if mc_atep ^= null () then
	     if mc_ate.flags.reply_restricted then
		if mc_ate.restrict_reply ^= "" then	/* If there is a restriction on reply */
		     if recipient ^= mc_ate.restrict_reply then do; /* .. check it. */
			code = error_table_$io_no_permission; /* Naughty. */
			return;
		     end;

	call mc_util_$mrt_source (recipient, mrt_source, code);
	if code ^= 0 then return;			/* Couldn't find him. */
	if ^MRT.source (mrt_source).flags.init then	/* He's not attached. */
	     do;
noreply:	     code = error_table_$ioname_not_active;
	     return;
	end;
	temp_SDBp -> stream.hismess = MRT.source (mrt_source).hismess; /* Where to put the reply. */

	autocode = 0;				/* Write it. */

	call mrd_util_$write (temp_SDBp, Message_ptr, 0, (Message_length), nt, state, autocode);
	code = autocode;

	return;
%page;

/* This entry checks to see if the source named has enabled quits, by checking a bit in mc.message.
   If quits are enabled, it uses a highly-privileged interface to send an IPS quit. */

quit_command: entry (insc, inttyp, code);

	code = 0;
	insca = insc;
	if inttyp ^= null ()			/* Not send_admin_command_ or some other previleged entity */
	then if inttyp -> mc_ate.flags.reply_restricted then /* Is this terminal limited in who it can quit? */
		if inttyp -> mc_ate.restrict_reply ^= insca then do;
		     code = error_table_$io_no_permission; /* Naughty. */
		     return;
		end;

	call mc_util_$mrt_source (insca, mrt_source, code);
	if code ^= 0 then return;			/* Couldn't find him. */
	if ^MRT.source (mrt_source).flags.init then	/* He's not attached. */
	     do;
	     code = error_table_$ioname_not_active;
	     return;
	end;
	if substr (mcmp -> syscon_mseg.quit_bits, mrt_source, 1) then do; /* Quits enabled? */
	     call ioa_ ("Sending quit to ^a (^w)", MRT.source (mrt_source).source, MRT.source (mrt_source).hismess -> syscon_mseg.current_process_id);
	     call hphcs_$ips_wakeup (MRT.source (mrt_source).hismess -> syscon_mseg.current_process_id, "quit");
	end;
	else code = error_table_$io_no_permission;
	return;
%page;
intercom: entry (Destination, Message_ptr, Message_length, inttyp, code);

/**** This entry is called when an operator downstairs wants to talk to
      an operator upstairs. */

	code = 0;
	bufferp2 = addr (buffer2);

	char32 = Destination;
	mc_atep = SEARCH_MC_ANSTBL (char32, code);	/* Look up destination. */
	if code ^= 0 then return;			/* Quit if not in table. */
	if mc_ate.iocb = null ()
	then do;
	     code = error_table_$ioname_not_active;
	     return;
	end;

	call ioa_$rsnnl ("FROM ^a: ^a", buffer2, lng, inttyp -> mc_ate.real_tty_name, message);
	qp = mc_ate.queue_ptr;			/* Locate device queue for destination. */
	sendalarm = "0"b;				/* Don't make a fuss. */
	call mc_util_$queue (qp, sendalarm, bufferp2, lng, 0, code); /* Queue stuff for writing. */
	return;
%page;

/* This entry is called by system_control_ whenever an input line is typed.
   It logs the input line, so that we can find out what was said to the system,
   and it may broadcast the input line to other terminals if the mc_ate for the sending terminal specifies. */

note_input: entry (Message, inttyp, code);

	code = 0;
	if inttyp = null () then return;
	mc_ansp = sc_stat_$mc_ansp;
	bufferp2 = addr (buffer2);
	call ioa_$rs (" (input on ^a) ^a", buffer2, lng, inttyp -> mc_ate.real_tty_name, Message);
	sendalarm = "0"b;				/* Not that important. */

	if inttyp -> mc_ate.broadcast & ^inttyp -> mc_ate.broadcast_all
	then do;					/* Broadcast to specified list? */
	     do k = 1 to inttyp -> mc_ate.n_casts;	/* Scan broadcast list. */
		char32 = inttyp -> mc_ate.cast (k);	/* Get one destination. */
		mc_atep = SEARCH_MC_ANSTBL (char32, code); /* Hunt receiver. */
		if code = 0
		then if mc_atep ^= inttyp then do;	/* NEVER broadcast back to inputter. */
			qp = mc_ate.queue_ptr;	/* Locate queue segment. */
			call mc_util_$queue (qp, sendalarm, bufferp2, lng, 0, code);
		     end;
	     end;
	end;
	else if inttyp -> mc_ate.broadcast & inttyp -> mc_ate.broadcast_all then do; /* Broadcast to everybody? */
	     do k = 1 to mc_anstbl.current_size;	/* Check all consoles. */
		mc_atep = addr (mc_anstbl.entry (k));
		if mc_ate.flags.active then
		     if mc_atep ^= inttyp then do;	/* .. nor does it mean myself (silly) */
			qp = mc_ate.queue_ptr;
			call mc_util_$queue (qp, sendalarm, bufferp2, lng, 0, code);
		     end;
	     end;
	end;
	return;
%page;

/* This entry is called by admin to set the broadcast list for a terminal. The default is no broadcast. */

set_broadcast: entry (intty, instring, code);

dcl  instring char (*);

	code = 0;
	char32 = intty;				/* Search for this console. */
	mc_atep = SEARCH_MC_ANSTBL (char32, code);	/* .. */
	if code ^= 0 then return;

	if instring = "none" then do;			/* Reset switch. */
	     mc_ate.broadcast, mc_ate.broadcast_all = "0"b;
	     mc_ate.n_casts = 0;
	     mc_ate.cast (*) = "";
	end;
	else if instring = "all" then
	     mc_ate.broadcast, mc_ate.broadcast_all = "1"b;
	else do;					/* Must be list. */
	     mc_ate.n_casts = 0;			/* Clear list. */
	     mc_ate.broadcast = "1"b;
	     do i = 1 repeat i + j while (i < length (instring));
		j = search (substr (instring, i), ","); /* find next comma. */
		if j = 0 then j = length (instring) - i + 2;
		mc_ate.n_casts = mc_ate.n_casts + 1;
		mc_ate.cast (mc_ate.n_casts) = substr (instring, i, j - 1);
	     end;
	end;
	return;
%page;

/* This entry is called by admin to set the "reply restriction" for a terminal. */

set_restrict: entry (intty, instring, code);

	code = 0;
	char32 = intty;
	mc_atep = SEARCH_MC_ANSTBL (char32, code);
	if code ^= 0 then return;

	mc_ate.restrict_reply = instring;
	mc_ate.flags.reply_restricted = (instring ^= "");
	return;

%page;
new_vchannel: entry (intty, authority, inttyp, code);

/* This entry is the same as accept (below) except that the virtual channels
   created this way, must be "accepted" by the operator before being used. */

	code = 0;
	char32 = intty;
	new_vchn_flag = "1"b;
	virtual_flag = "1"b;
	cdte_flag = "0"b;

	goto COMMON_NEW;
%page;
new_tty: entry (intty, authority, P_cdte_flag, inttyp, code);

/* This entry accepts a console by symbolic name and adds it
   to the message coordinator's answer table.  It also creates a
   typeout queue segment for this new tty.

   First check for this console already hooked up. If not, do it.
   Return error_table_$ionmat if it's already here.

   mc_commands_$mc_login is used for creating entries in the mc_anstbl
   when the "login {person_id} -operator", without -vchannel, is used;
   it sets the mc_ate.pending flag.  Only these custom-made entries may
   be used for dsa channels when virtual channels are not used.
*/

	code = 0;
	char32 = intty;
	virtual_flag = (index (char32, ".") = 0) & (char32 ^= "otw_");
	cdte_flag = P_cdte_flag;			/* has a cdte ? */
	new_vchn_flag = ""b;

COMMON_NEW:					/* new_vchannel joins us here */

	must_send_operator_response = ""b;		/* i.e., we don't need to send a response */

	mc_atep = SEARCH_MC_ANSTBL (char32, code);
	inttyp = mc_atep;				/* output param */
	if code = 0
	then if ^mc_ate.flags.pending
	     then do;
		string (mc_ate.authority) = authority;	/* Reset authority flags. */
		if mc_ate.sci_ptr ^= null () then do;	/* not supposed to happen, but faults are un-nice. */
		     sc_subsystem_info_ptr = ssu_$get_info_ptr (mc_ate.sci_ptr);
		     sc_subsystem_info.restriction_flags = authority;
		end;
		code = error_table_$ionmat;
		return;
	     end;
	     else if mc_ate.flags.virtual		/* vchannel pending accept */
	     then do;
		mc_ate.flags.pending = ""b;
		if mc_ate.ls_procid ^= ""b		/* network line */
		then call FILL_RESPONSE_STRUCTURE ();
						/* prepare to reply to login_server operator request */

		call CONNECT_PHYSICAL_CHANNEL ();
		return;
	     end;
	     else ;

	else if (code ^= error_table_$ioname_not_found
	     & code ^= error_table_$ioname_not_active)
	then return;

	if mc_atep = null				/* need to allocate a new_entry */
	then do;
	     if ^cdte_flag & ^virtual_flag then do;	/* non-cdt channels are created upon "dialing in" */
		code = error_table_$ioname_not_found;	/* same code as a channel not in MC_SERVICE */
		return;
	     end;
	     j, mc_anstbl.current_size = mc_anstbl.current_size + 1;
	     mc_atep = addr (mc_anstbl.entry (j));
	end;

	else if ^cdte_flag & ^virtual_flag		/* requires pending entry */
	     & code = error_table_$ioname_not_found
	then return;

	code = 0;
	mc_ate.flags = ""b;
	mc_ate.pad_ptrs = ""b;
	mc_ate.flags.vchn_requires_accept = new_vchn_flag;
	mc_ate.queue_ptr = null;
	mc_ate.sci_ptr = null;
	mc_ate.iocb = null;
	mc_ate.cdtep = null;
	mc_ate.queue_event = 0;
	mc_ate.pad_ev_chn = ""b;
	mc_ate.virtual_tty_name = intty;
	mc_ate.oper_info.personid = "";


	string (mc_ate.authority) = authority;		/* What this typewriter is allowed to do. */
	mc_ate.flags.active = "1"b;

/* Now initiate or create queue seg. */

	if length (rtrim (mc_ate.virtual_tty_name)) + length (".queue")
	     <= 32 then call mc_util_$get_seg
		(rtrim (mc_ate.virtual_tty_name) || ".queue", qp, code);
	else do;
	     call mc_util_$get_seg (unique_chars_ (""b), qp, code);
	     if code = 0 then call hcs_$chname_seg (qp, "", intty, (0));
	end;

	if code ^= 0 then goto NEWERR;

	mc_ate.queue_ptr = qp;			/* Seg for queue of things to be typed. */
	mc_ate.n_casts = 0;
	mc_ate.restrict_reply = "";			/* .. and to whom. (default is everybody) */
	string (mc_ate.control) = "0"b;		/* Allowed to type but nothing waiting */

	call ipc_$create_ev_chn (mc_ate.queue_event, code); /* Channel to wake when want to type. */
	if code ^= 0 then goto NEWERR;

/* Set up console queue seg */
	call hcs_$truncate_seg (qp, 0, code);
	if code ^= 0 then goto NEWERR;

	device_queue.channel = mc_ate.queue_event;
	device_queue.device_name = intty;
	device_queue.mc_atep = mc_atep;

/* What to do when typer channel kicked. */
	call ipc_$decl_ev_call_chn (device_queue.channel, mc_wakeups_$typer_out, qp, MC_PRIO, code);
	if code ^= 0 then goto NEWERR;

	call mc_con_rec_$check ();			/* Check to see if we can use this
						   terminal for console recovery. */

	if virtual_flag then do;
	     mc_ate.flags.virtual = "1"b;
	     return;
	end;

	if mc_ate.ls_procid ^= ""b			/* network line */
	then call FILL_RESPONSE_STRUCTURE ();		/* prepare to reply to login_server operator request */


	call CONNECT_PHYSICAL_CHANNEL ();		/* attach iocb, event channel for dial/hangup, etc.
						   mc_login does this for virtual channels
						   when someone logs into one */
	if mc_ate.real_tty_name = "otw_" &
	     mc_ate.flags.the_system_console then	/* Define the mc_ate pointer for otw_ */
	     inttyp = addr (mc_anstbl.entry (1));

	if code = 0 then return;

NEWERR:

	if must_send_operator_response
	then do;
	     ls_operator_resp.status_code = code;
	     call uc_send_ls_response_ (addr (ls_operator_resp),
		size (ls_operator_resp), ls_process_id,
		ls_handle, ls_event_channel, addr (zerobits),
		(intty), 0, code);
	end;
	else ;

	call KILL_TTY (mc_atep);

	return;

%page;
mc_login: entry (intty, Operator_name, P_utep, P_vchannel, P_access_class, P_ls_procid, P_ls_term_ev_chn, P_ls_resp_ev_chn, P_ls_handle, code);

/*  This routine is called by dial_mgr_ to let us know that someone wishes
   to "login" as a message coordinator.

   If the P_vchannel is "", we create a pending mc_ate for the channel, and
   "sign on" the operator.  Only a "pending" entry may be used for a DSA
   channel; "accept" will not create or assign a free mc_ate to DSA channels.
   This is required for DSA channels since there is no CDTE to hold this
   information.

   If the P_vchannel is provided, and a "virtual" mc_ate already exists,
   we fill in the mc_ate.tty portion, attach the iocb and "sign on" the
   operator.

*/

	code = 0;
	char32 = intty;
	utep = P_utep;
	vchannel = P_vchannel;
	access_class_range = P_access_class;
	mc_ansp = sc_stat_$mc_ansp;
	dutp = as_data_$dutp;
	iutep = addr (dutbl.entry (1));		/* Initializer's ute entry ptr */

	op_ok = ""b;

	if vchannel = ""
	then do;
	     mc_atep = SEARCH_MC_ANSTBL (char32, code);
	     if code = 0				/* already active */
		| code = error_table_$ioname_not_active /* already pending */
	     then do;
		code = error_table_$ionmat;
		call ABORT_DIALIN (code, "");
		return;
	     end;

	     else if code ^= error_table_$ioname_not_found
	     then do;
		call ABORT_DIALIN (code, "");
		return;				/* "real" error */
	     end;

	     if mc_atep = null			/* create a new entry */
	     then do;
		if mc_anstbl.current_size = mc_anstbl.max_size
		then do;				/* no more room */
		     code = error_table_$notalloc;
		     call ABORT_DIALIN (code, "");
		     return;
		end;

		mc_anstbl.current_size = mc_anstbl.current_size + 1;
		mc_atep = addr (mc_anstbl.entry (mc_anstbl.current_size));
	     end;

	     unspec (mc_ate) = ""b;
	end;

	else do;					/* attach to a virtual channel */
	     if (index (vchannel, ".") ^= 0) | (vchannel = "otw_")
	     then do;
		code = error_table_$bad_vchannel;
		call ABORT_DIALIN (code, "");
		return;
	     end;

	     mc_atep = SEARCH_MC_ANSTBL (char32, code);
	     if (code = 0
		| code = error_table_$ioname_not_active)
	     then do;
		code = error_table_$ionmat;
		call ioa_$rsnnl ("Channel ^a already in use.", buffer2,
		     (0), char32);
		call sys_log_$command_error (-1, code,
		     "mc_commands_$mc_login", buffer2);
		call ABORT_DIALIN (code, "");
		return;
	     end;

	     else if code ^= error_table_$ioname_not_found
	     then do;
		call ABORT_DIALIN (code, "");
		return;				/* real error */
	     end;

	     mc_atep = SEARCH_MC_ANSTBL (vchannel, code);
	     if code = 0
	     then if mc_ate.iocb ^= null ()
		then do;
		     code = error_table_$vchn_active;
						/* vchannel already active */
		     call ABORT_DIALIN (code, "");
		     return;
		end;
		else ;

	     else do;
		if code = error_table_$ioname_not_found /* vchannel does not exist */
		then code = error_table_$vchn_not_found;
		call ABORT_DIALIN (code, "");
		return;
	     end;

	     if sc_stat_$vchn_requires_accept then do;
		do i = 1 to mc_anstbl.current_size while (^op_ok);
		     if (Operator_name = mc_anstbl.entry (i).oper_info.personid)
						/* operator already cleared */
		     then op_ok = "1"b;
		end;
	     end;
	     if ^mc_ate.flags.vchn_requires_accept then op_ok = "1"b;
	end;

	if aim_check_$greater (get_process_access_class_ (), access_class_range (1))
	then do;
	     call ABORT_DIALIN (error_table_$ai_out_range, "Channel not system_low");
	     return;
	end;

	mc_ate.virtual_tty_name = vchannel;
	mc_ate.real_tty_name = intty;
	mc_ate.sci_ptr = null ();
	mc_ate.cdtep = null ();

	mc_ate.ls_procid = P_ls_procid;		/* Accept wakeups from this process in mc_tty_ */
	mc_ate.ls_term_ev_chn = P_ls_term_ev_chn;
	mc_ate.ls_resp_ev_chn = P_ls_resp_ev_chn;
	mc_ate.ls_handle = P_ls_handle;

	call ipc_$create_ev_chn (mc_ate.event, code);
	if code ^= 0 then do;
	     call ABORT_DIALIN (code, "");
	     return;
	end;

	call ipc_$decl_ev_call_chn (mc_ate.event, mc_anstbl.cons_cont_proc,
	     mc_atep, MC_PRIO, code);
	if code ^= 0 then do;
	     call ABORT_DIALIN (code, "");
	     return;
	end;

	if utep ^= null then
	     ute.proc_id = get_process_id_ ();		/* Target process set in case a bump is done */
	if op_ok
	then do;
	     mc_ate.flags.pending = ""b;
	     call FILL_RESPONSE_STRUCTURE ();
	     call CONNECT_PHYSICAL_CHANNEL ();
	     if code ^= 0 then do;
		call ABORT_DIALIN (code, "");
		return;				/* let AS deal with the login_server */
	     end;
	end;
	else mc_ate.flags.pending = "1"b;		/* wait for "accept" */

/* Tell the operator */

	call sys_log_ (SL_LOG_BEEP, "^a: Channel ^a^[ vchannel (^a)^;^s^] dialed to Initializer (^a^[ ACCEPTED^])",
	     "mc_commands_$mc_login", mc_ate.real_tty_name,
	     mc_ate.flags.virtual, mc_ate.virtual_tty_name,
	     Operator_name, op_ok);

/* Sign on the operator */

	if ^sc_stat_$no_operator_login then
	     mc_ate.oper_info.personid = Operator_name;

	code = 0;
	call DIALIN_OK ();

	return;
%page;

remove_tty: entry (intty, P_drop_terminal, code);

/* This entry is called to remove a tty from the message coordinator.
   It removes all references to this channel from all vcons table entries.
   If intty is the name of the real channel connected to a virtual channel,
   the real channel is dropped, but the output to the virtual channel
   continues to get queued up, i.e., the virtual channel may be reused
   without needing to be "accepted" again.  Otherwise, the channel is removed
   from the list of destinations of all virtual consoles and the iocb, queue
   segment, event channels and the corresponding mc_ate are destroyed.

   If this entry is called from mc_tty_ when a terminal is disconnected,
   P_drop_terminal is ""b and no attempt is made to disconnect the line.
*/

	code = 0;
	char32 = intty;
	if index (char32, ".") ^= 0
	     | intty = "otw_"
	then virtual_flag = ""b;
	else virtual_flag = "1"b;

	mc_atep = SEARCH_MC_ANSTBL (char32, code);

	if code = error_table_$ioname_not_active
	then do;
	     if P_drop_terminal
	     then do;
		code = 0;
		if mc_ate.ls_procid = ""b & ^mc_ate.virtual
		then call DROP_CDT_TERMINAL (mc_atep, char32);
		else call SEND_OPERATOR_RESPONSE (mc_ate.real_tty_name,
			error_table_$action_not_performed);
	     end;
	     mc_ate.flags.pending = ""b;
	     mc_ate.real_tty_name = "";
	     mc_ate.oper_info.personid = "";
	     mc_ate.ls_procid = ""b;
	     return;
	end;

	if code ^= 0 then do;
	     code = 0;
	     call DROP_CDT_TERMINAL (mc_atep, char32);
	     if code ^= 0 then call
		     sys_log_ (SL_LOG_BEEP, "Unable to locate a CDT entry for ^a while attempting to drop it.",
		     char32);
	     return;
	end;


/* Find every reference to this typewriter that is made in the vcons tab */
	do vce = 1 to vcons_tab.no_of_vcons;
	     vcep = addr (vcons_tab.vcons (vce));
	     if vcons.flags.inuse			/* No need to look at empty entries */
	     then do dest = 1 to vcons.no_of_dest;
		if vcons.dest (dest).dest = char32 then /* found a reference */
		     do;				/* Get rid of it */
		     do i = dest to vcons.no_of_dest - 1;
			vcons.dest (i).type = vcons.dest (i + 1).type;
			vcons.dest (i).dest = vcons.dest (i + 1).dest;
			vcons.dest (i).queue_seg_ptr = vcons.dest (i + 1).queue_seg_ptr;
		     end;
		     vcons.no_of_dest = vcons.no_of_dest - 1;
		     goto rtnext;			/* Assume its not here twice */
		end;
	     end;
rtnext:	end;


/* Remember the star entry */
	vcep = addr (vcons_tab.star_entry);
	do dest = 1 to vcons.no_of_dest;
	     if vcons.dest (dest).dest = char32 then
		do;
		do i = dest to vcons.no_of_dest - 1;
		     vcons.dest (i).type = vcons.dest (i + 1).type;
		     vcons.dest (i).dest = vcons.dest (i + 1).dest;
		     vcons.dest (i).queue_seg_ptr = vcons.dest (i + 1).queue_seg_ptr;
		end;
		vcons.no_of_dest = vcons.no_of_dest - 1;
		goto rtnext1;
	     end;
	end;
rtnext1:

	if mc_ate.pending				/* pending on a vchannel */
	then do;
	     if P_drop_terminal
	     then do;
		code = 0;
		if mc_ate.ls_procid = ""b & ^mc_ate.virtual
		then call DROP_CDT_TERMINAL (mc_atep, char32);
		else call SEND_OPERATOR_RESPONSE (mc_ate.real_tty_name,
			error_table_$action_not_performed);
	     end;
	     if mc_ate.real_tty_name = char32		/* just drop the real tty of a vchannel */
	     then do;
		mc_ate.flags.pending = ""b;
		mc_ate.real_tty_name = "";
		mc_ate.oper_info.personid = "";
		mc_ate.ls_procid = ""b;
		return;
	     end;
	     else ;				/* drop down to call kill_tty */
	end;

	else if ^(mc_ate.flags.virtual & mc_ate.virtual_tty_name = char32
	     & mc_ate.real_tty_name = "")		/* all but vchns not connected to a real channel */
	then do;
	     call DELETE_IOCB (mc_atep);
	     if P_drop_terminal then do;
		if mc_ate.ls_procid = ""b
		then do;
		     call DROP_CDT_TERMINAL (mc_atep, char32);
		     if code = error_table_$noentry then
			call sys_log_ (SL_TYPE_BEEP, "Unable to locate a CDT entry for ^a while attempting to drop it.", mc_ate.real_tty_name);
		end;
		else do;
		     call SEND_TERMINATE_RESPONSE ();
		     mc_ate.ls_procid = ""b;
		end;
	     end;
	     if mc_ate.virtual_tty_name ^= char32
	     then do;				/* do not remove the mc_ate */
		mc_ate.signed_on = ""b;
		mc_ate.oper_info.personid = "";
		return;
	     end;
	end;

/* "Delete" the mc_ate, queue segment, the whole thing */

	code = 0;
	qp = mc_ate.queue_ptr;

	call KILL_TTY (mc_atep);			/* Remove the mc_ate */

	return;
%page;
/* This entry is essentially an abbreviation for the following sequence of calls:
   remove_tty(intty)
   new_tty   (param1)
   define    (<intty's_vconss>,param1) where <intty's vconss> successively takes on the
   names of all virtual consoles that were
   previously directed to intty.
   It is complicated by having to preserve the output destined for intty, which it puts
   in param1's queue by copying it wholesale.   */

substty: entry (intty, param1, P_cdte_flag, inttyp, P_drop_terminal, code);

	code = 0;
	char32 = intty;
	mc_atep = SEARCH_MC_ANSTBL (char32, code);
	if code ^= 0 then return;			/* Not there, meaningless. */

	inttyp = SEARCH_MC_ANSTBL ((param1), code);	/* We need to weed out the pending entries */
	if code = error_table_$ioname_not_active
	     | code = 0
	then if inttyp -> mc_ate.pending
	     then do;
		code = error_table_$action_not_performed;
		return;
	     end;

	cdte_flag = P_cdte_flag;

	call new_tty (param1, string (mc_ate.authority), cdte_flag,
	     inttyp, autocode);
	if autocode ^= 0 then
	     if autocode = error_table_$ionmat then autocode = 0;
	     else do;				/* Real error. */
		code = autocode;
		return;
	     end;

	p = inttyp -> mc_ate.queue_ptr;		/* Pointer to queue seg of new typewriter. */
	qp = mc_atep -> mc_ate.queue_ptr;		/* Pointer to queue seg of old typewriter. */

/* Change all the references in the virtual console table. */
	do vce = 1 to vcons_tab.no_of_vcons;
	     vcep = addr (vcons_tab.vcons (vce));
	     if vcons.flags.inuse then		/* No need to look at empty entries */
		do dest = 1 to vcons.no_of_dest;
		if vcons.dest (dest).dest = intty then	/* Found a reference */
		     do;				/* Change it */
		     vcons.dest (dest).dest = param1;
		     vcons.dest (dest).queue_seg_ptr = p;
		end;
	     end;
	end;

/* * */
	vcep = addr (vcons_tab.star_entry);
	do dest = 1 to vcons.no_of_dest;
	     if vcons.dest (dest).dest = intty then
		do;
		vcons.dest (dest).dest = param1;
		vcons.dest (dest).queue_seg_ptr = p;
	     end;
	end;

/* Now transfer all the pending output for intty to queue for param1 */
	if qp -> device_queue.no_of_messages = 0 then goto delete; /* Nothing to save */
	i = p -> device_queue.end_of_queue;		/* Link saved stuff to end of savior queue */
	if i ^= 0 then p -> device_queue.line (i).next_line = p -> device_queue.next_free + 1;
	j = p -> device_queue.next_free + 1;		/* Dont fiddle with free list. Just allocate blocks */
	this_line = qp -> device_queue.top_of_queue;

	do jj = 1 to 10000 while (this_line ^= 0);
	     p -> device_queue.line (j).not_done = qp -> device_queue.line (this_line).not_done;
	     p -> device_queue.line (j).alarm = qp -> device_queue.line (this_line).alarm;
	     p -> device_queue.line (j).offset = qp -> device_queue.line (this_line).offset;
	     p -> device_queue.line (j).source = qp -> device_queue.line (this_line).source;
	     p -> device_queue.line (j).line_length = qp -> device_queue.line (this_line).line_length;
	     p -> device_queue.line (j).string = qp -> device_queue.line (this_line).string;
	     this_line = qp -> device_queue.line (this_line).next_line;
	     if this_line = 0 then			/* This is the end of the chain */
		p -> device_queue.line (j).next_line = 0;
	     else do;
		p -> device_queue.line (j).next_line = j + 1;
		j = j + 1;
	     end;
	end;

	p -> device_queue.no_of_messages = p -> device_queue.no_of_messages + qp -> device_queue.no_of_messages;
	if p -> device_queue.top_of_queue = 0 then	/* Savior was previously empty */
	     do;
	     p -> device_queue.top_of_queue = p -> device_queue.next_free + 1;
	     call hcs_$wakeup (mc_anstbl.mc_procid, p -> device_queue.channel, 0, code); /* wake typer_out */
	end;
	p -> device_queue.end_of_queue = j;
	p -> device_queue.next_free = j;

delete:	call DELETE_IOCB (mc_atep);

	if mc_ate.ls_procid = ""b & ^mc_ate.virtual
	then call DROP_CDT_TERMINAL (mc_atep, char32);
	else call SEND_TERMINATE_RESPONSE ();

	if ^(mc_ate.flags.virtual & mc_ate.real_tty_name = char32)
	then call KILL_TTY (mc_atep);			/* Delete the typewriter. */

	return;
%page;
/* This is the guts of the define command.  The human interface is
   in admin_ which then calls this entry for every definition.
   If the specified tty is not found in the mc_anstbl, the vcons
   given the default destination and an error code is returned.
   If the specified vcons is already known, the new destination
   is added, otherwise a new vcons entry is created.  The real
   channel associated with a vchannel may be specified interchangeably
   with the vchannel to which it is connected.  Pending entries not
   associated with vchannels are treated like non-existent ttys.
   Pending entries associated with vchannels are rejected; the
   operator can define the vcons using the star_entry or the
   vchannel name. */

define: entry (invc, type, intty, code);

	code = 0;					/* initialization is bliss */
	if type = "tty" then
	     do;
	     fbtype = 1;
	     char32 = intty;
	     mc_atep = SEARCH_MC_ANSTBL (char32, code);	/* Look for this typewriter in mc_answer table */
	     if code ^= 0 then
		if code ^= error_table_$ioname_not_found
		     & code ^= error_table_$ioname_not_active
		then return;			/* A real error */
		else do;				/* Not there. Use default typewriter. */
		     qp = vcons_tab.star_entry.dest (1).queue_seg_ptr;
		     tempdest = vcons_tab.star_entry.dest (1).dest;
		     mc_atep = device_queue.mc_atep;
		end;
	     else do;				/* Found it. Get relevant info */
		if mc_ate.flags.pending & mc_ate.real_tty_name = char32
		then do;				/* the real channel pending accept on vchannel */
		     code = error_table_$action_not_performed;
		     return;
		end;

		qp = mc_ate.queue_ptr;
		tempdest = char32;
	     end;
	     vcep = SEARCH_VCONS_TAB (invc, vce, autocode); /* Look for this vcons in table */
	     if autocode = 0 then goto change_vce;	/* Found it. */
	     if autocode = error_table_$ioname_not_found then goto new_vce; /* Not there */
	     if code = 0 then code = autocode;		/* A real error. */
	     return;
	end;
	else if type = "log" then do;
	     fbtype = 2;
	     tempdest = intty;
	     call log_write_$open (sc_stat_$log_dir, tempdest, "1"b /* create ok */, qp, code);
	     if code ^= 0 then return;
	     vcep = SEARCH_VCONS_TAB (invc, vce, code);	/* Look for this vcons in table. */
	     if code = 0 then goto change_vce;		/* Found it. */
	     if code ^= error_table_$ioname_not_found then return; /* A real error */
	     code = 0;				/* not there */
	     goto new_vce;
	end;

	else if type = "sink" then
	     do;
	     fbtype = 3;
	     tempdest = intty;
	     qp = null;
	     vcep = SEARCH_VCONS_TAB (invc, vce, code);
	     if code = 0 then goto change_vce;
	     if code ^= error_table_$ioname_not_found then return; /* Not there */
	     code = 0;
	     goto new_vce;
	end;

	else do;					/* Bad type */
	     code = error_table_$typename_not_found;
	     return;
	end;

change_vce:
						/* Find out if this destination is already defined */
	do i = 1 to vcons.no_of_dest while (vcons.dest (i).dest ^= tempdest);
	end;
	if i > vcons.no_of_dest then			/* didn't find it */
	     if i > 8 then				/* Not room for it anyway */
		do;
		if code = 0 then code = error_table_$notalloc;
		return;
	     end;
	     else vcons.no_of_dest = i;		/* Allocate new entry */
	vcons.dest (i).type = fbtype;
	vcons.dest (i).dest = tempdest;
	vcons.dest (i).queue_seg_ptr = qp;
	return;

new_vce:
	if vcep = null then				/* There wasn't a vacant entry. */
	     do;
	     vce,
		vcons_tab.no_of_vcons = vcons_tab.no_of_vcons + 1; /* Allocate a new entry. */
	     vcep = addr (vcons_tab.vcons (vce));
	end;
	vcons.vcons = invc;
	vcons.no_of_dest = 1;
	vcons.flags.inuse = "1"b;
	vcons.dest (1).type = fbtype;
	vcons.dest (1).dest = tempdest;
	vcons.dest (1).queue_seg_ptr = qp;
	return;
%page;
redefine: entry (invc, intty, type, param1, code);

	code = 0;
	call undefine (invc, intty, code);
	if code ^= 0 then return;
	call define (invc, type, param1, code);
	return;
%page;
undefine: entry (invc, intty, code);

	code = 0;
	vcep = SEARCH_VCONS_TAB (invc, vce, code);
	if intty = "*" then goto udsMRT;		/* This vcons goes entirely away. */
	if code ^= 0 then return;			/* That vcons isn't there! */
						/* Find the destination and delete it. */
	do dest = 1 to vcons.no_of_dest;
	     if vcons.dest (dest).dest = intty then do;
		do i = dest to vcons.no_of_dest - 1;
		     if vcons.dest (i).type = 2 then
			call log_write_$close (vcons.dest (i).queue_seg_ptr, (0));
		     vcons.dest (i).dest = vcons.dest (i + 1).dest;
		     vcons.dest (i).type = vcons.dest (i + 1).type;
		     vcons.dest (i).queue_seg_ptr = vcons.dest (i + 1).queue_seg_ptr;
		end;
		vcons.no_of_dest = vcons.no_of_dest - 1;
		go to udsMRT;			/* If any daemon is stuck, go wake him */
	     end;
	end;

	code = error_table_$ioname_not_found;		/* Fell out of loop, bad tty name. */
	return;

udsMRT:						/* Eliminate all references in the MRT */
	do mrt_source = 1 to MRT.no_of_sources;
	     if MRT.source (mrt_source).flags.valid then	/* No need to look at empty entries */
		do mrt_stream = 1 to MRT.source (mrt_source).no_of_streams;
		streamp = addr (MRT.source (mrt_source).stream (mrt_stream));
		if stream.flags.valid then		/* No need to look at empty entries */
		     do vc = 1 to stream.no_of_vcons;
		     if stream.vcons (vc) = invc then do; /* Found a reference */
			if intty = "*" then do;	/* Deleting whole vcon? */
			     do i = vc to stream.no_of_vcons - 1;
				stream.vcons (i) = stream.vcons (i + 1);
				stream.vcons_index (i) = stream.vcons_index (i + 1);
			     end;
			     stream.no_of_vcons = stream.no_of_vcons - 1;
			end;
			call SHAKE_SOURCE (MRT.source (mrt_source).hismess);
						/* If any daemon waits this console, wake */
			goto udnext;		/* Assume it's not here twice */
		     end;
		end;
udnext:	     end;
	end;
	if intty ^= "*" then return;			/* Unless destroying a vcon entirely, done */

	streamp = addr (MRT.star_entry.stream);
	do vc = 1 to stream.no_of_vcons;
	     if stream.vcons (vc) = invc then do;
		do i = vc to stream.no_of_vcons - 1;
		     stream.vcons (i) = stream.vcons (i + 1);
		     stream.vcons_index (i) = stream.vcons_index (i + 1);
		end;
		stream.no_of_vcons = stream.no_of_vcons - 1;
		goto wipeout;
	     end;
	end;

wipeout:
	if code ^= 0 then return;			/* this vcons isn't there. */
	vcons.flags.inuse = "0"b;			/* Invalidate the entry */
	vcons_tab.no_of_vcons = vcons_tab.no_of_vcons - 1;
	return;
%page;
route: entry (insc, instream, invc, type, code);

	code = 0;
	insca = insc;
	instreama = instream;

/* Find out if this virtual console is known */
	vcep = SEARCH_VCONS_TAB (invc, vce, code);
	if code ^= 0 then
	     if code ^= error_table_$ioname_not_found then return;
	     else do;				/* Use default virtual console */
		vce = 1;
		vcep = addr (vcons_tab.vcons (1));
	     end;

/* Now find place in MRT */
/* source */
	call mc_util_$mrt_source (insca, mrt_source, autocode);
	if autocode ^= 0 then
	     if autocode = error_table_$ioname_not_found then goto new_source; /* not already routed */
	     else return;				/* real error */

/* stream */
	call mc_util_$mrt_stream (mrt_source, instreama, streamp, mrt_stream, autocode);
	if autocode ^= 0 then
	     if autocode = error_table_$ioname_not_found then goto new_stream;
	     else return;

/* See if this vcons already recieves messages from this source-stream */

	do vc = 1 to stream.no_of_vcons;
	     if stream.vcons (vc) = invc then goto refresh;
	end;

/* Not here. */
	if stream.no_of_vcons < 8 then		/* Room enough for another entry. */
	     vc, stream.no_of_vcons = stream.no_of_vcons + 1;
	else do;
	     code = error_table_$notalloc;
	     return;
	end;

refresh:
	if type = "alarm" then substr (stream.flags.alarm, vc, 1) = "1"b; /* Are these messages important? */
	else substr (stream.flags.alarm, vc, 1) = "0"b;
	stream.vcons (vc) = vcons_tab.vcons (vce).vcons;
	stream.vcons_index (vc) = vce;
	return;

new_stream:					/* Create a new stream entry for this source */
	if mrt_stream = 0 then			/* need to allocate a new one */
	     if MRT.source (mrt_source).no_of_streams < 8 then /* there's room enough */
		mrt_stream,
		     MRT.source (mrt_source).no_of_streams = MRT.source (mrt_source).no_of_streams + 1;
	     else do;				/* Not room enough */
		code = error_table_$notalloc;
		return;
	     end;

/* Successfully allocated or there was a vacant entry */
set_stream:
	streamp = addr (MRT.source (mrt_source).stream (mrt_stream));
	stream.flags.valid = "1"b;
	stream.flags.active = "0"b;
	stream.source = insc;
	stream.stream = instream;
	stream.ourmess = mcmp;
	stream.hismess = MRT.source (mrt_source).hismess;
	stream.source_index = mrt_source;
	stream.stream_index = mrt_stream;
	vc, stream.no_of_vcons = 1;
	goto refresh;

new_source:					/* Create new source entry in MRT */
	if mrt_source = 0 then			/* Need to allocate a new one */
	     mrt_source,
		MRT.no_of_sources = MRT.no_of_sources + 1;
						/* else have a vacant one */

	MRT.source (mrt_source).source = insc;
	MRT.source (mrt_source).hismess = null;
	mrt_stream,
	     MRT.source (mrt_source).no_of_streams = 1;
	string (MRT.source (mrt_source).flags) = "01"b;	/* Not initialized but valid */
	goto set_stream;
%page;
reroute: entry (insc, instream, invc, param1, type, code);

	code = 0;
	call deroute (insc, instream, invc, code);
	if code ^= 0 then return;
	call route (insc, instream, param1, type, code);
	return;
%page;
deroute: entry (insc, instream, invc, code);

	code = 0;
	insca = insc;
	instreama = instream;
	call mc_util_$mrt_source (insca, mrt_source, code);
	if code ^= 0 then return;
	call mc_util_$mrt_stream (mrt_source, instreama, streamp, mrt_stream, code);
	if code ^= 0 then return;

	call SHAKE_SOURCE (MRT.source (mrt_source).hismess);
	do vc = 1 to stream.no_of_vcons;
	     if stream.vcons (vc) = invc then do;
		do i = vc to stream.no_of_vcons - 1;
		     stream.vcons (i) = stream.vcons (i + 1);
		     stream.vcons_index (i) = stream.vcons_index (i + 1);
		end;

		stream.no_of_vcons = stream.no_of_vcons - 1;
		goto drend;
	     end;
	end;
	code = error_table_$ioname_not_found;

drend:	return;
%page;

declare  MC_atep pointer;
declare  Operator_name char (*);
declare  Ex_operator_name char (*);
declare  Code fixed bin (35);

sign_in: entry (MC_atep, Operator_name, Ex_operator_name);

	mc_atep = MC_atep;
	Ex_operator_name = "";

	if mc_ate.signed_on
	then Ex_operator_name = mc_ate.oper_info.personid;
	mc_ate.signed_on = "1"b;
	mc_ate.oper_info.personid = Operator_name;
	mc_ate.oper_info.last_input_time = clock ();
	return;

sign_out: entry (MC_atep, Ex_operator_name, Code);

	call SIGN_OUT (MC_atep, Ex_operator_name, Code);
	return;

%page;
listen_to_ttys: entry (P_mpx_name);

/* entry called when FNP comes up, listens to all accepted terminals on that FNP */

declare  error_string char (100) aligned;

	mc_ansp = sc_stat_$mc_ansp;
	if mc_ansp = null () then return;
	mpx_starname = rtrim (P_mpx_name) || ".*.**";

	do i = 1 to mc_anstbl.current_size;
	     mc_atep = addr (mc_anstbl.entry (i));
	     if mc_ate.flags.active
	     then do;
		call match_star_name_ (mc_ate.real_tty_name,
		     mpx_starname, autocode);
		if autocode = 0 then do;
		     if mc_ate.iocb ^= null () then do;
			if mc_anstbl.trace then call ioa_$ioa_switch
				(sc_stat_$master_iocb,
				"MC ^a listen_to_ttys: DETACHING.",
				mc_ate.real_tty_name);
			call iox_$close (mc_ate.iocb, (0));
			call iox_$detach_iocb (mc_ate.iocb, (0));
			call iox_$destroy_iocb (mc_ate.iocb, (0));
		     end;
		     if mc_anstbl.trace then call ioa_$ioa_switch
			     (sc_stat_$master_iocb,
			     "MC ^a listen_to_ttys: ATTACHING.",
			     mc_ate.real_tty_name);

		     call ATTACH_ATE (autocode);
		     if mc_anstbl.trace then do;
			if autocode = 0 then call ioa_$ioa_switch
				(sc_stat_$master_iocb,
				"MC ^a listen_to_ttys: ATTACHED",
				mc_ate.real_tty_name);
			else do;
			     call convert_status_code_ (autocode,
				(8)" ", error_string);
			     call ioa_$ioa_switch (sc_stat_$master_iocb,
				"MC ^a listen_to_ttys: ATTACH FAILED ^a",
				mc_ate.real_tty_name, error_string);
			end;
		     end;
		end;
	     end;
	end;
	return;

%page;
create_iocb: entry (P_mc_atep, code);

/**** Note, if this attach fails, we will have a null sci_ptr.  This will
      occur for tty channels if the multiplexer is not up.

      This routine is also called by mc_tty_ when the login server sends
      a DIALED_UP wakeup to our event channel.
****/

	mc_ansp = sc_stat_$mc_ansp;
	mc_atep = P_mc_atep;
	iocb_name = "mc" || unique_chars_ (""b) || "." ||
	     rtrim (mc_ate.real_tty_name);
	call iox_$attach_name (iocb_name, mc_ate.iocb,
	     "tty_ " || rtrim (mc_ate.real_tty_name) ||
	     " -hangup_on_detach -suppress_dial_manager",
	     codeptr (mc_commands_), code);
	if code ^= 0 then return;

	call iox_$control (mc_ate.iocb, "set_event_channel", addr (mc_ate.event), code); /* cannot be fast */
	if code ^= 0 then go to ERROR;

	call sc_create_sci_ (mc_ate.sci_ptr, code);
	if code ^= 0 then go to ERROR;

	mc_ate.oper_info.last_input_time = clock ();

	sc_subsystem_info_ptr = ssu_$get_info_ptr (mc_ate.sci_ptr);
	sc_subsystem_info.real_iocb = mc_ate.iocb;
	sc_subsystem_info.mc_atep = mc_atep;
	sc_subsystem_info.source_name = mc_ate.real_tty_name;
	sc_subsystem_info.restriction_flags = string (mc_ate.authority);
	sc_subsystem_info.print_ready = "1"b;		/* fake a prompt */
	call iox_$open (mc_ate.iocb, Stream_input_output, "0"b, code);
	if code ^= 0 then do;
	     if mc_ate.flags.virtual then goto ERROR;	/* Should not happen */
	     call iox_$control (mc_ate.iocb, "listen", null (), (0));
	     code = 0;
	end;
	call hcs_$wakeup (mc_anstbl.mc_procid, mc_ate.event, (0), (0)); /* cause mc_tty_ to notice the arrival. */
	return;

ERROR:
	call iox_$close (mc_ate.iocb, (0));
	call iox_$detach_iocb (mc_ate.iocb, (0));
	call iox_$destroy_iocb (mc_ate.iocb, (0));
	if mc_ate.event ^= 0
	then call ipc_$delete_ev_chn (mc_ate.event, (0));
	mc_ate.iocb = null ();
	return;



/* Internal Procedures Follow */
%page;

SEND_OPERATOR_RESPONSE: procedure (P_tty_name, P_code);

dcl  P_tty_name char (32) unaligned;
dcl  P_code fixed bin (35) parameter;
dcl  code fixed bin (35);

	call FILL_RESPONSE_STRUCTURE ();
	ls_operator_resp.status_code = P_code;

	call uc_send_ls_response_ (addr (ls_operator_resp),
	     size (ls_operator_resp), ls_process_id, ls_handle,
	     ls_event_channel, addr (zerobits),
	     (P_tty_name), 0, code);			/* log out user and drop line */

	return;
     end SEND_OPERATOR_RESPONSE;
%page;
SEND_TERMINATE_RESPONSE: procedure;

	unspec (ls_term_resp) = ""b;
	ls_term_resp.header.message_type = LS_TERMINATION_RESPONSE;
	ls_term_resp.header.version = LOGIN_SERVER_TERMINATION_RESPONSE_VERSION_1;
	ls_term_resp.process_id = mc_anstbl.mc_procid;
	wakeup_data_ptr = mc_atep;
	wakeup_data_len = size (mc_ate);
	ls_handle = mc_ate.ls_handle;
	ls_process_id = mc_ate.ls_procid;
	ls_event_channel = mc_ate.ls_term_ev_chn;

	call uc_send_ls_response_ (addr (ls_term_resp),
	     size (ls_term_resp), ls_process_id, ls_handle,
	     ls_event_channel, addr (zerobits),
	     (mc_ate.real_tty_name), 0, code);		/* log out user and drop line */
	return;
     end SEND_TERMINATE_RESPONSE;
%page;

DROP_CDT_TERMINAL: procedure (P_mc_atep, P_tty);

declare  P_mc_atep pointer parameter;
declare  P_tty char (32) unaligned parameter;
declare  wakeup_msg char (8);
declare  bin_msg fixed bin (71) based;
declare  mc_tty char (32) unaligned;

	mc_atep = P_mc_atep;
	mc_tty = P_tty;				/* channel name, only used in case mc_atep or mc_ate.cdtep = null */
	cdtep = null ();

	if mc_atep = null then cdtep = FIND_CDTE (mc_tty);
	else
	     if ^mc_ate.the_system_console then do;
	     if mc_ate.cdtep = null () then cdtep = FIND_CDTE (mc_tty);
	     else cdtep = mc_ate.cdtep;
	end;
	else do;
	     code = 0;				/* this is the booload console */
	     return;
	end;

	if cdtep ^= null ()
	then do;

	     if ^(cdte.in_use > NOW_FREE)
	     then go to SET_NO_ENTRY;			/* not ours now */

	     if cdte.service_type = MC_SERVICE
	     then do				/* usually an MC terminal */
		     cdte.in_use = NOW_HUNG_UP;
		cdte.current_service_type = INACTIVE;
						/* not now */
		return;				/* nothing more to do */
	     end;

	     if cdte.current_service_type = MC_SERVICE
	     then do;
		cdte.current_service_type = INACTIVE;

		call astty_$tty_event (cdtep, (0));
						/* get channel back from MC now */
		cdte.current_service_type = cdte.service_type;
						/* no longer */
		cdte.dialed_to_procid = "0"b;
		cdte.dial_ev_chn = 0;
		cdte.process = null ();
		cdte.tra_vec = WAIT_DIALUP;
		cdte.in_use = NOW_DIALED;
/**** Make dialup_ aware of the channel's new state. */
		wakeup_msg = "device";
		call hcs_$wakeup (as_data_$as_procid, cdte.event,
		     addr (wakeup_msg) -> bin_msg, code);
/**** If channel is authenticated, log it out */
		if cdte.flags.access_control.slave_dial
		then call lg_ctl_$logout_channel (cdtep, "drop");
	     end;
	     else if code ^= error_table_$ioname_not_found
	     then code = error_table_$action_not_performed;
	end;
	else

SET_NO_ENTRY:
	     code = error_table_$noentry;		/* +++ should be changed */
	return;

     end DROP_CDT_TERMINAL;
%page;

DELETE_IOCB: procedure (xp);


dcl  xp ptr parameter;				/* pointer to mc_ate entry */

	if ^(xp -> mc_ate.the_system_console) & (xp -> mc_ate.iocb ^= null)
	     & (mc_ate.cdtep ^= null)
	then do;
	     call iox_$control (xp -> mc_ate.iocb, "hangup", null (), (0));
	     call iox_$close (xp -> mc_ate.iocb, (0));
	     call iox_$detach_iocb (xp -> mc_ate.iocb, (0));
	     call iox_$destroy_iocb (xp -> mc_ate.iocb, (0));
	     call ipc_$delete_ev_chn (xp -> mc_ate.event, code);
	end;

	xp -> mc_ate.iocb = null ();
	xp -> mc_ate.real_tty_name = "";
	xp -> mc_ate.flags.pending = ""b;

/**** Check to see if we have deleted the terminal used for console recovery.
      This routine keys on mc_ate.active to find out if it has any good
      consoles left.  As far as console recovery goes, this terminal is no
      longer active; but if only the real channel of a vchannel is being
      dropped, the vchannel is still active.  Thus the twiddling of
      mc_ate.active below:   */

	mc_ate.active = ""b;
	call mc_con_rec_$check ();
	mc_ate.active = "1"b;


/**** Sign out any operator on this terminal.  And destroy the SSU
      invocation. */

	call SIGN_OUT (xp, old_operator_name, code);

/**** First check for a null sci_ptr.  This can happen if the multiplexer
      for this channel never came up. */

	if xp -> mc_ate.sci_ptr ^= null () then
	     do;
	     if code = 0				/* only if there was an operator signed on */
	     then call lg_ctl_$logout_operator (
		     ssu_$get_info_ptr (xp -> mc_ate.sci_ptr),
		     old_operator_name, "drop");
	     if ^xp -> mc_ate.the_system_console then
		call sc_create_sci_$destroy (xp -> mc_ate.sci_ptr);
	end;
	code = 0;
	return;

     end DELETE_IOCB;

%page;
KILL_TTY: procedure (xp);

dcl  xp ptr parameter;				/* pointer to mc_ate entry */

dcl  (j, jj, k) fixed bin;
dcl  qp ptr;

	if xp -> mc_ate.queue_event ^= 0
	then call ipc_$delete_ev_chn (xp -> mc_ate.queue_event, (0));


	if xp -> mc_ate.queue_ptr ^= null () then do;
	     qp = xp -> mc_ate.queue_ptr;
	     j = qp -> device_queue.top_of_queue;
	     do jj = 1 to 10000 while (j ^= 0);
		k = qp -> device_queue.line (j).source;
		if k > 0 then call SHAKE_SOURCE (MRT.source (k).hismess);
	     end;
	     call hcs_$truncate_seg (qp, 0, (0));
	end;

	xp -> mc_ate.flags.active,
	     xp -> mc_ate.flags.vchn_requires_accept,
	     xp -> mc_ate.flags.virtual = "0"b;		/* free the mc_ate entry */
	xp -> mc_ate.virtual_tty_name = "";
	string (xp -> mc_ate.control) = ""b;

	xp -> mc_ate.flags.signed_on = ""b;
	xp -> mc_ate.oper_info.personid = "";
	xp -> mc_ate.ls_procid = ""b;

	return;

     end KILL_TTY;
%page;
SEARCH_MC_ANSTBL: proc (typw, code) returns (ptr);
dcl  code fixed bin (35);
dcl  typw char (32);
dcl  xp ptr;
dcl  (i, j) fixed bin;

	mc_ansp = sc_stat_$mc_ansp;			/* Most entrypoints call this internal proc */
						/*  just after entry; let this proc set	    */
						/*  mc_ansp.			    */
	j = 0;
	do i = 1 to mc_anstbl.current_size;		/* Search through mc_anstbl */
	     xp = addr (mc_anstbl.entry (i));

	     if xp -> mc_ate.flags.active then		/* Entry in use? */
		if xp -> mc_ate.virtual_tty_name = typw
		     | xp -> mc_ate.real_tty_name = typw
						/* That's us! Say it, go home */
		then do;
		     code = 0;
		     return (xp);
		end;
		else ;
	     else if xp -> mc_ate.flags.pending		/* pending & ^vchn */
	     then if xp -> mc_ate.real_tty_name = typw
						/* That's us ! */
		then do;
		     code = error_table_$ioname_not_active;
		     return (xp);
		end;
		else ;

	     else if j = 0 then j = i;		/* An empty entry; remember first one. */
	     else ;

	end;
	if j = 0 then xp = null;
	else xp = addr (mc_anstbl.entry (j));
	code = error_table_$ioname_not_found;
	return (xp);

     end SEARCH_MC_ANSTBL;
%page;
SEARCH_VCONS_TAB: proc (vcon, vce, code) returns (ptr);
dcl  code fixed bin (35);
dcl  vcon char (*);
dcl  vce fixed bin;
dcl  xp ptr;
dcl  j fixed bin;

	if vcon = "*" then
	     do;
	     vce = 0;
	     xp = addr (vcons_tab.star_entry);
	     code = 0;
	     return (xp);
	end;
	j = 0;
	do vce = 1 to vcons_tab.no_of_vcons;
	     xp = addr (vcons_tab.vcons (vce));
	     if ^(xp -> vcons.flags.inuse) then		/* Empty entry? */
		if j = 0 then j = vce;		/* .. yes. remember first one. */
		else ;
	     else if xp -> vcons.vcons = vcon then
		do;
		code = 0;
		return (xp);
	     end;
	end;
	if j = 0 then xp = null;			/* Currently always happens */
	else xp = addr (vcons_tab.vcons (j));
	vce = j;
	code = error_table_$ioname_not_found;
	return (xp);

     end SEARCH_VCONS_TAB;

SHAKE_SOURCE: proc (xp);

dcl  xp ptr;

	if xp = null then return;
	if xp -> syscon_mseg.mescount ^= 0 then do;
	     xp -> syscon_mseg.mescount = 0;
	     if xp -> syscon_mseg.output_wait then do;
		xp -> syscon_mseg.output_wait = "0"b;
		call hcs_$wakeup (xp -> syscon_mseg.current_process_id,
		     xp -> syscon_mseg.ipc_el.channel, 0, code);
	     end;
	end;

     end SHAKE_SOURCE;
%page;
FILL_RESPONSE_STRUCTURE: procedure ();

	must_send_operator_response = "1"b;

	unspec (ls_operator_resp) = ""b;
	ls_operator_resp.header.message_type = LS_OPERATOR_RESPONSE;
	ls_operator_resp.header.version = LOGIN_SERVER_OPERATOR_RESPONSE_VERSION_1;
	ls_operator_resp.status_code = 0;
	ls_operator_resp.process_group_id = get_group_id_ ();
	ls_operator_resp.process_id = mc_anstbl.mc_procid;
	ls_operator_resp.event_channel = mc_ate.event;
	ls_operator_resp.ring = get_ring_ ();

	wakeup_data_ptr = mc_atep;
	wakeup_data_len = size (mc_ate);

	ls_handle = mc_ate.ls_handle;
	ls_process_id = mc_ate.ls_procid;
	ls_event_channel = mc_ate.ls_resp_ev_chn;

	return;

     end FILL_RESPONSE_STRUCTURE;
%page;
CONNECT_PHYSICAL_CHANNEL: procedure ();

	on cleanup begin;
	     call CPC_ERROR ();
	end;

	mc_ate.flags.signed_on = ^(mc_ate.oper_info.personid = "");

	if mc_ate.ls_procid = ""b
	then do;
	     mc_ate.real_tty_name = char32;
	     call ipc_$create_ev_chn (mc_ate.event, code);/* system console or not */
	     if code ^= 0 then go to CPC_ERROR_RETURN;

	     call ipc_$decl_ev_call_chn (mc_ate.event,
		mc_anstbl.cons_cont_proc, mc_atep, MC_PRIO, code);
	     if code ^= 0 then go to CPC_ERROR_RETURN;
	end;

	if mc_ate.real_tty_name = "otw_"
	then do;
	     mc_ate.flags.the_system_console = "1"b;
	     mc_ate.iocb = sc_stat_$master_iocb;
	     mc_ate.sci_ptr = sc_stat_$master_sci_ptr;
	end;
	else if must_send_operator_response		/* network line */
	then do;					/* wait for connect wakeup */
	     mc_ate.tra_vec = MC_WAIT_DIALUP;
	     call uc_send_ls_response_ (addr (ls_operator_resp),
		size (ls_operator_resp), ls_process_id,
		ls_handle, ls_event_channel, addr (zerobits),
		(mc_ate.real_tty_name), 0, code);

	     must_send_operator_response = ""b;
	     return;
	end;

	else do;
	     call ATTACH_ATE (code);
	     if code = error_table_$invalid_device	/* FNP down */
	     then code = 0;
	end;

	if code = 0 then return;

CPC_ERROR_RETURN:
	call CPC_ERROR ();
	return;

CPC_ERROR: procedure ();

	     if mc_ate.iocb ^= null () & char32 ^= "otw_"
	     then do;
		call iox_$close (mc_ate.iocb, (0));
		call iox_$detach_iocb (mc_ate.iocb, (0));
		call iox_$destroy_iocb (mc_ate.iocb, (0));
	     end;

	     mc_ate.flags.pending = ""b;
	     if ^mc_ate.flags.virtual			/* don't inactivate vchannels */
	     then mc_ate.flags.active = "0"b;
	     mc_ate.real_tty_name = "";
	     call ipc_$delete_ev_chn (mc_ate.event, (0));

	     return;
	end CPC_ERROR;

     end CONNECT_PHYSICAL_CHANNEL;
%page;
ATTACH_ATE:
     procedure (code);

declare  code fixed bin (35);
declare  cdtx fixed bin;
declare  fnp bit (1) aligned;

	if mc_ate.ls_procid = ""b then do;
	     call cdt_mgr_$find_cdt_channel (as_data_$cdtp,
		mc_ate.real_tty_name, cdtx, fnp, code);
	     if code ^= 0 then return;
	     if fnp then do;
		code = error_table_$ioname_not_found;
		return;
	     end;
	     cdtep = addr (as_data_$cdtp -> cdt.cdt_entry (cdtx));
	     mc_ate.cdtep = cdtep;
	     if cdte.in_use = 0 |
		cdte.current_service_type ^= MC_SERVICE
	     then do;
		code = error_table_$ioname_not_found;
		return;
	     end;
	end;

	mc_ate.tra_vec = MC_WAIT_DIALUP;
	mc_ate.sci_ptr = null ();			/* easier to check for null () */

	if mc_ate.ls_procid = ""b
	then call create_iocb (mc_atep, code);
	else ;					/* mc_tty_ will create the iocb for network channels
						   when the login server sends it a DIALED_UP wakeup */
	return;

     end ATTACH_ATE;
%page;
SIGN_OUT:
     procedure (MC_atep, Ex_operator_name, Code);

/**** This procedure actually does the work of signing out an MC terminal. */

dcl  MC_atep ptr parameter;
dcl  Ex_operator_name char (*) parameter;
dcl  Code fixed bin (35) parameter;

	mc_atep = MC_atep;
	Code = 0;
	if ^mc_ate.signed_on
	then Code = error_table_$action_not_performed;
	else do;
	     Ex_operator_name = mc_ate.oper_info.personid;
	     mc_ate.oper_info.personid = "";
	     mc_ate.signed_on = "0"b;
	end;
	return;
     end SIGN_OUT;
%page;
ABORT_DIALIN:
     procedure (P_ec, P_reason);

dcl  P_ec fixed bin (35) parameter;
dcl  P_reason char (*) parameter;

dcl  action fixed bin (17);
dcl  code_reason char (150) varying;
dcl  code_reason_al char (100) aligned;

	if P_ec = 0
	then code_reason = P_reason;
	else do;
	     call convert_status_code_ (P_ec, (""), code_reason_al);
	     code_reason = rtrim (code_reason_al);
	     if P_reason ^= ""
	     then do;
		code_reason = code_reason || ", ";
		code_reason = code_reason || rtrim (P_reason);
	     end;
	end;

	if utep ^= null ()
	then do;

	     action = -AS_AUDIT_CHANNEL_DIALIN;

	     CAI.channel_name = ute.tty_name;
	     CAI.valid = FALSE;
	     if vchannel = "" then CAI.valid.service_info = FALSE;
	     else CAI.valid.service_info = TRUE;
	     if CAI.valid.service_info then do;
		if mc_atep ^= null then
		     CAI.service_info = mc_ate.virtual_tty_name;
		else CAI.service_info = "Unknown";
	     end;
	     else CAI.service_info = "system";
	     CAI.valid.access_class = FALSE;
	     CAI.access_class = FALSE;
	     CAI.valid.access_class_range = FALSE;
	     CAI.access_class_range = access_class_range;
	     CAI.valid.user_validation_level = TRUE;
	     CAI.user_validation_level = iutep -> ute.initial_ring;
	     call as_access_audit_$channel (null, utep, iutep, action, addr (CAI), (code_reason));
	end;

	if P_ec ^= 0
	then code = P_ec;				/* export this error code */
	else code = as_error_table_$dialnotup;		/* default error message */

	return;

     end ABORT_DIALIN;
%page;
DIALIN_OK:
     procedure ();

dcl  action fixed bin (17);

	action = AS_AUDIT_CHANNEL_DIALIN;

	CAI.channel_name = ute.tty_name;
	CAI.valid = FALSE;
	if vchannel = "" then CAI.valid.service_info = FALSE;
	else CAI.valid.service_info = TRUE;
	if CAI.valid.service_info then do;
	     if mc_atep ^= null then
		CAI.service_info = mc_ate.virtual_tty_name;
	     else CAI.service_info = "Unknown";
	end;
	else CAI.service_info = "system";
	CAI.valid.access_class = TRUE;
	CAI.access_class = FALSE;
	CAI.valid.access_class_range = FALSE;
	CAI.access_class_range = access_class_range;
	CAI.valid.user_validation_level = TRUE;
	CAI.user_validation_level = iutep -> ute.initial_ring;

	call as_access_audit_$channel (null, utep, iutep, action, addr (CAI), "");
     end DIALIN_OK;
%page;
FIND_CDTE:
     procedure (P_tty_name) returns (ptr);

dcl  P_tty_name char (*) parameter;

dcl  cdtx fixed bin (17) automatic;
dcl  cdte_ptr pointer;
dcl  tty_name char (32);
dcl  fnp bit (1) aligned;

	tty_name = P_tty_name;
	call cdt_mgr_$find_cdt_channel (as_data_$cdtp, tty_name, cdtx, fnp, code);
	if code = 0 & ^fnp then do;
	     cdte_ptr = addr (as_data_$cdtp -> cdt.cdt_entry (cdtx));
	     return (cdte_ptr);
	end;
	else return (null ());

     end FIND_CDTE;
%page;

/* format: off */
%page; %include access_audit_bin_header;
%page; %include answer_table;
%page; %include as_audit_structures;
%page; %include as_data_;
%page; %include as_wakeup_priorities;
%page; %include author_dcl;
%page; %include cdt;
%page; %include daemon_user_table;
%page; %include device_queue;
%page; %include dialup_values;
%page; %include iox_entries;
%page; %include iox_modes;
%page; %include login_server_messages;
%page; %include mc_anstbl;
%page; %include mess_route_table;
%page; %include sc_stat_;
%page; %include sc_subsystem_info_;
%page; %include sys_log_constants;
%page; %include syscon_mseg;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;
%page; %include vcons_tab;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   mc_commands_$mc_login: error: Channel XXXX already in use.

   S:	sc (error_output)

   T:	$response

   M:     The channel specified for MNA attachment is
   already in use by the message coordinator.

   A:	$tryagain

   Message:
   mc_commands_$mc_login:  Channel XXXX dialed to Initializer (NAME).

   S:	as (severity 1)

   T:	In response to a message coordinator dial request.

   M:     Informative message indicating that a successful dialin occured on
   the specified channel by the named operator.  A subsequent accept is
   required by an authenticated operator to complete the attachment.

   A:     $ignore

   Message:
   mc_commands_$mc_login:  Channel XXXX dialed to Initializer (NAME ACCEPTED).

   S:	as (severity 1)

   T:	In response to a message coordinator dial request.

   M:     Informative message indicating that a successful dialin occured on
   the specified channel by the named operator.

   A:     $ignore

   Message:
   mc_commands_$mc_login:  Channel XXXX vchannel (YYYY) dialed to Initializer (NAME).

   S:	as (severity 1)

   T:	In response to a message coordinator dial request.

   M:     Informative message indicating that a successful dialin occured on
   the specified channel by the named operator.  A subsequent accept is
   required by an authenticated operator to complete the attachment.

   A:     $ignore

   Message:
   mc_commands_$mc_login:  Channel XXXX vchannel (YYYY) dialed to Initializer (NAME ACCEPTED).

   S:	as (severity 1)

   T:	In response to a message coordinator dial request.

   M:     Informative message indicating that a successful dialin occured on
   the specified channel by the named operator.

   A:     $ignore

   Message:
   Unable to locate a CDT entry for XXXX while attempting to drop it.

   S:	as (severity 1)

   T:	In response to a drop operator command.

   M:     Notification that the CDT entry cannot be found to free it as
   a result of dropping the tty channel from the message coordinator.
   The mc_anstbl entry is freed at this point however.

   A:     $ignore

   END MESSAGE DOCUMENTATION */

     end mc_commands_;




		    mc_con_rec_.pl1                 08/04/87  1456.8rew 08/04/87  1428.9      112059



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

mc_con_rec_: procedure;

/* *	Modification history:
   *	75-11-05, Larry Johnson: Modified for new syserr message format
   *	76-08-13, Robert Coren: Modified to check CDT entry pointer
   *	81-06-27, T. Casey: Changed for MR9.0 new wakeup priorities
   *	83-10-08, E. A. Ranzenbach: Changed for new console recovery strategy
   *	84-10-19, W. Olin Sibert: Temp kludge to avoid calling phcs_$syserr_logger_copy
   *	84-11-11, W. Olin Sibert: Moved syserr recovery responsibility into
   *	   syserr_log_man_, and added $queue_message entrypoint for that.
   *	84-11-16, W. Olin Sibert: Modified to handle zero wakeup from 
   *	   ocdcm_ as signal to deactivate console recovery.
   *      1984-10-30 BIM for iox_.
   */

/****^  HISTORY COMMENTS:
  1) change(87-02-05,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek):
     Modified for a change to mc_anstbl.incl.pl1.
  2) change(87-02-12,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek):
     Correct reference through unset pointer (often null pointer)
     when mc_con_rec_$output calls QUEUE_MESSAGE. (phx20767)
                                                   END HISTORY COMMENTS */

/*	This procedure is part of the message coordinator.
   *	It performs those functions necessary for operator console
   *	recovery.  It contains the following entries:
   *
   *	init:	initializes internal static variables
   *	check:	checks to see whether or not the recovery mechanism
   *		should be enabled or disabled
   *	output:	outputs console traffic.
   *
   *	Note that the console recovery mechanism has two states:
   *	enabled:	there is a tty type device available for use by the
   *		console recovery mechanism - ocdcm_ has an event
   *		channel that it can use for console recovery
   *	disabled:	there are mo MC devices available for recovery.
   *
   *	The "active" bit controls whether console recovery is to be 
   *	used; it depends on the values of the wakeups received by
   *	mc_con_rec_$output: a zero value deactivates console recovery,
   *	and a non-zero value activates it. The active/inactive state
   *	controls whether syserr messages are recovered; non-zero 
   *	wakeups will only arrive when the console is inoperable, so 
   *	that the first such wakeup, in effect, turns the mechanism on.
*/


/*		PARAMETER  DATA		*/

declare   arg_mc_ansp pointer parameter;		/* (I) Ptr to message coordinator answer table. */
declare   arg_io_uid fixed bin (71) parameter;		/* (I) ID of message */
declare   arg_log_message_ptr pointer parameter;		/* (I) Pointer to log message to be queued */
declare   arg_alarm_flag bit (1) aligned parameter;	/* (I) Whether to beep */


/*		AUTOMATIC  DATA		*/

	dcl     error_code		 fixed bin (35),	/* Standard system error code. */
	        i			 fixed bin,	/* Work index. */
	        inzr_text_length	 fixed bin,	/* length returned by ocdcm_...	*/
	        inzr_text		 char (256),	/* text returned by ocdcm_...		*/
	        qp		 ptr,		/* Pointer to device queue. */
	        io_uid		 fixed bin (71);	/* identifier of message to retrieve */

/*		EXTERNAL ENTRIES		*/

	dcl     (addr, length, substr, byte, max)
				 builtin;

	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) varying),
	        hphcs_$ocdcm_err_event_chan entry (fixed bin (71)),
	        hphcs_$ocdcm_get_mc_output entry (fixed bin (71), fixed bin (17), char (256)),
	        ioa_$rsnnl		 entry options (variable),
	        ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35)),
	        ipc_$decl_ev_call_chn	 entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)),
	        ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35)),
	        mc_util_$queue	 entry (ptr, bit (1), ptr, fixed bin, fixed bin, fixed bin (35)),
	        mc_wakeups_$con_rec	 entry options (variable),
	        syserr_log_man_$console_recovery entry (bit (1) aligned, fixed bin (35));


/*  */

mc_con_rec_$init: 
     entry (arg_mc_ansp);

/*	This entry is called by mc_util_$init.  It will copy its two
   *	arguments into internal static storage.  It also turns OFF
   *	the console recovery enabled flag.
*/

	arg_mc_ansp -> mc_anstbl.con_rec.flags.enabled = "0"b;

	return;

check: entry;

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* 	This entry is called whenever a tty type device is added or	       */
/*	deleted from the message coordinator answer table.	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	mc_ansp = sc_stat_$mc_ansp;
	if mc_anstbl.con_rec.flags.enabled		/* Do we already have a device/ */
	then do;					/* Yes, make sure we still have it. */
		mc_atep = mc_anstbl.con_rec.mc_ate_ptr;
		if mc_ate.active		/* Is device entry still active? */
		then if mc_ate.tra_vec > MC_WAIT_ANSWERBACK
		     then return;			/* Yes, we are still enabled. */
	     end;


/*	We do not have a tty type device to use for recovery.  We will look
   *	through the list of devices asigned to the message coordinator to see
   *	if there is one that we can use.
*/
	do i = 1 to mc_anstbl.current_size;
	     mc_atep = addr (mc_anstbl.entry (i));	/* Get pointer to device entry. */
	     if ^mc_ate.the_system_console &
		mc_ate.active		/* mess. coord. now owns it ... */
		& mc_ate.tra_vec > MC_WAIT_ANSWERBACK
	     then do;				/* then we can use it for recovery. */
		     call ENABLE;			/* Enable console recovery. */
		     return;
		end;
	end;

/*	We could not find a device to use for recovery.  If recovery had been
   *	enabled, we must turn it OFF.
*/
	if mc_anstbl.con_rec.flags.enabled
	then call DISABLE;

	return;
						/* 	*/
mc_con_rec_$output:
     entry (arg_io_uid);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*										*/
/* This entry is called by mc_wakeups$con_rec when that procedure receives a wakeup. This wakeup	*/
/* indicates that the operator's console software is unable to  perform an output and has asked us	*/
/* to handle the output in its behalf. The io_uid will contain one of the following:		*/
/*										*/
/* 	A positive value which is the syserr sequence number of a syserr message for display.	*/
/* 	In this case we will extract the syserr message from the log and print it.		*/
/*										*/
/* 	A negative value which is a UID of the message in oc_data. For these we will call	*/
/* 	ocdcm_$get_mc_output to extract the message for printing.				*/
/*										*/
/* 	A zero, indicating that the console works again and that console recovery is		*/
/*	to be deactivated.								*/
/*										*/

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

	mc_ansp = sc_stat_$mc_ansp;
	io_uid = arg_io_uid;

	mc_atep = mc_anstbl.con_rec.mc_ate_ptr;		/* -> device entry to write to...	*/
	qp = mc_ate.queue_ptr;			/* -> device's queue segment...	*/

	if (io_uid = 0) then do;			/* Console working again */
	     if ^mc_anstbl.con_rec.flags.active then	/* It wasn't active, so ignore the wakeup */
		return;

	     call syserr_log_man_$console_recovery ("0"b, 0); /* Otherwise, deactivate it */
	     mc_anstbl.con_rec.flags.active = "0"b;
	     return;
	     end;

	if ^mc_anstbl.con_rec.flags.active then do;	/* This is a non-zero (activating) wakeup, */
	     call syserr_log_man_$console_recovery ("1"b, max (0, io_uid));
						/* so we activate the mechanism, giving the */
						/* number of the first message to be recovered, */
	     mc_anstbl.con_rec.flags.active = "1"b;	/* and turn on the flag (but only the first */
	     end;					/* time, until we get the deactivate wakeup */
		
	if (io_uid > 0) then			/* This is a syserr message, so we let */
	     return;				/* our counterpart in syserr_log_man_ get it. */

	if ^as_data_$debug_flag then
	     call hphcs_$ocdcm_get_mc_output (io_uid, inzr_text_length, inzr_text);

	call QUEUE_MESSAGE ("INZR", (-io_uid), 0, "0"b, addr (inzr_text), (inzr_text_length));

	return;

/*  */

mc_con_rec_$queue_log_message:
     entry (arg_log_message_ptr, arg_alarm_flag);

/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This entrypoint is called by syserr_log_man_ to queue a syserr message    */
/* into the console recovery mechanism.				       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	mc_ansp = sc_stat_$mc_ansp;
	log_message_ptr = arg_log_message_ptr;

	mc_atep = mc_anstbl.con_rec.mc_ate_ptr;		/* -> device entry to write to...	*/
	qp = mc_ate.queue_ptr;			/* -> device's queue segment...	*/

	call QUEUE_MESSAGE ("HARD", 
	     (log_message.time), (log_message.sequence), arg_alarm_flag,
	     addr (log_message.text), length (log_message.text));

	return;

/*  */

ENABLE: procedure;


/*	This internal procedure is called to enable the console recovery
   *	mechanism.  We must give ocdcm_ an event channel that it can use
   *	to signal that it wants console recovery.  We will also initialize
   *	the data that must be kept in the mc_anstbl.
*/

	mc_anstbl.con_rec.mc_ate_ptr = mc_atep;		/* Save pointer to recovery device entry. */

	if mc_anstbl.con_rec.enabled			/* Are we already enabled? */
	then return;				/* Yes. */

	call ipc_$create_ev_chn (mc_anstbl.con_rec.ec_id, error_code);
	if error_code ^= 0
	then return;

	call ipc_$decl_ev_call_chn (mc_anstbl.con_rec.ec_id, mc_wakeups_$con_rec, mc_ansp, MC_PRIO, error_code);
	if error_code ^= 0
	then return;

	if ^as_data_$debug_flag then
	     call hphcs_$ocdcm_err_event_chan (mc_anstbl.con_rec.ec_id);

	mc_anstbl.con_rec.flags.active = "0"b;		/* Initialize con_rec flags. */
	mc_anstbl.con_rec.flags.enabled = "1"b;

     end ENABLE;
						/* 	*/
DISABLE: procedure;


/*	This internal procedure is called when we must disable the console
   *	recovery mechanism.  We must tell ocdcm_ that it can no longer use
   *	the event channel that it was previously given.
*/

	mc_anstbl.con_rec.flags.enabled = "0"b;		/* Now all wakeups will be ignored. */

	if ^as_data_$debug_flag then
	     call hphcs_$ocdcm_err_event_chan (0);		/* Take event channel away. */

	call ipc_$delete_ev_chn (mc_anstbl.con_rec.ec_id, (0));

     end DISABLE;
						/* 	*/
QUEUE_MESSAGE: 
     procedure (P_msg_type, P_msg_time, P_msg_sequence, P_alarm_flag, P_msg_ptr, P_msg_lth);

declare   P_msg_type char (4) parameter;
declare   P_msg_time fixed bin (71) parameter;
declare   P_msg_sequence fixed bin (35) parameter;
declare   P_alarm_flag bit (1) aligned parameter;
declare   P_msg_ptr pointer parameter;
declare   P_msg_lth fixed bin (18) parameter;

declare   P_msg char (P_msg_lth) based (P_msg_ptr);

declare   output_buffer char (256);
declare   out_buf_len fixed bin (18);

	     
/* *	This internal procedure is called to queue a message for output
   *	over the assigned console recovery tty type terminal. It creates
   *	a printable representation of the message, including the time,
   *	sequence number (if any), and text, adding a newline if one is 
   *	not present at the end of the message already. */



	call ioa_$rsnnl ("^x^a^2x^4a ^[#^d^;^s^] ^a^[^/^]",
	     output_buffer, out_buf_len,
	     date_time_$format ("^Hd^99.9MH", P_msg_time, "", ""),
	     P_msg_type, 
	     (P_msg_sequence ^= 0), P_msg_sequence,
	     P_msg,
	     (substr (P_msg, length (P_msg), 1) ^= byte (10)));

	call mc_util_$queue (qp, (P_alarm_flag), addr (output_buffer), (out_buf_len), 0, error_code);

	return;

     end QUEUE_MESSAGE;

/* format: off */
%page; %include as_data_;
%page; %include as_wakeup_priorities;
%page; %include mc_anstbl;
%page; %include log_message;
%page; %include sc_stat_;

     end mc_con_rec_;




		    mc_list.pl1                     02/07/85  0954.7r w 02/06/85  1403.7       43038



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


mc_list: proc;

/* MC_LIST - produce a set of define and route commands from current tables.

   Written by THVV
   Modified 750213 by PG to be able to print test_udd tables
*/

dcl (path, dn) char (168) aligned,
     en char (32) aligned,
     srch (10) char (32) aligned,
    (i, j, k, l, m, n) fixed bin,
     write fixed bin init (0),
     ap ptr,
     al fixed bin,
     bchr char (al) unaligned based (ap),
     ec fixed bin (35);

dcl (addr, index, null, search, substr) builtin;

dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)),
     ioa_ entry options (variable),
     com_err_ entry options (variable);

dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
     fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35));

%include vcons_tab;
%include mess_route_table;

dcl  mrtp ptr;
dcl  streamp ptr;

dcl  vconsp ptr;
dcl  vcep ptr;

dcl  typer (3) char (4) aligned int static init ("tty", "log", "sink");

/* ------------------------------------------------------- */

	m = 0;
	l = 0;
	k = 1;
	path = ">system_control_1";
arglp:	call cu_$arg_ptr (k, ap, al, ec);
	if ec ^= 0 then go to vct1;
	if search (bchr, "<>") ^= 0			/* is it a pathname? */
	     then path = bchr;
	else do;
	     m = m + 1;				/* it's a keyword to search for */
	     if m > 10 then go to vct1;
	     if bchr = "*" then l = m;
	     srch (m) = bchr;
	end;
	k = k + 1;
	go to arglp;

vct1:
	i = index (path, " ");
	if i = 0 then i = length (path);
	call expand_path_ (addr (path), i, addr (dn), null, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, "mc_list", "^a", path);
	     return;
	end;
	en = "vcons_tab";
	call hcs_$initiate (dn, en, "", 0, 1, vconsp, ec);
	if vconsp = null then do;
er:
	     call com_err_ (ec, "mc_list", "^a>^a", dn, en);
	     return;
	end;

	call pvcons ("*", addr (vcons_tab.star_entry));

	do i = 1 to vcons_tab.no_of_vcons;
	     if ^vcons_tab.vcons (i).flags.inuse then go to skip;
	     call pvcons (vcons_tab.vcons (i).vcons, addr (vcons_tab.vcons (i)));
skip:	end;

	call hcs_$terminate_noname (vconsp, ec);

/* --------------- */

	en = "MRT";
	call hcs_$initiate (dn, en, "", 0, 1, mrtp, ec);
	if mrtp = null then go to er;

	call pstream ("*", addr (MRT.star_entry.stream));

	do i = 1 to MRT.no_of_sources;
	     if ^MRT.source (i).flags.valid then go to sskip;
	     do j = 1 to MRT.source (i).no_of_streams;
		if MRT.source (i).stream (j).flags.valid then
		     call pstream (MRT.source (i).source, addr (MRT.source (i).stream (j)));
	     end;

sskip:	end;

	call hcs_$terminate_noname (mrtp, ec);
	if write = 0 then call ioa_ ("none");
	return;

/* ------------------------------------------------------- */

pstream:	proc (id, sp);

dcl  id char (*) aligned, sp ptr;

dcl  k fixed bin,
     vstr char (64) varying,
     vconst char (32) aligned,
     sourcet char (32) aligned;

	     streamp = sp;
	     if substr (stream.source, 1, 1) < " " then sourcet = "*";
	     else sourcet = stream.source;
	     do k = 1 to stream.no_of_vcons;

		if substr (stream.flags.alarm, k, 1) then vconst = "*" || stream.vcons (k);
		else vconst = stream.vcons (k);	/* Star means alarm flag will be in message */
		do n = 1 to m;
		     if id = srch (n) then go to pvv1;
		end;
		do n = 1 to m;
		     if stream.stream = srch (n) then go to pvv1;
		end;
		do n = 1 to m;
		     if stream.vcons (k) = srch (n) then go to pvv1;
		end;
		if m ^= 0 then go to pvv2;
pvv1:		call ioa_ ("route ^a ^a ^a",
		     id, stream.stream, vconst);
		write = write + 1;

pvv2:	     end;

	end pstream;

pvcons:	proc (id, sp);

dcl  id char (*) aligned, sp ptr;

dcl  k fixed bin,
     temptype char (8) aligned;

	     vcep = sp;
	     do k = 1 to vcons.no_of_dest;
		temptype = typer (vcons.dest (k).type);
		do n = 1 to m;
		     if id = srch (n) then go to pvv3;
		end;
		do n = 1 to m;
		     if vcons.dest (k).dest = srch (n) then go to pvv3;
		end;
		do n = 1 to m;
		     if temptype = srch (n) then go to pvv3;
		end;
		if m ^= 0 then go to pvv4;
pvv3:		call ioa_ ("define ^a ^a ^a",
		     id, temptype, vcons.dest (k).dest);
		write = write + 1;

pvv4:	     end;

	end pvcons;

     end mc_list;




		    mc_quiesce_.pl1                 08/04/87  1456.8rew 08/04/87  1429.3       36558



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* format: style4 */
mc_quiesce_: proc;

/* Just a little something to wait until all message coordinator terminals are done. */
/* 82-10-28 Written  E. N. Kittlitz. */
/* Modified 1984-10-29 BIM for iox_ */

/****^  HISTORY COMMENTS:
  1) change(86-07-01,Swenson), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek):
     Added support for test system control; no hanging up of process' login
     channel.
  2) change(87-02-05,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek):
     Modified for change to mc_anstbl.incl.pl1.
                                                   END HISTORY COMMENTS */

dcl  atex fixed bin;
dcl  code fixed bin (35);
dcl  have_queued_output bit (1) aligned;
dcl  qp ptr;
dcl  quiesce_tries fixed bin;

dcl  1 write_status_info aligned,
       2 evchn fixed bin (71),
       2 output_pending bit (1);

dcl  ME char (12) static init ("mc_quiesce_") options (constant);

dcl  (addr, null) builtin;

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

dcl  get_process_id_ entry () returns (bit (36));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  mc_wakeups_$set_shutdown_limits entry;
dcl  phcs_$ring_0_message entry (char (*) aligned);
dcl  sub_err_ entry () options (variable);
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));

	mc_ansp = sc_stat_$mc_ansp;
	if ^sc_stat_$mc_is_on |
	     get_process_id_ () ^= mc_anstbl.mc_procid then
	     call sub_err_ (error_table_$out_of_sequence, ME, ACTION_CANT_RESTART);
	call mc_wakeups_$set_shutdown_limits;
	have_queued_output = "1"b;

	do quiesce_tries = 1 to 10 while (have_queued_output);
	     have_queued_output = "0"b;
	     do atex = 1 to mc_anstbl.current_size;
		mc_atep = addr (mc_anstbl.entry (atex));
		qp = mc_ate.queue_ptr;
		if mc_ate.active &			/* shall we even LOOK at this entry? */
		     mc_ate.tra_vec > MC_WAIT_ANSWERBACK &
		     qp ^= null then do;		/* really has a queue segment */
		     if device_queue.no_of_messages > 0 then do;
			have_queued_output = "1"b;	/* have something that can reasonably be done */
			call hcs_$wakeup (mc_anstbl.mc_procid, device_queue.channel, 0, (0));
			call timer_manager_$sleep (1, "10"b); /* 1 micro-second */
		     end;
		end;				/* active mc_ate */
	     end;					/* for each entry in the answer table */
	end;					/* try it a bunch of times */
	if have_queued_output then			/* still stuff left over */
	     call phcs_$ring_0_message ("mc_quiesce_: Unable to quiesce message coordinator. Some queued messages will be lost.");

/* now wait for ttys to stop chattering */

	have_queued_output = "1"b;
	do quiesce_tries = 1 to 60 while (have_queued_output); /* try for up to one minute */
	     have_queued_output = "0"b;
	     do atex = 1 to mc_anstbl.current_size;
		mc_atep = addr (mc_anstbl.entry (atex));
		call iox_$control (mc_ate.iocb, "write_status", addr (write_status_info), code);
		if code ^= 0 | ^write_status_info.output_pending
		then do;
		     call iox_$control (mc_ate.iocb, "hangup", null (), (0));
		     mc_ate.tra_vec = -1;
		end;
		else have_queued_output = "1"b;	/* STILL more */
	     end;					/* tty to check */

	     call timer_manager_$sleep (1, "11"b);	/* sleep 1 second */
	end;					/* try for 1 minute */

	if have_queued_output then
	     call phcs_$ring_0_message ("mc_quiesce_: some terminals still have output in progress. They will be hungup.");

	return;
%page;
%include device_queue;
%page;
%include mc_anstbl;
%page;
%include sc_stat_;
%page;
%include sub_err_flags;
%include iox_entries;
     end mc_quiesce_;




		    mc_tty_.pl1                     07/20/88  1251.1r w 07/19/88  1536.0      334935



/****^  ***********************************************************
        *                                                         *
        * 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: style2 */
mc_tty_:
     proc (Event_call_info_ptr);

/* MC_TTY_ - This program is invoked by ipc_ event call when the hardcore
   sends a device wakeup for a typewriter channel.  Alarm timers may also
   go off for a channel.

   The hardcore wakeup may mean that a channel which was writing and
   encountered lack of output buffer space may now proceed again; or it
   may indicate a read completion; or a hangup.

   When a read completion arrives, this program attempts to copy the data 
   read from the hardcore.  If the operator inputs just an empty line, we
   inhibit output on the channel for 3 minutes and wait to read his command.

   Once we have read a command line, we parse it, and execute it.

   Dennis Capps & Tom Van Vleck    */

/* revised for MCS by Grady 4/28/75
   modified by Robert Coren in August 1976 to use CDT entry
   modified by Robert Coren in June 1977 to use ttt_info_ for terminal-type stuff
   Modified June 1981 by T. Casey for MR9.0 to add metering.
   Modified October 1982 by E. N. Kittlitz to not squawk during shutdown.
   Modified 1984-10-29 BIM for iox_.
   Modified 1984-12-11, BIM: put OPER: back in.
   Modified 1985-01-21, BIM: mc_con_rec_$check when a terminal is dialed up.
   Modified 1985-04-01, E. Swenson: to cause sign_out on hangup.
   Modified 1985-05-14, E. Swenson to remove mc terminals from service 
      upon hangup if terminal was dialed to the Initializer.
*/

/****^  HISTORY COMMENTS:
  1) change(86-03-25,MSharpe), approve(87-07-09,MCR7690),
     audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055):
     Modified to work with (DSA) network channels; to drop channel if
     it can't connect it;  to always trace (temporary).
  2) change(86-06-19,Kissel), approve(86-07-30,MCR7475), audit(86-08-04,Coren),
     install(86-10-09,MR12.0-1181):
     Changed to support the new tty event message format declared in
     net_event_message.incl.pl1 which replaces tty_event_message.incl.pl1.
  3) change(86-06-26,Cox), approve(87-07-09,MCR7690), audit(87-07-30,Parisek),
     install(87-08-04,MR12.1-1055):
     Modified to not read answerback for network channels.  Removed trace
     calls to sys_log_.
  4) change(86-12-08,Brunelle), approve(87-07-09,MCR7690),
     audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055):
     Modified to work with (DSA) network channels; to drop channel if
     it can't connect it !!;to always trace (temporary). (Changes actually
     made by MSharpe on 86-03-25)
  5) change(87-02-05,GDixon), approve(87-07-09,MCR7690),
     audit(87-07-30,Parisek), install(87-08-04,MR12.1-1055):
     Modified for change to mc_anstbl.incl.pl1.
  6) change(87-05-11,Parisek), approve(87-07-09,MCR7690),
     audit(87-07-31,Beattie), install(87-08-04,MR12.1-1055):
     Check cdte.current_terminal_type before filling the set_term_type_info
     structure for the set_term_type order call.
  7) change(87-06-08,Parisek), approve(87-07-09,MCR7690),
     audit(87-07-31,Beattie), install(87-08-04,MR12.1-1055):
     Removed instances of sys_log_ calling when mc_ate.cdtep = null.
                                                   END HISTORY COMMENTS */

/* Parameters */

	declare Event_call_info_ptr	 pointer parameter;


/* Automatic */

	declare code		 fixed bin (35);
          declare errmsg                 char (200);
	declare input_buffer	 char (1000);
	declare line_status_space	 bit (72) aligned;
	declare length_read_in	 fixed bin (21);
	declare ls_wakeup		 bit (1);
	dcl     message		 char (8);
	dcl     old_operator_name	 char (32);
	declare p1		 pointer;
	declare perm_mc_service	 bit (1);
	declare read_answerback	 bit (1);
	declare 1 STTI		 aligned like set_term_type_info;
	declare 1 TI		 aligned like terminal_info;
	declare tty_state		 fixed bin;
	declare type_to_set		 char (32);
	declare wakeup_event	 fixed bin;

/* Based */

	dcl     fixed_bin_71	 fixed bin (71) based;
						/* overlay for message */
	dcl     signal_type		 char (8) based;	/* char overlay for ipc_ message */

/* Entries */

	dcl     astty_$tty_event	 entry (ptr, fixed bin (35));
	dcl     lg_ctl_$logout_channel entry (ptr, char (*));
	dcl     mc_commands_$remove_tty
				 entry (char (*), bit (1) aligned, fixed bin (35));
	dcl     mc_con_rec_$check	 entry;
	dcl     (
	        hphcs_$syserr,
	        hphcs_$syserr_error_code
	        )			 entry options (variable);
	dcl     hcs_$wakeup		 entry (bit (*) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
          declare ioa_$rs                entry options (variable);
	declare ipc_$drain_chn	 entry (fixed bin (71), fixed bin (35));
	declare lg_ctl_$logout_operator
				 entry (ptr, char (*), char (*));
	declare mc_commands_$sign_out	 entry (ptr, char (*), fixed bin (35));
	declare mc_commands_$create_iocb
				 entry (ptr, fixed bin (35));
	declare timed_io_$get_chars	 entry (pointer, fixed binary (71), pointer, fixed binary (21), fixed binary (21),
				 fixed binary (35));
	declare timed_io_$get_line	 entry (pointer, fixed binary (71), pointer, fixed binary (21), fixed binary (21),
				 fixed binary (35));
	declare timed_io_$put_chars	 entry (pointer, fixed binary (71), pointer, fixed binary (21), fixed binary (21),
				 fixed binary (35));
	declare ttt_info_$default_term_type
				 entry (fixed binary, fixed binary, character (*), fixed binary (35));
	dcl     ttt_info_$decode_answerback
				 entry (char (*), fixed bin, char (*), char (*), fixed bin (35));
	dcl     multiplexer_mgr_$state_mpx
				 entry (char (*), fixed bin, fixed bin (35));
	declare sc_process_command_line_
				 entry (pointer, pointer, fixed binary (21));
	declare ssu_$abort_line	 entry () options (variable);
	declare ssu_$get_info_ptr	 entry (pointer) returns (pointer);

	dcl     (
	        as_$meter_enter,
	        as_$meter_exit
	        )			 entry (fixed bin);
	dcl     sys_log_		 entry options (variable);
	dcl     sys_log_$error_log	 entry options (variable);
	dcl     timer_manager_$alarm_wakeup
				 entry (fixed binary (71), bit (2), fixed binary (71));
	dcl     timer_manager_$reset_alarm_wakeup
				 entry (fixed binary (71));

/* External */

	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$line_status_pending
				 fixed bin (35) ext static;
	dcl     error_table_$timeout	 fixed bin (35) ext static;
	dcl     error_table_$io_no_permission
				 fixed bin (35) ext static;
	dcl     error_table_$undefined_order_request
				 fixed bin (35) ext static;

/* Builtins */

	dcl     (null, addr, baseno, index, length,
		reverse, rtrim, substr, unspec, verify)
				 builtin;

/* Constant */

	dcl     ME		 char (32) initial ("mc_tty_") internal static options (constant);
	declare WHITESPACE		 char (7) init (" 	
") /* SP TAB BS VT NL CR FF */ int static options (constant);

	dcl     (
	        UNSPECIFIED_EVENT	 initial (0),
	        DIALUP_EVENT	 initial (1),
	        HANGUP_EVENT	 initial (2),
	        QUIT_EVENT		 initial (3),
	        INPUT_AVAILABLE_EVENT	 initial (4),
	        OUTPUT_SPACE_AVAILABLE_EVENT
				 initial (5),
	        LINE_STATUS_EVENT	 initial (6),
	        MASKED_EVENT	 initial (7)
	        )			 fixed bin internal static options (constant);

	dcl     EVENT_TO_PNAME	 (-1:7) char (22) internal static options (constant) init ("invalid",
						/* -1 */
				 "unspecified",	/*  0 */
				 "dialup",	/*  1 */
				 "hangup",	/*  2 */
				 "quit",		/*  3 */
				 "input available", /*  4 */
				 "output space available",
						/*  5 */
				 "line status",	/*  6 */
				 "masked");	/*  7 */
%page;

/* Program */

	call as_$meter_enter (MSGCORD_METER);		/* meter cpu time and paging used by this procedure */
	mc_ansp = sc_stat_$mc_ansp;

	if Event_call_info_ptr = null
	then call errx ("called with null ptr");

	event_call_info_ptr = Event_call_info_ptr;
	mc_atep = event_call_info.data_ptr;		/* Pointer to mcanstbl entry */
	cdtep = mc_ate.cdtep;			/* Pointer to CDT entry */

	p1 = addr (event_call_info.message);		/* What kind of signal  */
	if sc_stat_$mc_ansp = null
	then call errx ("sc_stat_$mc_ansp is null");
	if baseno (mc_atep) ^= baseno (sc_stat_$mc_ansp)
	then call errx ("called with bad pointer");

	wakeup_event = -1;				/* not set yet */
	errmsg = "";				/* init */

	if event_call_info.sender = mc_anstbl.mc_procid
	then do;
		if p1 -> signal_type = "alarm___"
		then do;				/* Timeout? */
			if mc_ate.iocb = null ()
			then do;
				call hphcs_$syserr (ANNOUNCE,
				     "^a: Channel ^a ^[(vchannel ^a)^;^s^] received TIMEOUT while awaiting DIALUP wakeup.",
				     ME, mc_ate.real_tty_name, mc_ate.flags.virtual, mc_ate.virtual_tty_name);
				goto ttydone;
			     end;

			mc_ate.control.inhibit = "0"b;/* Operator didn't type his command in time. */
			mc_ate.tra_vec = MC_WAIT_READY;
						/* Set state back to "not waiting" */
			call iox_$control (mc_ate.iocb, "start", null (), (0));
						/* In case of lost wakeup, honk on ring 0 */

			go to READ_COMMAND;
		     end;
	     end;

	else if event_call_info.origin.ring > mc_anstbl.dsa_ring_number
	then /* Else didn't signal ourself */
	     if event_call_info.sender = mc_ate.ls_procid
	     then do;				/* wakeup from login server, not hardcore */
		     ls_wakeup = "1"b;
		     dial_event_message_ptr = addr (event_call_info.message);
		     if dial_event_message.control = JUST_DIALED
		     then wakeup_event = DIALUP_EVENT;	/* deal with incompatible message formats */
		     else wakeup_event = HANGUP_EVENT;
		end;
	     else do;
		call ioa_$rs ("Event sent from incorrect ring. ^/event channel = ^d, event message = ^d, event sender = ^b, device signal = ^b^/, ring = ^d, event data ptr = ^p",
		     errmsg, (0), event_call_info.channel_id, event_call_info.message, event_call_info.sender,
		     event_call_info.dev_signal, event_call_info.ring, event_call_info.data_ptr);
		call errx (errmsg);			/* .. ignore unless from ring 0 or 1 */
	     end;
	     
	net_event_message_arg = event_call_info.message;	/* Overlayed on net_event_message. */

/**** Here, wakeup_event is non-zero IFF we received a wakeup from the 
      login server telling us that a MC channel dialed up or hung up.
      Otherwise, the event message contains a type-code which, combined
      with the network type, determines what kind of wakeup we must process. */

	if wakeup_event = -1
	then /* not set already */
	     wakeup_event = decode_event_type (net_event_message.network_type, net_event_message.type);

	if mc_anstbl.trace
	then call sys_log_ (SL_LOG_SILENT,
		"^a: ^a state wait ^[-1(MASKED)^;ZERO^;wait_dialup^;wait_answerback^;wait_ready^;wait_command^] message ^a.",
		ME, mc_ate.real_tty_name, mc_ate.tra_vec + 2,
						/* -1 -> 1 */
		EVENT_TO_PNAME (wakeup_event));

	if wakeup_event = -1			/* i.e. a bad event type, already logged */
	then goto ttydone;

	if mc_ate.tra_vec = -1
	then go to ttydone;				/* masked, whatever */
	tty_state = 0;
	if mc_ate.iocb = null ()
	then if wakeup_event = DIALUP_EVENT & mc_ate.tra_vec = MC_WAIT_DIALUP
	     then do;
		     code = 0;
		     call mc_commands_$create_iocb (mc_atep, code);
		     if code ^= 0
		     then do;
			     call hphcs_$syserr_error_code (ANNOUNCE, code,
				"^a: Connecting to ^a^[ (vchannel ^a)^;^s^].", ME, mc_ate.real_tty_name,
				mc_ate.flags.virtual, mc_ate.virtual_tty_name);

			     call mc_commands_$remove_tty ((mc_ate.real_tty_name), "1"b, code);
			     goto ttydone;
			end;
		end;
	     else do;
		     call hphcs_$syserr (ANNOUNCE,
			"^a: Channel ^a^[ (vchannel ^a)^;^s^] received ^a wakeup while awaiting DIALUP.",
			ME, mc_ate.real_tty_name, mc_ate.flags.virtual, mc_ate.virtual_tty_name,
			EVENT_TO_PNAME (wakeup_event));
		     goto ttydone;
		end;

	call iox_$control (mc_ate.iocb, "state", addr (tty_state), code);
	if tty_state ^= TTY_STATE_DIALED_UP
	then if wakeup_event ^= HANGUP_EVENT & wakeup_event ^= MASKED_EVENT
	     then wakeup_event = HANGUP_EVENT;		/* treat it as a hangup */

	if wakeup_event = QUIT_EVENT
	then if sc_stat_$admin_sci_ptr = mc_ate.sci_ptr & mc_ate.sci_ptr ^= null ()
	     then do;
		     mc_ate.control.inhibit = "0"b;	/* Allow output to come out. */
		     call hcs_$wakeup (mc_anstbl.mc_procid, mc_ate.queue_event, 0, code);
		     call as_$meter_exit (MSGCORD_METER);
						/* turn off metering before returning */
		     call ssu_$abort_line (mc_ate.sci_ptr, 0, "BREAK key aborted command execution.");
		end;

	if wakeup_event = HANGUP_EVENT | wakeup_event = MASKED_EVENT
						/* line hung up */
	then do;
		if wakeup_event = MASKED_EVENT
		then call hphcs_$syserr (BEEP, "^a: channel ^a masked by FNP.", ME, mc_ate.real_tty_name);
		else if mc_ate.tra_vec < MC_WAIT_READY	/* only tattle once */
		then do;				/* so quietly go back to listening */
			mc_ate.tra_vec = MC_WAIT_DIALUP;
			if cdtep ^= null
			then call listen_if_mpx_up ();
			go to ttydone;
		     end;

		go to tty_hung;			/* report it */
	     end;

	else if wakeup_event = OUTPUT_SPACE_AVAILABLE_EVENT
						/* output done, rather than input arrived */
	then go to check_ow;			/* see if we have more */
	else if wakeup_event = LINE_STATUS_EVENT
	then call FLUSH_LINE_STATUS;

	if mc_ate.tra_vec = MC_WAIT_DIALUP
	then do;					/* whatever it said, we see if we are alive */
		call iox_$control (mc_ate.iocb, "state", addr (tty_state), code);
		if code ^= 0 | tty_state < TTY_STATE_DIALED_UP
		then do;
			if cdtep ^= null ()
			then call listen_if_mpx_up;
			go to ttydone;
		     end;

		mc_ate.control.inhibit = "1"b;	/* .. yes. Inhibit output. */
		call SET_TERM_TYPE ("");		/* set the default terminal type */
		if cdtep = null ()			/* DSA channel */
		then read_answerback = "0"b;		/* DSA doesn't support answerback */
		else read_answerback = ^cdte.flags.dont_read_answerback;


		if read_answerback
		then do;
			call iox_$control (mc_ate.iocb, "resetread", null (), (0));
			call ipc_$drain_chn (mc_ate.event, (0));
						/* don't get fooled */
			call iox_$control (mc_ate.iocb, "wru", null (), code);
			if code = error_table_$undefined_order_request
			then goto SKIP_ANSWERBACK;

			if code ^= 0
			then do;
				call hphcs_$syserr_error_code (ANNOUNCE, code, "^a: wru failed for ^a.", ME,
				     mc_ate.real_tty_name);
				go to tty_err;
			     end;
			mc_ate.tra_vec = MC_WAIT_ANSWERBACK;
			goto ttydone;		/* come back later */
		     end;
		else do;
SKIP_ANSWERBACK:
			mc_ate.tra_vec = MC_WAIT_READY;
			call GREET;

			call mc_con_rec_$check;
		     end;
	     end;					/* end DIALUP message processing */

	else if mc_ate.tra_vec = MC_WAIT_ANSWERBACK
	then do;
		mc_ate.tra_vec = MC_WAIT_READY;
		call get_chars (0);			/* no timeout tolerance */
		if length_read_in > 0
		then do;
			if mc_anstbl.trace
			then call sys_log_ (SL_LOG_SILENT, "^a: ^a WRU response ^a", ME, mc_ate.real_tty_name,
				substr (input_buffer, 1, length_read_in));
			type_to_set = "";
			if mc_ate.iocb = null ()
			then do;
				unspec (TI) = ""b;
				TI.version = terminal_info_version;
				call iox_$control (mc_ate.iocb, "terminal_info", addr (TI), code);
				if code ^= 0
				then do;
					call ttt_info_$decode_answerback (
					     substr (input_buffer, 1, length_read_in), (cdte.line_type),
					     type_to_set, (""), code);
						/* ignore code, we will leave the initial terminal type if we have to */
				     end;
			     end;
		     end;
		else type_to_set = "";		/* default */
		call SET_TERM_TYPE (type_to_set);
		call iox_$control (mc_ate.iocb, "resetread", null (), (0));
		call GREET;
		call mc_con_rec_$check;
	     end;


/**** Arriving here, the terminal is dialed up, we were not trying to get
      rid of output. So we look for input. */

READ_COMMAND:
	do while ("1"b);
	     call get_line (0);
	     if length_read_in = 0
	     then go to check_ow;			/* If nothing read, done. */


	     if verify (substr (input_buffer, 1, length_read_in), WHITESPACE) = 0
						/* Its all whitespace */
	     then do;
		     if mc_ate.control.inhibit	/* toggle off */
		     then do;
			     call timer_manager_$reset_alarm_wakeup (mc_ate.event);
			     mc_ate.control.inhibit = "0"b;
			end;
		     else do;
			     mc_ate.control.inhibit = "1"b;
						/* Don't interrupt operator for a while. */
			     call timer_manager_$alarm_wakeup (30, "11"b, mc_ate.event);
						/* 30 seconds of peace and quiet */
			     call write ("OPER: ");
			end;
		end;
	     else do;				/* just execute the command, bud. */
		     mc_ate.control.inhibit = "1"b;	/* Don't interrupt operator for a while. */
		     call sc_process_command_line_ (mc_ate.sci_ptr, addr (input_buffer), length_read_in);
		     mc_ate.control.inhibit = "0"b;	/* Allow output. */
		end;
	end;					/* Try to read more */

/* -------------------------------------------------------- */

/* Come here when tty appears to be hung up */

tty_hung:
	if sc_stat_$shutdown_typed
	then do;					/* if shutting down */
		call sys_log_ (SL_LOG_SILENT, "^a: Line ^a hung up.", ME, mc_ate.real_tty_name);
		mc_ate.tra_vec = -1;
		go to stim;			/* kick outputter */
	     end;
	else if mc_ate.tra_vec >= MC_WAIT_READY
	then call hphcs_$syserr (BEEP, "^a: channel ^a hung up.", ME, mc_ate.real_tty_name);

/**** If the channel is normally designated as MC service (as opposed to being
      "dial system"'ed), then we listen for another dialup on this channel
      wherepon we will continue message coordinator service.  If, however,
      the channel is a network connection or an MCS channel in temporary MC
      service, then we remove it from MC service and give it back to the
      answering service. */

	if cdtep = null ()
	then perm_mc_service = ""b;
	else perm_mc_service = (cdte.service_type = MC_SERVICE);

	if ^perm_mc_service
	then do;					/* remove from MC service */
		call mc_commands_$remove_tty ((mc_ate.real_tty_name), ""b, code);
		if code ^= 0
		then call hphcs_$syserr_error_code (ANNOUNCE, code, "^a: Could not remove ^a from MC use.", ME,
			mc_ate.real_tty_name);

		if cdtep ^= null
		then do;
			call astty_$tty_event (cdtep, code);
			if code ^= 0
			then call hphcs_$syserr_error_code (ANNOUNCE, code,
				"^a: Could not get channel ^a back from MC.", ME, cdte.name);
			cdte.current_service_type = cdte.service_type;
			cdte.dialed_to_procid = ""b;
			cdte.dial_ev_chn = 0;
			cdte.process = null ();
			cdte.tra_vec = WAIT_GREETING_MSG;
			cdte.in_use = NOW_HUNG_UP;
			if cdte.flags.access_control.slave_dial
			then call lg_ctl_$logout_channel (cdtep, "mc hangup");
			message = "device";
			call hcs_$wakeup (mc_anstbl.mc_procid, cdte.event, addr (message) -> fixed_bin_71, code);
			if code ^= 0
			then call hphcs_$syserr_error_code (ANNOUNCE, code,
				"^a: Could not notify answering service of new login channel ^a.", ME, cdte.name);
		     end;
		goto ttydone;
	     end;

	else do;
		mc_ate.tra_vec = MC_WAIT_DIALUP;
		if cdtep ^= null ()
		then call listen_if_mpx_up ();
		go to error_exit;
	     end;


/* Come here when we get an error code from the ttydim. */
/* We check for hangup */
/* Message is printed elsewhere */

tty_err:
	if code = error_table_$line_status_pending	/* we lost the wakeup? */
	then do;
		call FLUSH_LINE_STATUS;
		go to ttydone;
	     end;
	if code ^= error_table_$io_no_permission
	then call iox_$control (mc_ate.iocb, "hangup", null (), (0));

	mc_ate.tra_vec = MC_WAIT_DIALUP;
	if cdtep ^= null
	then call listen_if_mpx_up ();

error_exit:
	mc_ate.control.inhibit = "0"b;		/* Allow output to come out. */
	call hcs_$wakeup (mc_anstbl.mc_procid, mc_ate.queue_event, 0, code);

/**** If a message coordinator terminal hangs up, force a sign_out.  We
      may get here as a result of a drop command.  If so, we have already
      signed out the terminal and desctroyed the ssu invocation. */

	if mc_ate.signed_on & mc_ate.sci_ptr ^= null ()
	then do;
		call mc_commands_$sign_out (mc_atep, old_operator_name, (0));
		call lg_ctl_$logout_operator (ssu_$get_info_ptr (mc_ate.sci_ptr), old_operator_name, "hangup");
	     end;

	if sc_stat_$admin_sci_ptr = mc_ate.sci_ptr & mc_ate.sci_ptr ^= null ()
	then do;
		call as_$meter_exit (MSGCORD_METER);	/* turn off metering before returning */
		sc_subsystem_info_ptr = ssu_$get_info_ptr (sc_stat_$admin_sci_ptr);
		call sc_subsystem_info.hangup_entry (sc_stat_$admin_sci_ptr);
	     end;

/* Come here when we have hung out a read and found no input.
   The ttydim will send us a wakeup when there is some
   If there is stacked output for this channel, or if the device is in output 
   wait, send a wakeup to the output driver for the device
   (mc_wakeups_$typer_out). */

check_ow:
	if (mc_ate.output_wait | mc_ate.output_pending)
	then
stim:
	     call hcs_$wakeup (mc_anstbl.mc_procid, mc_ate.queue_event, 0, code);

/* ALL RETURNS MUST COME HERE TO TURN OFF METERING BEFORE RETURNING !!! */

ttydone:
	call as_$meter_exit (MSGCORD_METER);		/* turn off metering before returning */
	return;					/* Exit */

/* -------------------------------------------------------- */

get_chars:
     procedure (time);

	declare time		 fixed bin (71);

	call timed_io_$get_chars (mc_ate.iocb, time, addr (input_buffer), length (input_buffer), length_read_in, code);
	go to READ_COMMON;

get_line:
     entry (time);

	call timed_io_$get_line (mc_ate.iocb, time, addr (input_buffer), length (input_buffer), length_read_in, code);
READ_COMMON:
	if code = error_table_$timeout
	then code = 0;
	if code = error_table_$io_no_permission
	then go to tty_hung;
	if code ^= 0
	then go to tty_err;

     end get_chars;


write:
     proc (message);

	declare message		 char (*);

/**** This should only be used for short messages. It assumes that
      a moment sleeping will get rid of the output. */


	call timed_io_$put_chars (mc_ate.iocb, 10 * 1000 * 1000, addr (message), length (message), (0), code);
						/* can't block, but patience is possible */
	if code = error_table_$timeout
	then code = 0;
	if code = error_table_$io_no_permission
	then go to tty_hung;
	if code ^= 0
	then go to tty_err;
     end write;


errx:
     proc (msg);
	dcl     msg		 char (*);

	call hphcs_$syserr (ANNOUNCE, "^a: ^a", ME, msg);
	go to ttydone;

     end errx;


listen_if_mpx_up:
     procedure;

	dcl     mpx_name		 char (32);
	dcl     state		 fixed bin;
	dcl     i			 fixed bin;
	dcl     codex		 fixed bin (35);

	i = index (reverse (cdte.name), ".");
	if i = 0
	then return;
	mpx_name = substr (cdte.name, 1, length (cdte.name) - i);
	call multiplexer_mgr_$state_mpx (mpx_name, state, codex);
	if codex = 0
	then if state = FNP_UP
	     then call iox_$control (mc_ate.iocb, "listen", null (), (0));
	return;

     end listen_if_mpx_up;

/* entry used by multiplexer mgr when mpx crashes. We are given a
   cdte pointer instead of a mc_ate pointer */

simulated_wakeup:
     entry (Event_call_info_ptr);

	dcl     1 local_event_call_info
				 aligned like event_call_info automatic;
	dcl     i			 fixed bin;

	event_call_info_ptr = Event_call_info_ptr;
	local_event_call_info = event_call_info;
	cdtep = event_call_info.data_ptr;
	mc_ansp = sc_stat_$mc_ansp;
	do i = 1 to mc_anstbl.current_size;
	     mc_atep = addr (mc_anstbl.entry (i));
	     if mc_ate.active
	     then if mc_ate.real_tty_name = cdte.name
		then do;
			local_event_call_info.channel_id = mc_ate.event;
			local_event_call_info.data_ptr = mc_atep;
			call mc_tty_ (addr (local_event_call_info));
			return;
		     end;
	end;
	return;

GREET:
     procedure;

	declare message		 char (100);

	call ioa_$rs ("Channel ^a attached by Message Coordinator.", message, (0), mc_ate.real_tty_name);
	call write (rtrim (message));
	mc_ate.control.inhibit = "0"b;		/* Reset output-inhibit */
	mc_ate.tra_vec = MC_WAIT_READY;
	return;
     end GREET;

SET_TERM_TYPE:
     procedure (a_type_to_set);

	declare a_type_to_set	 char (*);
	declare type_to_set		 char (32);

	if cdtep = null ()
	then return;				/* DSA doesn't allow changing terminal type */

	type_to_set = a_type_to_set;

	if type_to_set = ""
	then do;
	          if cdte.current_terminal_type ^= ""
		then type_to_set = cdte.current_terminal_type;
		else if cdte.initial_terminal_type ^= ""
		then type_to_set = cdte.initial_terminal_type;
		else do;
GET_TERM_TYPE:
			unspec (TI) = ""b;
			TI.term_type = "";
			TI.version = terminal_info_version;
			call iox_$control (mc_ate.iocb, "terminal_info", addr (TI), code);
			if (code = error_table_$io_no_permission)
			then go to tty_hung;	/* forgive and forget about it */

			if code ^= 0
			then go to TTP_ERROR;

			call ttt_info_$default_term_type (TI.line_type, TI.baud_rate, type_to_set, code);
			if code ^= 0
			then
TTP_ERROR:
			     do;
				call hphcs_$syserr_error_code (ANNOUNCE, code,
				     "^a: No default ttp for ^a line ^d baud ^d.", ME, mc_ate.real_tty_name,
				     TI.line_type, TI.baud_rate);
				go to tty_err;
			     end;
		     end;
	     end;

	STTI.version = 1;
	STTI.name = type_to_set;
	STTI.flags = "1"b;
	STTI.mbz = "0"b;
	if mc_anstbl.trace
	then call sys_log_ (SL_LOG_SILENT, "^a: ^a stty -ttp ^a", ME, mc_ate.real_tty_name, type_to_set);
	call iox_$control (mc_ate.iocb, "set_term_type", addr (STTI), code);
	if code = error_table_$io_no_permission
	then go to tty_hung;
	if code ^= 0
	then do;
		call hphcs_$syserr_error_code (ANNOUNCE, code, "^a: Failed to set terminal type for ^a.", ME,
		     mc_ate.real_tty_name);
		go to tty_err;
	     end;
     end SET_TERM_TYPE;

FLUSH_LINE_STATUS:
     procedure;

	declare code		 fixed bin (35);

	code = error_table_$line_status_pending;
	do while (code ^= 0);
	     call iox_$control (mc_ate.iocb, "line_status", addr (line_status_space), code);
	     if code ^= 0 & code ^= error_table_$line_status_pending
	     then go to tty_err;
	end;
	call iox_$control (mc_ate.iocb, "start", null (), (0));
     end FLUSH_LINE_STATUS;
%page;
decode_event_type:
     procedure (P_network_type, P_event_type) returns (fixed bin);

/**** This internal procedure returns an generic event type based on
      the network type and the event type. */

	dcl     P_network_type	 fixed bin (4) unsigned unaligned parameter;
	dcl     P_event_type	 fixed bin (8) unsigned unaligned parameter;
	dcl     event_type		 fixed bin;

%include net_event_message;

	if P_network_type = MCS_NETWORK_TYPE
	then do;
		if P_event_type = MCS_UNSPECIFIED_MSG
		then event_type = UNSPECIFIED_EVENT;
		else if P_event_type = MCS_DIALUP_MSG
		then event_type = DIALUP_EVENT;
		else if P_event_type = MCS_HANGUP_MSG
		then event_type = HANGUP_EVENT;
		else if P_event_type = MCS_QUIT_MSG
		then event_type = QUIT_EVENT;
		else if P_event_type = MCS_READ_MSG
		then event_type = INPUT_AVAILABLE_EVENT;
		else if P_event_type = MCS_WRITE_MSG
		then event_type = OUTPUT_SPACE_AVAILABLE_EVENT;
		else if P_event_type = MCS_LINE_STATUS_MSG
		then event_type = LINE_STATUS_EVENT;
		else if P_event_type = MCS_MASKED_MSG
		then event_type = MASKED_EVENT;
		else do;
			if P_event_type > MAX_MCS_EVENT_MSG_TYPE
			then call sys_log_$error_log (SL_LOG_SILENT, error_table_$bad_arg, ME,
				"Invalid MCS wakeup event type ^d.", P_event_type);
			else call sys_log_$error_log (SL_LOG_SILENT, error_table_$bad_arg, ME,
				"Unexpected MCS wakeup event type ^a.", MCS_MSG_TYPE_TO_PNAME (P_event_type));
			event_type = -1;
		     end;
	     end;
	else if P_network_type = DSA_NETWORK_TYPE
	then do;
		if P_event_type = DSA_UNSPECIFIED_MSG
		then event_type = UNSPECIFIED_EVENT;
		else if P_event_type = DSA_ESTABLISHMENT_MSG
		then event_type = DIALUP_EVENT;
		else if P_event_type = DSA_TERM_ABNORMAL_MSG
		then event_type = HANGUP_EVENT;
		else if P_event_type = DSA_ATTENTION_MSG
		then event_type = QUIT_EVENT;
		else if P_event_type = DSA_DATA_INPUT_MSG
		then event_type = INPUT_AVAILABLE_EVENT;
		else if P_event_type = DSA_DATA_OUTPUT_MSG
		then event_type = OUTPUT_SPACE_AVAILABLE_EVENT;
		else do;
			if P_event_type > MAX_DSA_EVENT_MSG_TYPE
			then call sys_log_$error_log (SL_LOG_SILENT, error_table_$bad_arg, ME,
				"Invalid DSA event type ^d.", P_event_type);
			else call sys_log_$error_log (SL_LOG_SILENT, error_table_$bad_arg, ME,
				"Unexpected DSA event type ""^a"".", DSA_MSG_TYPE_TO_PNAME (P_event_type));
			event_type = -1;
		     end;
	     end;
	else do;
		call sys_log_$error_log (SL_LOG_SILENT, error_table_$bad_arg, ME,
		     "Unexpected network type ^d in event message.", P_network_type);
		event_type = -1;
	     end;
	return (event_type);

     end decode_event_type;

/* format: off */
%page; %include as_data_;
%page; %include as_meter_numbers;
%page; %include author_dcl;
%page; %include cdt;
%page; %include dial_event_message;
%page; %include dialup_values;
%page; %include event_call_info;
%page; %include iox_entries;
%page; %include mc_anstbl;
%page; %include net_event_message;
%page; %include sc_stat_;
%page; %include sc_subsystem_info_;
%page; %include set_term_type_info;
%page; %include sys_log_constants;
%page; %include syserr_constants;
%page; %include terminal_info;
%page; %include tty_states;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   mc_tty_: Channel CHANNEL (vchannel VCHANNEL) received TIMEOUT while awaiting DIALUP wakeup.

   S:	$info

   T:	$run

   M:	Wakeup was not acted on soon enough by AS.

   A:	$inform

   Message:
   mc_tty_: Channel CHANNEL received TIMEOUT while awaiting DIALUP wakeup.

   S:	$info

   T:	$run

   M:	Wakeup was not acted on soon enough by AS.

   A:	$inform

   Message:
   mc_tty_: Event sent from incorrect ring.
   event channel = N, event message = M, event sender = S, device signal = D
   ring = R, event data ptr = P

   S:	$info

   T:	$run

   M:	An event was sent from a ring higher than the specified MNA ring 2.

   A:	$inform

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE Connecting to CHANNEL (vchannel VCHANNEL).

   S:	$info

   T:	$run

   M:	Error creating an IOCB while attempting to connect channel CHANNEL as
   message coordinator terminal.  Channel cannot be accepted as MC terminal.
   Cannot attach and open I/O switches.

   A:	$inform

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE Connecting to CHANNEL.

   S:	$info

   T:	$run

   M:	Error creating an IOCB while attempting to connect channel CHANNEL as
   message coordinator terminal.  Channel cannot be accepted as MC terminal.
   Cannot attach and open I/O switches.

   A:	$inform

   Message:
   mc_tty_: Channel CHANNEL (vchannel VCHANNEL) received WAKEUP_TYPE wakeup while awaiting DIALUP.

   S:	$info

   T:	$run

   M:	Received an unexpected WAKEUP_TYPE wakeup while waiting for a DIALUP
   wakeup.  Dialup will not succeed.

   A:	$inform

   Message:
   mc_tty_: Channel CHANNEL received WAKEUP_TYPE wakeup while awaiting DIALUP.

   S:	$info

   T:	$run

   M:	Did not receive a DIALUP wakeup WAKEUP_TYPE when should have.
   Recieved an unexpected WAKEUP_TYPE.

   A:	$inform

   Message:
   mc_tty_: Line CHAN hung up.

   S:	as (severity 0)

   T:	$run

   M:	Channel CHAN has been hungup during a system shutdown.

   A:	$ignore

   Message:
   mc_tty_: Invalid argument. Invalid MCS wakeup event type TYPE.

   S:     $as0

   T:     $run

   M:     An MCS wakeup event type TYPE was received which is out of the range
   of known event types. The wakeup was ignored.

   A:     $ignore

   Message:
   mc_tty_: Invalid argument. Unexpected MCS wakeup event type TYPE.

   S:     $as0

   T:     $run

   M:     A known MCS wakeup event type TYPE was received but was not expected
   for a message coordinator terminal. The wakeup was ignored.

   Message:
   mc_tty_: Invalid argument. Invalid DSA wakeup event type TYPE.

   S:     $as0

   T:     $run

   M:     A DSA wakeup event type TYPE was received which is out of the range
   of known event types. The wakeup was ignored.

   A:     $ignore

   Message:
   mc_tty_: Invalid argument. Unexpected DSA wakeup event type TYPE.

   S:     $as0

   T:     $run

   M:     A known DSA wakeup event type TYPE was received but was not expected
   for a message coordinator terminal. The wakeup was ignored.

   A:     $ignore

   Message:
   mc_tty_: Invalid argument. Unexpected network type TYPE in event message.

   S:     $as0

   T:     $run

   M:     An unknown network ident in wakeup event message was received.
   The wakeup was ignored.

   A:     $ignore

   Message:
   OPER:

   S:	Initializer terminal.

   T:	$run

   M:	This message is typed if the operator
   enters a blank line on a message coordinator terminal.
   It indicates that input is expected
   on the terminal, and that output will be
   inhibited for 30 seconds.

   A:	Type a system control command.

   Message:
   Channel CHANNEL_NAME attached by Message Coordinator.

   S:	Initializer terminal.

   T:	$run

   M:	The terminal has been attached by the message coordinator in 
          response to an accept or substty command.

   A:	Proceed to use the terminal.

   Message:
   mc_tty_: called with bad pointer

   S:	BOS typewriter.

   T:	$run

   M:	This message indicates a bug in system_control_ or in
   the Message Coordinator.  An illegal signal has been
   received by the attached terminal handler in system_control_;
   the data pointer that should point to an
   entry in the mc_anstbl does not point to the correct
   segment.  The signal is ignored.

   A:	$contact

   Message:
   mc_tty_: called with null ptr

   S:	BOS typewriter.

   T:	$run

   M:	This message indicates a bug in system_control_ or
   in the Message Coordinator.  An illegal signal has
   been received by the attached terminal handler in
   system_control_.  The signal is ignored.

   A:	$contact

   Message:
   mc_tty_: channel CHAN masked by FNP.

   S:	$beep

   T:	$run

   M:	The channel, CHAN, has just been masked by the FNP.  This is usually
   due to some hardware problem with the channel.

   A:	Fix the problem before re-using the channel.

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE wru failed for CHAN.

   S:	$info

   T:	$run

   M:	The CDT entry for channel CHAN requires an answerback, but an error
   was returned while trying to read it.  The returned error is described by
   ERROR_TABLE_MESSAGE.

   A:	Verify that the channel is configured correctly in the CDT.

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE Could not remove CHAN from MC use.

   S:	$info

   T:	$run

   M:	An error, described by ERROR_TABLE_MESSAGE, was returned from
   mc_commands_$remove_tty while tring to remove channel CHAN from MC service
   after a hangup.

   A:	$inform

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE Could not get channel CHAN back from MC.

   S:	$info

   T:	$run

   M:	An error, described by ERROR_TABLE_MESSAGE, was returned from
   astty_$tty_event while trying to give channel CHAN back to the AS after a
   hangup.

   A:	$inform

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE Could not notify answering service of new
   login channel CHAN.

   S:	$info

   T:	$run

   M:	An error, described by ERROR_TABLE_MESSAGE, was returned from
   hcs_$wakeup while trying to notify the AS about the new login channel CHAN,
   after a hangup.

   A:	$inform

   Message:
   mc_tty_: sc_stat_$mc_ansp is null

   S:	$info

   T:	$run

   M:	This message indicates a bug in system_control_ or
   in the Message Coordinator.  A signal has been received
   by the attached terminal handler in system_control_
   but the signal cannot be handled because the mc_anstbl
   cannot be located.  The signal is ignored.

   A:	$contact

   Message:
   mc_tty_: ERROR_TABLE_MESSAGE Failed to set terminal type for CHAN.

   S:	$info

   T:	$run

   M:	An error described ty ERROR_TABLE_MESSAGE was returned while trying to
   set the terminal type on channel CHAN.

   A:	Depending on the error, it may be ignored, or the channel may be
   hungup.  If the channel is hungup, an attempt should be made to fix the
   error before connecting the terminal again.

   Message:
   mc_tty_: channel CHAN hung up.

   S:	$beep

   T:	$run

   M:	This message indicates that an attempt has been made
   to read input from a terminal device channel attached
   to the Message Coordinator and that the channel is
   not active.  This condition may be due to a transient
   line condition, a terminal failure, or a communications
   line failure.  The system attempts to proceed.

   A:	If the terminal is a hardwired device and can be
   reconnected, do so.  If this is a dialup channel that has
   failed, use the substty or drop commands to remove
   the channel.

   Message:
   mc_tty_: No default ttp for CHANNEL line LINE baud BAUD.

   S:	$beep

   T:	$run

   M:	Could not get default terminal type for terminal on CHANNEL which
   has a line type of LINE.  Hangup will follow.

   A:     $inform


   END MESSAGE DOCUMENTATION */

     end mc_tty_;




		    mc_util_.pl1                    09/03/87  1218.5r w 09/03/87  1209.7      149238



/****^  ***********************************************************
        *                                                         *
        * 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: style4,indattr */

mc_util_: procedure;

/* This procedure contains utility routines used by the message coordinator.
   It contains the following entries:
   init:
   mrt_source:
   mrt_stream:
   get_seg:
   queue
*/

/* message_coordr_ was originally created by Dennis Capps
   with advice from TH VanVleck in October of 1972.
   mc_util_ created by Bill Silver on May 31, 1974.
   modified August 1976 by Robert Coren to get pointer to CDT and to behave sensibly if init entry is called twice.
   Modified June 1971 by T. Casey for MR9.0 for new wakeup priorities.
   Modified 1984-12, BIM: iox_ message coordinator.
*/


/****^  HISTORY COMMENTS:
  1) change(86-01-07,MSharpe), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     Added the new "virtual_flag" and "cdt_channel_flag" arguments to the
     declaration and calls to mc_commands_$new_tty.
  2) change(87-02-05,GDixon), approve(87-05-01,MCR7690),
     audit(87-05-10,Parisek), install(87-08-04,MR12.1-1055):
     Modified for a change to mc_anstbl.incl.pl1.
     Added the new "cdt_channel_flag" argument to the declaration and
     calls to mc_commands_$new_tty.
  3) change(87-03-27,Parisek), approve(87-05-01,MCR7690),
     audit(87-08-03,GDixon), install(87-08-04,MR12.1-1055):
     Initialize the mc_anstbl.dsa_ring_number entry in the mc_anstbl
     structure.
                                                   END HISTORY COMMENTS */

%page;
/* Parameters */
declare
         arg_alarm		  bit (1),		/* ON => alarm message. */
         arg_code		  fixed bin,		/* Error code. */
         arg_entry_name	  char (*),		/* Name of segment to initiate. */
         arg_qp		  ptr,			/* Pointer to output queue segment. */
         arg_seg_ptr	  ptr,			/* Pointer to segment that was initiated. */
         arg_source_name	  char (*),		/* Name of source entry. */
         arg_sourcex	  fixed bin,		/* Index to source entry. */
         arg_stream_name	  char (*),		/* Name of stream entry. */
         arg_streamp	  ptr,			/* Pointer to stream entry. */
         arg_streamx	  fixed bin,		/* Index to stream entry. */
         arg_string_len	  fixed bin,		/* Length of input string. */
         arg_source		  fixed bin,		/* Source index */
         arg_string_ptr	  ptr,			/* Pointer to input string. */
         ansptr		  ptr,			/* Returned pointer to mc_anstbl. */
         cons_cont_proc	  entry,			/* Entry to call to twitch typewriter. */
         intty		  char (*),		/* Console name.  */
         inttyp		  ptr,			/* Returned pointer to mc_ate. */
         sdir		  char (*);		/* Pathname of system directory for tables. */

/* Declarations of POINTERS  */
declare
         cdtp		  ptr,			/* to Channel Definition Table */
         mc_ansp_stat	  ptr int static init (null), /* to mc_anstbl */
         mcmp		  ptr int static init (null), /* to message seg for message coordinator */
         messp		  ptr int static init (null), /* to a partic message */
         mrtp		  ptr int static init (null), /* to Message Routing Table */
         qp		  ptr,			/* to queue of lines to be typed on a device */
         seg_ptr		  ptr,			/* to make a segment. */
         streamp		  ptr,			/* to a stream entry in MRT. */
         string_ptr		  ptr,			/* to input string. */
         temp_SDBp		  ptr int static init (null), /* to temp_SDB */
         vcep		  ptr,			/* to an entry in virtual console table */
         vconsp		  ptr int static init (null); /* to Virtual CONSole table */

/* Fixed binary quantities */
declare
         ackn		  fixed bin (71) init (0),	/* event message for calls to hcs_$wakeup */
         code		  fixed bin,		/* Error code */
         i		  fixed bin,		/* a temporary index */
         j		  fixed bin,		/* another temporary index */
         sourcex		  fixed bin,
         streamx		  fixed bin,
         string_len		  fixed bin,
         vacantx		  fixed bin;

/* Character strings */
declare
         entry_name		  char (32),
         source_name	  char (32),
         stream_name	  char (32),
         sysdir		  char (168) int static init (">system_control_1");

/* BIT strings */
declare
         dont_log		  bit (1) init ("0"b),	/* "1"b=>Sentinel-- Needn't be logged */
         initialized	  bit (1) int static init ("0"b), /* to prevent multiple initializations */
         wake_typer		  bit (1);		/* ON => send wakeup. */

/* BUILTIN FUNCTIONS */
declare
         addr		  builtin,
         null		  builtin,
         string		  builtin;

/* EXTERNAL ENTRIES */
declare
         get_process_id_	  entry returns (bit (36)),
         hcs_$add_acl_entries	  entry (char (*), char (*), ptr, fixed bin, fixed bin),
         hcs_$initiate	  entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin),
         hcs_$make_seg	  entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin),
         hcs_$terminate_noname  entry (ptr, fixed bin),
         hcs_$truncate_seg	  entry (ptr, fixed bin, fixed bin),
         hcs_$wakeup	  entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin),
         ipc_$create_ev_chn	  entry (fixed bin (71), fixed bin),
         ipc_$decl_ev_call_chn  entry (fixed bin (71), entry, ptr, fixed bin, fixed bin),
         mc_commands_$define	  entry (char (*), char (*), char (*), fixed bin),
         mc_commands_$init	  entry (ptr, ptr, ptr, ptr, ptr),
         mc_commands_$new_tty	  entry (char (*), bit (36), bit (1) aligned,
			    ptr, fixed bin),
         mc_con_rec_$init	  entry (ptr),
         mc_util_$get_seg	  entry (char (*), ptr, fixed bin),
         mc_wakeups_$init	  entry (ptr, ptr, ptr, ptr),
         mc_wakeups_$protocol	  entry (ptr),
         mc_wakeups_$router	  entry (ptr);

/* EXTERNAL constants */
declare
         error_table_$ioname_not_found ext fixed bin,
         error_table_$noentry	  ext fixed bin;

/* STRUCTURES */
declare
         1 temp_SDB		  int static aligned like stream, /* For calls to mrd_util_$read */
         1 temp_mess	  int static aligned like message_block; /* ditto */

dcl  based_string	        char (string_len) based (string_ptr);

declare
         1 segment_acl	  (1) aligned,
	 2 access_name	  char (32),
	 2 modes		  bit (36),
	 2 mbz		  bit (36) init ("0"b),
	 2 status_code	  fixed bin (35);

%page;
init: entry (sdir, intty, cons_cont_proc, ansptr, inttyp, arg_code);


/* This entry is called to initialize the message coordinator.
   It  sets up all the tables used by the message coordinator.
   It calls the initialization entries of the other procedures
   that make up the message coordinator.
*/
	sysdir = sdir;
	code = 0;

	if initialized				/* already been called */
	then do;					/* we still have to fill in output arguments */
	     call hcs_$initiate (sysdir, "mc_anstbl", "", 0, 1, ansptr, code);
	     if ansptr ^= null
	     then do;
		call hcs_$terminate_noname (ansptr, code); /* once is enough */
		call mc_commands_$new_tty (intty, (36)"1"b, "1"b, inttyp, code);
		arg_code = 0;
	     end;

	     else arg_code = code;
	     return;
	end;

	messp = addr (temp_mess);
	temp_SDBp = addr (temp_SDB);
	temp_SDB.ourmess = null;
	temp_SDB.hismess = null;
	temp_SDB.source = "(op)";
	temp_SDB.stream = "reply";
	temp_SDB.source_index = 0;
	temp_SDB.stream_index = 0;
	temp_SDB.prev_trans.first_block = 0;
	temp_SDB.prev_trans.end_block = 0;
	temp_SDB.prev_trans.current_block = 0;
	temp_SDB.prev_trans.offset = 0;
	temp_SDB.no_of_vcons = 0;
	string (temp_SDB.flags) = "0"b;

/* Initiate mc.message */
	call mc_util_$get_seg ("mc.message", mcmp, code);
	if code ^= 0
	then goto INIT_RETURN;

	temp_SDB.ourmess = mcmp;

/* Initialize mc.message */
	call hcs_$truncate_seg (mcmp, 0, code);		/* Zero it */
	mcmp -> syscon_mseg.current_process_id = get_process_id_ ();
	mcmp -> syscon_mseg.ipc_el.n = 1;
	call ipc_$create_ev_chn (mcmp -> syscon_mseg.ipc_el.channel, code);
	if code ^= 0 then goto INIT_RETURN;
	mcmp -> syscon_mseg.proto_el.n = 1;
	call ipc_$create_ev_chn (mcmp -> syscon_mseg.proto_el.channel, code);
	if code ^= 0 then goto INIT_RETURN;

/* Make these event call channels so sources can get some action going */
	call ipc_$decl_ev_call_chn (mcmp -> syscon_mseg.ipc_el.channel, mc_wakeups_$router, null, MC_PRIO, code);
	call ipc_$decl_ev_call_chn (mcmp -> syscon_mseg.proto_el.channel, mc_wakeups_$protocol, null, MC_PRIO, code);

/* Initiate other segs */
	call mc_util_$get_seg ("mc_anstbl", mc_ansp, code);
	if code ^= 0
	then goto INIT_RETURN;
	mc_ansp_stat, ansptr = mc_ansp;

	call mc_util_$get_seg ("cdt", cdtp, code);
	if code ^= 0 then go to INIT_RETURN;

	call mc_util_$get_seg ("vcons_tab", vconsp, code);
	if code ^= 0
	then goto INIT_RETURN;

	call mc_util_$get_seg ("MRT", mrtp, code);
	if code ^= 0
	then goto INIT_RETURN;

/* Set up mc_anstbl */
/* First fill in the header */
	call hcs_$truncate_seg (mc_ansp, 0, code);
	mc_anstbl.max_size = 256;			/* No of entries permitted. */
	mc_anstbl.mc_procid = mcmp -> syscon_mseg.current_process_id;
	mc_anstbl.sysdir = sysdir;			/* Where to find  put data segs. */
	mc_anstbl.mrtp = mrtp;			/* Pointer to MRT */
	mc_anstbl.vconsp = vconsp;			/* Pointer to Virtual Console Table */
	mc_anstbl.cons_cont_proc = cons_cont_proc;	/* Proc to wake when tty wants something. */
	mc_anstbl.max_sources = 32;
	mc_anstbl.dsa_ring_number = 2;		/* DSA ring */
	

/* Now we must initialize some of the other procedures which make up
   the message coordinator.  We will pass them some pointers they are
   interrested in.
*/
	call mc_commands_$init (mc_ansp, cdtp, temp_SDBp, mcmp, messp);
	call mc_con_rec_$init (mc_ansp);
	call mc_wakeups_$init (mc_ansp, temp_SDBp, mcmp, messp);

/*	Set up first entry in mc_anstbl.
*/
	call mc_commands_$new_tty (intty, (36)"1"b, "1"b, inttyp, code);
	if code ^= 0 then
	     if code = error_table_$ioname_not_found then code = 0;
	     else goto INIT_RETURN;

	call hcs_$truncate_seg (vconsp, 0, code);	/* Initialize virtual console table. */

/* Fill in * entry */
	vcep = addr (vcons_tab.star_entry);
	vcons.vcons = "*";
	vcons.no_of_dest = 1;
	vcons.dest (1).type = 1;
	vcons.dest (1).dest = intty;
	vcons.dest (1).queue_seg_ptr = addr (mc_anstbl.entry (1)) -> mc_ate.queue_ptr;

/* Define the default virtual console. */
	call mc_commands_$define ("default_vcons", "tty", intty, code);
	if code ^= 0 then
	     if code = error_table_$ioname_not_found then code = 0;


/* Initialize the MRT */
	call hcs_$truncate_seg (mrtp, 0, code);
	MRT.star_entry.source = "*";
	MRT.star_entry.hismess = null;
	MRT.star_entry.no_of_streams = 1;
	streamp = addr (MRT.star_entry.stream);
	stream.stream = "*";
	stream.ourmess = mcmp;
	stream.no_of_vcons = 1;
	stream.vcons (1) = "default_vcons";
	stream.vcons_index (1) = 1;
	initialized = "1"b;

INIT_RETURN:
	arg_code = code;
	return;
%page;

mrt_source: entry (arg_source_name, arg_sourcex, arg_code);


/* This entry is called to look for a source entry in the Message
   Routing Table.  It returns the index associated with this
   source entry.
*/

	source_name = arg_source_name;		/* Copy input argument. */
	vacantx = 0;				/* We remember first vacant entry. */

	do sourcex = 1 to MRT.no_of_sources;
	     if MRT.source (sourcex).source = source_name
	     then do;				/* We found the right source entry. */
		arg_sourcex = sourcex;		/* Set return arguments. */
		arg_code = 0;
		return;
	     end;
	     if vacantx = 0				/* Is this a vacant entry? */
	     then if ^MRT.source (sourcex).flags.valid
		then vacantx = sourcex;
	end;

	arg_sourcex = vacantx;			/* Didn't find right source entry. */
	arg_code = error_table_$ioname_not_found;

	return;
%page;

mrt_stream: entry (arg_sourcex, arg_stream_name, arg_streamp, arg_streamx, arg_code);


/* This entry is called to find a stream entry within a source entry.
   It will return a pointer to the stream entry as well as the array
   index associated with this stream entry.
*/

	sourcex = arg_sourcex;			/* Copy argument data. */
	stream_name = arg_stream_name;

	vacantx = 0;				/* We're going to remember the first vacancy. */

	do streamx = 1 to MRT.source (sourcex).no_of_streams;
	     streamp = addr (MRT.source (sourcex).stream (streamx));
	     if streamp -> stream.stream = stream_name
	     then do;				/* Found the right stream entry. */
		arg_streamp = streamp;
		arg_streamx = streamx;
		arg_code = 0;
		return;
	     end;
	     if vacantx = 0				/* Save index of first vacant entry. */
	     then if ^(streamp -> stream.flags.valid)
		then vacantx = streamx;
	end;

	streamx = vacantx;				/* Didn't find the right stream entry. */
	if streamx = 0				/* Did we find a vacant entry? */
	then arg_streamp = null ();			/* No. */
	else arg_streamp = addr (MRT.source (sourcex).stream (streamx));
	arg_streamx = streamx;
	arg_code = error_table_$ioname_not_found;

	return;
%page;

get_seg: entry (arg_entry_name, arg_seg_ptr, arg_code);


/* This entry is called to obtain a pointer to a segment whose entry name
   is passed as an argument.  If we cannot initiate the segment, we will
   make a new segment with that name.
*/

	entry_name = arg_entry_name;			/* Initialize arguments. */
	code = 0;

	call hcs_$initiate (sysdir, entry_name, "", 0, 1, seg_ptr, code);
	if seg_ptr ^= null
	then code = 0;				/* Not null, forget code. */
	else if code = error_table_$noentry		/* Null => segment  not there. */
	then do;
	     call hcs_$make_seg (sysdir, entry_name, "", 01011b, seg_ptr, code);
	     if seg_ptr ^= null
	     then do;				/* We have created it. */
		segment_acl (1).access_name = "*.SysDaemon.*";
		segment_acl (1).modes = "101"b;
		call hcs_$add_acl_entries (sysdir, entry_name,
		     addr (segment_acl), 1, code);
	     end;
	end;

	arg_seg_ptr = seg_ptr;			/* Return arguments. */
	arg_code = code;

	return;
%page;

queue: entry (arg_qp, arg_alarm, arg_string_ptr, arg_string_len, arg_source, arg_code);


/* This entry is called to put a message in a device output queue.
*/

	qp = arg_qp;				/* Copy arguments. */
	code = 0;
	string_ptr = arg_string_ptr;
	string_len = arg_string_len;

	code = 0;
	mc_ansp = mc_ansp_stat;

	if device_queue.top_of_queue = 0 then		/* Empty queue */
	     do;
	     wake_typer = "1"b;			/* REmember to wake typer_out */
	     if device_queue.free_top = 0 then		/* Empty free storage list */
		j,				/* Allocate new block */
		     device_queue.top_of_queue,
		     device_queue.end_of_queue,
		     device_queue.next_free = device_queue.next_free + 1;
	     else do;				/* Take block from free list */
		j, device_queue.top_of_queue,
		     device_queue.end_of_queue = device_queue.free_top;
		device_queue.free_top = device_queue.line (j).next_line;
	     end;
	end;
	else do;					/* Stuff already in queue */
	     wake_typer = "0"b;			/* Wakeup will come from self or tty_aught */
	     if device_queue.free_top = 0 then		/* Empty free storage list */
		j,				/* Allocate new block */
		     device_queue.next_free = device_queue.next_free + 1;
	     else do;				/* Take block from free list */
		j = device_queue.free_top;
		device_queue.free_top = device_queue.line (j).next_line;
	     end;
	     i = device_queue.end_of_queue;		/* Put it on end of queue */
	     device_queue.line (i).next_line,
		device_queue.end_of_queue = j;
	end;
	device_queue.line (j).not_done = "0"b;		/* Fill it in */
	device_queue.line (j).alarm = arg_alarm;
	device_queue.line (j).next_line = 0;
	device_queue.line (j).offset = 0;
	device_queue.line (j).line_length = string_len;
	device_queue.line (j).source = arg_source;
	device_queue.line (j).string = based_string;
	device_queue.no_of_messages = device_queue.no_of_messages + 1;
	if wake_typer
	then call hcs_$wakeup (mc_anstbl.mc_procid, device_queue.channel, 0, code);
	arg_code = code;
	return;

%page;	%include as_wakeup_priorities;
%page;	%include syscon_mseg;
%page;	%include mess_route_table;
%page;	%include vcons_tab;
%page;	%include device_queue;
%page;	%include mc_anstbl;
     end mc_util_;




		    mc_wakeups_.pl1                 07/20/88  1251.1r w 07/19/88  1536.0      290097



/****^  ***********************************************************
        *                                                         *
        * 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: style4 */
mc_wakeups_: procedure;

/* This procedure is part of the message coordinator.  It receives
   all wakeups handled by the message coordinator.

   The message coordinator was originally created by Dennis Capps
   with help from TH VanVleck in October of 1972.
   "mc_wakeups_" originally created by Bill Silver in May, 74.
   Modified 751215 by PG to make any_other handler just return, and fix error handling
   Modified June 1976 by Larry Johnson to use new ocdim_ alarm order call
   Modified August 1976 by Robert Coren to use CDT entry for tty channels
   Modified 770725 by PG to fix bug in folding of multi-line messages
   Modified 25 Sept 1979 by T. Casey to allow setting of message limits.
   Modified June 1981 by T. Casey for MR9.0 to add metering.
   Modified 830620 by E. A. Ranzenbach for new console recovery scheme...
   *	84-11-16, W. Olin Sibert: Modified to handle zero wakeup from
   *	   ocdcm_ as signal to deactivate console recovery.
   *    1985-01-02, BIM: new logging and other improvements.
*/

/****^  HISTORY COMMENTS:
  1) change(86-02-21,MSharpe), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek), install(87-08-06,MR12.1-1054):
     Modified to use new version of mc_anstbl.incl.pl1;  Fixed bug in "router"
     that lost stream.source when using the star_entry.
  2) change(87-02-05,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek), install(87-08-06,MR12.1-1054):
     Modified for a change to mc_anstbl.incl.pl1.  All entrypoints that refer
     to mc_anstbl must now set the automatic variable mc_ansp from
     mc_ansp_stat.
  3) change(87-09-17,Parisek), audit(87-09-21,GDixon),
     approve(87-09-21,MECR0008), install(87-09-21,MR12.1-1114):
     Return with error if status code equals error_table_$unable_to_do_io from
     calling mrd_util_.  This status code represents a condition error
     signalled from mrd_util_. (phx20928)
                                                   END HISTORY COMMENTS */

/* Declaration of Parameters */
declare
         arg_mc_ansp ptr,
         arg_mcmp ptr,
         arg_messp ptr,
         arg_event_call_info_ptr ptr,
         arg_temp_SDBp ptr;

/* Declarations of POINTERS  */
declare
         buffer_ptr pointer,
         log_buffer_ptr pointer,
         tty_buffer_ptr pointer,
         hismp ptr,					/* to message seg of a source */
         linep ptr,					/* to something in a device queue to be printed */
         mc_ansp_stat ptr int static init (null ()),	/* to mc_anstbl */
         mcmp ptr int static init (null),		/* to message seg for message coordinator */
         messp ptr int static init (null),		/* to a particular message */
         mrtp ptr int static init (null),		/* to Message Routing Table */
         qp ptr,					/* to queue of lines to be typed on a device */
         streamp ptr,				/* to a stream entry in MRT */
         temp_SDBp ptr int static init (null),		/* to temp_SDB */
         vcep ptr,					/* to an entry in virtual console table */
         vconsp ptr int static init (null);		/* to Virtual CONSole table */

/* Fixed binary quantities */
declare
         ackn fixed bin (71) init (0),			/* event message for calls to hcs_$wakeup */
         code fixed bin (35),				/* error code */
         dest fixed bin,				/* Index when looping thru phys devices in vcons_tab */
         i fixed bin,				/* a temporary index */
         k fixed bin,				/* loop counter for protocol and router */
         last_line fixed bin,				/* 1 link back in q of lines to be typed */
         limit fixed bin,				/* No of lines typer_out will try to type */
         lng fixed bin,				/* Length of formatted string for output */
         mrt_source fixed bin,			/* Index of source entry in MRT */
         mrt_stream fixed bin,			/* Index of stream entry in source entry in MRT */
         n fixed bin (21),				/* No of characters to be typed */
         nt fixed bin (21),				/* No of characters actually typed */
         offset fixed bin,				/* No of characters already typed */
         this_line fixed bin,				/* Current link in q of lines to be typed */
         ucs_recursion fixed bin initial (0),		/* Recursion counter for any_other handler */
         vc fixed bin,				/* Index when looping thru vcons in MRT */
         vce fixed bin,				/* Index of Virtual Console table Entry */
         wait_time fixed bin (71) int static init (5),	/* Settable time to wait til try to print some more */
         max_limit fixed bin int static init (20),	/* settable number of messages to print before waiting */
         when_sent fixed bin (71);			/* Postmark from each message. */
declare  log_buffer_length fixed bin (21);
declare  state fixed bin;

/* Character strings */

declare  (buffer_space,
         log_buffer_space) char (500) unaligned;

declare  tty_buffer_space char (132) unaligned;
declare  timestamp char (50) varying;

declare
         buffer char (nt) based (buffer_ptr),
         chain char (8),				/* whence the message is to be taken */
         log_buffer char (log_buffer_length) based (log_buffer_ptr),
         stream_source char (32),			/* saves the stream.source in case star entry is used */
         pigeon_hole char (32),			/* Name of a message segment to be initiated */
         sysdir char (168) int static init (">system_control_1"), /* ditto */
						/* where to find the message segs */
         time char (24);				/* for putting in messages */

dcl  NL char (1) aligned int static options (constant) init ("
");
dcl  stars char (16) aligned int static options (constant) init ("
***********
");						/* There are three BEL chars in this string */

/* BIT strings */
declare
         created_seg (8) bit (1) init ((8) (1)"0"b),	/* In case we want to write messages */
         dont_log bit (1),				/* "1"b=>Sentinel-- Needn't be logged */
         sendalarm bit (1);				/* TRUE if alarm message, at distribute */

/* builtins */

dcl  (addr, index, max, min, null, string, substr, length, addcharno, byte, rtrim)
			 builtin;

dcl  any_other condition;

/* EXTERNAL ENTRIES */
declare
         as_any_other_handler_ entry (character (*), entry, label, label),
         com_err_ entry options (variable),
         com_err_$suppress_name entry () options (variable),
         date_time_$format entry (character (*), fixed binary (71), character (*), character (*))
	    returns (character (250) var),
         hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
         hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)),
         ioa_$rsnnl entry () options (variable),
         ioa_ entry options (variable),
         mc_con_rec_$output entry (fixed bin (71)),
         mc_util_$mrt_source entry (char (*) aligned, fixed bin, fixed bin (35)),
         mc_util_$mrt_stream entry (fixed bin, char (*) aligned, ptr, fixed bin, fixed bin (35)),
         mc_util_$queue entry (ptr, bit (1), ptr, fixed bin, fixed bin, fixed bin (35)),
         mrd_util_$discard_remainder entry (ptr, fixed bin, fixed bin (35)),
         mrd_util_$read entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (21), char (*), ptr, fixed bin, fixed bin (35)),
         timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));

declare  log_write_$message entry (pointer, fixed binary, character (*), pointer, fixed binary (35));

declare  hphcs_$syserr entry options (variable);
declare  hphcs_$syserr_error_code entry options (variable);
declare  sys_log_ entry options (variable);
declare  sys_log_$error_log entry options (variable);
declare  timed_io_$put_chars entry (pointer, fixed binary (71), pointer, fixed binary (21), fixed binary (21),
	    fixed binary (35));
declare  (as_$meter_enter, as_$meter_exit) entry (fixed bin);

/* EXTERNAL constants */
declare
         (
         error_table_$ioname_not_found,
         error_table_$no_message ext,
         error_table_$notalloc,
         error_table_$timeout,
         error_table_$unable_to_do_io) fixed bin (35) ext static;

/* STRUCTURES */
declare
         1 based_ackn based,
	 2 source_index fixed bin (35),
	 2 stream_index fixed bin (35);

%page;

/* Program */

init: entry (arg_mc_ansp, arg_temp_SDBp, arg_mcmp, arg_messp);

/* This entry is called by mc_util_$init.  It sets up the internal static
   variables that were once part of the unified message_coordr_ procedure.
*/

	mc_ansp, mc_ansp_stat = arg_mc_ansp;
	temp_SDBp = arg_temp_SDBp;
	mcmp = arg_mcmp;
	messp = arg_messp;

	sysdir = mc_anstbl.sysdir;
	mrtp = mc_anstbl.mrtp;
	vconsp = mc_anstbl.vconsp;

	return;


/* This entry is called when a wakeup arrives on the
   message coordinator's protocol channel.  This happens
   whenever a source attaches an i/o stream through mrd_
   or detaches such a stream (if no previous protocol message is still pending)
   or when this program sends itself a wakeup after processing 20 messages. */

protocol: entry (arg_event_call_info_ptr);

	event_call_info_ptr = arg_event_call_info_ptr;
	on any_other call as_any_other_handler_ ("mc_wakeups_$prototol", mc_wakeups_handler_, ABORT_EXIT, ABORT_EXIT);
	call as_$meter_enter (MSGCORD_METER);		/* meter cpu time and paging used by this procedure */
	chain = "proto";
	do k = 1 to 20;				/* Do at most 20 messages. */

/* Read part (or all) of the first available message in the chain
   and get its index. */
	     call mrd_util_$read (temp_SDBp, addr (buffer_space), 0, length (buffer_space), nt, chain, messp, state, code);
	     if code = error_table_$no_message |
		code = error_table_$unable_to_do_io then goto METER_EXIT;
						/* There weren't 20 messages. */
	     when_sent = message_block.time_sent;
	     if message_block.flags.introduction then goto introduction;
	     if message_block.flags.farewell then goto farewell;

/* If we get here, complain and */
	     call hphcs_$syserr (ANNOUNCE, "mc_wakeups_: Bad protocol: index = ^d", message_block.next_message);
	     goto attached;

introduction:					/* This is where we fill in the MRT so that
						   the router can do its work .      */

/* Get indices in MRT */
/* First the source */
	     call mc_util_$mrt_source (message_block.from_source, mrt_source, code);
	     if code ^= 0 then
		if code ^= error_table_$ioname_not_found then /* A real error */
		     do;
gripe:		     call hphcs_$syserr_error_code (ANNOUNCE, code, "mc_wakeups_", "Protocol error: ^a ^a",
			message_block.from_source, message_block.from_stream);
		     goto attached;
		end;
		else do;				/* This is a source for which no routing has been provided.  Make one. */
		     if mrt_source = 0 then mrt_source, /* Need to allocate new entry */
			     MRT.no_of_sources = MRT.no_of_sources + 1;
		     MRT.source (mrt_source).source = message_block.from_source;
		     MRT.source (mrt_source).hismess = null;
		     MRT.source (mrt_source).no_of_streams = 0;
		     MRT.source (mrt_source).flags.init = "0"b; /* "message" segment not initiated */
		     MRT.source (mrt_source).flags.valid = "1"b; /* info otherwise correct */
		     goto make_stream;
		end;

/* Next the stream. */
	     call mc_util_$mrt_stream (mrt_source, message_block.from_stream, streamp, mrt_stream, code);
	     if code ^= 0 then
		if code ^= error_table_$ioname_not_found then goto gripe; /* A real error */
		else do;				/* No routing provided for this stream.  Make new entry. */
		     if mrt_stream = 0 then		/* Need to allocate new entry */
			if MRT.source (mrt_source).no_of_streams < 8 then /* Room for another? */
make_stream:		     mrt_stream,
				MRT.source (mrt_source).no_of_streams = MRT.source (mrt_source).no_of_streams + 1;
			else do;			/* No room. */
			     code = error_table_$notalloc;
			     goto gripe;
			end;
		     streamp = addr (MRT.source (mrt_source).stream (mrt_stream));
		     string (stream.flags) = "0"b;
		     stream.flags.valid = "1"b;	/* Entry contains correct info */
		     stream.source = message_block.from_source;
		     stream.stream = message_block.from_stream;
		     stream.ourmess = mcmp;
		     stream.source_index = mrt_source;
		     stream.stream_index = mrt_stream;

		     stream.no_of_vcons = MRT.star_entry.stream.no_of_vcons;

		     do vc = 1 to stream.no_of_vcons;
			stream.vcons (vc) = MRT.star_entry.stream.vcons (vc);
			stream.vcons_index (vc) = MRT.star_entry.stream.vcons_index (vc);
		     end;

		end;

/* now fill in pointer to message segment for this source */
	     if MRT.source (mrt_source).flags.init then hismp = MRT.source (mrt_source).hismess;
	     else do;				/* first time through, initiate it. */
		i = index (stream.source, " ") - 1;
		pigeon_hole = substr (stream.source, 1, i) || ".message";
		call hcs_$initiate (sysdir, pigeon_hole, "", 0, 1, hismp, code);
		if hismp = null then go to gripe;	/* EEK. message segment missing. */
		MRT.source (mrt_source).hismess = hismp;
		MRT.source (mrt_source).flags.init = "1"b; /* "message" segment now initiated */
	     end;

	     stream.hismess = MRT.source (mrt_source).hismess;
	     stream.flags.active = "1"b;		/* stream attached and sending */

/* Acknowledge the protocol, sending the indeces in the MRT */
	     addr (ackn) -> based_ackn.source_index = mrt_source;
	     addr (ackn) -> based_ackn.stream_index = mrt_stream;
	     call hcs_$wakeup (hismp -> syscon_mseg.current_process_id,
		hismp -> syscon_mseg.proto_el.channel,
		ackn, code);
	     if code ^= 0 then call com_err_ (code, "mc_wakeups_",
		     "Protocol cannot wake ^a", stream.source);
	     goto attached;

/* Reset active and send acknowledgement. */
farewell:
	     mrt_source = message_block.source_index;
	     mrt_stream = message_block.stream_index;

	     streamp = addr (MRT.source (mrt_source).stream (mrt_stream));
	     stream.flags.active = "0"b;

	     hismp = stream.hismess;

	     if hismp -> syscon_mseg.no_of_streams = 0 then MRT.source (mrt_source).flags.init = "0"b; /* More tidy */

	     ackn = 0;
	     call hcs_$wakeup (hismp -> syscon_mseg.current_process_id,
		hismp -> syscon_mseg.proto_el.channel,
		ackn, code);
attached:	     call mrd_util_$discard_remainder (temp_SDBp, state, code); /* Leave campsite as clean as found it */

	end;					/* When we have done 20, give rest of process a chance
						   But remember to do more later. */
	call hcs_$wakeup (mcmp -> syscon_mseg.current_process_id,
	     mcmp -> syscon_mseg.proto_el.channel, 0, code);
	goto METER_EXIT;

/* ROUTER - called when a wakeup arrives on the "normal" event channel.
   Daemons send a wakeup after they have sent output, and router sends itself
   a wakeup after processing 20 messages.

   Under most circumstances (stream.source <= 4 chars), the maximum line length
   will be 118 characters...just enough to fit on a TermiNet */

router: entry (arg_event_call_info_ptr);

          mc_ansp = mc_ansp_stat;
	event_call_info_ptr = arg_event_call_info_ptr;
	on any_other call as_any_other_handler_ ("mc_wakeups_$router", mc_wakeups_handler_, ABORT_EXIT, ABORT_EXIT);
	call as_$meter_enter (MSGCORD_METER);		/* meter cpu time and paging used by this procedure */
	chain = "normal";

	buffer_ptr = addr (buffer_space);
	log_buffer_ptr = addr (log_buffer_space);
	tty_buffer_ptr = addr (tty_buffer_space);

	do k = 1 to 20;				/* Do 20 messages at a time. */

/* Read part (or all) of first available message in the chain */

	     call mrd_util_$read (temp_SDBp, buffer_ptr, 0, length (buffer_space), nt, chain, messp, state, code);
	     if mc_anstbl.trace
	     then call trace_mrd_util_read;

	     if code = error_table_$no_message |
		code = error_table_$unable_to_do_io then goto METER_EXIT;
						/* There weren't 20 things in queue. */
						/* Find the MRT entry */
	     mrt_source = message_block.source_index;
	     mrt_stream = message_block.stream_index;

	     if mrt_source = 0 | mrt_stream = 0 then do;	/* AARGH! */
		call hphcs_$syserr (ANNOUNCE, "mc_wakeups_: bad message from ^a.", message_block.from_source);
		call hphcs_$syserr (ANNOUNCE, "mc_wakeups_: message is ""^a"".", substr (message_block.message_body, 1, message_block.length));
		call mrd_util_$discard_remainder (temp_SDBp, state, code);
		go to METER_EXIT;			/* for now */
	     end;

	     when_sent = message_block.time_sent;	/* Get this too while at it. */
	     streamp = addr (MRT.source (mrt_source).stream (mrt_stream));
	     hismp = stream.hismess;
	     stream_source = stream.source;		/* save this, as you won't find it in the star entry */
	     if stream.no_of_vcons = 0 then streamp = addr (MRT.star_entry.stream); /* Whoops! */

/* Set up line to be typed  */
another:	     dont_log = "0"b;
	     if message_block.flags.sentinel then do;	/* No special format */
		dont_log = "1"b;
		if nt = 0 then go to get_rest;	/* Unlikely */
		tty_buffer_ptr = addr (buffer_space);	/* reset ptr */
		lng = nt;
	     end;
	     else do;
		time = date_time_$format ("^Hd^MH", when_sent, "", "");
		if substr (buffer, nt, 1) = NL then nt = nt - 1; /* Remove extraneous nl */
		timestamp = "";			/* varying string, initialize */
		call ioa_$rsnnl (" ^a  ^4a ", timestamp, (0), time, stream_source); /* just prepare stamp */
		call ioa_$rsnnl ("^va  ^a", log_buffer_space, log_buffer_length, max (4, length (rtrim (stream_source))), stream.source, buffer);
	     end;

	     do vc = 1 to stream.no_of_vcons;		/* Send message to each virtual console */
		vce = stream.vcons_index (vc);
		sendalarm = substr (stream.flags.alarm, vc, 1); /* Set alarm switch. */
		vcep = addr (vcons_tab.vcons (vce));
		if vcons.no_of_dest = 0 then vcep = addr (vcons_tab.star_entry); /* Whoops! */

		do dest = 1 to vcons.no_of_dest;	/* Send it to each physical device */
		     if vcons.dest (dest).type = 1 then do; /* This is a typewriter */
			qp = vcons.dest (dest).queue_seg_ptr;
			if dont_log		/* just a sentinel */
			then do;
			     call mc_util_$queue (qp, sendalarm, tty_buffer_ptr, lng, mrt_source, code);
			     hismp -> syscon_mseg.mescount = hismp -> syscon_mseg.mescount + 1;
			end;
			else call queue_tty_message;	/* send one or more messages as needed to fit in 132 per message char limit */
		     end;
		     else if vcons.dest (dest).type = 2 then do; /* This is a log */
			if sendalarm then i = 2;
			else i = 1;
			if ^dont_log then		/* Interesting later? */
			     call log_write_$message (vcons.dest (dest).queue_seg_ptr, i, log_buffer, (null ()), (0));
		     end;
		     else if vcons.dest (dest).type = 3 then ; /* Sink */
		end;

	     end;
	     call check_off_message;
get_rest:	     if state ^= 0 then do;			/* Message cont more than 1 line or more chars than asked. */
		call mrd_util_$read (temp_SDBp, addr (buffer_space), 0, length (buffer_space), nt, chain, messp, state, code);
		if mc_anstbl.trace then call trace_mrd_util_read;
		if code = error_table_$unable_to_do_io then goto METER_EXIT;
		if nt ^= 0 then goto another;
	     end;
	end;
	call hcs_$wakeup (mcmp -> syscon_mseg.current_process_id,
	     mcmp -> syscon_mseg.ipc_el.channel, 0, code);
	goto METER_EXIT;				/* Fell out of loop. Big backlog.
						   Allow rest of process a chance, but insure we come back. */

check_off_message: proc;

	hismp -> syscon_mseg.mescount = hismp -> syscon_mseg.mescount - 1;
	if hismp -> syscon_mseg.mescount <= 0 then do;
	     hismp -> syscon_mseg.mescount = 0;
	     if hismp -> syscon_mseg.output_wait then do;
		hismp -> syscon_mseg.output_wait = "0"b;
		call hcs_$wakeup (hismp -> syscon_mseg.current_process_id,
		     hismp -> syscon_mseg.ipc_el.channel, 0, code);
	     end;
	end;

     end check_off_message;


/* This entry is called when a wakeup arrives on the event
   channel associated with a device queue.  This can happen
   in three ways.  When a line is placed in a previously empty queue
   a wakeup is sent to initiate processing by the typer_out.
   If the typer_out cannot complete typing all messages in a
   queue, it sets a timer to wake itself later to try again.
   If the typer_out cannot type all the characters of a given
   message it sets the output_wait switch in the mc answer
   table entry for this typewriter and expects system_control_$tty_aught
   to send a wakeup when hardcore is ready for more work.

   No lock is necessary on the device queues because mc$router and mc$typer_out
   are executed in the same process.  */

typer_out: entry (arg_event_call_info_ptr);

          mc_ansp = mc_ansp_stat;
	event_call_info_ptr = arg_event_call_info_ptr;
	on any_other call as_any_other_handler_ ("mc_wakeups_$typer_out", mc_wakeups_handler_, ABORT_EXIT, ABORT_EXIT);
	call as_$meter_enter (MSGCORD_METER);		/* meter cpu time and paging used by this procedure */

	qp = event_call_info.data_ptr;		/* What queue are we processing? */
	if device_queue.no_of_messages = 0 then goto METER_EXIT; /* Nothing to do. */
	mc_atep = device_queue.mc_atep;
	cdtep = mc_ate.cdtep;
	if mc_ate.control.inhibit then		/* Waiting for operator? */
	     do;					/* Tell mc_tty_ to talk to us */
	     mc_ate.control.output_pending = "1"b;
	     goto METER_EXIT;
	end;

	n, last_line = 0;
	this_line = device_queue.top_of_queue;		/* First message to type. */
	limit = min (max_limit, device_queue.no_of_messages); /* Total number to type. */

	do i = 1 to limit;
	     mrt_source = device_queue.line (this_line).source;
	     if mrt_source = 0 then hismp = null;
	     else hismp = MRT.source (mrt_source).hismess;
	     linep = addr (device_queue.line (this_line).string);
	     offset = device_queue.line (this_line).offset;
	     n = device_queue.line (this_line).line_length - offset;
	     if mc_anstbl.trace then begin;
declare  line char (n) based (addcharno (linep, offset));
		call sys_log_ (SL_LOG_SILENT,
		     "MC (mc_wakeups_ - typer_out): tty: ^a^[; physical channel: ^a^;^s^]; this_line: ^d; line_length: ^d; offset: ^d; n: ^d; line: ^a",
		     mc_ate.virtual_tty_name, mc_ate.virtual,
		     mc_ate.real_tty_name, this_line,
		     device_queue.line (this_line).line_length,
		     device_queue.line (this_line).offset, n, line);
	     end;
	     nt = 0;

	     if device_queue.line (this_line).alarm	/* alarm needed */
	     then if mc_ate.the_system_console
		then call iox_$control (mc_ate.iocb, "alarm", null, code);
		else call timed_io_$put_chars (mc_ate.iocb, 5 * 1000 * 1000, addr (stars), length (stars), (0), code); /* allow this to wait */

	     device_queue.line (this_line).alarm = "0"b;

	     if mc_ate.the_system_console
	     then do;
		call iox_$put_chars (mc_ate.iocb, addcharno (linep, offset), n, code);
		if code = 0 then nt = n;
	     end;
	     else do;
		call timed_io_$put_chars (mc_ate.iocb, 0, addcharno (linep, offset), n, nt, code);
		if code = error_table_$timeout then code = 0;
	     end;
	     if mc_anstbl.trace
	     then call sys_log_$error_log (SL_LOG_SILENT, code, "MC (mc_wakeups_ - typer_out)", "called put_chars nt: ^d", nt);

	     if code ^= 0 then do;
		nt = 0;
		go to finish;
	     end;

	     if nt ^= n then go to finish;		/* Hardcore buffers full. Can't do any more now */
	     last_line = this_line;			/* Useful below when unchaining */
	     this_line = device_queue.line (this_line).next_line; /* Next message to type. */
	     if hismp ^= null then call check_off_message;
	end;

	device_queue.line (last_line).next_line = device_queue.free_top; /* Unchain */
	device_queue.free_top = device_queue.top_of_queue;
	device_queue.top_of_queue = this_line;
	device_queue.no_of_messages = device_queue.no_of_messages - limit;
	if this_line = 0 then device_queue.end_of_queue = 0;
	else call timer_manager_$alarm_wakeup (wait_time, "11"b, /* More to do. Come back later. */
		device_queue.channel);
	mc_ate.control.output_wait = "0"b;		/* Did all wanted to do. */
	goto exit;

finish:
	if mc_anstbl.trace
	then call sys_log_ (SL_LOG_SILENT,
		"MC (mc_wakeups - finish): tty: ^a^[; physical channel: ^a^;^s^]; length: ^d; length transmitted ^d; offset: ^d",
		mc_ate.virtual_tty_name, mc_ate.virtual,
		mc_ate.real_tty_name, n, nt, offset);
	mc_ate.control.output_wait = "1"b;		/* Tell tty_aught to wake us when hardcore ready. */
	device_queue.line (this_line).offset = nt + offset; /* Remember how much got typed. */
	device_queue.line (this_line).not_done = "1"b;
	device_queue.no_of_messages = device_queue.no_of_messages - i + 1;
	if last_line = 0 then goto exit;		/* Stuck on first one? */
	device_queue.line (last_line).next_line = device_queue.free_top; /* No. Unchain. */
	device_queue.free_top = device_queue.top_of_queue;
	device_queue.top_of_queue = this_line;
exit:	if mc_ate.the_system_console then call iox_$control (mc_ate.iocb, "start", null, code); /* In case we stole a wakeup */
	goto METER_EXIT;

con_rec: entry (arg_event_call_info_ptr);

/* This entry is called when a wakeup arrives on the console recovery
   event channel. The event message will contain either a positive value which
   is used to recover a syserr message or a negative value which will be
   used to retrieve the message from oc_data. This message will be sent to
   used to retrieve the message from oc_data. This message will be sent to
   mc_con_rec_ for the actual work. If the event message is zero, it means
   that the console has come back into operation, and console recovery is
   deactivated; this is all handled by mc_con_rec_.
*/

          mc_ansp = mc_ansp_stat;
	event_call_info_ptr = arg_event_call_info_ptr;
	on any_other call as_any_other_handler_ ("mc_wakeups_$con_rec", mc_wakeups_handler_, ABORT_EXIT, ABORT_EXIT);
	call as_$meter_enter (MSGCORD_METER);		/* meter cpu time and paging used by this procedure */

	if ^mc_anstbl.con_rec.flags.enabled		/* Ignore wakeup if console recovery not enabled. */
	then goto METER_EXIT;

	call mc_con_rec_$output (event_call_info.message);/* process the message...		*/

	goto METER_EXIT;

/* ALL RETURNS MUST COME HERE TO TURN OFF METERING BEFORE RETURNING !!! */

ABORT_EXIT:
METER_EXIT:
	call as_$meter_exit (MSGCORD_METER);		/* turn off metering before returning */
	return;

queue_tty_message:
     procedure;

declare  SPACE_IN_A_QUEUE_ENTRY fixed bin init (131) int static options (constant); /* device_queue.string = 132,  NL = 1 */
declare  to_go fixed bin (21);
declare  to_go_1 fixed bin;
declare  n_sent fixed bin (21);
declare  max_to_send fixed bin;
declare  done bit (1) aligned;

	max_to_send = SPACE_IN_A_QUEUE_ENTRY - length (timestamp);
	to_go = nt;
	n_sent = 0;
	to_go_1 = 0;

/**** This loop must be executed at least once to insure that blank lines
      are processed. Since we haven't got do until, we simulate with
      the "done" flag. to_go is decremented at the end of the loop
      so it is co-located with recalculating done. */

	done = "0"b;
	do while (^done);
	     to_go_1 = min (to_go, max_to_send);	/* Zero is fine */
	     substr (tty_buffer_space, 1, length (timestamp)) = timestamp;
	     substr (tty_buffer_space, length (timestamp) + 1, to_go_1) = substr (buffer_space, n_sent + 1, to_go_1); /* Zero length is fine */
	     substr (tty_buffer_space, length (timestamp) + 1 + to_go_1, 1) = byte (10);
	     call mc_util_$queue (qp, sendalarm, addr (tty_buffer_space),
		to_go_1 + length (timestamp) + 1, mrt_source, code); /*  l(timestamp)+ NL */
	     if code ^= 0 then call hphcs_$syserr_error_code (LOG, code,
		"mc_wakeups_", "Failed to queue message for ^a.",
		device_queue.mc_atep -> mc_ate.virtual_tty_name);
	     sendalarm = "0"b;			/* Once is enough per message */
	     hismp -> syscon_mseg.mescount = hismp -> syscon_mseg.mescount + 1;
	     if mc_anstbl.trace
	     then call sys_log_ (SL_LOG_SILENT, "MC (mc_wakeups_ - queue_tty_message): n_sent: ^d; to_go: ^d; to_go_1: ^d; this_line: ^a",
		     n_sent, to_go, to_go_1, substr (tty_buffer_space, 1, to_go_1 + length (timestamp)));
	     n_sent = n_sent + to_go_1;
	     to_go = to_go - to_go_1;			/* This many left */
	     done = (to_go <= 0);			/* none left? Note that if to_go started as zero (a blank line), then to_go_1 will be zero, 0-0 = 0, so this terminates */
	end;
	return;
     end queue_tty_message;

mc_wakeups_handler_:
     procedure;

/*	This procedure is a handler for the "any_other" condition.
*/

/**** Nothing to do here? Not even send some protocol wakeups? */


     end mc_wakeups_handler_;

set_mc_message_limits: entry;

dcl  (argval, nargs) fixed bin;
dcl  l_wait_time fixed bin (71);
dcl  l_max_limit fixed bin;
dcl  ct_dly bit (1) aligned;

dcl  mcl_me char (24) init ("set_mc_message_limits") static options (constant);

dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  argp ptr, argl fixed bin (21), arg char (argl) based (argp);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));

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

	l_wait_time = wait_time;
	l_max_limit = max_limit;
	call cu_$arg_count (nargs, code);
	if code ^= 0 then call com_err_ (code, "set_mc_message_limits");
	if nargs < 1 then do;
	     call com_err_$suppress_name (0, mcl_me, "USAGE: set_mc_message_limits {-count N} {-delay N} {-print}");
	     return;
	end;

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, argl, code);
	     if arg = "-count" | arg = "-ct" |
		arg = "-delay" | arg = "-dly" then do;
		i = i + 1;
		if i > nargs then do;
		     call com_err_ (error_table_$noarg, mcl_me, "Following ^a.", arg);
		     return;
		end;
		ct_dly = substr (arg, 2, 1) = "c";
		call cu_$arg_ptr (i, argp, argl, code);
		argval = cv_dec_check_ ((arg), code);
		if (code ^= 0 | argval <= 0) then do;
		     call com_err_ (0, mcl_me, "^a is not a positive decimal number", arg);
		     return;
		end;
		if ct_dly then l_max_limit = argval;
		else l_wait_time = argval;
	     end;
	     else if arg = "-print" | arg = "-pr" then
		call ioa_ ("^a: Message coordinator message limit is ^d messages per ^d seconds.", mcl_me, l_max_limit, l_wait_time);
	     else do;
		call com_err_ (error_table_$badopt, mcl_me, "^a", arg);
		return;
	     end;
	end;

	max_limit = l_max_limit;
	wait_time = l_wait_time;
	return;


set_shutdown_limits: entry;

	max_limit = 131071;
	wait_time = 1;
	return;

trace_mrd_util_read:
     procedure;

	call sys_log_$error_log (SL_LOG_SILENT, code, "mc_wakeups_ (router)", "buffer: ^a; nt: ^d; chain: ^a; state: ^d",
	     substr (buffer_space, 1, nt),
	     nt, chain, state);
	call sys_log_ (SL_LOG_SILENT, "mc_wakeups_ (router): time ^a; from_source ^a; from_stream ^a; source_index ^d; stream_index ^d; next_message ^d; ^[continue^] ^[introduction^] ^[farewell^] ^[sentinel^]",
	     date_time_$format ("time", message_block.time_sent, "", ""),
	     message_block.from_source,
	     message_block.from_stream,
	     message_block.source_index,
	     message_block.stream_index,
	     message_block.next_message,
	     message_block.continue,
	     message_block.introduction,
	     message_block.farewell,
	     message_block.sentinel);
	call sys_log_ (SL_LOG_SILENT, "mc_wakeups_ (router): length: ^d; message ^a", message_block.length, substr (message_block.message_body, 1, message_block.length));
	return;
     end trace_mrd_util_read;

/* include files */
/* format: off */
%page; %include iox_entries;
%page; %include as_meter_numbers;
%page; %include syscon_mseg;
%page; %include mess_route_table;
%page; %include vcons_tab;
%page; %include device_queue;
%page; %include mc_anstbl;
%page; %include cdt;
%page; %include author_dcl;
%page; %include event_call_info;
%page; %include syserr_constants;
%page; %include sys_log_constants;

     end mc_wakeups_;




		    mrd_.alm                        11/05/86  1352.3r w 11/04/86  1039.3       15768



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"  ******************************************************
"  *                                                    *
"  *                                                    *
"  * Copyright (c) 1972 by Massachusetts Institute of   *
"  * Technology and Honeywell Information Systems, Inc. *
"  *                                                    *
"  *                                                    *
"  ******************************************************
"	Outer Module Transfer Vector for the mrd_ outer module.
	segdef	mrd_module
"
%include	stack_header;
"
"	**********INTERNAL CODE TO GET LP  (should be replaced by macro)**********

mrd_module:
	eppbp	*		get ptr to this seg
	spribp	sp|18,*		store it
	lda	sp|18,*		get seg number
	lda	sb|stack_header.lot_ptr,*au	get LOT entry
	easplp	0,au		get seg number in lp
	eawplp	0,al		get offset in lp

	tra	*+1,6		go to proper transfer instruction

	tra	<mrdim_>|[mrd_attach]
	tra	<mrdim_>|[mrd_detach]
	tra	<mrdim_>|[mrd_read]
	tra	<mrdim_>|[mrd_write]
	tra	<mrdim_>|[mrd_abort]
	tra	<mrdim_>|[mrd_order]
	tra	<mrdim_>|[mrd_resetread]
	tra	<mrdim_>|[mrd_resetwrite]
	tra	<ios_>|[no_entry]
	tra	<mrdim_>|[mrd_getsize]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<mrdim_>|[mrd_changemode]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]
	tra	<ios_>|[no_entry]

	end




		    mrd_util_.pl1                   09/21/87  1958.4rew 09/21/87  1954.4      287874



/****^  ***********************************************************
        *                                                         *
        * 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(87-09-15,Parisek), approve(87-09-21,MECR0008),
     audit(87-09-21,GDixon), install(87-09-21,MR12.1-1114):
     On any_other conditions report condition name, reset the message segment
     header, unlock the message segment if locked and return to caller with an
     error code instead of terminating the process. (phx20928)
                                                   END HISTORY COMMENTS */


/* format: style4 */
mrd_util_:
     procedure;

/* MRD_UTIL_ - This procedure contains all code which must deal with a
   message coordinator "message" segment in a consistent fashion.  This is
   the only program which locks and unlocks these segments. */

/* Coded by Dennis Capps, July 1972
   Modified by J. C. Whitmore, Aug 1975 to return event chan on each
   read_status call.
   Rewritten 751223 by PG
   Modified 6/8/83 by E. N. Kittlitz to fix uninitialized variable used by
   cleanup.
   Modified 1985-03-11 by E. Swenson to fix locking code and add cleanup
   handler.
*/

/* builtins */

dcl  (addr, clock, divide, index, min, null, string, substr) builtin;

/* parameters */

dcl  (tp ptr,					/* ptr to Stream Data Block */
     workp ptr,					/* ptr to I/O workspace for transfer */
     first_char fixed bin,				/* Offset from base of users workspace */
     nchar fixed bin,				/* Number of characters to be transferred */
     nchart fixed bin,				/* Number of characters actually transferred */
     state fixed bin,				/* 0 -- end of data,1 -- more to message. */
     code fixed bin (35),				/* error code */
     reqsw fixed bin,				/* what to abort */
     request char (*)				/* What kind of protocol request */
     ) parameter;

/* Automatic */

dcl  dont_flood bit (1) aligned init ("0"b);		/* TRUE = may go into output wait */
dcl  lock_ptr ptr init (null);			/* ptr to message seg we have locked */
dcl  lock_set bit (1) aligned init (""b);		/* ON if we have lock set */
dcl  mask bit (36) aligned init (""b),			/* IPS Mask */
     my_name char (32) varying,
     ourmp ptr,					/* Pointer to message seg for this function */
     recursion fixed bin initial (0),
     hismp ptr,					/* Pointer to message seg for destination func. */
     messp ptr,
     messp1 ptr,
     thatp ptr,					/* Used in transferring characters. */
     thisp ptr,					/* Used in transferring characters. */
     chainp ptr,					/* Points to head & tail info for current chain */
     mp ptr,
     wake_up_chan fixed bin (71),			/* How to tell him message deposited */
     event_mess fixed bin (71),			/* Give inkling of whats happening */
     i fixed bin,					/* A temporary index */
     autocode fixed bin (35),				/* Error code */
     this_message fixed bin,				/* Message block currently under inspection */
     begin_this fixed bin,				/* First block of this message */
     end_this fixed bin,				/* last block of this message  */
     prev_message fixed bin,				/* Message block previously under inspection */
     time fixed bin (71),				/* Current time  (postmark) */
     n fixed bin,					/* Temporaries of a dedicated nature */
     no_of_blocks fixed bin,
     len fixed bin;
dcl  ipc_mask_code fixed bin (35);
dcl  ipc_unmask_code fixed bin (35);

dcl  1 ci aligned like condition_info;			/* Condition info */
dcl  1 message_type,
       2 continue bit (1),				/* Message continued in next block */
       2 introduction bit (1),			/* This is an introductory message */
       2 farewell bit (1),				/* "       "   farewell  "  */
       2 sentinel bit (1),				/* Don't print time at front of this one */
       2 unused bit (32);
dcl  1 terminate_info structure aligned,
       2 version fixed bin,
       2 code fixed bin (35);

/* based */

dcl  1 chain based (chainp),
       2 chain_head fixed bin,			/* first_message or first_proto */
       2 chain_tail fixed bin;			/* last_message or last_proto */

dcl  based_mess char (len) based (thatp),		/* For transferring characters */
     char_array (buff_len) char (1) based (thisp),	/* For updating thisp   */
     char_event_mess char (8) based,			/* Goes with event_mess  */
     this_batch char (len) based (thisp);		/* For transferring characters */

dcl  1 SDB based (tp) aligned,			/* one entry in list of stream control blocks */
       2 dim_name char (32),				/* the name of this DIM */
       2 device_name_list ptr,			/* threaded list of device id's */
       2 next_device ptr,				/* pointer to next entry in threaded list */
       2 device_name_size fixed bin,			/* number of chars in device name */
       2 device_name char (32),			/* device id */
       2 pad1 fixed bin,
       2 ipc_ep ptr,				/* to normal event list for read block */
       2 proto_ep ptr,				/* to protocol event list for att & det */
       2 nextp ptr,					/* pointer to next stream block in chain */
       2 ourmess ptr,				/* Pointer to mseg for this function */
       2 hismess ptr,				/* Pointer to mseg for message coord'r */
       2 source char (32),				/* symbolic name of I/O source  */
       2 stream char (32),				/* symbolic name of I/O stream  */
       2 source_index fixed bin,			/* in MRT */
       2 stream_index fixed bin,
       2 flags,
         3 valid bit (1) unal,			/* "1"b = entry-in-use, "0"b = not_in_use */
         3 read bit (1) unal,				/* "1"b = stream attached for reading. */
         3 write bit (1) unal,			/* "1"b = stream attached for writing. */
         3 active bit (1) unal,			/* For compatibility with message_coordr_ */
         3 more bit (1) unal,				/* "1"b = More text in this message than we've given */
         3 unused bit (31) unal,
       2 prev_trans,
         3 first_block fixed bin,
         3 end_block fixed bin,
         3 current_block fixed bin,
         3 offset fixed bin;

/* Entries */

dcl  continue_to_signal_ entry (fixed bin (35)),
     find_condition_info_ entry (ptr, ptr, fixed bin(35)),
     get_process_id_ entry () returns (bit (36) aligned),
     hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned),
     hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned),
     hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)),
     ipc_$drain_chn entry (fixed bin (71), fixed bin (35)),
     ipc_$mask_ev_calls entry (fixed bin (35)),
     ipc_$unmask_ev_calls entry (fixed bin (35)),
     phcs_$ring_0_message ext entry (char (*)),
     set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl  terminate_process_ entry (char (*), ptr);

/* internal static */

dcl  (my_process_id bit (36) aligned initial ((18)"10"b),
     thirty_seconds fixed bin init (30) options (constant), /* How long before set_lock_ gives up */
     NL char (1) initial ("
"),
     LIMIT fixed bin init (10),			/* Max # lines queued but not printed */
     OWAIT fixed bin init (123)			/* Err code to mrdim_ => output wait */
     ) internal static;

/* external static */

dcl  error_table_$argerr fixed bin (35) external;
dcl  error_table_$lock_wait_time_exceeded fixed bin (35) external;
dcl  error_table_$invalid_lock_reset fixed bin (35) external;
dcl  error_table_$locked_by_this_process fixed bin (35) external;
dcl  error_table_$no_message fixed bin (35) external;
dcl  error_table_$unable_to_do_io fixed bin (35) external;

/* Conditions */

dcl  any_other condition;
dcl  cleanup condition;
%page;
/* Program */

protocol: entry (tp, workp, first_char, nchar, nchart, request, code);

/* This entry helps a function to do certain things to make the
   interaction with the message coordinator go smoothly */

	my_name = "mrd_util_$protocol";
	string (message_type) = ""b;
	hismp = SDB.hismess;
	addr (event_mess) -> char_event_mess = request;

	if request = "attach" then do;
	     my_process_id = get_process_id_ ();	/* this is the first call to this program... */
	     wake_up_chan = hismp -> syscon_mseg.proto_el.channel;
	     message_type.introduction = "1"b;
	     chainp = addr (hismp -> syscon_mseg.first_proto);
	end;
	else if request = "sentinel" then do;
	     wake_up_chan = hismp -> syscon_mseg.ipc_el.channel;
	     message_type.sentinel = "1"b;
	     chainp = addr (hismp -> syscon_mseg.first_message);
	end;
	else if request = "detach" then do;
	     wake_up_chan = hismp -> syscon_mseg.proto_el.channel;
	     message_type.farewell = "1"b;
	     chainp = addr (hismp -> syscon_mseg.first_proto);
	end;
	else do;
	     code = error_table_$argerr;
	     return;
	end;
	go to common_write;

/* This is the ordinary entry for writing.  */

write_dont_flood:
     entry (tp, workp, first_char, nchar, nchart, state, code);
	dont_flood = "1"b;

write: entry (tp, workp, first_char, nchar, nchart, state, code);

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

	my_name = "mrd_util_$write";
	string (message_type) = ""b;
	hismp = SDB.hismess;
	wake_up_chan = hismp -> syscon_mseg.ipc_el.channel;
	addr (event_mess) -> char_event_mess = "normal";
	chainp = addr (hismp -> syscon_mseg.first_message);
	ourmp = SDB.ourmess;

	if dont_flood
	     & (hismp -> syscon_mseg.current_process_id ^= ourmp -> syscon_mseg.current_process_id)
	     & (ourmp -> syscon_mseg.mescount >= LIMIT | ourmp -> syscon_mseg.output_wait)
	then do;
	     ourmp -> syscon_mseg.output_wait = "1"b;
	     code = OWAIT;
	     return;
	end;
	ourmp -> syscon_mseg.mescount = ourmp -> syscon_mseg.mescount + 1;

common_write:
	ourmp = SDB.ourmess;
	nchart = 0;				/* A couple of initializations. */
	code = 0;

	lock_set = "0"b;				/* for cleanup handler */
	lock_ptr = null ();				/* for cleanup handler */
	ipc_mask_code, ipc_unmask_code = -1;

	on condition (cleanup)
	     call CLEAN_UP ();

	call LOCK (hismp, code);			/* lock the message segment (shared amoung many processes) */
	if code ^= 0 then return;

/* Now that the seg is locked, calculate how many blocks we need
   for this message.  Grab them. Unlock the seg and we can fill them at our leisure. */
	no_of_blocks = divide (nchar + buff_len - 1, buff_len, 17, 0);

	message_type.continue = "1"b;
	do n = 1 to no_of_blocks;
	     if hismp -> syscon_mseg.first_free_buffer = 0 then do;
		hismp -> syscon_mseg.last_assigned_buffer = hismp -> syscon_mseg.last_assigned_buffer + 1;
		this_message = hismp -> syscon_mseg.last_assigned_buffer;
	     end;
	     else do;
		this_message = hismp -> syscon_mseg.first_free_buffer;
		hismp -> syscon_mseg.first_free_buffer =
		     hismp -> syscon_mseg.message (this_message).next_message;
	     end;
	     if n = 1 then begin_this = this_message;
	     else hismp -> syscon_mseg.message (prev_message).next_message = this_message;
	     prev_message = this_message;
	     hismp -> syscon_mseg.message (this_message).next_message = 0;
	     string (hismp -> syscon_mseg.message (this_message).flags) = string (message_type);
	end;

	hismp -> syscon_mseg.message (this_message).flags.continue = "0"b;
	end_this = this_message;
	call UNLOCK (hismp);

/* Now fill in the message blocks */
	len = min (nchar, buff_len);
	thisp = workp;
	thisp = addr (char_array (first_char + 1));	/* +1 because its really an offset */
	time = clock ();
	this_message = begin_this;

	do n = 1 to no_of_blocks;
	     hismp -> syscon_mseg.message (this_message).time_sent = time;
	     hismp -> syscon_mseg.message (this_message).from_source = SDB.source;
	     hismp -> syscon_mseg.message (this_message).from_stream = SDB.stream;
	     hismp -> syscon_mseg.message (this_message).source_index = SDB.source_index;
	     hismp -> syscon_mseg.message (this_message).stream_index = SDB.stream_index;
	     hismp -> syscon_mseg.message (this_message).message_body = this_batch;
	     hismp -> syscon_mseg.message (this_message).length = len;

	     thisp = addr (char_array (len + 1));	/* Update pointer & indeces */
	     nchart = nchart + len;
	     len = min (nchar - nchart, buff_len);
	     this_message = hismp -> syscon_mseg.message (this_message).next_message;
	end;

/* Lock the segment again, stick in the message, &unlock */
	call LOCK (hismp, code);
	if code ^= 0 then do;			/* Woops. Cannot lock seg to chain in. */
	     nchart = 0;				/* Pretend we didn't write at all */
	     return;				/* Some storage in message seg will be lost. */
	end;

	call VALIDATE_CHAIN (hismp, chainp, "write-2");

	if chain.chain_head = 0			/* Hook this into the proper message queue */
	then chain.chain_head = begin_this;
	else hismp -> syscon_mseg.message (chain.chain_tail).next_message = begin_this;

	chain.chain_tail = end_this;

	call UNLOCK (hismp);

/* Now wakeup other guy so he knows to look for what we just gave him. */

	call hcs_$wakeup (hismp -> syscon_mseg.current_process_id,
	     wake_up_chan, event_mess, autocode);
	return;
%page;
discard_remainder:
     entry (tp, state, code);

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

	my_name = "mrd_util_$discard_remainder";
	ourmp = SDB.ourmess;
	begin_this = SDB.prev_trans.first_block;
	end_this = SDB.prev_trans.end_block;
	code = 0;

	go to free_current_chain;
%page;
read: entry (tp, workp, first_char, nchar, nchart, request, mp, state, code);

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

	my_name = "mrd_util_$read";
	messp1 = mp;
	nchart = 0;
	code = 0;
	end_this = SDB.prev_trans.end_block;
	begin_this = SDB.prev_trans.first_block;
	ourmp = SDB.ourmess;
	if request = "proto" then chainp = addr (ourmp -> syscon_mseg.first_proto);
	else chainp = addr (ourmp -> syscon_mseg.first_message);
	if SDB.flags.more then goto get_message;

/* Unhook the blocks for this message (locking the seg first) */

	lock_set = "0"b;				/* for cleanup handler */
	lock_ptr = null ();				/* for cleanup handler */
	ipc_mask_code, ipc_unmask_code = -1;

	on condition (cleanup)
	     call CLEAN_UP ();

	call LOCK (ourmp, code);
	if code ^= 0 then return;

	call VALIDATE_CHAIN (ourmp, chainp, "read-1");

	SDB.prev_trans.offset = 0;

	if chain.chain_head = 0 then do;		/* Nothing in queue */
	     code = error_table_$no_message;
	     go to read_return;
	end;

	SDB.prev_trans.first_block,
	     SDB.prev_trans.current_block,
	     begin_this, this_message = chain.chain_head;

	no_of_blocks = 1;

	do while (ourmp -> syscon_mseg.message (this_message).continue);
	     this_message = ourmp -> syscon_mseg.message (this_message).next_message;
	     no_of_blocks = no_of_blocks + 1;
	end;

	SDB.prev_trans.end_block,
	     end_this = this_message;
	chain.chain_head = ourmp -> syscon_mseg.message (this_message).next_message;
	if end_this = chain.chain_tail then chain.chain_tail = 0;

	call UNLOCK (ourmp);

	messp = addr (ourmp -> syscon_mseg.message (begin_this));
	messp1 -> message_block.time_sent = message_block.time_sent;
	messp1 -> message_block.from_source = message_block.from_source;
	messp1 -> message_block.from_stream = message_block.from_stream;
	messp1 -> message_block.source_index = message_block.source_index;
	messp1 -> message_block.stream_index = message_block.stream_index;
	string (messp1 -> message_block.flags) = string (message_block.flags);

get_message:

/**** Extract the message */

	thisp = workp;
	thisp = addr (char_array (first_char + 1));
	this_message = SDB.prev_trans.current_block;
	len = min (nchar, ourmp -> syscon_mseg.message (this_message).length - SDB.prev_trans.offset);
	thatp = addr (ourmp -> syscon_mseg.message (this_message).message_body);
	thatp = addr (thatp -> char_array (SDB.prev_trans.offset + 1));

	do while (ourmp -> syscon_mseg.message (this_message).continue);
	     i = index (based_mess, NL);
	     if i ^= 0 then len = i;
	     this_batch = based_mess;
	     nchart = nchart + len;
	     if SDB.prev_trans.offset + len = ourmp -> syscon_mseg.message (this_message).length then
		do;
		SDB.prev_trans.offset = 0;
		this_message,
		     SDB.prev_trans.current_block = ourmp -> syscon_mseg.message (this_message).next_message;
	     end;
	     else do; SDB.prev_trans.offset = SDB.prev_trans.offset + len; goto theres_more; end;
	     if nchart = nchar then goto theres_more;
	     thatp = addr (ourmp -> syscon_mseg.message (this_message).message_body);
	     thisp = addr (char_array (len + 1));
	     len = min (nchar - nchart, ourmp -> syscon_mseg.message (this_message).length);
	end;

	i = index (based_mess, NL);
	if i ^= 0 then len = i;
	this_batch = based_mess;
	nchart = nchart + len;
	SDB.prev_trans.offset = SDB.prev_trans.offset + len;
	if SDB.prev_trans.offset ^= ourmp -> syscon_mseg.message (this_message).length
	then do;
theres_more:
	     state = 1;
	     SDB.flags.more = "1"b;
	     return;
	end;

/* Put used blocks back on the free storage list */

free_current_chain:
	SDB.flags.more = "0"b;
	state = 0;

	if begin_this = 0
	then return;

	if end_this = 0 then do;
	     call COMPLAIN (ourmp, "inconsistent threads");
	     call SAVE_STATE (ourmp);
	     return;
	end;

	call LOCK (ourmp, code);
	if code ^= 0 then return;

	ourmp -> syscon_mseg.message (end_this).next_message = ourmp -> syscon_mseg.first_free_buffer;
	ourmp -> syscon_mseg.first_free_buffer = begin_this;

read_return:
	SDB.prev_trans.first_block = 0;
	SDB.prev_trans.end_block = 0;
	call UNLOCK (ourmp);
	return;
%page;
read_status: entry (tp, statusp, code);

/**** entry to look at read ahead */

dcl  1 status_struct aligned based (statusp),
       2 ev_chan fixed bin (71),
       2 input_available bit (1);

dcl  statusp ptr;

	ourmp = SDB.ourmess;			/* get ptr to our msg seg */
	chainp = addr (ourmp -> syscon_mseg.first_message); /* get ptr to chain of messages */

	status_struct.ev_chan = ourmp -> syscon_mseg.ipc_el.channel;

	if chain.chain_head = 0 then			/* no chain, no input now */
	     status_struct.input_available = "0"b;	/* say no input */
	else status_struct.input_available = "1"b;

	return;
%page;
abort: entry (tp, reqsw, state, code);

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

	my_name = "mrd_util_$abort";

	ourmp = SDB.ourmess;
	hismp = SDB.hismess;

	lock_set = "0"b;				/* for cleanup handler */
	lock_ptr = null ();				/* for cleanup handler */
	ipc_mask_code, ipc_unmask_code = -1;

	on condition (cleanup)
	     call CLEAN_UP ();

	if reqsw = 1 | reqsw = 3 then do;		/* reset_read ==> wipe out messages in our seg */
	     call LOCK (ourmp, code);
	     if code ^= 0 then return;

	     ourmp -> syscon_mseg.first_message,
		ourmp -> syscon_mseg.last_message,
		ourmp -> syscon_mseg.first_proto,
		ourmp -> syscon_mseg.last_proto = 0;
	     call ipc_$drain_chn (ourmp -> syscon_mseg.ipc_el.channel, autocode);
	     call ipc_$drain_chn (ourmp -> syscon_mseg.proto_el.channel, autocode);
	     call UNLOCK (ourmp);
	end;

	if reqsw = 2 | reqsw = 3 then do;		/* reset_write ==> wipe out messages from us in mc's seg */
	     call LOCK (hismp, code);
	     if code ^= 0 then return;

	     do i = 1 to 2;				/* look in both chains */
		prev_message = 0;
		if i = 1 then chainp = addr (hismp -> syscon_mseg.first_message);
		else chainp = addr (hismp -> syscon_mseg.first_proto);

		call VALIDATE_CHAIN (hismp, chainp, "abort-1");

		this_message = chain.chain_head;

		do while (this_message ^= 0);		/* look for messages from us */
		     if hismp -> syscon_mseg.message (this_message).from_source = SDB.source then
			if hismp -> syscon_mseg.message (this_message).from_stream = SDB.stream then
			     do;			/* found one */
			     begin_this = this_message;
						/* Loop looking for end of message */
			     do while (hismp -> syscon_mseg.message (this_message).continue);
				this_message = hismp -> syscon_mseg.message (this_message).next_message;
			     end;
			     end_this = this_message;

			     if prev_message = 0 then chain_head, this_message =
				     hismp -> syscon_mseg.message (end_this).next_message;
			     else hismp -> syscon_mseg.message (prev_message).next_message, this_message =
				     hismp -> syscon_mseg.message (end_this).next_message;

			     if end_this = chain_tail then chain_tail = prev_message;
			     hismp -> syscon_mseg.message (end_this).next_message = hismp -> syscon_mseg.first_free_buffer;
			     hismp -> syscon_mseg.first_free_buffer = begin_this;
			end;

			else do;
skipover:			     do while (hismp -> syscon_mseg.message (this_message).continue);
				this_message = hismp -> syscon_mseg.message (this_message).next_message;
			     end;
			     this_message = hismp -> syscon_mseg.message (this_message).next_message;
			end;
		     else go to skipover;		/* sources don't match */
		end;
		call VALIDATE_CHAIN (hismp, chainp, "abort-2");
	     end;

	     ourmp -> syscon_mseg.mescount = 0;
	     ourmp -> syscon_mseg.output_wait = "0"b;
	     call UNLOCK (hismp);
	end;

	return;
%page;
LOCK:
     procedure (bv_lock_ptr, bv_lock_code);

/* parameters */

dcl  (bv_lock_ptr ptr,
     bv_lock_code fixed bin (35)) parameter;

/* automatic */

dcl  lock_code fixed bin (35);

	lock_set = "0"b;				/* we're not really locked yet */
	lock_ptr = bv_lock_ptr;			/* remember which lock we're locking */

	call ipc_$mask_ev_calls (ipc_mask_code);	/* mask ipc calls */
	call hcs_$set_ips_mask (""b, mask);		/* mask ips interrupts */

locking_loop:
	call set_lock_$lock (lock_ptr -> syscon_mseg.mlock, thirty_seconds, lock_code);
	if lock_code ^= 0 then
	     if lock_code = error_table_$lock_wait_time_exceeded then do;
		call SAVE_STATE (lock_ptr);
		lock_ptr -> syscon_mseg.mlock = "0"b;	/* This is naughty but may save a crash. */
		call COMPLAIN (lock_ptr, "had to blast lock");
		goto locking_loop;
	     end;
	     else if lock_code = error_table_$invalid_lock_reset then do;
		call COMPLAIN (lock_ptr, "reset bad lock");
		call SAVE_STATE (lock_ptr);
	     end;
	     else if lock_code = error_table_$locked_by_this_process then do;
		call COMPLAIN (lock_ptr, "killing process due to mylock error");
		call SAVE_STATE (lock_ptr);
		terminate_info.version = 0;
		terminate_info.code = lock_code;
		do while ("1"b);
		     call terminate_process_ ("fatal_error",
			addr (terminate_info));
		end;
	     end;
	     else do;
		bv_lock_code = lock_code;
		call hcs_$reset_ips_mask (mask, mask);
		call ipc_$unmask_ev_calls (ipc_unmask_code);
		return;
	     end;

	lock_ptr -> syscon_mseg.locked_by_pid = my_process_id;
	lock_set = "1"b;
	bv_lock_code = 0;
	return;

     end LOCK;
%page;
UNLOCK:
     procedure (bv_unlock_ptr);

/* parameters */

dcl  bv_unlock_ptr ptr parameter;

/* automatic */

dcl  unlock_ptr ptr;

/* program */

	unlock_ptr = bv_unlock_ptr;			/* remember what we're unlocking */
	lock_set = "0"b;				/* Turn off now to avoid bad window */
	lock_ptr = null ();
	call set_lock_$unlock (unlock_ptr -> syscon_mseg.mlock, autocode);
	call hcs_$reset_ips_mask (mask, mask);
	call ipc_$unmask_ev_calls (ipc_unmask_code);
	return;

     end UNLOCK;

SAVE_STATE:
     procedure (bv_seg_ptr);

/* parameters */

dcl  bv_seg_ptr ptr parameter;

/* automatic */

dcl  (p, segp) ptr;

/* program */

	segp = bv_seg_ptr;
	segp -> syscon_mseg.last_assigned_buffer = segp -> syscon_mseg.last_assigned_buffer + 1;
	p = addr (segp -> syscon_mseg.message (segp -> syscon_mseg.last_assigned_buffer));
	p -> debug_info.flag = -1;
	p -> debug_info.time = clock ();
	p -> debug_info.last_pid = segp -> syscon_mseg.locked_by_pid;
	p -> debug_info.first_msg = segp -> syscon_mseg.first_message;
	p -> debug_info.last_msg = segp -> syscon_mseg.last_message;
	p -> debug_info.first_pro = segp -> syscon_mseg.first_proto;
	p -> debug_info.last_pro = segp -> syscon_mseg.last_proto;
	p -> debug_info.free_chain = segp -> syscon_mseg.first_free_buffer;

     end SAVE_STATE;

VALIDATE_CHAIN:
     procedure (bv_seg_ptr, bv_chain_ptr, bv_where);

/* parameters */

dcl  (bv_chain_ptr ptr,
     bv_seg_ptr ptr,
     bv_where char (*)) parameter;

/* automatic */

dcl  (last_msgx, msgs_scanned, msgx) fixed bin;
dcl  (chain_ptr, msgp, segp) ptr;
dcl  why char (64) varying;

/* based */

dcl  1 chain based (chain_ptr) aligned,
       2 head fixed bin,
       2 tail fixed bin;

/* program */

	segp = bv_seg_ptr;
	chain_ptr = bv_chain_ptr;

	if chain.head = 0 & chain.tail = 0 then return;

	if chain.head = 0 & chain.tail ^= 0 then do;
	     why = "(head = 0 but tail ^= 0)";
	     go to die;
	end;

	if chain.head ^= 0 & chain.tail = 0 then do;
	     why = "(head ^= 0 but tail = 0)";
	     go to die;
	end;

	last_msgx = -1;
	msgs_scanned = 0;
	do msgx = chain.head repeat (msgp -> message_block.next_message) while (msgx ^= 0);
	     if msgs_scanned > 4662 then do;
		why = "(loop in chain)";
		go to die;
	     end;
	     msgs_scanned = msgs_scanned + 1;
	     if msgx <= 0 | msgx > min (segp -> syscon_mseg.last_assigned_buffer, 4662)
	     then do;
		why = "(msg index out of range)";
		go to die;
	     end;
	     if last_msgx = msgx then do;
		why = "(chain loops onto self)";
		go to die;
	     end;
	     msgp = addr (segp -> syscon_mseg.message (msgx));
	     last_msgx = msgx;
	end;

	if chain.tail ^= last_msgx then do;
	     why = "(chain.tail doesn't point to last msg)";
	     go to die;
	end;

	return;

die:
	call SAVE_STATE (segp);
	call RESET_HEADER (segp);
	call COMPLAIN (segp, bv_where || " " || why);

     end VALIDATE_CHAIN;

COMPLAIN:
     procedure (bv_complaint_ptr, bv_complaint);

/* parameters */

dcl  (bv_complaint char (*),
     bv_complaint_ptr ptr) parameter;

/* automatic */

dcl  complaint_ptr ptr,
     dname char (168),
     dname_len fixed bin,
     ename char (32);

/* program */

	complaint_ptr = bv_complaint_ptr;
	call hcs_$fs_get_path_name (complaint_ptr, dname, dname_len, ename, (0));
	call phcs_$ring_0_message (my_name || ": " || bv_complaint || " in " || ename);

     end COMPLAIN;

RESET_HEADER:
     procedure (bv_reset_ptr);

/* parameters */

dcl  bv_reset_ptr ptr parameter;

/* automatic */

dcl  reset_ptr ptr;

/* program */

	reset_ptr = bv_reset_ptr;
	reset_ptr -> syscon_mseg.first_message = 0;	/* zap msg chain */
	reset_ptr -> syscon_mseg.last_message = 0;
	reset_ptr -> syscon_mseg.first_proto = 0;	/* zap protocol chain */
	reset_ptr -> syscon_mseg.last_proto = 0;
	reset_ptr -> syscon_mseg.first_free_buffer = 0;	/* zap free chain */
	reset_ptr -> syscon_mseg.last_assigned_buffer = 0;

     end RESET_HEADER;
%page;
RETURN:
/**** any_other handler comes here. */
	return;
%page;
ANY_OTHER_HANDLER:
     procedure ();

/**** This procedure is the any_other handler for mrd_util_.  We report the
      find of condition, reset the message segment header elements, unlock
      the message segment if locked and return to mrd_ with an error status
      code. */

          call find_condition_info_ (null, addr(ci), code);
	if code = 0 then do;
	     call COMPLAIN (lock_ptr, "Condition encountered: "||ci.condition_name);
	     if ci.condition_name = "out_of_bounds" then do;
		if lock_ptr ^= null & lock_ptr ^= hismp then
		     call RESET_HEADER (lock_ptr);
						/* lock_ptr probably mc.message pointer anyway */
		else call RESET_HEADER (hismp);	/* mc.message */
	     end;
	end;
	if lock_ptr ^= null then call UNLOCK (lock_ptr);
	code = error_table_$unable_to_do_io;
	goto RETURN;
     end ANY_OTHER_HANDLER;
%page;
CLEAN_UP:
     procedure ();

	if lock_set then
	     do;
	     call set_lock_$unlock (lock_ptr -> syscon_mseg.mlock, (0));
	     lock_set = "0"b;
	     lock_ptr = null ();
	end;

	if substr (mask, 36, 1) = "1"b then		/* we were masked */
	     call hcs_$reset_ips_mask (mask, mask);

	if ipc_mask_code ^= -1 & ipc_unmask_code = -1 then
	     call ipc_$unmask_ev_calls (ipc_unmask_code);

	return;
     end CLEAN_UP;

/* format: off */
%page; %include condition_info;
%page; %include syscon_mseg;
/* format: on */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   mrd_util_$ENTRY: CALL_CODE (MESSAGE) in ENAME

   S:	$beep

   T:	$run

   M:	A problem has been discovered in the threading of the message
   coordinator segment ENAME.  CALL_CODE identifies the particular
   call that failed, and MESSAGE identifies the reason for the failure.
   Entry identifies the entrypoint in mrd_util_ that was called.
   All pending messages in ENAME are discarded.
   Debugging information is written into ENAME, and may be displayed
   using the dump_syscon_mseg tool.
   The message coordinator recovers from these errors and continues,
   possibly with the loss of some input or output.
   If ENAME is mc.message, some daemon output may be lost.
   If ENAME is anything else, some input to that daemon may be lost, and
   the operator should communicate with the daemon immediately, in case this has happened.
   $err

   A:	$inform
   Save all console and message coordinator terminal output.

   Message:
   mrd_util_$ENTRY: had to blast lock in ENAME

   S:	$beep

   T:	$run

   M:	The lock in the message coordinator segment ENAME did not
   unlock within thirty seconds.  The lock is reset forcibly,
   and locked to the calling process.
   ENTRY identifies the entrypoint in mrd_util_ that was called.
   Debugging information is written into ENAME, and may be displayed
   using the dump_syscon_mseg tool.
   Further errors may result if
   the process that originally locked the segment left it in
   an inconsistent state, or if it later starts up again.

   A:	$inform
   Save all console and message coordinator terminal output.

   Message:
   mrd_util_$ENTRY: reset bad lock in ENAME

   S:	$beep

   T:	$run

   M:	The message coordinator segment ENAME was locked to a
   nonexistent process.  The lock is reset and locked to the calling
   process.  ENTRY identifies the entrypoint in mrd_util_ that
   was called.
   Debugging information is written into ENAME, and may be displayed
   using the dump_syscon_mseg tool.
   Further errors may be reported if ENAME was in an inconsistent state.

   A:	$inform
   Save all console and message coordinator terminal output.

   Message:
   mrd_util_$ENTRY: killing process due to mylock error in ENAME

   S:	$term

   T:	$run

   M:	While trying to lock the message coordinator segment ENAME,
   the lock was found to already be locked to the calling process.
   ENTRY identifies the entrypoint in mrd_util_ that was called.
   Debugging information is written into ENAME, and may be displayed
   using the dump_syscon_mseg tool.
   $err

   A:	$inform
   Save all console and message coordinator terminal output.

   Message:
   mrd_util_$ENTRY: inconsistent threads in ENAME

   S:	$beep

   T:	$run

   M:	While trying to add unused blocks to the free chain
   in the message coordinator segment ENAME, an error was discovered.
   ENTRY identifies the entrypoint in mrd_util_ that was called.
   Debugging information is written into ENAME, and may be displayed
   using the dump_syscon_mseg tool.
   $err

   A:	$inform
   Save all console and message coordinator terminal output.

   Message:
   Error: CONDITION in mrd_util_$ENTRY

   S:	$beep

   T:	$run

   M:	CONDITION was signalled during a call to the entrypoint
   ENTRY in mrd_util_.
   A message coordinator dump is taken.
   If the calling process had a message coordinator segment locked, that
   segment is checked for consistency, and the lock is unlocked.
   mrd_util_ then returns to its caller without retrying the operation that failed.
   $err

   A:	$inform
   Save all console and message coordinator terminal output.

   END MESSAGE DOCUMENTATION */

     end mrd_util_;




		    mrdim_.pl1                      09/21/87  1958.4rew 09/21/87  1954.7      267309



/****^  ***********************************************************
        *                                                         *
        * 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(87-06-10,Parisek), approve(87-06-12,MCR7690),
     audit(87-06-12,Martinson), install(87-09-10,MR12.1-1104):
     Corrected a stringsize problem.
  2) change(87-09-08,Parisek), approve(87-09-08,MECR0005),
     audit(87-09-09,GDixon), install(87-09-10,MR12.1-1104):
     Expand "quit_mask" field to 504 bits from 72 bits for supporting QUITs to
     a larger array of daemons.
  3) change(87-09-17,Parisek), approve(87-09-21,MECR0008),
     audit(87-09-21,GDixon), install(87-09-21,MR12.1-1114):
     Return with error if status code equals error_table_$unable_to_do_io from
     calling mrd_util_.  This status code represents a condition error
     signalled from mrd_util_. (phx20928)
                                                   END HISTORY COMMENTS */

mrdim_: proc;
	return;					/* this is an undefined entry */

/* MRDIM_ - message routing DIM.

   This module replaces "ttydim_" for daemon processes which do not have stream terminals.
   It sends messages to and gets messages from a message coordinator which is part of the
   system control process group.
   The initializer may operate several consoles and route messages to them as it pleases.

   Coded by THVV from Feiertag's "ttydim_"
   Modified by Dennis Capps
   Attach entry modified for the access isolation mechanism on 10/16/74 - J. Whitmore
   Modified by J. C. Whitmore, 10/78, to zero words on first attach instead of calling hcs_$truncate_seg (BUG writearound)
   Modified by B. Margulies 11/81 for -login_channel.
   */

dcl (addr, index, length, null, size, string, substr, rtrim) builtin;

dcl (tp, sp, vp, p) ptr,				/* temporary storage */
    (state, n, nt, k, rw) fixed bin init (0),
     code fixed bin (35),
     em (4) fixed bin (71);

dcl  sysdir char (168) int static init (">system_control_1"), /* The directory in which to find the tables */
     RINGS (3) fixed bin (6) int static options (constant) init (4, 4, 4),
     OWAIT fixed bin static options (constant) init (123),	/* err code from mrdi_util_ */
     pigeon_hole char (32) init (""),
     USERID char (32),
     message char (132);

dcl  ourmp ptr,					/* Pointer to mseg for this function */
     mcmp ptr int static,				/* pointer to mseg for message coord'r */
     messp ptr int static init (null);			/* Periferal info on read. */

dcl
     need_priv bit (1) int static init ("0"b),		/* switch for using privileges */
     mask bit (36) aligned init ("0"b),			/* ips mask temporary */
     created_seg bit (1) init ("0"b),
     init bit (1) int static init ("0"b),
     leave_locked bit (1) init ("0"b),
     quit_mask bit (504)int static init ("0"b),
     source_init bit (1) init ("0"b),
     testing bit (1) int static init ("0"b),
     wrote_sentinel bit (1) init ("0"b);

dcl  lock_wait_time fixed bin init (300),
     i fixed bin,
     lcode fixed bin (35) init (0),
     level fixed bin,
     reset_priv fixed bin (35);

dcl 1 based_mrt_index based (p),
    2 dummy fixed bin (71),
    2 mrt_source fixed bin (35),
    2 mrt_stream fixed bin (35);

declare 1 dump int static aligned like message_block;

dcl 1 first_SDB int static aligned,			/* The first stream data block in the stream
						   data list for this process. */
    2 dim_name char (32),				/* the name of this DIM */
    2 device_name_list ptr,				/* threaded list of device id's */
    2 next_device ptr,				/* pointer to next entry in threaded list */
    2 device_name_size fixed bin,			/* number of chars in device name */
    2 device_name char (32),				/* device id */
    2 pad1 fixed bin,
    2 ipc_ep ptr,					/* to event list for block in read */
    2 proto_ep ptr,					/* to event list for block in att & det */
    2 nextp ptr init (null),				/* pointer to next stream block in chain */
    2 ourmess ptr,					/* Pointer to mseg for this function */
    2 hismess ptr,					/* Pointer to mseg for message coord'r */
    2 source char (32),				/* symbolic name of I/O source  */
    2 stream char (32),				/* symbolic name of I/O stream  */
    2 source_index fixed bin,				/* in MRT  */
    2 stream_index fixed bin,
    2 flags,
      3 valid bit (1) unal init ("0"b),			/* "1"b = entry-in-use, "0"b = not_in_use */
      3 read bit (1) unal,				/* "1"b = stream attached for reading. */
      3 write bit (1) unal,				/* "1"b = stream attached for writing. */
      3 active bit (1) unal,				/* For compatibility with message_coordr_ */
      3 more bit (1) unal,				/* "1"b = More text in this message than we've given */
      3 unused bit (31)unal,
    2 prev_trans,
      3 first_block fixed bin,
      3 end_block fixed bin,
      3 current_block fixed bin,
      3 offset fixed bin;

dcl 1 SDB based (tp) aligned,				/* one entry in list of stream control blocks */
    2 dim_name char (32),				/* the name of this DIM */
    2 device_name_list ptr,				/* threaded list of device id's */
    2 next_device ptr,				/* pointer to next entry in threaded list */
    2 device_name_size fixed bin,			/* number of chars in device name */
    2 device_name char (32),				/* device id */
    2 pad1 fixed bin,
    2 ipc_ep ptr,					/* to event list for block in read */
    2 proto_ep ptr,					/* to event list for block in att & det */
    2 nextp ptr,					/* pointer to next stream block in chain */
    2 ourmess ptr,					/* Pointer to mseg for this function */
    2 hismess ptr,					/* Pointer to mseg for message coord'r */
    2 source char (32),				/* symbolic name of I/O source  */
    2 stream char (32),				/* symbolic name of I/O stream  */
    2 source_index fixed bin,				/* in MRT  */
    2 stream_index fixed bin,
    2 flags,
      3 valid bit (1) unal,				/* "1"b = entry-in-use, "0"b = not_in_use */
      3 read bit (1) unal,				/* "1"b = stream attached for reading. */
      3 write bit (1) unal,				/* "1"b = stream attached for writing. */
      3 active bit (1) unal,				/* For compatibility with message_coordr_ */
      3 more bit (1) unal,				/* "1"b = More text in this message than we've given */
      3 unused bit (31)unal,
    2 prev_trans,
      3 first_block fixed bin,
      3 end_block fixed bin,
      3 current_block fixed bin,
      3 offset fixed bin;

% include line_types;
% include syscon_mseg;
% include tty_types;

dcl 1 st based (sp) aligned,				/* breakdown of I/O system status word */
    2 code fixed bin (35),				/* error status code (0 = OK) */
    2 comp bit (4) unaligned,				/* completion status, LI, LC, PI, PC */
    2 eof bit (1) unaligned,				/* end-of-file */
    2 pad1 bit (4) unaligned,
    2 eod bit (1) unaligned,				/* end of physical data */
    2 pad2 bit (4) unaligned,
    2 abs bit (1) unaligned,
    2 det bit (1) unaligned,				/* detach flag */
    2 quit bit (1) unaligned,				/* quit flag */
    2 abort bit (1) unaligned,			/* abort flag */
    2 callx bit (18) unaligned;			/* rel pointer to last transaction */

dcl  acc_mode fixed bin (35);				/* mode to satisfy the compiler */

dcl 1 syscon_template aligned based,			/* overlay for xxx.message to truncate above system_low AIM */
    2 lock_word fixed bin (35),
    2 words (2047) fixed bin (35);			/* two pages worth of stuff to zero out */

dcl 1 access based (addr (acc_mode)),
    2 access_pad bit (32) unaligned,
    2 R bit (1) unaligned,				/* the READ bit for the access mode */
    2 E bit (1) unaligned,				/* the EXECUTE bit... */
    2 W bit (1) unaligned,				/* the WRITE bit.... */
    2 A bit (1) unaligned;				/* the APPEND bit (obsolete for segs)... */

dcl
     com_err_ ext entry options (variable),
     continue_to_signal_ entry (fixed bin (35)),
     cu_$cl ext entry,
     cu_$level_get entry () returns (fixed bin),
     get_process_id_ ext entry returns (bit (36) aligned),
     ioa_$rs ext entry options (variable),
     get_group_id_$tag_star ext entry () returns (char (32)),
     ipc_$create_ev_chn ext entry (fixed bin (71), fixed bin (35)),
     ipc_$block ext entry (ptr, ptr, fixed bin (35)),
     ipc_$mask_ev_calls ext entry (fixed bin (35)),
     ipc_$unmask_ev_calls ext entry (fixed bin (35)),
     hcs_$append_branchx ext entry (char (*), char (*), fixed bin (5), (3) fixed bin (6),
     char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)),
     hcs_$assign_linkage ext entry (fixed bin, ptr, fixed bin (35)),
     hcs_$fs_get_mode entry (ptr, fixed bin (35), fixed bin (35)),
     hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned),
     mrd_util_$abort ext entry (ptr, fixed bin, fixed bin, fixed bin (35)),
     mrd_util_$discard_remainder ext entry (ptr, fixed bin, fixed bin (35)),
     mrd_util_$protocol ext entry (ptr, ptr, fixed bin, fixed bin, fixed bin, char (*), fixed bin (35)),
     mrd_util_$read ext entry (ptr, ptr, fixed bin, fixed bin, fixed bin, char (*), ptr, fixed bin, fixed bin (35)),
     mrd_util_$write ext entry (ptr, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     mrd_util_$write_dont_flood ext entry (ptr, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     mrd_util_$read_status ext entry (ptr, ptr, fixed bin (35)),
     phcs_$ring_0_message ext entry (char (*)),
     set_lock_$lock ext entry (bit (36) aligned, fixed bin, fixed bin (35)),
     set_lock_$unlock ext entry (bit (36) aligned, fixed bin (35)),
     system_privilege_$dir_priv_off entry (fixed bin (35)),
     system_privilege_$dir_priv_on entry (fixed bin (35)),
     system_privilege_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  user_info_$terminal_data entry options (variable);

dcl  error_table_$invalid_lock_reset ext fixed bin,
     error_table_$ionmat ext fixed bin,			/* stream already attached */
     error_table_$lock_wait_time_exceeded ext fixed bin,
     error_table_$locked_by_this_process ext fixed bin,
     error_table_$noentry ext fixed bin,
     error_table_$moderr ext fixed bin (35),
     error_table_$unable_to_do_io ext fixed bin (35),
     error_table_$undefined_order_request ext fixed bin;

dcl (any_other, linkage_error) condition;

/*  */
/* ===================================================== */

mrd_attach: entry (attname, attype, attchan, mode, attstat, attptr); /* entry to attach stream */

dcl  attname char (*),				/* stream name (e.g. user_i/o) */
     attype char (*),				/* device type name ("mrd") */
     attchan char (*),				/* stream channel name */
     mode char (*),					/* attachment mode */
     attstat bit (72) aligned,			/* I/O system status code (returned) */
     attptr ptr;					/* device attachment pointer (returned) */

dcl  mode_bits bit (36) init ("0"b);			/* For call to parse_mode */

declare  attach_channel_name character (32);

	attach_channel_name = attchan;
	if attach_channel_name = "-login_channel"
	then call user_info_$terminal_data ("", "", attach_channel_name);

	attstat = "0"b;				/* clear status code */
	sp = addr (attstat);			/* pick up pointer to status code argument */
	if attptr ^= null then do;			/* this is a multiple attachment, no good */
	     st.code = error_table_$ionmat;		/* return error code */
	     return;				/* return */
	end;

	if ^init then do;				/* be sure we are initialized */

	     USERID = get_group_id_$tag_star ();	/* get process name */
	     level = cu_$level_get ();		/* get validation level of process */
						/* see if process has access to coord message seg */
	     pigeon_hole = "mc.message";		/* name of message seg */

	     call hcs_$initiate (sysdir, pigeon_hole, "", 0, 1, mcmp, code); /* get the pointer */
	     if mcmp = null then go to check_priv;	/* we should have had access, try for priv initiate. */
						/* mc.message is assumed to be at the */
						/* lowest access class in the system.  */

	     call hcs_$fs_get_mode (mcmp, acc_mode, code); /* check real effective access */
	     if code ^= 0 then go to atterr;		/* bad news */

	     if ^(access.R & access.W) then do;		/*  are we restricted by access isolation? */
						/* yes, see if priv initiate is possible */

check_priv:	on linkage_error begin;		/* in case we don't have access to gate */
		     code = error_table_$moderr;	/* tell caller  he has no access */
		     go to atterr;			/* and return; */
		end;

		call system_privilege_$initiate (sysdir, pigeon_hole, "", 0, 1, mcmp, code);
		if mcmp = null then go to atterr;	/* this should never happen */
		revert linkage_error;		/* this must be off for the next part */
		need_priv = "1"b;			/* if we needed priv here, we will need it later */
	     end;
	     init = "1"b;				/* Let's not go through this again */
	     messp = addr (dump);			/* last item to initialize */

	end;

/* Search stream data list to see if this attachment is already made. */
	tp = addr (first_SDB);			/* get pointer to first entry in stream list */
	vp = null;				/* use vp to record first vacant entry (if any) */
	do while (tp ^= null);			/* search entire stream list */
	     p = tp;				/* keep track of last entry in p */
	     if ^SDB.flags.valid then do;		/* is this entry an unused (^valid) entry? */
		if vp = null then vp = tp;		/* record first vacant entry found in list */
	     end;
	     else if SDB.source = attach_channel_name then /* not vacant, is attach_channel_name-attname already attached? */
		do;
		if ^source_init then
		     do;
		     source_init = "1"b;
		     ourmp = SDB.ourmess;		/* So we don't have to initiate > once */
		end;
		if SDB.stream = attname then
		     do;
		     attptr = tp;			/* if so, return attachment ptr to this entry */
		     go to attrtn;			/* and return to caller */
		end;
	     end;
	     tp = SDB.nextp;			/* get pointer to next entry (if any) in list */
	end;
	if vp = null then do;			/* if no vacant entry found in stream list, */
	     i = size (SDB);
	     call hcs_$assign_linkage (i, vp, code);	/* then we must allocate space for a new entry */
	     string (vp -> SDB.flags) = "0"b;		/* initialize new stream list entry */
	     vp -> SDB.nextp = null;			/* indicate new entry is last entry in list */
	     p -> SDB.nextp = vp;			/* thread new entry into stream list */
	end;
	tp, attptr = vp;				/* set caller's attachment pointer */


/* Fill in SDB */
	SDB.dim_name = "mrd_";
	SDB.device_name_list = addr (SDB.next_device);	/* Pointer to list of device names. */
	SDB.next_device = null;			/* This is last entry in list of device names. */
	i = index (attach_channel_name, " ");
	if i = 0 then
	     SDB.device_name_size = length (attach_channel_name);
	else
	SDB.device_name_size = i - 1;
	SDB.device_name = attach_channel_name;
	SDB.source = attach_channel_name;
	SDB.stream = attname;
	SDB.hismess = mcmp;


	if ^source_init then
	     do;
						/* Initiate the message segment for this source */
	     pigeon_hole = substr (attach_channel_name, 1, SDB.device_name_size) || ".message";
	     if need_priv then
		call system_privilege_$initiate (sysdir, pigeon_hole, "", 0, 1, ourmp, code);
	     else call hcs_$initiate (sysdir, pigeon_hole, "", 0, 1, ourmp, code);
	     if ourmp = null then
		do;
		if code = error_table_$noentry then	/* see if we can create the message seg */
		     do;
		     USERID = get_group_id_$tag_star ();
		     if need_priv then do;		/* we can and need to use system priv */
			reset_priv = 1;		/* if this is 0, we set the priv */
			mask = "0"b;		/* old ips mask to be reset if not null */

			on any_other begin;		/* be sure we cleanup if an error occurs */
			     if reset_priv = 0 then
				call system_privilege_$dir_priv_off (reset_priv);
			     reset_priv = 0;
			     if mask then
				call hcs_$set_ips_mask (mask, ("0"b));
			     mask = "0"b;
			     call continue_to_signal_ ((0));
			end;

			call hcs_$set_ips_mask ((36)"0"b, mask); /* don't want to be interrupted */
			call system_privilege_$dir_priv_on (reset_priv); /* get dir priv */

			call hcs_$append_branchx (sysdir, pigeon_hole, 1011b, RINGS, USERID, 0, 0, 0, code);

			if reset_priv = 0 then
			     call system_privilege_$dir_priv_off (reset_priv);
			reset_priv = 1;		/* don't reset it twice */
			call hcs_$set_ips_mask (mask, ("0"b)); /* reset the old mask */
			mask = "0"b;		/* clear it out */
			revert any_other;
		     end;
		     else call hcs_$append_branchx (sysdir, pigeon_hole, 1011b, RINGS, USERID, 0, 0, 0, code);
		     if code ^= 0 then go to atterr;
		     if need_priv then
			call system_privilege_$initiate (sysdir, pigeon_hole, "", 0, 1, ourmp, code);
		     else call hcs_$initiate (sysdir, pigeon_hole, "", 0, 1, ourmp, code);
		     if ourmp = null then goto atterr;
		     created_seg = "1"b;		/* So we can mention it later */
		end;
		else goto atterr;
	     end;

/* Initialize our message segment */
	     call ipc_$mask_ev_calls (code);
lock_loop:
	     call set_lock_$lock (ourmp -> syscon_mseg.mlock, lock_wait_time, code);
	     if code ^= 0 then if code = error_table_$lock_wait_time_exceeded then
		     do;
		     if testing then
			do;
			call com_err_ (code, "mrdim_");
			call cu_$cl;
		     end;
		     else call phcs_$ring_0_message ("Unable to lock daemon message segment");
		     goto lock_loop;
		end;
		else if code = error_table_$locked_by_this_process then leave_locked = "1"b;
		else if code ^= error_table_$invalid_lock_reset then goto atterr;

	     ourmp -> syscon_template.words (*) = 0;	/* Zero all but the lock word */
						/* to get around hcs_$truncate bug for sys priv initiate */

	     ourmp -> syscon_mseg.current_process_id = get_process_id_ ();
						/* Fill in event lists */
	     ourmp -> syscon_mseg.ipc_el.n = 1;
	     ourmp -> syscon_mseg.proto_el.n = 1;
	     call ipc_$create_ev_chn (ourmp -> syscon_mseg.ipc_el.channel, code);
	     if code ^= 0 then goto latterr;
	     call ipc_$create_ev_chn (ourmp -> syscon_mseg.proto_el.channel, code);
	     if code ^= 0 then go to latterr;
	     ourmp -> syscon_mseg.flags.test_mode = testing;

	     if ^leave_locked then call set_lock_$unlock (ourmp -> syscon_mseg.mlock, lcode);
	     call ipc_$unmask_ev_calls (code);

	end;

	SDB.ipc_ep = addr (ourmp -> syscon_mseg.ipc_el);
	SDB.proto_ep = addr (ourmp -> syscon_mseg.proto_el);
	SDB.ourmess = ourmp;

/* Now let's introduce ourself to the message coordinator.  */
/* Construct a message. */
	call ioa_$rs ("^a function attaching ^a stream.",
	     message, i, attach_channel_name, attname);

	p = addr (em);				/* Preparation for reciept of acknowledgement */

/* Send introduction.  (This entry to mrd_util_ is really mrd_util_$write
   except that it wakes up a different channel & puts messages in a different chain.)  */
	call mrd_util_$protocol (tp, addr (message), 0, i, nt, "attach", code);
	if code ^= 0 then goto atterr;

/* Wait for acknowledgement. */
	call ipc_$block (SDB.proto_ep, p, code);
	SDB.source_index = based_mrt_index.mrt_source;
						/* All future correspondence must */
	SDB.stream_index = based_mrt_index.mrt_stream;	/* refer to these invoice numbers */
	substr (quit_mask, SDB.source_index, 1) = "1"b;
	ourmp -> syscon_mseg.no_of_streams = ourmp -> syscon_mseg.no_of_streams + 1;

	if created_seg then
	     do;
	     call ioa_$rs ("Created ^a>^a.message", message, i, sysdir, attach_channel_name);
	     call mrd_util_$write (tp, addr (message), 0, i, nt, state, code);
	     if code = error_table_$unable_to_do_io then goto atterr;
						/* Condition error */
	end;

	SDB.flags.valid = "1"b;			/* This SDB is being used. */
	SDB.flags.more = "0"b;
attrtn:
	st.eof = "1"b;				/* indicate stream at "end of file" */
	return;					/* and return to caller */

latterr:	if ^leave_locked then call set_lock_$unlock (ourmp -> syscon_mseg.mlock, lcode);
	call ipc_$unmask_ev_calls (lcode);

atterr:	st.code = code;				/* here on error, return status code to caller */
	st.det = "1"b;				/* indicate stream not attached */
	return;

/*  */
/* ===================================================== */

mrd_write: entry (SDBptr, wp, offset, ne, net, rwstat);	/* entry to write on stream */

dcl  SDBptr ptr,					/* attachment pointer to entry in stream list */
     wp ptr,					/* pointer to base of user's workspace */
     offset fixed bin,				/* character offset from wp */
     ne fixed bin,					/* number of elements (characters) to write (or read) */
     net fixed bin,					/* number of elements actually written (or read) */
     rwstat bit (72) aligned;				/* I/O system status code */

	tp = SDBptr;				/* get pointer to entry for this stream */
	rwstat = "0"b;				/* initialize status code to zero */
	sp = addr (rwstat);				/* get pointer to status code argument */
	if ne = 0 then go to wrtn;			/* skip to return if nothing to write */
	nt = 0;					/* initialize elements-written to zero */
	n = ne;					/* pick up number of elements to write */
	k = offset;				/* pick up element offset from wp */
wloop:	call mrd_util_$write_dont_flood (tp, wp, k, n, nt, state, code);
	if code = OWAIT then do;
	     call ipc_$block (SDB.ipc_ep, addr (em), code);
	     go to wloop;
	end;
	else if code = error_table_$unable_to_do_io then goto wrerr;
						/* Condition error */
	if n ^= nt then				/* if elements-written < elements-requested, */
	     do;
	     k = k + nt;				/* adjust element offset by elements transferred */
	     n = n - nt;				/* adjust element count to elements remaining */
	     nt = 0;				/* reset  elements transferred to zero and */
	     if n ^= 0 then go to wloop;		/* if elements remaining > 0, try again to write */
	end;

wrtn:	st.eof = "1"b;				/* indicate stream at "end-of-file" */
	st.comp = "1110"b;				/* return I/O completion indicators */
	net = ne;					/* indicate that all elements were transferred */
	return;
wrerr:    st.code = code;
	return;

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

mrd_read:	entry (SDBptr, wp, offset, ne, net, rwstat);	/* entry to read from stream */

	tp = SDBptr;				/* get pointer to entry for this stream */
	rwstat = "0"b;				/* initialize status code to zero */
	sp = addr (rwstat);				/* get pointer to status code argument */
	if ne = 0 then go to rdrtn;			/* skip to return if zero elements requested */
	net = 0;					/* initialize elements transferred to zero */
	p = addr (em);				/* get pointer to event message for call to block */
rdloop:	call mrd_util_$read (tp, wp, offset, ne, net, "normal", messp, state, code);
	if code = error_table_$unable_to_do_io then goto rdrtn;
						/* Condition error */
	if net = 0 then do;				/* if no elements read from console */
	     if ^wrote_sentinel then			/* Send one reminder to operator */
		do;
		call ioa_$rs ("-->  ^a", message, i, SDB.source);
		call mrd_util_$protocol (tp, addr (message), 0, i, nt, "sentinel", code);
		if code = error_table_$unable_to_do_io then goto rdrtn;
						/* Condition error */
		wrote_sentinel = "1"b;
	     end;
	     call ipc_$block (SDB.ipc_ep, p, code);	/* call block to await signal from message coord'r */
	     go to rdloop;				/* and try again to read from console */
	end;

rdrtn:	st.eof = "0"b;				/* not at end-of-file when in read-ahead mode */
	st.comp = "1111"b;				/* return I/O completion indicators */
	if state = 0 then st.eod = "1"b;
	return;					/* and return control to caller */

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

mrd_resetread: entry (SDBptr, stat2);			/* entry to reset read-ahead data */

dcl  stat2 bit (72) aligned;				/* I/O system status code (returned) */

	rw = 1;					/* set code to reset read-ahead only */
	go to reset;				/* join with code for resetwrite */

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

mrd_resetwrite: entry (SDBptr, stat2);			/* entry to reset write-behind buffers */

	rw = 2;					/* set code to reset write-behind only */

reset:	stat2 = "0"b;				/* initialize status code to zero */
	sp = addr (stat2);				/* get pointer to status code argument */
	go to rwabort;				/* join with code for abort */

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

mrd_abort: entry (SDBptr, stat2, stat3);		/* entry to reset read, write and quit condition */

dcl  stat3 bit (72) aligned;				/* I/O system status code (returned) */

	rw = 3;					/* set code to reset everything */
	stat3 = "0"b;				/* initialize status code to zero */
	sp = addr (stat3);				/* get pointer to status code argument */

rwabort:	tp = SDBptr;				/* get pointer to entry for this stream */
	call mrd_util_$abort (tp, rw, state, st.code);
	return;					/* and return */

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

mrd_order: entry (SDBptr, request, argptr, stat4);	/* entry to handle stream orders */

dcl  request char (*),				/* symbol stream request order code */
     argptr ptr,					/* pointer to additional arguments (if any) */
     stat4 bit (72) aligned;				/* I/O system status code (returned) */

dcl 1 info_struc aligned based (argptr),
    2 id char (4),
    2 flags aligned,
      3 bps_rate fixed binary (17) unaligned,
      3 line_type fixed binary (17) unaligned,
      3 pad bit (36) unaligned,
    2 tw_type fixed bin;

	string (stat4) = "0"b;
	tp = SDBptr;

	if request = "hangup" then return;
	if request = "listen" then return;
	if request = "line_length" then return;
	if request = "quit_enable" then
	     do;
	     mcmp -> syscon_mseg.quit_bits = mcmp -> syscon_mseg.quit_bits | quit_mask;
	     return;
	end;
	if request = "quit_disable" then
	     do;
	     mcmp -> syscon_mseg.quit_bits = mcmp -> syscon_mseg.quit_bits & ^quit_mask;
	     return;
	end;
	if request = "start" then return;
	if request = "printer_off" then return;
	if request = "printer_on" then return;

	if request = "info" then
	     do;
	     info_struc.id = rtrim(SDB.source);
	     info_struc.bps_rate = 0;
	     info_struc.line_type = LINE_MC;
	     info_struc.pad = ""b;
	     info_struc.tw_type = TYPE_UNKNOWN;
	     return;
	end;

	if request = "discard_remainder" then
	     do;
	     call mrd_util_$discard_remainder (tp, state, code);
	     return;
	end;

	if request = "read_status" then do;		/* request to look at read ahead */
	     call mrd_util_$read_status (tp, argptr, code);
	     return;
	end;

/* Any others are in error */
	addr (stat4) -> st.code = error_table_$undefined_order_request;
	return;

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

mrd_getsize: entry (SDBptr, elsize, stat3);		/* entry to return current element size */

dcl  elsize fixed bin;				/* current element size (returned) */

	elsize = 9;				/* element size for consoles is always 9 */
	return;					/* so return the constant 9 to the caller */

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

mrd_changemode: entry (SDBptr, mode, omode, stat4);	/* entry to modify the stream mode */

dcl  omode char (*);				/* returned mode prior to this call */

dcl 1 modes aligned,				/* structure for order call */
    2 len fixed bin,				/* length of mode string */
    2 mode_string char (128);				/* mode string */

	tp = SDBptr;				/* get pointer to SDB for this stream */
	stat4 = ""b;				/* initialize status to OK */
	sp = addr (stat4);				/* pick up pointer to status argument */
	modes.mode_string = mode;			/* copy mode string */
	omode = "";
	return;


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

mrd_detach: entry (SDBptr, ch2, disposal, stat4);		/* entry to detach a currently attached stream */

dcl (ch2, disposal) char (*);				/* these arguments ignored in this implementation */

	tp = SDBptr;				/* get pointer to entry for this stream */
	stat4 = "0"b;				/* initialize status code to zero */
	sp = addr (stat4);				/* get pointer to status code argument */
	ourmp = SDB.ourmess;
	st.det = "1"b;				/* set code to detach this ioname */
	if ^SDB.valid then return;
	SDB.valid = "0"b;				/* indicate stream list entry no longer in use */
	ourmp -> syscon_mseg.no_of_streams = ourmp -> syscon_mseg.no_of_streams - 1;
	if ourmp -> syscon_mseg.no_of_streams = 0 then
	     substr (quit_mask, SDB.source_index, 1) = "0"b;

/* Say goodbye to message coordinator */
	p = addr (em);				/* Preparation for reciept of acknowledgement. */

/* Construct a message */
	call ioa_$rs ("^a function detaching ^a stream. ", message, i, SDB.source, SDB.stream);

/* Send it */
	call mrd_util_$protocol (tp, addr (message), 0, i, nt, "detach", code);

/* Wait for acknowledgement */
	call ipc_$block (SDB.proto_ep, p, code);

	return;					/* and return */



/* =================================================== */

test_mrd:	entry (system_dir);

dcl  system_dir char (*);

	sysdir = system_dir;
	init = "0"b;
	need_priv = "0"b;				/* this will be determined later */
	testing = "1"b;
	return;

     end mrdim_;




		    restart_mc_ttys_.pl1            08/04/87  1456.8rew 08/04/87  1221.8       19269



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

restart_mc_ttys_: proc;

/* restart_mc_ttys_ is called to send a wakeup to all terminal device control channels.
   This insures that any asynchronously-invoked programs which do output will not steal a read wakeup. */

/* Modified August 1976 by Robert Coren to check CDTE pointer */
/* Modified 1985-01-02, BIM: new IOX MC. */


/****^  HISTORY COMMENTS:
  1) change(87-02-17,GDixon), approve(87-06-12,MCR7690),
     audit(87-05-07,Parisek), install(87-08-04,MR12.1-1055):
     Modified for change to mc_anstbl.incl.pl1.
                                                   END HISTORY COMMENTS */


	dcl     i			 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     fb71		 fixed bin (71) based (addr (larm));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     hcs_$wakeup		 entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));

	dcl     larm		 char (8) aligned int static init ("alarm___"); /* for restart_mc_ttys_ */

	dcl     (null, addr)	 builtin;

	mc_ansp = sc_stat_$mc_ansp;			/* Find table */
	call iox_$control (sc_stat_$mc_iocb, "start", null, code);
	do i = 1 to mc_anstbl.current_size;		/* Simulate timeout on attached consoles, get them going */
	     mc_atep = addr (mc_anstbl.entry (i));
	     if mc_ate.active & ^mc_ate.the_system_console then
		call hcs_$wakeup (mc_anstbl.mc_procid, mc_ate.event, fb71, code);
	end;

	return;

%include sc_stat_;
%include mc_anstbl;

     end restart_mc_ttys_;




		    suffix_mcacs_.pl1               04/09/85  1550.5r w 04/08/85  1133.0      124227



/* **************************************************************
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1983 *
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1983    *
   *                                                            *
   ************************************************************** */

/* format: style2,idind30,indcomtxt */

/* Typed-segment primitives for Message Coordinator ACS segments  */

/**** 1984-12-21, BIM: created from suffix_ms_ */

suffix_mcacs_:
     procedure ();


/* Common Parameters */

	dcl     P_desired_version	        character (*) parameter;
	dcl     P_dirname		        character (*) parameter;
						/* directory containing the message segment */
	dcl     P_ename		        character (*) parameter;
						/* name of the message segment */
	dcl     P_code		        fixed binary (35) parameter;

/* suffix_info and list_switches Parameters */

	dcl     P_switch_list_ptr	        ptr parameter;
	dcl     P_suffix_info_ptr	        ptr parameter;

/* chname_file Parameters */

	dcl     P_old_name		        character (*) parameter;
						/* name to be deleted */
	dcl     P_new_name		        character (*) parameter;
						/* name to be added */

/* copy parameters */

	dcl     P_copy_options_ptr	        ptr parameter;

/* Parameters used by most ACL entries */

	dcl     P_acl_ptr		        pointer parameter;
						/* -> an ACL array structure */


/* list_acl Parameters */

	dcl     P_user_area_ptr	        pointer parameter;
						/* -> area where to allocate listed_acl if non-null */


/* replace_acl Parameters */

	dcl     P_no_sysdaemon	        bit (1) parameter;
						/* ON => do not add explicit *.SysDaemon.* term */

/* switch Parameters */

	dcl     P_switch_name	        char (*) parameter;
	dcl     P_value		        bit (1) aligned parameter;

/* (get set)_max_length and bit_count parameters */

	dcl     P_max_length	        fixed bin (19) parameter;

/* get_user_access_modes parameters */

	dcl     (P_modes, P_exmodes)	        bit (36) aligned;
	dcl     P_ring		        fixed bin;
	dcl     P_user_name		        char (*);

/* ring brackets */

	dcl     P_rings		        (2) fixed bin (3);

/* Remaining declarations */

	dcl     acl_error		        bit (1) aligned;
	dcl     ex_acl_ptr		        pointer;
	dcl     user_area_ptr	        pointer;
	dcl     user_area		        area based (user_area_ptr);
	dcl     system_free_area	        area based (get_system_free_area_ ());

	dcl     idx		        fixed binary;

	dcl     error_table_$argerr	        fixed binary (35) external;
	dcl     error_table_$unsupported_operation
				        fixed binary (35) external;
	dcl     error_table_$unimplemented_version
				        fixed bin (35) ext static;
	declare error_table_$not_seg_type     fixed bin (35) ext static;

	declare cu_$generate_call	        entry (entry, ptr);
	declare cu_$arg_list_ptr	        entry returns (pointer);
	dcl     (get_system_free_area_, get_user_free_area_)
				        entry () returns (pointer);

	dcl     hcs_$get_user_access_modes    entry (char (*), char (*), char (*), fixed bin, bit (36) aligned,
				        bit (36) aligned, fixed bin (35));
	dcl     sub_err_		        entry () options (variable);


	declare V_entry		        entry variable options (variable);

	dcl     cleanup		        condition;

	dcl     null		        builtin;

	declare VALID_ACL_XMODES	        bit (36) aligned init
						/** abcdefghijklmnopqrstuvwxyz */
				        /*         */ ("001100000000000011000000000000000000"b) int static
				        options (constant);


/**** format: off */
%page; %include suffix_info;
%page; %include acl_structures;
%page; %include access_mode_values;
%include sub_err_flags;
%include copy_flags;
%include file_system_operations;
/* format: on */



/* Deletes a message segment */

delentry_file:
     entry (P_dirname, P_ename, P_code);

	call FORWARD (FS_DELENTRY_FILE, cu_$arg_list_ptr ());
	return;



chname_file:
     entry (P_dirname, P_ename, P_old_name, P_new_name, P_code);

	call FORWARD (FS_CHNAME_FILE, cu_$arg_list_ptr ());
	return;


copy:
     entry (P_copy_options_ptr, P_code);

	call FORWARD (FS_COPY, cu_$arg_list_ptr ());
	return;


validate:
     entry (P_dirname, P_ename, P_code);

	P_code = error_table_$not_seg_type;
	if index (P_ename, ".") > 0
	then if before (reverse (rtrim (P_ename)), ".") = reverse ("mcacs")
	     then P_code = 0;
	return;


suffix_info:
     entry (P_suffix_info_ptr);

	suffix_info_ptr = P_suffix_info_ptr;

	if suffix_info.version ^= SUFFIX_INFO_VERSION_1
	then call sub_err_ (error_table_$unimplemented_version, "bad suffix info version", ACTION_CANT_RESTART, null (),
		(0), "Invalid version ^a in call to suffix_ms_$suffix_info.", suffix_info.version);

	suffix_info.type = "mcacs";
	suffix_info.type_name = "Message Coordinator source ACS";
	suffix_info.plural_name = "Message Coordinator source ACS's";
	string (suffix_info.flags) = ""b;
	suffix_info.extended_acl = "0"b;
	suffix_info.has_switches = "0"b;
	suffix_info.modes = "cdqr";
	suffix_info.max_mode_len = 4;
	suffix_info.num_ring_brackets = 2;		/* gate bracket dull */
	string (suffix_info.copy_flags) = ""b;
	suffix_info.copy_flags.names, suffix_info.copy_flags.acl, suffix_info.copy_flags.max_length,
	     suffix_info.copy_flags.safety_switch = "1"b;

	suffix_info.info_pathname = "extended_access.gi.info";

	return;

%page;

add_acl_entries:
     entry (P_dirname, P_ename, P_acl_ptr, P_code);

	acl_ptr = P_acl_ptr;
	if acl_ptr = null ()
	then do;
		P_code = error_table_$argerr;
		return;
	     end;

	if general_acl.version ^= GENERAL_ACL_VERSION_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	acl_error = "0"b;
	general_acl.entries (*).status_code = 0;
	do idx = 1 to general_acl.count;
	     if (general_acl.entries (idx).mode & VALID_ACL_XMODES) ^= ""b
	     then do;
		     general_acl.entries (idx).status_code = error_table_$argerr;
		     acl_error = "1"b;
		end;
	end;
	if acl_error
	then do;
		P_code = error_table_$argerr;
		return;
	     end;

	acl_count = general_acl.count;
	allocate general_extended_acl in (system_free_area) set (ex_acl_ptr);
	ex_acl_ptr -> general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
	do idx = 1 to acl_count;
	     ex_acl_ptr -> general_extended_acl.entries (idx).access_name = general_acl.entries (idx).access_name;
	     ex_acl_ptr -> general_extended_acl.entries (idx).mode = ""b;
	     ex_acl_ptr -> general_extended_acl.entries (idx).extended_mode = general_acl.entries (idx).mode;
	     ex_acl_ptr -> general_extended_acl.entries (idx).status_code = 0;
	end;

	call MAKE_ENTRY (FS_ADD_EXTENDED_ACL_ENTRIES);
	call V_entry (P_dirname, P_ename, ex_acl_ptr, P_code);

	general_acl.entries (*).status_code = ex_acl_ptr -> general_extended_acl.entries (*).status_code;
	free general_extended_acl;
	return;


list_acl:
     entry (P_dirname, P_ename, P_desired_version, P_user_area_ptr, P_acl_ptr, P_code);

	acl_ptr = P_acl_ptr;
	ex_acl_ptr = null ();

	if acl_ptr ^= null ()
	then do;					/* wants to list specific entries */
		if general_acl.version ^= GENERAL_ACL_VERSION_1
		then do;
			P_code = error_table_$unimplemented_version;
			return;
		     end;

		acl_count = general_acl.count;
		if acl_count = 0
		then return;
		allocate general_extended_acl in (system_free_area) set (ex_acl_ptr);
		ex_acl_ptr -> general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
		do idx = 1 to acl_count;
		     ex_acl_ptr -> general_extended_acl.entries (idx).access_name =
			general_acl.entries (idx).access_name;
		     ex_acl_ptr -> general_extended_acl.entries (idx).status_code = 0;
		end;

		call MAKE_ENTRY (FS_LIST_EXTENDED_ACL);
		call V_entry (P_dirname, P_ename, "", null (), ex_acl_ptr, P_code);
		do idx = 1 to acl_count;
		     general_acl.entries (idx).mode = ex_acl_ptr -> general_extended_acl.entries (idx).extended_mode;
		     general_acl.entries (idx).status_code =
			ex_acl_ptr -> general_extended_acl.entries (idx).status_code;
		end;
		free ex_acl_ptr -> general_extended_acl;
	     end;


	else do;					/* wants to list an acl entirely */
		if P_desired_version ^= GENERAL_ACL_VERSION_1
		then do;
			P_code = error_table_$unimplemented_version;
			return;
		     end;

		user_area_ptr = P_user_area_ptr;
		if user_area_ptr = null ()
		then user_area_ptr = get_user_free_area_ ();

		call MAKE_ENTRY (FS_LIST_EXTENDED_ACL);
		call V_entry (P_dirname, P_ename, GENERAL_EXTENDED_ACL_VERSION_1, get_system_free_area_ (),
		     ex_acl_ptr, P_code);

		if P_code ^= 0
		then return;

		if ex_acl_ptr = null ()
		then do;
			P_acl_ptr = null ();
			return;
		     end;

		acl_count = max (1, ex_acl_ptr -> general_extended_acl.count);
		allocate general_acl in (user_area);
		P_acl_ptr = acl_ptr;
		general_acl.count = ex_acl_ptr -> general_extended_acl.count;
		if general_acl.count = 0
		then go to LIST_FREE_RETURN;

		general_acl.version = GENERAL_ACL_VERSION_1;
		do idx = 1 to acl_count;
		     general_acl.entries (idx).access_name =
			ex_acl_ptr -> general_extended_acl.entries (idx).access_name;
		     general_acl.entries (idx).mode = ex_acl_ptr -> general_extended_acl.entries (idx).extended_mode;
		     general_acl.entries (*).status_code = 0;
		end;
LIST_FREE_RETURN:
		free ex_acl_ptr -> general_extended_acl;
	     end;

	return;
%page;

delete_acl_entries:
     entry (P_dirname, P_ename, P_acl_ptr, P_code);

	acl_ptr = P_acl_ptr;
	if acl_ptr = null ()
	then do;
		P_code = error_table_$argerr;
		return;
	     end;

	call FORWARD (FS_DELETE_ACL_ENTRIES, cu_$arg_list_ptr ());

%page;

/**** NOTE -- the default SysDaemon access for an mcacs is null.
      Therefore, the no_sysdaemon switch is a noop. */

replace_acl:
     entry (P_dirname, P_ename, P_acl_ptr, P_no_sysdaemon, P_code);

	ex_acl_ptr = null ();

	acl_ptr = P_acl_ptr;
	if acl_ptr = null ()
	then do;
		P_code = error_table_$argerr;
		return;
	     end;

	on cleanup
	     begin;
		if ex_acl_ptr ^= null ()
		then do;
			free ex_acl_ptr -> general_extended_acl;
			ex_acl_ptr = null ();
		     end;
	     end;

	acl_count = general_acl.count;

	call MAKE_ENTRY (FS_REPLACE_EXTENDED_ACL);


	if acl_count = 0				/* cannot have no_sysdaemon */
	then do;
		acl_count = 1;
		allocate general_extended_acl in (system_free_area) set (ex_acl_ptr);
		ex_acl_ptr -> general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;
		ex_acl_ptr -> general_extended_acl.count = 0;
		call V_entry (P_dirname, P_ename, ex_acl_ptr, "1"b, P_code);
		free ex_acl_ptr -> general_extended_acl;
		return;
	     end;

	allocate general_extended_acl in (system_free_area) set (ex_acl_ptr);
	ex_acl_ptr -> general_extended_acl.version = GENERAL_EXTENDED_ACL_VERSION_1;

	do idx = 1 to acl_count;			/* no need to splice in funny acl */
	     ex_acl_ptr -> general_extended_acl.entries (idx).access_name = general_acl.entries (idx).access_name;
	     ex_acl_ptr -> general_extended_acl.entries (idx).extended_mode = general_acl.entries (idx).mode;
	     ex_acl_ptr -> general_extended_acl.entries (idx).mode = ""b;
	     ex_acl_ptr -> general_extended_acl.entries (idx).status_code = 0;

	end;

	call V_entry (P_dirname, P_ename, ex_acl_ptr, "1"b, P_code);

	general_acl.entries (*).status_code = ex_acl_ptr -> general_extended_acl.entries (*).status_code;
	free ex_acl_ptr -> general_extended_acl;

	return;


get_switch:
     entry (P_dirname, P_ename, P_switch_name, P_value, P_code);

	call FORWARD (FS_GET_SWITCH, cu_$arg_list_ptr ());

set_switch:
     entry (P_dirname, P_ename, P_switch_name, P_value, P_code);

	call FORWARD (FS_SET_SWITCH, cu_$arg_list_ptr ());

%page;
get_max_length:
     entry (P_dirname, P_ename, P_max_length, P_code);

	call FORWARD (FS_GET_MAX_LENGTH, cu_$arg_list_ptr ());

set_max_length:
     entry (P_dirname, P_ename, P_max_length, P_code);

	call FORWARD (FS_SET_MAX_LENGTH, cu_$arg_list_ptr ());

list_switches:
     entry (P_desired_version, P_user_area_ptr, P_switch_list_ptr, P_code);

	call FORWARD (FS_LIST_SWITCHES, cu_$arg_list_ptr ());


get_ring_brackets:
     entry (P_dirname, P_ename, P_rings, P_code);

	declare three_rings		        (3) fixed bin (3);

	call MAKE_ENTRY (FS_GET_RING_BRACKETS);
	call V_entry (P_dirname, P_ename, three_rings, P_code);
	P_rings (1) = three_rings (1);
	P_rings (2) = three_rings (2);
	return;

set_ring_brackets:
     entry (P_dirname, P_ename, P_rings, P_code);

	three_rings (1) = P_rings (1);
	three_rings (2), three_rings (3) = P_rings (2);
	call MAKE_ENTRY (FS_SET_RING_BRACKETS);
	call V_entry (P_dirname, P_ename, three_rings, P_code);
	return;


get_user_access_modes:
     entry (P_dirname, P_ename, P_user_name, P_ring, P_modes, P_exmodes, P_code);

	P_exmodes = ""b;				/* msegs, like dirs, have only modes, no exmodes */
	call hcs_$get_user_access_modes (P_dirname, P_ename, P_user_name, P_ring, ((36)"0"b), P_modes, P_code);
	return;


MAKE_ENTRY:
     procedure (OP);

	declare OP		        char (64);

	call MAKE_ENTRY_ (OP);
	return;
FORWARD:
     entry (OP, Arg_list_ptr);

	declare Arg_list_ptr	        pointer;

	call MAKE_ENTRY_ (OP);
	call cu_$generate_call (V_entry, Arg_list_ptr);
	go to FORWARD_RETURNS;
     end MAKE_ENTRY;

FORWARD_RETURNS:
	return;

MAKE_ENTRY_:
     procedure (OP);

	declare OP		        char (64);
	declare code		        fixed bin (35);

	declare fs_util_$make_entry_for_type  entry (character (*), character (*), entry, fixed binary (35));

	call fs_util_$make_entry_for_type ("-segment", (OP), V_entry, code);
	if code ^= 0
	then call sub_err_ (code, "suffix_mcacs_", ACTION_CANT_RESTART, null (), (0),
		"Failed to find entrypoint for ""^a"" for segments.", OP);
     end MAKE_ENTRY_;

     end suffix_mcacs_;




		    turn_on_mc_.pl1                 08/04/87  1456.8rew 08/04/87  1221.9       52263



/****^  ***********************************************************
        *                                                         *
        * 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: style2 */

/* This procedure is called to cause the message coordinator to start up.
   It reattaches the I/O streams used by the message coordinator so that the various sources
   inside the initializer process can be routed independently. */

/* Modified August 1981 by E. N. Kittlitz to get heed bad iox_ return codes */
/* Modified August 1982 by E. N. Kittlitz to not call sys_log_$mc_on. */
/* Modified 1984-10-08 BIM to remove tape_switch, use up-to-date iox. */
/* Modified 1984-12-02, BIM: remove mc_i/o altogether, use sc_ipc_mask_ */

/****^  HISTORY COMMENTS:
  1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387),
     audit(86-06-10,Martinson), install(86-07-11,MR12.0-1092):
     Correct error message documentation.
  2) change(87-06-12,Parisek), approve(87-06-12,MCR7690),
     audit(87-06-12,Martinson), install(87-08-04,MR12.1-1055):
       1) Removed unreferenced declarations.
       2) Added HBULL pnotice.
                                                   END HISTORY COMMENTS */

turn_on_mc_:
     proc;

	/* Builtins */
	dcl     codeptr		 builtin;

	dcl     code		 fixed bin (35);
	dcl     n_masks		 fixed bin;
	dcl     mc_tty_		 entry ();

	dcl     com_err_		 entry options (variable);
	dcl     mc_util_$init	 entry (char (*), char (6) aligned, entry, ptr, ptr, fixed bin (35));

%include iox_entries;
	dcl     sc_ipc_mask_$unmask	 entry (fixed binary);
	dcl     sc_ipc_mask_$remask	 entry (fixed binary);
	dcl     ssu_$get_info_ptr	 entry (ptr) returns (ptr);


%include iox_modes;
%include sc_stat_;
%include sc_subsystem_info_;

	if sc_stat_$mc_is_on
	then return;				/* once. */

/* First turn on the real message coordinator. */


	call mc_util_$init (sc_stat_$sysdir, sc_stat_$master_channel, mc_tty_, sc_stat_$mc_ansp, sc_stat_$initzer_ttyp,
	     code);
	if code ^= 0
	then call complain ("error from mc_init");

	call sc_ipc_mask_$unmask (n_masks);

	/*** event calls are now unmasked, and n_masks is the number
	     of times to remask them (perhaps 0). */

	call iox_$detach_iocb (sc_stat_$sv1_iocb, code);
	if code ^= 0
	then call complain ("detach severity1");
	call iox_$detach_iocb (sc_stat_$sv2_iocb, code);
	if code ^= 0
	then call complain ("detach severity2");
	call iox_$detach_iocb (sc_stat_$sv3_iocb, code);
	if code ^= 0
	then call complain ("detach severity3");
	call iox_$attach_ptr (sc_stat_$sv1_iocb, "mr_ as", codeptr (turn_on_mc_), code);
	if code ^= 0
	then call complain ("attach severity1");
	call iox_$attach_ptr (sc_stat_$sv2_iocb, "mr_ as", codeptr (turn_on_mc_), code);
	if code ^= 0
	then call complain ("attach severity2");
	call iox_$attach_ptr (sc_stat_$sv3_iocb, "mr_ as", codeptr (turn_on_mc_), code);
	if code ^= 0
	then call complain ("attach severity3");
	call iox_$open (sc_stat_$sv1_iocb, Stream_output, "1"b, code);
	if code ^= 0
	then call complain ("open severity1");
	call iox_$open (sc_stat_$sv2_iocb, Stream_output, "1"b, code);
	if code ^= 0
	then call complain ("open severity2");
	call iox_$open (sc_stat_$sv3_iocb, Stream_output, "1"b, code);
	if code ^= 0
	then call complain ("open severity3");

	call sc_ipc_mask_$remask (n_masks);

	sc_subsystem_info_ptr = ssu_$get_info_ptr (sc_stat_$master_sci_ptr);
	sc_subsystem_info.mc_atep = sc_stat_$initzer_ttyp;/* tell the world */
	sc_subsystem_info.real_iocb = sc_stat_$master_iocb;
						/* how to talk to this */

	sc_stat_$mc_is_on = "1"b;			/* Set flag. */
exit:
	return;


complain:
     proc (why);
	dcl     why		 char (*);
	call com_err_ (code, "turn_on_mc_", why);
	go to exit;
     end;


/* BEGIN MESSAGE DOCUMENTATION

   Message:
   turn_on_mc_: MESSAGE. detach STREAM

   S:	sc (error_output).

   T:	$init

   M:	The system attempted to start the Message Coordinator
   but the stream STREAM could not be detached from its initial
   dim.  The system continues to operate but the Message Coordinator
   is not used.  Probably, the daemon processes will also encounter
   trouble.

   A:	$contact


   Message:
   turn_on_mc_: MESSAGE. attach STREAM

   S:	sc (error_output).

   T:	$init

   M:	The system attempted to start the Message Coordinator
   but the stream STREAM cannot be attached to the message routing
   dim.  The system continues to operate but the Message Coordinator
   is not used.  Probably, the daemon processes will also encounter
   trouble.

   A:	$contact


   Message:
   turn_on_mc_: MESSAGE. open STREAM

   S:	sc (error_output).

   T:	$init

   M:	The system attempted to start the Message Coordinator but the
   stream STREAM cannot be opened by the message routing dim.  The system continues
   to operate but the Message Coordinator is not used.  Probably, the daemon
   processes will also encounter trouble.

   A:	$contact


   Message:
   turn_on_mc_: MESSAGE. error from mc_init

   S:	sc (error_output).

   T:	$init

   M:	The system attempted to start the Message Coordinator
   but it cannot be initialized.  The system continues to operate but
   the Message Coordinator is not used.  The daemon processes will
   probably also encounter trouble.

   A:	$contact

   END MESSAGE DOCUMENTATION */

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