



		    cmcs_create_queues_.pl1         05/24/89  1047.9rew 05/24/89  0833.9       96957



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_create_queues_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/28/81 by FCH, [4.4-1], once per process initialization, BUG468 */
/* Modified since Version 4.3 */



/* format: style3 */
cmcs_create_queues_:
     proc (a_code);

/* This COBOL MCS subroutine is used by cobol_mcs_admin to do the actual work of creating
   the CMCS queues, cmcs_wait_ctl.control, cmcs_system_ctl.control, and cmcs_queue_ctl.control. */

/* Bob May, 6/30/77 */

dcl	a_code		fixed bin (35);

dcl	vt_count		fixed bin,
	pic_value		pic "9999",		/* to build switch names */
	(q_name, sw_name)	char (32),
	iocbp		ptr,
	(hdr_len_21, constant_hdr_len)
			fixed bin (21);

dcl	(i, j, k)		fixed bin,
	temp_ctl_ptr	ptr,			/* for use with make_seg */
	my_name		char (19) init ("cmcs_create_queues_");



dcl	get_pdir_		entry () returns (char (168));
dcl	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl	hcs_$make_seg	entry (char (*) aligned, char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	hcs_$truncate_seg	entry (ptr, fixed bin (18), fixed bin (35));

dcl	(
	error_table_$namedup,
	error_table_$segknown,
	error_table_$action_not_performed,
	error_table_$no_record
	)		fixed bin (35) external;

dcl	(
	sub_err_,
	ioa_,
	ioa_$rsnnl
	)		entry options (variable);

dcl	sub_err_retval	fixed bin (35);		/* dummy for sub_err_ */

dcl	(addr, index, null, size, string, substr, truncate)
			builtin;

dcl	cleanup		condition;

dcl	vfile_table_ptr	ptr int static init (null);

dcl	vt_index		fixed bin;		/* manual index into vfile_table when being built */

dcl	1 vfile_table	(vt_count) based (vfile_table_ptr),
	  2 switch_name	char (32),
	  2 queue_name	char (32),
	  2 tree_ctl_eindex fixed bin,
	  2 iocb_ptr	ptr,
	  2 error_flag	bit (1);

dcl	var_cmcs_dir	char (256) varying;		/* temp to build vfile_ attach descr */
dcl	attach_descr	char (256);

dcl	1 vfile_rs1	like vfile_rs;

dcl	zero_overlay_len	fixed bin,
	zero_overlay	(zero_overlay_len) fixed bin (35) based;
						/* to zero space in stack or pre-used structure entries */

/*  */

%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_iox_processing;
%include cmcs_key_dcls;
%include cmcs_queue_ctl;
%include cmcs_system_ctl;
%include cmcs_tree_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;
%include cmcs_wait_ctl;

/*  */

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.create_queues)
	then call setup;



	var_cmcs_dir = substr (user_ctl.cmcs_dir, 1, index (user_ctl.cmcs_dir, " ") - 1);
						/* we'll always find blanks */

	vt_count = tree_ctl.queue_count;
	allocate vfile_table;
	vt_index = 0;

	do i = 1 to tree_ctl.current_size;

	     if ^tree_ctl.entries (i).inactive_sw
	     then if tree_ctl.entries (i).subtree_count = 0
						/* absolute tree path */
		then do;

			vt_index = vt_index + 1;
			vfile_table (vt_index).tree_ctl_eindex = i;
						/* to copy tree entry stuff into queue entry later */
			vfile_table (vt_index).queue_name = tree_ctl.entries (i).queue_name;
			vfile_table (vt_index).iocb_ptr = null ();
			vfile_table (vt_index).error_flag = "1"b;
						/* reset only if completely successful */

		     end;
	end;

	on cleanup go to free_vt;

/* first create the other control segs */

	call make_seg ("cmcs_system_ctl.control", system_ctl_ptr);

	if a_code ^= 0
	then go to free_vt;

	call cmcs_fillin_hdr_ (system_ctl_ptr, system_ctl_version, system_ctl_hdr_len, system_ctl_entry_len, a_code);

	if a_code ^= 0
	then do;

		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fillin hdr for system_ctl.");

		go to free_vt;

	     end;

	user_ctl.system_ctl_ptr = system_ctl_ptr;
	system_ctl.password = "cobol_mcs";		/* garbage until set with set_cmcs_password */
	system_ctl.lock_wait_time = 300;		/* seconds, maybe made variable later */

	call make_seg ("cmcs_queue_ctl.control", queue_ctl_ptr);

	if a_code ^= 0
	then go to free_vt;

	call cmcs_fillin_hdr_ (queue_ctl_ptr, queue_ctl_version, queue_ctl_hdr_len, queue_ctl_entry_len, a_code);

	if a_code ^= 0
	then do;

		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fillin hdr for queue_ctl.");

		go to free_vt;

	     end;

	user_ctl.queue_ctl_ptr = queue_ctl_ptr;

	call make_seg ("cmcs_wait_ctl.control", wait_ctl_ptr);

	if a_code ^= 0
	then go to free_vt;

	call cmcs_fillin_hdr_ (wait_ctl_ptr, wait_ctl_version, wait_ctl_hdr_len, wait_ctl_entry_len, a_code);

	if a_code ^= 0
	then do;

		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Fillin hdr for wait_ctl.");

		go to free_vt;

	     end;

	user_ctl.wait_ctl_ptr = wait_ctl_ptr;

/*
   The following a_code will create the CMCS message queues and set the queue control
   record (0/1) header data. Any existing message file will be truncated.
*/

/* init info structure for vfile_ record_status order call */

	vfile_rs_ptr = addr (vfile_rs1);
	zero_overlay_len = size (vfile_rs1);
	vfile_rs_ptr -> zero_overlay (*) = 0;
	vfile_rs.version = 1;
	vfile_rs.create_sw = "1"b;			/* easier than writing a dummy record */
	vfile_rs.rec_len, vfile_rs.max_rec_len = 128;	/* (32 * 4) */

/* Init key structure with constants */

	key_struc.msg_no = 0;			/* the header rcd is always 0/1 */
	key_struc.seg_no = 1;
	key_struc.key_len = 8;
	key = based_key;				/* strictly for iox_ */

	constant_hdr_len = control_hdr_len;		/* to reinit hdr len for seek_key */

	do i = 1 to vt_count;

	     pic_value = i;
	     sw_name = "cmcs_queue_" || pic_value;	/* unique for this run only */
	     q_name = vfile_table (i).queue_name;

	     if i ^= 1
	     then do j = 1 to i - 1;			/* don't duplicate previous queue names */
		     if q_name = vfile_table (j).queue_name
		     then go to loop_end;
		end;

	     vfile_table.switch_name = sw_name;

	     call ioa_$rsnnl ("vfile_ ^a>^a.cmcs_queue", attach_descr, j, var_cmcs_dir, q_name);
	     call iox_$attach_name (sw_name, iocbp, substr (attach_descr, 1, j), null (), a_code);

	     if a_code ^= 0
	     then do;

		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to attach ""^a"".",
			q_name);

		     go to loop_end;

		end;

	     vfile_table (i).iocb_ptr = iocbp;

	     call iox_$open (iocbp, 12, "0"b, a_code);	/* for direct_output to force truncate */

	     if a_code ^= 0
	     then do;

		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to open ""^a"".",
			q_name);

		     go to loop_end;

		end;

	     hdr_len_21 = constant_hdr_len + 4;		/* restore proper value + 4 chars for lockword */

	     call iox_$seek_key (iocbp, key, hdr_len_21, a_code);

	     if a_code ^= 0
	     then if a_code ^= error_table_$no_record
		then do;

			call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			     "Attempting to seek_key ""^a"".", q_name);

			go to loop_end;

		     end;

	     call iox_$control (iocbp, "record_status", vfile_rs_ptr, a_code);

	     if a_code ^= 0
	     then if a_code ^= error_table_$no_record	/* NOT SURE ABOUT ALL POSSIBLE CODES */
		then do;

			call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			     "Attempting to perform a record_status control order ""^a"".", q_name);

			go to close;

		     end;

	     control_hdr_ptr = vfile_rs.rec_ptr;	/* for based variable */

	     call cmcs_fillin_hdr_ (control_hdr_ptr, 1, 0, 0, a_code);

	     if a_code ^= 0
	     then do;

		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			"Attempting to set the msg hdr data ""^a"".", q_name);

		end;

close:
	     call iox_$close (iocbp, a_code);

	     if a_code ^= 0
	     then do;

		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to close ""^a"".",
			q_name);

		end;

	     call iox_$detach_iocb (iocbp, a_code);

	     if a_code ^= 0
	     then do;

		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to detach ""^a"".",
			q_name);

		end;

	     vfile_table (i).error_flag = "0"b;		/* we made it through this one */

/* Set up info in queue_ctl_entry */

	     queue_ctl.current_size, queue_ctl.entry_count = queue_ctl.current_size + 1;
						/* index to new entry and current size */
	     queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl.current_size));
	     j = vfile_table (i).tree_ctl_eindex;
	     tree_ctl_eptr = addr (tree_ctl.entries (j));

	     if queue_ctl.current_size ^= tree_ctl_entry.queue_ctl_eindex
	     then do;

		     a_code = error_table_$action_not_performed;

		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			"Mismatch found between queue_ctl_eindex in the tree_ctl_entry and the current location (^d vs ^d).",
			tree_ctl_entry.queue_ctl_eindex, queue_ctl.current_size);

		     return;

		end;

	     queue_ctl_entry.queue_name = "";		/* rsnnl doesn't blank fill */

	     call ioa_$rsnnl ("^a.cmcs_queue", queue_ctl_entry.queue_name, k, tree_ctl_entry.queue_name);

	     string (queue_ctl_entry.tree_path) = string (tree_ctl_entry.tree_path);
	     queue_ctl_entry.tree_ctl_eindex = j;
	     queue_ctl_entry.cmd_sw = tree_ctl_entry.cmd_sw;
	     queue_ctl_entry.mp_sw = tree_ctl_entry.mp_sw;


loop_end:
	end;					/* closes initial do loop */


free_vt:
	if vfile_table_ptr ^= null ()
	then do;

		free vfile_table;
		vfile_table_ptr = null ();

	     end;

	return;

make_seg:
     proc (a_name, a_ptr);

dcl	a_name		char (*),
	a_ptr		ptr;

	call hcs_$make_seg (user_ctl.cmcs_dir, a_name, a_name, 1010b, a_ptr, a_code);

	if a_code ^= 0
	then if a_code = error_table_$namedup | a_code = error_table_$segknown
						/* already exists */
	     then call hcs_$truncate_seg (a_ptr, 0, a_code);
						/* reset to zero */

	if a_ptr = null ()
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to create the segment ""^a"".",
		a_name);				/* DEBUG */

	return;

     end /* make_seg */;


setup:
     proc;

	user_ctl_ptr = external_user_ctl_ptr;
	tree_ctl_ptr = user_ctl.tree_ctl_ptr;

	user_ctl.init_sw.create_queues = "1"b;



	return;

     end /* setup */;

     end /* cmcs_create_queues_ */;




		    cmcs_date_time_.pl1             05/24/89  1047.9rew 05/24/89  0836.7       32031



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_date_time_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_date_time_:
     proc (a_clock_value, a_date, a_time);

dcl	a_clock_value	fixed bin (71),
	a_date		char (6) unaligned,
	a_time		char (8) unaligned;

/*
   This COBOL MCS procedure accepts a clock_ value as input and
   returns strings of form YYMMDD and HHMMSSTT, where
   YY is year
   MM is month
   DD is day
   and,
   HH is hour
   MM is minute
   SS is second
   TT is hundredths of a second

   It is directly adapted from the pl1_date_ and pl1_time_ subroutines, the difference being
   that the clock_ value is externally supplied and is used in both the date and time computations.

   Bob May, 6/30/77
   */

dcl	clock_value	fixed bin (71);		/* copy because we modify it */

dcl	sys_info$time_delta fixed bin ext,
	(date, day, month, year, i)
			fixed bin;

dcl	clk		float bin (63),
	(seconds, microseconds)
			fixed bin,
	digit		(0:9) char (1) aligned static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

dcl	(divide, min, mod, substr)
			builtin;

/* */

dcl	table		(6) fixed bin (6) static init (10, 10, 6, 10, 6, 10);

	clock_value = a_clock_value + 5000;		/* round up to hundredths of a second, we'll truncate later */

	date = (clock_value - sys_info$time_delta) / 8.64e10 + 694266;
						/* days from 3-1-0000 */

	day = mod (date, 146097);			/* days into 400 year cycle */

	year = 400 * divide (date, 146097, 35, 0);	/* year set to beginning of cycle */

	date = 3 + 4 * (day + min (3, divide (date, 36534, 17, 0)));
						/* prepare year estimator */

	day = mod (date, 1461);			/* day = 4 * day_of_year (0 ... 365) */

	year = year + divide (date, 1461, 17, 0);	/* add in year of cycle */

	date = 2 + 5 * divide (day, 4, 17, 0);		/* prepare month estimator */

	day = mod (date, 153);			/* day = 5 * day_of_month (0 ... 30) */

	month = 1 + mod (2 + divide (date, 153, 17, 0), 12);
						/* get month */

	if month < 3
	then year = year + 1;			/* correct for jan, feb */

	day = 1 + divide (day, 5, 17, 0);		/* get day */

	date = year * 10000 + month * 100 + day;

	do i = 6 by -1 to 1;
	     substr (a_date, i, 1) = digit (mod (date, 10));
	     date = divide (date, 10, 35, 0);
	end;

	clk = mod (clock_value - sys_info$time_delta, 8.64e10);

	seconds = clk / 1.e6;
	microseconds = clk - seconds * 1.e6;
	seconds = mod (seconds, 86400);


	microseconds = microseconds / 10000.0;		/* convert microseconds to hundredths of a second */

	do i = 8 by -1 to 7;
	     substr (a_time, i, 1) = digit (mod (microseconds, 10));
	     microseconds = divide (microseconds, 10, 35, 0);
	end;

	do while (i > 0);
	     substr (a_time, i, 1) = digit (mod (seconds, table (i)));
	     seconds = divide (seconds, table (i), 35, 0);
	     i = i - 1;
	end;

	return;

     end /* cmcs_date_time_ */;




		    cmcs_decode_status_.pl1         05/24/89  1047.9rew 05/24/89  0833.9       70578



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_decode_status_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_decode_status_:
     proc (a_iocbp, a_cdp, a_io_type, a_io_subtype, a_code);

/* This COBOL MCS subroutine decodes the status key in the input or output CD
   and prints this information on the specified output switch. If the call
   specifies a non-null output CD pointer, the station_names
   (in the output CD) are also printed with their corresponding error_keys.

   Bob May, 6/30/77 */

dcl	a_iocbp		ptr,
	a_cdp		ptr,			/* don't know yet if input, output, or null */
	a_io_type		fixed bin,
	a_io_subtype	fixed bin,
	a_code		fixed bin (35);		/* if ever nonzero, there's a bug */

dcl	io_types		(7) char (8) int static options (constant)
			init ("Send", "Receive", "Enable", "Disable", "Accept", "Purge", "Print");
						/* STOP RUN can't have status key */

dcl	io_subtypes	(0:28) char (24) int static options (constant) init ("Partial",
						/* Send - 0 */
			"Segment",		/* Send - 1 */
			"Message",		/* Send - 2 */
			"Group",			/* Send - 3 */
			"filler",			/* send is 0-3, others are 1-4 */
			"Segment, No Wait",		/* Receive - 1 */
			"Message, No Wait",		/* Receive - 2 */
			"Segment, Wait",		/* Receive - 3 */
			"Message, Wait",		/* Receive - 4 */
			"Input (Queue)",		/* Enable - 1 */
			"Input Terminal",		/* Enable - 2 */
			"Output (Destination)",	/* Enable - 3 */
			"N/A",			/* Enable - 4 */
			"Input (Queue)",		/* Disable - 1 */
			"Input Terminal",		/* Disable - 2 */
			"Output (Destination)",	/* Disable - 3 */
			"N/A",			/* Disable - 4 */
			"Message Count",		/* Accept - 1 */
			"N/A",			/* Accept - 2 */
			"N/A",			/* Accept - 3 */
			"N/A",			/* Accept - 4 */
			"Sends Only (CODASYL)",	/* Purge - 1 */
			"Receives Only (Multics)",	/* Purge - 2 */
			"All (Multics)",		/* Purge - 3 */
			"N/A",			/* Purge - 4 */
			"Segment, No Wait",		/* Print - 1 */
			"Message, No Wait",		/* Print - 2 */
			"N/A",			/* Print - 3 */
			"N/A");			/* Print - 4 */

dcl	status_keys	(10) char (2) int static options (constant)
			init ("na", "00", "10", "15", "20", "30", "40", "50", "60", "70");

dcl	io_type		fixed bin,
	io_subtype	fixed bin,
	count		fixed bin,
	status_key	char (2),
	error_key		char (1),
	i		fixed bin,
	input_cd_sw	bit (1);

dcl	ioa_$ioa_switch	entry options (variable);

/*  */
%include cmcs_cd_dcls;
%include cmcs_error_table_dcls;

/*  */
	a_code = 0;				/* highly unlikely it will ever be otherwise */
	input_cdp, output_cdp = a_cdp;		/* easier to do both now */

	go to set_io_type (a_io_type);

/* send, purge (CODASYL), enable/disable output */
set_io_type (1):
set_purge_io_subtype (1):				/* Standard CODASYL */
set_purge_io_subtype (3):				/* COBOL Extension */
set_en_dis_io_subtype (3):
	input_cd_sw = "0"b;				/* function uses output CD */
	if output_cdp = null ()
	then status_key = "na";
	else status_key = output_cd.status_key;
	go to print_status_key;

/* receive (and print), accept, enable/disable input/input terminal, purge (partial rcvs) */
set_io_type (2):
set_io_type (5):
set_io_type (7):
set_en_dis_io_subtype (1):
set_en_dis_io_subtype (2):
set_purge_io_subtype (2):
	input_cd_sw = "1"b;				/* uses input CD */
	if input_cdp = null ()
	then status_key = "na";			/* special COBOL extension */
	else status_key = input_cd.status_key;
	go to print_status_key;

/* enable, disable */
set_io_type (3):
set_io_type (4):
	go to set_en_dis_io_subtype (a_io_subtype);

/* purge */
set_io_type (6):
	go to set_purge_io_subtype (a_io_subtype);

/* */

print_status_key:
	call ioa_$ioa_switch (a_iocbp, "IO Type: ""^8a"", IO Subtype: ""^24a"", Status Key: ""^2a""",
	     io_types (a_io_type), io_subtypes ((4 * (a_io_type - 1) + a_io_subtype)), status_key);

	do i = 1 to 12;
	     if status_key = status_keys (i)
	     then go to print_status_msg (i);
	end;

	a_code = cmcs_error_table_$bad_call_parm;
	go to ds_ret;

/* na */
print_status_msg (1):
	call ioa_$ioa_switch (a_iocbp, "Null CD pointer used for this operation.");
	go to print_error_keys;

/* 00 */
print_status_msg (2):
	call ioa_$ioa_switch (a_iocbp, "No error detected. Action completed.");
	go to print_error_keys;

/* 10 */
print_status_msg (3):
	call ioa_$ioa_switch (a_iocbp, "One or more destinations are disabled. Action completed.");
	go to print_error_keys;

/* 15 */
print_status_msg (4):
	call ioa_$ioa_switch (a_iocbp, "One or more queues or destinations already enabled.");
	go to print_error_keys;

/* 20 */
print_status_msg (5):
	if a_io_subtype > 3
	then io_type = 7 - a_io_type;			/* 4, 5, 6 = 3, 2, 1, respectively */
	else io_type = a_io_type;			/* lumps send/purge, receive/accept, enable/disable */

	if io_type = 1
	then do;					/* send, purge, enable/disable output */
print_status_msg_20 (1):
		call ioa_$ioa_switch (a_iocbp,
		     "One or more destinations unknown. Action completed for known destinations. No action taken for unknown destinations. Data-name-4 (ERROR KEY) indicates known or unknown."
		     );
		go to print_error_keys;
	     end;

	else if io_type = 2
	then do;

/* receive, accept, enable/disable input */
print_status_msg_20 (2):
		call ioa_$ioa_switch (a_iocbp, "One or more queues or subqueues unknown. No action taken.");
		go to print_error_keys;
	     end;

	else do;					/* io_type = 3 */
		if a_io_subtype = 3
		then io_subtype = 1;
		else io_subtype = a_io_subtype + 1;
		go to print_status_msg_20 (io_subtype);
	     end;

/* enable/disable input terminal */
print_status_msg_20 (3):
	call ioa_$ioa_switch (a_iocbp, "The source is unknown. No action taken.");
	go to print_error_keys;

/* 30 */
print_status_msg (6):
	call ioa_$ioa_switch (a_iocbp, "Content of DESTINATION COUNT invalid. No action taken.");
	go to print_error_keys;

/* 40 */
print_status_msg (7):
	call ioa_$ioa_switch (a_iocbp, "Passord invalid. No enabling/disabling action taken.");
	go to print_error_keys;

/* 50 */
print_status_msg (8):
	call ioa_$ioa_switch (a_iocbp, "Character count greater than length of sending field. No action taken.");
	go to print_error_keys;

/* 60 */
print_status_msg (9):
	call ioa_$ioa_switch (a_iocbp,
	     "Partial segment with either zero character count or no sending area specified. No action taken.");
	go to print_error_keys;

/* 70 */
print_status_msg (10):
	call ioa_$ioa_switch (a_iocbp,
	     "One or more detinations do not have partial messages associated with them. Action completed for other destinations."
	     );
	go to print_error_keys;

print_error_keys:
	if ^input_cd_sw
	then if output_cdp ^= null ()
	     then do;				/* print out individual ERROR KEYs from output CD */
		     count = output_cd.station_count;
		     if count <= output_cd.bin_max_station_count
		     then do;			/* valid CD info */
			     call ioa_$ioa_switch (a_iocbp, "Station      Error Code");
			     do i = 1 to count;
				call ioa_$ioa_switch (a_iocbp, "^12a ^1a", output_cd.dest_table (i).station_name,
				     output_cd.dest_table (i).error_key);
			     end;
			     call ioa_$ioa_switch (a_iocbp, "");
						/* leave a little whitespace */
			end;
		end;

ds_ret:
	return;

     end /* cmcs_decode_status_ */;




		    cmcs_error_table_.alm           11/11/82  1551.2rew 11/11/82  1016.1       51354



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


"  Modified since Version 4.3

	name	cmcs_error_table_
	use	codes
.code_start:	null
	use	past_codes
.code_end:	null
	use	codes
	segdef	ambiguous_tree_path
ambiguous_tree_path:	vfd	18/.sys_sw,18/.ambiguous_tree_path
	use	messages
	aci	,ambig_tp,
.ambiguous_tree_path:	acc	;Insufficient qualification. Subordinate receives already in process.;
	use	codes
	segdef	bad_call_parm
bad_call_parm:	vfd	18/.sys_sw,18/.bad_call_parm
	use	messages
	aci	,bad_call,
.bad_call_parm:	acc	;An invalid parameter was passed to the COBOL MCS runtime support facility.;
	use	codes
	segdef	bad_dest
bad_dest:	vfd	18/.sys_sw,18/.bad_dest
	use	messages
	aci	,bad_dest,
.bad_dest:	acc	;A specified message destination is undefined.;
	use	codes
	segdef	bad_dest_count
bad_dest_count:	vfd	18/.sys_sw,18/.bad_dest_count
	use	messages
	aci	,bad_dc  ,
.bad_dest_count:	acc	;Specified message destination count is outside defined range.;
	use	codes
	segdef	bad_message_length
bad_message_length:	vfd	18/.sys_sw,18/.bad_message_length
	use	messages
	aci	,bad_msgl,
.bad_message_length:	acc	;Specified length of message to be sent is invalid.;
	use	codes
	segdef	bad_password
bad_password:	vfd	18/.sys_sw,18/.bad_password
	use	messages
	aci	,bad_psw ,
.bad_password:	acc	;Attempt to perform an enable or disable function using an incorrect password.;
	use	codes
	segdef	bad_queue_path
bad_queue_path:	vfd	18/.sys_sw,18/.bad_queue_path
	use	messages
	aci	,bad_qp  ,
.bad_queue_path:	acc	;The specified symbolic message queue is not in the current queue hierarchy.;
	use	codes
	segdef	bad_slew
bad_slew:	vfd	18/.sys_sw,18/.bad_slew
	use	messages
	aci	,bad_slew,
.bad_slew:	acc	;The CMCS slew control is incorrect.;
	use	codes
	segdef	bad_source
bad_source:	vfd	18/.sys_sw,18/.bad_source
	use	messages
	aci	,bad_src ,
.bad_source:	acc	;The specified symbolic message source is undefined.;
	use	codes
	segdef	bad_station
bad_station:	vfd	18/.sys_sw,18/.bad_station
	use	messages
	aci	,bad_sta ,
.bad_station:	acc	;The specified station is not defined for CMCS use.;
	use	codes
	segdef	bad_term_devchn
bad_term_devchn:	vfd	18/.sys_sw,18/.bad_term_devchn
	use	messages
	aci	,bad_term,
.bad_term_devchn:	acc	;The specified terminal device_channel is not defined for CMCS use.;
	use	codes
	segdef	bad_tree_path
bad_tree_path:	vfd	18/.sys_sw,18/.bad_tree_path
	use	messages
	aci	,bad_tree,
.bad_tree_path:	acc	;The specified symbolic message queue is not in the current queue hierarchy.;
	use	codes
	segdef	dest_already_disabled
dest_already_disabled:	vfd	18/.sys_sw,18/.dest_already_disabled
	use	messages
	aci	,dest_ad ,
.dest_already_disabled:	acc	;A specified message destination is already disabled.;
	use	codes
	segdef	dest_already_enabled
dest_already_enabled:	vfd	18/.sys_sw,18/.dest_already_enabled
	use	messages
	aci	,dest_ae ,
.dest_already_enabled:	acc	;A specified message destination is already enabled.;
	use	codes
	segdef	dest_disabled
dest_disabled:	vfd	18/.sys_sw,18/.dest_disabled
	use	messages
	aci	,dest_d  ,
.dest_disabled:	acc	;A specified message destination is currently disabled.;
	use	codes
	segdef	no_message
no_message:	vfd	18/.sys_sw,18/.no_message
	use	messages
	aci	,no_msg  ,
.no_message:	acc	;No message exists in the specified queue hierarchy.;
	use	codes
	segdef	no_partial_messages
no_partial_messages:	vfd	18/.sys_sw,18/.no_partial_messages
	use	messages
	aci	,no_pmsg ,
.no_partial_messages:	acc	;A message queue contains no partial messages which can be purged.;
	use	codes
	segdef	null_partial_message
null_partial_message:	vfd	18/.sys_sw,18/.null_partial_message
	use	messages
	aci	,nul_pmsg,
.null_partial_message:	acc	;Attempt to send a null partial message.;
	use	codes
	segdef	queue_already_disabled
queue_already_disabled:	vfd	18/.sys_sw,18/.queue_already_disabled
	use	messages
	aci	,q_ad    ,
.queue_already_disabled:	acc	;A specified message queue is already disabled.;
	use	codes
	segdef	queue_already_enabled
queue_already_enabled:	vfd	18/.sys_sw,18/.queue_already_enabled
	use	messages
	aci	,q_ae    ,
.queue_already_enabled:	acc	;A specified message queue is already enabled.;
	use	codes
	segdef	queue_disabled
queue_disabled:	vfd	18/.sys_sw,18/.queue_disabled
	use	messages
	aci	,q_d     ,
.queue_disabled:	acc	;A specified message queue is currently disabled.;
	use	codes
	segdef	source_already_disabled
source_already_disabled:	vfd	18/.sys_sw,18/.source_already_disabled
	use	messages
	aci	,src_ad  ,
.source_already_disabled:	acc	;A specified message source is already disabled.;
	use	codes
	segdef	source_already_enabled
source_already_enabled:	vfd	18/.sys_sw,18/.source_already_enabled
	use	messages
	aci	,src_ae  ,
.source_already_enabled:	acc	;A specified message source is already enabled.;
	use	codes
	segdef	source_disabled
source_disabled:	vfd	18/.sys_sw,18/.source_disabled
	use	messages
	aci	,src_d   ,
.source_disabled:	acc	;A specified message source is currently disabled.;
	bool	.sys_sw,0
"
	use	messages
	tempd	.tp
.trapproc: save
	eppbp	0,ic
	spribp	.tp
	lda	.tp
	ana	=o77777,du
	epbpsb	sp|0
	lda	sb|22,*au
	easplp	0,au
	eawplp	0,al
	ldx0	.tp
	eax1	.code_start         
.loop:	stx0	lp|0,x1
	eax1	1,x1
	cmpx1	.code_end,du
	tmi	.loop-*,ic
	return

	firstref	<*text>|.trapproc
	join	/text/messages
	join	/link/codes,past_codes
	end




		    cmcs_expand_tree_path.pl1       05/24/89  1047.9rew 05/24/89  0836.6       25938



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_expand_tree_path.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_expand_tree_path:
cmetp:
     proc ();

/* This COBOL MCS command and active function provides the command interface to expand
   a short-form CMCS tree_path (no blanks, period delimiters) into the proper 48-char
   tree_path string. Its primary use will be as an active function for interactive
   and absentee initiation of COBOL MCS application programs that have an
   "INITIAL MESSAGE" clause, where the program must be told what CMCS queue (and subqueues)
   to use in its initial RECEIVE request.

   Bob May, 6/30/77 */

dcl	af_sw		bit (1);

dcl	my_name		char (21) init ("cmcs_expand_tree_path");

dcl	tree_path		char (48);

%include cmcs_arg_processing;

dcl	code		fixed bin (35);

dcl	ioa_		entry options (variable);

dcl	cmcs_expand_tree_path_
			entry (char (*), char (48), fixed bin (35));

/*  */

	call cu_$af_return_arg (arg_count, af_return_arg_ptr, af_return_arg_len, code);
	if code ^= 0
	then if code = error_table_$not_act_fnc
	     then do;
		     call cu_$arg_count (arg_count);
		     af_sw = "0"b;
		end;
	     else do;				/* probably active function, but something else is wrong */
		     call active_fnc_err_ (code, my_name, "Attempting to get active function paramters.");
		     return;
		end;
	else af_sw = "1"b;				/* everything is go for AF */

	if arg_count ^= 1
	then do;
print_usage:
		code = 0;
print_error:
		if af_sw
		then call active_fnc_err_ (code, my_name,
			"^/Usage: cmcs_expand_tree_path level_name1{.l_n2{.l_n3{.l_n4}}}");
		else call com_err_ (code, my_name, "^/Usage: cmcs_expand_tree_path level_name1{.l_n2{.l_n3{.l_n4}}}");
		return;
	     end;

	if af_sw
	then call cu_$af_arg_ptr (1, arg_ptr, arg_len, code);
	else call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0
	then go to print_error;

	call cmcs_expand_tree_path_ (arg, tree_path, code);
	if code ^= 0
	then go to print_error;

	if af_sw
	then af_return_arg = """" || tree_path || """";	/* enclose it quotes for command line */
	else call ioa_ ("""^48a""", tree_path);
	return;

     end /* cmcs_expand_tree_path */;




		    cmcs_expand_tree_path_.pl1      05/24/89  1047.9rew 05/24/89  0837.3       36621



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_expand_tree_path_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_expand_tree_path_:
     proc (a_input, a_tree_path, a_code);

/* This COBOL MCS subroutine is used by the CMCS command interfaces to expand
   the short-form tree path (no blanks, period delimiters) into the proper
   48-character internal representation. The level_names can be from 1-12 chars
   in length and must be period separated. Blanks may appear only on
   the trailing end of the input string. Errors will be returned
   if there are more than three periods, intervening blanks, adjacent periods,
   and level_names outside the length of 1-12 characters.

   Bob May, 6/30/77 */

dcl	a_input		char (*),
	a_tree_path	char (48),
	a_code		fixed bin (35);

dcl	cmcs_error_table_$bad_tree_path
			fixed bin (35) external;

dcl	buffer		char (51),
	buffer_left_begin	fixed bin,
	buffer_left_len	fixed bin;

dcl	end_sw		bit (1),
	(i, j)		fixed bin;

dcl	tree_path_ptr	ptr;

dcl	1 tree_path	based (tree_path_ptr),
	  2 level_names	(4) char (12);

dcl	level_no		fixed bin;

dcl	(index, length, search, substr, verify)
			builtin;

/*  */

/* Preliminary Checks */

	if length (a_input) = 0 | length (a_input) > 51
	then go to bad_tree_path;
	if substr (a_input, 1, 1) = "." | substr (a_input, 1, 1) = " "
	then go to bad_tree_path;			/* period and blank */

/* Initialization */

	tree_path_ptr = addr (a_tree_path);
	buffer = a_input;				/* copy to fixed space for efficiency */
	buffer_left_begin = 1;
	buffer_left_len = 51;
	level_no = 0;
	end_sw = "0"b;

/* Main Procedure */

loop:
	level_no = level_no + 1;
	if level_no = 5
	then go to bad_tree_path;			/* data follows level_name-4 */

	i = index (substr (buffer, buffer_left_begin, buffer_left_len), ".");
						/* look for another component preceded with "." */
	if i = 0
	then do;					/* at least no more periods */
		end_sw = "1"b;			/* should be last time through */
		i = index (substr (buffer, buffer_left_begin, buffer_left_len), " ");
						/* trailing blanks? */
		if i = 0
		then do;				/* no, use all that remains */
			i = buffer_left_len;
		     end;
		else do;				/* found trailing blank */
			if buffer_left_begin + i < 53
			then if verify (substr (buffer, buffer_left_begin + i), " ") ^= 0
						/* look for data after blank */
			     then go to bad_tree_path;

			i = i - 1;		/* adjust field length to elim blank */
		     end;
	     end;
	else i = i - 1;				/* found a period, set i to length of level_name */

