



		    parse_tape_reel_name_.pl1       11/11/89  1105.7r w 11/11/89  0811.3       28008



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* PARSE_TAPE_REEL_NAME_ - Produce IOX Attach Description from Tape Reel Name
   coded 9/16/77 by Noel I. Morris
   modified 4/79 by R.J.C. Kissel to recognize 6250 bpi.
   modified 2/80 by Michael R. Jordan to lengthen the descrip variable.
*/

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



parse_tape_reel_name_:
     proc (reelname, attach_descrip);

/* Private version for backup handles long comment strings */
/* S. Herbst 05/15/81 */

dcl  reelname char (*),				/* tape reel name */
     attach_descrip char (*);				/* IOX attach description */

dcl (comment, descrip) char (256) var,
    (i, j) fixed bin,
     atom char (32) var;

dcl  requote_string_ entry (char (*)) returns (char (*));

dcl (index, length, rtrim, substr) builtin;


	comment, descrip = "";

	i = index (reelname, ",");
	if i = 0
	then descrip = reelname;
	else
	do;
	     descrip = substr (reelname, 1, i - 1);
	     do while (i ^= 0);
		j = index (substr (reelname, i + 1), ",");
		if j = 0
		then atom = substr (reelname, i + 1);
		else
		do;
		     j = j + i;
		     atom = substr (reelname, i + 1, j - i - 1);
		end;

		if atom = "7track"
		then descrip = descrip || " -tk 7";
		else if atom = "9track"
		then descrip = descrip || " -tk 9";
		else if index (atom, "=800") ^= 0
		then descrip = descrip || " -den 800";
		else if index (atom, "=1600") ^= 0
		then descrip = descrip || " -den 1600";
		else if index (atom, "=6250") ^= 0
		then descrip = descrip || " -den 6250";
		else if atom = "800"
		then descrip = descrip || " -den 800";
		else if atom = "1600"
		then descrip = descrip || " -den 1600";
		else if atom = "6250"
		then descrip = descrip || " -den 6250";
		else if atom = "sys"
		then descrip = descrip || " -sys";

		else comment = comment || atom || " ";
		i = j;
	     end;
	end;

	if comment ^= "" then do;
	     comment = rtrim (comment);
	     descrip = descrip || " -com ";
	     if length (descrip) + length (comment) <= length (attach_descrip) then /* fits in caller's arg */
		descrip = descrip || requote_string_ ((comment));
	     else descrip = descrip || requote_string_ (substr (comment, 1, length (attach_descrip) - length (descrip)));
	end;

	attach_descrip = descrip;

	return;


     end;




		    tape_dim_data_.alm              11/11/89  1105.7r w 11/11/89  0811.3       12996



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

"	This data segment is used to define the size of a tape record.  The value of the
"	record_data_size variable is the number of WORDS in the data portion of a
"	Multics standard record.  The two allowable values for this variable are:
"		1024	the new standard
"		256	the old standard which may be used temporarily.
"	This segment is also used to define the size of the tdcm_ I/O buffer.
"		2080	standard size = 2 1K Multics standard records
"		4160	special  size = 4 1K Multics standard records
"	These variables are defined in the linkage section so that each process
"	will have its own copy.


	name	tape_dim_data_



	use	linkage
	join	/link/linkage



	segdef	record_data_size

	segdef	tdcm_buf_size

record_data_size:
	dec	1024		Default is large records.

tdcm_buf_size:
	dec	2080		Default is 2 large records.


	end




		    tape_ioi_.alm                   11/11/89  1105.7r w 11/11/89  0807.4       14571



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

" Transfer vector for tape_ioi_
" Written on the tenth anniversary of the Watergate breakin by Chris Jones

	name	tape_ioi_

	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2$&1
	&end

	transfer	activate,tape_ioi_activate
	transfer	allocate_buffers,tape_ioi_wks_man
	transfer	allocate_work_area,tape_ioi_wks_man
	transfer	buffer_status,tape_ioi_buffer_man
	transfer	check_order,tape_ioi_io
	transfer	check_read,tape_ioi_io
	transfer	check_write,tape_ioi_io
	transfer	deactivate,tape_ioi_activate
	transfer	deallocate,tape_ioi_wks_man
	transfer	deallocate_buffers,tape_ioi_wks_man
	transfer	get_mode,tape_ioi_modes
	transfer	get_statistics,tape_ioi_activate
	transfer	hardware_status,tape_ioi_hardware_status
	transfer	list_buffers,tape_ioi_buffer_man
	transfer	order,tape_ioi_io
	transfer	queue_order,tape_ioi_io
	transfer	queue_read,tape_ioi_io
	transfer	queue_write,tape_ioi_io
	transfer	read,tape_ioi_io
	transfer	release_buffer,tape_ioi_buffer_man
	transfer	reserve_buffer,tape_ioi_buffer_man
	transfer	reset_statistics,tape_ioi_activate
	transfer	set_buffer_ready,tape_ioi_buffer_man
	transfer	set_mode,tape_ioi_modes
	transfer	stop_tape,tape_ioi_io
	transfer	write,tape_ioi_io

	end




		    tape_ioi_activate.pl1           11/11/89  1105.7rew 11/11/89  0811.3       92601



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



/****^  HISTORY COMMENTS:
  1) change(87-07-06,Hartogs), approve(87-07-06,MCR7726),
     audit(87-08-27,GWMay), install(87-08-27,MR12.1-1094):
     A) Set initial value for tai.at_bot to "1"b.
     B) Set initial value of tai.density_command to ""b.
                                                   END HISTORY COMMENTS */


/* Written by Chris Jones */
/* Modified July 1983 by Chris Jones to zero "recovery_succeeded" array on a reset_statistics call,
   and to accept a null error count pointer on a deactivate call. */

/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
tape_ioi_activate:
activate:
     proc (p_rsc_ptr, p_tioi_info_ptr, p_tioi_id, p_code);

dcl	p_code		   fixed bin (35) parameter;	/* (O) system status code */
dcl	p_error_ptr	   ptr parameter;		/* (I) pointer to structure for error counts */
dcl	p_rsc_ptr		   ptr parameter;		/* (I) pointer to resource information */
dcl	p_tioi_id		   bit (36) aligned parameter;/* (O) tape_ioi_ assigned index */
dcl	p_tioi_info_ptr	   ptr parameter;		/* (I) pointer to the tape_ioi_info structure */

/*
   DESCRIPTION

   This procedure sets up and initializes the ioi workspace which is
   used by the rest of the tape_ioi_ procedures for internal communication
   and interfacing with ioi_.  It also builds the order command buffer and
   the first entry in the status queue.
   The assumption is made that the tai structure starts at offset
   zero in the workspace.  Other notes and restrictions are given in the
   tape_ioi_workspace include file, and in comments throughout the procedure.
*/
/*	JOURNALIZATION	*/
/*	Written April to May 1982 by Chris Jones from version of 8/78 by R.J.C. Kissel */

/* Automatic Variables */

dcl	code		   fixed bin (35);		/* error code */
dcl	device_number	   bit (6);
dcl	ioi_index		   fixed bin (17);
dcl	stq_length	   fixed bin (8);		/* Units of status queue entries. */
dcl	stq_offset	   fixed bin (18);		/* status queue offset in workspace (in words) */
dcl	wks_length	   fixed bin (19);		/* current length of workspace */


dcl	1 tape_ioi_id	   unal like tai.tioi_id;	/* Built for this activation. */

/* Static Variables */

dcl	next_tioi_actid	   fixed bin (18) unsigned unaligned internal static init (1);
						/* Incremented for each activation in this process. */

/* External Entries */

dcl	ioi_$set_event	   entry (fixed bin, fixed bin (71), fixed bin (35));
dcl	ioi_$set_status	   entry (fixed bin, fixed bin (18), fixed bin (8), fixed bin (35));
dcl	ioi_$timeout	   entry (fixed bin, fixed bin (71), fixed bin (35));
dcl	ioi_$workspace	   entry (fixed bin, ptr, fixed bin (19), fixed bin (35));
dcl	tape_ioi_utils$get_workspace_ptr
			   entry (bit (36) aligned, ptr);
dcl	tape_ioi_utils$io_in_progress
			   entry (ptr) returns (bit (1) aligned);

dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$device_active
			   fixed bin (35) ext static;
dcl	error_table_$unimplemented_version
			   fixed bin (35) ext static;

/* Builtin Functions and Conditions */

dcl	(addr, after, baseno, bin, bit, mod, null, ptr, rel, size, string, unspec)
			   builtin;

/*	Copy the input parameters. */

	p_tioi_id = ""b;				/* just for starters */
	tioi_info_ptr = p_tioi_info_ptr;
	if tioi_info.version ^= tioi_info_version then
	     call quit (error_table_$unimplemented_version);

	ioi_index = tioi_info.ioi_index;
	tape_info_ptr = p_rsc_ptr;

/*	Initialize various lengths, offsets, and other values. */

	wksp = null;

	wks_length = size (tai) + size (istat);		/* (General info + order buffer) + one status entry. */

	stq_offset = size (tai) + mod (size (tai), 2);	/* Status queue starts right after tai. */
	stq_length = 1;				/* Units of status queue entries. */

	device_number = bit (bin (after (tape_info.device_name, "_"), 6), 6);

/*	Set things up with ioi_. */

	call ioi_$workspace (ioi_index, wksp, wks_length, code);
	call quit_if_error;
	call ioi_$set_status (ioi_index, stq_offset, stq_length, code);
						/* This _m_u_s_t follow the call to ioi_$workspace. */
	call quit_if_error;
	call ioi_$set_event (ioi_index, tioi_info.event_id, code);
	call quit_if_error;
	call ioi_$timeout (ioi_index, tioi_info.timeout_max, code);
	call quit_if_error;

/*	Build the identifier for this tape_ioi_ activation. */

	tape_ioi_id.segno = baseno (wksp);
	tape_ioi_id.actid = next_tioi_actid;
	next_tioi_actid = next_tioi_actid + 1;		/* Increment for the next activation. */

/*	Initialize the general information in the workspace maintained by tape_ioi_. */

	tai.ioi_index = ioi_index;
	tai.tioi_id = tape_ioi_id;
	tai.event_id = tioi_info.event_id;
	tai.cur_timeout, tai.max_timeout = tioi_info.timeout_max;
	tai.workspace_max = tioi_info.workspace_max - 1;
	tai.workspace_len = wks_length - 1;
	tai.buffer_list_offset = 0;
	tai.free_list_offset = 0;
	tai.queue_list_offset = 0;
	tai.susp_list_offset = 0;
	tai.buffer_count = 0;
	tai.status_entry_count = stq_length;
	tai.status_queue_offset = stq_offset;
	tai.status_entry_idx = 0;
	tai.workarea_len = 0;
	tai.workarea_offset = 0;

/*	Initialize the mode settings for tape_ioi_. */

	tai.modes.data_code = "05"b3;			/* See the encoding in tape_ioi_workspace.incl.pl1 */
	tai.modes.cif_code = "20"b3;			/* See the encoding in tape_ioi_workspace.incl.pl1 */
	tai.modes.align = (tape_info.model = 500);	/* right alignment for model 500 tape drives only */
	tai.modes.length = "0"b;			/* normal length processing */
	tai.modes.recovery = "1"b;			/* we'll do the recovery by default */
	tai.modes.wait = "1"b;			/* we'll do the blocking by default */
	tai.modes.req_len = "1"b;			/* default is to always know the length of a record */

/*	Initialize the flags for tape_ioi_ operation. */

	string (tai.flags) = ""b;

	tai.pad1, tai.pad2 = ""b;			/* At activate time, rcp_ has positioned to BOT */
	tai.at_bot = "1"b;
	tai.density_command = ""b;                        /* Will be set by tape_ioi_io */

/*	Initialize counts of operations and errors */

	tai.total_reads, tai.total_writes, tai.total_orders = 0;
	tai.read_errors, tai.write_errors, tai.order_errors = 0;
	tai.times_tape_stopped, tai.times_status_lost, tai.extra_statuses = 0;
	tai.recovery_succeeded (*) = 0;
	tai.retry_count = 0;

/*	Initialize the order buffer IDCW. */

	idcwp = addr (tai.order_idcw);
	idcw.command = "0"b;			/* Set later with the actual order. */
	idcw.device = device_number;			/* Set the device number. */
	idcw.ext = "0"b;				/* Address extension. */
	idcw.code = "111"b;				/* Must be set to this. */
	idcw.ext_ctl = "0"b;			/* Do not reset address extension. */
	idcw.control = "00"b;			/* A list of orders is not allowed. */
	idcw.chan_cmd = "02"b3;			/* Non-data transfer command. */
	idcw.count = "0"b;				/* Set later with the actual count. */

/*	Initialize the order buffer DCW, this is only used by a few order commands
   that return data.  In setting up the data address we use the fact that the
   tai structure starts at a zero offset in the workspace to eliminate a subtraction. */

	dcwp = addr (tai.order_dcw);
	dcw.address = rel (addr (tai.order_data));
	dcw.char_pos = "0"b;			/* Start at the zeroth character. */
	dcw.m64 = "1"b;				/* Character tally. */
	dcw.type = "00"b;				/* Transmit and disconnect. */
	dcw.tally = "0"b;				/* Set later with the actual tally. */

/*	Clear the order data buffer. */

	tai.order_data (*) = "0"b;

/*	Clear the status queue. */

	isp = ptr (wksp, stq_offset);
	unspec (isp -> istat) = "0"b;

/*	Everything is done.  Set the output parameters and return. */

	p_tioi_id = unspec (tape_ioi_id);		/* Copy the structure into a 36 bit word. */
	p_code = 0;				/* No errors. */
	return;

/* entry to deactivate tioi_ */
deactivate:
     entry (p_tioi_id, p_error_ptr, p_code);

	if p_error_ptr ^= null () then
	     call get_statistics_proc;
	if tape_ioi_utils$io_in_progress (wksp) then
	     call quit (error_table_$device_active);

/* Shrink the workspace and invalidate the ioi_index in it */

	ioi_index = tai.ioi_index;
	call ioi_$set_status (ioi_index, 0, 1, (0));
	call ioi_$workspace (ioi_index, wksp, size (istat), (0));
	tai.ioi_index = 0;
	unspec (tai.tioi_id) = ""b;
	p_code = 0;
	return;

/* entry to get the statistics without deactivating tape_ioi_ */
get_statistics:
     entry (p_tioi_id, p_error_ptr, p_code);

	call get_statistics_proc;
	return;

/* entry to reset the statistics */

reset_statistics:
     entry (p_tioi_id, p_code);

	call setup;
	if tape_ioi_utils$io_in_progress (wksp) then
	     call quit (error_table_$device_active);
	tai.total_reads, tai.total_writes, tai.total_orders = 0;
	tai.read_errors, tai.write_errors, tai.order_errors = 0;
	tai.recovery_succeeded (*) = 0;
	return;

/* Error handling code. */

quit_if_error:
     proc;

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

     end quit_if_error;
quit:
     proc (code);

dcl	code		   fixed bin (35);

	p_code = code;
	goto ERROR_RETURN;

     end quit;

ERROR_RETURN:
	return;

setup:
     proc;

	call tape_ioi_utils$get_workspace_ptr (p_tioi_id, wksp);
	if wksp = null () then
	     call quit (error_table_$bad_arg);

     end setup;

get_statistics_proc:
     proc;

	call setup;
	tape_ioi_error_counts_ptr = p_error_ptr;
	if tec.version ^= TEC_VERSION then
	     call quit (error_table_$unimplemented_version);
	tec.reads.total = tai.total_reads;
	tec.reads.errors = tai.read_errors;
	tec.writes.total = tai.total_writes;
	tec.writes.errors = tai.write_errors;
	tec.orders.total = tai.total_orders;
	tec.orders.errors = tai.order_errors;
	tec.successful_retry_strategy = tai.recovery_succeeded;

     end get_statistics_proc;

%include tape_ioi_workspace;
%page;
%include tape_ioi_info;
%page;
%include ioi_stat;
%page;
%include iom_pcw;
%include iom_dcw;
%page;
%include rcp_tape_info;
%page;
%include tape_ioi_error_counts;

     end tape_ioi_activate;





		    tape_ioi_buffer_man.pl1         11/11/89  1105.7r w 11/11/89  0811.3       83223



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

/* tape_ioi_ buffer management entries */
/* Written May 1982 by Chris Jones */
/* Modified 14 January 1983 by Chris Jones to add reserve_buffer and release_buffer entries. */
/* Modified 2 February 1983 by Chris Jones to add READY_AND_RESERVED distinction to list_buffers. */
/* Modified 9 February 1983 by Chris Jones to improve interaction between reserved buffers and deallocate_buffers. */

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

dcl	p_buffer_data_ptr	   ptr parameter;		/* (I) pointer to the data area of a buffer */
dcl	p_buffer_ptr	   ptr parameter;		/* (I) pointer to a buffer header */
dcl	p_buffer_ptrs	   (*) ptr parameter;	/* (O) array of buffer data area pointers */
dcl	p_code		   fixed bin (35) parameter;	/* (O) standard system status code */
dcl	p_num_bufs	   fixed bin parameter;	/* (O) count of buffers in a given state */
dcl	p_state		   fixed bin parameter;	/* (I) state of buffers we're interested in */
dcl	p_tbs_ptr		   ptr parameter;		/* (I) pointer to a buffer status structure */
dcl	p_tioi_id		   bit (36) aligned parameter;/* (I) tape_ioi_ activation ID */
dcl	p_wksp		   ptr parameter;		/* (I) pointer to the tape_ioi_ workspace */

/* Automatic variables */

dcl	buffer_ptr	   ptr;
dcl	num_bufs		   fixed bin;
dcl	state		   fixed bin;

/* Externals */

dcl	tape_ioi_utils$get_buffer_ptr
			   entry (ptr, ptr) returns (ptr);
dcl	tape_ioi_utils$get_workspace_ptr
			   entry (bit (36) aligned, ptr);

dcl	error_table_$action_not_performed
			   fixed bin (35) ext static;
dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$device_active
			   fixed bin (35) ext static;
dcl	error_table_$unimplemented_version
			   fixed bin (35) ext static;

/* Builtins */

dcl	(addr, bin, dim, lbound, null, ptr, rel)
			   builtin;

/* entry to return the status of a specified buffer */
buffer_status:
     entry (p_tioi_id, p_buffer_data_ptr, p_tbs_ptr, p_code);

	call setup;
	buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_buffer_data_ptr);
	if buffer_ptr = null () then
	     call quit (error_table_$bad_arg);

	tbs_ptr = p_tbs_ptr;
	if tbs.version ^= TBS_VERSION then
	     call quit (error_table_$unimplemented_version);

	tbs.state = buffer_ptr -> tbi.state;
	tbs.buffer_len = buffer_ptr -> tbi.buffer_len;
	tbs.data_len = buffer_ptr -> tbi.data_len;
	tbs.bit_count = buffer_ptr -> tbi.bit_len;
	tbs.channel_inst = buffer_ptr -> tbi.cif_code;
	if buffer_ptr -> tbi.modes.data_code = "05"b3 then
	     tbs.data_mode = "bin";
	else if buffer_ptr -> tbi.modes.data_code = "04"b3 then
	     tbs.data_mode = "bcd";
	else if buffer_ptr -> tbi.modes.data_code = "03"b3 then
	     tbs.data_mode = "tap9";
	else if buffer_ptr -> tbi.modes.data_code = "27"b3 then
	     tbs.data_mode = "asc";
	else if buffer_ptr -> tbi.modes.data_code = "24"b3 then
	     tbs.data_mode = "ebc";
	else if buffer_ptr -> tbi.modes.data_code = "25"b3 then
	     tbs.data_mode = "a/e";
	else tbs.data_mode = "****";			/* we'll get an error later if we try to use this */
	tbs.align_mode = buffer_ptr -> tbi.modes.align;
	tbs.length_mode = buffer_ptr -> tbi.modes.length;
	tbs.recovery_mode = buffer_ptr -> tbi.modes.recovery;
	tbs.reserved = buffer_ptr -> tbi.reserved;

	p_code = 0;
	return;

/* entry to return an array of all buffers, or all buffers in a specified state */
list_buffers:
     entry (p_tioi_id, p_state, p_buffer_ptrs, p_num_bufs, p_code);

	call setup;
	state = p_state;
	if state = 0 then
	     buffer_ptr = ptr (wksp, tai.buffer_list_offset);
	else if (state = READY_STATE) | (state = READY_AND_RESERVED_STATE) then
	     buffer_ptr = ptr (wksp, tai.free_list_offset);
	else if state = QUEUED_STATE then
	     buffer_ptr = ptr (wksp, tai.queue_list_offset);
	else if state = SUSPENDED_STATE then
	     buffer_ptr = ptr (wksp, tai.susp_list_offset);
	else call quit (error_table_$bad_arg);

/* Now loop thru the appropriate buffer list.  If rel (buffer_ptr) = ""b, then the offset in the ptr expression
   above must be 0, which means there are no buffers of the appropriate state, so skip the following loop. */

	num_bufs = 0;				/* none seen so far */
	do while (rel (buffer_ptr));
	     if ^((state = READY_STATE) & (buffer_ptr -> tbi.reserved)) then do;
		if num_bufs < dim (p_buffer_ptrs, 1) then
		     p_buffer_ptrs (lbound (p_buffer_ptrs, 1) + num_bufs) = ptr (wksp, buffer_ptr -> tbi.data_offset);
		num_bufs = num_bufs + 1;
	     end;
	     if state = 0 then
		buffer_ptr = ptr (wksp, buffer_ptr -> tbi.next_buf_offset);
	     else buffer_ptr = ptr (wksp, buffer_ptr -> tbi.next_state_offset);
	end;

	p_num_bufs = num_bufs;
	p_code = 0;
	return;

/* Entry to set a suspended buffer's state to ready. */

set_buffer_ready:
     entry (p_tioi_id, p_buffer_data_ptr, p_code);

	call setup;
	buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_buffer_data_ptr);
	if buffer_ptr = null () then
	     call quit (error_table_$bad_arg);

	if buffer_ptr -> tbi.state = QUEUED_STATE then
	     call quit (error_table_$device_active);
	else if buffer_ptr -> tbi.state = READY_STATE then
	     call quit (error_table_$action_not_performed);

	call set_buffer_ready_proc (buffer_ptr);
	p_code = 0;
	return;

/* Internal entry (not retained) to set a buffer's state to ready. */

internal_set_buffer_ready:
     entry (p_wksp, p_buffer_ptr);

	wksp = p_wksp;
	call set_buffer_ready_proc (p_buffer_ptr);
	return;

/* Procedure which actually sets a buffer's state to ready.  It insists that the state be either queued or suspended. */

set_buffer_ready_proc:
     proc (buffer_ptr);

dcl	buffer_ptr	   ptr parameter;

dcl	cbufp		   ptr;
dcl	last_offset_ptr	   ptr;

dcl	last_offset	   fixed bin (18) unsigned unaligned based (last_offset_ptr);

	if buffer_ptr -> tbi.state = QUEUED_STATE then do;
	     cbufp = ptr (wksp, tai.queue_list_offset);
	     last_offset_ptr = addr (tai.queue_list_offset);
	end;
	else if buffer_ptr -> tbi.state = SUSPENDED_STATE then do;
	     cbufp = ptr (wksp, tai.susp_list_offset);
	     last_offset_ptr = addr (tai.susp_list_offset);
	end;
	else return;

	do while ((cbufp ^= buffer_ptr) & (cbufp ^= wksp));
	     last_offset_ptr = addr (cbufp -> tbi.next_state_offset);
	     cbufp = ptr (wksp, cbufp -> tbi.next_state_offset);
	end;
	if cbufp = wksp then
	     return;

	last_offset = buffer_ptr -> tbi.next_state_offset;/* cbupf = buffer_ptr */
	buffer_ptr -> tbi.state = READY_STATE;
	buffer_ptr -> tbi.next_state_offset = 0;

	if tai.free_list_offset = 0 then
	     tai.free_list_offset = bin (rel (buffer_ptr));
	else do;
	     cbufp = ptr (wksp, tai.free_list_offset);
	     do while (cbufp -> tbi.next_state_offset ^= 0);
		cbufp = ptr (wksp, cbufp -> tbi.next_state_offset);
	     end;
	     cbufp -> tbi.next_state_offset = bin (rel (buffer_ptr));
	end;

     end set_buffer_ready_proc;

/* Entry to reserve a buffer.  A reserved buffer will not have a read done into it unless an explicit
   queue_read call is made with it as an argument.  A reserved buffer may not lie above a buffer which is
   not reserved (so that deallocate_buffers can keep the reserved buffers still allocated). */

reserve_buffer:
     entry (p_tioi_id, p_buffer_data_ptr, p_code);

	call setup;
	buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_buffer_data_ptr);
	if buffer_ptr = null () then
	     call quit (error_table_$bad_arg);

	begin;
dcl	bufp		   ptr;

	     do bufp = ptr (wksp, tai.buffer_list_offset) repeat ptr (wksp, bufp -> tbi.next_state_offset)
		while (rel (bufp));
		if ((bufp -> tbi.data_offset) < (buffer_ptr -> tbi.data_offset)) & ^(bufp -> tbi.reserved) then
		     call quit (error_table_$action_not_performed);
	     end;
	end;

	buffer_ptr -> tbi.reserved = "1"b;
	return;

/* Entry to release a buffer from its reserved state. */

release_buffer:
     entry (p_tioi_id, p_buffer_data_ptr, p_code);

	call setup;
	buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_buffer_data_ptr);
	if buffer_ptr = null () then
	     call quit (error_table_$bad_arg);

	begin;
dcl	bufp		   ptr;

	     do bufp = ptr (wksp, tai.buffer_list_offset) repeat ptr (wksp, bufp -> tbi.next_state_offset)
		while (rel (bufp));
		if ((bufp -> tbi.data_offset) > (buffer_ptr -> tbi.data_offset)) & (bufp -> tbi.reserved) then
		     call quit (error_table_$action_not_performed);
	     end;
	end;

	buffer_ptr -> tbi.reserved = "0"b;
	return;

setup:
     proc;

	call tape_ioi_utils$get_workspace_ptr (p_tioi_id, wksp);
	if wksp = null () then
	     call quit (error_table_$bad_arg);

     end setup;

quit:
     proc (code);

dcl	code		   fixed bin (35);

	p_code = code;
	goto ERROR_RETURN;

     end quit;

ERROR_RETURN:
	return;

%include tape_ioi_workspace;
%page;
%include tape_ioi_buffer_status;

     end tape_ioi_buffer_man;




		    tape_ioi_error_retry.pl1        11/11/89  1105.7rew 11/11/89  0806.8       79506



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



/****^  HISTORY COMMENTS:
  1) change(87-07-06,Hartogs), approve(87-07-06,MCR7726),
     audit(87-08-27,GWMay), install(87-08-27,MR12.1-1094):
     A) Error recovery changed to rewind on error at first label instead of a
        backspace and erase.
     B) Added SET_DENSITY routine.
     C) Changed dcw commands to use descriptive variables.
                                                   END HISTORY COMMENTS */


/* This is where all the tape error recovery is done.  */

/* Written Aug 1982 by Sherman D. Sprague. */
/* Modified October 1983 by Chris Jones to add eof entry. */

/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tape_ioi_error_retry:
     proc (arg_wksp_ptr, arg_buf_ptr, arg_status_ptr, arg_code);

/* Parameters */

dcl      arg_buf_ptr	  ptr parameter;		/* (I/O) pointer to  the data to be or just processed */
dcl      arg_code		  fixed bin (35) parameter;	/* (O) system status code */
dcl      arg_lost_status_cnt	  fixed bin parameter;	/* (I) count of number of statuses lost */
dcl      arg_wksp_ptr	  ptr parameter;		/* (O) pointer to the workspace */
dcl      arg_status_ptr	  ptr parameter;

/* Automatic variables */

dcl      backspace_cnt	  fixed bin;
dcl      block_count            fixed bin;
dcl      code		  fixed bin (35);
dcl      deadline		  fixed bin (71);
dcl      status_present	  bit (1) aligned init ("0"b);
dcl      status_special	  bit (36) aligned;
dcl      tries		  fixed bin;
dcl      write_sw		  bit (1) aligned;

/* Entries */

dcl      ioi_$connect	  entry (fixed bin, fixed bin (18), fixed bin (35));
dcl      ioi_$get_special_status
			  entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl      ipc_$block		  entry (ptr, ptr, fixed bin (35));
dcl      tape_ioi_utils$get_status
			  entry (ptr) returns (ptr);

dcl      timer_manager_$alarm_wakeup
			  entry (fixed bin (71), bit (2), fixed bin (71));
dcl      timer_manager_$reset_alarm_wakeup
			  entry (fixed bin (71));	/* External static variables */

dcl      error_table_$bad_density
			  fixed bin (35) ext static;
dcl      error_table_$device_active
			  fixed bin (35) ext static;
dcl      error_table_$device_parity
			  fixed bin (35) ext static;

/* Builtins */

dcl      (addr, addrel, bin, bit, clock, rel, substr, unspec)
			  builtin;

%page;

	wksp = arg_wksp_ptr;
	if tai.density_command = ""b then do;
	     arg_code = error_table_$bad_density;
	     return;
	end;
	dcwp = addr (tai.order_data);			/* use the  order data area as a scratch area */
	idcwp = addr (arg_buf_ptr -> tbi.idcw_word);	/* set up the current idcw */
	write_sw = substr (idcw.command, 3, 1);		/* are we writing ? */
	if write_sw then do;
	     if tai.at_bot then do;
		call REWIND (dcwp);			/* rewind to bot */
		call SET_DENSITY (dcwp);		/* and reset device density */
		call TDCW (dcwp, idcwp);		/* build idcw to bridge lists */
	     end;
	     else do;
		call BACKSPACE (1, dcwp);		/* go backspace */
		call ERASE (dcwp);
		call TDCW (dcwp, idcwp);		/* build idcw to bridge our lists */
	     end;
	     call CONNECT (addr (tai.order_data));	/* send him on his way... */
	end;

	else do;
	     if idcw.chan_cmd = MAX_READ_OPT then do;		/* have we tried all options yet */
		arg_code = error_table_$device_parity;	/* if so return code */
		return;
	     end;
	     idcw.chan_cmd = bit (bin (bin (idcw.chan_cmd) + 1, 6), 6);
						/* add one to the channel command */
	     call BACKSPACE (1, dcwp);		/* go backspace */
	     call TDCW (dcwp, idcwp);
	     call CONNECT (addr (tai.order_data));	/* send him on his way */
	end;
	return;

backspace:
     entry (arg_wksp_ptr, arg_buf_ptr, arg_status_ptr, arg_lost_status_cnt, arg_code);

	wksp = arg_wksp_ptr;			/* setup the workspace pointer */
	statp = addr (arg_status_ptr -> istat.iom_stat);
	dcwp = addr (tai.order_data);
	idcwp = addr (arg_buf_ptr -> tbi.idcw_word);	/* get the current idcw */

	if status.initiate then
	     backspace_cnt = arg_lost_status_cnt;
	else backspace_cnt = arg_lost_status_cnt + 1;
	call BACKSPACE (backspace_cnt, dcwp);		/* go backspace */
	call TDCW (dcwp, idcwp);
	call CONNECT (addr (tai.order_data));		/* send him on his way.... */
	return;

eof:
     entry (arg_wksp_ptr, arg_code);

	wksp = arg_wksp_ptr;
	idcwp = addr (tai.order_data (1));
	dcwp = addr (tai.order_idcw);
	call BACKSPACE (1, dcwp);
	call ERASE (dcwp);
	call CONNECT (addr (tai.order_idcw));
	return;


/* This procedure will backspace the tape */

BACKSPACE:
     proc (rec_bk, dcwp);
dcl      rec_bk		  fixed bin parameter;	/* records to be backspaced */
dcl      dcwp		  ptr parameter;		/* pointer into IDCW list */

	dcwp -> idcw = idcw;
	dcwp -> idcw.command = BACKSPACE_ONE_RECORD;
	dcwp -> idcw.control = CONTINUE_NO_MARKER;
	dcwp -> idcw.chan_cmd = NONDATA_TRANSFER;
	dcwp -> idcw.count = bit (bin (rec_bk, 6), 6);
	dcwp = addrel (dcwp, 1);

     end BACKSPACE;

BLOCK:
     proc;


dcl      1 auto_event_wait_info aligned like event_wait_info;

	event_wait_channel.channel_id = tai.event_id;
	if tai.special_status_expected then
	     call timer_manager_$alarm_wakeup (TWO_MINUTES, RELATIVE_SECONDS, tai.event_id);
	call ipc_$block (addr (event_wait_channel), addr (auto_event_wait_info), (0));
	if tai.special_status_expected then
	     call timer_manager_$reset_alarm_wakeup (tai.event_id);
						/* remove the extra event */

     end BLOCK;

CONNECT:
     proc (idcwp);

dcl      idcwp		  ptr parameter;		/* pointer to start of dcw list */

	deadline = clock () + TEN_SECONDS;
	do while ("1"b);
	     do tries = 1 to 10;
		call ioi_$connect (tai.ioi_index, bin (rel (idcwp)), arg_code);
		if arg_code ^= error_table_$device_active then
		     return;
	     end;
	     if clock () > deadline then
		return;
	end;

     end CONNECT;

/* This procedure will erase one record on the tape */

ERASE:
     proc (dcwp);
dcl      dcwp		  ptr parameter;		/* pointer into IDCW list */

	dcwp -> idcw = idcw;
	dcwp -> idcw.command = ERASE_COMMAND;
	dcwp -> idcw.control = CONTINUE_NO_MARKER;
	dcwp -> idcw.chan_cmd = NONDATA_TRANSFER;
	dcwp -> idcw.count = ONE_COUNT;
	dcwp = addrel (dcwp, 1);

     end ERASE;

/* This procedure will rewind the tape */

REWIND:
     proc (dcwp);

dcl      dcwp		  ptr parameter;		/* pointer into IDCW list */

	dcwp -> idcw = idcw;
	dcwp -> idcw.command = REWIND_COMMAND;
	dcwp -> idcw.control = NO_CONTINUE_NO_MARKER;
	dcwp -> idcw.chan_cmd = NONDATA_TRANSFER;
	dcwp -> idcw.count = ONE_COUNT;

	call ioi_$get_special_status (tai.ioi_index, status_present, status_special, code);
						/* First call flushes residue status */
	call CONNECT (dcwp);
	status_present = "0"b;
	call ioi_$get_special_status (tai.ioi_index, status_present, status_special, code);

	tai.special_status_expected = "1"b;
	do block_count = 1 to 2;                          /* Allows up to four minutes to rewind. */
	     if ^status_present then do;
		call BLOCK;
		call ioi_$get_special_status (tai.ioi_index, status_present, status_special, code);
	     end;
	end;
	tai.special_status_expected = "0"b;

	isp = tape_ioi_utils$get_status (wksp);		/* call to get_status sets indexes correctly */
	return;

     end REWIND;

/* This procedure will set the device density to the stored value */

SET_DENSITY:
     proc (dcwp);
dcl      dcwp		  ptr parameter;		/* pointer into IDCW list */

	dcwp -> idcw = idcw;
	dcwp -> idcw.command = tai.density_command;
	dcwp -> idcw.control = CONTINUE_NO_MARKER;
	dcwp -> idcw.chan_cmd = NONDATA_TRANSFER;
	dcwp -> idcw.count = ONE_COUNT;
	dcwp = addrel (dcwp, 1);

     end SET_DENSITY;

/* This procedure will build a TDCW to join two idcw lists */

TDCW:
     proc (dcwp, dest_idcwp);
dcl      dcwp		  ptr parameter;		/* pointer into IDCW list */
dcl      dest_idcwp		  ptr parameter;		/* pointer to the rest of the list */

	tdcwp = dcwp;				/* point as to a tdcw */
	unspec (tdcw) = ""b;
	tdcw.address = rel (dest_idcwp);
	tdcw.type = TDCW_TYPE;
	tdcw.rel = RELATIVE_MODE;

     end TDCW;

%page;
%include event_wait_channel;
%page;
%include event_wait_info;
%page;
%include tape_ioi_workspace;
%page;
%include iom_pcw;
%page;
%include iom_dcw;
%page;
%include iom_stat;
%page;
%include ioi_stat;
%page;
%include io_status_word;
%page;
%include interrupt_levels;
%page;
%include tape_ioi_result_indexes;
%page;
%include tape_ioi_buffer_status;
%page;
%include tape_ioi_constants;

     end tape_ioi_error_retry;




		    tape_ioi_hardware_status.pl1    11/11/89  1105.7r w 11/11/89  0807.4       97020



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* Entry to interpret status information for last I/O operation. */
/* Written 29 June 1982 by Chris Jones. */
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */

hardware_status:
     proc (p_tioi_id, p_ths_ptr, p_code);

/* Parameters */

dcl	p_code		   fixed bin (35) parameter;	/* (O) system status code */
dcl	p_ths_ptr		   ptr parameter;		/* (I) pointer to the ths structure */
dcl	p_tioi_id		   bit (36) aligned parameter;/* (I) tape_ioi_ activation ID */

/* Automatic storage */

dcl	1 auto_istat	   like istat;

/* Based storage */

dcl	fault_word	   bit (36) aligned based (statp);
						/* system fault word */

/* Externals */

dcl	analyze_ioi_istat_	   entry (ptr, ptr, char (*) var);
dcl	analyze_system_fault_$rsnnl
			   entry (char (*) var, bit (36) aligned);
dcl	tape_ioi_utils$get_workspace_ptr
			   entry (bit (36) aligned, ptr);
dcl	tape_ioi_utils$last_status_entry_offset
			   entry (ptr) returns (fixed bin (18) unsigned);

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

dcl	tape_status_table_$tape_status_table_
			   external;

/* Conditions */

dcl	any_other		   condition;

/* Builtins */

dcl	(addr, bin, null, ptr) builtin;

	call tape_ioi_utils$get_workspace_ptr (p_tioi_id, wksp);
	if wksp = null () then do;
	     p_code = error_table_$bad_arg;
	     return;
	end;
	ths_ptr = p_ths_ptr;
	if ths.version ^= THS_VERSION then do;
	     p_code = error_table_$unimplemented_version;
	     return;
	end;

	isp = ptr (wksp, tape_ioi_utils$last_status_entry_offset (wksp));
						/* point to the previous istat entry */
	auto_istat = istat;				/* copy it for analysis */
	auto_istat.st = "1"b;			/* turn the validity bit back on */
	statp = addr (auto_istat.iom_stat);

/* First, get the description of the status. */

	on any_other
	     begin;
		ths.description = "**** NO DESCRIPTION AVAILABLE ****";
		goto DESCRIPTION_DONE;
	     end;

	if auto_istat.level = IO_SYSTEM_FAULT_INTERRUPT_LEVEL then
	     call analyze_system_fault_$rsnnl (ths.description, fault_word);
	else call analyze_ioi_istat_ (addr (auto_istat), addr (tape_status_table_$tape_status_table_), ths.description);

/* Now, decode and reformat the status in a device independent way. */

DESCRIPTION_DONE:
	if auto_istat.time_out then
	     ths.major = TIME_OUT;
	else if auto_istat.level = IO_SYSTEM_FAULT_INTERRUPT_LEVEL then
	     ths.major = SYSTEM_FAULT;
	else if status.power then
	     ths.major = POWER_OFF;
	else if status.channel_stat then
	     ths.major = IOM_CHANNEL;
	else if status.central_stat then
	     ths.major = IOM_CENTRAL;
	else ths.major = bin (status.major);

	ths.minor = ""b;				/* initialize to no minor status */
	if ths.major = SUBSYSTEM_READY then
	     call fill_subsystem_ready_status;
	else if ths.major = DEVICE_BUSY then
	     call fill_device_busy_status;
	else if ths.major = DEVICE_ATTENTION then
	     call fill_device_attention_status;
	else if ths.major = DEVICE_DATA_ALERT then
	     call fill_device_data_alert_status;
	else if ths.major = END_OF_FILE then
	     call fill_end_of_file_status;
	else if ths.major = COMMAND_REJECT then
	     call fill_command_reject_status;
	else if ths.major = MPC_DEVICE_ATTENTION then
	     call fill_mpc_device_attention_status;
	else if ths.major = MPC_DEVICE_DATA_ALERT then
	     call fill_mpc_device_data_alert_status;
	else if ths.major = MPC_COMMAND_REJECT then
	     call fill_mpc_command_reject_status;
	else if ths.major = POWER_OFF then
	     call fill_power_off_status;
	else if ths.major = SYSTEM_FAULT then
	     call fill_system_fault_status;
	else if ths.major = IOM_CENTRAL then
	     call fill_iom_central_status;
	else if ths.major = IOM_CHANNEL then
	     call fill_iom_channel_status;
	else if ths.major = TIME_OUT then
	     call fill_time_out_status;

/* Lastly, pass back the IOM status and LPW */

	ths.iom = auto_istat.iom_stat;
	ths.lpw = auto_istat.lpw;
	p_code = 0;
	return;

/* Routines to fill in the various substatuses we keep track of. */

fill_subsystem_ready_status:
     proc;

	if (status.sub & "001001"b) = "000001"b then
	     ths.minor = ths.minor | WRITE_PROTECTED;
	if (status.sub & "111010"b) = "000010"b then
	     ths.minor = ths.minor | AT_BOT;
	if (status.sub & "111010"b) = "010000"b then
	     ths.minor = ths.minor | TWO_BIT_FILL;
	if (status.sub & "111010"b) = "100000"b then
	     ths.minor = ths.minor | FOUR_BIT_FILL;
	if (status.sub & "111010"b) = "110000"b then
	     ths.minor = ths.minor | SIX_BIT_FILL;
	if status.sub = "001100"b then
	     ths.minor = ths.minor | ASCII_ALERT;

     end fill_subsystem_ready_status;

fill_device_busy_status:
     proc;

	if status.sub = "000001"b then
	     ths.minor = ths.minor | REWINDING;
	if status.sub = "100000"b then
	     ths.minor = ths.minor | RESERVED;
	if status.sub = "000010"b then
	     ths.minor = ths.minor | ALTERNATE_CHANNEL;
	if status.sub = "000100"b then
	     ths.minor = ths.minor | LOADING;

     end fill_device_busy_status;

fill_device_attention_status:
     proc;

	if (status.sub & "110011"b) = "000001"b then
	     ths.minor = ths.minor | WRITE_PROTECTED;
	if status.sub = "000010"b then
	     ths.minor = ths.minor | NO_SUCH_HANDLER;
	if (status.sub & "100110"b) = "000100"b then
	     ths.minor = ths.minor | HANDLER_IN_STANDBY;
	if (status.sub & "101010"b) = "001000"b then
	     ths.minor = ths.minor | HANDLER_CHECK;
	if (status.sub & "110011"b) = "010000"b then
	     ths.minor = ths.minor | BLANK_TAPE_ON_WRITE;

     end fill_device_attention_status;

fill_device_data_alert_status:
     proc;

	if status.sub = "000001"b then
	     ths.minor = ths.minor | TRANSFER_TIMING_ALERT;
	if status.sub = "000010"b then
	     ths.minor = ths.minor | BLANK_TAPE_ON_READ;
	if (status.sub & "000011"b) = "000011"b then
	     ths.minor = ths.minor | BIT_DURING_ERASE;
	if status.sub & "000100"b then
	     ths.minor = ths.minor | TRANSMISSION_PARITY_ALERT;
	if status.sub & "001000"b then
	     ths.minor = ths.minor | LATERAL_PARITY_ALERT;
	if status.sub & "010000"b then
	     ths.minor = ths.minor | LONGITUDINAL_PARITY_ALERT;
	if status.sub & "100000"b then
	     ths.minor = ths.minor | END_OF_TAPE;

     end fill_device_data_alert_status;

fill_end_of_file_status:
     proc;

	if status.sub = "111111"b then
	     ths.minor = ths.minor | DATA_ALERT_CONDITION;

     end fill_end_of_file_status;

fill_command_reject_status:
     proc;

	if status.sub = "010000"b then
	     ths.minor = ths.minor | READ_AFTER_WRITE;
	if status.sub = "001000"b then
	     ths.minor = ths.minor | AT_BOT;
	if (status.sub & "111100"b) = "000100"b then
	     ths.minor = ths.minor | BAD_IDCW_PARITY;
	if (status.sub & "111010"b) = "000010"b then
	     ths.minor = ths.minor | BAD_DEVICE_CODE;
	if (status.sub & "111001"b) = "000001"b then
	     ths.minor = ths.minor | BAD_OP_CODE;
	if status.sub = "000000"b then
	     ths.minor = ths.minor | BAD_DENSITY;
	if status.sub = "100000"b then
	     ths.minor = ths.minor | NINE_TRACK_ERROR;

     end fill_command_reject_status;

fill_mpc_device_attention_status:
     proc;

	if status.sub = "000001"b then
	     ths.minor = ths.minor | CONFIG_SWITCH_ERROR;
	if status.sub = "000010"b then
	     ths.minor = ths.minor | MULTIPLE_DEVICES;
	if status.sub = "000011"b then
	     ths.minor = ths.minor | ILLEGAL_DEVICE_ID;
	if status.sub = "001000"b then
	     ths.minor = ths.minor | INCOMPATIBLE_MODE;
	if (status.sub & "111100"b) = "001100"b then
	     ths.minor = ths.minor | TCA_MALFUNCTION;
	if status.sub = "010000"b then
	     ths.minor = ths.minor | MTH_MALFUNCTION;
	if status.sub = "010001"b then
	     ths.minor = ths.minor | MULTIPLE_BOT;

     end fill_mpc_device_attention_status;

fill_mpc_device_data_alert_status:
     proc;

	if status.sub = "000001"b then
	     ths.minor = ths.minor | TRANSMISSION_PARITY_ALERT;
	if status.sub = "000010"b then
	     ths.minor = ths.minor | INCONSISTENT_COMMAND;
	if status.sub = "000011"b then
	     ths.minor = ths.minor | SUM_CHECK_ERROR;
	if status.sub = "000100"b then
	     ths.minor = ths.minor | BYTE_LOCKED_OUT;
	if status.sub = "001000"b then
	     ths.minor = ths.minor | ID_BURST_WRITE_ERROR;
	if status.sub = "001001"b then
	     ths.minor = ths.minor | PREAMBLE_ERROR;
	if status.sub = "100000"b then
	     ths.minor = ths.minor | MARGINAL_CONDITION;
	if status.sub = "010000"b then
	     ths.minor = ths.minor | MULTI_TRACK_ERROR;
	if status.sub = "010001"b then
	     ths.minor = ths.minor | SKEW_ERROR;
	if status.sub = "010010"b then
	     ths.minor = ths.minor | POSTAMBLE_ERROR;
	if status.sub = "010011"b then
	     ths.minor = ths.minor | NRZI_CCC_ERROR;
	if status.sub = "010100"b then
	     ths.minor = ths.minor | CODE_ALERT;

     end fill_mpc_device_data_alert_status;

fill_mpc_command_reject_status:
     proc;

	if status.sub = "000001"b then
	     ths.minor = ths.minor | ILLEGAL_PROCEDURE;
	if status.sub = "000010"b then
	     ths.minor = ths.minor | ILLEGAL_LC_NUMBER;
	if status.sub = "000011"b then
	     ths.minor = ths.minor | ILLEGAL_SUSPENDED_LC_NUMBER;
	if status.sub = "000100"b then
	     ths.minor = ths.minor | CONTINUE_BIT_NOT_SET;

     end fill_mpc_command_reject_status;

fill_iom_central_status:
     proc;

dcl	iom_central_statuses   (7) bit (36) aligned
			   init (LPW_TRO, CONSECUTIVE_TDCWS, BOUNDARY_ERROR, EXT_CHANGE_WHILE_RESTRICTED,
			   IDCW_WHILE_RESTRICTED, CP_SIZE_DISCREPANCY, BUS_PARITY_FROM_CHANNEL);

	ths.minor = ths.minor | iom_central_statuses (bin (status.central_stat));

     end fill_iom_central_status;

fill_iom_channel_status:
     proc;

dcl	iom_channel_statuses   (7) bit (36) aligned
			   init (CONNECT_WHILE_BUSY, BAD_PCW_CHANNEL_INST, INCORRECT_DCW,
			   INCOMPLETE_COMMAND_SEQUENCE, ""b, PARITY_ERROR_AT_PRPH_INTERFACE, BUS_PARITY_TO_CHANNEL);

	ths.minor = ths.minor | iom_channel_statuses (bin (status.channel_stat));

     end fill_iom_channel_status;

/* The following statuses don't have any minor statuses associated with them. */

fill_power_off_status:
fill_system_fault_status:
fill_time_out_status:
     proc;

     end fill_power_off_status;

%include tape_ioi_workspace;
%page;
%include tape_ioi_hw_status;
%page;
%include interrupt_levels;
%page;
%include ioi_stat;
%page;
%include iom_stat;

     end hardware_status;




		    tape_ioi_io.pl1                 11/11/89  1105.7r w 11/11/89  0807.4      580581



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



/****^  HISTORY COMMENTS:
  1) change(86-02-13,GWMay), approve(86-02-13,MCR7337), audit(86-03-11,Farley),
     install(86-03-17,MR12.0-1030):
     old history comments:
         Written May to July 1982 by Chris Jones.
         Various bugfixes by Chris Jones, December 1982 to November 1983.
         Modified 1985-03-14, BIM: set code right on blank tape.
         Modified 04/25/85 by Chris Jones to properly ignore extra statuses.
         Modified 05/02/85 by Chris Jones to set code (NOT result) to
                       error_table_$blank_tape.
  2) change(86-02-13,GWMay), approve(86-02-13,MCR7337), audit(86-03-11,Farley),
     install(86-03-17,MR12.0-1030):
     removed a section of code from the end of "missing_statuses" which checked
     for the initiate bit to be on and set the status index up by 1. This code
     would not always work with the FIPS tape drives.
  3) change(87-07-06,Hartogs), approve(87-07-06,MCR7726),
     audit(87-08-27,GWMay), install(87-08-27,MR12.1-1094):
     A) If first record is written, set tai.at_bot to "0"b
     B) Set tai.density_command for use by error_retry.
     C) Added an unspec (tai.order_data(*)) = ""b to compensate for a
        bug in ioi_.
                                                   END HISTORY COMMENTS */


/* This is where all the tape tape_ioi_ I/O is done.  There are entries to read, write, perform
   random order commands, and check on any of the preceding. */

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

/**** NOTE
      This program uses the "code" output argument ambiguously.
      For some entrypoints, such as check_write, code will be set
      nonzero even though the other output arguments are valid.
      In particular, check_write will return code = error_table_$device_end
      AND TAPE_IO_EOT when the EOT reflector is detected on write. */

/* Parameters */

dcl	p_buffer_data_ptr	   ptr parameter;		/* (I/O) pointer to  the data to be or just processed */
dcl	p_code		   fixed bin (35) parameter;	/* (O) system status code */
dcl	p_icount		   fixed bin parameter;	/* (I) count of orders to be done */
dcl	p_ocount		   fixed bin parameter;	/* (O) count of orders actually done */
dcl	p_data_len	   fixed bin (21) parameter;	/* (I/O) data count in characters */
dcl	p_order_data_ptr	   ptr parameter;		/* (I) data area for order commands */
dcl	p_order		   char (4) parameter;	/* (I) the order to be performed */
dcl	p_result_idx	   fixed bin parameter;	/* (O) encoding of relative success of operation */
dcl	p_tioi_id		   bit (36) aligned parameter;/* (I) tape_ioi_ activation ID */
dcl	p_write_buffers	   (*) ptr parameter;	/* (I) list of buffers to write */

/* Automatic variables */

dcl	auto_special_status	   bit (36) aligned;
dcl	buffer_idx	   fixed bin;
dcl	buffer_ptr	   ptr;
dcl	code		   fixed bin (35);
dcl	device_command	   bit (6);
dcl	idcw_idx		   fixed bin;
dcl	lost_statuses	   fixed bin;
dcl	next_buffer_offset	   fixed bin (18) unsigned unaligned;
dcl	recovery_strategy	   fixed bin (3) unsigned;
dcl	semi_queued_offset	   fixed bin (18) unsigned unaligned;
dcl	status_class	   char (2);
dcl	status_present	   bit (1) aligned;

/* Static storage */

dcl	order_mnemonics	   (0:21) char (4) static options (constant)
			   init ("rdy", "bsf", "bsr", "fsf", "fsr", "eof", "ers", "dse", "rew", "run", "lod", "rqs",
			   "rss", "rqd", "rsd", "den", "per", "pro", "rsv", "rel", "rcr", "wcr");

dcl	order_commands	   (0:21) bit (6) static options (constant)
			   init ("00"b3, "47"b3, "46"b3, "45"b3, "44"b3, "55"b3, "54"b3, "73"b3, "70"b3, "72"b3,
			   "75"b3, "00"b3, "40"b3, "50"b3, "51"b3, "77"b3, "63"b3, "62"b3, "66"b3, "67"b3, "26"b3,
			   "16"b3);

dcl	densities		   (5) fixed bin static options (constant) init (200, 556, 800, 1600, 6250);
dcl	density_commands	   (5) bit (6) static options (constant) init ("64"b3, "61"b3, "60"b3, "65"b3, "41"b3);

dcl	BITS_PER_BYTE	   fixed bin static options (constant) init (9);
dcl	BITS_PER_CHAR	   fixed bin static options (constant) init (6);
dcl	BITS_PER_WORD	   fixed bin static options (constant) init (36);
dcl	BYTES_PER_DCW_TALLY	   fixed bin static options (constant) init (16384);
dcl	BYTES_PER_WORD	   fixed bin static options (constant) init (4);
dcl	CHARS_PER_WORD	   fixed bin static options (constant) init (6);
dcl	ORDERS_PER_IDCW_TALLY  fixed bin static options (constant) init (64);
dcl	WORDS_PER_DCW_TALLY	   fixed bin static options (constant) init (4096);

dcl	TIMEOUT_IO	   fixed bin (71) static options (constant) init (30000000);
dcl	TIMEOUT_ORDER	   fixed bin (71) static options (constant) init (10000000);
dcl	TWENTY_SECONDS	   fixed bin (71) static options (constant) init (20000000);
dcl	MAX_RETRY_COUNT	   fixed bin static options (constant) init (10);

/* Externals */

dcl	ioi_$connect	   entry (fixed bin, fixed bin (18), fixed bin (35));
dcl	ioi_$get_detailed_status
			   entry (fixed bin, bit (1) aligned, bit (216), fixed bin (35));
dcl	ioi_$get_special_status
			   entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl	ioi_$timeout	   entry (fixed bin, fixed bin (71), fixed bin (35));
dcl	ipc_$drain_chn	   entry (fixed bin (71), fixed bin (35));
dcl	tape_ioi_buffer_man$internal_set_buffer_ready
			   entry (ptr, ptr);
dcl	tape_ioi_error_retry   entry (ptr, ptr, ptr, fixed bin (35));
dcl	tape_ioi_error_retry$backspace
			   entry (ptr, ptr, ptr, fixed bin, fixed bin (35));
dcl	tape_ioi_error_retry$eof
			   entry (ptr, fixed bin (35));
dcl	tape_ioi_hardware_status$hardware_status
			   entry (bit (36) aligned, ptr, fixed bin (35));
dcl	tape_ioi_utils$get_buffer_ptr
			   entry (ptr, ptr) returns (ptr);
dcl	tape_ioi_utils$get_status
			   entry (ptr) returns (ptr);
dcl	tape_ioi_utils$get_status_class
			   entry (ptr) returns (char (2));
dcl	tape_ioi_utils$get_workspace_ptr
			   entry (bit (36) aligned, ptr);
dcl	tape_ioi_utils$io_in_progress
			   entry (ptr) returns (bit (1) aligned);

dcl	error_table_$action_not_performed
			   fixed bin (35) ext static;
dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$bad_density
			   fixed bin (35) ext static;
dcl	error_table_$blank_tape
			   fixed bin (35) ext static;
dcl	error_table_$buffer_invalid_state
			   fixed bin (35) ext static;
dcl	error_table_$device_active
			   fixed bin (35) ext static;
dcl	error_table_$device_attention
			   fixed bin (35) ext static;
dcl	error_table_$device_code_alert
			   fixed bin (35) ext static;
dcl	error_table_$device_end
			   fixed bin (35) ext static;
dcl	error_table_$device_not_active
			   fixed bin (35) ext static;
dcl	error_table_$device_parity
			   fixed bin (35) ext static;
dcl	error_table_$invalid_state
			   fixed bin (35) ext static;
dcl	error_table_$invalid_tape_record_length
			   fixed bin (35) ext static;
dcl	error_table_$lost_device_position
			   fixed bin (35) ext static;
dcl	error_table_$no_operation
			   fixed bin (35) ext static;
dcl	error_table_$unexpected_device_status
			   fixed bin (35) ext static;

/* Builtins */

dcl	(addr, addrel, bin, bit, clock, divide, hbound, lbound, min, mod, null, ptr, rel, size, string, substr, unspec)
			   builtin;

