



		    create_daemon_queues.pl1        10/28/88  1351.7rew 10/28/88  1234.0       94383



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

/* format: style2  */
create_daemon_queues:
cdq:
     procedure options (variable);

/* Command for creating the dprint request queues and setting general access to them */
/* Uses iod_tables file to find out what request_types to create queues
   *  for. Already existing queues are left alone.
   *
   *  create_daemon_queues PATH {-control_args}
   *
   *      PATH is the pfull pathname of an iod_tables segment
   *
   *
   *      -dr path
   *	-directory path
   *		the queues will be created in the directory "path".
   *		Defaults to >daemon_dir_dir>io_daemon_dir.
   *		The iod tables iod_tables are used
   *
   *	-reset_access  forces default acl terms if queues already exist.
   *
   * Coded October 1973 by Robert S. Coren
   * Modified by J. Stern, 12/30/74
   * Modified by J. C. Whitmore, 4/78, for max queues per request type.
   * Modified by J. C. Whitmore, 10/78, for version 3 iod_tables format.
   * Modified by Benson I. Margulies for PATHnames
*/


/****^  HISTORY COMMENTS:
  1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199):
     Changed to handle version 5 i/o daemon tables.
                                                   END HISTORY COMMENTS */



	dcl     aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_max_authorization_ entry returns (bit (72) aligned);
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     message_segment_$create
				 entry (char (*), char (*), fixed bin (35));
	dcl     message_segment_$ms_acl_add
				 entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
	dcl     system_info_$access_ceiling
				 entry (bit (72) aligned);


	dcl     system_high		 bit (72) aligned;
	dcl     max_auth		 bit (72) aligned;
	dcl     testing		 bit (1) aligned;
	dcl     code		 fixed bin (35);
	dcl     table_name		 char (32);
	dcl     (dir, table)	 char (256);
	dcl     dir_name		 char (168);
	dcl     i			 fixed bin;
	dcl     j			 fixed bin;
	dcl     nargs		 fixed bin;
	dcl     mseg_name		 char (32);
	dcl     max_queues		 fixed bin;
	dcl     reset_access	 bit (1);
	dcl     (got_pn, got_dr)	 bit (1);

	dcl     AROS		 bit (36) int static options (constant) init ("10111"b);
	dcl     NONE		 bit (36) int static options (constant) init (""b);

	declare Default_io_daemon_dir	 init (">daemon_dir_dir>io_daemon_dir") char (168) int static options (constant);
	declare Default_iod_tables	 init ("iod_tables") char (32) int static options (constant);

	dcl     1 acla		 (4) aligned int static options (constant),
		2 userid		 char (32) init ("IO.SysDaemon.*", "*.SysDaemon.*", "*.*.*", "*.*.*"),
		2 access		 bit (36) init ((4) (1)"111"b),
						/* REW real access for all acl terms */
		2 ex_access	 bit (36) init ("11111"b, (2) (1)"10111"b, "00000"b),
						/* ADROS AROS AROS NULL */
		2 errcode		 fixed bin (35);

	dcl     1 an_acl		 (4) aligned like acla;
						/* automatic version */
	dcl     nacl		 fixed bin;	/* number of acl entries defined above */


	dcl     argptr		 ptr;
	dcl     arglen		 fixed bin;
	dcl     arg		 char (arglen) based (argptr);


	dcl     (
	        error_table_$badopt,
	        error_table_$namedup,
	        error_table_$inconsistent,
	        error_table_$noarg,
	        error_table_$too_many_args
	        )			 fixed bin (35) ext static;

	dcl     myname		 char (20) int static init ("create_daemon_queues");
	dcl     cleanup		 condition;

	dcl     (addr, after, null, ptr, substr)
				 builtin;
%page;

	testing = "0"b;				/* not testing unless "-dir" option specified */
	reset_access = "0"b;			/* do not set access on existing queues */

/* find arguments if any */

	call cu_$arg_count (nargs, code);		/* get number of arguments given */
	if code ^= 0
	then do;
		call com_err_ (code, myname);
		return;				/* We do not make a very useful AF */
	     end;

	table = "";
	dir = "";
	reset_access, got_pn, got_dr = ""b;
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argptr, arglen, (0));	/* guaranteed by the doloop limit */

	     if substr (arg, 1, 1) = "-"
	     then do;				/* control argument */

		     if arg = "-dr" | arg = "-dir" | arg = "-directory"
		     then do;

/* REMOVE -dir SOMEDAY --bim */
			     i = i + 1;		/* look at next arg */
			     if i > nargs
			     then do;
no_dp:
				     call com_err_ (error_table_$noarg, myname, "-directory requires a pathname.")
					;
				     return;
				end;
			     call cu_$arg_ptr (i, argptr, arglen, (0));
						/* we know how many we have */
			     if substr (arg, 1, 1) = "-"
			     then do;
				     call com_err_ (error_table_$noarg, myname,
					"-directory requires a pathname. Control argument ^a was in error.",
					arg);
				     return;
				end;
			     if got_pn
			     then do;
				     call com_err_ (error_table_$inconsistent, myname,
					"-directory may not be given if a iod table pathname is given.");
				     return;
				end;

			     if got_dr
			     then do;
				     call com_err_ (error_table_$inconsistent, myname,
					"-directory may not be supplied twice");
				     return;
				end;
			     got_dr = "1"b;
			     dir = arg;		/* do absolute pathname later */
			     testing = "1"b;	/* test dir specified */
			end;

		     else if arg = "-reset_access"
		     then reset_access = "1"b;	/* set access on existing queues */
		     else do;
			     call com_err_ (error_table_$badopt, myname, arg);
			     return;
			end;
		end;				/* the control arg dept. */
	     else do;				/* a pathname */
		     if got_pn
		     then do;
			     call com_err_ (error_table_$too_many_args, myname,
				"Only one pathname may be supplied.");
			     return;
			end;
		     got_pn = "1"b;
		     table = arg;
		     testing = "1"b;
		end;				/* the pathname */
	end;					/* the control arg loop */


	if got_dr
	then do;
		call absolute_pathname_ (dir, dir_name, code);
		if code ^= 0
		then do;
			call com_err_ (code, myname, "directory pathname ^a.", dir);
			return;
		     end;
		table_name = Default_iod_tables;
	     end;
	else if got_pn
	then do;
		call expand_pathname_ (table, dir_name, table_name, code);
		if code ^= 0
		then do;
			call com_err_ (code, myname, "table pathname ^a.", table);
			return;
		     end;
	     end;
	else do;					/* vanilla case */
		table_name = Default_iod_tables;
		dir_name = Default_io_daemon_dir;
	     end;

/* If we're not testing, make sure caller's max authorization is "system_high". */
/* If it's not, any queues created will not be accessible at all authorizations. */

	if ^testing
	then do;
		max_auth = get_max_authorization_ ();
		call system_info_$access_ceiling (system_high);
		if ^aim_check_$equal (system_high, max_auth)
		then /* max authorization is not system high */
		     call com_err_ (0, myname, "Warning -- Your maximum authorization is not ""system_high"".");
	     end;

/* get a pointer to the iod_tables segment */

	ithp = null ();
	on cleanup
	     begin;
		if ithp ^= null ()
		then call hcs_$terminate_noname (ithp, (0));
	     end;
	call hcs_$initiate (dir_name, table_name, "", (0), (0), ithp, code);
	if ithp = null ()
	then do;
		call com_err_ (code, myname, "^a>^a", dir_name, table_name);
		return;
	     end;

	if iod_tables_hdr.version ^= IODT_VERSION_5
	then do;					/* check version number */
		call com_err_ (0, myname, "Wrong version number for iod_tables.");
		go to finish;
	     end;

/*  now create the queues */

	qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset);
						/* get q group table ptr */

	do j = 1 to q_group_tab.n_q_groups;

	     qgtep = addr (q_group_tab.entries (j));
	     an_acl = acla;
	     max_queues = qgte.max_queues;		/* get max queues for this request type */
	     if qgte.driver_id = "IO.SysDaemon.*"
	     then do;				/* standard system driver */
		     an_acl (2).ex_access = AROS;	/* let SysDaemons use it like other users */
		     an_acl (3).userid = "*.*.*";	/* this queue is for all users */
		     an_acl (3).ex_access = AROS;	/* give them all access */
		     nacl = 3;			/* say only three entries are defined */
		end;
	     else do;				/* non-standard driver for this queue */
		     an_acl (2).ex_access = NONE;	/* project must request SysDaemon access */
		     an_acl (3).userid = "*." || after (qgte.driver_id, ".");
						/* give access to all on project */
		     an_acl (3).ex_access = AROS;	/* give them all access */
		     nacl = 4;			/* we have four entries now */
		end;

	     do i = 1 to max_queues;
		call ioa_$rsnnl ("^a_^d.ms", mseg_name, arglen, qgte.name, i);
		call message_segment_$create (dir_name, mseg_name, code);

		if code = 0
		then do;				/* created one, set up acl. */
			call ioa_ ("^a created.", mseg_name);
set_access:
			call message_segment_$ms_acl_add (dir_name, mseg_name, addr (an_acl), nacl, code);
			if code ^= 0
			then call com_err_ (code, myname, "Adding extended acl to ^a", mseg_name);
		     end;

		else if code ^= error_table_$namedup
		then call com_err_ (code, myname, "Could not create ^a", mseg_name);
		else if reset_access
		then go to set_access;		/* if queue exists, skip set_acl unless asked */
	     end;
	end;


finish:
	call hcs_$terminate_noname (ithp, code);

	return;
%page;
%include iod_tables_hdr;
%page;
%include q_group_tab;

     end create_daemon_queues;




		    find_next_request_.pl1          10/28/88  1351.7rew 10/28/88  1234.0      147339



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

find_next_request_: proc (dev_class_index, descr_ptr) returns (bit (1) aligned);

/* This is the io_coordinator procedure used for reading request messages
   *  out of the IO daemon queues. It is normally the only procedure that
   *  reads from message segments into request descriptors.
   *
   *  This procedure returns a bit(1) result indicating whether or not it actually
   *  found a message in the queue(s).
   */

/* Coded August 1973 by Robert S. Coren */
/* Modified for the Access Isolation Mechanism by J. Stern, 12/26/74 */
/* Modified by J. Stern, 11/25/75 */
/* Modified by J. C. Whitmore, 4/78, for max_queues per request type and new iod_tables format */
/* Modified by J. C. Whitmore, 7/78, for priority requests in waiting list */
/* Modified by J. C. Whitmore, 4/80, to mark the state of running requests */
/* Modified by R. Kovalcik, 6/82, to handle defer_until_process_termination */
/* Modified by R. Kovlacik, 1/83, to fix a problem in interaction between dupt and multiple printers */
/* Modified by C. Marker, 02/23/85, to use message_segment_$read_message_index to support version 5 message segments */


/****^  HISTORY COMMENTS:
  1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.
                                                   END HISTORY COMMENTS */


	dcl     dev_class_index	 fixed bin;	/* index of device class entry (INPUT) */
	dcl     descr_ptr		 ptr;		/* pointer to request descriptor to be filled in (INPUT) */

	dcl     code		 fixed bin (35);
	dcl     err_len		 fixed bin;
	dcl     err_mess		 char (200);
	dcl     found		 bit (1) aligned;
	dcl     (queue, q)		 fixed bin;	/* queue number variables */

	dcl     last_id		 bit (72) aligned;
	dcl     dcp		 ptr;
	dcl     retp		 ptr;
	dcl     q_idx		 fixed bin;

	dcl     wlp		 ptr int static;	/* ptr to the waiting list */
	dcl     dcx		 fixed bin;	/* device class table entry index */
	dcl     i			 fixed bin;	/* loop variable */
	dcl     auth		 bit (72) aligned;	/* used to hold the sender authorization of a message */
	dcl     auth_string		 char (170);	/* char string version of "auth" */
	dcl     message_len		 fixed bin (18);	/* bit length of based_message */
	dcl     based_message	 bit (message_len) aligned based; /* a message read from a queue */
	dcl     (x, y, z)		 fixed bin;	/* waiting list entry subscripts */

	dcl     convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     free_oldest_request_$force entry;
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     iodc_message_	 entry (bit (3) aligned, fixed bin (35), char (*));
	dcl     message_segment_$read_message_index entry (fixed bin, ptr, ptr, fixed bin (35));
	dcl     message_segment_$update_message_index entry (fixed bin, fixed bin (18), bit (72) aligned, ptr, fixed bin (35));
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     set_lock_$unlock	 entry (bit (36) aligned, fixed bin (35));

	dcl     re_read		 bit (2) int static options (constant) init ("00"b); /* mseg code to read given msg id */
	dcl     next_msg		 bit (2) int static options (constant) init ("01"b); /* mseg code to read next message forward */
	dcl     priority		 fixed bin int static options (constant) init (2); /* state code for priority requests */
	dcl     normal		 fixed bin int static options (constant) init (1); /* state code for normal priority */
	dcl     unused		 fixed bin int static options (constant) init (0); /* state code for a free entry */

	dcl     error_table_$bad_segment fixed bin (35) ext;
	dcl     error_table_$invalid_lock_reset fixed bin (35) ext;
	dcl     error_table_$no_message fixed bin (35) ext;
	dcl     error_table_$notalloc	 fixed bin (35) ext;

	dcl     (addr, unspec)	 builtin;
%page;

	dcx = dev_class_index;
	dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx)); /* get ptr to device class */
	qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index)); /* get q group table entry ptr */
	retp, mseg_message_info_ptr = descr_ptr;	/* this points to mseg return args and request desc */

	do queue = 1 to qgte.max_queues;

	     call read_one;				/* read a message from queue or list */
	     if found then do;			/* got one */
		     retp -> request_descriptor.q = q;	/* set source queue */
		     retp -> request_descriptor.charge_q = queue; /* and charging queue */
		     retp -> request_descriptor.dev_class_index = dcx;
		     return ("1"b);
		end;
	end;

/* no request found */

	return ("0"b);


read_one: proc;

/* This subroutine first checks the waiting list of the target device class.
   If the waiting list is non-empty, the first waiting request is reread.

   Otherwise, the ID of the last read message from the current queue is
   checked.  If zero, the first message is read from the queue.  
   If non-zero, the next message is read.

   If the authorization of the new message fits the target device
   class access range and it should not be deferred for process termination,
   the message is returned.  Otherwise it is appended to
   the waiting list of some other device class and the entire above procedure
   is repeated.
*/

	dcl     direction		 bit (2) aligned;	/* = 01 if reading ahead, 00 if rereading */
	dcl     (bad, space)	 fixed bin;
	dcl     dupt		 bit (1) aligned;	/* flag to note process is still around */
	dcl     scan_wait		 bit (1) aligned;	/* flag to scan wait list */

	found = "0"b;
	scan_wait = (dcte.first_waiting (queue) ^= 0);
	z = dcte.last_waiting (queue);		/* save stop marker */

next:	if scan_wait then do;			/* loop through requests in waiting list */
		x = dcte.first_waiting (queue);	/* get waiting list head index for this queue */
		last_id = wlp -> waiting_list.ms_id (x);/* get message id of the request */
		if wlp -> waiting_list.state (x) = priority then
		     retp -> request_descriptor.priority_request = "1"b;
		else retp -> request_descriptor.priority_request = ""b;
		q = wlp -> waiting_list.orig_q (x);	/* could have come from another queue */
		if wlp -> waiting_list.next (x) = 0 then /* no more requests in waiting list */
		     dcte.last_waiting (queue),
			dcte.first_waiting (queue) = 0;
		else dcte.first_waiting (queue) = wlp -> waiting_list.next (x); /* advance the list */
		dcte.n_waiting = dcte.n_waiting - 1;
		if (x = z) | (dcte.first_waiting (queue) = 0) then scan_wait = "0"b; /* if we are done with this, note it */
		call free_wle;			/* free the waiting list entry */
		direction = re_read;
	     end;

	else do;					/* look through the queue */
		q = queue;			/* read a fresh request from the current queue */
		last_id = qgte.last_read (q);		/* prepare to read request after the last */
		retp -> request_descriptor.priority_request = "0"b; /* this can't be priority */
		direction = next_msg;
	     end;

	q_idx = qgte.mseg_index (q);			/* get message segment index for read call */
	if q_idx = 0 then return;			/* if it was dropped forget it */

	bad, space = 0;

	unspec (mseg_message_info) = ""b;
	mseg_message_info.version = MSEG_MESSAGE_INFO_V1;
	mseg_message_info.ms_id = last_id;

retry:	if last_id = "0"b				/* no previous message, read one first */
	then mseg_message_info.message_code = MSEG_READ_FIRST;
	else if direction = re_read then mseg_message_info.message_code = MSEG_READ_SPECIFIED;
	else if direction = next_msg then mseg_message_info.message_code = MSEG_READ_AFTER_SPECIFIED;

	call message_segment_$read_message_index (q_idx, iodc_static.req_seg_ptr, mseg_message_info_ptr, code);
	if code = 0 then do;			/* fine */

		dupt = "0"b;			/* prepare to check for defer_until process termination */
		if mseg_message_info.ms_ptr -> queue_msg_hdr.defer_until_process_termination then do; /* check to see if defer_until_process_termination is requested */
			call set_lock_$lock (mseg_message_info.ms_ptr -> queue_msg_hdr.dupt_lock, 1, code); /* test to see if the process is still around */
			if (code ^= 0) & (code ^= error_table_$invalid_lock_reset) then dupt = "1"b; /* it is, defer request until later */
			else call set_lock_$unlock (mseg_message_info.ms_ptr -> queue_msg_hdr.dupt_lock, code); /* else, unlock the lock for good measure */
		     end;				/* end of DUPT processing */

		if direction = re_read then do;	/* request is from wait list */
			if ^dupt then do;		/* when request was from wait list and dupt is ok, we are done */
				call mark_request (STATE_RUNNING, code);
				if code ^= 0 then go to next;
				found = "1"b;
			     end;
			else do;
				call add_wle (dupt, dctep); /* otherwise, add it back to wait list! */
				goto flush;	/* and try again */
			     end;
		     end;

		else do;				/* else request is from queue, check authorization */
			qgte.last_read (q) = mseg_message_info.ms_id; /* update last_read */
			auth = mseg_message_info.sender_authorization;
			do i = qgte.first_dev_class to qgte.last_dev_class; /* find dev class with right access range */
			     dcp = addr (iodc_static.dctp -> dev_class_tab.entries (i));
			     if aim_check_$greater_or_equal (auth, dcp -> dcte.min_access) then
				if aim_check_$greater_or_equal (dcp -> dcte.max_access, auth) then /* range is right */
				     if (dcx = i) & ^dupt then do; /* bingo, this is our device class and we aren't waitng for process termination */
					     call mark_request (STATE_RUNNING, code);
					     if code ^= 0 then go to next;
					     found = "1"b;
					     return;
					end;
				     else do;	/* request belongs to another dev class or is waiting process termination, add it to waiting list */
					     call add_wle (dupt, dcp);
					     go to flush; /* free this one and try the next one */
					end;
			end;

/* come here if we fell through,  i.e. no device class had right access range for request */

			auth_string = "";
			call convert_authorization_$to_string_short (auth, auth_string, code);
			call ioa_$rsnnl ("Request skipped for request type ^a.^/Unexpected access class: ^a",
			     err_mess, err_len, qgte.name, auth_string);
			call iodc_message_ ("101"b, 0, err_mess); /* tell the operator */
flush:			message_len = mseg_message_info.ms_len;
			free mseg_message_info.ms_ptr -> based_message in (req_area); /* free request */
			go to next;
		     end;

	     end;
	else if code = error_table_$no_message then
	     /* this is okay too, but there's no message */
	     if direction = re_read then go to next;	/* waiting request must have been cancelled */
	     else return;				/* the queue is exhausted */

	else do;					/* not so good */
		if code = error_table_$bad_segment then
		     if bad = 0 then do;		/* message seg. was just salvaged, try again */

			     bad = 1;		/* once */
			     call ioa_$rsnnl ("Requests may be lost from queue ^d of request type ""^a"".",
				err_mess, err_len, q, qgte.name);
			     call iodc_message_ ("101"b, code, err_mess);
			     go to retry;
			end;

		if code = error_table_$notalloc then
		     if space = 0 then do;		/* if we couldn't allocate try freeing one */

			     space = 1;
			     call free_oldest_request_$force;
			     go to retry;
			end;

/* come here if an unrecoverable error occurred */
/* report error and drop the offending queue */

		call ioa_$rsnnl ("Dropping queue ^d of queue group ^a",
		     err_mess, err_len, q, qgte.name);
		call iodc_message_ ("101"b, code, err_mess); /* tell the operator */
		qgte.mseg_index (q) = 0;		/* turn off the queue */

	     end;

	return;

     end read_one;
%page;

add_wle: proc (dupt_flag, dc_ptr);

	dcl     dupt_flag		 bit (1) aligned;
	dcl     dc_ptr		 pointer;

	call allocate_wle;				/* get a waiting list entry */
	if y = 0 then do;				/* ugh, out of space */
		call ioa_$rsnnl ("Waiting list full.  Request skipped from queue ^a_^d.ms",
		     err_mess, err_len, qgte.name, q);
		call iodc_message_ ("101"b, 0, err_mess); /* tell the operator */
	     end;
	else do;					/* chain request into waiting list */
		wlp -> waiting_list.ms_id (y) = mseg_message_info.ms_id;
		wlp -> waiting_list.state (y) = normal; /* normal waiting request */
		wlp -> waiting_list.orig_q (y) = q;	/* queue it is from */
		if dc_ptr -> dcte.last_waiting (q) > 0 then /* waiting list is not empty */
		     wlp -> waiting_list.next (dc_ptr -> dcte.last_waiting (q)) = y;
		else dc_ptr -> dcte.first_waiting (q) = y;
		dc_ptr -> dcte.last_waiting (q) = y;
		dc_ptr -> dcte.n_waiting = dc_ptr -> dcte.n_waiting + 1;
		if dupt_flag then call mark_request (STATE_DUPT, (0));
		else call mark_request (STATE_DEFERRED, (0));
	     end;

     end add_wle;
%page;

allocate_wle: proc;					/* procedure to allocate a waiting list entry */

	y = wlp -> waiting_list.first_free;
	if y > 0 then do;				/* take block from free list */
		wlp -> waiting_list.first_free = wlp -> waiting_list.next (y); /* move free list head */
		wlp -> waiting_list.next (y) = 0;	/* don't leave junk around */
	     end;
	else if wlp -> waiting_list.last_used = max_wl_size then y = 0; /* no more room */
	else y, wlp -> waiting_list.last_used = wlp -> waiting_list.last_used + 1; /* raise high-water mark */
	if y > 0 then do;				/* clear the new entry */
		wlp -> waiting_list.state (y) = unused;
		wlp -> waiting_list.next (y) = 0;
		wlp -> waiting_list.orig_q (y) = 0;
		wlp -> waiting_list.ms_id (y) = ""b;
	     end;

     end allocate_wle;
%page;

free_wle: proc;					/* procedure to free a waiting list entry */

	if x = wlp -> waiting_list.last_used then do;	/* lower high-water mark */
		wlp -> waiting_list.last_used = wlp -> waiting_list.last_used - 1;
		wlp -> waiting_list.next (x) = 0;
	     end;
	else do;					/* add to head of free list */
		wlp -> waiting_list.next (x) = wlp -> waiting_list.first_free;
		wlp -> waiting_list.first_free = x;
	     end;
	wlp -> waiting_list.state (x) = unused;		/* mark it as free */
	wlp -> waiting_list.ms_id (x) = ""b;

     end free_wle;
%page;

mark_request: proc (new_state, code);

	dcl     new_state		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     msg_p		 ptr;
	dcl     msg_id		 bit (72) aligned;
	dcl     msg_len		 fixed bin (18);
	dcl     retry		 fixed bin;

	msg_p = mseg_message_info.ms_ptr;		/* get ptr to msg text */
	msg_p -> queue_msg_hdr.state = new_state;	/* tell user */
	msg_id = mseg_message_info.ms_id;		/* get ready to re-write the message */
	msg_len = mseg_message_info.ms_len;
	retry = 0;
update:	call message_segment_$update_message_index (q_idx, msg_len, msg_id, msg_p, code);
	if code ^= 0 then /* normal test should be cheap */
	     if code = error_table_$bad_segment		/* message seg was salvaged */
	     then if retry = 0 then do;		/* try once more */
			retry = 1;
			go to update;
		     end;

     end mark_request;
%page;

init: entry (a_ptr);

	dcl     a_ptr		 ptr;

	stat_p = a_ptr;				/* get ptr to iodc_static */

	wlp = iodc_static.wait_list_ptr;
	wlp -> waiting_list.first_free,
	     wlp -> waiting_list.last_used = 0;

	do dcx = 1 to iodc_static.dctp -> dev_class_tab.n_classes; /* init per device class info */
	     dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx));
	     dcte.n_waiting = 0;
	     do q = 1 to 4;				/* clear waiting list indices for all possible queues */
		dcte.first_waiting (q),
		     dcte.last_waiting (q) = 0;
	     end;
	end;

	return;
%page; %include device_class;
%page; %include iod_tables_hdr;
%page; %include iodc_static;
%page; %include iodc_wait_list;
%page; %include mseg_message_info;
%page; %include q_group_tab;
%page; %include queue_msg_hdr;
%page; %include request_descriptor;

     end find_next_request_;




		    free_oldest_request_.pl1        03/14/85  0831.6r   03/13/85  1025.6       58995



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


free_oldest_request_: proc;

/* Procedure to free oldest inactive request and associated descriptor.
   *  Normally invoked in response to alarm call set when request was
   *  completed, but also called by find_next_request_ if it didn't have space
   *  to allocate a fresh message.
   *
   *  This procedure will also delete the file if the user so requested (first
   * making sure he has "m" access on the directory containing it).
*/

/* Coded August 1973 by Robert S. Coren */
/* Modified by J. Stern, 12/27/74 */
/* Modified by J. Stern, 11/25/75 */
/* Modified by J. C. Whitmore, 4/78, to use the new queue_msg_hdr format */
/* Modified by C. Marker, 02/23/85, to use version 5 message segments */

dcl  desc_off fixed bin (18);
dcl  desc_p ptr;					/* pointer to a descriptor */

dcl  code fixed bin (35);
dcl  mask_code fixed bin (35);
dcl  acc_mode fixed bin (5);				/* access in form returned by get_user_effmode */

dcl  dirname char (168);
dcl  ename char (32);
dcl  ddir char (168);				/* directory portion of directory name */
dcl  dent char (32);				/* entry portion of directory name */

dcl  force_bit bit (1) aligned;
dcl  mask_bit bit (1) aligned;
dcl  clean_bit bit (1) aligned;

dcl  mp ptr;
dcl  message_len fixed bin (18);
dcl  based_message bit (message_len) aligned based;

dcl  access_class bit (72) aligned;

dcl  cleanup condition;

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  clock_ entry returns (fixed bin (71));
dcl  delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35));
dcl  expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$get_access_class entry (char(*), char(*), bit(72) aligned,
	fixed bin(35));
dcl  hcs_$get_link_target entry (char(*), char(*), char(*), char(*),
	fixed bin(35));
dcl  hcs_$get_user_effmode  entry (char(*), char(*), char(*), fixed bin,
	fixed bin(5), fixed bin(35));
dcl  hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr,
	fixed bin(35));
dcl  ipc_$mask_ev_calls entry (fixed bin (35));
dcl  ipc_$unmask_ev_calls entry (fixed bin (35));
dcl  unthread_descriptor_ entry (ptr);

dcl (addr, fixed, null, ptr, rel, bit) builtin;

dcl 1 branch aligned,
    2 pad1 fixed bin,
    2 dtm bit (36),					/* date-time modified */
    2 pad2 (2) fixed bin;

/**/

/* get pointer to oldest request */

	mask_code = -1;
	on cleanup begin;
	     if mask_code = 0 then call ipc_$unmask_ev_calls (code);
	end;
	call ipc_$mask_ev_calls (mask_code);
	mask_bit = "1"b;
	clean_bit, force_bit = "0"b;
join:

	desc_off = iodc_static.first_req_done;
	if desc_off = 0 then go to out;		/* no requests threaded, don't bother */

	desc_p, mseg_message_info_ptr = ptr (iodc_static.descr_seg_ptr, desc_off);

/* if cleanup entry we want to free them all, but not delete uncompleted ones */

	if clean_bit
	then do;
	     if ^desc_p -> request_descriptor.finished
	     then desc_p -> request_descriptor.dont_delete = "1"b;
	     mseg_message_info.ms_ptr = ptr (iodc_static.req_seg_ptr, rel (mseg_message_info.ms_ptr));
						/* segment number was left by previous coordinator process */
	     go to free_it;				/* skip other checks */
	end;

	do while (desc_p -> request_descriptor.saved);

/* find one that's not saved */

	     desc_off = desc_p -> request_descriptor.next_done;
	     if desc_off = 0 then return;
	     desc_p = ptr (iodc_static.descr_seg_ptr, desc_off);
	end;

/* make sure it's old enough */

	if (clock_ () - desc_p -> request_descriptor.time_done) >= iodc_static.time_interval | force_bit
	then do;
free_it:

	     call unthread_descriptor_ (desc_p);

	     mp = desc_p -> mseg_message_info.ms_ptr;

	     if mp -> queue_msg_hdr.delete_sw		/* user requested deletion */
	     then if ^desc_p -> request_descriptor.dont_delete /* and it's okay */
		then do;

/* check access on directory containing actual segment */
/* so if it's a link, chase it */

		     call hcs_$get_link_target ((mp -> queue_msg_hdr.dirname), (mp -> queue_msg_hdr.ename), dirname, ename, code);
		     if code ^= 0 then go to skip_it;	/* can't deal with this */


/* make sure the file hasn't been modified since */
/* the request was done */

		     call hcs_$status_ (dirname, ename, 1, addr (branch), null, code);
		     if code ^= 0 then go to skip_it;
		     if fixed (branch.dtm || (16)"0"b, 52) > desc_p -> request_descriptor.time_done
		     then go to skip_it;

/* now check the directory */

		     call expand_pathname_ (dirname, ddir, dent, code);
		     if code ^= 0 then go to skip_it;	/* God help us */

		     call hcs_$get_access_class (ddir, dent, access_class, code);
		     if code ^= 0 then go to skip_it;
		     if ^aim_check_$equal (desc_p -> mseg_message_info.sender_authorization, access_class)
		     then go to skip_it;

		     call hcs_$get_user_effmode (ddir, dent, desc_p -> mseg_message_info.sender_id,
			desc_p -> mseg_message_info.sender_level, acc_mode, code);
		     if code ^= 0 then go to skip_it;
		     if (bit (acc_mode, 5) & "00010"b) ^= "0"b
		     then call delete_$path (dirname, ename, "000100"b, "", code);
		end;

skip_it:
						/* now actually free the descriptor and the request */

	     message_len = desc_p -> mseg_message_info.ms_len;
	     free mp -> based_message in (req_area);
	     free desc_p -> request_descriptor in (descr_area);

	end;

out:	if mask_bit
	then call ipc_$unmask_ev_calls (code);

	return;

force:	entry;

/* called when a request must be freed to make space */

	clean_bit, mask_bit = "0"b;
	force_bit = "1"b;
	go to join;



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



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

cleanup:	entry;

/* called at initialization time to delete segments from requests */
/* performed in previous session */

	clean_bit = "1"b;
	mask_bit, force_bit = "0"b;
	go to join;


init:	entry (a_ptr);

dcl  a_ptr ptr;

	stat_p = a_ptr;
	return;

/**/

%include iodc_static;
%page;
%include mseg_message_info;
%page;
%include queue_msg_hdr;
%page;
%include request_descriptor;

     end free_oldest_request_;




		    iod_overseer_.pl1               11/15/82  1834.0rew 11/15/82  1450.8       97371



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



/* format: style4,delnl,insnl,ifthenstmt,ifthen */

iodc_overseer_:
iod_overseer_:
     procedure;

/* Login responder for I/O Daemon (IO.SysDaemon) */
/* It asks if it is supposed to be coordinator or driver,
   *  so it can call the appropriate initializing routine.
   *  For a coordinator, the "coordinator lock" is checked to make sure
   *  that there is not already a coordinator running; for a driver process,
   *  the lock is checked to make sure that a coordinator IS running, and if
   *  not, we wait a bit and try once more.
*/

/* Modified by J. Stern, 12/31/74 */
/* Modified by B. Margulies November 1980 for search rules and test improvements, and to rename to iod_overseer_ */
/* Modified: 6 May 1982 by G. Palter to set the working directory */

dcl  (Test_dir, Test_entry) char (*) parameter;

dcl  home_dir character (168);
dcl  iod_tables_entryname char (32);
dcl  iod_tables_dir char (168);
dcl  this_is_a_test bit (1) aligned;
dcl  exit_command char (6) aligned;
dcl  code fixed bin (35);
dcl  lock_ptr ptr int static init (null);
dcl  type char (32) varying;
dcl  iod_tables char (32);

dcl  any_other condition;

dcl  1 daemon_search aligned static options (constant),	/* Daemon search rules */
       2 number fixed bin init (1),
       2 dirs (1) char (168) init ("io_daemon");


dcl  1 coord_lock_seg aligned based,
       2 coord_lock bit (36),
       2 driver_lock bit (36);


%include query_info;

