



		    cross_ring_.pl1                 11/04/82  2005.6rew 11/04/82  1610.3      112716



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


/* format: style2 */
cross_ring_:
     procedure;
	return;

/* CROSS_RING_ - cross-ring iox attachment.

   This program runs in the outer ring. It attaches the outer ring IOCB to a gate
   into the appropriate inner ring.

   THVV 2/77 
   April 1981:
   Fixed bug whereby inner ring close entrypoint was called instead
   of cross_ring_close entry in this program. --Benson I. Margulies.

   November 1981:
   Fixed to use newer inner/outer ring protocol, cleaned up -- BIM */
/* 10/82 BIM: fixed att_err to use c instead of code uniformly */

/* parameters */

	dcl     iocb_ptr		 ptr;		/* pointer to cross_ring_ iocb */
	dcl     attach_param	 (*) char (*) varying;
						/* param list for attach */
	dcl     com_err_sw		 bit (1);		/* call com_err on error if "1"b */
	dcl     return_code		 fixed bin (35);	/* return error to caller */
	dcl     open_mode		 fixed bin;	/* open mode for open call only */
	dcl     dummy		 bit (1);		/* extend sw for open call only */

/* automatic storage */

	dcl     target_ring		 fixed bin;
	dcl     save_mask		 bit (36) aligned;	/* save ips mask here */
	dcl     code		 fixed bin (35);	/* for error codes */
	dcl     inner_index		 bit (72) aligned;
	dcl     myname		 char (11) static options (constant) init ("cross_ring_");
	dcl     act_iocb_ptr	 ptr;		/* store actual iocb pointer here on most calls */

	dcl     system_free_area	 area based (get_system_free_area_ ());

/* entry variables */

	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin);
	dcl     cu_$level_get	 entry () returns (fixed bin);
	dcl     (
	        hcs_$set_ips_mask,
	        hcs_$reset_ips_mask
	        )			 entry (bit (36) aligned, bit (36) aligned);
	dcl     com_err_		 entry options (variable);
	dcl     sub_err_		 entry () options (variable);
	dcl     get_system_free_area_	 entry () returns (ptr);



	dcl     cross_ring_gates_ptr_	 external static pointer unaligned init (null ());

INIT_GATES:
     procedure () returns (pointer unaligned);
	dcl     gp		 pointer unaligned;

	allocate gates set (gp);
	gp -> gates (*) = null_entry;
	return (gp);
     end INIT_GATES;

null_entry:					/* Used to initialize entry variables to known state */
     entry;
	return;

	dcl     1 gates		 (7) aligned based (cross_ring_gates_ptr_),
		2 dispatch_find_attachment
				 variable entry (char (*), bit (72) aligned, fixed bin (35)),
		2 dispatch_release_attachment
				 variable entry (bit (72) aligned, fixed bin (35)),
		2 dispatch_open	 variable entry (bit (72) aligned, fixed bin, bit (1), fixed bin (35)),
		2 dispatch_close	 variable entry (bit (72) aligned, fixed bin (35)),
		2 dispatch_modes	 variable entry,
		2 dispatch_control	 variable entry,
		2 dispatch_position	 variable entry,
		2 dispatch_put_chars variable entry,
		2 dispatch_get_line	 variable entry,
		2 dispatch_get_chars variable entry,
		2 dispatch_read_length
				 variable entry,
		2 dispatch_seek_key	 variable entry,
		2 dispatch_read_key	 variable entry,
		2 dispatch_write_record
				 variable entry,
		2 dispatch_read_record
				 variable entry,
		2 dispatch_rewrite_record
				 variable entry,
		2 dispatch_delete_record
				 variable entry;



/* Conditions */

	declare (cleanup, area, bad_area_format)
				 condition;

/* external variables */

	dcl     (
	        error_table_$bad_mode,
	        error_table_$not_open,
	        error_table_$smallarg,
	        error_table_$bad_conversion,
	        error_table_$badringno,
	        error_table_$noalloc
	        )			 ext static fixed bin (35);
	dcl     error_table_$bad_arg	 fixed bin (35) ext;
	dcl     error_table_$not_detached
				 external fixed bin (35);
	dcl     error_table_$wrong_no_of_args
				 external fixed bin (35);

/* built in fuctions */

	dcl     (size, hbound, addr, length, null, index, search, substr, ptr, fixed)
				 builtin;

%include cross_ring_attach_data_;

%include iocb;

%include iox_modes;
%include iox_entries;