/* Vanilla operations.  They simply call the queue_* and check_* entries. */
order:
     entry (p_tioi_id, p_order, p_icount, p_order_data_ptr, p_ocount, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	call setup;
	call queue_order_proc (p_order, p_icount, p_order_data_ptr, code);
	if code = 0 then
	     call check_order_proc (p_ocount, p_result_idx, code);
	else p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;
	p_code = code;
	return;

read:
     entry (p_tioi_id, p_buffer_data_ptr, p_data_len, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	call setup;
	semi_queued_offset = 0;
	do buffer_ptr = ptr (wksp, tai.free_list_offset) repeat ptr (wksp, next_buffer_offset)
	     while (rel (buffer_ptr) ^= ""b & code = 0);
	     next_buffer_offset = buffer_ptr -> tbi.next_state_offset;
	     if ^buffer_ptr -> tbi.reserved then do;
		call queue_read_proc (buffer_ptr, code);
		if code = 0 then
		     tai.total_reads = tai.total_reads + 1;
	     end;
	end;
	call run ("0"b, code);			/* kick if necessary */
	if code = 0 then
	     call check_read_proc (p_buffer_data_ptr, p_data_len, p_result_idx, code);
	else p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;
	p_code = code;
	return;

write:
     entry (p_tioi_id, p_write_buffers, p_data_len, p_buffer_data_ptr, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	p_buffer_data_ptr = null ();
	call setup;
	semi_queued_offset = 0;

/* Queue any suspended buffers. */

	do buffer_ptr = ptr (wksp, susp_list_offset) repeat ptr (wksp, next_buffer_offset)
	     while (rel (buffer_ptr) ^= ""b & code = 0);
	     next_buffer_offset = buffer_ptr -> tbi.next_state_offset;
	     call queue_write_proc (buffer_ptr, buffer_ptr -> tbi.buffer_len, code);
	end;
	if code ^= 0 then do;
QUEUE_WRITE_ERROR:
	     call run ("1"b, (0));
	     p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;
	     call quit (code);
	end;

/* Now queue any buffers the caller passed us. */

	do buffer_idx = lbound (p_write_buffers, 1) to hbound (p_write_buffers, 1) while (code = 0);
	     if p_write_buffers (buffer_idx) ^= null () then do;
		buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_write_buffers (buffer_idx));
		if buffer_ptr = null () then
		     code = error_table_$bad_arg;
		else do;
		     buffer_ptr -> tbi.modes = tai.modes;
		     call queue_write_proc (buffer_ptr, p_data_len, code);
		     if code = 0 then
			tai.total_writes = tai.total_writes + 1;
		end;
	     end;
	end;
	if code ^= 0 then
	     goto QUEUE_WRITE_ERROR;
	call run ("1"b, (0));

/* Now return a pointer to a ready buffer */

	if tai.free_list_offset ^= 0 then do;
	     p_result_idx = TAPE_IO_SUCCESS;
	     p_buffer_data_ptr = ptr (wksp, ptr (wksp, tai.free_list_offset) -> tbi.data_offset);
	end;
	else call check_write_proc (p_buffer_data_ptr, p_result_idx, p_code);
	return;

/* The basic queueing and checking entries */

queue_order:
     entry (p_tioi_id, p_order, p_icount, p_order_data_ptr, p_code);

	call setup;
	call queue_order_proc (p_order, p_icount, p_order_data_ptr, p_code);
	return;

check_order:
     entry (p_tioi_id, p_ocount, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	call setup;
	call check_order_proc (p_ocount, p_result_idx, p_code);
	return;

queue_read:
     entry (p_tioi_id, p_buffer_data_ptr, p_code);

	call setup;
	semi_queued_offset = 0;
	buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_buffer_data_ptr);
	if buffer_ptr ^= null () then do;
	     call queue_read_proc (buffer_ptr, p_code);
	     if p_code = 0 then
		tai.total_reads = tai.total_reads + 1;
	end;
	else p_code = error_table_$bad_arg;
	call run ("0"b, (0));
	return;

check_read:
     entry (p_tioi_id, p_buffer_data_ptr, p_data_len, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	call setup;
	call check_read_proc (p_buffer_data_ptr, p_data_len, p_result_idx, p_code);
	return;

queue_write:
     entry (p_tioi_id, p_buffer_data_ptr, p_data_len, p_code);

	call setup;
	semi_queued_offset = 0;
	buffer_ptr = tape_ioi_utils$get_buffer_ptr (wksp, p_buffer_data_ptr);
	if buffer_ptr ^= null () then do;
	     call queue_write_proc (buffer_ptr, p_data_len, p_code);
	     if p_code = 0 then
		tai.total_writes = tai.total_writes + 1;
	end;
	else p_code = error_table_$bad_arg;
	call run ("1"b, (0));
	return;

check_write:
     entry (p_tioi_id, p_buffer_data_ptr, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	call setup;
	call check_write_proc (p_buffer_data_ptr, p_result_idx, p_code);
	return;

/* Entry to stop all tape motion. */

stop_tape:
     entry (p_tioi_id, p_ocount, p_result_idx, p_code);

	p_result_idx = TAPE_IO_USER_PROGRAM_ERROR;	/* in case setup doesn't return */
	call setup;

/* First see if nothing is going on.  It's not an error to call us in this case. */

	if ^tape_ioi_utils$io_in_progress (wksp) then do;
	     p_ocount = 0;
	     p_result_idx = TAPE_IO_SUCCESS;
	     return;
	end;

/* Something's happening.  We have to handle orders (both in order_idcw and in order_data), and queued I/O. */

	addr (tai.order_idcw) -> idcw.control = "00"b;
	do idcw_idx = lbound (tai.order_data, 1) to hbound (tai.order_data, 1);
	     idcwp = addr (tai.order_data (idcw_idx));
	     if idcw.code = "111"b then		/* don't hammer non-IDCWs */
		idcw.control = "00"b;
	end;

/* Now handle all queued buffers */

	do buffer_ptr = ptr (wksp, queue_list_offset) repeat ptr (wksp, buffer_ptr -> tbi.next_state_offset)
	     while (rel (buffer_ptr) ^= ""b);
	     addr (buffer_ptr -> tbi.idcw_word) -> idcw.control = "00"b;
	end;

/* We've set it up so that we'll stop when the next IDCW is fetched, or the operation finishes.
   Now, just hang on 'til the tape stops. */

	if ^tai.order_queued then
	     tai.order_count_done = 0;

	do while ("1"b);
	     call get_status (tai.modes.wait, STOP_TAPE_MAKE_CALLER_WAIT);
	     idcwp = ptr (wksp, bin (substr (istat.lpw, 1, 18)) - 1);
	     statp = addr (istat.iom_stat);
	     if tai.order_queued then
		tai.order_count_done = tai.order_count_done + bin (idcw.count) - bin (status.rcount);
	     else tai.order_count_done = tai.order_count_done + 1;
	     if ^istat.run then do;
		p_ocount = tai.order_count_done;
		p_result_idx = TAPE_IO_SUCCESS;
		do buffer_ptr = ptr (wksp, queue_list_offset) repeat ptr (wksp, next_buffer_offset)
		     while (rel (buffer_ptr) ^= ""b);
		     next_buffer_offset = buffer_ptr -> tbi.next_state_offset;
		     call tape_ioi_buffer_man$internal_set_buffer_ready (wksp, buffer_ptr);
		end;
		do buffer_ptr = ptr (wksp, susp_list_offset) repeat ptr (wksp, next_buffer_offset)
		     while (rel (buffer_ptr) ^= ""b);
		     next_buffer_offset = buffer_ptr -> tbi.next_state_offset;
		     call tape_ioi_buffer_man$internal_set_buffer_ready (wksp, buffer_ptr);
		end;
		tai.order_queued, tai.read_queued, tai.write_queued = "0"b;
		return;
	     end;
	end;

STOP_TAPE_MAKE_CALLER_WAIT:
	p_ocount = 0;
	p_result_idx = TAPE_IO_BLOCK;
	return;

queue_order_proc:
     proc (order, count, data_ptr, code);

dcl	code		   fixed bin (35) parameter;
dcl	count		   fixed bin parameter;
dcl	data_ptr		   ptr parameter;
dcl	order		   char (4) parameter;

dcl	order_idx		   fixed bin;

	if tape_ioi_utils$io_in_progress (wksp) then do;
	     code = error_table_$device_active;
	     return;
	end;
	idcwp = addr (tai.order_idcw);
	idcw.control = "00"b;			/* in case retries of an EOF had happened */
	unspec (tai.order_data (*)) = ""b;

	do order_idx = hbound (order_mnemonics, 1) to lbound (order_mnemonics, 1) by -1
	     while (order_mnemonics (order_idx) ^= order);
	end;
	goto QUEUE_ORDER (order_idx);

QUEUE_ORDER (-1):					/* unknown order */
	code = error_table_$no_operation;
	return;

/* The following orders take a tally */

QUEUE_ORDER (2):					/* backspace record */
QUEUE_ORDER (4):					/* forwardspace record */
	if count >= ORDERS_PER_IDCW_TALLY then
	     idcw.count = "00"b3;			/* do as many as we can */
	else idcw.count = bit (bin (count, 6), 6);
	goto QUEUE_ORDER_JOIN_1;

/* The density order is handled specially.  Its command data is the density to set. */

QUEUE_ORDER (15):					/* density */
	begin;

dcl	density		   fixed bin;
dcl	density_idx	   fixed bin;

dcl	requested_density	   fixed bin based (data_ptr);

	     density = requested_density;
	     do density_idx = lbound (densities, 1) to hbound (densities, 1) while (density ^= densities (density_idx));
	     end;
	     if density_idx > hbound (densities, 1) then do;
		code = error_table_$bad_density;
		return;
	     end;
	     idcw.count = "01"b3;
	     device_command = density_commands (density_idx);
	     tai.density_command = device_command;
	     goto QUEUE_ORDER_JOIN_2;
	end;

/* The following orders need to access the command data in some way.  The command data is copied
   to the order_data buffer. */

QUEUE_ORDER (21):					/* write control registers */
	begin;

dcl	error_counters	   (4) bit (36) aligned based;

	     addr (tai.order_data) -> error_counters = data_ptr -> error_counters;
	     idcw.count = "01"b3;
	     goto QUEUE_ORDER_JOIN_1;
	end;

/* The following orders are repeatable, but not by the controller.  So, we build a list of IDCWs in the order data
   buffer.  If more than 8 repetitions are requested, we'll notice that we're not done when the order completes,
   and fire up some more until we have done enough. */

QUEUE_ORDER (1):					/* backspace file */
QUEUE_ORDER (3):					/* forward space file */
QUEUE_ORDER (5):					/* write EOF */
QUEUE_ORDER (6):					/* erase */
	begin;

dcl	idcw_idx		   fixed bin;

	     idcwp = addr (tai.order_data);		/* use a different spot for the IDCWs */
	     idcw.command = order_commands (order_idx);
	     idcw.device = addr (tai.order_idcw) -> idcw.device;
	     idcw.ext = ""b;
	     idcw.code = "111"b;
	     idcw.ext_ctl = ""b;
	     idcw.control = "10"b;			/* continue, no marker */
	     idcw.chan_cmd = "02"b3;
	     idcw.count = "01"b3;

/* Now propogate the IDCW thru the order_data buffer.  Then set the last IDCW to show a terminate status. */

	     do idcw_idx = 2 to min (count, hbound (tai.order_data, 1));
		string (tai.order_data (idcw_idx)) = string (idcw);
	     end;
	     addr (tai.order_data (idcw_idx - 1)) -> idcw.control = "00"b;
	     goto QUEUE_ORDER_JOIN_3;
	end;

/* The request device status order is handled specially.  First, a call to ioi_$get_detailed_status is
   made.  If we get valid status from that, we use it.  If not, we actually connect the channel to
   get the status.  */

QUEUE_ORDER (13):					/* request device status */
	begin;

dcl	based_detailed_status  bit (216) based (data_ptr);

	     call ioi_$get_detailed_status (tai.ioi_index, status_present, based_detailed_status, code);

	end;

	if code ^= 0 then
	     return;
	if status_present then do;
	     tai.flags.order_done = "1"b;
	     tai.order_count_done = 1;
	     goto QUEUE_ORDER_JOIN_4;
	end;
	else goto QUEUE_ORDER_REQUEST_DEVICE_STATUS;

/* The following orders do not take a tally, are not repeatable, and access no command data (at least 'til check time) */

QUEUE_ORDER (0):					/* ready pseudo-order */
	tai.saved_special_status = ""b;
QUEUE_ORDER (7):					/* data security erase */
QUEUE_ORDER (8):					/* rewind */
QUEUE_ORDER (9):					/* rewind/unload */
QUEUE_ORDER (10):					/* tape load */
QUEUE_ORDER (11):					/* request status */
QUEUE_ORDER (12):					/* reset status */
QUEUE_ORDER_REQUEST_DEVICE_STATUS:			/* request device status */
QUEUE_ORDER (14):					/* reset device status */
QUEUE_ORDER (16):					/* set file permit */
QUEUE_ORDER (17):					/* set file protect */
QUEUE_ORDER (18):					/* reserve device */
QUEUE_ORDER (19):					/* release device */
QUEUE_ORDER (20):					/* read control registers */
	idcw.count = "01"b3;			/* done only once */
QUEUE_ORDER_JOIN_1:
	device_command = order_commands (order_idx);
QUEUE_ORDER_JOIN_2:					/* density orders enter here */
	idcw.command = device_command;
	if order_idx = 7 then
	     idcw.chan_cmd = "03"b3;			/* data security erase */
	else idcw.chan_cmd = "02"b3;			/* vanilla non-data transfer command */
QUEUE_ORDER_JOIN_3:					/* all of the order connects come here */
	if (order_idx >= 1 & order_idx <= 4) |		/* bsf, bsr, fsf, fsr */
	     order_idx = 7 then			/* dse */
	     call set_timeout (tai.max_timeout);
	else call set_timeout (TIMEOUT_ORDER);
	call connect (bin (rel (idcwp)), code);
QUEUE_ORDER_JOIN_4:					/* orders that need no connects enter here */
	if code = 0 then do;
	     tai.flags.order_queued = "1"b;
	     tai.order_count_requested = count;
	     tai.order_count_done = 0;
	     tai.order_idx = order_idx;
	     tai.order_data_ptr = data_ptr;
	     tai.total_orders = tai.total_orders + 1;
	     if order_mnemonics (order_idx) = "rew" then  /* Reset at_bot after rewind order */
		tai.at_bot = "1"b;
	end;

     end queue_order_proc;

check_order_proc:
     proc (count, result, code);

dcl	count		   fixed bin parameter;
dcl	result		   fixed bin parameter;
dcl	code		   fixed bin (35) parameter;

dcl	based_special_status   bit (36) aligned based (tai.order_data_ptr);

	if ^tai.order_queued then do;			/* there's nothing to check */
	     count = 0;
	     result = TAPE_IO_USER_PROGRAM_ERROR;
	     code = error_table_$invalid_state;
	     return;
	end;

	if tai.order_done then do;			/* queue_order finished for us */
	     tai.order_done = "0"b;
	     count = tai.order_count_done;
	     result = TAPE_IO_SUCCESS;
	     goto CHECK_ORDER_GOOD_RETURN;
	end;

/* See if we're awaiting special status.  This will only happen if we got an "SI" status after a "rdy" order */

NEED_SPECIAL_STATUS:
	if tai.flags.special_status_expected then do;	/* we must be doing a rdy */
	     call get_special_status (auto_special_status);
						/* might not return */
	     tai.saved_special_status = auto_special_status;

	     tai.flags.special_status_expected = "0"b;
	     call connect (bin (rel (addr (tai.order_idcw))), code);
	     if code ^= 0 then do;
		result = TAPE_IO_USER_PROGRAM_ERROR;
		count = 0;
		return;
	     end;
	end;

/* Not waiting for special status, must be normal status */

	count = 0;
	call get_status (tai.modes.wait, CHECK_ORDER_MAKE_CALLER_WAIT);
						/* might not return */
	goto CHECK_ORDER (tai.order_idx);		/* case by case */

CHECK_ORDER (0):					/* rdy */
	if status_class = "UE" then do;
	     code = error_table_$unexpected_device_status;
	     goto CHECK_ORDER_PROGRAM_ERROR;
	end;
	else if status_class = "SI" then do;
	     tai.special_status_expected = "1"b;
	     goto NEED_SPECIAL_STATUS;
	end;
	else do;
	     based_special_status = tai.saved_special_status;
	     count = 1;
	     result = TAPE_IO_SUCCESS;
	     goto CHECK_ORDER_GOOD_RETURN;
	end;

CHECK_ORDER (1):					/* backspace file */
	do while ("1"b);				/* exitted by a goto somewhere in the loop */
	     if status_class = "AB" then do;		/* at BOT */
		result = TAPE_IO_BOT;
		tai.at_bot = "1"b;
		count = repeatable_order_count ();
		goto CHECK_ORDER_DONE;
	     end;
	     else if (status_class = "EF") | (status_class = "OK") then
		call finish_repeatable_order;
	     else do;
CHECK_ORDER_NOT_PERFORMED:
		code = error_table_$action_not_performed;
		goto CHECK_ORDER_IO_ERROR;
	     end;
	end;

CHECK_ORDER (2):					/* backspace record */
	idcwp = addr (tai.order_idcw);		/* point at the IDCW */
	io_status_word_ptr = addr (istat.iom_stat);
	do while ("1"b);
	     if status_class = "AB" then do;
		result = TAPE_IO_BOT;
		tai.at_bot = "1"b;
		count = repeatable_order_count ();
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else if status_class = "EF" then do;
		result = TAPE_IO_EOF;
		count = repeatable_order_count ();
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else if status_class = "OK" then
		call finish_repeatable_order;		/* might not return */
	     else do;
		count = repeatable_order_count ();
		goto CHECK_ORDER_NOT_PERFORMED;
	     end;
	end;

CHECK_ORDER (3):					/* forward space file */
	do while ("1"b);				/* exit via a goto in the loop */
	     if status_class = "ET" then do;		/* at EOT */
		result = TAPE_IO_EOT;
		count = repeatable_order_count ();
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else if (status_class = "EF") | (status_class = "OK") then
		call finish_repeatable_order;		/* might not return */
	     else goto CHECK_ORDER_NOT_PERFORMED;
	end;

CHECK_ORDER (4):					/* forward space record */
	idcwp = addr (tai.order_idcw);		/* point at the IDCW */
	io_status_word_ptr = addr (istat.iom_stat);
	do while ("1"b);
	     if status_class = "EF" then do;		/* EOF */
		result = TAPE_IO_EOF;
		count = repeatable_order_count ();
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else if status_class = "ET" then do;
		result = TAPE_IO_EOT;
		count = repeatable_order_count ();
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else if status_class = "OK" then
		call finish_repeatable_order;		/* might not return */
	     else do;
		count = repeatable_order_count ();
		goto CHECK_ORDER_NOT_PERFORMED;
	     end;
	end;

CHECK_ORDER (5):					/* write EOF */
	do while ("1"b);				/* exitted by goto */
	     if status_class = "ET" then do;
		if tai.retry_in_progress & (istat.offset < bin (rel (addr (tai.order_data)))) then
						/* backspace and erase finished, but not EOF, so reconnect */
		     call finish_repeatable_order ();

		result = TAPE_IO_EOT;
		count = repeatable_order_count ();
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else if (status_class = "EF") | (status_class = "OK") then
		call finish_repeatable_order ();
	     else if (status_class = "DA") | (status_class = "DE") then do;
		tai.order_count_done = repeatable_order_count () - 1;
						/* the last one was in error, so don't count it */
		tai.order_errors = tai.order_errors + 1;
		if tai.retry_count < MAX_RETRY_COUNT then do;
		     tai.retry_count = tai.retry_count + 1;
		     call refill_order_list ();
		     call tape_ioi_error_retry$eof (wksp, code);
		     if code ^= 0 then
			goto CHECK_ORDER_PROGRAM_ERROR;
		     call get_status (tai.modes.wait, CHECK_ORDER_MAKE_CALLER_WAIT);
		end;
		else do;
		     if status_class = "DE" then
			result = TAPE_IO_RECOVERABLE_IO_ERROR_AND_EOT;
		     else result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		     code = error_table_$device_parity;
		     goto CHECK_ORDER_DONE;
		end;
	     end;
	     else goto CHECK_ORDER_NOT_PERFORMED;
	end;

CHECK_ORDER (6):					/* erase */
	if status_class = "OK" then
	     call finish_repeatable_order ();
	else if status_class = "ET" then do;
	     count = repeatable_order_count ();
	     result = TAPE_IO_EOT;
	     goto CHECK_ORDER_GOOD_RETURN;
	end;
	else goto CHECK_ORDER_NOT_PERFORMED;

/* These orders return data to the caller */

CHECK_ORDER (11):					/* request status */
	call tape_ioi_hardware_status$hardware_status (unspec (tai.tioi_id), tai.order_data_ptr, code);
	if code = 0 then do;
	     count = 1;
	     result = TAPE_IO_SUCCESS;
	     goto CHECK_ORDER_GOOD_RETURN;
	end;
	else goto CHECK_ORDER_PROGRAM_ERROR;

CHECK_ORDER (13):					/* request device status */
	count = 1;
	result = TAPE_IO_SUCCESS;

	begin;

dcl	based_detailed_status  bit (216) based;

	     tai.order_data_ptr -> based_detailed_status = addr (tai.order_data) -> based_detailed_status;

	end;

	goto CHECK_ORDER_GOOD_RETURN;

CHECK_ORDER (20):					/* read control registers */
	count = 1;
	if ^((status_class = "AB") | (status_class = "OK")) then
	     goto CHECK_ORDER_NOT_PERFORMED;

	begin;

dcl	error_counters	   (4) bit (36) aligned based;

	     tai.order_data_ptr -> error_counters = addr (tai.order_data) -> error_counters;
	     result = TAPE_IO_SUCCESS;
	     goto CHECK_ORDER_GOOD_RETURN;
	end;

/* The following orders do not need to return any information, and can only be done once. */

CHECK_ORDER (7):					/* data security erase */
CHECK_ORDER (8):					/* rewind */
CHECK_ORDER (9):					/* rewind/unload */
CHECK_ORDER (10):					/* tape load */
CHECK_ORDER (12):					/* reset status */
CHECK_ORDER (14):					/* reset device status */
CHECK_ORDER (15):					/* set density */
CHECK_ORDER (16):					/* set file permit */
CHECK_ORDER (17):					/* set file protect */
CHECK_ORDER (18):					/* reserve device */
CHECK_ORDER (19):					/* release device */
CHECK_ORDER (21):					/* write control registers */
	if (status_class = "AB") | (status_class = "OK") then do;
	     count = 1;
	     result = TAPE_IO_SUCCESS;
	     if status_class = "AB" then
	        tai.at_bot = "1"b;
	     goto CHECK_ORDER_GOOD_RETURN;
	end;
	else goto CHECK_ORDER_NOT_PERFORMED;

CHECK_ORDER_IO_ERROR:				/* the order is done, but I/O errors occurred */
	result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
	tai.order_errors = tai.order_errors + 1;
	if status_class = "DN" then
	     code = error_table_$bad_density;
	else code = error_table_$action_not_performed;
	goto CHECK_ORDER_DONE;

CHECK_ORDER_PROGRAM_ERROR:
	result = TAPE_IO_USER_PROGRAM_ERROR;
	goto CHECK_ORDER_DONE;

CHECK_ORDER_GOOD_RETURN:				/* the order is done, no errors */
	code = 0;
CHECK_ORDER_DONE:					/* the order is completed, with or without an error */
	tai.order_queued = "0"b;
	tai.retry_in_progress = "0"b;
	return;

/* Routine which is called when special status is expected (for example, when the tape is rewinding).  This routine
   will go blocked exactly once waiting for the special status.  If no special status is returned after going blocked
   (i.e. the two minute timer went off), it hands back a special status of "0"b.  It is up to its caller to decide
   what to do next. */

get_special_status:
	proc (status);

dcl	status		   bit (36) aligned;

	     call ioi_$get_special_status (tai.ioi_index, status_present, status, code);
	     if status_present then
		return;

	     if tai.modes.wait then do;		/* we can block */
		call block;
		call ioi_$get_special_status (tai.ioi_index, status_present, status, code);
	     end;
	     else goto CHECK_ORDER_MAKE_CALLER_WAIT;	/* no time to wait... */

	end get_special_status;

CHECK_ORDER_MAKE_CALLER_WAIT:
	result = TAPE_IO_BLOCK;			/* make our caller wait */
	count = 0;
	code = 0;
	return;					/* get out of the loop */

/* This function returns the number of times the order has been executed. */

repeatable_order_count:
	proc () returns (fixed bin);

	     if (tai.order_idx = 2) | (tai.order_idx = 4) then
						/* forward or backward space records */
		if idcw.count = "00"b3 then
		     return (ORDERS_PER_IDCW_TALLY - bin (io_status_word.rcount) + tai.order_count_done);
		else return (bin (idcw.count) - bin (io_status_word.rcount) + tai.order_count_done);

	     else return (istat.offset - bin (rel (addr (tai.order_data))) + tai.order_count_done + 1);

	end repeatable_order_count;

/* This routine is called by a repeatable order handler when it is possible that the order is done.
   If so, it does not return to its caller, but just finishes up and signals success.  If there is
   still work to be done, it restarts the I/O.  It either blocks, if that is allowed, or signals that
   it's up to the user to block. */

finish_repeatable_order:
	proc;

	     tai.order_count_done = repeatable_order_count ();
	     if tai.order_count_done >= tai.order_count_requested then do;
		count = tai.order_count_done;
		result = TAPE_IO_SUCCESS;
		goto CHECK_ORDER_GOOD_RETURN;
	     end;
	     else do;
		call refill_order_list;
		call reconnect;
		call get_status (tai.modes.wait, CHECK_ORDER_MAKE_CALLER_WAIT);
	     end;

	end finish_repeatable_order;

/* This subroutine sets up the order list to continue from a repeatable order. */

refill_order_list:
	proc;

	     if (tai.order_idx = 2) | (tai.order_idx = 4) then
						/* forward or backward space records */
		if tai.order_count_requested - tai.order_count_done >= ORDERS_PER_IDCW_TALLY then
		     idcw.count = "00"b3;
		else idcw.count = bit (bin (tai.order_count_requested - tai.order_count_done, 6), 6);
	     else					/* If there are at least hbound (tai.order_data, 1) orders left to do, leave the list alone.
						   If there are less, set the stop bits in the IDCW. */
		if (tai.order_count_requested - tai.order_count_done) < hbound (tai.order_data, 1) then
		addr (tai.order_data (tai.order_count_requested - tai.order_count_done)) -> idcw.control = "00"b;

	end refill_order_list;

reconnect:
	proc;

	     if (tai.order_idx = 2) | (tai.order_idx = 4) then
		call connect (bin (rel (addr (tai.order_idcw))), code);
	     else call connect (bin (rel (addr (tai.order_data))), code);
	     if code ^= 0 then do;
		goto CHECK_ORDER_PROGRAM_ERROR;
	     end;

	end reconnect;

     end check_order_proc;

/* This procedure sets up one buffer for reading */

queue_read_proc:
     proc (buffer_ptr, code);

dcl	buffer_ptr	   ptr parameter;
dcl	code		   fixed bin (35) parameter;

	if tai.order_queued | tai.write_queued then do;
	     code = error_table_$invalid_state;
	     return;
	end;
	if buffer_ptr -> tbi.state ^= READY_STATE then do;
	     code = error_table_$buffer_invalid_state;
	     return;
	end;

	buffer_ptr -> tbi.modes = tai.modes;
	buffer_ptr -> tbi.state = QUEUED_STATE;
	idcwp = addr (buffer_ptr -> tbi.idcw_word);
	idcw.command = buffer_ptr -> tbi.modes.data_code; /* type of read command depends on data type */
	idcw.control = "00"b;			/* terminate */
	if buffer_ptr -> tbi.modes.recovery then
	     idcw.chan_cmd = "30"b3;			/* use normal values, auto-retry */
	else idcw.chan_cmd = buffer_ptr -> tbi.modes.cif_code;
	idcw.count = "00"b3;
	buffer_ptr -> tbi.data_len = buffer_ptr -> tbi.buffer_len;
	call fill_dcw_list (buffer_ptr);
	call remove_from_list (tai.free_list_offset, buffer_ptr);
	call add_to_list (semi_queued_offset, bin (rel (buffer_ptr)));

     end queue_read_proc;

check_read_proc:
     proc (buffer_data_ptr, data_len, result, code);

dcl	buffer_data_ptr	   ptr parameter;
dcl	data_len		   fixed bin (21) parameter;
dcl	result		   fixed bin parameter;
dcl	code		   fixed bin (35) parameter;

dcl	done		   bit (1) aligned;
dcl	xcode		   fixed bin (35);

	if ^tai.read_queued then do;
	     buffer_data_ptr = null ();
	     data_len = 0;
	     result = TAPE_IO_USER_PROGRAM_ERROR;
	     code = error_table_$device_not_active;
	     return;
	end;

	buffer_ptr = ptr (wksp, tai.queue_list_offset);
	code = 0;

	done = "0"b;
	do while (^done);
	     lost_statuses = -1;			/* so loop will loop */
	     do while (lost_statuses < 0);
		call get_status (buffer_ptr -> tbi.modes.wait, CHECK_READ_MAKE_CALLER_WAIT);
		lost_statuses = missing_statuses (buffer_ptr, isp);
		if lost_statuses < 0 then
		     tai.extra_statuses = tai.extra_statuses + 1;
	     end;
	     done = "1"b;				/* until proven otherwise... */
	     if lost_statuses ^= 0 then do;
		tai.times_status_lost = tai.times_status_lost + 1;
		if buffer_ptr -> tbi.modes.req_len then do;
		     addr (buffer_ptr -> tbi.idcw_word) -> idcw.control = "00"b;
						/* since we missed one, take no chances */
		     tai.retry_in_progress = "1"b;
		     do while (istat.run);
CHECK_READ_STOP_TAPE:
			call get_status ("0"b, CHECK_READ_STOP_TAPE);
		     end;
		     lost_statuses = missing_statuses (buffer_ptr, isp);
		     tai.order_count_requested = lost_statuses;
						/* in case we're at EOF and have to try again */
CHECK_READ_BACKSPACE:
		     call tape_ioi_error_retry$backspace (wksp, buffer_ptr, isp, lost_statuses, code);
		     if code = 0 then
			done = "0"b;
		     else do;
			result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
			code = error_table_$lost_device_position;
		     end;
		end;
		else do;				/* we lost it, but we don't care: it was good status */
		     istat.st = "1"b;
		     tai.status_entry_idx = mod (tai.status_entry_idx - 1, tai.status_entry_count);
		     isp = ptr (wksp,
			tai.status_queue_offset
			+ mod (tai.status_entry_idx - 1, tai.status_entry_count) * size (istat));
		     istat.level = IO_MARKER_INTERRUPT_LEVEL;
						/* we know it must have been */
		     istat.run = "1"b;
		     istat.er = "0"b;
		     status_class = "OK";		/* since it didn't stop, there must have been no error */
		     result = TAPE_IO_SUCCESS;
		end;
	     end;
	     else if status_class = "OK" then
		result = TAPE_IO_SUCCESS;
	     else if status_class = "UE" then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$device_parity;
	     end;
	     else if status_class = "AB" then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$unexpected_device_status;
	     end;
	     else if status_class = "SI" then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$device_attention;	/* probably */
	     end;
	     else if status_class = "DN" then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$bad_density;
	     end;
	     else if status_class = "EF" then do;
		if tai.retry_in_progress then do;
		     tai.order_count_requested = tai.order_count_requested - 1;
		     lost_statuses = tai.order_count_requested;
		     goto CHECK_READ_BACKSPACE;	/* try again */
		end;
		else result = TAPE_IO_EOF;
	     end;
	     else if status_class = "ET" then do;
		result = TAPE_IO_EOT;
		code = error_table_$device_end;
	     end;
	     else if status_class = "BT" then do;
		result = TAPE_IO_EOT;
		code = error_table_$blank_tape;
	     end;
	     else if status_class = "BL" then do;
		if ^tai.suspect_short_record then do;	/* first time we've had this problem on this buffer */
		     tai.suspect_short_record = "1"b;
/**** fell for the short record in the long DCW list trick (3rd time this month) */
		     semi_queued_offset = bin (rel (buffer_ptr));
		     tai.queue_list_offset = 0;
		     call run ("0"b, code);
		     if code ^= 0 then
			goto CHECK_READ_LIST_PROBLEM;
		     else done = "0"b;
		end;
		else do;
CHECK_READ_LIST_PROBLEM:
		     result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		     code = error_table_$unexpected_device_status;
		end;
	     end;
	     else if (status_class = "DA") | (status_class = "DE") | (status_class = "IP") then do;
						/* retryable error */
		if buffer_ptr -> tbi.recovery then do;
		     tai.retry_in_progress = "1"b;
		     call tape_ioi_error_retry (wksp, buffer_ptr, isp, code);
		     if code = 0 then
			done = "0"b;		/* keep on trying */
		     else do;
			result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
			if code ^= error_table_$bad_density then
			     code = error_table_$device_parity;
		     end;
		end;
		else do;				/* user want to handle it without our help */
		     result = TAPE_IO_RECOVERABLE_IO_ERROR;
		     code = error_table_$device_parity;
		end;
	     end;
	     else if status_class = "CA" then do;	/* code alert */
		code = error_table_$device_code_alert;
		if buffer_ptr -> tbi.modes.data_code = "05"b3 | buffer_ptr -> tbi.modes.data_code = "04"b3
		     | buffer_ptr -> tbi.modes.data_code = "03"b3 then
		     result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		else result = TAPE_IO_CODE_ALERT;
	     end;
	end;

	call remove_from_list (tai.queue_list_offset, buffer_ptr);
	if result = TAPE_IO_SUCCESS then do;
	     recovery_strategy = bin (substr (addr (buffer_ptr -> tbi.idcw_word) -> idcw.chan_cmd, 4, 3));
	     if recovery_strategy ^= 0 then
		tai.recovery_succeeded (recovery_strategy) = tai.recovery_succeeded (recovery_strategy) + 1;
	     tai.at_bot = "0"b;
	     call keep_it_going (isp, xcode);
	     if xcode ^= 0 then
		code = xcode;
	end;
	else do;
	     begin;

dcl	buffer_ptr	   ptr;

		semi_queued_offset = tai.queue_list_offset;
		tai.queue_list_offset = 0;
		do buffer_ptr = ptr (wksp, semi_queued_offset)
		     repeat ptr (wksp, buffer_ptr -> tbi.next_state_offset) while (rel (buffer_ptr) ^= ""b);
		     buffer_ptr -> tbi.state = READY_STATE;
		     tai.total_reads = tai.total_reads - 1;
		end;
	     end;
	     call add_to_list (tai.free_list_offset, semi_queued_offset);
	     if result ^= TAPE_IO_EOF & result ^= TAPE_IO_EOT then
		tai.read_errors = tai.read_errors + 1;
	end;

	buffer_ptr -> tbi.state = READY_STATE;
	call add_to_list (tai.free_list_offset, bin (rel (buffer_ptr)));

	if buffer_ptr -> tbi.modes.req_len then
	     data_len = get_io_byte_count (buffer_ptr, isp);
	buffer_data_ptr = ptr (wksp, buffer_ptr -> tbi.data_offset);
	tai.read_queued = (tai.queue_list_offset ^= 0);
	tai.suspect_short_record = "0"b;
	tai.retry_in_progress = "0"b;
	return;

CHECK_READ_MAKE_CALLER_WAIT:
	buffer_data_ptr = null ();
	data_len = 0;
	result = TAPE_IO_BLOCK;
	code = 0;
	return;

     end check_read_proc;

queue_write_proc:
     proc (buffer_ptr, data_len, code);

dcl	buffer_ptr	   ptr parameter;
dcl	data_len		   fixed bin (21) parameter;
dcl	code		   fixed bin (35) parameter;
dcl	1 char_position_overlay
			   based (addr (idcw.count)) unaligned,
	  2 tcp		   fixed bin (3) unsigned,	/* terminate character position */
	  2 icp		   fixed bin (3) unsigned;	/* initial character position */

	if tai.order_queued | tai.read_queued then do;
	     code = error_table_$invalid_state;
	     return;
	end;

	if (buffer_ptr -> tbi.state ^= READY_STATE) & (buffer_ptr -> tbi.state ^= SUSPENDED_STATE) then do;
	     code = error_table_$buffer_invalid_state;
	     return;
	end;

	buffer_ptr -> tbi.modes = tai.modes;
	idcwp = addr (buffer_ptr -> tbi.idcw_word);
	idcw.command = (buffer_ptr -> tbi.modes.data_code) | "10"b3;
						/* make a write command out of the mode */
	idcw.control = "00"b;			/* terminate */
	idcw.chan_cmd = "00"b3;

/* Length processing is somewhat hairy.  The whole thing is described in MTB-383, pp. 16-17. */

	if buffer_ptr -> tbi.modes.length then do;	/* special length mode, anything goes */
	     idcw.count = "00"b3;			/* reset both TCP and ICP initially */
	     if ascii_mode (buffer_ptr) then do;	/* controller is in ASCII mode */
						/* the ICP is 0, we set only the TCP */
		if buffer_ptr -> tbi.modes.data_code = "25"b3 then
		     char_position_overlay.tcp = mod (data_len, CHARS_PER_WORD);
		else char_position_overlay.tcp = mod (data_len, BYTES_PER_WORD);
		buffer_ptr -> tbi.data_len = data_len;
	     end;
	     else do;				/* no special ICP/TCP hackery */
		if mod (data_len, BYTES_PER_WORD) ^= 0 then
		     buffer_ptr -> tbi.data_len = data_len + 1;
		else buffer_ptr -> tbi.data_len = data_len;
	     end;
	end;
	else do;
	     if mod (data_len, BYTES_PER_WORD) ^= 0 then do;
		code = error_table_$invalid_tape_record_length;
		return;
	     end;
	     else do;
		buffer_ptr -> tbi.data_len = data_len;
		idcw.count = "00"b3;
	     end;
	end;

	if buffer_ptr -> tbi.state = READY_STATE then
	     call remove_from_list (tai.free_list_offset, buffer_ptr);
	else call remove_from_list (tai.susp_list_offset, buffer_ptr);
	call fill_dcw_list (buffer_ptr);
	buffer_ptr -> tbi.state = QUEUED_STATE;
	call add_to_list (semi_queued_offset, bin (rel (buffer_ptr)));

     end queue_write_proc;

check_write_proc:
     proc (buffer_data_ptr, result, code);

dcl	buffer_data_ptr	   ptr parameter;
dcl	result		   fixed bin parameter;
dcl	code		   fixed bin (35) parameter;

dcl	done		   bit (1) aligned;
dcl	xcode		   fixed bin (35);

	if ^tai.write_queued then do;
	     buffer_data_ptr = null ();
	     result = TAPE_IO_USER_PROGRAM_ERROR;
	     code = error_table_$device_not_active;
	     return;
	end;

	buffer_ptr = ptr (wksp, tai.queue_list_offset);
	code = 0;

	done = "0"b;
	do while (^done);
	     lost_statuses = -1;			/* so loop will loop */
	     do while (lost_statuses < 0);
		call get_status (buffer_ptr -> tbi.modes.wait, CHECK_WRITE_MAKE_CALLER_WAIT);
		lost_statuses = missing_statuses (buffer_ptr, isp);
		if lost_statuses < 0 then
		     tai.extra_statuses = tai.extra_statuses + 1;
	     end;
	     done = "1"b;				/* until proven otherwise... */
	     if lost_statuses ^= 0 then do;
		tai.times_status_lost = tai.times_status_lost + 1;
		istat.st = "1"b;			/* save this one for later */
		tai.status_entry_idx = mod (tai.status_entry_idx - 1, tai.status_entry_count);
		isp = ptr (wksp,
		     tai.status_queue_offset + mod (tai.status_entry_idx - 1, tai.status_entry_count) * size (istat));
		istat.level = IO_MARKER_INTERRUPT_LEVEL;/* we know it must have been */
		istat.run = "1"b;
		istat.er = "0"b;
		status_class = "OK";		/* since it didn't stop, there must have been no error */
	     end;

	     if status_class = "OK" then
		result = TAPE_IO_SUCCESS;
	     else if (status_class = "AB") | (status_class = "EF") then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$unexpected_device_status;
	     end;
	     else if status_class = "SI" then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$device_attention;
	     end;
	     else if status_class = "UE" then do;
		result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
		code = error_table_$device_parity;
	     end;
	     else if status_class = "ET" then do;
		if tai.retry_in_progress
		     & istat.offset < bin (rel (addr (tai.order_data (hbound (tai.order_data, 1))))) then do;
/**** We were retrying, and the backspace and erase were done, but the write wasn't.  Reconnect it. */
		     semi_queued_offset = tai.queue_list_offset;
		     tai.queue_list_offset = 0;
		     call run ("1"b, code);
		     if code ^= 0 then
			result = TAPE_IO_USER_PROGRAM_ERROR;
		     else done = "0"b;
		end;
		else do;
		     result = TAPE_IO_EOT;
		     code = error_table_$device_end;
		end;
	     end;
	     else if status_class = "BT" then do;
		result = TAPE_IO_EOT;
		code = error_table_$blank_tape;
	     end;
	     else if (status_class = "DA") | (status_class = "DE")
		| ((status_class = "IP") & (buffer_ptr -> tbi.modes.data_code ^= "03"b3)) then do;
						/* retryable error */
		tai.write_errors = tai.write_errors + 1;
		if buffer_ptr -> tbi.recovery then do;
		     if tai.retry_count < MAX_RETRY_COUNT then do;
			tai.retry_in_progress = "1"b;
			tai.retry_count = tai.retry_count + 1;
			call tape_ioi_error_retry (wksp, buffer_ptr, isp, code);
			if code = 0 then
			     done = "0"b;		/* keep on trying */
			else do;
CHECK_WRITE_CANT_RECOVER:
			     if status_class = "DE" then
				result = TAPE_IO_RECOVERABLE_IO_ERROR_AND_EOT;
			     else result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
			     if code ^= error_table_$bad_density then
				code = error_table_$device_parity;
			end;
		     end;
		     else do;			/* user wants no help */
			if status_class = "DE" then
			     result = TAPE_IO_RECOVERABLE_IO_ERROR_AND_EOT;
			else result = TAPE_IO_RECOVERABLE_IO_ERROR;
			code = error_table_$device_parity;
		     end;
		end;
		else goto CHECK_WRITE_CANT_RECOVER;
	     end;
	     else if (status_class = "CA") | (status_class = "IP") then do;
						/* code alert */
		code = error_table_$device_code_alert;
		if buffer_ptr -> tbi.modes.data_code = "03"b3 | buffer_ptr -> tbi.modes.data_code = "25"b3 then
		     result = TAPE_IO_CODE_ALERT;
		else result = TAPE_IO_UNRECOVERABLE_IO_ERROR;
	     end;
	end;

	call remove_from_list (tai.queue_list_offset, buffer_ptr);
	if result = TAPE_IO_SUCCESS then do;
	     tai.at_bot = "0"b;
	     call keep_it_going (isp, xcode);
	     if xcode ^= 0 then
		code = xcode;
	end;
	else do;					/* suspend all pending writes */
	     begin;

dcl	buffer_ptr	   ptr;

		semi_queued_offset = tai.queue_list_offset;
		tai.queue_list_offset = 0;
		do buffer_ptr = ptr (wksp, semi_queued_offset)
		     repeat ptr (wksp, buffer_ptr -> tbi.next_state_offset) while (rel (buffer_ptr) ^= ""b);
		     buffer_ptr -> tbi.state = SUSPENDED_STATE;
		end;
	     end;
	     call add_to_list (tai.susp_list_offset, semi_queued_offset);
	     if result ^= TAPE_IO_EOT then
		tai.write_errors = tai.write_errors + 1;
	end;

	buffer_ptr -> tbi.state = READY_STATE;
	call add_to_list (tai.free_list_offset, bin (rel (buffer_ptr)));

	buffer_data_ptr = ptr (wksp, buffer_ptr -> tbi.data_offset);
	tai.write_queued = (tai.queue_list_offset ^= 0);
	tai.retry_in_progress = "0"b;
	tai.retry_count = 0;
	return;

CHECK_WRITE_MAKE_CALLER_WAIT:
	buffer_data_ptr = null ();
	result = TAPE_IO_BLOCK;
	code = 0;
	return;

     end check_write_proc;

/* This function figures out the number of bytes which were transferred for a given I/O operation.  Note that
   these are 9-bit bytes.  If the I/O operation transferred 6-bit characters, our calculation may be a
   little off.  This is known as "too bad". */

get_io_byte_count:
     proc (buffer_ptr, status_ptr) returns (fixed bin (21));

dcl	buffer_ptr	   ptr parameter;
dcl	status_ptr	   ptr parameter;

/* First, we have to fudge a little bit on certain statuses.  The justification for this is in
   the EPS for the MTS0610 Magnetic Tape Subsystem, Spec #58033915.  The fudging is derived from
   the table on page 38. */

	statp = addr (status_ptr -> istat.iom_stat);
	if (^writing ()) & (^ascii_mode (buffer_ptr)) & (^status.eo) & (status_tcp () = 1) then do;
	     status.char_pos = "0"b3;
	     status.eo = "1"b;
	end;

/* Next, adjust the LPW residue.  On a marker interrupt, by the time io_manager gets around to picking up the LPW,
   it has been advanced.  We use the DCW address residue in the status to decide where the LPW was pointing. */

	if status.marker then
	     substr (status_ptr -> istat.lpw, 1, 18) =
		bit (
		bin (bin (rel (addr (buffer_ptr -> tbi.dcw_words)), 18)
		+ divide (bin (status.address) - (buffer_ptr -> tbi.data_offset), WORDS_PER_DCW_TALLY, 12) + 1, 18),
		18);

/* If the initiate bit is set in the status, no data was transferred (no tape movement occurred). */

	if status.initiate then
	     return (0);

/* The calculations have to be done differently depending on whether the operation was a read or a write,
   and on whether the channel was in ASCII mode or binary mode. */

	if writing () then do;			/* either all was written, or none, we claim... */
	     if status_ptr -> istat.er then
		return (0);			/* can't trust what's on the tape */
	     else return (buffer_ptr -> tbi.data_len);
	end;
	else do;					/* reading, we'll trust the counts */
	     if ascii_mode (buffer_ptr) then do;
		buffer_ptr -> tbi.data_len =
		     word_count () * BYTES_PER_WORD - mod (BYTES_PER_WORD - status_tcp (), BYTES_PER_WORD);
		buffer_ptr -> tbi.bit_len = (buffer_ptr -> tbi.data_len) * BITS_PER_BYTE;
	     end;
	     else do;
		buffer_ptr -> tbi.bit_len =
		     BITS_PER_WORD * (word_count () - 1 - bin (status.eo))
		     + BITS_PER_CHAR * (BITS_PER_CHAR - mod (BITS_PER_CHAR - status_tcp (), BITS_PER_CHAR));
		if (status.major = "0000"b) & ((status.sub & "001010"b) = "000000"b) then
		     buffer_ptr -> tbi.bit_len = buffer_ptr -> tbi.bit_len - bin (substr (status.sub, 1, 3));
		buffer_ptr -> tbi.data_len = divide (buffer_ptr -> tbi.bit_len, BITS_PER_BYTE, 21);
	     end;
	     return (buffer_ptr -> tbi.data_len);
	end;

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

	     return ((addr (buffer_ptr -> tbi.idcw_word) -> idcw.command & "10"b3) ^= "00"b3);

	end writing;

status_tcp:
	proc () returns (fixed bin (3));

	     return (bin (status.char_pos, 3));

	end status_tcp;

word_count:
	proc () returns (fixed bin (19));

dcl	dcw_idx		   fixed bin (9) unsigned;
dcl	dcw_ptr		   ptr;
dcl	wc		   fixed bin (19);

	     wc = 0;				/* no words yet */
	     dcw_idx = 1;				/* start with first DCW */
	     do dcw_ptr = addr (buffer_ptr -> tbi.dcw_words) repeat addrel (dcw_ptr, 1)
		while ((dcw_idx <= buffer_ptr -> tbi.ndcws)
		& (dcw_ptr ^= ptr (wksp, bin (substr (status_ptr -> istat.lpw, 1, 18)))));
		if dcw_ptr -> dcw.tally then
		     wc = wc + bin (dcw_ptr -> dcw.tally);
		else wc = wc + WORDS_PER_DCW_TALLY;	/* handle large tallies */
		dcw_idx = dcw_idx + 1;
	     end;
	     return (wc - bin (status.tally));

	end word_count;

     end get_io_byte_count;

/* This procedure is called after several queue_(read write)s.  It moves the list of semi-queued buffers
   to the end of the list of queued buffers.  If the queued list was empty, a connect is issued.  The reason
   we have a concept of semi-queued buffers is so that higher level routines can queue a list and issue
   one connect on it. */

run:
     proc (write_flag, code);

dcl	write_flag	   bit (1) aligned parameter;
dcl	code		   fixed bin (35) parameter;

dcl	bufp		   ptr;

	if tai.queue_list_offset = 0 then do;		/* no I/O currently happening */
	     call set_timeout (TIMEOUT_IO);
	     call connect (bin (rel (addr (ptr (wksp, semi_queued_offset) -> tbi.idcw_word))), code);
	     if code = 0 then do;
		if write_flag then
		     tai.write_queued = "1"b;
		else do;
		     tai.read_queued = "1"b;
		end;
		tai.queue_list_offset = semi_queued_offset;
	     end;
	     else do;				/* couldn't connect */
		do bufp = ptr (wksp, semi_queued_offset) repeat ptr (wksp, bufp -> tbi.next_state_offset)
		     while (rel (bufp) ^= ""b);
		     if write_flag then
			bufp -> tbi.state = SUSPENDED_STATE;
		     else bufp -> tbi.state = READY_STATE;
		end;
		if write_flag then
		     call add_to_list (tai.susp_list_offset, semi_queued_offset);
		else call add_to_list (tai.free_list_offset, semi_queued_offset);
	     end;
	end;
	else call add_to_list (tai.queue_list_offset, semi_queued_offset);

     end run;

/* This function is called to keep the tape spinning at top speed.  It reconnects the I/O
   if the current status shows a termination interrupt and the queued list shows that there is more
   I/O to be done (some race condition must have caused the IOM to miss the marker request).
   This routine should only be called if it is OK to continue--if error retries are to be done
   they should be done before this routine is called.  The buffer which just finished must have been
   removed from the queued list. */

keep_it_going:
     proc (status_ptr, code);

dcl	status_ptr	   ptr parameter;
dcl	code		   fixed bin (35) parameter;

	if (status_ptr -> istat.level = IO_TERMINATE_INTERRUPT_LEVEL) & (tai.queue_list_offset ^= 0) then do;
	     tai.times_tape_stopped = tai.times_tape_stopped + 1;
	     semi_queued_offset = tai.queue_list_offset;
	     tai.queue_list_offset = 0;
	     call run ((ptr (wksp, semi_queued_offset) -> tbi.idcw_word & "10"b3) ^= "0"b3, code);
	end;
	else code = 0;

     end keep_it_going;

/* Procedure to set the timeout value */

set_timeout:
     proc (time);

dcl	time		   fixed bin (71) parameter;

dcl	code		   fixed bin (35);

	if time ^= tai.cur_timeout then do;
	     call ioi_$timeout (tai.ioi_index, time, code);
	     if code = 0 then
		tai.cur_timeout = time;
	end;

     end set_timeout;

/* Procedure to do the IOI connect.  It will try to recover from an I/O in progress error. */

connect:
     procedure (offset, code);

dcl	offset		   fixed bin (18) parameter;
dcl	code		   fixed bin (35);

dcl	connect_attempt_count  fixed bin;
dcl	give_up_time	   fixed bin (71);

dcl	TEN_SECONDS	   fixed bin (71) static options (constant) init (10000000);

	give_up_time = clock () + TEN_SECONDS;
	do while ("1"b);
	     do connect_attempt_count = 1 to 10;
		call ioi_$connect (tai.ioi_index, offset, code);
		if code ^= error_table_$device_active then
		     return;
	     end;
	     if clock () > give_up_time then
		return;
	end;

     end connect;

/* Function to return a pointer to the location the TDCW  will occupy.  This location
   depends on the amount of data in the buffer. */

get_tdcw_ptr:
     proc (buffer_ptr) returns (ptr);

dcl	buffer_ptr	   ptr parameter;

	return (
	     addrel (addr (buffer_ptr -> tbi.dcw_words),
	     divide ((buffer_ptr -> tbi.data_len) - 1, BYTES_PER_DCW_TALLY, 17) + 1));

     end get_tdcw_ptr;

/* This procedure returns a flag signifying whether the specified buffer is to be processed with the
   controller in ASCII mode.  Currently, only tape9 and ASCII/EBCDIC modes will do so. */

ascii_mode:
     proc (buffer_ptr) returns (bit (1) aligned);

dcl	buffer_ptr	   ptr parameter;

	return ((buffer_ptr -> tbi.modes.data_code = "03"b3) | (buffer_ptr -> tbi.modes.data_code = "25"b3));

     end ascii_mode;

/* Procedure to fill a DCW list for a given buffer.  Enough DCWs are set to fully describe all the data in the buffer */

fill_dcw_list:
     proc (buffer_ptr);

dcl	buffer_ptr	   ptr parameter;

dcl	dcw_addr_ptr	   ptr;
dcl	words_left	   fixed bin (19);

	do dcwp = first_dcwp () repeat next_dcwp () while (full_dcw_tally_needed ());
	     dcw.address = rel (dcw_addr_ptr);
	     dcw.char_pos = "0"b3;
	     dcw.m64 = "0"b;
	     dcw.type = "01"b;			/* IOTP */
	     dcw.tally = "0"b;			/* 0 => 4096 */
	end;

/* Now fill in the last DCW */

	dcw.address = rel (dcw_addr_ptr);
	dcw.char_pos = "0"b3;
	dcw.m64 = "0"b;
	dcw.type = "00"b;				/* IOTD */
	dcw.tally = bit (bin (words_left, 12), 12);
	return;

/* various internal functions to make the do loop above work */

first_dcwp:
	proc returns (ptr);

	     words_left = divide ((buffer_ptr -> tbi.data_len) - 1, BYTES_PER_WORD, 18) + 1;
	     dcw_addr_ptr = ptr (wksp, buffer_ptr -> tbi.data_offset);
	     return (addr (buffer_ptr -> tbi.dcw_words));

	end first_dcwp;

next_dcwp:
	proc returns (ptr);

	     words_left = words_left - WORDS_PER_DCW_TALLY;
	     dcw_addr_ptr = addrel (dcw_addr_ptr, WORDS_PER_DCW_TALLY);
	     return (addrel (dcwp, 1));

	end next_dcwp;

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

	     return (words_left > WORDS_PER_DCW_TALLY);

	end full_dcw_tally_needed;

     end fill_dcw_list;

/* Procedure to add a list of buffers to the end of another list.  This procedure will adjust
   the IDCW and TDCW of the previously last buffer in the list to point to the list it is adding.
   The buffers to be added must have their state set correctly (to that of the new list), and should
   not be on any other list. */

add_to_list:
     proc (list_head, new_list);

dcl	list_head		   fixed bin (18) unsigned unaligned parameter;
dcl	new_list		   fixed bin (18) unsigned unaligned parameter;

dcl	cur_buf_ptr	   ptr;
dcl	prev_buf_ptr	   ptr;

	prev_buf_ptr = null ();
	do cur_buf_ptr = ptr (wksp, list_head) repeat ptr (wksp, cur_buf_ptr -> tbi.next_state_offset)
	     while (rel (cur_buf_ptr) ^= ""b);
	     prev_buf_ptr = cur_buf_ptr;
	end;

	if prev_buf_ptr = null () then
	     list_head = new_list;			/* the original list was empty */
	else do;					/* graft it on */
	     idcwp = addr (prev_buf_ptr -> tbi.idcw_word);
	     tdcwp = get_tdcw_ptr (prev_buf_ptr);
	     prev_buf_ptr -> tbi.next_state_offset = new_list;
	     string (tdcw) = ""b;
	     tdcw.address = bit (bin (rel (addr (ptr (wksp, new_list) -> tbi.idcw_word)), 18), 18);
	     tdcw.type = "10"b;

/* This is a kludge.  If we are adding to the queued list, and it's been more than 20 seconds since
   we've received a terminate interrupt, don't let the list continue (this allows us to do the multiplexing at the
   physical channel level). */
	     if (list_head = tai.queue_list_offset) & (clock () > tai.last_terminate_time + TWENTY_SECONDS) then
		idcw.control = "00"b;		/* terminate */
	     else idcw.control = "11"b;		/* continue, marker */
	end;

     end add_to_list;

/* Procedure to remove a buffer from a given list.  The TDCW and IDCW of the surrounding buffers are
   adjusted as necessary (as are their list pointers). */

remove_from_list:
     proc (list_head, buffer_ptr);

dcl	list_head		   fixed bin (18) unsigned unaligned parameter;
dcl	buffer_ptr	   ptr parameter;

dcl	cbufp		   ptr;
dcl	pbufp		   ptr;

	pbufp = null ();
	do cbufp = ptr (wksp, list_head) repeat ptr (wksp, cbufp -> tbi.next_state_offset)
	     while ((rel (cbufp) ^= ""b) & (cbufp ^= buffer_ptr));
	     pbufp = cbufp;
	end;
	if cbufp ^= buffer_ptr then
	     return;				/* this is less than deluxe */
	if pbufp = null () then
	     list_head = cbufp -> tbi.next_state_offset;	/* don't have to fiddle with DCWs */
	else do;
	     pbufp -> tbi.next_state_offset = cbufp -> next_state_offset;
	     if pbufp -> tbi.next_state_offset = 0 then	/* new end of list */
		addr (pbufp -> tbi.idcw_word) -> idcw.control = "00"b;
	     get_tdcw_ptr (pbufp) -> tdcw = get_tdcw_ptr (cbufp) -> tdcw;
	end;
	cbufp -> tbi.next_state_offset = 0;

     end remove_from_list;

/* This procedure gets the status from the last tape operation, and sets status_class */

get_status:
     proc (wait_flag, wait_label);

dcl	wait_flag		   bit (1) parameter;
dcl	wait_label	   label parameter;

	if tai.modes.wait & (tai.status_entry_idx = 0) then
						/* drain the channel once in awhile */
	     call ipc_$drain_chn (tai.event_id, (0));

	isp = tape_ioi_utils$get_status (wksp);
	do while (isp = null ());			/* wait for the status if that is allowed */
	     if tai.modes.wait then
		call ipc_$drain_chn (tai.event_id, (0));
	     isp = tape_ioi_utils$get_status (wksp);	/* prevent races */
	     if isp = null () then do;
		if wait_flag then do;
		     call block;
		     isp = tape_ioi_utils$get_status (wksp);
		end;
		else goto wait_label;
	     end;
	end;
	if ^istat.run then
	     tai.last_terminate_time = clock ();
	status_class = tape_ioi_utils$get_status_class (isp);

     end get_status;

/* Function to determine if the given status and buffer correspond to each other.  It returns the
   difference (in buffers) between this status and this buffer.  Thus, a result of 0 means that
   the status describes the I/O operation which was performed on the buffer.  A negative result
   means that the status is of an earlier I/O operation than the buffer (this should NEVER happen),
   and a +N result means that the status is for the Nth buffer along in the list.  All of this is
   determined by examining the DCW residue in the status, unless the status is for a terminate
   interrupt, in which case the LPW residue is used.  The buffer in question is assumed to be on the queued list. */

missing_statuses:
     proc (buffer_ptr, status_ptr) returns (fixed bin);

dcl	buffer_ptr	   ptr parameter;
dcl	status_ptr	   ptr parameter;

dcl	bbuf_idx		   fixed bin;
dcl	buf_idx		   fixed bin;
dcl	bufp		   ptr;
dcl	residue		   fixed bin (18) unsigned;
dcl	sbuf_idx		   fixed bin;

	statp = addr (status_ptr -> istat.iom_stat);
	lpwp = addr (status_ptr -> istat.lpw);
	if status.marker then			/* marker interrupt? */
	     residue = bin (status.address);		/* yes, use DCW residue */
	else do;					/* no, use LPW residue */
	     residue = istat.offset;
	     if bin (rel (addr (tai.order_data (hbound (tai.order_data, 1))))) >= residue then
		return (0);			/* must have been a retry, must be for first buffer */
	end;

	sbuf_idx, bbuf_idx = -1;			/* init to neither found */
	buf_idx = 0;
	do bufp = ptr (wksp, tai.queue_list_offset) repeat ptr (wksp, bufp -> tbi.next_state_offset)
	     while ((rel (bufp) ^= ""b) & ((sbuf_idx = -1) | (bbuf_idx = -1)));

/**** The reason the test is done for one word before the IDCW is a case which occurs when error recovery
      is in progress.  In this case, IOI's clever handling of the two TDCWs in a row problem causes it to
      return an offset which is one before the read IDCW (for this problem doesn't arise when write error
      recovery is done--then the erase IDCW prevents there from being two TDCWs in a row. */

	     if (residue >= bin (rel (addr (bufp -> tbi.idcw_word))) - 1)
		& (residue <= (bufp -> tbi.data_offset) + divide (bufp -> tbi.buffer_len, BYTES_PER_WORD, 19)) then
		sbuf_idx = buf_idx;
	     if bufp = buffer_ptr then
		bbuf_idx = buf_idx;
	     buf_idx = buf_idx + 1;
	end;

	return (sbuf_idx - bbuf_idx);

     end missing_statuses;

/* all blocking is done here */

block:
     proc;

%include event_wait_channel;
%include event_wait_info;

dcl	1 auto_event_wait_info aligned like event_wait_info;

dcl	ipc_$block	   entry (ptr, ptr, fixed bin (35));
dcl	timer_manager_$alarm_wakeup
			   entry (fixed bin (71), bit (2), fixed bin (71));
dcl	timer_manager_$reset_alarm_wakeup
			   entry (fixed bin (71));

dcl	RELATIVE_SECONDS	   bit (2) static options (constant) init ("11"b);
dcl	TWO_MINUTES	   fixed bin (71) static options (constant) init (120);

	event_wait_channel.channel_id = tai.event_id;
	if tai.special_status_expected then
	     call timer_manager_$alarm_wakeup (TWO_MINUTES, RELATIVE_SECONDS, tai.event_id);
	call ipc_$block (addr (event_wait_channel), addr (auto_event_wait_info), (0));
	if tai.special_status_expected then
	     call timer_manager_$reset_alarm_wakeup (tai.event_id);
						/* remove the extra event */

     end block;

setup:
     proc;

	call tape_ioi_utils$get_workspace_ptr (p_tioi_id, wksp);
	if wksp = null () then
	     call quit (error_table_$bad_arg);
	code, p_code = 0;

     end setup;

quit:
     proc (code);

dcl	code		   fixed bin (35);

	p_code = code;
	goto ERROR_RETURN;

     end quit;

ERROR_RETURN:
	return;

%include tape_ioi_workspace;
%page;
%include iom_pcw;
%include iom_dcw;
%page;
%include iom_lpw;
%page;
%include iom_stat;
%page;
%include ioi_stat;
%page;
%include io_status_word;
%page;
%include interrupt_levels;
%page;
%include tape_ioi_result_indexes;
%page;
%include tape_ioi_buffer_status;
%page;
%include io_special_status;

     end tape_ioi_io;




		    tape_ioi_modes.pl1              11/11/89  1105.7r w 11/11/89  0812.0       48429



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* Mode setting and getting routines for tape_ioi_ */
/* Written 7 May 1982 by Chris Jones */

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

/* Parameters */

dcl	p_code		   fixed bin (35) parameter;	/* (O) system status code */
dcl	p_data_ptr	   ptr parameter;		/* (I) pointer to the data for the mdoe */
dcl	p_mode		   char (*) parameter;	/* (I) name of the mode in question */
dcl	p_tioi_id		   bit (36) aligned parameter;/* (I) tape_ioi_ activation ID */

/* Automatic variables */

dcl	code		   fixed bin (35);
dcl	mode_idx		   fixed bin;

/* Based variables */

dcl	align_value	   bit (1) based (p_data_ptr);/* "0"=>left, "1"=>right */
dcl	cif_value		   bit (6) based (p_data_ptr);/* channel instruction (ignored if error recovery on) */
dcl	data_value	   char (4) based (p_data_ptr);
						/* data encoding (e.g. bcd, ascii) */
dcl	event_value	   fixed bin (71) based (p_data_ptr);
						/* IPC event channel */
dcl	length_value	   bit (1) based (p_data_ptr);/* "0"b=>normal, "1"b=>special */
dcl	recovery_value	   bit (1) based (p_data_ptr);/* "0"b=>off, "1"b=>on */
dcl	req_len_value	   bit (1) based (p_data_ptr);/* "0"b=>off, "1"b=on */
dcl	wait_value	   bit (1) based (p_data_ptr);/* "0"b=>simplex, "1"b=>multiplex */

/* Static storage */

dcl	MODE_NAMES	   (8) char (8) static options (constant)
			   init ("align", "cif", "data", "event", "length", "recovery", "wait", "req_len");

/* Externals */

dcl	ioi_$set_event	   entry (fixed bin, fixed bin (71), fixed bin (35));
dcl	tape_ioi_utils$get_workspace_ptr
			   entry (bit (36) aligned, ptr);

dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$bad_mode_value
			   fixed bin (35) ext static;
dcl	error_table_$undefined_mode
			   fixed bin (35) ext static;

/* Builtins */

dcl	(hbound, null)	   builtin;

set_mode:
     entry (p_tioi_id, p_mode, p_data_ptr, p_code);

	call setup;
	call get_mode_idx (mode_idx);			/* doesn't return if the mode is invalid */

	goto MODE_SET (mode_idx);

MODE_SET (1):					/* align */
	tai.align = align_value;
	return;

MODE_SET (2):					/* cif */
	tai.cif_code = cif_value;
	return;

MODE_SET (3):					/* data */
	if data_value = "bin" then
	     tai.data_code = "05"b3;
	else if data_value = "bcd" then
	     tai.data_code = "04"b3;
	else if data_value = "tap9" then
	     tai.data_code = "03"b3;
	else if data_value = "asc" then
	     tai.data_code = "27"b3;
	else if data_value = "ebc" then
	     tai.data_code = "24"b3;
	else if data_value = "a/e" then
	     tai.data_code = "25"b3;
	else call quit (error_table_$bad_mode_value);
	return;

MODE_SET (4):					/* event */
	call ioi_$set_event (tai.ioi_index, event_value, code);
	if code ^= 0 then
	     call quit (code);
	tai.event_id = event_value;
	return;

MODE_SET (5):					/* length */
	tai.modes.length = length_value;
	return;

MODE_SET (6):					/* recovery */
	tai.modes.recovery = recovery_value;
	return;

MODE_SET (7):					/* wait */
	tai.modes.wait = wait_value;
	return;
MODE_SET (8):					/* req_len */
	tai.modes.req_len = req_len_value;
	return;

get_mode:
     entry (p_tioi_id, p_mode, p_data_ptr, p_code);

	call setup;
	call get_mode_idx (mode_idx);			/* doesn't return if the mode is invalid */

	goto MODE_GET (mode_idx);

MODE_GET (1):					/* align */
	align_value = tai.align;
	return;

MODE_GET (2):					/* cif */
	cif_value = tai.cif_code;
	return;

MODE_GET (3):					/* data */
	if tai.data_code = "05"b3 then
	     data_value = "bin";
	else if tai.data_code = "04"b3 then
	     data_value = "bcd";
	else if tai.data_code = "03"b3 then
	     data_value = "tap9";
	else if tai.data_code = "27"b3 then
	     data_value = "asc";
	else if tai.data_code = "24"b3 then
	     data_value = "ebc";
	else if tai.data_code = "25"b3 then
	     data_value = "a/e";
	else data_value = "****";			/* how did this happen? */
	return;

MODE_GET (4):					/* event */
	event_value = tai.event_id;
	return;

MODE_GET (5):					/* length */
	length_value = tai.modes.length;
	return;

MODE_GET (6):					/* recovery */
	recovery_value = tai.modes.recovery;
	return;

MODE_GET (7):					/* wait */
	wait_value = tai.modes.wait;
	return;

MODE_GET (8):					/* req_len */
	req_len_value = tai.modes.req_len;
	return;

setup:
     proc;

	call tape_ioi_utils$get_workspace_ptr (p_tioi_id, wksp);
	if wksp = null () then
	     call quit (error_table_$bad_arg);

	p_code = 0;

     end setup;

get_mode_idx:
     proc (mode_idx);

dcl	mode_idx		   fixed bin;

dcl	mode_name		   char (8);

	mode_name = p_mode;
	do mode_idx = 1 to hbound (MODE_NAMES, 1);
	     if MODE_NAMES (mode_idx) = mode_name then
		return;
	end;

	call quit (error_table_$undefined_mode);

     end get_mode_idx;

quit:
     proc (code);

dcl	code		   fixed bin (35);

	p_code = code;
	goto ERROR_RETURN;

     end quit;

ERROR_RETURN:
	return;

%include tape_ioi_workspace;

     end tape_ioi_modes;




		    tape_ioi_utils.pl1              11/11/89  1105.7r w 11/11/89  0812.0       82566



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

/* Various internal interfaces of the tape_ioi_ software */
/* Written May 1982 by Chris Jones */
/* Modified 12/2/82 by Chris Jones to break out bad density from other MPC device attention errors. */
/* Modified 12/17/82 by Chris Jones to put more things into the "SI" and "DN" categories. */
/* Modified 1/5/83 by Chris Jones to look harder for valid status. */
/* Modified 2/4/83 by Chris Jones to break out blank tape on read from EOT */
/* Modified St. Valentine's day, 1983 by Chris Jones to look more carefully for status. */
/* Modified 8 March 1983 by Chris Jones to fix bug in last_status_entry_offset. */

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

/* Parameters */

dcl	p_buffer_data_ptr	   ptr parameter;		/* (I) pointer to the data area of a buffer */
dcl	p_status_ptr	   ptr parameter;		/* (I) pointer to a ioi status structure */
dcl	p_tioi_id		   bit (36) aligned;	/* (I) tape_ioi_ activation ID */
dcl	p_wksp		   ptr parameter;		/* (I/O) pointer to the tape_ioi_ workspace */

/* Automatic variables */

dcl	buffer_data_ptr	   ptr;
dcl	buffer_idx	   fixed bin;
dcl	buffer_ptr	   ptr;
dcl	done		   bit (1) aligned;
dcl	status_entry_idx	   fixed bin (9) unsigned;
dcl	test_read		   fixed bin (35);

/* Based variables */

dcl	based_integer	   fixed bin (35) based;
dcl	1 based_tioi_id	   aligned based,
	  2 segno		   bit (18) unal,
	  2 actid		   fixed bin (18) unsigned unal;

/* Builtins and Conditions */

dcl	(addr, addrel, baseptr, mod, null, ptr, size, unspec)
			   builtin;

dcl	any_other		   condition;

/* Entry to return a pointer to the buffer header of a buffer given its data pointer */

get_buffer_ptr:
     entry (p_wksp, p_buffer_data_ptr) returns (ptr);

	wksp = p_wksp;
	buffer_data_ptr = p_buffer_data_ptr;
	if tai.buffer_count = 0 then
	     return (null ());			/* can't be for real */
	else do;
	     buffer_ptr = ptr (wksp, tai.buffer_list_offset);
	     do buffer_idx = 1 to tai.buffer_count while (ptr (wksp, buffer_ptr -> tbi.data_offset) ^= buffer_data_ptr);
		buffer_ptr = ptr (wksp, buffer_ptr -> tbi.next_buf_offset);
	     end;
	     if ptr (wksp, buffer_ptr -> tbi.data_offset) = buffer_data_ptr then
		return (buffer_ptr);
	     else return (null ());
	end;

/* entry to return a pointer to the workspace given a tape_ioi_ activation ID */
get_workspace_ptr:
     entry (p_tioi_id, p_wksp);

	on any_other
	     begin;
		goto CANT_RETURN_PTR;
	     end;

	wksp = baseptr (addr (p_tioi_id) -> based_tioi_id.segno);
	if p_tioi_id ^= unspec (tai.tioi_id) then
	     goto CANT_RETURN_PTR;

/* Make sure we can read the last word of the buffer, and write any word.  The any_other handler will trap errors. */

	test_read = ptr (wksp, tai.workspace_len) -> based_integer;
	p_wksp = wksp;
	return;

CANT_RETURN_PTR:
	p_wksp = null ();
	return;

/* entry which tells whether or not I/O is in progress on the device */


io_in_progress:
     entry (p_wksp) returns (bit (1) aligned);

	wksp = p_wksp;
	return (tai.read_queued | tai.write_queued | tai.order_queued);

/* entry which returns a two character status class based on the given status */
/* These status classes are described in MTB-383, Appendix D */

get_status_class:
     entry (p_status_ptr) returns (char (2));

	isp = p_status_ptr;
	io_status_word_ptr = addr (istat.iom_stat);

/* Now just brute force the status lookup. */
/* This code works for type 500, 501, 601, 610, and 650 (DIPPER) tape controllers.  Much of the weird
   masking is to maintain compatibility between the various controllers. */

	if io_status_word.power then			/* power off */
	     return ("UE");
	else if istat.level = 1 then			/* system fault */
	     return ("UE");
	else if io_status_word.central_stat ^= "0"b3 then do;
	     if io_status_word.central_stat = "7"b3 then	/* parity error, data from channel */
		return ("DA");
	     else return ("UE");
	end;
	else if io_status_word.channel_stat ^= "0"b3 then do;
	     if io_status_word.channel_stat = "7"b3 then
		return ("IP");			/* parity error, data to channel */
	     else if io_status_word.channel_stat = "3"b3 then
		return ("BL");			/* incorrect DCW on list service */
	     else return ("UE");
	end;
	else if io_status_word.major = "0000"b then do;	/* peripheral subsystem ready */
	     if (io_status_word.sub & "111010"b) = "000010"b then
		return ("AB");			/* at beginning */
	     else if (io_status_word.sub & "111011"b) = "001000"b then
		return ("CA");			/* ASCII alert */
	     else return ("OK");
	end;
	else if io_status_word.major = "0001"b then do;	/* device busy */
	     if (io_status_word.sub & "000101"b) ^= "000000"b then
						/* rewinding or loading */
		return ("SI");			/* wait for special interrupt */
	     else return ("UE");			/* unrecoverable error */
	end;
	else if io_status_word.major = "0010"b then	/* device attention */
	     return ("UE");
	else if io_status_word.major = "0011"b then do;	/* device data alert */
	     if io_status_word.sub = "000010"b then	/* blank tape on read */
		return ("BT");			/* blank tape */
	     else if io_status_word.sub = "100000"b then	/* EOT */
		return ("ET");			/* end of tape */
	     else if (io_status_word.sub & "100000"b) = "100000"b then
						/* if EOT is set */
		return ("DE");			/* data alert, at end */
	     else return ("DA");			/* data alert */
	end;
	else if io_status_word.major = "0100"b then	/* EOF */
	     return ("EF");
	else if io_status_word.major = "0101"b then do;	/* command reject */
	     if io_status_word.sub = "001000"b then	/* at BOT */
		return ("AB");
	     else if io_status_word.sub = "000000"b then	/* invalid density */
		return ("DN");
	     else return ("UE");
	end;
	else if io_status_word.major = "1010"b then do;	/* MPC device attention */
	     if io_status_word.sub = "010000"b | (io_status_word.sub & "111100"b) = "001100"b then
		return ("DA");
	     else if io_status_word.sub = "001000"b then	/* incompatible mode */
		return ("DN");
	     else return ("UE");
	end;
	else if io_status_word.major = "1011"b then do;	/* MPC device data alert */
	     if io_status_word.sub = "001000"b |	/* ID burst write error */
		io_status_word.sub = "010011"b |	/* NRZI CCC error */
		io_status_word.sub = "001001"b |	/* preamble error */
		io_status_word.sub = "010010"b |	/* postamble error */
		io_status_word.sub = "010000"b |	/* multi-track error */
		io_status_word.sub = "100000"b then	/* marginal condition */
		return ("DA");
	     else if io_status_word.sub = "010100"b then	/* code alert */
		return ("CA");
	     else return ("UE");
	end;
	else if io_status_word.major = "1101"b then do;	/* MPC command reject */
	     if io_status_word.sub = "000011"b then	/* Illegal suspended L.C. number */
		return ("SI");
	     else return ("UE");
	end;
	else return ("UE");				/* should never happen, but... */

/* entry to return a pointer to the next status entry if it is valid */

get_status:
     entry (p_wksp) returns (ptr);

	wksp = p_wksp;
	status_entry_idx = tai.status_entry_idx;	/* save where we started */
	done = "0"b;
	do while (^done);				/* until we've had enough */
	     isp = ptr (wksp, tai.status_queue_offset + tai.status_entry_idx * size (istat));
						/* point to next status entry */
	     if istat.completion.st then do;		/* found one, get set to look again */
		if istat.level = IO_SPECIAL_INTERRUPT_LEVEL then
		     istat.completion.st = "0"b;	/* should never happen... */
		else done = "1"b;
	     end;
	     if ^done then
		tai.status_entry_idx = mod (tai.status_entry_idx + 1, tai.status_entry_count);
	     if ^done & tai.status_entry_idx = status_entry_idx then
		return (null ());			/* we've checked them all */
	end;

/* Since a status may have landed behind us after we had already checked, scan forward again to find the first */

	tai.status_entry_idx = status_entry_idx;
	do isp = ptr (wksp, tai.status_queue_offset + size (istat) * tai.status_entry_idx)
	     repeat ptr (wksp, tai.status_queue_offset + size (istat) * tai.status_entry_idx)
	     while (^istat.completion.st);
	     tai.status_entry_idx = mod (tai.status_entry_idx + 1, tai.status_entry_count);
	end;
	tai.status_entry_idx = mod (tai.status_entry_idx + 1, tai.status_entry_count);
	istat.completion.st = "0"b;			/* so we don't hit this again */
	return (isp);

/* Entry to return the offset of the last status entry. */

last_status_entry_offset:
     entry (p_wksp) returns (fixed bin (18) unsigned);

	wksp = p_wksp;
	return (tai.status_queue_offset + size (istat) * mod (tai.status_entry_idx - 1, tai.status_entry_count));

%include tape_ioi_workspace;
%page;
%include ioi_stat;
%page;
%include io_status_word;
%page;
%include interrupt_levels;

     end tape_ioi_utils;




		    tape_ioi_wks_man.pl1            11/11/89  1105.7r w 11/11/89  0812.1      161028



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



/****^  HISTORY COMMENTS:
  1) change(86-06-10,GWMay), approve(86-10-10,MCR7546),
     audit(86-10-13,Martinson), install(86-10-20,MR12.0-1189):
     Added complete initialization of tape_ioi workspace variables.
                                                   END HISTORY COMMENTS */


/* This program manages the tape_ioi_ workspace. */
/* Written 3 May 1982 by Chris Jones */
/* Modified 25 January 1983 by Chris Jones to wait a while on on I/O in progress */
/* Modified 9 February 1983 by Chris Jones to not deallocate reserved buffers when a deallocate_buffers call is made. */
/* Modified 30 April 1985 by Chris Jones to always have one more status queue entry than buffers. */

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

/* Parameters */

dcl	p_actual_count	   fixed bin parameter;	/* (O) actual number of buffers allocated */
dcl	p_actual_length	   fixed bin (21) parameter;	/* (O) actual length (in chars) of each buffer */
dcl	p_actual_wka_size	   fixed bin (19) parameter;	/* (O) actual size of user workarea */
dcl	p_buffer_ptrs	   (*) ptr parameter;	/* (O) pointers to the allocated buffers */
dcl	p_code		   fixed bin (35) parameter;	/* (O) standard system status code */
dcl	p_requested_count	   fixed bin parameter;	/* (I) desired number of buffers */
dcl	p_requested_length	   fixed bin (21) parameter;	/* (I) desired length (in chars) of each buffer */
dcl	p_requested_wka_size   fixed bin (19) parameter;	/* (I) desired size of user workarea */
dcl	p_tioi_id		   bit (36) aligned parameter;/* (I) tape_ioi_ ID */
dcl	p_wka_ptr		   ptr parameter;		/* (O) pointer to the user workarea */

/* Automatic variables */

dcl	basic_buffer_header_size
			   fixed bin;
dcl	buffer_count	   fixed bin;
dcl	buffer_idx	   fixed bin;
dcl	buffer_length	   fixed bin (21);		/* length in characters */
dcl	buffer_offset	   fixed bin (18);
dcl	buffer_space_available fixed bin (19);
dcl	cbufp		   ptr;
dcl	code		   fixed bin (35);
dcl	deadline		   fixed bin (71);
dcl	extra_dcws	   fixed bin;
dcl	obufp		   ptr;
dcl	save_workarea_and_reserved_buffers
			   bit (1) aligned;
dcl	status_entry_count	   fixed bin (8);
dcl	status_queue_offset	   fixed bin (18);
dcl	tries		   fixed bin;
dcl	user_workarea_offset   fixed bin (18);
dcl	user_workarea_size	   fixed bin (19);
dcl	words_left_in_page	   fixed bin;
dcl	workspace_length	   fixed bin (19);
dcl	workspace_ptr	   ptr;

/* Constants */

dcl	BITS_PER_WORD	   fixed bin static options (constant) init (36);
dcl	BYTES_PER_DCW_TALLY	   fixed bin static options (constant) init (16384);
dcl	BYTES_PER_WORD	   fixed bin static options (constant) init (4);
dcl	TEN_SECONDS	   fixed bin (71) static options (constant) init (10000000);
dcl	WORDS_PER_DCW_TALLY	   fixed bin static options (constant) init (4096);

/* Builtins */

dcl	(addr, bin, clock, dim, divide, lbound, min, mod, null, ptr, rel, size)
			   builtin;

/* External entries */

dcl	ioi_$set_status	   entry (fixed bin, fixed bin (18), fixed bin (8), fixed bin (35));
dcl	ioi_$workspace	   entry (fixed bin, ptr, fixed bin (19), fixed bin (35));
dcl	tape_ioi_utils$get_workspace_ptr
			   entry (bit (36) aligned, ptr);
dcl	tape_ioi_utils$io_in_progress
			   entry (ptr) returns (bit (1) aligned);

dcl	error_table_$action_not_performed
			   fixed bin (35) ext static;
dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$device_active
			   fixed bin (35) ext static;
dcl	error_table_$out_of_sequence
			   fixed bin (35) ext static;
dcl	error_table_$too_many_buffers
			   fixed bin (35) ext static;

dcl	sys_info$page_size	   fixed bin ext static;

/* Entry to allocate a number of buffers.  All are the same length.  Pointers to the data area
   of the buffers will be returned. */

allocate_buffers:
     entry (p_tioi_id, p_requested_length, p_requested_count, p_actual_length, p_actual_count, p_buffer_ptrs, p_code);

	call setup;
	if tai.workarea_last then			/* if caller has already allocated a workarea... */
	     call quit (error_table_$out_of_sequence);	/* ...at the end of the workspace, then quit */

/* Figure out what the caller really wants.  If the count is 0, give as many of the requested size as
   will fit.  If the length is 0, make each buffer as big as possible.  If both are 0, punt. */

	buffer_count = p_requested_count;
	buffer_length = p_requested_length;
	if ((buffer_length = 0) & (buffer_count = 0)) | (buffer_length < 0) | (buffer_count < 0) then
	     call quit (error_table_$bad_arg);

	buffer_space_available = tai.workspace_max - tai.workspace_len;

	if buffer_length ^= 0 then do;		/* caller knows how big the buffers are to be */

/* round up to next two word boundary */

	     if mod (buffer_length, 2 * BYTES_PER_WORD) ^= 0 then
		buffer_length = buffer_length + 2 * BYTES_PER_WORD - mod (buffer_length, 2 * BYTES_PER_WORD);
	     extra_dcws = divide (buffer_length - 1, BYTES_PER_DCW_TALLY, 17);
	     if buffer_count = 0 then			/* we have to figure out how many buffers to grab */
		buffer_count =
		     divide (BYTES_PER_WORD * buffer_space_available,
		     buffer_length + BYTES_PER_WORD * (size (tbi) + extra_dcws), 17);
	end;

	else do;					/* we have to figure out how big each buffer will be */

/* Now, this turns out to be a sticky problem.  The storage per buffer consists of the storage per header plus the
   storage per data area.  However, the storage per header is dependent on the storage per data area (because
   the number of DCWs in the header varies with the storage per data area.  So, given:

   Sh	storage per buffer header
   Stot	total storage available			(known, it is buffer_space_available)
   Nb	number of buffers
   Sho	length of constant part of buffer header	(known)
   Ds	amount of storage described by one DCW		(known, 4096 words)
   Sd	amount of storage 1 DCW itself takes up		(known, 1 word)
   Sb	storage per buffer (header + data)
   Nd	number of DCWs per buffer

   We want to solve for Nd.

   1. Sb = Stot / Nb
   2. Sh = Sho + Nd * Sd		or	2a. Sh = Sho + Nd	(since Sd = 1)
   3. Nd = (Sb - Sh) / Ds
   4. Nd = (Sb - (Sho + Nd)) / Ds		substituting (2a) into 3
   5. Ds * Nd = Sb - Sho - Nd			multiplying both sides of (4) by Ds
   6. Nd * (Ds + 1) = Sb - Sho		adding Nd to both sides and combining factors
   7. Nd = (Sb - Sho) / (Ds + 1)		dividing both sides by (Ds + 1)
   8. Nd = ((Stot / Nb) - Sho) / (Ds + 1)	combining (1) and (7)
*/

	     basic_buffer_header_size = size (tbi) + 1;	/* allow for first word of data */
	     extra_dcws =
		divide (divide (buffer_space_available, buffer_count, 17) - (basic_buffer_header_size + size (istat)),
		WORDS_PER_DCW_TALLY + 1, 17);
	     buffer_length =
		BYTES_PER_WORD
		* (divide (buffer_space_available, buffer_count, 17) - (size (tbi) + size (istat) + extra_dcws));
	     buffer_length = buffer_length - mod (buffer_length, 2 * BYTES_PER_WORD);
	     if (buffer_length <= 0) | (extra_dcws < 0) then
		call quit (error_table_$too_many_buffers);
	end;

/* Now we have the count and correct length of all the buffers we're going to allocate.
   Grab a workspace big enough for all of these buffers. */

	if buffer_count = 0 then
	     call quit (error_table_$bad_arg);

	workspace_length = tai.workspace_len + 1	/* unpack */
	     + buffer_count * (size (tbi) + size (istat) + extra_dcws + divide (buffer_length, BYTES_PER_WORD, 17));

	call set_workspace (workspace_ptr, workspace_length, code);
	call quit_if_error;
	tai.workspace_len = workspace_length - 1;	/* pack */

/* Relocate the status queue to the end of the workspace */

	status_entry_count = tai.buffer_count + buffer_count + 1;	/* allow for the MPC to hiccup */
	status_queue_offset = workspace_length - size (istat) * status_entry_count;
	call set_status (status_queue_offset, status_entry_count, code);
	call quit_if_error;

/**** Remember where the status queue was (this is where the new buffers will begin). */
	buffer_offset = tai.status_queue_offset;

	tai.status_queue_offset = status_queue_offset;
	tai.status_entry_idx = 0;
	tai.status_entry_count = status_entry_count;

/* Now thread the buffers onto the lists.  First, thread all of the newly created buffers together. */

	cbufp = ptr (wksp, buffer_offset);
	do buffer_idx = 1 to buffer_count;
	     cbufp -> tbi.data_offset = size (tbi) + extra_dcws + bin (rel (cbufp));
	     cbufp -> tbi.next_buf_offset = cbufp -> tbi.data_offset + divide (buffer_length, BYTES_PER_WORD, 17);
	     cbufp -> tbi.next_state_offset = cbufp -> tbi.next_buf_offset;
	     cbufp -> tbi.state = READY_STATE;
	     cbufp -> tbi.ndcws = 1 + extra_dcws;
	     cbufp -> tbi.modes = tai.modes;
	     cbufp -> tbi.reserved = "0"b;
	     cbufp -> tbi.buffer_len = buffer_length;
	     cbufp -> tbi.data_len = 0;
	     cbufp -> tbi.bit_len = 0;
	     cbufp -> tbi.idcw_word = "0"b;
	     cbufp -> tbi.dcw_words = "0"b;
	     cbufp -> tbi.tdcw_word = "0"b;
	     idcwp = addr (cbufp -> tbi.idcw_word);
	     idcw.device = addr (tai.order_idcw) -> idcw.device;
	     idcw.ext = "0"b;
	     idcw.code = "111"b;
	     idcw.ext_ctl = "0"b;
	     obufp = cbufp;
	     cbufp = ptr (wksp, cbufp -> tbi.next_buf_offset);
	end;

	obufp -> tbi.next_buf_offset = 0;		/* unlink the last one */
	obufp -> tbi.next_state_offset = 0;

	if tai.buffer_list_offset = 0 then
	     tai.buffer_list_offset = buffer_offset;	/* first buffers allocated */
	else do;
	     do obufp = ptr (wksp, tai.buffer_list_offset) repeat ptr (wksp, obufp -> tbi.next_buf_offset)
		while (obufp -> next_buf_offset ^= 0);
	     end;
	     obufp -> tbi.next_buf_offset = buffer_offset;
	end;
	if tai.free_list_offset = 0 then
	     tai.free_list_offset = buffer_offset;	/* first buffers allocated */
	else do;
	     do obufp = ptr (wksp, tai.free_list_offset) repeat ptr (wksp, obufp -> tbi.next_state_offset)
		while (obufp -> next_state_offset ^= 0);
	     end;
	     obufp -> tbi.next_state_offset = buffer_offset;
	end;

/* Update tai to reflect these new buffers */

	obufp = cbufp;
	cbufp = ptr (wksp, buffer_offset);		/* remember first buffer allocated */
	tai.buffer_count = tai.buffer_count + buffer_count;

/* Now return all sorts of information to the caller. */

	p_actual_count = buffer_count;
	p_actual_length = buffer_length;
	do buffer_idx = 1 to min (buffer_count, dim (p_buffer_ptrs, 1));
	     p_buffer_ptrs (lbound (p_buffer_ptrs, 1) + buffer_idx - 1) = ptr (wksp, cbufp -> tbi.data_offset);
	     cbufp = ptr (wksp, cbufp -> tbi.next_buf_offset);
	end;
	p_code = 0;
	return;

/* Entry to allocate a workarea for the caller.  This has the advantage that it will usually be wired,
   so page faults will be kept to a minimum. */

allocate_work_area:
     entry (p_tioi_id, p_requested_wka_size, p_actual_wka_size, p_wka_ptr, p_code);

	call setup;
	if tai.workarea_offset ^= 0 then		/* tsk, tsk */
	     call quit (error_table_$action_not_performed);

	user_workarea_size = p_requested_wka_size;
	if tai.buffer_count = 0 then do;		/* no buffers have been allocated yet */
	     if user_workarea_size = 0 then
		call quit (error_table_$bad_arg);

	     user_workarea_offset = tai.status_queue_offset;
	     if mod (user_workarea_offset, 2) ^= 0 then
		user_workarea_size = user_workarea_size + 1;
	     workspace_length = user_workarea_size + tai.workspace_len + 1;
	     call set_workspace (workspace_ptr, workspace_length, code);
	     call quit_if_error;
	     status_queue_offset = tai.status_queue_offset + user_workarea_size;
	     status_entry_count = tai.status_entry_count;
	     call set_status (status_queue_offset, status_entry_count, code);
	     call quit_if_error;
	     tai.workarea_offset = user_workarea_offset;	/* workarea starts where status queue was */
	     tai.workarea_len = user_workarea_size;
	     tai.status_queue_offset = status_queue_offset;
						/* remember where we put the status queue */
	     tai.status_entry_idx = 0;
	end;
	else do;					/* we've already allocated some buffers */
	     words_left_in_page = sys_info$page_size - mod (tai.workspace_len, sys_info$page_size) - 1;
	     if user_workarea_size = 0 then		/* user wants all of last page */
		user_workarea_size = words_left_in_page;
	     else if user_workarea_size < words_left_in_page - mod (user_workarea_size, 2) then
		call quit (error_table_$bad_arg);

	     workspace_length = tai.workspace_len + user_workarea_size + 1;
	     call set_workspace (workspace_ptr, workspace_length, code);
	     call quit_if_error;

	     tai.workarea_last = "1"b;
	     user_workarea_offset = tai.workspace_len;	/* so calculation after this clause will be set up */
	     tai.workarea_offset = tai.workspace_len;
	     tai.workarea_len = user_workarea_size;
	end;
	tai.workspace_len = workspace_length - 1;
	if mod (user_workarea_offset, 2) ^= 0 then do;	/* ensure it's on an even word boundary */
	     user_workarea_offset = user_workarea_offset + 1;
	     user_workarea_size = user_workarea_size - 1;
	end;
	p_wka_ptr = ptr (wksp, user_workarea_offset);
	p_actual_wka_size = user_workarea_size;
	p_code = 0;
	return;

/* Entry to deallocate all unreserved buffers and as many status queue entries as we can. */

deallocate_buffers:
     entry (p_tioi_id, p_code);

	save_workarea_and_reserved_buffers = "1"b;
	goto DEALLOCATE_COMMON;

/* Entry to deallocate all buffers, the user workarea, and all but one status queue entry. */

deallocate:
     entry (p_tioi_id, p_code);

	save_workarea_and_reserved_buffers = "0"b;
DEALLOCATE_COMMON:
	call setup;

	if (tai.workarea_last | tai.susp_list_offset ^= 0) & save_workarea_and_reserved_buffers then
	     call quit (error_table_$action_not_performed);

	if ^save_workarea_and_reserved_buffers then do;
	     tai.buffer_list_offset = 0;
	     tai.free_list_offset = 0;
	     tai.susp_list_offset = 0;
	     tai.buffer_count = 0;
	     tai.workarea_len = 0;
	     tai.workarea_offset = 0;
	     tai.workarea_last = "0"b;
	     status_queue_offset = size (tai);
	     status_entry_count = 1;
	end;
	else do;
	     cbufp = ptr (wksp, tai.buffer_list_offset);
	     buffer_count = 0;
	     if tai.workarea_offset = 0 then
		status_queue_offset = size (tai);
	     else status_queue_offset = tai.workarea_offset + tai.workarea_len + 1;
	     do while (rel (cbufp));
		if cbufp -> tbi.reserved then do;
		     buffer_count = buffer_count + 1;
		     status_queue_offset =
			cbufp -> tbi.data_offset + divide (cbufp -> tbi.buffer_len, BYTES_PER_WORD, 17, 0);
		     cbufp -> tbi.next_state_offset = cbufp -> tbi.next_buf_offset;
		     obufp = cbufp;
		     cbufp = ptr (wksp, cbufp -> tbi.next_buf_offset);
		end;
		else do;
		     if buffer_count ^= 0 then do;
			obufp -> tbi.next_buf_offset = 0;
			obufp -> tbi.next_state_offset = 0;
		     end;
		     cbufp = wksp;			/* this will stop the loop */
		end;
	     end;
	     if buffer_count = 0 then
		tai.buffer_list_offset, tai.free_list_offset = 0;
	     else tai.free_list_offset = tai.buffer_list_offset;
	     status_entry_count = buffer_count + 1;
	     tai.buffer_count = buffer_count;
	end;

	call set_status (status_queue_offset, status_entry_count, code);
	call quit_if_error;
	tai.status_queue_offset = status_queue_offset;
	tai.status_entry_count = status_entry_count;
	tai.status_entry_idx = 0;

	workspace_length = status_queue_offset + size (istat) * tai.status_entry_count;
	call set_workspace (workspace_ptr, workspace_length, code);
	call quit_if_error;
	tai.workspace_len = workspace_length - 1;
	p_code = 0;
	return;

/* Routine to change the size of the workspace */

set_workspace:
     proc (ws_ptr, ws_len, code);

dcl	ws_ptr		   ptr parameter;
dcl	ws_len		   fixed bin (19) parameter;
dcl	code		   fixed bin (35) parameter;

	deadline = clock () + TEN_SECONDS;
	do while ("1"b);
	     do tries = 1 to 10;
		call ioi_$workspace (tai.ioi_index, workspace_ptr, workspace_length, code);
		if code ^= error_table_$device_active then
		     return;
	     end;
	     if clock () > deadline then
		return;
	end;

     end set_workspace;

/* Routine to change the size of the status queue */

set_status:
     proc (q_offset, q_len, code);

dcl	q_offset		   fixed bin (18) parameter;
dcl	q_len		   fixed bin (8) parameter;
dcl	code		   fixed bin (35) parameter;


/* Clear the status queue */

	begin;

dcl	status_bit_string	   bit (BITS_PER_WORD * q_len * size (istat)) based (ptr (wksp, q_offset));

	     status_bit_string = ""b;

	end;

	deadline = clock () + TEN_SECONDS;
	do while ("1"b);
	     do tries = 1 to 10;
		call ioi_$set_status (tai.ioi_index, q_offset, q_len, code);
		if code ^= error_table_$device_active then
		     return;
	     end;
	     if clock () > deadline then
		return;
	end;

     end set_status;

/* Setup routine.  Verifies p_tioi_id.  Also ensures no I/O is in progress. */

setup:
     proc;

	call tape_ioi_utils$get_workspace_ptr (p_tioi_id, wksp);
	if wksp = null () then
	     call quit (error_table_$bad_arg);
	if tape_ioi_utils$io_in_progress (wksp) then
	     call quit (error_table_$device_active);

     end setup;

/* Routine to return to the caller if an error was found. */

quit_if_error:
     proc;

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

     end quit_if_error;

quit:
     proc (code);

dcl	code		   fixed bin (35);

	p_code = code;
	goto ERROR_RETURN;

     end quit;

ERROR_RETURN:
	return;

%include tape_ioi_workspace;
%page;
%include iom_pcw;
%page;
%include tape_ioi_buffer_status;
%page;
%include ioi_stat;

     end tape_ioi_wks_man;




		    tape_mult_.pl1                  11/11/89  1105.7rew 11/11/89  0812.1      134613



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




/****^  HISTORY COMMENTS:
  1) change(86-10-13,GWMay), approve(86-10-13,MCR7552),
     audit(86-10-13,Martinson), install(86-10-20,MR12.0-1189):
     Changed argument error processing to use the tape reel name in the error
     message if the reel name was given correctly.
  2) change(86-10-23,GWMay), approve(86-10-23,PBF7552),
     audit(86-11-17,Martinson), install(86-11-21,MR12.0-1223):
     Appended this comment to be included with the previous comments. Added
     support for the use of rcp_ in determining the density and format type of
     a tape.  Changed mounted tape message to include the format type and
     recording density of the mounted tape as determined by rcp_.
  3) change(86-12-03,GWMay), approve(86-12-03,PBF7552),
     audit(86-12-09,Martinson), install(86-12-17,MR12.0-1250):
     Changed mount message for ring 1.  Reimplemented history comment 2 above.
  4) change(87-01-08,GDixon), approve(87-03-30,MCR7643),
     audit(87-03-31,Farley), install(87-04-28,MR12.1-1028):
     Add support for attaching to a particular tape drive, via -device.
                                                   END HISTORY COMMENTS */


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

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/24/74 by Bill Silver.
   *	Modified 7/79 by R.J.C. Kissel to add 6250 bpi support.
   *	Modified 7/81 by J. A. Bush for bootable tape labels
   *	Modified 01/82 by J. A. Bush to change the name from tape_mult_attach_ to tape_mult_
   *      Modified 8/82 by S. Krupp to change from tdcm_ to tape_ioi_ interface.
   *	Modified 12/15/82 by Chris Jones to not require the record length on reads (performance improvement).
   *      Modified 1985-03-18, BIM: add modes entrypoint for async processing.
   *
   *	This program implements the iox_$attach entry point.
*/


/*		ARGUMENT  DATA		*/

dcl	arg_com_err_flag	   bit (1),		/* (I) ON => call com_err_ on errors. */
	arg_error_code	   fixed bin (35),		/* (O) error_table_ code. */
	arg_iocb_ptr	   ptr,			/* (I) Pointer to I/O control block. */
	arg_options	   (*) char (*) varying;	/* (I) List of option and value strings. */


/*		AUTOMATIC  DATA		*/

dcl	Sable_to_read_the_tape bit (1),
	1 auto_error_tally	   aligned like tec,
	com_err_flag	   bit (1),		/* ON => call com_err_. */
	activation_flag	   bit (1) aligned init ("0"b),
						/* ON => tape_ioi_ has been activated. */
	attach_flag	   bit (1) aligned init ("0"b),
						/* ON => tape drive attached by rcp_. */
	density		   fixed bin,
	dev_name		   char (32) var,		/* Requested device name */
	error_code	   fixed bin (35),		/* Standard system error code. */
	iocb_ptr		   ptr,			/* Pointer to our iocb. */
	reel_name		   char (32),		/* Tape reel name. */
	rcp_id		   bit (36) aligned,	/* id associated with a tape drive attachment */
	tioi_id		   bit (36) aligned,	/* id associated with a tape_ioi_ activation */
	event_channel	   fixed bin (71),		/* used by rcp for attachment and ioi */
	comment		   char (256),		/* user comment to operator */
	ioi_id		   fixed bin,		/* tape_ioi_ activation info */
	workspace_max	   fixed bin (19),
	timeout_max	   fixed bin (71),
	statex		   fixed bin,		/* state of pending tape drive attachment */
	req_work_area_len	   fixed bin (19),		/* requested size of work area allocation */
	act_work_area_len	   fixed bin (19);		/* actual size of allocated work area */

dcl	1 wait_list	   aligned,		/* Used to call ipc_. */
	  2 num		   fixed bin,		/* Number of event channels.  Always = 1. */
	  2 ev_chan	   fixed bin (71);		/* Event channel ID. */

dcl	1 event_info	   aligned,		/* Used to call ipc_. */
	  2 chan_name	   fixed bin (71),
	  2 message	   fixed bin (71),
	  2 sender	   bit (36),
	  2 origin,
	  ( 3 dev_signal	   bit (18),
	    3 ring	   bit (18)
	    )		   unaligned,
	  2 chanelx	   fixed bin;

dcl	1 auto_tmdb	   aligned like tmdb;

dcl	1 auto_tape_info	   aligned like tape_info;

dcl	1 auto_tioi_info	   aligned like tioi_info;

/*                  BUILTIN                       */

dcl	(addr, after, before, char, currentsize, index, ltrim, null, rtrim, unspec)
			   builtin;

/*                  CONDITIONS                    */

dcl	cleanup		   condition;

/*                  EXTERNAL STATIC DATA          */

dcl	(
	error_table_$area_too_small,
	error_table_$bad_density,
	error_table_$ionmat,
	error_table_$not_detached
	)		   fixed bin (35) ext static;

/*		INTERNAL STATIC DATA	*/

dcl	req_len		   bit (1) aligned init ("0"b) int static options (constant);

/*		EXTERNAL  ENTRIES		*/

dcl	tape_mult_detach_$detach
			   entry options (variable),
	tape_mult_util_$control
			   entry options (variable),
	tape_mult_open_$open   entry options (variable);
dcl	tape_mult_modes_	   entry options (variable);

dcl	com_err_		   entry options (variable),
	convert_ipc_code_	   entry (fixed bin (35)),
	cv_dec_check_	   entry (char (*), fixed bin (35)) returns (fixed bin (35)),
	hcs_$assign_channel	   entry (fixed bin (71), fixed bin (35)),
	ioa_		   entry options (variable),
	iox_$propagate	   entry (ptr),
	ipc_$block	   entry (ptr, ptr, fixed bin (35)),
	ipc_$create_ev_chn	   entry (fixed bin (71), fixed bin (35)),
	tape_mult_parse_	   entry (ptr, char (32) var, (*) char (*) var, bit (1), fixed bin (35));

dcl	rcp_$attach	   entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)),
	rcp_$check_attach	   entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71),
			   fixed bin, fixed bin (35)),
	rcp_$detach	   entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_error_counts;