/* validate level name */

	if i = 0
	then go to bad_tree_path;
	if i > 12
	then go to bad_tree_path;			/* must be 1-12 chars long */

	level_names (level_no) = substr (buffer, buffer_left_begin, i);
	if level_names (level_no) = " "
	then go to bad_tree_path;			/* tried to slip it in between good delims */
	if ^end_sw
	then do;
		buffer_left_begin = buffer_left_begin + i + 1;
		buffer_left_len = buffer_left_len - i - 1;
						/* include the trailing "." as well */
		go to loop;
	     end;

/* Finish Up */

	if level_no ^= 4
	then do i = level_no + 1 to 4;		/* blank out all trailing level names */
		level_names (i) = "";
	     end;

	a_code = 0;
	return;

bad_tree_path:
	a_code = cmcs_error_table_$bad_tree_path;
	a_tree_path = "";				/* make sure they can't use anything */
	return;

     end /* cmcs_expand_tree_path_ */;




		    cmcs_fillin_hdr_.pl1            05/24/89  1047.9rew 05/24/89  0836.6       17829



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_fillin_hdr_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_fillin_hdr_:
     proc (a_hdr_ptr, a_hdr_version, a_hdr_len, a_entry_len, a_code);

/* This COBOL MCS subroutine is used to fill in the standard infoirmation in all CMCS control headers */

/* Bob May, 5/31/77 */

dcl	a_hdr_ptr		ptr,
	a_hdr_version	fixed bin,
	a_hdr_len		fixed bin,
	a_entry_len	fixed bin,
	a_code		fixed bin (35);

%include cmcs_control_hdr;

dcl	sys_info$max_seg_size
			fixed bin (18) external;

dcl	divide		builtin;

dcl	clock_		entry () returns (fixed bin (71)),
	get_group_id_$tag_star
			entry () returns (char (32)),
	get_process_id_	entry () returns (bit (36));

/* */

	control_hdr_ptr = a_hdr_ptr;

	control_hdr.version = a_hdr_version;
	control_hdr.clock_created = clock_ ();
	control_hdr.group_id = get_group_id_$tag_star ();
	control_hdr.process_id = get_process_id_ ();

	if a_entry_len ^= 0				/* don't hiccup for structures with no entries */
	then control_hdr.max_size =
		divide ((sys_info$max_seg_size - (control_hdr_len + a_hdr_len)), a_entry_len, 18, 0);
	else control_hdr.max_size = 0;

	control_hdr.current_size, control_hdr.entry_count = 0;

	a_code = 0;
	return;

     end /* cmcs_fillin_hdr_ */;




		    cmcs_initiate_ctl_.pl1          05/24/89  1047.9rew 05/24/89  0836.6       37746



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_initiate_ctl_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/16/82 by FCH, [5.2-1], eliminate need for copy switch by using temp seg, BUG530 */
/* Modified since Version 5.0 */




/* format: style3 */
cmcs_initiate_ctl_:
     proc (a_name, a_ptr, a_code);

dcl	a_name		char (*),
	a_ptr		ptr,			/* used for xxx_ctl_ptr */
	a_code		fixed bin (35);

dcl	my_name		char (18) init ("cmcs_initiate_ctl_");

dcl	initiate_dir	char (168);		/* either WD or from user_ctl */

dcl	x_ptr		ptr;			/* global initiate ptr */

dcl	ioa_		entry options (variable);


dcl	get_wdir_		entry () returns (char (168));
dcl	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));

/*[5.2-1]*/
dcl	get_temp_segment_	entry (char (*), ptr, fixed bin (35));
						/*[5.2-1]*/
dcl	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35));
						/*[5.2-1]*/
dcl	hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
						/*[5.2-1]*/
dcl	code		fixed bin (35),
	TYPE		fixed bin (2),
	BIT_COUNT		fixed bin (24);

/*[5.2-1]*/
dcl	ptr_array		(1) ptr static int;		/*[5.2-1]*/
dcl	SEG		bit (9 * sys_info$max_seg_size) based;

dcl	error_table_$action_not_performed
			fixed bin (35) external;
dcl	sys_info$max_seg_size
			fixed bin (18) static ext;
dcl	null		builtin;			/*  */
%include cmcs_cobol_mcs_dcls;
%include cmcs_user_ctl;

/*  */

	a_ptr = null ();

	call cobol_mcs_$get_user_ctl_exists_sw (user_ctl_exists_sw);

	if ^user_ctl_exists_sw
	then do;

		initiate_dir = get_wdir_ ();
		call initiate (a_name);

		a_ptr = x_ptr;
		return;

	     end;

	user_ctl_ptr = external_user_ctl_ptr;
	initiate_dir = user_ctl.cmcs_dir;

	call initiate ("cmcs_queue_ctl.control");
	user_ctl.queue_ctl_ptr = x_ptr;		/* whether null or not */

	call initiate ("cmcs_station_ctl.control");
	user_ctl.station_ctl_ptr = x_ptr;		/* whether null or not */

	call initiate ("cmcs_system_ctl.control");
	user_ctl.system_ctl_ptr = x_ptr;		/* whether null or not */

	call initiate ("cmcs_terminal_ctl.control");
	user_ctl.terminal_ctl_ptr = x_ptr;		/* whether null or not */

	call initiate ("cmcs_tree_ctl.control");

/*[5.2-1]*/
	call get_temp_segment_ ("cmcs_initiate_ctl_", ptr_array (1), code);

/*[5.2-1]*/
	if code ^= 0				/*[5.2-1]*/
	then do;
		a_code = code;			/*[5.2-1]*/
		return;				/*[5.2-1]*/
	     end;

/*[5.2-1]*/
	call hcs_$status_minf (initiate_dir, "cmcs_tree_ctl.control", 1, TYPE, BIT_COUNT, code);

/*[5.2-1]*/
	if code ^= 0				/*[5.2-1]*/
	then do;
		a_code = code;			/*[5.2-1]*/
		return;				/*[5.2-1]*/
	     end;

/*[5.2-1]*/
	user_ctl.tree_ctl_ptr = ptr_array (1);		/*[5.2-1]*/
	substr (user_ctl.tree_ctl_ptr -> SEG, 1, BIT_COUNT) = substr (x_ptr -> SEG, 1);

	call initiate ("cmcs_wait_ctl.control");
	user_ctl.wait_ctl_ptr = x_ptr;		/* whether null or not */

	a_code = 0;

	return;

release:
     entry (a_code);

/*[5.2-1]*/
	call release_temp_segments_ ("cmcs_initiate_ctl_", ptr_array, code);

/*[5.2-1]*/
	if code ^= 0
	then a_code = code;				/*[5.2-1]*/
	return;

/* */

initiate:
     proc (x_name);