/* cross_ring_attach entry point to attach cross_ring_ to a switch. sample command call would be:

   io_call attach x cross_ring_ target ringno

   cross_ring_ sets the pointers in the iocb to a gate, dispatch_ which
   crosses into inner ring, and calls a pl1 program cross_ring_ring_io_ to drop validation level and forward.
*/

cross_ring_attach:
     entry (iocb_ptr, attach_param, com_err_sw, return_code);

	if cross_ring_gates_ptr_ = null
	then cross_ring_gates_ptr_ = INIT_GATES ();

	save_mask = ""b;
	attach_data_ptr = null;
	inner_index = ""b;
	target_ring = 0;

	on cleanup call clean_up_attach;

	if hbound (attach_param, 1) ^= 2
	then call att_err (error_table_$wrong_no_of_args, "Usage: cross_ring_ target_switch ringno.");

	target_ring = cv_dec_check_ ((attach_param (2)), code);
	if code ^= 0
	then call att_err (error_table_$bad_conversion, attach_param (2) || " is not a valid integer.");
	if target_ring < 1
	then call att_err (error_table_$smallarg,
		attach_param (2) || " is less than one. Cross Ring I/O to ring zero is not possible.");
	if target_ring > cu_$level_get ()
	then call att_err (error_table_$badringno,
		attach_param (2) || " is not less than or equal to the current validation level.");

/* We initialize only one ring's worth of entry variables because the
   system only provides the gates r1_io_ through r4_io_. We would take
   linkage errors on any others, but the user might have provided them. */

	call init_one_ring (target_ring, return_code);
	if return_code ^= 0
	then call att_err (return_code, "No cross ring I/O available for ring " || attach_param (2));

/* Locate the inner ring switch (which must exist already) */

	call dispatch_find_attachment (target_ring) ((attach_param (1)), inner_index, code);
	if code ^= 0
	then call att_err (code, attach_param (1) || " is not a valid inner ring switch.");

/* Prevent multiple attachment */

	call hcs_$set_ips_mask ("0"b, save_mask);
	if iocb_ptr -> iocb.attach_descrip_ptr ^= null
	then call att_err (error_table_$not_detached, "");


	on area, bad_area_format
	     begin;
		goto NO_ALLOC;
	     end;

	allocate attach_data set (attach_data_ptr) in (system_free_area);

/* fill in iocb with things required by attach */

	iocb_ptr -> iocb.attach_data_ptr = attach_data_ptr;
	iocb_ptr -> iocb.attach_descrip_ptr = addr (attach_data.atd);
	iocb_ptr -> iocb.open = cross_ring_open;
	iocb_ptr -> iocb.detach_iocb = cross_ring_detach;
	iocb_ptr -> iocb.modes = dispatch_modes (target_ring);
	iocb_ptr -> iocb.control = dispatch_control (target_ring);
	attach_data.atd = myname || " " || attach_param (1) || " " || attach_param (2);
	attach_data.inner_index = inner_index;
	attach_data.target_ring = target_ring;

	call iox_$propagate (iocb_ptr);
	call hcs_$reset_ips_mask (save_mask, save_mask);

	return_code = 0;
	return;

NO_ALLOC:
	call att_err (error_table_$noalloc, "Could not allocate space for attach data.");

/* some error occured during cross_ring_attach */

att_err:
     procedure (c, r);
	declare c			 fixed bin (35);
	declare r			 character (*);

	if save_mask ^= ""b
	then call hcs_$reset_ips_mask (save_mask, save_mask);

	if com_err_sw
	then call com_err_ (c, myname, "^a", r);
	else call sub_err_ (c, myname, "c", null (), (0), "^a", r);
	return_code = c;
	go to RETURN;
     end att_err;
RETURN:
	return;

/* entry point to detach cross_ring_ */

cross_ring_detach:
     entry (iocb_ptr, return_code);

	save_mask = ""b;
	on cleanup call clean_up;

	call hcs_$set_ips_mask (""b, save_mask);
	act_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	attach_data_ptr = act_iocb_ptr -> iocb.attach_data_ptr;
	inner_index = attach_data.inner_index;
	target_ring = attach_data.target_ring;
	iocb_ptr -> iocb.attach_descrip_ptr = null;
	call iox_$propagate (iocb_ptr);
	call hcs_$reset_ips_mask (save_mask, save_mask);
	call dispatch_release_attachment (target_ring) (inner_index, code);
	return_code = 0;
	return;