%page;
%include tape_ioi_info;
%page;
%include rcp_tape_info;
%page;
%include rcp_volume_formats;
%page;
%include mtape_constants;
%include rcp_resource_types;
%page;
%include iocb;
%page;
tape_mult_attach:
     entry (arg_iocb_ptr, arg_options, arg_com_err_flag, arg_error_code);

/*	This entry is called to attach a tape drive to a process.  This involves the
   *	following major tasks:
   *	1.  Interface with rcp_ to make the tape drive attachment.
   *	2.  Initialize tmdb variables.
   *	3.  Set up the tape_ioi_ activation.
   *	4.  Fill in the standard fields in the I/O control block.
*/
	iocb_ptr = arg_iocb_ptr;			/* Copy arguments. */
	com_err_flag = arg_com_err_flag;

	reel_name = "noreel";			/* no reel specified yet. */
	tmdb_ptr = addr (auto_tmdb);			/* temp tmdb storage */

	unspec (tmdb) = "0"b;			/* init tmdb structure */
	tmdb.opt.reel_name = "";
	tmdb.opt.density = 1600;
	tmdb.volume_density = 1600;
	tmdb.volume_format = "";

	if iocb_ptr -> iocb.attach_data_ptr ^= null then do;
						/* iocb is already attached. */
	     error_code = error_table_$not_detached;
	     goto ATTACH_ERROR;
	end;