dcl	x_name		char (*);

	call hcs_$initiate (initiate_dir, x_name, "", 0, 0, x_ptr, a_code);
	if x_ptr = null ()
	then do;

		call ioa_ ("""^a"" not not available. If needed, correct and retry.", x_name);
		return;

	     end;

	a_code = 0;				/* ptr is good, make code good too */
	return;

     end /* initiate */;

/* */

     end /* cmcs_initiate_ctl_ */;




		    cmcs_print_.pl1                 05/24/89  1047.9rew 05/24/89  0836.6       46026



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_print_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/02/81 by FCH, [5.0-1], emit NL after message if no slew, BUG510 */
/* Modified on 07/16/81 by FCH, [4.4-1], make BEF/AFT PAGE same as BEF/AFT 1 LINE unless printer, BUG468 */
/* Modified since Version 4.3 */

/* format: style3 */
cmcs_print_:
     proc (a_iocb_ptr, a_buffer_ptr, a_buffer_len, a_slew_ctl_ptr, a_code);

/* This COBOL MCS subroutine is used to reformat messages and message segments
   for final output to a terminal device. It uses the slew control originally given
   in the SEND verb to determine the nature of slewing required. Slew control can
   specify a slew of zero lines. Thus,  all output of data is terminated with a
   Carriage Return,  rather than a Newline. It is up to the COBOL program to keep
   track of the need to slew.

   Bob May,  6/30/77 */

dcl	a_iocb_ptr	ptr,
	a_buffer_ptr	ptr,
	a_buffer_len	fixed bin (35),
	a_slew_ctl_ptr	ptr,
	a_code		fixed bin (35);

dcl	buffer		char (a_buffer_len) based (a_buffer_ptr);
						/* for DEBUG */

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

dcl	test_sw		bit (1) int static init ("0"b);

dcl	1 esc_sequence,
	  2 ESC		char (1),
	  2 vfu_chn	pic "99",
	  2 ETX		char (1);

dcl	(NL, FF, CR)	char (1);

dcl	NL_string		char (128);

/*  */
%include cmcs_slew_ctl;
%include cmcs_iox_processing;
%include cmcs_error_table_dcls;
%include cmcs_user_ctl;

/*  */

/* Initialization */

	slew_ctl_ptr = a_slew_ctl_ptr;		/* to get at structure components */

	unspec (esc_sequence.ESC) = "033"b3;
	unspec (esc_sequence.ETX) = "003"b3;
	unspec (CR) = "015"b3;
	unspec (NL) = "012"b3;
	unspec (FF) = "014"b3;			/*[4.4-1]*/
	user_ctl_ptr = external_user_ctl_ptr;
	NL_string = copy (NL, 128);

/* */

	if slew_ctl.when = 0
	then do;

		call iox_$put_chars (a_iocb_ptr, addr (NL), 1, a_code);

		if a_code ^= 0
		then return;

		call put_data;			/* as-is,  with trailing CR */

/*[5.0-1]*/
		if ^user_ctl.attach_bit | (user_ctl.attach_bit & user_ctl.iocb_ptr = null ())
						/*[5.0-1]*/
		then call iox_$put_chars (a_iocb_ptr, addr (NL), 1, a_code);

	     end;
	else if slew_ctl.when = 1
	then do;					/* send before slew */

		call put_data;
		call put_slew;

	     end;
	else if slew_ctl.when = 2
	then do;					/* send data after slew */

		call put_slew;
		call put_data;

	     end;
	else do;

		a_code = cmcs_error_table_$bad_call_parm;

	     end;

	return;

/*  */
put_data:
     proc ();

	if a_buffer_len ^= 0
	then do;					/* sometimes they just want the slew */

		call iox_$put_chars (a_iocb_ptr, a_buffer_ptr, fixed (a_buffer_len, 21), a_code);

		if a_code ^= 0
		then return;

	     end;

	call iox_$put_chars (a_iocb_ptr, addr (CR), 1, a_code);

	return;

     end /* put_data */;

/* */

put_slew:
     proc ();

	if slew_ctl.what = 0
	then do;					/* same as slew zero lines... we put out the CR in front */

		a_code = 0;
		return;

	     end;
	else if slew_ctl.what = 1
	then do;					/* slew n lines */

/*[4.4-1]*/
		call lines;

		return;

	     end;					/* what = 1 */
	else if slew_ctl.what = 2
	then do;					/* wants slew to PAGE */

/*[4.4-1]*/
		if user_ctl.attach_bit		/*[4.4-1]*/
		then if user_ctl.iocb_ptr ^= null ()	/*[4.4-1]*/
		     then do;
			     call iox_$put_chars (a_iocb_ptr, addr (FF), 1, a_code);
						/*[4.4-1]*/
			     return;		/*[4.4-1]*/
			end;

/*[4.4-1]*/
		slew_ctl.how_much = 1;		/*[4.4-1]*/
		call lines;

		return;

	     end;					/* what = 2 */
	else if slew_ctl.what = 3
	then do;					/* wants slew to channel */

		if slew_ctl.how_much < 1 | slew_ctl.how_much > 16
		then do;				/* VFU channels can only be 1-16 */

			a_code = cmcs_error_table_$bad_call_parm;
			return;

		     end;

		esc_sequence.vfu_chn = slew_ctl.how_much;
						/* convert to ascii chars */

		call iox_$put_chars (a_iocb_ptr, addr (esc_sequence), 4, a_code);

		return;

	     end;
	else do;

		a_code = cmcs_error_table_$bad_call_parm;
		return;

	     end;

     end /* put_slew */;

/*[4.4-1]*/
lines:
     proc;

	if slew_ctl.how_much = 0
	then do;					/* same as what = 0 */

		a_code = 0;
		return;

	     end;
	else if slew_ctl.how_much > 128
	then do;					/* can't handle this */

		a_code = cmcs_error_table_$bad_call_parm;
		return;

	     end;

	call iox_$put_chars (a_iocb_ptr, addr (NL_string), fixed (slew_ctl.how_much, 21), a_code);

     end;						/*[4.4-1]*/

     end /* cmcs_print_ */;




		    cmcs_purge_queues_.pl1          05/24/89  1047.9rew 05/24/89  0833.9       64791



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_purge_queues_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */
/* Modified since Version 4.3 */

/* format: style3 */
cmcs_purge_queues_:
     proc (a_queue_ctl_eindex, a_long_sw, a_code);

dcl	a_queue_ctl_eindex	fixed bin,
	a_long_sw		bit (1),
	a_code		fixed bin (35);

dcl	i		fixed bin;		/* dummy to avoid looping for count ^= 0 */

dcl	my_name		char (18) int static options (constant) init ("cmcs_purge_queues_");

dcl	sub_err_		entry options (variable);
dcl	sub_err_retval	fixed bin (35);

dcl	iocb_ptr		ptr;

dcl	(
	ioa_,
	ioa_$rsnnl
	)		entry options (variable);

dcl	1 msg_descr	int static like vfile_descr;

dcl	msg_descr_ptr	ptr int static;

dcl	fb21		fixed bin (21);



dcl	(msg_no, seg_no)	fixed bin (35);

dcl	1 static_vfile_rs	int static like vfile_rs;

dcl	attach_descr	char (256),
	attach_descr_len	fixed bin;

dcl	switch_name	char (7) int static options (constant) init ("cmcs_pq");

dcl	overlay_len	fixed bin,
	overlay		(overlay_len) fixed bin (35) based;

dcl	(error_table_$no_record)
			fixed bin (35) external;

dcl	(addr, fixed, null, size, substr)
			builtin;

/*  */

%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_iox_processing;
%include cmcs_key_dcls;
%include cmcs_msg_hdr;
%include cmcs_msg_seg;
%include cmcs_queue_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;

/*  */

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.purge_queues)
	then call setup;

	if a_queue_ctl_eindex = 0
	then do queue_ctl_eindex = 1 to queue_ctl.current_size;

		call purge_queue;

	     end;

	else do;

		queue_ctl_eindex = a_queue_ctl_eindex;

		if queue_ctl_eindex < 1 | queue_ctl_eindex > queue_ctl.current_size
		then do;

			a_code = cmcs_error_table_$bad_call_parm;
			return;

		     end;

		call purge_queue;			/* dropped thru, specific index ok */

	     end;

	a_code = 0;
	return;

/* */

purge_queue:
     proc ();

/* Requires that queue_ctl_eindex be set to desired queue prior to call */

	queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

	if a_long_sw
	then call ioa_ ("Queue ^a^/^-Partial sends = ^d^/^-Available = ^d^/^-Partial receives ^d^/^-Completed = ^d",
		queue_ctl_entry.queue_name, queue_ctl_entry.status_list_ctl_entries (1).count,
		queue_ctl_entry.status_list_ctl_entries (2).count, queue_ctl_entry.status_list_ctl_entries (3).count,
		queue_ctl_entry.status_list_ctl_entries (4).count);

	call ioa_$rsnnl ("vfile_ ^a>^a -old", attach_descr, attach_descr_len, user_ctl.cmcs_dir,
	     queue_ctl_entry.queue_name);

	call iox_$attach_name (switch_name, iocb_ptr, substr (attach_descr, 1, attach_descr_len), null (), a_code);

	if a_code ^= 0
	then do;

		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to attach queue ^a.",
		     queue_ctl_entry.queue_name);

		go to pq_ret;

	     end;

	call iox_$open (iocb_ptr, 13, "0"b, a_code);

	if a_code ^= 0
	then do;

		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to open ^a.",
		     queue_ctl_entry.queue_name);

		go to detach;

	     end;

	do status_list_ctl_eindex = 1, 3, 4;

	     status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (status_list_ctl_eindex));

	     do i = 1 to status_list_ctl_entry.count;

		msg_descr = status_list_ctl_entry.f_descr;
						/* get first in list */

		if status_list_ctl_eindex = 3
		then do;
			call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, msg_descr_ptr, 3, 2, a_code);

			if a_code ^= 0
			then do;

				call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				     "Attempting to move status 3 message back to status 2.");

				go to end_count_loop;

			     end;
		     end;
		else do;				/* 1 or 4, delete it */

			static_vfile_rs.descr = status_list_ctl_entry.f_descr;

			call iox_$control (iocb_ptr, "record_status", vfile_rs_ptr, a_code);

			if a_code ^= 0
			then do;

				call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				     "Attempting to seek descriptor to get the msg header.");

				msg_hdr_ptr = null ();
				msg_seg_ptr = null ();

				go to end_count_loop;

			     end;

			msg_hdr_ptr = static_vfile_rs.rec_ptr;
			msg_seg_ptr = addr (msg_hdr.msg_seg);

			msg_no = msg_hdr.msg_no;	/* for subsequent seek keys */

			call cmcs_status_list_ctl_$delete (queue_ctl_eptr, iocb_ptr, msg_descr_ptr,
			     status_list_ctl_eindex, a_code);

			if a_code ^= 0
			then do;

				call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				     "Attempting to delete message from status list ^d.", status_list_ctl_eindex);

				go to end_count_loop;

			     end;

			key_struc.msg_no = msg_no;
			key_struc.seg_no = 0;

seg_delete_loop:
			key_struc.seg_no = key_struc.seg_no + 1;
			key = based_key;		/* to make vfile_ happy  */

			call iox_$seek_key (iocb_ptr, key, fb21, a_code);

			if a_code ^= 0
			then if a_code = error_table_$no_record
			     then go to end_count_loop;
			     else do;

				     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
					"Attempting to seek ^d/^d for deletion.", key_struc.msg_no,
					key_struc.seg_no);

				     go to end_count_loop;

				end;

			call iox_$delete_record (iocb_ptr, a_code);

			if a_code ^= 0
			then do;

				call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				     "Attempting to delete ^d/^d.", key_struc.msg_no, key_struc.seg_no);
				go to seg_delete_loop;

			     end;

		     end /* status 1 or 4 */;

end_count_loop:
	     end /* count > 0 */;
	end /* status 1, 3, or 4 */;

close:
	call iox_$close (iocb_ptr, a_code);

	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to close ^a.",
		queue_ctl_entry.queue_name);

detach:
	call iox_$detach_iocb (iocb_ptr, a_code);

	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to detach ^a.",
		queue_ctl_entry.queue_name);

pq_ret:
	return;

     end /* purge_queue */;

/* */

setup:
     proc ();

	user_ctl_ptr = external_user_ctl_ptr;
	queue_ctl_ptr = user_ctl.queue_ctl_ptr;

	msg_descr_ptr = addr (msg_descr);
	vfile_rs_ptr = addr (static_vfile_rs);
	overlay_len = size (static_vfile_rs);
	vfile_rs_ptr -> overlay (*) = 0;
	static_vfile_rs.locate_sw = "1"b;
	static_vfile_rs.version = vfile_rs_version;

	user_ctl.init_sw.purge_queues = "1"b;
	return;

     end /* setup */;

     end /* cmcs_purge_queues_ */;




		    cmcs_queue_ctl_.pl1             05/24/89  1047.9rew 05/24/89  0834.0      486792



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8087 cmcs_queue_ctl_.pl1 Shorten wait time for cmcs_station_ctl_.
                                                   END HISTORY COMMENTS */


/* Modified on 10/10/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */
/* Modified on 05/06/81 by FCH, [4.4-6], activate and deactivate commands, BUG468 */
/* Modified on 05/05/81 by FCH, [4.4-5], emi and egi are equiv, BUG468 */
/* Modified on 04/29/81 by FCH, [4.4-3], test station_ctl_entry.output_disabled_sw in send, BUG468 */
/* Modified on 04/25/81 by FCH, [4.4-2], once per process initialization, BUG468 */
/* Modified on 04/27/81, [4.4-1], check for now_much^=0 caused abort, BUG468 */
/* Modified since Version 4.3 */







/* format: style3 */
cmcs_queue_ctl_:
     proc;

	return;					/* bad entrypoint */

/* This COBOL MCS subroutine manages the queue related CMCS functions of
   ACCEPT, SEND, RECEIVE, PURGE, and ENABLE/DISABLE INPUT (QUEUE).
   Common code is shared by receive/print, and purge/stop_run.

   Bob May, 6/30/77 */

/* Note: The disable/enable entrypoints all accept a char (10) password string. This string is ignored
   because it was already checked by cobol_mcs_. Current ANSI rules on the use of multiple passwords for CMCS
   terminals and queues is unclear and requests for clarification have been submitted. Until the clarification
   is issued, this implementation will use a single password. Thus, cobol_mcs_ can do the checking for everybody. */

dcl	a_input_cdp	ptr,
	a_output_cdp	ptr,
	a_cdp		ptr,			/* when we don't know yet whether input or output (purge) */
	a_code		fixed bin (35),
	a_iocb_ptr	ptr,			/* print entrypoint only */
	a_buffer_ptr	ptr,
	a_buffer_len	fixed bin,
	a_station_count	fixed bin,		/* send entrypoint only */
	a_slew_ctl	fixed bin (35),		/* send entrypoint only */
	a_password	char (10),
	a_io_subtype	fixed bin;

dcl	cdp		ptr;			/* intermediate value for purge and stop_run */

dcl	buffer_len	fixed bin (21),
	buffer_left_index	fixed bin (35),
	buffer_left_len	fixed bin (35),
	buffer_ptr	ptr,
	buffer		char (buffer_len) based (buffer_ptr);
						/* for copying data */

dcl	(msg_no, seg_no)	fixed bin (35);

dcl	sysprint		file env (interactive);	/* for DEBUG */

dcl	program_interrupt	condition;

dcl	test_sw		bit (1) int static init ("0"b);

dcl	iocb_ptr		ptr;			/* for all the queue I/O, one at atime */

dcl	1 min_blksz_info	int static,		/* to ensure space for vfile lockword in each record */
	  2 min_residue	fixed bin (21),
	  2 min_capacity	fixed bin (21);

dcl	my_name		char (15) init ("cmcs_queue_ctl_");
						/* for DEBUG */

dcl	(addr, char, fixed, index, min, null, rtrim, size, string, substr)
			builtin;

dcl	(
	ioa_,
	ioa_$rsnnl,
	sub_err_
	)		entry options (variable);

dcl	sub_err_retval	fixed bin (35);		/* dummy for sub_err_ */

dcl	get_process_id_	entry () returns (bit (36)),
	get_group_id_	entry () returns (char (32)),
	hcs_$truncate_seg	entry (ptr, fixed bin (18), fixed bin (35)),
	clock_		entry () returns (fixed bin (71));

dcl	get_temp_segments_	entry (char (*), (*) ptr aligned, fixed bin (35)),
	release_temp_segments_
			entry (char (*), (*) ptr aligned, fixed bin (35));

dcl	set_lock_$lock	entry (bit (36) aligned, fixed bin, fixed bin (35)),
	set_lock_$unlock	entry (bit (36) aligned, fixed bin (35));

dcl	(i, code)		fixed bin (35);

dcl	(
	error_table_$action_not_performed,
	error_table_$bad_new_key,
	error_table_$no_record,
	error_table_$not_open
	)		fixed bin (35) external;

dcl	(old_status, new_status)
			fixed bin,		/* for status_list_ctl_ */
	(io_subtype, io_type)
			fixed bin,
	station_name	char (12),
	station_count	fixed bin;

dcl	overlay_len	fixed bin,		/* to erase structure data */
	overlay		(overlay_len) fixed bin (35) based;

dcl	dest_table_index	fixed bin,
	flag		bit (1);

dcl	1 msg_descr	like vfile_descr;

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

dcl	zero_descr_ptr	ptr int static;

dcl	1 zero_descr	like vfile_descr based (zero_descr_ptr);

/*  */

/* declarations for SEND */

dcl	send_init_sw	bit (1) int static init ("0"b);

dcl	ptr_array		(1) ptr static internal;	/* to pick up temp segs, one at a time */
dcl	tseg_ptr		ptr,			/* temporary buffer for partial messages, per queue */
	tseg_len		fixed bin (21),
	tseg		char (tseg_len) based (tseg_ptr);
dcl	tseg_max_len	fixed bin (21) init (64 * 1024 * 4);
						/* arbitrary */
dcl	switch_no		fixed bin int static init (0);/* to generate switch names for same queue */
dcl	attach_descr	char (256);		/* for iox_$attach */
dcl	attach_descr_len	fixed bin;		/* returned by ioa_$rsnnl */
dcl	switch_pic	pic "99";			/* to generate switch name from queue_name, number */

dcl	1 send_vfile_rs	like vfile_rs int static;	/* to allocate records for send */

dcl	send_vfile_rs_ptr	ptr int static;

dcl	1 send_descr	like vfile_descr int static;
dcl	seek_len		fixed bin (21);		/* for record_status allocate */
dcl	fb21		fixed bin (21);		/* dummy output variable for seek_key */

/* */

/* Declarations for RECEIVE */

dcl	init_queue_table_sw bit (1) int static init ("0"b);

dcl	queue_table_ptr	ptr int static;

dcl	1 queue_table_struc based (queue_table_ptr),
	  2 queue_table_len fixed bin,
	  2 queue_table	(tree_ctl.current_size refer (queue_table_struc.queue_table_len)) fixed bin;
						/* table of queue indices for subtree */
dcl	copy_len		fixed bin (35);

dcl	1 rcv_vfile_rs	like vfile_rs int static;

dcl	1 rcv_descr	like vfile_descr int static;

dcl	rcv_vfile_rs_ptr	ptr int static;

dcl	rcv_descr_ptr	ptr int static;

dcl	subtree_count	fixed bin;

dcl	rcv_init_sw	bit (1) int static init ("0"b);

/* Declarations for ACCEPT_MESSAGE_COUNT */

dcl	msg_count		fixed bin (35);		/* careful, inside input_cd, it's a char item */

/*  */
%include cmcs_cd_dcls;
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_iox_processing;
%include cmcs_key_dcls;
%include cmcs_msg_hdr;
%include cmcs_msg_seg;
%include cmcs_queue_ctl;
%include cmcs_slew_ctl;
%include cmcs_station_ctl;
%include cmcs_system_ctl;
%include cmcs_tree_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;
%include cmcs_wait_ctl;
/*  */
set:
     proc;

/*[4.4-2]*/
	if ^external_user_ctl_ptr -> user_ctl.init_sw.queue_ctl
	then call setup;

     end;

accept_message_count:
     entry (a_input_cdp, a_io_subtype, a_code);

/*[4.4-2]*/
	call set;

	input_cdp = a_input_cdp;
	io_type = 5;
	io_subtype = a_io_subtype;

	call build_queue_table ();

	if a_code ^= 0
	then return;				/* build_queue_table sets status_key */

	msg_count = 0;				/* accumulative */

	do i = 1 to queue_table_len;			/* sum individual counts for this specific request */

	     queue_ctl_eindex = queue_table (i);
	     queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

/* accumulated count is not a "locked" count, since it can change before the user does a receive anyway */

	     msg_count = msg_count + queue_ctl_entry.status_list_ctl_entries (2).count;
						/* count only available msgs */

	end;

	input_cd.msg_count = msg_count;		/* fixed bin -> char, required by COBOL */
	input_cd.status_key = "00";

	return;

/* end of accept_message_count entrypoint */

/*  */

disable:
     entry (a_input_cdp, a_io_subtype, a_password, a_code); /* strictly for queues, not stations */

/*[4.4-2]*/
	call set;

	input_cdp = a_input_cdp;
	io_type = 4;
	io_subtype = a_io_subtype;

	call build_queue_table;

	if a_code ^= 0
	then return;

	code = 0;

	do i = 1 to queue_table_len;

	     queue_ctl_eindex = queue_table (i);
	     queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

	     if ^queue_ctl_entry.input_disabled_sw
	     then queue_ctl_entry.input_disabled_sw = "1"b;
	     else code = cmcs_error_table_$queue_already_disabled;

	end;

	a_code = code;				/* whatever the results, status_key here is "00" */
	input_cd.status_key = "00";

	return;

/* end of disable entrypoint */

/*  */

enable:
     entry (a_input_cdp, a_io_subtype, a_password, a_code); /* strictly for queues, not stations */

/*[4.4-2]*/
	call set;

	input_cdp = a_input_cdp;
	io_type = 3;
	io_subtype = a_io_subtype;

	call build_queue_table;

	if a_code ^= 0
	then return;

	code = 0;

	do i = 1 to queue_table_len;

	     queue_ctl_eindex = queue_table (i);
	     queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

	     if queue_ctl_entry.input_disabled_sw
	     then queue_ctl_entry.input_disabled_sw = "0"b;

	     else code = cmcs_error_table_$queue_already_enabled;

	end;

	a_code = code;				/* whatever the results, status_key here is "00" */
	input_cd.status_key = "00";

	return;

/* end of enable entrypoint */

/*  */

stop_run:
     entry (a_io_subtype, a_code);			/* for now, a_io_subtype must always be 1 */

	io_type = 8;				/* for use in purge_common */
	cdp = null ();

	go to purge_common;

/* */

purge:
     entry (a_cdp, a_io_subtype, a_code);

	io_type = 6;				/* to identify purge request */
	cdp = a_cdp;

/* From now on, purge and stop_run share common code. */

purge_common:
	dest_table_index = 0;
	a_code = 0;

/*[4.4-2]*/
	call set;

	io_subtype = a_io_subtype;

/* if the cdp is null, we delete all sends and/or receives */

	if cdp = null ()
	then do;

		do tree_ctl_eindex = 1 to tree_ctl.hdr.current_size;

		     tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));
		     if tree_ctl_entry.subtree_count = 0
		     then if tree_ctl_entry.io_in_process_sw
			then do;			/* active entry */

				call get_tce_parms;

				if tree_ctl_entry.io_type = 1
				then if ^(io_type = 6 & io_subtype = 2)
						/* specifically shouldn't do sends */
				     then do;

					     call purge_send_entry;
					end;
				     else ;
				else if tree_ctl_entry.io_type = 2 | tree_ctl_entry.io_type = 7
				then if ^(io_type = 6 & io_subtype = 1)
						/* specifically shouldn't do receives */
				     then do;

					     call purge_rcv_entry;

					end;

			     end;

		     if tree_ctl_entry.iocb_ptr ^= null ()
		     then call close;

		end;

		a_code = 0;

		return;
	     end;					/* of code for null cdp */

/* Drop-thru means the cdp wasn't null. Thus, we must be in purge, not stop_run. */


	a_code = 0;				/* set zero now, to let first error set non-zero */

	if io_subtype = 1
	then do;					/* purge sends only */

		output_cdp = cdp;
		output_cd.status_key = "00";		/* initialize good, set only on first error */

		station_count = output_cd.station_count;/* thank heavens for pictures */

		do dest_table_index = 1 to station_count;

		     station_name = output_cd.dest_table (dest_table_index).station_name;

		     call cmcs_tree_ctl_$find_destination (station_name, tree_ctl_eindex, tree_ctl_eptr, code);

		     if code ^= 0
		     then do;
			     if a_code = 0
			     then do;

				     a_code = code;
				     output_cd.status_key = "20";

				end;

			     output_cd.dest_table (dest_table_index).error_key = "1";

			     go to send_loop_end;
			end;

		     call get_tce_parms;
		     call purge_send_entry;

		     if code ^= 0
		     then do;

			     if a_code = 0
			     then do;
				     a_code = code;
				     output_cd.status_key = "20";
				end;

			     output_cd.dest_table (dest_table_index).error_key = "1";

			     go to send_loop_end;

			end;
		end;
	     end;					/* of purges of sends, using supplied cdp */

	else if a_io_subtype = 2			/* just purge the receives */
	then do;

		input_cdp = cdp;
		input_cd.status_key = "00";		/* set good now, change if needed */

		call cmcs_tree_ctl_$find_tree_path (input_cdp, tree_ctl_eindex, subtree_count, tree_ctl_eptr, code);

		if code ^= 0
		then do;

purge_set_input_err:
			input_cd.status_key = "20";
			a_code = code;
			return;
		     end;

		if subtree_count = 0
		then do;

			call get_tce_parms;
			call purge_rcv_entry;

			if code ^= 0
			then go to purge_set_input_err;

		     end;
		else do i = tree_ctl_eindex to tree_ctl_eindex + subtree_count - 1;

			tree_ctl_eptr = addr (tree_ctl.entries (i));

			if tree_ctl_entry.subtree_count = 0
			then do;

				call get_tce_parms;
				call purge_rcv_entry;

				if code ^= 0
				then if a_code = 0
				     then do;

					     a_code = code;
					     input_cd.status_key = "20";

					end;
			     end;
		     end;				/* purge rcv subtree loop */

	     end;

	return;

/*  */

get_tce_parms:
     proc ();

	queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;
	queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));
	iocb_ptr = tree_ctl_entry.iocb_ptr;
	msg_descr = tree_ctl_entry.msg_descr;
	msg_no = tree_ctl_entry.msg_no;

	return;

     end /* get_tce_parms */;

/* */

purge_rcv_entry:
     proc ();

	if ^tree_ctl_entry.io_in_process_sw
	then do;

		code = cmcs_error_table_$no_partial_messages;

		return;

	     end;

/* Move the message from in-process back to available */

	call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, addr (msg_descr), 3, 2, code);

	if code ^= 0
	then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
		"Attempting to move message (^d in ^a) from status-3 back to status-2. Continuing.", msg_no,
		tree_ctl_entry.queue_name);

	call reset_tce_io;

	return;

     end /* purge_rcv_entry */;

/* */

purge_send_entry:
     proc ();

/* This procedure assumes that tree_ctl_eptr and dest_table_index are correctly set by the caller */

	if ^tree_ctl_entry.io_in_process_sw
	then do;

		code = cmcs_error_table_$no_partial_messages;

		return;

	     end;

	if tree_ctl_entry.partial_in_process_sw
	then do;

		tree_ctl_entry.tseg_len = 0;

		call hcs_$truncate_seg (tree_ctl_entry.tseg_ptr, 0, code);

		if code ^= 0
		then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			"Attempting to truncate the temporary data segment for ^a. Continuing.",
			tree_ctl_entry.queue_name);
		tree_ctl_entry.partial_in_process_sw = "0"b;

	     end;					/* of partial seg processing */

	if tree_ctl_entry.seg_count > 0
	then do;					/* physical records exist and must be deleted */

		call cmcs_status_list_ctl_$delete (queue_ctl_eptr, iocb_ptr, addr (msg_descr), 1, code);

		if code ^= 0
		then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			"Attempting to delete message (^d in ^a) from status-1. Continuing.", msg_no,
			tree_ctl_entry.queue_name);

		key_struc.msg_no = msg_no;
		do seg_no = 1 to tree_ctl_entry.seg_count;

		     key_struc.seg_no = seg_no;
		     key = based_key;		/* to keep vfile_ happy */

		     call iox_$seek_key (iocb_ptr, key, fb21, code);

		     if code ^= 0
		     then do;

			     call sub_err_ (code, my_name, "c", null (), sub_err_retval,
				"Attempting to seek message segment (^d/^d in ^a) for deletion. Continuing.",
				msg_no, seg_no, tree_ctl_entry.queue_name);

			     go to end_delete_msg_seg_loop;

			end;

		     call iox_$delete_record (iocb_ptr, code);

		     if code ^= 0
		     then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			     "Attempting to delete message segment (^d/^d in ^a). Continuing.", msg_no, seg_no,
			     tree_ctl_entry.queue_name);

end_delete_msg_seg_loop:
		end;
	     end;					/* seg_count > 0 */

	if io_type = 6 & dest_table_index ^= 0
	then do;

		call cmcs_station_ctl_$validate (station_name, station_ctl_eindex, code);
						/* just to get the entry index */
		call cmcs_station_ctl_$output_disabled (station_ctl_eindex, flag, code);

		if flag
		then do;
			code = cmcs_error_table_$dest_disabled;

			if a_code = 0
			then do;

				a_code = code;
				output_cd.status_key = "10";
			     end;

			output_cd.dest_table (dest_table_index).error_key = "1";

		     end;
	     end;

	call reset_tce_io;

	return;

     end /* purge_send_entry */;

/*  */

print:
     entry (a_input_cdp, a_io_subtype, a_iocb_ptr, a_code);

	io_type = 7;				/* to distinguish from receive in common code */

	go to rcv_common;

/* */

receive:
     entry (a_input_cdp, a_io_subtype, a_buffer_ptr, a_buffer_len, a_code);

	io_type = 2;				/* to indicate receive in common code */

rcv_common:					/* from here on, receive and print are nearly the same */
						/*[4.4-2]*/
	call set;

	if ^rcv_init_sw
	then do;					/* do only 1st time entered */

		rcv_descr_ptr = addr (rcv_descr);
		rcv_vfile_rs_ptr = addr (rcv_vfile_rs);
		overlay_len = size (rcv_vfile_rs);
		rcv_vfile_rs_ptr -> overlay (*) = 0;
		rcv_vfile_rs.version = vfile_rs_version;
		rcv_vfile_rs.lock_sw,		/* locate switch set dynamically */
		     rcv_vfile_rs.unlock_sw = "0"b;

/* We don't need to lock individual records because no two processes will ever be operating
   on the same message number at the same time. They are locked out at queue_ctl level. */

		rcv_init_sw = "1"b;

	     end;

/* set basic controls */

	input_cdp = a_input_cdp;
	io_subtype = a_io_subtype;

/* First check for ambiguous tree_path. ANSI says that results from the specification of an ambiguous tree path
   are vendor defined. This implementation defines this situation to be an error. */

	call build_queue_table;			/* sets tree_ctl_e(index ptr) */

	if a_code ^= 0
	then return;				/* status key already set */

	if subtree_count ^= 0
	then do;

		call rcv_check_io_in_process;

		if a_code ^= 0
		then return;			/* nonzero is ambiguous_tree_path */

	     end;
	else if tree_ctl_entry.io_in_process_sw
	then do;

		if io_type ^= tree_ctl_entry.io_type	/* don't let them do a receive, for example */
		then do;

			a_code = error_table_$action_not_performed;

/*[4.4-6]*/
			if ^user_ctl.rec
			then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				"Attempting to do a receive on tree path ""^a""
when another I/O operation (^d) is already in process.
Returning a status key of ""20"".", string (tree_ctl_entry.tree_path), tree_ctl_entry.io_type);

			input_cd.status_key = "20";

			return;

		     end;

		iocb_ptr = tree_ctl_entry.iocb_ptr;
		queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;
		queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

		call rcv_set_type;			/* reset  the old and set the new */

		if io_type = 7
		then go to rcv_get_next_seg;		/* only for print */

		call rcv_set_buffer;

		go to rcv_copy_seg_data;		/* only for receive */

	     end;

/* drop-through means no io_in_process, check first if terminal output disabled */

rcv_find_msg:
	if user_ctl.terminal_sw
	then do;

		call cmcs_station_ctl_$output_disabled (user_ctl.station_ctl_eindex, flag, a_code);

		if a_code ^= 0
		then return;

		if flag
		then do;
			a_code = cmcs_error_table_$dest_disabled;
			return;
		     end;

	     end;

	call qc_lock;				/* so we can safely acquire a message */

	if code ^= 0
	then do;					/* should never happen */

rcv_lock_err:					/*[4.4-6]*/
		if ^user_ctl.rec
		then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			"Problem locking queue_ctl to receive message. Return to COBOL program with status key of ""20""."
			);
		a_code = code;

		input_cd.status_key = "20";
		return;

	     end;

	if subtree_count = 0
	then do;					/* user gave abs_tree_path */

		queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;
		queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

		if queue_ctl_entry.status_list_ctl_entries (2).count = 0
		then do;

rcv_no_msg:
			if io_type = 2 & (io_subtype = 3 | io_subtype = 4)
			then go to rcv_wait_msg;

			a_code = cmcs_error_table_$no_message;
			input_cd.status_key = "00";	/* no-message is not an error */

			call qc_unlock;

			return;

		     end;

		go to rcv_found_msg;

	     end;

/* no abs path, must look in entire subtree */

	else do;					/* queue ctl still locked from above */

		do i = 1 to queue_table_len;

		     queue_ctl_eindex = queue_table (i);
		     queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

		     if queue_ctl_entry.status_list_ctl_entries (2).count ^= 0
		     then go to rcv_found_msg;

		end;

/* fell through, no messages in the subtree */

		go to rcv_no_msg;

	     end;

rcv_wait_msg:					/* come here to sit and wait */
	call qc_unlock;				/* don't keep locked or we'll have problems */

	on program_interrupt
	     begin;				/* interactive user got tired of waiting */

		call cmcs_wait_ctl_$delete (user_ctl.wait_ctl_eindex, a_code);

		a_code = cmcs_error_table_$no_message;
		input_cd.status_key = "20";		/* we can't say anything more meaningful */

/*[4.4-6]*/
		if ^user_ctl.rec
		then call sub_err_ (a_code, my_name, "h", null (), sub_err_retval,
			"Program Interrupt occurred while waiting for message.
	Type ""start"" to return to COBOL program with status key of ""20"".");

		go to rcv_error_return;

	     end;

	call cmcs_wait_ctl_$add (string (input_cd.tree_path), user_ctl.wait_ctl_eindex, a_code);

/* When we reach here, we either went to sleep and have been awakened with a message, or
		   wait ctl rejected our request to add our entry to its list. */

	revert program_interrupt;

	if a_code ^= 0
	then do;					/* should never happen */

rcv_error_return:
		input_cd.status_key = "20";
		return;

	     end;


/* We had a good sleep and were awakened with a message. Get the info about the message from the wait ctl entry
   and attempt to get it before someone else does. If we fail, just loop back on the wait again. */


	wait_ctl_eindex = user_ctl.wait_ctl_eindex;
	wait_ctl_eptr = addr (wait_ctl.entries (wait_ctl_eindex));

	queue_ctl_eindex = wait_ctl_entry.queue_ctl_eindex;
	queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

	tree_ctl_eindex = wait_ctl_entry.tree_ctl_eindex;
	tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));

	call qc_lock;

	if code ^= 0
	then go to rcv_lock_err;			/* should never happen */

	if queue_ctl_entry.status_list_ctl_entries (2).count = 0
	then do;					/* we missed it */

/*[4.4-6]*/
		if ^user_ctl.rec
		then call sub_err_ (0, my_name, "c", null (), sub_err_retval,
			"Missed locking record from receive wait. Will wait for another.");

		go to rcv_wait_msg;			/* unlock queue ctl there */

	     end;

/* Getting here means that we actually detected an available msg in queue ctl.
			   Now we must access it to be sure we really did get it. */

	call cmcs_wait_ctl_$delete (wait_ctl_eindex, code);

	if code ^= 0
	then do;

/*[4.4-6]*/
		if ^user_ctl.rec
		then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			"Unexpected error code from deleting entry in wait_ctl. Continuing.");

	     end;

	go to rcv_set_msg_busy;			/* all indices and ptrs already set */

rcv_found_msg:					/* Getting here means that we found a message without having to wait for it. queue_ctl_eindex and queue_ctl_eptr
   must have been set already. */
	tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex;
	tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));

rcv_set_msg_busy:					/* the lock, all ptrs, etc, must already be set */
	call reset_tce_io;				/* start clean */
	call open;				/* make sure the file is usable */

	if code ^= 0
	then do;

rcv_queue_err:					/* should never happen */
						/*[4.4-6]*/
		if ^user_ctl.rec
		then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			"Attempting to process queue ""^a"" for receive. Returning to COBOL program with status key of ""20"".",
			tree_ctl_entry.queue_name);

		a_code = code;
		input_cd.status_key = "20";

		call qc_unlock;			/* ignore error code */

		return;

	     end;

	rcv_descr, tree_ctl_entry.msg_descr = queue_ctl_entry.status_list_ctl_entries (2).f_descr;

	call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, rcv_descr_ptr, 2, 3, code);

/* move msg from available to busy */

	if code ^= 0
	then go to rcv_queue_err;			/* should never happen */

/* The msg is now truly ours. Indicate that I/O is truly in_process and set appropriate control info */

	call qc_unlock;				/* ignore status */

/* Initialize Message Control Info */

	call rcv_set_type;

	call rcv_seek_descr;			/* make msg known to process */

	if code ^= 0
	then go to rcv_queue_err;			/* should never happen */

	msg_hdr_ptr, tree_ctl_entry.msg_hdr_ptr = rcv_vfile_rs.rec_ptr;

	tree_ctl_entry.seg_count = msg_hdr.seg_count;	/* don't reference the hdr again until we're thru with it */
	tree_ctl_entry.msg_len = msg_hdr.msg_len;


/* Set Input CD Info */

	input_cd.station_name = msg_hdr.source_station;

	call cmcs_date_time_ (msg_hdr.clock_available, input_cd.msg_date, input_cd.msg_time);

	string (input_cd.tree_path) = string (tree_ctl_entry.tree_path);

	msg_no, tree_ctl_entry.msg_no, key_struc.msg_no = msg_hdr.msg_no;
	seg_no, tree_ctl_entry.seg_no, key_struc.seg_no = msg_hdr.seg_no;
	msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = addr (msg_hdr.msg_seg);

/* Check for and Initialize Buffer Control */

	if io_type = 2
	then do;					/* it's a rcv request */
		call rcv_set_buffer;
	     end;

/* Initialize Segment Control */

rcv_set_seg_ctl:
	tree_ctl_entry.msg_seg_len, tree_ctl_entry.msg_seg_left_len = msg_seg.hdr.seg_len;
	tree_ctl_entry.msg_seg_left_index = 1;

	if io_type = 7
	then do;					/* must be a print request (7) */

		call cmcs_print_ (a_iocb_ptr, addr (msg_seg.data.seg_data), msg_seg.hdr.seg_len,
		     addr (msg_seg.hdr.slew_ctl), code);

		go to rcv_check_for_more_segs;	/* ignore return status */

	     end;

/* Processing a receive request instead */

rcv_copy_seg_data:
	if tree_ctl_entry.msg_seg_left_len = 0
	then go to rcv_check_for_more_segs;

	if tree_ctl_entry.buffer_left_len = 0
	then do;					/* couldn't use up segment/message */

		input_cd.text_len = tree_ctl_entry.buffer_len;
		input_cd.text_delim = 0;		/* more to come */
		input_cd.status_key = "00";
		a_code = 0;

		return;
	     end;

	copy_len = min (tree_ctl_entry.msg_seg_left_len, tree_ctl_entry.buffer_left_len);

	substr (buffer, tree_ctl_entry.buffer_left_index, copy_len) =
	     substr (msg_seg.data.seg_data, tree_ctl_entry.msg_seg_left_index, copy_len);

	tree_ctl_entry.msg_seg_left_index = tree_ctl_entry.msg_seg_left_index + copy_len;
	tree_ctl_entry.msg_seg_left_len = tree_ctl_entry.msg_seg_left_len - copy_len;
	tree_ctl_entry.buffer_left_index = tree_ctl_entry.buffer_left_index + copy_len;
	tree_ctl_entry.buffer_left_len = tree_ctl_entry.buffer_left_len - copy_len;

	go to rcv_copy_seg_data;			/* one of the two tests must fail */

rcv_check_for_more_segs:
	if tree_ctl_entry.seg_count = tree_ctl_entry.seg_no
	then do;					/* no more segs, message is exhausted */

		msg_hdr_ptr = tree_ctl_entry.msg_hdr_ptr;
		msg_hdr.clock_deleted = clock_ ();	/* for future statistics */
		input_cd.text_delim = msg_hdr.final_delim;
		input_cd.text_len = tree_ctl_entry.buffer_left_index - 1;
		tree_ctl_entry.io_in_process_sw = "0"b;
		rcv_descr = tree_ctl_entry.msg_descr;


		call qc_lock;

		if code ^= 0
		then go to rcv_queue_err;

		call cmcs_status_list_ctl_$move (queue_ctl_eptr, tree_ctl_entry.iocb_ptr, rcv_descr_ptr, 3, 4, code);
						/* move from busy to used */

		if code ^= 0
		then do;				/* should never happen */

/*[4.4-6]*/
			if ^user_ctl.rec
			then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
				"Attempting to put msg in ""used"" status list. Continuing.");
		     end;

		call qc_unlock;			/* ignore status */

		input_cd.status_key = "00";
		a_code = 0;

		return;

	     end;

/* more segs available if we want them */

	if tree_ctl_entry.rcv_seg_sw
	then do;					/* just wants one seg at a time */

		input_cd.text_delim = 1;		/* mark as seg delim */
		input_cd.text_len = tree_ctl_entry.buffer_left_index - 1;
		input_cd.status_key = "00";
		a_code = 0;

		return;

	     end;

/* User does want full message instead of just a segment */

rcv_get_next_seg:					/* we already know there is one */
	seg_no, key_struc.seg_no, tree_ctl_entry.seg_no = tree_ctl_entry.seg_no + 1;

	msg_no, key_struc.msg_no = tree_ctl_entry.msg_no;

	call rcv_seek_key;

	if code ^= 0
	then do;

/*[4.4-6]*/
		if ^user_ctl.rec
		then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			"Attempting to seek another segment of current message.
	Returning to COBOL program with status key of ""20"".");

		a_code = code;
		input_cd.status_key = "20";

		return;

	     end;

	msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = rcv_vfile_rs.rec_ptr;

	go to rcv_set_seg_ctl;


/*  */

rcv_seek_key:
     proc ();

	key = based_key;

	call iox_$seek_key (tree_ctl_entry.iocb_ptr, key, fb21, code);

	if code ^= 0
	then return;

	rcv_vfile_rs.locate_sw = "0"b;		/* use the record found by the seek */

	call iox_$control (tree_ctl_entry.iocb_ptr, "record_status", rcv_vfile_rs_ptr, code);

	if code = 0
	then rcv_descr = rcv_vfile_rs.descr;
	else rcv_descr = zero_descr;

	return;					/* with last code */

     end /* rcv_seek_key */;

/* */

rcv_seek_descr:
     proc ();

	rcv_vfile_rs.descr = rcv_descr;
	rcv_vfile_rs.locate_sw = "1"b;

	call iox_$control (tree_ctl_entry.iocb_ptr, "record_status", rcv_vfile_rs_ptr, code);

	return;

     end /* rcv_seek_descr */;

/* */

rcv_check_io_in_process:
     proc ();

/* Assumes that tree_ctl_entry is set to starting node of subtree to be checked, and that subtree_count,
   always non_zero, includes the starting node. Both get set in call to build_queue_table.

   This procedure leaves the tree_ctl_eindex and tree_ctl_eptr intact with their original values upon exit. */



	do i = tree_ctl_eindex + 1 to tree_ctl_eindex + subtree_count;
						/* we know the top node is not a queue */

	     tree_ctl_eptr = addr (tree_ctl.entries (i));

	     if tree_ctl_entry.subtree_count = 0	/* first find an entry for a queue */
	     then if tree_ctl_entry.io_in_process_sw
		then if tree_ctl_entry.io_type = 2 | tree_ctl_entry.io_type = 7
		     then do;

			     a_code = cmcs_error_table_$ambiguous_tree_path;
			     input_cd.status_key = "20";
			     return;

			end;
	end;

	tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));
						/* restore to original value just in case */
	a_code = 0;

	return;

     end /* rcv_check_io_in_process */;

/*  */

build_queue_table:
     proc ();

/* If subtree_count = 0, then tree_ctl_eindex and tree_ctl_eptr are set. Otherwise not. */

	if ^init_queue_table_sw
	then do;

		allocate queue_table_struc;
		init_queue_table_sw = "1"b;
	     end;

	call cmcs_tree_ctl_$find_tree_path (input_cdp, tree_ctl_eindex, subtree_count, tree_ctl_eptr, a_code);

	if a_code ^= 0
	then do;

		input_cd.status_key = "20";

		return;
	     end;

	if subtree_count = 0
	then do;					/* we hit a queue entry all by itself */

		queue_table_len = 1;
		queue_table (1) = tree_ctl.entries (tree_ctl_eindex).queue_ctl_eindex;

		return;

	     end;
	else do;

		queue_table_len = 0;

		do i = tree_ctl_eindex + 1 to tree_ctl_eindex + subtree_count;

		     tree_ctl_eptr = addr (tree_ctl.entries (i));

		     if tree_ctl_entry.subtree_count = 0
		     then do;			/* found a queue entry */

			     queue_table_len = queue_table_len + 1;
			     queue_table (queue_table_len) = tree_ctl_entry.queue_ctl_eindex;

			end;
		end;
	     end;

	return;

     end /* build_queue_table */;

/* */

rcv_set_type:
     proc ();

	string (tree_ctl_entry.io_flags) = (36)"0"b;
	tree_ctl_entry.io_in_process_sw = "1"b;
	tree_ctl_entry.io_type = io_type;
	tree_ctl_entry.io_subtype = io_subtype;

	if io_type = 2
	then if io_subtype = 3 | io_subtype = 4
	     then tree_ctl_entry.rcv_wait_sw = "1"b;

	tree_ctl_entry.rcv_seg_sw, tree_ctl_entry.rcv_msg_sw = "0"b;
						/* init both to false and then set one true */

	if io_subtype = 1 | io_subtype = 3
	then tree_ctl_entry.rcv_seg_sw = "1"b;		/* print subtype 1 and rcv subtype 1 are the same */
	else tree_ctl_entry.rcv_msg_sw = "1"b;

	return;

     end /* rcv_set_type */;


/* */

rcv_set_buffer:
     proc ();

	buffer_ptr = a_buffer_ptr;
	buffer_len, tree_ctl_entry.buffer_len, tree_ctl_entry.buffer_left_len = a_buffer_len;

	buffer_left_index, tree_ctl_entry.buffer_left_index = 1;

     end /* rcv_set_buffer */;

/*  */

send:
     entry (a_output_cdp, a_io_subtype, a_buffer_ptr, a_buffer_len, a_station_count, a_slew_ctl, a_code);

/*[4.4-2]*/
	call set;

	if ^send_init_sw
	then call send_init;

/* from now on, a_code gets set only with the first non-zero status code returned */

	output_cdp = a_output_cdp;
	io_type = 1;
	new_status, io_subtype = a_io_subtype;		/* get old status later from tree_ctl_entry */

	if new_status = 3
	then new_status = 2;			/* EMI and EGI are the same for us */

	buffer_ptr = a_buffer_ptr;
	buffer_len = a_buffer_len;
	station_count = a_station_count;

	call send_check_slew;

	if a_code ^= 0
	then do;

		output_cd.status_key = "60";		/* indicates no action taken */

		return;

	     end;

/* No other checks needed here because cobol_mcs_ has already verified text-len, max-text-len,
   station-count, and max-station-count. */



	output_cd.status_key = "00";			/* start clean, change only on first error */



/* The BIG Loop! The loop processes the message data for each destination (station)
   in the output_cd. It is possible, and legal, for the various destinations to have
   different statuses. That is, the message could be the first piece of a message for
   one destination and the middle piece for another destination. Thus, each station must
   be handled independently from the others. */

/* Note: To keep the do/end code from nesting too deeply, gotos are used in the outer controls */





	do dest_table_index = 1 to station_count;	/* cobol_mcs_ ensures count of at least 1 */

	     station_name = output_cd.dest_table (dest_table_index).station_name;

/*[4.4-3]*/
	     call cmcs_station_ctl_$find_destination (station_name, station_ctl_eindex, station_ctl_eptr, code);

	     call cmcs_tree_ctl_$find_destination (station_name, tree_ctl_eindex, tree_ctl_eptr, code);

	     if code ^= 0
	     then do;

		     if a_code = 0
		     then do;			/* always report the first error encountered */

			     a_code = code;
			     output_cd.status_key = "20";
			end;

		     output_cd.dest_table (dest_table_index).error_key = "1";

/*[4.4-3]*/
		     return;

		end;

	     output_cd.dest_table (dest_table_index).error_key = "0";
						/* initialize to good now, reset only on error */

	     queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;

	     tree_ctl_entry.queue_ctl_eptr, queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

	     if tree_ctl_entry.io_in_process_sw
	     then do;
		     if tree_ctl_entry.io_type > 1
		     then call E9;

		     msg_hdr_ptr = tree_ctl_entry.msg_hdr_ptr;
		     old_status = tree_ctl_entry.io_subtype;
						/* always 0 or 1 */








		end;
	     else do;
		     call reset_tce_io;		/* reset message dep params */

		     tree_ctl_entry.io_type = 1;	/* send */

		     old_status = 0;		/* for use in key computation */


		end;

	     call test_subtype;

/*[4.4-4]*/
	     call set_new_status;			/* 0(partial), 1(esi), 2(emi,egi) */

send_loop_end:					/* set/reset io_in_process_sw. Only if there are no errors and the message is still not completed (just 0/EsI delim),
   will we set the busy switch. All other cases force it to be reset. This can cause garbage pieces (segments), to be left
   in the file. These can be cleaned up later with the cobol_mcs_admin request of purge_queues. At a later time,
   we may do dynamic purging. */
	     if (new_status ^= 2 & output_cd.dest_table (dest_table_index).error_key ^= "1")
	     then tree_ctl_entry.io_in_process_sw = "1"b;

/* set busy only if no errors and not (EMI or EGI) */

	     else tree_ctl_entry.io_in_process_sw = "0"b;

/* force reset, for subsequent I/O */

	end;

	return;


test_subtype:
     proc;

	if io_subtype = 0
	then call send_partial;
	else call send_non_partial;			/* esi,emi,egi */


     end;

E1:
     proc;					/* queue was disabled */

	a_code = code;
	output_cd.status_key = "10";
	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;

E2:
     proc;					/* output terminal was disabled */

	a_code = code;
	output_cd.status_key = "10";
	output_cd.dest_table (dest_table_index).error_key = "1";

/*[4.4-3]*/
/*go to send_loop_end;*/

     end;

E3:
     proc;					/* input terminal was disabled */

	if a_code = 0
	then do;

		a_code = code;
		output_cd.status_key = "20";		/* for lack of a better status key */
	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;

E4:
     proc;					/* check status after send_get_key */

	call sub_err_ (code, my_name, "c", sub_err_retval,
	     "Attempting to lock queue_ctl to get message number for ""^a"".", station_name);

	if a_code = 0
	then do;

		a_code = code;
		output_cd.status_key = "50";
	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;


E5:
     proc;					/* check status after open */

	call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to open queue for message to ""^a"".",
	     station_name);

	if a_code = 0
	then do;

		a_code = code;
		output_cd.status_key = "20";
	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;


E6:
     proc;					/* check status after send_seek_key */

	call sub_err_ (code, my_name, "c", sub_err_retval, "Attempting to seek space for message to ""^a"".",
	     station_name);

	if a_code = 0
	then do;

		a_code = code;
		output_cd.status_key = "20";
	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;

E8:
     proc;					/* check status after qc_lock, cmcs_status_list_ctl$(move,add) */

	call sub_err_ (code, my_name, "c", null (), sub_err_retval,
	     "Attempting to add message for ""^a"" to status list. Contact CMCS Administrator. Continuing.",
	     tree_ctl_entry.queue_name);

	if a_code = 0
	then do;

		a_code = cmcs_error_table_$bad_dest;
		output_cd.status_key = "20";
	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

     end;

E9:
     proc;

	call sub_err_ (error_table_$action_not_performed, my_name, "c", null (), sub_err_retval,
	     "Attempting to perform send to ""^a"" while other I/O in process.", station_name);

	if a_code = 0
	then do;

		a_code = cmcs_error_table_$bad_dest;
		output_cd.status_key = "20";
	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;


E10:
     proc;					/* check status in send_append_tag */

	code = cmcs_error_table_$bad_message_length;

	call sub_err_ (code, my_name, "c", null (), sub_err_retval,
	     "Maximum size exceeded for partial message to ""^a"".", station_name);

	if a_code = 0
	then do;

		a_code = code;
		output_cd.status_key = "20";

	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;

E11:
     proc;					/* check status after get_temp_segments */

	call sub_err_ (code, my_name, "s", null (), sub_err_retval,
	     "Attempting to get temp seg for send to ""^a"". Contact CMCS Administrator.", station_name);

	if a_code = 0
	then do;

		a_code = code;
		output_cd.status_key = "20";

	     end;

	output_cd.dest_table (dest_table_index).error_key = "1";

	go to send_loop_end;

     end;


send_partial:
     proc;

	if tree_ctl_entry.tseg_ptr = null ()
	then do;					/* allocate one temp seg */

		call get_temp_segments_ (my_name, ptr_array, code);

		if code ^= 0
		then call E11;

		tseg_ptr, tree_ctl_entry.tseg_ptr = ptr_array (1);

		tseg_len, tree_ctl_entry.tseg_len = 0;
	     end;

	else do;
		tseg_ptr = tree_ctl_entry.tseg_ptr;
		tseg_len = tree_ctl_entry.tseg_len;
	     end;

	if tree_ctl_entry.tseg_len + buffer_len > tseg_max_len
	then call E10;

/* exceeded implementation limit for msg seg size */

	substr (tseg, tseg_len + 1, buffer_len) = substr (buffer, 1, buffer_len);

/* copy data to temp seg */

	tree_ctl_entry.tseg_len = tree_ctl_entry.tseg_len + buffer_len;
	tree_ctl_entry.partial_in_process_sw = "1"b;


     end;


send_non_partial:
     proc;					/* send delim ^= 0 */



	if user_ctl.terminal_sw
	then do;					/* terminals are restricted, mp's aren't */

		if ^tree_ctl_entry.io_in_process_sw	/* check only for brand-new messages */
		then do;				/* once they are started, it's ok */

			if queue_ctl_entry.input_disabled_sw
			then do;			/* can't let them through */

				code = cmcs_error_table_$queue_disabled;

				if a_code = 0
				then call E1;

			     end;


			if station_ctl_entry.output_disabled_sw
			then do;
				code = cmcs_error_table_$dest_disabled;

				if a_code = 0
				then call E2;
			     end;


			call cmcs_station_ctl_$input_disabled (user_ctl.station_ctl_eindex, flag, code);

			if code ^= 0
			then call E3;

			if flag
			then do;

				code = cmcs_error_table_$source_disabled;
				call E3;
			     end;

		     end;

	     end;

	call send_get_key;

	if code ^= 0
	then call E4;

	call open;				/* be sure we have a good IO switch */

	if code ^= 0
	then call E5;

	if tree_ctl_entry.seg_no = 1
	then seek_len = msg_hdr_len + msg_seg_hdr_len;
	else seek_len = msg_seg_hdr_len;

	seek_len = 4 * seek_len + buffer_len;


	if tree_ctl_entry.partial_in_process_sw
	then seek_len = seek_len + tree_ctl_entry.tseg_len;

















	call send_seek_key;

	if code ^= 0
	then call E6;

	tree_ctl_entry.seg_count = seg_no;		/* so we know how many we have altogether */

	if tree_ctl_entry.seg_no = 1
	then do;					/* first segment of message */

		msg_hdr_ptr, tree_ctl_entry.msg_hdr_ptr = send_vfile_rs.rec_ptr;

		call send_fillin_msg_hdr;

		tree_ctl_entry.msg_descr = send_vfile_rs.descr;
						/* will be needed later for changing status */
		msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = addr (msg_hdr.msg_seg);

	     end;
	else do;					/* not the first segment of the message */

		msg_seg_ptr, tree_ctl_entry.msg_seg_ptr = send_vfile_rs.rec_ptr;
		tree_ctl_entry.msg_seg_descr = send_vfile_rs.descr;

/* may be useful sometime, but not now */

	     end;

	call send_fillin_seg_hdr;			/* then copy the real data */

	if ^tree_ctl_entry.partial_in_process_sw
	then substr (msg_seg.data.seg_data, 1, buffer_len) = substr (buffer, 1, buffer_len);

	else do;					/* do a gather-copy of the tseg and a_buffer */

		tseg_ptr = tree_ctl_entry.tseg_ptr;
		tseg_len = tree_ctl_entry.tseg_len;
		msg_seg.hdr.seg_len = msg_seg.hdr.seg_len + 1;

		substr (msg_seg.data.seg_data, 1, tseg_len) = substr (tseg, 1, tseg_len);
						/* part 1 */
		substr (msg_seg.data.seg_data, tseg_len + 1, 1) = "
";
		substr (msg_seg.data.seg_data, tseg_len + 2, buffer_len) = substr (buffer, 1, buffer_len);
						/* part 2 */

		tree_ctl_entry.partial_in_process_sw = "0"b;
		tree_ctl_entry.tseg_len = 0;

	     end;

	if new_status = 2
	then do;					/* this is the latest possible moment to set this info */

		msg_hdr.clock_available = clock_ ();
		msg_hdr.source_station = user_ctl.station_name;
		msg_hdr.source_group_id = get_group_id_ ();
		msg_hdr.msg_len = tree_ctl_entry.msg_len;
		msg_hdr.final_delim = io_subtype;	/* EMI or EGI */
		msg_hdr.seg_count = tree_ctl_entry.seg_count;

	     end;


	call qc_lock;				/* ipc_$wakeup called herein */

	if code ^= 0
	then call E8;
	else do;

		if new_status = 2 & old_status = 1
		then call cmcs_status_list_ctl_$move (queue_ctl_eptr, iocb_ptr, addr (tree_ctl_entry.msg_descr),
			old_status, new_status, code);
		else call cmcs_status_list_ctl_$add (queue_ctl_eptr, iocb_ptr, addr (tree_ctl_entry.msg_descr),
			new_status, code);

		if code ^= 0
		then call E8;

	     end;

	call qc_unlock;				/* ignore return status */

     end;

/*  */

send_check_slew:
     proc ();

	slew_ctl_ptr = addr (a_slew_ctl);		/* for overlay processing */

	if a_slew_ctl = 0
	then do;					/* when = 0, what = 0, how_much = 0 */

ret_good_slew:
		a_code = 0;
		return;
	     end;
	else if slew_ctl.when = 0
	then do;
ret_bad_slew:
		a_code = cmcs_error_table_$bad_slew;

		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		     "From check of the slew control. The slew control supplied is:
	when (^d), what (^d), how much (^d).
	Error keys set for all destinations.", slew_ctl.when, slew_ctl.what, slew_ctl.how_much);

		output_cd.status_key = "20";

		do i = 1 to station_count;
		     output_cd.dest_table (i).error_key = "1";
		end;

		return;

	     end;
	else if slew_ctl.when < 0 | slew_ctl.when > 2
	then go to ret_bad_slew;

	if slew_ctl.what < 0 | slew_ctl.what > 3
	then go to ret_bad_slew;

	if slew_ctl.what = 1
	then if slew_ctl.how_much < 0 | slew_ctl.how_much > 128
	     then go to ret_bad_slew;
	     else ;
	else if slew_ctl.what = 2
	then slew_ctl.how_much = 0;			/*[4.4-1]*/

	else if slew_ctl.what = 3
	then if slew_ctl.how_much < 1 | slew_ctl.how_much > 16
	     then go to ret_bad_slew;

	go to ret_good_slew;

     end /* send_check_slew */;

/* */

send_init:
     proc ();

	send_vfile_rs_ptr = addr (send_vfile_rs);
	overlay_len = size (send_vfile_rs);
	send_vfile_rs_ptr -> overlay (*) = 0;

	send_vfile_rs.version = vfile_rs_version;
	send_vfile_rs.create_sw = "1"b;		/* send will always create new records */

	send_init_sw = "1"b;

	return;

     end /* send_init */;

/*  */

send_seek_key:
     proc ();

	send_vfile_rs.rec_len, send_vfile_rs.max_rec_len = seek_len + 8;
						/* to give space for vfile lockword, if needed */

	key = based_key;				/* for vfile_ char (256) var key */

	call iox_$seek_key (iocb_ptr, key, fb21, code);

	if code = 0
	then do;					/* must never happen, should always be not_found */

		code = error_table_$bad_new_key;

		return;
	     end;
	else if code ^= error_table_$no_record
	then return;

/* Seek OK, now create new space */

	call iox_$control (iocb_ptr, "record_status", addr (send_vfile_rs), code);
	return;

     end /* send_seek_key */;

/* */

send_fillin_msg_hdr:
     proc ();

	overlay_len = msg_hdr_len;
	msg_hdr_ptr -> overlay (*) = 0;		/* erase any existing garbage */
	msg_hdr.lockword = get_process_id_ ();		/* temporary id of author */
	msg_hdr.version = msg_hdr_version;
	msg_hdr.source_station = user_ctl.station_name;
	msg_hdr.msg_no = tree_ctl_entry.msg_no;
	msg_hdr.seg_no = 1;				/* always 1 in the msg_hdr */
	msg_hdr.seg_count = -1;			/* don't have a good number yet */
	msg_hdr.msg_status = new_status;
	msg_hdr.final_delim = io_subtype;		/* can only be 1-3 */

	return;

     end /* send_fillin_msg_hdr */;

/* */

send_fillin_seg_hdr:
     proc ();

	msg_seg.hdr.msg_no = tree_ctl_entry.msg_no;
	msg_seg.hdr.seg_no = tree_ctl_entry.seg_no;
	msg_seg.hdr.slew_ctl = a_slew_ctl;

	if ^tree_ctl_entry.partial_in_process_sw
	then msg_seg.hdr.seg_len = buffer_len;
	else msg_seg.hdr.seg_len = buffer_len + tree_ctl_entry.tseg_len;

	tree_ctl_entry.msg_len = tree_ctl_entry.msg_len + msg_seg.hdr.seg_len;
	tree_ctl_entry.seg_count = tree_ctl_entry.seg_no; /* may need in case of purge */

	return;

     end /* send_fillin_seg_hdr */;

/*  */

reset_tce_io:
     proc;

/* Procedure to reset all message dependent parameters */

/* tree_ctl_eptr must be set to the tree_ctl_entry to be reset */

	string (tree_ctl_entry.io_flags) = (36)"0"b;

	tree_ctl_entry.msg_hdr_ptr = null ();
	tree_ctl_entry.io_type = 0;
	tree_ctl_entry.io_subtype = 0;
	string (tree_ctl_entry.io_flags) = (36)"0"b;
	tree_ctl_entry.seg_count = 0;
	tree_ctl_entry.msg_len = 0;
	tree_ctl_entry.msg_descr = zero_descr;
	tree_ctl_entry.msg_no = 0;
	tree_ctl_entry.seg_no = 0;
	tree_ctl_entry.tseg_len = 0;
	tree_ctl_entry.msg_seg_ptr = null ();
	tree_ctl_entry.msg_seg_descr = zero_descr;
	tree_ctl_entry.msg_seg_len = 0;
	tree_ctl_entry.msg_seg_left_index = 0;
	tree_ctl_entry.msg_seg_left_len = 0;
	tree_ctl_entry.buffer_len = 0;
	tree_ctl_entry.buffer_left_index = 0;
	tree_ctl_entry.buffer_left_len = 0;

	return;

     end /* reset_tce_io */;

/*  */

open:
     proc ();

	queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;
	queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

	if tree_ctl_entry.vfile_status = 2
	then do;					/* already open */

		iocb_ptr = tree_ctl_entry.iocb_ptr;
		code = 0;

		return;
	     end;
	else if tree_ctl_entry.vfile_status = 0
	then do;					/* brand new use */
iox_attach:
		switch_no = switch_no + 1;		/* build "unique" switch name */
		switch_pic = switch_no;
		tree_ctl_entry.switch_name = rtrim (tree_ctl_entry.queue_name) || "." || switch_pic;
						/* aaa.nn */

		call ioa_$rsnnl ("vfile_ ^a>^a -share ^d -old", attach_descr, attach_descr_len, user_ctl.cmcs_dir,
		     queue_ctl_entry.queue_name, system_ctl.lock_wait_time);

/* q name already has suffix */

		call iox_$attach_name (tree_ctl_entry.switch_name, iocb_ptr,
		     substr (attach_descr, 1, attach_descr_len), null (), code);

		if code ^= 0
		then return;

		tree_ctl_entry.vfile_status = 1;	/* log in case of trouble */

iox_open:
		call iox_$open (iocb_ptr, 13, "0"b, code);
						/* 13 = direct_update */

		if code ^= 0
		then return;

		call iox_$control (iocb_ptr, "min_block_size", addr (min_blksz_info), code);

		if code ^= 0
		then do;

			call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			     "Attempting to perform min_block_size control order for queue ^a (switch ^a). Continuing.",
			     tree_ctl_entry.queue_name, tree_ctl_entry.switch_name);

		     end;

		tree_ctl_entry.vfile_status = 2;
		tree_ctl_entry.iocb_ptr = iocb_ptr;

	     end;
	else if tree_ctl_entry.vfile_status = 1
	then go to iox_open;
	else do;					/* unrecognized vfile status */

		code = error_table_$not_open;
	     end;

	return;

     end /* open */;

/*  */

close:
     proc ();

/* This procedure assumes that tree_ctl_eptr is set to the entry to be closed. */

	if tree_ctl_entry.vfile_status > 0
	then do;

		if tree_ctl_entry.vfile_status = 2
		then do;

			call iox_$close (tree_ctl_entry.iocb_ptr, code);

			if code ^= 0
			then do;
close_err:
				call sub_err_ (code, my_name, "c", null (), sub_err_retval,
				     "Attempting to close the ^a queue.", tree_ctl_entry.queue_name);

				return;
			     end;

			tree_ctl_entry.vfile_status = 1;

		     end;

		call iox_$detach_iocb (tree_ctl_entry.iocb_ptr, code);

		if code ^= 0
		then go to close_err;

		tree_ctl_entry.iocb_ptr = null ();
		tree_ctl_entry.vfile_status = 0;
	     end;

	else if tree_ctl_entry.iocb_ptr ^= null ()
	then do;

		code = cmcs_error_table_$bad_call_parm;

		call sub_err_ (code, my_name, "c", null (), sub_err_retval,
		     "Inconsistent vfile_ status for queue ^a (switch ^a). File closed.", tree_ctl_entry.queue_name,
		     tree_ctl_entry.switch_name);

		call iox_$close (tree_ctl_entry.iocb_ptr, code);
						/* ignore return */
		call iox_$detach_iocb (tree_ctl_entry.iocb_ptr, code);
						/* ignore return */

		tree_ctl_entry.iocb_ptr = null ();
		tree_ctl_entry.vfile_status = 0;
	     end;

	else code = 0;

	if tree_ctl_entry.tseg_ptr ^= null ()
	then do;

		ptr_array (1) = tree_ctl_entry.tseg_ptr;

		call release_temp_segments_ (my_name, ptr_array, code);

		if code ^= 0
		then do;

			call sub_err_ (code, my_name, "c", null (), sub_err_retval,
			     "Attempting to release temporary buffer segment for ^a. Continuing.",
			     tree_ctl_entry.queue_name);

			code = 0;
		     end;
	     end;

	return;

     end /* close */;

/*  */

send_get_key:
     proc ();

	if tree_ctl_entry.msg_no = 0
	then do;					/* 1st segment of new msg */

/*[5.3-1]*/
		call cmcs_set_lock_$lock (queue_ctl.hdr.lockword, system_ctl.lock_wait_time, code);

		if code ^= 0
		then return;

		queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;
		queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));

		msg_no, tree_ctl_entry.msg_no, key_struc.msg_no, queue_ctl_entry.msg_no = queue_ctl_entry.msg_no + 1;
						/* update all related fields at once */

		call cmcs_set_lock_$unlock (queue_ctl.hdr.lockword, code);

		if code ^= 0
		then do;				/* also should never happen */
			call sub_err_ (code, my_name, "c", sub_err_retval,
			     "From attempt to unlock queue_ctl for ""^a"".", station_name);
			code = 0;
		     end;

		seg_no, key_struc.seg_no, tree_ctl_entry.seg_no = 1;
						/* starting fresh msg always uses segno of 1 */
	     end;

	else do;					/* msgno already exists, just bump the segno */

		msg_no, key_struc.msg_no = tree_ctl_entry.msg_no;

		seg_no, key_struc.seg_no, tree_ctl_entry.seg_no = tree_ctl_entry.seg_no + 1;
	     end;

	return;

     end /* send_get_key */;

/*  */

setup:
     proc;

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.queue_ctl)
	then do;

		user_ctl_ptr = external_user_ctl_ptr;	/* set local variable from global */

		queue_ctl_ptr = user_ctl.queue_ctl_ptr;
		system_ctl_ptr = user_ctl.system_ctl_ptr;
		tree_ctl_ptr = user_ctl.tree_ctl_ptr;
		wait_ctl_ptr = user_ctl.wait_ctl_ptr;

	     end;

/* The following code initializes the data for the vfile_ control "min_block_size".
   This control ensures at least 8 extra characters will be left for the vfile record lockword. */

	min_blksz_info.min_residue = 8;
	min_blksz_info.min_capacity = 8;

	zero_descr_ptr = addr (zero);			/* for assignments of "null" descriptors */

	user_ctl.init_sw.queue_ctl = "1"b;
	a_code = 0;
	return;

     end /* setup */;

test:
     entry ();

	test_sw = "1"b;
	return;

/* */

qc_lock:
     proc ();

/*[5.3-1]*/
	call cmcs_set_lock_$lock (queue_ctl.hdr.lockword, system_ctl.lock_wait_time, code);

	if code ^= 0
	then do;
		call sub_err_ (code, my_name, "c", null (), sub_err_retval, "Attempting to lock queue_ctl.");
	     end;

	return;

     end /* qc_lock */;

/* */

qc_unlock:
     proc ();

	call cmcs_set_lock_$unlock (queue_ctl.hdr.lockword, code);

	return;

     end /* qc_unlock */;

set_new_status:
     proc;

/*[4.4-4]*/
	new_status, io_subtype, tree_ctl_entry.io_subtype = a_io_subtype;

/*[4.4-4]*/
	if new_status = 3
	then new_status = 2;			/* egi = emi */

     end;

     end /* cmcs_queue_ctl_ */;




		    cmcs_scramble_.pl1              05/24/89  1047.9rew 05/24/89  0836.4       30357



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_scramble_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_scramble_:
     proc (arg) returns (char (10) aligned);

/* COBOL MCS subroutine directly adapted from the scramble_ routine in tools to handle 10 character passwords */

/* Bob May, 6/30/77 */

/* SCRAMBLE_ - Scramble a char (10) string.

   This procedure, given a password as input, returns a 10-character output string which:
   1. bears some relationship to the input
   2. loses some information - some passwords may scramble to the same value
   3. has no obvious relation to the input ("aaaaaaaa" and "aaaaaaab"
   .  scramble to noticeably different values.)

   Passwords stored in system files are scrambled, so that if anyone gets a dump
   of the password file by accident, it won't do him much good.

   The transform is supposed to be non-invertible.

   A previous version of this program had two defects:
   1) It was invertible, as Steve Lipner demonstrated.
   2) It depended on double-precision MOD and MULTIPLY. These turned out
   .  to have been incorrectly implemented by PL/I and so the scramble,
   .  while good, would have given different values if the bugs were fixed.

   Method:
   1. strip the two high-order bits of each ASCII character, packing to the right.
   2. treat the resulting 70-bit quantity as both key and cipher text for
   .  the system enciphering program.
   3. destroy selected bits of the resulting cipher.

   Revised 5/21/73, THVV, for new algorithm.
   THVV 10/30/71
   */

dcl	arg		char (10) aligned;

dcl	temp		char (10),
	temp1		(1) fixed bin (71),
	temp2		(1) fixed bin (71),
	(p1, p2, p3)	ptr,			/* ptrs to based overlays */
	(i, k)		fixed bin;

dcl	bbt		bit (72) aligned based (p1),
	b72		bit (72) aligned based (p3),
	bc10		char (10) aligned based (p3);

dcl	1 tsx		based (p2) aligned,
	  2 pad		bit (2) unal,
	  2 z		(8) bit (7) unal;

dcl	encipher_		entry (fixed bin (71), dim (*) fixed bin (71), dim (*) fixed bin (71), fixed bin);

dcl	(addr, fixed, mod, substr)
			builtin;

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

	temp = arg;				/* copy argument */
	p1 = addr (temp);
	p2 = addr (temp1 (1));
	p3 = addr (temp2 (1));
	temp1 (1) = 0;
	k = 1;
	do i = 3 to 90 by 9;
	     z (k) = substr (bbt, i, 7);		/* squeeze out always-zero bits */
	     k = k + 1;
	end;
	temp = "";				/* Erase temporary copy */
	call encipher_ (temp1 (1), temp1, temp2, 1);	/* Encipher the password. */
	temp1 (1) = 0;				/* Tidy up */
	b72 = b72 & "111111110111111110111111110111111110111111110111111110111111110111111110"b;
	return (bc10);

     end /* cmcs_scramble_ */;




		    cmcs_set_lock_.pl1              05/24/89  1047.9rew 05/24/89  0834.0       23895



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8087 cmcs_set_lock_.pl1 Shorten wait time for cmcs_station_ctl_.
                                                   END HISTORY COMMENTS */


/* Modified on 10/20/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */
/* Modified since Version 4.3 */

/* format: style3 */
cmcs_set_lock_:
     proc;

	return;					/* invalid entry point */

/* This COBOL MCS subroutine is  used to mask all IPS interrupts and then lock the specified lock.
   In the reverse, it will unlock the lock and then umask the IPS interrupts. */

/* Bob May, 6/30/77 */

/*   hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned),
     hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned), */
dcl	set_lock_$lock	entry (bit (36) aligned, fixed bin, fixed bin (35)),
	set_lock_$unlock	entry (bit (36) aligned, fixed bin (35));

dcl	error_table_$invalid_lock_reset
			fixed bin (35) external;

dcl	(mask, oldmask)	bit (36) aligned,
	lockword		bit (36) aligned;



dcl	code		fixed bin (35);

/*  */
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_system_ctl;
%include cmcs_user_ctl;
/*  */
lock:
     entry (a_lockword, time, a_code);

dcl	a_lockword	bit (36) aligned,
	a_code		fixed bin (35);

/*[5.3-1]*/
dcl	time		fixed bin;

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.set_lock)
	then do;
		call setup;
		if a_code ^= 0
		then return;
	     end;


/*[5.3-1]*/
	call set_lock_$lock (a_lockword, time, a_code);
	if a_code ^= 0
	then if a_code = error_table_$invalid_lock_reset
	     then a_code = 0;

	return;

unlock:
     entry (a_lockword, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.set_lock)
	then do;
		call setup;
		if a_code ^= 0
		then return;
	     end;

	call set_lock_$unlock (a_lockword, a_code);
	return;

setup:
     proc;

	user_ctl_ptr = external_user_ctl_ptr;		/* set local variable from global */

	system_ctl_ptr = user_ctl.system_ctl_ptr;

	user_ctl.init_sw.set_lock = "1"b;
	a_code = 0;
	return;

     end /* setup */;

     end /* cmcs_set_lock_ */;




		    cmcs_station_ctl_.pl1           05/24/89  1047.9rew 05/24/89  0834.0       92916



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8087 cmcs_station_ctl_.pl1 Shorten wait time for cmcs_station_ctl_.
                                                   END HISTORY COMMENTS */


/* Modified on 10/20/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */
/* Modified on 03/18/82 by FCH, [5.2-1], [4.4-4] was a disaster, BUG530 */
/* Modified on 06/08/81 by FCH, [4.4-5], code "20" not returned, BUG468 */
/* Modified on 05/12/81 by FCH, [4.4-4], zero deley if station in use, BUG468 */
/* Modified on 04/29/81 by FCH, [4.4-3], entry find_destination added, BUG468 */
/* Modified on 04/23/81 by FCH, [4.4-2], check destination count for legality, BUG468 */
/* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */
/* Modified since Version 4.3 */

/* format: style3 */
cmcs_station_ctl_:
     proc;

/* COBOL MCS subroutine to manage stations for enable and disable functions. */

/* Note: The disable/enable entrypoints all accept a char (10) password string. This string is ignored
   because it was already checked by cobol_mcs_. Current ANSI rules on the use of multiple passwords for CMCS
   terminals and queues is unclear and requests for clarification have been submitted. Until the clarification
   is issued, this implementation will use a single password. Thus, cobol_mcs_ can do the checking for everybody. */

/* Bob May, 6/01/77 */

	return;					/* bad entry point */

dcl	i		fixed bin,
	my_name		char (17) init ("cmcs_station_ctl_");


dcl	com_err_		entry options (variable);

dcl	a_station_name	char (12),
	a_station_ctl_eptr	ptr,
	a_station_ctl_eindex
			fixed bin,
	a_input_cdp	ptr,
	a_output_cdp	ptr,
	a_station_output_cdp,
	a_password	char (10),
	a_flag		bit (1),
	a_code		fixed bin (35);		/*[4.4-4]*/
declare	save_lwt		fixed bin;

dcl	x_station_name	char (12),
	station_count	fixed bin;		/* converted from char data */


dcl	(error_table_$invalid_lock_reset)
			fixed bin (35) external;

dcl	set_lock_$lock	entry (bit (36) aligned, fixed bin, fixed bin (35)),
	set_lock_$unlock	entry (bit (36) aligned, fixed bin (35));

dcl	(addr, null)	builtin;

/*  */
%include cmcs_cd_dcls;
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_station_ctl;
%include cmcs_system_ctl;
%include cmcs_user_ctl;
/*  */
validate:
     entry (a_station_name, a_station_ctl_eindex, a_code);

/*[4.4-1]*/
	call setup;

	call find_station (a_station_name);

	if a_code ^= 0
	then a_station_ctl_eindex = 0;
	else a_station_ctl_eindex = station_ctl_eindex;

	return;

/* end validate entrypoint */

attach:
     entry (a_station_name, a_station_ctl_eindex, a_code);

/*[4.4-1]*/
	call setup;

	call find_station (a_station_name);

	if a_code ^= 0
	then return;

/*[5.2-1]*/
/*save_lwt = system_ctl.lock_wait_time*/
/*[5.2-1]*/
/*system_ctl.lock_wait_time = 0;*/

	call lock_station;				/*[5.2-1]*/
						/*system_ctl.lock_wait_time = save_lwt;*/

	if a_code = 0
	then a_station_ctl_eindex = station_ctl_eindex;	/* went fine, give it to user */
	else a_station_ctl_eindex = 0;		/* if used, will blow */

	user_ctl.station_name = a_station_name;

	return;

/* */

detach:
     entry (a_station_ctl_eindex, a_code);

/*[4.4-1]*/
	call setup;

	station_ctl_eindex = a_station_ctl_eindex;
	station_ctl_eptr = addr (station_ctl.entries (station_ctl_eindex));

	call unlock_station;

	if a_code = 0
	then user_ctl.station_name = "";

	return;

/* */

detach_name:
     entry (a_station_name, a_code);

/*[4.4-1]*/
	call setup;

	call find_station (a_station_name);

	if a_code ^= 0
	then return;

	call unlock_station;

	if a_code = 0
	then user_ctl.station_name = "";

	user_ctl.station_name = "";

	return;

/* */

disable_input_terminal:
     entry (a_input_cdp, a_password, a_code);

/*[4.4-1]*/
	call setup;

	input_cdp = a_input_cdp;
	x_station_name = input_cd.station_name;

	call find_station (x_station_name);

	if a_code ^= 0
	then do;

		input_cd.status_key = "20";
		return;

	     end;

	if station_ctl_entry.input_disabled_sw
	then a_code = cmcs_error_table_$source_already_disabled;
	else do;

		station_ctl_entry.input_disabled_sw = "1"b;
		a_code = 0;

	     end;

	input_cd.status_key = "00";

	return;

/* */

enable_input_terminal:
     entry (a_input_cdp, a_password, a_code);

/*[4.4-1]*/
	call setup;

	input_cdp = a_input_cdp;
	x_station_name = input_cd.station_name;

	call find_station (x_station_name);

/*[4.4-5]*/
	if a_code ^= 0				/*[4.4-5]*/
	then do;
		input_cd.status_key = "20";		/*[4.4-5]*/
		return;				/*[4.4-5]*/
	     end;

	if ^station_ctl_entry.input_disabled_sw
	then a_code = cmcs_error_table_$source_already_enabled;
	else do;

		station_ctl_entry.input_disabled_sw = "0"b;
		a_code = 0;

	     end;

	input_cd.status_key = "00";

	return;					/* */
disable_output_terminal:
     entry (a_output_cdp, a_password, a_code);

/*[4.4-1]*/
	call setup;

	output_cdp = a_output_cdp;

	if output_cdp ^= null ()
	then do;					/* process the supplied list */

		output_cd.status_key = "00";		/* init to 00 is changed if any problem */
		station_count = output_cd.station_count;/* convert from char data */

/*[4.4-2]*/
		if station_count = 0 | station_count > output_cd.bin_max_station_count
						/*[4.4-2]*/
		then output_cd.status_key = "30";	/*[4.4-2]*/
		else do i = 1 to station_count;

			x_station_name = output_cd.station_name (i);

			call find_station (x_station_name);

			if a_code ^= 0
			then do;

				output_cd.error_key (i) = "1";
				output_cd.status_key = "20";

			     end;
			else output_cd.error_key (i) = "0";

			if station_ctl_entry.output_disabled_sw
			then a_code = cmcs_error_table_$dest_already_disabled;
			else do;

				station_ctl_entry.output_disabled_sw = "1"b;
				a_code = 0;

			     end;
		     end;
	     end;

/* null output_cdp, do them all and ignore status key */

	else do;

		do i = 1 to station_ctl.current_size;

		     if ^station_ctl.entries (i).inactive_sw
		     then station_ctl.entries (i).output_disabled_sw = "1"b;
						/* ignore previous state */

		end;

		a_code = 0;

	     end;

	return;

/* */

enable_output_terminal:
     entry (a_output_cdp, a_password, a_code);

/*[4.4-1]*/
	call setup;

	output_cdp = a_output_cdp;

	if output_cdp ^= null ()
	then do;					/* process the supplied list */

		output_cd.status_key = "00";		/* init to 00 is changed if any problem */
		station_count = output_cd.station_count;/* convert from char data */

/*[4.4-2]*/
		if station_count = 0 | station_count > output_cd.bin_max_station_count
						/*[4.4-2]*/
		then output_cd.status_key = "30";	/*{4.4-2]*/
		else do i = 1 to station_count;

			x_station_name = output_cd.station_name (i);

			call find_station (x_station_name);

			if a_code ^= 0
			then do;

				output_cd.error_key (i) = "1";
				output_cd.status_key = "20";

			     end;
			else output_cd.error_key (i) = "0";

			if ^station_ctl_entry.output_disabled_sw
			then a_code = cmcs_error_table_$dest_already_enabled;
			else do;

				station_ctl_entry.output_disabled_sw = "0"b;
				a_code = 0;

			     end;
		     end;
	     end;

/* null output_cdp, do them all and ignore status key */

	else do;

		do i = 1 to station_ctl.current_size;

		     if ^station_ctl.entries (i).inactive_sw
		     then station_ctl.entries (i).output_disabled_sw = "0"b;
						/* ignore previous state */

		end;

		a_code = 0;

	     end;

	return;

/* */

input_disabled:
     entry (a_station_ctl_eindex, a_flag, a_code);

/*[4.4-1]*/
	call setup;

	station_ctl_eptr = addr (station_ctl.entries (a_station_ctl_eindex));
	a_flag = station_ctl_entry.input_disabled_sw;
	a_code = 0;

	return;

/* */

output_disabled:
     entry (a_station_ctl_eindex, a_flag, a_code);

/*[4.4-1]*/
	call setup;

	station_ctl_eptr = addr (station_ctl.entries (a_station_ctl_eindex));
	a_flag = station_ctl_entry.output_disabled_sw;
	a_code = 0;

	return;

/* */


setup:
     proc;

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.station_ctl)
						/*[4.4-1]*/
	then do;

		user_ctl_ptr = external_user_ctl_ptr;	/* set local variable from global */
						/*[4.4-4]*/
		system_ctl_ptr = user_ctl.system_ctl_ptr;
		station_ctl_ptr = user_ctl.station_ctl_ptr;
		user_ctl.init_sw.station_ctl = "1"b;

/*[4.4-1]*/
	     end;

	a_code = 0;

	return;

     end /* setup */;

/* */

find_station:
     proc (x_station_name);

dcl	x_station_name	char (12);

	a_code = 0;				/* init to good for immediate return */

	do station_ctl_eindex = 1 to station_ctl.current_size;

	     if x_station_name = station_ctl.entries (station_ctl_eindex).station_name
	     then do;

		     station_ctl_eptr = addr (station_ctl.entries (station_ctl_eindex));
		     if ^station_ctl_entry.inactive_sw
		     then return;			/* right name and active, go to it */

		end;
	end;

	a_code = cmcs_error_table_$bad_station;		/* didn't make it */

	return;

     end /* find_station */;

/* */

lock_station:
     proc;

dcl	LOCAL_LOCK_WAIT_TIME
			fixed bin internal static options (constant) init (5);

/*[5.3-1]*/
	call cmcs_set_lock_$lock (station_ctl_entry.lockword, LOCAL_LOCK_WAIT_TIME, a_code);

	return;

     end /* lock_station */;

/* */

unlock_station:
     proc;

	call cmcs_set_lock_$unlock (station_ctl_entry.lockword, a_code);

	return;

     end /* unlock_station */;

find_destination:
     entry (a_station_name, a_station_ctl_eindex, a_station_ctl_eptr, a_code);

/*[4.4-1]*/
	call setup;

/*[4.4-3]*/
	call find_station (a_station_name);

/*[4.4-3]*/
	if a_code ^= 0				/*[4.4-3]*/
	then a_station_ctl_eindex = 0;		/*[4.4-3]*/
	else do;
		a_station_ctl_eindex = station_ctl_eindex;
						/*[4.4-3]*/
		a_station_ctl_eptr = station_ctl_eptr;	/*[4.4-3]*/
	     end;

/*[4.4-3]*/
	return;

     end /* cmcs_station_ctl_ */;




		    cmcs_status_list_ctl_.pl1       05/24/89  1047.9rew 05/24/89  0834.0      110907



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_status_list_ctl_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_status_list_ctl_:
     proc ();

	return;					/* bad entrypoint */

/* This COBOL MCS subroutine is called by cmcs_queue_ctl_ to manipulate the activity
   status of a given message. It uses the process-INdependent locators of the vfile_
   record_status control order, and manipulates linked-list locator values in the
   affected records to keep the messages in the desired status list.

   Note: This module requuires that the caller do the locking and unlocking of queue_ctl.hdr.lockword.

   Bob May, 6/30/77 */

dcl	a_iocb_ptr	ptr,
	a_queue_ctl_eptr	ptr,
	a_old_status	fixed bin,
	a_new_status	fixed bin,
	a_descr_ptr	ptr,
	a_code		fixed bin (35);

dcl	1 a_descr		like vfile_descr based (a_descr_ptr);

dcl	sysprint		file env (interactive);	/* for DEBUG */

dcl	my_name		char (21) init ("cmcs_status_list_ctl_");

dcl	iocb_ptr		ptr,
	descr_ptr		ptr;

dcl	(ioa_)		entry options (variable);

dcl	test_sw		bit (1) int static init ("0"b);

dcl	(size, string, unspec)
			builtin;

dcl	error_table_$action_not_performed
			fixed bin (35) external;

/*  */

dcl	1 (b_descr, c_descr, f_descr)
			like vfile_descr int static;

dcl	(b_descr_ptr, c_descr_ptr, f_descr_ptr)
			ptr int static;

dcl	1 (b_rs, c_rs, f_rs)
			like vfile_rs int static;

dcl	(b_rs_ptr, c_rs_ptr, f_rs_ptr)
			ptr int static;

dcl	(b_ptr, c_ptr, f_ptr)
			ptr int static;

dcl	1 (
	b		based (b_ptr),
	c		based (c_ptr),
	f		based (f_ptr)
	)		like msg_hdr;

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

dcl	zero_descr_ptr	ptr int static;

dcl	1 zero_descr	like vfile_descr based (zero_descr_ptr);
dcl	init_ptrs_sw	bit (1) int static init ("0"b);

dcl	overlay_len	fixed bin,
	overlay		(overlay_len) fixed bin (35) based;

dcl	(addr, baseptr, fixed, null)
			builtin;

dcl	sub_err_		entry options (variable),
	sub_err_retval	fixed bin (35);

/*  */
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_iox_processing;
%include cmcs_key_dcls;
%include cmcs_msg_hdr;
%include cmcs_msg_seg;
%include cmcs_queue_ctl;
%include cmcs_slew_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;
/*  */
add:
     entry (a_queue_ctl_eptr, a_iocb_ptr, a_descr_ptr, a_new_status, a_code);

	if test_sw				/* DEBUG */
	then do;
		put skip data (a_queue_ctl_eptr);
		put skip data (a_iocb_ptr);
		put skip data (a_descr_ptr);
		put skip data (a_new_status);
	     end;


	if ^(external_user_ctl_ptr -> user_ctl.init_sw.status_list_ctl)
	then call setup;

	call set_descr;
	if a_code ^= 0
	then go to error_ret;
	call check_msg_status (a_new_status);
	if a_code ^= 0
	then go to error_ret;

	status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_new_status));

	call link_descr;
	if a_code ^= 0
	then go to error_ret;

	go to check_wait;

/* end of add entrypoint */


/* */

delete:
     entry (a_queue_ctl_eptr, a_iocb_ptr, a_descr_ptr, a_old_status, a_code);

	if test_sw				/* DEBUG */
	then do;
		put skip data (a_queue_ctl_eptr);
		put skip data (a_iocb_ptr);
		put skip data (a_descr_ptr);
		put skip data (a_old_status);
	     end;


	if ^(external_user_ctl_ptr -> user_ctl.init_sw.status_list_ctl)
	then call setup;

	call set_descr;
	if a_code ^= 0
	then go to error_ret;
	call check_msg_status (a_old_status);
	if a_code ^= 0
	then go to error_ret;
	status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_old_status));

	call unlink_descr;
	if a_code ^= 0
	then go to error_ret;

	go to good_ret;

/* end of delete entrypoint */


/* */

move:
     entry (a_queue_ctl_eptr, a_iocb_ptr, a_descr_ptr, a_old_status, a_new_status, a_code);

	if test_sw				/* DEBUG */
	then do;
		put skip data (a_iocb_ptr);
		put skip data (a_queue_ctl_eptr);
		put skip data (a_descr_ptr);
		put skip data (a_old_status);
		put skip data (a_new_status);
	     end;


	if ^(external_user_ctl_ptr -> user_ctl.init_sw.status_list_ctl)
	then call setup;

	call set_descr;
	if a_code ^= 0
	then go to error_ret;
	call check_msg_status (a_old_status);
	if a_code ^= 0
	then go to error_ret;
	if a_new_status < 1 | a_new_status > 4
	then do;
		a_code = cmcs_error_table_$bad_call_parm;
		go to error_ret;
	     end;

	status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_old_status));
	call unlink_descr;
	if a_code ^= 0
	then go to error_ret;
	status_list_ctl_eptr = addr (queue_ctl_entry.status_list_ctl_entries (a_new_status));
	c.msg_status = a_new_status;			/* do before we link in, it may be processed next */
	call link_descr;
	if a_code ^= 0
	then go to error_ret;

check_wait:
	if a_new_status = 2				/* notify only for available messages */
	then do;
		if status_list_ctl_entry.count ^= 1
		then goto good_ret;			/* and only when going nonzero */
		call cmcs_wait_ctl_$find (string (queue_ctl_entry.tree_path), queue_ctl_eptr, a_code);
		if a_code ^= 0
		then if a_code ^= cmcs_error_table_$no_message
		     then do;
			     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				"Attempting to find process waiting for message in ""^a"". Continuing.",
				string (queue_ctl_entry.tree_path));
			     go to error_ret;
			end;
		     else a_code = 0;		/* it's ok, nobody was waiting */
	     end;

good_ret:
	a_code = 0;
error_ret:
	return;

/* end of move entrypoint */

/*  */

link_descr:
     proc ();

/* Procedure to add a message to the end of a given status list. It assumes that the
   main procedure has already set the following: status_list_ctl_eptr, all of the c_xxx
   variables for the current record, including the c_rs structure. Also assumes that the
   queue_ctl.hdr.lockword is locked by the caller of cmcs_status_list_ctl_, whatever the entrypoint. */

	if status_list_ctl_entry.count = 0
	then do;					/* this is the easy one */
		status_list_ctl_entry.f_descr, status_list_ctl_entry.b_descr = c_descr;
						/* for just one, both point to new entry */
		c.f_descr, c.b_descr = zero_descr;	/* similarly for new msg */
	     end;

/* already at least one msg, new one always goes at the end */

	else do;
		b_descr = status_list_ctl_entry.b_descr;/* get old last-entry descr */
		call seek_descr (b_descr, b_rs_ptr, b_ptr);
		if a_code ^= 0
		then return;
		c.b_descr = b_descr;
		c.f_descr = zero_descr;		/* new one points back to head */
		status_list_ctl_entry.b_descr, b.f_descr = c_descr;
						/* new one now in the loop */
	     end;

	a_code = 0;
	status_list_ctl_entry.count = status_list_ctl_entry.count + 1;
	return;

     end /* link_descr */;

/*  */

unlink_descr:
     proc ();

/* Procedure to unlink a message from anywhere in the linked list.
   This subroutine makes the same assumptions as link_descr. */

	if status_list_ctl_entry.count = 0
	then do;					/* impossible, unquote */
		a_code = cmcs_error_table_$bad_call_parm;
		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		     "Fatal error detected. Attempt to perform an unlink in a list with zero entries. Continuing.");
		return;
	     end;
	if status_list_ctl_entry.count = 1
	then do;					/* another easy one */
		if unspec (status_list_ctl_entry.f_descr) ^= unspec (c_descr)
		then do;				/* another impossible situation */
			a_code = cmcs_error_table_$bad_call_parm;
			call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			     "Message in status list does not match descriptor of record to be deleted. Continuing.")
			     ;
			return;
		     end;

		status_list_ctl_entry.f_descr, status_list_ctl_entry.b_descr = zero_descr;
						/* reset list to null */
		c.f_descr, c.b_descr = zero_descr;
		c.msg_status = 0;
	     end;

/* not so easy, more than one message int static in the list */

	else do;
		b_descr = c.b_descr;
		f_descr = c.f_descr;		/* set both now, may only use one */

		if unspec (b_descr) = (36)"0"b & unspec (f_descr) = (36)"0"b
		then do;
			a_code = error_table_$action_not_performed;
			call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			     "Attempting to unlink a message from queue ""^a"", status ""^d"",
where both forward and backward record descriptors are zero.
Please contact the CMCS Administrator. Continuing.", queue_ctl_entry.queue_name, a_old_status);
			go to zero_c_descr;
		     end;


		if unspec (b_descr) = unspec (zero_descr)
		then do;				/* first one in list */
			call seek_descr (f_descr, f_rs_ptr, f_ptr);
			if a_code ^= 0
			then return;
			f.b_descr = zero_descr;	/* now 2nd one is first */
			status_list_ctl_entry.f_descr = f_descr;
		     end;
		else if unspec (f_descr) = unspec (zero_descr)
		then do;				/* last one in list */
			call seek_descr (b_descr, b_rs_ptr, b_ptr);
			if a_code ^= 0
			then return;
			b.f_descr = zero_descr;	/* second to last now last */
			status_list_ctl_entry.b_descr = b_descr;
		     end;

/* message to be deleted is in middle of the list */

		else do;
			call seek_descr (b_descr, b_rs_ptr, b_ptr);
			if a_code ^= 0
			then return;
			call seek_descr (f_descr, f_rs_ptr, f_ptr);
			if a_code ^= 0
			then return;

			b.f_descr = f_descr;	/* link ones on each side together */
			f.b_descr = b_descr;
		     end;
	     end;

zero_c_descr:
	c.f_descr, c.b_descr = zero_descr;		/* zero out for clean job */
	status_list_ctl_entry.count = status_list_ctl_entry.count - 1;

	a_code = 0;
	return;

     end /* unlink_descr */;

/*  */

set_descr:
     proc ();

	queue_ctl_eptr = a_queue_ctl_eptr;
	iocb_ptr = a_iocb_ptr;
	descr_ptr = a_descr_ptr;
	c_descr = a_descr;

	call seek_descr (c_descr, c_rs_ptr, c_ptr);
	return;

     end /* set_descr */;

/* */

check_msg_status:
     proc (x_status);

dcl	x_status		fixed bin;

	a_code = cmcs_error_table_$bad_call_parm;
	if x_status < 1 | x_status > 4
	then return;
	if c.msg_status ^= x_status
	then return;

	a_code = 0;
	return;

     end /* check_msg_status */;

/* */

seek_descr:
     proc (x_descr, x_rs_ptr, x_ptr);

/* uses vfile_ record_status control to find messages by their vfile_ descriptor */

dcl	1 x_descr		like vfile_descr,
	x_rs_ptr		ptr,
	x_ptr		ptr;

dcl	1 x_rs		like vfile_rs based (x_rs_ptr);

dcl	1 x		like msg_hdr based (x_ptr);

	x_rs.descr = x_descr;			/* maybe redundant sometimes, but consistent */
	call iox_$control (iocb_ptr, "record_status", x_rs_ptr, a_code);
	if a_code ^= 0
	then do;					/* bad news, should never happen */
		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		     "Attempting to use record_status control order to locate descriptor ^d.^d.", x_rs.descr.comp_no,
		     fixed (x_rs.descr.comp_offset, 18));
		x_ptr = null ();
	     end;
	else x_ptr = x_rs.rec_ptr;

	return;

     end /* seek_descr */;

/* */

init_ptrs:
     proc ();

	b_descr_ptr = addr (b_descr);
	c_descr_ptr = addr (c_descr);
	f_descr_ptr = addr (f_descr);

	b_rs_ptr = addr (b_rs);
	c_rs_ptr = addr (c_rs);
	f_rs_ptr = addr (f_rs);

	overlay_len = size (b_rs);
	b_rs_ptr -> overlay (*) = 0;
	c_rs_ptr -> overlay (*) = 0;
	c_rs_ptr -> overlay (*) = 0;

	b_rs.locate_sw = "1"b;

	c_rs.locate_sw = "1"b;

	f_rs.locate_sw = "1"b;

	b_rs.version, c_rs.version, f_rs.version = vfile_rs_version;

	zero_descr_ptr = addr (zero);

	init_ptrs_sw = "1"b;
	return;

     end /* init_ptrs */;

/* */

setup:
     proc;


	user_ctl_ptr = external_user_ctl_ptr;		/* set local variable from global */

	queue_ctl_ptr = user_ctl.queue_ctl_ptr;

	call init_ptrs;				/* setup, part two */

	user_ctl.init_sw.status_list_ctl = "1"b;	/* do this only once */
	a_code = 0;
	return;

     end /* setup */;

test:
     entry ();

	test_sw = "1"b;
	return;

     end /* cmcs_status_list_ctl_ */;




		    cmcs_terminal_ctl_.pl1          05/24/89  1047.9rew 05/24/89  0834.0       22797



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_terminal_ctl_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.3 */

/* format: style3 */
cmcs_terminal_ctl_:
     proc;					/* must never enter here */

/* This COBOL MCS subroutine is used to obtain the default station_name for a given terminal subchannel (device_channel) */

/* Bob May, 5/31/77 */

	return;

/* */

dcl	a_device_channel	char (8),
	a_station_name	char (12),
	a_code		fixed bin (35);

dcl	my_name		char (18) init ("cmcs_terminal_ctl_");

%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_terminal_ctl;
%include cmcs_user_ctl;

dcl	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));

dcl	get_pdir_		entry () returns (char (168));

dcl	(ioa_, com_err_)	entry options (variable);


dcl	i		fixed bin (35);

dcl	(cmcs_error_table_$bad_term_devchn)
			fixed bin (35) external;

find:
     entry (a_device_channel, a_station_name, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.terminal_ctl)
	then do;
		user_ctl_ptr = external_user_ctl_ptr;
		terminal_ctl_ptr = user_ctl.terminal_ctl_ptr;
		user_ctl.init_sw.terminal_ctl = "1"b;
	     end;

	do i = 1 to terminal_ctl.current_size;
	     if ^terminal_ctl.inactive_sw (i)
	     then if terminal_ctl.device_channel (i) = a_device_channel
		then do;
			a_station_name = terminal_ctl.station_name (i);
			a_code = 0;
			return;
		     end;
	end;

	a_station_name = "Undefined!";
	a_code = cmcs_error_table_$bad_term_devchn;
	return;

     end /* cmcs_terminal_ctl_ */;




		    cmcs_tree_ctl_.pl1              05/24/89  1047.9rew 05/24/89  0834.0       45504



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cmcs_tree_ctl_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 05/05/81 by FCH, [4.4-3], entry name find_qual_name added, BUG468 */
/* Modified on 05/05/81 by FCH, [4.4-2], destination name may be any primitive node name, BUG468 */
/* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */
/* Modified since Version 4.3 */

/* format: style3 */
cmcs_tree_ctl_:
     proc;

	return;					/* invalid_entrypoint */

/* This COBOL MCS subroutine is used to find and process the various
   entries in cmcs_tree_ctl.control segment. */

/* Bob May, 6/30/77 */

dcl	a_dest		char (12),
	a_index		fixed bin,
	a_eptr		ptr,
	a_count		fixed bin,
	a_code		fixed bin (35),
	a_input_cdptr	ptr;

dcl	(i, j)		fixed bin,
	full_tree_path	char (48);

/* Internal Static */



dcl	(addr, null, string)
			builtin;

/*  */
%include cmcs_cd_dcls;
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_tree_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;
/*  */
find_destination:
     entry (a_dest, a_index, a_eptr, a_code);

/*[4.4-2]*/
declare	ch48		char (48),
	loc		fixed bin;

/*[4.4-3]*/
	call find_name;

/*[4.4-3]*/
	return;

find_name:
     proc;

/*[4.4-1]*/
	call setup;

	do i = 1 to tree_ctl.current_size;

/*[4.4-2]*/
	     tree_ctl_eptr = addr (tree_ctl.entries (i)); /*[4.4-2]*/
	     ch48 = string (tree_ctl_entry.tree_path);	/*[4.4-2]*/
	     loc = index (ch48, a_dest);

/*[4.4-2]*/
	     if loc > 0				/*[4.4-2]*/
	     then if a_dest = substr (ch48, loc)	/*[4.4-2]*/
		then do;
			a_index = i;		/*[4.4-2]*/
			a_eptr = tree_ctl_eptr;	/*[4.4-2]*/
			a_code = 0;

/*[4.4-2]*/
			return;			/*[4.4-2]*/
		     end;

	end;

	a_index = 0;				/* didn't find it */
	a_eptr = null ();
	a_code = cmcs_error_table_$bad_dest;

     end;

find_qual_name:
     entry (a_dest, a_index, a_eptr, qn, a_code);

/*[4.4-3]*/
	call find_name;				/*[4.4-3]*/
	if a_code ^= 0
	then return;

/*[4.4-3]*/
	call form_qual_name;

/*[4.4-3]*/
	qn = qual_name;

/*[4.4-3]*/
	return;

/*[4.4-3]*/
declare	blank_pos		fixed bin;		/*[4.4-3]*/
declare	qual_name		char (52) varying;		/*[4.4-3]*/
declare	qn		char (52);

form_qual_name:
     proc;

/*[4.4-3]*/
	qual_name = "";

/*[4.4-3]*/
	call qual_comp (1);

/*[4.4-3]*/
	if blank_pos ^= 1				/*[4.4-3]*/
	then do;
		call qual_comp (13);

/*[4.4-3]*/
		if blank_pos ^= 1			/*[4.4-3]*/
		then do;
			call qual_comp (25);

/*[4.4-3]*/
			if blank_pos ^= 1
			then call qual_comp (37);	/*[4.4-3]*/
		     end;				/*[4.4-3]*/
	     end;
     end;

qual_comp:
     proc (pos);

/*[4.4-3]*/
declare	pos		fixed bin;

/*[4.4-3]*/
	blank_pos = index (substr (ch48, pos, 12), " ");

/*[4.4-3]*/
	if blank_pos = 1
	then return;

/*[4.4-3]*/
	if blank_pos = 0
	then blank_pos = 13;

/*[4.4-3]*/
	if qual_name ^= ""
	then qual_name = qual_name || ".";

/*[4.4-3]*/
	qual_name = qual_name || substr (ch48, pos, blank_pos - 1);

     end;

find_index:
     entry (a_index, a_eptr, a_code);

/*[4.4-1]*/
	call setup;

	if a_index <= tree_ctl.current_size
	then do;

		tree_ctl_eptr = addr (tree_ctl.entries (a_index));

		if ^tree_ctl_entry.inactive_sw
		then do;

			a_eptr = tree_ctl_eptr;
			a_code = 0;

			return;

		     end;
	     end;

	a_eptr = null ();
	a_code = cmcs_error_table_$bad_dest;

	return;

/* end of find_index entrypoint */

find_tree_path:
     entry (a_input_cdptr, a_index, a_count, a_eptr, a_code);

/*[4.4-1]*/
	call setup;

	full_tree_path = string (a_input_cdptr -> input_cd.tree_path);

	do i = 1 to tree_ctl.current_size;

	     tree_ctl_eptr = addr (tree_ctl.entries (i));

	     if ^tree_ctl_entry.inactive_sw
	     then if full_tree_path = string (tree_ctl_entry.tree_path)
		then do;

			a_index = i;
			a_count = tree_ctl_entry.subtree_count;
			a_eptr = tree_ctl_eptr;
			a_code = 0;

			return;

		     end;
	end;

	a_index, a_count = 0;			/* didn't find it */
	a_eptr = null ();
	a_code = cmcs_error_table_$bad_queue_path;	/* ---- */

	return;

/* end of find_tree_path entrypoint */

setup:
     proc;

/*[4.4-1]*/
	if (external_user_ctl_ptr -> user_ctl.init_sw.tree_ctl)
	then return;

	user_ctl_ptr = external_user_ctl_ptr;		/* set local variable from global */

	tree_ctl_ptr = user_ctl.tree_ctl_ptr;
	user_ctl.init_sw.tree_ctl = "1"b;

	a_code = 0;

     end /* setup */;

     end /* cmcs_tree_ctl_ */;




		    cmcs_wait_ctl_.pl1              05/24/89  1047.9rew 05/24/89  0834.1      191556



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8087),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8087 cmcs_wait_ctl_.pl1 Shorten wait time for cmcs_station_ctl_.
                                                   END HISTORY COMMENTS */


/* Modified on 10/20/84 by FCH, [5.3-1], BUG565(phx18385), wait time for set_lock_$lock */
/* Modified since Version 4.3 */




/* format: style3 */
cmcs_wait_ctl_:
     proc;

	return;					/* bad entrypoint */

/* This COBOL MCS subroutine is used to manage the wait control lists. The lists
   are linked forward and backward by entry index. All additions are done at the end of the list.
   Deletions can occur anywhere. Lists are always searched from the beginning,
   in order to serve requests on a first-come, first-served (when appropriate) basis.

   Note: the wait_ctl.current_size is not decremented even when the last physical entry of the segment
   is deleted. The entry is just added to the free list. The segment will never have more entries
   than the maximum number of concurrent users, so it will never grow to unreasonable size. */

/* Bob May, 6/30/77 */

/* DEBUG dcls */

dcl	(sub_err_, ioa_)	entry options (variable);

dcl	sub_err_retval	fixed bin (35);		/* dummy for sub_err_ */

/* input/output parameters */

dcl	a_tree_path	char (48),
	a_index		fixed bin,
	a_queue_ctl_eptr	ptr,
	a_wait_ctl_mp_eindex
			fixed bin,
	a_tree_ctl_eindex	fixed bin,
	a_code		fixed bin (35);

/* variables to manipulate entries */

dcl	(c_ptr, b_ptr, f_ptr)
			ptr,
	(c_index, b_index, f_index)
			fixed bin,
	1 c		like wait_ctl_entry based (c_ptr),
						/* "current" entry */
	1 b		like wait_ctl_entry based (b_ptr),
						/* entry before current entry */
	1 f		like wait_ctl_entry based (f_ptr);
						/* entry following current entry */

dcl	i		fixed bin,
	new_index		fixed bin;		/* additional FB to process entry indices */

dcl	code		fixed bin (35);

dcl	my_name		char (14) int static init ("cmcs_wait_ctl_");

dcl	test_sw		bit (1) int static init ("0"b);

dcl	(
	free_flag		init ("1"b),
	used_flag		init ("0"b)
	)		bit (1) aligned int static options (constant);

dcl	get_process_id_	entry () returns (bit (36) aligned);

dcl	hcs_$wakeup	entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)),
	ipc_$create_ev_chn	entry (fixed bin (71), fixed bin (35)),
	ipc_$block	entry (ptr, ptr, fixed bin (35));

dcl	error_table_$action_not_performed
			fixed bin (35) external;

dcl	(addr, null, string)
			builtin;

/*  */
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_queue_ctl;
%include cmcs_tree_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;
%include cmcs_wait_ctl;
/*  */
add:
     entry (a_tree_path, a_index, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

	call lock;
	if a_code ^= 0
	then return;

	call get_free_index (a_index);

	wait_ctl_eptr = addr (wait_ctl.entries (a_index));
	wait_ctl_entry.rcv_process_id = get_process_id_ ();
						/* set owner info */
	string (wait_ctl_entry.rcv_tree_path) = a_tree_path;
	wait_ctl_entry.ev_wait_chn = user_ctl.ev_wait_chn;

	call link_index (a_index, used_flag);
	call unlock;

	if test_sw
	then call ioa_ ("Now going to sleep.");

/* Code to go to sleep until wakeup goes here */

	call ipc_$block (user_ctl.ev_wait_list_ptr, user_ctl.ev_info_ptr, a_code);

	return;

/* end of add entrypoint */

find:
     entry (a_tree_path, a_queue_ctl_eptr, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

	queue_ctl_eptr = a_queue_ctl_eptr;

	call lock;
	if a_code ^= 0
	then return;

	call find_index (new_index);
	if a_code ^= 0				/* First check to see if COBOL program waiting */
	then do;
		if a_code ^= cmcs_error_table_$no_message
		then do;				/* should never happen */
			call unlock;
			return;
		     end;

/* Drop-through means that no COBOL program was waiting */

		tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex;
						/* should we notify an mp? */
		tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));

		if (tree_ctl_entry.mp_sw | tree_ctl_entry.cobol_program_id_sw)
						/* don't bother unless there is some thing to do */
		then if wait_ctl.mp_info.mp_active_count > 0
		     then do wait_ctl_mp_eindex = 1 to wait_ctl.mp_current_size;
			     wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));
			     if wait_ctl_mp_entry.process_id ^= (36)"0"b
			     then if wait_ctl_mp_entry.available_sw
						/* found waiting mp */
				then do;
					wait_ctl_mp_entry.available_sw = "0"b;
					wait_ctl_mp_entry.ev_message = 0;
						/* unused for the present */
					wait_ctl_mp_entry.tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex;
					call hcs_$wakeup (wait_ctl_mp_entry.process_id,
					     wait_ctl_mp_entry.ev_wait_chn, 0, code);
					if code ^= 0
					then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
						"Attempting to send wakeup to message processor (^w). Continuing.",
						wait_ctl_mp_entry.process_id);
					go to find_mp_ret;
				     end;
			end;

/* Drop-through means no message processors available either */

find_mp_ret:
		call unlock;
		a_code = 0;
		return;
	     end;

/* Got to here, so we found a COBOL program that was waiting on a receive */

	tree_ctl_eindex, c.tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex;

	tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));
	string (c.abs_tree_path) = string (tree_ctl_entry.tree_path);
	c.queue_ctl_eindex = tree_ctl_entry.queue_ctl_eindex;
	c.queue_name = tree_ctl_entry.queue_name;
	c.ev_message = 0;

	wait_ctl_eptr = addr (wait_ctl.entries (new_index));

	if test_sw
	then do;
		call ioa_ ("wait_ctl_$wakeup:^-^a, ^p", a_tree_path, a_queue_ctl_eptr);
						/* DEBUG */
		call ioa_ ("^2-^a.", string (wait_ctl_entry.rcv_tree_path));
						/* DEBUG */
	     end;

	call hcs_$wakeup (wait_ctl_entry.rcv_process_id, wait_ctl_entry.ev_wait_chn, 0, a_code);
						/* 0 says process message */
	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		"Attempting to send wakeup to waiting process. Continuing.");
	call unlock;

	return;

/* end of find entrypoint */

/*  */

delete:
     entry (a_index, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

	wait_ctl_eptr = addr (wait_ctl.entries (a_index));
	if get_process_id_ () = wait_ctl_entry.rcv_process_id
	then do;
		call lock;
		if a_code ^= 0
		then return;
		call unlink_index (a_index, used_flag);
		call link_index (a_index, free_flag);	/* keep it for reuse */
		call unlock;
		a_code = 0;
	     end;
	else do;					/* wrong index */
		a_code = error_table_$action_not_performed;
	     end;

	return;

/* end of delete entrypoint */

/*  */
link_index:
     proc (x_index, x_free_flag);

dcl	x_index		fixed bin,
	x_free_flag	bit (1) aligned;

	c_index = x_index;
	c_ptr = addr (wait_ctl.entries (c_index));
	c.findex = 0;				/* new entry always added at (logical) end */

	if x_free_flag
	then do;					/* added to free list */
		b_index = wait_ctl.free.bindex;
		if b_index = 0
		then do;				/* new entry is only entry */
			wait_ctl.free.bindex, wait_ctl.free.findex = c_index;
			c.bindex = 0;		/* new, only entry can only point back to hdr */
		     end;
		else do;
			b_ptr = addr (wait_ctl.entries (b_index));
			b.findex = c_index;		/* make old last entry point forward to new, only one */
			c.bindex = b_index;		/* point back to old last entry */
			wait_ctl.free.bindex = c_index;
						/* now points to new, only entry */
		     end;
		c.entry_status = 0;			/* free */
		wait_ctl.free.count = wait_ctl.free.count + 1;
	     end;
	else do;					/* added to used list */
		b_index = wait_ctl.used.bindex;
		if b_index = 0
		then do;				/* new, only entry is only entry */
			wait_ctl.used.bindex, wait_ctl.used.findex = c_index;
			c.bindex = 0;		/* new, only entry can only point back to hdr */
		     end;
		else do;
			b_ptr = addr (wait_ctl.entries (b_index));
			b.findex = c_index;		/* make old last entry point forward to new one */
			c.bindex = b_index;		/* point back to old last entry */
			wait_ctl.used.bindex = c_index;
						/* now points to new last entry */
		     end;
		c.entry_status = 1;			/* used */
		wait_ctl.used.count = wait_ctl.used.count + 1;
	     end;

	return;

     end /* link_index */;

/*  */
unlink_index:
     proc (x_index, x_free_flag);

dcl	x_index		fixed bin,
	x_free_flag	bit (1) aligned;

	c_index = x_index;
	c_ptr = addr (wait_ctl.entries (c_index));
	b_index = c.bindex;
	f_index = c.findex;
	if b_index = 0
	then if x_free_flag				/* current is first record (logically) following hdr */
	     then wait_ctl.free.findex = f_index;	/* free list */
	     else wait_ctl.used.findex = f_index;	/* used list */
	else do;					/* current was not the 1st record following hdr */
		b_ptr = addr (wait_ctl.entries (b_index));
		b.findex = f_index;
	     end;
	if f_index = 0
	then if x_free_flag				/* current is last record in one list or the other */
	     then wait_ctl.free.bindex = b_index;	/* free list */
	     else wait_ctl.used.bindex = b_index;	/* used list */
	else do;					/* current was not last entry in list */
		f_ptr = addr (wait_ctl.entries (f_index));
		f.bindex = b_index;
	     end;

	if x_free_flag
	then wait_ctl.free.count = wait_ctl.free.count - 1;
	else wait_ctl.used.count = wait_ctl.used.count - 1;

	c.findex, c.bindex = 262143;			/* 777777, easy to spot unlinked entries */

	return;

     end /* unlink_index */;

/*  */

find_index:
     proc (x_index);

dcl	x_index		fixed bin;		/* output, 0 if none found */

dcl	x_level_names	(4) char (12) based (addr (a_tree_path));

	if wait_ctl.used.count = 0
	then go to not_found;			/* don't look any further */

	c_index = wait_ctl.used.findex;


find_index_loop:
	if c_index = 0				/* will never happen 1st time through */
	then go to not_found;			/* we exhausted the list without an appropriate match */

	c_ptr = addr (wait_ctl.entries (c_index));
	if x_level_names (1) = c.rcv_tree_path.level_names (1)
	then do i = 2 to 4;				/* there's hope, check the rest */
		if c.rcv_tree_path.level_names (i) = ""
		then go to found;			/* req was for higher level, which is fine */
		if x_level_names (i) ^= c.rcv_tree_path.level_names (i)
		then go to find_index_continue;	/* doesn't agree at higher levels, forget it */
	     end;

find_index_continue:
	c_index = c.findex;
	go to find_index_loop;

found:
	x_index = c_index;
	a_code = 0;
	return;

not_found:
	x_index = 0;
	a_code = cmcs_error_table_$no_message;
	return;

     end /* find_index */;

/*  */
setup:
     proc;

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then do;

		user_ctl_ptr = external_user_ctl_ptr;	/* set local variable from global */

		queue_ctl_ptr = user_ctl.queue_ctl_ptr;
		tree_ctl_ptr = user_ctl.tree_ctl_ptr;
		wait_ctl_ptr = user_ctl.wait_ctl_ptr;

		user_ctl.init_sw.wait_ctl = "1"b;
	     end;

	a_code = 0;

	return;

     end /* setup */;

/* */

get_free_index:
     proc (x_index);				/* caller must link back in */

dcl	x_index		fixed bin;

	if wait_ctl.free.count = 0
	then do;					/* this is the easy way */
		x_index, wait_ctl.current_size, wait_ctl.entry_count = wait_ctl.current_size + 1;
	     end;
	else do;
		x_index = wait_ctl.free.findex;	/* take the first one */
		call unlink_index (x_index, free_flag); /* let caller link it to used list */
	     end;

	return;

     end /* get_free_index */;


/*  */

mp_login:
     entry (a_wait_ctl_mp_eindex, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

	if user_ctl.ev_wait_chn = 0 | user_ctl.process_id = (36)"0"b
	then do;
		a_code = cmcs_error_table_$bad_call_parm;
mp_err:
		a_wait_ctl_mp_eindex = -1;		/* if they try to use it, we'll blow */
		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		     "Error found in message processor login control info. Returning to caller.");
		return;
	     end;

	call mp_lock;
	if a_code ^= 0
	then return;

/* First check to see if mp is already logged in */

	if wait_ctl.mp_current_size > 0
	then do;
		do i = 1 to wait_ctl.mp_current_size;
		     wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (i));
		     if wait_ctl_mp_entry.process_id = user_ctl.process_id
		     then do;
			     call mp_unlock;
			     a_code = cmcs_error_table_$bad_call_parm;
			     go to mp_err;
			end;
		end;

/* So far, so good. Now, do we have any open slots already? */

		do wait_ctl_mp_eindex = 1 to wait_ctl.mp_info.mp_current_size;
		     wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));
		     if wait_ctl_mp_entry.process_id = (36)"0"b
		     then do;
set_mp_info:
			     string (wait_ctl_mp_entry.flags) = (36)"0"b;
			     wait_ctl_mp_entry.ev_wait_chn = user_ctl.ev_wait_chn;
			     wait_ctl_mp_entry.process_id = user_ctl.process_id;
			     wait_ctl.mp_info.mp_active_count = wait_ctl.mp_info.mp_active_count + 1;
			     a_wait_ctl_mp_eindex = wait_ctl_mp_eindex;
						/* all future calls will use this index */
			     call mp_unlock;
			     a_code = 0;
			     return;
			end;
		end;
	     end;

/* Got to here, so we must increase the current size of the table for the new entry */

	if wait_ctl.mp_info.mp_current_size < 10
	then do;
		wait_ctl_mp_eindex, wait_ctl.mp_info.mp_current_size = wait_ctl.mp_info.mp_current_size + 1;
		wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));
		go to set_mp_info;
	     end;

	else do;					/* already have 10 message processors */
		a_code = error_table_$action_not_performed;
		go to mp_err;
	     end;

/* end of mp_login entrypoint */

/* */

mp_available:
     entry (a_wait_ctl_mp_eindex, a_tree_ctl_eindex, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

/* No need to use mp_lock because entry is ignored until we set the available_sw true */

	wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (a_wait_ctl_mp_eindex));
	wait_ctl_mp_entry.available_sw = "1"b;

	call ipc_$block (user_ctl.ev_wait_list_ptr, user_ctl.ev_info_ptr, a_code);
	return;

/* end of mp_available entrypoint */

/* */

mp_logout:
     entry (a_wait_ctl_mp_eindex, a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

	wait_ctl_mp_eindex = a_wait_ctl_mp_eindex;
	wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));

	call mp_lock;
	if a_code ^= 0
	then return;

	wait_ctl_mp_entry.process_id = (36)"0"b;
	wait_ctl_mp_entry.ev_wait_chn = 0;
	string (wait_ctl_mp_entry.flags) = (36)"0"b;
	if wait_ctl.mp_info.mp_active_count ^= 0
	then wait_ctl.mp_info.mp_active_count = wait_ctl.mp_info.mp_active_count - 1;

	if wait_ctl_mp_eindex = wait_ctl.mp_info.mp_current_size
	then wait_ctl.mp_info.mp_current_size = wait_ctl.mp_info.mp_current_size - 1;

	call mp_unlock;
	a_code = 0;
	return;

/* end of mp_logout entrypoint */

/*  */

clear_mp:
     entry (a_code);

/* Used to force a reset to zero of the message processor control information.
   This is necessary in case of a crash with active message processors. */

/*[5.3-1]*/
	call cmcs_set_lock_$lock (wait_ctl.hdr.lockword, 0, a_code);
	if a_code ^= 0
	then do;
		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		     "Attempting to set lock in preparation for clear_mp request. Returning to request level.");
		return;
	     end;

	if wait_ctl.mp_info.mp_active_count > 0
	then call sub_err_ (0, my_name, "c", null (), sub_err_retval,
		"Active message processor count reset from ^d to 0.", wait_ctl.mp_info.mp_active_count);

	do i = 1 to 10;
	     wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (i));
	     wait_ctl_mp_entry.process_id = (36)"0"b;
	     string (wait_ctl_mp_entry.flags) = (36)"0"b;
	end;
	wait_ctl.mp_info.mp_active_count, wait_ctl.mp_info.mp_current_size = 0;
	call cmcs_set_lock_$unlock (wait_ctl.mp_info.mp_lockword, a_code);
						/* ignore status */

	a_code = 0;
	return;

/* end of clear_mp entrypoint */

/* */

start_mp:
     entry (a_code);

/* Used to wakeup message processors explicitly because the queues are already non-empty.
   The message processors must already be logged in and available. */

	do queue_ctl_eindex = 1 to queue_ctl.current_size;
	     queue_ctl_eptr = addr (queue_ctl.entries (queue_ctl_eindex));
	     if queue_ctl_entry.status_list_ctl_entries (2).count > 0
	     then do;				/* messages waiting to be processed */
		     tree_ctl_eindex = queue_ctl_entry.tree_ctl_eindex;
		     tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));
						/* needed for getting short queue name in case of trouble */
		     call start_next_mp;
		     if a_code ^= 0
		     then return;
		end;
	end;

	return;

/* end of start_mp entrypoint */

/* */

stop_mp:
     entry (a_code);

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.wait_ctl)
	then call setup;

	call mp_lock;
	if a_code ^= 0
	then return;

/* Send a wakeup with a message of 1 to all mps. All will get this either immediately or the next time they go blocked */

	if wait_ctl.mp_info.mp_active_count > 0
	then do wait_ctl_mp_eindex = 1 to wait_ctl.mp_info.mp_current_size;
		wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));
		if wait_ctl_mp_entry.process_id ^= (36)"0"b
		then do;
			call hcs_$wakeup (wait_ctl_mp_entry.process_id, wait_ctl_mp_entry.ev_wait_chn, 1, a_code);
						/* 1 says to logout */
			if a_code ^= 0
			then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
				"Attempting to send wakeup to tell process (^b) to log out. Continuing.",
				wait_ctl_mp_entry.process_id);
		     end;
	     end;
	call mp_unlock;
	a_code = 0;
	return;

/* end of stop_mp entrypoint */

/*  */

start_next_mp:
     proc ();

/* Finds the next available message processor and sends it a wakeup. It will complain if none are available,
   rather than sending multiple wakeups to a single process. */

dcl	old_wait_ctl_mp_eindex
			fixed bin int static init (0);/* To make sure we don't just continue looping */

	if old_wait_ctl_mp_eindex = 0
	then wait_ctl_mp_eindex, old_wait_ctl_mp_eindex = 1;
						/* first time through, initialize */

	do i = 1 to wait_ctl.mp_info.mp_current_size;
	     wait_ctl_mp_eindex = wait_ctl_mp_eindex + 1;
	     if wait_ctl_mp_eindex > wait_ctl.mp_info.mp_current_size
	     then wait_ctl_mp_eindex = 1;		/* don't overflow the table entries */
	     if wait_ctl_mp_eindex = old_wait_ctl_mp_eindex
	     then do;				/* didn't finnd an available mp */
		     a_code = error_table_$action_not_performed;
		     call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
			"Couldn't find an available message processor to start for ^a.", tree_ctl_entry.queue_name);
						/* without the suffix */
		     return;
		end;

	     wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));
	     if wait_ctl_mp_entry.process_id ^= (36)"0"b
	     then if wait_ctl_mp_entry.available_sw
		then do;
			call hcs_$wakeup (wait_ctl_mp_entry.process_id, wait_ctl_mp_entry.ev_wait_chn, 0, a_code);
			if a_code ^= 0
			then do;
				call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
				     "Attempting to send wakeup to message processor for queue ^a.",
				     tree_ctl_entry.queue_name);
				return;
			     end;
			else do;
				wait_ctl_mp_entry.available_sw = "0"b;
						/* now this one is busy */
				call sub_err_ (0, my_name, "c", null (), sub_err_retval,
				     "Started message processor for queue ^a.", tree_ctl_entry.queue_name);
			     end;
		     end;
	end;

	a_code = 0;
	return;

     end /* start_next_mp */;

/*  */

test:
     entry;

	test_sw = "0"b;
	return;

/* end of test entrypoint */

/* */

lock:
     proc;

/*[5.3-1]*/
	call cmcs_set_lock_$lock (wait_ctl.hdr.lockword, 0, a_code);
	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to lock wait control.");
	return;

     end /* lock */;

/* */

mp_lock:
     proc;

/*[5.3-1]*/
	call cmcs_set_lock_$lock (wait_ctl.mp_lockword, 0, a_code);
	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		"Attempting to lock message processor wait control.");
	return;

     end /* mp_lock */;

/* */

unlock:
     proc;

	call cmcs_set_lock_$unlock (wait_ctl.hdr.lockword, a_code);
	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval, "Attempting to unlock wait control.");
	return;

     end /* unlock */;

/* */

mp_unlock:
     proc;

	call cmcs_set_lock_$unlock (wait_ctl.mp_lockword, a_code);
	if a_code ^= 0
	then call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		"Attempting to unlock message processor wait control.");
	return;

     end /* mp_unlock */;

     end /* cmcs_wait_ctl_ */;




		    cobol_mcs.pl1                   05/24/89  1047.9rew 05/24/89  0834.1      391707



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_mcs.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/17/82 by FCH, [5.2-1], eliminate need for copy switch by using temp seg, BUG530 */
/* Modified on 07/21/81 by FCH, [4.4-9], ..command added, BUG468 */
/* Modified on 06/02/81 by FCH, [4.4-8], initialization, BUG468 */
/* Modified on 06/01/81 by FCH, [4.4-7], on command_abort_ added, BUG468 */
/* Modified on 05/05/81 by FCH, [4.4-5], attach and detach commands added, BUG468 */
/* Modified on 05/01/81 by FCH, [4.4-3], all option on receive added, BUG468 */
/* Modified on 04/23/81 by FCH, [4.4-1], delete final new-line from send buffer, BUG468 */
/* Modified since Version 4.3 */






/* format: style3 */
cmcs:
cobol_mcs:
     procedure options (separate_static);

/* This COBOL MCS command is used to intialize the process environment
   for subsequent CMCS processing. For "CMCS terminals", it will enter
   request mode, and allow the user to essentially duplicate the COBOL program
   MCS functions through the request interface.
*/

/* Bob May, 5/31/77 */

dcl	(i, j)		fixed bin,
	dname		char (168),
	ename		char (32),
	char_delim	char (1),
	io_subtype	fixed bin,
	rcv_tree_path	char (48) init (""),
	code		fixed bin (35),
	my_name		char (16),		/* either cobol_mcs or cobol_mcs_admin */
	my_brief_name	char (8),			/* for whoami */
	(password1, password2)
			char (10);

dcl	station_name	char (12),
	dest_table_index	fixed bin,
	err_sw		bit (1) init ("0"b);

dcl	output_cd_size	fixed bin;		/* temp output CD stuff, to get started */

dcl	output_cd_area	(output_cd_size) fixed bin based (output_cdp);

dcl	ptr_array		(1) ptr;			/* for get, release temp segments */

dcl	overlay_len	fixed bin,		/* for structure initialization */
	overlay		(overlay_len) fixed bin based;

dcl	buffer_len	fixed bin (21),
	buffer_max_len	fixed bin (21),
	buffer_ptr	ptr,
	buffer		char (256);


dcl	send_buffer_ptr	ptr,
	send_buffer_max_len fixed bin (21),
	send_buffer_len	fixed bin (35),		/* actual number of chars in temp buffer */
	char_send_buffer_len
			pic "9999",
	send_buffer	char (send_buffer_max_len) based (send_buffer_ptr);

/* Switches */

dcl	(scpsw_sw, interactive_sw)
			bit (1);

dcl	test_sw		bit (1) int static init ("0"b);

dcl	(cleanup, program_interrupt, command_abort_)
			condition;

dcl	term_id		char (4),
	term_type		fixed bin,
	term_channel	char (8);

dcl	command_count	fixed bin int static init (15);

dcl	1 command_list	int static,
	  2 brief		(15) char (8) init ("q",	/* 1 */
			"e",			/* 2 */
			"amc",			/* 3 */
			"r",			/* 4 */
			"s",			/* 5 */
			"ei",			/* 6 */
			"eit",			/* 7 */
			"eo",			/* 8 */
			"di",			/* 9 */
			"dit",			/* 10 */
			"do",			/* 11 */
			"p",			/* 12 */
			".",			/* 13 */
			"a",			/* 14 */
			"d"),			/* 15 */
	  2 long		(15) char (32) init ("quit",	/* 1 */
			"execute",		/* 2 */
			"accept_message_count",	/* 3 */
			"receive",		/* 4 */
			"send",			/* 5 */
			"enable_input",		/* 6 */
			"enable_input_terminal",	/* 7 */
			"enable_output",		/* 8 */
			"disable_input",		/* 9 */
			"disable_input_terminal",	/* 10 */
			"disable_output",		/* 11 */
			"purge",			/* 12 */
			".",			/* 13 */
			"activate",		/* 14 */
			"deactivate");		/* 15 */


dcl	admin_command_count fixed bin int static init (11);

dcl	1 admin_command_list
			int static,
	  2 brief		(11) char (8) init (".",	/* 1 */
			"q",			/* 2 */
			"e",			/* 3 */
			"test",			/* 4 */
			"ccpsw",			/* 5 */
			"scpsw",			/* 6 */
			"ccq",			/* 7 */
			"start_mp",		/* 8 (not currently used) */
			"stop_mp",		/* 9 */
			"clear_mp",		/* 10 */
			"purge_qs"),		/* 11 */
	  2 long		(11) char (32) init (".",	/* 1 */
			"quit",			/* 2 */
			"execute",		/* 3 */
			"test",			/* 4 */
			"change_cmcs_password",	/* 5 */
			"set_cmcs_password",	/* 6 */
			"create_cmcs_queues",	/* 7 */
			"start_mp",		/* 8 (not currently used) */
			"stop_mp",		/* 9 */
			"clear_mp",		/* 10 */
			"purge_queues");		/* 11 */

dcl	req		char (256),		/* request line input buffer */
	(req_arg_count, req_left_begin, req_left_len)
			fixed bin,
	req_len		fixed bin (21),		/* for use with iox_$get_line */
	req_cmd_ptr	ptr,
	req_cmd_len	fixed bin;

dcl	(cmd_parsed_sw, args_parsed_sw)
			bit (1);

dcl	max_arg_count	fixed bin int static options (constant) init (25);

dcl	1 arg_array	(25),
	  2 argp		ptr,
	  2 argl		fixed bin;


dcl	max_req_args	fixed bin int static options (constant) init (16);
						/* loop control */

dcl	whitespace	char (5) int static options (constant) init ("

");						/* b, HT, NL, VT, FF */


dcl	user_info_$absentee_queue
			entry (fixed bin),
	user_info_$tty_data entry (char (*), fixed bin, char (*)),
	absolute_pathname_	entry (char (*), char (*), fixed bin (35)),
	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35)),
	cu_$cp		entry (ptr, fixed bin, fixed bin (35)),
	read_password_	entry (char (*), char (*)),
	get_process_id_	entry () returns (bit (36)),
	get_wdir_		entry () returns (char (168)),
	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35)),
	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35)),
	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
	(
	ioa_,
	ioa_$rsnnl
	)		entry options (variable);	/*[5.2-1]*/
dcl	cmcs_initiate_ctl_$release
			entry (fixed bin (35));
dcl	(
	error_table_$action_not_performed,
	error_table_$long_record,
	error_table_$too_many_args,
	error_table_$wrong_no_of_args
	)		fixed bin (35) external;

dcl	(addr, char, fixed, null, search, size, string, substr, verify)
			builtin;			/*  */
%include cmcs_arg_processing;
%include cmcs_cd_dcls;
%include cmcs_cobol_mcs_dcls;
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_iox_processing;
%include cmcs_ipc_processing;
%include cmcs_station_ctl;
%include cmcs_system_ctl;
%include cmcs_terminal_ctl;
%include cmcs_tree_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;
%include cmcs_wait_ctl;

/*  */
/* cobol_mcs, cmcs only */

	my_name = "cobol_mcs";
	my_brief_name = "cmcs";

	call cu_$arg_count (arg_count);

	if arg_count < 2 | arg_count > 3
	then do;

print_usage:
		code = 0;

print_error_usage:
		call com_err_ (code, my_name, "^/Usage: cobol_mcs cmcs_dir -message_processor (-mp) <station_name>

or:    cobol_mcs cmcs_dir -terminal (-term) {<station_name>}");

		return;

	     end;

common_entry:
	call get_temp_segments_ ("cobol_mcs", ptr_array, code);

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "Attempting to create cmcs_user_ctl_.control in your process_dir.");
		return;
	     end;

	user_ctl_ptr = ptr_array (1);			/* now we can do something with it */

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

	if code ^= 0
	then go to print_error_usage;

	if arg = "-wd" | arg = "-working_dir"
	then dname = get_wdir_ ();
	else do;

		call absolute_pathname_ (arg, dname, code);
		if code ^= 0
		then go to print_error_usage;
	     end;

/* general initialization */

	buffer_ptr = addr (buffer);
	buffer_max_len = 4 * 16 * 1024;		/* terminal input arbitrarily limited to 16k chunks */

/*[4.4-5]*/
	user_ctl.attach_bit, user_ctl.rec = "0"b;
	d_stat_path = "";				/*[4.4-5]*/
	user_ctl.output_file = "";			/*[4.4-5]*/
	user_ctl.iocb_ptr = null ();			/*[4.4-5]*/
	IOCB_ptr = iox_$user_output;


/* clear all user_ctl data */

	overlay_len = size (user_ctl);
	user_ctl_ptr -> overlay (*) = 0;		/* clean slate */
						/*[4.4-8]*/
	string (user_ctl.init_sw) = "0"b;
	user_ctl.cmcs_dir, user_ctl.station_name, user_ctl.term_id, user_ctl.term_channel,
	     user_ctl.last_receive_info.tree_path, user_ctl.last_send_info.dest_name = "";
						/* so it isn't garbage if printed */

	user_ctl.last_receive_info.tree_ctl_eptr = null ();
	user_ctl.last_send_info.tree_ctl_eptr = null ();
	user_ctl.station_info.station_entries (*).station_ctl_eptr = null ();
	user_ctl.wait_info.wait_ctl_eptr = null ();	/* so we don't reference the dseg */

	user_ctl.cmcs_dir = dname;			/* start filling things in */

	external_user_ctl_ptr = user_ctl_ptr;		/* first reference */

	call cobol_mcs_$set_user_ctl_exists_sw ("1"b);	/* let the world know we're ready */
	call cmcs_initiate_ctl_ ("", null (), code);	/* just set all the ptrs in user_ctl, ma'am */

	if code ^= 0
	then do;

		external_user_ctl_ptr = null ();
		return;				/* cminit_ will print the error message */
	     end;

/* Drop-thru means that user_ctl has had all its control seg ptrs set by cminit_.
			   Now we all can get ptrs from user_ctl without using a call */

	queue_ctl_ptr = user_ctl.queue_ctl_ptr;		/* for admin and MPs */
	station_ctl_ptr = user_ctl.station_ctl_ptr;	/* for admin and MPs */
	system_ctl_ptr = user_ctl.system_ctl_ptr;	/* for admin and MPs */
	terminal_ctl_ptr = user_ctl.terminal_ctl_ptr;	/* for admin and MPs */
	tree_ctl_ptr = user_ctl.tree_ctl_ptr;		/* for admin and MPs */
	wait_ctl_ptr = user_ctl.wait_ctl_ptr;

	user_ctl.process_id = get_process_id_ ();

	call set_interactive_info;

	if my_brief_name = "cmcsa"
	then do;

		user_ctl.admin_sw = "1"b;
		user_ctl.process_type = 3;		/* admin process */
	     end;

	if my_name = "cobol_mcs"
	then do;					/* cobol_mcs only */

		call cu_$arg_ptr (2, arg_ptr, arg_len, code);
		if code ^= 0
		then go to print_error_usage;

		if arg = "-mp" | arg = "-message_processor"
		then do;

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

			if code ^= 0
			then go to print_error_usage;
			station_name = arg;
			user_ctl.mp_sw = "1"b;	/* we made it, user is a station */
			user_ctl.process_type = 1;	/* process is a CMCS message processor */
		     end;

		else if arg = "-term" | arg = "-terminal"
		then do;


			if ^interactive_sw
			then do;

				call com_err_ (0, my_name, "The terminal option must be used interactively.");
				go to print_usage;
			     end;

			if arg_count = 3
			then do;

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

				if code ^= 0
				then go to print_error_usage;

				station_name = arg;
			     end;
			else do;

				call cmcs_terminal_ctl_$find (term_channel, station_name, code);
				if code ^= 0
				then do;
					call com_err_ (code, my_name,
					     "Attempting to find your terminal subchannel in the cmcs_terminal_ctl.control segment."
					     );
					return;
				     end;
			     end;

			user_ctl.station_name = station_name;
			user_ctl.terminal_sw = "1"b;
			user_ctl.process_type = 2;	/* user is a CMCS terminal */
		     end;

		call cmcs_station_ctl_$attach (station_name, station_ctl_eindex, code);

		if code ^= 0
		then do;				/* station already taken */

			call com_err_ (code, my_name,
			     "Attempting to attach station ""^a"". Returning to command level.", station_name);
			return;
		     end;

		user_ctl.station_name = station_name;
		user_ctl.station_ctl_eindex = station_ctl_eindex;
						/* save for disable checks */

	     end;

/* Initialization for use as terminal */

	if user_ctl.terminal_sw
	then do;

		allocate input_cd;			/* fixed size, no problem */
		output_cd_size = 100;		/* can be increased later, if desired */
		allocate output_cd_area;
		output_cd.bin_max_station_count = 10;	/* artificial command-interface  limitation */
		output_cd.char_max_station_count = 10;	/* artificial command-interface  limitation */

		call get_temp_segments_ (my_name, ptr_array, code);

		if code ^= 0
		then do;
			call com_err_ (code, my_name, "Attempting to get temp seg for send buffer.");
			return;
		     end;

		send_buffer_ptr = ptr_array (1);	/* only using one */
		send_buffer_max_len = 9999;		/* max no of chars a COBOL program can send at one time */
	     end;

	if ^user_ctl.mp_sw
	then do;					/* they just abort */

/* check for interrupted operations */

		on program_interrupt /* for all modes of use */
		     begin;
			call ioa_ ("Returning to request level.");
			go to nonlocal_request;	/* nonlocal goto */
		     end;

/* catch any release stack */
/*[4.4-7]*/
		on command_abort_ go to nonlocal_return;
		on cleanup go to nonlocal_return;	/* for all modes of use */
	     end;

	user_ctl.initialized_sw = "1"b;

/* Station Processing */

	if ^user_ctl.admin_sw			/* everyone else may need this */
	then do;

/* Any checks to force use only as daemon should go here */

		call ipc_$create_ev_chn (user_ctl.ev_wait_chn, code);

		if code ^= 0
		then do;
			call com_err_ (code, my_name,
			     "Attempting to create an event wait channel. Returning to command level.");
			go to nonlocal_return;
		     end;

		ev_wait_list.n_chn = 1;
		ev_wait_list.ev_chn (1) = user_ctl.ev_wait_chn;
		ev_wait_list_ptr, user_ctl.ev_wait_list_ptr = addr (ev_wait_list);
		ev_info_ptr, user_ctl.ev_info_ptr = addr (ev_info);
	     end;

	if user_ctl.mp_sw
	then do;

		call cmcs_wait_ctl_$mp_login (user_ctl.wait_ctl_mp_eindex, code);

		if code ^= 0
		then do;
			call com_err_ (code, my_name,
			     "Attempting to add process to list of logged-in message processors. Returning to command level."
			     );
			go to nonlocal_return;
		     end;

/* We are logged in, but not yet available. Set ptr to mp wait entry for subsequent wakeup prcessing. */

		wait_ctl_mp_eindex = user_ctl.wait_ctl_mp_eindex;
						/* set working value from saved value */
		wait_ctl_mp_eptr = addr (wait_ctl.mp_info.mp_entries (wait_ctl_mp_eindex));

mp_loop:
		call cmcs_wait_ctl_$mp_available (user_ctl.wait_ctl_mp_eindex, tree_ctl_eindex, code);

/* wakeup with an available message, hopefully */

		if code ^= 0
		then do;

			call com_err_ (code, my_name,
			     "Attempting to add process to list of available message processors. Returning to command level."
			     );
			go to nonlocal_return;
		     end;

/* So far, so good. Now check the ev_message to see what we are supposed to do. If 0, we process a message.
   If 1, we log out. If anything else, we complain, and wait for the next wakeup. Ho hum, what a life! */

		if ev_info.ev_message = 1
		then do;

mp_logout:
			call ioa_ ("Message Processor (Station ^a) returning to command level.",
			     user_ctl.station_name);
			call cmcs_wait_ctl_$mp_logout (wait_ctl_mp_eindex, code);
						/* we don't want any more wakeups */

			if code ^= 0
			then call com_err_ (code, my_name,
				"Attempting to request an mp_logout for this process. Continuing to log out.");

			go to nonlocal_return;
		     end;

		else if ev_info.ev_message ^= 0
		then do;

			code = error_table_$action_not_performed;
			call com_err_ (code, my_name,
			     "Invalid event message  received in wakeup. Returning to mp_loop.");

			go to mp_loop;

		     end;

/* Drop-thru means we must process a message in some queue specified in the mp wait entry */

/* process the returned tree_ctl_eindex */

		tree_ctl_eindex = wait_ctl_mp_entry.tree_ctl_eindex;
						/* the tree_ctl_entry has all the necessary info */
		tree_ctl_eptr = addr (tree_ctl.entries (tree_ctl_eindex));

		if ^(tree_ctl_entry.mp_sw | tree_ctl_entry.cobol_program_id_sw)
		then do;

			code = error_table_$action_not_performed;

mp_cmd_err:
			call com_err_ (code, my_name,
			     "Error found in command line syntax or execution for ""^a"". Returning to mp_loop.");

			go to mp_loop;

		     end;

		call ioa_$rsnnl ("^a ^a ^a", buffer, buffer_len,
		     substr (tree_ctl_entry.mp_line, 1, tree_ctl_entry.mp_line_len),
		     substr (tree_ctl_entry.cobol_program_id, 1, tree_ctl_entry.cobol_program_id_len),
		     string (tree_ctl_entry.tree_path));

		call cu_$cp (addr (buffer), fixed (buffer_len, 17), code);

		if code ^= 0
		then do;

			call com_err_ (code, my_name, "Executing command line (^a).  Returning to mp_loop.",
			     substr (buffer, 1, buffer_len));
		     end;

		go to mp_loop;
	     end;					/* of station processing */

/*[4.4-5]*/
declare	1 info_structure	aligned,			/*[4.4-5]*/
	  2 ev_chain	fixed bin (71),		/*[4.4-5]*/
	  2 input_available bit (1);

/*[4.4-5]*/
declare	timer_manager_$sleep
			entry (fixed bin (71), bit (2));
						/*[4.4-5]*/
declare	info_ptr		ptr;			/*[4.4-5]*/
declare	IOCB_ptr		ptr;

delay:
     proc;

/*[4.4-5]*/
	info_ptr = addr (info_structure);



/*[4.4-5]*/
	do while ("1"b);

/*[4.4-5]*/
	     call timer_manager_$sleep (1, "11"b);	/* 1 sec delay */
						/*[4.4-5]*/
	     call iox_$control (iox_$user_input, "read_status", info_ptr, code);

/*[4.4-5]*/
	     if info_structure.input_available
	     then go to GL;

/*[4.4-5]*/
	     call rec_messages;

/*[4.4-5]*/
	end;

     end;

rec_messages:
     proc;

/*[4.4-5]*/
	char_delim = "2";				/*[4.4-5]*/
	io_subtype = 2;				/*[4.4-5]*/
	all_bit = "1"b;				/*[4.4-5]*/
	string (input_cd.tree_path) = d_stat_path;

/*[4.4-5]*/
	user_ctl.rec = "1"b;			/*[4.4-5]*/
	call rec;					/*[4.4-5]*/
	user_ctl.rec = "0"b;


     end;

/* NONLOCAL REQUEST */

nonlocal_request:
read_request:					/*[4.4-5]*/
	if my_brief_name = "cmcs"
	then if user_ctl.attach_bit
	     then call delay;



GL:
	call iox_$get_line (iox_$user_input, addr (req), 256, req_len, code);

	if code ^= 0
	then do;
		if code = error_table_$long_record
		then do;

			call com_err_ (code, my_name, "Request lines must be <= 256 characters. Please reenter.");
			go to read_request;
		     end;
		else do;				/* unexpected problem */

			call com_err_ (code, my_name, "Attempting to read a request line from user_input.");
			return;
		     end;
	     end;

	if req_len = 1
	then go to read_request;			/* just spacing down the terminal */

/*[4.4-9]*/
	if substr (arg, 1, 2) = ".."			/*[4.4-9]*/
	then do;
		req_left_begin = 3;			/*[4.4-9]*/
		req_left_len = req_len - 2;

/*[4.4-9]*/
		go to command (2);			/*[4.4-9]*/
	     end;

	cmd_parsed_sw, args_parsed_sw = "0"b;		/* flags to control parsing */
	req_left_begin = 1;
	req_left_len = req_len - 1;			/* forget the trailing NL */

	call get_req_cmd;				/* strip off the command */

	if user_ctl.process_type = 2
	then do;

		do i = 1 to command_count;		/* try the brief forms first */
		     if arg = command_list.brief (i)
		     then go to command (i);
		end;

		do i = 1 to command_count;		/* likes to type */
		     if arg = command_list.long (i)
		     then go to command (i);
		end;

	     end;

	else if user_ctl.process_type = 3
	then do;

		do i = 1 to admin_command_count;	/* try the brief forms first */
		     if arg = admin_command_list.brief (i)
		     then go to admin_command (i);
		end;

		do i = 1 to admin_command_count;	/* likes to type */
		     if arg = admin_command_list.long (i)
		     then go to admin_command (i);
		end;

	     end;

	call com_err_ (0, my_name, "Unrecognized command ""^a"". Please reenter request.", arg);

	go to read_request;


cmcsa:
cobol_mcs_admin:
     entry;

	my_name = "cobol_mcs_admin";
	my_brief_name = "cmcsa";

	call cu_$arg_count (arg_count);

	if arg_count ^= 1
	then do;					/* needs help */

		call com_err_ (0, my_name, "Usage: cobol_mcs_admin cmcs_dir");
		return;
	     end;

	go to common_entry;

/* NONLOCAL RETURN */
/* quit */

command (1):
admin_command (2):					/*[4.4-5]*/
	if my_brief_name = "cmcs"
	then if user_ctl.attach_bit
	     then call rec_messages;

nonlocal_return:
	if ^user_ctl.admin_sw			/* do for everyone except admin */
	then do;

		if test_sw
		then call ioa_ ("Starting purge all before return.");
						/* DEBUG */

		call cobol_mcs_$stop_run ();

		if user_ctl.terminal_sw		/* no one else uses these */
		then do;

			if input_cdp ^= null ()
			then free input_cd;

			if output_cdp ^= null ()
			then free output_cd;

			if send_buffer_ptr ^= null ()
			then do;

				ptr_array (1) = send_buffer_ptr;

				call release_temp_segments_ (my_name, ptr_array, code);

				if code ^= 0
				then call com_err_ (code, my_name,
					"From releasing the send buffer segment. Continuing.");
			     end;
		     end;

		call ipc_$delete_ev_chn (user_ctl.ev_wait_chn, code);

		if code ^= 0
		then call com_err_ (code, my_name,
			"Attempting to delete the wait event channel. Please contact the CMCS Administrator. Continuing."
			);

		call cmcs_station_ctl_$detach (user_ctl.station_ctl_eindex, code);

		if code ^= 0
		then call com_err_ (code, my_name, "Attempting to detach the process station_name. Continuing.");
	     end;


	call cobol_mcs_$set_user_ctl_exists_sw ("0"b);	/* now illegal to use CMCS */

	external_user_ctl_ptr = null ();
	ptr_array (1) = user_ctl_ptr;			/*[5.2-1]*/
	if my_brief_name = "cmcs"			/*[5.2-1]*/
	then do;
		call release_temp_segments_ ("cobol_mcs", ptr_array, code);

		if code ^= 0
		then call com_err_ (code, my_name,
			"Attempting to release temporary segment for user_ctl. Continuing return to command level.")
			;			/*[5.2-1]*/
		call cmcs_initiate_ctl_$release (code); /*[5.2-1]*/
	     end;
	return;					/* execute */

command (2):
admin_command (3):
	call cu_$cp (addr (substr (req, req_left_begin, 1)), req_left_len, code);

	if code ^= 0
	then do;
		call com_err_ (code, my_name, "From execute request.");
	     end;

/*[4.4-5]*/
	if my_brief_name = "cmcs"
	then if user_ctl.attach_bit
	     then call rec_messages;

	go to read_request;


/* accept_message_count */

command (3):
	if test_sw
	then call ioa_ ("amc");

	io_subtype = 1;

	call get_req_arg_count;

	if arg_count ^= 1
	then do;

		call com_err_ (0, my_name, "Usage: accept_message_count tree_path");

		go to read_request;

	     end;


	call req_arg_ptr (1);

	call cmcs_expand_tree_path_ (arg, rcv_tree_path, code);

	if code ^= 0
	then do;

amc_error:
		call com_err_ (code, my_name, "From accept_message_count, using ""^a"".", arg);

		call cmcs_decode_status_ (iox_$user_output, input_cdp, 5, io_subtype, code);

		go to read_request;

	     end;



	string (input_cd.tree_path) = rcv_tree_path;



	call cobol_mcs_$accept (input_cdp, code);

	if code ^= 0
	then go to amc_error;

	call ioa_ ("Message count for ""^a"" is ^a.", arg, input_cd.msg_count);

	rcv_tree_path = "";				/* so we don't confuse receives */

	go to read_request;

/*[4.4-3]*/
declare	all_bit		bit (1);

/* receive */

command (4):
	if test_sw
	then call ioa_ ("receive");

/*[4.4-3]*/
	all_bit = "0"b;

	call get_req_arg_count;

	if arg_count = 0 | arg_count > 2
	then do;

		call com_err_ (0, my_name, "Usage: receive delim {tree_path}");
		go to read_request;
	     end;

	call req_arg_ptr (1);			/* get delimiter */

	if arg = "1" | arg = "esi"
	then do;					/* wants message segment */

		char_delim = "1";
		io_subtype = 1;
	     end;
	else if arg = "2" | arg = "emi"
	then do;					/* wants entire message */

		char_delim = "2";
		io_subtype = 2;
	     end;

/*[4.4-3]*/
	else if arg = "3" | arg = "all"		/*[4.4-3]*/
	then do;
		char_delim = "2";			/*[4.4-3]*/
		io_subtype = 2;			/* entire message */
						/*[4.4-3]*/
		all_bit = "1"b;			/*[4.4-3]*/
	     end;

	else do;

/*[4.4-3]*/
		call com_err_ (0, my_name, "Receive delimiter must be esi (1) or emi (2) or all (3).");
		go to read_request;
	     end;

	if arg_count = 2
	then do;					/* supplied the tree_path */

		call req_arg_ptr (2);
		call cmcs_expand_tree_path_ (arg, rcv_tree_path, code);

		if code ^= 0
		then do;

			call com_err_ (code, my_name, "Expanding ""^a"" to full tree path.", arg);
			go to read_request;
		     end;
	     end;
	else if rcv_tree_path = ""			/* didn't give new one, is old one ok? */
	then do;

		call com_err_ (0, my_name, "Previous tree path is blank. Please reenter request with new tree path.");

		go to read_request;
	     end;

	string (input_cd.tree_path) = rcv_tree_path;

/*[4.4-3]*/
	call rec;

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "From receive.");
		call cmcs_decode_status_ (iox_$user_output, input_cdp, 2, io_subtype, code);

		if code ^= 0
		then call com_err_ (code, my_name, "From the status decode.");

	     end;

	if input_cd.text_delim = 0 | input_cd.text_delim = 1
	then rcv_tree_path = string (input_cd.tree_path); /* partial message, keep abs tree path */
	else rcv_tree_path = "";			/* nullify for complete messages and rcv errors */

	go to read_request;

rec:
     proc;

/*[4.4-3]*/
declare	mess_bit		bit (1);

/*[4.4-3]*/
	mess_bit = "0"b;

/*[4.4-3]*/
	do while ("1"b);

/*[4.4-3]*/
	     call cmcs_queue_ctl_$print (input_cdp, io_subtype, IOCB_ptr, code);

/*[4.4-3]*/
	     if ^all_bit
	     then return;

/*[4.4-3]*/
	     if code ^= 0				/*[4.4-3]*/
	     then do;
		     if code = cmcs_error_table_$no_message & (mess_bit | user_ctl.attach_bit)
		     then code = 0;

/*[4.4-3]*/
		     return;			/*[4.4-3]*/
		end;

/*[4.4-3]*/
	     mess_bit = "1"b;			/*[4.4-3]*/
	end;

     end;

/* send */

command (5):
	if test_sw
	then call ioa_ ("send");

	send_buffer_len = 0;			/* start fresh each time */

	call get_req_arg_count;			/* for initial checks */

	if arg_count < 2
	then do;					/* doesn't know how to use */

		call com_err_ (0, my_name, "Usage: send delim dest1 {dest2 ... destn}");
		go to read_request;
	     end;
	else if arg_count > 11
	then do;

		call com_err_ (0, my_name,
		     "Only 10 destinations can be specified in the send request. Please reenter request.");
		go to read_request;
	     end;

	call req_arg_ptr (1);			/* get message delim */

	if arg = "1" | arg = "esi"
	then do;					/* send data as message segment */

		char_delim = "1";			/* for cobol_mcs_ interface */
		io_subtype = 1;			/* for internal interfaces */
	     end;
	else if arg = "2" | arg = "emi"
	then do;					/* send data as complete message */

		char_delim = "2";
		io_subtype = 2;
	     end;
	else if arg = "3" | arg = "egi"
	then do;					/* egi same as emi */

		char_delim = "3";
		io_subtype = 3;

	     end;
	else do;

		call com_err_ (0, my_name, "The send delimiter must be esi (1), emi (2), or egi (3).");
		go to read_request;
	     end;

	call fill_dest_table (2);			/* arg 2 = 1st dest name */

send_loop:
	call iox_$get_line (iox_$user_input, buffer_ptr, buffer_max_len, buffer_len, code);

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "While doing a get_line for the send data.");

		go to read_request;
	     end;

	if buffer_len = 2
	then if substr (buffer, 1, 1) = "."
	     then do;

		     if send_buffer_len = 0
		     then do;			/* tried to send a null message */

			     call com_err_ (0, my_name, "Send data must be non-null. Returning to request level.");

			     go to read_request;
			end;

/*[4.4-1]*/
		     if substr (send_buffer, send_buffer_len, 1) = "
"						/*[4.4-1]*/
		     then send_buffer_len = send_buffer_len - 1;

		     output_cd.text_len = send_buffer_len;

		     call cobol_mcs_$send (output_cdp, send_buffer_ptr, "9999", char_delim, (36)"0"b, code);

		     if code ^= 0
		     then do;

			     call com_err_ (code, my_name, "From send.");
			     call cmcs_decode_status_ (iox_$user_output, output_cdp, 1, io_subtype, code);

			     if code ^= 0
			     then call com_err_ (code, my_name, "From decode of status information.");
			end;

		     go to read_request;
		end;

	if send_buffer_len + buffer_len > send_buffer_max_len
	then do;					/* should never happen, but just in case... */

		call com_err_ (0, my_name,
		     "You have exceeded the maximum amount of input to the send request (^d characters).
	Returning to request level.", send_buffer_max_len);

		go to read_request;
	     end;

	substr (send_buffer, send_buffer_len + 1, buffer_len) = substr (buffer, 1, buffer_len);
	send_buffer_len = send_buffer_len + buffer_len;

	go to send_loop;

/* enable_input */

command (6):
	if test_sw
	then call ioa_ ("ei");

	io_subtype = 1;

	call get_req_arg_count;

	if arg_count ^= 1
	then do;

		call com_err_ (0, my_name, "Usage: enable_input tree_path");
		go to read_request;
	     end;

	call req_arg_ptr (1);
	call cmcs_expand_tree_path_ (arg, rcv_tree_path, code);

	if code ^= 0
	then do;

ei_error:
		call com_err_ (code, my_name, "From enable_input.");
		call cmcs_decode_status_ (iox_$user_output, input_cdp, 3, io_subtype, code);

		go to read_request;
	     end;

	string (input_cd.tree_path) = rcv_tree_path;

	call get_password;

	call cobol_mcs_$enable_input_queue (input_cdp, password1, code);

	if code ^= 0
	then go to ei_error;

	go to read_request;


/* enable_input_terminal */

command (7):
	if test_sw
	then call ioa_ ("eit");

	io_subtype = 2;

	call get_req_arg_count;

	if arg_count ^= 1
	then do;
		call com_err_ (0, my_name, "Usage: enable_input_terminal station_name");
		go to read_request;
	     end;

	call get_password;

	call req_arg_ptr (1);

	input_cd.station_name = arg;

	call cobol_mcs_$enable_input_terminal (input_cdp, password1, code);

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "From enable_input_terminal.");
		call cmcs_decode_status_ (iox_$user_output, input_cdp, 3, io_subtype, code);

		go to read_request;
	     end;

	go to read_request;


/* enable_output */

command (8):
	if test_sw
	then call ioa_ ("eo");

	io_subtype = 3;

	call get_req_arg_count;

	if arg_count = 0
	then do;

		call com_err_ (0, my_name, "Usage: enable_output dest1 {dest2 ... dest10}");
		go to read_request;
	     end;

	call get_password;
	call fill_dest_table (1);

	call cobol_mcs_$enable_output (output_cdp, password1, code);

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "From enable_output");
		call cmcs_decode_status_ (iox_$user_output, output_cdp, 3, io_subtype, code);

		go to read_request;
	     end;

	go to read_request;


/* disable_input */

command (9):
	if test_sw
	then call ioa_ ("di");

	io_subtype = 1;

	call get_req_arg_count;

	if arg_count ^= 1
	then do;

		call com_err_ (0, my_name, "Usage: disable_input tree_path");
		go to read_request;
	     end;

	call req_arg_ptr (1);
	call cmcs_expand_tree_path_ (arg, rcv_tree_path, code);

	if code ^= 0
	then do;

di_error:
		call com_err_ (code, my_name, "From disable_input.");
		call cmcs_decode_status_ (iox_$user_output, input_cdp, 4, io_subtype, code);

		go to read_request;
	     end;

	string (input_cd.tree_path) = rcv_tree_path;

	call get_password;

	call cobol_mcs_$disable_input_queue (input_cdp, password1, code);

	if code ^= 0
	then go to di_error;

	go to read_request;


/* disable_input_terminal */

command (10):
	if test_sw
	then call ioa_ ("dit");

	io_subtype = 2;

	call get_req_arg_count;

	if arg_count ^= 1
	then do;

		call com_err_ (0, my_name, "Usage: disable_input_terminal station_name");
		go to read_request;
	     end;

	call get_password;
	call req_arg_ptr (1);

	input_cd.station_name = arg;

	call cobol_mcs_$disable_input_terminal (input_cdp, password1, code);

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "From disable_input_terminal.");
		call cmcs_decode_status_ (iox_$user_output, input_cdp, 4, io_subtype, code);

		go to read_request;
	     end;

	go to read_request;


/* disable_output */

command (11):
	if test_sw
	then call ioa_ ("do");

	io_subtype = 3;

	call get_req_arg_count;

	if arg_count = 0
	then do;

		call com_err_ (0, my_name, "Usage: disable_output dest1 {dest2 ... dest10}");

		go to read_request;
	     end;

	call fill_dest_table (1);
	call get_password;

	call cobol_mcs_$disable_output (output_cdp, password1, code);

	if code ^= 0
	then do;

		call com_err_ (code, my_name, "From disable_output");
		call cmcs_decode_status_ (iox_$user_output, output_cdp, 4, io_subtype, code);

		go to read_request;
	     end;

	go to read_request;


/* purge */

command (12):
	if test_sw
	then call ioa_ ("purge");

	io_subtype = 1;

	call get_req_arg_count;

	if arg_count = 0
	then do;

print_purge_usage:
		call com_err_ (0, my_name, "Usage: purge s {dest1 dest2 ... {dest10}");

		go to read_request;

	     end;

	call req_arg_ptr (1);

	if arg ^= "s"
	then go to print_purge_usage;

	if arg_count > 1
	then do;

		call fill_dest_table (2);

		call cobol_mcs_$purge (output_cdp, code);
						/* sends only, for cmd interface */

		if code ^= 0
		then do;

			call com_err_ (code, my_name, "From purge");
			call cmcs_decode_status_ (iox_$user_output, output_cdp, 6, io_subtype, code);

		     end;
	     end;
	else do;

		call cobol_mcs_$purge (null (), code);
		if code ^= 0
		then call com_err_ (code, my_name, "From purge.");

	     end;

	go to read_request;

/*activate */

command (14):					/* activate [ station_name [ path_name ]] */
						/*[4.4-5]*/
	if user_ctl.attach_bit			/*[4.4-5]*/
	then do;
		call com_err_ (0, my_name, "Station already activated");
						/*[4.4-5]*/
		go to read_request;			/*[4.4-5]*/
	     end;

/*[4.4-5]*/
	call get_req_arg_count;

/*[4.4-5]*/
	if arg_count > 2				/*[4.4-5]*/
	then do;
		call bad_attach;			/*[4.4-5]*/
		go to read_request;			/*[4.4-5]*/
	     end;

/*[4.4-5]*/
	go to A (arg_count);			/* activate */
A (0):						/*[4.4-5]*/
	ARG = user_ctl.station_name;
	user_ctl.iocb_ptr = null ();			/*[4.4-5]*/
	go to A0;					/* activate station-name */
A (1):						/*[4.4-5]*/
	call save_station;
	user_ctl.iocb_ptr = null ();			/*[4.4-5]*/
	go to A0;					/* activate station-name file_name */
A (2):						/*[4.4-5]*/
	call save_station;				/*[4.4-5]*/
	call save_path (2);				/*[4.4-5]*/
	go to A0;

A0:						/*[4.4-5]*/
	call cmcs_tree_ctl_$find_qual_name (ARG, a_index, a_eptr, d_stat_path, code);

/*[4.4-5]*/
	if code ^= 0				/*[4.4-5]*/
	then do;
		d_stat_path = "";			/*[4.4-5]*/
		call com_err_ (code, my_name, "illegal destination");
						/*[4.4-5]*/
	     end;

/*[4.4-5]*/
	user_ctl.attach_bit = "1"b;

/*[4.4-5]*/
	go to read_request;

/*[4.4-5]*/
declare	a_index		fixed bin,
	a_eptr		ptr;			/*[4.4-5]*/
declare	ARG		char (12);		/*[4.4-5]*/
declare	d_stat_path	char (52);


/* deactivate */

command (15):					/* deactivate */
						/*[4.4-5]*/
	if ^user_ctl.attach_bit			/*[4.4-5]*/
	then do;
		call com_err_ (0, my_name, "Station already deactivated");
						/*[4.4-5]*/
		go to read_request;			/*[4.4-5]*/
	     end;

/*[4.4-5]*/
	if user_ctl.iocb_ptr ^= null ()		/*[4.4-5]*/
	then do;
		call iox_$close (user_ctl.iocb_ptr, code);
						/*[4.4-5]*/
		call code_test;			/*[4.4-5]*/
		call iox_$detach_iocb (user_ctl.iocb_ptr, code);
						/*[4.4-5]*/
		call code_test;			/*[4.4-5]*/
	     end;

/*[4.4-5]*/
	user_ctl.attach_bit = "0"b;			/*[4.4-5]*/
	user_ctl.output_file = "";			/*[4.4-5]*/
	user_ctl.iocb_ptr = null ();			/*[4.4-5]*/
	IOCB_ptr = iox_$user_output;

/*[4.4-5]*/
	go to read_request;

save_station:
     proc;

/*[4.4-5]*/
	call req_arg_ptr (1);

/*[4.4-5]*/
	ARG = arg;
     end;

save_path:
     proc (arg_num);

/*[4.4-5]*/
declare	arg_num		fixed bin;

/*[4.4-5]*/
	call req_arg_ptr (arg_num);

/*[4.4-5]*/
	call exp;

/*[4.4-5]*/
	call iox_$attach_name /*[4.4-5]*/ ("A",		/*[4.4-5]*/
	     user_ctl.iocb_ptr,			/*[4.4-5]*/
	     "vfile_ " || substr (dname, 1, dsz) || ">" || substr (ename, 1, esz) || " -extend",
						/*[4.4-5]*/
	     null (),				/*[4.4-5]*/
	     code /*[4.4-5]*/);

/*[4.4-5]*/
	call code_test;

/*[4.4-5]*/
	call iox_$open (user_ctl.iocb_ptr, 2, "0"b, code);

/*[4.4-5]*/
	call code_test;

/*[4.4-5]*/
	IOCB_ptr = user_ctl.iocb_ptr;
     end;

code_test:
     proc;

/*[4.4-5]*/
	if code ^= 0				/*[4.4-5]*/
	then do;
		call com_err_ (code);

/*[4.4-5]*/
		go to read_request;			/*[4.4-5]*/
	     end;
     end;

bad_attach:
     proc;

/*[4.4-5]*/
	call com_err_ (0, my_name, "Usage: attach [atation-name] ");

     end;



/* change_cmcs_password */

admin_command (5):
	if test_sw
	then call ioa_ ("Command ""change_cmcs_password"":");

	scpsw_sw = "0"b;				/* check old psw before resetting it */

	call ioa_ ("Old password will be requested and then new password will be requested.");
	call get_password;

	scpsw_sw = "1"b;

common_password:
	call get_password;				/* if we return here, we checked out ok */

	system_ctl.password = password2;		/* changed from now on */

	go to read_request;

/* set_cmcs_password */

admin_command (6):
	if test_sw
	then call ioa_ ("Command ""set_cmcs_password"":");
	scpsw_sw = "1"b;				/* don't check old psw before resetting it */

	go to common_password;



/* create_cmcs_queues */

admin_command (7):
	if test_sw
	then call ioa_ ("Command ""create_cmcs_queues"":");

	call cmcs_create_queues_ (code);

	if code ^= 0
	then do;
		call com_err_ (code, my_name);
	     end;

	go to read_request;

/* who am I? */

command (13):
admin_command (1):
	if user_ctl.process_type = 2
	then call ioa_ ("^a, ^a", my_brief_name, user_ctl.station_name);
	else call ioa_ ("^a", my_brief_name);

	go to read_request;


/* test */

admin_command (4):
	call get_req_arg_count;

	call ioa_ ("Arg count is ^d.", arg_count);

	go to read_request;

/* stop_mp */

admin_command (9):
	call cmcs_wait_ctl_$stop_mp (code);

	if code ^= 0
	then call com_err_ (code, my_name, "Attempting to issue ""stop_mp"" command. Returning to request level.");

	go to read_request;

/* */

/* clear_mp */

admin_command (10):
	call cmcs_wait_ctl_$clear_mp (code);

	if code ^= 0
	then call com_err_ (code, my_name, "Attempting to perform clear_mp request. Returning to request level.");

	go to read_request;


/* */

/* start_mp */
admin_command (8):
	call cmcs_wait_ctl_$start_mp (code);

	if code ^= 0
	then call com_err_ (code, my_name, "Attempting to perform start_mp request. Returning to request level.");

	go to read_request;

/*  */

/* purge_queues */
admin_command (11):					/* This request currently purges all queues and all records with status 1 and status 4 are deleted.
   Records with status 3 are moved back to status 2. Records with status 2 are left as-is.
   This request must be executed only when no other users of the given CMCS environment are on the system
   because no attempt is made to determine that a message is being processed by another process. */
	if test_sw
	then call ioa_ ("Command ""purge_queues"":");

	call cmcs_purge_queues_ (0, "1"b, code);

	if code ^= 0
	then call com_err_ (code, my_name, "From the purge_queues request. Returning to request level.");

	go to read_request;

/* */

/* Parsing Procedures */

get_req_cmd:
     proc;

	if ^cmd_parsed_sw
	then do;

		call parse_args;
		req_cmd_ptr = arg_ptr;		/* save for later reference */
		req_cmd_len = arg_len;
	     end;
	else do;

		arg_ptr = req_cmd_ptr;		/* retrieve previously set values */
		arg_len = req_cmd_len;
	     end;

	return;

     end /* get_req_cmd */;

/* */

get_req_arg_count:
     proc;

	if ^cmd_parsed_sw
	then call parse_args;

	if ^args_parsed_sw
	then do;

		call parse_args;
		req_arg_count = arg_count;		/* save for later reference */
		args_parsed_sw = "1"b;
	     end;
	else arg_count = req_arg_count;

	return;

     end /* get_req_arg_count */;

/* */

req_arg_ptr:
     proc (arg_no);

dcl	arg_no		fixed bin;

	call get_req_arg_count;			/* make sure everything is set up */

	arg_ptr = arg_array (arg_no).argp;
	arg_len = arg_array (arg_no).argl;

	return;

     end /* req_arg_ptr */;

/* */

parse_args:
     proc;

	arg_count = 0;

	do j = 1 to max_req_args while (req_left_len > 0);

	     i = verify (substr (req, req_left_begin, req_left_len), whitespace);
						/* find first nonblank */

	     if i ^= 0
	     then do;				/* found another arg */

		     arg_count = arg_count + 1;
		     req_left_begin = req_left_begin + i - 1;
		     req_left_len = req_left_len - i + 1;
		end;
	     else req_left_len = 0;			/* no more args, stop looking */

	     arg_ptr = addr (substr (req, req_left_begin, 1));

	     i = search (substr (req, req_left_begin, req_left_len), whitespace);
						/* find end of arg */

	     if i ^= 0
	     then arg_len = i - 1;
	     else arg_len = req_left_len;

	     req_left_begin = req_left_begin + arg_len;	/* set for next iteration now or later */
	     req_left_len = req_left_len - arg_len;

	     if ^cmd_parsed_sw
	     then do;

		     cmd_parsed_sw = "1"b;		/* avoid infinite loop */
		     code = 0;

		     return;			/* that's all we need this time */
		end;

	     arg_array (arg_count).argp = arg_ptr;
	     arg_array (arg_count).argl = arg_len;

	end;					/* of parse loop */

	if req_left_len ^= 0
	then code = error_table_$too_many_args;
	else code = 0;

	return;

     end /* parse_args */;

/*  */

set_interactive_info:
     proc;

	call user_info_$absentee_queue (i);		/* to see if we're interactive */

	if i ^= -1
	then interactive_sw = "0"b;			/* No, Virginia */
	else do;

		interactive_sw = "1"b;		/* yes, Virginia */

		call user_info_$tty_data (term_id, term_type, term_channel);

		user_ctl.interactive_sw = "1"b;
		user_ctl.term_id = term_id;
		user_ctl.term_type = term_type;
		user_ctl.term_channel = term_channel;
	     end;
	return;

     end /* set_interactive_info */;

/* */

get_password:
     proc ();

	if interactive_sw				/* should be done interactively but... */
	then do;

request_password:
		call read_password_ ("Input COBOL MCS password:", password1);
		call read_password_ ("Please repeat for verification...", password2);

		if password1 ^= password2
		then do;

			call com_err_ (0, my_name, "Passwords do not match. Please repeat.");

			go to request_password;

		     end;

encode_password:
		password2 = cmcs_scramble_ (password1); /* maintain secure passwords */

		if ^scpsw_sw
		then if password2 ^= system_ctl.password/* change, not set */
		     then do;			/* not what it's thought to be */

			     call com_err_ (cmcs_error_table_$bad_password, my_name, "Returning to request level.");

			     go to read_request;

			end;
		scpsw_sw = "0"b;			/* reset so we check the next time */
	     end;
	else do;

		call com_err_ (error_table_$action_not_performed, my_name,
		     "Passwords for COBOL MCS must be changed either by COBOL program or interactively.");

		go to read_request;

	     end;
	return;

     end /* get_password */;

/*  */

fill_dest_table:
     proc (x_arg_no);

dcl	x_arg_no		fixed bin;		/* starting arg number */

	err_sw = "0"b;
	dest_table_index = 0;			/* initialize */

	do i = x_arg_no to arg_count;

	     call req_arg_ptr (i);
	     station_name = arg;			/* for fixed 12 char size */

	     call cmcs_station_ctl_$validate (station_name, station_ctl_eindex, code);

	     if code ^= 0
	     then do;

		     err_sw = "1"b;
		     call com_err_ (code, my_name, """^a"".", station_name);
		end;
	     else do;

		     dest_table_index = dest_table_index + 1;
		     output_cd.dest_table (dest_table_index).station_name = station_name;
		end;
	end;

	if err_sw
	then do;

		call com_err_ (error_table_$action_not_performed, my_name, "Please reenter request.");

		go to read_request;			/* non-local */
	     end;

	output_cd.station_count = dest_table_index;
	code = 0;

	return;

     end /* fill_dest_table */;


exp:
     proc;

/*[4.4-5]*/
	call expand_pathname_ (arg, dname, ename, code);

/*[4.4-5]*/
	call code_test;

/*[4.4-5]*/
	dsz = index (dname, " ");			/*[4.4-5]*/
	if dsz <= 0
	then dsz = 168;
	else dsz = dsz - 1;

/*[4.4-5]*/
	esz = index (ename, " ");			/*[4.4-5]*/
	if esz <= 0
	then esz = 32;
	else esz = esz - 1;

     end;

/*[4.4-5]*/
declare	(dsz, esz)	fixed bin;

test:
     entry ();

	test_sw = "1"b;
	return;

     end /* cobol_mcs */;




		    cobol_mcs_.pl1                  05/24/89  1047.9rew 05/24/89  0834.1       97011



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_mcs_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/08/81 by FCH, [4.4-2], code "60" returned, BUG468 */
/* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */
/* Modified since Version 4.3 */

/* format: style3 */
cobol_mcs_:
     proc;

dcl	a_input_cdp	ptr,
	a_output_cdp	ptr,
	a_code		fixed bin (35),
	a_rcv_type	fixed bin,
	a_slew_ctl	bit (36),
	a_buffer_ptr	ptr,
	a_char_buffer_len	char (4),
	a_char_max_buffer_len
			char (4),
	a_bin_buffer_len	fixed bin,
	a_char_delim	char (1),
	a_sw		bit (1) aligned,		/* flag for set/get user_ctl_exists_sw */
	a_password	char (*);

dcl	buffer_len	fixed bin,
	max_buffer_len	fixed bin,
	io_subtype	fixed bin,
	code		fixed bin (35),
	purge_ptr		ptr,
	scrambled_password	char (10),
	password		char (10);

dcl	my_name		char (10) int static init ("cobol_mcs_");

dcl	test_sw		bit (1) int static init ("0"b);

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

dcl	(ioa_, com_err_, sub_err_)
			entry options (variable);	/* Both for DEBUG */

dcl	sub_err_retval	fixed bin (35);
dcl	station_count	fixed bin;

dcl	(
	error_table_$noentry,
	error_table_$action_not_performed
	)		fixed bin (35) external;

dcl	cleanup		condition;

dcl	continue_to_signal_ entry (fixed bin (35));

/*  */
%include cmcs_cd_dcls;
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_error_table_dcls;
%include cmcs_queue_ctl;
%include cmcs_station_ctl;
%include cmcs_system_ctl;
%include cmcs_tree_ctl;
%include cmcs_user_ctl;
%include cmcs_vfile_rs;

/* %include cmcs_wait_ctl; */

/*  */

accept:
     entry (a_input_cdp, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	io_subtype = 1;				/* and in this case only, only 1 */

	call cmcs_queue_ctl_$accept_message_count (a_input_cdp, io_subtype, a_code);
	return;


/* */

receive:
     entry (a_input_cdp, a_rcv_type, a_buffer_ptr, a_bin_buffer_len, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	if a_rcv_type = 0
	then io_subtype = 2;			/* convert to std form, 0 input = message, no wait */
	else if a_rcv_type = 1
	then io_subtype = 1;			/* 1 input = segment, no wait */

	call cmcs_queue_ctl_$receive (a_input_cdp, io_subtype, a_buffer_ptr, a_bin_buffer_len, a_code);
	return;


/* */

receive_wait:
     entry (a_input_cdp, a_rcv_type, a_buffer_ptr, a_bin_buffer_len, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	if a_rcv_type = 0
	then io_subtype = 4;			/* convert to std form, 0 input = message (wait) */
	else if a_rcv_type = 1
	then io_subtype = 3;			/* 1 input = segment (wait) */

	call cmcs_queue_ctl_$receive (a_input_cdp, io_subtype, a_buffer_ptr, a_bin_buffer_len, a_code);
	return;


/* */

send:
     entry (a_output_cdp, a_buffer_ptr, a_char_max_buffer_len, a_char_delim, a_slew_ctl, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	io_subtype = index ("0123", a_char_delim) - 1;

	if io_subtype < 0				/* not 0-3 */
	then io_subtype = 0;

	output_cdp = a_output_cdp;

	buffer_len = output_cd.text_len;
	max_buffer_len = fixed (a_char_max_buffer_len, 17);

/*[4.4-2]*/
	if io_subtype = 0 & (buffer_len = 0 | a_buffer_ptr = null ())
	then do;

		output_cd.status_key = "60";
		a_code = cmcs_error_table_$null_partial_message;
		return;
	     end;


	if buffer_len > max_buffer_len
	then do;

		a_code = cmcs_error_table_$bad_message_length;
		output_cd.status_key = "50";
		return;
	     end;

	output_cd.bin_max_station_count = output_cd.char_max_station_count;
	station_count = output_cd.station_count;

	if output_cd.bin_max_station_count < station_count | station_count = 0
	then do;

		output_cd.status_key = "30";
		a_code = cmcs_error_table_$bad_dest_count;
		return;
	     end;

/* The following call uses parameters different than those passed to cobol_mcs_. Specifically, buffer_len and
   station_count are used instead of max_buffer_len (and nothing). Since the validity checks are done here, there is
   no reason that we must continue passing character representations of numeric data. */

	call cmcs_queue_ctl_$send (a_output_cdp, io_subtype, a_buffer_ptr, buffer_len, station_count, a_slew_ctl,
	     a_code);

	return;


/* */

purge:
     entry (a_output_cdp, a_code);			/* CODASYL PURGE, sends only */

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	if a_output_cdp ^= null ()
	then do;

		output_cdp = a_output_cdp;
		output_cd.bin_max_station_count = output_cd.char_max_station_count;
		station_count = output_cd.station_count;

		if (output_cd.bin_max_station_count < station_count) | station_count = 0
		then do;

			output_cd.status_key = "30";
			a_code = cmcs_error_table_$bad_dest_count;
			return;
		     end;
	     end;

	io_subtype = 1;				/* sends only, per CODASYL */

	call cmcs_queue_ctl_$purge (a_output_cdp, io_subtype, a_code);

	return;


/* */

enable_input_queue:
     entry (a_input_cdp, a_password, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	call check_password;			/* also gets fixed size password */

	if a_code ^= 0
	then do;

		input_cdp = a_input_cdp;
		input_cd.status_key = "40";
		return;
	     end;

	io_subtype = 1;

	call cmcs_queue_ctl_$enable (a_input_cdp, io_subtype, password, a_code);
	return;


/* */

disable_input_queue:
     entry (a_input_cdp, a_password, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	call check_password;			/* also gets fixed size password */

	if a_code ^= 0
	then do;

		input_cdp = a_input_cdp;
		input_cd.status_key = "40";
		return;
	     end;

	io_subtype = 1;

	call cmcs_queue_ctl_$disable (a_input_cdp, io_subtype, password, a_code);

	return;


/* */

enable_input_terminal:
     entry (a_input_cdp, a_password, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	call check_password;			/* also gets fixed size password */

	if a_code ^= 0
	then do;

		input_cdp = a_input_cdp;
		input_cd.status_key = "40";
		return;
	     end;

	io_subtype = 2;

	call cmcs_station_ctl_$enable_input_terminal (a_input_cdp, password, a_code);

	return;


/* */

disable_input_terminal:
     entry (a_input_cdp, a_password, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	call check_password;			/* also gets fixed size password */

	if a_code ^= 0
	then do;

		input_cdp = a_input_cdp;
		input_cd.status_key = "40";
		return;
	     end;

	io_subtype = 2;

	call cmcs_station_ctl_$disable_input_terminal (a_input_cdp, password, a_code);

	return;


/* */

enable_output:
     entry (a_output_cdp, a_password, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	call check_password;			/* also gets fixed size password */

	if a_code ^= 0
	then do;

		output_cdp = a_output_cdp;
		output_cd.status_key = "40";
		return;
	     end;

	io_subtype = 3;

	call cmcs_station_ctl_$enable_output_terminal (a_output_cdp, password, a_code);


	return;


/* */

disable_output:
     entry (a_output_cdp, a_password, a_code);

/*[4.4-1]*/
	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then call setup;

	call check_password;			/* also gets fixed size password */

	if a_code ^= 0
	then do;

		output_cdp = a_output_cdp;
		output_cd.status_key = "40";
		return;
	     end;

	io_subtype = 3;

	call cmcs_station_ctl_$disable_output_terminal (a_output_cdp, password, a_code);

	return;

ret:						/*[4.4-1]*/
	return;

/* */

check_password:
     proc ();

	password = a_password;			/* need fixed size */
	scrambled_password = cmcs_scramble_ (password);
	password = "";				/* at least eliminate OUR password visibility */

	if scrambled_password = system_ctl.password
	then a_code = 0;
	else a_code = cmcs_error_table_$bad_password;

	return;

     end /* check_password */;


/* */

stop_run:
     entry ();

	if ^(external_user_ctl_ptr -> user_ctl.init_sw.mcs)
	then return;				/* temporary test to see if user doesn't use cmcs */

	call cmcs_queue_ctl_$stop_run (1, code);

	if code ^= 0
	then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
		"From purge (and queue detach) initiated by stop_run.");

	return;

/* end of stop_run entrypoint */


cleanup_handler:
	call sub_err_ (0, my_name, "c", null (), sub_err_retval,
	     "The cleanup condition was detected. A stop_run will be simulated.");

	call cmcs_queue_ctl_$stop_run (1, code);

	if code ^= 0
	then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
		"From purge (and queue detach) initiated by stop_run.");

	call continue_to_signal_ (code);

	if code ^= 0
	then call sub_err_ (code, my_name, "c", null (), sub_err_retval,
		"From attempt to continue signalling up the stack. Continuing.");
	return;

/* end of cleanup_handler code */

/*  */
setup:
     proc;

	if user_ctl_exists_sw			/* must be running in the proper environment */
	then do;

		user_ctl_ptr = external_user_ctl_ptr;	/* set local variable from global */

		queue_ctl_ptr = user_ctl.queue_ctl_ptr;
		station_ctl_ptr = user_ctl.station_ctl_ptr;
		system_ctl_ptr = user_ctl.system_ctl_ptr;
		terminal_ctl_ptr = user_ctl.terminal_ctl_ptr;
		tree_ctl_ptr = user_ctl.tree_ctl_ptr;
		wait_ctl_ptr = user_ctl.wait_ctl_ptr;

		on cleanup go to cleanup_handler;

		user_ctl.init_sw.mcs = "1"b;
		a_code = 0;

	     end;
	else do;

		a_code = error_table_$action_not_performed;
		call sub_err_ (a_code, my_name, "c", null (), sub_err_retval,
		     "Private COBOL application programs using CMCS must be run under the cobol_mcs command (execute request). Please consult with your CMCS Administrator on procedures."
		     );

		go to ret;
	     end;

     end /* setup */;

/* */

test:
     entry ();

	test_sw = "1"b;
	return;

/* */

set_user_ctl_exists_sw:
     entry (a_sw);

	user_ctl_exists_sw = a_sw;
	return;

/* */

get_user_ctl_exists_sw:
     entry (a_sw);

	a_sw = user_ctl_exists_sw;
	return;

     end /* cobol_mcs_ */;




		    cv_cmcs_station_ctl.rd          03/17/86  1520.5rew 03/17/86  1431.2       90279



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


/* Modified on 04/23/81 by FCH, [4.4-2], accept minus in station names, BUG468 */
/* Modified on 03/03/81 by FCH, [4.4-1], once per process initialization, BUG468 */
/* Modified since Version 4.3 */

/* This procedure converts an ASCII list of station subchannels and
   their correspnding default station names to a binary control segment */

/*++

   BEGIN	/ <valid_station> ;		/ add LEX (2)		/ BEGIN \
	/ end ;			/ close			/ RETURN \
	/ <any-token>		/ ERROR (1) NEXT_STMT	/ BEGIN \
	/ <no-token>		/ ERROR (2)		/ RETURN \

++*/

cv_cmcs_station_ctl: proc;

dcl  new_station_name char (12),
     j fixed bin,
     aclinfo_ptr ptr,				/* for use by tssi_ */
     temp3 char (3);

dcl  test_sw bit (1) int static init ("0"b);

/*  */
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_station_ctl;

/*  */
/* automatic */


declare (APstmt, APtoken) ptr,
         area_ptr ptr,				/* for use by lex_string_. */
         arg_length fixed bin (21),			/* length of command argument. */
         arg_ptr ptr,				/* ptr to command argument */
         bitcount fixed bin (24),
         code fixed bin (35),
         dname char (168),
         ename char (32),
         i fixed bin,
         n_chars fixed bin (21),
         object_name char (32),			/* entry name of output control seg */
        (pntep, object_ptr) ptr,			/* ptrs to base of pnte and pnt */
         source_ptr ptr;				/* ptr to base of persmf */

/* based */

declare  arg_string char (arg_length) based (arg_ptr) unaligned;

/* builtin */

declare (addr, collate, dimension, divide, index, length, null,
         reverse, string, substr, verify) builtin;

/* conditions */

declare  cleanup condition;

/* entries */

declare
         clock_ entry () returns (fixed bin (71)),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)),
         expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
         get_group_id_ entry () returns (char (32) aligned),
         get_process_id_ entry () returns (bit (36)),
         get_wdir_ entry () returns (char (168) aligned),
         hcs_$delentry_seg entry (ptr, fixed bin (35)),
         hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)),
         hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
         hcs_$terminate_noname entry (ptr, fixed bin (35)),
         hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)),
        (ioa_, com_err_) entry options (variable),
         lex_error_ entry options (variable),
         lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*),
         bit (*), char (*) var, char (*) var, char (*) var, char (*) var),
         lex_string_$lex entry (ptr, fixed bin (21), fixed bin, ptr, bit (*), char (*), char (*), char (*),
         char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)),
         translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)),
         translator_temp_$release_all_segments entry (ptr, fixed bin (35)),

         tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)),
         tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)),
         tssi_$clean_up_segment entry (ptr),

         unique_chars_ entry (bit (*)) returns (char (15) aligned);