dcl  change_wdir_ entry (char (168) aligned, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  command_query_ entry () options (variable);
dcl  hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$initiate_search_rules entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  privileged_make_seg_ entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  iodc_$iodc_init entry (char (*), bit (1) aligned, char (*));
dcl  iodd_$iodd_init entry (char (*), bit (1) aligned);
dcl  ioa_ entry options (variable);
dcl  logout entry;
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl  system_privilege_$dir_priv_on entry (fixed bin (35));
dcl  system_privilege_$ipc_priv_on entry (fixed bin (35));
dcl  system_privilege_$ring1_priv_on entry (fixed bin (35));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  user_info_$homedir entry (char (*));
%page;


dcl  error_table_$argerr fixed bin (35) ext static;
dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$lock_wait_time_exceeded fixed bin (35) ext static;
dcl  error_table_$invalid_lock_reset fixed bin (35) ext static;
dcl  error_table_$locked_by_this_process fixed bin (35) ext static;


dcl  (addr, null) builtin;
%page;

	iod_tables_dir = ">daemon_dir_dir>io_daemon_dir";
	iod_tables_entryname = "iod_tables";
	this_is_a_test = "0"b;			/* indicates we're not in test mode */

	exit_command = "logout";
	on any_other call early_handler;
	call hcs_$initiate_search_rules (addr (daemon_search), code);
	if code ^= 0 then
	     call com_err_ (code, "iod_overseer_",
		"Warning: could not set search rules to the tagged set ""io_daemon"". Default search rules in use.");
	call user_info_$homedir (home_dir);
	call change_wdir_ ((home_dir), code);
	if code ^= 0 then
	     call com_err_ (code, "iod_overseer_", "Warning: could not set working directory to ^a.", home_dir);


/* find out what kind of process we're supposed to be */

common:
read:
	query_info.version = query_info_version_4;
	query_info.switches.suppress_name_sw = "1"b;
	query_info.switches.cp_escape_control = "1"b || this_is_a_test;
						/* allowed if in test mode */
	query_info.switches.suppress_spacing = "1"b;
	call command_query_ (addr (query_info), type, "iod_overseer_", "Enter command:  coordinator, driver, or ^a:^/",
	     exit_command);

	if type = "driver"				/* regular driver */
	then do;
	     if ^coord_running ()			/* no coordinator */
	     then call com_err_ (0, "iod_overseer_", "Coordinator not ready or not logged in.");

	     else do;				/* start up a driver */
		call iodd_$iodd_init (iod_tables_dir, this_is_a_test);
						/* byvalue until the aligned attribute is flushed from iodd_ */
		go to exit;
	     end;

	end;

	else if type = "coord" | type = "coordinator" then do;

/* make sure there isn't already a Coordinator process */

	     if ^first_coord ()			/* somebody goofed */
	     then do;
		call com_err_ (0, "iod_overseer_", "Coordinator is already running.");
		goto read;
	     end;

	     if ^this_is_a_test then do;		/* not testing, turn on privileges */
		call system_privilege_$dir_priv_on (code);
		call system_privilege_$ipc_priv_on (code);
		call system_privilege_$ring1_priv_on (code);
	     end;

	     call iodc_$iodc_init (iod_tables_dir, this_is_a_test, iod_tables_entryname);
	     call set_lock_$unlock (lock_ptr -> coord_lock, code);
						/* unlock the coordinator lock */
	     call set_lock_$unlock (lock_ptr -> driver_lock, code);
						/* and the driver lock */
	     go to exit;
	end;
	else if type = exit_command then go to exit;

	else call com_err_ (0, "iod_overseer_", "Invalid response.");

	go to read;


test:
     entry (Test_dir);
	iod_tables_dir = Test_dir;
	iod_tables_entryname = "iod_tables";
	goto TEST_COMMON;

test_path:
     entry (Test_dir, Test_entry);
	iod_tables_dir = Test_dir;
	iod_tables_entryname = Test_entry;

TEST_COMMON:
	this_is_a_test = "1"b;
	exit_command = "return";
	go to common;

exit:
	if this_is_a_test then
	     return;
	else call logout;


coord_ready:
     entry;

/* This entry is called by the coordinator after it has initialized.
   Until this entry is called, drivers will not be allowed to start. */


	if lock_ptr ^= null () then do;
	     lock_ptr -> driver_lock = ""b;		/* erase any previous lock */
	     call set_lock_$lock (lock_ptr -> driver_lock, 0, code);
	end;

	return;

/**/


first_coord:
     proc returns (bit (1) aligned);

/* This procedure verifies that no coordinator process yet exists. */


dcl  1 acl aligned,
       2 name char (32),
       2 modes bit (36),
       2 mbz bit (36),
       2 status fixed bin (35);


	if this_is_a_test then
	     call hcs_$make_seg (iod_tables_dir, "coord_lock", "", 01010b, lock_ptr, code);
	else call privileged_make_seg_ (iod_tables_dir, "coord_lock", "", 01010b, lock_ptr, code);
	if lock_ptr = null () then do;
	     call com_err_ (code, "iod_overseer_", "Cannot create coord_lock");
	     go to exit;
	end;

	if code = 0 then do;			/* if just created, set acl */
	     acl.name = "*.*.*";			/* give everyone access to read the lock */
	     acl.modes = "1"b;
	     acl.mbz = ""b;
	     call hcs_$add_acl_entries (iod_tables_dir, "coord_lock", addr (acl), 1, code);
	     if code ^= 0 then do;
		if code = error_table_$argerr then code = acl.status;
		call com_err_ (code, "iod_overseer_", "Cannot set access to coord_lock");
		go to exit;
	     end;
	end;

	call set_lock_$lock (lock_ptr -> coord_lock, 0, code);
	if code = 0 then return ("1"b);		/* we locked it */
	if code = error_table_$invalid_lock_reset then return ("1"b);
						/* we locked it */
	if code = error_table_$lock_wait_time_exceeded then return ("0"b);
						/* we didn't lock it */
	if this_is_a_test then			/* we'll try anything in test mode */
	     if code = error_table_$locked_by_this_process then return ("1"b);
	call com_err_ (code, "iod_overseer_", "Attempting to lock coord_lock");
	go to exit;

     end first_coord;

/**/


coord_running:
     proc returns (bit (1) aligned);

/* This procedure verifies that a coordinator process has been initialized. */

dcl  test_lock bit (36) aligned;
dcl  i fixed bin;


	call hcs_$initiate (iod_tables_dir, "coord_lock", "", 0, 1, lock_ptr, code);
	if lock_ptr = null then
	     if code = error_table_$noentry then
		return ("0"b);
	     else do;
		call com_err_ (code, "iod_overseer_", "Cannot initiate coord_lock");
		go to exit;
	     end;

	do i = 1 to 10;				/* try 10 times */
	     test_lock = lock_ptr -> driver_lock;	/* copy driver_lock since we don't want to set it */
	     call set_lock_$lock (test_lock, 0, code);
	     if code = error_table_$lock_wait_time_exceeded then return ("1"b);
						/* it's locked */
	     if code = 0 | code = error_table_$invalid_lock_reset then do;
						/* it's not locked */
		call timer_manager_$sleep (6, "11"b);	/* wait 6 seconds */
		go to retry;
	     end;
	     if this_is_a_test then			/* if we're testing */
		if code = error_table_$locked_by_this_process then return ("1"b);
						/* this is probably deliberate */
	     call com_err_ (code, "iod_overseer_", "Attempting to test coord_lock");
	     go to exit;
retry:
	end;

	return ("0"b);				/* no luck, give up */

     end coord_running;


/**/

early_handler:
     proc;

/*
   All conditions not recognized by early_handler are considered fatal.
   A standard message is printed, after which the process is logged out.
*/

dcl  ec fixed bin (35);

dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
dcl  default_error_handler_ entry (ptr, char (*), ptr, ptr, bit (1) aligned);


dcl  1 cond_info aligned,
%include cond_info;


	cond_info.version = 1;			/* version of cond_info */
	call find_condition_info_ (null (), addr (cond_info), ec);

	if cond_info.condition_name = "command_error" then return;
	else if cond_info.condition_name = "command_question" then return;

	else if cond_info.condition_name = "cput" | cond_info.condition_name = "alrm"
		| cond_info.condition_name = "sus_" | cond_info.condition_name = "trm_"
		| cond_info.condition_name = "wkp_" | cond_info.condition_name = "finish" then do;
	     call default_error_handler_ (mcptr, (condition_name), wcptr, infoptr, "0"b);
	     return;
	end;

	call ioa_ ("iod_overseer_: ^a condition intercepted.  Process will be terminated.", cond_info.condition_name);
	call condition_interpreter_ (null, null, 0, 3, mcptr, (condition_name), wcptr, infoptr);
	go to exit;

     end early_handler;
     end /* iod_overseeer_ */;




		    iod_set_line.pl1                10/28/88  1351.7rew 10/28/88  1233.9       48294



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

/* format: style4,indattr,ifthen,^indproc */

iod_set_line: proc;

/* Command to patch the line number given for a device in iod_tables */

/****^  HISTORY COMMENTS:
  1) change(85-02-06,Homan), approve(87-04-06,MCR7656),
     audit(87-07-08,Beattie), install(87-08-04,MR12.1-1055):
     Add new command to change line number for a device in the
     iod_working_tables.
  2) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.
                                                   END HISTORY COMMENTS */

	ithp = null ();
	on cleanup
	     call cleaner;

	call cu_$arg_list_ptr (arg_list_ptr);
	call process_args;

	call patch_it;

EXIT:
	call cleaner;

	return;
%page;
cleaner: proc;

	if ithp ^= null () then
	     call terminate_file_ (ithp, 0, TERM_FILE_TERM, (0));

     end cleaner;
%page;
process_args: proc;

	daemon_dir = ">daemon_dir_dir>io_daemon_dir";
	brief = "0"b;

	call cu_$arg_count_rel (nargs, arg_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     goto EXIT;
	end;

	if nargs < 2 then do;
	     call com_err_ (error_table_$wrong_no_of_args, ME, "^/Usage: ^a Device Line {-control_args}", ME);
	     goto EXIT;
	end;

	call cu_$arg_ptr_rel (1, argp, argl, (0), arg_list_ptr);
	device_name = arg;
	call cu_$arg_ptr_rel (2, argp, argl, (0), arg_list_ptr);
	line_name = arg;

	argN = 3;
	do while (argN <= nargs);
	     call cu_$arg_ptr_rel (argN, argp, argl, (0), arg_list_ptr);
	     if arg = "-directory" | arg = "-dr" then do;
		argN = argN + 1;
		if argN > nargs then do;
		     call com_err_ (error_table_$noarg, ME, "Argument missing after -directory.");
		     goto EXIT;
		end;
		call cu_$arg_ptr_rel (argN, argp, argl, (0), arg_list_ptr);
		call absolute_pathname_ (arg, daemon_dir, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "^a", arg);
		     goto EXIT;
		end;
	     end;
	     else if arg = "-brief" | arg = "-bf" then
		brief = "1"b;
	     else do;
		call com_err_ (error_table_$bad_arg, ME, "^a", arg);
		goto EXIT;
	     end;
	     argN = argN + 1;
	end;

     end process_args;
%page;
patch_it: proc;

dcl  i		        fixed bin;

	call initiate_file_ (daemon_dir, "iod_working_tables", RW_ACCESS, ithp, (0), code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", pathname_ (daemon_dir, "iod_working_tables"));
	     goto EXIT;
	end;

	idtp = ptr (ithp, iod_tables_hdr.device_tab_offset);

	do i = 1 to iod_device_tab.n_devices;
	     idtep = addr (iod_device_tab.entries (i));
	     if idte.dev_id = device_name then do;
		if idte.attach_type ^= 2 then do;
		     call com_err_ (0, ME, "Device ^a does not have a ""line:"" statement, or uses ""line: variable"".",
			device_name);
		     goto EXIT;
		end;

		if ^brief then
		     call ioa_ ("Line changed from ^a to ^a for device ^a.",
			requote_string_ (rtrim (idte.attach_name)), requote_string_ (rtrim (line_name)), device_name);
		idte.attach_name = line_name;
		goto EXIT;
	     end;

	end;

	call com_err_ (0, ME, "Device ^a not found in ^a.", device_name, pathname_ (daemon_dir, "iod_working_tables"));

     end patch_it;
%page;
/* External entries */

dcl  cu_$arg_list_ptr       entry (ptr);
dcl  cu_$arg_count_rel      entry (fixed bin, ptr, fixed bin (35));
dcl  cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  com_err_	        entry () options (variable);
dcl  ioa_		        entry () options (variable);
dcl  initiate_file_	        entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  terminate_file_        entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  absolute_pathname_     entry (char (*), char (*), fixed bin (35));
dcl  requote_string_        entry (char (*)) returns (char (*));
dcl  pathname_	        entry (char (*), char (*)) returns (char (168));

/* Builtins */

dcl  (addr, null, ptr, rtrim) builtin;

/* External static */

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

/* Automatic variables */

dcl  arg_list_ptr	        ptr;
dcl  argp		        ptr;
dcl  argl		        fixed bin (21);
dcl  argN		        fixed bin;
dcl  nargs	        fixed bin;
dcl  code		        fixed bin (35);
dcl  brief	        bit (1);
dcl  daemon_dir	        char (168);
dcl  device_name	        char (32);
dcl  line_name	        char (32);
						/* Based variables */

dcl  arg		        char (argl) based (argp);

/* Constants */

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

/* Conditions */

dcl  cleanup	        condition;
%page; %include access_mode_values;
%page; %include iod_device_tab;
%page; %include iod_tables_hdr;
%page; %include terminate_file;

     end iod_set_line;




		    iod_tables_compiler.rd          10/23/89  1406.2rew 10/23/89  1405.0      941022



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

/* HISTORY COMMENTS:
  1) change(88-01-27,Brunelle), approve(), audit(), install():
     Written by J. Stern, January 1975
     Modified by J. C. Whitmore, April 1978 for new RQT substatements
     Modified by J. C. Whitmore, Oct 1978, for version 3 -> adding the
     line_id table
     Modified by J. C. Whitmore, Jan 1980, to remove warning 7 - ctl term
     illegal with line variable construct.
     Modified by R. McDonald May 1980  to add keywords card_charge and
     page_charge. (UNCA)
     Modified: 10 April 1981 by G. Palter to remove warning 4 --
     dprint/dpunch restricts request type names to < 9 characters
     Modified by E. N. Kittlitz June 1981 for UNCA card_charge, page_charge
  2) change(88-01-27,Brunelle), approve(88-10-31,MCR7911),
     audit(88-10-21,Wallman), install(89-10-23,MR12.3-1099):
     Converted to reduction form.  Add new statements.
  3) change(88-10-31,Brunelle), approve(88-10-31,MCR7911),
     audit(88-11-01,Wallman), install(89-10-23,MR12.3-1099):
     Add cross check to verify that any device defined as allowed for a
     request_type has a forms_table entry if the request_type has a
     forms_table entry.
  4) change(89-02-28,Brunelle), approve(89-10-17,MCR8140),
     audit(89-10-23,Beattie), install(89-10-23,MR12.3-1099):
     Correct problem of truncated output file because bitcount not being set
     properly.
                                                   END HISTORY COMMENTS */
%page;

/*++
\" REDUCTIONS FOR iod_tables_compiler

BEGIN	/ <no-token>			/ ERROR (1)				/ RETURN \

\" Scan for main delimiting statements
	/ Time : <decimal-integer> ;		/ LEX (2) store_global_grace_time NEXT_STMT	/ BEGIN \
	/ Time : <any-token>		/ ERROR (3) NEXT_STMT			/ BEGIN \

	/ Max_queues : <decimal-integer> ;	/ LEX (2) store_global_max_queues NEXT_STMT	/ BEGIN \
	/ Max_queues : <any-token>		/ ERROR (5) NEXT_STMT			/ BEGIN \

\" now the main group delimiting statements 
	/ Line : <name_32> ;		/ LEX (2) line_create_table_entry LEX (2)	/ line_stmts \
	/ Line : <any-token>		/ ERROR (3)
					  LEX (2) line_create_table_entry NEXT_STMT	/ line_stmts \

	/ Device : <name_24> ;		/ LEX (2) dev_create_table_entry LEX (2)	/ device_stmts \
	/ Device : <any-token>		/ ERROR (3)
					  LEX (2) dev_create_table_entry NEXT_STMT	/ device_stmts \

	/ Request_type : <name_24> ;		/ LEX (2) rqt_create_table_entry LEX (2)	/ rqt_stmts \
	/ Request_type : <any-token>		/ ERROR (3)
					  LEX (2) rqt_create_table_entry NEXT_STMT	/ rqt_stmts \

	/ Forms_table : <name_32> ;		/ LEX (2) forms_create_group_entry LEX (2)	/ forms_stmts \
	/ Forms_table : <any-token>		/ ERROR (3)
					  LEX (2) forms_create_group_entry NEXT_STMT	/ forms_stmts \

	/ End ;				/ LEX
					  [if token.Pnext ^= null () then
					     call statement_error ()]			/ RETURN \

	/ <any-token> :			/ ERROR (2) NEXT_STMT			/ BEGIN \
	/ <any-token> 			/ ERROR (3) NEXT_STMT			/ BEGIN \
	/ <no-token> 			/ ERROR (1)				/ RETURN \
\" 

\" section to decode Line statements
line_stmts

	/ comment : <quoted-string> ;		/ LEX (2) line_save_comment LEX (2)		/ line_stmts \
	/ comment : <any-token> ;		/ LEX (2) line_save_comment LEX (2)		/ line_stmts \
	/ comment : <any-token> 		/ ERROR (3) NEXT_STMT			/ line_stmts \

	/ channel : <name_comm_line> ;	/ LEX (2) line_save_channel_id LEX (2)		/ line_stmts \
	/ channel : <any-token>		/ ERROR (3) NEXT_STMT			/ line_stmts \

	/ att_desc : <quoted-string> ;	/ LEX (2) line_save_att_desc LEX (2)		/ line_stmts \
	/ att_desc : <any-token> ;		/ LEX (2) line_save_att_desc LEX (2)		/ line_stmts \
	/ att_desc : <any-token> 		/ ERROR (3) NEXT_STMT			/ line_stmts \

	/ device : <name_24> ;		/ LEX (2) line_save_device LEX (2)		/ line_stmts \
	/ device : <any-token>		/ ERROR (3) NEXT_STMT			/ line_stmts \

	/ <any-token>			/ line_validate_entry			/ BEGIN \

\" 

\" section to decode Device statements
device_stmts
	/ comment : <quoted-string> ;		/ LEX (2) dev_save_comment LEX (2)		/ device_stmts \
	/ comment : <any-token> ;		/ LEX (2) dev_save_comment LEX (2)		/ device_stmts \
	/ comment : <any-token> 		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ prph : <name_32> ;		/ LEX (2)
					  dev_save_attach_method (1, ATTACH_TYPE_IOM)
					  LEX (2)					/ device_stmts \
	/ prph : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ line : variable ;			/ LEX (2)
					  dev_save_attach_method (1, ATTACH_TYPE_VARIABLE_LINE)
					  LEX (2)					/ device_stmts \
	/ line : <name_comm_line> ;		/ LEX (2)
					  dev_save_attach_method (1, ATTACH_TYPE_TTY)
					  LEX (2)					/ device_stmts \
	/ line : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ dial_id : <name_32> ;		/ LEX (2)
					  dev_save_attach_method (1, ATTACH_TYPE_DIAL)
					  LEX (2)					/ device_stmts \
	/ dial_id : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ ctl_line : <name_32> ;		/ LEX (2)
					  dev_save_attach_method (2, CTL_ATTACH_TYPE_TTY)
					  LEX (2)					/ device_stmts \
	/ ctl_line : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ ctl_dial_id : <name_32> ;		/ LEX (2)
					  dev_save_attach_method (2, CTL_ATTACH_TYPE_DIAL)
					  LEX (2)					/ device_stmts \
	/ ctl_dial_id : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ ctl_source : <name_32> ;		/ LEX (2)
					  dev_save_attach_method (2, CTL_ATTACH_TYPE_MC)
					  LEX (2)					/ device_stmts \
	/ ctl_source : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ driver_module : <name_path> ;	/ LEX (2) dev_save_driver_module LEX (2)	/ device_stmts \
	/ driver_module : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ head_sheet : <name_path> ;		/ LEX (2) dev_save_head_sheet LEX (2)		/ device_stmts \
	/ head_sheet : <any-token> 		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ tail_sheet : <name_path> ;		/ LEX (2) dev_save_tail_sheet LEX (2)		/ device_stmts \
	/ tail_sheet : <any-token> 		/ ERROR (3) NEXT_STMT			/ device_stmts \
 
	/ paper_type : single ;		/ LEX (2) dev_save_paper_type LEX (2)		/ device_stmts \
	/ paper_type : continuous ;		/ LEX (2) dev_save_paper_type LEX (2)		/ device_stmts \
	/ paper_type : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ forms_validation : <name_path> ;	/ LEX (2) dev_save_forms_validation LEX (2)	/ device_stmts \
	/ forms_validation : <any-token> 	/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ default_form :			/ LEX (2) 				/ dev_process_default_form_string \

	/ font_dir : <name_path> ;		/ LEX (2) dev_save_font_dir LEX (2)		/ device_stmts \
	/ font_dir : <any-token>	 	/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ forms_info : <name_path> ;		/ LEX (2) dev_save_forms_table LEX (2)		/ device_stmts \
	/ forms_info : <any-token>	 	/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ args : <quoted-string> ;		/ LEX (2) dev_save_args LEX (2)		/ device_stmts \
	/ args : <any-token> ;		/ LEX (2) dev_save_args LEX (2)		/ device_stmts \
	/ args : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ minor_device : <name_24> ;		/ LEX (2)
					  dev_create_minor_table_entry NEXT_STMT	/ device_stmts \
	/ minor_device : <any-token>		/ ERROR (3) LEX (2)
					  dev_create_minor_table_entry NEXT_STMT	/ device_stmts \

	/ minor_args : <quoted-string> ;	/ LEX (2) dev_save_minor_args LEX (2)		/ device_stmts \
	/ minor_args : <any-token> ;		/ LEX (2) dev_save_minor_args LEX (2)		/ device_stmts \
	/ minor_args : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ default_type : <name_32_multi> ;	/ LEX (2) dev_save_default_type LEX (2)		/ device_stmts \
	/ default_type : <any-token>		/ ERROR (3) NEXT_STMT			/ device_stmts \

	/ <any-token>			/ dev_validate_entry			/ BEGIN \

\" routine to handle default form string for device
dev_process_default_form_string
	/				/ PUSH (dev_process_default_form_string1)	/ build_temp_token_value \
dev_process_default_form_string1
	/				/ dev_save_default_form			/ device_stmts \

build_temp_token_value
	/				/ [temp_token_value = "";
					   temp_token_value_used = TRUE]		/ \
build_temp_token_value_loop
	/ ;				/ LEX					/ STACK_POP \
	/ <any-token>			/ [temp_token_value = temp_token_value || token_value]
					  LEX					/ build_temp_token_value_loop \
\" 

\" section to decode Request_type statements
rqt_stmts
	/ comment : <quoted-string> ;		/ LEX (2) rqt_save_comment LEX (2)		/ rqt_stmts \
	/ comment : <any-token> ;		/ LEX (2) rqt_save_comment LEX (2)		/ rqt_stmts \
	/ comment : <any-token> 		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ driver_userid : <name_user_id> ;	/ LEX (2) rqt_save_driver_id LEX (2)		/ rqt_stmts \
	/ driver_userid : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ accounting : <name_path> ;		/ LEX (2) rqt_save_accounting LEX (2)		/ rqt_stmts \
	/ accounting : <any-token> 		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ generic_type : <name_24> ;		/ LEX (2) rqt_save_generic_type LEX (2)		/ rqt_stmts \
	/ generic_type : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ rqti_seg : <name_32> ;		/ LEX (2) rqt_save_rqti_seg LEX (2)		/ rqt_stmts \
	/ rqti_seg : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ max_queues : <decimal-integer> ;	/ LEX (2) rqt_save_max_queues LEX (2)		/ rqt_stmts \
	/ max_queues : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ default_queue : <decimal-integer> ;	/ LEX (2) rqt_save_default_queue LEX (2)	/ rqt_stmts \
	/ default_queue : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ line_charge : <any-token>	 	/ LEX (2) rqt_save_charge (1) LEX		/ rqt_save_charges \

	/ page_charge : <any-token> 		/ LEX (2) rqt_save_charge (2) LEX		/ rqt_save_charges \

	/ card_charge : <any-token> 		/ LEX (2) rqt_save_charge (3) LEX		/ rqt_save_charges \

	/ forms_validation : <name_path> ;	/ LEX (2) rqt_save_forms_validation LEX (2)	/ rqt_stmts \
	/ forms_validation : <any-token> 	/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ default_form : 			/ LEX (2)					/ rqt_process_default_form_string \

	/ font_dir : <name_path> ;		/ LEX (2) rqt_save_font_dir LEX (2)		/ rqt_stmts \
	/ font_dir : <any-token>	 	/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ forms_info : <name_path> ;		/ LEX (2) rqt_save_forms_table LEX (2)		/ rqt_stmts \
	/ forms_info : <any-token>	 	/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ device_class : <name_24> ;		/ LEX (2)
					  rqt_create_device_class_entry NEXT_STMT	/ rqt_stmts \
	/ device_class : <any-token>		/ ERROR (3) LEX (2)
					  rqt_create_device_class_entry NEXT_STMT	/ rqt_stmts \
					     
	/ max_access_class : <access_class_ok> ;/ LEX (2) rqt_save_access (1) NEXT_STMT		/ rqt_stmts \
	/ max_access_class : <any-token>	/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ min_access_class : <access_class_ok> ;/ LEX (2) rqt_save_access (2) NEXT_STMT		/ rqt_stmts \
	/ min_access_class : <any-token>	/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ min_banner : <access_class_ok> ;	/ LEX (2) rqt_save_access (3) NEXT_STMT		/ rqt_stmts \
	/ min_banner : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ device : <name_32_multi> ;		/ LEX (2) rqt_save_device LEX (2)		/ rqt_stmts \
	/ device : <any-token>		/ ERROR (3) NEXT_STMT			/ rqt_stmts \

	/ <any-token>			/ rqt_validate_entry			/ BEGIN \

\" section to handle multiple values for line/page/card_charge statements
rqt_save_charges
	/ , 				/ LEX					/ rqt_save_charges \
	/ ; 				/ LEX					/ rqt_stmts \
	/ <any-token>			/ rqt_save_charge_continue LEX		/ rqt_save_charges\
	/ <no-token>			/					/ BEGIN \


\" routine to handle default form string for request type
rqt_process_default_form_string
	/				/ PUSH (rqt_process_default_form_string1)	/ build_temp_token_value \
rqt_process_default_form_string1
	/				/ rqt_save_default_form			/ rqt_stmts \

\" 

\" section to decode Forms_table statements
forms_stmts
	/ name : <name_32>			/ LEX (2) forms_create_element_entry LEX	/ save_forms_name_synonyms \


	/ comment : <quoted-string> ;		/ LEX (2) forms_save_comment LEX (2)		/ forms_stmts \
	/ comment : <any-token> ;		/ LEX (2) forms_save_comment LEX (2)		/ forms_stmts \
	/ comment : <any-token> 		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ type : <forms_type> ;		/ LEX (2) forms_save_type LEX (2)		/ forms_stmts \
	/ type : <any-token>		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ uses : <name_32>			/ LEX (2) forms_save_uses_name LEX		/ save_forms_uses_names \


	/ string : <quoted-string> ;		/ LEX (2) forms_save_string_token LEX (2)	/ forms_stmts \
	/ string : ;			/ LEX (3) 				/ forms_stmts \
	/ string :			/ LEX (2) 
					  [forms_escape_string_index = 1;
					   forms_escape_string_n (*) = 0]
					  / forms_char_string \

	/ page_height : <forms_size_ok> ;	/ LEX (2) forms_save_size (1) LEX (2)		/ forms_stmts \
	/ page_height : <any-token>		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ page_width : <forms_size_ok> ;	/ LEX (2) forms_save_size (2) LEX (2)		/ forms_stmts \
	/ page_width : <any-token>		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ char_height : <forms_size_ok> ;	/ LEX (2) forms_save_size (3) LEX (2)		/ forms_stmts \
	/ char_height : <any-token>		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ char_width : <forms_size_ok> ;	/ LEX (2) forms_save_size (4) LEX (2)		/ forms_stmts \
	/ char_width : <any-token>		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ line_height : <forms_size_ok> ;	/ LEX (2) forms_save_size (5) LEX (2)		/ forms_stmts \
	/ line_height : <any-token>		/ ERROR (3) NEXT_STMT			/ forms_stmts \

	/ <any-token>			/ forms_validate_group			/ BEGIN \

\" section to handle multiple values for uses statement
save_forms_name_synonyms
	/ , 				/ LEX					/ save_forms_name_synonyms \
	/ ; 				/ LEX					/ forms_stmts \
	/ <name_32>			/ forms_add_syn_element_name LEX		/ save_forms_name_synonyms \
	/ <any-token>			/ ERROR (3) forms_add_syn_element_name LEX	/ save_forms_name_synonyms \
	/ <no-token>			/					/ BEGIN \


save_forms_uses_names
	/ , 				/ LEX					/ save_forms_uses_names \
	/ ; 				/ LEX					/ forms_stmts \
	/ <name_32>			/ forms_save_uses_name_continue LEX		/ save_forms_uses_names \
	/ <any-token>			/ ERROR (3) forms_save_uses_name_continue LEX	/ save_forms_uses_names \
	/ <no-token>			/					/ BEGIN \


\" section to handle string statements
forms_char_string
forms_string_item
	/ <quoted-string>			/ append_token_value_string LEX		/ forms_string_item \
	/ <forms_tty_char_ok>		/ insert_single_char ((token.Nvalue)) LEX	/ forms_string_item \

	/ ;				/ forms_save_string LEX			/ forms_stmts \
	/ <any-token>			/ ERROR (3) NEXT_STMT			/ forms_stmts \
	/ <no-token>			/ 					/ RETURN \

   ++*/
%page;

/* format: style4 */
iod_tables_compiler: iodtc: proc;

/* The iod_tables_compiler produces an encoded representation of the various
   IO daemon tables from a source language description.  Source segments are
   assumed to have a name ending with the suffix ".iodt".  An object segment
   will be given the same name as its corresponding source segment with the
   suffix removed.
*/

/* External Entries & Procedures */

dcl  cdt_mgr_$find_cdt_channel entry (ptr, char (32), fixed bin, bit (1) aligned, fixed bin (35));
dcl  clock_ entry () returns (fixed bin (71));
dcl  com_err_ entry () options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_float_ entry (char (*), fixed bin (35)) returns (float bin (27));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  error_table_$bad_conversion fixed bin (35) ext static;
dcl  error_table_$bad_opt fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$too_many_args fixed bin (35) ext static;
dcl  error_table_$zero_length_seg fixed bin (35) ext static;
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  get_wdir_ entry () returns (char (168));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  lex_error_ entry () options (variable);
dcl  lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var,
	char (*) var, char (*) var, char (*) var);
dcl  lex_string_$lex entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*),
	char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
dcl  suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl  system_info_$resource_price entry (char (*), float bin (27), fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35));
dcl  translator_temp_$release_all_segments entry (ptr, fixed bin (35));
dcl  tssi_$clean_up_segment entry (ptr);
dcl  tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
dcl  tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35));

/* Builtins */

dcl  (addr, addrel, after, before, bin, char, collate, convert, currentsize,
     dimension, divide, fixed, hbound, index, lbound, length, max, mod, null,
     rank, rel, rtrim, substr, translate, unspec, verify) builtin;

dcl  cleanup condition;

/* External Static */

dcl  iod_tables_compiler_severity_ fixed bin (35) ext init (0);
dcl  sc_stat_$sysdir char (168) aligned external;

/* Internal Static */

dcl  ALL_VALID_CHARS_AND_NUMERIC char (62) int static options (constant)
	init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789");

