



		    ioam_.pl1                       11/11/89  1139.8rew 11/11/89  0801.3       73818



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

/* format: off */

ioam_: proc;

/* The I/O assignment manager - maintains a table of devices
   owned by various subsystems so that the subsystem can be
   notified if the process dies without properly detaching
   its devices.

   Rewritten 4/14/76 by Mike Grady.
*/


/****^  HISTORY COMMENTS:
  1) change(86-09-17,Farley), approve(86-07-18,MCR7439),
     audit(86-09-24,Fawcett), install(86-10-20,MR12.0-1189):
     Changed to execute in the BCE environment.
                                                   END HISTORY COMMENTS */


dcl  devx fixed bin,
     handler entry,
     code fixed bin (35),
     pid bit (36) aligned;

dcl  ioat_uidc char (4) int static init ("ioat") options (constant),
     ioat_uid bit (36) based (addr (ioat_uidc));

dcl  pds$processid bit (36) ext,
    (error_table_$bad_index,
     error_table_$dev_nt_assnd,
     error_table_$already_assigned,
     error_table_$ioat_err) fixed bin (35) ext;

dcl  sys_info$service_system
     bit (1) aligned external static;

dcl  ignore fixed bin (35),
     isize fixed bin,
     i fixed bin;

dcl (addr, baseno, divide, fixed, hbound, rel, size) builtin;

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

dcl  syserr entry options (variable),
     lock$wait entry (ptr, bit (36), fixed bin (35)),
     lock$unlock entry (ptr, bit (36));

dcl (ioatp, ioatep) ptr,
    (dseg$, ioat$) fixed bin ext;

dcl 1 ioat aligned based (ioatp),			/* The IO assigment table */
      2 lock bit (36),				/* lock while doing updates */
      2 last_entry fixed bin,				/* highest entry used in table */
      2 max_entries fixed bin,			/* highest entry we can use in table */
      2 entries (2048) like ioate;			/* the ioat entries */

dcl 1 ioate aligned based (ioatep),			/* declaration of ioat entries */
      2 pid bit (36),				/* process id of this devices owner */
      2 devx fixed bin,				/* device index assigned by dstint */
      2 handler entry (fixed bin, fixed bin (35));	/* routine to call when process dies */

%include sdw;

assign: entry (devx, handler, code);			/* entry to assign a device to a process */

	call setup;				/* init some stuff and set ptrs */

	call find_device (code);			/* attempt to see if already assigned */
	if code = 0 then				/* it is already assigned to us */
	     ioate.handler = handler;			/* just update detach handler */
	else if code = error_table_$dev_nt_assnd then do; /* if not assigned, then assign it */
	     call find_free;			/* assign new block in ioat */

	     ioate.pid = pds$processid;		/* use this processid */
	     ioate.devx = devx;			/* fill in devx and */
	     ioate.handler = handler;			/* the unassign_handler */
	     code = 0;				/* no error */
	end;

	if sys_info$service_system then
	     call lock$unlock (ioatp, ioat_uid);	/* unlock IOAT */
	return;



unassign: entry (devx, code);				/* entry to unassign a device from this process */

	call setup;
	call find_device (code);			/* it had better be our device */
	if code = 0 then				/* it was ours, unassign */
	     ioate.pid = "0"b;			/* clear processid to indicate entry free */

	if sys_info$service_system then
	     call lock$unlock (ioatp, ioat_uid);
	return;

preempt: entry (pid, devx, code);			/* entry to force the unassign of a device */

	call setup;				/* setup stuff */
	call find_device (code);			/* locate the device, it had better be assigned */
	if code ^= error_table_$dev_nt_assnd then do;	/* if it was assigned at all, dump it */
	     call ioate.handler (ioate.devx, code);	/* call the detach handler */

	     ioate.pid = "0"b;			/* mark entry free */
	end;

	if sys_info$service_system then
	     call lock$unlock (ioatp, ioat_uid);
	return;



process_release: entry (pid);				/* entry to release all devices from a process */

	ioatp = addr (ioat$);			/* make ptr, can't call setup */
	if sys_info$service_system then do;
	     call lock$wait (ioatp, ioat_uid, ignore);	/* lock the IOAT lock */
	     if ignore ^= 0 then return;		/* some locking error has occured */
	end;

	do i = 1 to ioat.last_entry;			/* search the table for this processid */
	     ioatep = addr (ioat.entries (i));		/* get entry ptr */

	     if (ioate.pid ^= "0"b) & (ioate.pid = pid) then do; /* if owned and owned by this guy then */
		call ioate.handler (ioate.devx, ignore); /* call unassign handler, ignore code */
		ioate.pid = "0"b;			/* free the slot */
	     end;
	end;

	if sys_info$service_system then
	     call lock$unlock (ioatp, ioat_uid);
	return;

setup: proc;					/* proc to setup ptrs and validate devx */

	if (devx < 0) | (devx > hbound (ioat.entries, 1)) then do;	/* validate the devx */
	     code = error_table_$bad_index;
	     goto RETURN;
	end;

	code = 0;					/* initialize the code */
	ioatp = addr (ioat$);			/* get ptr  to the IOAT */

	if ioat.max_entries = 0 then do;		/* init the max size of the IOAT */
	     sdwp = addr (dseg$);
	     sdwp = addr (sdwa (fixed (baseno (ioatp), 17))); /* get ptr to sdw */
	     isize = fixed (sdw.bound, 17) * 16;	/* get size of seg */

	     isize = isize - fixed (rel (addr (ioat.entries)), 17); /* minus the header */
	     ioat.max_entries = divide (isize, size (ioate), 17, 0); /* divided by size of an entry */
	end;

	if sys_info$service_system then do;
	     call lock$wait (ioatp, ioat_uid, code);	/* lock the IOAT */
	     if code ^= 0 then goto RETURN;		/* some locking error */
	end;
	return;

   end;


RETURN:	return;					/* non-local return */


find_device: proc (acode);				/* proc to find the device in the IOAT */

dcl acode fixed bin (35);

	acode = 0;				/* init the return code */
	do i = 1 to ioat.last_entry;			/* loop over whole IOAT */
	     ioatep = addr (ioat.entries (i));		/* get ptr to entry */

	     if ioate.devx = devx then		/* if we found devx then */
		if ioate.pid = pds$processid then return; /* and it is this process, we got it */
		else if ioate.pid = "0"b then do;	/* else if not assigned, say so */
		     acode = error_table_$dev_nt_assnd;
		     return;
		end;
		else do;				/* else it is assigned, but not to us */
		     acode = error_table_$already_assigned;
		     return;
		end;
	end;

	acode = error_table_$dev_nt_assnd;		/* devx not in table at all */
	return;

   end;



find_free: proc;

	do i = 1 to ioat.last_entry;			/* search the IOAT for a free slot */
	     ioatep = addr (ioat.entries (i));		/* get ptr to this slot */
	     if ioate.pid = "0"b then return;		/* found a free slot */
	end;

	if ioat.last_entry < ioat.max_entries then do;	/* if still room in IOAT at end, take one */
	     ioat.last_entry = ioat.last_entry + 1;	/* bump counter */
	     ioatep = addr (ioat.entries (ioat.last_entry)); /* set ptr */
	     return;
	end;

	if ^syserr_sw then				/* no more room in table, type message */
	     call syserr (3, "ioam_: The IOAT is too small, use TBLS config card to increase size.");
	syserr_sw = "1"b;				/* message goes out only once */
	code = error_table_$ioat_err;
	goto RETURN;				/* jump back to caller */

   end;


/* BEGIN MESSAGE DOCUMENTATION

Message:
ioam_: The IOAT is too small, use TBLS config card to increase size.

S:	$beep

T:	$init

M:	The system was unable to make an entry in the IO Assignment Table.
One or more devices may be unattachable.

A:	$inform
Correct the configuration deck before the next bootload.


END MESSAGE DOCUMENTATION */

end;




		    ioi_assignment.pl1              11/11/89  1139.8rew 11/11/89  0801.3      120114



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

ioi_assignment:
     proc;

/* Module which handles devices assignments and unassignments for IOI */
/* Rewritten February 1983 by Chris Jones. */
/* Modified January 1984 by Chris Jones to add (add delete)_device entries. */
/* Modified May 1984 by Paul Farley to check for IPC flag. */
/* Modified Jan 1985 by Paul Farley to change IPC to FIPS. */
/* Modified Sept 1985 by Paul Farley to add "controller" checking. */

/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(85-11-26,CLJones), install(86-03-21,MR12.0-1033):
     Support FIPS.
  2) change(86-05-16,Kissel), approve(86-07-30,MCR7461), audit(86-07-31,Coren),
     install(86-08-19,MR12.0-1120):
     Recompiled because of change in ioi_data.incl.pl1 to the constant
     IOI_DEFAULT_MAX_BOUND.
  3) change(86-06-03,Farley), approve(86-07-18,MCR7439),
     audit(86-08-18,Fawcett), install(86-10-20,MR12.0-1189):
     Changed to execute in the BCE environment.
                                                   END HISTORY COMMENTS */

dcl	p_dtx		   fixed bin parameter;	/* device table index (O) */
dcl	p_name		   char (*) parameter;	/* device name (I) */
dcl	p_priv		   bit (1) aligned parameter; /* privileged assign flag (I) */
dcl	p_eventid		   fixed bin (71) parameter;	/* IPC event ID for wakeups (I) */
dcl	p_code		   fixed bin (35) parameter;	/* error code (O) */

dcl	code		   fixed bin (35);		/* local error code */
dcl	controller	   bit (1) aligned;		/* set if device = controller */
dcl	device		   bit (6) aligned;		/* physical device address */
dcl	dtx		   fixed bin;		/* device table index */
dcl	eventid		   fixed bin (71);		/* IPC event ID */
dcl	locked_for_reconfig	   bit (1) aligned;		/* set if we hold the reconfig lock */
dcl	must_be_deleted	   bit (1) aligned;		/* set if the device must be in the deleted state */
dcl	name		   char (32) var;		/* device name */
dcl	no_path		   bit (1) aligned;		/* set if we haven't found a path to the device */
dcl	priv		   bit (1) aligned;		/* "1"b if privileged user */
dcl	statusp		   ptr;			/* pointer to where io_manager stuffs status */
dcl	subsys_name	   char (4) aligned;	/* subsystem name */

dcl	cleanup		   cond;

dcl	error_table_$invalid_device
			   fixed bin (35) ext;
dcl	error_table_$io_configured
			   fixed bin (35) ext static;
dcl	error_table_$io_no_path
			   fixed bin (35) ext static;
dcl	error_table_$io_not_configured
			   fixed bin (35) ext static;