/* internal static */

declare ((BREAKS, IGBREAKS, LEXCTL, LEXDLM) char (128) varying,
/*[4.4-1]*/         first_time bit (1) aligned initial ("1"b)) int static;

dcl (LEGAL char (71) aligned initial ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ."),
     my_name char (20) initial ("cv_cmcs_station_ctl"),
     ALPHANUMERICS char (64) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-") /*[4.4-2]*/
     ) internal static options (constant);

/* external static */

declare ((error_table_$badopt, error_table_$entlong,
         error_table_$bad_name, error_table_$translation_failed) fixed bin (35),
         sys_info$max_seg_size fixed bin (18)
         ) external static;


/* program */

	call cu_$arg_ptr (1, arg_ptr, arg_length, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "Usage: cv_cmcs_station_ctl pathname (-brief|-bf|-long|-lg)");
	     return;

	end;

	call expand_pathname_ (arg_string, dname, ename, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "^a", arg_string);
	     return;

	end;

	call cu_$arg_ptr (2, arg_ptr, arg_length, code);

	if code = 0
	then if arg_string = "-brief" | arg_string = "-bf"
	     then SERROR_CONTROL = "01"b;
	     else if arg_string = "-long" | arg_string = "-lg"
	     then SERROR_CONTROL = "10"b;
	     else do;

		call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
		return;

	     end;

	source_ptr = null;				/* Initialize for cleanup handler */
	object_ptr = null;				/* .. */
	area_ptr = null;				/* .. */
	aclinfo_ptr = null;				/* .. */

	on cleanup call clean_up;

	call hcs_$initiate_count (dname, ename, "", bitcount, 1b, source_ptr, code);

	if source_ptr = null
	then do;