dcl  BREAKS char (35) varying int static;
dcl  CTL_CHARS char (32) varying int static;
dcl  FALSE bit (1) int static options (constant) init ("0"b);
dcl  LEX_CHARS char (6) int static options (constant) init ("""/**/;");
dcl  LEX_COMMENT_CLOSE char (2) defined LEX_CHARS pos (4);
dcl  LEX_COMMENT_OPEN char (2) defined LEX_CHARS pos (2);
dcl  LEX_STATEMENT_DELIMITER char (1) defined LEX_CHARS pos (6);
dcl  LEX_QUOTE_CLOSE char (1) defined LEX_CHARS pos (1);
dcl  LEX_QUOTE_OPEN char (1) defined LEX_CHARS pos (1);
dcl  LEXCTL char (80) varying int static;
dcl  LEXDLM char (80) varying int static;
dcl  TOKEN_BAD bit (1) int static options (constant) init ("0"b);
dcl  TOKEN_GOOD bit (1) int static options (constant) init ("1"b);
dcl  TRUE bit (1) int static options (constant) init ("1"b);
dcl  already_called bit (1) int static init (FALSE);
dcl  max_length_att_desc fixed bin int static options (constant) init (512);
dcl  max_length_att_desc_char char (3) int static options (constant) init ("512");
dcl  max_length_comment fixed bin int static options (constant) init (256);
dcl  max_length_comment_char char (3) int static options (constant) init ("256");
dcl  max_size fixed bin int static options (constant) init (360);
dcl  max_size_char char (3) int static options (constant) init ("360");
dcl  prog_name char (32) int static options (constant) init ("new_iod_tables_compiler");

/* Internal Automatic */

dcl  acl_info_ptr ptr;
dcl  arg char (argl) based (argp);			/* command argument */
dcl  argc fixed bin;				/* input argument count */
dcl  argl fixed bin (21);				/* length of arg */
dcl  argp ptr;					/* ptr to arg */
dcl  argx fixed bin;				/* current input arg being processed */
dcl  authorization_bits bit (72) aligned;		/* converted authorization bits */
dcl  bit_count fixed bin (24);			/* bit count */
dcl  cdtp ptr;					/* Channel Definition Table ptr */
dcl  code fixed bin (35);				/* error code */
dcl  copy_ptr ptr;
dcl  debug bit (1);
dcl  default_device_class_defined bit (1);
dcl  default_minor_device_defined bit (1);
dcl  default_print_defined bit (1);
dcl  default_punch_defined bit (1);
dcl  error_string char (128) varying;
dcl  fb35 fixed bin (35);
dcl  forms_size_info float bin;
dcl  forms_size_type fixed bin;
dcl  forms_element_validated bit (1);
dcl  (i, j, k, l) fixed bin;
dcl  input_dir_name char (168);			/* input directory pathname */
dcl  input_ent_name char (32);			/* input entry name */
dcl  input_ptr ptr;					/* ptr to input segment */
dcl  item_ok bit (1);
dcl  line_charge_keyword_used bit (1);
dcl  minor_name char (32);
dcl  output_dir_name char (168);			/* output directory pathname */
dcl  output_ent_name char (32);			/* output entry name */
dcl  output_ptr ptr;				/* ptr to output segment */
dcl  page_charge_keyword_used bit (1);
dcl  saved_charge_cntr fixed bin;
dcl  saved_charge_type fixed bin;
dcl  stmtp ptr;					/* RDC statement ptr */
dcl  temp_ptrs (10) ptr;				/* scratch segment ptrs */
dcl  text_strings_array (text_strings.length) char (1) unaligned based (text_strings_array_ptr);
dcl  text_strings_array_ptr ptr;
dcl  translator_temp_ptr ptr;

/* temp storage for forms elements & groups used while building the forms info tab */
dcl  forms_elements_ptr ptr;
dcl  forms_elements (iod_forms_info_tab.n_words) fixed bin (35) based (forms_elements_ptr);
dcl  forms_groups_ptr ptr;
dcl  1 forms_groups (iod_forms_info_tab.n_groups) like iod_forms_info_tab.groups based (forms_groups_ptr);

dcl  1 cn aligned,					/* component names of a two-part name  */
       2 first_name char (24),
       2 second_name char (24);

/* the following are for device names and other data which must be saved as we go along */
dcl  misc_data_ptr ptr;
dcl  1 misc_data based (misc_data_ptr),

/* the following are for device names encountered while processing Line
   statements */
       2 line_device_names_count fixed bin,
       2 line_device_names (max_size) char (32),
       2 line_device_index (max_size) fixed bin,

/* the following are for device names (major and/or minor) encountered while
   processing Request_type statements */
       2 q_group_device_names_count fixed bin,
       2 q_group (max_size),
         3 device_name like cn,
         3 is_default_minor bit (1),			/* ON if this is default minor device  */
         3 is_default_device_class bit (1),		/* ON if this is default device class */
         3 device_index fixed bin,			/* device index for this device */
         3 default_type like cn,

/* the following is used while processing Device statements where bit I is ON
   if Device I uses "line: variable;" statement */
       2 var_line_list bit (max_size),

       2 forms_escape_string_index fixed bin,
       2 forms_escape_string_n (1024) fixed bin (8) unaligned,

       2 parms_count fixed bin,
       2 parms_indices_start (64) fixed bin,
       2 parms_indices_length (64) fixed bin,
       2 parms (11) char (32),
       2 temp_token_value_used bit (1),
       2 temp_token_value char (1024) varying,

/* the following two define those request type/device classes and
   major/minor devices which have a forms_table string defined for them */
       2 device_class_forms bit (max_size),
       2 minor_device_forms bit (max_size),

       2 pad fixed bin;
%page;

/* Actual Program Begins Here */

	input_ptr, output_ptr, temp_ptrs (*), translator_temp_ptr, cdtp,
	     acl_info_ptr, copy_ptr = null;

	on cleanup begin;
	     call clean_up;
	     iod_tables_compiler_severity_ = 5;
	end;

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

	debug = FALSE;
	SERROR_CONTROL = "00"b;
	TRACING = FALSE;

	if argc < 1 then do;
	     call com_err_$suppress_name (0, prog_name,
		"Usage:  iod_tables_compiler iod_tables_name [-brief | -long]");
	     go to severity_5_failure;
	end;

	input_ent_name = "";			/* no input name yet */

	do argx = 1 to argc;
	     call cu_$arg_ptr (argx, argp, argl, code);
	     if char (arg, 1) ^= "-" then do;
		if input_ent_name ^= "" then do;
		     call com_err_ (error_table_$too_many_args, prog_name,
			"Only one pathname may be given. ^a was the second.", arg);
		     go to severity_5_failure;
		end;

		call expand_pathname_$add_suffix (arg, "iodt", input_dir_name, input_ent_name, code);
		if code ^= 0 then do;
path_error:
		     call com_err_ (code, prog_name, "^a", arg);
		     go to severity_5_failure;
		end;

/* if we get this far, how can we fail? */
		call suffixed_name_$new_suffix (input_ent_name, "iodt", "", output_ent_name, code);
		if code ^= 0 then			/* still, let's have a look */
		     go to path_error;

	     end;					/* Pathname case */
	     else if arg = "-bf" | arg = "-brief" then
		SERROR_CONTROL = "01"b;

	     else if arg = "-lg" | arg = "-long" then
		SERROR_CONTROL = "10"b;

	     else if arg = "-severity" | arg = "-sv" then do;
		if argx >= argc then do;
		     call com_err_ (error_table_$noarg, prog_name, "After ""^a"".", arg);
		     go to severity_5_failure;
		end;
		argx = argx + 1;
		call cu_$arg_ptr (argx, argp, argl, code);
		fb35 = cv_dec_check_ (arg, code);
		if code ^= 0 | fb35 < 0 | fb35 > 5 then do;
		     call com_err_ (error_table_$bad_conversion, prog_name,
			"Severity must be an integer in the range 0 - 5, not ""^a"".", arg);
		     go to severity_5_failure;
		end;
		MIN_PRINT_SEVERITY = fb35;
	     end;

	     else if arg = "-trace_on" | arg = "-tron" then
		TRACING = TRUE;
	     else if arg = "-trace_off" | arg = "-trof" then
		TRACING = FALSE;
	     else if arg = "-debug" | arg = "-db" then
		debug = TRUE;
	     else do;
		code = error_table_$bad_opt;
		call com_err_ (code, prog_name, arg);
		go to severity_5_failure;
	     end;
	end;					/* argument processing loop */

	if input_ent_name = "" then
	     go to path_error;


	call initiate_file_ (input_dir_name, input_ent_name, R_ACCESS, input_ptr, bit_count, code); /* get ptr to input seg */
	if input_ptr = null then do;
	     call com_err_ (code, prog_name, "^a>^a", input_dir_name, input_ent_name);
	     return;
	end;
	if bit_count = 0 then do;
	     call com_err_ (error_table_$zero_length_seg, prog_name, "^a>^a", input_dir_name, input_ent_name);
	     go to finish;
	end;

/* get ptr to channel definition table */
	call initiate_file_ ((sc_stat_$sysdir), "cdt", R_ACCESS, cdtp, (0), code);
	if code ^= 0 then do;
	     call com_err_ (code, prog_name,
		"Accessing cdt.  Channel name checks will not be performed.");
	end;

/* get scratch segments */
	call get_temp_segments_ (prog_name, temp_ptrs, code); /* make temp output seg */
	if code ^= 0 then do;
	     call com_err_ (code, prog_name, "Getting temp segments.");
	     go to finish;
	end;

/* Get pointers to the various tables.  For now let the table sizes be maximum. */

	ithp = temp_ptrs (1);			/* set ptr to header */
	ltp = temp_ptrs (2);			/* get ptr to line id table */
	idtp = temp_ptrs (3);			/* get ptr to iod device table */
	mdtp = temp_ptrs (4);			/* get ptr to minor device table */
	dctp = temp_ptrs (5);			/* get ptr to device class table */
	qgtp = temp_ptrs (6);			/* get ptr to queue group table */
	ifitp = temp_ptrs (7);			/* get ptr to forms info tables */
	forms_groups_ptr = temp_ptrs (8);		/* get ptr to temp storage for forms elements */
	iod_forms_info_tab.n_groups=101;
	forms_elements_ptr = addr (forms_groups.name (101)); /* leave room for 100 Forms_info groups */
	iod_forms_info_tab.n_groups=0;
	text_strings_ptr = temp_ptrs (9);		/* get ptr to text strings area */
	text_strings_array_ptr = addr (text_strings.chars);
	misc_data_ptr = temp_ptrs (10);

/* initialize to common state */

	iod_tables_hdr.max_queues = -1;
	iod_tables_hdr.grace_time = -1;

	line_device_names_count, q_group_device_names_count = 0;
	idtep, mdtep, qgtep, dctep, ltep, fep = null ();
	forms_element_validated,
	     q_group.is_default_minor (*),
	     q_group.is_default_device_class (*),
	     default_minor_device_defined,
	     default_print_defined,
	     default_punch_defined,
	     temp_token_value_used = FALSE;
	device_class_forms, minor_device_forms = "0"b;
	error_string = "";

/* set up for lex_string_ */

	call translator_temp_$get_segment ((prog_name), translator_temp_ptr, code);
	if translator_temp_ptr = null () then do;
	     call com_err_ (code, prog_name, "From translator_temp_$get_segment");
	     go to severity_5_failure;
	end;

	if ^already_called then do;
	     CTL_CHARS = substr (collate (), 1, 8) || substr (collate (), 10, 24);
	     BREAKS = CTL_CHARS || ",:;";
	     call lex_string_$init_lex_delims (LEX_QUOTE_OPEN, LEX_QUOTE_CLOSE,
		LEX_COMMENT_OPEN, LEX_COMMENT_CLOSE, LEX_STATEMENT_DELIMITER,
		"10"b, BREAKS, CTL_CHARS, LEXDLM, LEXCTL);
	     already_called = TRUE;
	end;

	if TRACING | debug then
	     call ioa_ ("calling lex_string_$lex");

	call lex_string_$lex (input_ptr, divide (bit_count, 9, 21, 0), 0,
	     translator_temp_ptr, "1000"b, LEX_QUOTE_OPEN, LEX_QUOTE_CLOSE,
	     LEX_COMMENT_OPEN, LEX_COMMENT_CLOSE, LEX_STATEMENT_DELIMITER,
	     BREAKS, CTL_CHARS, LEXDLM, LEXCTL, stmtp, Pthis_token, code);

	if code ^= 0 then do;
	     call com_err_ (code, prog_name, "Lexing ^a>^a.", input_dir_name, input_ent_name);
	     go to finish;
	end;

/* Go to it! */
	Pstmt = stmtp;
	temp_token_value = stmt_value;

	if TRACING | debug then
	     call ioa_ ("calling SEMANTIC_ANALYSYS");

	call SEMANTIC_ANALYSIS ();

	if TRACING | debug then
	     call ioa_ ("SEMANTIC_ANALYSYS done");

	if MERROR_SEVERITY <= 2 then do;
	     if debug then
		call ioa_ ("Cross checking table.");
	     call cross_check_table;
	end;
	if MERROR_SEVERITY <= 2 then do;
	     if debug then
		call ioa_ ("Building forms table.");
	     if debug then
		call ioa_ ("Building output table.");
	     call build_output_table;
	end;

	if MERROR_SEVERITY > 2 then
	     call com_err_ (0, prog_name, "Translation failed.");
	iod_tables_compiler_severity_ = MERROR_SEVERITY;

	go to finish;

severity_5_failure:
	iod_tables_compiler_severity_ = 5;
finish:	call clean_up;
	return;
%page;

clean_up: proc;

/* cleanup handler -- makes sure anything we initiated gets terminated, anything we allocated gets freed */

	if input_ptr ^= null then
	     call terminate_file_ (input_ptr, (0), TERM_FILE_TERM, (0));
	input_ptr = null;

	if acl_info_ptr ^= null then
	     call tssi_$clean_up_segment (acl_info_ptr);
	acl_info_ptr = null;

	if output_ptr ^= null then
	     call terminate_file_ (output_ptr, (0), TERM_FILE_TRUNC_BC_TERM, (0));
	output_ptr = null;

	if translator_temp_ptr ^= null then
	     call translator_temp_$release_all_segments (translator_temp_ptr, (0));
	translator_temp_ptr = null;

	if temp_ptrs (1) ^= null then
	     call release_temp_segments_ (prog_name, temp_ptrs, code);
	temp_ptrs (*) = null;

	if cdtp ^= null then
	     call terminate_file_ (cdtp, (0), TERM_FILE_TERM, (0));
	cdtp = null;

	return;

     end clean_up;
%page;

/* Since this is a single pass compiler, there is no guarantee that all names
   of entries will be known when they are encountered in the input file.
   Thus we will cross check all of the variables at the end of the input file. */

cross_check_table: proc;

dcl  (full_name, full_name2) char (32);			/* for error display */
dcl  (minor_kw, minor_kw2) char (32);			/* for error display */
dcl  major_name char (32);
dcl  price_name char (32);
dcl  price float bin;
dcl  temp_list bit (360) aligned;			/* a temporary copy of dcte.device_list */

dcl  starting_element_index fixed bin;
dcl  error_statement_no fixed bin;
dcl  error_device_name char (32);
dcl  error_entry_type char (32);
dcl  error_entry_type_id char (32);

/* validate that each 'device' referenced under the Line keywords is
   a) defined as a Device
   b) has a attach type of 'variable'
*/

	line_device_index (*) = 0;			/* mark all as invalid til found */

	do i = 1 to line_device_names_count;		/* all names found */
	     do j = 1 to iod_device_tab.n_devices;	/* all available devices */

/* If name matches and the device was defined with a variable line, save index
   into device table for the entry.

   If the name matches but the device was not defined with a variable line,
   save the index but negate it so we can tell later */

		if iod_device_tab.entries (j).dev_id = line_device_names (i) then do;
		     if iod_device_tab.entries (j).attach_type = ATTACH_TYPE_VARIABLE_LINE then
			line_device_index (i) = j;
		     else line_device_index (i) = -j;
		     go to next_line_dev;
		end;
	     end;
next_line_dev:
	end;

	do i = 1 to line_tab.n_lines;
	     ltep = addr (line_tab.entries (i));
	     temp_list = lte.maj_dev_list;
	     lte.maj_dev_list = ""b;			/* clear so we can put in correct order */
	     j = index (temp_list, TRUE);
	     do while (j ^= 0);
		if line_device_index (j) = 0 then	/* not defined above */
		     call semant_error (12, "device", line_device_names (j), "line", lte.line_id);
		else do;
		     if line_device_index (j) < 0 then
			call semant_error (25, idte.dev_id, lte.line_id);
		     else do;
			substr (lte.maj_dev_list, line_device_index (j), 1) = TRUE; /* a good one */
			substr (var_line_list, line_device_index (j), 1) = FALSE; /* this one was used */
		     end;
		end;
		substr (temp_list, j, 1) = FALSE;
		j = index (temp_list, TRUE);
	     end;
	end;

/* if any unused variable line keywords found, gripe */
	if var_line_list then do;
	     i = index (var_line_list, TRUE);
	     do while (i ^= 0);
		call semant_error (26, iod_device_tab.dev_id (i));
		substr (var_line_list, j, 1) = FALSE;
		i = index (var_line_list, TRUE);
	     end;
	end;

/* Validate the devices specified in the Request_type and device_class entries. */
/* Find the minor device index for each name in the device array. */

	q_group.device_index (*) = 0;			/* mark all as not found until we find them */
	do i = 1 to q_group_device_names_count;		/* loop thru devices */
	     cn = q_group.device_name (i);
	     do j = 1 to iod_device_tab.n_devices;	/* look for major device */
		idtep = addr (iod_device_tab.entries (j));
		if idte.dev_id = cn.first_name then do; /* found major device */
		     if cn.second_name = "" then do;	/* must have a default minor */
			if q_group.is_default_minor (idte.first_minor) then
			     q_group.device_index (i) = idte.first_minor;
			else q_group.device_index (i) = -1; /* error, no default minor */
			go to next_device;
		     end;
		     else do k = idte.first_minor to idte.last_minor;
			mdtep = addr (minor_device_tab.entries (k));
			if mdte.dev_id = cn.second_name then do; /* found minor device */
			     q_group.device_index (i) = k;
			     go to next_device;
			end;
		     end;
		end;
	     end;
next_device:
	end;

/* Transform the device_list of each device class so that each bit
   in the device list corresponds to an entry in the minor device
   table rather than an entry in the device array. */

	do i = 1 to dev_class_tab.n_classes;		/* loop thru device classes */
	     dctep = addr (dev_class_tab.entries (i));
	     if dcte.device_list = ""b then
		go to skip_this_entry;
	     temp_list = dcte.device_list;
	     dcte.device_list = ""b;
	     j = index (temp_list, TRUE);
	     do while (j ^= 0);
		if q_group.device_index (j) <= 0 then do; /* error detected above */
		     if q_group.device_index (j) = -1 then
			error_statement_no = 33;	/* set error number */
		     else error_statement_no = 34;
		     error_device_name = q_group.device_name (j).first_name;
		     if q_group.device_name (j).second_name ^= "" then
			error_device_name = rtrim (error_device_name) || "." || q_group.device_name (j).second_name;
		     error_entry_type_id = before (q_group_tab.name (dcte.qgte_index), " ");
		     if q_group.is_default_device_class (i) then
			error_entry_type = "Request_type";
		     else do;
			error_entry_type = "device_class";
			error_entry_type_id = rtrim (error_entry_type_id) || "." || dcte.id;
		     end;
		     call semant_error (error_statement_no, error_device_name, error_entry_type, error_entry_type_id);
		end;
		else substr (dcte.device_list, q_group.device_index (j), 1) = TRUE;
		substr (temp_list, j, 1) = FALSE;
		j = index (temp_list, TRUE);
	     end;
skip_this_entry:
	end;

/* Validate the default types optionally specified for each minor device. */

	do i = 1 to minor_device_tab.n_minor;		/* loop thru minor devices */
	     if q_group.default_type (i).first_name ^= "" then do; /* default class specified */
		cn = q_group.default_type (i);
		mdtep = addr (minor_device_tab.entries (i));
		do j = 1 to q_group_tab.n_q_groups;	/* look for the default_type */
		     qgtep = addr (q_group_tab.entries (j));
		     if cn.first_name = qgte.name then do;
			if cn.second_name = "" then	/* no device class specified */
			     if q_group.is_default_device_class (qgte.first_dev_class) then /* ok, it's a default class */
				mdte.default_dev_class = qgte.first_dev_class;
			     else do;		/* no default class for this q group */
				error_statement_no = 35; /* set up error number */
				go to bad_def_type;
			     end;
			else do;			/* look for second name of default_type */
			     do k = qgte.first_dev_class to qgte.last_dev_class
				while (dev_class_tab.id (k) ^= cn.second_name);
			     end;
			     if k > qgte.last_dev_class then
				go to def_type_not_found;
			     mdte.default_dev_class = k;
			end;
			dctep = addr (dev_class_tab.entries (mdte.default_dev_class));
			if ^substr (dcte.device_list, i, 1) then do; /* device not specified for default type */
			     error_statement_no = 36;
			     go to bad_def_type;
			end;
			go to next_minor;
		     end;
		end;

def_type_not_found: error_statement_no = 37;
bad_def_type:
		full_name2 = cn.first_name;
		if cn.second_name ^= "" then do;
		     full_name2 = rtrim (full_name2) || "." || cn.second_name;
		     minor_kw2 = "device_class";
		end;
		else minor_kw2 = "Request_type";
		full_name = before (iod_device_tab.dev_id (mdte.major_index), " ");
		if q_group.is_default_minor (i) then
		     minor_kw = "Device";
		else do;
		     full_name = rtrim (full_name) || "." || mdte.dev_id;
		     minor_kw = "minor_device";
		end;
		if error_statement_no ^= 36 then
		     call semant_error (error_statement_no, full_name2, minor_kw, full_name);
		else call semant_error (error_statement_no, full_name2, minor_kw, full_name, full_name, minor_kw2, full_name2);
	     end;
next_minor: end;

/* make sure the optional request type parameters are defined correctly */

	do i = 1 to q_group_tab.n_q_groups;
	     qgtep = addr (q_group_tab.entries (i));

	     if qgte.max_queues = -1 then		/* if not defined, use the Global value */
		qgte.max_queues = iod_tables_hdr.max_queues;

	     if qgte.default_queue = -1 then do;	/* if not defined, use highest up to 3 */
		if qgte.max_queues < 3 then
		     qgte.default_queue = qgte.max_queues;
		else qgte.default_queue = 3;		/* any queue 4 is low priority */
	     end;
	     else if qgte.default_queue > qgte.max_queues then
		call semant_error (38, qgte.name);

	     if qgte.page_charge.queue (1) ^= "" then do; /* was the page_charge keyword given? */
		do j = 1 to hbound (qgte.page_charge.queue, 1); /* look at each price name */
		     price_name = qgte.page_charge.queue (j);
		     if price_name = "UNDEFINED_PRICE" then do; /* it was blank */
			if j > qgte.max_queues then
			     qgte.page_charge.queue (j) = ""; /* not used */
			else do;			/* otherwise we need a real price name */
			     call semant_error (39, qgte.name);
			     go to skip_charge1;
			end;
		     end;
		     else do;
			call system_info_$resource_price (price_name, price, code);
			if code ^= 0 then
			     call semant_error (40, qgte.name, price_name);
		     end;
		end;
skip_charge1:  end;


	     if qgte.line_charge.queue (1) ^= "" then do; /* was the line_charge keyword given? */
		do j = 1 to hbound (qgte.line_charge.queue, 1); /* look at each price name */
		     price_name = qgte.line_charge.queue (j);
		     if price_name = "UNDEFINED_PRICE" then do; /* it was blank */
			if j > qgte.max_queues then
			     qgte.line_charge.queue (j) = ""; /* not used */
			else do;			/* otherwise we need a real price name */
			     call semant_error (39, qgte.name);
			     go to skip_charge;
			end;
		     end;
		     else do;
			call system_info_$resource_price (price_name, price, code);
			if code ^= 0 then
			     call semant_error (40, qgte.name, price_name);
		     end;
		end;
skip_charge:   end;

/* now let's make sure any forms information references are available.
   make sure forms table is defined if they are using forms */
	     if qgte.forms_table.total_chars ^= 0 then do;
		major_name = return_string (qgte.forms_table);
		do j = 1 to iod_forms_info_tab.n_groups
		     while (major_name ^= forms_groups.name (j));
		end;
		if j > iod_forms_info_tab.n_groups then
		     call semant_error (12, "Forms_table", major_name, "Request_type", qgte.name);
		else do;
		     starting_element_index = forms_groups (j).first_element_index;
		     if qgte.default_form.total_chars ^= 0 then do;
			call parse_parms_string (addr (qgte.default_form));
			do k = 1 to parms_count;
			     l = forms_scan_for_element_name (starting_element_index, parms (k));
			     if l = -1 then
				call semant_error (12, "default forms element", parms (k), "Request_type", qgte.name);
			end;
		     end;
		end;

/* make sure any minor devices referred to by this request type also have
   forms tables defined for them */
		do k = qgte.first_dev_class to qgte.last_dev_class;
		     dctep = addr (dev_class_tab.entries (k));
		     do l = 1 to max_size;
			if substr (dcte.device_list, l, 1) then
			     if ^substr (minor_device_forms, l, 1) then do;
				full_name = q_group_tab.entries.name (dcte.qgte_index);
				if q_group_tab.entries.name (dcte.qgte_index) ^= dcte.id then
				     full_name = rtrim (full_name) || "." || dcte.id;
				mdtep = addr (minor_device_tab.entries (l));
				idtep = addr (iod_device_tab.entries (mdte.major_index));
				full_name2 = idte.dev_id;
				if full_name2 ^= mdte.dev_id then
				     full_name2 = rtrim (full_name2) || "." || mdte.dev_id;
				call semant_error (53, full_name, full_name2);
			     end;
		     end;
		end;
	     end;
	end;

/* make sure we've got one of everything we need */

	if iod_tables_hdr.max_queues = -1 then call semant_error (41);

	if iod_tables_hdr.grace_time = -1 then call semant_error (42);

	if iod_device_tab.n_devices = 0 then call semant_error (43);

	if q_group_tab.n_q_groups = 0 then call semant_error (44);

	if ^default_print_defined then call semant_error (45);
	if ^default_punch_defined then call semant_error (46);

     end cross_check_table;
%page;

build_output_table: proc;

/* create permanent output seg and copy in the temp seg */
	output_dir_name = get_wdir_ ();		/* put output seg in working directory */
	call tssi_$get_segment (output_dir_name, output_ent_name, output_ptr, acl_info_ptr, code);
	if code ^= 0 then do;
output_error:  call com_err_ (code, prog_name, "^a>^a", output_dir_name, output_ent_name);
	     go to finish;
	end;

/* copy the tables into the output seg */

	output_ptr -> iod_tables_hdr = iod_tables_hdr;
	ithp = output_ptr;
	iod_tables_hdr.version = "";			/* mark it inconsistent while we're copying */

	copy_ptr = adjust_ptr (addr (iod_tables_hdr.start_of_tables));
	copy_ptr -> line_tab = line_tab;
	ltp = copy_ptr;

	line_tab.n_lines = line_tab.n_lines + 1;
	copy_ptr = adjust_ptr (addr (line_tab.entries (line_tab.n_lines)));
	line_tab.n_lines = line_tab.n_lines - 1;
	copy_ptr -> iod_device_tab = iod_device_tab;
	idtp = copy_ptr;

	iod_device_tab.n_devices = iod_device_tab.n_devices + 1;
	copy_ptr = adjust_ptr (addr (iod_device_tab.entries (iod_device_tab.n_devices)));
	iod_device_tab.n_devices = iod_device_tab.n_devices - 1;
	copy_ptr -> minor_device_tab = minor_device_tab;
	mdtp = copy_ptr;

	minor_device_tab.n_minor = minor_device_tab.n_minor + 1;
	copy_ptr = adjust_ptr (addr (minor_device_tab.entries (minor_device_tab.n_minor)));
	minor_device_tab.n_minor = minor_device_tab.n_minor - 1;
	copy_ptr -> q_group_tab = q_group_tab;
	qgtp = copy_ptr;

	q_group_tab.n_q_groups = q_group_tab.n_q_groups + 1;
	copy_ptr = adjust_ptr (addr (q_group_tab.entries (q_group_tab.n_q_groups)));
	q_group_tab.n_q_groups = q_group_tab.n_q_groups - 1;
	copy_ptr -> dev_class_tab = dev_class_tab;
	dctp = copy_ptr;

	dev_class_tab.n_classes = dev_class_tab.n_classes + 1;
	copy_ptr = adjust_ptr (addr (dev_class_tab.entries (dev_class_tab.n_classes)));
	dev_class_tab.n_classes = dev_class_tab.n_classes - 1;
	iod_forms_info_tab.element_data_block = forms_elements;
	iod_forms_info_tab.groups = forms_groups;
	copy_ptr -> iod_forms_info_tab = iod_forms_info_tab;
	ifitp = copy_ptr;

	iod_forms_info_tab.n_groups = iod_forms_info_tab.n_groups + 1;
	copy_ptr = adjust_ptr (addr (iod_forms_info_tab.groups (iod_forms_info_tab.n_groups)));
	iod_forms_info_tab.n_groups = iod_forms_info_tab.n_groups - 1;
	copy_ptr -> text_strings = text_strings;
	text_strings_ptr = copy_ptr;

/* now fill in the header */

	iod_tables_hdr.line_tab_offset = fixed (rel (ltp), 18);
	iod_tables_hdr.device_tab_offset = fixed (rel (idtp), 18);
	iod_tables_hdr.minor_device_tab_offset = fixed (rel (mdtp), 18);
	iod_tables_hdr.q_group_tab_offset = fixed (rel (qgtp), 18);
	iod_tables_hdr.dev_class_tab_offset = fixed (rel (dctp), 18);
	iod_tables_hdr.forms_info_tab_offset = fixed (rel (ifitp), 18);
	iod_tables_hdr.text_strings_offset = fixed (rel (text_strings_ptr), 18);
	iod_tables_hdr.date_time_compiled = clock_ ();
	iod_tables_hdr.version = IODT_VERSION_5;

	text_strings_array_ptr = addr (text_strings.chars);
	text_strings.length = text_strings.length + 4;
	copy_ptr = addr (text_strings_array (text_strings.length));  /* get ptr 1 char beyond end of data */
	bit_count = 36 * fixed (rel (copy_ptr), 18);	/* compute bit count */
	call tssi_$finish_segment (output_ptr, bit_count, "1000"b, acl_info_ptr, code);
	if code ^= 0 then go to output_error;
	output_ptr, acl_info_ptr = null;

/* internal routine to make sure pointer is on an even word boundary */
adjust_ptr: proc (ptr_to_adjust) returns (ptr);

dcl  ptr_to_adjust ptr;

	     if mod (fixed (rel (ptr_to_adjust), 18), 2) ^= 0 then
		return (addrel (ptr_to_adjust, 1));
	     else return (ptr_to_adjust);

	end adjust_ptr;

     end build_output_table;
%page;

/* Syntax Functions */

/* General syntax functions */

/* similar to the <name> built-in syntax functions except they use different
   length limitations and special char strings */

name_routines: proc;

dcl  name_length fixed bin;
dcl  name_type fixed bin;

name_32: entry returns (bit (1));			/* allow upper/lower case alpha, numeric, - & _ */
	name_length = 32;
	name_type = 1;
	go to name_routines_common;

name_24: entry returns (bit (1));			/* allow upper/lower case alpha, numeric, - & _ */
	name_length = 24;
	name_type = 1;
	go to name_routines_common;

name_path: entry returns (bit (1));			/* allow upper/lower case alpha, numeric & -_$<> */
	name_length = 256;
	name_type = 2;
	go to name_routines_common;

name_comm_line: entry returns (bit (1));		/* allow upper/lower case alpha, numeric & _.* / */
	name_length = 32;
	name_type = 3;
	go to name_routines_common;

name_user_id: entry returns (bit (1));			/* allow upper/lower case alpha, numeric & -_.* */
	name_length = 30;
	name_type = 4;
	go to name_routines_common;

name_32_multi: entry returns (bit (1));			/* allow upper/lower case alpha, numeric & _.- */
	name_length = 32;
	name_type = 5;
	go to name_routines_common;

name_routines_common:
	if token.Lvalue > 0 then do;
	     if token.Lvalue <= name_length then do;

		if name_type = 1 then do;		/* name_32 & name_24 */
		     if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_-") = 0 then
			return (TOKEN_GOOD);
		end;

		else if name_type = 2 then do;	/* name_path */
		     if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "-_$<>") = 0 then
			return (TOKEN_GOOD);
		end;

		else if name_type = 3 then do;	/* name_comm_line */
		     if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_.*/") = 0 then
			return (TOKEN_GOOD);
		end;

		else if name_type = 4 then do;	/* name_user_id */
		     if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_.*") = 0 then
			return (TOKEN_GOOD);
		end;

		else if name_type = 5 then do;	/* name_32_multi */
		     if verify (token_value, ALL_VALID_CHARS_AND_NUMERIC || "_.-") = 0 then
			return (TOKEN_GOOD);
		end;
	     end;
	end;
	return (TOKEN_BAD);

     end name_routines;
%page;

/* General action routines */

/* routines to store various strings in the text_strings area */

store_string_functions: proc;

dcl  string_to_store char (*);

dcl  1 target unaligned like text_offset;

dcl  source_string char (source_string_len) based (source_string_ptr);
dcl  source_string_len fixed bin;
dcl  source_string_ptr ptr;

dcl  target_string char (source_string_len) based (target_string_ptr);
dcl  target_string_ptr ptr;
dcl  dupe_string_loc fixed bin;

store_forms_escape_string: entry (target);

/* copy the string in forms_escape_string_n into text_strings and save offset
   and length of the copied string in target structure values */

	source_string_ptr = addr (forms_escape_string_n);
	source_string_len = forms_escape_string_index - 1;
	go to common;


store_temp_token_value_string: entry (target);

/* routine copies the temp_token_value string into text_strings and saves
   offset and length of the copied string in target structure values */

	source_string_ptr = addrel (addr (temp_token_value), 1);
	source_string_len = length (temp_token_value);
	go to common;

store_token_value_string: entry (target);

/* routine copies the token_value string into text_strings and saves offset
   and length of the copied string in target structure values */

	source_string_ptr = token.Pvalue;
	source_string_len = token.Lvalue;
	go to common;

store_direct_string: entry (target, string_to_store);

/* this routine stores the input string it is called with into text_strings
   and saves the offset and length of the string into target structure values */

	source_string_ptr = addr (string_to_store);
	source_string_len = length (rtrim (string_to_store));

common:
	text_strings.length = text_strings.length + 1;
	target_string_ptr = addr (text_strings_array (text_strings.length));
	text_strings.length = text_strings.length - 1;

/* eliminate dupe strings by seeing if this exact string is already in the
   text_strings area.  If not, we will add it.  If it is, we will just
   record the starting location of the string already in the text_strings area
   as the location of this copy */

	dupe_string_loc = index (text_strings.chars, source_string);
	if dupe_string_loc = 0 then do;		/* new string */
	     target_string = source_string;		/* copy string */
	     target.first_char = text_strings.length + 1; /* save where it starts */
	     text_strings.length = text_strings.length + source_string_len; /* bump count of string chars saved */
	end;
	else do;					/* dupe string */
	     target.first_char = dupe_string_loc;	/* save where it starts */
	end;
	target.total_chars = source_string_len;		/* save length of string */

	return;

     end store_string_functions;


/* routine to return a string from the text string area */

return_string: proc (source_offsets) returns (char (*));

dcl  1 source_offsets unaligned like text_offset;

	if source_offsets.total_chars = 0 then
	     return ("");
	else return (substr (text_strings.chars, source_offsets.first_char, source_offsets.total_chars));

     end return_string;


/* parse a comma delimited string into its components */

parse_parms_string: proc (data_offset_ptr);

dcl  data_offset_ptr ptr;				/* ptr to text_offset data */
dcl  1 source_text_offsets unaligned like text_offset based (data_offset_ptr);

	temp_token_value = return_string (source_text_offsets);
	parms_count = 0;
	parms (*) = "";
loop:	parms_count = parms_count + 1;
	parms (parms_count) = before (temp_token_value, ",");
	temp_token_value = after (temp_token_value, ",");
	if temp_token_value ^= "" then
	     go to loop;

     end parse_parms_string;
%page;

/* global action routines */

store_global_grace_time: proc;

	if iod_tables_hdr.grace_time ^= -1 then
	     call statement_error (4, "Time");
	else iod_tables_hdr.grace_time = token.Nvalue * 60000000;

     end store_global_grace_time;


store_global_max_queues: proc;

	if iod_tables_hdr.max_queues ^= -1 then
	     call statement_error (4, "Max_queues");
	else do;
	     if token.Nvalue < 1 | token.Nvalue > 4 then
		call statement_error (6, "Max_queues", "4");
	     else iod_tables_hdr.max_queues = token.Nvalue;
	end;

     end store_global_max_queues;
%page;

/* syntax functions and action routines for Line keyword
   and it's subordinate keywords */

/* Syntax functions */

/* Action Routines */

/* create a new entry in the line table */
line_create_table_entry: proc;

/* first see if line is currently defined in the table */
	do i = 1 to line_tab.n_lines			/* is line currently defined */
	     while (line_tab.line_id (i) ^= token_value);
	end;
	if i <= line_tab.n_lines then			/* in table so complain */
	     call statement_error (10, "Line", token_value);

/* Create entry in table for this line name.
   We will create a new entry for a duplicate name so we can check the rest
   of the substatements */

	line_tab.n_lines = line_tab.n_lines + 1;
	ltep = addr (line_tab.entries (line_tab.n_lines));

/* now clear out the entry */
	unspec (lte) = "0"b;
	lte.line_id = token_value;
	lte.chan_id = "";
	lte.att_desc.first_char,
	     lte.att_desc.total_chars = 0;
	lte.maj_dev_list = ""b;

     end line_create_table_entry;

/* save line attach description */
line_save_att_desc: proc;

	if token.Lvalue > max_length_att_desc then
	     call statement_error (15, "att_desc", max_length_att_desc_char);
	if lte.att_desc.total_chars ^= 0 then
	     call statement_error (13, "att_desc", "Line", token_value);
	call store_token_value_string (lte.att_desc);

     end line_save_att_desc;

/* save line comment */
line_save_comment: proc;

	if token.Lvalue > max_length_comment then
	     call statement_error (15, "comment", max_length_comment_char);
	if lte.comment.total_chars ^= 0 then
	     call statement_error (13, "comment", "Line", token_value);
	call store_token_value_string (lte.comment);

     end line_save_comment;

/* make sure channel ID is valid and save it */
line_save_channel_id: proc;

dcl  channel_id fixed bin;
dcl  fnp_sw bit (1) aligned;

/* validate that this is good channel ID */
	if cdtp ^= null then do;
	     call cdt_mgr_$find_cdt_channel (cdtp, (token_value), channel_id, fnp_sw, code);
	     if code ^= 0 then
		call statement_error (14);
	end;
	if lte.chan_id ^= "" then
	     call statement_error (13, "channel", "Line", (lte.line_id));
	lte.chan_id = token_value;

     end line_save_channel_id;

/* save line device name */
line_save_device: proc;

/* see if this device name is already used in a line statement */
	do i = 1 to line_device_names_count while
	     (line_device_names (i) ^= token_value);
	end;
	if i > line_device_names_count then do;		/* new device name */
	     if i > max_size then do;			/* table too big */
		call statement_error (16, max_size_char, "devices");
	     end;

	     line_device_names_count = i;		/* bump count of remembered devices */
	     line_device_names (i) = token_value;	/* and save the new name */
	end;

/* set the lte entry to point to the device name in the temp list.
   We will reset to to the true device entry later */
	substr (lte.maj_dev_list, i, 1) = TRUE;

     end line_save_device;

/* validate that line table entry is complete */
line_validate_entry: proc;

	if lte.maj_dev_list = FALSE then
	     call semant_error (18, "devices", "Line", lte.line_id);
	if lte.chan_id = "" then
	     call semant_error (19, "channel", "Line", lte.line_id);
	if lte.att_desc.total_chars = 0 then
	     call semant_error (19, "att_desc", "Line", lte.line_id);

     end line_validate_entry;
%page;

/* syntax functions for Device keyword and it's subordinate keywords */


/* the following action entries are for the Device keyword and it's device table */

/* create a new minor device table entry */
dev_create_minor_table_entry: proc;

/* If we defined a default minor device because we already found some minor
   device statements, change its name from the default name to this name.

   If there is no default minor device defined yet, we start add this one to
   the chain of current minor devices */

	if default_minor_device_defined then do;
	     default_minor_device_defined = FALSE;
	     call revert_default_minor_device;
	end;
	else call init_minor_device;

     end dev_create_minor_table_entry;


/* create a new entry in the device table */
dev_create_table_entry: proc;

/* see if this is valid device name and is currently undefined */
	do i = 1 to iod_device_tab.n_devices		/*  is device already defined */
	     while (iod_device_tab.dev_id (i) ^= token_value);
	end;
	if i <= iod_device_tab.n_devices then		/* it is in table so complain */
	     call statement_error (10, "Device", token_value);

/* Create entry in table for this line name.
   We will create a new entry for a duplicate name so we can check the rest
   of the substatements */

	iod_device_tab.n_devices = iod_device_tab.n_devices + 1;
	idtep = addr (iod_device_tab.entries (iod_device_tab.n_devices));

/* now clear out the entry */
	unspec (idte) = "0"b;
	default_minor_device_defined = FALSE;
	idte.dev_id = token_value;
	idte.attach_name,
	     idte.ctl_attach_name = "";
	idte.driver_module.first_char,
	     idte.driver_module.total_chars,
	     idte.args.first_char,
	     idte.args.total_chars,
	     idte.head_sheet.first_char,
	     idte.head_sheet.total_chars,
	     idte.tail_sheet.first_char,
	     idte.tail_sheet.total_chars = 0;
	idte.attach_type,
	     idte.ctl_attach_type,
	     idte.first_minor,
	     idte.last_minor,
	     idte.paper_type = -1;
	mdtep = null;

     end dev_create_table_entry;

dev_save_args: proc;

	if idte.args.total_chars ^= 0 then
	     call statement_error (13, "args", "Device", idte.dev_id);
	call store_token_value_string (idte.args);

     end dev_save_args;

dev_save_attach_method: proc (device_or_terminal, type_attach);

dcl  device_or_terminal fixed bin;			/* 1 = device entry */
						/* 2 = control terminal attachment */
dcl  type_attach fixed bin;
dcl  item_names (2, 4) char (13) int static options (constant) init (
	"prph", "line", "dial_id", "variable line",
	"ctl_line", "ctl_dial_id", "ctl_source", "");

	if device_or_terminal = 1 then do;		/* device */
	     if idte.attach_type ^= -1 then do;		/* already have attachment for this entry */
		if idte.attach_type = type_attach then
		     call statement_error (13, item_names (device_or_terminal, type_attach), "Device", idte.dev_id);
		else call statement_error (22, idte.dev_id);
	     end;
	     else do;
		if type_attach = ATTACH_TYPE_DIAL then
		     call check_dial_id (token_value, "dial_id");
		idte.attach_name = token_value;
		idte.attach_type = type_attach;
		if type_attach = ATTACH_TYPE_VARIABLE_LINE then
		     substr (var_line_list, iod_device_tab.n_devices, 1) = TRUE;
	     end;
	end;
	else do;					/* control terminal attachment */
	     if idte.ctl_attach_type ^= -1 then do;	/* already have attachment for this entry */
		if idte.ctl_attach_type = type_attach then
		     call statement_error (13, item_names (device_or_terminal, type_attach), "Device", idte.dev_id);
		else call statement_error (24, idte.dev_id);
	     end;
	     else do;
		if type_attach = CTL_ATTACH_TYPE_DIAL then
		     call check_dial_id (token_value, "ctl_dial_id");
		idte.ctl_attach_name = token_value;
		idte.ctl_attach_type = type_attach;
		if type_attach = CTL_ATTACH_TYPE_MC then
		     substr (var_line_list, iod_device_tab.n_devices, 1) = TRUE;
	     end;
	end;

/* checks if a dial id is unique */
check_dial_id: proc (value_to_check, keyword_name);

dcl  value_to_check char (*);
dcl  keyword_name char (*);

	     do i = 1 to iod_device_tab.n_devices;
		if iod_device_tab.attach_type (i) = ATTACH_TYPE_DIAL then
		     if iod_device_tab.attach_name (i) = value_to_check then
			go to dial_id_dup;
		if iod_device_tab.ctl_attach_type (i) = CTL_ATTACH_TYPE_DIAL then
		     if iod_device_tab.ctl_attach_name (i) = value_to_check then
			go to dial_id_dup;
	     end;
	     return;

dial_id_dup:
	     call statement_error (23, keyword_name, value_to_check, idte.dev_id);

	end check_dial_id;

     end dev_save_attach_method;

/* save device or minor device comment */
dev_save_comment: proc;

	if token.Lvalue > max_length_comment then
	     call statement_error (15, "comment", max_length_comment_char);

/* if there is no minor device entry, the comment belongs in the device entry */
	if mdtep = null () then do;
	     if idte.comment.total_chars ^= 0 then
		call statement_error (13, "comment", "Device", idte.dev_id);
	     call store_token_value_string (idte.comment);
	end;
	else do;
	     if mdte.comment.total_chars ^= 0 then
		call statement_error (13, "comment", "minor_device", mdte.dev_id);
	     call store_token_value_string (mdte.comment);
	end;

     end dev_save_comment;

dev_save_default_form: proc;

/* if no minor devices defined, then define the default */
	if idte.first_minor = -1 then
	     call init_default_minor_device;

/* validate that this is the first default form entry for this minor device */
	if mdte.default_form.total_chars ^= 0 then
	     call statement_error (49, "default_form", "minor_device", mdte.dev_id, "Device", idte.dev_id);

	if temp_token_value_used then do;
	     temp_token_value_used = FALSE;
	     call store_temp_token_value_string (mdte.default_form);
	end;
	else call store_token_value_string (mdte.default_form);

     end dev_save_default_form;


dev_save_default_type: proc;

/* parse default_type name into it's two possible parts */
	cn.first_name = before (token_value, ".");
	cn.second_name = after (token_value, ".");

/* if there are no minor devices, create the default entry */
	if idte.first_minor = -1 then
	     call init_default_minor_device;

/* otherwise check for duplicate entry for this device */
	else do;
	     if q_group.default_type (minor_device_tab.n_minor).first_name ^= "" then
		call statement_error (49, "default_type", "minor_device", mdte.dev_id,
		     "Device", idte.dev_id);
	end;

/* save the minor device name in temp storage for later use */
	q_group.default_type (minor_device_tab.n_minor).first_name = cn.first_name;
	q_group.default_type (minor_device_tab.n_minor).second_name = cn.second_name;

     end dev_save_default_type;


dev_save_driver_module: proc;

	if idte.driver_module.total_chars ^= 0 then do;
	     call statement_error (13, "driver_module", "Device", idte.dev_id);
	end;
	call store_token_value_string (idte.driver_module);

     end dev_save_driver_module;


dev_save_forms_validation: proc;

	if idte.forms_validation.total_chars ^= 0 then
	     call statement_error (13, "forms_validation", "Device", idte.dev_id);
	call store_token_value_string (idte.forms_validation);
     end dev_save_forms_validation;


dev_save_font_dir: proc;

	if idte.font_dir.total_chars ^= 0 then
	     call statement_error (13, "font_dir", "Device", idte.dev_id);
	call store_token_value_string (idte.font_dir);
     end dev_save_font_dir;


dev_save_forms_table: proc;

	if idte.forms_table.total_chars ^= 0 then
	     call statement_error (13, "forms_table", "Device", idte.dev_id);
	call store_token_value_string (idte.forms_table);
     end dev_save_forms_table;


dev_save_head_sheet: proc;

	if idte.head_sheet.total_chars ^= 0 then
	     call statement_error (13, "head_sheet", "Device", idte.dev_id);
	call store_token_value_string (idte.head_sheet);
     end dev_save_head_sheet;


dev_save_minor_args: proc;

/* if no minor devices defined, then define the default */
	if idte.first_minor = -1 then
	     call init_default_minor_device;

/* validate that this is the first minor args entry for this minor device */
	if mdte.args.total_chars ^= 0 then
	     call statement_error (49, "minor_args", "minor_device", mdte.dev_id, "Device", idte.dev_id);

	call store_token_value_string (mdte.args);

     end dev_save_minor_args;


dev_save_paper_type: proc;

	if idte.paper_type ^= -1 then
	     call statement_error (13, "paper_type", "Device", idte.dev_id);

	if token_value = "continuous" then
	     idte.paper_type = PAPER_TYPE_CONTINUOUS;
	else if token_value = "single" then
	     idte.paper_type = PAPER_TYPE_SINGLE;
     end dev_save_paper_type;


dev_save_tail_sheet: proc;

	if idte.tail_sheet.total_chars ^= 0 then
	     call statement_error (13, "tail_sheet", "Device", idte.dev_id);
	call store_token_value_string (idte.tail_sheet);
     end dev_save_tail_sheet;


/* validate that a device entry is complete */
dev_validate_entry: proc;

/* create a default minor device if none explicitely defined */
	if idte.first_minor = -1 then
	     call init_default_minor_device;

/* make sure required elements are defined */
	if idte.driver_module.total_chars = 0 then
	     call semant_error (47, idte.dev_id);
	if idte.attach_type = 0 then
	     call semant_error (48, idte.dev_id);

/* make sure there is a cross-check between forms_table and default forms */
	do i = idte.first_minor to idte.last_minor;
	     mdtep = addr (minor_device_tab.entries (i));
	     if mdte.default_form.total_chars = 0 then do;/* no default form defined */
		if idte.forms_table.total_chars ^= 0 then do; /* but a forms table defined */
		     if mdte.dev_id = idte.dev_id then
			call semant_error (19, "default_form", "Device", idte.dev_id);
		     else call semant_error (19, "default_form", "minor_device", mdte.dev_id);
		end;
	     end;
	     else do;				/* have default form defined */
		if idte.forms_table.total_chars = 0 then/* but no forms table defined */
		     call semant_error (19, "forms_table", "Device", idte.dev_id);

/* turn on bits for any minor devices which have forms_table entries defined */
		substr (minor_device_forms, i, 1) = TRUE;
	     end;
	end;
     end dev_validate_entry;


init_default_minor_device: proc;

	default_minor_device_defined = TRUE;

init_minor_device: entry;

	minor_device_tab.n_minor = minor_device_tab.n_minor + 1;
	if minor_device_tab.n_minor > max_size then do;
	     call statement_error (16, max_size_char, "minor_device");
	end;
	mdtep = addr (minor_device_tab.entries (minor_device_tab.n_minor));
	unspec (mdte) = "0"b;
	if idte.first_minor = -1 then
	     idte.first_minor = minor_device_tab.n_minor;
	idte.last_minor = minor_device_tab.n_minor;
	mdte.default_dev_class = 0;
	mdte.major_index = iod_device_tab.n_devices;
	mdte.args.first_char,
	     mdte.args.total_chars,
	     mdte.default_form.first_char,
	     mdte.default_form.total_chars = 0;
	q_group.default_type (minor_device_tab.n_minor) = "";
	if default_minor_device_defined then
	     minor_name = idte.dev_id;
	else do;
revert_default_minor_device: entry;
	     minor_name = token_value;
	end;
	mdte.dev_id = substr (minor_name, 1, length (mdte.dev_id));
	q_group.is_default_minor (minor_device_tab.n_minor) = default_minor_device_defined;

     end init_default_minor_device;
%page;

/* syntax and action functions for Request_type keyword
   and it's subordinate keywords */

/* Syntax */

access_class_ok: proc returns (bit (1));

/* validate authorization for validity. leave the validated result in the
   authorization_bits variable for later use */
	call convert_authorization_$from_string (authorization_bits, token_value, code);

	return (code = 0);

     end access_class_ok;


/* Action routines */

/* create a new entry in the request type table */
rqt_create_table_entry: proc;

/* see if this is valid request type name and is currently undefined */
	do i = 1 to q_group_tab.n_q_groups		/* is line in table */
	     while (q_group_tab.name (i) ^= token_value);
	end;
	if i <= q_group_tab.n_q_groups then		/* it is in table so complain */
	     call statement_error (10, "Request_Type", token_value);

/* Create entry in table for this line name.
   We will create a new entry for a duplicate name so we can check the rest
   of the substatements */

	q_group_tab.n_q_groups = q_group_tab.n_q_groups + 1;
	qgtep = addr (q_group_tab.entries (q_group_tab.n_q_groups));

/* now clear out the entry */
	unspec (qgte) = "0"b;
	default_device_class_defined = FALSE;		/* OFF until default class is defined by implication */
	qgte.name = token_value;
	qgte.driver_id,
	     qgte.generic_type,
	     qgte.rqti_seg_name,
	     qgte.line_charge.queue (*),
	     qgte.page_charge.queue (*) = "";
	qgte.accounting.first_char,
	     qgte.accounting.total_chars,
	     qgte.forms_validation.first_char,
	     qgte.forms_validation.total_chars,
	     qgte.default_form.first_char,
	     qgte.default_form.total_chars,
	     qgte.forms_table.first_char,
	     qgte.forms_table.total_chars,
	     qgte.font_dir.first_char,
	     qgte.font_dir.total_chars = 0;
	qgte.default_generic_queue,
	     qgte.default_queue,
	     qgte.max_queues,
	     qgte.first_dev_class,
	     qgte.last_dev_class = -1;
	line_charge_keyword_used, page_charge_keyword_used = FALSE;
	dctep = null;
     end rqt_create_table_entry;

rqt_save_access: proc (type);

dcl  type fixed bin;
dcl  error_string_names (3) char (16) int static options (constant)
	init ("max_access_class", "min_access_class", "min_banner");

/* create default access class if there is no class currently defined */
	if qgte.first_dev_class = -1 then
	     call rqt_create_default_device_class_entry;

/* validate for dupe entry for this storage value */
	if (type = 1 & dcte.max_access ^= (72)"1"b)
	     | (type = 2 & dcte.min_access ^= (72)"1"b)
	     | (type = 3 & dcte.min_banner ^= (72)"1"b) then do;
	     call statement_error (13,
		error_string_names (type), "Request_type", qgte.name);
	end;

/* the authorization_bits variable was set by an immediately preceeding call
   to access_class_ok.  now store it. */

	if type = 1 then				/* max_access_class */
	     dcte.max_access = authorization_bits;
	else if type = 2 then			/* min_access_class */
	     dcte.min_access = authorization_bits;
	else dcte.min_banner = authorization_bits;	/* min_banner */

     end rqt_save_access;

rqt_save_accounting: proc;

	if qgte.accounting.total_chars ^= 0 then
	     call statement_error (13, "accounting", "Request_type", qgte.name);
	call store_token_value_string (qgte.accounting);

     end rqt_save_accounting;


rqt_save_charge: proc (type);

dcl  type fixed bin;

dcl  charge_type (3) char (11) int static options (constant)
	init ("line_charge", "page_charge", "card_charge");

	if type = 1 | type = 3 then do;
	     if line_charge_keyword_used then
		call statement_error (13, charge_type (type), "Request_type", qgte.name);
	     qgte.line_charge.queue (*) = "UNDEFINED_PRICE";
	     line_charge_keyword_used = TRUE;
	end;
	else if type = 2 then do;
	     if qgte.generic_type = "punch" then
		call statement_error (2, charge_type (type));
	     if page_charge_keyword_used then
		call statement_error (13, charge_type (type), "Request_type", qgte.name);
	     qgte.page_charge.queue (*) = "UNDEFINED_PRICE";
	     page_charge_keyword_used = TRUE;
	end;
	saved_charge_type = type;
	saved_charge_cntr = 1;

rqt_save_charge_continue: entry;

	if saved_charge_type = 1 | saved_charge_type = 3 then
	     qgte.line_charge.queue (saved_charge_cntr) = token_value;
	else qgte.page_charge.queue (saved_charge_cntr) = token_value;
	if saved_charge_cntr < 4 then
	     saved_charge_cntr = saved_charge_cntr + 1;

     end rqt_save_charge;


/* save Request_type comment */
rqt_save_comment: proc;

	if token.Lvalue > max_length_comment then
	     call statement_error (15, "comment", max_length_comment_char);

	if qgte.comment.total_chars ^= 0 then
	     call statement_error (13, "comment", "Device", qgte.name);
	call store_token_value_string (qgte.comment);

     end rqt_save_comment;

rqt_save_default_form: proc;

/* look for dupe entry */
	if qgte.default_form.total_chars ^= 0 then
	     call statement_error (13, "default_form", "Request_type", qgte.name);

	if temp_token_value_used then do;
	     temp_token_value_used = FALSE;
	     call store_temp_token_value_string (qgte.default_form);
	end;
	else call store_token_value_string (qgte.default_form);

     end rqt_save_default_form;

rqt_save_default_queue: proc;

	if qgte.default_queue ^= -1 then
	     call statement_error (13, "default_queue", "Request_type", qgte.name);
	if token.Nvalue < 1 | token.Nvalue > 3 then
	     call statement_error (6, "default_queue", "3");
	else qgte.default_queue = token.Nvalue;

     end rqt_save_default_queue;


rqt_save_device: proc;

/* parse device name into it's two possible parts */
	cn.first_name = before (token_value, ".");
	cn.second_name = after (token_value, ".");

/* see device is already defined */
	do i = 1 to q_group_device_names_count while
	     (q_group.device_name (i).first_name ^= cn.first_name
	     | q_group.device_name (i).second_name ^= cn.second_name);
	end;
	if qgte.first_dev_class = -1 then
	     call rqt_create_default_device_class_entry;
	else do;
	     if substr (dcte.device_list, i, 1) then
		call statement_error (17, token_value, "request_type", qgte.name);
	end;

/* save the data */
	substr (dcte.device_list, i, 1) = TRUE;
	if i > q_group_device_names_count then do;
	     q_group_device_names_count = i;
	     q_group.device_name.first_name (i) = cn.first_name;
	     q_group.device_name.second_name (i) = cn.second_name;
	end;

     end rqt_save_device;


rqt_save_driver_id: proc;

dcl  (person, project, instance) char (32) varying;

	if qgte.driver_id ^= "" then do;
	     call statement_error (13, "driver_id", "Request_type", qgte.name);
	end;
	person = before (token_value, ".");
	project = after (token_value, ".");
	if project = "" then
	     call statement_error (20);
	instance = after (project, ".");
	project = before (project, ".");
	if instance ^= "" then
	     call statement_error (21);
	qgte.driver_id = person || "." || project || ".*";

     end rqt_save_driver_id;

rqt_save_forms_validation: proc;

	if qgte.forms_validation.total_chars ^= 0 then
	     call statement_error (13, "forms_validation", "Request_type", qgte.name);
	call store_token_value_string (qgte.forms_validation);
     end rqt_save_forms_validation;


rqt_save_font_dir: proc;

	if qgte.font_dir.total_chars ^= 0 then
	     call statement_error (13, "font_dir", "Device", qgte.name);
	call store_token_value_string (qgte.font_dir);
     end rqt_save_font_dir;


rqt_save_forms_table: proc;

	if qgte.forms_table.total_chars ^= 0 then
	     call statement_error (13, "forms_table", "Device", qgte.name);
	call store_token_value_string (qgte.forms_table);
     end rqt_save_forms_table;


rqt_save_generic_type: proc;

	if qgte.generic_type ^= "" then
	     call statement_error (13, "generic_type", "Request_type", qgte.name);
	qgte.generic_type = token_value;
	if token_value = qgte.name then do;
	     qgte.default_generic_queue = 1;
	     if token_value = "printer" then
		default_print_defined = TRUE;
	     else if token_value = "punch" then
		default_punch_defined = TRUE;
	end;
     end rqt_save_generic_type;

rqt_save_max_queues: proc;

	if qgte.max_queues ^= -1 then
	     call statement_error (13, "max_queues", "Request_type", qgte.name);
	if token.Nvalue < 1 | token.Nvalue > 4 then
	     call statement_error (6, "max_queues", "4");
	else qgte.max_queues = token.Nvalue;

     end rqt_save_max_queues;


rqt_save_rqti_seg: proc;

	if qgte.rqti_seg_name ^= "" then
	     call statement_error (13, "rqti_seg_name", "Request_type", qgte.name);
	qgte.rqti_seg_name = token_value;

     end rqt_save_rqti_seg;


/* validate that a request type entry is complete */
rqt_validate_entry: proc;

	if qgte.first_dev_class = -1 then
	     call rqt_create_default_device_class_entry;
	call rqt_check_device_class;

	if qgte.driver_id = "" then
	     qgte.driver_id = "IO.SysDaemon.*";

	if qgte.accounting.total_chars = 0 then
	     call store_direct_string (qgte.accounting, "system");

	if return_string (qgte.accounting) ^= "system" then do;
	     if qgte.driver_id = "IO.SysDaemon" then
		call semant_error (28, qgte.name);
	end;
	else if after (qgte.driver_id, ".") ^= "SysDaemon.*" then
	     call semant_error (29, qgte.name);

	if qgte.generic_type = "" then
	     call semant_error (19, "generic_type", "Request_type", qgte.name);

	if qgte.forms_table.total_chars = 0 then do;	/* no forms table defined */
	     if qgte.default_form.total_chars ^= 0 then	/* but default form defined */
		call semant_error (19, "forms_table", "Request_type", qgte.name);
	end;
	else do;					/* forms table is defined */
	     if qgte.default_form.total_chars = 0 then	/* but no default form defined */
		call semant_error (19, "default_form", "Request_type", qgte.name);

/* turn on bits to show which device classes have forms table entries */
	     do i = qgte.first_dev_class to qgte.last_dev_class;
		substr (device_class_forms, i, 1) = TRUE;
	     end;
	end;
     end rqt_validate_entry;


rqt_check_device_class: proc;				/* fills in defaults if necessary */

	if dcte.min_access = (72)"1"b then
	     dcte.min_access = ""b;
	if dcte.min_banner = (72)"1"b then
	     dcte.min_banner = dcte.min_access;
	if dcte.max_access = (72)"1"b then
	     dcte.max_access = dcte.min_access;
	if dcte.device_list = ""b then
	     call semant_error (18, "devices", "Request_type", qgte.name);

     end rqt_check_device_class;


rqt_create_default_device_class_entry: proc;

	default_device_class_defined = TRUE;

rqt_create_device_class_entry: entry;

	dev_class_tab.n_classes = dev_class_tab.n_classes + 1;
	if dev_class_tab.n_classes > max_size then do;
	     call statement_error (16, max_size_char, "device_class");
	end;
	dctep = addr (dev_class_tab.entries (dev_class_tab.n_classes));
	unspec (dcte) = "0"b;
	if qgte.first_dev_class = -1 then
	     qgte.first_dev_class = dev_class_tab.n_classes;
	qgte.last_dev_class = dev_class_tab.n_classes;
	dcte.qgte_index = q_group_tab.n_q_groups;
	dcte.max_access,
	     dcte.min_access,
	     dcte.min_banner = (72)"1"b;
	dcte.device_list = ""b;
	if default_device_class_defined then
	     minor_name = qgte.name;
	else do;
revert_default_class: entry;
	     minor_name = token_value;
	end;
	dcte.id = minor_name;
	q_group.is_default_device_class (dev_class_tab.n_classes) = default_device_class_defined;

     end rqt_create_default_device_class_entry;

%page;

/* syntax functions for the Forms_table keyword and it's subordinate keywords */

forms_size_ok: proc returns (bit (1));

dcl  number_float float bin (27);
dcl  type char (12);

	item_ok = TOKEN_GOOD;
	number_float = cv_float_ (token_value, code);	/* try to convert */
	forms_size_type = 1;			/* assume inches */

/* if it didn't like the number to convert, probabily contains alpha chars
   defining the type of number specified.  Reconvert the data up to the bad
   char and test the bad chars for valid conversion types. */
	if code ^= 0 then do;
	     number_float = convert (number_float, substr (token_value, 1, code - 1));
	     type = substr (token_value, code);
	     if type = "in" | type = "i" | type = "inches" then
		forms_size_type = FACTOR_INCHES;
	     else if type = "cm" | type = "c" | type = "centimeters" then
		forms_size_type = FACTOR_CENTIMETERS;
	     else if type = "pt" | type = "p" | type = "points" then
		forms_size_type = FACTOR_POINTS;
	     else if type = "lpi" | type = "LPI" then
		forms_size_type = FACTOR_LPI;
	     else item_ok = TOKEN_BAD;
	end;
	if item_ok then do;
	     if forms_size_type ^= FACTOR_LPI then
		forms_size_info = SIZE_FACTORS (forms_size_type) * number_float;
	     else forms_size_info = SIZE_FACTORS (forms_size_type) / number_float;
	end;
	return (item_ok);

     end forms_size_ok;


forms_type: proc returns (bit (1));

	item_ok = TOKEN_GOOD;
	do i = lbound (FORMS_TYPE_STRINGS, 1) to hbound (FORMS_TYPE_STRINGS, 1)
	     while (token_value ^= FORMS_TYPE_STRINGS (i));
	end;
	if i > hbound (FORMS_TYPE_STRINGS, 1) then do;
	     item_ok = TOKEN_BAD;
	     token.Nvalue = 0;
	end;
	else token.Nvalue = i;
	return (item_ok);
     end forms_type;


forms_tty_char_ok: proc returns (bit (1) aligned);

dcl  ALL_LOWERCASE char (26) defined ALL_VALID_CHARS_AND_NUMERIC pos (27);
dcl  ALL_UPPERCASE char (26) defined ALL_VALID_CHARS_AND_NUMERIC pos (1);
dcl  asc_mnemonic char (3);
dcl  i fixed bin;

dcl  asc_value (0:32) char (3) static options (constant) init
	("nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
	"bs ", "tab", "lf ", "vt ", "ff ", "cr ", "so ", "si ",
	"dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
	"can", "em ", "sub", "esc", "fs ", "gs ", "rs ", "us ", "sp ");

	if token.quoted_string & token.Lvalue = 1 then
	     call return_tty_char (bin (unspec (token_value)));

	if token.Lvalue = 1 then do;
	     if index (BREAKS, token_value) = 0 then
		call return_tty_char (bin (unspec (token_value)));
	end;
	if octal_char_ok () then return (TOKEN_GOOD);
	if token.Lvalue = 2 & substr (token_value, 1, 1) = "^" then do;
	     i = index ("@abcdefghijklmnopqrstuvwxyz[\]^_", substr (token_value, 2, 1));
	     if i = 0 then
		i = index ("@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_", substr (token_value, 2, 1));
	     if i = 0 then return (TOKEN_BAD);
	     call return_tty_char (i - 1);
	end;
	if token.Lvalue <= 3 then do;
	     asc_mnemonic = translate (token_value, ALL_LOWERCASE, ALL_UPPERCASE);
	     if asc_mnemonic = "del" then call return_tty_char (127);
	     if asc_mnemonic = "nl " then call return_tty_char (10);
	     if asc_mnemonic = "pad" then call return_tty_char (0);
	     if asc_mnemonic = "ht" then call return_tty_char (9);
	     do i = lbound (asc_value, 1) to hbound (asc_value, 1);
		if asc_value (i) = asc_mnemonic then call return_tty_char (i);
	     end;

	end;
	return (TOKEN_BAD);

return_tty_char: proc (a_value);

dcl  a_value fixed bin;

	     token.Nvalue = a_value;
	     go to nlret;
	end return_tty_char;

nlret:	return (TOKEN_GOOD);

octal_char_ok: proc returns (bit (1) aligned);

	     if token.Lvalue > 3 then
		return (TOKEN_BAD);

	     token.Nvalue = cv_oct_check_ (token_value, code);
	     return (code = 0);
	end octal_char_ok;

     end forms_tty_char_ok;
%page;

/* the following entries are for the Forms_table keyword and it's table */

/* add a synonym name to the current element entry */
forms_add_syn_element_name: proc;

	element_common.n_names = element_common.n_names + 1;
	call store_token_value_string (element_common.names (element_common.n_names));

     end forms_add_syn_element_name;

/* create a new element entry.  since we are creating these entries in a temp
   segment, we know that the entire entry is zeros when we start */
forms_create_element_entry: proc;

dcl  element_offset fixed bin;
dcl  temp_fep ptr;

	call forms_validate_entry;			/* validate last entry */

/* see if this name is already defined within the forms group.  We will save
   the current element ptr (fep), then scan through the current element names
   to see if this one is unique;  if not we will complain.  In any case, we
   will create a new element ptr at the end of the current elements */
	element_offset = forms_groups (iod_forms_info_tab.n_groups).first_element_index;
	i = forms_scan_for_element_name (element_offset, token_value);
	if i ^= -1 then
	     call statement_error (50, token_value, return_string (element_common.names (i)));

/* Create entry in table for this line name.
   We will create a new entry for a duplicate name so we can check the rest
   of the substatements */
	temp_fep = addrel (addr (forms_elements (iod_forms_info_tab.n_words)), 1);
	if fep ^= null then
	     element_common.next_element_index = iod_forms_info_tab.n_words + 1;
	else forms_groups (iod_forms_info_tab.n_groups).first_element_index = iod_forms_info_tab.n_words + 1;
	fep = temp_fep;

/* now clear out the entry */
	unspec (element_common) = "0"b;
	element_common.n_names = 1;
	call store_token_value_string (element_common.names (1));
	element_common.type,
	     element_common.next_element_index = -1;
	element_common.comment.first_char,
	     element_common.comment.total_chars = 0;
	forms_element_validated = FALSE;

     end forms_create_element_entry;

/* create a new entry in the group table */
forms_create_group_entry: proc;

/* validate the last forms group if there is one */
	call forms_validate_group;

/* first see if line is currently defined in the table */
	do i = 1 to iod_forms_info_tab.n_groups		/* is forms group already defined */
	     while (forms_groups (i).name ^= token_value);
	end;
	if i <= iod_forms_info_tab.n_groups then	/* it is in table so complain */
	     call statement_error (10, "Forms_table", token_value);

/* Create entry in table for this line name.
   We will create a new entry for a duplicate name so we can check the rest
   of the substatements */
	iod_forms_info_tab.n_groups = iod_forms_info_tab.n_groups + 1;

/* now initialize the entry */
	forms_groups (i).name = token_value;
	forms_groups (i).comment.first_char,
	     forms_groups (i).comment.total_chars = 0;
	forms_groups (i).first_element_index = -1;
	fep = null;

     end forms_create_group_entry;


forms_save_comment: proc;

/* if there is an element entry open, save the comment there;
   else save in the group entry */
	if fep ^= null () then do;
	     if element_common.comment.first_char ^= 0 then
		call statement_error (13, "comment", "name", return_string (element_common.names (1)));
	     call store_token_value_string (element_common.comment);
	end;
	else do;
	     if forms_groups (iod_forms_info_tab.n_groups).comment.first_char ^= 0 then
		call statement_error (13, "comment", "Forms_info", forms_groups (iod_forms_info_tab.n_groups).name);
	     call store_token_value_string (forms_groups (iod_forms_info_tab.n_groups).comment);
	end;

     end forms_save_comment;


forms_save_size: proc (type);

dcl  type fixed bin;
dcl  type_strings (5) char (11) int static options (constant) init
	("page_height", "page_width", "char_height", "char_width", "line_height");

dcl  got_dupe bit (1);

	got_dupe = FALSE;
	if type = 1 | type = 3 | type = 5 then do;
	     if orientation_element.height ^= 0 then
		got_dupe = TRUE;
	     orientation_element.height = forms_size_info;
	     orientation_element.factors (1) = forms_size_type;
	end;
	if type = 2 | type = 4 then do;
	     if orientation_element.width ^= 0 then
		got_dupe = TRUE;
	     orientation_element.width = forms_size_info;
	     orientation_element.factors (2) = forms_size_type;
	end;

	if got_dupe then
	     call statement_error (13, type_strings, "name", return_string (element_common.names (1)));

     end forms_save_size;

forms_save_string: proc;

dcl  got_dupe bit (1);
dcl  use_token bit (1);

	use_token = "0"b;
	go to forms_save_string_common;

forms_save_string_token: entry;

	use_token = "1"b;

forms_save_string_common:
	got_dupe = "0"b;
	if element_common.type = TYPE_ORIENTATION	/* orientation */
	     | element_common.type = TYPE_FONT_DESC	/* font desc */
	     | element_common.type = TYPE_FONT_SIZE
	     | element_common.type = TYPE_LINE_DESC	/* line desc */
	     | element_common.type = TYPE_HOLES
	then do;
	     if orientation_element.escape_string.total_chars ^= 0 then
		got_dupe = "1"b;
	     if use_token then
		call store_token_value_string (orientation_element.escape_string);
	     else call store_forms_escape_string (orientation_element.escape_string);
	end;

	else if element_common.type = TYPE_SPECIAL then do; /* special */
	     if special_element.special_string.total_chars ^= 0 then
		got_dupe = "1"b;
	     if use_token then
		call store_token_value_string (special_element.special_string);
	     else call store_forms_escape_string (special_element.special_string);
	end;

	else if element_common.type = TYPE_FONT_NAME
	     | element_common.type = TYPE_PREAMBLE
	     | element_common.type = TYPE_POSTAMBLE then do;
	     if font_name_element.escape_string.total_chars ^= 0 then
		got_dupe = "1"b;
	     if use_token then
		call store_token_value_string (font_name_element.escape_string);
	     call store_forms_escape_string (font_name_element.escape_string);
	end;
	else if element_common.type = TYPE_USES then do;
	end;

	if got_dupe then
	     call statement_error (13, "string", "name ", return_string (element_common.names (1)));

     end forms_save_string;


forms_save_type: proc;

	if element_common.type ^= -1 then do;
	     call statement_error (13, "type", "name", return_string (element_common.names (1)));
	     return;
	end;

	element_common.type = token.Nvalue;

     end forms_save_type;


forms_save_uses_name: proc;

	if element_common.type ^= -1 then
	     call statement_error (13, "uses", "name", return_string (element_common.names (1)));
	element_common.type = TYPE_USES;
	uses_element.n_indices = 0;

forms_save_uses_name_continue: entry;

	uses_element.n_indices = uses_element.n_indices + 1;
	call store_token_value_string (uses_element.name (uses_element.n_indices));
	uses_element.index (uses_element.n_indices) = -1;

     end forms_save_uses_name;

/* scan through the given forms table looking for specific element name */
forms_scan_for_element_name: proc (starting_index, seek_name) returns (fixed bin (17));

dcl  starting_index fixed bin;
dcl  seek_name char (*);

dcl  element_index fixed bin;
dcl  element_name char (32);
dcl  i fixed bin;
dcl  my_fep ptr;

	element_index = starting_index;
	do while (element_index ^= -1);
	     my_fep = addr (forms_elements (element_index));
	     do i = 1 to my_fep -> element_common.n_names;
		element_name = return_string (my_fep -> element_common.names (i));
		if element_name = rtrim (seek_name) then
		     go to return_element_index;
	     end;
	     element_index = my_fep -> element_common.next_element_index;
	end;
return_element_index:
	return (element_index);

     end forms_scan_for_element_name;
%page;
/* validate that the current element entry isn't missing any required items */
forms_validate_entry: proc;

dcl  element_words fixed bin;

	if fep = null then return;			/* no current element */
	if forms_element_validated then return;		/* already validated this element */

/* validate the element entry */
	if element_common.type = -1 then do;
	     call semant_error (19, "type", "name", return_string (element_common.names (1)));
	     element_words = currentsize (element_common);
	end;
	else do;
	     if element_common.type = TYPE_USES then do;	/* check out "uses" */
		if uses_element.n_indices = 0 then
		     call semant_error (19, "uses", "name", return_string (element_common.names (1)));
		element_words = currentsize (uses_element);
	     end;
	     else if element_common.type = TYPE_ORIENTATION then do; /* check out "orientation" */
		if orientation_element.height = 0 then
		     call semant_error (19, "page_height", "name", return_string (element_common.names (1)));
		if orientation_element.width = 0 then
		     call semant_error (19, "page_width", "name", return_string (element_common.names (1)));
		if orientation_element.escape_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (orientation_element);
	     end;
	     else if element_common.type = TYPE_FONT_DESC then do; /* check out "font_name" */
		if font_element.height = 0 then
		     call semant_error (19, "char_height", "name", return_string (element_common.names (1)));
		if font_element.width = 0 then
		     call semant_error (19, "char_width", "name", return_string (element_common.names (1)));
		if font_element.escape_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (font_element);
	     end;
	     else if element_common.type = TYPE_FONT_SIZE then do; /* check out "font_name" */
		if font_size_element.height = 0 then
		     call semant_error (19, "char_height", "name", return_string (element_common.names (1)));
		if font_size_element.width = 0 then
		     call semant_error (19, "char_width", "name", return_string (element_common.names (1)));
		if font_size_element.escape_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (font_size_element);
	     end;
	     else if element_common.type = TYPE_LINE_DESC then do; /* check out "line_height" */
		if line_element.height = 0 then
		     call semant_error (19, "line_height", "name", return_string (element_common.names (1)));
		if line_element.escape_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (line_element);
	     end;
	     else if element_common.type = TYPE_HOLES then do; /* check out "font_name" */
		if holes_element.height = 0 & holes_element.width = 0 then
		     call semant_error (52, return_string (element_common.names (1)));
		if holes_element.escape_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (holes_element);
	     end;
	     else if element_common.type = TYPE_SPECIAL then do; /* check out "special" */
		if special_element.special_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (special_element);
	     end;
	     else if element_common.type = TYPE_FONT_NAME then do;
		if font_name_element.escape_string.total_chars = 0 then
		     call semant_error (19, "string", "name", return_string (element_common.names (1)));
		element_words = currentsize (font_name_element);
	     end;
	     else if element_common.type = TYPE_PREAMBLE then do;
		element_words = currentsize (preamble_element);
	     end;
	     else if element_common.type = TYPE_POSTAMBLE then do;
		element_words = currentsize (postamble_element);
	     end;
	end;
	iod_forms_info_tab.n_words = iod_forms_info_tab.n_words + element_words;
	forms_element_validated = TRUE;

     end forms_validate_entry;


/* validate the current group of forms elements */
forms_validate_group: proc;

dcl  (element_index, starting_element_index) fixed bin;
dcl  my_fep ptr;
dcl  i fixed bin;

/* nothing to do if no groups defined yet */
	if iod_forms_info_tab.n_groups = 0 then return;

/* first validate the last element entry if there is one */
	call forms_validate_entry;

/* now validate all the forms elements within this group */
	if forms_groups (iod_forms_info_tab.n_groups).first_element_index = -1 then do;
	     call semant_error (18, "forms elements", "Forms_table", forms_groups (iod_forms_info_tab.n_groups).name);
	end;
	else do;
	     element_index,
		starting_element_index = forms_groups (iod_forms_info_tab.n_groups).first_element_index;
	     do while (element_index ^= -1);
		my_fep = addr (forms_elements (element_index));
		if my_fep -> element_common.type = TYPE_USES then do;
		     do i = 1 to my_fep -> uses_element.n_indices;
			my_fep -> uses_element.index (i) = forms_scan_for_element_name (starting_element_index,
			     return_string (my_fep -> uses_element.name (i)));
			if my_fep -> uses_element.index (i) = -1 then
			     call semant_error (12, "uses element", my_fep -> uses_element.name (i), "name", return_string (my_fep -> element_common.names (1)));
		     end;
		end;
		element_index = my_fep -> element_common.next_element_index;
	     end;
	end;

     end forms_validate_group;


append_token_value_string: proc;

dcl  i fixed bin;
dcl  c char (1);

	do i = 1 to token.Lvalue;
	     c = substr (token_value, i, 1);
	     call insert_single_char (rank (c));
	end;
	return;

     end append_token_value_string;

insert_single_char: proc (n);

dcl  n fixed bin (18);

	forms_escape_string_n (forms_escape_string_index) = n;
	forms_escape_string_index = forms_escape_string_index + 1;
	return;

     end insert_single_char;
%page;

statement_error: proc options (variable);

dcl  arg_count fixed bin;
dcl  arg_lens (7) fixed bin (21);
dcl  arg_ptrs (7) ptr;
dcl  error_num fixed bin based (arg_ptrs (1));
dcl  i fixed bin;
dcl  parm1 char (arg_lens (2)) based (arg_ptrs (2));
dcl  parm2 char (arg_lens (3)) based (arg_ptrs (3));
dcl  parm3 char (arg_lens (4)) based (arg_ptrs (4));
dcl  parm4 char (arg_lens (5)) based (arg_ptrs (5));
dcl  parm5 char (arg_lens (6)) based (arg_ptrs (6));
dcl  parm6 char (arg_lens (7)) based (arg_ptrs (7));
dcl  dummy_string char (1);
dcl  (stmt_ptr, token_ptr) ptr;

	stmt_ptr = token.Pstmt;
	token_ptr = Pthis_token;
	go to error_common;

/* semant_error: entry (error_num, parm1, ..., parm6); */
semant_error: entry options (variable);

	stmt_ptr, token_ptr = null;

error_common: arg_lens (*) = 0;
	arg_ptrs (*) = addr (dummy_string);

	call cu_$arg_count (arg_count, code);
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, arg_ptrs (i), arg_lens (i), code);
	end;

	if error_control_table (error_num).severity >= MIN_PRINT_SEVERITY
	then call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)),
		MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL,
		(error_control_table.message (error_num)), (error_control_table.brief_message (error_num)),
		parm1, parm2, parm3, parm4, parm5, parm6);
	else do;
	     MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (error_num).severity);
	     SERROR_PRINTED (error_num) = TRUE;
	end;
	return;

     end statement_error;
%page;

dcl  1 error_control_table (53) aligned int static options (constant),

       2 severity fixed bin (17) unal init (
	  3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
	  3, 3, 3, 1, 2, 4, 3, 2, 3, 3,
	  3, 3, 3, 3, 3, 3, 3, 1, 1, 3,
	  3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
	  3, 3, 3, 3, 1, 1, 3, 3, 3, 3,
	  3, 3, 3
	  ),

       2 Soutput_stmt bit (1) unal init (
	  "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b,
	  "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b,
	  "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b,
	  "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b,
	  "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b,
	  "1"b, "1"b, "0"b
	  ),

       2 message char (120) varying init (
	  "End of input encountered before End statement.", /*  1 */
	  "Keyword ""^a"" unrecognized or out of order.", /*  2 */
	  "Syntax error.",				/*  3 */
	  "Global ""^a"" keyword appears more than once.",/*  4 */
	  "Bad numeric parameter (^a).",		/*  5 */
	  "^a must be between 1 and ^a.",		/*  6 */
	  "Grace time must be positive.",		/*  7 */
	  "The name ""^a"" contains an invalid char.",	/*  8 */
	  "Name ""^a"" is too long.",			/*  9 */
	  "^a ""^a"" has already been defined.",	/* 10 */
	  "^a ""^a"" has not been defined.",		/* 11 */
	  "The ^a ""^a"" specified for ""^a: ^a;"" has not been defined.", /* 12 */
	  "Keyword ""^a"" appears more than once for ""^a: ^a;"".", /* 13 < */
	  "Channel not found in CDT.  Possible error.",	/* 14 */
	  "Data for ""^a"" exceeds ^a chars.",		/* 15 */
	  "Limit of ^a ^a exceeded.  Translation aborted.", /* 16 */
	  "The ^a device has been specified more that once for ^a.", /* 17 */
	  "No ^a specified for ""^a: ^a""",		/* 18 */
	  "No ^a keyword found for ""^a: ^a;"".",	/* 19 */
	  "Specified driver userid doesn't contain project name.", /* 20 */
	  "Specified driver userid contains more than two components.", /* 21 */
	  "Two of the mutually exclusive prph, line and dial_id keywords have been specified for device ""^a"".", /* 22 */
	  "Specified ""^a: ^a;"" for Device ""^a"" matches a previous dial_id or ctl_dial_id.", /* 23 */
	  "Two of the mutually exclusive ctl_line, ctl_dial_id and ctl_source keywords have been specified for device ""^a"".", /* 24 */
	  "Device ""^a"" does not have the ""line: variable;"" statement needed for line ""^a"".", /* 25 */
	  "Device ""^a"" uses a ""line: variable;"" statement, but has no corresponding Line entry.", /* 26 */
	  "The full name of ^a ""^a.^a"" exceeds 32 characters.", /* 27 */
	  "Non-system accounting specified for IO.SysDaemon in Request_type ""^a"".", /* 28 */
	  "System accounting specified for other than *.SysDaemon in Request_type ""^a"".", /* 29 */
	  "",					/* 30 */
	  "One or more device class subkeywords appeared before the first device_class keyword for ""Request_type: ^a;"".", /* 31 */
	  "^a name ""^a"" appears more than once for ^a ""^a"".", /* 32 */
	  "The device ""^a"" specified for ""^a: ^a;"" is missing a minor device component.", /* 33 */
	  "The device ""^a"" specified for ""^a: ^a;"" has not been defined.", /* 34 */
	  "The default_type ""^a"" specified for ""^a: ^a;"" is missing a minor device component.", /* 35 */
	  "The default_type ""^a"" has been specified for ""^a: ^a;"" but device ""^a"" has not been specified for ""^a: ^a;"".", /* 36 */
	  "The default_type ""^a"" specified for ""^a: ^a;"" has not been defined.", /* 37 */
	  "Specified default_queue is greater than max_queues for Request_type ""^a"".", /* 38 */
	  "There must be one price name defined for each possible queue.  Request_type ""^a"".", /* 39 */
	  "Request_type ""^a"".  There is no price defined for ""^a"" in the system price table.", /* 40 */
	  "Max_queues not specified.",		/* 41 */
	  "Time has not been specified.",		/* 42 */
	  "No Device keywords have been specified.",	/* 43 */
	  "No Request_type keywords have been specified.",/* 44 */
	  "No default Request_type has been specified for the ""printer"" generic type.", /* 45 */
	  "No default Request_type has been specified for the ""punch"" generic type.", /* 46 */
	  "No driver_module has been specified for Device ""^a"".", /* 47 */
	  "No prph, line or dial_id has been specified for Device ""^a"".", /* 48 */
	  "Keyword ""^a"" appears more than once for ""^a: ^a;"", ""^a: ^a;"".", /* 49 */
	  "The ""name: ^a;"" statement has already been used in ""Forms_table: ^a;"".", /* 50 */
	  "The ^a statement has too many elements, only ^a allowed.", /* 51 */
	  "Either page_height and/or page_width must be specified for ""name: ^a"".", /* 52 */
	  "Request_type ""^a"" cannot be used by Device ""^a"" since Device entry is missing a forms_table entry." /* 53 */
	  ),

       2 brief_message char (36) varying init (
	  "",					/*  1 */
	  "^a",					/*  2 */
	  "",					/*  3 */
	  "^a",					/*  4 */
	  "^a",					/*  5 */
	  "^a",					/*  6 */
	  "",					/*  7 */
	  "^a",					/*  8 */
	  "^a",					/*  9 */
	  "^a ^a",				/* 10 */
	  "^a ^a",				/* 11 */
	  "^a of ""^a"" for ""^a: ^a"" not defined.",	/* 12 */
	  "Multiple ^a for ""^a: ^a;""",		/* 13 */
	  "",					/* 14 */
	  "^a too long",				/* 15 */
	  "",					/* 16 */
	  "^a ^a",				/* 17 */
	  "^a ""^a: ^a""",				/* 18 */
	  "^a ""^a: ^a;""",				/* 19 */
	  "",					/* 20 */
	  "",					/* 21 */
	  "^a",					/* 22 */
	  """^a: ^a"" ""^a""",			/* 23 */
	  "^a",					/* 24 */
	  """^a"" for Line ""^a"".",			/* 25 */
	  """^a"" for Line ""^a"".",			/* 26 */
	  "^a name ""^a.^a"".",			/* 27 */
	  """^a""",				/* 28 */
	  """^a""",				/* 29 */
	  "",					/* 30 */
	  "^a ""^a""",				/* 31 */
	  "^a ""^a"" ^a ""^a""",			/* 32 */
	  """^a"" ""^a:^a;""",			/* 33 */
	  """^a"" ""^a:^a;""",			/* 34 */
	  """^a"" ""^a:^a;""",			/* 35 */
	  "^a ""^a: ^a;"" ^a ""^a: ^a;""",		/* 36 */
	  "^a ""^a: ^a;""",				/* 37 */
	  """^a""",				/* 38 */
	  """^a""",				/* 39 */
	  """^a"" ""^a""",				/* 40 */
	  "",					/* 41 */
	  "",					/* 42 */
	  "",					/* 43 */
	  "",					/* 44 */
	  "",					/* 45 */
	  "",					/* 46 */
	  """^a""",				/* 47 */
	  """^a""",				/* 48 */
	  """^a"" ""^a: ^a;"" ""^a: ^a;""",		/* 49 */
	  """name: ^a;"" ""Forms_table: ^a;""",		/* 50 */
	  "^a",					/* 51 */
	  "name: ^a",				/* 52 */
	  "Request_type ""^a"", Device ""^a"""		/* 53 */
	  );