dcl	pds$process_id	   bit (36) aligned external;
dcl	pds$validation_level   fixed bin (3) external;

dcl	sys_info$service_system
			   bit (1) aligned external static;

dcl	ioi_device$assign	   entry (ptr, bit (6) aligned, bit (1) aligned, fixed bin, fixed bin (35));
dcl	ioi_device$get_dtep	   entry (fixed bin, ptr, fixed bin (35));
dcl	ioi_device$get_dtep_force
			   entry (fixed bin, ptr, fixed bin (35));
dcl	ioi_device$unassign	   entry (ptr);
dcl	ioi_device$unlock	   entry (ptr);
dcl	ioi_masked$flush_status
			   entry (ptr);
dcl	ioi_masked$interrupt   entry (fixed bin (35), fixed bin (3), bit (36) aligned);
dcl	ioi_masked$reset_device
			   entry (ptr);
dcl	ioi_page_table$put	   entry (fixed bin, fixed bin (35));
dcl	ioi_usurp_channels$assign
			   entry (ptr, fixed bin (35));
dcl	ioi_usurp_channels$unassign
			   entry (ptr, fixed bin (35));
dcl	ioi_wire$unwire	   entry (ptr);
dcl	ioi_workspace$create   entry (ptr, fixed bin (35));
dcl	ioi_workspace$destroy  entry (ptr, fixed bin (35));
dcl	ioi_workspace$release_aste
			   entry (ptr);

dcl	(addr, after, before, bin, bit, index, null, ptr, rel, rtrim)
			   builtin;

assign_deleted:
     entry (p_dtx, p_name, p_eventid, p_priv, p_code);

	must_be_deleted = "1"b;
	goto ASSIGN_COMMON;

assign:
     entry (p_dtx, p_name, p_eventid, p_priv, p_code);

	must_be_deleted = "0"b;
ASSIGN_COMMON:
	name = rtrim (p_name);			/* Copy the device name. */
	priv = p_priv;				/* Copy privileged assign switch. */
	eventid = p_eventid;			/* Grab the event ID. */

	idp = addr (ioi_data$);			/* Get data base pointer. */
	p_code = 0;				/* Clear error code. */
	subsys_name = before (name, "_");

	call find_gte (subsys_name);
	if gtep = null () then do;
	     p_code = error_table_$invalid_device;
	     return;
	end;

	controller = "0"b;				/* start by saying its not */
	if index (name, "_") = 0 then			/* no device given */
	     if gte.fips then do;
		device = "00"b3;			/* devices start at zero */
		controller = "1"b;			/* and this is the controller */
	     end;
	     else device = "01"b3;			/* otherwise start at one */
	else device = bit (bin (after (name, "_"), 6, 0));
	if device = "00"b3 & ^gte.fips then
	     controller = "1"b;			/* old style controller */

	dtep = null ();
	on cleanup call cleanup_assign;		/* Establish cleanup handler to undo whatever. */

	call ioi_device$assign (gtep, device, controller, dtx, code);
	if code ^= 0 then do;
	     p_code = code;
	     return;
	end;
	gte.n_devices = gte.n_devices + 1;
	call ioi_device$get_dtep (dtx, dtep, code);	/* lock it to us too */
	if code ^= 0 then do;			/* except if there's an error */
	     call cleanup_assign;
	     p_code = code;
	     return;
	end;

	if dte.deleted & ^must_be_deleted then do;
	     call cleanup_assign;
	     p_code = error_table_$io_not_configured;
	     return;
	end;
	if ^dte.deleted & must_be_deleted then do;
	     call cleanup_assign;
	     p_code = error_table_$io_configured;
	     return;
	end;

	if gte.disk_data_subsystem_idx ^= 0 then do;	/* If channels to be taken from page control ... */
	     call ioi_usurp_channels$assign (gtep, code); /* ...get channels for our use. */
	     if code ^= 0 then do;
		call cleanup_assign;
		p_code = code;
		return;
	     end;
	end;
	else if ^gte.mplex then do;			/* channels aren't assigned yet */
	     ctep = ptr (gtep, gte.ctep);		/* there's only one channel */
	     if ^cte.ioi_use then do;
		call io_manager$assign (cte.chx, cte.chanid, ioi_masked$interrupt, bin (rel (ctep)), statusp, code);
		if code = 0 then do;
		     cte.ioi_use = "1"b;
		     cte.statusp = statusp;
		end;
		else do;
		     call cleanup_assign;
		     p_code = code;
		     return;
		end;
	     end;
	end;

/**** Fill in the dte ****/
	dte.cur_ctep = ""b;				/* no channel in use */
	dte.channel_required = "";			/* no channel required */
	dte.ev_chn = eventid;			/* use caller supplied event channel */
	dte.max_bound = IOI_DEFAULT_MAX_BOUND;		/* use defaults */
	dte.max_timeout = IOI_DEFAULT_MAX_TIMEOUT;
	dte.timeout = IOI_DEFAULT_TIMEOUT;
	dte.unwire_time = 0;
	dte.bound = 0;
/****^	dte.process_id...				...has already been set */
	dte.priv = priv;				/* use caller supplied value */
	dte.connected = "0"b;			/* no channel ready to run this device */
	dte.active = "0"b;				/* no I/O to be done yet */
	dte.workspace_wired = "0"b;			/* workspace is not wired yet */
	dte.special_interrupt = "0"b;			/* no special interrupt received */
	dte.log_status_cnt = "0"b;			/* status information not valid yet */
	dte.reading_detailed_status = "0"b;
	dte.detailed_status_valid = "0"b;

/**** Build the workspace ****/
	dte.ring = pds$validation_level;
	dte.ptx = 0;				/* no page table yet */
	dte.status_offset = 0;			/* clear status queue information */
	dte.status_entries = 0;
	dte.status_entry_idx = 0;
	call ioi_workspace$create (dtep, code);
	if code ^= 0 then do;
	     call cleanup_assign;
	     p_code = code;
	     return;
	end;

	call unlock;
	p_dtx = dtx;				/* return the device table index */
	return;

unassign:
     entry (p_dtx, p_code);

	dtx = p_dtx;
	p_code = 0;
	call ioi_device$get_dtep_force (dtx, dtep, code);
	if code ^= 0 then do;
	     p_code = code;
	     return;
	end;

	idp = addr (ioi_data$);
	gtep = ptr (idp, dte.gtep);
	if dte.active then do;			/* if device has unfinished business */
	     call ioi_masked$reset_device (dtep);	/* stop it */
	     do while (dte.active);			/* it will stop eventually */
	     end;
	end;

	if dte.ptx ^= 0 then do;
	     call ioi_page_table$put (dte.ptx, code);
	     dte.ptx = 0;
	     if code ^= 0 then do;
		call unlock;
		p_code = code;
		return;
	     end;
	end;

/**** Destroy the workspace if the process which owns this device is doing the call.  Otherwise, simply unwire it.
      In this case the process is about to go away, and either its process directory is going to be destroyed,
      which will take the workspace with it, or it will be saved in a dead pdir, in which case it may be
      interesting to whoever owned it. ****/

	if dte.process_id = pds$process_id then
	     call ioi_workspace$destroy (dtep, code);	/* get rid of the workspace */
	else do;
	     call ioi_wire$unwire (dtep);		/* unwire it */
	     call ioi_workspace$release_aste (dtep);	/* and let go of its aste */
	end;
	if code ^= 0 then do;
	     call unlock;
	     p_code = code;
	     return;
	end;

	dte.ev_chn = 0;				/* stop notifications */
	dte.channel_required = "";
	call ioi_masked$flush_status (dtep);
	call channel_unassign;
	call ioi_device$unassign (dtep);
	call unlock;
	p_code = 0;
	return;

add_device:
     entry (p_name, p_code);

	dtx = 0;
	locked_for_reconfig = "0"b;
	on cleanup call cleanup_reconfigure;

	call assign_deleted (dtx, p_name, 0, "0"b, code);
	if code ^= 0 then do;
	     p_code = code;
	     return;
	end;

	call ioi_device$get_dtep (dtx, dtep, code);
	if code ^= 0 then do;
	     call cleanup_reconfigure;
	     p_code = code;
	     return;
	end;

	call lock_for_reconfig_proc;
	no_path = "1"b;
	gtep = ptr (dtep, dte.gtep);
	do ctep = ptr (gtep, gte.ctep) repeat ptr (ctep, cte.next_ctep) while (rel (ctep) ^= ""b & no_path);
	     no_path = cte.deleted | cte.deleting;
	end;
	if no_path then do;
	     call cleanup_reconfigure;
	     p_code = error_table_$io_no_path;
	     return;
	end;

	dte.deleted = "0"b;
	io_config_data_ptr = addr (io_config_data$);
	io_config_device_table_ptr = ptr (io_config_data_ptr, io_config_data.device_table_offset);
	device_table.device_entry (dte.device_table_idx).configured = "1"b;
	call cleanup_reconfigure;
	p_code = 0;
	return;

delete_device:
     entry (p_name, p_code);

	dtx = 0;
	locked_for_reconfig = "0"b;
	on cleanup call cleanup_reconfigure;

	call assign (dtx, p_name, 0, "0"b, code);
	if code ^= 0 then do;
	     p_code = code;
	     return;
	end;

	call ioi_device$get_dtep (dtx, dtep, code);
	if code ^= 0 then do;
	     call cleanup_reconfigure;
	     p_code = code;
	     return;
	end;

	if dte.deleted then do;
	     call cleanup_reconfigure;
	     p_code = error_table_$io_not_configured;
	     return;
	end;

	dte.deleted = "1"b;
	io_config_data_ptr = addr (io_config_data$);
	io_config_device_table_ptr = ptr (io_config_data_ptr, io_config_data.device_table_offset);
	device_table.device_entry (dte.device_table_idx).configured = "0"b;
	call cleanup_reconfigure;
	p_code = 0;
	return;

lock_for_reconfig:
     entry;

	call lock_for_reconfig_proc;
	return;

unlock_for_reconfig:
     entry;

	call unlock_for_reconfig_proc;
	return;

cleanup_reconfigure:
     proc;

	if locked_for_reconfig then
	     call unlock_for_reconfig_proc;
	if dtx ^= 0 then do;
	     call ioi_device$unlock (dtep);
	     call unassign (dtx, (0));
	end;

     end cleanup_reconfigure;

lock_for_reconfig_proc:
     proc;

dcl	lock$lock_fast	   entry (ptr);

	idp = addr (ioi_data$);
	if sys_info$service_system then
	     call lock$lock_fast (addr (ioi_data.reconfig_lock));
	locked_for_reconfig = "1"b;

     end lock_for_reconfig_proc;

unlock_for_reconfig_proc:
     proc;