/*	We must parse the attach options.  tape_mult_parse_ will do this.
   *	It puts the converted values in the tape_mult_ data block.
*/

	call tape_mult_parse_ (tmdb_ptr, dev_name, arg_options, com_err_flag, error_code);

/*        before checking for an error from the parse of the args, check to */
/*        see if the arg reader was able to get the tape reel name. If so,  */
/*        assign it, then cheack the error.  This way the tape reel can be  */
/*	displayed in the error message.			      */

	if tmdb.opt.reel_name ^= "" then do;
	     if index (tmdb.opt.reel_name, ",sys") > 0 then
		tmdb.opt.system = "1"b;

	     if index (tmdb.opt.reel_name, ",den=") > 0 then do;
		density = cv_dec_check_ (before (after (tmdb.opt.reel_name, ",den="), ","), error_code);
		if error_code ^= 0 then
		     goto ATTACH_ERROR;

		if density ^= 800 & density ^= 1600 & density ^= 6250 then do;
		     error_code = error_table_$bad_density;
		     go to ATTACH_ERROR;
		end;
		tmdb.opt.density = density;
	     end;

	     tmdb.opt.reel_name = before (tmdb.opt.reel_name, ",");
	     reel_name = tmdb.opt.reel_name;
	end;

	if error_code ^= 0 then
	     goto ATTACH_ERROR;

	on cleanup call cleanup_attach ();

	call ATTACH;				/* Get tape drive. */
	if error_code ^= 0				/* Was there an error while attaching? */
	     then
	     goto ATTACH_ERROR;

/*	Attachment has been completed successfully.  We must fill in the iocb.
   *	Then we must propagate this iocb.
*/
	iocb_ptr -> iocb.attach_descrip_ptr = addr (tmdb.attach);
	iocb_ptr -> iocb.attach_data_ptr = tmdb_ptr;
	iocb_ptr -> iocb.detach_iocb = tape_mult_detach_$detach;
	iocb_ptr -> iocb.open = tape_mult_open_$open;
	iocb_ptr -> iocb.control = tape_mult_util_$control;
	iocb_ptr -> iocb.modes = tape_mult_modes_;

	call iox_$propagate (iocb_ptr);		/* Propagate this iocb. */

	arg_error_code = 0;				/* Tape has been successfully attached. */
	return;

ATTACH_ERROR:
	arg_error_code = error_code;			/* Return error code. */
	if com_err_flag				/* Should we write com_err_ message? */
	     then
	     call com_err_ (error_code, "tape_mult_", "Error attaching tape reel ^a", reel_name);
	call cleanup_attach ();

	return;					/*						*/
ATTACH:
     procedure;

/*	This internal procedure is called to attach a tape
   *      and set up the tape_ioi_ activation which includes getting
   *      any needed workspace and setting the appropriate modes.
   *      Tape attachment is accomplished via rcp_.
*/

	tape_info_ptr = addr (auto_tape_info);
	tape_info.version_num = tape_info_version_3;
	tape_info.usage_time = 0;			/* Initialize, not used yet */
	tape_info.wait_time = 0;			/* Same */
	tape_info.system_flag = tmdb.opt.system;	/* System process */
	tape_info.device_name = dev_name;		/* Any drive? */
	tape_info.model = 0;			/* Any model */
	tape_info.tracks = tmdb.opt.tracks;		/* User option */

	if tmdb.opt.density = 800			/* User option */
	     then
	     tape_info.density = "00100"b;
	else if tmdb.opt.density = 1600 then
	     tape_info.density = "00010"b;
	else tape_info.density = "00001"b;		/* 6250 bpi */

	tape_info.speed = tmdb.opt.speed;		/* User option */
	tape_info.unused_qualifier = "0"b;
	tape_info.volume_name = reel_name;		/* User option */
	tape_info.write_flag = tmdb.opt.ring;		/* User option */
	tape_info.position_index = 0;			/* Initialize, not used yet */

/*        Get event channel for rcp_. */

	call ipc_$create_ev_chn (event_channel, error_code);
	if error_code ^= 0 then do;
	     call convert_ipc_code_ (error_code);
	     return;
	end;

	tmdb.channels.rcp = event_channel;

	if tmdb.opt.system | tmdb.opt.density ^= 1600 | tmdb.opt.comment ^= "" then do;
	     comment = rtrim (reel_name);
	     if tmdb.opt.density ^= 1600 then
		comment = rtrim (comment) || ",den=" || ltrim (rtrim (char (tmdb.opt.density)));
	     if tmdb.opt.system then
		comment = rtrim (comment) || ",sys";
	     if tmdb.opt.comment ^= "" then
		comment = rtrim (comment) || ",*" || tmdb.opt.comment;
	end;
	else comment = "";

/*        Attach drive. */

	call ioa_ ("Mounting tape ^a for ^a", reel_name, tmdb.opt.mount_mode);

	call rcp_$attach (DEVICE_TYPE (TAPE_DRIVE_DTYPEX), tape_info_ptr, event_channel, comment, rcp_id, error_code);
	if error_code ^= 0 then
	     return;

	attach_flag = "1"b;				/* Must be detached if error */

	wait_list.num = 1;
	wait_list.ev_chan = event_channel;

ATTACH_LOOP:
	comment = "";

	call rcp_$check_attach (rcp_id, tape_info_ptr, comment, ioi_id, workspace_max, timeout_max, statex, error_code);
	if comment ^= "" & com_err_flag then
	     call com_err_ (0, "tape_mult_", "RCP comment: ^a", comment);

	go to ATTACH_STATE (statex);

ATTACH_STATE (1):					/* short wait */
	call ipc_$block (addr (wait_list), addr (event_info), error_code);
	if error_code ^= 0 then do;
	     call convert_ipc_code_ (error_code);
	     return;
	end;

	go to ATTACH_LOOP;

ATTACH_STATE (2):					/* long wait, forget it */
	error_code = error_table_$ionmat;

ATTACH_STATE (3):					/* fatal error */
	return;

ATTACH_STATE (0):					/* success */
	Sable_to_read_the_tape = "1"b;

	if tape_info.volume_type = Volume_blank | tape_info.volume_type = Volume_unreadable then do;
	     Sable_to_read_the_tape = "0"b;
	     tmdb.volume_density = tmdb.opt.density;
	end;
	else tmdb.volume_density = MTAPE_VALID_DENSITIES (tape_info.volume_density);

	tmdb.volume_format = Tape_volume_types (tape_info.volume_type);

	tioi_info_ptr = addr (auto_tioi_info);
	tioi_info.version = tioi_info_version_1;
	tioi_info.ioi_index = ioi_id;
	tioi_info.timeout_max = timeout_max;
	tioi_info.workspace_max = workspace_max;

	call hcs_$assign_channel (event_channel, error_code);
	if error_code ^= 0 then do;
	     call ipc_$create_ev_chn (event_channel, error_code);
	     if error_code ^= 0 then do;
		call convert_ipc_code_ (error_code);
		return;
	     end;
	end;

	tmdb.channels.ioi = event_channel;

	tioi_info.event_id = event_channel;

	call tape_ioi_$activate (tape_info_ptr, tioi_info_ptr, tioi_id, error_code);
	if error_code ^= 0 then
	     return;

	activation_flag = "1"b;

/*        Finish tmdb initialization. */

	tmdb.opt.reel_name = before (tape_info.volume_name, ",");
						/* might have changed */
	tmdb.work.rcp_id = rcp_id;
	tmdb.work.tioi_id = tioi_id;

/*        Get workspace for permanent tmdb storage. */

	req_work_area_len = currentsize (tmdb);

	call tape_ioi_$allocate_work_area (tioi_id, req_work_area_len, act_work_area_len, tmdb_ptr, error_code);
	if error_code ^= 0 then
	     return;
	if act_work_area_len ^= req_work_area_len then do;
	     error_code = error_table_$area_too_small;	/* A different code should be used. */
	     return;
	end;

	tmdb = auto_tmdb;


	call ioa_ ("Mounted ^a volume ""^a"" ^[(recorded at ^d BPI), ^;^1s^]on device ^a", tmdb.volume_format,
	     tape_info.volume_name, Sable_to_read_the_tape, tmdb.volume_density, tape_info.device_name);

/*        Set appropriate modes: not req_len by tape_ioi_, all other default. */

	call tape_ioi_$set_mode (tioi_id, "req_len", addr (req_len), error_code);

     end ATTACH;

cleanup_attach:
     proc ();

	if attach_flag then
	     call rcp_$detach (rcp_id, "0"b, (0), "", (0));

	if activation_flag then do;
	     auto_error_tally.version = TEC_VERSION_1;
	     call tape_ioi_$deactivate (tioi_id, addr (auto_error_tally), (0));
	end;

     end cleanup_attach;

     end tape_mult_;




		    tape_mult_close_.pl1            11/11/89  1105.7r w 11/11/89  0812.6       81090



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


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

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/28/74 by Bill Silver.
   *      Modified 07/02/81 by J. A. Bush for bootable tape labels
   *	Modified 01/16/82 by J. A. Bush to process the "error_tally" att desc arg
   *      Modified 8/82 by S. Krupp for change from tdcm_ to tape_ioi_ interface.
   *
   *	This program implements the iox_$close entry point.
   *	We must prepare the tape and all of our info for the tape to be opened
   *	again.  When closing the tape we must do the following:
   *	     1.  Rewind the tape reel.  When opening a tape it must be at BOT.
   *	     2.  Close the I/O control block.
   *	When closing a tape that has been opened for writing we must first perform the
   *	following additional steps:
   *	     1.  Write out all currently buffered output data.
   *	     2.  Write an EOF record.
   *	     3.  Write an End of Reel record.  This contains all PAD characters.
   *	     4.  Write two EOF records.
   *	When writing this end of tape information we must ignore all device_end errors.
*/


/*		ARGUMENTS			*/

dcl	arg_error_code	   fixed bin (35),		/* (O) Standard system error code. */
	arg_iocb_ptr	   ptr;			/* (I) Pointer to I/O control block. */


/*		AUTOMATIC  DATA		*/

dcl	eot_flag		   bit (1),		/* ON => tape at End of Tape. */
	error_code	   fixed bin (35),		/* Standard system error code. */
	i		   fixed bin,
	iocb_ptr		   ptr,			/* Pointer to I/O control block. */
	put_hdr		   bit (1) aligned,
	rx		   fixed bin,
	save_code		   fixed bin (35),		/* Used to play with error code. */
	tioi_id		   bit (36) aligned;	/* Id of tape_ioi_ activation. */

dcl	1 auto_error_tally	   aligned like tec;	/* Keeps track of number of errors. */

/*		INTERNAL STATIC DATA	*/

dcl	pad_char		   bit (9) aligned internal static init ("111111111"b);
						/*		EXTERNAL ENTRIES		*/

dcl	(addr, hbound, null, string)
			   builtin;

dcl	error_table_$device_end
			   fixed bin (35) external;
dcl	error_table_$device_parity
			   fixed bin (35) external;

dcl	iox_$err_not_open	   entry options (variable),
	iox_$propagate	   entry (ptr),
	ioa_		   entry options (variable),
	tape_mult_detach_$detach
			   entry (ptr, fixed bin (35)),
	tape_mult_open_$open   entry (ptr, fixed bin, bit (1), fixed bin (35)),
	tape_mult_util_$wait_for_write
			   entry (bit (36) aligned, fixed bin, fixed bin (35)),
	tape_mult_write_$flush entry (ptr, fixed bin (35)),
	tape_mult_write_$eof   entry (ptr, fixed bin (35)),
	tape_mult_write_$record
			   entry (ptr, ptr, fixed bin, fixed bin (35));
%page;
%include iocb;
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_error_counts;
%page;
close:
     entry (arg_iocb_ptr, arg_error_code);

	iocb_ptr = arg_iocb_ptr;			/* Copy argument. */

	iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;	/* Initialize pointers. */
	tmdb_ptr = iocb_ptr -> iocb.attach_data_ptr;
	tioi_id = tmdb.tioi_id;
	error_code = 0;

	if tmdb.open.description = "stream_input" then do;
	     call STOP_TAPE (error_code);
	     if error_code ^= 0 then
		go to REWIND;
	     if tmdb.opt.flags.err_tal		/* user wants error recovery tally */
	     then do;
		auto_error_tally.version = TEC_VERSION_1;
		call tape_ioi_$get_statistics (tioi_id, addr (auto_error_tally), error_code);
		if error_code ^= 0 then
		     call ioa_ ("Unable to get error statistics for tape volume ^a", tmdb.opt.reel_name);
		else do;
		     call ioa_ ("^/Error statistics for tape volume ^a:^/", tmdb.opt.reel_name);
		     call ioa_ ("Total tape errors:^-^d", auto_error_tally.reads.errors);
		     put_hdr = "0"b;
		     do i = 1 to hbound (auto_error_tally.successful_retry_strategy, 1);
			if auto_error_tally.successful_retry_strategy (i) ^= 0 then do;
			     if ^put_hdr then do;
				put_hdr = "1"b;
				call ioa_ ("Successful error recovery by backspace/re-read record:^/");
			     end;
			     call ioa_ ("With ^2d retries:^-^d", i, auto_error_tally.successful_retry_strategy (i));
			end;
		     end;
		     if tmdb.meters.fwd_rd_recovery ^= 0 then do;
			call ioa_ ("Successful error recovery by reading re-written record:");
			call ioa_ ("^2-^d", tmdb.meters.fwd_rd_recovery);
		     end;
		     if tmdb.meters.reposition_recovery ^= 0 then do;
			call ioa_ ("Successful error recovery by repositioning and re-reading:");
			call ioa_ ("^2-^d", tmdb.meters.reposition_recovery);
		     end;
		end;
	     end;
	     goto REWIND;				/* If reading nothing to do to close. */
	end;

	call tape_mult_write_$flush (tmdb_ptr, error_code);
						/* Ignore error, just try to close. */

	call FIX_HEADER_AND_TRAILER (error_code);
	if error_code ^= 0 then
	     go to REWIND;

	if tmdb.head.rec_within_file ^= -1		/* If we haven't just written an EOF. */
	then do;
	     call tape_mult_write_$eof (tmdb_ptr, error_code);
	     if ^(error_code = 0 | error_code = error_table_$device_end) then
		goto REWIND;
	end;

	if tmdb.head.flags.eot			/* Are we at the End of Tape? */
	then eot_flag = "1"b;
	else eot_flag = "0"b;

	string (tmdb.head.flags) = "0"b;		/* Turn OFF all flags. */

	tmdb.head.flags.set, tmdb.head.flags.eot = eot_flag;
						/* Set EOT flag if appropriate. */
	tmdb.head.flags.admin, tmdb.head.flags.eor = "1"b;/* Turn ON  End of Reel  flag. */
	call tape_mult_write_$record (tmdb_ptr, addr (pad_char), 1, error_code);
	if ^(error_code = 0 | error_code = error_table_$device_end) then
	     goto REWIND;

	do i = 1 to 2;				/* Write two EOF records at end of tape. */
	     call tape_mult_write_$eof (tmdb_ptr, error_code);
	     if ^(error_code = 0 | error_code = error_table_$device_end) then
		goto REWIND;
	end;

	error_code = 0;				/* Getting this far => no error. */

REWIND:						/* A closed tape reel should be rewound. */
	string (tmdb.head.flags) = "0"b;		/* Make sure all flags are OFF. */

	if error_code ^= 0 then
	     call STOP_TAPE ((0));

	call tape_ioi_$deallocate_buffers (tioi_id, save_code);
	if error_code = 0 then
	     error_code = save_code;
	call tape_ioi_$order (tioi_id, "rew", 1, (null), (0), (0), save_code);
						/* issue rewind order, but don't bother to wait. */
	if error_code = 0				/* Use first error_code. */
	then error_code = save_code;

/*	Now we must fill in the I/O control block to indicate that it is closed.
*/
	iocb_ptr -> iocb.open_descrip_ptr = null ();
	iocb_ptr -> iocb.detach_iocb = tape_mult_detach_$detach;
	iocb_ptr -> iocb.open = tape_mult_open_$open;
	iocb_ptr -> iocb.close, iocb_ptr -> iocb.put_chars, iocb_ptr -> iocb.get_chars = iox_$err_not_open;

	call iox_$propagate (iocb_ptr);		/* Propagate changes to the I/O control block. */

	arg_error_code = error_code;			/* Return our error code. */

%page;
STOP_TAPE:
     proc (code);

dcl	code		   fixed bin (35);

	code = 0;

	call tape_ioi_$stop_tape (tioi_id, (0), rx, code);
	if rx ^= 0 then do;
	     if code = 0 then
		code = error_table_$device_parity;
	end;

     end STOP_TAPE;

/* This procedure is used to find the last good buffer written after a
   write error occured in the last subset.  We must do this because counters
   in the eor record must be in line with those of the last good record written. */

FIX_HEADER_AND_TRAILER:
     proc (error_code);

dcl	error_code	   fixed bin (35);
dcl	n_ready_buffers	   fixed bin;
dcl	READY_BUFS	   fixed bin init (1);
dcl	ready_buffers	   (tmdb.work.n_bufs) ptr;
dcl	rx		   fixed bin;

	error_code = 0;

	call tape_mult_util_$wait_for_write (tioi_id, rx, error_code);
	if rx ^= 0 then do;
	     if error_code = 0 then
		error_code = error_table_$device_parity;
	     return;
	end;

	call tape_ioi_$list_buffers (tioi_id, READY_BUFS, ready_buffers, n_ready_buffers, error_code);
	if error_code ^= 0 then
	     return;

	if n_ready_buffers = 0 then
	     return;

	mstrp = ready_buffers (n_ready_buffers);

	if mstr.trail.tot_rec = tmdb.trail.tot_rec then
	     return;				/* We are ok. */

/* We are not ok, counts must be reset so that they are consistent.
   This is because some error occured that caused us to abort writing. */

	tmdb.head = mstr.head;
	tmdb.trail = mstr.trail;

	tmdb.work.buf_pos, tmdb.work.n_full = 0;

	call STOP_TAPE (error_code);

     end FIX_HEADER_AND_TRAILER;

     end tape_mult_close_;




		    tape_mult_detach_.pl1           11/11/89  1105.7r w 11/11/89  0812.6       41634



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


/* format: style4,delnl,insnl,ifthen */
tape_mult_detach_:
     procedure;

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/28/74 by Bill Silver.
   *         Modified 7/28/81 by J. A. Bush for bootable tape labels
   *         Modified 8/82 by S. Krupp for change from tdcm_ to tape_ioi_ interface.
   *
   *	This program implements the iox_$detach_iocb entry point.
   *	Detaching involves the following steps:
   *	     1.  Calling rcp_ to detach the tape drive.
   *	     2.  Deleting the event channel that  was created for this attachment.
   *	     3.  Setting the iocb to the detached state.
*/


/*		ARGUMENTS			*/

dcl  arg_error_code fixed bin (35),			/* (O) Standard system error code. */
     arg_iocb_ptr ptr;				/* (I) Pointer to I/O control block. */


/*		AUTOMATIC  DATA		*/

dcl  error_code fixed bin (35),			/* Standard system error code. */
     error_count fixed bin,				/* Rcp error count. */
     event_channel fixed bin(71),
     iocb_ptr ptr,					/* Pointer to I/O control block. */
     ioi_channel fixed bin(71),
     rcp_id bit(36) aligned,				/* Id for tape drive attachment. */
     rcp_channel fixed bin(71),
     save_code fixed bin (35),			/* Used to play with error code. */
     tioi_id bit(36) aligned;				/* Id for tape_ioi_ activation. */

dcl  1 auto_error_tally aligned like tec;

/*                  STATIC                        */

dcl  DISPOSITION bit(1) init("0"b) int static options(constant);
						/* Disposition of tape drive */
						/* after rcp detachment. */

/*		EXTERNAL ENTRIES		*/

dcl  (addr, unspec, null) builtin;

dcl  hcs_$delete_channel entry (fixed bin(71), fixed bin(35)),
     ipc_$delete_ev_chn entry (fixed bin(71), fixed bin(35)),
     iox_$err_not_attached entry options (variable),
     iox_$propagate entry (ptr),
     rcp_$detach entry(bit(36) aligned, bit(*), fixed bin, char(*), fixed bin(35)),
     release_temp_segment_ entry (char (*), ptr, fixed bin (35)),
     convert_ipc_code_ entry (fixed bin (35));