%page; %include access_mode_values;
%page; %include device_class;
%page; %include iod_forms_info_tab;
%page; %include iod_constants;
%page; %include iod_device_tab;
%page; %include iod_line_tab;
%page; %include iod_tables_hdr;
%page; %include q_group_tab;
%page; %include terminate_file;




		    iodc_.pl1                       03/15/89  0841.8r w 03/15/89  0800.1      743238



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


/* format: style2 */
iodc_:
     procedure;

/* This is the central procedure of the I/O Daemon Coordinator.
   *  It has various entries which are woken up by event calls.
*/

/* Coded by Robert S. Coren  in August 1973 */
/* Modified for the Access Isolation Mechanism by J. Stern, December 1974 */
/* Modified by J. Stern, 11/25/75 */
/* Modified by J. C. Whitmore, 4/78, to support max queues per request type and save more descriptor flags */
/* Modified by J. C. Whitmore, 7/78, for extended driver commands and queue priority functions */
/* Modified by J. C. Whitmore, 11/78, for version 3 iod_tables format and start using coord version numbers */
/* Modified by J. C. Whitmore, 5/80, to mark priority requests in the queue */
/* Modified by Benson I. Margulies 1980*12*29 for unaligned system_dir
   argument and variable iod_table segname. */
/* Modified January 1984 by C. Marker  Added probe as a valid command in test mode. */
/* Modified December 1984 by Keith Loepere to set dir_quota. */
/* Modified January 1985 by Keith Loepere to be smarter about same. */
/* Modified February 23, 1985 by C. Marker to use version 5 message segments */