dcl	lock$unlock_fast	   entry (ptr);

	idp = addr (ioi_data$);
	if sys_info$service_system then
	     call lock$unlock_fast (addr (ioi_data.reconfig_lock));
	locked_for_reconfig = "0"b;

     end unlock_for_reconfig_proc;

find_gte:
     proc (name);

dcl	name		   char (4) aligned parameter;

dcl	gtx		   fixed bin;


	do gtx = 1 to ioi_data.ngt;			/* Search for channel name. */
	     gtep = addr (ioi_data.gt (gtx));		/* Get pointer to group table entry. */
	     if gte.name = subsys_name then		/* if this is the one */
		return;
	end;
	gtep = null ();

     end find_gte;

cleanup_assign:
     proc;

	if dtep ^= null () then do;			/* if we've gotten the device */
	     call unlock;
	     call channel_unassign;
	     call ioi_device$unassign (dtep);
	end;

     end cleanup_assign;

channel_unassign:
     proc;

	gte.n_devices = gte.n_devices - 1;
	if gte.disk_data_subsystem_idx ^= 0 then
	     call ioi_usurp_channels$unassign (gtep, (0));
	else if ^gte.mplex then do;
	     ctep = ptr (gtep, gte.ctep);
	     if cte.ioi_use then do;
		call io_manager$unassign (cte.chx, code);
		if code = 0 then
		     cte.ioi_use = "0"b;
	     end;
	end;

     end channel_unassign;

unlock:
     proc;

	call ioi_device$unlock (dtep);

     end unlock;

%include ioi_data;
%page;
%include io_config_data;
%page;
%include io_manager_dcls;

     end ioi_assignment;




		    ioi_config.pl1                  11/11/89  1139.8rew 11/11/89  0801.3       41373



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

/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-01-16,CLJones), install(86-03-21,MR12.0-1033):
     Support FIPS by
     adding "ipc fips" card.
                                                   END HISTORY COMMENTS */

/* config deck searches and the like */

/* Written Patriots' Day, 1983 by Chris Jones */
/* Modified Jan 1985 by Paul Farley to add IPC FIPS. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
ioi_config:
     proc;

dcl	p_chanid		   char (8) aligned;

dcl	chanid		   char (8) aligned;
dcl	channo		   fixed bin (7);
dcl	code		   fixed bin (35);
dcl	iomno		   fixed bin (3);
dcl	portno		   fixed bin;

dcl	config_$find	   entry (char (4) aligned, ptr);

dcl	(divide, hbound, lbound, max, null, substr)
			   builtin;

/* Entry to find the controller (e.g. MPC or IPC) card in the config deck which contains a given channel.
   It returns a pointer to the first such card it finds (there should only be one of them)
   or null if it can't find one. */

find_controller_card:
     entry (p_chanid) returns (ptr);

	call find_controller_card_proc;
	return (mpc_cardp);

/* Entry to return the base channel of the given channel. */

find_base_channel:
     entry (p_chanid) returns (char (8) aligned);

	call find_controller_card_proc;		/* leaves mpc_cardp pointing at the right card */
	if mpc_cardp = null () then
	     return ("");				/* let our caller decide what to make of this */
	if mpc_card.word = IPC_CARD_WORD then do;
	     ipc_cardp = mpc_cardp;
	     if (ipc_card.iom = iomno) & (ipc_card.chan <= channo) & (channo < ipc_card.chan + ipc_card.nchan) then do;
		call io_chnl_util$iom_to_name (ipc_card.iom, (ipc_card.chan), chanid, code);
		if code = 0 then
		     return (chanid);
		else return ("");			/* oh well... */
	     end;
	end;
	if (substr (mpc_card.name, 1, 3) ^= "msp") & (substr (mpc_card.name, 1, 3) ^= "mtp") then
	     return (p_chanid);			/* not a multiplexed MPC, every channel is a base */

	do portno = lbound (mpc_card_array.port, 1) to hbound (mpc_card_array.port, 1);
	     if (mpc_card_array.port (portno).iom = iomno) & (mpc_card_array.port (portno).chan <= channo)
		& (channo < mpc_card_array.port (portno).chan + mpc_card_array.port (portno).nchan) then do;
		call io_chnl_util$iom_to_name (mpc_card_array.port (portno).iom, (mpc_card_array.port (portno).chan),
		     chanid, code);
		if code = 0 then
		     return (chanid);
		else return ("");			/* oh well... */
	     end;
	end;

	return ("");				/* can't happen... */

find_controller_card_proc:
     proc;

	chanid = p_chanid;
	mpc_cardp, ipc_cardp = null ();		/* Start at the beginning of the config deck. */
	call io_chnl_util$name_to_iom (chanid, iomno, channo, code);
	if code ^= 0 then
	     return;				/* illegal chanid, can't be on any mpc card */

	call config_$find (MPC_CARD_WORD, mpc_cardp);	/* find first mpc card */
	do while (mpc_cardp ^= null ());		/* ...or until we find what we're looking for */
	     do portno = lbound (mpc_card_array.port, 1) to hbound (mpc_card_array.port, 1);
		if (mpc_card_array.port (portno).iom = iomno) & (mpc_card_array.port (portno).chan <= channo)
		     & (channo < mpc_card_array.port (portno).chan + mpc_card_array.port (portno).nchan) then
		     return;			/* this is the one */
	     end;
	     call config_$find (MPC_CARD_WORD, mpc_cardp);/* on to the next one */
	end;

	call config_$find (IPC_CARD_WORD, ipc_cardp);	/* find first ipc card */
	do while (ipc_cardp ^= null ());		/* ...or until we find what we're looking for */
	     if ipc_card.type = IPC_FIPS then do;	/* for now only fips */
		if (ipc_card.iom = iomno) & (ipc_card.chan <= channo) & (channo < ipc_card.chan + ipc_card.nchan)
		then do;
		     mpc_cardp = ipc_cardp;		/* this is the one */
		     return;
		end;
	     end;
	     call config_$find (IPC_CARD_WORD, ipc_cardp);/* on to the next one */
	end;
	return;					/* wasn't on any of the card, signal failure */

     end find_controller_card_proc;

%include io_chnl_util_dcls;
%page;
%include config_mpc_card;
%page;
%include config_ipc_card;
     end ioi_config;




		    ioi_connect.pl1                 11/11/89  1139.8r w 11/11/89  0801.3       43785



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */
/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
ioi_connect:
     procedure (p_devx, p_offset, p_code);

/* Rewritten by C. Hornig, June 1982 */
/* Rewrite finished August 1982 by Chris Jones */
/* Modified 1984-08-10 BIM for direct channel support (ignore pcw and offset) */

dcl	p_devx		   fixed bin parameter;	/* (I) device index */
dcl	p_offset		   fixed bin (18) parameter;	/* (I) offset in workspace of DCW list */
dcl	p_pcw		   bit (36) aligned parameter;/* (I) PCW to be used for connect */
dcl	p_code		   fixed bin (35) parameter;	/* (O) status code */

dcl	ioi_device$get_dtep	   entry (fixed bin, ptr, fixed bin (35));
dcl	ioi_device$unlock	   entry (ptr);
dcl	ioi_masked$getwork_device
			   entry (ptr);
dcl	ioi_wire$wire	   entry (ptr);

dcl	error_table_$dev_offset_out_of_bounds
			   fixed bin (35) ext static;
dcl	error_table_$device_active
			   fixed bin (35) ext static;
dcl	error_table_$no_operation
			   fixed bin (35) ext static;
dcl	error_table_$out_of_main_memory
			   fixed bin (35) ext static;
dcl	error_table_$out_of_sequence
			   fixed bin (35) ext static;
dcl	code		   fixed bin (35);
dcl	auto_pcw		   bit (36) aligned;
dcl	devx		   fixed bin;
dcl	offset		   fixed bin (18);

dcl	(addr, binary, pointer)
			   builtin;

	auto_pcw = ""b;				/* default PCW */
	goto common;


ioi_connect_pcw:
     entry (p_devx, p_offset, p_pcw, p_code);

	auto_pcw = p_pcw;				/* user-supplied PCW */
	goto common;


common:
	devx = p_devx;
	offset = p_offset;
	idp = addr (ioi_data$);			/* find databases */
	call ioi_device$get_dtep (devx, dtep, code);	/* lock the device */
	if code ^= 0 then do;
	     p_code = code;
	     return;
	end;

	if dte.active & ^dte.direct then do;		/* already connecting */
	     call unlock;
	     p_code = error_table_$device_active;
	     return;
	end;

	if ^dte.direct then do;
	     if (offset < 0) | (offset >= dte.bound) then do;
						/* offset is patently ridiculous */
BOUNDS_ERR:
		call unlock;
		p_code = error_table_$dev_offset_out_of_bounds;
		return;
	     end;

	     gtep = pointer (idp, dte.gtep);
	     if gte.psia then do;			/* must do special checks for PSIA */
		if (auto_pcw ^= ""b) & ^dte.priv then do;
						/* no PCW unless privileged */
		     call unlock;
		     p_code = error_table_$no_operation;
		     return;
		end;

		call chase_tdcw;			/* skip leading TDCW's */
		dte.idcw_listx = offset;		/* remember where is IDCW */
		idcwp = addr (dte.idcw);
		idcw = pointer (dte.workspace_ptr, offset) -> idcw;
						/* get first IDCW */
		if idcw.code ^= "111"b then do;	/* no valid IDCW */
		     call unlock;
		     p_code = error_table_$no_operation;
		     return;
		end;

/**** Here would be a good place to check for weird device commands which should only be allowed if the controller
      has been attached or the caller is privileged.  However, the MPCs insist that the device code be 0 in this
      case, and the check below will take care of that.  In the case of IPCs, there are currently no such
      commands defined. */

		if ^dte.priv then
		     idcw.device = dte.device;
		else if idcw.device then
		     idcw.device = dte.device;

		offset = offset + 1;		/* now find the next DCW */
		call chase_tdcw;			/* keeping track of TDCW's */
	     end;
	end;					/* direct channels have no control words to check out */

	if dte.ptx = 0 then do;
	     call unlock;
	     p_code = error_table_$out_of_sequence;
	end;
	call ioi_wire$wire (dtep);			/* Wire the buffer */
	if ^dte.workspace_wired then do;		/* couldn't wire it */
	     call unlock;
	     p_code = error_table_$out_of_main_memory;
	     return;
	end;

	if ^dte.direct then
	     dte.listx = offset;			/* where to start in DCW list */
	dte.pcw = auto_pcw;

	call ioi_masked$getwork_device (dtep);		/* find a channel */

	call unlock;				/* release the device */
	p_code = 0;
	return;

/* * * * * * * * * CHASE_TDCW * * * * * * * * * */