report_error:

	     call com_err_ (code, my_name, "^a>^a", dname, ename);
	     return;

	end;

	i = index (ename, ".src") - 1;

	if i < 1 then do;

	     call com_err_ (error_table_$bad_name, my_name, "Source segment must have "".src"" suffix.");
	     return;

	end;

	if i + length (".control") > length (object_name)
	then do;

	     code = error_table_$entlong;
	     go to report_error;

	end;

	object_name = substr (ename, 1, i) || ".control";

	n_chars = divide (bitcount + 8, 9, 24, 0);

	dname = get_wdir_ ();

	call tssi_$get_segment (dname, object_name, object_ptr, aclinfo_ptr, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "^a>^a", dname, object_name);
	     return;

	end;

	station_ctl_ptr = object_ptr;			/* actual working ptr - other is generic ptr */

	call cmcs_fillin_hdr_ (station_ctl_ptr, station_ctl_version, station_ctl_hdr_len, station_ctl_entry_len, code);

	if code ^= 0
	then do;
	     call com_err_ (code, my_name, "Setting common header data.");
	     return;

	end;

/*[4.4-1]*/	if first_time
/*[4.4-1]*/	then	do;

	     BREAKS = substr (collate, 1, 8) || substr (collate, 10, 24) || ";:,()";
	     IGBREAKS = substr (BREAKS, 1, 8+24);

	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b,
		BREAKS, IGBREAKS, LEXDLM, LEXCTL);