/****^  HISTORY COMMENTS:
  1) change(87-02-04,Gilcrease), approve(87-02-04,MCR7610),
     audit(87-02-18,Farley), install(87-03-25,MR12.1-1013):
               Correct call to internal subroutine for the NEXT command.
  2) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-17,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.
                                                   END HISTORY COMMENTS */

	dcl     a_ptr		 ptr;		/* pointer passed as argument to most entries */


/* External entries */

	dcl     aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     aim_check_$greater_or_equal
				 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     com_err_		 entry options (variable);
	dcl     convert_ipc_code_	 entry (fixed bin (35));
	dcl     debug		 entry;
	dcl     delete_$path	 entry (char (*) aligned, char (*) aligned, bit (6), char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
	dcl     find_next_request_	 entry (fixed bin, ptr) returns (bit (1) aligned);
	dcl     find_next_request_$init
				 entry (ptr);
	dcl     free_oldest_request_$cleanup
				 entry;
	dcl     free_oldest_request_$force
				 entry;
	dcl     free_oldest_request_$init
				 entry (ptr);
	dcl     get_authorization_	 entry returns (bit (72) aligned);
	dcl     get_group_id_$tag_star entry returns (char (32));
	dcl     get_process_id_	 entry returns (bit (36) aligned);
	dcl     get_ring_		 entry returns (fixed bin (6));
	dcl     get_system_free_area_	 entry (ptr);
	dcl     hcs_$chname_seg	 entry (ptr, char (*) aligned, char (*), fixed bin (35));
	dcl     hcs_$create_branch_	 entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
	dcl     hcs_$delentry_seg	 entry (ptr, fixed bin (35));
	dcl     hcs_$get_access_class	 entry (char (*) aligned, char (*), bit (72) aligned, fixed bin (35));
	dcl     hcs_$initiate_count	 entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24),
				 fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*) aligned, char (*) aligned, char (*), fixed bin (5), ptr,
				 fixed bin (35));
	dcl     hcs_$set_ring_brackets entry (char (*) aligned, char (*) aligned, (3) fixed bin (3), fixed bin (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	dcl     hcs_$wakeup		 entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$ioa_stream	 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     iod_overseer_$coord_ready
				 entry;
	dcl     iodc_$command_level	 entry;
	dcl     iodc_$free_device	 entry (ptr, fixed bin (35));
	dcl     iodc_message_	 entry (bit (3) aligned, fixed bin (35), char (*));
	dcl     iodc_message_$loud	 entry (bit (3) aligned, fixed bin (35), char (*));
	dcl     iodc_message_$init	 entry;
	dcl     iodd_$iodd_init	 entry (char (*) aligned, bit (1) aligned);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$decl_ev_call_chn	 entry (fixed bin (71), ptr, ptr, fixed bin, fixed bin (35));
	dcl     ipc_$drain_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     ipc_$mask_ev_calls	 entry (fixed bin (35));
	dcl     ipc_$unmask_ev_calls	 entry (fixed bin (35));
	dcl     logout		 entry;
	dcl     match_request_id_	 entry (fixed bin (71), char (*) aligned) returns (bit (1) aligned);
	dcl     message_segment_$create
				 entry (char (*) aligned, char (*) aligned, fixed bin (35));
	dcl     message_segment_$delete
				 entry (char (*) aligned, char (*) aligned, fixed bin (35));
	dcl     message_segment_$delete_index
				 entry (fixed bin, bit (72) aligned, fixed bin (35));
	dcl     message_segment_$ms_acl_add
				 entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35));
	dcl     message_segment_$read_message_index
				 entry (fixed bin, pointer, pointer, fixed bin (35));
	dcl     message_segment_$open	 entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (35));
	dcl     message_segment_$check_salv_bit_index
				 entry (fixed bin, bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     message_segment_$update_message_index
				 entry (fixed bin, fixed bin (24), bit (72) aligned, ptr, fixed bin (35));
	dcl     new_proc		 entry;
	dcl     print_devices	 entry options (variable);
	dcl     privileged_make_seg_	 entry (char (*) aligned, char (*) aligned, char (*), fixed bin (5), ptr,
				 fixed bin (35));
	dcl     probe		 entry ();
	dcl     save_request_	 entry (ptr, ptr);
	dcl     save_request_$init	 entry (ptr);
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     signal_		 entry (char (*));
	dcl     system_info_$access_ceiling
				 entry (bit (72) aligned);
	dcl     system_privilege_$initiate_count
				 entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24),
				 fixed bin (2), ptr, fixed bin (35));
	dcl     timer_manager_$reset_alarm_wakeup
				 entry (fixed bin (71));
	dcl     unique_bits_	 entry returns (bit (70));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     unthread_descriptor_	 entry (ptr);
	dcl     unthread_descriptor_$init
				 entry (ptr);

/* Automatic storage */

	dcl     ack_chan		 fixed bin (71);
	dcl     area_flag		 fixed bin;
	dcl     auth		 bit (72) aligned;	/* process access authorization */
	dcl     bc		 fixed bin (24);	/* bit count */
	dcl     chan_name		 fixed bin (71);
	dcl     cmd		 char (24) aligned;
	dcl     code		 fixed bin (35);
	dcl     code2		 fixed bin (35);
	dcl     copy_ptr		 ptr;		/* pointer to copy of descriptor */
	dcl     copy_words		 fixed bin;	/* size of copy_template array */
	dcl     cwtp		 ptr;		/* ptr to coord_working_tables */
	dcl     dcx		 fixed bin;	/* index of a device_class entry */
	dcl     desc_off		 fixed bin (18);	/* offset of a request descriptor */
	dcl     desc_ptr		 ptr;		/* pointer to a request descriptor */
	dcl     dev_id		 char (32) aligned;
	dcl     dir_quota		 fixed bin;
	dcl     dr_ptr		 ptr;
	dcl     entry_type		 fixed bin;
	dcl     ev_info_ptr		 ptr;
	dcl     finish		 fixed bin;
	dcl     fwx		 fixed bin;
	dcl     i			 fixed bin;
	dcl     idtx		 fixed bin;	/* iod device table index */
	dcl     iodc_data_ptr	 ptr;
	dcl     iwtp		 ptr;		/* ptr to iod_working_tables */
	dcl     iwtrb		 (3) fixed bin (3); /* ring brackets for iod_working_tables */
	dcl     len		 fixed bin;
	dcl     line		 char (80);
	dcl     lwx		 fixed bin;
	dcl     mask_code		 fixed bin (35);	/* status code from ipc_$unmask_ev_calls */
	dcl     match_dir		 char (168) aligned;
	dcl     match_ent		 char (32) aligned;
	dcl     mdtx		 fixed bin;	/* minor device table index */
	dcl     message_len		 fixed bin;	/* length (in bits) of based_message */
	dcl     ms_id		 bit (72) aligned;	/* message id */
	dcl     nc		 fixed bin;
	dcl     new_driver_id	 char (32) aligned; /* person/project id of new driver */
	dcl     new_idx		 fixed bin;
	dcl     new_iwtp		 ptr;		/* ptr to new copy of iod_working_tables */
	dcl     next_ptr		 ptr;		/* pointer to next request descriptor */
	dcl     nseries		 fixed bin;	/* number of series in series_info */
	dcl     nx		 fixed bin;
	dcl     out_len		 fixed bin;	/* length of error message */
	dcl     out_msg		 char (200);
	dcl     proc_id		 bit (36) aligned;
	dcl     q			 fixed bin;
	dcl     q_idx		 fixed bin;	/* index of queue message seg. */
	dcl     q_name		 char (32) aligned;
	dcl     quota		 fixed bin;
	dcl     retry		 fixed bin;
	dcl     reqp		 ptr;
	dcl     seg_name		 char (32) aligned;
	dcl     sender_class	 char (32) aligned; /* name of device class of sender of driver signal */
	dcl     sender_device	 char (32) aligned; /* name of device run by sender of  a driver signal */
	dcl     sender_id		 char (32) aligned;
	dcl     seq_id		 fixed bin (35);
	dcl     series_id		 fixed bin (35);
	dcl     series_sw		 bit (1) aligned;
	dcl     sig_type		 fixed bin;
	dcl     sip		 ptr;		/* ptr to series_info structure */
	dcl     start		 fixed bin;
	dcl     subdir		 char (168) aligned;/* used to hold pathnames of subdirs of sysdir */
	dcl     system_high		 bit (72) aligned;	/* system high authorization */
	dcl     unbit		 bit (1) aligned;
	dcl     user_id		 char (32) aligned;
	dcl     wlp		 ptr;
	dcl     x			 fixed bin;

/* Internal static storage */

	dcl     areap		 ptr int static;	/* ptr to sys_area */
	dcl     driver_sig_chan	 fixed bin (71) int static;
						/* name of channel over which signals from */
						/* driver processes will come */
	dcl     static_idtp		 int static ptr;	/* pointer to io daemon device table */
	dcl     static_mdtp		 int static ptr;	/* pointer to minor device table */
	dcl     driver_cmd_chan	 fixed bin (71) int static;
						/* IPC channel for driver to signal commands which */
						/* are read through the coord_comm.ms seg */
	dcl     recursion_flag	 fixed bin int static;
						/* used to prevent recursive faults */
	dcl     scu_msg		 char (120) int static init ("");
	dcl     sysdir		 char (168) aligned int static;
	dcl     testing		 bit (1) int static;
	dcl     quit_flag		 bit (1) int static;
	dcl     err_label		 label int static;
	dcl     return_label	 label int static;	/* for returning in test environment */

	dcl     comm_mseg_idx	 fixed bin int static;
						/* message segment index for coord_comm.ms */
	dcl     sysdir_len		 fixed bin int static;
						/* length of pathname in sysdir */
	dcl     sysdir_class	 bit (72) aligned int static;
						/* access class of sysdir */
	dcl     initialized		 bit (1) aligned int static;
						/* turned on when coord initialization is complete */
	dcl     coord_proc_id	 bit (36) int static;
						/* coordinator's process id */
	dcl     new_driver_series	 int static;	/* first sequence number for new driver */
	dcl     com_level		 fixed bin int static;
						/* command level depth */
	dcl     n_acl		 fixed bin int static;

/* External static */

	dcl     error_table_$action_not_performed
				 fixed bin (35) ext static;
	dcl     error_table_$bad_segment
				 fixed bin (35) ext static;
	dcl     error_table_$invalid_move_qmax
				 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$namedup	 fixed bin (35) ext static;
	dcl     error_table_$pathlong	 fixed bin (35) ext static;
	dcl     error_table_$argerr	 fixed bin (35) ext static;
	dcl     error_table_$invalid_lock_reset
				 fixed bin (35) ext static;
	dcl     error_table_$segknown	 fixed bin (35) ext static;
	dcl     error_table_$request_not_recognized
				 fixed bin (35) ext static;
	dcl     error_table_$ai_above_allowed_max
				 fixed bin (35) ext static;
	dcl     error_table_$ai_restricted
				 fixed bin (35) ext static;

	dcl     iox_$user_input	 ptr ext;
	dcl     iox_$user_io	 ptr ext static;
%page;

/* Constants */

	dcl     io_coordinator_version char (8) int static options (constant) init ("3.2");
	dcl     driver_command	 fixed bin int static options (constant) init (100);
	dcl     id		 char (16) int static options (constant) init ("io_coordinator");
	dcl     new_driver		 fixed bin int static options (constant) init (200);
	dcl     priority		 fixed bin int static options (constant) init (2);
	dcl     NL		 char (1) int static options (constant) init ("
");


/* Conditions */

	dcl     any_other		 condition;
	dcl     quit		 condition;
	dcl     cleanup		 condition;
	dcl     area		 condition;

/* these guys are just used to pass addresses to ipc_$decl_ev_call_chn */

	dcl     free_oldest_request_$free_oldest_request_
				 fixed bin ext static;
	dcl     iodc_$new_driver	 fixed bin ext static;
	dcl     iodc_$driver_signal	 fixed bin ext static;
	dcl     iodc_$driver_command	 fixed bin ext static;

/* Based storage */

	dcl     based_message	 bit (message_len) aligned based;
	dcl     copy_template	 (copy_words) fixed bin based;
						/* for segment copying */
	dcl     sys_area		 area (65560) based (areap);
						/* system area */

/* Builtins */

	dcl     (addr, before, divide, empty, fixed, length, ltrim, max, mod, null, ptr, rel, rtrim, stac, string,
	        substr, unspec)	 builtin;
%page;

/* Structure declarations */

	dcl     1 ev_info		 based (ev_info_ptr),
		2 channel		 fixed bin (71),
		2 message		 fixed bin (71),
		2 sending_proc	 bit (36);

	dcl     1 acl		 (3) aligned int static,
		2 ac_name		 char (32),
		2 modes		 bit (36),
		2 pad		 bit (36) init ((3) (36)"0"b),
		2 code		 fixed bin (35);

	dcl     1 dir_acl		 (2) aligned int static,
		2 ac_name		 char (32),
		2 modes		 bit (36),
		2 code		 fixed bin (35);

	dcl     1 driver_mmi	 aligned like mseg_message_info;

	dcl     1 msg_mmi		 aligned like mseg_message_info;

	dcl     1 coord_static	 int static aligned like iodc_static;
						/* space for iodc_static */

	dcl     1 branch_info	 aligned int static like create_branch_info;

	dcl     1 ms_acl		 aligned,		/* for setting extended acl on message segment */
		2 acc_name	 char (32),
		2 mode		 bit (36),
		2 exmode		 bit (36),
		2 reterr		 fixed bin (35);

	dcl     1 series_info	 (nseries) aligned based (sip),
						/* for restart_status command */
		2 count		 fixed bin,
		2 first		 fixed bin,
		2 last		 fixed bin,
		2 dcx		 fixed bin;

	dcl     1 option		 aligned,		/* control options for the next_req driver request */
		2 dev		 bit (1) unal,
		2 q		 bit (1) unal,
		2 user		 bit (1) unal,
		2 id		 bit (1) unal,
		2 et		 bit (1) unal,
		2 pn		 bit (1) unal,
		2 pad		 bit (30) unal;

%page;

iodc_init:
     entry (dir, test_bit, test_iod_tables);

/* Main entry point for I/O Coordinator */
/* Initializes I/O Coordinator and waits for drivers.
*/

	dcl     dir		 char (*);
	dcl     test_bit		 bit (1) aligned;
	dcl     test_iod_tables	 char (*);

	call iodc_message_$init ();			/* set up stream attachments */

	call ioa_ ("I/O Coordinator Version: ^a", io_coordinator_version);

	sysdir = dir;
	sysdir_len = length (rtrim (sysdir));
	if sysdir_len > 136
	then do;
		call com_err_ (error_table_$pathlong, "iodc_init", "Cannot append max size device name to ^a.",
		     sysdir);
		go to forget_it;
	     end;

	subdir = substr (sysdir, 1, sysdir_len) || ">coord_dir";
						/* construct pathname of coord_dir */

	testing = test_bit;
	return_label = back;
	err_label = forget_it;
	stat_p = addr (coord_static);

	call get_system_free_area_ (areap);		/* set this once for temp allocations */

	new_driver_series = 0;
	com_level = -1;



	initialized = "0"b;
	quit_flag = "0"b;
	on quit call quit_handler;
	call iox_$control (iox_$user_io, "quit_enable", null, code);

	recursion_flag = 0;
	on cleanup call clean_up;			/* unmask, drop timer, etc. */
	on any_other call iodc_handler;

/* set up acl for data segs and directories */

	n_acl = 2;

	dir_acl (1).ac_name, acl (1).ac_name = get_group_id_$tag_star ();
						/* make sure this process always has access */
	dir_acl (1).modes, acl (1).modes = "111"b;

	dir_acl (2).ac_name, acl (2).ac_name = "*.*.*";
	dir_acl (2).modes, acl (2).modes = "100"b;

/* First thing to do is check the saved list left by the last
   coordinator for segments to be deleted.  To do this we need
   two data bases:  req_desc_seg, and request_seg.
*/

	call free_oldest_request_$init (stat_p);
	call unthread_descriptor_$init (stat_p);

	call initiate (subdir, "req_desc_seg", iodc_static.descr_seg_ptr, code);
	if code ^= 0
	then
no_purge:
	     call com_err_ (0, "iodc_init",
		"Warning -- Cannot get old saved list.  Some deletions may not be performed.");
	else do;
		call initiate (subdir, "request_seg", iodc_static.req_seg_ptr, code);
		if code ^= 0
		then go to no_purge;

		iodc_static.save_first_req_p = addr (req_desc_seg.first_saved);
		iodc_static.first_req_done = req_desc_seg.first_saved;
		do while (iodc_static.first_req_done ^= 0);
		     call free_oldest_request_$cleanup;
		end;
	     end;

/* delete coord_dir to make sure it gets recreated with proper access class */

	call delete_$path (sysdir, "coord_dir", "101101"b, "", code);
	if code ^= 0
	then if code ^= error_table_$noentry
	     then do;
		     call com_err_ (code, "iodc_init", "Deleting coord_dir");
		     go to forget_it;
		end;


/* get access class of sysdir and process authorization */

	call hcs_$get_access_class (sysdir, "", sysdir_class, code);
	if code ^= 0
	then do;
		call com_err_ (code, "iodc_init", sysdir);
		go to forget_it;
	     end;

	auth = get_authorization_ ();
	if ^testing
	then do;
		call system_info_$access_ceiling (system_high);
		if ^aim_check_$equal (system_high, auth)
		then call com_err_ (0, "iodc_init", "Warning -- Coordinator authorization is not ""system_high"".");
	     end;

/* make a subdirectory to hold the coordinator's writable data segs (i.e. segs modified after initialization) */
/* this subdirectory will be upgraded (if necessary) to the coordinator's authorization */
/* if upgraded, a quota of 250/25 records will be assigned */

	branch_info.version = create_branch_version_2;	/* initialize branch info structure */
	branch_info.dir_sw = "1"b;
	branch_info.copy_sw = "0"b;
	branch_info.chase_sw = "1"b;
	branch_info.priv_upgrade_sw = "0"b;
	branch_info.mbz1 = ""b;
	branch_info.mode = "101"b;
	branch_info.mbz2 = ""b;
	branch_info.rings (1), branch_info.rings (2), branch_info.rings (3) = get_ring_ ();
	branch_info.userid = acl (1).ac_name;
	branch_info.bitcnt = 0;

	call make_dir ("coord_dir", auth, 250, 25, code);
	if code ^= 0
	then do;
		call com_err_ (code, "iodc_init", "^a>^a", sysdir, "coord_dir");
		go to forget_it;
	     end;

/* set up data segments residing in sysdir */

	seg_name = "iodc_data";
	call make (sysdir, seg_name, iodc_data_ptr, code);
	if code ^= 0
	then do;
no_init:
		call com_err_ (code, "iodc_init", "Could not initiate(create) ^a", seg_name);
forget_it:
		call ioa_$ioa_stream ("error_output", "Process cannot be initialized.");
		return;
	     end;

	if test_bit & test_iod_tables ^= ""
	then seg_name = test_iod_tables;
	else seg_name = "iod_tables";			/* get ptr to most recently compiled iod tables */
	call initiate (sysdir, seg_name, ithp, code);
	if code ^= 0
	then go to no_init;
	copy_words = divide (bc, 36, 24, 0);		/* remember number of words */

	if iod_tables_hdr.version ^= IODT_VERSION_5
	then do;
		call com_err_ (0, "iodc_init", "Wrong version number for iod_tables.");
		go to forget_it;
	     end;

/* now get the last iod_working_tables used to see if anything has changed. */
	iwtp = null;
	seg_name = "iod_working_tables";
	call initiate (sysdir, seg_name, iwtp, code);
	if code ^= 0
	then if code = error_table_$noentry
	     then go to update;
	     else go to no_init;

/* If version number has changed, iod_working_tables is to be ignored.
   Fake a new table update.
   If the version numbers are the same, then see if iod_tables is newer.
   If so update the working tables with the new tables */
	if iwtp -> iod_tables_hdr.version ^= IODT_VERSION_5
	then go to update;
	if iod_tables_hdr.date_time_compiled > iwtp -> iod_tables_hdr.date_time_compiled
	then do;					/* new tables, must update the working tables */
update:
		seg_name = unique_chars_ (unique_bits_ ());
						/* create unique name segment */
		call make (sysdir, seg_name, new_iwtp, code);
		if code ^= 0
		then go to no_init;

		iwtrb (1) = branch_info.rings (1);	/* set up ring brackets for working tables */
		iwtrb (2), iwtrb (3) = 5;		/* make available through ring 5 */
		call hcs_$set_ring_brackets (sysdir, seg_name, iwtrb, code);
		if code ^= 0
		then do;
			call com_err_ (code, "iodc_init", "Attempting to set ring brackets of ^a", seg_name);
			go to forget_it;
		     end;

		new_iwtp -> copy_template = ithp -> copy_template;
						/* copy in iod_tables */

		if iwtp ^= null
		then do;
			call hcs_$delentry_seg (iwtp, code);
						/* delete old working tables */
			if code ^= 0
			then do;
				call com_err_ (code, "iodc_init", "Attempting to delete iod_working_tables");
				go to forget_it;
			     end;
		     end;
		call hcs_$chname_seg (new_iwtp, seg_name, "iod_working_tables", code);
						/* change name of new working tables */
		if code ^= 0
		then do;
			call com_err_ (code, "iodc_init", "Attempting to change name of iod_working_tables");
			go to forget_it;
		     end;
		iwtp = new_iwtp;
	     end;

	call hcs_$terminate_noname (ithp, code);


/* set up segments in "coord_dir" */

	seg_name = "coord_working_tables";		/* make coordinator's private copy of iod_tables */
	call make (subdir, seg_name, cwtp, code);
	if code ^= 0
	then go to no_init;
	cwtp -> copy_template = iwtp -> copy_template;

	call hcs_$terminate_noname (iwtp, code);

	seg_name = "waiting_list";
	call make (subdir, seg_name, iodc_static.wait_list_ptr, code);
	if code ^= 0
	then go to no_init;

	seg_name = "req_desc_seg";
	call make (subdir, "req_desc_seg", iodc_static.descr_seg_ptr, code);
	if code ^= 0
	then go to no_init;
	descr_area = empty;

	seg_name = "request_seg";
	call make (subdir, "request_seg", iodc_static.req_seg_ptr, code);
	if code ^= 0
	then go to no_init;
	req_area = empty;


/* initialize table pointers and other static info */

	static_idtp = ptr (cwtp, cwtp -> iod_tables_hdr.device_tab_offset);
	static_mdtp = ptr (cwtp, cwtp -> iod_tables_hdr.minor_device_tab_offset);
	text_strings_ptr = ptr (cwtp, cwtp -> iod_tables_hdr.text_strings_offset);
	iodc_static.qgtp = ptr (cwtp, cwtp -> iod_tables_hdr.q_group_tab_offset);
	iodc_static.dctp = ptr (cwtp, cwtp -> iod_tables_hdr.dev_class_tab_offset);
	iodc_static.time_interval = cwtp -> iod_tables_hdr.grace_time;
	iodc_static.max_q = cwtp -> iod_tables_hdr.max_queues;
	iodc_static.first_req_done, iodc_static.last_req_done = 0;
	iodc_static.save_first_req_p = addr (req_desc_seg.first_saved);
	req_desc_seg.first_saved = 0;

/* set up message segment for new driver messages */

	call message_segment_$delete (sysdir, "coord_comm.ms", code);
						/* delete old message seg, if any */
	if code ^= 0
	then if code ^= error_table_$noentry
	     then do;				/* could not delete it */
		     call com_err_ (code, "iodc_init", "Attempting to delete coord_comm.ms");
		     go to forget_it;
		end;

	seg_name = "coord_comm.ms";			/* for error message */
	call message_segment_$create (sysdir, "coord_comm.ms", code);
						/* create new message seg */
	if code ^= 0
	then go to no_init;				/* give up */
	call message_segment_$open (sysdir, "coord_comm.ms", comm_mseg_idx, code);
						/* open it */
	if code ^= 0
	then go to no_init;				/* give up */

/* place the userid for each queue group on the message segment acl */

	ms_acl.mode = "101"b;			/* want "rw" real access */
	ms_acl.exmode = "1"b;			/* want "a" extended access */

	do q = 1 to iodc_static.qgtp -> q_group_tab.n_q_groups;
						/* loop through queue groups */
	     qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (q));
						/* get ptr to q group entry */
	     if qgte.driver_id ^= acl (1).ac_name
	     then do;				/* don't change coord's access */
		     ms_acl.acc_name = qgte.driver_id;
		     call message_segment_$ms_acl_add (sysdir, "coord_comm.ms", addr (ms_acl), 1, code);
		     if code ^= 0
		     then do;
			     if code = error_table_$argerr
			     then code = ms_acl.reterr;
			     call com_err_ (code, "iodc_init", "Adding to acl of coord_comm.ms");
			     go to forget_it;
			end;
		end;

	     qgte.open = 0;				/* initialize this while we're here */
	end;

/* initialize other coordinator procedures */

	call find_next_request_$init (stat_p);
	call save_request_$init (stat_p);

/*  free all devices, i.e. delete all device dirs and segs */

	do idtx = 1 to static_idtp -> iod_device_tab.n_devices;
	     idtep = addr (static_idtp -> iod_device_tab.entries (idtx));
	     idte.process_id = ""b;
	     call iodc_$free_device (idtep, code);
	     if code ^= 0
	     then /* failed to delete device directory */
		go to forget_it;
	end;


/* initialize the device class table */

	do dcx = 1 to iodc_static.dctp -> dev_class_tab.n_classes;
	     dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx));
	     dcte.pending_request, dcte.restart_req = 0;
	end;

/* change initial acl so it will work for driver segs. */

	n_acl = 3;
	acl (n_acl).modes = "101"b;


/* set up drivers' event channels */
/* new-driver signal will have lower priority so coming-up message */
/* can't beat previous logout message for same device */

	call ipc_$create_ev_chn (chan_name, code);
	if code ^= 0
	then do;
no_ipc:
		call convert_ipc_code_ (code);
		call com_err_ (code, "iodc_init", "IPC error setting up event channels.");
		go to forget_it;
	     end;
	call ipc_$decl_ev_call_chn (chan_name, addr (iodc_$new_driver), null, 3, code);
	if code ^= 0
	then go to no_ipc;
	iodc_data.init_event_channel = chan_name;

	call ipc_$create_ev_chn (chan_name, code);
	if code ^= 0
	then go to no_ipc;
	call ipc_$decl_ev_call_chn (chan_name, addr (iodc_$driver_signal), null, 1, code);
	if code ^= 0
	then go to no_ipc;
	driver_sig_chan = chan_name;

	call ipc_$create_ev_chn (chan_name, code);
	if code ^= 0
	then go to no_ipc;
	call ipc_$decl_ev_call_chn (chan_name, addr (iodc_$driver_command), null, 2, code);
	if code ^= 0
	then go to no_ipc;
	driver_cmd_chan = chan_name;