chase_tdcw:
     procedure;

	tdcwp = pointer (dte.workspace_ptr, offset);
	if (tdcw.type = "10"b) & (tdcwp -> idcw.code ^= "111"b) then do;
						/* is it a TDCW? */
	     offset = binary (tdcw.address, 18);	/* yes, chase it */
	     if (offset < 0) | (offset >= dte.bound) then
		goto BOUNDS_ERR;
	end;

     end chase_tdcw;


unlock:
     procedure;

	call ioi_device$unlock (dtep);

     end unlock;

%include ioi_data;
%page;
%include iom_pcw;
%include iom_dcw;

     end ioi_connect;




		    ioi_device.pl1                  11/11/89  1139.8rew 11/11/89  0801.3       58329



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

ioi_device:
     procedure;

/* Written May 1982 by C. Hornig for new ioi_ */
/* Finished March 1983 by Chris Jones */
/* Modified April 1984 by Chris Jones to fix bug when unlocking after a dead process. */

/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(85-11-26,CLJones), install(86-03-21,MR12.0-1033):
     Add support for FIPS.
  2) change(86-02-03,Farley), approve(86-07-18,MCR7439),
     audit(86-08-18,Fawcett), install(86-10-20,MR12.0-1189):
     Changed to execute in the BCE environment.
  3) change(86-11-18,Farley), approve(86-11-20,MECR0002),
     audit(86-11-19,Fawcett), install(86-11-20,MR12.0-1222):
     Corrected a race condition with the setting of dte.lock by validating that
     the device is still assigned to the process AFTER getting the lock. (e.g.
     the Initializer had the lock as part of doing a force unassignment of the
     device and now the device table entry is initialized.)
  4) change(86-12-19,Farley), approve(86-12-19,MCR7587),
     audit(86-12-19,Fawcett), install(87-01-05,MR12.0-1253):
     Formal installation to close out above MECR0002.
                                                   END HISTORY COMMENTS */

dcl	p_code		   fixed bin (35) parameter;
dcl	p_device		   bit (6) aligned parameter;
dcl	p_controller	   bit (1) aligned parameter;
dcl	p_devx		   fixed bin parameter;
dcl	p_dtep		   ptr parameter;
dcl	p_gtep		   ptr parameter;

dcl	code		   fixed bin (35);
dcl	device		   bit (6) aligned;
dcl	controller	   bit (1) aligned;
dcl	devx		   fixed bin;
dcl	force_flag	   bit (1) aligned;
dcl	test_processid	   bit (36) aligned;

dcl	ioi_assignment$unassign
			   entry (fixed bin, fixed bin (35));
dcl	lock$lock_fast	   entry (ptr);
dcl	lock$unlock_fast	   entry (ptr);
dcl	tc_util$validate_processid
			   entry (bit (36) aligned, fixed bin (35));

dcl	error_table_$already_assigned
			   fixed bin (35) ext static;
dcl	error_table_$bad_index fixed bin (35) ext static;
dcl	error_table_$bad_ring_brackets
			   fixed bin (35) ext static;
dcl	error_table_$dev_nt_assnd
			   fixed bin (35) ext static;
dcl	error_table_$invalid_device
			   fixed bin (35) ext static;
dcl	error_table_$process_unknown
			   fixed bin (35) ext static;

dcl	pds$process_id	   bit (36) aligned external;
dcl	pds$validation_level   fixed bin (3) external;

dcl	sys_info$service_system
			   bit (1) aligned external static;

dcl	(addr, hbound, lbound, null, ptr, rel, stac, stacq)
			   builtin;

/* * * * * * * * * * GET_DTEP * * * * * * * * * */

get_dtep:
     entry (p_devx, p_dtep, p_code);

	force_flag = "0"b;
	goto get_dtep_join;

get_dtep_force:
     entry (p_devx, p_dtep, p_code);

	force_flag = "1"b;
get_dtep_join:
	devx = p_devx;
	p_dtep = null ();
	p_code = 0;

	idp = addr (ioi_data$);
	if (devx < lbound (ioi_data.dt, 1)) | (devx > hbound (ioi_data.dt, 1)) then do;
	     p_code = error_table_$bad_index;
	     return;
	end;

	dtep, p_dtep = addr (ioi_data.dt (devx));

	if ^force_flag & (dte.process_id ^= pds$process_id) then do;
	     p_code = error_table_$dev_nt_assnd;
	     return;
	end;

	if ^force_flag & (dte.ring < pds$validation_level) then do;
	     p_code = error_table_$bad_ring_brackets;
	     return;
	end;

	if sys_info$service_system then do;
	     call lock$lock_fast (addr (dte.lock));
	     if ^force_flag & (dte.process_id ^= pds$process_id) then do;
		p_code = error_table_$dev_nt_assnd;	/* lost the race */
		call lock$unlock_fast (addr (dte.lock));
		return;
	     end;
	end;
	return;

/* * * * * * * * * * UNLOCK * * * * * * * * * */

unlock:
     entry (p_dtep);

	dtep = p_dtep;
	if sys_info$service_system then
	     call lock$unlock_fast (addr (dte.lock));
	return;

/* * * * * * * * * * ASSIGN * * * * * * * * * */

assign:
     entry (p_gtep, p_device, p_controller, p_devx, p_code);

	gtep = p_gtep;
	device = p_device;
	controller = p_controller;
	idp = addr (ioi_data$);
	call find_dte;
	if dtep = null () then do;
	     p_code = error_table_$invalid_device;
	     return;
	end;

/**** We now try to get control of this device by placing our process_id (PID) in the dte.  If the PID is zero,
      no one else has the device and we will be successful.  If the PID in the dte is non-zero, we check to
      see if the process which controls the device is still alive.  If it is, we give up; the device is under the
      control of that process.  If the PID in the dte is for a non-existant process, we slam our PID on top
      of it.  We use gating instructions (stac and stacq) for all of this since another process on another
      processor may be trying to do the same thing. ****/

	if ^sys_info$service_system then
	     dte.process_id = pds$process_id;		/* If not UP force setting */
	else do while (^stac (addr (dte.process_id), pds$process_id));
	     test_processid = dte.process_id;
	     call tc_util$validate_processid (test_processid, code);
	     if code ^= error_table_$process_unknown then do;
		p_code = error_table_$already_assigned;
		return;
	     end;
	     if stacq (dte.process_id, pds$process_id, test_processid) then do;
						/* grab the device */
		call ioi_assignment$unassign (devx, code);
		if code ^= 0 then do;
		     dte.process_id = ""b;		/* could use stacq, but what if it fails? */
		     p_code = code;
		     return;
		end;
	     end;
	end;

	dte.ring = pds$validation_level;
	p_devx = devx;
	p_code = 0;
	return;

/* * * * * * * * * * UNASSIGN * * * * * * * * * */

unassign:
     entry (p_dtep);

	dtep = p_dtep;
	gtep = ptr (dtep, dte.gtep);
	dte.process_id = ""b;			/* all necessary validation has already been done */
	return;

find_dte:
     proc;

	do devx = 1 to ioi_data.ndt;
	     dtep = addr (ioi_data.dt (devx));
	     if dte.in_use & (rel (gtep) = dte.gtep) & (dte.device = device) & (dte.controller = controller) then
		return;
	end;
	dtep = null ();				/* couldn't find it */
	return;

     end find_dte;

%include ioi_data;

     end ioi_device;




		    ioi_get_status.pl1              11/11/89  1139.8r w 11/11/89  0801.3       24741



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */
/* Written July 1983 by Chris Jones (from ioi_get_special_status). */

/* Program to return either the special status or the detailed status from a given device.  A flag is set
   indicating whether there was any such status to return. */
/* Modified March 1985 by Keith Loepere to properly copy arguments. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
ioi_get_status:
     proc;

dcl	p_dtx		   fixed bin parameter;	/* (I) device table index */
dcl	p_valid		   bit (1) aligned parameter; /* (O) returned status is valid */
dcl	p_special_status	   bit (36) aligned parameter;/* (O) special status */
dcl	p_detailed_status	   bit (216) parameter;	/* (O) detailed status */
dcl	p_code		   fixed bin (35) parameter;	/* (O) status code */

dcl	code		   fixed bin (35);
dcl	detailed_status	   bit (216);
dcl	dtx		   fixed bin;
dcl	special_status	   bit (36) aligned;
dcl	valid		   bit (1) aligned;

dcl	ioi_device$get_dtep	   entry (fixed bin, ptr, fixed bin (35));
dcl	ioi_device$unlock	   entry (ptr);

dcl	unspec		   builtin;

special_status:
     entry (p_dtx, p_valid, p_special_status, p_code);

	call setup;
	if dte.special_interrupt then do;		/* If special interrupt has occurred ... */
	     dte.special_interrupt = "0"b;		/* Clear the flag in table entry. */
	     valid = "1"b;				/* Tell caller special occurred. */
	     special_status = dte.special_status;	/* Give him back the special status. */
	end;

	else do;					/* No special occurred. */
	     valid = "0"b;
	     special_status = "0"b;
	end;
	call ioi_device$unlock (dtep);

	p_valid = valid;
	p_special_status = special_status;
	return;

/* return detailed status */

detailed_status:
     entry (p_dtx, p_valid, p_detailed_status, p_code);

	call setup;
	if dte.detailed_status_valid then do;
	     detailed_status = unspec (dte.detailed_status);
	     valid = "1"b;
	end;
	else do;
	     detailed_status = "0"b;
	     valid = "0"b;
	end;
	call ioi_device$unlock (dtep);

	p_valid = valid;
	p_detailed_status = detailed_status;
	return;

setup:
     proc;

	p_code, code = 0;
	dtx = p_dtx;
	call ioi_device$get_dtep (dtx, dtep, code);
	if code ^= 0 then
	     goto QUIT;

     end setup;

QUIT:
	p_valid = "0"b;
	p_code = code;
	return;

%include ioi_data;

     end ioi_get_status;




		    ioi_set.pl1                     11/11/89  1139.8rew 11/11/89  0801.3       97011



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


/****^  HISTORY COMMENTS:
  1) change(86-03-04,CLJones), approve(86-07-30,MCR7461),
     audit(86-07-31,Coren), install(86-08-19,MR12.0-1120):
     Allow workspace size to be changed when direct channels aren't active;
     allow a status queue for devices attached to direct channels.
  2) change(86-11-17,Farley), approve(86-11-20,MECR0002),
     audit(86-11-19,Fawcett), install(86-11-20,MR12.0-1222):
     Added check for channel being deleted or already deleted to the
     channel_required entry. It will now return a non-zero error code for these
     cases.
  3) change(86-12-19,Farley), approve(86-12-19,MCR7587),
     audit(86-12-19,Fawcett), install(87-01-05,MR12.0-1253):
     Formal installation to close out above MECR0002.
                                                   END HISTORY COMMENTS */