%page;
%include iocb;
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_error_counts;
%page;
detach:
     entry (arg_iocb_ptr, arg_error_code);

	iocb_ptr = arg_iocb_ptr;			/* Copy argument. */

	tmdb_ptr = iocb_ptr -> iocb.attach_data_ptr;	/* Initialize pointer. */
	tioi_id = tmdb.work.tioi_id;
	rcp_id = tmdb.work.rcp_id;
	error_code, save_code = 0;
	if tmdb.tbpp ^= null then			/* user had boot pgm, and never opened */
	     call release_temp_segment_ ("tape_mult_", tmdb.opt.tbpp, (0));
						/* so release boot pgm temp seg now */

          rcp_channel = tmdb.channels.rcp;
	ioi_channel = tmdb.channels.ioi;

          unspec(auto_error_tally) = "0"b;
          auto_error_tally.version = TEC_VERSION_1;

          call tape_ioi_$deactivate(tioi_id, addr(auto_error_tally), save_code);
						/* release buffers and workspace, */
	call SAVE_CODE;				/* generally deactivate. */

          error_count = auto_error_tally.writes.errors + auto_error_tally.reads.errors + auto_error_tally.orders.errors;

	call rcp_$detach(rcp_id, DISPOSITION, error_count, "", save_code);
						/* Detach tape drive. */
	call SAVE_CODE;

	do event_channel = rcp_channel, ioi_channel;
	     call ipc_$delete_ev_chn(event_channel, save_code);
	     if save_code ^= 0
	     then call convert_ipc_code_(save_code);
	     call SAVE_CODE;
	end;

	iocb_ptr -> iocb.attach_data_ptr,		/* Now put iocb in detached state. */
	     iocb_ptr -> iocb.attach_descrip_ptr = null ();
	iocb_ptr -> iocb.open, iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;

	call iox_$propagate (iocb_ptr);		/* Propagate changes to I/O control block. */

	arg_error_code = error_code;
	return;					/*						*/
SAVE_CODE:
     procedure;

/*	Called to save first error code that is not zero. */

	if error_code = 0 then
	error_code = save_code;

     end SAVE_CODE;


     end tape_mult_detach_;




		    tape_mult_labeler_.pl1          11/11/89  1105.7rew 11/11/89  0812.6      103932



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




/****^  HISTORY COMMENTS:
  1) change(86-10-13,GWMay), approve(86-10-13,MCR7552),
     audit(86-10-13,Martinson), install(86-10-20,MR12.0-1189):
     Moved density determining code to tape_mult_read_$label.  Added the tmdb
     initialization code, removed from tape_mult_read_ to this module.
  2) change(86-10-22,GWMay), approve(86-10-22,PBF7552),
     audit(86-10-24,Martinson), install(86-11-21,MR12.0-1223):
     removed added init values which caused some operations to not work.
     The above comment (1) is in error.  The density determining code was not
     removed from this module.  The actual movement of code was from
     tape_mult_open_.pl1 to tape_mult_read_.pl1
  3) change(87-01-07,GWMay), approve(87-01-07,PBF7552), audit(87-01-08,Farley),
     install(87-01-12,MR12.0-1268):
     move init of tmdb.opt.blp to before read of tape label.
                                                   END HISTORY COMMENTS */


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

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/26/74 by Bill Silver.
   *	Modified 3/80 by R.J.C. Kissel to fix a label writing bug.
   *	Modified 1/2/81 by J. A. Bush for bootable tape labels
   *	Modified 8/13/81 by J. A. Bush for pre-MR9.0 label compatibility
   *      Modified 8/82 by S. Krupp to change from tdcm_ to tape_ioi_ interface.
   *	Modified 12/14/82 by J. A. Bush to add header label version
   *      Modified 1985-05-14, BIM: reset record length to full after writing
   *	         label.
   *      Modified 1985-05-17, BIM: don't do an FSF command since its results
   *	         can be unpredictable.
   *
   *	This program is called to write or read the label of a Multics standard tape.
*/

/*		ARGUMENTS			*/

dcl	arg_error_code	   fixed bin (35),		/* (O) Standard system error code. */
	arg_tmdbp		   ptr,			/* (I) Pointer to tseg set up by tape_. */
	arg_volid		   char (*);		/* (I/O) Tape reel ID. */


/*		AUTOMATIC  DATA		*/

dcl	act_length	   fixed bin (21),		/* Actual length of buffer allocated. */
	act_number	   fixed bin,		/* Actual number of buffers allocated. */
	dummy_arrayp	   ptr,			/* Designates array of pointers to newly alocated I/O buffers. */
	error_code	   fixed bin (35),		/* Standard system error code. */
	n_bufs		   fixed bin,		/* Number of buffers currently being allocated. */
	record_data_len	   fixed bin,		/* Number of chars in data portion of label record. */
	record_data_size	   fixed bin,		/* Number of words in data portion of label record. */
	record_size	   fixed bin (21),		/* Number of words in the physical label record. */
	tioi_id		   bit (36) aligned,	/* Id for this tape_ioi_ activation. */
	tl_ptr		   ptr;			/* Pointer to our tape label data. */

/*                  BASED                         */

dcl	dummy_array	   (n_bufs) ptr based (dummy_arrayp);

/*		EXTERNAL  ENTRIES		*/

dcl	(addr, divide, hbound, null, size, string)
			   builtin;

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



dcl	tape_mult_read_$label  entry (ptr, ptr, fixed bin, fixed bin (35)),
	tape_mult_write_$eof   entry (ptr, fixed bin (35)),
	tape_mult_write_$label entry (ptr, fixed bin (35));
%page;
%include tape_ioi_dcls;
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include iox_modes;
%page;
write:
     entry (arg_tmdbp, arg_error_code);

/*	This entry is called to write the label record of a Multics standard tape.  It
   *	must also write an EOF record after the label record.  tape_mult_ will only
   *	write records of size 1024 words.
*/

	tmdb_ptr = arg_tmdbp;
	tioi_id = tmdb.work.tioi_id;
	error_code = 0;

	record_data_size = 1024 -			/* must subtract length of transfer vector */
	     (hbound (arg_tmdbp -> mst_label.xfer_vector, 1) * 2);
	record_size =
	     record_data_size + size (mstr_header) + size (mstr_trailer)
	     + (hbound (arg_tmdbp -> mst_label.xfer_vector, 1) * 2);

	call INIT_TMDB;				/* Set up data in the TMDB. */
	if error_code ^= 0 then
	     goto WRITE_RETURN;

	tmdb.head.flags.admin, tmdb.head.flags.label = "1"b;
						/* Turn ON label flags. */
	call tape_mult_write_$label (tmdb_ptr, error_code);
	if error_code ^= 0 then
	     go to WRITE_RETURN;

	string (tmdb.head.flags) = "0"b;		/* Turn OFF all flags. */
	call tape_mult_write_$eof (tmdb_ptr, error_code);
	if error_code ^= 0 then
	     go to WRITE_RETURN;

	record_data_size = 1024;			/* Now that we have the bootable label written, reset to full length */
	record_size = record_data_size + size (mstr_header) + size (mstr_trailer);
	tmdb.work.rec_length = record_data_size * 4;
	tmdb.head.data_bit_len = record_data_size * 36;

	call COMPLETE_TMDB;				/* Label records written OK. */

WRITE_RETURN:					/* Common exit from this entry. */
	arg_error_code = error_code;
	return;
%page;
read:
     entry (arg_tmdbp, arg_volid, arg_error_code);

/*	This entry is called to read a label record and an End of File record from the
   *	beginning of a Multics standard tape.
*/

	tmdb_ptr = arg_tmdbp;
	tioi_id = tmdb.work.tioi_id;

	record_data_size = 1024;			/* Initially assume that this tape has large records. */
	record_size = record_data_size + size (mstr_header) + size (mstr_trailer);

	tmdb.opt.blp = null;

	call INIT_TMDB;				/* Set up an TMDB. */
	if error_code ^= 0 then
	     goto READ_RETURN;

	tmdb.work.label_version = 1;			/* set to old type label initially */
	tmdb.work.output_mode = Stream_output;		/* default output mode is stream_output */
	tl_ptr = addr (tmdb.buffer);			/* Read label data into this buffer. */

	call tape_mult_read_$label (tmdb_ptr, tl_ptr, record_data_len, error_code);
						/* Read the label. */
	if error_code ^= 0 then
	     go to READ_RETURN;

/*	We have successfully read the first record of the tape.
   *	On some tapes, on some tape drives, FSF commands miss file marks
   *	that reads find. So instead of sending in an FSF here to
   *	skip the file mark, we leave the tape just after the label,
   *	and trust that tape_mult_read_ will cheerfully skip the 
   *	file mark (if the drive picks it up.)
   *	Now, we must see how many words are in this record.  The rest of the records on
   *	this tape should be the same size.  We must also check to see that this record is a
   *	valid Multics standard tape label record.
*/
	record_data_size = divide (tmdb.head.data_bit_len, 36, 17, 0);
	if (record_data_size ^= 1024) & (record_data_size ^= 256) then
	     goto BAD_LABEL;

	if ^tmdb.head.flags.admin |			/* Check that label flags are correct. */
	     ^tmdb.head.flags.label then
	     goto BAD_LABEL;			/* Both MUST be ON. */
	if tmdb.work.label_version > 2 then do;		/* if a bootable label.. */
	     tmdb.opt.blp = tl_ptr;			/* save ptr to full label for control */
	     tl_ptr = addr (tl_ptr -> mst_label.installation_id);
						/* adjust ptr to volume info */
	end;

	if tmdb.work.label_version > 1 then		/* if a new style  label */
	     if tmdb.opt.volume_set_id ^= "" then	/* and if a volume set was specified in att. desc. */
		if tl_ptr -> volume_identifier.volume_set_id ^= "" then
						/*  and if tape label has something besides blanks */
		     if tl_ptr -> volume_identifier.volume_set_id ^= tmdb.opt.volume_set_id then
						/* they must be equal */
			go to BAD_LABEL;

	string (tmdb.work.flags),			/* Zero work.flags. */
	   string (tmdb.head.flags) = "0"b;

	call COMPLETE_TMDB;				/* Return a good TMDB to tape_. */
	if error_code ^= 0 then
	     go to READ_RETURN;

	tmdb.work.rec_length = 0;
	tmdb.work.buf_pos = 1;
	tmdb.trail.tot_rec = 0;
	tmdb.work.curr_buf = null;
	tmdb.work.next_buf = null;
	tmdb.meters = 0;
	tmdb.work.label_uid = tmdb.head.uid;

	arg_volid = tl_ptr -> volume_identifier.tape_reel_id;
						/* give caller right info. */
	goto READ_RETURN;


BAD_LABEL:
	error_code = error_table_$bad_label;

READ_RETURN:					/* Common exit from this entry. */
	arg_error_code = error_code;
	return;
%page;
INIT_TMDB:
     procedure;

/*	This internal procedure is called by both the write and read entries.
   *      Its job is to initialize the TMDB and set up a buffer for the
   *      label I/O.
*/

	tmdb.head.c1 = header_c1;			/* 670314355245 */
	tmdb.head.rec_within_file = -1;		/* Incremented before record is written. */
	tmdb.head.phy_file = 0;
	tmdb.head.data_bit_len = record_data_size * 36;
	string (tmdb.head.flags) = "0"b;
	tmdb.head.header_version = HEADER_VERSION;	/* set version number of record header */
	tmdb.head.c2 = header_c2;			/* 512556146073 */

	tmdb.trail.c1 = trailer_c1;			/* 107463422532 */
	tmdb.trail.tot_data_bits = 0;
	tmdb.trail.pad_pattern = "777777777777"b3;
	tmdb.trail.reel_num, tmdb.trail.tot_file = 0;
	tmdb.trail.tot_rec = -1;			/* Incremented before record is written. */
	tmdb.trail.c2 = trailer_c2;			/* 265221631704 */

	string (tmdb.work.flags) = "0"b;

	tmdb.work.buf_pos = 0;			/* Start with no data. */
	tmdb.work.rec_length = record_data_size * 4;
	tmdb.work.next_buf = null;			/* Only one now. */
	tmdb.work.buf_len = record_size * 4;
	tmdb.work.n_full = 0;
	tmdb.work.n_recs_to_eof = 0;
	tmdb.work.buffer (*) = null;

	if tmdb.work.n_bufs ^= 0			/* Make sure we only have one buffer for synchronous I/O */
	then do;
	     call tape_ioi_$deallocate_buffers (tioi_id, error_code);
	     if error_code ^= 0 then
		return;
	end;

	tmdb.work.n_bufs = 1;
	tmdb.work.bufs_per_subset = 1;

	n_bufs = 1;
	dummy_arrayp = addr (tmdb.work.buffer (1));

	call tape_ioi_$allocate_buffers (tioi_id, tmdb.work.buf_len, n_bufs, act_length, act_number, dummy_array,
	     error_code);				/* Allocate only 1 buffer now - rest later. */
						/* This is for synchronous I/O of label. */
	if error_code ^= 0 then
	     return;

	tmdb.work.curr_buf = dummy_array (1);		/* Buffer for label I/O. */

	return;

     end INIT_TMDB;
%page;
COMPLETE_TMDB:
     procedure;

/*	This internal procedure is called when we have successfully processed the tape label.
   *	Its job is to set up all the buffers that we will be using to process this tape.
   *      Previously, only one buffer was set up because we only wanted 1 record (the label record)
   *      and wanted to read/write it synchronously.  Tapes with the "-system" option specified
   *      get more buffers than ones without because RCP allows a greater maximum workspace
   *      size for system processes.
*/

	if tmdb.opt.system				/* System procs get more buffers. */
	then do;
	     tmdb.work.n_bufs = 16;
	     tmdb.work.bufs_per_subset = 8;
	end;
	else do;
	     tmdb.work.n_bufs = 4;
	     tmdb.work.bufs_per_subset = 2;
	end;

	n_bufs = tmdb.work.bufs_per_subset - 1;
	dummy_arrayp = addr (tmdb.work.buffer (2));
	call tape_ioi_$allocate_buffers (tioi_id, tmdb.work.buf_len, tmdb.work.n_bufs - 1, act_length, act_number,
	     dummy_array, error_code);

     end COMPLETE_TMDB;


     end tape_mult_labeler_;




		    tape_mult_modes_.pl1            11/11/89  1105.7r w 11/11/89  0812.6       16533



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/* tape_mult_modes_ -- modes entrypoint for tape_mult_.
    Implemented for the unfortunate but unavoidable "async" mode.*/

/* format: style2 */

tape_mult_modes_:
     procedure (p_iocb_ptr, p_new_modes, p_old_modes, p_code);

/**** Modification history:
      Created 1985-03-18.
*/

	declare p_iocb_ptr		 pointer;
	declare (p_new_modes, p_old_modes)
				 char (*);
	declare p_code		 fixed bin (35);

	declare iocb_ptr		 pointer;
	declare error_table_$bad_mode	 fixed bin (35) ext static;


	iocb_ptr = p_iocb_ptr -> iocb.actual_iocb_ptr;
	tmdb_ptr = iocb_ptr -> iocb.attach_data_ptr;

	p_code = 0;

/**** Note that the following is not a "general" modes entrypoint.
      We never expect to add another mode to tape_mult_, because
      we intend to replace it with mtape_. If we do add, the resources
      to code mode_string_ calls and the like can be spent at a later time */

	if tmdb.async_sw
	then p_old_modes = "async.";			/* old mode string is trivial to construct */
	else p_old_modes = "^async.";

	if p_new_modes = "" | p_new_modes = "."
	then return;

	if p_new_modes = "async" | p_new_modes = "async."
	then tmdb.async_sw = "1"b;

	else if p_new_modes = "^async" | p_new_modes = "^async."
	then tmdb.async_sw = "0"b;

	else p_code = error_table_$bad_mode;
	return;

%include tmdb;
%include mstr;
%include iocb;

     end tape_mult_modes_;




		    tape_mult_open_.pl1             11/11/89  1105.7rew 11/11/89  0812.6       69300



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




/****^  HISTORY COMMENTS:
  1) change(86-10-13,GWMay), approve(86-10-13,MCR7552),
     audit(86-10-13,Martinson), install(86-10-20,MR12.0-1189):
     Added support for the use of rcp_ in  determining the density and format
     type of a tape.  Changes mounted tape message to include the format type
     and recording density of the mounted tape as determined by rcp_.
  2) change(86-10-23,GWMay), approve(86-10-23,PBF7552),
     audit(86-11-11,Martinson), install(86-11-21,MR12.0-1223):
     History comment correction.   Please disregard the previous comment.  The
     rcp_ density determining support was added to tape_mult_.pl1.  This module
     was modified to remove the density determining read loop which was moved
     to tape_mult_read_$label.  Howwever, the initial value returned by rcp_ is
     assigned within this routine.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,ifthen */
tape_mult_open_:
     procedure;

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/28/74 by Bill Silver.
   *	Modified 4/79 by R.J.C. Kissel to handle 6250 bpi.
   *	Modified 1/12/81 by J. A. Bush for bootable tape labels
   *      Modified 8/82 by S. Krupp for change from tdcm_ to tape_ioi_ interface.
   *	This program implements the iox_$open entry point.
*/


/*			ARGUMENT  DATA	*/

dcl  arg_error_code fixed bin (35),			/* (O) Standard error code. */
     arg_extend_flag bit (1),				/* (I) ON => extend file - illegal for tape_mult_ */
     arg_iocb_ptr ptr,				/* (I) Pointer to I/O control block. */
     arg_open_mode fixed bin;				/* (I) Index that => opening mode. */


/*			AUTOMATIC  DATA	*/

dcl  density fixed bin,				/* Density of tape: 800, 1600, or 6250. */
     error_code fixed bin (35),			/* Standard system error code. */
     iocb_ptr ptr,					/* Pointer to I/O control block. */
     open_mode fixed bin,				/* Index that => opening mode. */
     rdy_status bit (36) aligned,			/* Rdy status returned here. */
     tioi_id bit (36) aligned,			/* Id for this tape_ioi_ activation. */
     volid char (16);				/* Tape reel ID. */


/*		INTERNAL STATIC DATA	*/

dcl  stream_input_mode fixed bin init (1) internal static,
     stream_output_mode fixed bin init (2) internal static;


/*		EXTERNAL  ENTRIES		*/

dcl  (addr, null) builtin;

dcl  (
     error_table_$bad_arg,
     error_table_$bad_mode
     ) external fixed bin (35);

dcl  iox_$err_not_closed entry options (variable),
     iox_$propagate entry (ptr),
     tape_mult_close_$close entry options (variable),
     tape_mult_labeler_$read entry (ptr, char (*), fixed bin (35)),
     tape_mult_labeler_$write entry (ptr, fixed bin (35)),
     tape_mult_read_$get_chars entry options (variable),
     tape_mult_read_$position entry options (variable),
     tape_mult_write_$put_chars entry options (variable);
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include tape_ioi_dcls;
%page;
%include iocb;
%page;
open:
     entry (arg_iocb_ptr, arg_open_mode, arg_extend_flag, arg_error_code);

	iocb_ptr = arg_iocb_ptr;			/* Copy arguments. */
	open_mode = arg_open_mode;

	iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;	/* Initialize pointers and work variables. */
	tmdb_ptr = iocb_ptr -> iocb.attach_data_ptr;
	tioi_id = tmdb.work.tioi_id;

	tmdb.open.length = 18;			/* Set up default open mode. */
	tmdb.open.description = "uninitialized_mode";

	if arg_extend_flag				/* tape_mult_ does not support extend. */
	then do;					/* We will not allow it to be specified. */
	     error_code = error_table_$bad_arg;
	     goto OPEN_ERROR;
	end;

	if open_mode = stream_input_mode		/* Are we opening for input or output? */
	then do;					/* Input. */
	     tmdb.open.length = 12;
	     tmdb.open.description = "stream_input";
	     goto SETUP_REEL;
	end;

	if open_mode = stream_output_mode		/* If not input it must be output. */
	then do;
	     if ^tmdb.opt.flags.ring			/* Is write ring in? */
		then
		goto BAD_MODE;			/* No, we must abort the open. */
	     tmdb.open.length = 13;
	     tmdb.open.description = "stream_output";
	     goto SETUP_REEL;
	end;

BAD_MODE:						/* We cannot open with this mode. */
	error_code = error_table_$bad_mode;
	goto OPEN_ERROR;

/*	Now we must get the tape reel ready for I/O processing.  We must set
   *	the density and process the tape label.
*/
SETUP_REEL:


	if open_mode = stream_output_mode		/* Are we writing or reading? */
	then do;					/* Writing. */
 	     density = tmdb.opt.density;		/* Get user specified density. */
	     call REWIND (error_code);		/* rewind before setting density */
	     if error_code ^= 0 then
		goto OPEN_ERROR;
	     call tape_ioi_$order (tioi_id, "den", 1, addr (density), (0), (0), error_code);
	     if error_code ^= 0 then
		goto OPEN_ERROR;
	     tmdb.opt.write_sw = "1"b;
	     call tape_mult_labeler_$write (tmdb_ptr, error_code);
	end;
	else do;					/* Reading. */
	     density = tmdb.volume_density;		/* use rcp determined density */
	     tmdb.opt.write_sw = "0"b;
	     call tape_mult_labeler_$read (tmdb_ptr, volid, error_code);
	end;
	if error_code ^= 0 then
	     goto OPEN_ERROR;

/*	Now we must fill in the iocb.  It will be set up so an error will occur
   *	if any attempt is made to open the switch again or to detach it before
   *	it is closed.  Depending upon the opening mode we will set up the
   *	put_chars or get_chars entry point.
*/
	iocb_ptr -> iocb.open_descrip_ptr = addr (tmdb.open);
	iocb_ptr -> iocb.open = iox_$err_not_closed;
	iocb_ptr -> iocb.close = tape_mult_close_$close;
	iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed;

/*	The I/O operations supported by tape_mult_ depends upon the opening mode.
   *	     stream_input:
   *		get_chars
   *		position
   *	     stream_output:
   *		put_chars
   *		control (error_count order)
*/
	if open_mode = stream_output_mode		/* Set up I/O entry and tseg write switch. */
	     then
	     iocb_ptr -> iocb.put_chars = tape_mult_write_$put_chars;
						/* Writing. */
	else do;					/* Reading. */
	     iocb_ptr -> iocb.get_chars = tape_mult_read_$get_chars;
	     iocb_ptr -> iocb.position = tape_mult_read_$position;
	end;

	call iox_$propagate (iocb_ptr);

	arg_error_code = 0;				/* Open completed successfully. */
	return;

OPEN_ERROR:					/* Fatal error during opening. */
	arg_error_code = error_code;
	return;
%page;
REWIND:
     proc (code);

/*        This procedure signals the tape rewind order and the waits until
   *      the tape is actually rewound (device is ready for processing).
*/

dcl  code fixed bin (35);

	call tape_ioi_$order (tioi_id, "rdy", 1, addr (rdy_status), (0), (0), code);
						/* Wait til device is ready. */
	if code ^= 0 then
	     return;
	call tape_ioi_$order (tioi_id, "rew", 1, (null), (0), (0), code);
						/* Rewind tape. */
	if code ^= 0 then
	     return;
	call tape_ioi_$order (tioi_id, "rdy", 1, addr (rdy_status), (0), (0), code);
						/* Wait til rewound. */

     end REWIND;

     end tape_mult_open_;




		    tape_mult_parse_.pl1            11/11/89  1105.7rew 11/11/89  0812.6      112077



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


/****^  HISTORY COMMENTS:
  1) change(87-01-08,GDixon), approve(87-03-30,MCR7643),
     audit(87-03-31,Farley), install(87-04-28,MR12.1-1028):
     Add support for -device attach option, to specify the tape device on which
     to mount the tape.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tape_mult_parse_:
     procedure (arg_tmdb_ptr, arg_dev_name, arg_options, arg_com_err_sw, arg_error_code);

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/24/74 by  Bill Silver.
   *	Modified 4/79 by R.J.C. Kissel to handle 6250 bpi.
   *	Modified 1/2/81 by J. A. Bush for bootable tape_labels
   *	Modified 1/7/82 by J. A. Bush for the "-error_tally" att. desc arg
   *      Modified 8/82 by S. Krupp for change from tdcm_ to tape_ioi_ interface.
   *
   *	This program is called to parse the attach options accepted by tape_mult_.
   *	It will set up all of the attach option defaults.  The option values will be
   *	returned in the tape_mult_ data block.  tape_mult_parse_ will also build the
   *	attach description string.
*/


/*		ARGUMENT  DATA		*/

dcl      arg_error_code	  fixed bin (35),		/* (O) error_table_ code. */
         arg_com_err_sw	  bit (1),		/* (I) I/O module comerr switch. */
         arg_options	  (*) char (*) varying,	/* (I) Array of input options. */
         arg_dev_name	  char (32) varying,	/* (O) Requested -device name. */
         arg_tmdb_ptr	  ptr;			/* (I) Pointer to tape_mult_ data block. */


/*		AUTOMATIC  DATA		*/

dcl      attach_description	  char (64) varying,	/* Used to build attach description. */
         com_err_sw		  bit (1) aligned,
         error_code		  fixed bin (35),		/* error_table_ code. */
         keyx		  fixed bin,		/* Index to option key arrays. */
         num_options	  fixed bin,		/* Number of attach options. */
         option		  char (32) varying,	/* A single option string. */
         optx		  fixed bin,		/* Index to options array. */
         pic99		  pic "99",		/* tape device number */
         value		  char (32) varying;	/* A single option value string. */


/*		INTERNAL STATIC DATA	*/

dcl      short_keys		  (9) char (4) internal static/* Table of short option key names. */
			  init ("-wrt", "-den", "-tk ", "-com", "-sys", "-vsn", "-et ", "-ips", "-dv");

dcl      long_keys		  (9) char (16) internal static
						/* Table of long  option key names. */
			  init ("-write", "-density", "-track", "-comment", "-system", "-volume_set_name",
			  "-error_tally", "-speed", "-device");

dcl      value_flags	  (9) bit (1) internal static /* ON => option has accompanying value . */
			  init ("0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b);


/*		EXTERNAL ENTRIES CALLED	*/

dcl      (after, decimal, hbound, index, length, ltrim, null, string, substr, verify)
			  builtin;

dcl      (
         error_table_$bad_arg,
         error_table_$inconsistent,
         error_table_$noarg,
         error_table_$wrong_no_of_args
         )		  fixed bin (35) external;

dcl      com_err_		  entry options (variable);
dcl      canon_for_volume_label_
			  entry (char (*), char (*), char (*), fixed bin, fixed bin (35));
dcl      get_group_id_	  entry () returns (char (32)),
         get_ring_		  entry returns (fixed bin);

%include tmdb;
%page;
%include mstr;
%page;
%include rcp_volume_formats;
%page;
%include rcp_resource_types;

	tmdb_ptr = arg_tmdb_ptr;			/* Copy argument. */
	com_err_sw = arg_com_err_sw;

	error_code = 0;

	attach_description = "tape_mult_";		/* Initialize option values. */
	arg_dev_name = "";
	string (tmdb.opt.flags) = "0"b;		/* Defaults are all FALSE. */
	tmdb.opt.flags.com_err = com_err_sw;
	tmdb.opt.mount_mode = "reading";		/* Default is reading. */
	tmdb.opt.tracks = 9;			/* Default is 9 track tape drive. */
	tmdb.opt.density = 0;			/* Default depends upon track type. */
	tmdb.opt.speed = ""b;
	tmdb.opt.comment = " ";
	tmdb.opt.volume_set_id = "";			/* default is no volume set name */
	tmdb.opt.tbpp = null;			/* Use internal boot pgm by default */
	tmdb.opt.blp = null;			/* set boot label ptr to null, initially */

	num_options = hbound (arg_options, 1);		/* Get number of options. */
	if num_options < 1				/* There must be at least a reel name. */
	then do;					/* No options. */
	     error_code = error_table_$noarg;
	     goto RETURN;
	end;

	option = arg_options (1);			/* Copy reel name argument. */
	if (length (option) < 1) | /* Is it a valid reel name length? */ (length (option) > 32) then do;
						/* No, reject option. */
	     error_code = error_table_$bad_arg;
	     goto RETURN;
	end;

	if (get_group_id_ () = "Initializer.SysDaemon.z") & (get_ring_ () = 1) then do;
	     call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), (option), tmdb.opt.reel_name,
		Volume_multics_tape, error_code);
	     if error_code ^= 0 then
		goto RETURN;
	end;
	else tmdb.opt.reel_name = option;

	attach_description = attach_description || " " || option;

	do optx = 2 to num_options;			/* Now look for all other options. */
	     option = arg_options (optx);		/* Copy next option string */
	     if length (option) < 5			/* Look for long or short key? */
	     then do;				/* Look through list of short keys. */
		do keyx = 1 to hbound (short_keys, 1);
		     if short_keys (keyx) = option then
			goto FOUND_OPTION_KEY;
		end;
	     end;
	     else do;				/* Look through list of long keys. */
		do keyx = 1 to hbound (long_keys, 1);
		     if long_keys (keyx) = option then
			goto FOUND_OPTION_KEY;
		end;
	     end;
	     error_code = error_table_$bad_arg;		/* No key matched. */
	     if tmdb.opt.flags.com_err then
		call com_err_ (0, "tape_mult_", "Unknown attach option ^a", option);
	     goto RETURN;

FOUND_OPTION_KEY:					/* We found the key that matched. */
	     call PROCESS_OPTION;			/* Now go process this option. */
	     if error_code ^= 0			/* Check for option errors. */
		then
		goto RETURN;
	end;					/* All options OK, return attach description. */
	tmdb.attach.length = length (attach_description);
	tmdb.attach.description = attach_description;

	if tmdb.opt.tracks = 9 then			/* Is this a 9 track tape? */
	     if tmdb.opt.density = 0 then		/* Yes, default density is 1600 bpi */
		tmdb.opt.density = 1600;
	     else ;
	else if tmdb.opt.density = 0 then		/* No, 7 track. Was density specified? */
	     tmdb.opt.density = 800;			/* No, set 7 track default density to 800 bpi */
	else if tmdb.opt.density ^= 800 then		/* if density was specified, it must be 800 bpi */
	     error_code = error_table_$inconsistent;

RETURN:
	arg_error_code = error_code;
	return;

PROCESS_OPTION:
     procedure;

/*	This procedure is called to process the current option.  We
   *	know its option key index.  We will use this to goto a routine
   *	that knows how to process this option.  We will add this option
   *	string to the attach description.  If this option has an accompanying
   *	value then we will add the value string to the attach description.
   *	We will skip over this value argument in the option array.
*/
	attach_description = attach_description || " " || option;

	if value_flags (keyx)			/* Does this option have a value? */
	then do;					/* Yes, process value string. */
	     optx = optx + 1;			/* Skip to value argument in array. */
	     if optx > num_options			/* Make sure a value argument was given. */
		then
		goto UNBALANCED_OPTION;
	     value = arg_options (optx);		/* Pick up value string. */
	     attach_description = attach_description || " " || value;
	end;

	goto OPTION (keyx);				/* GOTO based on key index. */

OPTION (1):					/* "-wrt" or "-write" */
	tmdb.opt.flags.ring, tmdb.opt.flags.write_sw = "1"b;
						/* Turn ON write ring flag and switch. */

	tmdb.opt.mount_mode = "writing";		/* Set mount mode field. */
	return;

OPTION (2):					/* "-den" or "-density" */
	if value = "1600"				/* Is it a legal density value? */
	then do;					/* Yes, 1600 BPI is legal. */
	     tmdb.opt.density = 1600;
	     return;
	end;
	if value = "800"				/* 800 BPI is legal too. */
	then do;
	     tmdb.opt.density = 800;
	     return;
	end;
	if value = "6250" then do;			/* 6250 bpi is legal too. */
	     tmdb.opt.density = 6250;
	     return;
	end;
	goto ILLEGAL_VALUE;				/* Illegal density option value. */

OPTION (3):					/* "-tk" or "-track" */
	if value = "9"				/* 9 track is valid. */
	then do;
	     tmdb.opt.tracks = 9;
	     return;
	end;
	if value = "7"				/* 7 track is valid. */
	then do;
	     tmdb.opt.tracks = 7;
	     return;
	end;
	goto ILLEGAL_VALUE;

OPTION (4):					/* "-com" or "-comment" */
	optx = optx + 1;				/* Value_flag for comment key is OFF. */
	if optx > num_options			/* Check for comment value. */
	     then
	     goto UNBALANCED_OPTION;
	tmdb.opt.comment = arg_options (optx);		/* Copy comment arg.  Not put in att desc. */
	return;

OPTION (5):					/* "-sys" or "-system" */
	tmdb.opt.flags.system = "1"b;
	return;

OPTION (6):
	tmdb.opt.volume_set_id = value;		/* "-vsn" or "-volume_set_name" */
	return;

OPTION (7):
	tmdb.opt.flags.err_tal = "1"b;		/* "-et" or "-error_tally" */
	return;

OPTION (8):					/* "-ips" or "-speed" */
	begin;
dcl      COMMA		  char (1) init (",") static options (constant);
dcl      current_value	  char (32) varying;
dcl      current_idx	  fixed bin;		/* how far we've gotten into value */

	     current_idx = 1;			/* start from the beginning of the string */
	     current_value = get_next_value ();
	     if current_value = "" then
		goto ILLEGAL_VALUE;			/* insist on at least one */
	     do while (current_value ^= "");
		if current_value = "75" then
		     tmdb.opt.speed = tmdb.opt.speed | "100"b;
		else if current_value = "125" then
		     tmdb.opt.speed = tmdb.opt.speed | "010"b;
		else if current_value = "200" then
		     tmdb.opt.speed = tmdb.opt.speed | "001"b;
		else goto ILLEGAL_VALUE;
		current_value = get_next_value ();
	     end;					/* do while ... */
	     return;

get_next_value:
     proc returns (char (32) varying);

dcl      next_value		  char (32) varying;

	if current_idx = -1 then
	     return ("");
	if index (substr (value, current_idx), COMMA) = 0 then do;
	     next_value = substr (value, current_idx);
	     current_idx = -1;			/* so next call will stop */
	     return (next_value);
	end;
	else do;
	     next_value = substr (value, current_idx, index (substr (value, current_idx), COMMA) - 1);
	     current_idx = current_idx + length (next_value) + 1;
	     return (next_value);
	end;

     end get_next_value;

	end;					/* the begin */

OPTION (9):
	if length (value) < length ("tape1") then
	     go to ILLEGAL_VALUE;
	if index (value, "tap") ^= 1 then
	     go to ILLEGAL_VALUE;
	value = after (value, "tap");
	if verify (substr (value, 1, 1), "abcdefghijklmnopqurstuvwxyz") > 0 then
	     go to ILLEGAL_VALUE;
	arg_dev_name = "tap" || substr (value, 1, 1) || "_";
	value = ltrim (substr (value, 2), "_");
	if verify (value, "0123456789") > 0 then
	     go to ILLEGAL_VALUE;
	if length (value) > length ("99") then
	     go to ILLEGAL_VALUE;
	pic99 = decimal (value);
	arg_dev_name = arg_dev_name || pic99;
	return;


ILLEGAL_VALUE:					/* We don't know this value. */
	if substr (value, 1, 1) = "-"			/* Does this look like a key name? */
	     then
	     goto UNBALANCED_OPTION;			/* Yes, illegal because unbalanced. */
	error_code = error_table_$bad_arg;
	if tmdb.opt.flags.com_err then
	     call com_err_ (0, "tape_mult_", "Attachment option ^a is unknown.", option);
	return;

UNBALANCED_OPTION:
	error_code = error_table_$wrong_no_of_args;
	if tmdb.opt.flags.com_err then
	     call com_err_ (0, "tape_mult_", "Expected value with option ^a is missing.", option);

     end PROCESS_OPTION;


     end tape_mult_parse_;




		    tape_mult_read_.pl1             11/11/89  1105.7rew 11/11/89  0812.6      234801



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