/* and timer channel for freeing "saved" requests */

	call ipc_$create_ev_chn (iodc_static.timer_chan, code);
	if code ^= 0
	then go to no_ipc;
	call ipc_$decl_ev_call_chn (iodc_static.timer_chan, addr (free_oldest_request_$free_oldest_request_), null, 1,
	     code);
	if code ^= 0
	then go to no_ipc;


/* OK, let the show begin ... */

	coord_proc_id, iodc_data.proc_id = get_process_id_ ();

	initialized = "1"b;
	call iodc_message_ ("010"b, 0, "I/O Coordinator initialized");
	call iod_overseer_$coord_ready;		/* drivers can now get started */
	call iodc_$command_level;


back:
	call clean_up;
	return;					/* return to overseer (only in test mode) */


clean_up:
     proc;

	call timer_manager_$reset_alarm_wakeup (iodc_static.timer_chan);
						/* through with this */
	call ipc_$drain_chn (iodc_static.timer_chan, code);
	call iox_$control (iox_$user_io, "start", null (), code);
	call ipc_$unmask_ev_calls (code2);
	call ipc_$delete_ev_chn (iodc_static.timer_chan, code2);
	call ipc_$delete_ev_chn (driver_cmd_chan, code2);
	call ipc_$delete_ev_chn (driver_sig_chan, code2);
	call ipc_$delete_ev_chn (iodc_data.init_event_channel, code2);
	return;

     end clean_up;
%page;

make:
     proc (dirname, entname, p, code);

	dcl     dirname		 char (*) aligned;
	dcl     entname		 char (*) aligned;
	dcl     p			 ptr;
	dcl     code		 fixed bin (35);
	dcl     hcs_$replace_acl	 entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1) aligned,
				 fixed bin (35));

	if testing
	then call hcs_$make_seg (dirname, entname, "", 01111b, p, code);
	else call privileged_make_seg_ (dirname, entname, "", 01111b, p, code);
	if code ^= 0
	then if code ^= error_table_$namedup
	     then if code ^= error_table_$segknown
		then return;
	call hcs_$replace_acl (dirname, entname, addr (acl), n_acl, "0"b, code);

	return;
     end;

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

make_dir:
     proc (ename, aclass, aquota, adir_quota, code);

	dcl     ename		 char (*) aligned;
	dcl     aclass		 bit (72) aligned;	/* access class of directory */
	dcl     aquota		 fixed bin;	/* quota on directory */
	dcl     adir_quota		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     hcs_$replace_dir_acl	 entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1),
				 fixed bin (35));

	branch_info.access_class = aclass;
	if aim_check_$equal (aclass, sysdir_class)
	then branch_info.quota, branch_info.dir_quota = 0;
	else do;
		branch_info.quota = aquota;		/* need quota if dir is upgraded */
		branch_info.dir_quota = adir_quota;
	     end;

create_branch:
	call hcs_$create_branch_ (sysdir, ename, addr (branch_info), code);
	if code = error_table_$invalid_move_qmax
	then if branch_info.dir_quota = 0
	     then return;
	     else do;				/* try create without dir quota */
		     branch_info.dir_quota = 0;
		     go to create_branch;
		end;
	if code ^= 0
	then return;

	call hcs_$replace_dir_acl (sysdir, ename, addr (dir_acl), 2, "0"b, code);
     end make_dir;

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

initiate:
     proc (dir, ent, p, code);

	dcl     dir		 char (*) aligned;
	dcl     ent		 char (*) aligned;
	dcl     p			 ptr;
	dcl     code		 fixed bin (35);

	if testing
	then /* don't use system_privilege_ in test mode */
	     call hcs_$initiate_count (dir, ent, "", bc, 0, p, code);
	else call system_privilege_$initiate_count (dir, ent, "", bc, 0, p, code);

	if code = error_table_$segknown
	then code = 0;

     end initiate;
%page;

driver_signal:
     entry (a_ptr);

/* This entry receives the wakeup from a driver process that has
   *  just finished a request (or otherwise become ready for work),
   *  or has just received a "restart", "save", or "logout" command.
   *  The code in the event message will tell us which.
*/

	mask_code = -1;
	on cleanup
	     begin;
		if mask_code = 0
		then call ipc_$unmask_ev_calls (code2);
	     end;
	call ipc_$mask_ev_calls (mask_code);

	ev_info_ptr = a_ptr;
	err_label = iodc_return;
	proc_id = ev_info.sending_proc;

/* find out which driver sent signal and make sure it's legitimate */

	mdtx = addr (ev_info.message) -> ev_msg.minor_dev_index;
						/* get minor device index */

	call identify_sender (code);
	if code ^= 0
	then go to bad_signal;			/* reject the signal */

/* find out what kind of signal it was, and branch accordingly */

	sig_type = addr (ev_info.message) -> ev_msg.code;
	if sig_type < 0 | sig_type > 5		/* Uh oh */
	then do;
		call ioa_$rsnnl ("Driver signal rejected from device ^a (bad code: ^d)", out_msg, out_len,
		     sender_device, sig_type);
bad_signal:
		call iodc_message_ ("101"b, 0, out_msg);
		go to iodc_return;
	     end;

	go to sig_label (sig_type);


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

identify_sender:
     proc (code);

	dcl     code		 fixed bin (35);

	if mdtx < 0 | mdtx > static_mdtp -> minor_device_tab.n_minor
						/* a bum index */
	then do;
		out_msg = "Driver signal rejected (bad device index)";
		code = error_table_$request_not_recognized;
		return;
	     end;

	mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx));
						/* get ptr to minor device entry */
	idtx = mdte.major_index;			/* get major device index for this minor device */
	idtep = addr (static_idtp -> iod_device_tab.entries (idtx));
						/* get ptr to major device entry */

	if idte.process_id ^= ev_info.sending_proc	/* whoever sent signal does not own the device */
	then do;
		out_msg = "Driver signal rejected (device not assigned to process)";
		code = error_table_$request_not_recognized;
		return;
	     end;

	if mdte.active ^= 1
	then do;					/* device isn't active, cannot accept signal */
		out_msg = "Driver signal rejected (minor device not active)";
		code = error_table_$request_not_recognized;
		return;
	     end;

	dr_ptr = mdte.driver_ptr;			/* pick up ptr to driver status segment */
	dcx = mdte.dev_class_index;			/* pick up index of device class entry */
	dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx));
						/* get ptr to device class entry */
	qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index));

	sender_device = get_device_name ();		/* keep signal sender's device name handy */
	sender_class = get_class_name ();		/* and device class name too */

	code = 0;
	return;

     end identify_sender;

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

get_device_name:
     proc returns (char (32) aligned);

	dcl     name		 char (32) aligned;

	if idte.last_minor > idte.first_minor /* if more than one minor */ | idte.dev_id ^= mdte.dev_id
	then /* or if minor name is different, add it on */
	     name = rtrim (idte.dev_id) || "." || mdte.dev_id;
	else name = idte.dev_id;
	return (name);

     end get_device_name;


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

get_class_name:
     proc returns (char (32) aligned);

	dcl     name		 char (32) aligned;

	if qgte.last_dev_class > qgte.first_dev_class /* if more than one device class */ | qgte.name ^= dcte.id
	then /* or if device class name is different, add it on */
	     name = rtrim (qgte.name) || "." || dcte.id;
	else name = qgte.name;
	return (name);

     end get_class_name;
%page;

sig_label (0):
sig_label (1):					/*
 Come here on normal driver signal.
 (sig_type = 0) => driver done with request
 (sig_type = 1) => driver wants a new request (and is done with any current request) */
						/* find out if driver just finished a request */
	if mdte.current_request ^= 0
	then do;

/* yes, we've got a descriptor */
/* copy updated portions */

		desc_ptr = ptr (iodc_static.descr_seg_ptr, mdte.current_request);
		copy_ptr = addr (dr_ptr -> driver_status.descriptor);
		if ^(copy_ptr -> request_descriptor.finished | copy_ptr -> request_descriptor.cancelled)
		then go to iodc_return;		/* don't screw up active request */
		call update_descriptor;

		mdte.current_request = 0;

/* if it hasn't been saved yet, save it */

		call save_request_ (desc_ptr, dctep);
	     end;

	if sig_type = 0
	then go to iodc_return;			/* driver doesn't want a new request */

/* is there a request hanging? */

	if dcte.pending_request ^= 0
	then do;
		desc_ptr = ptr (iodc_static.descr_seg_ptr, dcte.pending_request);
		dcte.pending_request = desc_ptr -> request_descriptor.next_pending;
	     end;


/* are we in a restart cycle ? */

	else if dcte.restart_req ^= 0
	then do;					/* in restart cycle */
		desc_ptr = ptr (iodc_static.descr_seg_ptr, dcte.restart_req);
		call unthread_descriptor_ (desc_ptr);	/* will be moved to end of saved list */
		desc_ptr -> request_descriptor.restarted = "1"b;
		desc_ptr -> request_descriptor.prev_seq_id = desc_ptr -> request_descriptor.seq_id;
		dcte.restart_req = 0;		/* reset indicator til we find another */

/* 	if restarting a series, find the next request to restart next time around */

		if desc_ptr -> request_descriptor.series_restart
		then do;
			series_id = divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0);
			desc_off = desc_ptr -> request_descriptor.next_done;
			do while (desc_off ^= 0);	/* look for next request to restart */
			     next_ptr = ptr (iodc_static.descr_seg_ptr, desc_off);
						/* if this is part of the series */
			     if divide (next_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id
			     then do;
				     next_ptr -> request_descriptor.saved = "1"b;
						/* should be on already, make sure */
				     next_ptr -> request_descriptor.series_restart = "1"b;
						/* so should this */
				     dcte.restart_req = desc_off;
						/* we'll do this one next time */
				     desc_off = 0;	/* drop out of loop */
				end;

			     else desc_off = next_ptr -> request_descriptor.next_done;
			end;
		     end;
	     end;


	else do;

/* Now we must get a brand new request from one of the queues */

		area_flag = 0;			/* indicates area condition not raised yet */
		on area call area_handler;
		allocate request_descriptor in (descr_area) set (desc_ptr);
		revert area;

		unspec (desc_ptr -> request_descriptor) = ""b;

		if ^find_next_request_ (dcx, desc_ptr)
		then do;

/* we didn't get one */

			free desc_ptr -> request_descriptor in (descr_area);

			if dr_ptr -> driver_status.acknowledge
			then do;			/* must tell driver anyway */
				call hcs_$wakeup (idte.process_id, dr_ptr -> driver_status.driver_chan, 0, code);
				if code ^= 0
				then call check_wakeup_code (code);
			     end;

			go to iodc_return;
		     end;

	     end;


/* Okay, let's send it! */

	desc_ptr -> request_descriptor.seq_id = mdte.seq_id + 1;
	desc_ptr -> request_descriptor.finished = "0"b;

	addr (dr_ptr -> driver_status.descriptor) -> request_descriptor = desc_ptr -> request_descriptor;
	addr (dr_ptr -> driver_status.descriptor) -> request_descriptor.saved = "0"b;
						/* see if driver wants it saved */
	message_len = desc_ptr -> mseg_message_info.ms_len;
	addr (dr_ptr -> driver_status.message) -> based_message = desc_ptr -> mseg_message_info.ms_ptr -> based_message;

	desc_off = fixed (rel (desc_ptr), 18);

	if ^stac (addr (dr_ptr -> driver_status.request_pending), coord_proc_id)
	then do;					/* driver no longer wants request */
make_pending:
		desc_ptr -> request_descriptor.next_pending = dcte.pending_request;
		dcte.pending_request = desc_off;
		go to iodc_return;
	     end;

	call hcs_$wakeup (idte.process_id, dr_ptr -> driver_status.driver_chan, 0, code);
	if code ^= 0
	then do;
		call check_wakeup_code (code);
		go to make_pending;
	     end;

	mdte.current_request = desc_off;
	if mod (desc_ptr -> request_descriptor.seq_id, 10000) = 9999
	then do;
new_series:
		new_driver_series = new_driver_series + 10000;
		mdte.seq_id = new_driver_series;
		call ioa_$rsnnl ("Device ^a switched to series ^d.", out_msg, out_len, sender_device,
		     new_driver_series);
		call iodc_message_ ("100"b, 0, out_msg);
	     end;
	else mdte.seq_id = desc_ptr -> request_descriptor.seq_id;

/* all done, go home */

iodc_return:
	call ipc_$unmask_ev_calls (code);
	recursion_flag = 0;
	return;


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


/* This procedure updates a few items in the coord's
   copy of a descriptor from the driver's copy. */

update_descriptor:
     proc;

	desc_ptr -> request_descriptor.driver_data = copy_ptr -> request_descriptor.driver_data;
	desc_ptr -> request_descriptor.cancelled = copy_ptr -> request_descriptor.cancelled;
	desc_ptr -> request_descriptor.dont_delete = copy_ptr -> request_descriptor.dont_delete;
	if ^desc_ptr -> request_descriptor.saved
	then /* if still in queue we may keep it there */
	     desc_ptr -> request_descriptor.keep_in_queue = copy_ptr -> request_descriptor.keep_in_queue;
	desc_ptr -> request_descriptor.saved =
	     /* hold request if saved or deferred by driver command */ copy_ptr -> request_descriptor.saved
	     | copy_ptr -> request_descriptor.keep_in_queue;

     end update_descriptor;
%page;

sig_label (2):
	series_sw = "1"b;
	ack_chan = 0;
	seq_id = addr (ev_info.message) -> ev_msg.seq_id;
	go to restart_or_save;

sig_label (3):
	series_sw = "1"b;
	ack_chan = 0;
	seq_id = addr (ev_info.message) -> ev_msg.seq_id;


restart_or_save:					/*
   Here for "restart _n"(2) or "save _n"(3) command given to driver. For
   "restart" we will record that requests for the device class have been
   restarted, and look for the request from which to restart. For "save" we
   will simply scan through setting "saved" bit in all requests done of 
   specified series. */

	if sig_type = save
	then cmd = "Save";				/* set up for messages */
	else cmd = "Restart";

	call ioa_$rsnnl ("^a command received from device ^a", out_msg, out_len, cmd, idte.dev_id);
	call iodc_message_ ("110"b, 0, out_msg);

	series_id = divide (seq_id, 10000, 35, 0);

	do desc_off = iodc_static.first_req_done repeat desc_ptr -> request_descriptor.next_done while (desc_off ^= 0);
	     desc_ptr = ptr (iodc_static.descr_seg_ptr, desc_off);

	     if divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id
	     then /* right series? */
		if desc_ptr -> request_descriptor.seq_id >= seq_id
		then /* right request or next one in series? */
		     if desc_ptr -> request_descriptor.dev_class_index = dcx
		     then /* is it ours? */
			go to found_desc;		/* WHEW!  Now make decisions for this one */

		     else do;

/* A restart or save of a given series is logically only allowed
   to be performed by a driver of the same device class that the
   series was originally done under.  However, a driver with multiple
   minor devices has one device class for each minor device.
   Therefore, even if the minor device that actually sent the
   wakeup does not have the matching device class, we will allow
   it so long as one of the other minor devices of the same
   driver process does have the matching device class.
*/

			     if idte.last_minor > idte.first_minor
			     then /* more than one minor device */
				do mdtx = idte.first_minor to idte.last_minor;
						/* look for one with right device class */
				     mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx));
				     if mdte.active = 1
				     then if mdte.dev_class_index = desc_ptr -> request_descriptor.dev_class_index
					then do;
						sender_device = get_device_name ();
						dctep =
						     addr (iodc_static.dctp
						     -> dev_class_tab.entries (mdte.dev_class_index));
						qgtep =
						     addr (iodc_static.qgtp
						     -> q_group_tab.entries (dcte.qgte_index));
						sender_class = get_class_name ();
						go to found_desc;
					     end;
				end;

			     call ioa_$rsnnl (
				"^a rejected.  Sender device class does not match that of specified request.",
				out_msg, out_len, cmd);
			     call iodc_message_ ("110"b, 0, out_msg);
			     code = error_table_$action_not_performed;
			     call driver_ack (code, 0);
						/* tell driver */
			     go to iodc_return;
			end;

	end;

/* come here if the specified sequence id was not found and
   neither were any higher sequence ids in the same series.
*/

	call ioa_$rsnnl ("No saved requests from number ^d", out_msg, out_len, seq_id);
	call iodc_message_ ("101"b, 0, out_msg);
	code = error_table_$noentry;
	go to tell_driver;


found_desc:
	if sig_type = restart
	then /* restart only */
	     if dcte.restart_req ^= 0
	     then do;
		     call ioa_$rsnnl ("Restart already in progress for request type ^a", out_msg, out_len,
			sender_class);
		     call iodc_message_ ("101"b, 0, out_msg);
		     code = error_table_$namedup;	/* duplicate request for restart */
		     go to tell_driver;
		end;

	if desc_ptr -> request_descriptor.seq_id > seq_id
	then do;
		call ioa_$rsnnl ("Request ^d is gone.", out_msg, out_len, seq_id);
		call iodc_message_ ("001"b, 0, out_msg);
		code = error_table_$noentry;		/* for single restart error message */
		if ^series_sw
		then go to tell_driver;		/* stop now if no series */
	     end;

	code = 0;					/* we will do a restart now, tell driver OK */
	seq_id = desc_ptr -> request_descriptor.seq_id;	/* say we started at this request */

	call ioa_$rsnnl ("^a ^[from^;of^] request ^d initiated for request type ^a", out_msg, out_len, cmd, series_sw,
	     seq_id, sender_class);
	call iodc_message_ ("110"b, 0, out_msg);

	if sig_type = restart
	then /* establish restart cycle */
	     dcte.restart_req = desc_off;

/* for both restart and save, turn on "saved" indicators */

	desc_ptr -> request_descriptor.saved = "1"b;
	if series_sw
	then do;
		if sig_type = restart
		then desc_ptr -> request_descriptor.series_restart = "1"b;
						/* this triggers the sequence for next req cmd */
		do desc_off = desc_ptr -> request_descriptor.next_done
		     repeat desc_ptr -> request_descriptor.next_done while (desc_off ^= 0);
		     desc_ptr = ptr (iodc_static.descr_seg_ptr, desc_off);
		     if divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id
		     then do;
			     desc_ptr -> request_descriptor.saved = "1"b;
			     if sig_type = restart
			     then desc_ptr -> request_descriptor.series_restart = "1"b;
			end;
		end;
	     end;

/* if the series restarted or saved is in use, give driver a new series */

	do mdtx = 1 to static_mdtp -> minor_device_tab.n_minor;
						/* see if series is in use */
	     mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx));
	     if mdte.active = 1
	     then if divide (mdte.seq_id, 10000, 35, 0) = series_id
		then do;
			idtep = addr (static_idtp -> iod_device_tab.entries (mdte.major_index));
			sender_device = get_device_name ();
			call driver_ack (0, seq_id);	/* be sure driver gets OK */
			go to new_series;
		     end;
	end;

tell_driver:
	call driver_ack (code, seq_id);		/* tell what happened and which request number */
	go to iodc_return;				/* ============= */

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

driver_ack:
     proc (code, num);

	dcl     code		 fixed bin (35);
	dcl     num		 fixed bin (35);
	dcl     ec		 fixed bin (35);

	if ack_chan = 0
	then return;				/* if nothing defined, quit */

	addr (event_message) -> ack_msg.code = code;
	addr (event_message) -> ack_msg.num = num;

	call hcs_$wakeup (proc_id, ack_chan, event_message, ec);

	if ec ^= 0
	then call iodc_message_ ("101"b, code, "Unable to acknowledge driver command.");

	return;

     end driver_ack;
%page;


sig_label (4):					/* 
   This branch is taken when a driver process has received a "logout" command.
   It frees the major device assigned to the driver process. */

	call iodc_$free_device (idtep, code);
	if code = 0
	then do;
		call ioa_$rsnnl ("Driver logout for device ^a", out_msg, out_len, idte.dev_id);
		call iodc_message_ ("100"b, 0, out_msg);
	     end;
	go to iodc_return;


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


sig_label (5):					/* 
This branch is taken when the driver wants to get the event channel needed to
send commands through coord_comm.ms, which is only given to live drivers */

	event_message = driver_cmd_chan;

	call hcs_$wakeup (proc_id, dr_ptr -> driver_status.driver_chan, event_message, code);

	if code ^= 0
	then call check_wakeup_code (code);

	go to iodc_return;
%page;

free_device:
     entry (a_idtep, a_code);

/* This entry frees a major device for subsequent use by  another driver. */
/* The process id assigned to the device is zeroed, and each minor device is marked inactive */
/* The major device directory and all contained driver status segments are deleted. */
/* If an unfinished request is found for a minor device, that request is
   made pending for the associated device class and marked as "continued". */

	dcl     a_idtep		 ptr;		/* device table entry ptr */
	dcl     a_code		 fixed bin (35);


	idtep = a_idtep;

/* loop thru minor devices making each inactive */

	do mdtx = idte.first_minor to idte.last_minor;
	     mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx));
	     if idte.process_id ^= ""b
	     then if mdte.active = 1
		then if mdte.current_request ^= 0
		     then do;			/* could be an unfinished request */
			     dctep = addr (iodc_static.dctp -> dev_class_tab.entries (mdte.dev_class_index));
			     desc_ptr = ptr (iodc_static.descr_seg_ptr, mdte.current_request);
			     copy_ptr = addr (mdte.driver_ptr -> driver_status.descriptor);
			     call update_descriptor;
			     if copy_ptr -> request_descriptor.finished | copy_ptr -> request_descriptor.cancelled
			     then /* consider it done */
				call save_request_ (desc_ptr, dctep);

			     else do;		/* not finished, make request pending */
				     desc_ptr -> request_descriptor.next_pending = dcte.pending_request;
				     dcte.pending_request = fixed (rel (desc_ptr), 18);
				     desc_ptr -> request_descriptor.continued = "1"b;
						/* this request is not brand new */
				     desc_ptr -> request_descriptor.contd_seq_id =
					desc_ptr -> request_descriptor.seq_id;
				end;

			     mdte.current_request = 0;
			end;

	     mdte.active = 0;
	end;

	idte.lock, idte.process_id = ""b;

	call delete_$path (sysdir, idte.dev_id, "101101"b, "", code);
						/* delete major device dir */
	if code ^= 0
	then if code ^= error_table_$noentry
	     then do;
		     call ioa_$rsnnl ("Deleting ^a>^a.  Cannot free device.", out_msg, out_len, sysdir, idte.dev_id);
		     call iodc_message_ ("101"b, code, out_msg);
		end;
	     else code = 0;

	a_code = code;

	return;
%page;

new_driver:
     entry (a_ptr);

/* This entry gets a wakeup from a driver that's just come up. We
   *  must allocate a structure for it and alert it that we're ready for it
   *  to operate.
*/

	entry_type = new_driver;
	go to read_comm_msg;


driver_command:
     entry (a_ptr);

/* this entry uses some similar code to the new driver entry, but is used by a driver to signal commands
   which need more space than an event message can provide */

	entry_type = driver_command;

read_comm_msg:
	ack_chan = 0;				/* define this as not known for now */
	mask_code = -1;
	on cleanup
	     begin;
		call driver_ack (error_table_$action_not_performed, 0);
						/* break driver loose */
		if mask_code = 0
		then call ipc_$unmask_ev_calls (code2);
	     end;
	call ipc_$mask_ev_calls (mask_code);
	err_label = iodc_return;
	ev_info_ptr = a_ptr;
	proc_id = ev_info.sending_proc;

/* The event message for the new driver wakeup should contain a message id. */
/* The message id  identifies a message placed in coord_comm.ms by the driver */

	ms_id = unspec (ev_info.message);
	unspec (driver_mmi) = ""b;
	driver_mmi.version = MSEG_MESSAGE_INFO_V1;
	driver_mmi.ms_id = ms_id;
	driver_mmi.message_code = MSEG_READ_SPECIFIED;
	call message_segment_$read_message_index (comm_mseg_idx, areap, addr (driver_mmi), code);
	if code ^= 0
	then do;
		call iodc_message_ ("101"b, code, "Attempting to read driver message from coord_comm.ms");
		go to iodc_return;
	     end;
	call message_segment_$delete_index (comm_mseg_idx, ms_id, code);
						/* delete the message */
	if code ^= 0
	then call iodc_message_ ("101"b, code, "Deleting coord_comm.ms driver message");

	if entry_type = new_driver
	then go to make_new_driver;

/* otherwise, this is a driver command .. so get set up for it */
%page;

	comm_ptr = driver_mmi.ms_ptr;			/* set pointer to message for easy reference */
	ack_chan = iodd_comm.ack_chan;		/* this is how we tell what happened */
	err_label = abort_driver_cmd;			/* be sure we jolt driver on errors */
	mdtx = iodd_comm.minor_idx;			/* see who the driver says he is */

	call identify_sender (code);
	if code ^= 0
	then do;
bad_req:
		call driver_ack (code, 0);		/* don't let the driver hang */
		go to iodc_return;
	     end;

	sig_type = iodd_comm.type;			/* this is the command code */

	if sig_type = save | sig_type = restart
	then do;					/* for save and restart commands */
		seq_id = iodd_comm.request_no;
		if iodd_comm.type_ext = ""b
		then series_sw = ""b;
		else series_sw = "1"b;
		go to restart_or_save;		/* join the main part */
	     end;

	if sig_type = restart_q
	then go to restart_queue;			/* for restart_q command */

	if sig_type = next_req
	then go to next_request;

	code = error_table_$request_not_recognized;
	go to bad_req;


abort_driver_cmd:
	call driver_ack (error_table_$action_not_performed, 0);
	go to iodc_return;
%page;

make_new_driver:
	new_driver_id = driver_mmi.sender_id;		/* get person/project name of new driver */
	i = length (rtrim (new_driver_id));		/* locate tag portion of group id */
	substr (new_driver_id, i) = "*";		/* any tag is ok */
	auth = driver_mmi.sender_authorization;		/* get authorization of new driver */
	new_driver_msg_p = driver_mmi.ms_ptr;
	chan_name = new_driver_msg.wakeup_chan;		/* pick up channel on which to wakeup driver */

/* find out what device class the new driver wants */
/* make sure the driver's authorization is right for the device class */

	dcx = new_driver_msg.dev_class_index;		/* get index of desired device class */
	if dcx < 1 | dcx > iodc_static.dctp -> dev_class_tab.n_classes
						/* bad index */
	then do;
		code = 1;
		call ioa_$rsnnl ("New driver rejected: ^a (bad device class index)", out_msg, out_len, new_driver_id);

bad_new_driver:
		call iodc_message_ ("100"b, 0, out_msg);
		go to wake_driver;
	     end;

	dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx));
						/* get dev class table entry ptr */

	qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index));
						/* get q group tab entry ptr */

	sender_class = get_class_name ();		/* get device class name */

	if ^aim_check_$greater_or_equal (auth, dcte.max_access)
	then do;					/* insufficient authorization */
		code = 2;
		call ioa_$rsnnl ("New driver rejected: ^a (wrong authorization for device class ^a)", out_msg,
		     out_len, new_driver_id, sender_class);
		go to bad_new_driver;
	     end;

/* make sure driver's userid is right for queue group */

	if qgte.driver_id ^= new_driver_id
	then do;					/* wrong userid */
		code = 3;
		call ioa_$rsnnl ("New driver rejected: ^a (invalid userid for ^a queue group)", out_msg, out_len,
		     new_driver_id, qgte.name);
		go to bad_new_driver;
	     end;

/* now find out which device the new driver wants */
/* make sure that its valid for the device class and that its not already in use */

	mdtx = new_driver_msg.device_index;
	if mdtx < 1 | mdtx > static_mdtp -> minor_device_tab.n_minor
						/* bad index */
	then do;
		code = 4;
		call ioa_$rsnnl ("New driver rejected: ^a (bad minor device index)", out_msg, out_len, new_driver_id);
		go to bad_new_driver;
	     end;

	mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx));
	idtx = mdte.major_index;			/* get major device index */
	idtep = addr (static_idtp -> iod_device_tab.entries (idtx));
	sender_device = get_device_name ();		/* pick up major device name */

	if ^substr (dcte.device_list, mdtx, 1)
	then do;					/* device not valid for this class */
		code = 5;
		call ioa_$rsnnl ("New driver rejected: ^a (device ^a invalid for device class ^a)", out_msg, out_len,
		     new_driver_id, sender_device, sender_class);
		go to bad_new_driver;
	     end;

	if idte.process_id ^= ""b
	then /* major device is already assigned */
	     if idte.process_id ^= proc_id
	     then do;				/* but not to this process */
		     call set_lock_$lock (idte.lock, 0, code);
						/* see if lock is still valid */
		     if code = 0 | code = error_table_$invalid_lock_reset
		     then do;			/* bad lock so free the device */
			     call iodc_$free_device (idtep, code);
			     if code ^= 0
			     then do;
				     code = 10;
				     go to wake_driver;
				end;
			end;
		     else do;			/* lock was good, can't give new driver this device */
			     code = 6;
			     call ioa_$rsnnl ("New driver rejected: ^a (device ^a assigned to other process)",
				out_msg, out_len, new_driver_id, idte.dev_id);
			     go to bad_new_driver;
			end;
		end;
	     else if mdte.active ^= 0
	     then do;				/* we already gave him this one */
		     code = 7;
		     call ioa_$rsnnl ("New driver rejected: ^a (device ^a already active)", out_msg, out_len,
			new_driver_id, sender_device);
		     go to bad_new_driver;
		end;

/* if the message segment queues have not yet been opened for this group, then open them */

	if qgte.open = 0
	then /* queues have not been opened */
	     do q = 1 to qgte.max_queues;		/* open them */
		qgte.last_read (q) = "0"b;
		call ioa_$rsnnl ("^a_^d.ms", q_name, out_len, qgte.name, q);
		call message_segment_$open (sysdir, q_name, q_idx, code);

		if code ^= 0
		then do;
			if code = error_table_$noentry
			then call ioa_$rsnnl ("Queue ^d for request type ^a missing.", out_msg, out_len, q, dcte.id)
				;
			else call ioa_$rsnnl ("Could not open ^a>^a", out_msg, out_len, sysdir, q_name);
			call iodc_message_ ("101"b, code, out_msg);
			code = 8;
			go to wake_driver;
		     end;

		call message_segment_$check_salv_bit_index (q_idx, "1"b, unbit, code);
		if unbit
		then do;
			call ioa_$rsnnl ("Message segment ^a was salvaged. Some requests may have been lost.",
			     out_msg, out_len, q_name);
			call iodc_message_ ("110"b, 0, out_msg);
		     end;

		qgte.mseg_index (q) = q_idx;		/* save the message segment index */
	     end;

/* If the major device was not previously assigned, we must  create */
/* a directory to hold all driver status segments for the major device. */
/* This directory will be upgraded (if necessary) to the authorization of the new driver. */
/* If upgraded, a quota of 2 records per minor device will be assigned. 
The dir_quota will be a min of 5, or 1/6 page per segment. */

	if idte.process_id = ""b
	then do;					/* device not previously assigned */
		quota = 2 * (idte.last_minor - idte.first_minor + 1);
						/* 2 records per minor device */
		dir_quota = max (5, divide (idte.last_minor - idte.first_minor + 1, 6, 17));
		call make_dir (idte.dev_id, auth, quota, dir_quota, code);
		if code ^= 0
		then do;				/* failed to create dir */
			call ioa_$rsnnl ("Cannot create directory for device ^a", out_msg, out_len, idte.dev_id);
			call iodc_message_ ("101"b, code, out_msg);
						/* tell the operator */
			code = 9;
			go to wake_driver;
		     end;
	     end;

/* now we're ready to set up driver status segment */

	subdir = sysdir;
	substr (subdir, sysdir_len + 1, 1) = ">";
	substr (subdir, sysdir_len + 2) = idte.dev_id;	/* construct dir name */
	acl (n_acl).ac_name = new_driver_id;		/* put driver on the acl of driver status seg */
	call make (subdir, mdte.dev_id, dr_ptr, code);

	if code ^= 0
	then do;
		call ioa_$rsnnl ("Cannot create driver status segment for device ^a", out_msg, out_len, sender_device)
		     ;
		call iodc_message_ ("101"b, code, out_msg);
		code = 10;
		go to wake_driver;
	     end;

/* set up driver status segment contents */

	unspec (dr_ptr -> driver_status) = "0"b;
	dr_ptr -> driver_status.req_type_label = sender_class;
	dr_ptr -> driver_status.dev_name_label = sender_device;
	dr_ptr -> driver_status.device_id = mdte.dev_id;
	dr_ptr -> driver_status.device_class_id = dcte.id;
	dr_ptr -> driver_status.coord_chan = driver_sig_chan;
	dr_ptr -> driver_status.request_pending = "0"b;
	dr_ptr -> driver_status.dev_index = mdtx;
	dr_ptr -> driver_status.maj_index = idtx;
	dr_ptr -> driver_status.dev_class_index = dcx;
	dr_ptr -> driver_status.minor_args = mdte.args;
	dr_ptr -> driver_status.min_banner = dcte.min_banner;

	dr_ptr -> driver_status.rqti_ptr = null;
	dr_ptr -> driver_status.dev_out_iocbp = null;
	dr_ptr -> driver_status.dev_in_iocbp = null;
	dr_ptr -> driver_status.dev_out_stream = "";
	dr_ptr -> driver_status.dev_in_stream = "";
	dr_ptr -> driver_status.forms_validation_ptr = null;
	dr_ptr -> driver_status.dev_ptr1 = null;
	dr_ptr -> driver_status.dev_ctl_ptr = null;

/* modify coordinator data bases to reflect new driver */

	qgte.open = 1;
	idte.lock = new_driver_msg.lock_id;
	idte.process_id = proc_id;
	mdte.dev_class_index = dcx;
	mdte.active = 1;
	mdte.driver_ptr = dr_ptr;
	mdte.current_request = 0;
	new_driver_series = new_driver_series + 10000;
	mdte.seq_id = new_driver_series;

	call ioa_$rsnnl ("New driver for device ^a, request type ^a (series = ^d)", out_msg, out_len, sender_device,
	     sender_class, new_driver_series);
	;
	call iodc_message_ ("100"b, 0, out_msg);


wake_driver:					/* tell the guy all about it */
	event_message = 0;
	addr (event_message) -> ev_msg.code = code;

	call hcs_$wakeup (proc_id, chan_name, event_message, code);
	if code ^= 0
	then call check_wakeup_code (code);
	go to iodc_return;
%page;

restart_queue:					/* 
go back to the head of the queues for this driver, flush any normal waiting
requests from the wait list, but leave all priority requests */

	wlp = iodc_static.wait_list_ptr;
	qgte.last_read (*) = ""b;			/* next time read the first message */

	do dcx = qgte.first_dev_class to qgte.last_dev_class;
	     dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx));
	     do q = 1 to 4;				/* look at all possible queues */
		nx = dcte.first_waiting (q);		/* get first waiting list index for this queue */
		if nx ^= 0
		then do;				/* do we need to check? */
			lwx, fwx = 0;		/* get ready to re-thread the list */
			do x = nx repeat nx while (nx ^= 0);
			     nx = wlp -> waiting_list.next (x);
						/* advance the forward thread */
			     if wlp -> waiting_list.state (x) = priority
			     then do;
				     if fwx = 0
				     then fwx = x;
				     else wlp -> waiting_list.next (lwx) = x;
						/* add to tail of list */
				     lwx = x;	/* advance the tail marker */
				     wlp -> waiting_list.next (x) = 0;
						/* mark this as the end */
				end;
			     else do;		/* this is a normal entry, drop it */
				     if x = wlp -> waiting_list.last_used
				     then do;	/* drop the high water mark */
					     wlp -> waiting_list.next (x) = 0;
					     wlp -> waiting_list.last_used = wlp -> waiting_list.last_used - 1;
					end;
				     else do;	/* add to the free list */
					     wlp -> waiting_list.next (x) = wlp -> waiting_list.first_free;
					     wlp -> waiting_list.first_free = x;
					end;
				     wlp -> waiting_list.state (x) = 0;
						/* clear any garbage */
				     wlp -> waiting_list.ms_id (x) = ""b;
				     wlp -> waiting_list.orig_q (x) = 0;
				     dcte.n_waiting = dcte.n_waiting - 1;
						/* reduce the count */
				end;
			end;
			dcte.first_waiting (q) = fwx;
			dcte.last_waiting (q) = lwx;
		     end;
	     end;
	end;

	call driver_ack (0, 0);
	go to iodc_return;
%page;