/* Entries to set various IOI parameters (timeout, event channel, etc.) */
/* Started by Charlie Hornig, finished by Chris Jones. */
/* Modified 1984-08-09 BIM for direct channel support */
/* Modified March 1985 by Keith Loepere to properly copy arguments. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
ioi_set:
     procedure;

dcl	p_channel		   fixed bin (7) parameter;
dcl	p_code		   fixed bin (35) parameter;
dcl	p_devx		   fixed bin parameter;
dcl	p_evchn		   fixed bin (71) parameter;
dcl	p_iom		   fixed bin (3) parameter;
dcl	p_count		   fixed bin parameter;
dcl	p_offset		   fixed bin (18) parameter;
dcl	p_ring		   fixed bin (3) parameter;
dcl	p_time		   fixed bin (71) parameter;
dcl	p_workspace_ptr	   ptr parameter;
dcl	p_workspace_size	   fixed bin (19) parameter;

dcl	chanid		   char (8) aligned;
dcl	channel		   fixed bin (7);
dcl	code		   fixed bin (35);
dcl	devx		   fixed bin;
dcl	evchn		   fixed bin (71);
dcl	iom		   fixed bin (3);
dcl	n_entries		   fixed bin;
dcl	offset		   fixed bin (18);
dcl	ring		   fixed bin (3);
dcl	time		   fixed bin (71);
dcl	workspace_ptr	   ptr;
dcl	workspace_size	   fixed bin (19);

dcl	error_table_$bad_channel
			   fixed bin (35) ext static;
dcl	error_table_$bad_ring_brackets
			   fixed bin (35) ext static;
dcl	error_table_$buffer_big
			   fixed bin (35) ext static;
dcl	error_table_$chnl_already_deleted
			   fixed bin (35) ext static;
dcl	error_table_$chnl_being_deleted
			   fixed bin (35) ext static;
dcl	error_table_$dev_offset_out_of_bounds
			   fixed bin (35) ext static;
dcl	error_table_$device_active
			   fixed bin (35) ext static;
dcl	error_table_$no_operation
			   fixed bin (35) ext static;
dcl	error_table_$time_too_long
			   fixed bin (35) ext static;

dcl	pds$validation_level   fixed bin (3) external;
dcl	sys_info$page_size	   fixed bin external;
dcl	sys_info$seg_size_256K fixed bin external;

dcl	ioi_page_table$get	   entry (fixed bin (19), fixed bin, fixed bin (35));
dcl	ioi_page_table$ptx_to_ptp
			   entry (fixed bin) returns (ptr);
dcl	ioi_page_table$put	   entry (fixed bin, fixed bin (35));
dcl	ioi_device$get_dtep	   entry (fixed bin, ptr, fixed bin (35));
dcl	ioi_device$unlock	   entry (ptr);
dcl	ioi_usurp_channels$required
			   entry (ptr, fixed bin (35));
dcl	ioi_wire$unwire	   entry (ptr);
dcl	ioi_workspace$set_rb   entry (ptr, fixed bin (35));
dcl	ioi_workspace$set_max_size
			   entry (ptr, fixed bin (35));

dcl	(divide, null, ptr, rel, size)
			   builtin;

	return;

/* * * * * * * * * * TIMEOUT * * * * * * * * * */

/* Entry to set the time allowed for an I/O operation to complete on this device.  If the device runs longer
   than this, it is stopped and the caller receives a timeout status. */

timeout:
     entry (p_devx, p_time, p_code);

	time = p_time;
	call check_devx;

	if dte.direct then do;
	     call unlock;
	     p_code = error_table_$no_operation;
	     return;
	end;

	if (time > dte.max_timeout) & ^dte.priv then do;
	     call unlock;
	     p_code = error_table_$time_too_long;
	     return;
	end;

	dte.timeout = time;
	call unlock;
	p_code = code;
	return;

/* * * * * * * * * * MAX_TIMEOUT * * * * ** * * * */

/* Privileged entry to set the maximum the timeout value is allowed to be set to. */

max_timeout:
     entry (p_devx, p_time, p_code);

	time = p_time;
	call check_devx;

	dte.max_timeout = time;
	call unlock;
	p_code = code;
	return;

/* * * * * * * * * * EVENT * * * * * * * * * */

/* Entry to set the event channel over which status events are signalled for a device. */

event:
     entry (p_devx, p_evchn, p_code);

	evchn = p_evchn;
	call check_devx;

	dte.ev_chn = evchn;
	call unlock;
	p_code = code;
	return;

/* * * * * * * * * WORKSPACE * * * * * * * * * */

/* Entry to set the current size of the workspace. */

workspace:
     entry (p_devx, p_workspace_ptr, p_workspace_size, p_code);

	workspace_size =
	     divide (p_workspace_size + sys_info$page_size - 1, sys_info$page_size, 17) * sys_info$page_size;
	p_workspace_ptr, workspace_ptr = null ();
	call check_devx;

	if dte.active then do;
	     call unlock;
	     p_code = error_table_$device_active;
	     return;
	end;

	if (workspace_size <= 0) | (workspace_size > dte.max_bound) then do;
	     call unlock;
	     p_code = error_table_$buffer_big;
	     return;
	end;

	if workspace_size < dte.status_offset + dte.status_entries * size (istat) then do;
	     call unlock;
	     p_code = error_table_$dev_offset_out_of_bounds;
	     return;
	end;


	if dte.workspace_wired then
	     call ioi_wire$unwire (dtep);		/* can't be wired */

	dte.bound = workspace_size;
	if dte.ptx ^= 0 then do;
	     call ioi_page_table$put (dte.ptx, code);
	     dte.ptx = 0;				/* so we won't try again */
	     call quit_if_error;
	end;

	if dte.direct then
	     call ioi_page_table$get ((sys_info$seg_size_256K), dte.ptx, code);
	else call ioi_page_table$get (dte.bound, dte.ptx, code);
	call quit_if_error;
	dte.ptp = ioi_page_table$ptx_to_ptp (dte.ptx);
	workspace_ptr = dte.workspace_ptr;
	call unlock;

	p_workspace_ptr = workspace_ptr;
	p_code = code;
	return;

/* * * * * * * * * * MAX_WORKSPACE * * * * * * * * * */

/* Privileged entry to set the maximum workspace size allowed for a device. */

max_workspace:
     entry (p_devx, p_workspace_size, p_code);

	workspace_size =
	     divide (p_workspace_size + sys_info$page_size - 1, sys_info$page_size, 17) * sys_info$page_size;
	call check_devx;

	dte.max_bound = workspace_size;
	call ioi_workspace$set_max_size (dtep, code);
	call quit_if_error;
	call unlock;
	p_code = code;
	return;

/* * * * * * * * * * * LEVEL * * * * * * * * * */

/* Privileged entry to set the highest ring allowed to make IOI calls for a device. */

level:
     entry (p_devx, p_ring, p_code);

	ring = p_ring;
	call check_devx;

	if ring < pds$validation_level then do;
	     call unlock;
	     p_code = error_table_$bad_ring_brackets;
	     return;
	end;

	dte.ring = ring;
	call ioi_workspace$set_rb (dtep, code);
	call quit_if_error;
	call unlock;
	p_code = code;
	return;

/* * * * * * * * * * CHANNEL_REQUIRED * * * * * * * * * */

/* Privileged entry called to set a required channel for a device.  This will restrict the device
   to running on that channel. */

channel_required:
     entry (p_devx, p_iom, p_channel, p_code);

	iom = p_iom;
	channel = p_channel;
	call check_devx;

	if ^dte.priv then do;			/* must have a privileged assignment */
	     call unlock;
	     p_code = error_table_$no_operation;
	     return;
	end;

	if (iom = 0) & (channel = 0) then do;		/* special case, clear requirement */
	     dte.channel_required = "";
	     call unlock;
	     p_code = code;
	     return;
	end;

	call io_chnl_util$iom_to_name (iom, channel, chanid, code);
	if code ^= 0 then do;			/* bogus channel */
	     call unlock;
	     p_code = error_table_$bad_channel;
	     return;
	end;

	if dte.active then do;			/* device must not be running now */
	     call unlock;
	     p_code = error_table_$device_active;
	     return;
	end;

	gtep = ptr (dtep, dte.gtep);
	do ctep = ptr (gtep, gte.ctep) repeat ptr (ctep, cte.next_ctep) while (rel (ctep) ^= ""b);
	     if cte.chanid = chanid then do;		/* found it */

		if cte.deleted then do;		/* can't have a deleted channel */
		     call unlock;
		     p_code = error_table_$chnl_already_deleted;
		     return;
		end;

		if cte.deleting then do;		/* can't have this either */
		     call unlock;
		     p_code = error_table_$chnl_being_deleted;
		     return;
		end;

		if (gte.disk_data_subsystem_idx ^= 0) & ^cte.ioi_use then
						/* must grab channel from disk_control */
		     if ^gte.suspend_devices then do;	/* can't usurp if we're suspended */
			call ioi_usurp_channels$required (ctep, code);
			if code ^= 0 then do;
			     call unlock;
			     p_code = code;
			     return;
			end;
		     end;
		     else do;
			call unlock;
			p_code = error_table_$no_operation;
			return;
		     end;

		dte.channel_required = chanid;
		call unlock;
		p_code = code;
		return;
	     end;
	end;

	call unlock;
	p_code = error_table_$bad_channel;
	return;

/* * * * * * * * * * STATUS * * * * * * * * * */

/* Entry to set the offset (in the workspace) and number of entries in the circular status queue */

status:
     entry (p_devx, p_offset, p_count, p_code);

	offset = p_offset;
	n_entries = p_count;
	call check_devx;

	if (offset < 0) | (n_entries < 0) | (offset + (n_entries * size (istat)) > dte.bound) then do;
	     call unlock;
	     p_code = error_table_$dev_offset_out_of_bounds;
	     return;
	end;

	dte.status_control.status_offset = offset;
	dte.status_control.status_entries = n_entries;
	dte.status_control.status_entry_idx = 0;
	call unlock;
	p_code = code;
	return;

/* Routine to get the dtep given the devx.  It returns with dtep set and the dte locked.  If it cannot do both,
   it does not return, but passes the error code back to this program's caller. */

check_devx:
     procedure;

	p_code, code = 0;
	devx = p_devx;
	call ioi_device$get_dtep (devx, dtep, code);	/* cleverly setting p_code to 0 if all is cool. */
	if code ^= 0 then
	     goto QUIT;

     end check_devx;

/* Routine to unlock the dte */