/****^  HISTORY COMMENTS:
  1) change(74-10-06,Silver), approve(), audit(), install():
     Written by Bill Silver.
  2) change(77-09-01,Morris), approve(), audit(), install():
     Reading algorithm completely reworked.
  3) change(81-01-02,Bush), approve(), audit(), install():
     for bootable tape labels.
  4) change(81-08-12,Bush), approve(), audit(), install():
     Pre-Mr9.0 label compatibility.
  5) change(81-12-15,Bush), approve(), audit(), install():
     Rewrote read error recovery.
  6) change(82-08-01,SKrupp), approve(), audit(), install():
     changed from tdcm_ interface to tape_ioi_.
  7) change(83-03-01,Kittlitz), approve(), audit(), install():
     added 256K segment processing ability.
  8) change(83-09-01,SKrupp), approve(), audit(), install():
     to abort read retries on unrecoverable errors that return certain
     major statuses (such as POWER_OFF or DEVICE_ATTENTION etc.).
  9) change(84-09-01,CJones), approve(), audit(), install():
     to ignore consecutive EOFs and to recognize a record with a UID less
     than the label UID as EOI.
 10) change(85-03-11,Margulies), approve(), audit(), install():
     Get rid of useless "clean the tape" repositioning. Return
     error_table_$data_loss if we lose stream.
 11) change(85-05-17,Margulies), approve(), audit(), install():
     Remove misleading dead code on data_loss.
 12) change(86-02-13,GWMay), approve(86-02-13,MCR7337), audit(86-03-11,Farley),
     install(86-03-17,MR12.0-1030):
     Changed to allow no further reading after the eor mark is found.
     Restructured the routine VALIDATE_CHARS so that the end-of-reel (eor)
     mark is always diagnosed. The code is set up to diagnose other errors
     encountered in the read first and then return the
     error_table_$end_of_information code on the next read. If there are no
     other errors, the code is returned on the first pass.
 13) change(86-09-30,GWMay), approve(86-09-30,MCR7552),
     audit(86-10-13,Martinson), install(86-10-20,MR12.0-1189):
     rewritten to eliminate useless intermediate subroutines which have lost
     their functionality over the years. Modified the record evaluation
     conditions to match on the record number of the tape record only when
     determining data loss. Moved density determination process from
     tape_mult_labeler_ to this module.  Added back the repositioning code
     with some additional retry processes that will reduce data loss errors
     considerably and give tape_mult_ much better tape reading powers.
 14) change(86-10-22,GWMay), approve(86-10-22,PBF7552),
     audit(86-11-19,Martinson), install(86-11-21,MR12.0-1223):
     added to sets of tmdb.opt.flags.begin to set allow operations to know when
     we are at the beginnning of the tape and when we are into it. changed
     things around just a little bit to make the tape complete rewinds before
     setting the next density.  Also, removed the return on bad code from below
     the call to tape_ioi to set density because, if the tape drive does not
     support the particular density we are trying to set, then it will return
     when in fact there is special handling for bad density.  the problem which
     results is that we return and incorrect error message sometimes.
 15) change(87-03-30,GWMay), approve(87-03-30,MCR7643), audit(87-03-31,Farley),
     install(87-04-28,MR12.1-1028):
     changed to not reset the valid information flag when the retry loop is
     exhausted.
 16) change(87-07-07,GWMay), approve(87-07-17,MCR7747),
     audit(87-07-07,Beattie), install(87-07-17,MR12.1-1043):
     Changed to return immediately when records are out of sequence.
                                                   END HISTORY COMMENTS */

/* format: off */
%page;
tape_mult_read_: proc;

/* This program is part of the Multics standard tape I/O module, tape_mult_.*/
/* This program contains all of the read logic needed by tape_mult_.	      */
/* It implements the iox_$get_chars entry point.  It also contains an entry */
/* point for reading the label record.				      */

       dcl Piocb			ptr,
	 Ptmdb			ptr,
	 number_of_chars_requested	fixed bin (21),
	 code			fixed bin (35);

       dcl Lcallers_buffer		fixed bin (21),
	 Pcallers_buffer		ptr,
				/* never ever assign a value to     */
				/* this pointer.		      */
	 callers_buffer		char  (Lcallers_buffer)
				based (Pcallers_buffer);

       dcl Lcallers_buffer_insert	fixed bin (21),
	 Pcallers_buffer_insert	ptr,
	 callers_buffer_insert	char  (Lcallers_buffer_insert)
				based (Pcallers_buffer_insert);

       dcl Ldata_to_return		fixed bin,
	 Pdata_to_return		ptr,
	 data_to_return		char  (Ldata_to_return)
				based (Pdata_to_return);

       dcl Sentry_was_at_get_chars	bit (1) aligned,
	 Shave_a_label		bit (1) aligned,
	 Shave_next_record		bit (1) aligned,
	 Smissing_eor		bit (1) aligned,
	 Srecovery		bit (1) aligned,
	 Suser_defined_bootlabel	bit (1) aligned,
	 auto_retry_cnt		fixed bin,
	 channel_command		bit (6) aligned,
	 density_counter		fixed bin,
	 density_index		fixed bin,
	 density_index_adder	fixed bin,
	 number_of_chars_left_to_return
				fixed bin (21),
           read_cnt			fixed bin,
	 reads_past_error		fixed bin,
	 rewind_cnt		fixed bin,
	 test_checksum		bit (36) aligned;

/* constants */

       dcl DENSITY (0:2)		fixed bin 
				internal static options (constant)
				init (800, 1600, 6250),
           LABEL_LEN		fixed bin internal static
				options (constant) init (48),
           MAX_AUTO_RETRYS		fixed bin internal static
				options (constant) init (8),
           MAX_BK_RETRYS		fixed bin internal static
				options (constant) init (2),
           MAX_FWD_READS		fixed bin internal static
				options (constant) init (64),
           MAX_LABEL_READS		fixed bin internal static
				options (constant) init (8),
           MAX_READS_PAST_ERROR	fixed bin internal static
				options (constant) init (32),
           FIVE_FILES		fixed bin internal static
				options (constant) init (5),
           ONE_FILE			fixed bin internal static
				options (constant) init (1),
           TWO_FILES		fixed bin internal static
				options (constant) init (2);

/* builtins */

       dcl (addcharno, addr, bin, bit, currentsize, divide, hbound,
	  lbound, min, mod, null, string, substr, unspec)
				builtin;
	       
/* external static */

       dcl error_table_$bad_density	fixed bin (35) external static,
	 error_table_$bad_label	fixed bin (35) external static,
	 error_table_$data_improperly_terminated
				fixed bin (35) external static,
           error_table_$data_loss	fixed bin (35) external static,
	 error_table_$device_attention
				fixed bin (35) external static,
           error_table_$device_parity	fixed bin (35) external static,
	 error_table_$end_of_info	fixed bin (35) external static,
	 error_table_$improper_data_format
				fixed bin (35) external static,
           error_table_$invalid_read	fixed bin (35) external static,
	 error_table_$no_operation	fixed bin (35) external static,
	 error_table_$null_info_ptr	fixed bin (35) external static,
	 error_table_$tape_error	fixed bin (35) external static,
	 sys_info$seg_size_256K	fixed bin (19) external static;

/* external entries */

       dcl sub_err_			entry () options (variable),
	 tape_checksum_		ext entry (ptr, ptr);

%page;
/* ************************************************************************ */

get_chars: entry (Piocb,
	        Pcallers_buffer,
	        number_of_chars_requested,
	        Lcallers_buffer,
	        code);

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

       code = 0;
       Sentry_was_at_get_chars = "1"b;
       call get_number_of_chars_requested (Sentry_was_at_get_chars, code);
       return;
%page;
/* ************************************************************************ */

position: entry (Piocb,
	       arg_pos_type,
	       number_of_chars_requested,
	       code);

/* ************************************************************************ */
/*							      */
/* Although the position i/o operation is not supported externally, this    */
/* entry allows forward positioning.				      */
/*							      */
/* Usage: io switch_name position 3 {number of chars to position forward}   */
/*							      */
/* ************************************************************************ */

       dcl arg_pos_type		fixed bin;

       code = 0;

       if arg_pos_type ^= 3 then do;	/* Only type 3 supported */
	code = error_table_$no_operation;
	return;
	end;

       if number_of_chars_requested = 0 then
	return;

       Sentry_was_at_get_chars = "0"b;
       call get_number_of_chars_requested (Sentry_was_at_get_chars, code);
       return;
%page;
get_number_of_chars_requested: proc (Sentry_was_at_get_chars,
			       code);

       dcl Sentry_was_at_get_chars	bit(1) aligned,
	 code			fixed bin (35);	 

       if number_of_chars_requested < 0
	| number_of_chars_requested > sys_info$seg_size_256K * 4 then do;
	if Sentry_was_at_get_chars then
	   Lcallers_buffer = 0;
	code = error_table_$no_operation;
	return;
	end;

       tmdb_ptr = Piocb -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;

       if tmdb_ptr = null then do;
	code = error_table_$null_info_ptr;
	return;
	end;

       if tmdb.opt.write_sw then do;    /* can't write & read together     */
	code = error_table_$invalid_read;
	return;
	end;

       if tmdb.work.flags.eod then do;  /* at the logical end of the tape  */
	code = error_table_$end_of_info;
	return;
	end;

       tmdb.opt.flags.begin = "0"b;	/* no longer at beginning of tape  */
       channel_command = "30"b3;
       if Sentry_was_at_get_chars then
	Lcallers_buffer = 0;

       number_of_chars_left_to_return = number_of_chars_requested;
       mstrp = tmdb.work.curr_buf;

       /* The object of the following is to read the number of characters   */
       /* requested by the caller from the mounted tape volume.             */
       /* When the get_chars entrypoint is used the data is returned in work*/
       /* space supplied by the caller.  If the position entrypoint is used */
       /* the data is read from the tape, but not returned.		      */
       /* Note that the tape record may not be the same size as the number  */
       /* of characters the caller requests.  To handle this, the code reads*/
       /* tape records into and internal buffer, then moves the data as     */
       /* needed to the callers buffer.				      */

       do while (number_of_chars_left_to_return > 0);

	if tmdb.work.buf_pos >= tmdb.work.rec_length  then do;
	   string (tmdb.work.flags) = "0"b;
	   read_cnt = 0;
	   reads_past_error = 0;
	   tmdb.work.buf_pos = 0;
	   tmdb.trail.tot_rec = tmdb.trail.tot_rec + 1;
	   Shave_next_record = "0"b;
				/* have tape_ioi_ do error recovery */
	   Srecovery = "1"b;
	   auto_retry_cnt = 0;

	   call tape_ioi_$set_mode (tmdb.work.tioi_id, "recovery", 
	      addr(Srecovery), code);
	   if code ^= 0 then
	      return;

	   do while (^Shave_next_record
		   & read_cnt < MAX_FWD_READS
		   & auto_retry_cnt < MAX_AUTO_RETRYS
		   & reads_past_error < MAX_READS_PAST_ERROR
		   & ^tmdb.work.flags.eod);

	      Smissing_eor = "1"b;
	      tmdb.work.flags.data_loss = "0"b;
	      tmdb.work.flags.eod = "0"b;
				/* read a new mstr and set mstrp    */
	      call READ_TAPE (code);

	      read_cnt = read_cnt + 1;
	      if tmdb.work.flags.fatal_read_error then
	         reads_past_error = reads_past_error + 1;

	      if code = 0 then do;
	         tmdb.work.curr_buf = mstrp;

	         call VALIDATE_RECORD (code);
	         if code = 0 then do;

		  Smissing_eor = "0"b;

		  /* although the record is good, it may be out of order*/
		  /* this is a data loss condition if the record number */
		  /* is greater than the number we are attempting to    */
		  /* read. For this we will back the tape up and try a  */
		  /* new set of tape hardware settings and try to read  */
		  /* the missing record.			      */
                      /* This section will allow any end-of-reel record     */
		  /* to be recognized.  It does not matter if it is from*/
		  /* a previous write, we will still use it to set eot  */
                      /* then report the bad uid.			      */

		  if mstr.trail.tot_rec < tmdb.trail.tot_rec then
		     read_cnt = 0;

		  else do;

		     if mstr.trail.tot_rec > tmdb.trail.tot_rec then
		        tmdb.work.flags.data_loss = "1"b;
		     else		/* otherwise it is equal & is the 1 */
				/* we want.		      */
		        Shave_next_record = "1"b;
		     end;

		  if mstr.head.admin & mstr.head.eor then
		     tmdb.work.flags.eod = "1"b;

		  if mstr.head.uid < tmdb.work.label_uid then do;
		     tmdb.work.flags.eod = "1"b;
		     Smissing_eor = "1"b;
		     tmdb.work.flags.data_loss = "1"b;
		     end;
		  else
		     if tmdb.work.flags.data_loss then do;
		        call set_next_auto_retry_possibility (auto_retry_cnt,
			 code);
		        if code ^= 0 then
			 return;
		        if auto_retry_cnt < MAX_AUTO_RETRYS then do;
			 read_cnt = 0;
			 reads_past_error = 0;
			 tmdb.work.flags.eod = "0"b;
			 end;
		        end;
		  end;
	         end;
	      else
	         if tmdb.work.flags.fatal_read_error then		
	            reads_past_error = reads_past_error + 1;
	      end;
	   
	   if reads_past_error >= MAX_READS_PAST_ERROR then
	      code = error_table_$device_attention;

	   if ^tmdb.work.flags.data_loss then do;
	      if read_cnt < MAX_FWD_READS then;
	      else
	         
	         code = error_table_$tape_error;

	      if code ^= 0 then
	         return;
	      end;

	   if tmdb.work.flags.eod then do;
	      if Smissing_eor then
	         code = error_table_$data_improperly_terminated;
	      else
	         code = error_table_$end_of_info;
	      return;
	      end;

	   tmdb.work.rec_length = divide(mstr.head.data_bits_used, 9, 17);

	   /* if data loss, return what we have in the buffer and then    */
	   /* start on the tape record next time through.		      */

	   if tmdb.work.flags.data_loss then do;
	      code = error_table_$data_loss;
	      tmdb.trail.tot_rec = mstr.trail.tot_rec;
	      if Sentry_was_at_get_chars then
	         if Lcallers_buffer > 0 then
	            return;
	      end;
	   end;

	Pdata_to_return = addcharno (addr(mstr.data), tmdb.work.buf_pos);
         	Ldata_to_return = min ((tmdb.work.rec_length - tmdb.work.buf_pos), number_of_chars_left_to_return);

	if Sentry_was_at_get_chars then do;
	   Pcallers_buffer_insert =
	      addcharno (Pcallers_buffer, Lcallers_buffer);
	   Lcallers_buffer_insert = Ldata_to_return;
             callers_buffer_insert = data_to_return;
	   Lcallers_buffer = Lcallers_buffer + Ldata_to_return;
	   end;

	number_of_chars_left_to_return =
	   number_of_chars_left_to_return - Ldata_to_return;

	tmdb.work.buf_pos = tmdb.work.buf_pos + Ldata_to_return;
          end;
       return;
%page;
set_next_auto_retry_possibility: proc (auto_retry_cnt, code);

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

       dcl completed_bsfs		fixed bin,
	 completed_fsfs		fixed bin,
	 requested_bsfs		fixed bin,
	 rx			fixed bin;

/* This routine supplies special code that will tell the tape hardware to   */
/* use a new set of settings when reading the tape.  This way if a record   */
/* was lost in a previous read attempt, it may be readable after setting    */
/* the tape device to new tolerances.				      */
/* The tape drives currently allow seven various settings.		      */

       if channel_command = "37"b3 then do;
	auto_retry_cnt = MAX_AUTO_RETRYS;
	return;
	end;
       else do;
	auto_retry_cnt = auto_retry_cnt + 1;
	channel_command = bit( bin( bin (channel_command) + 1, 6), 6);
	end;

       call tape_ioi_$stop_tape (tmdb.work.tioi_id, (0), rx, code);
       if rx ^= 0 then do;
	if code = 0 then
	   code = error_table_$device_parity;
	return;
	end;

       completed_bsfs = 0;
       if tmdb.work.flags.eod then
	requested_bsfs = FIVE_FILES;
       else
	requested_bsfs = TWO_FILES;

       do while (requested_bsfs > 0);
	call tape_ioi_$order (tmdb.work.tioi_id, "bsf", requested_bsfs,
	   null, completed_bsfs, rx, code);
	if rx = 0 then do;
	   requested_bsfs = requested_bsfs - completed_bsfs;
	   code = 0;
	   end;
	else
	   if rx = TAPE_IO_BOT then do;
	      rx = 0;
	      requested_bsfs = 0;
	      code = 0;
	      end;

	if code ^= 0 then
	   return;
	end;

       completed_fsfs = 0;
       do while (completed_fsfs < 1);
	call tape_ioi_$order (tmdb.work.tioi_id, "fsf", ONE_FILE, null,
	   completed_fsfs, rx, code);
	if code ^= 0 then
	   return;
	end;

				/* turn off tape_ioi_ error retry   */
       if auto_retry_cnt = 1 then do;
	Srecovery = "0"b;
	call tape_ioi_$set_mode (tmdb.work.tioi_id, "recovery", 
	   addr(Srecovery), code);
	if code ^= 0 then
	   return;
	end;
				/* and control it from here	      */
       call tape_ioi_$set_mode (tmdb.work.tioi_id, "cif",
	addr (channel_command), code);
       return;
       end set_next_auto_retry_possibility;
       end get_number_of_chars_requested;
%page;
/* ************************************************************************ */

label: entry (Ptmdb,
	    Pcallers_buffer,
	    Lcallers_buffer,
	    code);

/* ************************************************************************ */
/* caller: tape_mult_labeler_.		                          */
/*							      */
/* This routine will attempt to read and interpret a standard Multics	tape  */
/* label.							      */
/*							      */
/* 1) The first action is an attempt to read the tape at either the density */
/* determined when the tape was mounted by rcp_, or  if the installation    */
/* parameter that controls tape authentication is turned off, the density   */
/* supplied by the -density control argument is used.  There is a default   */
/* density of 1600 that will be used if either of the first two are not     */
/* available for use.					      */
/*							      */
/* 2) The density value "loop" is used to facilitate the following sequences*/
/* of density read trys.  The starting density (see 1) is looked up in the  */
/* DENSITY array.  Once done, a counter is established so that the densities*/
/* will be tried in the order:				      */
/*         starting density   next   next			      */
/*               800          1600   6250			      */
/*	       1600	6250    800			      */
/*	       6250	1600    800			      */
/*							      */
/* 3) After setting the density, a read is attempted.		      */
/*    If the read is successful and the record is good,		      */
/*       then we read again looking for an EOF			      */
/*       If the next read is another good label,			      */
/*          we will accept it as the label.			      */
/*							      */
/* 4) Any other conditions will cause a rewind and reread.		      */
/*							      */
/* Note:	The code will read forward 8 times looking for a label when the   */
/*        correct density is established.  It will attempt to do this 2     */
/*	times before returning an error.  When the density fails on the   */
/*	read, we will set to the next density without retrying the read.  */
/*							      */
/* ************************************************************************ */
%page;

       code = 0;

       if Ptmdb = null then do;
	code = error_table_$null_info_ptr;
	return;
	end;

       tmdb_ptr = Ptmdb;
       Lcallers_buffer = 0;
       Ldata_to_return = 0;
       Pdata_to_return = null;
       Shave_a_label = "0"b;
       string (tmdb.work.flags) = "0"b;

       do density_index = lbound (DENSITY, 1) to hbound (DENSITY, 1)
	while (tmdb.volume_density ^= DENSITY (density_index));
	end;
			
       if density_index = hbound(DENSITY, 1) then
	density_index_adder = -1;	/* process densities in descending order */
       else
	density_index_adder = 1;	/* process densities in ascending order */

       do density_counter = lbound (DENSITY, 1) to hbound (DENSITY, 1)
	while ((code = 0 | code = error_table_$bad_density)
	      & ^Shave_a_label
	      & ^tmdb.work.flags.eof);

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

	call tape_ioi_$order (tmdb.work.tioi_id, "den", 1, 
	   addr (DENSITY(density_index)), (0), (0), code);

	read_cnt = MAX_LABEL_READS;
	rewind_cnt = -1;

	do while (^tmdb.work.flags.eof & code = 0);
	   Suser_defined_bootlabel = "0"b;
	   Shave_next_record = "0"b;

	   do while (^Shave_next_record
		  & ^tmdb.work.flags.eof
		  & read_cnt <= MAX_LABEL_READS
		  & rewind_cnt <= MAX_BK_RETRYS
		  & code ^= error_table_$bad_density);

	      read_cnt = read_cnt + 1;
	      if read_cnt > MAX_LABEL_READS then
	         call REWIND (read_cnt, rewind_cnt, code);
	      if code ^= 0 then
	         return;

	      call READ_TAPE (code);
	      if code = 0 then do;
	         call VALIDATE_RECORD (code);
	         if code = 0 then
		  Shave_next_record = "1"b;
	         end;
	      end;

	   if code = 0 & ^tmdb.work.flags.eof then do;
	      Shave_a_label = "1"b;

	      if Suser_defined_bootlabel then do;
	         Pdata_to_return = mstrp;
	         Ldata_to_return = currentsize (mst_label) * 4;
	         tmdb.head = mst_label.head;
	         tmdb.trail = mst_label.trail;
	         tmdb.head.data_bit_len = tmdb.head.data_bit_len + ((hbound (mst_label.xfer_vector, 1) * 2) * 36);
	         tmdb.work.label_version = mst_label.label_version;
	         tmdb.work.output_mode = mst_label.output_mode;
	         end;

	      else do;
	         Pdata_to_return = addr (mstr.data);
	         Ldata_to_return = divide (mstr.head.data_bits_used, 9, 17, 0);
	         if Ldata_to_return = 0 then do;
		  if mstr.head.flags.label then
		     Ldata_to_return = LABEL_LEN;
		  else do;
		     code = error_table_$improper_data_format;
		     return;
		     end;
		  end;

	         tmdb.head = mstr.head;
	         tmdb.trail = mstr.trail;
	         if unspec(substr(Pdata_to_return -> volume_identifier.volume_set_id, 1, 1)) ^= "777"b3 then
		  tmdb.work.label_version = 2;
	         end;
	      end;
	   end;
				/* get the next density to try      */
	density_index = mod (density_index + density_index_adder,
	   hbound(DENSITY,1) + 1);
	end;

       if rewind_cnt > MAX_BK_RETRYS | (code ^= 0) then do;
	code = error_table_$bad_label;
	return;
	end;

       Lcallers_buffer = Ldata_to_return;
       callers_buffer = data_to_return;
       tmdb.opt.flags.begin = "1"b;	/* set beginning og tape switch     */
       return;
%page;
READ_TAPE: proc (code);


       dcl code			fixed bin (35);

       dcl data_len			fixed bin (21),
	 rx			fixed bin;

       code = 0;
       call tape_ioi_$read (tmdb.work.tioi_id, mstrp, data_len, rx, code);   

       if rx = 0 then
	code = 0;
       else
	if rx = TAPE_IO_EOF then do;
	   tmdb.work.flags.eof = "1"b;
	   code = 0;
	   end;
       else
	if rx = TAPE_IO_UNRECOVERABLE_IO_ERROR then
	   tmdb.work.flags.fatal_read_error = "1"b;
       else
	if rx = TAPE_IO_EOT then do;
	   tmdb.work.flags.eod = "1"b;
	   if code = 0 then
	      code = error_table_$end_of_info;
	   end;
       else
	if rx = TAPE_IO_BOT then
	   tmdb.work.flags.bot = "1"b;
       else do;
	call sub_err_ (0, "tape_mult_read_", ACTION_DEFAULT_RESTART,
	   null (), (0), "Unexpected tape_ioi_ result ^d on read.", rx);
	code = error_table_$device_parity;
	end;

       return;

     end READ_TAPE;
%page;
REWIND: proc (read_cnt,
	    rewind_cnt,
	    code);

       dcl read_cnt			fixed bin,
	 rewind_cnt		fixed bin,
	 code			fixed bin (35);

       dcl rdy_status		bit (36) aligned;

       code = 0;

       call tape_ioi_$order (tioi_id, "rdy", 1, addr (rdy_status), (0), (0),
	code);
				/* Wait for device to be ready. */
       if code = 0 then do;		/* Rewind the tape */
	call tape_ioi_$order (tioi_id, "rew", 1, (null), (0), (0), 
	   code);

	if code = 0 then do;
	   call tape_ioi_$order (tioi_id, "rdy", 1, addr (rdy_status), (0),
	      (0), code);
	   rewind_cnt = rewind_cnt + 1;
	   read_cnt = 0;
	   end;
	end;

       return;
       end REWIND;
%page;
VALIDATE_RECORD: proc (code);

/* This internal procedure is called to validate a record.  The record has  */
/* been read successfully. We want to be sure that the header and trailer   */
/* data is valid.						      */

dcl	code		   fixed bin (35);

       code = 0;

       /* Invalid header or bootable tape label. */

       if (mstr.head.c1 ^= tmdb.head.c1)
	| (mstr.head.c2 ^= tmdb.head.c2) then do;

	if mstr.head.c1 = label_c1 then do;

				/* is this a bootable label record? */
	   if (mst_label.head.c1 = tmdb.head.c1)
	      & (mst_label.head.c2 = tmdb.head.c2)
	      & (mst_label.trail.c1 = tmdb.trail.c1)
	      & (mst_label.trail.c2 = tmdb.trail.c2)
	      & mst_label.head.label then do;

	      
	      Suser_defined_bootlabel = "1"b;
	      call tape_checksum_ (addr (mst_label.head), addr (test_checksum));

	      if mst_label.head.checksum ^= test_checksum then
	         code = error_table_$device_parity;

	      return;
	      end;
	   end;

	code = error_table_$device_parity;
	return;
	end;

				/* Invalid trailer */
       if (mstr.trail.c1 ^= tmdb.trail.c1)
	| (mstr.trail.c2 ^= tmdb.trail.c2) then do;
	code = error_table_$device_parity;
	return;
	end;

       call tape_checksum_ (mstrp, addr (test_checksum));

       if mstr.head.checksum ^= test_checksum then
	code = error_table_$device_parity;

       return;

     end VALIDATE_RECORD;
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include tape_ioi_result_indexes;
%page;
%include tape_ioi_dcls;
%page;
%include iocb;
%page;
%include sub_err_flags;
     end tape_mult_read_;




		    tape_mult_util_.pl1             11/11/89  1105.7r w 11/11/89  0807.4      148626



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


/* format: style4,delnl,insnl,ifthen */
tape_mult_util_:
     procedure;

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *
   *	Created on 10/28/74 by Bill Silver.
   *	Modified 4/79 by R.J.C. Kissel to handle 6250 bpi.
   *	Modified 7/81 by J. A. Bush to add the boot_program control order.
   *	Modified 8/81 by J. A. Bush to add get_boot_program control order.
   *      Modified 8/82 by S. Krupp for change from tdcm_ to tape_ioi_ interface.
   *      Modified 1985-03-18, BIM: added get_buffer_size for async support.
   *      Modified 1985-03-28, BIM: return device_end, not end_of_into, on EOT on write.
   *
   *	This program also contains a set of unrelated utility entries
   *	that are used by tape_mult_ itself.  A complete list of the entries
   *	contained in this program is given below:
   *
   *	control:		- implements the tape_mult_ control order call.
*/


/*		ARGUMENTS			*/

dcl  arg_error_code fixed bin (35),			/* (O) Standard system error code. */
     arg_info_ptr ptr,				/* (I) Pointer to control order return data. */
     arg_iocb_ptr ptr,				/* (I) Pointer to I/O control block. */
     arg_order_name char (*),				/* (I) Control order name. */
     arg_rx fixed bin,
     arg_tioi_id bit (36) aligned;			/* (I) Ids tape_ioi activation. */

/*		AUTOMATIC  DATA		*/

dcl  error_code fixed bin (35),			/* Standard system error code. */
     info_ptr ptr,					/* Pointer to control order return data. */
     iocb_ptr ptr,					/* Pointer to I/O control block. */
     segp ptr,					/* Temp ptr for initiate_count */
     bc fixed bin (24),				/* storage for bit count from initiate_count */
     (boot_path, boot_dir) char (168),			/* storage for boot program directory name */
     boot_entry char (32),				/* storage for boot program entry name */
     bd_len fixed bin,				/* length of boot_dir */
     rl fixed bin,					/* temporary  length storage */
     order_name char (16),				/* Control order name. */
     error_count fixed bin (35),			/* storage for error_count control order */
     tioi_id bit (36) aligned;			/* Id for tape_ioi_ activation. */

dcl  1 auto_error_tally aligned like tec;



/*		BASED  DATA		*/

dcl  based_error_count fixed bin based;			/* Returned by "error_count" control order. */
dcl  1 oi like object_info aligned;
dcl  1 bpi like boot_program_info based (info_ptr) aligned;
dcl  based_seg (bpi.boot_program_text_length) bit (36) based aligned;

/*		EXTERNAL ENTRIES		*/

dcl  (addr, before, bin, currentsize, divide, hbound, null, ptr, rel, reverse, rtrim, size, substr) builtin;

dcl  (
     error_table_$bigarg,
     error_table_$device_not_active,
     error_table_$device_parity,
     error_table_$device_end,
     error_table_$no_operation,
     error_table_$not_closed,
     error_table_$not_open,
     error_table_$wrong_no_of_args
     ) external fixed bin (35);
declare  error_table_$null_info_ptr fixed bin (35) ext static;


dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35)),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
     hcs_$terminate_noname entry (ptr, fixed bin (35)),
     object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)),
     tape_mult_write_$flush entry (ptr, fixed bin (35));	/*						*/
%include iocb;
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include iom_stat;
%page;
%include tape_mult_boot_info;
%page;
%include object_info;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_error_counts;
%page;
%include tape_ioi_result_indexes;
%page;

control:
     entry (arg_iocb_ptr, arg_order_name, arg_info_ptr, arg_error_code);

/*	This entry implements the tape_mult_ order call.  the following
   *	order calls are currently supported:
   *
   *	error_count:	If the tape is opened for reading, an error is
   *			returned.  If the tape is opened for writing then all
   *			output data currently buffered will be written and the
   *			up-to-date error count will be returned.
   *
   *
   *	boot_program:	Copies a user specified boot program into
   *			a temporary segment for subsequent writing
   *			onto the tape label record.  The I/O switch
   *			must be closed when this control order is
   *			issued.  info_ptr  should  point  to   a
   *			structure       as       defined      by
   *			tape_mult_boot_info.incl.pl1.
   *
   *	get_boot_program:	Returns  information  as to the location, length
   *			and  entry  name of the tape label boot program,
   *			as  read  from the tape which must be opened for
   *			input.   This  control  order  must  be executed
   *			after  a tape is opened for input and before the
   *			first     read     is    performed,    otherwise
   *			error_table_$no_operation  is  returned  to  the
   *			user.  If the tape does not contain a boot label
   *			program,  then the location ptr is returned as a
   *			null pointer and the length is returned as 0.
   *
   *      get_buffer_size:    Returns the amount of data that can be held
   *			unwritten in asynchronous output.
   *
   *	io_call:		perform an order on behalf of the io_call command.
*/
	iocb_ptr = arg_iocb_ptr;			/* Copy arguments. */
	order_name = arg_order_name;
	arg_error_code = 0;
	info_ptr = arg_info_ptr;

	iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;	/* Initialize pointers. */
	tmdb_ptr = iocb_ptr -> iocb.attach_data_ptr;
	tioi_id = tmdb.tioi_id;

	if order_name = "get_buffer_size"		/* how much stuff? */
	then do;
	     if arg_info_ptr = null () then do;
		arg_error_code = error_table_$null_info_ptr;
		return;
	     end;
	     begin;
declare  buffer_size fixed bin (35) based (arg_info_ptr);
		buffer_size = tmdb.n_bufs * 1024 * 4;	/* Characters */
		return;
	     end;
	end;

	if order_name = "io_call" then
	     call control_io_call;			/* Special subroutine for this one */

	else if order_name = "error_count" then
	     if iocb_ptr -> iocb.open_descrip_ptr ^= null then do;
						/* switch must be open */

		error_count = 0;			/* Set default error count. */

		if tmdb.open.description ^= "stream_output" then do;
						/* Error count order valid only if writing. */
		     error_code = error_table_$no_operation;
		     goto return_error_count;
		end;

		call tape_mult_write_$flush (tmdb_ptr, error_code);
						/* Write all buffered output. */
		if error_code ^= 0 then
		     goto return_error_count;
		call wait_for_write_proc (tioi_id, (0), error_code);
		if error_code ^= 0 then
		     goto return_error_count;

		auto_error_tally.version = TEC_VERSION_1;
		call tape_ioi_$get_statistics (tioi_id, addr (auto_error_tally), error_code);
		if error_code ^= 0 then
		     go to return_error_count;

		error_count = auto_error_tally.writes.errors;

		if tmdb.head.flags.eot then		/* If at End of Tape tell caller. */
		     error_code = error_table_$device_end;

return_error_count:
		info_ptr -> based_error_count = error_count;
	     end;
	     else do;				/* I/O switch not open, complain */
		info_ptr -> based_error_count = 0;
		error_code = error_table_$not_open;
	     end;
	else if order_name = "boot_program" then	/* if user wants to write boot label */
	     if iocb_ptr -> iocb.open_descrip_ptr = null then do;
						/* switch must be closed */
		call get_temp_segment_ ("tape_mult_", mstrp, error_code);
		if error_code ^= 0 then		/* if no problem continue */
		     go to ret_err;
		mst_label.boot_pgm_len = bpi.boot_program_text_length;
						/* copy text length */
		if currentsize (mst_label) > size (mstr) then do;
						/* if boot pgm too big, complain */
		     error_code = error_table_$bigarg;
		     go to ret_err;
		end;

		mst_label.boot_pgm = bpi.boot_program_ptr -> based_seg;
						/* copy boot pgm text */
		call hcs_$fs_get_path_name (bpi.boot_program_ptr, boot_dir, bd_len, boot_entry, error_code);
		if error_code = 0 then do;		/*  only put  path in if  we get it */
		     if bpi.boot_program_name = "" then /* Use entry name from hcs_$fs_get_path_name? */
			mst_label.boot_pgm_path = substr (boot_dir, 1, bd_len) || ">" || boot_entry;
		     else mst_label.boot_pgm_path = substr (boot_dir, 1, bd_len) || ">" || bpi.boot_program_name;
		end;
		else if bpi.boot_program_name ^= "" then/* use boot_program_name on error if not blank */
		     mst_label.boot_pgm_path = bpi.boot_program_name;
		else mst_label.boot_pgm_path = "";

		tmdb.opt.tbpp = mstrp;		/* save temp seg ptr for tape_mult_open_ */
	     end;
	     else error_code = error_table_$not_closed;	/* I/O switch must be closed, complain */
	else if order_name = "get_boot_program" then	/* if user wants to get boot label from tape */
	     if iocb_ptr -> iocb.open_descrip_ptr ^= null then do;
						/* switch must be open */
		arg_error_code = 0;
		if tmdb.open.description ^= "stream_input" | ^tmdb.opt.flags.begin then do;
						/* must be open for input, before first data read is done */
		     error_code = error_table_$no_operation;
						/* not legal */
		     go to ret_err;
		end;
		if tmdb.work.label_version < 3 | tmdb.blp = null then do;
						/* not bootable label or label not there */
		     bpi.boot_program_ptr = null;	/* return null ptr */
		     bpi.boot_program_text_length = 0;	/* and zero length */
		     bpi.boot_program_name = "";	/* and null name */
		     return;			/* and return */
		end;

/* We now know that we have a valid boot label in buffer */

		mstrp = tmdb.blp;			/* set tape label ptr */
		bpi.boot_program_ptr = addr (mst_label.boot_pgm);
						/* return boot pgm ptr to user */
		bpi.boot_program_name = rtrim (reverse (before (reverse (mst_label.boot_pgm_path), ">")));
		rl = divide (mst_label.head.data_bits_used, 36, 17, 0) + hbound (mst_label.xfer_vector, 1) * 2
		     + size (mstr_header);		/* compute real record length */
		bpi.boot_program_text_length = rl - bin (rel (addr (ptr (mstrp, 0) -> mst_label.boot_pgm)), 18);
						/* compute length of boot pgm */
		return;				/* and return */
	     end;
	     else error_code = error_table_$not_open;
	else error_code = error_table_$no_operation;	/* Not recognized */
ret_err:
	arg_error_code = error_code;
	return;

/* Procedure to perform the io_call order on behalf of the io_call command. */

control_io_call:
     proc;

dcl  error_count fixed bin (35);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));