next_request:					/* 
   Here a driver has requested the coord to make a certain request high priority.
   This is done by searching the driver's queues for a request which matches given parameters.
   Then the message_id and queue number data are threaded into the drivers queue 1 waiting
   list, behind any other priority requests */

	if iodd_comm.queue_no = 0
	then do;					/* do we look in each possible queue? */
		start = 1;
		finish = qgte.max_queues;
	     end;
	else start, finish = iodd_comm.queue_no;	/* just look in the given queue */

	if start < 1 | finish > qgte.max_queues
	then do;					/* bad to start with */
		code = error_table_$action_not_performed;
		go to bad_req;
	     end;

	user_id = iodd_comm.user_id;
	string (option) = iodd_comm.type_ext;

	if option.et
	then do;					/* use this as precedence */
		option.pn = ""b;			/* in case both were set */
		match_dir = "";
		match_ent = iodd_comm.data;		/* get the entry name we will look for */
	     end;
	else if option.pn
	then do;
		call expand_pathname_ (iodd_comm.data, match_dir, match_ent, code);
		if code ^= 0
		then go to bad_req;
	     end;
	else do;
		match_dir, match_ent = "";		/* clear the names */
		if ^option.id
		then do;
			code = error_table_$action_not_performed;
			go to bad_req;
		     end;
	     end;

/*	now look for a request matching user, segment and/or request_id */

	code = 0;					/* clear, then watch for aim errors */

	do q = start to finish;
	     q_idx = qgte.mseg_index (q);		/* get the message segment index for reading */
	     ms_id = ""b;				/* start at the begining of the queue */

	     retry = 0;
retry1:
	     unspec (msg_mmi) = ""b;
	     msg_mmi.version = MSEG_MESSAGE_INFO_V1;
	     msg_mmi.message_code = MSEG_READ_FIRST;
	     call message_segment_$read_message_index (q_idx, areap, addr (msg_mmi), code2);
	     if code2 ^= 0
	     then /* normal test should be cheap */
		if code2 = error_table_$bad_segment	/* message seg was salvaged */
		then if retry = 0
		     then do;			/* try once more */
			     retry = 1;
			     go to retry1;
			end;

	     do while (code2 = 0);
		ms_id = msg_mmi.ms_id;		/* record the last message read */
		reqp = msg_mmi.ms_ptr;		/* get pointer to request */

		sender_id = msg_mmi.sender_id;	/* see who put it there */
		len = length (rtrim (sender_id));	/* get its size */
		sender_id = substr (sender_id, 1, len - 2);
						/* strip off the tag */

		if sender_id ^= user_id
		then go to next_msg;		/* user didn't match, skip the request */


		if option.et
		then if match_ent ^= reqp -> queue_msg_hdr.ename
		     then go to next_msg;

		if option.pn
		then do;
			if match_ent ^= reqp -> queue_msg_hdr.ename
			then go to next_msg;
			if match_dir ^= reqp -> queue_msg_hdr.dirname
			then go to next_msg;
		     end;

		if option.id
		then if ^match_request_id_ (reqp -> queue_msg_hdr.msg_time, iodd_comm.req_id)
		     then go to next_msg;

/*	We have a matching request, see if the driver can run it */

		auth = msg_mmi.sender_authorization;

		if ^aim_check_$greater_or_equal (auth, dcte.min_access)
		then /* below minimum? */
		     code = error_table_$ai_restricted;
		else if aim_check_$greater_or_equal (dcte.max_access, auth)
		then do;				/* not above max */
			reqp -> queue_msg_hdr.state = STATE_ELIGIBLE;
			retry = 0;
retry3:
			call message_segment_$update_message_index (q_idx, msg_mmi.ms_len, ms_id, reqp, code2);
			if code2 ^= 0
			then do;			/* normal test should be cheap */
				if code2 = error_table_$bad_segment
						/* message seg was salvaged */
				then if retry = 0
				     then do;	/* try once more */
					     retry = 1;
					     go to retry3;
					end;

				go to next_msg;
			     end;
			go to found_next_request;	/* OK, put it into the waiting list */
		     end;
		else code = error_table_$ai_above_allowed_max;

/*		if driver can't see the request, pretend we didn't see it either */

next_msg:
		free reqp -> queue_msg_hdr in (sys_area);
						/* free the old request */
		retry = 0;
retry2:
		unspec (msg_mmi) = ""b;
		msg_mmi.version = MSEG_MESSAGE_INFO_V1;
		msg_mmi.ms_id = ms_id;
		msg_mmi.message_code = MSEG_READ_AFTER_SPECIFIED;
		call message_segment_$read_message_index (q_idx, areap, addr (msg_mmi), code2);
		if code2 ^= 0
		then /* normal test should be cheap */
		     if code2 = error_table_$bad_segment/* message seg was salvaged */
		     then if retry = 0
			then do;			/* try once more */
				retry = 1;
				go to retry2;
			     end;
	     end;
	end;

/* No matching request was found or it was out of aim range */

	if code = 0
	then code = error_table_$noentry;
	go to bad_req;

found_next_request:
	free reqp -> queue_msg_hdr in (sys_area);	/* we are done with the text for now */

/* 	thread the request info into the waiting list */

	wlp = iodc_static.wait_list_ptr;

	if wlp -> waiting_list.first_free > 0
	then do;
		new_idx = wlp -> waiting_list.first_free;
						/* pick off a free entry */
		wlp -> waiting_list.first_free = wlp -> waiting_list.next (new_idx);
						/* move the list back */
	     end;
	else do;					/* list is full, extend it */
		if wlp -> waiting_list.last_used = max_wl_size
		then do;
			call iodc_message_ ("101"b, 0, "Waiting_list full.");
			code = error_table_$action_not_performed;
			go to bad_req;
		     end;
		new_idx = wlp -> waiting_list.last_used + 1;
						/* allocate the next entry */
		wlp -> waiting_list.last_used = new_idx;/* record the usage */
	     end;

	wlp -> waiting_list.next (new_idx) = 0;		/* fill in the new entry */
	wlp -> waiting_list.state (new_idx) = priority;
	wlp -> waiting_list.ms_id (new_idx) = ms_id;
	wlp -> waiting_list.orig_q (new_idx) = q;

	nx = dcte.first_waiting (1);			/* find queue 1 waiting list */
	if nx > 0
	then do;					/* is there a real list? */
		lwx = 0;				/* last good entry not found yet */
		do x = nx repeat nx while (nx ^= 0);
		     nx = wlp -> waiting_list.next (x); /* offset of next in the chain */
		     if wlp -> waiting_list.state (x) ^= priority
		     then do;			/* found last of the priority entries */
			     nx = 0;		/* stop the loop */
			     wlp -> waiting_list.next (new_idx) = x;
						/* put new one in front */
			     if lwx = 0
			     then dcte.first_waiting (1) = new_idx;
						/* if this was the first one */
			     else wlp -> waiting_list.next (lwx) = new_idx;
						/* link the last one to the new one */
			end;
		     else if nx = 0
		     then do;			/* last entry was also priority */
			     wlp -> waiting_list.next (x) = new_idx;
						/* put this on the end */
			     dcte.last_waiting (1) = new_idx;
						/* update the last pointer for chaining to end */
			end;
		     lwx = x;			/* save the last index of skipped request */
		end;
	     end;
	else dcte.first_waiting (1), dcte.last_waiting (1) = new_idx;
						/* no list, so start one */

	dcte.n_waiting = dcte.n_waiting + 1;

	call driver_ack (0, 0);			/* tell driver we found it */
	go to iodc_return;
%page;

proc_dies:					/* Come here for new process after disaster */
	call ioa_$rsnnl ("^a^/New coordinator process will be created. All device drivers will be reinitialized.",
	     out_msg, out_len, out_msg);
	call iodc_message_$loud ("001"b, code, out_msg);

/* put machine conditions if any in log */

	if scu_msg ^= ""
	then call iodc_message_ ("100"b, code, scu_msg);
	call new_proc;
%page;

quit_handler:
     proc;

/* Entered when coordinator receives QUIT.
*/

	dcl     mask_code		 fixed bin (35);

	if quit_flag
	then if ^testing
	     then do;				/* don't stack quits */
		     call com_err_ (0, "io_coordinator", "QUIT already pending.");
		     return;
		end;

	mask_code = -1;
	on cleanup
	     begin;
		if mask_code = 0
		then call ipc_$unmask_ev_calls (code2);
	     end;
	call ipc_$mask_ev_calls (mask_code);

	quit_flag = "1"b;
	call ioa_ ("QUIT received.");
	call iox_$control (iox_$user_input, "resetread", null (), code);

	call iodc_$command_level;

	quit_flag = "0"b;
	call ipc_$unmask_ev_calls (code2);
	call iox_$control (iox_$user_io, "start", null, code);
	return;

     end quit_handler;
%page;

command_level:
     entry;

/* This is the IO Coordinator command processor.  It is
   called by the quit handler and also by the unclaimed
   signal handler when in test mode.
*/

	com_level = com_level + 1;
	mask_code = -1;

	on cleanup
	     begin;
		com_level = com_level - 1;
		if mask_code = 0
		then call ipc_$unmask_ev_calls (code2);
	     end;

	if com_level > 0
	then /* don't ask for a command just after initialization */
ask:
	     call ioa_ ("Enter command.^[ (level ^d)^;^s^]", (com_level > 1), com_level);

	if mask_code = 0
	then do;
		call ipc_$unmask_ev_calls (code2);
		mask_code = -1;
	     end;

	line = "";
	call iox_$get_line (iox_$user_input, addr (line), length (line), nc, code);
	line = ltrim (rtrim (line, NL || " "));		/* trim spaces and NL chars */
	cmd = before (line, " ");			/* command is the first part */
	if cmd = "" | cmd = "."
	then go to ask;

	call ipc_$mask_ev_calls (mask_code);

	if cmd = "help"
	then do;					/* HELP COMMAND */
		call ioa_ ("list, logout, print_devices, restart_status, start, term, wait_status");
		if testing
		then call ioa_ ("**Test: debug, probe, driver, pi, return");
		go to ask;
	     end;

	if cmd = "start"				/* START COMMAND */
	then if com_level > 0
	     then do;
		     com_level = com_level - 1;
		     if mask_code = 0
		     then call ipc_$unmask_ev_calls (code2);
		     return;
		end;
	     else do;
		     call com_err_ (0, "io_coordinator", "Coordinator already started.");
		     go to ask;
		end;

	if cmd = "return"
	then /* RETURN COMMAND */
	     if testing
	     then go to return_label;
	     else go to bad_cmd;

	if cmd = "debug"				/* DEBUG COMMAND */
	then if testing
	     then do;
		     call debug;
		     go to ask;
		end;

	if cmd = "probe" | cmd = "pb"			/* PROBE COMMAND */
	then if testing
	     then do;
		     call probe;
		     go to ask;
		end;

	if cmd = "pi"				/* PI COMMAND */
	then if testing
	     then do;
		     call signal_ ("program_interrupt");
		     go to ask;
		end;

	if cmd = "logout"				/* LOGOUT COMMAND */
	then if testing
	     then go to return_label;
	     else call logout;

	if ^initialized
	then go to bad_cmd;				/* other commands only valid after initialization */

	if cmd = "print_devices"
	then do;					/* PRINT_DEVICES COMMAND */
		call print_devices ("-dir", sysdir);
		go to ask;
	     end;

	if cmd = "list"
	then do;					/* LIST COMMAND */
		i = 0;
		do idtx = 1 to static_idtp -> iod_device_tab.n_devices;
		     idtep = addr (static_idtp -> iod_device_tab.entries (idtx));
		     if idte.process_id ^= ""b
		     then do mdtx = idte.first_minor to idte.last_minor;
			     mdtep = addr (static_mdtp -> minor_device_tab.entries (mdtx));
			     if mdte.active = 1
			     then do;
				     dctep =
					addr (iodc_static.dctp -> dev_class_tab.entries (mdte.dev_class_index));
				     qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index));
				     sender_device = get_device_name ();
				     sender_class = get_class_name ();
				     call ioa_ ("device ^a is active, request type ^a, request ^d", sender_device,
					sender_class, mdte.seq_id);
				     i = i + 1;
				end;
			end;
		end;
		if i = 0
		then call ioa_ ("No active devices");
		go to ask;
	     end;

	if cmd = "restart_status"			/* RESTART_STATUS COMMAND */
	then do;
		nseries = divide (new_driver_series, 10000, 35, 0);
		if nseries = 0
		then go to no_restartable;

		allocate series_info in (sys_area);
		series_info (*).count = 0;

		desc_off = iodc_static.first_req_done;
		do while (desc_off ^= 0);		/* scan the saved list */
		     desc_ptr = ptr (iodc_static.descr_seg_ptr, desc_off);
		     series_id = divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0);

		     if series_info (series_id).count = 0
		     then do;			/* first request of this series */
			     series_info (series_id).first = desc_ptr -> request_descriptor.seq_id;
			     series_info (series_id).dcx = desc_ptr -> request_descriptor.dev_class_index;
			end;
		     series_info (series_id).last = desc_ptr -> request_descriptor.seq_id;
		     series_info (series_id).count = series_info (series_id).count + 1;

		     desc_off = desc_ptr -> request_descriptor.next_done;
		end;

		i = 0;
		do series_id = 1 to nseries;		/* now let's see what we found */
		     if series_info (series_id).count > 0
		     then do;
			     dctep = addr (iodc_static.dctp -> dev_class_tab.entries (series_info (series_id).dcx));
			     qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index));
			     sender_class = get_class_name ();
						/* get type/class name for series */

			     call ioa_ ("^d restartable request(s) from ^d to ^d (^a)",
				series_info (series_id).count, series_info (series_id).first,
				series_info (series_id).last, sender_class);

			     if dcte.restart_req ^= 0
			     then do;		/* restart in progress for device class */
				     desc_ptr = ptr (iodc_static.descr_seg_ptr, dcte.restart_req);
				     if divide (desc_ptr -> request_descriptor.seq_id, 10000, 35, 0) = series_id
				     then call ioa_ ("   restart in progress at request ^d",
					     desc_ptr -> request_descriptor.seq_id);
				end;

			     i = i + 1;		/* count number of series */
			end;
		end;

		free series_info in (sys_area);

		if i = 0
		then
no_restartable:
		     call ioa_ ("No restartable requests.");

		go to ask;
	     end;

	if cmd = "wait_status" | /* WAIT_STATUS COMMAND */ cmd = "defer_status"
	then do;					/* old command name */
		i = 0;
		do q = 1 to iodc_static.qgtp -> q_group_tab.n_q_groups;
		     qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (q));
		     if qgte.open = 1
		     then do dcx = qgte.first_dev_class to qgte.last_dev_class;
			     dctep = addr (iodc_static.dctp -> dev_class_tab.entries (dcx));
			     if dcte.n_waiting ^= 0
			     then do;
				     sender_class = get_class_name ();
				     call ioa_ ("^d request(s) waiting for device class ^a", dcte.n_waiting,
					sender_class);
				     i = i + 1;
				end;
			end;
		end;
		if i = 0
		then call ioa_ ("No waiting requests");
		go to ask;
	     end;

	if cmd = "term"				/* TERM COMMAND */
	then if com_level > 0
	     then go to not_after_quit;
	     else do;

/* operator asked to terminate driver */

		     dev_id = ltrim (substr (line, 5));
		     if dev_id = ""
		     then do;
			     call ioa_ ("Name of major device missing: term <devid>");
			     go to ask;
			end;

		     do idtx = 1 to static_idtp -> iod_device_tab.n_devices;
			idtep = addr (static_idtp -> iod_device_tab.entries (idtx));
			if idte.dev_id = dev_id
			then do;
				call iodc_$free_device (idtep, code);
				go to ask;
			     end;
		     end;
		     call com_err_ (0, "io_coordinator", "Unrecognized device name: ^a", dev_id);

		     go to ask;
		end;

	if cmd = "driver"
	then /* DRIVER COMMAND */
	     if testing
	     then if com_level > 0
		then go to not_after_quit;
		else do;
			if mask_code = 0
			then do;
				call ipc_$unmask_ev_calls (code2);
				mask_code = -1;
			     end;
			call iodd_$iodd_init (sysdir, "1"b);
			go to ask;
		     end;

bad_cmd:
	call com_err_ (0, "io_coordinator", "Invalid response -- ^a", line);
	go to ask;


not_after_quit:
	if testing
	then call com_err_ (0, id, "Specified command can only be used at command level 0:  ^a", cmd);
	else call com_err_ (0, id, "Specified command cannot be used after a QUIT:  ^a", cmd);

	go to ask;
%page;

area_handler:
     proc;

/* Handler for area condition when allocating a descriptor.
   *  If it happens once, free a descriptor and try again. If
   *  it still fails, area is screwed up, and we're in trouble.
*/

	if area_flag ^= 0
	then do;
		out_msg = "Multiple area condition in request descriptor segment.";
		go to proc_dies;			/* blow */
	     end;

	area_flag = 1;				/* watch for recursion */
	call free_oldest_request_$force;		/* do our best to get some space */
	return;

     end;
%page;

check_wakeup_code:
     proc (wcode);

/* Another little internal procedure, this one to check the return code from hcs_$wakeup */

	dcl     wcode		 fixed bin (35);
	dcl     wp		 ptr;
	dcl     code		 fixed bin (35);

	dcl     1 two		 based aligned,
		2 word1		 fixed bin,
		2 word2		 fixed bin;


	if wcode = 2
	then call ioa_$rsnnl ("Invalid arguments to hcs_$wakeup.", out_msg, out_len);

	else if wcode = 1 | wcode = 3
	then do;
		call ioa_$rsnnl ("Driver for device ^a is gone.", out_msg, out_len, idte.dev_id);
		call iodc_$free_device (idtep, code);	/* driver is gone, free device */
	     end;

	else do;
		wp = addr (dr_ptr -> driver_status.driver_chan);
		call ioa_$rsnnl ("^w ^w", out_msg, out_len, wp -> two.word1, wp -> two.word2);
	     end;

	if wcode < 4
	then wcode = 0;
	call iodc_message_$loud ("101"b, wcode, out_msg);

	return;

     end;
%page;

iodc_handler:
     proc;

/* Unclaimed signal handler for I/O Coordinator */

	dcl     conname		 char (32);
	dcl     ec		 fixed bin (35);

	dcl     ap		 ptr;
	dcl     mp		 ptr;

	dcl     m_len		 fixed bin;

	dcl     cond_mess		 char (m_len) based (mp);

	dcl     find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	dcl     continue_to_signal_	 entry (fixed bin (35));
	dcl     condition_interpreter_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*), ptr, ptr);
	dcl     ioa_$ioa_stream_nnl	 entry options (variable);

	dcl     w			 (8) fixed bin based (scup);
						/* for storing scu data on recursion */

	dcl     1 local_condition_info aligned like condition_info;

	local_condition_info.version = condition_info_version_1;
						/* version of condition_info structure */
	call find_condition_info_ (null, addr (local_condition_info), ec);
	conname = local_condition_info.condition_name;

	if conname = "command_question"
	then return;
	if conname = "command_error"
	then return;

	if conname = "cput"
	then do;
pass_on:
		call continue_to_signal_ (ec);
		return;
	     end;
	if conname = "alrm"
	then go to pass_on;
	if conname = "finish"
	then go to pass_on;
	if testing
	then if conname = "program_interrupt"
	     then go to pass_on;
	     else if conname = "mme2"
	     then go to pass_on;

	call get_system_free_area_ (ap);
	call condition_interpreter_ (ap, mp, m_len, 3, local_condition_info.mc_ptr, conname,
	     local_condition_info.wc_ptr, local_condition_info.info_ptr);

/* now we've got message to send to err_output and log */

	if m_len > 0
	then do;
		call ioa_$ioa_stream_nnl ("error_output", "io_coordinator: ");
		call iodc_message_ ("101"b, 0, cond_mess);
	     end;

	if testing
	then do;
		call iodc_$command_level;		/* give tester a chance to do something */
		return;
	     end;


	if recursion_flag ^= 0
	then do;					/* Bad news indeed */
		call ioa_$rsnnl ("Condition ^a signalled while handling unclaimed signal.", out_msg, out_len, conname)
		     ;

/* try to save scu data so we can check what happened some day */

		if local_condition_info.mc_ptr ^= null
		then do;
			scup = addr (local_condition_info.mc_ptr -> mc.scu);
			code = local_condition_info.mc_ptr -> mc.errcode;
			call ioa_$rsnnl ("^/scu: ^w ^w ^w ^w^/^5x^w ^w ^w ^w", scu_msg, out_len, w (1), w (2),
			     w (3), w (4), w (5), w (6), w (7), w (8));
		     end;

		else do;
			code = 0;
			scu_msg = "";
		     end;

		go to proc_dies;
	     end;

	recursion_flag = 1;
	go to err_label;

     end;
%page;
%include condition_info;
%page;
%include create_branch_info;
%page;
%include device_class;
%page;
%include driver_status;
%page;
%include iod_device_tab;
%page;
%include iod_event_message;
%page;
%include iod_tables_hdr;
%page;
%include iodc_data;
%page;
%include iodc_static;
%page;
%include iodc_wait_list;
%page;
%include iodd_comm;
%page;
%include mc;
%page;
%include mseg_message_info;
%page;
%include new_driver_msg;
%page;
%include q_group_tab;
%page;
%include queue_msg_hdr;
%page;
%include request_descriptor;

     end iodc_;




		    iodc_message_.pl1               11/15/82  1834.0rew 11/15/82  1507.1       34587



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


iodc_message_: proc (a_severity, err_code, message);

/* Procedure for writing error and other messages for the I/O coordinator, both
   *  on the log and to "users" (i.e. on error_output and user_output).
*/

/* Coded August 1973 by Robert S. Coren */
/* Modified by J. Stern, 2/10/75 to combine with iod_set_streams_ */
/* Modified by J. Stern, 12/4/75 to eliminate log output except through mrd_ */

dcl  a_severity bit (3) aligned;			/* bit 0 = log, bit 1 = user_output, bit 2 = error_output */
dcl  err_code fixed bin (35);
dcl  message char (*);

dcl  severity bit (3) aligned;
dcl  short char (8) aligned;
dcl  long char (100) aligned;
dcl  out_msg char (300) aligned;
dcl  out_len fixed bin;
dcl  time_string char (16) aligned;
dcl  bells char (10) int static init ((10)"");		/* BEL (007) chars */
dcl  stars char (30) int static init ((30)"*");

dcl  bell_out char (10);
dcl (star1, star2) char (31);
dcl  nl char (1) int static init ("
");						/* new-line char. */


dcl  clock_ entry returns (fixed bin (71));
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_stream entry options (variable);
dcl  ioa_$rsnnl entry options (variable);

dcl  substr builtin;



	star1, star2, bell_out = "";
join:
	if err_code ^= 0 then do;
	     call convert_status_code_ (err_code, short, long);
	     call ioa_$rsnnl ("^a^/^a", out_msg, out_len, long, message);
	end;

	else out_msg = message;


	severity = a_severity;
	if no_log then				/* don't write on log_output */
	     if substr (severity, 1, 1) then do;
		substr (severity, 1, 1) = "0"b;
		if substr (severity, 2, 2) then;	/* message was not for log_output only */
		else substr (severity, 2, 1) = "1"b;	/* write it on user_output */
	     end;

	if substr (severity, 1, 1)
	then call ioa_$ioa_stream ("log_output", "^a^a^a", star1, out_msg, star2);

	if substr (severity, 2, 1) then call ioa_ ("^a^a^a^a", bell_out, star1, out_msg, star2);

	if substr (severity, 3, 1) then call ioa_$ioa_stream ("error_output", "^a^a^a^a", bell_out, star1, out_msg, star2);

	return;



loud:	entry (a_severity, err_code, message);

	star1 = stars || nl;
	star2 = nl || stars;
	bell_out = bells;
	go to join;



init:	entry;

/* This entry, formerly called iod_set_streams_, makes sure that
   *  appropriate stream attachments are made through the message coordinator
   *  if it is being used.
*/

dcl  get_at_entry_ entry (char (*), char (*) aligned, char (*) aligned,
     char (*), fixed bin (35));
dcl  ios_$attach entry (char (*), char (*), char (*) aligned, char (*), bit (72) aligned);

dcl  code fixed bin (35);
dcl  dev_id char (32) aligned;
dcl  dim_name char (32) aligned;
dcl  ig char (4);
dcl  stat bit (72) aligned;
dcl  no_log bit (1) int static;			/* ON if not using log_output */

	call get_at_entry_ ("user_i/o", dim_name, dev_id, ig, code);
	if dim_name = "mrd_"
	then do;

	     call ios_$attach ("error_i/o", "mrd_", dev_id, "", stat);
	     call ios_$attach ("log_i/o", "mrd_", dev_id, "", stat);
	     call ios_$attach ("error_output", "syn", "error_i/o", "w", stat);
	     call ios_$attach ("log_output", "syn", "log_i/o", "w", stat);
	     no_log = "0"b;
	end;

	else no_log = "1"b;

	return;


     end iodc_message_;




		    print_devices.pl1               10/28/88  1351.7rew 10/28/88  1233.8       77769



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

print_devices: proc;

/* This command prints a list of devices for each request type
   handled by the IO daemon as determined by inspecting the
   iod_working_tables segment.  If more than one device class
   is defined for a request type, then the device classes
   are treated separately.  For each request type, the
   associated driver access name and authorization is
   printed.  An asterisk is placed immediately before a device
   name if the corresponding request type (device class) is
   the default for the device.
*/

/* Written by J. Stern, 5/9/75 */
/* Modified by J. C. Whitmore, 4/78, for new iod_tables format */
/* Modified by J. C. Whitmore, 10/78, to use version 3 iod_tables */
/* Modified by E. N. Kittlitz, 6/81, to use version 4 iod_tables */


/****^  HISTORY COMMENTS:
  1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.  Also displays comments
     store in the major and minor device entries.  Display columns are based
     on length of longest entry for each column.
                                                   END HISTORY COMMENTS */


	dcl     argp		 ptr;		/* ptr to arg */
	dcl     arglen		 fixed bin;	/* length of arg */
	dcl     arg		 char (arglen) based (argp); /* command argument */

	dcl     bfsw		 bit (1) aligned;	/* ON for brief option */
	dcl     rqt_found		 bit (1) aligned;	/* ON if desired request type found */
	dcl     an_found		 bit (1) aligned;	/* ON if desired access name found */
	dcl     select		 bit (1) aligned;	/* ON if selecting subset of request types */
	dcl     match		 bit (1) aligned;	/* ON if request type or access name matched */
	dcl     accname		 char (32) aligned; /* access name */
	dcl     req_type		 char (32) aligned; /* request type name */
	dcl     rqt_name		 char (32) aligned; /* request type name */
	dcl     dev_name		 char (32) aligned; /* device name */
	dcl     sysdir		 char (168) aligned;/* directory containing iod_working_tables */
	dcl     ent_name		 char (32) aligned;

	dcl     (i, j, k)		 fixed bin;
	dcl     did_len		 fixed bin;	/* driver id length */
	dcl     code		 fixed bin (35);	/* error code */
	dcl     star		 char (1) aligned;	/* to indicate default request type for device */
	dcl     count		 fixed bin;	/* count of queue groups printed */
	dcl     nargs		 fixed bin;

	dcl     system_high		 bit (72) aligned;	/* system high access authorization */
	dcl     auth_string		 char (170);	/* authorization string */

	dcl     whoami		 char (13) aligned int static init ("print_devices");

	dcl     error_table_$badopt	 fixed bin (35) ext;

	dcl     (addr, substr, ptr, null, before, rtrim, length) builtin;

	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     com_err_		 entry options (variable);
	dcl     expand_pathname_	 entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35));
	dcl     hcs_$initiate	 entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	dcl     convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     system_info_$access_ceiling entry (bit (72) aligned);
%page;

/* initialize control argument defaults */

	bfsw = "0"b;
	an_found, rqt_found = "1"b;
	accname, req_type = "";
	sysdir = ">daemon_dir_dir>io_daemon_dir";

/* look for arguments */

	call cu_$arg_count (nargs);

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, arglen, code);
	     if code ^= 0 then go to noarg;
	     if arg = "-bf" | arg = "-brief" then bfsw = "1"b;
	     else if arg = "-an" | arg = "-access_name" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then do;
noarg:			     call com_err_ (code, whoami);
			     return;
			end;
		     accname = arg;
		     an_found = "0"b;
		end;
	     else if arg = "-rqt" | arg = "-request_type" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then go to noarg;
		     req_type = arg;
		     rqt_found = "0"b;
		end;
	     else if arg = "-dir" | arg = "-directory" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then go to noarg;
		     call expand_pathname_ (arg, sysdir, ent_name, code); /* take apart and put it back together */
		     if code ^= 0 then do;
			     call com_err_ (code, whoami, arg);
			     return;
			end;
		     if sysdir = ">" then sysdir = ">" || ent_name;
		     else sysdir = rtrim (sysdir) || ">" || ent_name;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, whoami, arg);
		     return;
		end;
	end;

	select = ^(an_found & rqt_found);

/* get a pointer to the iod_working_tables */

	call hcs_$initiate (sysdir, "iod_working_tables", "", 0, 1, ithp, code);
	if ithp = null then do;
		call com_err_ (code, whoami, "^a>iod_working_tables", sysdir);
		return;
	     end;

	if iod_tables_hdr.version ^= IODT_VERSION_5 then do;
		call com_err_ (0, whoami, "Wrong version number for iod_working_tables.");
		return;
	     end;

	idtp = ptr (ithp, iod_tables_hdr.device_tab_offset);
	mdtp = ptr (ithp, iod_tables_hdr.minor_device_tab_offset);
	dctp = ptr (ithp, iod_tables_hdr.dev_class_tab_offset);
	qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset);

/* print the table */

	call system_info_$access_ceiling (system_high);
	count = 0;

	do i = 1 to q_group_tab.n_q_groups;
	     qgtep = addr (q_group_tab.entries (i));
	     did_len = length (before (qgte.driver_id, ".*")); /* compiler ensures it ends with ".*" */

	     if select then do;
		     match = "1"b;
		     if req_type ^= "" then
			if req_type = qgte.name then rqt_found = "1"b;
			else match = "0"b;
		     if accname ^= "" then
			if accname = substr (qgte.driver_id, 1, did_len) then an_found = "1"b;
			else match = "0"b;
		     if ^match then go to next;
		end;

	     do j = qgte.first_dev_class to qgte.last_dev_class;
		dctep = addr (dev_class_tab.entries (j));

		do k = 1 to minor_device_tab.n_minor;
		     count = count + 1;
		     if substr (dcte.device_list, k, 1) then do;
			     mdtep = addr (minor_device_tab.entries (k));
			     idtep = addr (iod_device_tab.entries (mdte.major_index));
			     dev_name = idte.dev_id;
			     if idte.last_minor > idte.first_minor
				| dev_name ^= mdte.dev_id then
				dev_name = rtrim (dev_name) || "." || mdte.dev_id;
			     if mdte.default_dev_class = j then star = "*";
			     else star = " ";

			     if count = 1 then
				if ^bfsw then call ioa_ ("^/  Device^-^-Request type^-Access name^/");

			     if substr (dcte.device_list, 1, k - 1) = ""b then do;
				     rqt_name = qgte.name;
				     if qgte.last_dev_class > qgte.first_dev_class
					| rqt_name ^= dcte.id then
					rqt_name = rtrim (rqt_name) || "." || dcte.id;

				     auth_string = "";
				     call convert_authorization_$to_string_short (dcte.max_access, auth_string, code);
				     if auth_string ^= "" then
					if dcte.max_access = system_high then auth_string = "system_high";

				     call ioa_ ("^1a ^18a^20a^20a^a", star, dev_name, rqt_name,
					substr (qgte.driver_id, 1, did_len), auth_string);
				end;
			     else call ioa_ ("^1a ^a", star, dev_name);
			end;
		end;
	     end;
next:	end;

	if ^rqt_found then call com_err_ (0, whoami, "Request type not found: ^a", req_type);
	if ^an_found then call com_err_ (0, whoami, "Access name not found: ^a", accname);
	if rqt_found & an_found then
	     if count = 0 then call com_err_ (0, whoami, "No devices.");
	     else call ioa_ ("");			/* throw in an extra blank line */

	call hcs_$terminate_noname (ithp, code);
%page; %include device_class;
%page; %include iod_device_tab;
%page; %include iod_tables_hdr;
%page; %include q_group_tab;

     end print_devices;




		    print_iod_tables.pl1            10/03/89  1002.6rew 10/03/89  0952.9      198036



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

/* format: style4 */

print_iod_tables: piodt: proc;


/* This command decodes and prints the contents of an object
   segment produced by the iod_tables_compiler.  The format
   of the printed output corresponds exactly to the source
   language accepted by iod_tables_compiler.  Thus, if output
   is directed to a file, the resulting file can be compiled.
*/

/* Written by J. Stern, 1/31/75 */
/* Modified by J. Stern, 12/9/75 */
/* Modified by J. C. Whitmore, April 1978, for new iodt version and keywords. */
/* Modified by J. C. Whitmore, 10/78, for version 3 and line tables */
/* Modified by E. N. Kittlitz 6/81, for rate-structures */


/****^  HISTORY COMMENTS:
  1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.  This includes the
     addition of the forms table entries.
  2) change(89-09-18,Brunelle), approve(89-09-18,MCR8129),
     audit(89-09-29,Beattie), install(89-10-03,MR12.3-1083):
     Correct display of line_charge and page_charge to that it is compatible
     with the iod_tables_compiler.  Also correct the following unreported
     problems: 1) outputting forms_table instead of forms_info in each forms
     specification in device and request type; 2) add missing size value for
     holes type specifications.
                                                   END HISTORY COMMENTS */


/* External Procedures & Variables */

dcl  com_err_ entry () options (variable);
dcl  convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  error_table_$badarg fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry () options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  ioa_$rsnpnnl entry () options (variable);
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  system_info_$access_ceiling entry (bit (72) aligned);

dcl  (addr, divide, hbound, index, length, null, ptr, rank, rtrim, search, substr) builtin;

dcl  cleanup condition;

/* Internal Static */