/* entry point to open cross_ring_ */

cross_ring_open:
     entry (iocb_ptr, open_mode, dummy, return_code);

	if (open_mode < lbound (iox_modes, 1)) | (open_mode > hbound (iox_modes, 1))
	then do;
		return_code = error_table_$bad_mode;
		return;
	     end;
	save_mask = ""b;
	on cleanup call clean_up;

	if return_code ^= 0
	then return;

	call hcs_$set_ips_mask (""b, save_mask);
	act_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	attach_data_ptr = act_iocb_ptr -> iocb.attach_data_ptr;
	target_ring = attach_data.target_ring;

	act_iocb_ptr -> iocb.close = cross_ring_close;	/* close up shop inside too */
	act_iocb_ptr -> iocb.position = dispatch_position (target_ring);
	if (open_mode = Stream_output) | (open_mode = Stream_input_output)
	then act_iocb_ptr -> iocb.put_chars = dispatch_put_chars (target_ring);
	if (open_mode = Stream_input) | (open_mode = Stream_input_output)
	then act_iocb_ptr -> iocb.get_line = dispatch_get_line (target_ring);
	if (open_mode = Stream_input) | (open_mode = Stream_input_output)
	then act_iocb_ptr -> iocb.get_chars = dispatch_get_chars (target_ring);
	if open_mode > Stream_input_output
	then do;
		act_iocb_ptr -> iocb.read_length = dispatch_read_length (target_ring);
		act_iocb_ptr -> iocb.seek_key = dispatch_seek_key (target_ring);
		act_iocb_ptr -> iocb.read_key = dispatch_read_key (target_ring);
		act_iocb_ptr -> iocb.write_record = dispatch_write_record (target_ring);
		act_iocb_ptr -> iocb.read_record = dispatch_read_record (target_ring);
		act_iocb_ptr -> iocb.rewrite_record = dispatch_rewrite_record (target_ring);
		act_iocb_ptr -> iocb.delete_record = dispatch_delete_record (target_ring);
	     end;
	attach_data.open = iox_modes (open_mode);
	attach_data.open_mode = open_mode;
	act_iocb_ptr -> iocb.open_descrip_ptr = addr (attach_data.open);
	inner_index = attach_data.inner_index;
	call iox_$propagate (act_iocb_ptr);
	call hcs_$reset_ips_mask (save_mask, save_mask);

	call dispatch_open (target_ring) (inner_index, open_mode, dummy, return_code);

	return;

/* entry to close cross_ring_ */

cross_ring_close:
     entry (iocb_ptr, return_code);

	save_mask = ""b;
	on cleanup call clean_up;

	call hcs_$set_ips_mask (""b, save_mask);
	act_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
	act_iocb_ptr -> iocb.open_descrip_ptr = null;
	act_iocb_ptr -> iocb.open = cross_ring_open;
	act_iocb_ptr -> iocb.detach_iocb = cross_ring_detach;
	attach_data_ptr = act_iocb_ptr -> iocb.attach_data_ptr;
	inner_index = attach_data.inner_index;
	target_ring = attach_data.target_ring;
	call iox_$propagate (act_iocb_ptr);
	call hcs_$reset_ips_mask (save_mask, save_mask);

	call dispatch_close (target_ring) (inner_index, return_code);
	if return_code = error_table_$not_open
	then return_code = 0;
	return;

clean_up_attach:
     procedure;
	if inner_index ^= ""b
	then call dispatch_release_attachment (target_ring) (inner_index, (0));
clean_up:
     entry;
	if save_mask ^= ""b
	then call hcs_$reset_ips_mask (save_mask, save_mask);
     end clean_up_attach;

init_one_ring:
     procedure (ring, code);
	declare ring		 fixed bin;
	declare code		 fixed bin (35);
	declare hbound		 builtin;
	declare entrypoints		 (17) character (32)
				 init ("find_attachment", "release_attachment", "open", "close", "modes",
				 "control", "position", "put_chars", "get_line", "get_chars", "read_length",
				 "seek_key", "read_key", "write_record", "read_record", "rewrite_record",
				 "delete_record") internal static options (constant);

	declare 1 segname		 unaligned,
		2 r		 character (1) init ("r"),
		2 N		 picture "9",
		2 io		 character (4) init ("_io_");