unlock:
     procedure;

	call ioi_device$unlock (dtep);

     end unlock;

quit_if_error:
     proc;

	if code ^= 0 then do;
	     call unlock;
	     goto QUIT;
	end;

     end quit_if_error;

QUIT:
	p_code = code;
	return;

%include ioi_data;
%page;
%include ioi_stat;
%page;
%include io_chnl_util_dcls;

     end ioi_set;




		    ioi_suspend_devices.pl1         11/11/89  1139.8rew 11/11/89  0801.3       64863



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */
/* ioi_suspend_devices - suspend and restore I/O activity on devices */
/* Rewritten May 1983 by Chris Jones */
/* Modified March 1984 by Chris Jones for IOM reconfiguration. */
/* Modified March 1985 by Keith Loepere to properly copy arguments. */


/****^  HISTORY COMMENTS:
  1) change(86-09-05,Farley), approve(86-07-18,MCR7439),
     audit(86-09-24,Fawcett), install(86-10-20,MR12.0-1189):
     Changed to execute in the BCE environment.
                                                   END HISTORY COMMENTS */


/* This procedure is called by a T&D user to suspend or restore I/O on all other devices sharing the same MPC. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
ioi_suspend_devices:
     proc (p_devx, p_code);

dcl	p_code		   fixed bin (35) parameter;	/* (O) error code */
dcl	p_devx		   fixed bin parameter;	/* (I) device table entry pointer */

dcl	code		   fixed bin (35);
dcl	devx		   fixed bin;
dcl	locked		   bit (1) aligned;		/* set if we've got the dte locked */
dcl	mcp		   ptr;			/* pointer to MPC configuration card */

dcl	ioi_config$find_controller_card
			   entry (char (8) aligned) returns (ptr);
dcl	ioi_device$get_dtep	   entry (fixed bin, ptr, fixed bin (35));
dcl	ioi_device$unlock	   entry (ptr);
dcl	ioi_masked$getwork_channel
			   entry (ptr);
dcl	ioi_masked$quiesce_channel
			   entry (ptr);
dcl	ioi_usurp_channels$suspend
			   entry (ptr, ptr, fixed bin (35));
dcl	ioi_usurp_channels$unassign
			   entry (ptr, fixed bin (35));
dcl	lock$lock_fast	   entry (ptr);
dcl	lock$unlock_fast	   entry (ptr);

dcl	error_table_$no_operation
			   fixed bin (35) ext;

dcl	sys_info$service_system
			   bit (1) aligned external static;

dcl	(addr, null, ptr, rel) builtin;

	call setup;				/* lock device to us */
	if code ^= 0 then
	     goto EXIT;				/* get out if error */

	if gte.disk_data_subsystem_idx ^= 0 then	/* If suspending disk controller ... */
	     if (dte.channel_required = "") |		/* Must already have channel required. */
		^gte.dual_controller then do;		/* Must be dual controller configuration. */
		code = error_table_$no_operation;	/* Otherwise, error. */
		goto EXIT;
	     end;

	call get_channel;
	if code ^= 0 then
	     goto EXIT;

	call walk_channels (stop_channel);		/* Find all channels on MPC. */

	call walk_channels (wait_channel);		/* Wait for all devices to come to a halt. */

	dte.suspended = "0"b;			/* Leave our device usable. */
EXIT:
	if locked then
	     call ioi_device$unlock (dtep);

	p_code = code;
	return;					/* That's all. */

suspend_error:					/* Arrive here by non local goto. */
	call walk_channels (start_channel);		/* Start up all channels again. */
	goto EXIT;

ioi_release_devices:
     entry (p_devx, p_code);

	call setup;				/* Validate call and set up. */
	if code ^= 0 then
	     goto EXIT;

	call get_channel;				/* find channel id */
	if code ^= 0 then
	     goto EXIT;

	call walk_channels (start_channel);		/* Restart all channels on this controller. */
	goto EXIT;				/* And exit. */


setup:
     proc;

	p_code, code = 0;
	devx = p_devx;
	locked = "0"b;
	call ioi_device$get_dtep (devx, dtep, code);
	if code ^= 0 then
	     return;
	locked = "1"b;

	idp = addr (ioi_data$);			/* Get pointer to base of IOI data segment. */
	gtep = ptr (idp, dte.gtep);			/* Get pointer to group table entry for this device. */

	if ^dte.priv | ^gte.psia then			/* Error if not privileged and a PSIA channel. */
	     code = error_table_$no_operation;

     end setup;

get_channel:
     proc;

dcl	chanid		   char (8) aligned;	/* name of channel */

	chanid = "";				/* initialize channel name */
	if dte.channel_required ^= "" then		/* If device requires a channel ... */
	     chanid = dte.channel_required;		/* ...that's the MPC we're interested in. */
	else do ctep = ptr (gtep, gte.ctep) repeat ptr (ctep, cte.next_ctep)
		while ((rel (ctep) ^= "0"b) & (chanid = ""));
	     if cte.ioi_use then			/* If we found a channel ... */
		chanid = cte.chanid;		/* Use that channel */
	end;

	mcp = ioi_config$find_controller_card (chanid);
	if mcp = null () then			/* Pointer should never be null. */
	     code = error_table_$no_operation;

     end get_channel;


walk_channels:
     proc (do_cte);

dcl	do_cte		   entry parameter;

dcl	ctx		   fixed bin;

	do ctx = 1 to ioi_data.nct;			/* Iterate through all channels. */

	     ctep = addr (ioi_data.ct (ctx));		/* Get pointer to channel table entry. */
	     gtep = ptr (idp, cte.gtep);		/* Get pointer to corresponding group table entry. */

	     if ioi_config$find_controller_card (cte.chanid) = mcp then
						/* If this channel is on this controller ... */
		call do_cte;			/* Go perform action on this channel. */
	end;


     end walk_channels;



walk_devices:
     proc (suspended_sw);

dcl	suspended_sw	   bit (1) aligned parameter;

dcl	done		   bit (1) aligned;
dcl	list_head		   bit (18);
dcl	saved_dtep	   ptr;

	saved_dtep = dtep;
	done = "0"b;
	list_head = gte.dtep;
	do dtep = ptr (idp, list_head) repeat ptr (idp, dte.next_dtep) while (^done);
	     if ^sys_info$service_system then
		dte.suspended = suspended_sw;		/* No lock worries at BCE */
	     else do;
		if dtep ^= saved_dtep then
		     call lock$lock_fast (addr (dte.lock));
						/* lock it to ensure this bit gets updated right */
		dte.suspended = suspended_sw;
		if dtep ^= saved_dtep then
		     call lock$unlock_fast (addr (dte.lock));
	     end;
	     done = dte.next_dtep = list_head;
	end;
	dtep = saved_dtep;

     end walk_devices;

stop_channel:
     proc;

	if ^gte.suspend_devices then do;		/* If this group has not yet been suspended ... */
	     if gte.disk_data_subsystem_idx ^= 0 then do; /* If disk, get all channels on controller. */
		call ioi_usurp_channels$suspend (dtep, gtep, code);
		if code ^= 0 then
		     go to suspend_error;
	     end;

	     gte.suspend_devices = "1"b;		/* Suspend all devices in this group. */
	     call walk_devices ("1"b);		/* Walk through list and stop each one. */
	end;

	return;



wait_channel:
     entry;

	call ioi_masked$quiesce_channel (ctep);
	do while (cte.connected | cte.quiescing);	/* Wait for channel to stop. */
	end;

	return;



start_channel:
     entry;

	if gte.suspend_devices then do;		/* If this group is still suspended ... */
	     gte.suspend_devices = "0"b;		/* Allow devices to run again. */
	     if gte.disk_data_subsystem_idx ^= 0 then	/* If disk, get rid of any excess channels. */
		call ioi_usurp_channels$unassign (gtep, code);

	     call walk_devices ("0"b);		/* Walk through list and restore each device. */
	end;

	if cte.ioi_use then				/* start it if it's one of ours */
	     call ioi_masked$getwork_channel (ctep);

     end stop_channel;

%include ioi_data;

     end ioi_suspend_devices;




		    ioi_usurp_channels.pl1          11/11/89  1139.8r w 11/11/89  0801.3      100494



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */
/*
   Rewritten May 1983 by Chris Jones.
   Modified January 1984 by Chris Jones for IOM reconfiguration.
*/

/* This procedure is responsible for managing the sharing of disk subsystem
   channels between page control and the I/O Interfacer.  When channels are
   needed for IOI operation, they are taken away from page control.  When
   IOI no longer needs the channels, they are given back to page control. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
ioi_usurp_channels:
     proc;

dcl	p_code		   fixed bin (35);		/* (O) error code */
dcl	p_ctep		   ptr;			/* (I) pointer to channel table entry */
dcl	p_dtep		   ptr;			/* (I) pointer to device table Entry */
dcl	p_gtep		   ptr;			/* (I) group table entry pointer */

dcl	ctep_to_retain	   ptr;			/* never cede this channel */
dcl	max_chan_count	   fixed bin;		/* maximum number of channels to use */
dcl	mcp		   ptr;			/* pointer to MPC config card */
dcl	required		   bit (1) aligned;		/* "1"b if specific channel required */
dcl	statusp		   ptr;			/* pointer to where io_manager stuffs status */
dcl	used_chan_count	   fixed bin;		/* count of channels in use by IOI */
dcl	usurped		   bit (1) aligned;		/* "1"b if channel successfully usurped */

dcl	config$find_2	   entry (char (4) aligned, char (4) aligned, ptr);
dcl	disk_control$usurp_channel
			   entry (fixed bin (8), fixed bin (35), bit (1) aligned, fixed bin (35), ptr);
dcl	disk_control$cede_channel
			   entry (fixed bin (8), fixed bin (35), fixed bin (35), ptr);
dcl	ioi_config$find_controller_card
			   entry (char (8) aligned) returns (ptr);
dcl	ioi_masked$getwork_channel
			   entry (ptr);
dcl	ioi_masked$quiesce_channel
			   entry (ptr);
dcl	error_table_$no_operation
			   fixed bin (35) ext;

dcl	(max, min, null, ptr, rel)
			   builtin;

assign:
     entry (p_gtep, p_code);				/* entry to usurp enough channels */

	p_code = 0;
	gtep = p_gtep;
	required = "0"b;				/* we'll take any channel */

	used_chan_count = cur_chans ();		/* get count of channels currently usurped */
	max_chan_count = max_chans ();		/* get maximum number to usurp */
	do while (used_chan_count < max_chan_count);	/* try to usurp enough channels */
	     usurped = "0"b;			/* no channel usurped as yet */
	     call walk_channels (usurp_unused);		/* usurp an unused channel */
	     if ^usurped then
		max_chan_count = 0;			/* stop if no usurpable channel usurped */
	end;

	if (used_chan_count <= 0) & (gte.n_devices > 0) then
						/* if no channel was found ... */
	     p_code = error_table_$no_operation;
	return;