dcl  NO_ATTACH_TYPE fixed bin int static options (constant) init (-1);
dcl  QUOTE_SPACE_HTAB char (3) int static options (constant) init (""" 	");
dcl  whoami char (16) aligned int static init ("print_iod_tables");

/* Internal Automatic */

dcl  (i, j, k, group) fixed bin;			/* loop variables */
dcl  arg char (arglen) based (argp);			/* command argument */
dcl  argcount fixed bin;
dcl  arglen fixed bin (21);				/* length of arg */
dcl  argp ptr;					/* ptr to arg */
dcl  brief_mode bit (1);
dcl  code fixed bin (35);				/* error code */
dcl  date char (24);				/* the date in ascii */
dcl  dir char (168);				/* directory pathname */
dcl  ent char (32);					/* entry name */
dcl  keyword char (20);				/* holds a keyword */
dcl  string char (128) var;
dcl  text_strings_array (text_strings.length) char (1) unaligned based (text_strings_array_ptr);
dcl  text_strings_array_ptr ptr;
%page;

	brief_mode = "1"b;				/* start in brief mode */
	call cu_$arg_count (argcount, code);
	call cu_$arg_ptr (1, argp, arglen, code);	/* get pathname arg */
	if code ^= 0 then do;
	     call com_err_ (error_table_$noarg, whoami);
	     return;
	end;

	call expand_pathname_ (arg, dir, ent, code);
	if code ^= 0 then do;
	     call com_err_ (code, whoami, arg);
	     return;
	end;

	ithp = null;
	on cleanup go to finish;

	call hcs_$initiate (dir, ent, "", 0, 0, ithp, code); /* get segment ptr */
	if ithp = null then do;
	     call com_err_ (code, whoami, "^a>^a", dir, ent);
	     return;
	end;

	if iod_tables_hdr.version ^= IODT_VERSION_5 then do;
	     call com_err_ (0, whoami, "Wrong version number for ^a.", ent);
	     go to finish;
	end;

	call date_time_ (date_time_compiled, date);	/* keep compilation date handy */

	do i = 2 to argcount;
	     call cu_$arg_ptr (i, argp, arglen, code);
	     if arg = "-brief" | arg = "-bf" then
		brief_mode = "1"b;
	     else if arg = "-long" | arg = "-lg" then
		brief_mode = "0"b;
	     else do;
		call com_err_ (error_table_$badarg, whoami, "Argument (^a).", arg);
		go to finish;
	     end;
	end;

/* start with a little background information */
	call ioa_ ("^//* Listing of segment ^a>^a */
/* compiled on:  ^a */
/* object segment version number:  ^a */",
	     dir, ent, date, iod_tables_hdr.version);

/* Global parameters are next */

	call ioa_ ("^2//* Global parameters */");
	call ioa_ ("^/Time:^-^-^d;", divide (grace_time, 60000000, 35, 0));
	call ioa_ ("^/Max_queues:^-^d;", iod_tables_hdr.max_queues);

/* get ptrs to the various tables */

	ltp = ptr (ithp, iod_tables_hdr.line_tab_offset);
	idtp = ptr (ithp, iod_tables_hdr.device_tab_offset);
	mdtp = ptr (ithp, iod_tables_hdr.minor_device_tab_offset);
	qgtp = ptr (ithp, iod_tables_hdr.q_group_tab_offset);
	dctp = ptr (ithp, iod_tables_hdr.dev_class_tab_offset);
	ifitp = ptr (ithp, iod_tables_hdr.forms_info_tab_offset);
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);
	text_strings_array_ptr = addr (text_strings.chars);
%page;

	if line_tab.n_lines > 0 then			/* if we have line descriptions */
	     call print_line_table_entries;		/* then print them */

	call print_device_entries;			/* print the device descriptions */

	call print_request_type_entries;		/* print the request type descriptions */

	if iod_forms_info_tab.n_groups > 0 then		/* if we have forms data */
	     call print_forms_info;			/* then print it */

	call ioa_ ("^2/End;");

finish:	if ithp ^= null then
	     call hcs_$terminate_noname (ithp, code);
	return;
%page;
print_line_table_entries: proc;

	call ioa_ ("^2//* Lines */");

	do i = 1 to line_tab.n_lines;
	     ltep = addr (line_tab.entries (i));
	     call ioa_ ("^/Line:^2-^a;", lte.line_id);
	     if lte.comment.total_chars > 0 then
		call ioa_ ("  comment:^-^a;", display_string (lte.comment, "0"b, "0"b));
	     call ioa_ ("  channel:^-^a;", lte.chan_id);	/* ZZZ */
	     call ioa_ ("  att_desc:^-^a;", requote_string_ (extract_string (lte.att_desc)));
	     do k = 1 to iod_device_tab.n_devices;
		if substr (lte.maj_dev_list, k, 1) then do;
		     idtep = addr (iod_device_tab.entries (k));
		     call ioa_ ("  device:^2-^a;", idte.dev_id);
		end;
	     end;
	end;

     end print_line_table_entries;
%page;
print_device_entries: proc;

	call ioa_ ("^2//* Devices */");

	do i = 1 to iod_device_tab.n_devices;
	     idtep = addr (iod_device_tab.entries (i));
	     call ioa_ ("^/Device:^-^-^a;", idte.dev_id);
	     if idte.comment.total_chars > 0 then
		call ioa_ ("  comment:^-^a;", display_string (idte.comment, "0"b, "0"b));
	     call ioa_ ("  driver_module:^-^a;", display_string (idte.driver_module, "0"b, "0"b)); /* ZZZ */
	     if idte.args.total_chars ^= 0 then
		call ioa_ ("  args:^-^-^a;", display_string (idte.args, "0"b, "1"b));

	     if idte.attach_type ^= NO_ATTACH_TYPE then do;
		if idte.attach_type = ATTACH_TYPE_IOM then
		     keyword = "prph";
		else if idte.attach_type = ATTACH_TYPE_TTY then
		     keyword = "line";
		else if idte.attach_type = ATTACH_TYPE_DIAL then
		     keyword = "dial_id";
		else if idte.attach_type = ATTACH_TYPE_VARIABLE_LINE then
		     keyword = "line";
		call ioa_ ("  ^a:^2-^a;", keyword, idte.attach_name);
	     end;

	     if idte.ctl_attach_type ^= NO_ATTACH_TYPE then do;
		if idte.ctl_attach_type = CTL_ATTACH_TYPE_TTY then
		     keyword = "ctl_line";
		else if idte.ctl_attach_type = CTL_ATTACH_TYPE_DIAL then
		     keyword = "ctl_dial_id";
		else if idte.ctl_attach_type = CTL_ATTACH_TYPE_MC then
		     keyword = "ctl_source";
		call ioa_ ("  ^a:^-^a;", keyword, idte.ctl_attach_name);
	     end;

	     if idte.head_sheet.total_chars ^= 0 then
		call ioa_ ("  head_sheet:^-^a;", display_string (idte.head_sheet, "0"b, "0"b));
	     if idte.tail_sheet.total_chars ^= 0 then
		call ioa_ ("  tail_sheet:^-^a;", display_string (idte.tail_sheet, "0"b, "0"b));
	     if idte.paper_type > 0 then do;
		if idte.paper_type = PAPER_TYPE_SINGLE then
		     keyword = "single";
		else keyword = "continuous";
		call ioa_ ("  paper_type:^-^a;", keyword);
	     end;
	     if idte.forms_table.total_chars ^= 0 then
		call ioa_ ("  forms_info:^-^a;", extract_string (idte.forms_table));
	     if idte.forms_validation.total_chars ^= 0 then
		call ioa_ ("  forms_validation:^-^a;", extract_string (idte.forms_validation));
	     if idte.font_dir.total_chars ^= 0 then
		call ioa_ ("  font_dir:^-^a;", extract_string (idte.font_dir));
	     do j = idte.first_minor to idte.last_minor;
		mdtep = addr (minor_device_tab.entries (j));
		if idte.last_minor > idte.first_minor
		     | mdte.dev_id ^= idte.dev_id then
		     call ioa_ ("^/ minor_device:^-^a;", mdte.dev_id);
		if mdte.comment.total_chars > 0 then
		     call ioa_ ("  comment:^-^a;", display_string (mdte.comment, "0"b, "0"b));
		if mdte.args.total_chars ^= 0 then
		     call ioa_ ("  minor_args:^-^a;", display_string (mdte.args, "0"b, "1"b));
		if mdte.default_form.total_chars ^= 0 then
		     call ioa_ ("  default_form:^-^a;", display_string (mdte.default_form, "0"b, "0"b));
		if mdte.default_dev_class ^= 0 then do;
		     dctep = addr (dev_class_tab.entries (mdte.default_dev_class));
		     qgtep = addr (q_group_tab.entries (dcte.qgte_index));
		     if qgte.last_dev_class > qgte.first_dev_class
			| dcte.id ^= qgte.name
			| dcte.min_banner ^= ""b then
			call ioa_ ("  default_type:^-^a;", rtrim (qgte.name) || "." || rtrim (dcte.id));
		     else call ioa_ ("  default_type:^-^a;", qgte.name);
		end;
	     end;
	end;
     end print_device_entries;
%page;
print_request_type_entries: proc;

	call ioa_ ("^2//* Request types */");

	do i = 1 to q_group_tab.n_q_groups;
	     qgtep = addr (q_group_tab.entries (i));
	     call ioa_ ("^/Request_type:^-^a;", qgte.name);
	     if qgte.comment.total_chars > 0 then
		call ioa_ ("  comment:^-^a;", display_string (qgte.comment, "0"b, "0"b));
	     call ioa_ ("  generic_type:^-^a;", qgte.generic_type); /* ZZZ */
	     j = length (rtrim (qgte.driver_id)) - 2;	/* drop the ".*" put there by iodtc */
	     call ioa_ ("  driver_userid:^-^a;", substr (qgte.driver_id, 1, j));
	     call ioa_ ("  accounting:^-^a;", display_string (qgte.accounting, "0"b, "0"b));

	     if qgte.rqti_seg_name ^= "" then
		call ioa_ ("  rqti_seg:^-^a;", qgte.rqti_seg_name);

	     if qgte.forms_validation.total_chars ^= 0 then
		call ioa_ ("  forms_validation:^-^a;", display_string (qgte.forms_validation, "0"b, "0"b));

	     if qgte.font_dir.total_chars ^= 0 then
		call ioa_ ("  font_dir:^-^a;", display_string (qgte.font_dir, "0"b, "0"b));

	     if qgte.forms_table.total_chars ^= 0 then
		call ioa_ ("  forms_info:^-^a;", display_string (qgte.forms_table, "0"b, "0"b));

	     if qgte.default_form.total_chars ^= 0 then
		call ioa_ ("  default_form:^-^a;", display_string (qgte.default_form, "0"b, "0"b));

	     if qgte.max_queues ^= iod_tables_hdr.max_queues then
		call ioa_ ("  max_queues:^-^d;", qgte.max_queues);

	     call ioa_ ("  default_queue:^-^d;", qgte.default_queue);

	     if qgte.line_charge.queue (1) ^= "" then do; /* if not default charges, print price names */
		string = "";
		do k = 1 to qgte.max_queues;
		     string = string || rtrim (qgte.line_charge.queue (k)) || ",";
		end;
		k = length (string) - 1;		/* omit the last comma-space */
		call ioa_ ("  line_charge:^-^a;", substr (string, 1, k));
	     end;
	     if qgte.page_charge.queue (1) ^= "" then do; /* if not default charges, print price names */
		string = "";
		do k = 1 to qgte.max_queues;
		     string = string || rtrim (qgte.page_charge.queue (k)) || ",";
		end;
		k = length (string) - 1;
		call ioa_ ("  page_charge:^-^a;", substr (string, 1, k));
	     end;

	     do j = qgte.first_dev_class to qgte.last_dev_class;
		dctep = addr (dev_class_tab.entries (j));
		if qgte.last_dev_class > qgte.first_dev_class
		     | dcte.id ^= qgte.name then
		     call ioa_ (" device_class:^-^a;", dcte.id);
		if dcte.max_access | dcte.min_access | dcte.min_banner then do; /* don't bother if all zero */
		     call ioa_ ("  min_access_class:^-^a;", get_access_class_string (dcte.min_access));
		     call ioa_ ("  max_access_class:^-^a;", get_access_class_string (dcte.max_access));
		     call ioa_ ("  min_banner:^-^a;", get_access_class_string (dcte.min_banner));
		end;

		do k = 1 to minor_device_tab.n_minor;
		     if substr (dcte.device_list, k, 1) then do;
			mdtep = addr (minor_device_tab.entries (k));
			idtep = addr (iod_device_tab.entries (mdte.major_index));
			if idte.last_minor > idte.first_minor
			     | mdte.dev_id ^= idte.dev_id then
			     call ioa_ ("  device:^-^-^a;", rtrim (idte.dev_id) || "." || rtrim (mdte.dev_id));
			else call ioa_ ("  device:^-^-^a;", idte.dev_id);
		     end;
		end;
	     end;
	end;
     end print_request_type_entries;
%page;
print_forms_info: proc;

	call ioa_ ("^2//* Forms Information */");

/* process one group at a time */
	do group = 1 to iod_forms_info_tab.n_groups;
	     call ioa_ ("^/Forms_table:^-^a;", iod_forms_info_tab (group).name);
	     if iod_forms_info_tab (group).comment.total_chars ^= 0 then
		call ioa_ ("  comment:^-^a;", display_string (iod_forms_info_tab (group).comment, "0"b, "1"b));

/* set up ptr to 1st element for this group */
	     fep = addr (iod_forms_info_tab.element_data_block (iod_forms_info_tab (group).first_element_index));

element_display_loop:
	     string = extract_string (element_common.names (1));
	     if element_common.n_names > 1 then do;
		do j = 2 to element_common.n_names;
		     string = string || ",";
		     string = string || extract_string (element_common.names (j));
		end;
	     end;
	     call ioa_ ("^/  name:^2-^a;", output_the_string ((string)));

	     if element_common.comment.total_chars ^= 0 then
		call ioa_ ("  comment:^-^a;", display_string (element_common.comment, "0"b, "1"b));

	     if element_common.type = TYPE_USES then do;	/* uses */
		string = "";
		do j = 1 to uses_element.n_indices;
		     if j ^= 1 then
			string = string || ",";
		     string = string || extract_string (uses_element.name (j));
		end;
		call ioa_ ("  uses:^2-^a;", string);
	     end;
	     else do;
		call ioa_ ("  type:^2-^a;",
		     FORMS_TYPE_STRINGS (element_common.type));
		if element_common.type = TYPE_SPECIAL then do;
		     call ioa_ ("  string:^2-^a;", display_string (special_element.special_string, "0"b, "0"b));
		end;
		else if element_common.type = TYPE_FONT_NAME
		     | element_common.type = TYPE_PREAMBLE
		     | element_common.type = TYPE_POSTAMBLE then do;
		     if orientation_element.escape_string.total_chars ^= 0 then
			call ioa_ ("  string:^2-^a;", display_string (orientation_element.escape_string, "1"b, "0"b));
		end;
		else if element_common.type = TYPE_ORIENTATION
		     | element_common.type = TYPE_HOLES
		     | element_common.type = TYPE_FONT_DESC
		     | element_common.type = TYPE_LINE_DESC then do;
		     if element_common.type = TYPE_ORIENTATION
			| element_common.type = TYPE_HOLES then do;
			call display_forms_size (orientation_element.height, "page_height",
			     orientation_element.factors (1));
			call display_forms_size (orientation_element.width, "page_width",
			     orientation_element.factors (2));
		     end;
		     else if element_common.type = TYPE_FONT_DESC then do;
			call display_forms_size (orientation_element.height, "char_height",
			     orientation_element.factors (1));
			call display_forms_size (orientation_element.width, "char_width",
			     orientation_element.factors (2));
		     end;
		     else if element_common.type = TYPE_LINE_DESC then do;
			call display_forms_size (orientation_element.height, "line_height",
			     orientation_element.factors (1));
			call display_forms_size (orientation_element.width, "line_width",
			     orientation_element.factors (2));
		     end;
		     if orientation_element.escape_string.total_chars ^= 0 then
			call ioa_ ("  string:^2-^a;", display_string (orientation_element.escape_string, "1"b, "0"b));
		end;
	     end;
	     if element_common.next_element_index ^= -1 then do;
		fep = addr (iod_forms_info_tab.element_data_block (element_common.next_element_index));
		go to element_display_loop;
	     end;
	end;
     end print_forms_info;
%page;

extract_string: proc (target_offset) returns (char (*));

dcl  1 target_offset like text_offset;

	if target_offset.total_chars = 0 then
	     return ("");
	else return (substr (text_strings.chars, target_offset.first_char, target_offset.total_chars));

     end extract_string;


get_access_class_string: proc (access_class) returns (char (200) aligned);

/* procedure which takes a binary access class and returns an ascii access class string. */

dcl  access_class bit (72) aligned;			/* binary access class */
dcl  ac_string char (200);				/* string representation of above */
dcl  system_high bit (72) aligned;			/* access class for system_high */
dcl  1 dblword aligned based (addr (access_class)),	/* for error message */
       2 word1 fixed bin (35),
       2 word2 fixed bin (35);

	call convert_authorization_$to_string_short (access_class, ac_string, code);
	if code ^= 0 then
	     call com_err_ (code, whoami, "Access class = ^w ^w", word1, word2);
	else if ac_string = "" then
	     ac_string = "system_low";

	if length (rtrim (ac_string)) > 30 then do;	/* if long, check for system_high */
	     call system_info_$access_ceiling (system_high); /* get binary ceiling */
	     if access_class = system_high then
		ac_string = "system_high";		/* this is cleaner */
	end;

	return (ac_string);

     end get_access_class_string;
%page;

display_forms_size: proc (item, item_title, factor);

dcl  item float bin unaligned;
dcl  item_title char (*);
dcl  factor fixed bin unaligned;
dcl  temp_string char (10) varying;

	if item = -1 then return;
	if item = 0 then return;
	if factor ^= FACTOR_LPI then
	     call ioa_$rsnpnnl ("^.2f", temp_string, (0), item / SIZE_FACTORS (factor));
	else call ioa_$rsnpnnl ("^.2f", temp_string, (0), SIZE_FACTORS (factor) / item);

	temp_string = rtrim (temp_string, "0");
	temp_string = rtrim (temp_string, ".");
	call ioa_ ("  ^a:^-^a^[in^;cm^;pt^;lpi^];",
	     item_title, temp_string, factor);

     end display_forms_size;

output_the_string: proc (string_to_check) returns (char (*));

dcl  string_to_check char (*);
	if index (rtrim (string_to_check), " ") = 0 then
	     return (rtrim (string_to_check));
	else return (requote_string_ (rtrim (string_to_check)));
     end output_the_string;
%page;
display_string: proc (string_data, special_process, force_requote) returns (char (*));

dcl  special_process bit (1);
dcl  force_requote bit (1);
dcl  1 string_data unaligned like text_offset;

dcl  input_string char (input_string_len) based (input_string_ptr);
dcl  input_string_len fixed bin;
dcl  input_string_ptr ptr;

dcl  return_string char (1024) varying;

dcl  (i, j) fixed bin;

	return_string = "";
	input_string_ptr = addr (text_strings_array (string_data.first_char));
	input_string_len = string_data.total_chars;
	if ^special_process then do;
	     if search (input_string, QUOTE_SPACE_HTAB) ^= 0 | force_requote then
		return_string = requote_string_ (input_string);
	     else return_string = input_string;
	end;
	else do i = 1 to input_string_len;
	     call count_text;
	     if j > 1 then do;
		return_string = return_string
		     || requote_string_ (substr (input_string, i, j));
		i = i + j - 1;
	     end;
	     else return_string = return_string || tchar (substr (input_string, i, 1));
	     return_string = return_string || " ";
	end;

	return (return_string);

count_text: proc;

	     do j = i to input_string_len
		while (rank (substr (input_string, j, 1)) >= 32
		& rank (substr (input_string, j, 1)) <= 126);
	     end;
	     j = j - i;
	end count_text;

     end display_string;

/* return prettyest representation of a character */

tchar: proc (c) returns (char (4) var);

dcl  c char (1);
dcl  i fixed bin;
dcl  temp char (4);

dcl  asc_value (0:32) char (3) static options (constant) init
	("NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
	"BS ", "TAB", "LF ", "VT ", "FF ", "CR ", "SO ", "SI ",
	"DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
	"CAN", "EM ", "SUB", "ESC", "FS ", "GS ", "RS ", "US ", "SP ");

	i = rank (c);
	if i <= hbound (asc_value, 1) then return (rtrim (asc_value (i)));
	if i > 126 then do;
	     if i = 127 then
		return ("DEL");
	     call ioa_$rsnnl ("^o", temp, (0), i);
	     return (temp);
	end;
	if index ("0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ", c) > 0 then return (c);
	if c = """" then return ("""""""""");
	else return ("""" || c || """");

     end tchar;
%page; %include device_class;
%page; %include iod_forms_info_tab;
%page; %include iod_constants;
%page; %include iod_device_tab;
%page; %include iod_line_tab;
%page; %include iod_tables_hdr;
%page; %include q_group_tab;

     end print_iod_tables;




		    print_line_ids.pl1              10/28/88  1351.7rew 10/28/88  1233.8       46503



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


print_line_ids: prt: proc;

/* This command prints a list of line ids handled by the
   IO daemon as determined by inspecting the "iod_working_tables"
   segment.  For each line id, the associated channel is printed.
*/

/* Written by J. C. Whitmore, 10/78, modeled after print_request_types.pl1 */
/* Modified by E. N. Kittlitz, 6/81, to use version_4 iod_tables_hdr */



/****^  HISTORY COMMENTS:
  1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.  Also displays comments
     store in the line table entry.  Display columns are based on length of
     longest entry for each column.
                                                   END HISTORY COMMENTS */


	dcl     argp		 ptr;		/* ptr to arg */
	dcl     arglen		 fixed bin;	/* length of arg */
	dcl     arg		 char (arglen) based (argp); /* command argument */

	dcl     bfsw		 bit (1) aligned;	/* ON for brief option */
	dcl     sysdir		 char (168) aligned;/* directory containing iod_working_tables */
	dcl     ent_name		 char (32) aligned;

	dcl     i			 fixed bin;
	dcl     code		 fixed bin (35);	/* error code */
	dcl     nargs		 fixed bin;
	dcl     (max_chan_id, max_line_id) fixed bin;

	dcl     whoami		 char (19) aligned int static options (constant) init ("print_line_ids");

	dcl     error_table_$badopt	 fixed bin (35) ext;

	dcl     (addr, null, length, ptr, rtrim, substr) builtin;

	dcl     cu_$arg_count	 entry (fixed bin);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     com_err_		 entry options (variable);
	dcl     expand_pathname_	 entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35));
	dcl     hcs_$initiate	 entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     hcs_$terminate_noname	 entry (ptr, fixed bin (35));
%page;

/* initialize control argument defaults */

	bfsw = "0"b;
	sysdir = ">daemon_dir_dir>io_daemon_dir";

/* look for arguments */

	call cu_$arg_count (nargs);

	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argp, arglen, code);
	     if code ^= 0 then go to noarg;
	     if arg = "-bf" | arg = "-brief" then bfsw = "1"b;
	     else if arg = "-dir" | arg = "-directory" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, argp, arglen, code);
		     if code ^= 0 then do;
noarg:			     call com_err_ (code, whoami);
			     return;
			end;
		     call expand_pathname_ (arg, sysdir, ent_name, code); /* take apart and put it back together */
		     if code ^= 0 then do;
			     call com_err_ (code, whoami, arg);
			     return;
			end;
		     if sysdir = ">" then sysdir = ">" || ent_name;
		     else sysdir = rtrim (sysdir) || ">" || ent_name;
		end;
	     else do;
		     call com_err_ (error_table_$badopt, whoami, arg);
		     return;
		end;
	end;

/* get a pointer to the line table */

	call hcs_$initiate (sysdir, "iod_working_tables", "", 0, 1, ithp, code);
	if ithp = null then do;
		call com_err_ (code, whoami, "^a>iod_working_tables", sysdir);
		return;
	     end;

	if iod_tables_hdr.version ^= IODT_VERSION_5 then do;
		call com_err_ (0, whoami, "Wrong version number for iod_working_tables.");
		return;
	     end;

	ltp = ptr (ithp, iod_tables_hdr.line_tab_offset);
	text_strings_ptr = ptr (ithp, iod_tables_hdr.text_strings_offset);

/* first find the lengths for the longest line_id & chan_id */
	max_line_id = 7;
	max_chan_id = 7;
	do i = 1 to line_tab.n_lines;
	     ltep = addr (line_tab.entries (i));
	     if length (rtrim (lte.line_id)) > max_line_id then
		max_line_id = length (rtrim (lte.line_id));
	     if length (rtrim (lte.chan_id)) > max_chan_id then
		max_chan_id = length (rtrim (lte.chan_id));
	end;

/* now print the table */
	do i = 1 to line_tab.n_lines;
	     ltep = addr (line_tab.entries (i));

	     if i = 1 then
		if ^bfsw then call ioa_ ("^/Line ID^vxChannel^vxComment^/",
			max_line_id - 7 + 2, max_chan_id - 7 + 2);

	     call ioa_ ("^va  ^va  ^a", max_line_id, lte.line_id,
		max_chan_id, lte.chan_id,
		substr (text_strings.chars, lte.comment.first_char, lte.comment.total_chars));
	end;

	if line_tab.n_lines > 0 then call ioa_ ("");	/* throw in an extra blank line */
	else call ioa_ ("No line ids specified in iod_working_tables.");

	call hcs_$terminate_noname (ithp, code);
%page;
%include iod_line_tab;
%include iod_tables_hdr;

     end print_line_ids;




		    save_request_.pl1               10/28/88  1351.7rew 10/28/88  1233.7       76950



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

save_request_: proc (descr_ptr, dev_class_ptr);

/* This procedure is used to thread a completed request onto the end of the "saved"
   *  list, and delete the request message from the appropriate queue.
   *  If it happens to be the one most recently read from that queue, we will have to update
   *  that information before deleting it.
*/


/* Coded August 1973 by Robert S. Coren */
/* Modified by J. Stern, 12/27/74 */
/* Modified by J. Stern, 11/25/75 */
/* Modified by J. C. Whitmore, 4/78, to use the keep_in_queue flag */
/* Modified by J. C. Whitmore, 7/78, to mark deferred requests in the queue */
/* Modified by J. C. Whitmore, 5/80, to not add user deleted requests to the saved list */
/* Modified by C. Marker, 02/23/85, to use version 5 message segments */


/****^  HISTORY COMMENTS:
  1) change(88-06-03,Brunelle), approve(88-06-03,MCR7911),
     audit(88-10-18,Wallman), install(88-10-28,MR12.2-1199):
     Upgraded to handle version 5 I/O daemon tables.
                                                   END HISTORY COMMENTS */


	dcl     descr_ptr		 ptr;		/* pointer to descriptor being threaded */
	dcl     dev_class_ptr	 ptr;		/* pointer to entry for this request's device class */

	dcl     code		 fixed bin (35);
	dcl     desc_p		 ptr;
	dcl     desc_off		 fixed bin (18);
	dcl     rest_p		 ptr;

	dcl     err_msg		 char (64);
	dcl     err_len		 fixed bin;
	dcl     last_ptr		 ptr;		/* pointer to previous descriptor in list */
	dcl     mseg_idx		 fixed bin;
	dcl     q			 fixed bin;
	dcl     retry		 fixed bin;

	dcl     msg_id		 bit (72) aligned;	/* id of message from the current descr */
	dcl     msg_p		 ptr;		/* pointer to the message text in request area */
	dcl     msg_len		 fixed bin (18);

	dcl     based_offset	 fixed bin (18) based;

	dcl     deferred		 fixed bin int static options (constant) init (1);

	dcl     error_table_$bad_segment fixed bin (35) ext;
	dcl     error_table_$no_message fixed bin (35) ext;

	dcl     (addr, fixed, ptr, rel, divide) builtin;


	dcl     clock_		 entry returns (fixed bin (71));
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     iodc_message_	 entry (bit (3) aligned, fixed bin (35), char (*));
	dcl     message_segment_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35));
	dcl     message_segment_$update_message_index entry (fixed bin, fixed bin (18), bit (72) aligned, ptr, fixed bin (35));
	dcl     timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2) aligned, fixed bin (71));
%page;

	dctep = dev_class_ptr;			/* copy pointer args */
	desc_p = descr_ptr;
	desc_off = fixed (rel (desc_p), 18);

	qgtep = addr (iodc_static.qgtp -> q_group_tab.entries (dcte.qgte_index));
	q = desc_p -> request_descriptor.q;
	mseg_idx = qgte.mseg_index (q);
	msg_p = desc_p -> request_descriptor.ms_ptr;
	msg_len = desc_p -> request_descriptor.ms_len;
	msg_id = desc_p -> request_descriptor.ms_id;

	if desc_p -> request_descriptor.keep_in_queue then do; /* this is highest priority action */
		msg_p -> queue_msg_hdr.state = deferred;/* mark the request as deferred */

		retry = 0;
update:		call message_segment_$update_message_index (mseg_idx, msg_len, msg_id, msg_p, code);
		if code ^= 0 then
		     if code ^= error_table_$no_message
		     then if code = error_table_$bad_segment /* message seg was salvaged */
			then do;
				if retry = 0 then do; /* try once more */
					retry = 1;
					go to update;
				     end;
				go to no_update;
			     end;
			else do;
no_update:			call ioa_$rsnnl ("Could not update message in queue ^d of request type ^a.",
				     err_msg, err_len, q, qgte.name);
				call iodc_message_ ("101"b, code, err_msg);
			     end;
		free msg_p -> queue_msg_hdr in (req_area);
		free desc_p -> request_descriptor in (req_desc_seg.descr_area);
		return;				/* this one is done, like we never saw it */
	     end;

	else if desc_p -> request_descriptor.cancelled then do;

/* if it was "cancelled", we will not really save it, rather the reverse */

		call delete_from_queue (code);

		free msg_p -> queue_msg_hdr in (req_area);
		free desc_p -> request_descriptor in (req_desc_seg.descr_area);
	     end;

	else do;

/* If not deferred or cancelled, we must add it to the saved list */

		desc_p -> request_descriptor.finished = "1"b; /* be sure the descriptor is right */
		desc_p -> request_descriptor.continued = "0"b;
		desc_p -> request_descriptor.series_restart = "0"b;
		desc_p -> request_descriptor.priority_request = "0"b;

		if dcte.restart_req ^= 0 then do;	/* restart in progress */
						/* see if this request should be added to series */
			rest_p = ptr (iodc_static.descr_seg_ptr, dcte.restart_req);
			if rest_p -> request_descriptor.series_restart then do; /* it was a series, check more */
				if divide (rest_p -> request_descriptor.seq_id, 10000, 35, 0) =
				     divide (desc_p -> request_descriptor.seq_id, 10000, 35, 0) then do; /* same series */
					desc_p -> request_descriptor.saved = "1"b; /* make sure it stays around */
					desc_p -> request_descriptor.series_restart = "1"b; /* mark as part of series */
				     end;
			     end;
		     end;

/* remove the message from the queue, indicating that from the users view it is done */

		call delete_from_queue (code);
		if code ^= 0 then
		     if code = error_table_$no_message then do; /* already gone? Maybe the user deleted it. */
			     if ^desc_p -> request_descriptor.restarted then do; /* if restarted, we deleted it earlier */
						/* otherwise, assume the user deleted the message and flush it */
				     free msg_p -> queue_msg_hdr in (req_area);
				     free desc_p -> request_descriptor in (req_desc_seg.descr_area);
				     return;
				end;
			end;

/* set time done and set up alarm to delete it later */

		desc_p -> request_descriptor.time_done = clock_ ();
		if ^(desc_p -> request_descriptor.saved) then
		     call timer_manager_$alarm_wakeup (iodc_static.time_interval, "10"b, iodc_static.timer_chan);

		if iodc_static.last_req_done = 0 then do; /* if no requests in the list, point head of list at this one */
			desc_p -> request_descriptor.prev_done,
			     desc_p -> request_descriptor.next_done = 0;
			iodc_static.first_req_done = desc_off;
			iodc_static.save_first_req_p -> based_offset = desc_off; /* also store in req_desc_seg for reinit */
		     end;
		else do;				/* Yes, chain them together */
			desc_p -> request_descriptor.next_done = 0; /* this is the end of the chain */
			desc_p -> request_descriptor.prev_done = last_req_done;
			last_ptr = ptr (iodc_static.descr_seg_ptr, iodc_static.last_req_done); /* get ptr to previous descr */
			last_ptr -> request_descriptor.next_done = desc_off; /* make it point to this one */
		     end;
		iodc_static.last_req_done = desc_off;
	     end;

	return;
%page;

delete_from_queue: proc (code);

	dcl     code		 fixed bin (35);

	retry = 0;
delete:	call message_segment_$delete_index (mseg_idx, msg_id, code);
	if code ^= 0
	then if code ^= error_table_$no_message
	     then if code = error_table_$bad_segment	/* message seg was salvaged */
		then do;
			if retry = 0 then do;	/* try once more */
				retry = 1;
				go to delete;
			     end;
			go to fatal_err2;
		     end;
		else do;

/* trouble deleting from queue; to avoid further problems, */
/* drop the queue */

fatal_err2:		call ioa_$rsnnl ("Could not delete message from queue ^d of request type ^a. Queue will be dropped",
			     err_msg, err_len, q, qgte.name);
			call iodc_message_ ("101"b, code, err_msg);
			qgte.mseg_index (q) = 0;
		     end;

	return;

     end delete_from_queue;


init: entry (a_ptr);

	dcl     a_ptr		 ptr;

	stat_p = a_ptr;
	return;
%page; %include device_class;
%page; %include iod_tables_hdr;
%page; %include iodc_static;
%page; %include mseg_message_info;
%page; %include q_group_tab;
%page; %include queue_msg_hdr;
%page; %include request_descriptor;

     end save_request_;




		    test_io_daemon.pl1              11/15/82  1834.0rew 11/15/82  1507.4       39420



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


/* command interface for IOD testing */
/* format: style2 */

/* History:
   Coded Fall 1980 Benson I. Margulies 
*/

test_io_daemon:
     procedure options (variable);

	declare iod_overseer_$test_path
				 entry (char (*), char (*));
	declare cu_$arg_count	 entry (fixed bin, fixed bin (35));
	declare cu_$arg_ptr		 entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
	declare com_err_		 entry options (variable);
	declare absolute_pathname_	 entry (char (*), char (*), fixed bin (35));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare n_args		 fixed bin;
	declare code		 fixed bin (35);
	declare dir		 char (168);
	declare entryname		 char (32);
	declare got_pn		 bit (1);
	declare got_dr		 bit (1);
	declare current_argument	 fixed bin;
	declare arg_ptr		 pointer;
	declare arg_len		 fixed bin (21);
	declare argument		 char (arg_len) based (arg_ptr);

	declare ME		 char (14) init ("test_io_daemon") int static options (constant);
	declare Default_entryname	 char (32) init ("iod_tables") int static options (constant);

	declare (
	        error_table_$noarg,
	        error_table_$badopt,
	        error_table_$too_many_args,
	        error_table_$inconsistent
	        )			 fixed bin (35) ext static;

	call cu_$arg_count (n_args, code);
	if code ^= 0
	then do;
		call com_err_ (code, ME);
		return;
	     end;
	if n_args = 0
	then do;
		call com_err_ (0, ME, "Usage: test_io_daemon {IOD_TABLE_PATH} {-directory TEST_DIR_PATH}.");
		return;
	     end;
	got_pn, got_dr = ""b;
	current_argument = 0;
	do while (current_argument < n_args);
	     current_argument = current_argument + 1;
	     call cu_$arg_ptr (current_argument, arg_ptr, arg_len, (0));
						/* we know how many arguments */
	     if index (argument, "-") ^= 1
	     then do;				/* noncontrol */
		     if got_pn
		     then do;
			     call com_err_ (error_table_$too_many_args, ME,
				"Only one pathname may be given, ^a was in error.", argument);
			     return;
			end;
		     if got_dr
		     then goto pn_and_dr_given;

		     call expand_pathname_ (argument, dir, entryname, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, ME, "^a.", argument);
			     return;
			end;
		     got_pn = "1"b;
		end;				/* only one possible noncontrol */
	     else do;				/* control argument */
		     if argument = "-directory" | argument = "-dr"
		     then do;
			     if got_dr
			     then do;
				     call com_err_ (error_table_$inconsistent, ME,
					"-directory may only be given once.");
				     return;
				end;
			     if got_pn
			     then do;
pn_and_dr_given:
				     call com_err_ (error_table_$inconsistent, ME,
					"-directory may not be given with a pathname.");
				     return;
				end;

			     if current_argument = n_args
			     then do;
				     call com_err_ (error_table_$noarg, ME,
					"A directory pathname must be given with ^a.", argument);
				     return;
				end;
			     current_argument = current_argument + 1;
			     call cu_$arg_ptr (current_argument, arg_ptr, arg_len, (0));
			     if substr (argument, 1, 1) = "-"
			     then do;		/* no path */
				     call com_err_ (error_table_$noarg, ME,
					"A pathname must be given following -directory. Control argument ^a was in error."
					, argument);
				     return;
				end;
			     call absolute_pathname_ (argument, dir, code);
			     if code ^= 0
			     then do;
				     call com_err_ (code, ME, "^a", argument);
				     return;
				end;
			     entryname = Default_entryname;
			     got_dr = "1"b;
			end;			/* processing -dir */
		     else do;			/* bad control arg */
			     call com_err_ (error_table_$badopt, ME, "Control argument ^a not recognized.", argument);
			     return;
			end;
		end;				/* control args */
	end;					/* arg loop */
	call iod_overseer_$test_path (dir, entryname);
	return;
     end test_io_daemon;




		    unthread_descriptor_.pl1        03/14/85  0831.6r   03/13/85  1025.6       15138



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


unthread_descriptor_: proc (a_ptr);

/* A little procedure to unthread request descriptors */
/* Modified: February 26, 1985 by C. Marker to use version 5 message segments */

dcl  a_ptr ptr;

dcl  desc_ptr ptr;

dcl  prev_ptr ptr;
dcl  prev_off fixed bin (18);

dcl  next_ptr ptr;
dcl  next_off fixed bin (18);

dcl  based_offset fixed bin (18) based;

dcl  ptr builtin;

/**/

	desc_ptr = a_ptr;

	next_off = desc_ptr -> request_descriptor.next_done;
	prev_off = desc_ptr -> request_descriptor.prev_done;

	if prev_off = 0 then do;			/* this was first on list */
	     iodc_static.first_req_done = next_off;
	     iodc_static.save_first_req_p -> based_offset = next_off;
	end;

	else do;
	     prev_ptr = ptr (desc_ptr, prev_off);
	     prev_ptr -> request_descriptor.next_done = next_off;
	end;

	if next_off ^= 0 then do;
	     next_ptr = ptr (desc_ptr, next_off);
	     next_ptr -> request_descriptor.prev_done = prev_off;
	end;

	else iodc_static.last_req_done = prev_off;

	return;


init:	entry (a_ptr);

	stat_p = a_ptr;
	return;

/**/

%include iodc_static;
%page;
%include mseg_message_info;
%page;
%include request_descriptor;

     end unthread_descriptor_;





		    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