/* Warning, the following is marginal (tho probably legal) PL/I */

	declare 1 gates_as_arrays	 (7) aligned based (cross_ring_gates_ptr_),
		2 entries		 (17) entry variable;

	declare ex		 fixed bin;
	declare hcs_$make_entry	 entry (ptr, char (*), char (*), entry, fixed bin (35));

	segname.N = ring;
	code = 0;

	do ex = 1 to hbound (entrypoints, 1);
	     call hcs_$make_entry (null (), string (segname), entrypoints (ex), gates_as_arrays (ring).entries (ex),
		code);
	     if code ^= 0
	     then return;
	end;

     end init_one_ring;
     end cross_ring_;




		    cross_ring_io_.pl1              11/20/86  1404.7rew 11/20/86  1142.5      112509



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




/****^  HISTORY COMMENTS:
  1) change(86-08-20,DGHowe), approve(86-08-20,MCR7391),
     audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222):
     removed unrequired declarations.
                                                   END HISTORY COMMENTS */


/* format: style2 */
cross_ring_io_:
     procedure;

/* CROSS_RING_IO_ - Handle iox attachments which cross ring boundaries.

   This module runs in the inner ring. It is called by a gate
   whose name depends on the inner target ring sought.

   THVV 2/77 */


/* Modified November 1981 by Benson I. Margulies to fix resused and misused
		 attachment index bug. */
/* Modified 9/10/82 by R. Lamson to fix syn_ attachments. */
/* Modified 10/82 BIM to keep table of valid indices to avoid construction */
/*	        of bogus blocks in mailboxes. */


/* parameters */

	dcl     iocb_ptr		 ptr;		/* pointer to outer ring iocb */
	dcl     inner_iocbp		 ptr;		/* ptr to switch in inner ring */
	dcl     blp		 ptr;		/* ptr to attachment permission block */

	dcl     switchname		 char (*);

	dcl     return_code		 fixed bin (35);
	dcl     open_mode		 fixed bin;	/* open mode for open call only */
	dcl     dummy		 bit (1) aligned;	/* extend sw for open call only */
	dcl     control_arg		 char (*);	/* arg for control call */
	dcl     control_ptr		 ptr;		/* arg for control call */
	dcl     old_modes		 char (*);	/* arg for modes call */
	dcl     new_modes		 char (*);	/* arg for modes call */
	dcl     (char_cnt, char_cnt1)	 fixed bin (21);	/* character count on iox call */
	dcl     char_ptr		 ptr;		/* character pointer on iox call */
	dcl     postype		 fixed bin;
	dcl     poscount		 fixed bin (21);
	dcl     key		 char (256) var;
	dcl     reclth		 fixed bin (21);


/* automatic storage */

	declare was_found		 bit (1) aligned;
	declare node_ptr		 pointer;
	dcl     save_level		 fixed bin;
	dcl     inner_index		 bit (72) aligned;
	declare i			 fixed bin;

	declare 1 inner_index_struc	 aligned,
		2 iocb_ptr	 pointer unaligned,
		2 block_ptr	 pointer unaligned;

/* entry variables */

	dcl     set_ext_variable_	 entry (character (*), pointer,
				 pointer, bit (1) aligned, pointer,
				 fixed binary (35));
	dcl     get_ring_		 entry () returns (fixed bin);
	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);

/* built in fuctions */

	dcl     (addr, hbound, null, rtrim, stackbaseptr, unspec)
				 builtin;


	dcl     1 block		 based (blp) aligned,
		2 sentinel	 character (16) aligned,
		2 name		 char (32) unaligned,
		2 head_ptr	 pointer,		/* will be correct ringno */
		2 validation	 fixed bin,
		2 permission_granted bit (1) aligned,
		2 i_opened	 bit (1),
		2 attach_count	 fixed bin,
		2 open_count	 fixed bin;

	declare BLOCK_SENTINEL	 character (16) init ("Cross Ring I/O") internal static options (constant);
	declare any_other		 condition;

	declare cross_ring_io_block_table_ptr_
				 ptr unaligned external static init (null ());
	declare 1 block_table	 aligned based (cross_ring_io_block_table_ptr_),
		2 count		 fixed bin,
		2 known		 (block_table_count refer (block_table.count)) bit (72) aligned;
						/* ""b if free */

	declare block_table_count	 fixed bin;


	dcl     error_table_$io_no_permission
				 fixed bin (35) ext;

%include iocb;
%include system_link_names;
%include iox_entries;
%include cross_ring_attach_data_;


/* helper for attach */

find_attachment:
     entry (switchname, inner_index, return_code);

	call setup;
	if addr (block_table) = null
	then do;
		block_table_count = 4;
		allocate block_table;
		block_table.known = ""b;
	     end;