/* Routine to usurp exactly one channel.  It is called by walk_channels, and only usurps if no channel has been
   usurped during this walk (i.e. if the variable "usurped" isn't set). */

usurp_unused:
     proc;

	if ^usurped then				/* if no channel usurped as yet ... */
	     if ^(cte.ioi_use | cte.deleted | cte.deleting) then
						/* if channel not already in use ... */
		call usurp_chan;			/* try to grab it */

     end usurp_unused;


/* Entry to cede channels back to disk control when a channel is unassigned. */

unassign:
     entry (p_gtep, p_code);

	ctep_to_retain = null ();
	p_code = 0;
	gtep = p_gtep;
	if gte.suspend_devices then
	     return;				/* cannot cede channels if controller suspended */

unassign_join:
	used_chan_count = cur_chans ();		/* get count of channels currently usurped */
	max_chan_count = max_chans ();		/* get maximum number to usurp */
	do while (used_chan_count > max_chan_count);	/* give back excess channels */
	     usurped = "1"b;			/* no cedable channel ceded as yet */
	     call walk_channels (cede_used);		/* give back one used channel */
	     if usurped then
		return;				/* return if no candidate found */
	end;

	return;

/* Routine to cede exactly one cedable channel.  It works like "usurped_unused", only backwards. */
cede_used:
     proc;

	if (ctep ^= ctep_to_retain)			/* if not holding on to this channel */
	     & usurped				/* if no channel ceded as yet ... */
	     & cte.ioi_use				/* if this channel is in use ... */
	     & ^(cte.deleted | cte.deleting)		/* ...for real */
	     & (^test_chan_req ()) then do;		/* if no device requires this channel ... */
	     call cede_chan;			/* give up the channel */
	     usurped = "0"b;			/* found channel to cede */
	end;

test_chan_req:
	proc returns (bit (1) aligned);		/* internal proc to see if channel required */

dcl	chan_req		   bit (1) aligned;

	     chan_req = "0"b;			/* set if some device requires this channel */
	     call walk_devices (test_req);		/* test each device */
	     return (chan_req);

/* sets chan_req if the given channel is required by the given device (where the given entities are pointed to
   by ctep and dtep respectively). */

test_req:
	     proc;

		if dte.channel_required = cte.chanid then
		     chan_req = "1"b;		/* set bit if channel is required */

	     end test_req;

	end test_chan_req;

     end cede_used;

/* Entry to usurp a given channel. */

required:
     entry (p_ctep, p_code);

	p_code = 0;
	ctep = p_ctep;

	gtep = ptr (ctep, cte.gtep);			/* get pointer to group table entry */
	if gte.suspend_devices then do;		/* cannot do this if controller suspended */
	     p_code = error_table_$no_operation;
	     return;
	end;

	required = "1"b;				/* we need this specific channel */
	usurped = "0"b;
	do while (^usurped);
	     ctep = p_ctep;				/* grab desired channel, now */
	     call usurp_chan;

	     if ^usurped then do;			/* if we did not get desired channel ... */
		if cte.deleting then do;		/* can't give any back since we're about to lose this one */
		     p_code = error_table_$no_operation;
		     return;
		end;
		usurped = "1"b;			/* no channel to cede found yet */
		call walk_channels (cede_used);	/* cede one channel */
		if usurped then do;			/* if no other candidate for ceding ... */
		     p_code = error_table_$no_operation;
		     return;
		end;
	     end;					/* now try again */
	end;

	ctep_to_retain = ctep;
	goto unassign_join;				/* cede excess channels */
/****	never returns	****/


ioi_usurp_channels$suspend:
     entry (p_dtep, p_gtep, p_code);

	p_code = 0;
	dtep = p_dtep;
	gtep = p_gtep;
	required = "1"b;				/* specific channels are required */

	mcp = ioi_config$find_controller_card (dte.channel_required);
						/* Get pointer to MPC card for this channel. */

	if test_other_controller () then do;		/* No channels may be required for other controller. */
	     p_code = error_table_$no_operation;
	     return;
	end;

	call walk_channels (usurp_controller);		/* Grab all channels on this controller. */

	return;



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

dcl	other_controller	   bit (1) aligned init ("0"b);
						/* set to "1"b if channel on other controller required */


	call walk_devices (test_controller);		/* See if any device requires other controller. */

	return (other_controller);			/* Return bit setting. */



test_controller:
	proc;

	     if dte.channel_required ^= "" then		/* If this device requires a channel ... */
		if mcp ^= ioi_config$find_controller_card (dte.channel_required) then
		     other_controller = "1"b;		/* Channel should be on same controller. */

	     return;


	end test_controller;

     end test_other_controller;


usurp_controller:
     proc;

dcl	same_controller	   bit (1) aligned;		/* "1"b if two channels share same MPC */

	same_controller = (mcp = ioi_config$find_controller_card (cte.chanid));

	if cte.ioi_use then				/* If channel already in use ... */
	     if ^same_controller then			/* If channel on another MPC ... */
		call cede_chan;			/* Give it up. */
	     else ;
	else					/* If channel not in use ... */
	     if same_controller & ^cte.deleted then do;	/* If channel on this MPC ... */
	     call usurp_chan;			/* Usurp it now. */
	     if ^usurped then
		goto suspend_failure;		/* Abort everything if channel not available. */
	end;

	return;


     end usurp_controller;



suspend_failure:
	call unassign (gtep, p_code);			/* Adjust usurped channels properly. */

	p_code = error_table_$no_operation;		/* Couldn't get desired channel on controller. */

	return;


max_chans:
     proc returns (fixed bin);

	call config$find_2 ("udsk", gte.name, udsk_cardp);/* Search for UDSK card. */
	if udsk_cardp ^= null () then			/* If card found ... */
	     return (min (max (udsk_card.nchan, 1), gte.n_devices));
						/* Allow at least one channel. */
	else					/* Otherwise ... */
	     return (min (gte.n_devices, 1));		/* Usurp only one channel. */


     end max_chans;



cur_chans:
     proc returns (fixed bin);

dcl	count		   fixed bin;		/* count of usurped channels */


	count = 0;				/* Initialize count. */

	call walk_channels (count_used);		/* Count all usurped channels. */

	return (count);				/* And return the count. */



count_used:
	proc;

	     if cte.ioi_use then			/* Count surped channels. */
		count = count + 1;


	end count_used;

     end cur_chans;


walk_channels:
     proc (examine_channel);

dcl	examine_channel	   entry;

	do ctep = ptr (gtep, gte.ctep) repeat ptr (gtep, cte.next_ctep) while (rel (ctep) ^= ""b);
	     call examine_channel;			/* check out channel. */
	end;

     end walk_channels;

walk_devices:
     proc (examine_device);

dcl	examine_device	   entry;

dcl	done		   bit (1) aligned;
dcl	list_head		   bit (18);

	done = "0"b;
	list_head = gte.dtep;
	do dtep = ptr (gtep, list_head) repeat ptr (gtep, dte.next_dtep) while (^done);
	     call examine_device;			/* check out device. */
	     done = (dte.next_dtep = list_head);
	end;

     end walk_devices;


usurp_chan:
     proc;

	call disk_control$usurp_channel ((gte.disk_data_subsystem_idx), (cte.disktab_ctx), required, cte.chx, statusp);
						/* Take channel from disk control. */
	usurped = (cte.chx ^= 0);
	if ^usurped then
	     return;				/* Return now if channel not usurped. */

	cte.statusp = statusp;
	cte.ioi_use = "1"b;				/* Place channel in use for IOI. */
	used_chan_count = used_chan_count + 1;		/* Keep track of count. */
	call ioi_masked$getwork_channel (ctep);		/* use the channel if possible */

     end usurp_chan;



cede_chan:
     proc;					/* internal procedure to return disk channel */


	call ioi_masked$quiesce_channel (ctep);
	do while (cte.connected | cte.quiescing);	/* Wait for channel to stop. */
	end;
	cte.ioi_use = "0"b;				/* Take channel away from IOI. */
	used_chan_count = used_chan_count - 1;		/* Keep track of count. */

	call disk_control$cede_channel ((gte.disk_data_subsystem_idx), (cte.disktab_ctx), cte.chx, (cte.statusp));
						/* Give channel back to disk control. */

     end cede_chan;

%include ioi_data;
%page;
%include config_udsk_card;

     end ioi_usurp_channels;




		    ioi_verify_lock.pl1             11/11/89  1139.8rew 11/11/89  0801.3       34209



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

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

/* Program to unlock any locks a process has when it crawls out. */
/* Written 1 August 1983 by Chris Jones. */
/* Modified 1985-03-28, EJ Sharpe: log unlocks, return bit(1) */


/****^  HISTORY COMMENTS:
  1) change(85-10-01,Farley), approve(86-07-18,MCR7439),
     audit(86-08-18,Fawcett), install(86-10-20,MR12.0-1189):
     Changed to execute in the BCE environment.
                                                   END HISTORY COMMENTS */


dcl	dtx		   fixed bin;
dcl	gtx		   fixed bin;

dcl	unlocked_something	   bit (1) aligned;

dcl	addr		   builtin;

dcl	lock$unlock_fast	   entry (ptr);
dcl	syserr		   entry () options (variable);

dcl	pds$process_id	   external bit (36) aligned;
dcl	pds$process_group_id   external char (32);

dcl	sys_info$service_system
			   bit (1) aligned external static;

dcl	stacq		   builtin;


	unlocked_something = "0"b;
	if ^sys_info$service_system then
	     return (unlocked_something);		/* not up far enough to worry about it */
	idp = addr (ioi_data$);
	if unlock_needed (ioi_data.reconfig_lock) then
	     call syserr (SYSERR_LOG_OR_PRINT, "ioi_verify_lock: Force unlocked reconfigure lock for ^a.",
		pds$process_group_id);

	do dtx = 1 to ioi_data.ndt;
	     dtep = addr (ioi_data.dt (dtx));
	     if unlock_needed (dte.lock) then
		call syserr (SYSERR_LOG_OR_PRINT, "ioi_verify_lock: Force unlocked device entry lock #^d for ^a.",
		     dtx, pds$process_group_id);
	end;

	do gtx = 1 to ioi_data.ngt;
	     gtep = addr (ioi_data.gt (gtx));
	     if gte.lock = pds$process_id then do;
		if stacq (gte.lock, ""b, pds$process_id) then
		     ;
		call syserr (SYSERR_LOG_OR_PRINT, "ioi_verify_lock: Force unlocked group entry lock #^d for ^a.", gtx,
		     pds$process_group_id);
		unlocked_something = "1"b;
	     end;
	end;

	return (unlocked_something);