/*[4.4-1]*/	     first_time = "1"b;

/*[4.4-1]*/		end;

	call translator_temp_$get_segment (my_name, area_ptr, code);

	if area_ptr = null
	then do;


	     call com_err_ (code, my_name, "Making temporary segment in process directory.");
	     return;

	end;

	call lex_string_$lex (source_ptr, n_chars, 0, area_ptr, "1000"b, """", """", "/*", "*/", ";",
	     BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, ename);
	     return;

	end;

	Pthis_token = APtoken;

	call SEMANTIC_ANALYSIS ();

	if MERROR_SEVERITY > 1
	then do;

	     call com_err_ (error_table_$translation_failed, my_name, ename);
	     call hcs_$delentry_seg (object_ptr, code);

	end;
	else do;

	     bitcount = 36 * (station_ctl_hdr_len + station_ctl_entry_len * station_ctl.current_size);

	     call tssi_$finish_segment (object_ptr, bitcount, "101"b, aclinfo_ptr, code);

	     if code ^= 0
	     then call com_err_ (code, my_name, "Unable to set bitcount on ^a>^a to ^d", dname, object_name, bitcount);

	end;

	call clean_up;				/* terminate input segments */

	return;

/* Clean up procedure. Called if command is "quit" out of, and at end of normal processing. */