/* cann't create it so pass null init iinfo and null seg ptr */

	call set_ext_variable_ (rtrim (var_name (switchname)), null (), 
	     stackbaseptr (), was_found, node_ptr, return_code);
	if ^was_found | return_code ^= 0
	then do;

NO_GO_ATTACHMENT:
		return_code = error_table_$io_no_permission;
		go to exit;
	     end;
	blp = node_ptr -> variable_node.vbl_ptr;


	call iox_$find_iocb (switchname, inner_iocbp, return_code);
	if return_code ^= 0
	then go to NO_GO_ATTACHMENT;			/* censor code*/

	if save_level > block.validation
	then go to NO_GO_ATTACHMENT;
	block.attach_count = block.attach_count + 1;
	inner_index_struc.block_ptr = blp;
	inner_index_struc.iocb_ptr = inner_iocbp;
FILL_IN:
	do i = 1 to hbound (block_table.known, 1);
	     if block_table.known (i) = ""b
	     then do;
		     block_table.known (i) = unspec (inner_index_struc);
		     go to FILLED_IN;
		end;
	end;
	call grow_block_table;
	go to FILL_IN;

FILLED_IN:
	inner_index = block_table.known (i);

	return_code = 0;
exit:
	call cu_$level_set (save_level);
	return;

/* helper for detach */

release_attachment:
     entry (inner_index, return_code);

	call setup;
	unspec (inner_index_struc) = inner_index;
	call validate_index (unspec (inner_index_struc), (null ()));

	block.attach_count = block.attach_count - 1;
	do i = 1 to hbound (block_table.known, 1);
	     if block_table.known (i) = unspec (inner_index_struc)
	     then do;
		     block_table.known (i) = ""b;
		     go to exit;
		end;
	end;
	go to exit;

/* helper for open */

open:
     entry (inner_index, open_mode, dummy, return_code);

	call setup;
	call validate_index (inner_index, inner_iocbp);

	block.open_count = block.open_count + 1;
	if inner_iocbp -> iocb.open_descrip_ptr = null
	then do;
		call iox_$open (inner_iocbp, open_mode, dummy, return_code);
		if return_code = 0
		then block.i_opened = "1"b;
		else block.open_count = block.open_count - 1;
	     end;
	go to exit;

/* helper for close */

close:
     entry (inner_index, return_code);

	call setup;
	call validate_index (inner_index, inner_iocbp);

	block.open_count = block.open_count - 1;
	if block.open_count > 0
	then go to exit;
	if block.i_opened
	then call iox_$close (inner_iocbp, return_code);
	block.i_opened = "0"b;
	go to exit;

/* control entry point */

control:
     entry (iocb_ptr, control_arg, control_ptr, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);

	call iox_$control (inner_iocbp, control_arg, control_ptr, return_code);
	go to exit;

/* modes entry */

