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