clean_up:
	procedure;

	     if source_ptr ^= null
	     then call hcs_$terminate_noname (source_ptr, code);

	     if object_ptr ^= null
	     then call hcs_$terminate_noname (object_ptr, code);

	     if area_ptr ^= null
	     then call translator_temp_$release_all_segments (area_ptr, code);

	     if aclinfo_ptr ^= null
	     then call tssi_$clean_up_segment (aclinfo_ptr);

	end /* clean_up */ ;




declare 1 error_control_table (2) aligned internal static,
        2 severity fixed bin (17) unaligned initial (
       (2)3),
        2 Soutput_stmt bit (1) unaligned initial (
         "1"b,
         "0"b),
        2 message char (64) varying initial (
         "Syntax error in ""^a"" statement.",
         "Premature end of input encountered."),
        2 brief_message char (20) varying initial (
         "^a",
         "Premature EOF.");

/*  */

valid_station: proc () returns (bit (1) aligned);

	     if test_sw then call ioa_ ("Parse: token (^a).", token_value);

	     if token_value = "end" then return ("0"b);	/* special case this name */

	     if length (token_value) > 12 then return ("0"b);

	     if verify (token_value, ALPHANUMERICS) ^= 0 then return ("0"b);

	     new_station_name = token_value;

	     return ("1"b);

	end /* valid_station */ ;

close:	proc ();

	     if test_sw then call ioa_ ("CLOSE");
	     return;
	end /* close */ ;

/*  */