%include io_call_info;

	io_call_infop = info_ptr;

	if io_call_info.order_name = "error_count" then do;
	     error_code, error_count = 0;
	     if io_call_info.nargs ^= 0 then do;	/* no args allowed */
		call io_call_info
		     .
		     error (error_table_$wrong_no_of_args, io_call_info.caller_name,
		     "No additional arguments allowed for the ""error_count"" control order");
		return;
	     end;
	     call iox_$control (iocb_ptr, "error_count", addr (error_count), error_code);
	     if error_code ^= 0 then do;
		call io_call_info.error (error_code, io_call_info.caller_name, "Error count = ^d.", error_count);
		error_code = 0;
	     end;
	     else call io_call_info.report ("^a: Error count = ^d.", io_call_info.caller_name, error_count);
	end;

	if io_call_info.order_name = "get_buffer_size" then do;
	     if io_call_info.nargs ^= 0 then do;	/* no args allowed */
		call io_call_info
		     .
		     error (error_table_$wrong_no_of_args, io_call_info.caller_name,
		     "No additional arguments allowed for the ""get_buffer_size"" control order");
		return;
	     end;
	     call iox_$control (iocb_ptr, "get_buffer_size", addr (error_count), error_code);
	     if error_code ^= 0 then do;
		arg_error_code = error_code;
		return;
	     end;
	     else call io_call_info.report ("^a: Buffer size: ^d chars.", io_call_info.caller_name, error_count);
	end;


	else if io_call_info.order_name = "boot_program" then do;
						/* user wants to write a boot label */
	     error_code = 0;
	     if io_call_info.nargs ^= 1 then do;
		call io_call_info
		     .
		     error (error_table_$wrong_no_of_args, io_call_info.caller_name,
		     "The ""boot_program"" control order must have a path argument");
		return;
	     end;
	     boot_path = io_call_info.args (1);		/* pick up the boot pgm name */
	     call expand_pathname_ (boot_path, boot_dir, boot_entry, error_code);
	     if error_code ^= 0 then do;		/* can't find it */
		call io_call_info
		     .
		     error (error_code, io_call_info.caller_name,
		     "expanding pathname of ""boot_program"" argument (""^a"")", boot_path);
		return;
	     end;
	     call hcs_$initiate_count (boot_dir, boot_entry, "", bc, 0, segp, error_code);
	     if segp = null then do;			/* can't find it */
		call io_call_info
		     .
		     error (error_code, io_call_info.caller_name,
		     "getting bit count of ""boot_program"" argument (""^a"")", boot_path);
		error_code = 0;
		return;
	     end;
	     oi.version_number = object_info_version_2;	/* set proper version # */
	     call object_info_$brief (segp, bc, addr (oi), error_code);
	     if error_code ^= 0 then do;		/* can't find it */
		call io_call_info
		     .
		     error (error_code, io_call_info.caller_name,
		     "getting object info of ""boot_program"" argument (""^a"")", boot_path);
		error_code = 0;
		return;
	     end;
	     boot_program_info.version = BOOT_PROGRAM_INFO_VERSION_1;
						/* set version */
	     boot_program_info.boot_program_name = boot_entry;
	     boot_program_info.boot_program_ptr = oi.textp;
						/* copy ptr to text section */
	     boot_program_info.boot_program_text_length = oi.tlng;
						/* and length of text */
	     call iox_$control (iocb_ptr, "boot_program", addr (boot_program_info), error_code);
	     if error_code ^= 0 then do;		/* can't do it */
		call io_call_info
		     .error (error_code, io_call_info.caller_name, "executing the ""boot_program"" control order");
		error_code = 0;
	     end;
	     call hcs_$terminate_noname (segp, (0));	/* terminate the boot program */

	end;
	else if io_call_info.order_name = "get_boot_program" then do;
						/* user wants to write a boot label */
	     error_code = 0;

	     boot_program_info.version = BOOT_PROGRAM_INFO_VERSION_1;
						/* set version */
	     call iox_$control (iocb_ptr, "get_boot_program", addr (boot_program_info), error_code);
	     if error_code ^= 0 then do;		/* can't do it */
		call io_call_info
		     .
		     error (error_code, io_call_info.caller_name, "executing the ""get_boot_program"" control order");
		error_code = 0;
	     end;
	     else if boot_program_info.boot_program_ptr = null then
		call io_call_info
		     .report ("^a: This tape does not contain a tape label boot program", io_call_info.caller_name);
	     else call io_call_info
		     .
		     report ("^a:^-Boot program info:^/Pointer:^-^p^/Length:^-^o^/Name:^-^a",
		     io_call_info.caller_name, boot_program_info.boot_program_ptr,
		     boot_program_info.boot_program_text_length, boot_program_info.boot_program_name);
	end;
	else error_code = error_table_$no_operation;
	return;

     end control_io_call;

wait_for_write:
     entry (arg_tioi_id, arg_rx, arg_error_code);

	tioi_id = arg_tioi_id;
	call wait_for_write_proc (tioi_id, arg_rx, arg_error_code);
	return;

wait_for_write_proc:
     proc (tioi_id, rx, error_code);

dcl  tioi_id bit (36) aligned parameter;
dcl  rx fixed bin;
dcl  error_code fixed bin (35) parameter;

	rx = 0;
	error_code = 0;
	do while (error_code = 0 & rx = 0);
	     call tape_ioi_$check_write (tioi_id, (null), rx, error_code);
	end;
	if error_code = error_table_$device_not_active then do;
	     error_code = 0;
	     rx = 0;
	end;
	else if rx = TAPE_IO_EOT then
	     ;
	else if rx ^= 0 & error_code = 0 then
	     error_code = error_table_$device_parity;

     end wait_for_write_proc;

     end tape_mult_util_;




		    tape_mult_write_.pl1            11/11/89  1105.7r   11/11/89  0812.6      264933



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




/****^  HISTORY COMMENTS:
  1) change(85-12-05,GWMay), approve(), audit(), install():
     history comments before the hcom program:
        Created on 10/24/74 by Bill Silver.
        Modified 3/80 by R.J.C. Kissel to fix a bug in label writing.
        Modified 1/2/81 by J. A. Bush for bootable tape labels.
        Modified 8/12/81 by J. A. Bush for pre-MR9.0 label compatibility
        Modified 8/82 by S. Krupp to change from tdcm_ to tape_ioi_ interface.
        Modified 4/83 by Chris Jones to fix critical bug when writing suspended
        buffers
        Modified 12/84 by Chris Jones to improve writing strategy as subsets
        fill
        Modified 1985-03-14, BIM: fix dropped records end of tapes.
        Modified 1985-03-25, BIM: fixed off-by-one in padding changes above.
        Modified 1985-03-28, BIM: call PAD before instead of after
        SETUP_RECORD.
        Modified 1985-05-13, BIM: correctly set .admin and .set every time.
  2) change(86-02-13,GWMay), approve(86-02-13,MCR7337), audit(86-03-11,Farley),
     install(86-03-17,MR12.0-1030):
     moved the call to tape_io_$write before the check for eot so that when the
     last write is performed which causes the eot to be signalled, the program
     will handle the cleanup before returning. Before this change the program
     was not flushing its internal work buffers before exiting causing the tape
     to be out of format.
                                                   END HISTORY COMMENTS */


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

/*	This program is part of the Multics standard tape I/O module, tape_mult_.
   *	All of the functions that involve writing on a tape have been combined in this program.
   *	It contains the following entry points.
   *
   *	put_chars: Writes data onto the tape.  The character stream is broken up into Multics
   *		 standard records.  This implements the iox_$put_chars entry point.
   *	record:	 Writes one Multics standard record.  The data that is to be written must
   *		 fit into one Multics standard record.  Currently, this entry may be
   *		 called only from within tape_mult_.
   *	eof:	 Writes one End of File record.  May be called only from within tape_mult_.
   *	flush:	 Writes all the data we have currently buffered.  This entry
   *		 may be called only from within tape_mult_.
   *	label:	 sets up a buffer with the data for a standard tape label,
   *		 defined by the structure mst_label (for a bootable tape)
   *		 within the include file  mstr.incl.pl1. The label record
   *		 is actually written by a succeeding call to the eof entry,
   *		 which will write the label record followed by an EOF mark.
   *		 This entry is called only from within
   *		 tape_mult_ (currently from tape_mult_labeler_).
*/


/*		ARGUMENTS			*/

dcl	arg_char_count	   fixed bin (21),		/* (I) Number of characters to write. */
	arg_error_code	   fixed bin (35),		/* (O) Standard system error code. */
	arg_iocb_ptr	   ptr,			/* (I) Pointer to I/O control block. */
	arg_tmdbp		   ptr,			/* (I) Pointer to tape_mult_ data . */
	arg_work_buf_ptr	   ptr;			/* (I) Pointer to beginning of caller's buffer. */


/*		AUTOMATIC  DATA		*/

dcl	buf_space		   fixed bin,		/* Num of unused characters in record buffer. */
	char_count	   fixed bin (21),		/* Current num of characters to be written. */
	error_code	   fixed bin (35),		/* Standard system error code. */
	boot_label	   bit (1),		/* ON => a bootable (version >= 3) label is being generated */
	i		   fixed bin,		/* iteration counter */
	iocb_ptr		   ptr,			/* Pointer to I/O control block. */
	move_len		   fixed bin,		/* Num of chars to move. */
	n_ready_bufs	   fixed bin,
	n_susp_bufs	   fixed bin,
	num_data_bits	   fixed bin,		/* Bit count of actual data in a record. */
	rb_plen		   fixed bin,		/* Num of chars already in record buffer. */
	rb_ptr		   ptr,			/* Pointer to record buffer. */
	rx		   fixed bin,		/* result index */
	vidp		   ptr,			/* Pointer to version 2 label volume info */
	ip		   ptr,			/* pointer to installation_parms segment */
	bpp		   ptr,			/* temp pointer */
	bpo		   fixed bin,		/* length of external boot program  */
	segfaultsw	   bit (1) init ("0"b),	/* Set if segfault occurs moving data to buffer */
	wb_plen		   fixed bin (21),		/* Num of chars moved from work buffer. */
	tn1		   fixed bin,		/* temp number storage */
	tb1		   bit (18),		/* temp bit offset storage */
	wb_ptr		   ptr;			/* Pointer to caller's work buffer. */


/*   CONSTANTS */
/* program offset if booted (octal 30) */
dcl	boot_offset	   fixed bin internal static options (constant) init (24);

/*  change v3_label to "1"b to enable generation of version 3 bootable default labels */

dcl	v3_label		   bit (1) aligned int static options (constant) init ("0"b);

dcl	READY_BUFFERS	   fixed bin init (1) int static options (constant);
dcl	SUSPENDED_BUFFERS	   fixed bin init (3) int static options (constant);

/*		 BASED  DATA		*/

dcl	1 work_buf	   based unaligned,		/* Caller's buffer. */
	  2 processed	   char (wb_plen),		/* Data already written. */
	  2 move		   char (move_len);		/* Data being moved to record buffer. */

dcl	1 record_buf	   based aligned,		/* Physical record buffer. */
	  2 head		   (size (mstr_header)) bit (36),
						/* Multics standard tape record header. */
	  (
	  2 processed	   char (rb_plen),		/* Data already moved into record buffer. */
	  2 move		   char (move_len)
	  )		   unal;			/* Data being moved into record buffer. */

dcl	1 based_record	   based aligned,		/* Physical record buffer. */
	  2 head		   (size (mstr_header)) bit (36),
						/* Multics standard tape record header. */
	  2 array		   (1:4096) bit (9) unaligned;/* Record data as an array. */

/*		EXTERNAL  DATA		*/

dcl	(
	error_table_$bad_arg,
	error_table_$device_end,
	error_table_$device_not_active,
	error_table_$device_parity,
	error_table_$segfault,
	error_table_$invalid_write
	)		   fixed bin external;


dcl	get_group_id_	   entry returns (char (32)),
	hcs_$initiate	   entry (char (*), char (*), char (*), fixed bin (5), fixed bin (2), ptr, fixed bin (35)),
	release_temp_segment_  entry (char (*), ptr, fixed bin (35)),
	tape_checksum_	   entry (ptr, ptr),
	tape_mult_util_$wait_for_write
			   entry (bit (36) aligned, fixed bin, fixed bin (35)),
	unique_bits_	   entry returns (bit (70));

dcl	seg_fault_error	   condition;

dcl	(addr, addcharno, bin, bit, divide, hbound, high9, min, null, ptr, rel, size, substr, unspec)
			   builtin;

put_chars:
     entry (arg_iocb_ptr, arg_work_buf_ptr, arg_char_count, arg_error_code);

/*	This entry is called to write stream data onto a tape.  The element size of the
   *	stream must be 9 bits.  The stream will be broken up into units that can be written
   *	as one Multics standard tape record.
*/
	iocb_ptr = arg_iocb_ptr;			/* Copy arguments. */
	wb_ptr = arg_work_buf_ptr;
	char_count = arg_char_count;

	iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;	/* Initialize pointers. */
	tmdb_ptr = iocb_ptr -> iocb.attach_data_ptr;

	tioi_id = tmdb.work.tioi_id;			/* Initialize variables. */
	wb_plen = 0;
	error_code = 0;

	if ^tmdb.opt.write_sw			/* May we write on this tape? */
	then do;					/* NO. */
	     error_code = error_table_$invalid_write;
	     goto PUT_CHARS_ERROR;
	end;

	if tmdb.head.flags.eot			/* Have we past the End of Tape reflector? */
	then do;					/* YES, can't write anymore. */
	     error_code = error_table_$device_end;
	     goto PUT_CHARS_ERROR;
	end;

/*	We will now move the caller's data into the record buffers.  This loop breaks the
   *	data up into Multics standard tape records.  Each iteration implies that one
   *	tape record has been filled  or  contains all the data we have to write.
*/
	do while (char_count > 0);			/* Keep looping until all data moved. */
	     call FILL_BUFFER (error_code);		/* Fill buffer - up to 1 Mult. stand. tape record. */
	     if error_code ^= 0 then
		go to PUT_CHARS_ERROR;
	end;

	if ^tmdb.async_sw then do;
	     call tape_mult_util_$wait_for_write (tioi_id, rx, error_code);
	     call CHECK_RX (rx, error_code);
	     if error_code ^= 0 then
		go to PUT_CHARS_ERROR;
	end;

	if segfaultsw then do;			/* error copying data */
	     error_code = error_table_$segfault;
	     go to PUT_CHARS_ERROR;
	end;

	arg_error_code = 0;				/* put_chars operation was successful. */
	return;

PUT_CHARS_ERROR:
	arg_error_code = error_code;
	return;

record:
     entry (arg_tmdbp, arg_work_buf_ptr, arg_char_count, arg_error_code);

/*	This entry is called to write ONE Multics standard tape record.  The data
   *	that the user wants to write MUST fit into one Multics standard tape record.
   *	No record is written unless the caller supplies at least one character.
   *	If there is space in the record which is not used it will be padded with
   *	characters of "111111111"b.  If there is unwritten data in the current
   *	record buffer then that record will also be padded.  We will always begin
   *	writing our data at the beginning of the data portion of the Multics standard record.
*/
	tmdb_ptr = arg_tmdbp;			/* Initialize pointers, etc. */
	wb_ptr = arg_work_buf_ptr;
	char_count = arg_char_count;

	tioi_id = tmdb.work.tioi_id;			/* Initialize variables. */
	error_code = 0;
	char_count = min (char_count, tmdb.work.rec_length);
	wb_plen = 0;

	if char_count = 0				/* No data => no write. */
	     then
	     goto RECORD_RETURN;

	call PAD ();				/* Pad current record. */
	call SETUP_RECORD ();			/* Set record header and trailer. */
	if SUBSET_IS_FULL () then do;
	     call WRITE_SUBSET (error_code);
	     if ^(error_code = 0 | error_code = error_table_$device_end) then
		go to RECORD_RETURN;
	end;

	call FILL_BUFFER (error_code);		/* Move data into record buffer. */
	call PAD ();				/* Pad the rest of this record */
	call SETUP_RECORD ();			/* Set the header and trailer. */
	call WRITE_SUBSET (error_code);

RECORD_RETURN:					/* Common way out of this entry. */
	arg_error_code = error_code;			/* Return code. */
	return;

label:
     entry (arg_tmdbp, arg_error_code);

/*	This entry is called to set up a buffer with the information
   *	required for a Multics standard tape label.  If the "boot_program"
   *	control order has been executed, then a "bootable" tape label is set
   *	up which is defined by the mst_label structure within the include
   *	file mstr.incl.pl1.  If the "boot_program" control order has not been
   *	executed, then the label record takes on the personality of an
   *	"ordinary" tape_mult standard record, the volume information being
   *	defined by the volume_identifier structure within the mstr include
   *	file.
*/

	tmdb_ptr = arg_tmdbp;			/* Initialize pointers, etc. */
	tioi_id = tmdb.work.tioi_id;
	wb_plen = 0;				/* set processed char count to 0 */
	error_code = 0;				/* Return good code. */
	mstrp, rb_ptr = tmdb.work.curr_buf;		/* Set ptr to label buffer */
	bpp = ptr (mstrp, 0);			/* mstrp with zero offset */
	tb1 = bit (bin (bin (rel (addr (bpp -> mst_label.boot_pgm)), 18) + boot_offset, 18), 18);
	call hcs_$initiate (">system_control_1", "installation_parms", "", 0b, 0, ip, (0));

	if tmdb.opt.tbpp ^= null then do;		/* if external boot program */
	     mst_label = tmdb.opt.tbpp -> mst_label;	/* copy it */
	     bpo = mst_label.boot_pgm_len;		/* set text length */
	     mst_label.copyright = protection_notice;	/* set protection notice on bootable tapes */
	     call release_temp_segment_ ("tape_mult_", tmdb.opt.tbpp, (0));
						/* release our temp boot pgm buffer */
	     tmdb.opt.tbpp = null;			/* null out ptr, so if called again, will work */
	     boot_label = "1"b;			/* indicate this is a bootable label */
	     tmdb.work.buf_pos = bpo * 4;
	end;
	else if v3_label then do;			/* default boot label */
	     bpo = 2;				/* set boot program length, (pad the rest) */
	     mst_label.boot_pgm (1) = tb1 || "616200"b3;	/* set up DIS to stop if this tape is booted */
	     mst_label.boot_pgm (2) = "777777710204"b3;	/* and a tra to *-1,ic to make sure he stops */
	     mst_label.boot_pgm_path = "";		/* pad with blanks */
	     mst_label.copyright = "";		/* protection notice only goes on bootable tapes */
	     boot_label = "1"b;			/* indicate this is a bootable label */
	     tmdb.work.buf_pos = bpo * 4;
	end;
	else do;					/* pre-MR9.0 label compatibility hack */
	     vidp = addr (mstr.data);			/* set volume info ptr */
	     boot_label = "0"b;			/* indicate this is not a bootable label */
	     if ip = null then			/* Is there an installation_parms segment? */
		vidp -> volume_identifier.installation_id = " ";
						/* NO, use blanks. */
	     else vidp -> volume_identifier.installation_id = installation_parms.installation_id;
	     vidp -> volume_identifier.tape_reel_id = tmdb.opt.reel_name;
						/* Caller knows reel ID. */
	     vidp -> volume_identifier.volume_set_id = tmdb.opt.volume_set_id;
						/* copy directly, could be blanks */
	     tmdb.work.buf_pos = size (volume_identifier) * 4;
						/* set char size of label */
	     tmdb.work.rec_length = 1024 * 4;		/* reset  record length */
	     tmdb.head.data_bit_len = 1024 * 36;	/* and max bit count */
	     call PAD ();				/* Pad the rest of this record */
	     call SETUP_RECORD ();
	     call WRITE_SUBSET (error_code);		/* and write it. */
	     go to LABEL_RETURN;
	end;


/* set up the rest of the bootable tape label record */

	if ip = null then				/* Is there an installation_parms segment? */
	     mst_label.installation_id = " ";		/* NO, use blanks. */
	else mst_label.installation_id = installation_parms.installation_id;
	mst_label.tape_reel_id = tmdb.opt.reel_name;	/* Caller knows reel ID. */
	mst_label.volume_set_id = tmdb.opt.volume_set_id; /* copy directly, could be blanks */
	mst_label.label_version = LABEL_VERSION;	/* set the label version number */
	do i = 1 to hbound (iox_modes, 1) while (iox_modes (i) ^= substr (tmdb.open.description, 1, tmdb.open.length));
	end;
	mst_label.output_mode = i;			/* set output mode */
	do i = 1 to hbound (mst_label.xfer_vector, 1);	/* initialize transfer vector */
	     mst_label.xfer_vector (i).lda_instr = label_c1;
						/* set a "LDA 4" instruction */
	     mst_label.xfer_vector (i).tra_instr = tb1 || "710000"b3;
						/* and "TRA" instruction */

	end;
	tb1 = bit (bin (bin (rel (addr (bpp -> mst_label.fault_data)), 18) + boot_offset, 18), 18);
	tn1 = bin (rel (addr (bpp -> mst_label.fv_overlay)), 18) + boot_offset;
	do i = 0 to hbound (mst_label.fv_overlay, 1);	/* initialize fault vector overlay */
	     mst_label.fv_overlay (i).scu_instr = tb1 || "657200"b3;
	     mst_label.fv_overlay (i).dis_instr = bit (bin (tn1 + (i * 2), 18), 18) || "616200"b3;
	end;

	mst_label.boot_pgm_len =
	     (divide (tmdb.work.rec_length, 4, 17, 0)
	     - (bin (rel (addr (mst_label.boot_pgm))) - bin (rel (addr (mst_label.installation_id)))));
						/* set  max boot pgm length */
	mst_label.userid = get_group_id_ ();		/* put userid of tape creator in label */
	if bpo > mst_label.boot_pgm_len then		/* if user boot pgm  too long... */
	     bpo = mst_label.boot_pgm_len;		/* truncate it. This condition should */
						/*  have been detected by tape_mult_util_$control */

	if bpo < mst_label.boot_pgm_len then do;	/* is padding needed? */
	     do i = bpo + 1 to mst_label.boot_pgm_len;	/* yes, pad it out to end of data area */
		mst_label.boot_pgm (i) = "777777777777"b3;
	     end;
	     tmdb.head.flags.set, tmdb.head.flags.padded = "1"b;
						/* turn on padding flag */
	end;
	else tmdb.head.flags.padded = "0"b;		/* turn it off if it was on */
	num_data_bits =
	     (bpo + (bin (rel (addr (mst_label.boot_pgm))) - bin (rel (addr (mst_label.installation_id))))) * 36;
	call SETUP_RECORD ();
	call WRITE_SUBSET (error_code);		/* Write the buffer. */

LABEL_RETURN:
	arg_error_code = error_code;
	return;

eof:
     entry (arg_tmdbp, arg_error_code);

/*	This entry is called to write one End of File record.  If there is any
   *	unwritten data in the current buffer it will be padded and written
   *	before the EOF record is written.
*/
	tmdb_ptr = arg_tmdbp;			/* Initialize pointers, etc. */
	tioi_id = tmdb.work.tioi_id;
	error_code = 0;

	call PAD ();				/* Pad any data in current record buffer */
	call SETUP_RECORD ();
	call WRITE_SUBSET (error_code);		/* and write it. */
	if ^(error_code = 0 | error_code = error_table_$device_end) then
	     goto EOF_RETURN;

	call tape_mult_util_$wait_for_write (tioi_id, rx, error_code);
	call CHECK_RX (rx, error_code);
	if error_code ^= 0 then
	     go to EOF_RETURN;

	call WRITE_EOF (error_code);			/* Write the EOF record. */

EOF_RETURN:					/* Common way out of this entry. */
	arg_error_code = error_code;
	return;

flush:
     entry (arg_tmdbp, arg_error_code);

/*	This entry is called to flush out all the data we currently have
   *	buffered.  If the current buffer is only partially full it will be
   *	padded.
   *	Calling this entry guarantees that the next data given to tape_write_
   *	will be placed at the beginning of the data portion of the next
   *	physical Multics standard record.
*/

	tmdb_ptr = arg_tmdbp;			/* Initialize. */
	tioi_id = tmdb.work.tioi_id;
	error_code = 0;

	call PAD ();				/* Take care of any data in the current buffer */
	call SETUP_RECORD ();
	call WRITE_SUBSET (error_code);		/* (pad and write it). */

FLUSH_RETURN:
	arg_error_code = error_code;
	return;

FILL_BUFFER:
     procedure (error_code);

dcl	error_code	   fixed bin (35) parameter;

/*	This procedure is called to move data into the current record buffer.
   *	It will only move the number of characters needed to fill up one buffer.
   *	If there is more data to write, this procedure must be called again.
   *	This procedure calls SETUP_RECORD to fill in the record header and
   *	the record trailer.  Then, WRITE_BUFFER is called to perform
   *      the write.
*/
	rb_ptr = tmdb.work.curr_buf;
	rb_plen = tmdb.work.buf_pos;			/* Get current position in record buffer. */
	buf_space = tmdb.work.rec_length - tmdb.work.buf_pos;

	move_len = min (char_count, buf_space);

	tmdb.work.buf_pos = tmdb.work.buf_pos + move_len;
	num_data_bits = tmdb.work.buf_pos * 9;
	error_code = 0;

/*	Now move the data from the input work buffer to the record buffer.
   *	We must then update our current work buffer counters.
*/

	on seg_fault_error
	     begin;				/* if segment goes away during copy */
	     if segfaultsw then
		go to FILL_BUFFER_RETURN;		/* only allow this once */
	     segfaultsw = "1"b;
	     go to move_to_buffer;
	end;

move_to_buffer:
	if ^segfaultsw then
	     rb_ptr -> record_buf.move = wb_ptr -> work_buf.move;
	else unspec (rb_ptr -> record_buf.move) = ""b;	/* use zeroes if segfault or page fault happened */
	wb_plen = wb_plen + move_len;
	char_count = char_count - move_len;
	if tmdb.work.buf_pos >= tmdb.work.rec_length | ^tmdb.async_sw then do;
	     call PAD ();				/* PAD turns off the padded bit if no padding is needed, so we call it always. */
	     call SETUP_RECORD ();

	     if tmdb.work.n_full >= tmdb.work.bufs_per_subset | ^tmdb.async_sw then
		call WRITE_SUBSET (error_code);
	end;

FILL_BUFFER_RETURN:
	return;

     end FILL_BUFFER;

PAD:
     procedure;

/*	This procedure is called to pad out the current record with characters of
   *	(-1) and write it out to tape.  We will not pad if there is no data
   *      in the current buffer.  Padded records will have the "set" and
   *      "Padded" flags ON.
*/

declare	pad_string_ptr	   pointer;
declare	pad_string_length	   fixed bin;
declare	pad_string	   char (pad_string_length) based (pad_string_ptr);

	if tmdb.work.buf_pos = 0 | tmdb.work.buf_pos >= tmdb.work.rec_length then do;
						/* Need to pad? */
	     tmdb.head.flags.padded = "0"b;		/* NO, no padding needed. */
	     return;
	end;

	rb_ptr = tmdb.work.curr_buf;
	num_data_bits = tmdb.work.buf_pos * 9;		/* Get number of actual bits of data. */

	pad_string_ptr = addcharno (addr (rb_ptr -> based_record.array), tmdb.work.buf_pos);
						/* addcharno is like a 0:N array */
	pad_string_length = tmdb.work.rec_length - tmdb.work.buf_pos;

	pad_string = high9 (pad_string_length);

	tmdb.head.flags.set,			/* Turn ON padding flags. */
	     tmdb.head.flags.padded = "1"b;

     end PAD;

SETUP_RECORD:
     procedure;

/*	This procedure is called to set up the header and trailer of the current
   *	record and then write the record to tape.  First it will update the information
   *      that must go into the header and trailer.  Then it will move the work header
   *      and trailer into the actual write buffer for this record.
*/

	mstrp = tmdb.work.curr_buf;			/* Get pointer to actual record buffer. */

	if tmdb.work.buf_pos = 0			/* Data in buffer? */
	     then
	     return;				/* No. */

	tmdb.head.uid,				/* Same UID in header & trailer. */
	     tmdb.trail.uid = unique_bits_ ();

	tmdb.head.rec_within_file = tmdb.head.rec_within_file + 1;
	tmdb.head.data_bits_used = num_data_bits;
	tmdb.head.repeat_count = 0;

	tmdb.trail.tot_data_bits = tmdb.trail.tot_data_bits + num_data_bits;
	tmdb.trail.tot_rec = tmdb.trail.tot_rec + 1;

	tmdb.flags.admin = tmdb.flags.label | tmdb.flags.eor;
						/* Recalculate these, avoid all problems of un-reset bits */
	tmdb.flags.set =
	     tmdb.flags.repeat | tmdb.flags.padded | tmdb.flags.eot | tmdb.flags.drain | tmdb.flags.continue;

	if tmdb.head.label & boot_label then do;	/* is this a bootable label record? */
	     mst_label.head = tmdb.head;		/* yes, copy header and trailer  to label structure */
	     mst_label.trail = tmdb.trail;
	     call tape_checksum_ (addr (mst_label.head), addr (mst_label.head.checksum));
	end;
	else do;					/* no, must be standard record */
	     mstr.head = tmdb.head;			/* Copy work header and trailer. */
	     mstr.trail = tmdb.trail;
	     call tape_checksum_ (mstrp, addr (mstr.head.checksum));
	end;

	tmdb.work.n_full = tmdb.work.n_full + 1;	/* We have filled another buffer. */
	tmdb.work.curr_buf = NEXT_BUF ();		/* Get ptr to next empty buffer. */
	tmdb.work.buf_pos = 0;			/* This record full - reset character offset. */

	if tmdb.head.rec_within_file = 127 then do;
	     tmdb.work.flags.eof = "1"b;
	     tmdb.work.n_recs_to_eof = tmdb.work.n_full;
	     tmdb.head.rec_within_file = -1;		/* EOF OK, update header & trailer. */
	     tmdb.head.phy_file = tmdb.head.phy_file + 1;
	     tmdb.trail.tot_file = tmdb.trail.tot_file + 1;
	end;

     end SETUP_RECORD;

WRITE_EOF:
     procedure (code);

/*	This procedure is called to write one End of File record.
   *      We must update the record header and trailer data to reflect
   *      the beginning of a new file.
*/

dcl	code		   fixed bin (35);

	code = 0;

	if (tmdb.head.rec_within_file = -1 & ^tmdb.head.flags.eor) then
	     return;				/* EOF already there */

	call tape_ioi_$order (tioi_id, "eof", 1, (null), (0), (0), code);
	if code ^= 0 then
	     return;

	tmdb.head.rec_within_file = -1;		/* EOF OK, update header & trailer. */
	tmdb.head.phy_file = tmdb.head.phy_file + 1;
	tmdb.trail.tot_file = tmdb.trail.tot_file + 1;

     end WRITE_EOF;


WRITE_SUBSET:
     proc (code);

/*        This procedure queues a set of buffers to be written to tape.
   *      The number of buffers depends on how many have been filled
   *      at the time this procedure is called.  It then gets
   *      that number of free buffers so that we can start filling them
   *      with data while the other buffers are being written.
*/

dcl	buf_num		   fixed bin;
dcl	buf_pos		   fixed bin;
dcl	code		   fixed bin (35);
dcl	n_bufs		   fixed bin;
dcl	n_bufs_written	   fixed bin;
dcl	n_write_buffers	   fixed bin;
dcl	write_buffers	   (n_write_buffers) ptr based (write_buffers_ptr);
dcl	write_buffers_ptr	   ptr;

	code = 0;
	n_bufs = tmdb.work.n_full;
	buf_pos = tmdb.work.buf_pos;

	if n_bufs = 0 then
	     return;

	tmdb.work.n_full = 0;
	tmdb.work.buf_pos = 0;			/* Reset this only if we write successfully. */

	n_bufs_written = 0;

	do while (n_bufs > 0);

	     write_buffers_ptr = addr (tmdb.work.buffer (n_bufs_written + 1));

	     if tmdb.work.flags.eof then do;
		n_write_buffers = tmdb.work.n_recs_to_eof;
		n_bufs = n_bufs - n_write_buffers;
	     end;
	     else do;
		n_write_buffers = n_bufs;
		n_bufs = 0;
	     end;

	     n_bufs_written = n_bufs_written + n_write_buffers;

	     if ^tmdb.head.flags.eot then do;
		call tape_ioi_$write (tioi_id, write_buffers, tmdb.work.buf_len, (null), rx, code);
		call CHECK_RX (rx, code);
		if code ^= 0 then
		     go to WRITE_RETURN;
	     end;

	     if tmdb.head.flags.eot then do;
		do i = 1 to n_write_buffers;
		     mstrp = write_buffers (i);
		     if ^mstr.head.eot then do;
			mstr.head.eot, mstr.head.set = "1"b;
			call tape_checksum_ (mstrp, addr (mstr.head.checksum));
		     end;
		     call tape_ioi_$queue_write (tioi_id, mstrp, tmdb.work.buf_len, code);
		     if code ^= 0 then
			go to WRITE_RETURN;
		     call tape_ioi_$check_write (tioi_id, mstrp, rx, code);
		     call CHECK_RX (rx, code);
		     if code ^= 0 then
			go to WRITE_RETURN;
		end;
	     end;

	     if tmdb.work.flags.eof then do;
		tmdb.work.flags.eof = "0"b;
		tmdb.work.n_recs_to_eof = 0;
		call tape_mult_util_$wait_for_write (tioi_id, rx, code);
		call CHECK_RX (rx, code);
		if code ^= 0 then
		     go to WRITE_RETURN;
		call tape_ioi_$order (tioi_id, "eof", 1, (null), (0), (0), code);
		if code ^= 0 then
		     go to WRITE_RETURN;
	     end;

	end;

	call tape_ioi_$list_buffers (tioi_id, READY_BUFFERS, tmdb.work.buffer, n_ready_bufs, code);
	do buf_num = n_ready_bufs + 1 to tmdb.work.bufs_per_subset;
	     call tape_ioi_$check_write (tioi_id, tmdb.work.buffer (buf_num), rx, code);
	     call CHECK_RX (rx, code);
	     if code ^= 0 then do;
		if code = error_table_$device_not_active then do;
		     call tape_ioi_$list_buffers (tioi_id, READY_BUFFERS, tmdb.work.buffer, n_ready_bufs, code);
		     if code ^= 0 then
			go to WRITE_RETURN;
		     if n_ready_bufs < tmdb.work.bufs_per_subset then do;
/**** ******* Put a real code here ****** ****/
			code = error_table_$bad_arg;
			go to WRITE_RETURN;
		     end;
		     buf_num = tmdb.work.bufs_per_subset;
		end;
		else go to WRITE_RETURN;
	     end;
	end;

	tmdb.work.buf_pos = buf_pos;			/* Successful write, we want to write the rest. */

	if tmdb.head.flags.eot then
	     code = error_table_$device_end;

WRITE_RETURN:
	tmdb.work.curr_buf = tmdb.work.buffer (1);	/* Always restart from this buffer. */


     end WRITE_SUBSET;

SUBSET_IS_FULL:
     proc () returns (bit (1));

/*        This procedure tells us whether or not a subset of buffers is full.
   *      If a subset is full, we want to queue the buffers to be written. */

	if tmdb.work.n_full >= tmdb.work.bufs_per_subset then
	     return ("1"b);
	else return ("0"b);

     end SUBSET_IS_FULL;


NEXT_BUF:
     proc () returns (ptr);

/*        This procedure returns a pointer to the next buffer in the subset. */

	if tmdb.work.n_full >= tmdb.work.bufs_per_subset then
	     return (tmdb.work.buffer (1));
	else return (tmdb.work.buffer (tmdb.work.n_full + 1));

     end NEXT_BUF;

CHECK_RX:
     proc (rx, code);

dcl	rx		   fixed bin;
dcl	code		   fixed bin (35);

	if rx = 0 then
	     return;

	if rx = TAPE_IO_EOT then do;
	     if ^tmdb.head.flags.eot			/* First time. */
	     then do;
		tmdb.head.flags.eot = "1"b;		/* Set these first! */
		tmdb.head.flags.set = "1"b;
		call REQUEUE_SUSP_BUFS (code);
		if code ^= 0 then
		     return;
	     end;
	     else code = 0;				/* get rid of error_table_$device_end */
	end;
	else do;
	     if code = 0 then
		code = error_table_$device_parity;
	end;

     end CHECK_RX;


REQUEUE_SUSP_BUFS:
     proc (code);

dcl	code		   fixed bin (35);
dcl	i		   fixed bin;
dcl	susp_bufs		   (16) ptr;

	call tape_ioi_$list_buffers (tioi_id, SUSPENDED_BUFFERS, susp_bufs, n_susp_bufs, code);
	if code ^= 0 then
	     return;

	do i = 1 to n_susp_bufs;
	     mstrp = susp_bufs (i);
	     if ^mstr.head.flags.eot & tmdb.head.flags.eot then do;
		mstr.head.flags.set, mstr.head.flags.eot = "1"b;
		call tape_checksum_ (mstrp, addr (mstr.head.checksum));
	     end;
	     call tape_ioi_$queue_write (tioi_id, susp_bufs (i), tmdb.work.buf_len, code);
	     if code ^= 0 then
		return;

	     call tape_ioi_$check_write (tioi_id, susp_bufs (i), rx, code);
	     if (rx = TAPE_IO_SUCCESS) | (rx = TAPE_IO_EOT) then
		code = 0;				/* continue writing suspended buffers */
	     if code ^= 0 then
		return;
	end;

     end REQUEUE_SUSP_BUFS;

%include iox_modes;
%page;
%include tmdb;
%page;
%include mstr;
%page;
%include protection_notice;
%page;
%include installation_parms;
%page;
%include tape_ioi_dcls;
%page;
%include tape_ioi_result_indexes;
%page;
%include iocb;

     end tape_mult_write_;






		    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