/* Procedure which does the actual unlocking.  It assumes all locks it is called with are fast locks,
   and unlocks the lock if it is held by this process. */

unlock_needed:
     proc (lock_in_question) returns (bit (1) aligned);

dcl	1 lock_in_question	   like lock aligned parameter;

	lock_ptr = addr (lock_in_question);
	if lock.pid = pds$process_id then do;
	     call lock$unlock_fast (lock_ptr);
	     unlocked_something = "1"b;
	     return ("1"b);
	end;
	else return ("0"b);

     end unlock_needed;

%include ioi_data;

%include syserr_constants;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   ioi_verify_lock: Force unlocked reconfigure lock for USERID.

   S:	$info

   T:	$run

   M:	$err
   The process encountered a condition in ring-0 which forced a
   crawlout.  IOI unlocks all locks for the process.

   A:	$notify


   Message:
   ioi_verify_lock: Force unlocked device entry lock #N for USERID.

   S:	$info

   T:	$run

   M:	$err
   The process encountered a condition in ring-0 which forced a
   crawlout.  IOI unlocks all locks for the process.

   A:	$notify


   Message:
   ioi_verify_lock: Force unlocked group entry lock for USERID.

   S:	$info

   T:	$run

   M:	$err
   The process encountered a condition in ring-0 which forced a
   crawlout.  IOI unlocks all locks for the process.

   A:	$notify

   END MESSAGE DOCUMENTATION */

     end ioi_verify_lock;




		    ioi_workspace.pl1               11/11/89  1139.8rew 11/11/89  0801.3       77499



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

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */

ioi_workspace:
     proc;

/* ioi_workspace--creation, deletion, and ring bracket setting entries for the IOI workspace */
/* Written March 1983 by Chris Jones (based on ioi_buffer) */


/****^  HISTORY COMMENTS:
  1) change(85-10-01,Farley), approve(86-07-18,MCR7439),
     audit(86-08-18,Fawcett), install(86-10-20,MR12.0-1189):
     Changed to execute in the BCE environment.
  2) change(86-11-17,Farley), approve(86-11-20,MECR0002),
     audit(86-11-19,Fawcett), install(86-11-20,MR12.0-1222):
     Added check to unwire any active workspace pages before releasing the
     workspace in the set_max_size entry.
  3) change(86-12-19,Farley), approve(86-12-19,MCR7587),
     audit(86-12-19,Fawcett), install(87-01-05,MR12.0-1253):
     Formal installation to close out above MECR0002.
  4) change(87-04-27,Farley), approve(87-07-06,MCR7717),
     audit(87-07-13,Lippard), install(87-07-17,MR12.1-1043):
     Changed code to use bce_early_ioi_workspace when the bootload_temp_N
     segments are not yet available.
                                                   END HISTORY COMMENTS */


dcl	p_code		   fixed bin (35);		/* error code (O) */
dcl	p_dtep		   ptr;			/* pointer to dte (I) */

dcl	code		   fixed bin (35);		/* local error code */
dcl	dname		   char (168);		/* workspace segment directory name */
dcl	ename		   char (32);		/* workspace segment name */
dcl	rba		   (3) fixed bin (3);	/* ring bracket array */
dcl	workspace_segno	   fixed bin (17);		/* seg# for finding astep */
dcl	validation_level	   fixed bin (3);		/* current validation level */

dcl	bce_early_ioi_workspace$
			   bit (36) aligned external static;
dcl	dseg$		   (0:1023) fixed bin (71) external static;
dcl	pds$process_dir_name   char (32) ext;
dcl	sys_info$service_system
			   bit (1) aligned external static;

dcl	append$branch	   entry (char (*), char (*), fixed bin (5), fixed bin (35));
dcl	delentry$dseg	   entry (ptr, fixed bin (35));
dcl	fs_get$path_name	   entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	get_ptrs_$given_astep  entry (ptr) returns (fixed bin (71));
dcl	get_ptrs_$given_segno  entry (fixed bin (17)) returns (ptr);
dcl	get_temp_segment_	   entry (char (*), ptr, fixed bin (35));
dcl	grab_aste$grab_aste_io entry (ptr, fixed bin (19), fixed bin (35)) returns (ptr);
dcl	grab_aste$release_io   entry (ptr);
dcl	initiate		   entry (char (*), char (*), char (*), fixed bin (1), fixed bin (1), ptr, fixed bin (35));
dcl	ioi_wire$unwire	   entry (ptr);
dcl	level$get		   entry returns (fixed bin (3));
dcl	level$set		   entry (fixed bin (3));
dcl	release_temp_segment_  entry (char (*), ptr, fixed bin (35));
dcl	ringbr_$set	   entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
dcl	sdw_util_$get_valid	   entry (ptr) returns (bit (1) aligned);
dcl	set$max_length_ptr	   entry (ptr, fixed bin (19), fixed bin (35));
dcl	slt_manager$get_seg_ptr
			   entry (char (32) aligned) returns (ptr);
dcl	unique_chars_	   entry (bit (*)) returns (char (15));

dcl	(addr, baseno, fixed, null)
			   builtin;

	return;

create:
     entry (p_dtep, p_code);

	dtep = p_dtep;
	p_code = 0;

	if ^sys_info$service_system then do;		/* at BCE */
	     if ^(sdw_util_$get_valid (addr (dseg$ (fixed (baseno (slt_manager$get_seg_ptr ("bootload_temp_1")), 18)))))
		then
		dte.workspace_ptr = addr (bce_early_ioi_workspace$);
						/* temp segments not yet available */
	     else do;
		call get_temp_segment_ ("ioi_workspace", dte.workspace_ptr, code);
						/* bootload_temp_XX segment */
		if code ^= 0 then do;		/* unable to continue */
		     p_code = code;
		     return;
		end;
	     end;

	     workspace_segno = fixed (baseno (dte.workspace_ptr), 17);
	     dte.workspace_astep = get_ptrs_$given_segno (workspace_segno);
	     dte.workspace_sdw = get_ptrs_$given_astep (dte.workspace_astep);
	     return;
	end;

	dname = pds$process_dir_name;			/* the workspace lives in our process directory */
	ename = unique_chars_ ("0"b) || ".ioi";		/* create unique workspace segment name. */

	validation_level = level$get ();		/* save current validation level */
	call level$set (0);				/* set hardcore ring validation level */

	call append$branch (dname, ename, RW_ACCESS_BIN, code);
	call quit_if_error;
	call initiate (dname, ename, "", 0b, 1b, dte.workspace_ptr, code);
	call quit_if_error;
	call set_rb_proc;				/* set the ring brackets */
	call set$max_length_ptr (dte.workspace_ptr, dte.max_bound, code);
	call grab;
	call quit_if_error;

	call level$set (validation_level);		/* restore original validation level */
	return;

destroy:
     entry (p_dtep, p_code);

	dtep = p_dtep;
	p_code = 0;

	if ^sys_info$service_system then do;		/* at BCE */
	     if sdw_util_$get_valid (addr (dseg$ (fixed (baseno (slt_manager$get_seg_ptr ("bootload_temp_1")), 18))))
	     then do;
		if dte.workspace_wired then		/* if segment is active */
		     call ioi_wire$unwire (dtep);	/* unwire the pages NOW */
		call release_temp_segment_ ("ioi_workspace", dte.workspace_ptr, code);
						/* bootload_temp_XX segment */
		if code ^= 0 then do;
		     p_code = code;
		     return;
		end;
	     end;

	     dte.workspace_ptr = null ();
	     dte.workspace_astep = null ();
	     dte.workspace_sdw = 0;
	     return;
	end;

	if dte.workspace_wired then			/* if segment is active */
	     call ioi_wire$unwire (dtep);		/* unwire the pages NOW */

	if dte.workspace_ptr ^= null () then do;	/* if workspace exists... */
	     validation_level = level$get ();		/* save current validation level */
	     call level$set (0);			/* set hardcore ring validation level */

	     call release;
	     call delentry$dseg (dte.workspace_ptr, code);
	     call quit_if_error;
	     dte.workspace_ptr = null ();

	     call level$set (validation_level);		/* restore original validation level */
	end;

	return;

release_aste:
     entry (p_dtep);

	dtep = p_dtep;
	if ^sys_info$service_system then
	     dte.workspace_astep = null ();
	else call release;
	return;

set_max_size:
     entry (p_dtep, p_code);

	dtep = p_dtep;
	p_code = 0;

	if ^sys_info$service_system then
	     return;				/* No need at BCE */

	if dte.workspace_ptr ^= null () then do;	/* if workspace exists */
	     if dte.workspace_wired then
		call ioi_wire$unwire (dtep);		/* unwire active pages */
	     validation_level = level$get ();
	     call level$set (0);
	     call release;
	     call set$max_length_ptr (dte.workspace_ptr, dte.max_bound, code);
	     call quit_if_error;
	     call grab;
	     call level$set (validation_level);
	end;
	return;

set_rb:
     entry (p_dtep, p_code);

	dtep = p_dtep;
	p_code = 0;

	if ^sys_info$service_system then
	     return;				/* No need at BCE */

	if dte.workspace_ptr ^= null () then do;	/* if workspace exists */
	     validation_level = level$get ();
	     call level$set (0);
	     call fs_get$path_name (dte.workspace_ptr, dname, (0), ename, code);
	     call quit_if_error;
	     call set_rb_proc;
	     call level$set (validation_level);
	end;
	return;

set_rb_proc:
     proc;

	rba (*) = dte.ring;				/* set up ring bracket array */
	call ringbr_$set (dname, ename, rba, code);	/* change the ring brackets of the workspace segment */
	call quit_if_error;

     end set_rb_proc;

/* routine to grab the aste and get the sdw */

grab:
     proc;

	if dte.max_bound ^= 0 then do;
	     dte.workspace_astep = grab_aste$grab_aste_io (dte.workspace_ptr, dte.max_bound, code);
	     call quit_if_error;
	     dte.workspace_sdw = get_ptrs_$given_astep (dte.workspace_astep);
	end;

     end grab;

/* routine to release the aste */

release:
     proc;

	if dte.workspace_astep ^= null () then do;
	     call grab_aste$release_io (dte.workspace_astep);
	     dte.workspace_astep = null ();
	end;

     end release;

quit_if_error:
     proc;

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

     end quit_if_error;

quit:
     proc (code);

dcl	code		   fixed bin (35) parameter;

	call level$set (validation_level);
	p_code = code;
	goto QUIT;

     end quit;

QUIT:
	return;

%include ioi_data;
%page;
%include access_mode_values;

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