modes:
     entry (iocb_ptr, new_modes, old_modes, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$modes (inner_iocbp, new_modes, old_modes, return_code);
	go to exit;

/* read_key entry */

read_key:
     entry (iocb_ptr, key, reclth, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$read_key (inner_iocbp, key, reclth, return_code);
	go to exit;

/* read_length entry */

read_length:
     entry (iocb_ptr, reclth, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$read_length (inner_iocbp, reclth, return_code);
	go to exit;

/* delete_record entry */

delete_record:
     entry (iocb_ptr, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$delete_record (inner_iocbp, return_code);
	go to exit;

/* entry point for put_chars. */

put_chars:
     entry (iocb_ptr, char_ptr, char_cnt, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$put_chars (inner_iocbp, char_ptr, char_cnt, return_code);
	go to exit;

/* entry point for get_chars. */

get_chars:
     entry (iocb_ptr, char_ptr, char_cnt, char_cnt1, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	char_cnt1 = 0;
	call iox_$get_chars (inner_iocbp, char_ptr, char_cnt, char_cnt1, return_code);
	go to exit;

/* entry point for get_line. */

get_line:
     entry (iocb_ptr, char_ptr, char_cnt, char_cnt1, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	char_cnt1 = 0;
	call iox_$get_line (inner_iocbp, char_ptr, char_cnt, char_cnt1, return_code);
	go to exit;

/* entry point for read_record. */

read_record:
     entry (iocb_ptr, char_ptr, char_cnt, char_cnt1, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	char_cnt1 = 0;
	call iox_$read_record (inner_iocbp, char_ptr, char_cnt, char_cnt1, return_code);
	go to exit;

/* entry point for write_record. */

write_record:
     entry (iocb_ptr, char_ptr, char_cnt, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$write_record (inner_iocbp, char_ptr, char_cnt, return_code);
	go to exit;

/* entry point for rewrite_record. */

rewrite_record:
     entry (iocb_ptr, char_ptr, char_cnt, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$rewrite_record (inner_iocbp, char_ptr, char_cnt, return_code);
	go to exit;

/* entry point for position. */

position:
     entry (iocb_ptr, postype, poscount, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	return_code = 0;
	call iox_$position (inner_iocbp, postype, poscount, return_code);
	go to exit;

/* entry point for seek_key. */

seek_key:
     entry (iocb_ptr, key, char_cnt, return_code);

	call setup;
	inner_iocbp = validate_io (iocb_ptr);
	call iox_$seek_key (inner_iocbp, key, char_cnt, return_code);
	go to exit;


allow_cross:
     entry (x, v_arg, return_code);

	dcl     x			 char (*);
	dcl     v_arg		 fixed bin;


	begin;

%include system_link_init_info;
	     declare size		      builtin;	/* avoid confusion with structure component */
	     init_size = 0;
	     allocate init_info;
	     init_info.size = size (block);
	     init_info.type = NO_INIT;
	     was_found = "0"b;

/* no ptr init so pass null seg ptr */

	     call set_ext_variable_ (rtrim (var_name (x)), addr (init_info),
		stackbaseptr (), was_found, node_ptr, return_code);
	     if return_code ^= 0
	     then go to exit;
	     blp = node_ptr -> variable_node.vbl_ptr;
	end;

	if ^was_found
	then do;
		block.open_count, block.attach_count = 0;
		block.sentinel = BLOCK_SENTINEL;
		block.head_ptr = addr (block);
	     end;
	block.name = x;
	block.permission_granted = "1"b;
	block.validation = v_arg;


	return;


setup:
     proc;

	call cu_$level_get (save_level);
	call cu_$level_set (get_ring_ ());
	return_code = 0;

     end setup;

validate_io:
     procedure (iocbp) returns (pointer);
	declare iocbp		 pointer;
	declare inner_iocb		 pointer;

	call validate_index (iocbp -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> attach_data.inner_index,
	     inner_iocb);
	return (inner_iocb);
     end validate_io;

validate_index:
     procedure (bits, iocb_ptr);
	declare bits		 bit (72) aligned;
	declare iocb_ptr		 pointer;

	declare 1 val_data		 aligned like inner_index_struc;

	unspec (val_data) = bits;
	on any_other go to BAD_POINTER;

	if cross_ring_io_block_table_ptr_ = null ()
	then goto BAD_POINTER;

	if ^found_block (unspec (val_data)) | val_data.block_ptr -> block.validation < save_level
						/** **/
	     | val_data.block_ptr -> block.name ^= val_data.iocb_ptr -> iocb.name
						/** **/
	     | val_data.block_ptr -> block.sentinel ^= BLOCK_SENTINEL
						/** **/
	     | ^val_data.block_ptr -> block.permission_granted
	then do;
BAD_POINTER:
		return_code = error_table_$io_no_permission;
		go to exit;
	     end;
	iocb_ptr = val_data.iocb_ptr;
	blp = val_data.block_ptr;			/* global */
	return;

found_block:
     procedure (ix) returns (bit (1) aligned);
	declare ix		 bit (72) aligned;
	declare i			 fixed bin;
	do i = 1 to hbound (block_table.known, 1);
	     if block_table.known (i) = ix
	     then return ("1"b);
	end;
	return ("0"b);
     end found_block;

     end validate_index;

grow_block_table:
     procedure;
	declare new_bt_p		 pointer;
	declare i			 fixed bin;

	block_table_count = block_table.count * 2;
	allocate block_table set (new_bt_p);
	new_bt_p -> block_table.known = ""b;
	do i = 1 to hbound (block_table.known, 1);	/* old one */
	     new_bt_p -> block_table.known (i) = block_table.known (i);
	end;
	free block_table;
	cross_ring_io_block_table_ptr_ = new_bt_p;
	return;
     end grow_block_table;

var_name:
     procedure (sname) returns (character (64));

	declare sname		 character (*);
	return ("cross_ring_io_." || sname);
     end var_name;
     end cross_ring_io_;






		    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