add:	proc ();

	     station_ctl.entry_count, station_ctl.current_size = station_ctl.current_size + 1;
	     string (station_ctl.flags (station_ctl.current_size)) = (36) "0"b;
	     station_ctl.station_name (station_ctl.current_size) = new_station_name;

	     return;

	end /* add */ ;

/* */

test:	entry;

	test_sw = "1"b;
	return;

/* end of test entrypoint */





		    cv_cmcs_terminal_ctl.rd         03/17/86  1520.5rew 03/17/86  1431.3      105768



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


/* Modified on 10/27/82 by FCH, [5.1-1], term subchannel name can only start with a/b/c/d, BUG14117(phx14117) */
/* Modified on 04/23/81 by FCH, [4.4-1], accept minus in station names, BUG468 */
/* Modified on 03/03/81 by FCH, [4.4-2], once per process initialization, BUG468 */
/* Modified on 02/27/81 by FCH, [4.4-1], BUG 467(TR9227), terminal name check */
/* Modified since Version 4.3 */

/* This procedure converts an ASCII list of terminal subchannels and
   their correspnding default station names to a binary control segment */

/*++

   BEGIN	/ <valid_terminal> :	/ LEX (2)			/ station \
	/ end ;			/ 			/ RETURN \
	/ <any-token>		/ ERROR (1) NEXT_STMT	/ BEGIN \
	/ <no-token>		/ ERROR (2)		/ RETURN \

   station / <valid_station> ;	/ add LEX (2)		/ BEGIN \
	/ <any-token>		/ ERROR (1) NEXT_STMT	/ BEGIN \
	/ <no-token>		/ ERROR (2)		/ RETURN \

++*/

cv_cmcs_terminal_ctl: proc;

dcl  new_station_name char (12),
     new_terminal_name char (8),
     j fixed bin,
     aclinfo_ptr ptr,				/* for use by tssi_ */
     temp3 char (3);

%include cmcs_control_hdr;

%include cmcs_station_ctl;

%include cmcs_terminal_ctl;

%include cmcs_entry_dcls;

/* automatic */


declare (APstmt, APtoken) ptr,
         area_ptr ptr,				/* for use by lex_string_. */
         arg_length fixed bin (21),			/* length of command argument. */
         arg_ptr ptr,				/* ptr to command argument */
         bitcount fixed bin (24),
         code fixed bin (35),
         dname char (168),
         ename char (32),
         i fixed bin,
         n_chars fixed bin (21),
         object_name char (32),			/* entry name of output control seg */
        (pntep, object_ptr) ptr,			/* ptrs to base of pnte and pnt */
         source_ptr ptr;				/* ptr to base of persmf */

/* based */

declare  arg_string char (arg_length) based (arg_ptr) unaligned;

/* builtin */

declare (addr, collate, dimension, divide, index, length, null,
         reverse, string, substr, verify) builtin;

/* conditions */

declare  cleanup condition;

/* entries */

declare
         clock_ entry () returns (fixed bin (71)),
         com_err_ entry options (variable),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)),
         expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
         get_group_id_ entry () returns (char (32) aligned),
         get_process_id_ entry () returns (bit (36)),
         get_wdir_ entry () returns (char (168) aligned),
         hcs_$delentry_seg entry (ptr, fixed bin (35)),
         hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
         hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)),
         hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
         hcs_$terminate_noname entry (ptr, fixed bin (35)),
         hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)),
         lex_error_ entry options (variable),
         lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*),
         bit (*), char (*) var, char (*) var, char (*) var, char (*) var),
         lex_string_$lex entry (ptr, fixed bin (21), fixed bin, ptr, bit (*), char (*), char (*), char (*),
         char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)),
         translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)),
         translator_temp_$release_all_segments entry (ptr, fixed bin (35)),

         tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)),
         tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)),
         tssi_$clean_up_segment entry (ptr),

         unique_chars_ entry (bit (*)) returns (char (15) aligned);

/* internal static */

declare ((BREAKS, IGBREAKS, LEXCTL, LEXDLM) char (128) varying,
/*[4.4-2]*/         first_time bit (1) aligned initial ("1"b)) int static;

dcl (LEGAL char (71) aligned initial ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ."),
     my_name char (20) initial ("cv_cmcs_terminal_ctl"),
     ALPHANUMERICS char (64) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-") /*[4.4-1]*/
     ) internal static options (constant);

/* external static */

declare ((error_table_$badopt, error_table_$entlong,
         error_table_$bad_name, error_table_$translation_failed) fixed bin (35),
         sys_info$max_seg_size fixed bin (18)
         ) external static;


/* program */

	call cu_$arg_ptr (1, arg_ptr, arg_length, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "Usage: cv_cmcs_terminal_ctl pathname (-brief|-bf|-long|-lg)");
	     return;

	end;

	call expand_pathname_ (arg_string, dname, ename, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "^a", arg_string);
	     return;

	end;

	call cu_$arg_ptr (2, arg_ptr, arg_length, code);

	if code = 0
	then if arg_string = "-brief" | arg_string = "-bf"
	     then SERROR_CONTROL = "01"b;
	     else if arg_string = "-long" | arg_string = "-lg"
	     then SERROR_CONTROL = "10"b;
	     else do;

		call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
		return;

	     end;

	source_ptr = null;				/* Initialize for cleanup handler */
	object_ptr = null;				/* .. */
	area_ptr = null;				/* .. */
	aclinfo_ptr = null;				/* .. */

	on cleanup call clean_up;

	call hcs_$initiate_count (dname, ename, "", bitcount, 1b, source_ptr, code);

	if source_ptr = null
	then do;

report_error:

	     call com_err_ (code, my_name, "^a>^a", dname, ename);
	     return;

	end;

	i = index (ename, ".src") - 1;

	if i < 1 then do;

	     call com_err_ (error_table_$bad_name, my_name, "Source segment must have "".src"" suffix.");
	     return;

	end;

	if i + length (".control") > length (object_name)
	then do;

	     code = error_table_$entlong;
	     go to report_error;

	end;

	object_name = substr (ename, 1, i) || ".control";

	n_chars = divide (bitcount + 8, 9, 24, 0);

	dname = get_wdir_ ();

	call tssi_$get_segment (dname, object_name, object_ptr, aclinfo_ptr, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "^a>^a", dname, object_name);
	     return;

	end;

	terminal_ctl_ptr = object_ptr;		/* actual working ptr - other is generic ptr */

	call cmcs_fillin_hdr_ (terminal_ctl_ptr, terminal_ctl_version, terminal_ctl_hdr_len, terminal_ctl_entry_len, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "Setting common header data.");
	     return;

	end;

/*[4.4-2]*/	if first_time
/*[4.4-2]*/	then	do;

	     BREAKS = substr (collate, 1, 8) || substr (collate, 10, 24) || ":,()";
	     IGBREAKS = substr (BREAKS, 1, 8+24);

	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b,
		BREAKS, IGBREAKS, LEXDLM, LEXCTL);

	     call hcs_$initiate
		(get_wdir_ (), "cmcs_station_ctl.control", "cmcs_station_ctl.control", 0, 0, station_ctl_ptr, code);

	     if station_ctl_ptr = null ()
	     then do;

		call com_err_ (code, my_name,
		     "The cmcs_station_ctl.control segment must exist in the current working directory before this command can be run.");
		return;

	     end;

/*[4.4-2]*/			first_time = "1"b;

/*[4.4-2]*/		end;

	call translator_temp_$get_segment (my_name, area_ptr, code);

	if area_ptr = null ()
	then do;

	     call com_err_ (code, my_name, "Making temporary segment in process directory.");
	     return;

	end;

	call lex_string_$lex (source_ptr, n_chars, 0, area_ptr, "1000"b, """", """", "/*", "*/", ";",
	     BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, ename);
	     return;

	end;

	Pthis_token = APtoken;

	call SEMANTIC_ANALYSIS ();

	if MERROR_SEVERITY > 1
	then do;

	     call com_err_ (error_table_$translation_failed, my_name, ename);
	     call hcs_$delentry_seg (object_ptr, code);

	end;
	else do;

	     bitcount = 36 * (terminal_ctl_hdr_len + terminal_ctl_entry_len * terminal_ctl.current_size);
	     call tssi_$finish_segment (object_ptr, bitcount, "100"b, aclinfo_ptr, code);

	     if code ^= 0
	     then call com_err_ (code, my_name, "Unable to set bitcount on ^a>^a to ^d", dname, object_name, bitcount);

	end;

	call clean_up;				/* terminate input segments */

	return;

/* Clean up procedure. Called if command is "quit" out of, and at end of normal processing. */

clean_up:
	procedure;

	     if source_ptr ^= null
	     then call hcs_$terminate_noname (source_ptr, code);

	     if object_ptr ^= null
	     then call hcs_$terminate_noname (object_ptr, code);

	     if area_ptr ^= null
	     then call translator_temp_$release_all_segments (area_ptr, code);

	     if aclinfo_ptr ^= null
	     then call tssi_$clean_up_segment (aclinfo_ptr);

	end /* clean_up */ ;




declare 1 error_control_table (2) aligned internal static,
        2 severity fixed bin (17) unaligned initial (
       (2)3),
        2 Soutput_stmt bit (1) unaligned initial (
         "1"b,
         "0"b),
        2 message char (64) varying initial (
         "Syntax error in ""^a"" statement.",
         "Premature end of input encountered."),
        2 brief_message char (20) varying initial (
         "^a",
         "Premature EOF.");

/*  */

valid_terminal: proc () returns (bit (1) aligned);

/*[4.4-1]*/
			/* name of communications channel, see CC92, Apendix A */
	i = length(token_value);

	if i < 6 | i > 32 then return("0"b);

/*[5.1-1]*/	i = index("abcdefghijklmnopqrst",substr(token_value,1,1));
	if i <= 0 then return("0"b);

	if substr(token_value,2,1) ^= "." then return("0"b);

	i = index("lh",substr(token_value,3,1));
	if i <= 0 then return("0"b);

	i = cv_dec_check_(substr(token_value,4,1),j);
	if j ^= 0 then return("0"b);

	if substr(token_value,3,1) = "h"
	then	do;	if i > 5 then return("0"b);	end;
	else	do;	if i > 2 then return("0"b);	end;

	i = cv_dec_check_(substr(token_value,5,2),j);

	if j ^= 0 then return("0"b);

/*[4.4-1]*/


	     new_terminal_name = token_value;

	     return ("1"b);

	end /* valid_terminal */ ;



valid_station: proc () returns (bit (1) aligned);

	     if token_value = "end" then return ("0"b);	/* special case */

	     if length (token_value) > 12 then return ("0"b);

	     if verify (token_value, ALPHANUMERICS) ^= 0 then return ("0"b);

	     new_station_name = token_value;

	     do station_ctl_eindex = 1 to station_ctl.current_size;

		station_ctl_eptr = addr (station_ctl.entries (station_ctl_eindex));

		if ^station_ctl_entry.inactive_sw
		then if station_ctl_entry.station_name = new_station_name
		     then return ("1"b);

	     end;

	     return ("0"b);

	end /* valid_station */ ;

/*  */

add:	proc ();

	     terminal_ctl.entry_count, terminal_ctl.current_size = terminal_ctl.current_size + 1;
	     string (terminal_ctl.flags (terminal_ctl.current_size)) = (36) "0"b;
	     terminal_ctl.device_channel (terminal_ctl.current_size) = new_terminal_name;
	     terminal_ctl.station_name (terminal_ctl.current_size) = new_station_name;

	     return;

	end /* add */ ;





		    cv_cmcs_tree_ctl.rd             03/17/86  1520.5rew 03/17/86  1430.1      207414



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


/* Modified on 10/02/81 by FCH, incorrect diags sometimes generated, BUG512 */
/* Modified on 06/01/81 by FCH, [4.4-2], once per process initialization, BUG468 */
/* Modified on 04/22/81 by FCH, [4.4-1], accept 01 as level number, accept minus in queue names, BUG468 */
/* Modified since Version 4.3 */


/* This procedure converts the ASCII definition of a COBOL MCS queue hierarchy
   into its binary representation.
*/
/*++

 BEGIN		/ dcl 1			/			/ do_init \
		/ dcl 01			/			/ do_init \
		/ declare 1		/			/ do_init \
		/ declare 01		/			/ do_init \
		/ end ;			/ close_db		/ fini \
		/ <any-token>		/ ERROR (1) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (2)		/ abort \

 do_init		/			/ init_tree LEX (2) 	/ get_level_name \

 get_level_name	/ <valid_level_name> 	/ set_level_name LEX (1)	/ follow \
		/ <any-token>		/ ERROR (3) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (2)		/ abort \

 follow		/ ,			/ close_tree_level LEX (1)	/ get_level_no \
		/ ;			/ close_tree LEX (1)	/ BEGIN \
		/ queue_name		/ LEX (1) 		/ get_queue_name \
		/ command_line		/ LEX (1) 		/ get_command_line \
		/ mp_line			/ LEX (1) 		/ get_mp_line \
		/ cobol_program_id		/ LEX (1) 		/ get_program_id \
 follow_error	/ <any-token>		/ ERROR (4) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (2)		/ abort \

 get_queue_name	/ <valid_queue_name>	/ set_queue_name LEX (1) 	/ follow \
		/ <any-token>		/ ERROR (5) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (6)		/ abort \

 get_command_line	/ <quoted-string>		/ set_command_line LEX (1)	/ follow \
		/ <any-token>		/ ERROR (10) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (7)		/ abort \

 get_mp_line	/ <quoted-string>		/ set_mp_line LEX (1)	/ follow \
		/ <any-token>		/ ERROR (10) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (1)		/ abort \

 get_program_id	/ <valid_program_id>	/ set_program_id LEX (1)	/ follow \
		/ <any-token>		/ ERROR (11) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (1)		/ abort \

 get_level_no	/ <valid_level>		/ open_tree_level LEX (1)	/ get_level_name \
		/ <any-token>		/ ERROR (8) NEXT_STMT	/ BEGIN \
		/ <no-token>		/ ERROR (9)		/ abort \

 abort		/			/			/ RETURN \
 fini		/			/			/ RETURN \

   ++*/

cv_cmcs_tree_ctl: proc;

dcl  new_station_name char (12),
     new_terminal_name char (8),
     j fixed bin,
     aclinfo_ptr ptr,				/* for use by tssi_ */
     queue_name char (32),
     temp3 char (3);

/*  */
%include cmcs_control_hdr;
%include cmcs_entry_dcls;
%include cmcs_station_ctl;
%include cmcs_tree_ctl;
%include cmcs_vfile_rs;

/*  */

/* automatic */

/* levels structure, used to keep control information until the complete level entry is
   ready to be inserted into the tree_ctl structure */

dcl (current_level, previous_level, queue_level) fixed bin;


dcl 1 levels (4),
    2 flags,
     (3 cmd_sw bit (1),
      3 mp_sw bit (1),
      3 cobol_program_id_sw bit (1),
      3 queue_sw bit (1),
      3 filler bit (33)) unaligned,
    2 tree_entry_index fixed bin,
    2 subtree_count fixed bin,
    2 level_name char (12),
    2 queue_name char (32),
    2 cmd_line_len fixed bin,
    2 cmd_line char (128),
    2 mp_line_len fixed bin,
    2 mp_line char (128),
    2 cobol_program_id_len fixed bin,
    2 cobol_program_id char (128);


declare (APstmt, APtoken) ptr,
         area_ptr ptr,				/* for use by lex_string_. */
         arg_length fixed bin (21),			/* length of command argument. */
         arg_ptr ptr,				/* ptr to command argument */
         bitcount fixed bin (24),
         code fixed bin (35),
         dname char (168),
         ename char (32),
         i fixed bin,
         n_chars fixed bin (21),
         object_name char (32),			/* entry name of output control seg */
        (pntep, object_ptr) ptr,			/* ptrs to base of pnte and pnt */
         source_ptr ptr;				/* ptr to base of persmf */

/* based */

declare  arg_string char (arg_length) based (arg_ptr) unaligned;

dcl  tree_ctl_entry_overlay (size (tree_ctl_entry)) fixed bin based (tree_ctl_eptr);
						/* used to zero out the entry before setting */

/* builtin */

declare (addr, collate, dimension, divide, index, length, null,
         reverse, size, string, substr, verify) builtin;

/* conditions */

declare  cleanup condition;

/* entries */

declare
         clock_ entry () returns (fixed bin (71)),
         com_err_ entry options (variable),
         cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35)),
         expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
         get_group_id_ entry () returns (char (32) aligned),
         get_process_id_ entry () returns (bit (36)),
         get_wdir_ entry () returns (char (168) aligned),
         hcs_$delentry_seg entry (ptr, fixed bin (35)),
         hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)),
         hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)),
         hcs_$terminate_noname entry (ptr, fixed bin (35)),
         hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)),
        (ioa_, ioa_$ioa_switch) entry options (variable),
         lex_error_ entry options (variable),
         lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*),
         bit (*), char (*) var, char (*) var, char (*) var, char (*) var),
         lex_string_$lex entry (ptr, fixed bin (21), fixed bin, ptr, bit (*), char (*), char (*), char (*),
         char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)),
         translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)),
         translator_temp_$release_all_segments entry (ptr, fixed bin (35)),

         tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)),
         tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)),
         tssi_$clean_up_segment entry (ptr),

         unique_chars_ entry (bit (*)) returns (char (15) aligned);

/* internal static */

declare ((BREAKS, IGBREAKS, LEXCTL, LEXDLM) char (128) varying,
         test_sw bit (1) init ("0"b),
/*[4.4-2]*/         first_time bit (1) aligned initial ("1"b)) int static;

dcl (LEGAL char (71) aligned initial ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ."),
     my_name char (16) initial ("cv_cmcs_tree_ctl"),
     alphanumerics char (64) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-")  /*[4.4-1]*/
     ) internal static options (constant);
dcl  letters char (52) defined (alphanumerics);

/* external static */

declare ((error_table_$badopt, error_table_$entlong,
         error_table_$bad_name, error_table_$translation_failed) fixed bin (35),
         sys_info_$max_seg_size fixed bin (18)
         ) external static;


/*  */

	call cu_$arg_ptr (1, arg_ptr, arg_length, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "Usage: cv_cmcs_tree_ctl pathname (-brief|-bf|-long|-lg)");
	     return;

	end;

	call expand_pathname_ (arg_string, dname, ename, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "^a", arg_string);
	     return;

	end;

	call cu_$arg_ptr (2, arg_ptr, arg_length, code);

	if code = 0
	then if arg_string = "-brief" | arg_string = "-bf"
	     then SERROR_CONTROL = "01"b;
	     else if arg_string = "-long" | arg_string = "-lg"
	     then SERROR_CONTROL = "10"b;
	     else do;
		call com_err_ (error_table_$badopt, my_name, "^a", arg_string);
		return;
	     end;

/*[5.0-1]*/	current_level,queue_level = 0;

	source_ptr = null;				/* Initialize for cleanup handler */
	object_ptr = null;				/* .. */
	area_ptr = null;				/* .. */
	aclinfo_ptr = null;				/* .. */

	on cleanup call clean_up;

	call hcs_$initiate_count (dname, ename, "", bitcount, 1b, source_ptr, code);

	if source_ptr = null
	then do;

report_error:

	     call com_err_ (code, my_name, "^a>^a", dname, ename);
	     return;

	end;

	i = index (ename, ".src") - 1;

	if i < 1 then do;

	     call com_err_ (error_table_$bad_name, my_name, "Source segment must have "".src"" suffix.");
	     return;

	end;

	if i + length (".control") > length (object_name)
	then do;

	     code = error_table_$entlong;
	     go to report_error;

	end;

	object_name = substr (ename, 1, i) || ".control";

	n_chars = divide (bitcount + 8, 9, 24, 0);

	dname = get_wdir_ ();

	call tssi_$get_segment (dname, object_name, object_ptr, aclinfo_ptr, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, "^a>^a", dname, object_name);
	     return;

	end;

/* Initialize Header Info */

	tree_ctl_ptr = object_ptr;			/* actual working ptr - other is generic ptr */

	call cmcs_fillin_hdr_ (object_ptr, tree_ctl_version, tree_ctl_hdr_len, tree_ctl_entry_len, code);

	if code ^= 0 then call com_err_ (code, my_name, "Continuing compilation.");

	tree_ctl.queue_count = 0;			/* not part of common hdr */

/* */

/*[4.4-2]*/	if first_time
	then do;

	     BREAKS = substr (collate, 1, 8) || substr (collate, 10, 24) || ":,()";
	     IGBREAKS = substr (BREAKS, 1, 8+24);

	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b,
		BREAKS, IGBREAKS, LEXDLM, LEXCTL);

/*[4.4-2]*/	     first_time = "1"b;

	end;

	call translator_temp_$get_segment (my_name, area_ptr, code);

	if area_ptr = null
	then do;

	     call com_err_ (code, my_name, "Making temporary segment in process directory.");
	     return;
	end;

	call lex_string_$lex (source_ptr, n_chars, 0, area_ptr, "1000"b, """", """", "/*", "*/", ";",
	     BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code);

	if code ^= 0
	then do;

	     call com_err_ (code, my_name, ename);
	     return;

	end;

	Pthis_token = APtoken;

	call SEMANTIC_ANALYSIS ();

	if MERROR_SEVERITY > 1
	then do;

	     call com_err_ (error_table_$translation_failed, my_name, ename);
	     call hcs_$delentry_seg (object_ptr, code);

	end;
	else do;

	     bitcount = 36 * (tree_ctl_hdr_len + tree_ctl_entry_len * tree_ctl.current_size);

	     call tssi_$finish_segment (object_ptr, bitcount, "101"b, aclinfo_ptr, code); /* rw, still needs copysw */

	     if code ^= 0
	     then call com_err_ (code, my_name, "Unable to set bitcount on ^a>^a to ^d", dname, object_name, bitcount);
	end;

	call clean_up;				/* terminate input segments */

	return;

/* Clean up procedure. Called if command is "quit" out of, and at end of normal processing. */

clean_up:
	procedure;

	     if source_ptr ^= null
	     then call hcs_$terminate_noname (source_ptr, code);

	     if object_ptr ^= null
	     then call hcs_$terminate_noname (object_ptr, code);

	     if area_ptr ^= null
	     then call translator_temp_$release_all_segments (area_ptr, code);

	     if aclinfo_ptr ^= null
	     then call tssi_$clean_up_segment (aclinfo_ptr);

	end /* clean_up */ ;



declare 1 error_control_table (11) aligned internal static,
        2 severity fixed bin (17) unaligned initial (
		     (11) 3),
        2 Soutput_stmt bit (1) unaligned initial (
         "1"b,
     (10) (1) "0"b),
        2 message char (96) varying initial (
         "New declarations must begin with ""declare 01"" or ""dcl 01"": ^a", /* 01 */
         "Premature end of input encountered.",		/* 02 */
         "Invalid level name: ^a",			/* 03 */
         "Level name must be followed by "","", queue, command, mp, or "";""", /* 04 */
         "Invalid queue name: ^a",			/* 05 */
         "Unexpected EOF in source segment. Looking for queue name. ^a", /* 06 */
         "Unexpected EOF in source segment. Looking for command line. ^a", /* 07 */
         "Invalid tree level: ^a",			/* 08 */
         "Unexpected EOF in source segment. Looking for tree level number. ^a", /* 09 */
         "Need quoted string for command or mp line: ^a",	/* 10 */
         "Bad program-id for cobol_program_id: ^a"),	/* 11 */
        2 brief_message char (24) varying initial (
         "Bad Declare: ^a",				/* 01 */
         "Unexpected EOF",				/* 02 */
         "Bad level name: ^a",			/* 03 */
         "Bad level args: ^a",			/* 04 */
         "Bad Queue Name: ^a",			/* 05 */
         "Msg Queue Name: ^a",			/* 06 */
         "Msg Command Line: ^a",			/* 07 */
         "Bad Tree Level: ^a",			/* 08 */
         "Msg Tree Level: ^a",			/* 09 */
         "Need quoted string ^a",			/* 10 */
         "Bad program-id ^a");			/* 11 */

/*  */

/* */

valid_level: proc () returns (bit (1) aligned);

	     if test_sw
	     then call ioa_ ("Parse: valid_level: ""^a"".", token_value);

	     i = cv_dec_check_ (token_value, j);

	     if j ^= 0 then return ("0"b);

	     if (i < 1 | i > 4) then return ("0"b);

	     if i > current_level
	     then do;

		if i > current_level + 1 then return ("0"b);
		if queue_level = current_level then return ("0"b);

	     end;
	     else do;				/* new level <= current level */

		if queue_level = 0 then return ("0"b);	/* didn't specify a queue name for abs tree path */
		else if queue_level ^= current_level then return ("0"b); /* should never find this */

		queue_level = 0;			/* last level had good queue, set up for next time */

	     end;

	     previous_level = current_level;
	     current_level = i;
	     return ("1"b);

	end /* valid_level */ ;

/* */

valid_program_id: proc () returns (bit (1) aligned);

	     if test_sw
	     then call ioa_ ("Parse: valid_program_id: ""^a"".", token_value);

	     if length (token_value) > 30 then return ("0"b); /* COBOL variables limited to 30 chars */

	     if verify (token_value, alphanumerics) > 0 then return ("0"b);

	     if index (letters, substr (token_value, 1, 1)) = 0 then return ("0"b); /* 1st char must be letter */

	     return ("1"b);

	end /* valid_program_id */ ;

/* */

valid_queue_name: proc () returns (bit (1) aligned);

	     if test_sw
	     then call ioa_ ("Parse: valid_queue_name: ""^a"".", token_value);

	     if length (token_value) > 21 then return ("0"b); /* COBOL queue names limited to 21 chars, plus suffix */

	     if verify (token_value, alphanumerics) > 0 then return ("0"b);

	     if index (letters, substr (token_value, 1, 1)) = 0 then return ("0"b); /* 1st char must be letter */

	     return ("1"b);

	end /* valid_queue_name */ ;

/* */

valid_level_name: proc () returns (bit (1) aligned);

	     if test_sw
	     then call ioa_ ("Parse: valid_level_name: ""^a"".", token_value);

	     if length (token_value) > 12 then return ("0"b); /* COBOL variables limited to 12 chars */

	     if verify (token_value, alphanumerics) > 0 then return ("0"b);

	     if index (letters, substr (token_value, 1, 1)) = 0 then return ("0"b); /* 1st char must be letter */

	     return ("1"b);

	end /* valid_level_name */ ;

/* */

close_db:	proc ();

	     if test_sw
	     then call ioa_ ("Semantics: close_db: ""^a"".", token_value);

	     return;

	end /* close_db */ ;

/* */

close_tree: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: close_tree: ""^a"".", token_value);

	     call close_tree_level;

	end /* close_tree */ ;

/* */

close_tree_level: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: close_tree_level: ""^a"".", token_value);

	     i = levels (current_level).tree_entry_index; /* get location of tree_ctl_entry */
	     tree_ctl_eptr = addr (tree_ctl.entries (i)); /* for based operations */
	     tree_ctl_entry_overlay (*) = 0;		/* wipe the slate clean */

	     tree_ctl_entry.level_no = current_level;	/* for perusing the tree elsewhere */
	     tree_ctl_entry.cmd_sw = levels (current_level).cmd_sw;
	     tree_ctl_entry.queue_sw = levels (current_level).queue_sw;
	     tree_ctl_entry.mp_sw = levels (current_level).mp_sw;
	     tree_ctl_entry.cobol_program_id_sw = levels (current_level).cobol_program_id_sw;

	     queue_name,
		tree_ctl_entry.queue_name = levels (current_level).queue_name;
	     tree_ctl_entry.cmd_line_len = levels (current_level).cmd_line_len;
	     tree_ctl_entry.mp_line_len = levels (current_level).mp_line_len;
	     tree_ctl_entry.cmd_line = levels (current_level).cmd_line;

/* set ptr variables to null () for subsequent testing */

	     tree_ctl_entry.queue_ctl_eptr,
		tree_ctl_entry.iocb_ptr,
		tree_ctl_entry.msg_hdr_ptr,
		tree_ctl_entry.msg_seg_ptr,
		tree_ctl_entry.buffer_ptr,
		tree_ctl_entry.tseg_ptr = null ();

	     tree_ctl_entry.switch_name = "";		/* so we dont print junk for unused entries */

	     tree_ctl_entry.mp_line = levels (current_level).mp_line;
	     tree_ctl_entry.cobol_program_id_len = levels (current_level).cobol_program_id_len;
	     tree_ctl_entry.cobol_program_id = levels (current_level).cobol_program_id;

	     do i = 1 to 4;				/* copy all level names, including blank trailing names */

		tree_ctl_entry.level_names (i) = levels (i).level_name;

	     end;

	     do i = 1 to current_level;		/* copy all the subtree counts */

		j = levels (i).tree_entry_index;	/* index into tree_ctl for the given entry */
		tree_ctl.entries (j).subtree_count = levels (i).subtree_count;

	     end;

	     if tree_ctl_entry.queue_sw		/* if entry is for queue, bump count */
	     then do;				/* it's an entry for a queue */

		do j = 1 to tree_ctl.current_size - 1;

		     if queue_name = tree_ctl.entries (j).queue_name
		     then do;

			tree_ctl_entry.queue_ctl_eindex = tree_ctl.entries (j).queue_ctl_eindex;
						/* point to the first occurrance */
			go to close_tree_level_ret;
		     end;
		end;

		tree_ctl_entry.queue_ctl_eindex,
		     tree_ctl.queue_count = tree_ctl.queue_count + 1; /* drop-thru means first occurance */
	     end;

close_tree_level_ret:
	     return;

	end /* close_tree_level */ ;

/* */

init_tree: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: init_tree: ""^a"".", token_value);

	     current_level, previous_level = 1;		/* initialize for new set */
	     call open_tree_level;

	     return;

	end /* init_tree */ ;

/* */

open_tree_level: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: open_tree_level: ""^a"".", token_value);

	     tree_ctl.current_size, tree_ctl.entry_count = tree_ctl.current_size + 1; /* next place to store an entry */
	     levels (current_level).tree_entry_index = tree_ctl.current_size; /* remember it */

	     if current_level = 1
	     then do;

		string (levels (1).flags) = (36) "0"b;

		levels (1).level_name, levels (2).level_name, levels (3).level_name, levels (4).level_name,
		     levels (1).queue_name,
		     levels (1).cmd_line,
		     levels (1).mp_line,
		     levels (1).cobol_program_id = "";

		levels (1).subtree_count,
		     levels (1).cmd_line_len,
		     levels (1).mp_line_len,
		     levels (1).cobol_program_id_len = 0;

	     end;
	     else do;				/* current_level ^= 1 */

		do j = 1 to current_level - 1;

		     levels (j).subtree_count = levels (j).subtree_count + 1; /* bump all ancestor counts by 1 */

		end;

		if current_level ^= 4		/* clear out all following level names */
		then do i = current_level + 1 to 4;	/* just the trailing fields */

		     levels (i).level_name = "";

		end;

		j = current_level - 1;		/* copy from prev level, newer args overlay */

		string (levels (current_level).flags) = string (levels (j).flags);
		levels (current_level).level_name = levels (j).level_name;
		levels (current_level).queue_name = levels (j).queue_name;
		levels (current_level).subtree_count = 0;
		levels (current_level).cmd_line_len = levels (j).cmd_line_len;
		levels (current_level).cmd_line = levels (j).cmd_line;
		levels (current_level).mp_line_len = levels (j).mp_line_len;
		levels (current_level).mp_line = levels (j).mp_line;
		levels (current_level).cobol_program_id_len = levels (j).cobol_program_id_len;
		levels (current_level).cobol_program_id = levels (j).cobol_program_id;

		if current_level > previous_level
		then if previous_level = queue_level
		     then call ioa_ ("Warning: higher level follows queue_name level.");
		     else;
		else queue_level = 0;		/* ok - reset for next time */

	     end;

	     return;

	end /* open_tree_level */ ;

/* */

set_mp_line: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: set_mp_line: ""^a"".", token_value);

	     if length (token_value) > 128
	     then do;

		levels (current_level).mp_line_len = 128; /* truncate and push on to catch other errors */
		levels (current_level).mp_line = substr (token_value, 1, 128);

		if test_sw
		then call ioa_ ("Warning: mp line truncated to 128 chars. Continuing.");

	     end;

	     else do;

		levels (current_level).mp_line_len = length (token_value);
		levels (current_level).mp_line = token_value;

	     end;

	     levels (current_level).mp_sw = "1"b;

	     return;

	end /* set_mp_line */ ;

/* */

set_command_line: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: set_command_line: ""^a"".", token_value);

	     if length (token_value) > 128
	     then do;

		levels (current_level).cmd_line_len = 128; /* truncate and push on to catch other errors */
		levels (current_level).cmd_line = substr (token_value, 1, 128);

		if test_sw
		then call ioa_ ("Warning: command line truncated to 128 chars. Continuing.");

	     end;
	     else do;

		levels (current_level).cmd_line_len = length (token_value);
		levels (current_level).cmd_line = token_value;

	     end;
	     levels (current_level).cmd_sw = "1"b;

	     call ioa_ ("Warning: The command_line arguments are ignored in this version."); /* just so they know */

	     return;

	end /* set_command_line */ ;

/* */

set_program_id: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: set_program_id: ""^a"".", token_value);

	     levels (current_level).cobol_program_id_len = length (token_value);
	     levels (current_level).cobol_program_id = token_value;

	     levels (current_level).cobol_program_id_sw = "1"b;
	     return;

	end /* set_program_id */ ;

/* */

set_queue_name: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: set_queue_name: ""^a"".", token_value);

	     levels (current_level).queue_name = token_value;
	     queue_level = current_level;		/* to check that queue was given when needed */
	     levels (current_level).queue_sw = "1"b;

	     return;

	end /* set_queue_name */ ;

/* */

set_level_name: proc ();

	     if test_sw
	     then call ioa_ ("Semantics: set_level_name: ""^a"".", token_value);

	     levels (current_level).level_name = token_value;

	     return;

	end /* set_level_name */ ;

test:	entry;					/* used to print out parse and semantics calls */

	test_sw = "1"b;
	return;






		    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
