



		    alloc_cb_file.pl1               11/04/82  1940.0rew 11/04/82  1620.6       10368



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


alloc_cb_file:
     proc (size, cb_ptr);
	if system_areap = null			/* first call this process */
	then system_areap = get_system_free_area_ ();
	allocate cb in (free_area) set (cb_ptr);
	return;

free_cb_file:
     entry (size, cb_ptr);
	free cb_ptr -> cb in (free_area);
	return;

	dcl     size		 fixed;
	dcl     null		 builtin;
	dcl     cb_ptr		 ptr;		/* points to the control block to created or freed */
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     free_area		 area based (system_areap);
	dcl     system_areap	 ptr static init (null);
	dcl     1 cb		 based (cb_ptr),
		2 cb_words	 (size) fixed;
     end alloc_cb_file;




		    change_index.pl1                11/04/82  1940.0rew 11/04/82  1619.7      278235



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


change_index:
     proc (iocb_ptr, abort_exit);
	indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	f_b_ptr = file_base_ptr;
	fs_ptr = indx_cb.file_state_ptr;
	is_ptr = indx_cb.index_state_ptr;
	call initialize_substate;
	do while (index_action ^= 0);			/* the change cycle */
	     pos_ptr = change_position_ptr;
	     call prepare_next_state;
	     call save_node_head;
	     if index_action = insert_action
	     then do;
		     if last_branch_num = 1
		     then call insert_at_root;
		     else do;
			     call set_new_cont_space;
			     space = scat_space + new_cont_space;
			     if space < 0
			     then call overflow;
			     else do;
				     call simple_insert (branch_num);
				     call adjust_branch_num;
				end;
			end;
		end;				/* end insert action */
	     else do;
		     call set_old_key_info;
		     if index_action = delete_action
		     then do;
			     call simple_delete;
			     space = cont_space (node_ptr) + scat_space;
			     if space > half_node_length
			     then call underflow;
			     else call adjust_branch_num;
			end;			/* end delete action */
		     else do;			/* replace action */
			     x = old_key_length - new_key_length;
			     if x = 0
			     then do;
				     record_designator (branch_num) = new_record_designator;
						/* should use record_descrip, but compiler problems */
				     substr (keys, key_pos (branch_num), new_key_length) =
					substr (new_key_string, 1, new_key_length);
				     call adjust_branch_num;
				end;
			     else do;
				     y = cont_space (node_ptr);
				     space = y + scat_space + x;
				     if space >= 0
				     then do;	/* key will fit */
					     call replace_key;
					     if space > half_node_length
					     then call underflow;
					     else call adjust_branch_num;
					end;
				     else do;	/* key won't fit, turn into overflow-insert */
					     call set_new_branch;
					     call simple_delete;
					     call overflow;
					end;
				end;
			end;			/* end replace action */
		end;
	     call switch_index_state;
	end;					/* end change cycle */
	return;					/* end change_index routine */

prepare_next_state:
     proc;					/* sets up alternate index state variables */
	a_s_ptr = addr (index_state_blocks (1 - index_state));
	a_s_ptr -> index_action = 0;
	a_s_ptr -> index_substate = 0;
	a_s_ptr -> branch_num_adjust = 0;
	a_s_ptr -> index_height = index_height;
	a_s_ptr -> current_node = file_position_ptr -> node;
	a_s_ptr -> number_of_nodes = number_of_nodes;
	a_s_ptr -> index_tail_comp_num = index_tail_comp_num;
	a_s_ptr -> free_node_designator = free_node_designator;
     end prepare_next_state;

initialize_substate:
     proc;
	if repeating
	then do;
		if index_substate = 0
		then repeating = "0"b;
		else next_substate = 0;
		return;				/* don't alter permanent substate vars */
	     end;
	branch_num_adjust = 0;
	index_substate = 0;
	file_substate = file_substate + 1;
     end initialize_substate;

save_node_head:
     proc;
	if repeating
	then do;					/* restore header variables */
		call check_index_substate;
		last_branch_num = old_last_branch_num;
		low_key_pos = old_low_key_pos;
		scat_space = old_scat_space;
		return;
	     end;
	old_last_branch_num = last_branch_num;
	old_low_key_pos = low_key_pos;
	old_scat_space = scat_space;
	index_substate = index_substate + 1;
     end save_node_head;

switch_index_state:
     proc;
	if a_s_ptr -> index_action = 0
	then if new_desc_val = 0			/* not replacing non-leaf key */
	     then go to switch;
	change_position_ptr = parent_position_ptr;	/* pop change position */
	a_s_ptr -> change_node = node;
	call save_position_stack;
switch:
	index_state = 1 - index_state;		/* switch states */
	index_state_ptr = a_s_ptr;
	is_ptr = index_state_ptr;
	return;					/* end of switch_state routine */

save_position_stack:
     proc;
	p = root_position_ptr;

	do i = 1 to a_s_ptr -> index_height;
	     p = p -> son_position_ptr;
	     a_s_ptr -> saved_node (i) = p -> node;
	     a_s_ptr -> saved_branch_num (i) = p -> branch_num;
	end;

	dcl     p			 ptr;
	dcl     i			 fixed;
     end save_position_stack;

     end switch_index_state;

simple_insert:
     proc (b_num);
	if new_cont_space < 0
	then call compact_node (node_ptr);
	if b_num < last_branch_num
	then call move_bytes (node_ptr, 5 + bd_len * b_num, bd_len, bd_len * (last_branch_num - b_num));
	call insert_key (b_num);
	last_branch_num = last_branch_num + 1;
	branch (b_num + 1) = new_branch;
	return;
	dcl     i			 fixed;
	dcl     b_num		 fixed;
     end;						/* end simple insert */

insert_key:
     proc (br_num);
	low_key_pos = low_key_pos - new_key_length;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	record_designator (br_num) = new_record_designator;
						/* should use record_descrip, but compiler problems */
	key_length (br_num) = new_key_length;
	key_pos (br_num) = low_key_pos;
	substr (keys, low_key_pos, new_key_length) = substr (new_key_string, 1, new_key_length);
	index_substate = index_substate + 1;
	dcl     br_num		 fixed;
     end insert_key;

simple_delete:
     proc;
	call free_key_space;
	last_branch_num = last_branch_num - 1;
	if branch_num < last_branch_num
	then call move_bytes (node_ptr, 5 + bd_len * (branch_num + 1), -bd_len, bd_len * (last_branch_num - branch_num));
	return;

	dcl     len		 fixed;
     end;						/* end simple delete */

adjust_branch_num:
     proc;
	branch_num = branch_num + branch_num_adjust;
     end;

move_bytes:
     proc (np, source_offset, displacement, n_bytes);
	dest_offset = source_offset + displacement;
	call save_new_string;
	call set_new_string;
	return;					/* end move_bytes main routine */

save_new_string:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	substr (spare_node, dest_offset, n_bytes) = substr (np -> keys, source_offset, n_bytes);
	index_substate = index_substate + 1;
     end;

set_new_string:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	substr (np -> keys, dest_offset, n_bytes) = substr (spare_node, dest_offset, n_bytes);
	index_substate = index_substate + 1;
     end;

	dcl     np		 ptr;
	dcl     (source_offset, displacement, n_bytes, dest_offset)
				 fixed;
     end move_bytes;

set_new_branch:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	new_branch = branch (branch_num + 1);
	index_substate = index_substate + 1;
     end;

set_old_key_info:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	old_key_pos = key_pos (branch_num);
	old_key_length = key_length (branch_num);
	index_substate = index_substate + 1;
     end;

free_key_space:
     proc;
	if old_key_pos = low_key_pos
	then low_key_pos = low_key_pos + old_key_length;
	else scat_space = scat_space + old_key_length;
     end;

replace_key:
     proc;
	call free_key_space;
	if new_key_length > y
	then do;					/* make room for larger key */
		call zero_key;
		call compact_node (node_ptr);
	     end;
	call insert_key (branch_num);
	return;					/* end of replace_key routine */

zero_key:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	key_length (branch_num) = 0;
	index_substate = index_substate + 1;
     end zero_key;

     end replace_key;

compact_node:
     proc (n_ptr);
	np = n_ptr;
	call make_compact_copy;
	call set_compacted_node;
	np -> low_key_pos = new_low_key_pos;
	np -> scat_space = 0;
	return;					/* end of compaction routine */

make_compact_copy:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	n_keys = np -> last_branch_num - 1;
	len = n_keys * bd_len + node_head_length;
	substr (spare_node, 1, len) = substr (np -> keys, 1, len);
	k = node_length + 1;

	do i = 1 to n_keys;
	     m = np -> key_length (i);
	     if m > 0
	     then do;
		     k = k - m;
		     substr (spare_node, k, m) = substr (np -> keys, np -> key_pos (i), m);
		     addr (spare_node) -> key_pos (i) = k;
		end;
	end;

	new_low_key_pos = k;
	index_substate = index_substate + 1;
	dcl     (n_keys, len)	 fixed;
     end make_compact_copy;

set_compacted_node:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	substr (np -> keys, 1, node_length) = substr (spare_node, 1, node_length);
	index_substate = index_substate + 1;
     end;

	dcl     (np, n_ptr)		 ptr;
	dcl     (i, k, m)		 fixed;
     end;						/* end compact node */

set_new_cont_space:
     proc;
	new_cont_space = cont_space (node_ptr) - new_key_length - bd_len;
     end set_new_cont_space;

cont_space:
     proc (np) returns (fixed);
	return (np -> low_key_pos - 1 - node_head_length + bd_len - np -> last_branch_num * bd_len);
	dcl     np		 ptr;
     end cont_space;

insert_at_root:
     proc;
	call extend_position_stack (indx_cb_ptr);	/* sets change position to new frame */
	pos_ptr = change_position_ptr;
	call create_node (node, node_ptr);
	call set_first_branch;
	only_branch_in_root = node;
	a_s_ptr -> index_height = index_height + 1;
	a_s_ptr -> current_node = file_position_ptr -> node;
	old_index_height = a_s_ptr -> index_height;
	branch_num = 1;
	new_cont_space = 0;				/* avoids unnecessary compaction */
	call simple_insert (1);
	call adjust_branch_num;
	return;

set_first_branch:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	branch (1) = only_branch_in_root;
	index_substate = index_substate + 1;
     end;
     end;						/* end insert_at_root */

overflow:
     proc;
	is_overflow = "1"b;
	num_of_keys = last_branch_num;		/* num of keys in node + 1 for inserted key */
	call get_parent;
	if is_ks_out
	then do;					/* create right brother but don't balance */
		call split (num_of_keys - 1);
		call adjust_position_right;
		return;
	     end;
	if p_b_num < p_n_ptr -> last_branch_num
	then do;					/* try rotate right */
		call get_right_brother;
		call rotate_right;			/* sets count */
		if first_count > 0
		then do;
			call adjust_position_right;
			return;
		     end;
	     end;
						/* rotate left or split */
	if p_b_num > 1
	then do;					/* try left brother */
		call get_left_brother;
		call rotate_left;			/* sets count */
		if second_count > 0
		then do;
			call adjust_position_left;
			return;
		     end;
	     end;
						/* must split node, p_b_num irrelevant(no pivot),split sets b_n_ptr */
	call find_split_num;
	call split (split_num);			/* split_num is num of key after last included in space */
	call adjust_position_right;
	return;					/* end overflow code */

get_parent:
     proc;
	p_n_ptr = parent_position_ptr -> node_ptr;
	p_b_num = parent_position_ptr -> branch_num;
     end;

get_right_brother:
     proc;
	b_node = p_n_ptr -> branch (p_b_num + 1);
	b_n_ptr = get_ptr (b_node);
	call set_b_vars;
	return;					/* end of get_right_brother routine */

get_left_brother:
     entry;
	p_b_num = p_b_num - 1;
	b_node = p_n_ptr -> branch (p_b_num);
	b_n_ptr = get_ptr (b_node);
	call set_b_vars;
	return;					/* end of get_left_brother routine */

set_b_vars:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	b_space = cont_space (b_n_ptr) + b_n_ptr -> scat_space;
	last_b_num = b_n_ptr -> last_branch_num;
	index_substate = index_substate + 1;
     end set_b_vars;

     end get_right_brother;

find_split_num:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	space = node_head_length;

	do split_num = 1 repeat (split_num + 1) while (space < half_node_length);
	     space = space + bd_len + key_length (split_num);
	end;

	index_substate = index_substate + 1;
     end find_split_num;

underflow:
     entry;
	is_overflow = "0"b;
	call get_parent;
	if p_b_num < p_n_ptr -> last_branch_num
	then do;					/*
						   balance or combine with right brother */
		call get_right_brother;
		num_of_keys = last_b_num - 1;
		dest_np = node_ptr;
		if is_combination_possible ()
		then call combine (node_ptr, b_n_ptr);
		else call rotate_left;
		call adjust_branch_num;
	     end;
	else if p_b_num > 1
	then do;					/* balance or combine with left brother */
		call get_left_brother;
		num_of_keys = last_b_num - 1;
		parent_position_ptr -> branch_num = p_b_num;
		dest_np = b_n_ptr;
		if is_combination_possible ()
		then do;
			call combine (b_n_ptr, node_ptr);
			call set_node_to_brother;
			branch_num = last_b_num + branch_num + branch_num_adjust;
		     end;
		else do;
			call rotate_right;
			branch_num = branch_num + branch_num_adjust + count;
			a_s_ptr -> branch_num_adjust = 1;
		     end;
	     end;
	else /* the parent node is the root node */
	     if last_branch_num = 1			/* height of tree decreases */
	then call underflow_to_root;
	else call adjust_branch_num;
	return;					/* end of underflow code */

underflow_to_root:
     proc;
	call set_root_branch;
	call free_node (node, node_ptr);
	a_s_ptr -> index_height = index_height - 1;
	old_index_height = a_s_ptr -> index_height;
	node_ptr = parent_position_ptr -> node_ptr;
	node = parent_position_ptr -> node;
	a_s_ptr -> current_node = file_position_ptr -> node;
	branch_num = 1;
	root_position_ptr = pos_ptr;
	return;					/* end of underflow_to_root routine */

set_root_branch:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	only_branch_in_root = branch (1);
	index_substate = index_substate + 1;
     end;

     end underflow_to_root;

/* Declarations */
	dcl     is_new_key		 bit (1) aligned;
	dcl     is_overflow		 bit (1) aligned;
	dcl     (p_n_ptr, b_n_ptr)	 ptr;		/* parent,brother nodes */
	dcl     b_node		 fixed (35);	/* brother node designator */
	dcl     last_b_num_left	 fixed;		/* used in combining node with left brother */
	dcl     p_b_num		 fixed;		/* branch num for pivot kay is parent */
	dcl     n_ptr		 ptr;
	dcl     (dest_np, np1, np2)	 ptr;
	dcl     i			 fixed;
	dcl     num_of_keys		 fixed;		/* number of keys available for rotation,
						   includes new key in overflow case */

get_key:
     proc (i, p, k);				/* locates the node(p)and branch_num(k)for the ith key"in"
						   the source node. Allows for new key. This routine is used in rotate_x and
						   split */
	p = np1;
	k = i;
	if is_overflow
	then if i >= branch_num
	     then if i = branch_num
		then do;				/* use new key */
			p = addr (fake_node);
			k = 1;
			is_new_key = "1"b;
			return;
		     end;
		else k = k - 1;
	is_new_key = "0"b;
	return;

	dcl     i			 fixed;		/* 1<=i<=num_of_keys */
	dcl     k			 fixed;
	dcl     p			 ptr;
     end;						/* end get_key */

split:
     proc (n);					/* creates new right brother */
	count = num_of_keys - n + 1;
	call create_node (b_node, b_n_ptr);
	a_s_ptr -> new_branch = b_node;
	a_s_ptr -> index_action = insert_action;
	call set_nps;
	call split_keys;
	np2 -> last_branch_num = 0;
	call finish_dest_node;
	call finish_left_node;
	return;					/* end of split routine */

split_keys:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	call get_key (n, p, k);
	call set_upbound_key;
	np2 -> branch (1) = first_branch;
	call set_dest_node_info;
	dest_b_num = num_of_keys - n;

	do i = num_of_keys to n + 1 by -1;
	     call get_key (i, source_n_ptr, source_b_num);
	     call move_adjust;
	     dest_b_num = dest_b_num - 1;
	end;

	index_substate = index_substate + 1;
     end split_keys;

	dcl     n			 fixed;		/* index of first key to be moved */
	dcl     b_num		 fixed;
	dcl     n_ptr		 ptr;
     end;						/* end split */

move_adjust:
     proc;					/* adjust low_key_pos and free space count in source */
	source_key_pos = source_n_ptr -> key_pos (source_b_num);
	source_key_len = source_n_ptr -> key_length (source_b_num);
	if source_key_pos > min_source_key_pos
	then new_scat_space = new_scat_space + source_key_len;
	else if ^is_new_key
	then min_source_key_pos = min_source_key_pos + source_key_len;
move:
     entry;					/* moves key and bd_words from source node to dest node */
	dest_bd_words = source_bd_words;
	min_dest_key_pos = min_dest_key_pos - source_key_len;
	dest_n_ptr -> key_pos (dest_b_num) = min_dest_key_pos;
	substr (dest_n_ptr -> keys, min_dest_key_pos, source_key_len) =
	     substr (source_n_ptr -> keys, source_key_pos, source_key_len);
	dcl     source_bd_words	 (branch_and_descrip_size) based (addr (source_n_ptr -> descrip (source_b_num)))
				 fixed;
	dcl     dest_bd_words	 (branch_and_descrip_size) based (addr (dest_n_ptr -> descrip (dest_b_num))) fixed;
     end move_adjust;

set_new_key_and_descrip:
     proc (n_ptr, b_num);
	a_s_ptr -> new_key_length = n_ptr -> key_length (b_num);
	substr (a_s_ptr -> new_key_string, 1, a_s_ptr -> new_key_length) =
	     substr (n_ptr -> keys, n_ptr -> key_pos (b_num), a_s_ptr -> new_key_length);
	a_s_ptr -> new_record_designator = n_ptr -> record_designator (b_num);
	return;

	dcl     n_ptr		 ptr;
	dcl     b_num		 fixed;
     end;						/* end set-new_key */

compact_if_nec:
     proc;
	b_n_ptr -> last_branch_num = last_b_num;
	if must_compact_dest
	then call compact_node (np2);
     end;

rotate_right:
     proc;
	i = num_of_keys;				/* defines first key to be moved */
	di = -1;
	call compute_count;
	call set_first_count;
	if first_count ^= 0
	then do;					/* rotation is possible */
		a_s_ptr -> index_action = replace_action;
		call compact_if_nec;
		call move_bytes (np2, bd_len + 1, count * bd_len, bd_len * (np2 -> last_branch_num - 1) + 4);
		call rotate_keys_right;
		np2 -> branch (1) = first_branch;
		call finish_dest_node;
		call finish_left_node;
	     end;
	return;					/* end rotate_right code */

rotate_keys_right:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	call set_dest_node_info;
	dest_b_num = count;
	call move_key_down;
	np2 -> branch (count + 1) = np2 -> branch (1);
	call get_key (num_of_keys + 1 - count, p, k);
	call set_upbound_key;

	do i = 1 to count - 1;
	     call get_key (num_of_keys + 1 - i, source_n_ptr, source_b_num);
	     dest_b_num = dest_b_num - 1;
	     call move_adjust;
	end;

	index_substate = index_substate + 1;
     end rotate_keys_right;

set_first_count:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	first_count = count;
	index_substate = index_substate + 1;
     end;

set_second_count:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	second_count = count;
	index_substate = index_substate + 1;
     end;

rotate_left:
     entry;
	i = 1;					/* defines first key to be moved */
	di = 1;
	call compute_count;
	call set_second_count;
	if second_count ^= 0
	then do;					/* rotation is possible */
		a_s_ptr -> index_action = replace_action;
		call compact_if_nec;
		call rotate_keys_left;
		np1 -> branch (1) = first_branch;
		call finish_dest_node;
		call finish_right_node;
	     end;
	return;					/* end rotate_left */

rotate_keys_left:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	call set_dest_node_info;
	call move_key_down;
	call get_key (count, p, k);
	call set_upbound_key;

	do i = 1 to count - 1;
	     call get_key (i, source_n_ptr, source_b_num);
	     dest_b_num = dest_b_num + 1;
	     call move_adjust;
	end;

	index_substate = index_substate + 1;
     end rotate_keys_left;

	dcl     i			 fixed;		/* indexes keys "in" source node-including inserted keys */
	dcl     di		 fixed;		/* defines order to take keys from source node */

compute_count:
     proc;
	call set_nps;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	if is_overflow
	then do;
		x = space;
		y = b_space;
	     end;
	else do;
		x = b_space;
		y = space;
	     end;
	dy = bd_len + p_n_ptr -> key_length (p_b_num);	/* parent key is first to be moved */
	count = 0;
	call get_key (i, p, k);
	dx = bd_len + p -> key_length (k);
	do while (i > 0);				/* i=0 just a convienient stop flag */
	     if dy > y
	     then i = 0;
	     else do;				/* key will fit */
		     count = count + 1;
		     y = y - dy;
		     x = x + dx;
		     if x >= y
		     then i = 0;			/* nodes are more or less balanced */
		     else do;
			     dy = dx;
			     i = i + di;
			     call get_key (i, p, k);
			     dx = bd_len + p -> key_length (k);
			end;
		end;
	end;
	if x < 0
	then count = 0;				/* can not move enough keys to correct overflow */
	else if count > 0
	then if y < np2 -> scat_space
	     then must_compact_dest = "1"b;
	     else must_compact_dest = "0"b;
	index_substate = index_substate + 1;
	return;

	dcl     (x, y)		 fixed;		/* x is space in source node,y in target node.
						   Initially x<y. Indeed, is overflow case x<o. routine finds count

						   of keys to be moved such that x>=y if possible. Constraint is y>=o */
	dcl     (dx, dy)		 fixed;
     end;						/* end compute_count_set_nps */

     end;						/* end rotate_right */

set_dest_node_info:
     proc;
	dest_n_ptr = np2;
	dest_b_num = np2 -> last_branch_num;
	min_dest_key_pos = np2 -> low_key_pos;
     end;

move_key_down:
     proc;
	source_n_ptr = p_n_ptr;
	source_b_num = p_b_num;
	source_key_pos = source_n_ptr -> key_pos (source_b_num);
	source_key_len = source_n_ptr -> key_length (source_b_num);
	call move;
	np2 -> branch (dest_b_num + 1) = np1 -> branch (1);
     end move_key_down;

set_upbound_key:
     proc;
	call set_new_key_and_descrip (p, k);
	first_branch = p -> branch (k + 1);
	min_source_key_pos = np1 -> low_key_pos;
	new_scat_space = np1 -> scat_space;
	key_len = p -> key_length (k);
	if p -> key_pos (k) > min_source_key_pos
	then new_scat_space = new_scat_space + key_len;
	else if ^is_new_key
	then min_source_key_pos = min_source_key_pos + key_len;
	dcl     key_len		 fixed;
     end;

finish_dest_node:
     proc;
	np2 -> low_key_pos = min_dest_key_pos;
	np2 -> last_branch_num = np2 -> last_branch_num + count;
     end;

set_nps:
     proc;
	if is_overflow
	then do;
		np1 = node_ptr;
		np2 = b_n_ptr;
	     end;
	else do;
		np1 = b_n_ptr;
		np2 = node_ptr;
	     end;
     end set_nps;

finish_left_node:
     proc;					/* called after split or right rotate */
	call set_source_vars;
	if is_overflow
	then /* main node is left one */
	     if branch_num <= last_branch_num
	     then do;				/* new key must be inserted */
		     call set_new_cont_space;
		     call simple_insert (branch_num);
		end;
	     else /* new key was moved */
		np1 -> last_branch_num = np1 -> last_branch_num + 1;
     end;						/* end finish_left_node */

finish_right_node:
     proc;					/* called after left rotate */
	call set_source_vars;
	if is_overflow
	then do;					/* main node is right one */
		if branch_num <= count
		then do;				/* new key was moved */
			np1 -> last_branch_num = np1 -> last_branch_num + 1;
			call left_shift (count - 1);
		     end;
		else do;				/* new key must be inserted */
			call left_shift (count);
			call set_new_cont_space;
			call simple_insert (branch_num - count);
		     end;
	     end;
	else /* underflow case,brother node is right one */
	     call left_shift (count);
     end;						/* end finish_right_node */

set_source_vars:
     proc;
	np1 -> last_branch_num = np1 -> last_branch_num - count;
	np1 -> low_key_pos = min_source_key_pos;
	np1 -> scat_space = new_scat_space;
     end;

left_shift:
     proc (n);					/* shifts descriptors n places left within node */
	disp = n * bd_len;
	call move_bytes (np1, 1 + node_head_length + disp, -disp, bd_len * (np1 -> last_branch_num - 1));
	dcl     (disp, n)		 fixed;
     end;						/* end left_shift */

is_combination_possible:
     proc returns (bit (1));
	spare_space = space + b_space + node_head_length - node_length - p_n_ptr -> key_length (p_b_num) - bd_len;
	if spare_space >= 0
	then do;
		if spare_space < dest_np -> scat_space
		then must_compact_dest = "1"b;
		else must_compact_dest = "0"b;
		return ("1"b);
	     end;
	return ("0"b);
     end is_combination_possible;

combine:
     proc (n_ptr_1, n_ptr_2);				/* moves key  in parent and all keys in node 2 (the right node)
						   into node 1 (movement to left), deletes node 2 */
	a_s_ptr -> index_action = delete_action;
	np1 = n_ptr_2;
	np2 = n_ptr_1;
	call compact_if_nec;
	call combine_keys;
	call finish_dest_node;
	call free_node (p_n_ptr -> branch (p_b_num + 1), np1);
						/* delete right node */
	return;					/* end of combine routine */

combine_keys:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	call set_dest_node_info;
	call move_key_down;
	count = np1 -> last_branch_num;
	source_n_ptr = np1;

	do source_b_num = 1 to count - 1;
	     dest_b_num = dest_b_num + 1;
	     source_key_pos = source_n_ptr -> key_pos (source_b_num);
	     source_key_len = source_n_ptr -> key_length (source_b_num);
	     call move;
	end;

	index_substate = index_substate + 1;
     end combine_keys;

	dcl     (n_ptr_1, n_ptr_2)	 ptr;
     end;						/* end combine */

adjust_position_right:
     proc;					/* used after split or right rotation for overflow */
	call adjust_branch_num;
	if branch_num > last_branch_num
	then do;
		branch_num = branch_num - last_branch_num;
		call set_node_to_brother;
		a_s_ptr -> branch_num_adjust = 1;
	     end;
	else if branch_num = last_branch_num
	then if file_position_ptr = pos_ptr
	     then call set_current_node_to_parent;
	return;
     end;						/* end adjust_position_right */

adjust_position_left:
     proc;					/* used after left rotation for overflow */
	parent_position_ptr -> branch_num = p_b_num;
	branch_num = branch_num + branch_num_adjust - count;
	if branch_num = 0
	then if file_position_ptr = pos_ptr		/* position moves to parent */
	     then do;
		     call set_current_node_to_parent;
		     return;
		end;
	if branch_num <= 0				/* position is in left node */
	then do;
		call set_node_to_brother;
		branch_num = last_branch_num + branch_num;
	     end;
	else a_s_ptr -> branch_num_adjust = 1;		/* position is in right node */
	return;
     end;						/* end adjust_position_left */

set_node_to_brother:
     proc;
	node = b_node;
	node_ptr = b_n_ptr;
	a_s_ptr -> current_node = file_position_ptr -> node;
     end;

set_current_node_to_parent:
     proc;
	file_position_ptr = parent_position_ptr;
	a_s_ptr -> current_node = parent_position_ptr -> node;
     end;

	dcl     p			 ptr;
	dcl     k			 fixed;
     end;						/* end overflow_underflow */

create_node:
     proc (designator, node_ptr_arg);			/* ref17 */
	a_s_ptr -> number_of_nodes = number_of_nodes + 1;
	free_node_ptr = get_ptr (free_node_designator);
	call save_create_free_info;
	if free_node_designator ^= 0
	then if old_number_of_free_nodes > 0
	     then do;				/* grab a free node from the list */
		     designator = nodes (old_number_of_free_nodes);
		     number_of_free_nodes = old_number_of_free_nodes - 1;
		     node_ptr_arg = get_ptr (designator);
		end;
	     else do;				/* use this free node */
		     designator = free_node_designator;
		     node_ptr_arg = free_node_ptr;
		     a_s_ptr -> free_node_designator = old_next_node_designator;
		end;
	else if old_seg_lim + node_size <= max_seg_limit
	then do;					/* use next available page of index tail */
		call make_designator (index_tail_comp_num, (old_seg_lim), designator);
		node_ptr_arg = get_ptr (designator);
		seg_limit (index_tail_comp_num) = old_seg_lim + node_size;
	     end;
	else do;					/* get a new index file component */
		a_s_ptr -> index_tail_comp_num = new_index_comp_num;
		call get_new_seg (iocb_ptr, a_s_ptr -> index_tail_comp_num, node_ptr_arg, index_substate, abort_exit);
		comp_link (a_s_ptr -> index_tail_comp_num) = index_tail_comp_num;
		call make_designator (a_s_ptr -> index_tail_comp_num, 0, designator);
		seg_limit (a_s_ptr -> index_tail_comp_num) = node_size;
	     end;
	node_ptr_arg -> last_branch_num = 1;
	node_ptr_arg -> low_key_pos = node_length + 1;
	node_ptr_arg -> scat_space = 0;
	return;					/* end create node code */

save_create_free_info:
     proc;
	if repeating
	then do;
		call check_index_substate;
		return;
	     end;
	old_seg_lim = abs (seg_limit (index_tail_comp_num));
	old_number_of_free_nodes = number_of_free_nodes;
	old_next_node_designator = next_node_designator;
	new_index_comp_num = last_comp_num + 1;
	index_substate = index_substate + 1;
     end save_create_free_info;

free_node:
     entry (designator, node_ptr_arg);
	a_s_ptr -> number_of_nodes = number_of_nodes - 1;
	if free_node_designator ^= 0
	then do;					/* at least one free node exists */
		free_node_ptr = get_ptr (free_node_designator);
		call save_create_free_info;
		if old_number_of_free_nodes < (node_size - 2)
		then do;				/* add new entry to free list */
			number_of_free_nodes = old_number_of_free_nodes + 1;
			nodes (number_of_free_nodes) = designator;
			unspec (node_words) = "0"b;
			return;
		     end;
	     end;
	free_node_ptr = node_ptr_arg;
	number_of_free_nodes = 0;
	next_node_designator = free_node_designator;
	a_s_ptr -> free_node_designator = designator;
	return;					/* end of free_node routine */

	dcl     1 free_node		 based (free_node_ptr),
		2 number_of_free_nodes
				 fixed,
		2 next_node_designator
				 fixed (35),
		2 nodes		 (1 /* really node-size-2 */) fixed (35);
	dcl     designator		 fixed (35);
	dcl     node_ptr_arg	 ptr;
	dcl     node_words		 (node_size) fixed based (node_ptr_arg);
	dcl     free_node_ptr	 ptr;
     end create_node;

check_index_substate:
     proc;
	next_substate = next_substate + 1;
	if index_substate = next_substate
	then repeating = "0"b;			/* execution resumes normally */
     end check_index_substate;

get_ptr:
     proc (descriptor) returns (ptr);
	return (addr (seg_ptr_array (desc.comp_num) -> seg_array (fixed (desc.offset))));
	dcl     descriptor		 fixed (35);
	dcl     1 desc		 like designator_struct aligned based (addr (descriptor));
     end get_ptr;

/* Arguments */
	dcl     iocb_ptr		 ptr;
	dcl     abort_exit		 label;

/* Local Variables */
	dcl     (source_n_ptr, dest_n_ptr)
				 ptr;
	dcl     (source_b_num, source_key_pos, source_key_len, dest_b_num)
				 fixed;
	dcl     pos_ptr		 ptr;
	dcl     spare_space		 fixed;
	dcl     new_cont_space	 fixed;
	dcl     space		 fixed;
	dcl     (x, y)		 fixed;
	dcl     a_s_ptr		 ptr;

/* Constants Depending on Node Structure */
	dcl     bd_len		 static options (constant) fixed init (12);
	dcl     branch_and_descrip_size
				 static options (constant) fixed init (3);
	dcl     node_head_length	 static options (constant) fixed init (16);
						/* includes first branch */

%include vfile_indx;
%include iocbv;
     end change_index;




		    change_record_list.pl1          11/04/82  1940.0rew 11/04/82  1620.7      253269



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


/* The initial design and implementation of this program was
   by M. D. MacLaren (1974) */
/* All changes since 1975 by M. Asherman:
   Modified to support recovery from interruptions.
   Extended to support stationary type records.
   Modified to avoid wasting first two words of each record component.
   Extended to support transaction mode updates.
   Changed for new comp_array format in file header to avoid csl's. */
/* the following conventions must be observed in manipulating the
   file statistics giving the number_of_allocated_records and the
   number_of_free_blocks:

   fs_ptr->number_of_free_blocks is reconstructed, using the protected
   variable old_number_of_free_blocks in the allocation logic, and
   using the protected variable old_num_free in the freeing logic.

   fs_ptr->number_of_allocated_records is always protected.

   the alternate state statistics are always reconstructed. */
change_record_list:
     proc (iocb_ptr, record_action, buff_ptr, abort_exit);
	indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	f_b_ptr = file_base_ptr;
	fs_ptr = indx_cb.file_state_ptr;
	os_ptr = indx_cb.o_s_ptr;
	if record_action = allocate_action
	then do;
		header_size = 2;
		call set_required_block_size;
		call allocate;
		if ^indx_cb.repeating		/* non-recovery execution */
		then addr (seg_array (block_offset)) -> excess_words = required_block_size - needed_block_size;
						/* save min block size info for later
						   attempt to replace tail in compact form */
	     end;
	else if record_action = free_action
	then do;					/* get rid of preceding allocation */
		call find_new_ind_block;		/* locate after image block */
		call free;			/* disposes of allocation */
	     end;					/* done with cleaning up interrupted stat rewrite */
	else if record_action = insert_action
	then if ^file_base.was_stat			/* non-stationary record */
	     then do;				/* requires smaller block header in this case */
		     header_size = 2;		/* block size and record length words */
		     call set_required_block_size;
		     call allocate;			/* finds available block of sufficient size */
		end;
	     else do;				/* make a new stationary record */
		     header_size = stat_header_size;	/* reserve space for lock and counts */
		     call set_required_block_size;
		     call allocate;
		     if ^indx_cb.repeating		/* non-recovery execution */
		     then do;			/* mark record as such */
			     stat_block.ref_count = file_base.old_ref_count;
						/* for initial key or ref count in record_status */
			     block_head.stationary = "1"b;
						/* keeps descriptor valid during rewrites */
			     if file_base.was_transaction
			     then do;
				     stat_block.ref_count_after = file_base.old_ref_count;
				     stat_block.ind_comp = new_rec_des.comp_num;
				     time_stamp_struct.ind_offset = new_rec_des.offset;
				     stat_block.prev_mod = -3;
						/* signifies pre-creation */
				end;
			     else stat_block.time_stamp_words = clock ();
			end;
		end;
	else do;
		call find_old_block;
		if record_action = delete_action
		then if ^file_base.was_stat
		     then call free;		/* completely dispose of record allocation */
		     else do;			/* logically delete the record, but leave around until ref_count diminishes */
			     if ^file_base.is_partial_deletion & ^file_base.out_of_index
						/* key also deleted */
			     then do;
				     new_count = file_base.old_ref_count - 1;
						/* will decrement for
						   deleted key pointing to this record */
				     if ^indx_cb.repeating
						/* protect during recovery */
				     then ind_head.ref_count = new_count;
				end;
			     else new_count = file_base.old_ref_count;
						/* count stays the same */
			     if ^indx_cb.repeating	/* not recovery case */
			     then do;		/* otherwise allocation is protected */
				     block_head.after_applies = "1"b;
				     time_stamp_struct.time_last_modified = clock ();
				     ind_head.prev_desc = -1;
						/* stands for logical deletion */
				     ind_head.prev_mod = file_base.old_modifier;
				     block_head.indirect = "1"b;
				     block_head.after_applies = "0"b;
				end;
			     if file_base.was_ind	/* already in indirect form */
			     then do;		/* dispose of indirect allocation, if any */
				     if file_base.old_ind_desc > 0
						/* additional block does exist */
				     then do;
					     call find_old_ind_block;
					     call free;
					     os_ptr -> number_of_allocated_records = number_of_allocated_records;
						/* don't count ind block as separate */
					end;
				     if new_count <= 0
						/* no more references to this record */
				     then do;	/* dispose of entirely */
					     call find_old_block;
						/* locate fixed portion */
					     call free;
						/* garbage collect */
					end;
				     else os_ptr -> number_of_allocated_records = number_of_allocated_records;
				end;
			     else if new_count <= 0	/* no more references to this compact stat record */
			     then call free;	/* can completely dispose of */
			     else do;		/* logically delete a compact stationary record */
				     required_block_size = minimum_block_size;
				     residue = file_base.prior_block_size - minimum_block_size;
				     go to check_tail;
				end;
			end;
		else do;				/* replace action */
						/* replace the current record image, using
						   buffer pointed to by buff_ptr arg
						   for the case of non-stationary records */
			if ^file_base.was_stat	/* non-stationary type record */
			then do;			/* rewrite a movable record */
				header_size = 2;
				call set_required_block_size;
				residue = prior_block_size - required_block_size;
				if residue < 0
				then do;		/* get a new block */
					call allocate;
					call find_old_block;
						/* restore former location */
					call free;
				     end;
				else do;		/* use old block */
					new_descriptor = old_record_designator;
					block_head.lock_flag = "1"b;
						/* in case of record level synch */
					call copy_buffer;
						/* must do before touching residue */
check_tail:
					if residue >= minimum_block_size
					then do;	/* use first part of block and free residual space */
						if ^indx_cb.repeating
						/* not recovery case */
						then do;
						/* otherwise protect block header */
							block_head.block_size = required_block_size;
						/* make residue allocated block and free it */
							block_offset = block_offset + required_block_size;
							seg_array (block_offset) = 0;
						/* clear flags and first word stuff */
							block_head.block_size = residue;
						     end;
						/* this can't be repeated since the
						   free logic is not repeatable, and it
						   involves subsequent changes to these same
						   locations; i.e. we must consistently
						   protect these values, since we have
						   chosen not to reconstruct them during
						   recovery execution */
						else block_offset = block_offset + required_block_size;
						call free;
					     end;
				     end;
			     end;			/* end of non-stat rewrite case */

			else /* rewrite a stationary record */
			     /* replace the current image with that pointed
						   to by new_descriptor */
			     if file_base.was_transaction
						/* transaction */
			then if (^file_base.was_ind) & (file_base.old_prev_mod = -3)
						/* compact, pre-created record */
			     then go to compact_case; /* replace after image in compact tail */
			     else do;		/* replace new indirect image */
				     call find_old_ind_block;
						/* locate old new contents */
				     call free;	/* dispose of previous after-image */
				end;
			else if file_base.was_ind	/* indirect record */
			then do;
				block_head.after_applies = "1"b;
				time_stamp_struct.time_last_modified = clock ();
				ind_head.prev_mod = file_base.old_modifier;
				ind_head.prev_desc = file_base.new_descriptor;
				block_head.after_applies = "0"b;
				if file_base.old_ind_desc ^= 0
						/* old block existed */
				then do;		/* dispose of old indirect block */
					call find_old_ind_block;
					call free;/* de-allocates */
				     end;
			     end;			/* end of indirect record rewrite logic */
			else do;			/* rewrite compact stationary type record */
compact_case:
				if file_base.new_descriptor > 0
				then do;
					block_ptr = addr (seg_array (block_offset));
					record_ptr = addr (seg_array (block_offset + stat_header_size - 1));
					call find_new_ind_block;
						/* after image */
					call save_needed_blksz;
					required_block_size = file_base.needed_blksz;
					if (file_base.prior_block_size
					     >= required_block_size /* old alloc big enough */)
					then do;	/* copy back into initial block */
						if ^indx_cb.repeating
						then if file_base.was_transaction
						     then do;
						/* replace compact after image */
							     record_head.record_length =
								file_base.new_record_length;
							     record_head.record =
								addr (seg_array (block_offset + 1))
								-> record_head.record;
							end;
						     else do;
						/* non-TP case */
							     block_ptr -> block_head.after_applies = "1"b;
							     addr (block_ptr -> stat_block.time_stamp_words)
								-> time_stamp_struct.time_last_modified =
								clock ();
							     record_head.record_length =
								file_base.new_record_length;
							     record_head.record =
								addr (seg_array (block_offset + 1))
								-> record_head.record;
						/* copy back into old */
							     block_ptr -> stat_block.prev_mod =
								file_base.old_modifier;
							     block_ptr -> block_head.after_applies = "0"b;
							     addr (block_ptr -> stat_block.time_stamp_words)
								-> time_stamp_struct.time_last_modified =
								clock ();
							end;
						call free;
						/* deallocate after image */
						call find_old_block;
						/* back to header */
						residue = file_base.prior_block_size - required_block_size;
						go to check_tail;
						/* see how much extra */
					     end; /* record left in compact form */
					else call find_old_block;
						/* back to header */
				     end;
						/* convert compact record into
						   indirect form */
				if file_base.was_transaction
				then do;		/* replace after image under TP */
						/* record was created in this
						   transaction, and is being
						   subsequently rewritten, deleted,
						   or rolled back */
					ind_head.prev_desc = -1;
					block_head.indirect = "1"b;
				     end;
				else do;		/* called by rewrite or checkpoint  logic */
					block_head.after_applies = "1"b;
					time_stamp_struct.time_last_modified = clock ();
					ind_head.prev_desc = file_base.new_descriptor;
					block_head.indirect = "1"b;
					stat_block.prev_mod = file_base.old_modifier;
					block_head.after_applies = "0"b;
				     end;
				required_block_size = minimum_block_size;
				residue = file_base.prior_block_size - minimum_block_size;
						/* tail of init block */
				go to check_tail;	/* free tail, if large enough */
			     end;
			os_ptr -> number_of_allocated_records = number_of_allocated_records;
		     end;
	     end;
	os_ptr -> number_of_free_blocks = number_of_free_blocks;
	return;					/* end main code */

find_old_block:
     proc;					/* locate previously existing record */
	comp_num = old_rec_des.comp_num;
	seg_ptr = seg_ptr_array (comp_num);
	block_offset = fixed (old_rec_des.offset, 18);
     end find_old_block;

find_new_ind_block:
     proc;					/* locates newly allocated image block */
	comp_num = new_rec_des.comp_num;		/* locate the new allocation */
	block_offset = fixed (new_rec_des.offset, 18);
	seg_ptr = seg_ptr_array (comp_num);		/* logic of rewrite guarantees
						   that this comp is initiated */
     end find_new_ind_block;

find_old_ind_block:
     proc;					/* finds old indirect allocation */
	comp_num = old_ind_des.comp_num;
	seg_ptr = seg_ptr_array (comp_num);
	block_offset = fixed (old_ind_des.offset, 18);
     end find_old_ind_block;

set_required_block_size:
     proc;
	min_recl = max (file_base.saved_min_cap, new_record_length + file_base.saved_min_res);
	needed_block_size = header_size + 2 * divide (min_recl + 7, 8, 18, 0);
	required_block_size = max (minimum_block_size, needed_block_size);
     end set_required_block_size;

save_needed_blksz:
     proc;
	if indx_cb.repeating
	then do;
		call check_file_substate;
		return;
	     end;
	file_base.needed_blksz =
	     6 + addr (seg_array (block_offset)) -> block_head.block_size
	     - addr (seg_array (block_offset)) -> block_head.excess_words;
						/* enforce min block size */
	file_substate = file_substate + 1;
     end save_needed_blksz;

allocate:
     proc;					/* grabs a block of space from the free list */
	call find_free_block;
	if need_new_seg
	then do;
		call use_new_segment;		/* creates new component if necessary */
		if indx_cb.repeating		/* recovery in progress */
		then return;			/* protect permanent file variables */
	     end;
	else do;					/* allocate block of space in existing segment */
		rover_seg_ptr = seg_ptr;
		old_rover_comp_num = comp_num;
		if indx_cb.repeating
		then return;			/* protect state during recovery execution */
		rover_comp_num = comp_num;
		is_this_block_free = "0"b;
		if residue < minimum_block_size
		then call allocate_whole_block;
		else call allocate_part_block;	/* frees the residue */
	     end;
	os_ptr -> number_of_allocated_records = number_of_allocated_records + 1;

copy_buffer:
     entry;					/* does the assignment of the record's contents */
	block_offset = fixed (new_rec_des.offset);	/* locate allocated record block */
	record_ptr = addr (seg_array (block_offset + header_size - 1));
	record_head.record_length = new_record_length;	/* set len in block header */
	if buff_ptr ^= null
	then record_head.record = buffer;		/* does the assignment */
	else if block_head.block_size > header_size	/* room for record contents */
	then do;					/* just zero first and last words, in case non-zero */
		seg_array (block_offset + header_size) = 0;
						/* free list thread word */
		seg_array (block_offset + block_head.block_size - 1) = 0;
						/* free block size tail word */
	     end;
	return;					/* end of allocate code */

find_free_block:
     proc;					/* searches free list for block of sufficient size */
	if repeating
	then do;					/* restore non-permanent vars and skip search */
		call check_file_substate;
		comp_num = new_rec_des.comp_num;
		block_offset = fixed (new_rec_des.offset);
		residue = old_residue;
		seg_ptr = get_seg_ptr (iocb_ptr, comp_num);
		return;
	     end;
	need_new_seg = "0"b;			/* will be set if no adequate block */
	seg_ptr = rover_seg_ptr;
	comp_num = rover_comp_num;
	block_offset = rover_offset;
	file_base.old_number_of_free_blocks = number_of_free_blocks;
	search_not_done = "1"b;
	do while (search_not_done);			/* look for suitable block */
	     if block_offset = 0			/* indicates segment is full */
	     then do;				/* try another component */
		     comp_num = comp_link (comp_num);
		     block_offset = init_offset (comp_num);
		     seg_ptr = get_seg_ptr (iocb_ptr, comp_num);
		     go to check_rover;		/* give up search if at starting point */
		end;
	     else do;				/* check this block's size */
		     block_offset = non_neg (block_offset);
		     residue = block_head.block_size - required_block_size;
		     if residue >= 0
		     then do;			/* satisfactory block found */
			     new_rec_des.comp_num = comp_num;
			     new_rec_des.offset = bit (block_offset);
			     old_prev_free_block = prev_free_block;
						/* save for recovery */
			     old_next_free_block = next_free_block;
			     old_residue = residue;
			     search_not_done = "0"b;
			end;
		     else do;			/* block too small -- try next on list */
			     block_offset = next_free_block;
check_rover:
			     if block_offset = rover_offset
			     then if comp_num = rover_comp_num
				then do;		/* back at start--search failed */
					new_rec_des.comp_num = last_comp_num + 1;
					new_rec_des.offset = "0"b;
					need_new_seg = "1"b;
					search_not_done = "0"b;
				     end;
			end;
		end;
	end;
	file_substate = file_substate + 1;
	dcl     search_not_done	 bit (1) aligned;
     end find_free_block;

use_new_segment:
     proc;					/* finds new component and allocates record block */
	comp_num = new_rec_des.comp_num;
	call get_new_seg (iocb_ptr, comp_num, seg_ptr, file_substate, abort_exit);
	block_offset = 0;
	old_rover_comp_num = comp_num;
	rover_seg_ptr = seg_ptr;
	call set_new_comp_link;
	if indx_cb.repeating			/* recovery case */
	then return;				/* protect state */
	comp_link (0) = comp_num;
	residue = max_seg_limit - required_block_size - block_offset;
	if residue < minimum_block_size		/* use whole seg */
	then do;
		block_head.block_size = max_seg_limit;	/* whole segment is allocated block */
		seg_limit (comp_num) = max_seg_limit;
		init_offset (comp_num) = 0;
		rover_offset = 0;
	     end;
	else do;
		block_head.block_size = required_block_size;
		block_offset = required_block_size + block_offset;
		is_preceding_block_free = "0"b;
		is_this_block_free = "1"b;
		block_head.block_size = residue;
		next_free_block = 0;
		prev_free_block = 0;
		init_offset (comp_num) = block_offset;
		rover_offset = block_offset;
		seg_limit (comp_num) = block_offset + size (block_head);
		number_of_free_blocks = old_number_of_free_blocks + 1;
	     end;
     end use_new_segment;

set_new_comp_link:
     proc;
	if repeating
	then do;
		call check_file_substate;
		return;
	     end;
	is_preceding_block_free = "0"b;
	is_this_block_free = "0"b;
	rover_comp_num = comp_num;
	comp_link (comp_num) = comp_link (0);
	file_substate = file_substate + 1;
     end;

allocate_whole_block:
     proc;					/* uses entire block for new record */
	rover_offset = old_next_free_block;
	if old_prev_free_block ^= 0
	then addr (seg_array (non_neg (old_prev_free_block))) -> next_free_block = old_next_free_block;
	else init_offset (comp_num) = old_next_free_block;
	if old_next_free_block ^= 0
	then addr (seg_array (non_neg (old_next_free_block))) -> prev_free_block = old_prev_free_block;
	following_block_offset = block_offset + block_head.block_size;
	if following_block_offset = max_seg_limit
	then seg_limit (comp_num) = max_seg_limit;	/* allocating last block in segment */
	else addr (seg_array (following_block_offset)) -> is_preceding_block_free = "0"b;
						/* set block end */
	number_of_free_blocks = old_number_of_free_blocks - 1;
     end allocate_whole_block;

allocate_part_block:
     proc;					/* allocates first part and frees the residual space */
	residue_offset = block_offset + required_block_size;
	rover_offset = residue_offset;
						/* Set links in residue and free block list */
	if old_prev_free_block ^= 0
	then addr (seg_array (non_neg (old_prev_free_block))) -> next_free_block = residue_offset;
	else init_offset (comp_num) = residue_offset;
	if old_next_free_block ^= 0
	then addr (seg_array (non_neg (old_next_free_block))) -> prev_free_block = residue_offset;
	addr (seg_array (residue_offset)) -> prev_free_block = old_prev_free_block;
	addr (seg_array (residue_offset)) -> next_free_block = old_next_free_block;
	block_head.block_size = required_block_size;
						/* set header info for residue of block */
	block_offset = residue_offset;
	is_preceding_block_free = "0"b;
	is_this_block_free = "1"b;
	block_head.block_size = residue;
						/* set block end */
	following_block_offset = block_offset + residue;
	if following_block_offset = max_seg_limit
	then seg_limit (comp_num) = block_offset + size (block_head);
	else seg_array (following_block_offset - 1) = residue;
     end allocate_part_block;

	dcl     residue		 fixed (19);
	dcl     residue_offset	 fixed (18);
     end allocate;

free:
     proc;					/* places new block onto the free list */
	call save_old_vars;
	call make_free;				/* does the work in protected procedure--in case called twice */
	return;					/* end of free routine */

make_free:
     proc;
	if repeating
	then do;
		call check_file_substate;
		return;
	     end;
	if prec_block_was_free
	then call merge_preceding_block;
	else call free_this_block;
	if following_block_offset = max_seg_limit
	then seg_limit (comp_num) = block_offset + size (block_head);
						/* last block in segment--set new seg_limit */
	else do;					/* take care of next block */
		p = addr (seg_array (following_block_offset));
		if next_block_was_free
		then call merge_next_block;
		else do;				/* set next block's prior block info */
			p -> is_preceding_block_free = "1"b;
			seg_array (following_block_offset - 1) = former_block_size;
		     end;
	     end;
	number_of_free_blocks = old_num_free + 1 - times_merged;
	os_ptr -> number_of_allocated_records = number_of_allocated_records - 1;
	file_substate = file_substate + 1;
     end make_free;

save_old_vars:
     proc;					/* sets permanent block info for crash recovery */
	if repeating
	then do;
		call check_file_substate;
		return;
	     end;
	old_init_offset = init_offset (comp_num);
	old_block_size = block_head.block_size;
	prec_block_was_free = is_preceding_block_free;
	old_num_free = number_of_free_blocks;
	former_rover_comp_num = rover_comp_num;
	former_rover_offset = rover_offset;
	if prec_block_was_free
	then do;
		prev_block_size = seg_array (block_offset - 1);
		former_block_size = prev_block_size + old_block_size;
	     end;
	else former_block_size = old_block_size;
	following_block_offset = block_offset + old_block_size;
	if following_block_offset < max_seg_limit
	then do;
		p = addr (seg_array (following_block_offset));
						/* p-> next block */
		next_block_size = p -> block_head.block_size;
		next_next_free_block = p -> next_free_block;
		next_block_was_free = p -> is_this_block_free;
		if (following_block_offset = old_init_offset) & ^prec_block_was_free
		then next_prev_free_block = non_zero (block_offset);
						/* thread will be changed */
		else next_prev_free_block = p -> prev_free_block;
						/* usual case */
	     end;
	file_substate = file_substate + 1;
     end save_old_vars;

merge_preceding_block:
     proc;					/* combines new block with preceding free block */
	times_merged = 1;
	old_block_offset = block_offset;
	block_offset = old_block_offset - prev_block_size;
	call zero_words (addr (seg_array (old_block_offset - 1)), 1 + old_block_size);
	block_head.block_size = prev_block_size + old_block_size;
						/* combined size */
	following_block_offset = block_offset + block_head.block_size;
     end merge_preceding_block;

free_this_block:
     proc;					/* puts new block onto the free list */
	times_merged = 0;
	next_free_block = old_init_offset;
	prev_free_block = 0;
	nzbo = non_zero (block_offset);
	init_offset (comp_num) = nzbo;
	if next_free_block ^= 0
	then addr (seg_array (non_neg (next_free_block))) -> prev_free_block = nzbo;
	is_this_block_free = "1"b;
	unspec (block_head.flags) = "0"b;
	call zero_words (addr (seg_array (block_offset + size (block_head))), old_block_size - size (block_head));
	following_block_offset = block_offset + old_block_size;
	return;
	dcl     nzbo		 fixed (18) unsigned;
     end free_this_block;

merge_next_block:
     proc;					/* combines new block with following free block */
	times_merged = times_merged + 1;
	block_head.block_size = former_block_size + next_block_size;
						/* Adjust links to-from removed block */
	if next_prev_free_block ^= 0
	then addr (seg_array (non_neg (next_prev_free_block))) -> next_free_block = next_next_free_block;
	else init_offset (comp_num) = next_next_free_block;
	if next_next_free_block ^= 0
	then addr (seg_array (non_neg (next_next_free_block))) -> prev_free_block = next_prev_free_block;
						/* Adjust rover if it designates block being removed from free list */
	if following_block_offset = former_rover_offset
	then if comp_num = former_rover_comp_num
	     then rover_offset = non_zero (block_offset);
						/* Set end of merged block */
	if (following_block_offset + next_block_size) = max_seg_limit
	then do;					/* merged block is last in seg */
		call zero_words (p, size (block_head));
		seg_limit (comp_num) = block_offset + size (block_head);
	     end;
	else do;
		call zero_words (p, next_block_size - 1);
		seg_array (block_offset + block_head.block_size - 1) = block_head.block_size;
	     end;
	return;
     end merge_next_block;

	dcl     p			 ptr;
	dcl     times_merged	 fixed;
	dcl     old_block_offset	 fixed (18);
     end free;

non_neg:
     proc (offset) returns (fixed (18));
	if offset = 262143				/* 2**18 - 1 */
	then return (0);				/* stands for offset 0 */
	return (offset);
	dcl     offset		 fixed (18);
     end non_neg;

non_zero:
     proc (offset) returns (fixed (18));
	if offset = 0
	then return (262143);
	return (offset);
	dcl     offset		 fixed (18);
     end non_zero;

zero_words:
     proc (p, n);
	if n > 0
	then unspec (words) = "0"b;
	return;

	dcl     words		 (n) fixed based (p);
	dcl     p			 ptr;
	dcl     n			 fixed (19);
     end;						/* end zero words */

check_file_substate:
     proc;
	next_substate = next_substate + 1;
	if file_substate = next_substate
	then repeating = "0"b;			/* execution resumes normally */
     end check_file_substate;

/* Declarations */
	dcl     new_count		 fixed (34);
	dcl     os_ptr		 ptr;
	dcl     buff_ptr		 ptr;
	dcl     buffer		 char (new_record_length) based (buff_ptr);
	dcl     iocb_ptr		 ptr;
	dcl     record_action	 fixed;
	dcl     abort_exit		 label;
	dcl     pos_ptr		 ptr;		/* not used in this procedure */
	dcl     header_size		 fixed;
	dcl     min_recl		 fixed (21);
	dcl     block_ptr		 ptr;
	dcl     1 block_head	 based (addr (seg_array (block_offset))),
		2 is_preceding_block_free
				 bit (1) unal,
		2 is_this_block_free bit (1) unal,
		2 block_size	 fixed (19) unal,
		2 flags,
		  3 lock_flag	 bit (1) unal,
		  3 stationary	 bit (1) unal,
		  3 indirect	 bit (1) unal,
		  3 after_applies	 bit (1) unal,
		  3 pad		 bit (6) unal,
		  3 excess_words	 fixed (3) unal,	/* only used in indirect allocations */
		2 prev_free_block	 fixed (18) aligned,
		2 next_free_block	 fixed (18) aligned;
	dcl     1 stat_block	 based (addr (seg_array (block_offset))),
		2 pad		 bit (26) unal,
		2 ref_count_after	 fixed (15) unal,
		2 ind_comp	 fixed (13) unal,
		2 ref_count	 fixed (15) unal,
		2 record_lock	 bit (36) aligned,
		2 modifier	 fixed (35),
		2 time_stamp_words	 fixed (71) aligned,
		2 prev_mod	 fixed (35),
		2 record_length	 fixed (21),
		2 record		 char (0 refer (stat_block.record_length));
	dcl     1 ind_head		 based (addr (seg_array (block_offset))),
		2 pad		 bit (26) unal,
		2 ref_count_after	 fixed (15) unal,
		2 ind_comp	 fixed (13) unal,
		2 ref_count	 fixed (15) unal,
		2 record_lock	 bit (36) aligned,
		2 modifier	 fixed (35),
		2 time_stamp_words	 fixed (71) aligned,
		2 prev_mod	 fixed (35),
		2 prev_desc	 fixed (35);
	dcl     1 time_stamp_struct	 based (addr (stat_block.time_stamp_words)),
		2 ind_offset	 bit (18) unal,
		2 time_last_modified fixed (53) unal;
	dcl     record_ptr		 ptr;
	dcl     1 record_head	 based (record_ptr),
		2 record_length	 fixed (21) aligned,
		2 record		 char (0 refer (record_head.record_length));
	dcl     1 old_rec_des	 like designator_struct aligned based (addr (old_record_designator));
	dcl     1 old_ind_des	 like designator_struct aligned based (addr (file_base.old_ind_desc));
	dcl     1 new_rec_des	 like designator_struct aligned based (addr (new_descriptor));
	dcl     comp_num		 fixed;
	dcl     block_offset	 fixed (18);
	dcl     following_block_offset fixed (18);
	dcl     required_block_size	 fixed (19);
	dcl     residue		 fixed (19);

%include vfile_indx;
%include iocbv;
	dcl     clock		 builtin;
	dcl     needed_block_size	 fixed (19);
     end /* end change_record_list */;




		    check_file_version.pl1          10/16/90  1526.9rew 10/16/90  1518.0       77733



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






/****^  HISTORY COMMENTS:
  1) change(90-10-15,Zimmerman), approve(90-10-15,MCR8216),
     audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043):
     Increase maximum number of components in MSF to 1250.
                                                   END HISTORY COMMENTS */




check_file_version:
     proc (indx_cb_ptr, code);
	f_b_ptr = file_base_ptr;
	fs_ptr = file_state_ptr;
	code = 0;
	if file_version = file_version_MR2		/* original version */
	then do;
		old_file_state_ptr = addr (old_file_state_blocks (file_state));
		if old_f_s_block.file_action ^= 0	/* too bad--no crashproofing */
		then do;
			code = error_table_$bad_file; /* nothing can be done */
			call sub_err_ (code, "vfile_", "c", null, code,
			     "Old file is inconsistent because of interrupted update--this version does not support recovery from interruptions."
			     );
		     end;
	     end;
	else if file_version = file_version_MR3		/* MR3.0 version */
	then do;
		old_file_state_ptr = addr (v20_fs_blocks (file_state));
		if v20_fsb.file_action ^= 0		/* operation in progress */
		then do;
			code = error_table_$unimplemented_version;
						/* user must adjust with
						   version 20 vfile_ before transformation can occur */
			call sub_err_ (code, "vfile_", "c", null, code,
			     "Operation in progress--this file must be adjusted with the MR3 version of vfile_.");
		     end;
	     end;
	else if file_version = file_version_MR6
	then if (file_state_block.file_action = 0) | (file_state_block.file_action = read_exclude)
	     then ;				/* no operations in progress */
	     else do;				/* complain--must adjust with old version vfile_ first */
		     code = error_table_$unimplemented_version;
		     call sub_err_ (code, "vfile_", "c", null, code,
			"Operation in progress--this file must be adjusted with the MR6 version of vfile_.");
		end;
	else do;
		code = error_table_$bad_file;		/* unrecognizable version */
		call sub_err_ (code, "vfile_", "c", null, code, "Unrecognizable indexed file version number.");
	     end;
	if (code = 0) & ^is_read_only
	then do;					/* make the version transformation */
		if (program_version > 11) & (program_version < 23)
		then do;
			code = error_table_$unimplemented_version;
			call sub_err_ (code, "vfile_", "c", null, code,
			     "Old version file must be adjusted with MR6 version of vfile_ in order to fix bad header statistics caused by old bugs."
			     );
			return;
		     end;
		if file_version = file_version_MR2
		then do;
			call move_comp_info;
			call move_file_statis;
			call move_index_statis;
		     end;
		else if file_version = file_version_MR3
		then call move_v20_statis;
		file_version = file_version_MR6;
		call rebuild_comp_array;
		file_version = current_file_version;
	     end;
	return;					/* end of file version update routine */

rebuild_comp_array:
     proc;					/* repacks items in comp_array */
	comp_info_ptr = addr (file_base.max_comp_num);

	do while (y_count <= 2 * true_max_comp_num);	/* loop through array */
	     i = divide (y_count, 2, 17, 0);		/* current element number */
	     if 2 * i = y_count			/* first copy old values into safe location */
	     then do;
		     file_base.old_init_offset = comp_info.init_offset (i);
		     file_base.former_rover_comp_num = comp_info.comp_link (i);
						/* these are just convenient header slots for temporary use */
		end;
	     else do;				/* now copy from temp back into comp_array in new format */
		     comp_table.init_offset (i) = file_base.old_init_offset;
		     comp_table.comp_link (i) = file_base.former_rover_comp_num;
		end;
	     y_count = y_count + 1;
	end;					/* note each cycle is repeatable */

	dcl     i			 fixed;
     end rebuild_comp_array;

move_comp_info:
     proc;
	comp_info_ptr = addr (old_version_comp_info);

	do while (x_count <= true_max_comp_num);	/* if this loop is interrupted, x_count will keep track of progress */
	     n = true_max_comp_num - x_count;
	     addr (file_base.max_comp_num) -> comp_info.comp_table (n) = comp_info.comp_table (n);
	     x_count = x_count + 1;
	end;

	file_base.first_free_comp_num = 0;
	file_base.last_comp_num = comp_info.last_comp_num;
	file_base.max_comp_num = true_max_comp_num;
     end move_comp_info;

move_file_statis:
     proc;
	file_state_block.file_action = 0;
	file_state_block.number_of_records = old_f_s_block.number_of_records;
	file_state_block.total_key_length = old_f_s_block.total_key_length;
	file_state_block.total_record_length = old_f_s_block.total_record_length;
	record_state_ptr = addr (record_state_blocks (record_state));
	file_state_block.number_of_allocated_records = record_state_block.number_of_allocated_records;
	file_state_block.number_of_free_blocks = record_state_block.number_of_free_blocks;
	call set_default_stats;
     end move_file_statis;

move_index_statis:
     proc;
	index_state = 0;
	index_state_ptr = addr (index_state_blocks (0));
	is_ptr = index_state_ptr;
	number_of_nodes = old_version_number_of_nodes;
	free_node_designator = old_version_free_node_designator;
	index_tail_comp_num = old_version_index_tail_comp_num;
	index_height = old_version_index_height;
	n = node_head_length + branch_and_descrip_length + 1;
	new_key_pos = n;				/* usually set at file creation */
	addr (index_state_blocks (1)) -> new_key_pos = n;
     end move_index_statis;

move_v20_statis:
     proc;
	file_state_block.file_action = 0;
	file_state_block.number_of_records = v20_fsb.number_of_records;
	file_state_block.total_key_length = v20_fsb.total_key_length;
	file_state_block.total_record_length = v20_fsb.total_record_length;
	file_state_block.number_of_allocated_records = v20_fsb.number_of_allocated_records;
	file_state_block.number_of_free_blocks = v20_fsb.number_of_free_blocks;
	call set_default_stats;
     end move_v20_statis;

set_default_stats:
     proc;					/* used with old version indexed files */
	file_state_block.number_of_keys = file_state_block.number_of_records;
	file_state_block.duplicate_keys = 0;
	file_state_block.dup_key_bytes = 0;
     end set_default_stats;

	dcl     pos_ptr		 ptr;		/* not used by this proc */
	dcl     code		 fixed (35);
%include vfile_error_codes;
	dcl     current_file_version	 static fixed init (40);
	dcl     file_version_MR2	 static internal options (constant) init (10);
	dcl     file_version_MR3	 static internal options (constant) init (20);
	dcl     file_version_MR6	 static internal options (constant) init (30);
	dcl     node_head_length	 static fixed init (16);
	dcl     branch_and_descrip_length
				 static fixed init (12);
	dcl     n			 fixed;
	dcl     1 v20_file_header	 based (f_b_ptr),	/* MR3.0 version header */
		2 words		 (62) fixed,
		2 v20_fs_blocks	 (0:1),		/* file state blocks */
		  3 words		 (7) fixed;
	dcl     1 v20_fsb		 based (old_file_state_ptr),
						/* MR3.0 file state block */
		2 file_action	 fixed,
		2 file_substate	 fixed,
		2 number_of_records	 fixed (34),
		2 total_key_length	 fixed (34),
		2 total_record_length
				 fixed (34),
		2 number_of_allocated_records
				 fixed (34),
		2 number_of_free_blocks
				 fixed (34);
	dcl     record_state_ptr	 ptr;
	dcl     1 record_state_block	 based (record_state_ptr),
		2 words		 (2) fixed,
		2 number_of_free_blocks
				 fixed (34),
		2 number_of_allocated_records
				 fixed (34);

	dcl     old_file_state_ptr	 ptr;
	dcl     1 old_f_s_block	 based (old_file_state_ptr),
		2 file_action	 fixed,
		2 word		 fixed,
		2 number_of_records	 fixed (34),
		2 total_key_length	 fixed (34),
		2 total_record_length
				 fixed (34);

	dcl     comp_info_ptr	 ptr;
	dcl     1 comp_info		 based (comp_info_ptr),
		2 max_comp_num	 fixed,
		2 last_comp_num	 fixed,
		2 first_free_comp_num /* not supported--used for converting versions */,
		2 comp_table	 (0:true_max_comp_num) aligned,
		  3 seg_limit	 fixed (19),
		  3 comp_link	 fixed (15) unal,
		  3 init_offset	 fixed (18) unal;

%include vfile_indx;
	dcl     sub_err_		 entry options (variable);
     end check_file_version;




		    create_position_stack.pl1       11/04/82  1940.0rew 11/04/82  1620.7       33930



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


create_position_stack:
     proc (indx_cb_ptr);
	f_b_ptr = file_base_ptr;
	is_ptr = index_state_ptr;
	if file_version = 10			/* previous file version */
	then old_index_height = old_version_index_height;
	else old_index_height = index_height;
	position_stack_height = max (min_stack_height, old_index_height + 1);
	call alloc_cb_file (size (position_stack), position_stack_ptr);
	call chain_stack_frames;
	return;					/* end create_position_stack code */

extend_position_stack:
     entry;					/* This inserts a new position frame immediately below
						   the root. change_position_ptr is set to this new frame. The whole stack
						   may be reallocated. */
	f_b_ptr = file_base_ptr;
	is_ptr = index_state_ptr;
	change_position_ptr = root_position_ptr;
	if parent_position_ptr = null
	then do;					/* reallocate stack, get one more frame */
		old_stack_ptr = position_stack_ptr;
		old_stack_height = position_stack_height;
		position_stack_height = position_stack_height + 1;
		call alloc_cb_file (size (position_stack), position_stack_ptr);
		call chain_stack_frames;
		file_position_ptr = root_position_ptr;
		do i = 1 to old_stack_height;		/* copy old stack */
		     change_position_ptr = addr (position_stack (i));
		     old_frame_ptr = addr (old_stack (i));
		     node_ptr = old_frame_ptr -> node_ptr;
		     node = old_frame_ptr -> node;
		     if node = current_node
		     then file_position_ptr = change_position_ptr;
		     branch_num = old_frame_ptr -> branch_num;
		end;
		parent_position_ptr = addr (position_stack (position_stack_height));
		parent_position_ptr -> parent_position_ptr = null;
		parent_position_ptr -> son_position_ptr = change_position_ptr;
		call free_cb_file (size (old_stack), old_stack_ptr);
	     end;
						/* Set up new root frame */
	root_position_ptr = parent_position_ptr;
	root_position_ptr -> node_ptr = node_ptr;
	root_position_ptr -> node = node;
	root_position_ptr -> branch_num = 1;
	return;					/* end extend stack code */

free_position_stack:
     entry;
	call free_cb_file (size (position_stack), position_stack_ptr);
	return;

	dcl     1 position_stack	 (position_stack_height) based (position_stack_ptr),
		2 words		 (size (position_frame));
	dcl     1 old_stack		 (old_stack_height) based (old_stack_ptr),
		2 words		 (size (position_frame));
	dcl     pos_ptr		 ptr defined (change_position_ptr);
	dcl     sp		 ptr;
	dcl     old_frame_ptr	 ptr;
	dcl     old_stack_ptr	 ptr;
	dcl     old_stack_height	 fixed;
	dcl     i			 fixed;
	dcl     min_stack_height	 static fixed init (4);
						/* 1 would work */

chain_stack_frames:
     proc;
	sp = null;
	do i = 1 to position_stack_height;
	     change_position_ptr = addr (position_stack (i));
	     son_position_ptr = sp;
	     branch_num = 1;			/* clear upper half word */
	     if sp ^= null
	     then sp -> parent_position_ptr = change_position_ptr;
	     sp = change_position_ptr;
	     if i = old_index_height + 1
	     then do;				/* set_root position */
		     node_ptr = addr (root_node_block);
		     node = fixed (rel (node_ptr), 35);
		     root_position_ptr = change_position_ptr;
		end;
	end;
	parent_position_ptr = null;
	return;
     end;						/* end chain_stack_frames */

%include vfile_indx;
     end /* end create_position_stack */;




		    create_seg_ptrs.pl1             10/16/90  1526.9rew 10/16/90  1517.7      105804



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





/****^  HISTORY COMMENTS:
  1) change(90-10-12,Zimmerman), approve(90-10-12,MCR8216),
     audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043):
     Data_Mgt 63 (phx21194): Raise the max number of components in an MSF to
     1250.
                                                   END HISTORY COMMENTS */




/* Changed 6/13/77 for even-word aligned allocations to have
   correct max_record_size */
/*
Modified:
07/14/81 by Lindsey Spratt:  In get_seg_ptr, when closing the current fcb and
	  re-opening, set the fcbp in the attach block as well as the
	  fcb_ptr in the indx_cb, since the fcb may have moved.
	       Change from using the iocbv include file to the iocb.incl.pl1
	  include file.  This is necessary because the iocbv.incl.pl1
	  include file has been deleted from the system as obsolete.
11/16/82 by Lindsey Spratt:  Changed to extend the seg_ptr_array when an
	  attempt to get a seg_ptr for a compnum >= seg_ptr_array_limit is
	  made via the get_seg_ptr entry.
02/05/85 by Steve Herbst: Fixed $get_seg_ptr to reinitialize file information
	  when the file has been closed and reopened because
	  msf_manager_$get_ptr has failed. Fixes bug allowing KST overflow
	  to damage files.
*/

/* format: style2,ind3 */
create_seg_ptrs:
   proc (iocb_ptr);
      begin;
         indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
         f_b_ptr = file_base_ptr;
         if file_version = 10				/* previous file version */
         then
	  do;					/* use old version file base info */
	     comp_number = old_version_index_tail_comp_num;
	     comp_info_ptr = addr (old_version_comp_info);
	  end;
         else
	  do;
	     index_state_ptr = addr (index_state_blocks (index_state));
	     is_ptr = index_state_ptr;
	     comp_number = index_tail_comp_num;
	     comp_info_ptr = addr (file_base.max_comp_num);
	  end;
         seg_ptr_array_limit = comp_info.last_comp_num + 2; /* allow 2 for growth, note: this must
						   be large enough for alloc_cb_file */
         call alloc_cb_file (size (seg_ptr_array), seg_ptr_array_ptr);
         seg_ptr_array = null;
         seg_ptr_array (0) = f_b_ptr;
         do while (comp_number > 0);			/* initiate additional index components */
	  p = get_seg_ptr (iocb_ptr, comp_number);	/* sets value in seg_ptr_array */
	  if file_version <= 30			/* old version comp_table */
	  then comp_number = old_comp_info.comp_link (comp_number);
	  else comp_number = comp_info.comp_link (comp_number);
         end;
         node_length = 4 * node_size;
         half_node_length = 2 * node_size;
         if file_version >= 40			/* latest version doesn't waste first two words */
         then max_record_size = 4 * max_seg_limit - 8;	/* compare with seq files */
         else max_record_size = 4 * max_seg_limit - 16;
         rover_seg_ptr = get_seg_ptr (iocb_ptr, rover_comp_num);
         old_last_comp_num = comp_info.last_comp_num;
         old_rover_comp_num = rover_comp_num;
         return;

         dcl     comp_info_ptr	ptr;
         dcl     1 comp_info		based (comp_info_ptr),
	         2 max_comp_num	fixed,
	         2 last_comp_num	fixed,
	         2 first_free_comp_num
				fixed,
	         2 comp_table	(0:true_max_comp_num) aligned,
		 3 seg_limit	fixed (19),
		 3 comp_link	fixed (17) unal,
		 3 init_offset	fixed (18) unsigned unal;
         dcl     1 old_comp_info	based (comp_info_ptr),
	         2 max_comp_num	fixed,
	         2 last_comp_num	fixed,
	         2 first_free_comp_num /* not supported--used for converting versions */,
	         2 comp_table	(0:true_max_comp_num),
		 3 seg_limit	fixed (19),
		 3 comp_link	fixed (15) unal,
		 3 init_offset	fixed (18) unal;
      end;					/* end of create_seg_ptrs routine */

free_seg_ptrs:
   entry (iocb_ptr);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      call free_cb_file (size (seg_ptr_array), seg_ptr_array_ptr);
      return;

get_new_seg:
   entry (iocb_ptr, comp_num, seg_ptr, substate_arg, abort_exit);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      f_b_ptr = file_base_ptr;
      fs_ptr = file_state_ptr;			/* not yet supported
						   if first_free_comp_num^=0 then do; use existing component
						   comp_num=first_free_comp_num;
						   first_free_comp_num=comp_link(comp_num);
						   call msf_manager_$get_ptr(fcb_ptr,comp_num,"0"b,seg_ptr,foo24,foo);
						   seg_ptr_array(comp_num)=seg_ptr;
						   end;
						   */
						/* else */
      do;						/* create new component */
         if comp_num >= max_comp_num
         then if max_comp_num < true_max_comp_num
              then max_comp_num = true_max_comp_num;
              else go to abort_exit;
         if comp_num >= seg_ptr_array_limit
         then call extend_seg_ptr_array (1);
         last_comp_num = comp_num;
         call adjust_if_nec;
         call set_new_ptr;
         old_last_comp_num = last_comp_num;
      end;
      return;					/* end get new seg */

/* not yet supported
   free_seg:entry(iocb_ptr,comp_num,seg_ptr); the segment must already be zeroed
   indx_cb_ptr=iocb_ptr->iocb.open_data_ptr;
   f_b_ptr=file_base_ptr;
   seg_ptr_array(comp_num)=null;
   call hcs_$set_bc_seg(seg_ptr,0,foo);
   seg_limit(comp_num)=0;
   comp_link(comp_num)=first_free_comp_num;
   first_free_comp_num=comp_num;
   return;
   */

adjust_if_nec:
   proc;
      if repeating
      then
         do;
	  call check_substate;
	  if substate_arg = next_substate
	  then call msf_manager_$adjust (fcb_ptr, comp_num - 1, foo24, "000"b, foo);
	  return;
         end;
      substate_arg = substate_arg + 1;
   end adjust_if_nec;

set_new_ptr:
   proc;
      if repeating
      then
         do;
	  call check_substate;
	  seg_ptr = get_seg_ptr (iocb_ptr, comp_num);
	  return;
         end;
      call msf_manager_$get_ptr (fcb_ptr, comp_num, "1"b, seg_ptr, foo24, foo);
      if seg_ptr = null				/* unable to get new component */
      then
         do;
	  if foo ^= 0
	  then call sub_err_ (foo, "vfile_", "c", null, foo, "Unable to create a new msf component.");
	  return;
         end;
      seg_ptr_array (comp_num) = seg_ptr;
      substate_arg = substate_arg + 1;
   end set_new_ptr;

check_substate:
   proc;
      next_substate = next_substate + 1;
      if substate_arg = next_substate
      then repeating = "0"b;				/* execution resumes normally */
   end check_substate;

set_bitcounts:
   entry (iocb_ptr);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      f_b_ptr = file_base_ptr;
      do i = 0 to last_comp_num;
         if seg_limit (i) > 0
         then
	  do;
	     if seg_ptr_array (i) = null
	     then call msf_manager_$get_ptr (fcb_ptr, i, "0"b, seg_ptr_array (i), foo24, foo);
	     call hcs_$set_bc_seg (seg_ptr_array (i), 36 * seg_limit (i), foo);
	     if foo = 0
	     then seg_limit (i) = -seg_limit (i);
	  end;
      end;
      return;					/* end set_bitcounts code */

get_seg_ptr:
   entry (iocb_ptr, comp_num) returns (ptr);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      if comp_num >= seg_ptr_array_limit
      then call extend_seg_ptr_array (comp_num - seg_ptr_array_limit + 1);
      if seg_ptr_array (comp_num) = null
      then
         do;
	  call msf_manager_$get_ptr (fcb_ptr, comp_num, "0"b, p, foo24, foo);
	  if p = null				/* unexpected failure */
	  then if atb.shared			/* maybe due to an asynch change */
	       then
		do;				/* in case msf_manager_ bug has struck */
		   call msf_manager_$close (indx_cb.fcb_ptr);
						/*
						   try closing and reopening msf */
		   call
		      msf_manager_$open (substr (attach_descrip_string, 8, dname_len),
		      substr (attach_descrip_string, 9 + dname_len, ename_len), indx_cb.fcb_ptr, foo);
		   iocb_ptr -> iocb.attach_data_ptr -> atb.fcbp = indx_cb.fcb_ptr;
						/* The fcb may have moved */
						/* between closing and opening,*/
						/* so the attach_block ptr must be updated.*/
		   seg_ptr_array (*) = null;		/* reinitialize file info */
		   call msf_manager_$get_ptr (indx_cb.fcb_ptr, 0, "0"b, seg_ptr_array (0), foo24, foo);
		   indx_cb.file_base_ptr = seg_ptr_array (0);
		   iocb_ptr -> iocb.attach_data_ptr -> atb.fsp = seg_ptr_array (0);

		   call msf_manager_$get_ptr (indx_cb.fcb_ptr, comp_num, "0"b, p, foo24, foo);
						/* try one more time */
		end;
	  if (p = null) & (foo ^= 0) then do;
	       if (true_max_comp_num > comp_num) & (foo = error_table_$noentry) then;   /* Do nothing: this file has hit limit before, */
	       else                                                                     /* but can now be extended.  */
		  call sub_err_ (foo, "vfile_", "c", null, foo, "Can't get a pointer to this msf component.");
	  end;
	  
	  else seg_ptr_array (comp_num) = p;
         end;
      return (seg_ptr_array (comp_num));		/* end get_seg_ptr */

make_designator:
   entry (comp_num, offset, designator);
      designator_struct.comp_num = comp_num;
      designator_struct.offset = bit (offset);
      return;					/* end make designator */

extend_seg_ptr_array:
   proc (p_number_of_new_components);
      dcl	    p_number_of_new_components
			       fixed bin;
      dcl	    comp_idx	       fixed bin;
      old_array_limit = seg_ptr_array_limit;
      old_array_ptr = seg_ptr_array_ptr;
      seg_ptr_array_limit = seg_ptr_array_limit + p_number_of_new_components;
      call alloc_cb_file (size (seg_ptr_array), seg_ptr_array_ptr);
      do comp_idx = 0 to old_array_limit;
         seg_ptr_array (comp_idx) = old_array (comp_idx);
      end;
      do comp_idx = old_array_limit + 1 to seg_ptr_array_limit;
         seg_ptr_array (comp_idx) = null;
      end;
      call free_cb_file (size (old_array), old_array_ptr);
      return;

      dcl	    old_array_limit	       fixed;
      dcl	    old_array_ptr	       ptr;
      dcl	    old_array	       (0:old_array_limit) ptr based (old_array_ptr);
   end;						/* end extend_seg_ptrs */

      dcl	    substate_arg	       fixed;
      dcl	    (comp_num, comp_number)
			       fixed;
      dcl	    p		       ptr;
      dcl	    i		       fixed;
      dcl	    foo		       fixed (35);
      dcl	    foo24		       fixed (24);
      dcl	    offset	       fixed (18);
      dcl	    abort_exit	       label;

      dcl	    pos_ptr	       ptr defined (file_position_ptr);
						/* not used in this module */

      dcl	    hcs_$set_bc_seg	       entry (ptr,		/* pointer to seg, input */
			       fixed bin (24),	/* bit count to be set */
			       fixed bin (35));	/* status code */
      dcl	    sub_err_	       entry options (variable);
      dcl	    msf_manager_$close     entry (ptr);
      dcl	    msf_manager_$open      entry (char (*), char (*), ptr, fixed (35));
      dcl	    msf_manager_$get_ptr   entry (ptr,		/* fcb_ptr */
			       fixed bin,		/* component number of desired segment */
			       bit (1),		/* create switch */
			       ptr,		/* ptr to seg or null if error, output */
			       fixed bin (24),	/* bitcount of segment, output */
			       fixed bin (35));	/* status code */
      dcl	    msf_manager_$adjust    entry (ptr, fixed, fixed (24), bit (3), fixed (35));
      dcl     error_table_$noentry  fixed bin(35) ext static;
   
%include vfile_indx;
%include iocb;
%include vf_attach_block;
      dcl	    iocb_ptr	       ptr;
   end /* end create_seg_ptrs */;




		    delete_old_subsets.pl1          11/04/82  1940.0rew 11/04/82  1620.7       31014



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


/* format: style2 */
delete_old_subsets:
     proc (p_iocb_ptr);

/* START OF DECLARATIONS */
/* Parameter */

	dcl     p_iocb_ptr		 ptr;

/* Automatic */

	dcl     attach_descrip	 char (256) varying;
	dcl     mode		 fixed bin;
	dcl     fcb_ptr		 ptr;
	dcl     code		 fixed bin (35);
	dcl     pos_ptr		 ptr;
	dcl     iocb_ptr		 ptr;
	dcl     dname		 char (168);
	dcl     ename		 char (32);

/* Based */
/* Builtin */
/* Controlled */
/* Constant */

	dcl     SET_BC_AND_TRUNCATE	 init ("110"b) bit (3) internal static options (constant);
	dcl     myname		 init ("vfile_") char (6) internal static options (constant);
	dcl     PATHNAME_START	 init (8) fixed bin internal static options (constant);

/* Entry */

	dcl     msf_manager_$adjust	 entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35));
	dcl     msf_manager_$open	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     msf_manager_$close	 entry (ptr);
	dcl     sub_err_		 entry options (variable);

/* External */
/* END OF DECLARATIONS */

	iocb_ptr = null;
	indx_cb_ptr = p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.open_data_ptr;
	attach_descrip = p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.attach_descrip_string;

	dname =
	     substr (attach_descrip, PATHNAME_START,
	     p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.dname_len);
	ename =
	     substr (attach_descrip,
	     PATHNAME_START + p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.dname_len + 1,
	     p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.ename_len);
	mode = p_iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr -> atb.opening_mode;

	call iox_$close (p_iocb_ptr, code);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to close the temporary for subsets.");

	call iox_$detach_iocb (p_iocb_ptr, code);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to detach the switch for subsets.");


	call msf_manager_$open (dname, ename, fcb_ptr, code);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to open the msf for temporary subsets.");

	call msf_manager_$adjust (fcb_ptr, 0, 0, SET_BC_AND_TRUNCATE, code);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to adjust the msf ofr temporary subsets.");

	call msf_manager_$close (fcb_ptr);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to close the msf ofr temporary subsets.");

	call iox_$attach_ptr (p_iocb_ptr, (attach_descrip), null, code);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to attach the temporary subset vfile_.");

	call iox_$open (p_iocb_ptr, mode, "0"b, code);
	if code ^= 0
	then call sub_err_ (code, myname, "s", null, 0, "Unable to open the temporary subset vfile_.");

	return;

%include iocb;
%include iox_dcls;
%include vfile_indx;
%include vf_attach_block;
     end delete_old_subsets;




		    fast_put.alm                    11/04/82  1940.0rew 11/04/82  1633.0       18531



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

"fast_put: proc(iocb_ptr,buff_ptr,buff_len,code);
	name	fast_put
	segdef	fast_put
fast_put:	epp1	pr0|2,*		pr1 gets addr of first arg
	epp1	pr1|0,*		pr1->iocb
	epp1	pr1|open_data_ptr,*	pr1->cb_uns_file

"len=max(buff_len,0);
	ldq	pr0|6,*		q gets arg2
	tpl	2,ic		done if buff_len is > 0
	ldq	0,dl		else set len to zero

"cb_uns_file.write_pos=cb_uns_file.write_pos+len;
	lda	pr1|write_pos	save old value of write pos
	sta	pr0|8,*		use last arg for temp
	asq	pr1|write_pos	advance write position

"if write_pos<=cb_uns_file.write_limit then do;
	lda	pr1|write_pos	a gets new write pos
	cmpa	pr1|write_limit	write_pos::write_limit
	tpnz	slow_put		exception--make external call

     "record_write=buffer;
	epp2	pr0|4,*		pr2 gets addr of buff_ptr arg
	epp2	pr2|0,*		pr2->buffer
	lda	pr0|8,*		get saved write position
	epp3	pr1|seg_ptr,*	pr3->segment base
	mlr	(pr,rl),(pr,rl,al),fill(040)  copy buffer into the file
	desc9a	pr2|0,ql		output buffer descrip
	desc9a	pr3|-1(3),ql	file position descrip

     "code=0. return, end;
	stz	pr0|8,*		arg4<--0
	short_return		done with put_chars operation

"write_pos=write_pos-len;
slow_put:	lda	pr0|8,*		a<--saved write position
	sta	pr1|write_pos	restores write pos to former value

"call open_uns_file$put_chars_uns_file(iocb_ptr,buff_ptr,buff_len,code);
	fld	4*2048,dl		set up arg count for external call
	callsp	<open_uns_file>|[put_chars_uns_file] handles exceptional cases
	short_return

"declarations:
	equ	open_data_ptr,18	in iocb
	equ	write_pos,10	in cb_uns_file
	equ	write_limit,2	     "
	equ	seg_ptr,0		     "
	end




		    find_key.alm                    11/04/82  1940.0rew 11/04/82  1633.0       52335



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

"find_key: proc(indx_cb_ptr,(key_ptr),search_code);
	name	find_key
	segdef	find_key
find_key:	epp1	pr0|2,*		pr1<-->indx_cb_ptr
	epp1	pr1|0,*		pr1<-->indx_cb
	epp2	pr1|file_position_ptr,*  pr2<-->position_frame
	epp5	pr2|node_ptr,*	pr5<-->node_block
	epp3	pr0|4,*		pr3<-->key_ptr
	epp3	pr3|0,*		pr3<-->key
	lxl5	pr3|0		x5<-length(key)

"q=branch(branch_num).if q=0 then return;
	eax2	0		will be set if key found
descent:	ldq	pr2|branch_num	ql<-position_frame.branch_num
	qls	1		ql<-2*branch_num
	adq	pr2|branch_num	ql<-3*branch_num
	ldq	pr5|0,ql		q<-branch(branch_num)
	tnz	get_son		if branch(branch_num)^=0 ==>get_son
	stz	pr0|6,*		clear garbage in arg3
	stx2	pr0|6,*		set result in arg3
	short_return

"pos_ptr=son_position_ptr;
get_son:	epp2	pr2|son_position_ptr,*  pr2<-son_position_ptr
	spri2	pr1|file_position_ptr  pos_ptr<-son_position_ptr

"node=q;
	stq	pr2|node		position_frame.node<-q

"node_ptr=addr(seg_ptr_array(q.comp_num)->seg_array(q.offset));
	eaa	0,qu		au<-q.comp_num,al<-0
	als	1		au<-2*q.comp_num
	epp5	pr1|seg_ptr_array_ptr,*au  pr5<-->seg_ptr_array(comp_num)
	epp5	pr5|0,*ql		pr5<-->seg_array(q.offset)
	spri5	pr2|node_ptr	node_ptr<-->seg_array(q.offset)

"low=1
	eax3	1		low<-1

"high=last_branch_num-1;
	ldq	pr5|last_branch_num	ql<-last_branch_num
	sbq	1,dl		ql<-last_branch_num-1
	qls	18		qu<-last_branch_num, ql<-0
	epp1	pr0|6,*		pr1<-->arg3
	stq	pr1|0		high<-last_branch_num-1
	epp2	pr0|4,*		pr2<-->arg2

"search:	i=(low+high)/2  ;
search:	eaq	0,3		qu<-low
	adq	pr1|0		qu<-(low+high)
	qrl	1		i<-(low+high)/2
	eax4	0,qu		x4<-(low+high)/2
	stx4	pr2|0		arg2<-(low+high)/2
	adx4	pr2|0		x4<-2*i
	adx4	pr2|0		x4<-3*i

"if substr(keys,key_pos(i),key_length(i))<key then low=i+1;
	ldx7	pr5|1,4		x7<-key_pos(i)
	lxl6	pr5|1,4		x6<-key_length(i)
	cmpc	(pr,rl,x7),(pr,rl),fill(040)  substr::key
	desc9a	pr5|-1(3),x6	addr(keys(0)),key_length(i)
	desc9a	pr3|1,x5		addr(key),length(key)
	trc	not_low		if substr>=key ==>not_low
	eax3	1,qu		low=i+1
	tra	continue		==>continue

"else if substr=key then search_code=1;
not_low:	tnz	unequal		if substr>key ==>unequal
	eax2	1		will be copied into arg

"high=i-1;
unequal:	eaq	-1,qu		qu<-i-1
	stq	pr1|0		high<-i-1

"if low<=high then go to search;
continue:	cmpx3	pr1|0		low::high
	tmoz	search		if high>=low ==>search

"branch_num=low. go to descent;
done:	epp1	pr0|2,*		pr1<-->indx_cb_ptr
	epp1	pr1|0,*		pr1<-->indx_cb
	epp2	pr1|file_position_ptr,*  pr2<-->position_frame
	sxl3	pr2|branch_num	branch_num<-low
	tra	descent		descend to leaf


	entry	last
last:
	epp1	pr0|2,*		pr1<-->indx_cb_ptr
	epp1	pr1|0,*		pr1<-->indx_cb
	epp2	pr1|file_position_ptr,*  pr2<-->position_frame
	epp5	pr2|node_ptr,*	pr5<-->node_block
	epp3	pr0|4,*		pr3<-->key_ptr
	epp3	pr3|0,*		pr3<-->key
	lxl5	pr3|0		x5<-length(key)

"q=branch(branch_num).if q=0 then return;
	eax2	0		will be set if key found
ldescent:	ldq	pr2|branch_num	ql<-position_frame.branch_num
	qls	1		ql<-2*branch_num
	adq	pr2|branch_num	ql<-3*branch_num
	ldq	pr5|0,ql		q<-branch(branch_num)
	tnz	lget_son		if branch(branch_num)^=0 ==>lget_son
	stz	pr0|6,*		clear garbage in arg3
	stx2	pr0|6,*		set result in arg3
	short_return

"pos_ptr=son_position_ptr;
lget_son:	epp2	pr2|son_position_ptr,*  pr2<-son_position_ptr
	spri2	pr1|file_position_ptr  pos_ptr<-son_position_ptr

"node=q;
	stq	pr2|node		position_frame.node<-q

"node_ptr=addr(seg_ptr_array(q.comp_num)->seg_array(q.offset));
	eaa	0,qu		au<-q.comp_num,al<-0
	als	1		au<-2*q.comp_num
	epp5	pr1|seg_ptr_array_ptr,*au  pr5<-->seg_ptr_array(comp_num)
	epp5	pr5|0,*ql		pr5<-->seg_array(q.offset)
	spri5	pr2|node_ptr	node_ptr<-->seg_array(q.offset)

"low=1
	eax3	1		low<-1

"high=last_branch_num-1;
	ldq	pr5|last_branch_num	ql<-last_branch_num
	sbq	1,dl		ql<-last_branch_num-1
	qls	18		qu<-last_branch_num, ql<-0
	epp1	pr0|6,*		pr1<-->arg3
	stq	pr1|0		high<-last_branch_num-1
	epp2	pr0|4,*		pr2<-->arg2

"lsearch:	i=(low+high)/2  ;
lsearch:	eaq	0,3		qu<-low
	adq	pr1|0		qu<-(low+high)
	qrl	1		i<-(low+high)/2
	eax4	0,qu		x4<-(low+high)/2
	stx4	pr2|0		arg2<-(low+high)/2
	adx4	pr2|0		x4<-2*i
	adx4	pr2|0		x4<-3*i

"if substr(keys,key_pos(i),key_length(i))<key then low=i+1;
	ldx7	pr5|1,4		x7<-key_pos(i)
	lxl6	pr5|1,4		x6<-key_length(i)
	cmpc	(pr,rl,x7),(pr,rl),fill(040)  substr::key
	desc9a	pr5|-1(3),x6	addr(keys(0)),key_length(i)
	desc9a	pr3|1,x5		addr(key),length(key)
	trc	lnot_low		if substr>=key ==>lnot_low
low:	eax3	1,qu		low=i+1
	tra	lcontinue		==>lcontinue

"else if substr=key then do search_code=1 low=i+1 end;
lnot_low:	tnz	lunequal		if substr>key ==>unequal
	eax2	1		will be copied into arg
	tra	low		set low=i+1
	
"high=i-1;
lunequal:	eaq	-1,qu		qu<-i-1
	stq	pr1|0		high<-i-1

"if low<=high then go to lsearch;
lcontinue:	cmpx3	pr1|0		low::high
	tmoz	lsearch		if high>=low ==>lsearch

"branch_num=low. go to ldescent;
ldone:	epp1	pr0|2,*		pr1<-->indx_cb_ptr
	epp1	pr1|0,*		pr1<-->indx_cb
	epp2	pr1|file_position_ptr,*  pr2<-->position_frame
	sxl3	pr2|branch_num	branch_num<-low
	tra	ldescent		descend to leaf





"declarations:
	equ	file_position_ptr,22  in indx_cb
	equ	node_ptr,4	in position_frame
	equ	branch_num,7	in position_frame
	equ	son_position_ptr,2	in position_frame
	equ	node,6		in position_frame
	equ	seg_ptr_array_ptr,8	in indx_cb
	equ	last_branch_num,0	in node_block

"this routine depends upon having branch_and_descrip_size=3

	end




		    open_blk_file.pl1               11/08/82  1652.6rew 11/08/82  1651.2      454311



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


/* This module supports I/O on blocked files */

open_blk_file:
     proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_comp_size, code);
	code = 0;
	if is_new_file | ((first_seg_ptr -> bf_head.end_pos = 0) & (mode > 4) & (atb.max_rec_len > 0) & ^atb.inv_lock_reset)
	then do;					/* initialize empty file */
		first_seg_ptr -> bf_head.max_rec_len = iocb_ptr -> iocb.attach_data_ptr -> atb.max_rec_len;
						/* determines block size */
		first_seg_ptr -> bf_head.max_comp_size = max_comp_size;
		if is_new_file
		then call hcs_$set_bc_seg (first_seg_ptr, 36 * (size (bf_head)), code);
						/*
						   sets initial bitcount */
		first_seg_ptr -> bf_head.version = current_bf_version;
	     end;
	call create_initialize_cb;			/* prepare control block */
	call create_seg_ptrs;			/* allocates seg_ptr_array if msf */
	if (cb_ptr -> cb.file_base_ptr -> bf_head.file_action ^= 0) & (mode > 4)
						/*
						   operation in progress and output opening */
	then call adjust_op;			/* adjusts the inconsistency */
	if (code = 0) & (file_base_ptr -> bf_head.version ^= current_bf_version /* old or bad file */)
	then if mode > 4				/* modify opening */
	     then call convert_file;			/* brings version up to date */
	     else cb.old_version = "1"b;		/* can use without converting if input-only */
	if code = 0
	then call set_entries_and_positions;		/* opening is successful */
	else do;					/* cleanup */
		call free_seg_ptrs;			/* de-allocates seg_ptr_array if msf */
		call free_cb_file (size (cb), cb_ptr);	/* release open_data_block */
		return;
	     end;
	if mode > 4
	then if ^cb.shared
	     then do;				/* set action and time_stamp */
		     file_base_ptr -> bf_head.file_action = unshared_opening;
		     file_base_ptr -> bf_head.time_last_modified = clock ();
		     return;
		end;
	     else go to unlock;			/* leave unlocked for shared openings */
exit:
	return;					/* end of open routine */

verify_done:
	if cb.shared
	then if file_base_ptr -> bf_head.time_last_modified ^= initial_time_stamp
	     then do;				/* asynch changes--must retry or abort */
		     cb.scan_backward = was_scan_backward;
		     cb.current_pos = old_current_pos;
		     cb.next_pos = old_next_pos;
		     cb.current_status = old_current_status;
		     if clock () < time_limit		/* time left to keep trying */
		     then go to retry_ent (current_entry);
		     code = error_table_$file_busy;	/* unable to verify result in time */
		end;
	return;					/* back to caller */

init_entry:					/* initialization for passive shared operations */
	if cb.wait_time < 0
	then time_limit = forever;
	else time_limit = clock () + cb.micro_wait_time;
	was_scan_backward = cb.scan_backward;
	old_current_pos = cb.current_pos;
	old_next_pos = cb.next_pos;
	old_end_pos = cb.end_pos;			/* save for detecting asynch eof changes */
	old_current_status = cb.current_status;
	cb.as_ins_del = "00"b;			/* set if asynch insertion or deletion detected */
	if cb.handler_required			/* asynch component deletions possible */
	then do;
setup_handler:
		comp_num = 0;			/* initial ref is to header comp */
		on seg_fault_error
		     begin;			/* deals with asynch comp deletions */
			on seg_fault_error
			     system;		/* fuck you */
			dname = substr (attach_descrip_string, 8, dname_len);
			ename = substr (attach_descrip_string, 9 + dname_len, ename_len);
			on seg_fault_error
			     go to inv_header;
			call hcs_$status_mins (cb.file_base_ptr, type, bc, foo);
			if foo ^= 0
			then do;			/* re-initiate header ptr */
inv_header:
				on seg_fault_error
				     system;
				call hcs_$terminate_seg (cb.file_base_ptr, 1, foo);
				call hcs_$initiate ((dname), (ename), "", 1, 1, cb.file_base_ptr, foo);
						/*
						   re-initiate header component, in case this was cause of fault */
				if foo = 0
				then go to resume;
				dname = dname || ">" || ename;
						/* probably is an msf */
				call hcs_$initiate ((dname), "0", "", 1, 1, cb.file_base_ptr, foo);
				if foo = 0	/* header ptr had to be re-initialized, msf case */
				then go to resume;
			     end;
			else if comp_num > 0	/* may have faulted because of ref to later comp */
			then do;			/* try re-initiating this component if necessary */
				on seg_fault_error
				     system;
				call hcs_$status_mins (cb.seg_ptr_array_ptr -> seg_ptr_array (comp_num), type, bc,
				     foo);
				if foo ^= 0
				then do;		/* re-obtain ptr to component */
					dname = dname || ">" || ename;
					call hcs_$terminate_seg (seg_ptr_array (comp_num), 1, foo);
					call hcs_$initiate ((dname), ltrim (char (comp_num)), "", 1, 1,
					     cb.seg_ptr_array_ptr -> seg_ptr_array (comp_num), foo);
					if foo = 0/* that was the problem */
					then go to resume;
				     end;
			     end;
			call continue_to_signal_ (foo);
						/* unaccountable error */
resume:
			dcl     dname		 char (168) var;
			dcl     ename		 char (32) var;
			dcl     type		 fixed (2);
			dcl     bc		 fixed (24);
			dcl     foo		 fixed (35);
		     end;				/* end of handler logic */
	     end;
	go to retry_ent (current_entry);		/* continue with operation */

position_blk_file:
     entry (iocb_ptr, pos_type, n_recs, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	if cb.shared
	then do;
		current_entry = 1;
		go to init_entry;
retry_ent (1):
		call prepare_process;
	     end;
	code = 0;

	if pos_type = 2				/* direct positioning */
	then if n_recs < 0				/* absolute position must be >=0 */
	     then code = error_table_$negative_nelem;
	     else if (n_recs > cb_ptr -> cb.end_pos) & ^cb.noend
						/* attempt to pass eof */
	     then do;				/* signal error and go to end of file */
eof_error:
		     call position_eof;
		     code = error_table_$end_of_info;
		end;
	     else do;				/* successful position operation */
		     cb_ptr -> cb.next_pos = n_recs;
		     cb_ptr -> cb.current_pos = n_recs;
		     cb.current_status = "00"b;	/* indicates that record is
						   not definitely known to be either present or absent */
		end;
	else if pos_type = 0			/* relative positioning */
	then if (cb.as_ins_del = "01"b) & ^cb.noend
	     then do;
		     code = error_table_$asynch_deletion;
						/* warn user his
						   position is not where he may think */
		     cb.current_status = "01"b;	/* current known absent */
		end;
	     else do;				/* skip forward or backward */
		     cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos + n_recs;
						/* move next position */
		     if cb_ptr -> cb.next_pos < 0	/* attempt to pass bof */
		     then do;			/* signal error and go to file base */
			     call position_bof;
			     code = error_table_$end_of_info;
			end;
		     else if (cb_ptr -> cb.next_pos > cb_ptr -> cb.end_pos) & ^cb.noend
						/* attempt to pass eof */
		     then go to eof_error;
		     else do;
			     cb.current_status = "00"b;
			     cb_ptr -> cb.current_pos = cb_ptr -> cb.next_pos;
						/* successful skip */
			end;
		end;

	else if pos_type = -1			/* beginning of file */
	then call position_bof;

	else if pos_type = 1			/* end of file */
	then call position_eof;
	else do;
		code = error_table_$bad_arg;
		return;				/* don't alter scan state */
	     end;
	cb_ptr -> cb.scan_backward = ((code = 0) & (pos_type = 0) & (n_recs < 0));
						/* for masking logically absent records */
	go to verify_done;				/* end of main position routine */

read_length_blk_file:
     entry (iocb_ptr, rec_len, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	if cb.shared
	then do;
		current_entry = 2;
		go to init_entry;
retry_ent (2):
		call prepare_process;
	     end;
	call find_next_record;			/* sets code */
	if code = 0				/* record found at next position */
	then rec_len = max (0, seg_ptr -> seg (pos));	/* record length at record head */
	go to verify_done;				/* end of read_length routine */

read_blk_file:
     entry (iocb_ptr, buff_ptr, buff_len, rec_len, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	if cb.shared
	then do;
		current_entry = 3;
		go to init_entry;
retry_ent (3):
		call prepare_process;
	     end;
	call find_next_record;
	if code = 0				/* record found */
	then do;					/* read the record */
		rec_len = max (0, seg_ptr -> seg (pos));/* length in record header */
		if rec_len > buff_len		/* record too big for buffer */
		then do;				/* signal error, but still prepare to move part record */
			code = error_table_$long_record;
			n = buff_len;		/* smaller than rec_len */
		     end;
		else n = rec_len;			/* move entire record into buffer */
		if n > 0				/* in case negative */
		then substr (buff_ptr -> buffer, 1, n) = substr (seg_ptr -> seg_str, 4 * (pos + 1) + 1, n);
						/* move record into buffer */
		cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos + 1;
						/* advance next record position */
	     end;
	go to verify_done;				/* end of read_record routine */

end_update:
	if cb.shared
	then do;
		file_base_ptr -> bf_head.file_action = 0;
						/* mark operation complete */
		go to unlock;
	     end;
	return;

unlock_exit:
	if cb.shared
	then do;
unlock:
		if stacq (file_base_ptr -> bf_head.file_lock, "0"b, cb.saved_lock_copy)
						/* resets the lock */
		then ;
	     end;
	return;					/* exit */

write_blk_file:
     entry (iocb_ptr, buff_ptr, buff_len, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	code = 0;
	if buff_len > cb_ptr -> cb.max_rec_len		/* record length exceeds maximum */
	then code = error_table_$long_record;
	else if buff_len < 0
	then code = error_table_$negative_nelem;
	else do;
		if cb.shared
		then do;
			if cb.handler_required	/* comps may vanish */
			then do;			/* handle seg_fault_errors */
				current_entry = 6;	/* handler must be in my frame */
				go to setup_handler;/* kludged call */
			     end;			/* now OK to reference file */
retry_ent (6):
			call lock_file_check;
		     end;
		if cb_ptr -> cb.next_pos < cb_ptr -> cb.end_pos
						/* not at end of file */
		then if cb_ptr -> cb.appending | (cb_ptr -> cb.mode = 5)
		     then do;			/* go to eof--not an error */
			     action = append;
			     call position_eof;	/* instead go to end of file */
			end;
		     else if cb.as_ins_del = "10"b
		     then do;			/* warn user he is not appending as expected */
			     code = error_table_$asynch_insertion;
			     cb.current_status = "00"b;
						/* still may be logically
						   deleted, however */
			     cb.scan_backward = "0"b;
			end;
		     else if cb_ptr -> cb.mode = 6	/* input_output */
		     then action = write_trunc;	/* truncate after write */
		     else action = rewrite;		/* replace an existing rec */
		else if cb.as_ins_del = "01"b
		then if ^cb_ptr -> cb.noend & (cb_ptr -> cb.mode = 5)
						/* output opening */
		     then do;			/* no error--just get back to eof */
			     action = append;
			     call position_eof;
			end;
		     else do;			/* asynchronously moved to eof--warn him */
			     code = error_table_$asynch_deletion;
			     cb.current_status = "01"b;
						/* known absent */
			     cb.scan_backward = "0"b;
			end;
		else action = append;		/* extending file */
		cb_ptr -> cb.current_pos = cb_ptr -> cb.next_pos;
						/* set current position */
		if code ^= 0			/* asynch insertion or deletion */
		then go to unlock_exit;
	     end;
	if code = 0
	then do;
		if cb_ptr -> cb.ssf_sw		/* might be full */
		then if cb_ptr -> cb.current_pos >= cb_ptr -> cb.capacity
						/* not enough room */
		     then do;
			     code = error_table_$file_is_full;
			     go to unlock_exit;
			end;
		call init_update (action);
		call get_current_pos;
		if comp_num > cb_ptr -> cb.last_comp_num/* must extend msf */
		then do while (comp_num > cb.last_comp_num);
			call set_bc (cb_ptr -> cb.capacity);
						/* set bitcount of full component */
			call extend_seg_ptr_array (cb.last_comp_num + 1);
						/* may re-allocate seg_ptr_array */
			cb_ptr -> cb.last_comp_num = cb.last_comp_num + 1;
			call msf_manager_$get_ptr (cb.fcb_ptr, cb.last_comp_num, "1"b, seg_ptr, foo24, code);
						/* create a new component */
			if code ^= 0
			then go to exit;
			cb.seg_ptr_array_ptr -> seg_ptr_array (cb.last_comp_num) = seg_ptr;
			file_base_ptr -> bf_head.last_comp = cb.last_comp_num;
		     end;
		else seg_ptr = get_seg_ptr (comp_num);
		call insert_record;			/* does the assignment */
		if cb_ptr -> cb.current_pos >= cb_ptr -> cb.end_pos
						/* at eof */
		then do;
			if cb.shared
			then file_base_ptr -> bf_head.end_pos = cb.next_pos;
			cb_ptr -> cb.end_pos = cb_ptr -> cb.next_pos;
						/* advance end */
		     end;
		else if action = write_trunc		/* must truncate now */
		then do;
			call truncate_file;		/* truncates at next position */
			cb.current_pos = cb.next_pos - 1;
		     end;				/* current_pos at record just written, next at eof */
		go to end_update;			/* clears action and unlocks if shared */
	     end;
	return;					/* end of write_record routine */

rewrite_blk_file:
     entry (iocb_ptr, buff_ptr, buff_len, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	if buff_len > cb_ptr -> cb.max_rec_len		/* record length exceeds maximum */
	then code = error_table_$long_record;
	else if buff_len < 0
	then code = error_table_$negative_nelem;
	else do;					/* proceed with rewrite */
		if cb.shared
		then do;
			if cb.handler_required
			then do;
				current_entry = 7;
				go to setup_handler;
			     end;
retry_ent (7):
			call lock_file_check;
		     end;
		if cb.current_pos >= cb.end_pos	/* end of file */
		then do;
			if cb.as_ins_del = "01"b
			then code = error_table_$asynch_deletion;
			else code = error_table_$no_record;
			cb.current_status = "01"b;	/* known absent */
			cb.scan_backward = "0"b;
			go to unlock_exit;		/* abort */
		     end;
		call get_current_pos;
		seg_ptr = get_seg_ptr (comp_num);
		if seg_ptr -> seg (pos) = 0		/* logically absent record--error */
		then do;
			if cb.current_status = "10"b	/* should be present */
			then code = error_table_$asynch_deletion;
			else code = error_table_$no_record;
			cb.current_status = "01"b;	/* now we know it's absent */
		     end;
		else do;				/* successful rewrite */
			call init_update (rewrite);
			code = 0;
			call insert_record;		/* does the work */
			go to end_update;
		     end;
		go to unlock_exit;
	     end;
	return;					/* end of rewrite routine */

delete_blk_file:
     entry (iocb_ptr, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	if cb.shared
	then do;
		if cb.handler_required
		then do;
			current_entry = 8;
			go to setup_handler;
		     end;
retry_ent (8):
		call lock_file_check;
	     end;
	if cb.current_pos >= cb.end_pos		/* at or beyond eof */
	then do;					/* treat as an error */
		if cb.as_ins_del = "01"b
		then code = error_table_$asynch_deletion;
		else code = error_table_$no_record;
		cb.current_status = "01"b;
		cb.scan_backward = "0"b;
		go to unlock_exit;
	     end;
	call get_current_pos;
	seg_ptr = get_seg_ptr (comp_num);
	if seg_ptr -> seg (pos) = 0			/* already deleted or not present */
	then do;
		if cb.current_status = "10"b
		then code = error_table_$asynch_deletion;
		else code = error_table_$no_record;
		cb.current_status = "01"b;
	     end;
	else do;					/* successful deletion */
		if cb.current_pos = cb.end_pos - 1	/* last record */
		then action = eof_delete;
		else action = non_eof_delete;
		call init_update (action);
		code = 0;
		unspec (addr (seg_ptr -> seg (pos)) -> record_block) = "0"b;
						/* zero entire block */
		if action = non_eof_delete
		then do;
			cb.current_status = "00"b;
			cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos + 1;
						/* advance */
		     end;
		else call set_true_eof;		/* finds last non-deleted record */
		cb_ptr -> cb.next_pos = cb_ptr -> cb.current_pos;
						/* by convention after delete */
		cb_ptr -> cb.scan_backward = "0"b;	/* resume default forward scanning */
		go to end_update;
	     end;
	go to unlock_exit;

control_blk_file:
     entry (iocb_ptr, order, info_ptr, code);
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	code = 0;

	if order = "read_position"
	then do;					/* return next record and end of file positions */
		if cb.shared
		then do;
			current_entry = 4;
			go to init_entry;
retry_ent (4):
			call prepare_process;
		     end;
		info_ptr -> info1.end_pos = cb_ptr -> cb.end_pos;
						/* get eof position */
		info_ptr -> info1.next_pos = cb_ptr -> cb.next_pos;
						/* get next position */
		go to verify_done;
	     end;

	else if order = "record_status"
	then do;
		rs_info_ptr = info_ptr;
		if (rs_info.version < rs_info_version_1) | (rs_info.version > rs_info_version_2)
		then code = error_table_$unimplemented_version;
		else if substr (string (rs_info.flags), 1, 6) ^= "0"b
						/* only 7th bit is supported */
		then code = error_table_$bad_arg;
		else do;				/* fill in info structure */
			if cb.shared
			then do;
				current_entry = 5;
				go to init_entry;
retry_ent (5):
				call prepare_process;
			     end;

			if rs_info.locate_pos_sw	/* set position */
			then if (rs_info.record_length >= cb.end_pos) & ^cb_ptr -> cb.noend
			     then go to norec;
			     else do;		/* use record_length arg as absolute pos */
				     cb.next_pos = rs_info.record_length;
				     cb.current_pos = rs_info.record_length;
				     cb.scan_backward = "0"b;
				end;
			else if cb.current_pos >= cb.end_pos
			then do;
norec:
				if cb.as_ins_del = "01"b
				then code = error_table_$asynch_deletion;
				else code = error_table_$no_record;
				cb.current_status = "01"b;
				go to exit;	/* no need to verify */
			     end;
			call get_current_pos;
			seg_ptr = get_seg_ptr (comp_num);
			rs_info.max_rec_len = cb.max_rec_len;
			rs_desc.comp_num = comp_num;
			rs_desc.offset = pos_bits;
			if seg_ptr ^= null
			then do;
				rs_info.record_ptr = addr (seg_ptr -> seg (pos + 1));
				rs_info.record_length = max (0, seg_ptr -> seg (pos));
			     end;
			if (seg_ptr = null) | ((seg_ptr -> seg (pos) = 0) & ^cb_ptr -> cb.old_version)
			then do;			/* error--logically absent record */
				if cb.current_status = "10"b
				then code = error_table_$asynch_deletion;
				else code = error_table_$no_record;
				cb.current_status = "01"b;
				rs_info.record_ptr = null;
				rs_info.record_length = 0;
			     end;
			else code = 0;
			go to verify_done;
		     end;
	     end;

	else if (order = "truncate") & (cb_ptr -> cb.mode > 4)
	then do;
		if cb.shared
		then do;
			if cb.handler_required
			then do;
				current_entry = 9;
				go to setup_handler;
			     end;
retry_ent (9):
			call lock_file_check;
		     end;
		if cb.next_pos > cb.end_pos		/* beyond end of file--error */
		then do;
			if cb.as_ins_del = "01"b
			then code = error_table_$asynch_deletion;
			else code = error_table_$end_of_info;
			cb.current_status = "01"b;
			go to unlock_exit;
		     end;
		cb.current_pos = cb.next_pos;
		cb.scan_backward = "0"b;
		if ^cb.shared
		then do;
			file_base_ptr -> bf_head.file_action = truncate;
			call truncate_file;
			file_base_ptr -> bf_head.file_action = unshared_opening;
			return;
		     end;
		call init_update (truncate);
		call truncate_file;			/* does the truncation at next_record_pos */
		go to end_update;
	     end;

	else if order = "max_rec_len"
	then do;					/* obtain and possibly set the file's max_rec_len */
		info_ptr -> info2.old_max_recl = cb_ptr -> cb.max_rec_len;
		if info_ptr -> info2.new_max_recl < 0	/* negative length is meaningless */
		then code = error_table_$negative_nelem;
		else if info_ptr -> info2.new_max_recl > 0
						/* indicates setting desired */
		then if (cb_ptr -> cb.mode = 4)	/* changing
						   max_rec_len not permitted unless file empty and opened for output */
		     then code = error_table_$no_operation;
		     else do;			/* OK to change max_rec_len */
			     if cb.shared
			     then do;
				     if cb.handler_required
				     then do;
					     current_entry = 10;
					     go to setup_handler;
					end;
retry_ent (10):
				     call lock_file_check;
				     file_base_ptr -> bf_head.time_last_modified = clock ();
				     cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified;
				end;
			     if cb.end_pos > 0
			     then code = error_table_$no_operation;
			     else do;
				     cb_ptr -> cb.file_base_ptr -> bf_head.max_rec_len =
					info_ptr -> info2.new_max_recl;
				     call set_maxl; /* propagates change to cb variables */
				end;
			     go to unlock_exit;
			end;
	     end;

	else if order = "file_status"
	then do;
		call vfile_status_$seg (iocb_ptr, cb.file_base_ptr, info_ptr, code);
		return;
	     end;

	else if order = "io_call"
	then call vfile_io_control (iocb_ptr, cb.file_base_ptr, info_ptr, code);
	else code = error_table_$no_operation;		/* invalid order call */
	return;					/* end of main control routine */

close_blk_file:
     entry (iocb_ptr);				/* cleanup routine called by vfile_attach */
	cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	if cb_ptr -> cb.mode > 4			/* eof may have moved */
	then do;					/* set end of file properly */
		if cb.shared			/* file not locked */
		then do;
			if cb.handler_required
			then do;
				current_entry = 11;
				go to setup_handler;
			     end;
retry_ent (11):
			if ^stac (addr (file_base_ptr -> bf_head.file_lock), cb.saved_lock_copy)
			then go to just_cleanup;	/* unable to lock--let other user close */
			else if file_base_ptr -> bf_head.file_action ^= 0
			then do;			/* leave locked invalidly */
leave_locked:
				if stacq (file_base_ptr -> bf_head.file_lock, (36)"1"b, cb.saved_lock_copy)
				then ;		/* make the lock invalid */
				go to just_cleanup;
			     end;
			else if cb.old_time_stamp ^= file_base_ptr -> bf_head.time_last_modified
			then call reinit_cb_vars;	/* for asynch changes */
			else ;			/* cb info is valid */
		     end;
		else if (file_base_ptr -> bf_head.file_action ^= unshared_opening)
			& (file_base_ptr -> bf_head.file_action ^= 0)
		then go to leave_locked;
		call position_eof;
		call get_current_pos;
		rel_pos = cb_ptr -> cb.end_pos - base_pos;
						/* eof position relative to base of last comp */
		if (rel_pos = 0) & (cb_ptr -> cb.end_pos > 0)
						/* eof at seg_end */
		then rel_pos = cb_ptr -> cb.capacity;	/* indicates last comp is full */
		call set_bc (rel_pos);		/* set bitcount of last_comp_num */
		cb_ptr -> cb.file_base_ptr -> bf_head.end_pos = cb_ptr -> cb.end_pos;
						/* set end position in header */
		file_base_ptr -> bf_head.file_action = 0;
		if stacq (file_base_ptr -> bf_head.file_lock, "0"b, cb.saved_lock_copy)
						/* unlock the file */
		then ;
	     end;
just_cleanup:
	call free_seg_ptrs;				/* de-allocates seg_ptr_array, if any */
	call free_cb_file (size (cb), cb_ptr);		/* deallocates open data block */
	return;					/* end of close routine */

find_next_record:
     proc;					/* locates record at next position */

	do while ("1"b);				/* may loop past logically absent records */
	     cb_ptr -> cb.current_pos = cb_ptr -> cb.next_pos;
	     if cb_ptr -> cb.current_pos >= cb_ptr -> cb.end_pos
						/* beyond eof */
	     then do;				/* error--at end of file */
		     cb.current_status = "01"b;	/* no current record */
		     if cb.as_ins_del = "01"b
		     then code = error_table_$asynch_deletion;
		     else code = error_table_$end_of_info;
		     cb_ptr -> cb.scan_backward = "0"b; /* reset to default forward scanning */
		     return;
		end;
	     else do;				/* next record found */
		     call get_current_pos;
		     seg_ptr = get_seg_ptr (comp_num);
		     if (seg_ptr -> seg (pos) ^= 0) | cb.old_version
						/* not logically absent */
		     then do;
			     code = 0;
			     cb.current_status = "10"b;
						/* known to be present */
			     cb.scan_backward = "0"b;
			     return;
			end;
		     else if cb.current_status = "10"b	/* should have been present */
		     then do;
			     code = error_table_$asynch_deletion;
			     cb.current_status = "01"b;
			     return;
			end;
		     cb.current_status = "00"b;	/* will have to scan */
		     if cb_ptr -> cb.scan_backward	/* preceding operation was backspace */
		     then if cb_ptr -> cb.next_pos <= 0 /* at bof */
			then do;			/* error--scanned to bof */
				code = error_table_$end_of_info;
				cb.scan_backward = "0"b;
				cb.current_status = "01"b;
				return;
			     end;
			else cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos - 1;
						/* scan backward */
		     else cb_ptr -> cb.next_pos = cb_ptr -> cb.next_pos + 1;
						/* scan forward--default case */
		end;
	end;					/* end of scan loop */

     end find_next_record;

get_seg_ptr:
     proc (comp) returns (ptr);
	if cb.seg_ptr_array_ptr -> seg_ptr_array (comp) = null
	then call msf_manager_$get_ptr (cb.fcb_ptr, comp, "0"b, cb.seg_ptr_array_ptr -> seg_ptr_array (comp), foo24, foo);
	return (cb.seg_ptr_array_ptr -> seg_ptr_array (comp));
	dcl     comp		 fixed;
     end get_seg_ptr;

get_current_pos:
     proc;
	comp_num = divide (cb_ptr -> cb.current_pos, capacity, 34, 0);
	base_pos = comp_num * cb_ptr -> cb.capacity;
	pos = (cb.current_pos - base_pos) * cb.block_size + size (bf_head);
     end get_current_pos;

prepare_process:
     proc;					/* initialize for attempt at passive shared operation */
	code = 0;

	do while ("1"b);				/* wait loop */
	     initial_time_stamp = file_base_ptr -> bf_head.time_last_modified;
	     if file_base_ptr -> bf_head.file_action = 0
	     then go to not_busy;
	     lock_copy = file_base_ptr -> bf_head.file_lock;
	     if stac (addr (lock_copy), cb.saved_lock_copy)
	     then go to not_busy;
	     if clock () >= time_limit
	     then do;
file_busy:
		     code = error_table_$file_busy;
		     go to exit;			/* abort entire operation */
		end;
	     call set_lock_$lock (lock_copy, 1, code);
	     if code ^= error_table_$lock_wait_time_exceeded
	     then go to file_busy;
	end;					/* end of wait loop */

not_busy:
	if initial_time_stamp ^= cb.old_time_stamp
	then do;
		call reinit_cb_vars;		/* note asynch header changes */
		cb.old_time_stamp = initial_time_stamp;
	     end;
	dcl     lock_copy		 bit (36) aligned;
     end prepare_process;

reinit_cb_vars:
     proc;					/* used to reinitialize cb variables to corresponding
						   header values after detecting asynch changes since last saving these vals */
	if cb.end_pos ^= file_base_ptr -> bf_head.end_pos
	then do;
		if (cb.current_pos < old_end_pos) & (cb.current_pos >= file_base_ptr -> bf_head.end_pos)
		then cb.as_ins_del = "01"b;
		else if (cb.current_pos >= old_end_pos) & (cb.current_pos < file_base_ptr -> bf_head.end_pos)
		then cb.as_ins_del = "10"b;
		else cb.as_ins_del = "00"b;
		cb.end_pos = file_base_ptr -> bf_head.end_pos;
	     end;
	if ^cb.noend
	then if cb.current_pos >= cb.end_pos		/* asynch deletions from eof */
	     then call position_eof;			/* might be more reasonable to return an
						   error code as well--in any case we can't let user stay at an
						   impossible position */
	if cb.last_comp_num ^= file_base_ptr -> bf_head.last_comp
	then do;
		call extend_seg_ptr_array (file_base_ptr -> bf_head.last_comp);
		cb.last_comp_num = file_base_ptr -> bf_head.last_comp;
	     end;
	if cb.max_rec_len ^= file_base_ptr -> bf_head.max_rec_len
	then call set_maxl;				/* asynch record size change */
     end reinit_cb_vars;

insert_record:
     proc;					/* places buffer contents into current record position */
	cb_ptr -> cb.next_pos = cb_ptr -> cb.current_pos + 1;
						/* set next position to following record */
	if buff_len <= 0				/* special case zero length records to distinguish from logically absent */
	then seg_ptr -> seg (pos) = -1;		/* convention for zero-length records */
	else do;					/* copy buffer and set record_length */
		substr (seg_ptr -> seg_str, 4 * (pos + 1) + 1, buff_len) = substr (buff_ptr -> buffer, 1, buff_len);
						/* copy buffer contents */
		seg_ptr -> seg (pos) = buff_len;	/* sets record length */
	     end;
	cb_ptr -> cb.scan_backward = "0"b;		/* resume default forward scanning */
	cb.current_status = "10"b;
     end insert_record;

lock_file_check:
     proc;					/* used to lock file in shared openings */
	if ^stac (addr (file_base_ptr -> bf_head.file_lock), cb.saved_lock_copy)
	then do;					/* more effort required to set lock */
		call set_lock_$lock (file_base_ptr -> bf_head.file_lock, cb.wait_time, code);
		if code ^= 0			/* as we expect unless it was just unlocked */
		then if code = error_table_$invalid_lock_reset
		     then code = 0;			/* file_action will still be checked */
		     else do;			/* locked by live process--abort or may interfere */
			     code = error_table_$file_busy;
			     go to exit;		/* external return to caller */
			end;
	     end;
	old_end_pos = cb.end_pos;
	cb.as_ins_del = "00"b;
	if cb.old_time_stamp ^= file_base_ptr -> bf_head.time_last_modified
	then do;
		call reinit_cb_vars;		/* note asynch header changes */
		cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified;
	     end;
	if file_base_ptr -> bf_head.file_action ^= 0	/* update in progress */
	then call adjust_op;			/* cleans up interrupted operation */
     end lock_file_check;

init_update:
     proc (action_code);				/* sets file_action and time_last_modified */
						/* for shared updates--otherwise header is only altered on closing
						   or when a truncate operation occurs */
	if ^cb.shared
	then return;
	file_base_ptr -> bf_head.change_pos = cb.current_pos;
						/* save position
						   at which change is to occur */
	file_base_ptr -> bf_head.file_action = action_code;
						/* identifies which
						   update entry is involved */
	file_base_ptr -> bf_head.time_last_modified = clock ();
						/* tells shared
						   readers that the file has changed asynchronously */
	cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified;
	dcl     action_code		 fixed;
     end init_update;				/* file marked as having an operation in progress */

position_eof:
     proc;					/* sets positions to end of file */
	cb.current_status = "01"b;			/* current record not defined */
	cb_ptr -> cb.next_pos = cb_ptr -> cb.end_pos;
	cb_ptr -> cb.current_pos = cb_ptr -> cb.end_pos;
     end position_eof;

position_bof:
     proc;					/* sets positions to beginning of file */
	cb.current_status = "00"b;			/* current record status unknown */
	cb_ptr -> cb.next_pos = 0;
	cb_ptr -> cb.current_pos = 0;
     end position_bof;

set_true_eof:
     proc;					/* sets eof after last non-deleted record */

	do while (cb.current_pos > 0);		/* find true eof */
	     cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos - 1;
						/* backspace */
	     call get_current_pos;			/* look at preceding record */
	     seg_ptr = get_seg_ptr (comp_num);
	     if seg_ptr -> seg (pos) ^= 0		/* record found */
	     then do;
		     cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos + 1;
		     go to set_eof;			/* exit from loop */
		end;
	end;					/* backspace loop */

set_eof:
	cb_ptr -> cb.end_pos = cb_ptr -> cb.current_pos;
	if cb.shared
	then file_base_ptr -> bf_head.end_pos = cb.end_pos;
	cb.current_status = "01"b;
     end set_true_eof;

create_initialize_cb:
     proc;					/* prepares open data block */
	call alloc_cb_file (size (cb), cb_ptr);		/* allocates space in linkage section */
	iocb_ptr -> iocb.open_data_ptr = cb_ptr;	/* set pointer in iocb */
	cb_ptr -> cb.mode = mode;			/* save opening mode */
	cb_ptr -> cb.file_base_ptr = first_seg_ptr;	/* pointer to base of file component */
	cb_ptr -> cb.appending = iocb_ptr -> iocb.attach_data_ptr -> atb.appending;
						/*
						   causes positioning to eof instead of truncation in input_output openings */
	cb.fcb_ptr = fcb_ptr_arg;
	cb.is_msf = atb.msf;
	cb.ssf_sw = atb.ssf;
	cb.noend = atb.noend_sw;
	cb.scan_backward = "0"b;			/* determines direction of scanning over logically absent records */
	cb.old_version = "0"b;			/* for read-only openings on old version files */
	cb.shared = atb.shared;
	cb.saved_lock_copy = "0"b;
	cb.as_ins_del = "00"b;
	call set_lock_$lock (cb.saved_lock_copy, 0, foo);
	if cb.shared
	then do;
		current_entry = 12;
		go to setup_handler;
	     end;
retry_ent (12):
	if file_base_ptr -> bf_head.version = current_bf_version
	then cb.last_comp_num = file_base_ptr -> bf_head.last_comp;
	else cb.last_comp_num = atb.last_comp;
	if (mode > 4) & (file_base_ptr -> bf_head.max_comp_size <= 0)
						/* old file */
	then file_base_ptr -> bf_head.max_comp_size = max_comp_size;
	cb_ptr -> cb.max_comp_size = file_base_ptr -> bf_head.max_comp_size;
						/* needed to determine capacity */
	call set_maxl;				/* initializes max_len dependent cb variables */
	cb_ptr -> cb.end_pos = file_base_ptr -> bf_head.end_pos;
						/* get eof position */
	if cb.shared
	then do;					/* see if asynch component deletions possible */
		call hcs_$get_safety_sw_seg (file_base_ptr, safety_sw, code);
		cb.handler_required = ^ssf_sw & (^safety_sw | ^is_msf);
		cb.wait_time = atb.wait_time;
		cb.micro_wait_time = 1000000 * cb.wait_time;
		cb.old_time_stamp = file_base_ptr -> bf_head.time_last_modified;
	     end;
     end create_initialize_cb;

set_entries_and_positions:
     proc;					/* sets iocb entries for valid operations and positions
						   to start or end of file depending on opening mode */
	close_x = close_blk_file;			/* close routine called by vfile_attach */
	call position_bof;
	if mode ^= 5				/* input operations supported */
	then do;					/* set passive entries */
		iocb_ptr -> iocb.read_record = read_blk_file;
		iocb_ptr -> iocb.read_length = read_length_blk_file;
		iocb_ptr -> iocb.position = position_blk_file;
		iocb_ptr -> iocb.control = control_blk_file;
	     end;
	else do;					/* output-only opening */
		iocb_ptr -> iocb.control = control_blk_file;
		iocb_ptr -> iocb.write_record = write_blk_file;
	     end;
	if mode = 6				/* input_output */
	then iocb_ptr -> iocb.write_record = write_blk_file;
	else if mode = 7				/* sequential_update */
	then do;					/* output operations also supported */
		iocb_ptr -> iocb.write_record = write_blk_file;
		iocb_ptr -> iocb.rewrite_record = rewrite_blk_file;
		iocb_ptr -> iocb.delete_record = delete_blk_file;
	     end;
	if (mode = 5) | ((mode = 6) & (^cb_ptr -> cb.appending))
						/* output or input_output
						   without -append attach option */
	then call position_eof;			/* position at open should be eof */
     end set_entries_and_positions;

truncate_file:
     proc;					/* truncates file at next record position */
	cb_ptr -> cb.current_pos = cb.next_pos;
	cb_ptr -> cb.end_pos = cb_ptr -> cb.next_pos;	/* next position becomes eof */
	cb_ptr -> cb.file_base_ptr -> bf_head.end_pos = cb_ptr -> cb.end_pos;
						/* mark new eof in file header */
	if ^cb.is_msf
	then call hcs_$truncate_seg (cb_ptr -> cb.file_base_ptr,
		size (bf_head) + cb_ptr -> cb.end_pos * cb_ptr -> cb.block_size, code);
						/* truncates the file */
	else do;
		call get_current_pos;
		if (base_pos = cb.end_pos) & (comp_num > 0)
						/* end of segment case */
		then do;				/* don't keep last seg with just a header */
			comp_num = comp_num - 1;	/* true last comp */
			pos = size (bf_head) + cb.capacity * cb.block_size;
						/* word offset of first word
						   beyond last record in the file */
		     end;
		call msf_manager_$adjust (cb.fcb_ptr, comp_num, 36 * pos, "010"b, code);
		file_base_ptr -> bf_head.last_comp = comp_num;
		cb.last_comp_num = comp_num;
	     end;
	call set_true_eof;				/* in case preceding records are absent anyway */
	cb.next_pos = cb.end_pos;
     end truncate_file;

set_maxl:
     proc;					/* sets cb variables which depend on max_rec_len */
	cb_ptr -> cb.max_rec_len = cb_ptr -> cb.file_base_ptr -> bf_head.max_rec_len;
						/* use max from file header */
	cb_ptr -> cb.block_size = divide (cb_ptr -> cb.max_rec_len + 7, 4, 19, 0);
						/* block
						   has single word header */
	cb_ptr -> cb.capacity = divide (cb_ptr -> cb.max_comp_size - size (bf_head), cb_ptr -> cb.block_size, 17, 0);
						/* capacity of each seg, in records */
     end set_maxl;

create_seg_ptrs:
     proc;					/* allocates seg_ptr_array if file is an msf */
	if cb.last_comp_num <= 0
	then do;					/* ssf case--just return */
		cb_ptr -> cb.seg_ptr_array_limit = -1;	/* indicates no separate allocation */
		cb_ptr -> seg_ptr_array_ptr = addr (cb.file_base_ptr);
						/* superimpose array */
		return;
	     end;
	cb.seg_ptr_array_limit = max (3, cb.last_comp_num);
	call alloc_cb_file (size (seg_ptr_array), cb.seg_ptr_array_ptr);

	do i = 0 to cb.seg_ptr_array_limit;		/* initialize array to null */
	     cb.seg_ptr_array_ptr -> seg_ptr_array (i) = null;
	end;

	seg_ptr_array (0) = cb.file_base_ptr;
     end create_seg_ptrs;

free_seg_ptrs:
     proc;					/* de-allocates seg_ptr_array, if any */
	if cb_ptr -> cb.seg_ptr_array_limit < 0		/* no array */
	then return;
	call free_cb_file (size (seg_ptr_array), cb_ptr -> cb.seg_ptr_array_ptr);
     end free_seg_ptrs;

extend_seg_ptr_array:
     proc (new_last_comp);				/* may re-allocate seg_ptr_array to accomodate
						   a new msf component */
	if new_last_comp <= cb.seg_ptr_array_limit	/* enough room */
	then return;
	if ^cb_ptr -> cb.is_msf			/* msf not yet opened */
	then do;
		call msf_manager_$open (substr (attach_descrip_string, 8, dname_len),
		     substr (attach_descrip_string, 9 + dname_len, ename_len), cb.fcb_ptr, foo);
		cb_ptr -> cb.is_msf = "1"b;
		atb.fcbp = cb.fcb_ptr;
	     end;
	old_array_limit = cb.seg_ptr_array_limit;
	cb.seg_ptr_array_limit = 4 * divide (new_last_comp + 4, 4, 17, 0) - 1;
	old_array_ptr = cb.seg_ptr_array_ptr;
	call alloc_cb_file (size (seg_ptr_array), cb.seg_ptr_array_ptr);

	do i = 0 to cb.seg_ptr_array_limit;		/* initialize array to null */
	     cb.seg_ptr_array_ptr -> seg_ptr_array (i) = null;
	end;


	do i = 0 to cb.last_comp_num;
	     cb.seg_ptr_array_ptr -> seg_ptr_array (i) = old_seg_ptr_array (i);
	end;

	if old_array_limit > 0			/* old array was separately allocated */
	then call free_cb_file (size (old_seg_ptr_array), old_array_ptr);

	dcl     old_seg_ptr_array	 (0:old_array_limit) ptr based (old_array_ptr);
	dcl     old_array_limit	 fixed;
	dcl     old_array_ptr	 ptr;
	dcl     new_last_comp	 fixed;
     end extend_seg_ptr_array;

set_bc:
     proc (nrecs);					/* sets bitcount on last comp */
	call hcs_$set_bc_seg (get_seg_ptr (cb.last_comp_num), 36 * (size (bf_head) + nrecs * cb.block_size), foo);
	dcl     nrecs		 fixed (19);
     end set_bc;

adjust_file:
     proc;					/* called when an interrupted opening is detected */
	call adjust_bit_count_ (substr (attach_descrip_string, 8, dname_len),
	     substr (attach_descrip_string, 9 + dname_len, ename_len), "0"b, bc, code);
						/* find last non-zero word */
	if bc > 0
	then do;					/* proceed with adjustment */
		tot_nz_words = divide (bc, 36, 34, 0);
		full_comp_size = size (bf_head) + cb.capacity * cb.block_size;
		full_comps = divide (tot_nz_words, full_comp_size, 17, 0);
		nz_words = tot_nz_words - full_comps * full_comp_size;
						/* words in last comp */
		base_pos = cb.capacity * full_comps;	/* rec_no at base of last comp */
		nz_recs =
		     divide (nz_words - size (bf_head) + cb_ptr -> cb.block_size - 1, cb_ptr -> cb.block_size, 17, 0);
						/* count of non-zero records */
		tot_nz_recs = base_pos + nz_recs;	/* total adjusted record count */
		file_base_ptr -> bf_head.last_comp = full_comps;
		cb.last_comp_num = full_comps;
		if (tot_nz_recs > cb_ptr -> cb.end_pos)
		     |
		     /* eof is not properly set */ ((tot_nz_recs ^= cb.end_pos)
		     & (file_base_ptr -> bf_head.version = current_bf_version))
		then if get_seg_ptr (cb.last_comp_num)
			-> seg (size (bf_head) + cb_ptr -> cb.block_size * (nz_recs - 1)) ^= 0
						/*
						   last record is valid */
		     then do;
			     cb_ptr -> cb.end_pos = tot_nz_recs;
			     file_base_ptr -> bf_head.end_pos = tot_nz_recs;
			end;
		     else do;			/* last record is incomplete--delete it */
			     cb_ptr -> cb.next_pos = tot_nz_recs - 1;
			     call truncate_file;	/* removes dubious last record */
			end;
		     end;
     end adjust_file;

adjust_op:
     proc;					/* makes file consistent */
	if (file_base_ptr -> bf_head.file_action = eof_delete) | (file_base_ptr -> bf_head.file_action = unshared_opening)
	     | (file_base_ptr -> bf_head.file_action = append)
	then call adjust_file;
	else if file_base_ptr -> bf_head.file_action = write_trunc
	then if file_base_ptr -> bf_head.end_pos > file_base_ptr -> bf_head.change_pos + 1
						/* rewrite phase */
	     then call print_warning;			/* contents may be bad */
	     else go to finish_trunc;			/* just do the truncation */
	else if file_base_ptr -> bf_head.file_action = non_eof_delete
	then call re_zero;				/* clean up garbage */
	else if file_base_ptr -> bf_head.file_action = truncate
	then do;					/* finish a truncation */
finish_trunc:
		call position_eof;
		call truncate_file;
	     end;
	else call print_warning;			/* non_eof_replacement */
	cb.current_pos = old_current_pos;		/* reset positions */
	cb.next_pos = old_next_pos;
	file_base_ptr -> bf_head.file_action = 0;
	return;					/* operation in progress has been adjusted */

print_warning:
     proc;					/* signals fact that record may have bad contents */
	call sub_err_ (0, "vfile_", "c", null, foo, "Record contents may be damaged for position: ^d",
	     file_base_ptr -> bf_head.change_pos);
     end print_warning;

re_zero:
     proc;					/* handles interrupted deletions */
	cb.current_pos = file_base_ptr -> bf_head.change_pos;
	call get_current_pos;
	seg_ptr = get_seg_ptr (comp_num);
	unspec (addr (seg_ptr -> seg (pos)) -> record_block) = "0"b;
	cb.current_pos = old_current_pos;
     end re_zero;

     end adjust_op;

convert_file:
     proc;					/* brings old file up to current version, or detects bad version */
	if first_seg_ptr -> bf_head.version ^= bf_version_0
						/* previous version file? */
	then do;					/* not previous version */
		code = error_table_$unimplemented_version;
						/* unknown version--abort */
		return;				/* opening will fail */
	     end;
	if atb.inv_lock_reset			/* old file was being updated */
	then call adjust_file;			/* not really necessary if operation was truncate */
	call position_bof;

	do while (cb_ptr -> cb.current_pos < cb_ptr -> cb.end_pos);
						/* convert zero-length records */
	     call get_current_pos;
	     seg_ptr = get_seg_ptr (comp_num);
	     if seg_ptr -> seg (pos) = 0		/* old-style zero-length record */
	     then seg_ptr -> seg (pos) = -1;		/* new representation for zero-length records */
	     cb_ptr -> cb.current_pos = cb_ptr -> cb.current_pos + 1;
						/* advance through file */
	end;					/* end of loop which converts records */

	file_base_ptr -> bf_head.last_comp = cb.last_comp_num;
	first_seg_ptr -> bf_head.version = current_bf_version;
						/* completes conversion atomically */
     end convert_file;

	dcl     (vfile_io_control, vfile_status_$seg)
				 entry (ptr, ptr, ptr, fixed (35));
	dcl     current_entry	 fixed;
	dcl     full_comp_size	 fixed (19);
	dcl     stacq		 builtin;
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed, fixed (35));
	dcl     seg_ptr		 ptr;
	dcl     sub_err_		 entry options (variable);
	dcl     action		 fixed;
	dcl     clock		 builtin;
	dcl     (iocb_ptr, fcb_ptr_arg, first_seg_ptr)
				 ptr;
	dcl     rel_pos		 fixed (19);
	dcl     base_pos		 fixed (34);
	dcl     tot_nz_words	 fixed (34);
	dcl     full_comps		 fixed;
	dcl     tot_nz_recs		 fixed;
	dcl     comp_num		 fixed;
	dcl     seg_ptr_array	 (0:cb_ptr -> cb.seg_ptr_array_limit) ptr based (cb.seg_ptr_array_ptr);
	dcl     msf_manager_$open	 entry (char (*), char (*), ptr, fixed (35));
	dcl     msf_manager_$adjust	 entry (ptr,	/* fcb_ptr */
				 fixed bin,	/* component number of segment to be
						   made last segment */
				 fixed bin (24),	/* bit count for that seg */
				 bit (3),		/* "010" = dont set bit counts, truncate
						   segment, dont terminate components */
				 fixed bin (35));	/* status code */
	dcl     msf_manager_$get_ptr	 entry (ptr,	/* fcb_ptr */
				 fixed bin,	/* component number of desired segment */
				 bit (1),		/* create switch */
				 ptr,		/* ptr to seg or null if error, output */
				 fixed bin (24),	/* bitcount of segment, output */
				 fixed bin (35));	/* status code */
	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed (24),
				 fixed (35));
	dcl     d_name		 char (168) aligned;
	dcl     e_name		 char (32) aligned;
	dcl     d_len		 fixed;
	dcl     bc		 fixed (24);
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*) aligned, fixed, char (*) aligned, fixed (35));
	dcl     hcs_$status_mins	 entry (ptr, fixed (2), fixed (24), fixed (35));
	dcl     hcs_$terminate_seg	 entry (ptr, fixed (1), fixed (35));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
	dcl     is_new_file		 bit (1) aligned;
	dcl     mode		 fixed;		/* may be 4,5,6, or 7 */
	dcl     close_x		 entry;
	dcl     first_seg_bitcount	 fixed (24);	/* of no interest in this module */
	dcl     max_comp_size	 fixed (19);
	dcl     code		 fixed (35);
	dcl     1 bf_head		 aligned based,	/* standard header for blocked files */
		2 common_header_words,
		  3 file_type_code	 fixed (35),
		  3 file_lock	 bit (36) aligned,
		  3 time_last_modified
				 fixed (71),
		2 version		 fixed,
		2 change_pos	 fixed (34),	/* record being modified when shared */
		2 reserved1	 (1) fixed,
		2 last_comp	 fixed,		/* last msf component number */
		2 max_rec_len	 fixed (21),	/* bytes */
		2 end_pos		 fixed,		/* number of records */
		2 file_action	 fixed,		/* non-zero value indicates truncation in progress */
		2 max_comp_size	 fixed (19),
		2 reserved2	 (4) fixed;
%include iocbv;
%include rs_info;
%include vf_attach_block;
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed (24), fixed (35));
	dcl     (size, max, null, divide)
				 builtin;
	dcl     i			 fixed;
	dcl     cb_ptr		 ptr;
	dcl     bf_version_0	 static internal fixed options (constant) init (0);
	dcl     current_bf_version	 static internal fixed options (constant) init (1);
	dcl     1 cb		 based (cb_ptr) aligned,
						/* open data block--controls blocked files */
		2 file_base_ptr	 ptr,		/* points to base of segment */
		2 seg_ptr_array_ptr	 ptr,
		2 fcb_ptr		 ptr,
		2 mode		 fixed,		/* opening mode (=4,5,6, or 7) */
		2 appending	 bit (1) aligned,	/* -append option */
		2 max_comp_size	 fixed (19),	/* determines capacity of file */
		2 max_rec_len	 fixed (21),	/* determines block size */
		2 block_size	 fixed (19),	/* words, including header */
		2 capacity	 fixed (19),	/* max number of records per comp */
		2 current_pos	 fixed (34),	/* current record number */
		2 next_pos	 fixed (34),	/* next record position (0,1,2,...) */
		2 end_pos		 fixed (34),	/* number of records in file */
		2 last_comp_num	 fixed,
		2 is_msf		 bit (1) aligned,
		2 ssf_sw		 bit (1) aligned,
		2 seg_ptr_array_limit
				 fixed,
		2 noend		 bit (1) aligned,	/* if on, user pay position beyond eof */
		2 scan_backward	 bit (1) aligned,	/* for masking logically absent records */
		2 old_version	 bit (1) aligned,	/* set if file does not support logical deletion */
		2 shared		 bit (1) aligned,	/* on if -share attachment */
		2 wait_time	 fixed,		/* applies only if shared */
		2 saved_lock_copy	 bit (36) aligned,	/* copy of my lock id */
		2 micro_wait_time	 fixed (71),	/* wait_time in microseconds */
		2 old_time_stamp	 fixed (71),
		2 handler_required	 bit (1) aligned,	/* applies if sharing */
		2 current_status	 bit (2) aligned,
		2 as_ins_del	 bit (2) aligned;
	dcl     old_end_pos		 fixed (34);
	dcl     old_current_status	 bit (2) aligned;
	dcl     (pos_type, n_recs)	 fixed;
	dcl     seg_fault_error	 condition;
	dcl     time_limit		 fixed (71);
	dcl     forever		 static internal fixed (54) aligned init (1.801e16);
	dcl     (error_table_$negative_nelem, error_table_$asynch_insertion, error_table_$asynch_deletion,
	        error_table_$lock_wait_time_exceeded, error_table_$invalid_lock_reset, error_table_$safety_sw_on,
	        error_table_$file_busy, error_table_$unimplemented_version, error_table_$end_of_info,
	        error_table_$no_record, error_table_$bad_arg, error_table_$no_operation, error_table_$long_record,
	        error_table_$file_is_full)
				 external fixed (35);
	dcl     seg		 (0:cb.max_comp_size) fixed aligned based;
	dcl     pos		 fixed (19);
	dcl     1 pos_struct	 based (addr (pos)),
		2 pad_bits	 bit (18) unal,
		2 pos_bits	 bit (18) unal;
	dcl     buff_ptr		 ptr;
	dcl     (buff_len, rec_len)	 fixed (21);
	dcl     buffer		 char (buff_len) based (buff_ptr);
	dcl     n			 fixed (21);
	dcl     substr		 builtin;
	dcl     order		 char (*);
	dcl     info_ptr		 ptr;
	dcl     was_scan_backward	 bit (1) aligned;
	dcl     (old_next_pos, old_current_pos)
				 fixed (34);
	dcl     write_trunc		 static internal fixed options (constant) init (-9);
	dcl     rewrite		 static internal fixed options (constant) init (-2);
	dcl     eof_delete		 static internal fixed options (constant) init (-3);
	dcl     non_eof_delete	 static internal fixed options (constant) init (-10);
	dcl     unshared_opening	 static internal fixed options (constant) init (-11);
	dcl     append		 static internal fixed options (constant) init (-1);
	dcl     truncate		 static internal fixed options (constant) init (1);
	dcl     1 info1		 based (info_ptr),	/* for "read_position" order */
		2 next_pos	 fixed,		/* output */
		2 end_pos		 fixed;		/* output */
	dcl     continue_to_signal_	 entry (fixed (35));
	dcl     initial_time_stamp	 fixed (71);
	dcl     safety_sw		 bit (1);
	dcl     hcs_$get_safety_sw_seg entry (ptr, bit (1), fixed (35));
	dcl     1 info2		 based (info_ptr),	/* for "max_rec_len" order */
		2 old_max_recl	 fixed (21),	/* output */
		2 new_max_recl	 fixed (21);	/* input */
	dcl     foo		 fixed (35);
	dcl     foo24		 fixed (24);
	dcl     nz_words		 fixed (19);
	dcl     nz_recs		 fixed;
	dcl     addr		 builtin;
	dcl     1 record_block	 based,
		2 recl		 fixed (21),
		2 rec_words	 (cb.block_size - 1) fixed;
	dcl     seg_str		 char (1000000) aligned based;
	dcl     alloc_cb_file	 entry (fixed, ptr);
	dcl     free_cb_file	 entry (fixed, ptr);
	dcl     hcs_$truncate_seg	 entry (ptr, fixed (18), fixed (35));
     end open_blk_file;




		    open_indx_file.pl1              10/16/90  1526.9rew 10/16/90  1518.4     1820997



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






/****^  HISTORY COMMENTS:
  1) change(90-10-12,Zimmerman), approve(90-10-12,MCR8216),
     audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043):
     Data_Mgt 63 (phx21194): Raise the max number of components in an MSF to
     1250.
                                                   END HISTORY COMMENTS */




/* The initial design and implementation of this program was by M. D. MacLaren (1974) */
/* All extensions, optimizations, and bug fixes since 1975 designed and implemented by M. Asherman */
/* The above was true up through 1978.  Major modifications have been made by Jim Paradise prior to the first listed modification.
   Modified:
   05/31/79  by  Lindsey L. Spratt; fix "delete" bug by correcting a check seeing if the key
   associated with branch_num is the same as the key in automatic storage.( a tip of the hat to
   Chris D. Tavares for figuring out this fix)
   Also, added code to check for improperly converted files, since check_file_version
   was not doing the comp_table reformatting it should have been doing.
   Modified by Jim Paradise on January 16, 1980 to correctly handle
   modifiers of stationary records; problems due to interaction
   of tp code and redefinition meaning of stationary header variable: modifier
   04/29/80 by Jim Paradise to add fix to select/exclude logic to not try to
   free at times there is not anything to free in returned descrip list,
   Found and fix provided by Jim Gray.
   Modified by Jim Paradise on June 27, 1980 to fix a performance bug, when inserting
   duplicate keys search for them on the right.  Based on
   the fix provided by Ed Brunnell.
   12/18/80  by  Lindsey L. Spratt: add the ability to delete old subsets from
   the "subset" vfile built for holding the results of selection and exclusion.
   This also involved adding a new bit to the common_sl_info structure,
   common_sl_info.delete_old_subsets.
06/29/81 by Lindsey Spratt: Changed to use the iocb.incl.pl1 include file
	  instead of the (now obsolete) iocbv.incl.pl1 include file.  This
	  required explicitly qualifying with a locator value (iocb_ptr) all
	  references to elements of the iocb structure.  Also, moved
	  (nearly) all include files to the end of the source.
01/20/82 by Lindsey Spratt:  Changed rewrite_indx_file entry point to only
            reference the "current" node when indx_cb.outside_index is off.
            This was causing a null pointer fault when no valid position had
            established (e.g., the only kind of positioning done since the 
            opening of the file was via the record_status control order.)
01/21/82 by Lindsey Spratt:  Changed the declaration of the error_info structure
            from fixed to fixed bin (35).  There was a size mis-match between
            indx_cb.requested (fixed bin(34)) and error_info.requested (fixed 
            bin(17)).
03/31/82 by Lindsey Spratt: Changed close_indx_file to re-initialize the
	  file_state pointers (fs_ptr, o_s_ptr, os_ptr, and
	  indx_cb.file_state_ptr) when entered. (vfile bug 23.)
04/05/82 by Lindsey Spratt: Changed the select control order to not allocate a
	  descriptor array when the caller's selection gets an
	  error_table_$no_record (i.e., when flag = select_flag, and
	  indx_cb.subset_selected = "00"b, indicating that no selection has
	  taken place).  This is checked in get_subset_status.
*/
/* format: style2,ind3 */
open_indx_file:
   proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode_arg, close_x, first_seg_bitcount, component_size_arg,
      code);

      go to open_file;

init_down_up:					/* prologue for ops which must first lock file */
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      passive = "0"b;
      go to init_body;
init_up_down:					/* prologue for semi-passive operations */
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      passive = indx_cb.stat;				/* lock file first if non-stationary */
      go to init_body;
initialize:					/* prologue for all passive index operations */
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      passive = "1"b;				/* will never lock on this operation */
init_body:
      code = 0;
      cleanup_flags = "000000"b;			/* nothing locked */
      if ^indx_cb.shared				/* unshared opening */
      then
         do;
	  saved_state.shared = "0"b;
	  timeout = 0;
	  go to retry_loc (current_retry_loc);		/* back to mainline with handler established */
         end;
      saved_state_block = current_state_block;		/* for cleanup */
						/* continue initialization for a shared operation */
      pos_ptr = file_position_ptr;
      f_b_ptr = file_base_ptr;
      fs_ptr = indx_cb.file_state_ptr;
      if indx_cb.wait_time < 0			/* will wait indefinitely */
      then timeout = eternity;			/* may wait forever */
      else timeout = clock () + indx_cb.wait_time;	/* microseconds */
      on cleanup call restore_abort;
      if current_retry_loc = rs_retry_2
      then go to retry_loc (rs_retry_2);
      if leave_locked				/* file left locked by me */
      then go to retry_loc (current_retry_loc);
      if ^passive
      then
         do;					/* insist on first locking the file */
	  call lock_file_check;
	  go to retry_loc (current_retry_loc);
         end;
      fault_ok = "0"b;				/* set when possible asynch file change errors should be handled */

      on any_other
         begin;					/* asynch change handler */
	  if fault_ok				/* fault may be due to asynch change to the file */
	  then
	     do;					/* see if this is the case */
	        fault_ok = "0"b;			/* suppress recursive any_other handling */
	        call find_condition_info_ (null, addr (cond_info), er_code);
						/* gets condition name */
	        if asynch_change_condition (cond_name)	/* OK to handle */
	        then if iocb_ptr -> iocb.open_data_ptr -> indx_cb.file_base_ptr -> file_base.change_count
		      ^= iocb_ptr -> iocb.open_data_ptr -> indx_cb.last_change_count
						/* file has changed--note indx_cb_ptr may not be valid now */
		   then go to try_again;		/* reattempt operation or abort */
	        fault_ok = "1"b;			/* pass on this fault, but resume handling others */
	     end;
	  call continue_to_signal_ (er_code);		/* quit or file not changed--must be an error */

asynch_change_condition:
   proc (cond_name) returns (bit (1) aligned);		/*
						   returns "1"b if condition may have arisen from asynch file change */
      if length (cond_name) > length ("simfault_")
      then if substr (cond_name, 1, length ("simfault_")) = "simfault_"
	 then return ("1"b);
      if cond_name = "sub_err_"
      then if sub_err_info.name = "vfile_"
	 then return ("1"b);			/* OK to handle vfile_'s own sub_err_ only */
	 else return ("0"b);

      do i = 1 to num_conds;				/* check each possible condition known */
         if cond_name = as_cond_names (i)		/* match */
         then return ("1"b);
      end;					/* try each name in loop */

      return ("0"b);				/* not a condition which should be handled */

      dcl	    1 sub_err_info	       based (cond_info.infop),
	      2 pad	       (70),
	      2 name	       char (32);
      dcl	    cond_name	       char (32) var;
      dcl	    i		       fixed;
      dcl	    num_conds	       static internal fixed options (constant) init (21);
      dcl	    as_cond_names	       (1:21) static options (constant) char (32) var internal
			       init ("fault_tag_1", "fault_tag_3", "fixedoverflow", "illegal_modifier",
			       "linkage_error", "lockup", "no_execute_permission", "no_read_permission",
			       "no_write_permission", "not_in_read_bracket", "not_in_write_bracket",
			       "out_of_bounds", "overflow", "seg_fault_error", "size", "storage", "stringrange",
			       "stringsize", "subscriptrange", "truncation", "underflow");
   end asynch_change_condition;

	  dcl	find_condition_info_   entry (ptr, ptr, fixed (35));
	  dcl	1 cond_info	   aligned,
		  2 words1	   (3) fixed,
		  2 cond_name	   char (32) var,	/* all that interests us */
		  2 infop		   ptr,
		  2 words2	   (12) fixed init ((12) 0);
	  dcl	er_code		   fixed (35);
         end;					/* end of any_other handler */

      call prepare_process;
      go to retry_loc (current_retry_loc);		/* end of initialization pseudo-proc */

try_again:					/* reattempt a passive operation if time enough */
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      call restore_state;
      call prepare_process;				/* may wait on file lock */
      go to retry_loc (current_retry_loc);		/* back to mainline */

verify_done:
      if indx_cb.shared
      then if cleanup_flags ^= "000000"b		/* not passive */
	 then go to unlock_exit;			/* don't leave things locked */
	 else
	    do;
	       call save_correct_pos;
	       if ^indx_cb.leave_locked
	       then
		do;				/* verify a passive operation */
		   if indx_cb.last_change_count = file_base.change_count
						/* file unchanged during operation */
		   then return;			/* result is therefore verified--done */
		   call restore_state;		/* resets process vars to their former values */
		   if clock () > timeout		/* time limit exhausted */
		   then
		      do;				/* abort */
		         code = error_table_$file_busy;
		         return;
		      end;
		   call prepare_process;
		   go to retry_loc (current_retry_loc);
		end;
	    end;
      return;					/* external exit */

passive_abort:
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      if saved_state.shared				/* state has been saved */
      then call restore_state;
      return;

/* seek_key routine for openings with mode keyed_sequential_output */
seek_key_ks_out:
   entry (iocb_ptr, key, rec_len, code);
      current_retry_loc = seek_kso_retry;
      go to initialize;
retry_loc (1):
      if indx_cb.pos_incorrect
      then
         do;					/* position correctly to end of file */
	  call position_eof;
	  indx_cb.pos_incorrect = "0"b;
         end;
      else
         do;
	  pos_ptr = file_position_ptr;
	  indx_cb.outside_index = "0"b;		/* current pos moves into index */
	  branch_num = last_branch_num;
	  call set_at_eof;				/* sets indx_cb vars */
         end;
      indx_cb.new_key = key;				/* save key for insertion */
      call compare_last_key (indx_cb.new_key);		/* sets code and key_is_dup */
      if code = 0					/* indx_cb.new_key larger than last key in file */
      then
         do;
	  code = error_table_$no_record;
	  indx_cb.ready_to_write = "1"b;
         end;
      else indx_cb.ready_to_write = (key_is_dup & dup_ok);	/* write will succeed if
						   key exists and duplications are allowed */
      go to verify_done;				/* end seek_key for keyed sequential output */

seek_key_indx_file:
   entry (iocb_ptr, key, rec_len, code);
      current_retry_loc = seek_retry;
      go to initialize;
retry_loc (2):
      indx_cb.at_bof, indx_cb.at_eof = "0"b;
      file_position_ptr = root_position_ptr;
      indx_cb.outside_index = "0"b;
      indx_cb.skip_state = 0;				/* revert to forward scanning over deletions */
      call find_key (indx_cb_ptr, (addr (key)), search_code);
						/* 2nd arg is destroyed */
      pos_ptr = file_position_ptr;
      indx_cb.pos_incorrect = "0"b;			/* Now set file position and code */
      if search_code = 0				/* means not found */
      then code = error_table_$no_record;
      else
         do;					/* try to get ptr and len */
	  call find_from_leaf;			/* in case match was in upper node */
	  indx_cb.current_descrip = record_designator (branch_num);
	  call set_next_reclp_seek (block_ptr, lock_ptr); /* sets ptr and length */
						/* limits scanning to entries for this key */
						/* also sets the code to indicate failure */
         end;					/* either len is known or error code set */
      if (code = 0) | (code ^= error_table_$no_record)
      then
         do;					/* set position indicators and recl arg */
	  rec_len = record_len;
	  indx_cb.current_record_is_valid = "1"b;
	  indx_cb.next_record_position = 1;
	  indx_cb.ready_to_write = dup_ok;
         end;
      else
         do;					/* set indicators for unsuccessful seek */
	  rec_len = 0;
	  indx_cb.current_record_is_valid = "0"b;
	  indx_cb.next_record_position = 0;
	  if ^is_read_only
	  then
	     do;
	        indx_cb.ready_to_write = "1"b;
	        indx_cb.new_key = key;
	     end;
         end;
      go to verify_done;				/* end of seek_key routine */

      dcl	    search_code	       fixed (35);

read_length_indx_file:
   entry (iocb_ptr, rec_len, code);
      current_retry_loc = read_len_retry;
      go to initialize;
retry_loc (3):
      call find_next_record;
      if code = 0					/* next record exists */
      then
         do;					/* get its length */
	  call set_next_reclp (block_ptr, lock_ptr);
	  rec_len = record_len;
         end;
      go to verify_done;				/* end of read_length routine */

read_key_indx_file:
   entry (iocb_ptr, key, rec_len, code);
      current_retry_loc = read_key_retry;
      go to initialize;
retry_loc (4):
      call find_next_record;
      if code = 0					/* next position exists */
      then
         do;
	  call set_next_reclp (block_ptr, lock_ptr);
	  rec_len = record_len;
	  len = get_key_length ();
	  if len > 0
	  then key = substr (keys, key_pos (branch_num), len);
	  else key = "";
         end;
      go to verify_done;				/* end of read_key routine */

read_indx_file:
   entry (iocb_ptr, buff_ptr, buff_len, rec_len, code);
      current_retry_loc = read_retry;
      go to initialize;
retry_loc (5):
      call find_next_record;
      if code = 0					/* next position exists */
      then
         do;
	  call set_next_reclp_and_contents (block_ptr, lock_ptr);
	  rec_len = record_len;
	  if is_sequential_open & ((code = 0) | ((code ^= error_table_$end_of_info) & (code ^= error_table_$no_record)))
	  then indx_cb.next_record_position = 2;	/* next record follows that just read */
	  else indx_cb.next_record_position = 0;
         end;
      go to verify_done;				/* end of read routine */

position_indx_file:
   entry (iocb_ptr, pos_type, skip, code);
      if pos_type = 0
      then
         do;
	  current_retry_loc = skip_retry;
	  saved_error_info = iocb_ptr -> iocb.open_data_ptr -> indx_cb.error;
	  go to initialize;
retry_loc (6):
	  if indx_cb.next_record_position = 0		/* position may be undefined */
	  then
	     do;
	        call find_next_record;		/* sets position indicators */
	        if code ^= 0			/* really is an error */
	        then return;
	     end;
	  indx_cb.outside_index = "0"b;		/* current pos moves back into index */
	  if pos_incorrect
	  then
	     do;
	        call restore_position;
	        if code ^= 0
	        then go to verify_done;
	     end;
	  else pos_ptr = file_position_ptr;
	  indx_cb.at_bof, indx_cb.at_eof = "0"b;
	  indx_cb.skip_state = 0;
	  if skip >= 0				/* forward skip */
	  then
	     do;
	        count = skip + indx_cb.next_record_position - 1;
	        indx_cb.current_record_is_valid, indx_cb.ready_to_write = "0"b;

	        do while (count > 0);			/* advance until count zero or eof reached */
		 branches_left = last_branch_num - branch_num;
						/* branches in current node */
		 if branches_left > 0
		 then if (indx_cb.subset_selected = "00"b) & (branch (branch_num) = 0)
						/* leaf node */
		      then
		         do;			/* skip over a chunk of branches in one node */
			  chunk_size = min (count, branches_left);
						/* as many as possible */
			  branch_num = branch_num + chunk_size;
						/* will be last if more to skip */
			  count = count - chunk_size; /* remainder to be skipped */
		         end;
		      else
		         do;			/*  skip one from upper to leaf */
			  if indx_cb.subset_selected ^= "00"b
			  then
			     do;			/* see if this entry is being masked */
			        call check_subset (record_designator (branch_num));
			        if ^rec_deleted	/* this one counts */
			        then count = count - 1;
			     end;
			  else count = count - 1;	/* none are being masked */
			  branch_num = branch_num + 1;/* next non-leaf branch */
			  call find_leftmost_descendent;
		         end;
		 else
		    do;				/* move to entry from last branch in a node */
		       call find_this_entry;
		       if pos_ptr = root_position_ptr	/* at end of file */
		       then
			do;
			   count = -count;		/* causes exit from loop */
			   code = error_table_$end_of_info;
			end;
		    end;
	        end;

	        if code ^= 0			/* attempted to pass eof */
	        then
		 do;
		    call position_eof;		/* set position properly */
		    indx_cb.error.type = skip_error;	/* error -- attempt to pass end of file on position skip */
		    indx_cb.error.requested = skip;	/* number of skips specified in call */
		    indx_cb.error.received = skip + count;
						/* number of records actually skipped */
		 end;
	        else indx_cb.next_record_position = 1;
	     end;					/* end of forward skip case */
	  else
	     do;					/* backward skip */
	        count = 1 - skip - indx_cb.next_record_position;

	        do while (count > 0);
		 if count = 1
		 then
		    do;				/* backspace by a single branch */
back_1:
		       call find_prev_entry;		/* handles exceptions */
		       if branch_num = 1		/* beginning of file */
		       then
			do;
			   code = error_table_$end_of_info;
			   count = -count;		/* causes exit from loop */
			end;
		       else
			do;
			   branch_num = branch_num - 1;
			   if indx_cb.subset_selected ^= "00"b
			   then
			      do;
			         call check_subset (record_designator (branch_num));
			         if ^rec_deleted
			         then count = count - 1;
			      end;
			   else count = count - 1;
			end;
		    end;
		 else if branch_num > 1		/* not at first branch in node */
		 then if (indx_cb.subset_selected = "00"b) & (branch (branch_num) = 0)
		      then
		         do;			/* skip over a bunch of leaf branches */
			  chunk_size = min (count, branch_num - 1);
			  count = count - chunk_size;
			  branch_num = branch_num - chunk_size;
						/* does the backspacing */
		         end;
		      else go to back_1;
		 else go to back_1;
	        end;

	        if code ^= 0
	        then
		 do;				/* set position properly and save error info */
		    call position_bof;
		    indx_cb.error.type = skip_error;
		    indx_cb.error.requested = skip;
		    indx_cb.error.received = skip - count;
						/* actual number successfully skipped */
		 end;
	        else
		 do;
		    indx_cb.next_record_position = 1;
		    indx_cb.current_record_is_valid = "1"b;
		    indx_cb.ready_to_write = dup_ok;
		    indx_cb.skip_state = -1;		/* causes reverse scanning over deleted records */
		 end;
	     end;					/* end of backward skip case */
         end;					/* end of position skip case */
      else if abs (pos_type) = 1			/* valid type */
      then
         do;
	  current_retry_loc = pos_bof_or_eof_retry;
	  go to initialize;
retry_loc (7):
	  if pos_type = 1
	  then call position_eof;
	  else call position_bof;
	  indx_cb.outside_index = "0"b;
	  pos_incorrect = "0"b;
         end;
      else
         do;
	  code = error_table_$bad_arg;
	  return;
         end;
      go to verify_done;				/* end of position routine */

control_indx_file:
   entry (iocb_ptr, order, info_ptr_arg, code);
      info_ptr = info_ptr_arg;
      code = 0;

      if order = "get_key"
      then
         do;
	  current_retry_loc = gk_retry;
	  go to initialize;
retry_loc (8):					/* first validate arguments in info structure */
	  if ^gk_inf.input_key & (gk_inf.current = "1"b) & (gk_inf.input_desc)
	  then
	     do;
	        code = error_table_$bad_arg;
	        go to exit;				/* abort */
	     end;
	  if (gk_inf.current & ^gk_inf.input_key) | (^gk_inf.input_desc & (gk_inf.desc_code = 1))
						/* current position required */
	  then
	     do;
	        call check_current;
	        if code ^= 0
	        then go to verify_done;		/* abort--no current position */
	        if ^gk_inf.input_key & gk_inf.current	/* current key required */
	        then if indx_cb.outside_index		/* no current key is defined */
		   then
		      do;
		         code = error_table_$no_key;
		         gk_inf.descrip = indx_cb.current_descrip;
		         gk_inf.key_len = 0;
		         go to verify_done;		/* abort this operation */
		      end;
	        if gk_inf.reset_pos & (^indx_cb.shared | ^saved_state.current_record_is_valid)
	        then
		 do;
		    saved_state.skip_state = indx_cb.skip_state;
		    call save_correct_pos;
		 end;
	     end;
	  else if gk_inf.reset_pos & ^indx_cb.shared
	  then
	     do;
	        saved_state.skip_state = indx_cb.skip_state;
	        call save_correct_pos;
	     end;
	  if ^gk_inf.input_key			/* current or next position */
	  then if gk_inf.current			/* current position */
	       then if indx_cb.subset_selected ^= "00"b	/* must see if this record is being masked */
		  then
		     do;
		        call check_subset (indx_cb.current_descrip);
		        if rec_deleted
		        then code = error_table_$no_record;
		     end;
		  else ;				/* just set gk_info and return now */
	       else
		do;				/* find next entry, possibly scanning over unwanted descriptors */
		   if pos_incorrect
		   then
		      do;
		         call restore_position;
		         if code ^= 0
		         then go to verify_done;
		      end;
		   else pos_ptr = indx_cb.file_position_ptr;
		   if indx_cb.next_record_position = 1
		   then if branch_num < last_branch_num
		        then go to next_found;
		        else ;			/* will have to handle special case */
		   else if indx_cb.next_record_position = 2
		   then branch_num = branch_num + 1;
		   else
		      do;
		         code = error_table_$no_record;
		         go to next_found;		/* abort */
		      end;
		   call find_this_entry;
		   if pos_ptr = root_position_ptr	/* eof */
		   then
		      do;
		         code = error_table_$end_of_info;
		         if ^gk_inf.reset_pos
		         then call position_eof;
		      end;
next_found:
		   if code = 0
		   then
		      do;
		         pad_key_ptr = addr (indx_cb.new_key);
						/* in case previous seek_head applies */
		         call gk_scan;		/* find valid entry by scanning if necessary */
		      end;
		end;
	  else
	     do;					/* seek to proper location in index */
	        pad_key_ptr = addr (gk_pad_key);
	        pad_key_len = 256;			/* must pad with 0's for proper seek */
	        len = min (fixed (gk_inf.head_size), gk_inf.key_len);
	        unspec (substr (pad_key, len + 1, 256 - len)) = "0"b;
						/* pad with 0's */
	        substr (pad_key, 1, len) = substr (gk_inf.key, 1, len);
	        indx_cb.pos_incorrect = "0"b;
	        call seek_head ((gk_inf.rel_type), addr (pad_key_info), (fixed (gk_inf.head_size)));
	        if pos_ptr = root_position_ptr		/* no luck */
	        then
		 do;
		    if ^gk_inf.reset_pos
		    then indx_cb.at_bof, indx_cb.at_eof = "0"b;
		    code = error_table_$no_key;
		 end;
	        else
		 do;
		    if gk_inf.rel_type = 0
		    then indx_cb.skip_state = fixed (gk_inf.head_size);
						/* indicates scanning after head match */
		    else indx_cb.skip_state = 0;	/* just scan forward */
		    call gk_scan;			/* finds satisfactory descriptor */
		    if ^indx_cb.shared & ^gk_inf.reset_pos
		    then call save_correct_pos;	/* in case of scan */
		 end;
	     end;
	  if code = 0
	  then
	     do;
	        gk_inf.key_len = get_key_length ();
	        gk_inf.key = substr (keys, key_pos (branch_num), key_length (branch_num));
	        gk_inf.descrip = record_designator (branch_num);
	        if ^gk_inf.reset_pos			/* leave position here */
	        then
		 do;
		    indx_cb.ready_to_write = indx_cb.dup_ok;
		    indx_cb.outside_index, indx_cb.at_eof, indx_cb.at_bof = "0"b;
		    indx_cb.current_record_is_valid = "1"b;
		    indx_cb.next_record_position = 1;
		 end;
	        else
		 do;
		    indx_cb.skip_state = saved_state.skip_state;
		    indx_cb.pos_incorrect = "1"b;
		 end;
	     end;
	  else if ^gk_inf.reset_pos			/* leave next position undefined */
	  then
	     do;
	        indx_cb.ready_to_write, indx_cb.current_record_is_valid, indx_cb.outside_index = "0"b;
	        if ^(indx_cb.at_bof | indx_cb.at_eof)
	        then indx_cb.next_record_position = 0;
	     end;
	  else
	     do;
	        indx_cb.skip_state = saved_state.skip_state;
	        indx_cb.pos_incorrect = "1"b;
	     end;
	  go to verify_done;
         end;

      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      code = 0;

      if order = "record_status"
      then
         do;
	  call check_rs_args;			/* aborts on error */
	  if code ^= 0				/* fatal error detected by arg checking */
	  then return;				/* abort--don't bother looking at file */
	  current_retry_loc = rs_retry_1;
	  if indx_cb.shared
	  then if ^passive_op & (^indx_cb.stat | rs_info.create_sw)
						/* first must lock file */
	       then go to init_down_up;
	       else if ^(indx_cb.outside_index | rs_info.locate_sw)
	       then go to initialize;
	       else
		do;				/* get file's change count, but synch at record level */
		   current_retry_loc = rs_retry_2;
		   go to initialize;
retry_loc (9):
		   new_change_count = file_base.change_count;
		   if new_change_count ^= indx_cb.last_change_count
						/* asynch change */
		   then
		      do;				/* bring process vars up to date */
		         call initialize_ptrs;
		         indx_cb.pos_incorrect = "1"b;
		         indx_cb.last_change_count = new_change_count;
		      end;			/* open data consistent with last change count now */
		end;				/* file level verification will occur if non-stationary */
	  else go to init_up_down;
retry_loc (10):
	  call record_status;			/* may create rec or alter lock, as well as returning info
						   and setting current current record pos outside index */
	  if rs_info.unlock_sw & ^rs_info.lock_sw	/* explicit unlocking without locking */
	  then if code = 0
	       then code = error_table_$lock_not_locked;	/* complain if not already locked by me */
	       else if code = error_table_$locked_by_this_process
						/* expected */
	       then
		do;
		   i_locked_rec = "1"b;		/* cause unlocking to be done */
		   code = 0;
		end;
	  if ^passive_op				/* file modification */
	  then go to unlock_exit;			/* unlock after shared file alteration */
	  else if rs_info.unlock_sw
	  then go to unlock_exit;			/* unlock the record only */
	  else if ^indx_cb.outside_index		/* file level synchronization */
	  then go to verify_done;			/* will re-attempt operation if asynch changes detected */
	  else if block_ptr ^= null
	  then if ^block_ptr -> record_block.stationary	/* non-stationary */
	       then go to verify_done;		/* may have to retry to get snapshot */
	  return;					/* may have already made external exit */
         end;					/* record_status proc does external exit */

      if order = "seek_head"
      then if is_sequential_open & ^is_ks_out & (mode > 7 /* keyed */)
	 then
	    do;					/* won't be no_operation */
	       if (info.rel_type < 0) | (info.rel_type > 2) | (n < 0)
	       then
		do;				/* bag arg--abort */
		   code = error_table_$bad_arg;
		   return;
		end;
	       else
		do;
		   current_retry_loc = sh_retry;
		   go to initialize;
retry_loc (11):
		   indx_cb.at_bof, indx_cb.at_eof = "0"b;
		   indx_cb.outside_index = "0"b;
		   pad_key_ptr = addr (indx_cb.new_key);
		   pad_key_len = 256;
		   unspec (substr (pad_key, n + 1, 256 - n)) = "0"b;
						/* pad with zeroes, not blanks */
		   substr (pad_key, 1, n) = search_key;
		   call seek_head (info.rel_type, addr (pad_key_info), info.n);
		   if pos_ptr = indx_cb.root_position_ptr
						/* not found */
		   then code = error_table_$no_record;
		   if code = 0
		   then
		      do;
		         if indx_cb.dup_ok
		         then indx_cb.ready_to_write = "1"b;
		         else indx_cb.ready_to_write = "0"b;
		         indx_cb.current_record_is_valid = "1"b;
		         indx_cb.next_record_position = 1;
		         if info.rel_type = 0		/* exact match was required */
		         then indx_cb.skip_state = n;	/* will only scan while head condition is met */
		         else indx_cb.skip_state = 0;	/* any subsequent entry will do on detection of deletion */
		         if indx_cb.subset_selected ^= "00"b
						/* select or exclude in effect */
		         then call sh_scan;		/* scan for entry in the current subset */
		      end;
		   else
		      do;
		         indx_cb.ready_to_write = "0"b;
		         indx_cb.current_record_is_valid = "0"b;
		         indx_cb.next_record_position = 0;
		      end;
		   pos_incorrect = "0"b;
		   go to verify_done;		/* will save key if shared */
		end;
	    end;

      if ^is_read_only				/* must have modify access */
      then
         do;
	  if (order = "add_key")
	  then go to add_key;

	  else if (order = "delete_key")
	  then go to delete_key;			/* does the work */

	  else if (order = "reassign_key")
	  then go to reassign_key;
         end;

      if order = "select"
      then go to select;

      if order = "exclude"
      then go to exclude;

      if order = "error_status"
      then
         do;
	  if error_info.version ^= 1
	  then code = error_table_$bad_arg;
	  else
	     do;
	        error_info.type = indx_cb.error.type;
	        error_info.requested = indx_cb.error.requested;
	        error_info.received = indx_cb.error.received;
	     end;
	  return;
         end;

      if order = "min_block_size"
      then
         do;
	  indx_cb.min_res = max (0, mbs_info.min_residue);
	  indx_cb.min_cap = max (0, mbs_info.min_capacity);
	  return;
         end;

      if indx_cb.shared
      then
         do;
	  if (order = "set_wait_time")
	  then
	     do;					/* change setting of max wait time */
	        if new_wait_time = -2			/* collection delay version */
	        then if wt_info.collection_delay_time < 0
		   then code = error_table_$bad_arg;
		   else indx_cb.collection_delay_time = 1000000 * wt_info.collection_delay_time;
	        else if new_wait_time < -1
	        then code = error_table_$bad_arg;
	        else indx_cb.wait_time = 1000000 * new_wait_time;
	        return;				/* that's all there is to it */
	     end;

	  if (order = "set_file_lock") & ^indx_cb.is_read_only
	  then
	     do;					/* attempt to lock or unlock the file */
	        if info_ptr -> set_lock_flag		/* wants to set the lock */
	        then if indx_cb.leave_locked
		   then code = error_table_$locked_by_this_process;
		   else
		      do;				/* lock and restore process vars */
		         current_retry_loc = lock_file_retry;
		         go to init_down_up;		/* setup handler */
retry_loc (24):
		         if set_lock_info.exclusive
		         then file_action = read_exclude;
						/* stops readers */
		         indx_cb.read_exclu = info_ptr -> exclusive;
		         indx_cb.leave_locked = "1"b;	/* remember locked */
		      end;
	        else if ^indx_cb.leave_locked
	        then
		 do;
		    code = error_table_$lock_not_locked;
		    if indx_cb.file_base_ptr -> file_base.lock_word = indx_cb.saved_lock_copy
						/* my lock */
		    then call check_code (code, "File lock set by another opening in this
process.  This opening can't clear the lock.  Either
unlock from the opening that locked, of force unlocking
with the vfile_adjust command.");
		 end;
	        else
		 do;				/* OK to unlock */
		    saved_state_block = current_state_block;
		    cleanup_flags = "100000"b;	/* OK to unlock file */
		    on cleanup call restore_abort;
		    leave_locked = "0"b;		/* remember I unlocked */
		    f_b_ptr = file_base_ptr;
		    pos_ptr = file_position_ptr;
		    fs_ptr = indx_cb.file_state_ptr;
		    if file_action = read_exclude
		    then file_action = 0;		/* clear read lock */
		    indx_cb.read_exclu = "0"b;
		    go to unlock_exit;		/* sets last_change_count */
		 end;
	        return;				/* finished with operation */
	     end;
         end;

      if order = "file_status"
      then
         do;
	  call vfile_status_$seg (iocb_ptr, file_base_ptr, info_ptr, code);
	  return;
         end;

      if order = "io_call"
      then
         do;
	  call vfile_io_control (iocb_ptr, file_base_ptr, info_ptr, code);
	  return;					/* work done on recursive call */
         end;

      if order = "io_call_af"
      then
         do;
	  call vfile_io_control$af (iocb_ptr, file_base_ptr, info_ptr, code);
	  return;					/* return from call for active function */
         end;

      code = error_table_$no_operation;
      return;					/* end of control routine */

get_ptr:
   proc (designator_arg) returns (ptr);
      return (addr (seg_ptr_array (des_arg.comp_num) -> seg_array (fixed (des_arg.offset))));
      dcl	    designator_arg	       fixed (35);
      dcl	    1 des_arg	       like designator_struct aligned based (addr (designator_arg));
   end;

lock_current_record:
   proc (block_ptr, lock_ptr, i_locked_mask, ref_count_change);
						/* non-passive, non-scanning */
						/* delete_record suppresses cleanup by setting input_only flag */
      if indx_cb.repeating				/* recovery in progress */
      then
         do;					/* reconstruct pointers */
	  f_b_ptr = indx_cb.file_base_ptr;
	  fs_ptr = indx_cb.file_state_ptr;
	  block_ptr = get_pointer (indx_cb.current_descrip);
	  lock_ptr = null;
	  cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask);
	  if file_base.was_stat			/* record may have been stationary type */
	  then
	     do;					/* get correct lock_ptr */
	        if (file_action = reassigning_key)	/* maybe non-stat */
	        then if ^block_ptr -> record_block.stationary
		   then return;			/* suppress unlocking */
	        lock_ptr = addr (block_ptr -> stat_struct.record_lock);
	     end;
	  return;
         end;
      passive = "0"b;
      scan = "0"b;					/* treats logical deletion as error without scanning */
      go to get_reclp;				/* main body of record access synch routine */
set_next_reclp_and_contents:				/* for read_record op */
set_next_reclp_seek:				/* passive with restricted
						   scanning, i.e. scanning of duplicate keys matching seek arg */
set_next_reclp:
   entry (block_ptr, lock_ptr);			/* passive with scanning */
      passive = "1"b;				/* never modify via this entry */
      scan = "1"b;					/* means scan over absent entries, if found */
      go to get_reclp;
set_current_reclp:
   entry (block_ptr, lock_ptr);			/* passive, non-scanning */
      passive = "1"b;
      scan = "0"b;					/* will not scan if record is logically absent */
get_reclp:
      code = 0;
      block_ptr = null;				/* loop condition */
      lock_ptr = null;
      record_ptr = null;
      record_len = 0;
      max_rec_wds = 0;				/* allocated block size minus header size */
      ref_cnt = 0;					/* reference count--stationary records only */

      do while (block_ptr = null);			/* may loop over logically absent records */
         if indx_cb.subset_selected ^= "00"b		/* may be masked */
         then call check_subset (indx_cb.current_descrip);	/* sets rec_deleted flag */
						/* will know whether or not to clean up by nullness of block_ptr */
         else rec_deleted = "0"b;			/* entry not masked so far */
         if ^rec_deleted				/* OK to look for allocation */
         then
	  do;					/* look at the record block allocation */
	     if indx_cb.current_descrip <= 0		/* no allocation possible for this descriptor */
	     then
	        do;				/* check for error and return */
		 if ^passive			/* only attempt to lock may regard as an error */
		 then if indx_cb.trans
		      then code = error_table_$no_room_for_lock;
						/* must support null descriptor special case */
		 return;				/* nothing more to do in this routine */
	        end;				/* will exit loop with non-null block_ptr */
	     if indx_cb.shared & ^indx_cb.leave_locked & ^i_locked_file & ^indx_cb.outside_index
						/* possible asynch file change errors */
	     then if indx_cb.last_change_count ^= file_base.change_count
						/* asynch change
						   has occurred--descriptor may not be valid--reobtain */
		then go to verify_done;		/* will abort if no time left */
	     block_ptr = get_pointer (indx_cb.current_descrip);
						/* ptr to block header */
	     if block_ptr = null			/* should never happer */
	     then call check_code (error_table_$no_record, "Can't obtain record pointer--reason unknown.");
	     if ^block_ptr -> record_block.stationary	/* non-stationary record */
	     then call inspect_non_stat_rec;		/* gets lock ptr if room */
	     else call inspect_stat_record;		/* sees if logically deleted */
	  end;					/* rec_deleted flag set if logically absent */
         if rec_deleted				/* user can't see this entry */
         then
	  do;					/* see if OK to scan and/or garbage-collect */
	     call mask_entry;			/* OK to scan if returned code = 0 */
						/* no refl entry required, since deletion is irreversible */
						/* until index changes supported under TP, however, there is still
						   the reversible deletion of pre-created records to be considered */
	     if code ^= 0				/* can't scan--just return with error */
	     then return;				/* abort */
						/* otherwise block_ptr will necessarily be null */
	  end;					/* fall through case scans next entry */
      end;					/* scan over logically masked or deleted entries */

      return;					/* end of main get_reclp routine */

mask_entry:
   proc;						/* takes care of scanning and cleanup */
						/* returns either with a non-zero code or null block_ptr */
      if ^scan					/* don't scan--return no_record error */
      then
         do;					/* still may clean up one entry, though */
	  if ^indx_cb.is_read_only & indx_cb.stat & (block_ptr ^= null)
						/* OK to collect */
	  then
	     do;
	        if indx_cb.outside_index
	        then if (ref_cnt > 0) | passive		/* nothing can be collected now */
		   then
		      do;				/* return immediately */
		         code = error_table_$no_record;
		         return;
		      end;
		   else threshold = 0;		/* garbage collection threshold */
	        else threshold = 1;			/* can delete one key along with the record */
	        call collect_item;			/* may delete key and/or record */
	     end;
	  code = error_table_$no_record;		/* warn user record is absent */
	  return;					/* done with non-scanning case */
         end;
      if block_ptr ^= null				/* may have to clean up */
      then
         do;					/* end up with null block_ptr */
	  if ^indx_cb.is_read_only & indx_cb.stat	/* may collect item */
	  then
	     do;
	        threshold = 1;			/* only delete key for larger ref counts */
	        call collect_item;
	        indx_cb.outside_index = "0"b;		/* in case only the key was deleted */
	     end;
	  else if indx_cb.skip_state >= 0
	  then indx_cb.next_record_position = 2;
	  block_ptr = null;				/* allow scanning to continue if final code is zero */
	  lock_ptr = null;
         end;
      else if indx_cb.skip_state >= 0
      then indx_cb.next_record_position = 2;		/* advance */
      if (indx_cb.skip_state < 0)			/* scan backwards */
      then if indx_cb.next_record_position = 2		/* staggerred next and current */
	 then
	    do;					/* reset next to current--must exist */
	       indx_cb.next_record_position = 1;
	       indx_cb.current_descrip = record_designator (branch_num);
	       code = 0;				/* clear any old code */
	       return;				/* backward scan continues successfully */
	    end;
	 else call backspace;			/* also sets code */
      else call find_next_record;			/* scan forward--also sets code */
      if code = 0					/* did not run into either end of file */
      then
         do;					/* see if code must be set */
	  if current_retry_loc = seek_retry
	  then if key = substr (keys, key_pos (branch_num), get_key_length ())
	       then return;				/* OK to check this entry--key matches */
	       else ;				/* fall through complains about no_record error */
	  else if indx_cb.skip_state > 0		/* follows seek_head */
	  then if substr (indx_cb.new_key, 1, indx_cb.skip_state)
		= substr (keys, key_pos (branch_num), min (get_key_length (), indx_cb.skip_state))
						/* head still matches that of prior seek_head */
	       then return;				/* OK to continue search for record with this descrip */
	       else ;				/* fall through and complain */
	  else return;				/* previous entry obtained without eof error */
	  code = error_table_$no_record;		/* complain */
         end;					/* fall through resets skip state */
      else if (current_retry_loc = seek_retry) /* called by seek_key */ & (code = error_table_$end_of_info)
      then code = error_table_$no_record;		/* suitable code */
						/* unable to continue scanning, although permitted */
      indx_cb.skip_state = 0;				/* resume normal scanning forward */
      return;					/* done masking one entry */

collect_item:
   proc;						/* garbage collection routine */
      if indx_cb.trans
      then if (mod > 0) & (mod = current_t_code)		/* locked by this transaction */
	 then go to handle_pos;			/* don't garbage collect yet */
      if cur_mod = -3				/* special case--means creation in progress */
      then
         do;
	  call get_lock_status (lock_ptr, er_code);
	  if er_code ^= error_table_$lock_is_invalid
	  then go to handle_pos;			/* maybe skip over this entry */
         end;
      if ref_cnt <= threshold				/* record can be removed */
						/* ref count obtained in set_current_image_info logic */
      then if indx_cb.shared
	 then if time_stamp + indx_cb.collection_delay_time > clock ()
	      then go to handle_pos;			/* just skip over entry if scanning */
      if indx_cb.shared
      then indx_cb.shared = ^indx_cb.leave_locked & ^i_locked_file;
      else saved_state.skip_state = indx_cb.skip_state;
      indx_cb.is_sequential_open = "1"b;
      if ref_cnt <= threshold				/* OK to dispose of stationary header */
      then call delete_indx_file (iocb_ptr, er_code);
      else call control_indx_file (iocb_ptr, "delete_key", null, er_code);
      if indx_cb.mode < 11
      then indx_cb.is_sequential_open = "1"b;
      else indx_cb.is_sequential_open = "0"b;
      indx_cb.skip_state = saved_state.skip_state;
      indx_cb.shared = saved_state.shared;
      pos_ptr = indx_cb.file_position_ptr;		/* because of intervening external vfile_ calls */
      return;					/* item collected */
handle_pos:
      if scan & (indx_cb.skip_state >= 0)
      then indx_cb.next_record_position = 2;		/* skip over entry */
      dcl	    er_code	       fixed (35);
   end collect_item;

      dcl	    threshold	       fixed (34);
   end mask_entry;

inspect_non_stat_rec:
   proc;						/* examines a non-stationary record */
      blksz = block_ptr -> record_block.block_size;
      max_rec_wds = blksz - 2;
      if (blksz > divide (length (block_ptr -> record_block.record) + 11, 4, 19, 0))
      then lock_ptr = addr (block_ptr -> non_stat_struct.record_lock);
						/* room for lock at tail of block */
      else lock_ptr = null;				/* no room for separate record lock */
      if indx_cb.trans				/* transaction mode--error--record must be stationary */
      then code = error_table_$no_room_for_lock;		/* rec header too small */
      else if lock_ptr = null				/* can't touch lock */
      then if passive
	 then if block_ptr -> record_block.lock_flag
	      then call get_lock_status (addr (file_base_ptr -> file_base.lock_word), code);
	      else code = 0;
	 else code = 0;				/* no lock to set--treat as successful */
      else if ^passive				/* wants to lock--file must first be locked */
      then if indx_cb.shared & ^indx_cb.leave_locked & ^i_locked_file
						/* I haven't locked */
	 then
	    do;					/* file must first be locked to lock non-stat record */
	       call lock_file_check;			/* may adjust the file */
						/* aborts if file busy or unrecoverable */
	       go to retry_loc (current_retry_loc);	/* try again with file locked */
	    end;					/* never lock non-stationary record without first locking file */
	 else
	    do;					/* try to lock the record */
	       call compute_time_left;
	       if ^(lock_ptr -> based_lock = indx_cb.saved_lock_copy)
	       then cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask);
	       call set_lock (lock_ptr, time_left, code); /* really shouldn't
						   wait with file locked in all cases */
	       if code ^= 0				/* lock was set */
	       then if (code = error_table_$locked_by_this_process) | (code = error_table_$invalid_lock_reset)
						/* not fatal */
		  then if ^block_ptr -> record_block.lock_flag
						/* record is valid */
		       then
			do;
			   code = 0;
			   cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask);
			end;
		       else ;			/* locking was complete */
		  else if code = error_table_$lock_wait_time_exceeded
		  then code = error_table_$record_busy; /* appropriate code */
	    end;					/* done with locking attempt */
      else if block_ptr -> record_block.lock_flag		/* may be busy */
      then call get_lock_status (lock_ptr, code);		/* sets code without locking */
      else code = 0;				/* contents must be valid */
      record_ptr = addr (block_ptr -> record_block.record);
      record_len = length (record_ptr -> based_vstring);
      if current_retry_loc = read_retry			/* contents also wanted */
      then call return_contents;
      dcl	    blksz		       fixed (19);
   end inspect_non_stat_rec;

inspect_stat_record:
   proc;						/* looks at a stationary record */
      lock_ptr = addr (block_ptr -> stat_struct.record_lock);
      if passive					/* just obtaining status--not locking */
      then
         do while ("1"b);				/* loop for asynch changes */
keep_loopin:
	  call get_current_image_info;
	  if code ^= 0				/* fatal error at this point */
	  then if code ^= error_table_$higher_inconsistency
	       then return;				/* abort immediately */
	       else
		do;				/* maybe waiting will help */
		   call get_lock_status (lock_ptr, code);
		   if code ^= error_table_$record_busy	/* not other
						   live process--no point waiting */
		   then
		      do;
		         code = error_table_$higher_inconsistency;
		         return;			/* warn user that he can't get valid image */
		      end;
		   mics_left = timeout - clock ();
		   if mics_left <= 0		/* no time to wait */
		   then return;
		   call timer_manager_$sleep (min (50000, mics_left), "10"b);
		   code = 0;			/* set up for another try */
		   go to keep_loopin;
		end;
	  if ind_desc = -1				/* logically deleted */
	  then
	     do;					/* return immediately */
	        rec_deleted = "1"b;
	        if cur_mod ^= -3			/* still must take care or ref list */
	        then return;			/* may continue scanning */
	     end;
	  else if ind_desc = -2			/* means that before image applies */
	  then if block_ptr -> record_block.indirect
	       then ind_desc = block_ptr -> ind_struct.prev_desc;
	       else ind_desc = indx_cb.current_descrip;	/* compact case */
	  if mod = 0				/* may need lock status to warn user */
	  then if block_ptr -> record_block.lock_flag
	       then call get_lock_status (lock_ptr, code);
	  if indx_cb.shared & indx_cb.trans /* reference within a transaction */
	     & ((code = 0) | (code = error_table_$locked_by_this_process) | (code = error_table_$lock_is_invalid))
	  then
	     do;					/* take care of reference list */
	        if current_t_code = 0			/* no transaction number assigned yet */
	        then call get_t_code;			/* assigns a code or aborts if unable */
	        if (mod ^= current_t_code)		/* not already locked by this transaction */
	        then call set_ref_list_entry (block_ptr); /* detects invalid prior ref */
	     end;
	  call set_stat_reclp;			/* ptr to stationary rec contents */
	  if current_retry_loc = read_retry
	  then call return_contents;
	  if fixed (time_stamp_struct.time_last_modified) = time_stamp
	  then return;
	  if clock () > timeout
	  then
	     do;
	        code = error_table_$record_busy;
	        return;
	     end;
         end;					/* loop until record snapshot passively obtained */
      else
         do;					/* lock the record and look at its header */
reattempt:					/* retry point for post-adjustment case */
	  call compute_time_left;
	  if ^(lock_ptr -> based_lock = indx_cb.saved_lock_copy)
	  then cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask);
	  call set_lock (lock_ptr, time_left, code);
	  er_code = code;				/* save returned code giving lock status */
	  call get_current_image_info;
	  if code ^= 0				/* lock was non-zero */
	  then if code = error_table_$higher_inconsistency
	       then
		do;
		   if er_code = error_table_$locked_by_this_process
		   then code = error_table_$record_busy;/* suppress attempt to unlock record */
		   else if stacq (lock_ptr -> based_lock, (36)"1"b, indx_cb.saved_lock_copy)
		   then ;				/* invalidate the lock again */
		   return;			/* abort--fatal error */
		end;
	       else if code = error_table_$lock_wait_time_exceeded
	       then
		do;				/* abort with suitable code */
		   code = error_table_$record_busy;
		   return;
		end;
	       else if mod = 0			/* see if warning required */
	       then if block_ptr -> record_block.lock_flag
		  then ;				/* leave code non-zero as a warning */
		  else
		     do;
		        code = 0;
		        cleanup_flags = cleanup_flags | (i_locked_mask & rec_lock_mask);
						/* permit unlocking */
		     end;
	       else if code = error_table_$locked_by_this_process
	       then if ^(indx_cb.trans)
		  then
		     do;				/* abort with suitable code */
		        code = error_table_$record_busy;/* fatal error */
		        return;			/* not locked by own transaction */
		     end;
		  else if (mod = current_t_code)
		  then code = 0;			/* suppress warning--already locked by this trans */
		  else
		     do;				/* abort with suitable code */
		        code = error_table_$record_busy;/* fatal error */
		        return;			/* not locked by own transaction */
		     end;
	       else
		do;				/* adjust record left locked by dead process */
		   call adjust_record (iocb_ptr, indx_cb.current_descrip, cur_mod, code);
		   call check_code (code, "Can't adjust a record locked by dead process.");
		   go to reattempt;			/* adjustment ends by unlocking--do again */
		end;
	  if ind_desc = -1				/* logically deleted record */
	  then if cur_mod = -3			/* new record this transaction */
	       then if mod = 0			/* this operation is creating */
		  then ind_desc = indx_cb.current_descrip;
		  else rec_deleted = "1"b;
	       else
		do;				/* not a pre-creation case */
		   rec_deleted = "1"b;
		   if block_ptr -> stat_struct.modifier = 0
		   then
		      do;				/* mark vfile_ operation in progress */
		         cleanup_flags = cleanup_flags | (i_locked_mask & negmod_mask);
						/* set bit indicating modifier set */
		         block_ptr -> stat_struct.modifier = -1;
		      end;
		   go to adjust_ref_count;		/* suppress ref list manipulation */
		end;
	  if indx_cb.trans				/* modification inside a transaction */
	  then
	     do;
	        if current_t_code = 0
	        then call get_t_code;
	        if mod ^= current_t_code		/* not already locked by this transaction */
	        then
		 do;				/* take care of ref list */
		    if block_ptr -> stat_struct.prev_mod = -3
						/* new record */
		    then call add_lock_list_entry (block_ptr, cleanup_flags & passive_ref_bit_mask);
						/* no need to verify this reference */
		    else
		       do;
			call set_lock_list_entry (block_ptr, cleanup_flags & passive_ref_bit_mask);
						/* check for prior passive ref */
			if (code ^= 0) & (code ^= error_table_$locked_by_this_process)
			   & (code ^= error_table_$invalid_lock_reset)
						/* fatal error */
			then return;		/* abort */
			block_ptr -> stat_struct.ind_comp = -1;
			time_stamp_struct.ind_offset = (17)"1"b;
						/* after descrip= -2 */
			block_ptr -> stat_struct.ref_count_after = ref_cnt;
						/* indicates after image initially same as before--special case */
		       end;
		    block_ptr -> stat_struct.modifier = current_t_code;
		    call set_stat_reclp;
		    ind_desc = -2;
		 end;
	        else if ind_desc = -2			/* before image applies */
	        then
		 do;
		    if block_ptr -> record_block.indirect
		    then ind_desc = block_ptr -> ind_struct.prev_desc;
		    else ind_desc = indx_cb.current_descrip;
		    call set_stat_reclp;
		    ind_desc = -2;
		 end;
	        else call set_stat_reclp;
	     end;
	  else
	     do;					/* initialize header for non-TP modification */
	        cleanup_flags = cleanup_flags | (i_locked_mask & negmod_mask);
						/* leave record locked but still need to zero modifier */
	        block_ptr -> stat_struct.modifier = -1;	/* non-TP operation in progress */
	        call set_stat_reclp;
	     end;
adjust_ref_count:
	  if ref_count_change < 0			/* decrementing */
	  then
	     do;					/* check lower limit constraint */
	        if rec_deleted			/* logically absent */
	        then min_ref_count = 0;		/* zero references permitted--can clean up */
	        else min_ref_count = 1;		/* not deleted--at least one ref must remain */
	        if ref_cnt + ref_count_change < min_ref_count
	        then
		 do;				/* abort */
		    code = error_table_$last_reference;
		    return;			/* suppress changing ref count below minimum */
		 end;
	     end;
	  else if ref_cnt + ref_count_change > max_ref_count
	  then
	     do;
	        code = error_table_$too_many_refs;
	        return;
	     end;
	  ref_cnt = ref_cnt + ref_count_change;
	  if rec_deleted & ^is_read_only & (ref_count_change ^= 0) & (block_ptr -> stat_struct.modifier = -1)
						/* record_status ref_count
						   change on a deleted record */
	  then
	     do;
	        block_ptr -> stat_struct.ref_count_after = ref_cnt;
	        block_ptr -> stat_struct.ref_count = ref_cnt;
	     end;					/* permits garbage collection of unkeyed records */
         end;					/* lock is now set */
      return;					/* end of main stat rec inspection routine */

get_current_image_info:
   proc;						/* same as set_current_image_info, except
						   that it checks for the case of an item that may have already been modified by this transaction */
      mod = block_ptr -> stat_struct.modifier;
      if (mod <= 0) | ^indx_cb.trans
      then call set_current_image_info;
      else if (mod = current_t_code)			/* own transaction */
      then
         do;					/* get after image info */
	  time_stamp = fixed (time_stamp_struct.time_last_modified);
	  cur_mod = mod;
	  ind_des.comp = stat_struct.ind_comp;
	  ind_des.offset = time_stamp_struct.ind_offset;
	  ref_cnt = stat_struct.ref_count_after;
         end;
      else call set_current_image_info;			/* handle any other case but own transaction */
   end get_current_image_info;

set_stat_reclp:
   proc;
      if ind_desc > 0				/* record allocation exists */
      then
         do;
	  if ind_desc = indx_cb.current_descrip		/* compact case */
	  then
	     do;
	        max_rec_wds = block_ptr -> record_block.block_size - stat_header_size;
	        record_ptr = addr (block_ptr -> stat_struct.record);
	     end;
	  else
	     do;
	        p = get_pointer (ind_desc);
	        max_rec_wds = p -> record_block.block_size - 2;
	        record_ptr = addr (p -> record_block.record);
	     end;
	  record_len = length (record_ptr -> based_vstring);
         end;
      dcl	    p		       ptr;
   end set_stat_reclp;

      dcl	    er_code	       fixed (35);
      dcl	    min_ref_count	       fixed;
      dcl	    mics_left	       fixed (71);
   end inspect_stat_record;

return_contents:
   proc;						/* gets record contents for read_record */
      if record_len > 0
      then if record_len <= buff_len
	 then buffer = substr (record_ptr -> based_vstring, 1, record_len);
	 else
	    do;
	       if buff_len > 0
	       then substr (buffer, 1, buff_len) = substr (record_ptr -> based_vstring, 1, buff_len);
	       code = error_table_$long_record;
	    end;
   end return_contents;

get_t_code:
   proc;						/* initializes the current transaction */
      call transaction_call_$assign (indx_cb.tcfp, 0, er_code);
						/* creates
						   a unique tcf entry for this transaction */
      call check_code (er_code, "Unable to assign a transaction number to the current transaction.");
      dcl	    er_code	       fixed (35);
   end get_t_code;

get_lock_status:
   proc (lockp, er_code);
      lock_copy = lockp -> based_lock;
      call set_lock (addr (lock_copy), 0, er_code);
      if er_code = 0
      then return;
      if er_code = error_table_$lock_wait_time_exceeded
      then er_code = error_table_$record_busy;
      else if er_code = error_table_$invalid_lock_reset
      then er_code = error_table_$lock_is_invalid;
      dcl	    lockp		       ptr;
      dcl	    er_code	       fixed (35);
      dcl	    lock_copy	       bit (36) aligned;
   end get_lock_status;

%include set_current_image_info;
      dcl	    1 non_stat_struct      based (block_ptr),
	      2 words	       (record_block.block_size - 1),
	      2 record_lock	       bit (36) aligned;
      dcl	    scan		       bit (1) aligned;
      dcl	    passive	       bit (1) aligned;
      dcl	    ref_count_change       fixed;
      dcl	    (lock_ptr, block_ptr)  ptr;
      dcl	    i_locked_mask	       bit (36) aligned;
   end lock_current_record;

check_subset:
   proc (descrip);					/* sees if descriptor has been excluded */
      temp_cbp = indx_cb.temp_iocbp -> iocb.open_data_ptr;
      temp_cbp -> indx_cb.file_position_ptr = temp_cbp -> indx_cb.root_position_ptr;
      subset_key = current_subset_bytes || descrip_bytes;
      call find_key (temp_cbp, (addr (subset_key)), search_code);
      if indx_cb.subset_selected = "10"b
      then if search_code = 0
	 then rec_deleted = "1"b;
	 else rec_deleted = "0"b;
      else if search_code ^= 0
      then rec_deleted = "1"b;
      else rec_deleted = "0"b;			/* verbose form to avoid operator call */
      dcl	    descrip	       fixed (35);
      dcl	    descrip_bytes	       char (4) based (addr (descrip));
      dcl	    temp_cbp	       ptr;
      dcl	    current_subset_bytes   char (4) based (addr (indx_cb.current_subset));
      dcl	    search_code	       fixed (35);
      dcl	    subset_key	       char (8) var;
   end check_subset;

gk_scan:
   proc;						/* called by get_key to find satisfactory descriptor */
      if ^gk_inf.input_desc
      then if gk_inf.desc_code = 0
	 then desc_known = "0"b;
	 else desc_known = "1"b;
      else desc_known = "1"b;
      if desc_known
      then
         do;
	  if gk_inf.input_desc
	  then wanted_desc = gk_inf.descrip;
	  else wanted_desc = indx_cb.current_descrip;
	  if indx_cb.subset_selected ^= "00"b
	  then
	     do;
	        call check_subset (wanted_desc);
	        if rec_deleted
	        then
		 do;
		    if ^gk_inf.reset_pos
		    then indx_cb.at_bof, indx_cb.at_eof = "0"b;
		    go to norec;			/* logically absent record */
		 end;
	     end;
         end;
      else if indx_cb.subset_selected = "00"b		/* any entry will do */
      then return;					/* current position is satisfactory */
      reset_position = gk_inf.reset_pos;
      go to scan_loop;				/* skip setup code for seek_head scan */

sh_scan:
   entry;						/* handles scanning for seek_head */
      desc_known = "0"b;
      reset_position = "0"b;

scan_loop:
      do while ("1"b);
         descrip = record_designator (branch_num);
         if desc_known
         then if descrip = wanted_desc
	    then return;				/* desired descriptor found */
	    else ;				/* must keep looking--scan */
         else
	  do;
	     call check_subset (descrip);
	     if ^rec_deleted			/* not logically masked by current subset */
	     then
	        do;
		 if ^reset_position
		 then indx_cb.current_descrip = descrip;/* must be valid for check_current */
		 return;				/* done with scanning */
	        end;
	  end;
         if indx_cb.skip_state < 0			/* scanning backward */
         then
	  do;
	     call find_prev_entry;
	     if branch_num = 1			/* bof */
	     then
	        do;
		 if ^reset_position
		 then call position_bof;
norec:
		 code = error_table_$no_record;	/* abort */
		 indx_cb.skip_state = 0;		/* resume default forward scanning */
		 return;				/* stop scanning */
	        end;
	     branch_num = branch_num - 1;
	  end;
         else
	  do;
	     branch_num = branch_num + 1;		/* advance one index entry */
	     call find_this_entry;
	     if pos_ptr = indx_cb.root_position_ptr	/* eof */
	     then
	        do;
		 if ^reset_position
		 then call position_eof;
		 go to norec;
	        end;
	     if indx_cb.skip_state > 0
	     then if substr (keys, key_pos (branch_num), min (key_length (branch_num), indx_cb.skip_state))
		   > substr (pad_key, 1, indx_cb.skip_state)
						/* key out of range */
		then
		   do;
		      if ^reset_position
		      then
		         do;
			  indx_cb.next_record_position = 0;
			  indx_cb.current_record_is_valid = "0"b;
		         end;
		      go to norec;
		   end;
	  end;
      end;

      dcl	    desc_known	       bit (1) aligned;
      dcl	    (wanted_desc, descrip) fixed (35);
      dcl	    reset_position	       bit (1) aligned;
   end gk_scan;

find_next_record:
   proc;
      code = 0;
      if pos_incorrect				/* must restore index pos */
      then
         do;
	  call restore_position;
	  if code ^= 0
	  then return;				/* asynch deletion */
         end;
      else pos_ptr = file_position_ptr;
      indx_cb.ready_to_write = indx_cb.dup_ok;
      indx_cb.outside_index, indx_cb.at_eof, indx_cb.at_bof = "0"b;
						/* reset if outside */
      indx_cb.current_record_is_valid = "1"b;
      if indx_cb.next_record_position = 1
      then
         do;
	  if branch_num < last_branch_num
	  then go to set_current;
         end;
      else if indx_cb.next_record_position = 2
      then
         do;					/* next record follows current position */
	  branch_num = branch_num + 1;
	  indx_cb.next_record_position = 1;
         end;
      else
         do;					/* next record is undefined */
	  code = error_table_$no_record;
	  indx_cb.current_record_is_valid = "0"b;
	  indx_cb.ready_to_write = "0"b;
	  return;
         end;
      call find_this_entry;
      if pos_ptr = root_position_ptr			/* end of file */
      then
         do;
	  call position_eof;			/* set process info and position */
	  code = error_table_$end_of_info;
         end;
      else
         do;
set_current:
	  indx_cb.current_descrip = record_designator (branch_num);
         end;
   end find_next_record;

find_this_entry:
   proc;						/* routine gets position of following index proc */
      call find_leftmost_descendent;			/* in case we are not at a leaf */
find_from_leaf:
   entry;

loop:
      if branch_num = last_branch_num
      then if last_branch_num > 1
	 then
	    do;
	       pos_ptr = parent_position_ptr;
	       go to loop;
	    end;

      file_position_ptr = pos_ptr;
   end find_this_entry;

find_prev_entry:
   proc;						/* routine finds position of preceding index entry */
      call find_rightmost_descendent;			/* in case non-leaf */

loop:
      if branch_num = 1
      then if last_branch_num > 1
	 then
	    do;
	       pos_ptr = parent_position_ptr;		/* position moves to parent node */
	       go to loop;
	    end;

      file_position_ptr = pos_ptr;
   end find_prev_entry;

backspace:
   proc;						/* moves index position back one, setting code if end of info */
      code = 0;
      if indx_cb.pos_incorrect
      then
         do;
	  call restore_position;
	  if code ^= 0
	  then return;				/* asynch deletion */
         end;
      else pos_ptr = indx_cb.file_position_ptr;
      indx_cb.outside_index = "0"b;
      call find_prev_entry;
      if branch_num = 1				/* beginning of file */
      then
         do;
	  code = error_table_$end_of_info;
	  call position_bof;
	  return;
         end;
      branch_num = branch_num - 1;
      indx_cb.current_descrip = record_designator (branch_num);
   end backspace;

seek_head:
   proc (rel_type, key_ptr, head_len);
      indx_cb.file_position_ptr = indx_cb.root_position_ptr;/* prepare for descent */
      call find_key (indx_cb_ptr, (key_ptr), foo);
      pos_ptr = indx_cb.file_position_ptr;
      call find_from_leaf;				/* in case of match in upper node */

      do while (pos_ptr ^= root_position_ptr);
         if substr (key_ptr -> based_vstring, 1, head_len)
	  = substr (keys, key_pos (branch_num), min (key_length (branch_num), head_len))
						/* heads match */
         then if rel_type ^= 2			/* that's fine */
	    then return;				/* satisfactory entry found */
	    else
	       do;				/* keep searching forward */
		branch_num = branch_num + 1;
		call find_this_entry;		/* handles exceptional cases */
	       end;
         else if rel_type > 0				/* looking for larger head--fine */
         then return;				/* search done */
         else pos_ptr = root_position_ptr;		/* causes exit from loop */
      end;

      dcl	    rel_type	       fixed;
      dcl	    key_ptr	       ptr;
      dcl	    head_len	       fixed;
   end seek_head;

get_pointer:
   proc (descrip) returns (ptr);
      if descrip < 4096
      then return (null);
      if (desc.comp_num >= 0) & (desc.comp_num <= indx_cb.old_last_comp_num)
						/* in case shared and unlocked */
      then if seg_ptr_array (desc.comp_num) = null
	 then p = get_seg_ptr (iocb_ptr, (desc.comp_num));
	 else ;					/* fall through */
      else call check_code (error_table_$bad_arg, "Invalid msf component.");
      return (get_ptr (descrip));
      dcl	    p		       ptr;
      dcl	    descrip	       fixed (35);
      dcl	    1 desc	       aligned based (addr (descrip)),
	      2 comp_num	       fixed (17) unal,
	      2 offset	       bit (18) unal;
   end get_pointer;

get_key_length:
   proc returns (fixed);
      len = key_length (branch_num);
      if indx_cb.min_key_len <= 0			/* keys never padded with blanks */
      then return (len);
      if len = indx_cb.min_key_len
      then
         do;
	  tail_len = verify (reverse (substr (keys, key_pos (branch_num), len)), " ") - 1;
	  if tail_len < 0
	  then tail_len = len;
	  len = len - tail_len;
         end;
      return (len);

      dcl	    len		       fixed;
      dcl	    tail_len	       fixed;
   end;						/* end get_key_length */

compare_last_key:
   proc (key);					/* used to verify key order in kso openings */
      key_is_dup = "0"b;				/* will be set if user seeks last key in file */
      if last_branch_num > 1				/* file not empty */
      then if key <= substr (keys, key_pos (last_branch_num - 1), key_length (last_branch_num - 1))
	 then
	    do;					/* key not larger--maybe dup */
	       code = error_table_$key_order;
	       if key = substr (keys, key_pos (last_branch_num - 1), key_length (last_branch_num - 1))
	       then key_is_dup = "1"b;
	    end;
      dcl	    key		       char (256) var;
   end compare_last_key;

check_rs_args:
   proc;						/* routine validates args to the "record_status" order */
      rs_info_ptr = info_ptr;
      if (rs_info.version < rs_info_version_1) | (rs_info.version > rs_info_version_2)
						/* only versions currently supported */
      then code = error_table_$unimplemented_version;
      else if indx_cb.trans & rs_info.unlock_sw & ^rs_info.unlock_sw
						/* no unlocking under -trans */
      then code = error_table_$no_operation;
      else
         do;					/* keep checking */
						/* unlocking is treated passively, as far as synchronization is concerned */
	  passive_op = ^(rs_info.create_sw | rs_info.lock_sw | rs_info.inc_ref_count | rs_info.dec_ref_count);
	  if (^passive_op | rs_info.unlock_sw) & is_read_only
						/* need write access */
	  then code = error_table_$no_operation;
	  else
	     do;
	        if rs_info.create_sw
	        then if max (rs_info.max_rec_len, rs_info.record_length) > max_record_size
		   then code = error_table_$long_record;
		   else if indx_cb.subset_selected = "10"b
						/* pure selection in effect */
		   then code = error_table_$no_record;
		   else if rs_info.dec_ref_count & ^rs_info.inc_ref_count
		   then code = error_table_$last_reference;
						/* error--ref count too small */
		   else if ^rs_info.lock_sw
		   then if rs_info.unlock_sw
		        then code = error_table_$lock_not_locked;
		        else ;
		   else if ^indx_cb.shared
		   then if ^indx_cb.stat & ^rs_info.inc_ref_count & ^rs_info.dec_ref_count
		        then
			 do;
			    recl = max (0, rs_info.record_length);
			    capacity = max (min_max_rec_len, recl, rs_info.max_rec_len);
			    if rs_info.max_rec_len <= 0
			    then capacity = max (capacity, indx_cb.min_cap, recl + indx_cb.min_res);
			    if capacity - recl < 4
			    then code = error_table_$no_room_for_lock;
			 end;
		        else ;
		   else ;
	        else
		 do;				/* non-creation case */
		    if rs_info.locate_sw		/* descriptor is input arg */
		    then if (addr (rs_info.descriptor) -> rs_desc.comp_num <= 0)
						/* invalid component number */
		         then code = error_table_$no_record;
		         else /* use input descrip to set current record position */
			    call make_current (rs_info.descriptor);
		    if rs_info.inc_ref_count
		    then if rs_info.dec_ref_count
		         then delta_ref_count = 0;
		         else delta_ref_count = 1;
		    else if rs_info.dec_ref_count
		    then delta_ref_count = -1;
		    else delta_ref_count = 0;
		 end;
	     end;
         end;
      dcl	    (recl, capacity)       fixed (21);
   end check_rs_args;

record_status:
   proc;						/* routine supports record_status order except for arg checking */
      if rs_info.create_sw				/* create a new record */
      then
         do;
	  call initialize_substate;			/* prepare file state block */
	  file_base.new_record_length = max (rs_info.record_length, 0);
						/* save args for crash recovery */
	  if rs_info.max_rec_len > 0			/* override default min_block_size settings */
	  then
	     do;
	        file_base.saved_min_cap = max (rs_info.max_rec_len, min_max_rec_len);
	        file_base.saved_min_res = 0;
	     end;
	  else call save_min_blksz_inf;		/* in case of crash */
	  file_base.out_of_index = rs_info.locate_sw;
	  if rs_info.locate_sw & ^indx_cb.repeating	/* new rec won't be entered into index with key */
	  then call set_add_rec_stats;
	  else call set_add_ent_info ("1"b);		/* prepare to add index entry and new record */
	  file_base.old_ref_count =
	     fixed (rs_info.inc_ref_count) - fixed (rs_info.dec_ref_count) + fixed (^rs_info.locate_sw);
						/* initial ref count desired */
	  file_base.was_stat = indx_cb.stat | rs_info.inc_ref_count | rs_info.dec_ref_count;
	  file_action = adding_record;		/* necessary info saved, now alter file */
	  call change_record_list (iocb_ptr, insert_action, (null), abort_exit);
						/* create empty record */
	  file_base.change_count = file_base.old_file_ch_count + 1;
	  if rs_info.locate_sw			/* don't add index entry */
	  then call make_current (new_descriptor);	/* set current position to new record */
	  else
	     do;					/* place entry into the index */
	        indx_cb.current_descrip = new_descriptor;
	        call set_new_record_designator;
	        call change_index (iocb_ptr, abort_exit); /* does the work */
	        pos_ptr = file_position_ptr;
	        call set_post_write_pos;
	     end;
	  call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0);
						/* no ref count change */
	  call set_rs_return_info;			/* fills in info structure */
	  if (code = 0) | (code = error_table_$locked_by_this_process) /* in case of recovery--can't hurt */
	     | (code = error_table_$invalid_lock_reset)
	  then if ^rs_info.lock_sw			/* nothing more to do */
	       then go to switch_file_state;
	       else if lock_ptr = null		/* small non-stationary allocation */
	       then code = error_table_$no_room_for_lock;
	       else if rs_info.unlock_sw		/* also immediately unlock--silly request when creating */
	       then go to switch_file_state;
	       else if indx_cb.trans			/* TP case--leave locked, but no need to set flag */
	       then go to switch_file_state;
	       else
		do;
		   block_ptr -> record_block.lock_flag = "1"b;
						/* warn others about image change */
		   i_locked_rec = "0"b;		/* suppress unlocking this record in unlock_exit */
		   go to switch_file_state;
		end;
	  aborting = "1"b;				/* unexpected error -- file will be adjusted later */
         end;					/* new record created and made current */
      else
         do;					/* non-creation case */
	  if ^rs_info.locate_sw
	  then
	     do;					/* make sure current record is defined */
	        call check_current;			/* may find next rec if not at current */
	        if code ^= 0			/* error--current record must be defined */
	        then return;
	     end;
	  if passive_op
	  then call set_current_reclp (block_ptr, lock_ptr);
	  else
	     do;					/* obtain record_ptr non-passively */
	        call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, delta_ref_count);
						/* may wait up to wait time limit */
	        if (code = 0) | (code = error_table_$locked_by_this_process) | (code = error_table_$invalid_lock_reset)
						/* no fatal errors occurred */
	        then
		 do;
		    if rs_info.lock_sw & ^rs_info.unlock_sw
		    then if indx_cb.trans		/* transaction case */
		         then if ind_desc = -2	/* means first modification--after=before */
			    then
			       do;		/* initialize after image as copy of before */
				if indx_cb.shared
				then indx_cb.shared = ^indx_cb.leave_locked & ^i_locked_file;
				else saved_state.outside_index = indx_cb.outside_index;
				indx_cb.outside_index = "1"b;
						/* prevent rewrite from changing position */
				call rewrite_indx_file (iocb_ptr, addrel (record_ptr, 1), record_len, er_code);
						/* should have internal procedure for efficiency */
				indx_cb.outside_index = saved_state.outside_index;
						/* restore to prior state */
				indx_cb.shared = saved_state.shared;
				if er_code ^= 0
				then
				   do;
				      code = er_code;
				      call set_rs_return_info;
				      return;
				   end;
				ind_des.comp = stat_struct.ind_comp;
				ind_des.offset = time_stamp_struct.ind_offset;
				record_ptr = addrel (get_ptr (ind_desc), 1);
						/* comp must be known */
			       end;
			    else ;		/* already have initialized after image */
		         else if lock_ptr = null	/* allocation too small for lock in tail */
		         then code = error_table_$no_room_for_lock;
		         else
			  do;			/* just locking, non-TP case */
			     block_ptr -> record_block.lock_flag = "1"b;
						/* warn others */
			     if block_ptr -> record_block.stationary
						/* record has time_stamp */
			     then time_stamp_struct.time_last_modified = clock ();
			     else file_base_ptr -> file_base.change_count =
				   file_base_ptr -> file_base.change_count + 1;
			     i_locked_rec = "0"b;	/* suppress unlocking */
			  end;
		    if rs_info.inc_ref_count | rs_info.dec_ref_count
		    then if ^block_ptr -> record_block.stationary
		         then code = error_table_$no_room_for_lock;
						/* error really is that rec is non-stationary */
		         else if indx_cb.trans
		         then block_ptr -> stat_struct.ref_count_after = ref_cnt;
		         else block_ptr -> stat_struct.ref_count = ref_cnt;
		 end;
	     end;					/* pointer obtained non-passively */
	  call set_rs_return_info;
         end;					/* end of non-creation case logic */

set_rs_return_info:
   proc;						/* fills in user-supplied info structure */
      rs_info.record_length = record_len;
      rs_info.descriptor = indx_cb.current_descrip;
      if record_ptr = null				/* no record allocation */
      then
         do;
	  rs_info.record_ptr = null;
	  rs_info.max_rec_len = 0;
         end;
      else rs_info.record_ptr = addrel (record_ptr, 1);	/* point to contents,
						   not length word */
      if block_ptr ^= null				/* allocation exists */
      then
         do;					/* get info about block */
	  if block_ptr -> record_block.stationary
	  then
	     do;					/* give stationary record info */
	        rs_info.ref_count = ref_cnt;
	        if rs_info.version = rs_info_version_2	/* larger info structure than old one */
	        then
		 do;
		    rs_info.modifier = mod;
		    rs_info.time_last_modified = time_stamp;
		    rs_info.last_image_modifier = cur_mod;
		 end;
	     end;
	  if rs_info.version = rs_info_version_2	/* see comment above */
	  then rs_info.block_ptr = block_ptr;
	  rs_info.max_rec_len = 4 * max_rec_wds;
         end;
   end set_rs_return_info;

      dcl	    er_code	       fixed (35);
   end record_status;

save_correct_pos:
   proc;						/* routine remembers current info so positions can be restored */
      if ^indx_cb.pos_incorrect & (string (indx_cb.at_eof_or_bof) = "00"b) & ^(indx_cb.next_record_position = 0)
      then
         do;
	  pos_ptr = indx_cb.file_position_ptr;
	  if branch_num = last_branch_num		/* key may not exist */
	  then
	     do;
	        call find_this_entry;
	        if pos_ptr = root_position_ptr		/* at end of file */
	        then
		 do;				/* set position vars */
		    call set_at_eof;		/* no need to actually descend now */
		    indx_cb.current_record_is_valid = indx_cb.outside_index;
		    pos_incorrect = "1"b;
		    return;
		 end;
	     end;
	  indx_cb.new_key = substr (keys, key_pos (branch_num), key_length (branch_num));
	  indx_cb.saved_descrip = record_designator (branch_num);
         end;
   end save_correct_pos;

make_current:
   proc (descrip);					/* routine sets current pos outside index */
      indx_cb.ready_to_write = "0"b;
      indx_cb.current_descrip = descrip;
      indx_cb.outside_index = "1"b;			/* current record moves outside index */
      indx_cb.current_record_is_valid = "1"b;
      dcl	    descrip	       fixed (35);
   end make_current;

set_add_rec_stats:
   proc;						/* prepares statistics indicating successful creation of new record */
      if indx_cb.trans				/* transaction case */
      then return;					/* stats not changed until checkpoint */
      os_ptr -> number_of_records = number_of_records + 1;
      os_ptr -> total_record_length = total_record_length + new_record_length;
   end set_add_rec_stats;

prepare_process:
   proc;						/* used by passive shared operations to set up process vars
						   and wait for opportunity to look at file */
      if ^i_locked_file & ^leave_locked			/* unlocked between operations */
      then
         do;					/* check for asynch activity */
	  call check_file_lock;			/* waits till unlocked or time exhausted */
	  fault_ok = "1"b;				/* fault may reasonably occur because of asynch changes */
	  if last_change_count ^= new_change_count	/* asynch changes--restore process info */
	  then
	     do;
	        call initialize_ptrs;
	        pos_incorrect = "1"b;			/* will reseek before attempting index ref */
	        last_change_count = new_change_count;
	     end;
         end;
      else code = 0;
   end prepare_process;

check_file_lock:
   proc;						/* waits for lock to be clear until time left is exhausted */
      code = 0;
      if indx_cb.wait_time < 0			/* will wait indefinitely */
      then timeout = eternity;			/* may wait forever */
      else timeout = clock () + indx_cb.wait_time;	/* microseconds */

      do while (code = 0);				/* wait loop */
         new_change_count = change_count;		/* must save this before checking lock */
         fs_ptr = addr (file_state_blocks (file_state));
         if file_action = 0				/* not busy with alteration */
         then if new_change_count = change_count		/* in case state has flipped */
	    then return;
         lock_copy = file_base.lock_word;		/* copy the lock--can't alter file itself */
         call set_lock (addr (lock_copy), 0, code);
         if code = 0
         then return;				/* lock was clear */
         mics_left = timeout - clock ();
         if (code = error_table_$lock_wait_time_exceeded) /* really busy */ & (mics_left > 0)
						/* OK to wait longer */
         then
	  do;
	     call timer_manager_$sleep (min (50000, mics_left), "10"b);
						/* wait .05 seconds */
	     code = 0;
	  end;
         else if (code = error_table_$invalid_lock_reset) & ^indx_cb.is_read_only
         then call adjust_file (iocb_ptr, code);
         else code = error_table_$file_busy;
      end;					/* end of wait loop */

      go to exit;					/* abort */
      dcl	    mics_left	       fixed (71);
   end check_file_lock;

position_eof:
   proc;
      pos_ptr = root_position_ptr;
      call find_rightmost_descendent;
set_at_eof:
   entry;						/* avoids cost of descent when not needed */
      indx_cb.next_record_position = 1;
      indx_cb.ready_to_write = "0"b;
      indx_cb.current_record_is_valid = "0"b;
      indx_cb.at_eof = "1"b;				/* causes re-seek to eof if shared and asynch changes */
   end;

position_bof:
   proc;
      pos_ptr = root_position_ptr;
      call find_leftmost_descendent;
      indx_cb.next_record_position = 1;
      if last_branch_num > 1
      then indx_cb.current_record_is_valid = "1"b;
      else indx_cb.current_record_is_valid = "0"b;
      indx_cb.ready_to_write = indx_cb.current_record_is_valid & dup_ok;
      indx_cb.at_bof = "1"b;				/* shared re-seek will be to bof */
   end;

find_rightmost_descendent:
   proc;
      do while (branch (branch_num) ^= 0);
         son_position_ptr -> node = branch (branch_num);
         son_position_ptr -> node_ptr = get_ptr (branch (branch_num));
         pos_ptr = son_position_ptr;
         branch_num = last_branch_num;
      end;
      file_position_ptr = pos_ptr;
   end;						/* end find_rightmost_descendent */

find_leftmost_descendent:
   proc;
      do while (branch (branch_num) ^= 0);
         son_position_ptr -> node = branch (branch_num);
         son_position_ptr -> node_ptr = get_ptr (branch (branch_num));
         pos_ptr = son_position_ptr;
         branch_num = 1;
      end;
      file_position_ptr = pos_ptr;
   end;						/* end find_leftmost_descendent */

set_lock:
   proc (lockp, wtime, er_code);			/* internal equivalent of system set_lock_$lock */
      if stac (lockp, indx_cb.saved_lock_copy)		/* sets if zero */
      then er_code = 0;				/* done */
      else if lockp -> based_lock = indx_cb.saved_lock_copy
      then er_code = error_table_$locked_by_this_process;
      else call set_lock_$lock (lockp -> based_lock, wtime, er_code);
						/* must resort
						   to expensive call */
      dcl	    lockp		       ptr;
      dcl	    wtime		       fixed;
      dcl	    er_code	       fixed (35);
   end set_lock;

compute_time_left:
   proc;
(nosize):
      time_left = divide (fixed (timeout - clock () + 999999, 35, 0), 1000000, 17, 0);
   end compute_time_left;

lock_file_check:
   proc;						/* locks & re-seeks previously located position if file has changed */
      pos_ptr = file_position_ptr;
      f_b_ptr = file_base_ptr;
      fs_ptr = indx_cb.file_state_ptr;
      if indx_cb.leave_locked | i_locked_file		/* already locked */
      then return;					/* no need to lock again */
      fault_ok = "0"b;				/* no more asynch change errors allowed */
      call compute_time_left;
      if (file_base.lock_word = indx_cb.saved_lock_copy)
      then i_locked_file = "0"b;			/* this op is not first to lock */
      else i_locked_file = "1"b;			/* if lock becomes set, this op did it */
      call set_lock (addr (file_base.lock_word), time_left, er_code);
      if er_code ^= 0				/* lock was non-zero */
      then if er_code = error_table_$invalid_lock_reset
	 then er_code = 0;
	 else
	    do;					/* abort */
	       code = error_table_$file_busy;
	       indx_cb.state_vars = saved_state;	/* quick state restore */
	       go to unlock_exit;
	    end;
      if change_count ^= last_change_count
      then call initialize_ptrs;
      if (file_action ^= 0) & (file_action ^= read_exclude)
      then
         do;
	  call restart (iocb_ptr, er_code);		/* try to complete interrupted operation */
	  fs_ptr = indx_cb.file_state_ptr;
	  call check_code (er_code, "Unable to adjust a vfile_ operation in progress.");
         end;
      if change_count ^= last_change_count
      then pos_incorrect = "1"b;			/* will force re-seek if index is referenced */
      dcl	    er_code	       fixed (35);
   end lock_file_check;

initialize_substate:
   proc;						/* prepares recovery vars */
      f_b_ptr = file_base_ptr;
      if indx_cb.shared
      then call lock_file_check;
      fs_ptr = indx_cb.file_state_ptr;
      os_ptr = indx_cb.o_s_ptr;
      if repeating					/* recovery is in progress */
      then if file_substate = 0			/* died before finishing first block */
	 then repeating = "0"b;			/* switch to normal execution */
	 else next_substate = 0;			/* this count will keep track of recovery execution */
      else
         do;					/* normal execution */
	  file_substate = 0;			/* first block not yet completed */
	  file_base.old_file_ch_count = file_base.change_count;
	  file_base.was_transaction = indx_cb.trans;
	  os_ptr -> file_state_words = fs_ptr -> file_state_words;
	  if indx_cb.read_exclu			/* leave read lock set */
	  then os_ptr -> file_action = read_exclude;	/* locks out readers */
	  else os_ptr -> file_action = 0;
         end;
      dcl	    1 fsb		       based,		/* file state block */
	      2 word	       fixed,		/* file action slot */
	      2 file_state_words   (9) fixed;		/* avoids unused portion of fsb */
   end initialize_substate;

check_current:
   proc;						/* routine aborts if current record is undefined */
      pos_ptr = file_position_ptr;
      code = 0;
      if ^indx_cb.outside_index			/* current record located via index */
      then
         do;
	  if pos_incorrect
	  then
	     do;
	        call restore_position;
	        if code ^= 0
	        then return;
	     end;
	  if indx_cb.current_record_is_valid
	  then
	     do;
	        indx_cb.at_bof = "0"b;		/* reposition to record now that reference has occurred */
	        indx_cb.current_descrip = record_designator (branch_num);
	        return;
	     end;
	  else if indx_cb.next_record_position ^= 0
	  then
	     do;					/* current is next--find it */
	        call find_next_record;		/* detects eof */
	        if indx_cb.subset_selected ^= "00"b	/* may have to scan */
	        then if code = 0			/* index entry exists, but may be masked */
		   then call sh_scan;		/* does subset checking and scanning */
	     end;
         end;
      if ^indx_cb.current_record_is_valid
      then code = error_table_$no_record;
   end check_current;

save_min_blksz_inf:
   proc;						/* save info set by "min_block_size" order, in case
						   of crash while rewriting or inserting */
      file_base.saved_min_res = indx_cb.min_res;
      file_base.saved_min_cap = indx_cb.min_cap;
   end save_min_blksz_inf;

initialize_ptrs:
   proc;						/* resets process vars invalidated by asynch changes */
      if old_last_comp_num ^= last_comp_num
      then
         do;					/* recreate seg_ptr_array */
	  call free_seg_ptrs (iocb_ptr);
	  call create_seg_ptrs (iocb_ptr);
         end;
      else
         do;					/* these initialized by createseg_ptrs */
	  if old_rover_comp_num ^= rover_comp_num
	  then
	     do;					/* initialize rover */
	        rover_seg_ptr = get_seg_ptr (iocb_ptr, rover_comp_num);
	        old_rover_comp_num = rover_comp_num;
	     end;
	  index_state_ptr = addr (index_state_blocks (index_state));
         end;
      if old_index_height < index_state_ptr -> index_height /* no sweat if height decreases */
      then
         do;					/* recreate position stack */
	  call free_position_stack (indx_cb_ptr);
	  call create_position_stack (indx_cb_ptr);
	  pos_ptr = file_position_ptr;
         end;
      file_state_ptr = addr (file_state_blocks (file_state));
      fs_ptr = indx_cb.file_state_ptr;
      o_s_ptr = addr (file_state_blocks (1 - file_state));
      if ^indx_cb.dup_ok
      then if duplicate_keys ^= 0
	 then indx_cb.dup_ok = "1"b;
   end initialize_ptrs;

restore_position:
   proc;						/* re-establishes index position which may have become
						   invalid because of asynch changes */
      code = 0;
      if indx_cb.is_ks_out & indx_cb.ready_to_write	/* must keep track of key order constraint */
      then
         do;					/* position to end of file and test order */
	  file_position_ptr = root_position_ptr;	/* prepare for descent */
	  call find_rightmost_descendent;		/* end of file */
	  call compare_last_key (indx_cb.new_key);	/* sets code and key_is_dup */
	  if code ^= 0				/* not larger than last key in file */
	  then
	     do;
	        code = 0;				/* don't flag key_order error now */
	        if ^key_is_dup			/* no longer at last key */
	        then indx_cb.ready_to_write = "0"b;	/* asynch insertions leave indx_cb.new_key out of order */
	        else if ^dup_ok			/* key exists but no duplications allowed */
	        then
		 do;
		    indx_cb.ready_to_write = "0"b;	/* stop illegal duplications */
		    if indx_cb.at_eof		/* must have just done unsuccessful seek */
		    then code = error_table_$asynch_insertion;
						/* signal this error */
		 end;
	     end;
	  if indx_cb.at_eof				/* position fully restored and checked */
	  then return;				/* no more work necessary */
         end;					/* now indx_cb.ready_to_write reflects asynch changes if mode is kso */
      if indx_cb.at_bof
      then call position_bof;
      else if indx_cb.at_eof
      then call position_eof;
      else if ^dup_ok				/* no duplications allowed */
      then
         do;
	  file_position_ptr = root_position_ptr;
	  call find_key (indx_cb_ptr, (addr (indx_cb.new_key)), search_code);
	  pos_ptr = file_position_ptr;
	  if search_code ^= 0			/* key found */
	  then
	     do;
	        call find_from_leaf;
	        if indx_cb.ready_to_write		/* key should be absent */
	        then
		 do;
		    code = error_table_$asynch_insertion;
		    indx_cb.ready_to_write = "0"b;
		    indx_cb.current_record_is_valid = "1"b;
		    indx_cb.next_record_position = 1;
		 end;
	     end;
	  else
	     do;
as_del:
	        if (indx_cb.next_record_position ^= 0) | (indx_cb.current_record_is_valid & ^indx_cb.outside_index)
	        then
		 do;				/* previously located record has been deleted by another process */
		    code = error_table_$asynch_deletion;
		    indx_cb.ready_to_write = (^is_read_only & ^is_ks_out);
		    indx_cb.current_record_is_valid = "0"b;
		    indx_cb.next_record_position = 0;
		 end;
	     end;
         end;
      else
         do;
	  call find_entry (indx_cb.new_key, indx_cb.saved_descrip);
	  if search_code = 0			/* no asynch insertions when dup keys allowed */
	  then if first_code = 0			/* key not found */
	       then go to as_del;			/* check for possible asynch deletion */
	       else if indx_cb.stat			/* insist on same descriptor */
	       then go to as_del;
	       else
		do;				/* key was found, but not current descrip */
		   call find_prev_entry;		/* set pos to last matching key */
		   branch_num = branch_num - 1;	/* does the backspace */
		end;
         end;
      pos_incorrect = "0"b;				/* index position correctly restored */
   end restore_position;

find_entry:
   proc (key, descrip);				/* routine finds pos for given key and record descriptor */
      file_position_ptr = root_position_ptr;		/* search starts at base of index */
      call find_key (indx_cb_ptr, (addr (key)), search_code);
      pos_ptr = file_position_ptr;
      if search_code ^= 0				/* key found */
      then call find_from_leaf;			/* in case match is non-leaf */
      first_code = search_code;			/* will be non-zero if key was found */
      key_is_dup = "0"b;				/* will be set in loop if key is not unique */

      do while (search_code ^= 0);			/* advance until descrip is found or key changes */
         if record_designator (branch_num) = descrip	/* descrip found */
         then return;				/* done--position set properly */
         branch_num = branch_num + 1;			/* advance position */
         call find_this_entry;			/* takes care of exceptional cases */
         if pos_ptr = root_position_ptr			/* end of file */
         then search_code = 0;			/* stop searching */
         else if substr (keys, key_pos (branch_num), key_length (branch_num)) = key
         then key_is_dup = "1"b;
         else search_code = 0;			/* key has changed--stop searching */
      end;

      dcl	    key		       char (256) var;
      dcl	    descrip	       fixed (35);
   end find_entry;

abort_exit:
      code = error_table_$file_is_full;
      aborting = "1"b;
      file_base_ptr -> file_base.max_comp_num = true_max_comp_num + 2;
      go to unlock_exit;

switch_file_state:
      file_state = 1 - file_state;
      file_state_ptr = os_ptr;
      o_s_ptr = fs_ptr;
unlock_exit:
      if indx_cb.shared
      then if ^indx_cb.leave_locked & i_locked_file
	 then if ^aborting
	      then
	         do;				/* OK to clear the file lock */
		  call save_correct_pos;
		  last_change_count = change_count;
		  if stacq (lock_word, "0"b, indx_cb.saved_lock_copy)
						/* unlock */
		  then ;
	         end;
	      else
	         do;
		  call restore_state;
		  if stacq (lock_word, (36)"1"b, indx_cb.saved_lock_copy)
		  then ;				/* invalidate the lock */
	         end;
	 else if aborting
	 then call restore_state;
	 else call save_correct_pos;
      if i_locked_rec
      then call unlock_record (block_ptr, lock_ptr, old_passive_ref_mask);
      else if i_set_negmod & ^aborting & (block_ptr ^= null)/* modifier set to -1 */
      then block_ptr -> stat_struct.modifier = 0;		/* clear it */
      if i_locked_new
      then call unlock_record (new_block_ptr, new_lock_ptr, new_passive_ref_mask);
						/*
						   in case of reassign_key operation */
      else if i_set_new_negmod & ^aborting & (new_block_ptr ^= null)
      then new_block_ptr -> stat_struct.modifier = 0;
exit:
      return;					/* external exit point */

rewrite_indx_file:
   entry (iocb_ptr, buff_ptr, buff_len, code);
      current_retry_loc = rew_retry;
      go to init_up_down;
retry_loc (12):
      call check_buff_len;
      call check_current;
      if code ^= 0
      then go to verify_done;
      call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0);
						/* handles deleted record case */
      if code ^= 0
      then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset)
	 then go to verify_done;
      if indx_cb.outside_index			/* not using index */
      then if ^block_ptr -> record_block.stationary	/* see if non-stationary */
	 then if buff_len + indx_cb.min_res > 4 * (block_ptr -> record_block.block_size - 2)
	      then
	         do;				/* don't permit reallocation from outside index */
		  if code = error_table_$locked_by_this_process
		  then i_locked_rec = "0"b;		/* suppress unlocking of the record */
		  code = error_table_$long_record;
		  go to unlock_exit;		/* abort--no need to verify, since indx_cb.outside_index */
	         end;
	      else ;
	 else ;
      else if is_sequential_open
      then indx_cb.next_record_position = 2;
      else indx_cb.next_record_position = 0;		/* OK to lock file now that record is locked */
      call initialize_substate;			/* prepare for file state change after locking file, if not already locked */
      file_base.old_record_designator = indx_cb.current_descrip;
      if ^indx_cb.outside_index
      then
         do;					/*Only need to save current node when using index.*/
	  first_branch = node;			/* just a convenient place to save current node */
	  file_base.count = branch_num;		/* convenient place to save current branch_num */
         end;
      call save_min_blksz_inf;
      file_base.out_of_index = indx_cb.outside_index;	/* remember in case of crash */
      call save_old_record_length;
      new_record_length = max (0, buff_len);
      file_action = replace_action;
      if file_base.was_stat				/* record is stationary type */
      then
         do;
	  if (new_record_length > 0) | (indx_cb.min_cap > 0) | (indx_cb.min_res > 0)
	  then /* always save buffer contents before rewriting */
	       call change_record_list (iocb_ptr, allocate_action, buff_ptr, abort_exit);
	  else file_base.new_descriptor = 0;		/* no allocation required */
	  stat_struct.ind_comp = new_rec_des.comp;
	  time_stamp_struct.ind_offset = new_rec_des.offset;
	  change_count = file_base.old_file_ch_count + 1; /* must be bumped before body of operation */
	  if file_base.was_transaction		/* in transaction mode */
	  then
	     do;					/* transaction case--retain before image */
	        if (file_base.old_ind_desc > 0)		/* current allocation exists--replace it */
	        then call change_record_list (iocb_ptr, replace_action, buff_ptr, abort_exit);
	        os_ptr -> number_of_allocated_records = number_of_allocated_records;
						/*
						   this statistic not changed until checkpoint occurs */
	     end;					/* done with rewrite for transaction case */
	  else
	     do;					/* non-TP case */
	        os_ptr -> total_record_length = total_record_length + buff_len - old_record_length;
	        call change_record_list (iocb_ptr, replace_action, null, abort_exit);
	     end;
         end;					/* end of stationary replacement logic */
      else
         do;					/* non-stationary case */
	  file_base.change_count = file_base.old_file_ch_count + 1;
	  os_ptr -> total_record_length = total_record_length + buff_len - old_record_length;
	  if (new_record_length > 0) | (indx_cb.min_cap > 0) | (indx_cb.min_res > 0)
	  then
	     do;					/* insert or replace record */
	        if old_record_designator ^= 0
	        then record_action = replace_action;
	        else
		 do;
		    record_action = insert_action;
		    i_locked_rec = "1"b;		/* unlock when done */
		 end;
	        call change_record_list (iocb_ptr, record_action, buff_ptr, abort_exit);
	        if file_base.new_descriptor = file_base.old_record_designator
						/* allocation hasn't moved */
	        then if i_locked_rec			/* lock set by this operation */
		   then block_ptr -> record_block.lock_flag = "0"b;
						/*
						   not leaving locked, so clear the flag */
		   else if (code ^= 0) & (code = error_table_$locked_by_this_process)
						/* lock was already set by my process before rewriting */
		   then ;				/* will leave lock set, if room remains */
		   else
		      do;				/* won't leave lock set */
		         block_ptr -> record_block.lock_flag = "0"b;
		         go to end_ns_rew;		/* didn't set lock anyway */
		      end;
	        else if (code ^= 0) & (code = error_table_$locked_by_this_process)
	        then
		 do;				/* leave new allocation locked, if room */
		    block_ptr = get_ptr (file_base.new_descriptor);
		    block_ptr -> record_block.lock_flag = "1"b;
		 end;
	        else
		 do;
		    i_locked_rec = "0"b;		/* suppress unlocking rec */
		    go to end_ns_rew;
		 end;
	        if block_ptr -> record_block.block_size > divide (file_base.new_record_length + 11, 4, 19, 0)
	        then
		 do;				/* room for lock--be sure it is still set */
		    lock_ptr = addr (block_with_lock.record_lock);
		    lock_ptr -> based_lock = indx_cb.saved_lock_copy;
						/*
						   in case location of the lock has moved */
		 end;
	        else
		 do;				/* no more room for record lock */
		    block_ptr -> record_block.lock_flag = "0"b;
		    i_locked_rec = "0"b;		/* suppress attempt to unlock */
		 end;
	     end;					/* done with new allocation case */
	  else
	     do;					/* don't create or leave a record */
	        if old_record_designator ^= 0
	        then /* delete the old record */
		   call change_record_list (iocb_ptr, delete_action, (null), abort_exit);
	        new_descriptor = 0;
	        i_locked_rec = "0"b;
	     end;
end_ns_rew:
	  if ^indx_cb.outside_index			/* index position being used */
	  then record_descrip (branch_num) = new_descriptor;
						/* put new
						   record descriptor into current index position */
	  else indx_cb.current_descrip = new_descriptor;
         end;					/* done with non-stationary logic */
      go to switch_file_state;			/* unlocks file and record--end of rewrite logic */

unlock_record:
   proc (block_ptr_arg, lock_ptr_arg, passive_ref_mask);	/* by convention, the record is always unlocked last when independent synch levels are involved */
      if block_ptr_arg = null				/* no record allocation to unlock */
      then return;
      if lock_ptr_arg = null
      then return;
      if aborting
      then
         do;					/* invalidate the record lock, if room */
	  if indx_cb.trans
	  then if block_ptr_arg -> record_block.stationary
	       then if (block_ptr_arg -> stat_struct.modifier > 0)
		     & (block_ptr_arg -> stat_struct.modifier = current_t_code)
		  then return;			/* leave locked -- refl entry must exist */
		  else if cleanup_flags & passive_ref_mask ^= "000000"b
						/* passive refl entry exists */
		  then return;			/* don't invalidate if in ref list */
	  if lock_ptr_arg ^= null
	  then if stacq (lock_ptr_arg -> based_lock, (36)"1"b, indx_cb.saved_lock_copy)
	       then ;				/* clobber record lock */
	  return;
         end;
      if block_ptr_arg -> record_block.stationary
      then if block_ptr_arg -> stat_struct.modifier > 0
	 then return;				/* leave locked until checkpoint or rollback */
      if ^(lock_ptr_arg -> based_lock = indx_cb.saved_lock_copy)
      then return;
      block_ptr_arg -> record_block.lock_flag = "0"b;
      if block_ptr_arg -> record_block.stationary
      then
         do;
	  stat_struct.ind_comp = 0;
	  time_stamp_struct.ind_offset = "0"b;
	  stat_struct.modifier = 0;
         end;
      if stacq (lock_ptr_arg -> based_lock, "0"b, indx_cb.saved_lock_copy)
      then ;
      dcl	    (block_ptr_arg, lock_ptr_arg)
			       ptr;
      dcl	    1 time_stamp_struct    like time_stamp_structure based (addr (stat_struct.time_stamp_words));
      dcl	    passive_ref_mask       bit (36) aligned;
      dcl	    1 record_block	       like record_block_structure based (block_ptr_arg);
      dcl	    1 stat_struct	       like stat_structure based (block_ptr_arg);
   end unlock_record;

save_old_record_length:
   proc;
      if repeating
      then
         do;
	  call check_file_substate;
	  return;
         end;
      file_base.old_record_length = record_len;
      call save_stat_info;
      file_substate = file_substate + 1;
   end save_old_record_length;

save_stat_info:
   proc;						/* saves info about current record for recovery */
      if file_base.old_record_designator <= 0		/* no allocated record */
      then file_base.was_stat = "0"b;			/* stationary record is always allocated */
      else
         do;					/* save info about record block */
	  file_base.prior_block_size = block_ptr -> record_block.block_size;
	  file_base.was_stat = block_ptr -> record_block.stationary;
	  file_base.was_ind = block_ptr -> record_block.indirect;
	  file_base.old_prev_mod = block_ptr -> stat_struct.prev_mod;
	  file_base.old_ind_desc = ind_desc;		/* indirect descriptor */
	  file_base.old_modifier = max (0, stat_struct.modifier);
         end;
   end save_stat_info;

prepare_key:
   proc (new_key);
      new_key_length = max (length (new_key), indx_cb.min_key_len);
      substr (new_key_string, 1, new_key_length) = new_key;

      dcl	    new_key	       char (256) varying;
   end;						/* end prepare key */

write_indx_file:
   entry (iocb_ptr, buff_ptr, buff_len, code);		/* ref6 */
      current_retry_loc = write_retry;
      go to init_down_up;
retry_loc (13):
      call check_buff_len;
      if indx_cb.subset_selected = "10"b		/* pure selection */
      then
         do;
	  code = error_table_$no_record;
	  go to unlock_exit;
         end;
      call initialize_substate;
      call save_min_blksz_inf;
      new_record_length = max (buff_len, 0);
      call set_add_ent_info ("1"b);			/* prepare to add key and rec */
      file_base.old_ref_count = 1;			/* initial ref count will be for key entered with record, if -stat */
      file_action = insert_action;
      if (file_base.new_record_length > 0) | file_base.was_stat | (indx_cb.min_cap > 0) | (indx_cb.min_res > 0)
      then
         do;					/* allocate space for record and copy buffer */
	  call change_record_list (iocb_ptr, insert_action, buff_ptr, abort_exit);
	  if file_base.was_transaction		/* creating record in a transaction */
	  then
	     do;					/* mask presence to others until checkpoint */
	        indx_cb.current_descrip = file_base.new_descriptor;
	        call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0);
						/* also creates refl entry */
	     end;					/* only my transaction will see this record */
         end;
      else new_descriptor = 0;
      file_base.change_count = file_base.old_file_ch_count + 1;
      call set_new_record_designator;
      call change_index (iocb_ptr, abort_exit);
      pos_ptr = file_position_ptr;
      call set_post_write_pos;
      go to switch_file_state;			/* end of write routine */

check_buff_len:
   proc;						/* sets code non-zero if buffer is too big */
      if buff_len > indx_cb.max_record_size
      then
         do;
	  code = error_table_$long_record;
	  go to unlock_exit;
         end;
   end check_buff_len;

set_post_write_pos:
   proc;						/* also used by record_status when creating with locate_sw clear */
      indx_cb.current_record_is_valid = "1"b;
      indx_cb.at_bof, indx_cb.at_eof = "0"b;
      indx_cb.ready_to_write = dup_ok;
      indx_cb.skip_state = 0;
      if is_sequential_open
      then indx_cb.next_record_position = 2;
      else
         do;
	  indx_cb.next_record_position = 0;
	  indx_cb.saved_descrip = file_base.new_descriptor;
						/* save now
						   because save correct pos logic won't handle next_rec_pos=0 case */
         end;
   end set_post_write_pos;

set_add_ent_info:
   proc (add_rec_sw);				/* routine prepares for adding index entry
						   and record if add_rec_sw="1"b */
      is_ptr = indx_cb.index_state_ptr;
      if repeating					/* recovery in progress */
      then
         do;
	  call check_file_substate;
	  return;
         end;
      file_base.new_desc_val = 0;			/* used by change_index */
      file_base.saved_ks_out = indx_cb.is_ks_out;		/* in case of crash */
      if ^add_rec_sw				/* add_key operation */
      then
         do;					/* will not create record */
	  if (block_ptr = null)
	  then file_base.was_stat = "0"b;
	  else if block_ptr -> record_block.stationary
	  then
	     do;
	        file_base.was_stat = "1"b;
	        file_base.new_ref_count = ref_cnt;
	     end;
	  else file_base.was_stat = "0"b;
	  if ak_inf.input_key			/* get new key from info structure */
	  then
	     do;
	        call prepare_key (ak_info_key);
	        new_key_len = ak_inf.key_len;
	     end;
	  else call prepare_key_for_insertion;
	  new_record_designator = indx_cb.current_descrip;
	  file_base.new_descriptor = new_record_designator;
         end;
      else
         do;					/* prepare for write_record or record_status(**10) */
	  file_base.was_stat = indx_cb.stat;		/* -stat option used--default record
						   type is stationary */
	  call check_key_for_insertion;
	  call prepare_key_for_insertion;
	  call set_add_rec_stats;
         end;
      os_ptr -> number_of_keys = number_of_keys + 1;
      os_ptr -> total_key_length = total_key_length + new_key_len;
      if key_is_dup
      then
         do;					/* change duplicate key stats */
	  os_ptr -> duplicate_keys = duplicate_keys + 1;
	  os_ptr -> dup_key_bytes = dup_key_bytes + new_key_len;
	  call find_rightmost_descendent;		/* sets pos properly in case at non-leaf entry */
         end;
      change_position_ptr = pos_ptr;
      change_node = node;
      call save_position_info;
      new_branch = 0;
      index_action = insert_action;
      file_substate = file_substate + 1;
      return;					/* end of main routine for set_add_ent_info */

prepare_key_for_insertion:
   proc;
      key_is_dup = indx_cb.current_record_is_valid;
      if key_is_dup
      then
         do;
	  new_key_len = get_key_length ();		/* length of current key */
	  new_key_length = key_length (branch_num);
	  substr (new_key_string, 1, new_key_length) = substr (keys, key_pos (branch_num), key_length (branch_num));
						/* set up key for insertion */
	  if ^add_rec_sw				/* add_key operation */
	  then
	     do;
	        indx_cb.saved_descrip = record_designator (branch_num);
						/*
						   remember current descriptor */
	        pos_incorrect = "1"b;
	     end;
	  call find_next_key;			/* advance position beyond last dup key */
         end;
      else
         do;
	  call prepare_key (indx_cb.new_key);		/* key for insertion */
	  new_key_len = length (indx_cb.new_key);
         end;
   end prepare_key_for_insertion;

      dcl	    new_key_len	       fixed;
      dcl	    add_rec_sw	       bit (1) aligned;
   end set_add_ent_info;

check_key_for_insertion:
   proc;						/* makes sure current key is defined */

      do while ("1"b);				/* may loop once */
         if ^indx_cb.ready_to_write
         then if dup_ok & ^is_ks_out			/* may be ready to write anyway */
	    then
	       do;
		call check_current;			/* sets code to zero if current really exists */
		if code ^= 0			/* really is no key for insertion */
		then
		   do;				/* forget the whole thing */
no_key:
		      code = error_table_$no_key;	/* set proper code */
		      go to verify_done;
		   end;
	       end;
	    else go to no_key;
         if pos_incorrect
         then
	  do;
	     call restore_position;
	     if code ^= 0
	     then go to verify_done;
	  end;
         else
	  do;
	     pos_ptr = indx_cb.file_position_ptr;
	     return;
	  end;
      end;

   end check_key_for_insertion;

find_next_key:
   proc;						/* routine used to advance pos beyond set of dup keys */
      init_key_len = key_length (branch_num);
      init_key_ptr = addr (node_ptr -> bytes (key_pos (branch_num)));
						/* keep track of prev key */

      do while ("1"b);
         branch_num = branch_num + 1;
         call find_this_entry;			/* takes care of exceptional cases */
         if pos_ptr = root_position_ptr			/* at eof */
         then return;
         if substr (keys, key_pos (branch_num), key_length (branch_num)) ^= init_key_ptr -> initial_key
						/* key no longer matches */
         then return;				/* found different key--done */
      end;

      dcl	    init_key_len	       fixed;
      dcl	    init_key_ptr	       ptr;
      dcl	    initial_key	       char (init_key_len) based (init_key_ptr);
      dcl	    bytes		       (1:4096) char (1) based;
   end find_next_key;

set_new_record_designator:
   proc;
      if repeating
      then
         do;
	  call check_file_substate;
	  return;
         end;
      new_record_designator = new_descriptor;
      file_substate = file_substate + 1;
   end set_new_record_designator;

delete_indx_file:
   entry (iocb_ptr, code);				/* ref7 */
      current_retry_loc = del_retry;
      go to init_up_down;
retry_loc (14):
      del_cur = "1"b;
      call check_current;
      if code ^= 0
      then go to verify_done;				/* file may not be locked yet */
      indx_cb.is_read_only = "1"b;			/* to suppress recursive cleanup attempt */
      call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 0);
						/* must restore read_only status if abort is made */
      indx_cb.is_read_only = "0"b;
      if code ^= 0
      then if code = error_table_$no_record & (block_ptr ^= null)
	 then ;					/* collect a garbage item--leave non-zero code as warning */
	 else if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset)
	 then go to unlock_exit;			/* abort */
      call delete_entry ("1"b);			/* delete index entry and current record */
      return;

adjust_record:
   entry (iocb_ptr, descrip_arg, modifier_arg, code);	/*
						   used by transaction_call_ to unlock a record */
      current_retry_loc = adj_retry;
      go to init_down_up;
retry_loc (15):
      call initialize_substate;			/* prepare for file modification */
      file_base.old_record_designator = descrip_arg;
      block_ptr = get_pointer (descrip_arg);
      lock_ptr = addr (block_ptr -> stat_struct.record_lock);
      i_locked_rec = "1"b;
      if indx_cb.repeating
      then
         do;
	  rollback_sw = (file_action = rollback_action);
	  if file_base.was_ind & (file_base.old_ind_desc > 0)
	  then p = get_pointer (file_base.old_ind_desc);	/* be sure initiated */
         end;
      else
         do;
	  if (block_ptr -> stat_struct.modifier <= 0)
	  then go to unlock_exit;
	  if ^(lock_ptr -> based_lock = indx_cb.saved_lock_copy)
	  then go to unlock_exit;			/* already adjusted */
	  if modifier_arg = block_ptr -> stat_struct.prev_mod
	  then rollback_sw = "1"b;			/* adjust to before image */
	  else if modifier_arg = block_ptr -> stat_struct.modifier
	  then
	     do;
	        rollback_sw = "0"b;			/* adjust to after image */
	        if block_ptr -> stat_struct.prev_mod = -3 /* pre-created record
						   which previous to this transaction did not exist */
	        then
		 do;				/* use null before image */
		    record_len = 0;			/* used only in following protected procedure */
		    ind_desc = -1;
		 end;
	        else if block_ptr -> record_block.indirect/* separate allocation of before */
	        then
		 do;
		    ind_desc = ind_struct.prev_desc;	/* before image */
		    if ind_struct.prev_desc <= 0	/* no allocation--special case */
		    then record_len = 0;
		    else record_len = length (get_pointer (ind_desc) -> record_block.record);
		 end;
	        else
		 do;
		    ind_desc = descrip_arg;
		    record_len = length (stat_struct.record);
						/* compact case */
		 end;
	     end;
	  else rollback_sw = "1"b;			/* roll back by default */
	  file_base.old_ref_count = block_ptr -> stat_struct.ref_count;
         end;
      if ^rollback_sw				/* checkpoint case */
      then
         do;					/* retain after and discard before image */
	  call save_old_record_length;		/* saves before-image info */
	  ind_des.comp = stat_struct.ind_comp;
	  ind_des.offset = time_stamp_struct.ind_offset;
	  call set_after_image_info;
	  if file_base.old_prev_mod = -3		/* new record created this trans */
	  then os_ptr -> number_of_records = number_of_records + 1;
	  else os_ptr -> number_of_records = number_of_records;
						/* note that this is only nec because of recovery */
	  if ind_desc = -1				/* deletion case */
	  then os_ptr -> number_of_records = os_ptr -> number_of_records - 1;
	  os_ptr -> total_record_length =
	     total_record_length + file_base.new_record_length - file_base.old_record_length;
	  file_action = adjust_action;
	  file_base.change_count = file_base.old_file_ch_count + 1;
	  block_ptr -> stat_struct.ref_count = block_ptr -> stat_struct.ref_count_after;
	  if ind_desc = -2				/* no change to the record image */
	  then
	     do;
	        block_ptr -> stat_struct.modifier = -1;	/* allow unlocking */
	        file_action = o_s_ptr -> file_action;	/* fast state switch */
	        go to unlock_exit;			/* don't change time stamp */
	     end;
	  if file_base.was_ind
	  then
	     do;
	        time_stamp_struct.time_last_modified = clock ();
	        ind_struct.prev_mod = file_base.old_modifier;
	        ind_struct.prev_desc = file_base.after_desc;
	        if file_base.old_ind_desc > 0
	        then
		 do;
		    file_base.new_descriptor = file_base.old_ind_desc;
						/* block to be freed */
		    call change_record_list (iocb_ptr, free_action, null, abort_exit);
		 end;
	     end;
	  else if file_base.old_prev_mod ^= -3		/* old record */
	  then
	     do;					/* overrite tail or convert into an indirect record */
	        file_base.new_descriptor = file_base.after_desc;
						/* after image descriptor */
	        file_base.was_transaction = "0"b;
	        call change_record_list (iocb_ptr, replace_action, null, abort_exit);
						/* tries to overrite in place if room */
	     end;
	  else
	     do;
	        time_stamp_struct.time_last_modified = clock ();
	        stat_struct.prev_mod = file_base.old_modifier;
	     end;
         end;					/* end of forward adjustment logic */
      else
         do;					/* rollback case */
	  ind_des.comp = stat_struct.ind_comp;		/* after image info */
	  ind_des.offset = time_stamp_struct.ind_offset;
	  call save_old_record_length;		/* protected procedure for recovery */
	  file_base.new_descriptor = file_base.old_ind_desc;
						/* block to free */
	  file_base.was_transaction = "1"b;
	  file_action = rollback_action;		/* can't stop this operation now */
	  file_base.change_count = file_base.old_file_ch_count + 1;
						/* must bump since file's substate will be switched */
	  if file_base.old_prev_mod = -3
	  then
	     do;
	        if file_base.old_ref_count <= 0
	        then
		 do;
		    file_base.out_of_index = "1"b;	/* not deleting key */
		    call change_record_list (iocb_ptr, delete_action, null, abort_exit);
		    os_ptr -> number_of_allocated_records = number_of_allocated_records;
		    i_locked_rec = "0"b;		/* suppress unlocking */
		    go to switch_file_state;
		 end;
	        else
		 do;
		    if ^file_base.was_ind
		    then
		       do;
			file_base.new_descriptor = -1;
			call change_record_list (iocb_ptr, replace_action, null, abort_exit);
						/* leave only a logically deleted indirect header */
		       end;
		    else
		       do;
			if file_base.old_ind_desc > 0
			then call change_record_list (iocb_ptr, free_action, null, abort_exit);
			ind_struct.prev_desc = -1;
		       end;
		    stat_struct.prev_mod = 0;
		 end;
	     end;
	  else if file_base.old_ind_desc > 0		/* allocation exists */
	  then call change_record_list (iocb_ptr, free_action, null, abort_exit);
         end;
      os_ptr -> number_of_allocated_records = number_of_allocated_records;
      block_ptr -> stat_struct.modifier = -1;		/* allow unlocking now */
      go to switch_file_state;			/* end of adjust_record logic */

adjust_file:
   entry (iocb_ptr, code);				/* called if file found locked by dead
						   process in passive file lock checking */
      current_retry_loc = adj_file_retry;
      go to init_down_up;				/* tries to lock the file */
retry_loc (25):
      go to unlock_exit;				/* that's all there is to it */

set_after_image_info:
   proc;
      if indx_cb.repeating				/* recovery in progress */
      then
         do;
	  if file_base.after_desc > 0
	  then p = get_pointer (file_base.after_desc);
	  call check_file_substate;
	  return;					/* skip protected body of procedure */
         end;
      file_base.after_desc = ind_desc;
      if ind_desc <= 0
      then file_base.new_record_length = 0;
      else if (block_ptr -> stat_struct.prev_mod = -3) & ^block_ptr -> record_block.indirect
						/* new compact */
      then file_base.new_record_length = length (stat_struct.record);
      else file_base.new_record_length = length (get_pointer (ind_desc) -> record_block.record);
      file_substate = file_substate + 1;		/* mark completion of this step */
   end set_after_image_info;

delete_entry:
   proc (del_rec_sw);				/* routine to delete index entry and rec if switch set */
      call initialize_substate;
      file_base.out_of_index = indx_cb.outside_index;	/* in case of crash */
      call set_del_ent_info;
      if del_cur
      then if is_sequential_open
	 then
	    do;
	       indx_cb.skip_state = 0;		/* scanning of deletions is forward */
	       indx_cb.next_record_position = 1;
	    end;
	 else indx_cb.next_record_position = 0;
      if del_rec_sw					/* delete_record operation */
      then
         do;
	  file_action = delete_action;
	  if del_cur				/* not delete_key case */
	  then
	     do;
	        indx_cb.current_record_is_valid = "0"b;	/* in case at eof or direct opening */
	        indx_cb.ready_to_write = "0"b;		/* may actually be ready if current exists */
	     end;
	  else if saved_state.current_record_is_valid
	  then indx_cb.current_descrip = saved_state.current_descrip;
	  else indx_cb.current_descrip = indx_cb.saved_descrip;
	  file_base.change_count = file_base.old_file_ch_count + 1;
	  if file_base.was_stat
	  then
	     do;					/* delete a stationary record */
	        if file_base.old_modifier > 0		/* TP case */
	        then
		 do;
		    file_base.new_descriptor = -1;
		    if file_base.old_ind_desc > 0	/* non-null after image */
		    then call change_record_list (iocb_ptr, replace_action, null, abort_exit);
						/* discard indirect after image allocation */
		    indx_cb.outside_index = "0"b;
		    if indx_cb.next_record_position = 1
		    then indx_cb.next_record_position = 2;
						/* skip over this key */
		    go to switch_file_state;		/* nothing more to do until checkpoint */
		 end;
	        call change_record_list (iocb_ptr, delete_action, null, abort_exit);
	        if indx_cb.outside_index
	        then
		 do;
		    indx_cb.outside_index = "0"b;
		    go to switch_file_state;
		 end;
	        if file_base.is_partial_deletion
	        then
		 do;
		    if indx_cb.next_record_position = 1
		    then indx_cb.next_record_position = 2;
		    go to switch_file_state;		/* don't delete last key */
		 end;
	        if ^del_cur				/* delete_key case */
	        then indx_cb.outside_index = saved_state.outside_index;
	     end;
	  else
	     do;
	        if old_record_designator ^= 0
	        then call change_record_list (iocb_ptr, delete_action, (null), abort_exit);
	        if indx_cb.outside_index		/* no key to delete */
	        then
		 do;
		    indx_cb.outside_index = "0"b;
		    go to switch_file_state;		/* just deleted the current record */
		 end;
	     end;
         end;
      else
         do;					/* operation is delete_key */
	  file_action = deleting_key;			/* all info necessary for recovery is saved */
	  if del_cur /* key to delete is at the current file position */ & ^indx_cb.outside_index
						/* deleting key of current record */
	  then call make_current (old_record_designator); /* current pos moves out of index */
	  else if saved_state.current_record_is_valid
	  then indx_cb.current_descrip = saved_state.current_descrip;
	  else indx_cb.current_descrip = indx_cb.saved_descrip;
	  file_base.change_count = file_base.old_file_ch_count + 1;
	  if file_base.was_stat
	  then
	     do;
	        block_ptr -> stat_struct.ref_count_after = file_base.old_ref_count;
	        block_ptr -> stat_struct.ref_count = file_base.old_ref_count;
	     end;
         end;
      if new_desc_val ^= 0				/* non-leaf node */
      then
         do;					/* replace key with highest preceding one */
	  call replace_non_leaf_key;
	  call reset_change_position;
	  if is_sequential_open & del_cur
	  then indx_cb.next_record_position = 2;
         end;
      call change_index (iocb_ptr, abort_exit);		/* deletes the key */
      pos_ptr = file_position_ptr;
      if new_desc_val ^= 0
      then if del_cur				/* pos belongs upstairs */
	 then call find_from_leaf;			/* climbs up tree */
      go to switch_file_state;			/* end of delete routine */

set_del_ent_info:
   proc;						/* saves vars necessary for deletion */
      is_ptr = indx_cb.index_state_ptr;
      if repeating
      then
         do;
	  i_locked_rec =
	     (file_action ^= delete_action)
	     | ((file_action = delete_action) & file_base.was_stat
	     & (file_base.is_partial_deletion | (file_base.old_modifier > 0)
	     | (file_base.old_ref_count > fixed (^file_base.out_of_index))));
	  call check_file_substate;
	  return;
         end;
      file_base.old_record_designator = indx_cb.current_descrip;
      if del_rec_sw					/* delete_record operation */
      then
         do;					/* prepare to remove old record */
	  call save_stat_info;			/* save more info if record is stationary */
	  file_base.is_partial_deletion = "0"b;
	  if file_base.was_stat			/* stationary record case */
	  then
	     do;
	        stat_struct.ind_comp = -1;
	        time_stamp_struct.ind_offset = (18)"1"b;	/* -1 */
	        file_base.old_ref_count = ref_cnt;
	        if file_base.old_modifier > 0		/* won't alter index at this time */
	        then go to bump_substate;		/* no more info to save for recoverability */
	        if indx_cb.shared
	        then if ^indx_cb.outside_index		/* key exists */
		   then if ref_cnt <= 1		/* at last reference */
		        then if time_stamp + indx_cb.collection_delay_time > clock ()
			   then file_base.is_partial_deletion = "1"b;
			   else i_locked_rec, i_set_negmod = "0"b;
						/* suppress unlocking */
		        else ;			/* will unlock record when done */
		   else if ref_cnt <= 0		/* no more refs--can collect */
		   then i_locked_rec, i_set_negmod = "0"b;
						/* block will be zeroed */
		   else ;				/* won't collect entire block--unlock */
	        else if ref_cnt <= fixed (^indx_cb.outside_index)
	        then i_locked_rec, i_set_negmod = "0"b;
	     end;
	  else i_locked_rec = "0"b;			/* always collect storage completely */
	  if ^rec_deleted				/* statistics must be adjusted */
	  then os_ptr -> number_of_records = number_of_records - 1;
	  os_ptr -> total_record_length = total_record_length - record_len;
	  if file_base.is_partial_deletion | indx_cb.outside_index
	  then go to bump_substate;
         end;
      else if (block_ptr = null)
      then file_base.was_stat = "0"b;
      else if block_ptr -> record_block.stationary
      then
         do;
	  file_base.was_stat = "1"b;
	  file_base.old_ref_count = ref_cnt;
         end;
      else file_base.was_stat = "0"b;
      os_ptr -> number_of_keys = number_of_keys - 1;
      os_ptr -> total_key_length = total_key_length - get_key_length ();
      change_position_ptr = pos_ptr;
      change_node = node;
      file_base.new_desc_val = branch (branch_num + 1);
      if dup_ok
      then if deleting_dup ()
	 then
	    do;					/* duplicate key stats must change */
	       os_ptr -> duplicate_keys = duplicate_keys - 1;
	       os_ptr -> dup_key_bytes = dup_key_bytes - get_key_length ();
	    end;
      if new_desc_val ^= 0				/* non-leaf node */
      then
         do;					/* prepare to delete preceding key */
	  call find_rightmost_descendent;
	  branch_num = branch_num - 1;
	  call prepare_key (substr (keys, key_pos (branch_num), key_length (branch_num)));
	  new_record_designator = record_designator (branch_num);
	  index_action = replace_action;		/* first replace key with copy of predecessor */
         end;
      else index_action = delete_action;
      call save_position_info;			/* remember index location */
bump_substate:
      file_substate = file_substate + 1;
   end set_del_ent_info;

deleting_dup:
   proc returns (bit (1) aligned);			/* routine checks whether key to delete is a duplicate */
      change_branch = branch_num;			/* remember current branch num */
      return (next_is_dup () | prev_is_dup ());		/* compares key with neighbors */

next_is_dup:
   proc returns (bit (1) aligned);			/* sees if next key matches current */
      branch_num = branch_num + 1;			/* advance position */
      call find_this_entry;				/* in case non-leaf or at last branch */
      new_branch_num = branch_num;
set_result:
      if pos_ptr = root_position_ptr			/* end of file */
      then keys_match = "0"b;				/* no prev or next key exists */
      else if (
	    substr (change_position_ptr -> node_ptr -> keys, change_position_ptr -> node_ptr -> key_pos (change_branch),
	    change_position_ptr -> node_ptr -> key_length (change_branch))
	    = substr (keys, key_pos (branch_num), key_length (branch_num)))
      then keys_match = "1"b;
      else keys_match = "0"b;
      branch_num = new_branch_num;			/* in case checking prev of first in node */
      pos_ptr = change_position_ptr;			/* restore file position */
      file_position_ptr = pos_ptr;
      branch_num = change_branch;
      return (keys_match);				/* return result */

prev_is_dup:
   entry returns (bit (1) aligned);			/* sees if preceding key matches current */
      call find_prev_entry;				/* in case non-leaf or at first branch */
      new_branch_num = branch_num;			/* in case this node is parent */
      branch_num = branch_num - 1;			/* does the backspace */
      go to set_result;				/* finish up */

   end next_is_dup;
      dcl	    keys_match	       bit (1) aligned;
      dcl	    new_branch_num	       fixed (35);
      dcl	    change_branch	       fixed (35);
   end deleting_dup;

      dcl	    del_rec_sw	       bit (1) aligned;
   end delete_entry;

replace_non_leaf_key:
   proc;
      if repeating
      then
         do;
	  next_substate = next_substate + 1;		/* file_substate is bumped by change_index */
	  call check_file_substate;
	  if file_substate >= next_substate
	  then return;
         end;
      call change_index (iocb_ptr, abort_exit);
      pos_ptr = file_position_ptr;
      file_substate = file_substate + 1;
   end replace_non_leaf_key;

reset_change_position:
   proc;
      is_ptr = indx_cb.index_state_ptr;
      if repeating
      then
         do;
	  call check_file_substate;
	  return;
         end;
      change_position_ptr = pos_ptr;
      change_node = node;
      index_action = delete_action;
      file_substate = file_substate + 1;
   end reset_change_position;

save_position_info:
   proc;						/* saves process variables required for recovery mechanism */
      current_node = node;
      p = root_position_ptr;
      do i = 1 to index_height;
         p = p -> son_position_ptr;
         saved_node (i) = p -> node;
         saved_branch_num (i) = p -> branch_num;
      end;
      dcl	    i		       fixed;
      dcl	    p		       ptr;
   end save_position_info;

add_key:						/* routine adds specified key to current record */
      if indx_cb.mode = 7				/* unkeyed update opening */
      then
         do;					/* abort */
	  code = error_table_$no_operation;
	  go to exit;
         end;
      current_retry_loc = ak_retry;
      go to init_up_down;
retry_loc (16):
      saved_state.current_record_is_valid = indx_cb.current_record_is_valid;
      saved_state.current_descrip = indx_cb.current_descrip;
      if ak_inf.input_key				/* get new key from info structure */
      then
         do;
	  if ^ak_inf.input_desc			/* using current record's descrip */
	  then
	     do;
	        call check_current;			/* checks if current rec is not defined */
	        if code ^= 0			/* error */
	        then go to verify_done;		/* abort or retry */
	        if ^indx_cb.shared | ^saved_state.current_record_is_valid
	        then call save_correct_pos;
	     end;
	  else if ^indx_cb.shared
	  then call save_correct_pos;
	  pos_incorrect = "1"b;			/* index position will not be current pos */
	  file_position_ptr = root_position_ptr;	/* start search from root */
	  if ^is_ks_out				/* update opening */
	  then
	     do;
	        call find_key$last (indx_cb_ptr, (addr (ak_info_key)), search_code);
						/* look for key */
	        pos_ptr = file_position_ptr;
	        if search_code = 0			/* key not found */
	        then key_is_dup = "0"b;		/* not a duplication */
	        else
		 do;				/* key already exists--set position properly */
		    key_is_dup = "1"b;
		    call find_from_leaf;		/* in case match was non-leaf */
						/*				call find_next_key; /* advance to beyond last duplication, */
		 end;
	     end;
	  else
	     do;					/* verify key order */
	        pos_ptr = indx_cb.file_position_ptr;
	        call find_rightmost_descendent;		/* position to end of file */
	        call compare_last_key (ak_info_key);	/* test key order */
	        if code ^= 0			/* key not larger than last in file */
	        then if ^key_is_dup			/* error--key out of order */
		   then go to verify_done;
		   else code = 0;			/* may be permitted */
	     end;
	  if key_is_dup & ^dup_ok			/* illegal key duplication */
	  then
	     do;					/* abort */
	        code = error_table_$key_duplication;
	        go to verify_done;
	     end;
         end;
      else if ^indx_cb.repeating
      then
         do;
	  if ak_inf.input_desc
	  then
	     do;
	        call check_current;
	        if code ^= 0
	        then go to verify_done;
	     end;
	  call check_key_for_insertion;
         end;
      if ak_inf.input_desc				/* descriptor in info structure */
      then indx_cb.current_descrip = ak_inf.descrip;
      if indx_cb.stat				/* record must be adjusted in this case */
      then
         do;
	  call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, 1);
						/* bump the ref count */
	  if code ^= 0
	  then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset)
						/* fatal */
	       then
		do;
		   if saved_state.current_record_is_valid
		   then indx_cb.current_descrip = saved_state.current_descrip;
		   else indx_cb.current_descrip = indx_cb.saved_descrip;
		   go to verify_done;
		end;
	       else code = 0;
         end;
      else block_ptr = null;				/* won't have to unlock the record */
      call initialize_substate;
      call set_add_ent_info ("0"b);			/* just add key, no record */
      if saved_state.current_record_is_valid
      then indx_cb.current_descrip = saved_state.current_descrip;
      else indx_cb.current_descrip = indx_cb.saved_descrip;
      file_action = adding_key;			/* no turning back now */
      file_base.change_count = file_base.old_file_ch_count + 1;
      if file_base.was_stat
      then
         do;
	  block_ptr -> stat_struct.ref_count_after = file_base.new_ref_count;
	  block_ptr -> stat_struct.ref_count = file_base.new_ref_count;
         end;
      call change_index (iocb_ptr, abort_exit);		/* inserts the new key */
      pos_ptr = file_position_ptr;
      go to switch_file_state;			/* end of add_key routine */

delete_key:					/* contains logic for the delete_key control order */
      call verify_keyed_update;			/* check opening mode */
      current_retry_loc = dk_retry;
      go to init_up_down;
retry_loc (17):
      saved_state.current_record_is_valid = indx_cb.current_record_is_valid;
      saved_state.current_descrip = indx_cb.current_descrip;
      if info_ptr = null				/* delete current entry for current rec */
      then
         do;
	  if indx_cb.outside_index			/* no key is associated with current record */
	  then code = error_table_$no_key;
	  else call check_current;			/* sets code */
	  if code ^= 0				/* error has occurred--abort */
	  then go to verify_done;
	  del_cur = "1"b;				/* indicates deleted entry is at current file position */
         end;
      else if ak_inf.input_key			/* use key in info structure */
      then
         do;
	  if ^ak_inf.input_desc
	  then
	     do;					/* use current record's descriptor */
	        call check_current;
	        if code ^= 0
	        then go to verify_done;		/* error */
	        if ^indx_cb.shared | ^saved_state.current_record_is_valid
						/* may not have saved current descriptor */
	        then call save_correct_pos;		/* don't lose your place */
	     end;
	  else
	     do;
	        if ^indx_cb.shared
	        then call save_correct_pos;
	        indx_cb.current_descrip = ak_inf.descrip; /* temporarily call this the current descriptor */
	     end;
	  if ^indx_cb.at_bof & ^indx_cb.at_eof
	     & ((indx_cb.next_record_position ^= 0) | (indx_cb.current_record_is_valid & ^indx_cb.outside_index))
	     & (indx_cb.current_descrip = indx_cb.saved_descrip) & (ak_info_key = indx_cb.new_key)
	  then
	     do;
	        del_cur = "1"b;
	        if indx_cb.pos_incorrect
	        then go to find_input_key;
	        else first_code, search_code = 1;	/* fake successful finding--already there */
	     end;
	  else
	     do;
	        del_cur = "0"b;
	        indx_cb.pos_incorrect = "1"b;
find_input_key:
	        call find_entry (ak_info_key, indx_cb.current_descrip);
						/* look for old entry */
	     end;
check_codes:
	  if first_code = 0				/* key not found--error */
	  then code = error_table_$no_key;
	  else if search_code = 0			/* old descrip not found--error */
	  then code = error_table_$no_record;
	  if code ^= 0				/* error has occurred */
	  then
	     do;
	        if saved_state.current_record_is_valid
	        then indx_cb.current_descrip = saved_state.current_descrip;
	        else indx_cb.current_descrip = indx_cb.saved_descrip;
	        go to verify_done;
	     end;
	  if del_cur				/* deleting current_key */
	  then indx_cb.pos_incorrect = "0"b;		/* save new current key */
         end;
      else if indx_cb.outside_index			/* no key for insertion */
      then
         do;					/* signal error */
	  code = error_table_$no_key;
	  go to verify_done;
         end;
      else
         do;
	  call check_current;			/* need current record's key */
	  if code ^= 0				/* error */
	  then
	     do;
	        if ak_inf.input_desc & (code = error_table_$no_record)
	        then code = error_table_$no_key;
	        go to verify_done;
	     end;
	  if ^ak_inf.input_desc			/* current key of current record */
	  then del_cur = "1"b;
	  else
	     do;
	        if ^indx_cb.shared | ^saved_state.current_record_is_valid
	        then call save_correct_pos;
	        indx_cb.current_descrip = ak_inf.descrip;
	        if indx_cb.current_descrip = indx_cb.saved_descrip
	        then
		 do;
		    del_cur = "1"b;
		    if indx_cb.pos_incorrect
		    then go to find_cur_key;
		 end;
	        else
		 do;
		    del_cur = "0"b;
		    indx_cb.pos_incorrect = "1"b;
find_cur_key:
		    call find_entry (indx_cb.new_key, indx_cb.current_descrip);
		    go to check_codes;
		 end;
	     end;
         end;
      if indx_cb.stat
      then
         do;					/* the ref count must be decremented */
	  indx_cb.is_read_only = "1"b;		/* suppress recursive garbage collection */
	  call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, -1);
						/* decrement the ref count */
	  indx_cb.is_read_only = "0"b;		/* restore opening state properly */
	  if code ^= 0
	  then if (code = error_table_$no_record) & (block_ptr ^= null)
	       then
		do;				/* handle logically deleted record */
		   if (ref_cnt <= 0) & (block_ptr -> stat_struct.modifier <= 0)
		   then
		      do;				/* setup delete_record case */
		         saved_state.outside_index = indx_cb.outside_index;
		         indx_cb.outside_index = "0"b;	/* signal remove key with record */
		         ref_cnt = ref_cnt + 1;	/* undo decrementing, not done by delete_record */
		         call delete_entry ("1"b);
		         return;			/* not supposed to get here */
		      end;
		end;
	       else if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset)
	       then
		do;
		   if saved_state.current_record_is_valid
		   then indx_cb.current_descrip = saved_state.current_descrip;
		   else indx_cb.current_descrip = indx_cb.saved_descrip;
		   go to verify_done;
		end;
	       else code = 0;
         end;
      else block_ptr = null;				/* don't unlock record */
      call delete_entry ("0"b);			/* don't delete the record, just the key */
      return;					/* end of delete_key */

verify_keyed_update:
   proc;						/* makes sure opening is valid for delete_key
						   or reassign_key */
      if (mode ^= 10) & (mode ^= 13)			/* not a valid mode */
      then
         do;					/* set error code and abort */
	  code = error_table_$no_operation;
	  go to exit;
         end;
   end verify_keyed_update;

select:						/* selects specified subset of records in the file */
      flag = select_flag;
      if ^common_sl_info.status_only			/* current subset will be reset or changed */
      then if common_sl_info.list_type = 0		/* no list specification--reselect given subset */
	 then
	    do;
	       if (common_sl_info.subset_no < 0) | (common_sl_info.subset_no > indx_cb.last_subset)
	       then
		do;
bad_arg:
		   code = error_table_$bad_arg;	/* invalid subset number */
		   go to exit;			/* abort */
		end;
	       indx_cb.current_subset = common_sl_info.subset_no;
	       if indx_cb.current_subset = 0		/* the identity subset */
	       then
		do;
		   indx_cb.subset_selected = "00"b;	/* convention means default subset */
		   if common_sl_info.output_descriptors /* must do more work */
		   then go to generate_subset;
		end;
	       else indx_cb.subset_selected = "10"b;
	       call count_subset;
	    end;
	 else go to generate_subset;
      else if common_sl_info.output_descriptors & (indx_cb.subset_selected = "00"b)
      then go to generate_subset;
      call get_subset_status;
      return;					/* end of select routine */

exclude:						/* creates temporary exclude list or removes entries from current subset */
      flag = exclude_flag;
      if common_sl_info.list_type = 0			/* reset to previous subset */
      then if (common_sl_info.subset_no <= 0) | (common_sl_info.subset_no > indx_cb.last_subset)
	 then go to bad_arg;
	 else
	    do;
	       indx_cb.current_subset = common_sl_info.subset_no;
	       indx_cb.subset_selected = "01"b;		/* pure exclusion */
	       call count_subset;			/* return subset count to user */
	    end;
      else go to generate_subset;
      call get_subset_status;
      return;					/* end of exclude routine */

get_subset_status:
   proc;						/* returns subset info into common_sl_info structure */
      if indx_cb.subset_selected = "00"b		/* nothing excluded or explicitly selected */
      then
         do;
	  if ^(common_sl_info.status_only & common_sl_info.output_descriptors)
	  then
	     do;					/* trust number of allocations as the count */
	        f_b_ptr = indx_cb.file_base_ptr;
	        indx_cb.subset_count = addr (file_state_blocks (file_base.file_state)) -> number_of_allocated_records;
	     end;
	  common_sl_info.subset_no = 0;
         end;
      else if indx_cb.subset_selected = "10"b		/* pure selection */
      then common_sl_info.subset_no = indx_cb.current_subset;
      else common_sl_info.subset_no = -1 * indx_cb.current_subset;
						/* pure exclusion */
      common_sl_info.count = indx_cb.subset_count;	/* count of items in temporary file for this subset */

      if common_sl_info.output_descriptors & ^(indx_cb.subset_selected = "00"b & flag = select_flag)
      then
         do;
	  if common_sl_info.desc_arrayp = null & common_sl_info.count > 0
						/* wants me to make allocation */
	  then
	     do;
	        if system_freep = null		/* first time this process */
	        then system_freep = get_system_free_area_ ();
	        allocate desc_array in (system_freep -> based_area) set (common_sl_info.desc_arrayp);
	     end;
	  call list_subset;
         end;
   end get_subset_status;

count_subset:
   proc;						/* sets subset_count for current subset */
      if indx_cb.subset_selected = "00"b
      then
         do;					/* treat identity subset as a special case */
	  f_b_ptr = indx_cb.file_base_ptr;
	  indx_cb.subset_count = addr (file_state_blocks (file_base.file_state)) -> number_of_allocated_records;
	  return;
         end;
      count = 0;
      unspec (zero_word_bytes) = "0"b;
      subset_key = current_subset_bytes || zero_word_bytes; /* head for desired portion of temp index */
      indx_cb_ptr = indx_cb.temp_iocbp -> iocb.open_data_ptr;
      call seek_head (1, addr (subset_key), 8);		/* position to start of range in temp file */

      do while (pos_ptr ^= root_position_ptr);		/* loop steps until beyond current subset's range */
         if substr (subset_key, 1, 4) = substr (keys, key_pos (branch_num), 4)
						/* in current subset */
         then
	  do;
	     count = count + 1;
	     branch_num = branch_num + 1;
	     call find_this_entry;			/* in case last branch in node or non-leaf */
	  end;
         else pos_ptr = root_position_ptr;		/* force exit from loop */
      end;

      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      pos_ptr = indx_cb.file_position_ptr;
      indx_cb.subset_count = count;
      return;					/* end of count_subset logic */

list_subset:
   entry;						/* fills descriptor array with entries for current subset */
      unspec (zero_word_bytes) = "0"b;
      subset_key = current_subset_bytes || zero_word_bytes;
      count = indx_cb.subset_count;
      i = 0;
      indx_cb_ptr = indx_cb.temp_iocbp -> iocb.open_data_ptr;
      call seek_head (1, addr (subset_key), 8);		/* find start of current subset in temp file */

      do while ((i < count) & (pos_ptr ^= root_position_ptr));
         i = i + 1;
         common_sl_info.desc_arrayp -> desc_array_bytes (i) = substr (keys, key_pos (branch_num) + 4, 4);
						/* descriptor in lower word of temp key */
         branch_num = branch_num + 1;			/* advance to next */
         call find_this_entry;			/* handles exceptions */
      end;

      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;	/* restore stuff for current file */
      pos_ptr = indx_cb.file_position_ptr;
      indx_cb.subset_count = i;
      common_sl_info.count = i;			/* in case count was wrong */
      return;					/* end of list_subset logic */

      dcl	    subset_key	       char (8) var;
      dcl	    desc_array_bytes       (1:common_sl_info.count) char (4) based (common_sl_info.desc_arrayp);
      dcl	    current_subset_bytes   char (4) based (addr (indx_cb.current_subset));
      dcl	    zero_word_bytes	       char (4) aligned;
      dcl	    count		       fixed;
      dcl	    i		       fixed;
   end count_subset;

generate_subset:					/* flag indicates whether select or exclude */
      if common_sl_info.list_type > max_list_type
      then go to bad_arg;
      else
         do;
	  if flag = select_flag
	  then next_subset = indx_cb.last_subset + 1;	/* select creates a new subset */
	  else if indx_cb.subset_selected = "00"b
	  then next_subset = indx_cb.last_subset + 1;
	  else next_subset = indx_cb.current_subset;	/* modify current subset */
	  if indx_cb.temp_iocbp = null		/* have not yet used temp switch */
	  then call get_temp_switch;
	  else if common_sl_info.delete_old_subsets
	  then if indx_cb.current_subset = 0
	       then call delete_old_subsets (indx_cb.temp_iocbp);
	       else
		do;
		   code = error_table_$bad_arg;
		   return;
		end;

	  count = 0;				/* will accumulate total count of descriptors */
	  temp_ak_inf.flags = "11"b;
	  temp_ak_inf.descriptor = 0;
	  temp_ak_inf.key_len = 8;
	  if (common_sl_info.list_type = 1) | (common_sl_info.status_only)
						/* array of intervals */
	  then
	     do;
	        current_retry_loc = init_retry;
	        saved_subset_selected = indx_cb.subset_selected;
	        saved_current_subset = indx_cb.current_subset;
	        go to initialize;
retry_loc (18):
	        call save_correct_pos;		/* in order to restore initial position */
	        indx_cb.pos_incorrect = "1"b;
	        if common_sl_info.status_only
	        then n_int = 1;
	        else n_int = common_sl_info.array_limit;
	        pad_key_ptr = addr (gk_pad_key);
	        last_info_ptr = addr (last_info_block (0));
	        last_info.new_last_info_ptr = addr (last_info_block (1));
	        new_last_info.new_last_info_ptr = last_info_ptr;

	        do i = 1 to n_int;			/* for each interval accumulate descriptors */
		 current_retry_loc = outer_retry;
outer_loop:
		 if common_sl_info.status_only
		 then
		    do;
		       last_head = "";
		       call position_bof;
		       if last_branch_num = 1		/* file is empty */
		       then go to next_interval;
		    end;
		 else
		    do;
		       if ((hi_sl_info.last_head.length (i) < 0)
			& (hi_sl_info.first_head.kptr (i) = hi_sl_info.last_head.kptr (i)))
						/* else exact match required */
		       then head_spec = "0"b;
		       else head_spec = "1"b;
		       if head_spec			/* interval defined in terms of first and last head */
		       then
			do;
			   pad_key_len = 256;	/* must pad with zeroes for valid seek_head */
			   unspec (
			      substr (pad_key, hi_sl_info.first_head.length (i) + 1,
			      256 - hi_sl_info.first_head.length (i))) = "0"b;
						/* pad with zeroes */
			   substr (pad_key, 1, hi_sl_info.first_head.length (i)) =
			      substr (hi_sl_info.first_head.kptr (i) -> bstring, 1,
			      hi_sl_info.first_head.length (i));
			   call seek_head (1, addr (pad_key_info), hi_sl_info.first_head.length (i));
			   if pos_ptr = indx_cb.root_position_ptr
						/* head not found */
			   then go to next_interval;
			   last_head =
			      substr (hi_sl_info.last_head.kptr (i) -> bstring, 1,
			      abs (hi_sl_info.last_head.length (i)));
			   if (hi_sl_info.last_head.length (i) < 0)
			   then open_ended = "1"b;
			   else open_ended = "0"b;
			end;
		       else
			do;			/* force exact match with given key */
			   open_ended = "0"b;
			   vpad_key =
			      substr (hi_sl_info.first_head.kptr (i) -> bstring, 1,
			      hi_sl_info.first_head.length (i));
			   file_position_ptr = root_position_ptr;
						/* prepare for descent */
			   call find_key (indx_cb_ptr, (addr (vpad_key)), search_code);
			   pos_ptr = file_position_ptr;
			   if search_code = 0	/* not found */
			   then go to next_interval;
			   call find_from_leaf;	/* in case match in upper node */
			   last_head_len = 256;
			   substr (last_head, 1, length (vpad_key)) = vpad_key;
			   substr (last_head, length (vpad_key) + 1, 256 - length (vpad_key)) =
			      substr (blanks, 1, 256 - length (vpad_key));
			end;
		    end;
		 last_key = substr (keys, key_pos (branch_num), key_length (branch_num));
		 last_descrip = record_designator (branch_num);

inner_loop:
		 do while (substr (last_key, 1, min (length (last_head), length (last_key))) <= last_head);
						/* pick up each index entry in this interval */
		    if substr (last_key, 1, min (length (last_head), length (last_key))) = last_head
						/*
						   exact match of head */
		    then if open_ended
		         then go to next_interval;	/* done with this interval */
		    if indx_cb.shared & ^indx_cb.leave_locked
						/* may have undergone asynch changes */
		    then if file_base.change_count ^= indx_cb.last_change_count
						/* has changed */
		         then
			  do;
			     call note_last_subset;
			     call prepare_process;
			     if current_retry_loc ^= inner_retry
			     then go to retry_loc (current_retry_loc);
retry_loc (19):
			     call find_entry (last_key, last_descrip);
			     if search_code = 0	/* prev entry not found */
			     then
			        do;		/* abort--can't find previous position */
				 call note_last_subset;
				 code = error_table_$asynch_deletion;
				 go to verify_done; /* may retry again if another asynch change */
			        end;
			     go to inner_loop;	/* resume inner loop scan from last position */
			  end;
		         else current_retry_loc = inner_retry;
		    if indx_cb.subset_selected ^= "00"b
		    then
		       do;
			call check_subset (last_descrip);
			if rec_deleted		/* this descriptor has been masked */
			then go to next_entry;	/* just skip to next */
		       end;
		    temp_key_words (1) = next_subset;
		    temp_key_words (2) = last_descrip;
		    call enter_temp_key;
next_entry:
		    branch_num = branch_num + 1;
		    call find_this_entry;
		    new_last_key = substr (keys, key_pos (branch_num), key_length (branch_num));
		    new_last_descrip = record_designator (branch_num);
		    last_info_ptr = last_info.new_last_info_ptr;
		    if pos_ptr = root_position_ptr	/* at eof */
		    then go to next_interval;		/* done with this interval */
		 end;

next_interval:
		 if indx_cb.shared & ^indx_cb.leave_locked
		 then if indx_cb.last_change_count ^= file_base.change_count
		      then
		         do;
			  if current_retry_loc ^= outer_retry
			  then go to retry_loc (current_retry_loc);
retry_loc (20):
			  call note_last_subset;
			  call prepare_process;
			  go to outer_loop;
		         end;
	        end;				/* end of outer loop */

	     end;					/* end of interval list case */
	  else if common_sl_info.list_type = 2		/* descriptor array specification */
	  then
	     do i = 1 to common_sl_info.array_limit;	/* use descriptors from list */
	        if indx_cb.subset_selected ^= "00"b
	        then call check_subset (da_sl_info.desc_array (i));
	        else rec_deleted = "0"b;
	        if ^rec_deleted
	        then
		 do;
		    temp_key_words (1) = next_subset;
		    temp_key_words (2) = da_sl_info.desc_array (i);
		    call enter_temp_key;
		 end;
	     end;

         end;					/* count is now known */
      if count = 0					/* no records found */
      then code = error_table_$no_record;
      else
         do;
	  code = 0;
	  if (flag = select_flag) | ((flag ^= select_flag) & (indx_cb.subset_selected = "00"b))
	  then indx_cb.subset_count = count;
	  else if indx_cb.subset_selected = "10"b
	  then indx_cb.subset_count = indx_cb.subset_count - count;
						/* entries removed from subset */
	  else indx_cb.subset_count = indx_cb.subset_count + count;
						/* entries added to exclude list */
	  indx_cb.current_subset = next_subset;
	  call note_last_subset;

	  if common_sl_info.status_only
	  then go to get_status;
	  if (flag = select_flag) | ((flag ^= select_flag) & (indx_cb.subset_selected = "10"b))
	  then indx_cb.subset_selected = "10"b;		/* pure selection */
	  else indx_cb.subset_selected = "01"b;		/* pure exclusion */
         end;
get_status:
      call get_subset_status;
      return;					/* end of generate subset--done with select or exclude */

get_temp_switch:
   proc;						/* obtains temp file for sorting descriptors */
      unique_name = unique_chars_ ("0"b) || ".temp.vfile_";
      proc_dir_string = get_pdir_ ();

      pd_path_len = index (proc_dir_string, " ") - 1;
      call iox_$attach_name (unique_name, iocbp, "vfile_ " || proc_dir_path || ">" || unique_name, null, code);
      call iox_$open (iocbp, 10, "0"b, code);
      call check_code (code, "Cannot open temporary subset file.");
      indx_cb.temp_iocbp = iocbp;
      dcl	    unique_chars_	       entry (bit (*)) returns (char (15));
      dcl	    1 proc_dirp_overlay,
	      2 pd_path_len	       fixed,
	      2 proc_dir_string    char (168);
      dcl	    proc_dir_path	       char (168) var based (addr (pd_path_len));
      dcl	    iocbp		       ptr;
   end get_temp_switch;

enter_temp_key:
   proc;						/* adds entry to temp file or removes entry and adjusts count */
      if (flag = select_flag) | ((flag ^= select_flag) & (indx_cb.subset_selected ^= "10"b))
      then
         do;
	  call control_indx_file (indx_cb.temp_iocbp, "add_key", addr (temp_ak_inf), code);
	  if code = 0
	  then count = count + 1;
	  else if code ^= error_table_$key_duplication
	  then
	     do;
	        call note_last_subset;
	        call check_code (code, "Can't add descriptor into current subset.");
	     end;
         end;
      else
         do;
	  call control_indx_file (indx_cb.temp_iocbp, "delete_key", addr (temp_ak_inf), code);
	  if code = 0
	  then count = count + 1;
	  else if code ^= error_table_$no_key
	  then
	     do;
	        call note_last_subset;
	        call check_code (code, "Can't remove descriptor from current subset.");
	     end;
         end;
   end enter_temp_key;

note_last_subset:
   proc;						/* keeps track of highest used subset number */
      if count = 0					/* no entries in new subset */
      then return;					/* no adjustment needed */
      indx_cb.last_subset = max (indx_cb.last_subset, next_subset);
   end note_last_subset;

reassign_key:					/* routine swaps record descrip for spec key */
      call verify_keyed_update;			/* checks opening mode */
      current_retry_loc = rk_retry;
      go to init_up_down;
retry_loc (21):
      saved_state.current_record_is_valid = indx_cb.current_record_is_valid;
      saved_state.current_descrip = indx_cb.current_descrip;
      pos_unchanged = "0"b;
      if ^rk_inf.input_key & indx_cb.outside_index	/* error--no key associated with current rec */
      then code = error_table_$no_key;
      else if ^rk_inf.input_old_desc | ^rk_inf.input_new_desc
						/* need current descrip */
      then call check_current;
      else if ^rk_inf.input_key			/* using current record's key */
      then
         do;
	  call check_current;			/* need current record to be defined */
	  if code ^= 0				/* error */
	  then code = error_table_$no_key;		/* set proper code */
         end;
      if code ^= 0
      then go to verify_done;				/* abort on error */
      if rk_inf.input_old_desc
      then old_des = rk_inf.old_descrip;
      else old_des = indx_cb.current_descrip;
      if rk_inf.input_new_desc
      then new_des = rk_inf.new_descrip;
      else new_des = indx_cb.current_descrip;
      if rk_inf.input_key
      then
         do;
	  if ^indx_cb.shared | ^saved_state.current_record_is_valid
	  then call save_correct_pos;
	  if ^indx_cb.at_bof & ^indx_cb.at_eof
	     & ((indx_cb.next_record_position ^= 0) | (indx_cb.current_record_is_valid & ^indx_cb.outside_index))
	     & (old_des = indx_cb.saved_descrip) & (indx_cb.new_key = key_to_reassign)
	  then
	     do;
	        if indx_cb.pos_incorrect
	        then
		 do;
		    call restore_position;
		    if (code = 0) & (record_designator (branch_num) ^= indx_cb.saved_descrip)
		    then code = error_table_$asynch_deletion;
						/* insist on same
						   descriptor */
		 end;
	        else pos_ptr = indx_cb.file_position_ptr;
	        pos_unchanged = "1"b;
	        first_code = 1;			/* anything non-zero indicates key was found */
	        search_code = 1;			/* indicates descriptor was found */
	     end;
	  else call find_entry (key_to_reassign, old_des);/* look for entry */
         end;
      else if rk_inf.input_old_desc			/* key is same, but entry may be different */
      then
         do;
	  if ^indx_cb.shared | ^saved_state.current_record_is_valid
	  then call save_correct_pos;
	  if old_des = indx_cb.saved_descrip
	  then
	     do;
	        pos_unchanged = "1"b;
	        first_code = 1;
	        search_code = 1;
	     end;
	  else call find_entry (indx_cb.new_key, old_des);
         end;
      else
         do;					/* file position is already correct */
	  first_code = 1;
	  search_code = 1;
	  pos_unchanged = "1"b;
         end;
      if ^pos_unchanged
      then indx_cb.pos_incorrect = "1"b;
      if first_code = 0				/* key not found */
      then code = error_table_$no_key;
      else if search_code = 0				/* key found, but not specified descrip */
      then code = error_table_$no_record;
      if code ^= 0
      then go to verify_done;
      indx_cb.current_descrip = old_des;
      if indx_cb.stat				/* look for ref counts */
      then
         do;
	  saved_state.outside_index = indx_cb.outside_index;
	  indx_cb.outside_index = "0"b;		/* in case of garbage collection */
	  call lock_current_record (block_ptr, lock_ptr, i_locked_rec_mask, -1);
						/* decrement old record ref count */
	  indx_cb.outside_index = saved_state.outside_index;
						/* restore */
	  if code ^= 0
	  then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset)
	       then
		do;
		   if saved_state.current_record_is_valid
		   then indx_cb.current_descrip = saved_state.current_descrip;
		   else indx_cb.current_descrip = indx_cb.saved_descrip;
		   go to verify_done;
		end;
	  old_ref_cnt = ref_cnt;
	  current_retry_loc = reass_key_retry_2;
	  indx_cb.current_descrip = new_des;
retry_loc (22):
	  indx_cb.outside_index = "0"b;
	  call lock_current_record (new_block_ptr, new_lock_ptr, i_locked_new_mask, 1);
	  indx_cb.outside_index = saved_state.outside_index;
	  if (code ^= 0)
	  then if (code ^= error_table_$locked_by_this_process) & (code ^= error_table_$invalid_lock_reset)
	       then
		do;				/* undo any change and abort */
		   if saved_state.current_record_is_valid
		   then indx_cb.current_descrip = saved_state.current_descrip;
		   else indx_cb.current_descrip = indx_cb.saved_descrip;
		   go to unlock_exit;
		end;
	       else code = 0;			/* suppress non-fatal warning */
         end;
      else
         do;
	  block_ptr = null;
	  new_block_ptr = null;
         end;
      if saved_state.current_record_is_valid
      then indx_cb.current_descrip = saved_state.current_descrip;
      else indx_cb.current_descrip = indx_cb.saved_descrip;
      call initialize_substate;
      call set_rk_info;				/* saves info for recovery */
      file_action = reassigning_key;
      file_base.change_count = file_base.old_file_ch_count + 1;
      if block_ptr ^= null
      then if block_ptr -> record_block.stationary
	 then
	    do;
	       block_ptr -> stat_struct.ref_count_after = file_base.old_ref_count;
	       block_ptr -> stat_struct.ref_count = file_base.old_ref_count;
	    end;
      if new_block_ptr ^= null
      then if new_block_ptr -> record_block.stationary
	 then
	    do;
	       new_block_ptr -> stat_struct.ref_count_after = file_base.new_ref_count;
	       new_block_ptr -> stat_struct.ref_count = file_base.new_ref_count;
	    end;
      record_descrip (branch_num) = file_base.new_descriptor;
      go to switch_file_state;			/* end of reassign key routine */

set_rk_info:
   proc;						/* saves reassign key info for recovery */
      if repeating
      then
         do;
	  pos_ptr = indx_cb.file_position_ptr;		/* reconstruct during recovery */
	  call check_file_substate;
	  return;
         end;
      if (block_ptr = null)
      then file_base.was_stat = "0"b;
      else if block_ptr -> record_block.stationary
      then
         do;
	  file_base.was_stat = "1"b;
	  file_base.old_ref_count = old_ref_cnt;
         end;
      else file_base.was_stat = "0"b;
      if (new_block_ptr ^= null)
      then if new_block_ptr -> record_block.stationary
	 then
	    do;
	       file_base.was_stat = "1"b;
	       file_base.new_ref_count = ref_cnt;
	    end;
      file_base.new_descriptor = new_des;
      file_base.old_record_designator = old_des;		/* now save index location in convenient header variables */
      file_base.first_branch = node;			/* same protected variable used by rewrite */
      file_base.count = branch_num;
      file_substate = file_substate + 1;		/* note this block of code has been completed */
   end set_rk_info;

set_lock_list_entry:
   proc (block_ptr_arg, passive_ref_mask);		/* add non-passive reference list entry after
						   verifying any prior reference */
      passive = "0"b;
      must_verify = indx_cb.shared;
      go to main;
add_lock_list_entry:
   entry (block_ptr_arg, passive_ref_mask);		/* create entry for new record */
      passive = "0"b;
      must_verify = "0"b;
      go to main;
set_ref_list_entry:
   entry (block_ptr_arg);				/* adds item to passive ref list */
      passive = "1"b;				/* not locking an item */
      must_verify = "1"b;
main:
      if indx_cb.tcfp -> iocb.open_data_ptr -> indx_cb.reflp = null
      then
         do;					/* initialize ref list */
	  call transaction_call_$setup_ref_list (indx_cb.tcfp, er_code);
	  call check_code (er_code, "Unable to initialize a transaction reference list.");
         end;
      refp = indx_cb.tcfp -> iocb.open_data_ptr -> indx_cb.reflp;
      if indx_cb.uid = "0"b				/* comp 0 uid has not yet been obtained */
      then call init_uid_info;			/* gets uid--by now file will be an msf */
      temp_key.transaction_number = current_t_code;
      temp_key.file_id = indx_cb.uid;			/* for process independent record locator */
      temp_key.rec_id = indx_cb.current_descrip;
      temp_key.blockp = block_ptr_arg;			/* this shouldn't really be necessary when right */
      if ^must_verify				/* just add lock list entry for new record */
      then
         do;					/* don't bother to verify */
	  temp_ak_inf.flags = "11"b;
	  temp_ak_inf.key_len = 16;			/* short form */
	  temp_ak_inf.descrip = -1;			/* non-passive reference */
	  call iox_$control (refp, "add_key", addr (temp_ak_inf), er_code);
	  if (er_code ^= 0) & (er_code ^= error_table_$key_duplication)
						/* avoid cost of calling check_code if not needed */
	  then call check_code (er_code, "Can't create a ref list entry for the new record.");
	  return;
         end;
      temp_key.time = 0;				/* pad with 0's */
      temp_rk_inf.key_len = 22;
      indx_cb_ptr = refp -> iocb.open_data_ptr;		/* set up for seek_head */
      call seek_head (0, addr (temp_rk_inf.key_len), 12);	/* sets pos_ptr to root if fails */
      if (passive & ((cur_mod = 0) | (cur_mod = -1))) /* modifier isn't enough to uniquely
						   identify this record's image */
         | (^passive & (block_ptr_arg -> stat_struct.prev_mod = 0))
						/* prev image requires
						   long form verification */
      then
         do;
	  temp_key.time = time_stamp;
	  temp_rk_inf.old_descrip = ind_desc;
	  if passive				/* record modifier will be non-positive */
	  then temp_rk_inf.new_descrip = ind_desc;	/* also setting add_key's
						   descriptor in info structure */
	  else temp_rk_inf.new_descrip = -1;
         end;
      else
         do;					/* short form ref list entry */
	  temp_rk_inf.key_len = 16;
	  temp_rk_inf.old_descrip = cur_mod;		/* current image id */
	  if ^passive
	  then temp_rk_inf.new_descrip = -1;		/* this value means ref is to lock */
	  else temp_rk_inf.new_descrip = cur_mod;
         end;
      if pos_ptr ^= indx_cb.root_position_ptr		/* not first ref */
      then if (record_designator (branch_num) = temp_rk_inf.old_descrip)
	    & (substr (keys, key_pos (branch_num), key_length (branch_num)) = rk_key)
	 then
	    do;					/* prev ref is verified */
	       indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	       pos_ptr = indx_cb.file_position_ptr;	/* restore local environment */
	       if ^passive				/* verified ref was to lock */
	       then
		do;
		   cleanup_flags = cleanup_flags | passive_ref_mask;
						/* remember that refl entry exists */
		   if temp_rk_inf.key_len = 16	/* old ref in short form */
		   then
		      do;				/* just reassign--already short form */
		         temp_rk_inf.flags = "111"b;	/* input all params */
		         call iox_$control (refp, "reassign_key", addr (temp_rk_inf), er_code);
		         if er_code ^= 0		/* optimization */
		         then call
			       check_code (er_code,
			       "Can't convert a short form passive ref list entry into a non-passive one.");
		      end;			/* end of simple reassignment case */
		   else
		      do;				/* convert long form passive entry into
						   short form non-passive ref list entry */
		         temp_ak_inf.key_len = 16;
		         temp_ak_inf.flags = "11"b;	/* input key and desc */
		         call iox_$control (refp, "add_key", addr (temp_ak_inf), er_code);
						/* add new entry before removing old one */
		         if (er_code ^= 0) & (er_code ^= error_table_$key_duplication)
		         then call
			       check_code (er_code,
			       "Can't add a non-passive ref list entry for a previous long form passive reference.")
			       ;
		         temp_ak_inf.key_len = 22;	/* set up to delete
						   long form entry */
		         temp_ak_inf.descrip = ind_desc;
		         call iox_$control (refp, "delete_key", addr (temp_ak_inf), er_code);
		         if er_code ^= 0
		         then call
			       check_code (er_code,
			       "Can't delete the old long form passive ref list entry for a subsequently modified item."
			       );
		      end;
		end;
	    end;					/* end of verified ref case */
	 else
	    do;					/* error--prev reference invalid */
	       indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	       pos_ptr = indx_cb.file_position_ptr;
	       if key_length (branch_num) = 16
	       then if record_designator (branch_num) = -1/* thought I locked it--maybe interrupted */
		  then if block_ptr_arg -> stat_struct.record_lock = indx_cb.saved_lock_copy
		       then return;			/* suppress error message */
	       code = error_table_$asynch_change;
	    end;
      else
         do;					/* add a ref list entry for first ref this transaction */
	  indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
	  pos_ptr = indx_cb.file_position_ptr;
	  temp_ak_inf.flags = "11"b;
	  if ^passive
	  then temp_ak_inf.key_len = 16;		/* create short form entry */
	  call iox_$control (refp, "add_key", addr (temp_ak_inf), er_code);
	  if er_code ^= 0
	  then call check_code (er_code, "Can't create a new ref list entry for this item.");
         end;					/* end of no previous reference case */
      return;					/* done with ref list manipulation */

init_uid_info:
   proc;						/* gets uid for this file from component 0 */
						/* also may create a ref list entry to remember iocb_ptr, if no such entry
						   already exists for this file in this process */
      call hcs_$get_uid_seg (indx_cb.file_base_ptr, uid_val, er_code);
      call check_code (er_code, "Cannot get a uid for the file.");
      unspec (gk_inf.flags) = "0"b;
      gk_inf.input_key = "1"b;
      gk_inf.head_size = 12;
      gk_inf.key_len = 12;
      gk_key.zero = 0;
      gk_key.proc_id = indx_cb.saved_lock_copy;
      gk_key.file_id = uid_val;
      refp = indx_cb.tcfp -> iocb.open_data_ptr -> indx_cb.reflp;
      call iox_$control (refp, "get_key", addr (gk_inf), er_code);
      if er_code = 0				/* file is known to this ref list */
      then if gk_desc = iocb_ptr			/* this I/O switch */
	 then return;				/* nothing more to do--refl entry is fine */
	 else
	    do;					/* set refl entry to use this iocb_ptr */
	       string (rk_inf.flags) = "111"b;
	       rk_inf.old_descrip = rk_inf.new_descrip;	/* set by gk */
	       gk_desc = iocb_ptr;			/* new descrip for reassign_key */
	       call iox_$control (refp, "reassign_key", addr (rk_inf), er_code);
	       call
		check_code (er_code, "Can't reset default iocb_ptr for this file in the transaction reference list.");
	    end;
      else
         do;					/* attempt to create new refl entry */
	  string (ak_inf.flags) = "11"b;		/* input key and desc */
	  gk_desc = iocb_ptr;
	  call iox_$control (refp, "add_key", addr (ak_inf), er_code);
	  call check_code (er_code, "Can't save the iocb_ptr for this file in the transaction reference list.");
         end;
      indx_cb.uid = uid_val;
      dcl	    refp		       ptr;
      dcl	    uid_val	       bit (36) aligned;
      dcl	    er_code	       fixed (35);
      dcl	    1 rk_inf,
	      2 header	       like rk_header,
	      2 key	       char (12);
      dcl	    1 gk_inf	       based (addr (rk_inf.old_descrip)),
	      2 header	       like gk_header,
	      2 key	       char (12);
      dcl	    1 ak_inf	       based (addr (rk_inf.old_descrip)),
	      2 header	       like ak_header,
	      2 key	       char (12);
      dcl	    gk_desc	       ptr unal based (addr (gk_inf.descrip));
      dcl	    1 gk_key	       based (addr (gk_inf.key)),
	      2 zero	       fixed (35),
	      2 proc_id	       bit (36) aligned,
	      2 file_id	       bit (36) aligned;
   end init_uid_info;

      dcl	    passive	       bit (1) aligned;
      dcl	    must_verify	       bit (1) aligned;
      dcl	    er_code	       fixed (35);
      dcl	    1 temp_rk_inf,
	      2 flags	       bit (36) aligned,
	      2 old_descrip	       fixed (35),
	      2 new_descrip	       fixed (35),
	      2 key_len	       fixed,
	      2 key	       char (22);
      dcl	    1 temp_ak_inf	       based (addr (temp_rk_inf.old_descrip)),
	      2 flags	       bit (36) aligned,
	      2 descrip	       fixed (35),
	      2 key_len	       fixed,
	      2 key	       char (22);
      dcl	    refp		       ptr;
      dcl	    1 temp_key	       based (addr (temp_rk_inf.key)),
	      2 transaction_number fixed (35),
	      2 file_id	       bit (36) aligned,
	      2 rec_id	       fixed (35),
	      2 blockp	       ptr unal,		/* should not be needed when done right */
	      2 time	       fixed (53) unal;	/* long form only */
      dcl	    rk_key	       char (22) var based (addr (temp_rk_inf.key_len));
      dcl	    block_ptr_arg	       ptr;
      dcl	    passive_ref_mask       bit (36) aligned;
   end set_lock_list_entry;

restore_abort:
   proc;						/* cleans up after unusual abort */
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      indx_cb.pos_incorrect = "1"b;			/* restore indx_cb state */
      call restore_state;
      if cleanup_flags = "000000"b
      then return;					/* nothing to unlock */
      aborting = "1"b;
      if i_locked_file
      then if stacq (file_base.lock_word, (36)"1"b, indx_cb.saved_lock_copy)
	 then ;					/* invalidate file lock */
      if i_locked_rec & (block_ptr ^= null) & (lock_ptr ^= null)
      then if indx_cb.trans
	 then if block_ptr -> record_block.stationary
	      then if (block_ptr -> stat_struct.modifier > 0) & (block_ptr -> stat_struct.modifier = current_t_code)
		 then ;				/* leave old record locked--has a lock list entry */
		 else if old_passive_ref
		 then ;
		 else go to inv_old;
	      else go to inv_old;
	 else
	    do;
inv_old:
	       if stacq (lock_ptr -> based_lock, (36)"1"b, indx_cb.saved_lock_copy)
	       then ;
	    end;
      if i_locked_new & (new_block_ptr ^= null) & (new_lock_ptr ^= null)
      then if indx_cb.trans
	 then if new_block_ptr -> record_block.stationary
	      then if (new_block_ptr -> stat_struct.modifier > 0)
		    & (new_block_ptr -> stat_struct.modifier = current_t_code)
		 then ;
		 else if new_passive_ref
		 then ;
		 else go to inv_new;
	      else go to inv_new;
	 else
	    do;
inv_new:
	       if stacq (new_lock_ptr -> based_lock, (36)"1"b, indx_cb.saved_lock_copy)
	       then ;
	    end;
   end restore_abort;

restore_state:
   proc;						/* re-establishes initial values of process vars which may have been clobbered */
      indx_cb.mode = atb.opening_mode;
      indx_cb.is_sequential_open = (indx_cb.mode < 11);
      indx_cb.is_read_only = substr ("0001000100100"b, indx_cb.mode, 1);
      indx_cb.is_ks_out = (indx_cb.mode = 9);
      if current_retry_loc = skip_retry			/* position skip attempt */
      then indx_cb.error = saved_error_info;
      else if (current_retry_loc = init_retry) | (current_retry_loc = inner_retry) | (current_retry_loc = outer_retry)
						/* select or exclude */
      then
         do;					/* restore subset state */
	  indx_cb.subset_selected = saved_subset_selected;
	  indx_cb.current_subset = saved_current_subset;
         end;
      indx_cb.state_vars = saved_state;
   end restore_state;

open_file:
      call create_indx_cb;
      if is_new_file
      then call initialize_new_file;
      else if file_version ^= current_file_version
      then
         do;
	  call check_file_version (indx_cb_ptr, code);	/* checks for pre-crashproof version */
	  if code ^= 0
	  then
	     do;
	        saved_state.shared = indx_cb.shared;
	        call free_cb_file (size (indx_cb), indx_cb_ptr);
	        if ^substr ("0001000100100"b, atb.opening_mode, 1) & saved_state.shared
	        then call set_lock_$unlock (lock_word, foo);
	        return;
	     end;
         end;
      else call check_comp_array_table;			/* To catch bad tables produced by bug in */
						/* check_file_version . */
      call create_seg_ptrs (iocb_ptr);
      call create_position_stack (indx_cb_ptr);
      if (file_action ^= 0) & ^is_read_only & (file_action ^= read_exclude)
      then if file_base.program_version > current_program_version
	 then
	    do;
	       code = error_table_$unimplemented_version;
	       call
		sub_err_ (code, "vfile_", "c", null, code,
		"Can't adjust operation in progress with this version of vfile_.");
	    end;
	 else
	    do;
	       call restart (iocb_ptr, code);
	       fs_ptr = indx_cb.file_state_ptr;
	    end;
      if (file_base.program_version < current_program_version_2) & indx_cb.stat & ^indx_cb.is_read_only & (code = 0)
      then
         do;
	  code = error_table_$unimplemented_version;
	  call
	     sub_err_ (code, "vfile_", "c", null, code, "Old version file does not support -stationary attach option.");
         end;
      foo = 0;					/* in case of cleanup */
      if code = 0
      then call set_entries_and_positions;
      else go to cleanup_exit;
      if is_read_only
      then return;
      if indx_cb.read_exclu
      then file_action = read_exclude;
      cleanup_flags = "100000"b;			/* just unlock the file */
      current_retry_loc = cleanup_retry;		/* initialize this variable */
      go to unlock_exit;

close_indx_file:
   entry (iocb_ptr);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      f_b_ptr = file_base_ptr;
      indx_cb.file_state_ptr = addr (file_state_blocks (file_state));
      fs_ptr = indx_cb.file_state_ptr;
      o_s_ptr = addr (file_state_blocks (1 - file_state));
      os_ptr = o_s_ptr;

      foo = 0;
      on seg_fault_error
         begin;
	  foo = error_table_$lock_wait_time_exceeded;
	  go to cleanup_exit;
         end;
      if indx_cb.shared & ^is_read_only & ^leave_locked
      then
         do;					/* prepare to set bit counts */
	  call set_lock (addr (file_base.lock_word), 0, foo);
	  if foo = error_table_$lock_wait_time_exceeded
	  then go to cleanup_exit;
	  if old_last_comp_num ^= last_comp_num		/* new component */
	  then
	     do;					/* recreate the seg_ptr_array */
	        call free_seg_ptrs (iocb_ptr);
	        call create_seg_ptrs (iocb_ptr);
	     end;
         end;
      if ^is_read_only
      then call set_bitcounts (iocb_ptr);
retry_loc (23):
cleanup_exit:
      revert seg_fault_error;
      call free_seg_ptrs (iocb_ptr);
      call free_position_stack (indx_cb_ptr);
      call discard_temp_file (indx_cb.temp_iocbp);	/* subset file
						   can be thrown away, if one exists */
      call discard_temp_file (indx_cb.reflp);		/* for transaction
						   control file only--throw away temporary reference list */
      lock_copy = indx_cb.saved_lock_copy;
      call free_cb_file (size (indx_cb), indx_cb_ptr);
      if substr ("0001000100100"b, atb.opening_mode, 1) | (foo = error_table_$locked_by_this_process)
         | (foo = error_table_$lock_wait_time_exceeded)
      then return;					/* don't unlock in this case */
      if file_action = read_exclude
      then file_action = 0;				/* clear read lock */
      if file_action = 0
      then
         do;
	  unspec (spare_node) = "0"b;			/* free unneeded storage */
	  if stacq (file_base.lock_word, "0"b, lock_copy) /* unlock */
	  then ;
         end;
      else if stacq (file_base.lock_word, (36)"1"b, lock_copy)
      then ;					/* make it look like I died */
      return;					/* end of close routine */

set_entries_and_positions:
   proc;
      close_x = close_indx_file;
      iocb_ptr -> iocb.control = control_indx_file;
      go to open_case (mode);
open_case (4):					/* sequential input */
      indx_cb.at_bof = "1"b;
      iocb_ptr -> iocb.read_record = read_indx_file;
      iocb_ptr -> iocb.read_length = read_length_indx_file;
      iocb_ptr -> iocb.position = position_indx_file;
      return;
open_case (7):					/* sequential update */
      indx_cb.at_bof = "1"b;
      iocb_ptr -> iocb.read_record = read_indx_file;
      iocb_ptr -> iocb.read_length = read_length_indx_file;
      iocb_ptr -> iocb.position = position_indx_file;
      iocb_ptr -> iocb.rewrite_record = rewrite_indx_file;
      iocb_ptr -> iocb.delete_record = delete_indx_file;
      return;
open_case (8):					/* keyed sequential input */
      indx_cb.at_bof = "1"b;
      iocb_ptr -> iocb.read_record = read_indx_file;
      iocb_ptr -> iocb.read_length = read_length_indx_file;
      iocb_ptr -> iocb.read_key = read_key_indx_file;
      iocb_ptr -> iocb.position = position_indx_file;
      iocb_ptr -> iocb.seek_key = seek_key_indx_file;
      return;
open_case (9):					/* keyed sequential output */
      indx_cb.at_eof = "1"b;
      iocb_ptr -> iocb.seek_key = seek_key_ks_out;
      iocb_ptr -> iocb.write_record = write_indx_file;
      return;
open_case (10):					/* keyed sequential update */
      indx_cb.at_bof = "1"b;
      iocb_ptr -> iocb.read_record = read_indx_file;
      iocb_ptr -> iocb.read_length = read_length_indx_file;
      iocb_ptr -> iocb.read_key = read_key_indx_file;
      iocb_ptr -> iocb.position = position_indx_file;
      iocb_ptr -> iocb.seek_key = seek_key_indx_file;
      iocb_ptr -> iocb.control = control_indx_file;
      iocb_ptr -> iocb.write_record = write_indx_file;
      iocb_ptr -> iocb.rewrite_record = rewrite_indx_file;
      iocb_ptr -> iocb.delete_record = delete_indx_file;
      return;
open_case (11):					/* direct input */
      iocb_ptr -> iocb.read_record = read_indx_file;
      iocb_ptr -> iocb.read_length = read_length_indx_file;
      iocb_ptr -> iocb.seek_key = seek_key_indx_file;
      return;
open_case (12):					/* direct output */
      iocb_ptr -> iocb.seek_key = seek_key_indx_file;
      iocb_ptr -> iocb.write_record = write_indx_file;
      return;
open_case (13):					/* direct update */
      iocb_ptr -> iocb.read_record = read_indx_file;
      iocb_ptr -> iocb.read_length = read_length_indx_file;
      iocb_ptr -> iocb.seek_key = seek_key_indx_file;
      iocb_ptr -> iocb.write_record = write_indx_file;
      iocb_ptr -> iocb.rewrite_record = rewrite_indx_file;
      iocb_ptr -> iocb.delete_record = delete_indx_file;
   end set_entries_and_positions;

create_indx_cb:
   proc;						/* creates open data structure */
      code = 0;
      call alloc_cb_file (size (indx_cb), iocb_ptr -> iocb.open_data_ptr);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      fcb_ptr = fcb_ptr_arg;
      file_base_ptr = first_seg_ptr;
      f_b_ptr = file_base_ptr;
      last_change_count = change_count;			/* must be saved before referencing file_state */
      mode = mode_arg;
      is_sequential_open = (mode < 11);
      is_read_only = substr ("0001000100100"b, mode, 1);
      is_ks_out = (mode = 9);
      indx_cb.next_record_position = 0;
      indx_cb.current_record_is_valid = "0"b;
      indx_cb.ready_to_write = "0"b;
      indx_cb.shared = atb.shared;
      indx_cb.wait_time = atb.wait_time;
      repeating = "0"b;
      file_state_ptr = addr (file_state_blocks (file_state));
      fs_ptr = file_state_ptr;
      o_s_ptr = addr (file_state_blocks (1 - file_state));
      indx_cb.error.type = 0;				/* used by "error_status" control order */
      indx_cb.at_bof = "0"b;				/* used in shared openings for asynch re-seeks */
      indx_cb.at_eof = "0"b;
      indx_cb.min_res = 0;				/* default is no spare space allocated with records */
      indx_cb.min_cap = 0;				/* default is not to allocate null recs */
      leave_locked = "0"b;				/* if shared, will leave unlocked between operations */
      indx_cb.outside_index = "0"b;			/* may be set by "record_status" */
      dup_ok = atb.dup_ok_sw | (duplicate_keys ^= 0);
      indx_cb.stat = atb.stat_sw;			/* -stat option used */
      indx_cb.read_exclu = atb.exclu_sw;		/* may be set by "set_file_lock" order */
      indx_cb.pos_incorrect = "1"b;			/* may be set by "add_key", etc. */
      indx_cb.saved_lock_copy = "0"b;			/* in case happens to contain a valid lock */
      call set_lock_$lock (indx_cb.saved_lock_copy, 0, foo);
      indx_cb.new_key = "";
      file_position_ptr = null;
      indx_cb.min_key_len = file_base.minimum_key_length;	/* non-zero for old files */
      indx_cb.skip_state = 0;				/* default is to scan forward over deletions */
      indx_cb.current_subset = 0;
      indx_cb.last_subset = 0;
      indx_cb.subset_selected = "00"b;
      indx_cb.temp_iocbp = null;
      indx_cb.trans = atb.trans_sw;			/* set if -transaction attachment */
      if indx_cb.trans
      then indx_cb.tcfp = atb.tcf_iocbp;		/* ptr to transaction control iocb */
      else indx_cb.tcfp = null;
      indx_cb.transaction_code = 0;
      indx_cb.reflp = null;				/* used in transaction control file only */
      indx_cb.collection_delay_time = 0;
   end create_indx_cb;
check_comp_array_table:
   proc;

/*  This  looks  through  the comp_table comp_links for any component which is
   greater  than  the  maximum  component in use, identified by last_comp_num.
   Should  such a bogus comp_link be found, sub_err_ is signaled and vfile_ is
   ground to an unrestartable stop.  */

      dcl	    table_idx	       fixed bin (35);
      do table_idx = lbound (comp_table, 1) to hbound (comp_table, 1);
         if comp_table.comp_link (table_idx) > file_base.last_comp_num
         then if is_read_only
	    then call
		  sub_err_ (error_table_$bad_file, "vfile_", "c", null, code,
		  "Previous modifications to this file may have resulted 
in lost data, due to incorrect information in the file_base 
of this file.  Type ""help damaged_keyed_files"" for more information.
  Processing will continue.");
	    else
	       do;
		if stacq (file_base.common_header.lock_word, "0"b, indx_cb.saved_lock_copy)
		then ;
		call
		   sub_err_ (error_table_$bad_file, "vfile_", "s", null, error_table_$bad_file,
		   "This file cannot safely be 
updated due to incorrect information in its 
file_base.  Type ""help damaged_keyed_files"" 
for more information.");
	       end;
      end;
   end;

discard_temp_file:
   proc (iocbp);					/* cleanup routine for subsets and ref lists */
      if iocbp = null
      then return;					/* nothing to discard */
      call iox_$close (iocbp, foo);
      unique_name =
         substr (iocbp -> iocb.attach_descrip_ptr -> based_vstring,
         length (iocbp -> iocb.attach_descrip_ptr -> based_vstring) + 1 - length (unique_name), length (unique_name));
						/* unique name of temp file from attach description */
      call hcs_$delentry_file (get_pdir_ (), unique_name, foo);
						/* delete temporary index */
      call iox_$detach_iocb (iocbp, foo);
      call iox_$destroy_iocb (iocbp, foo);
      iocbp = null;
      dcl	    iocbp		       ptr;
      dcl	    foo		       fixed (35);
   end discard_temp_file;

initialize_new_file:
   proc;						/* At this point all words except the common header are zero. This routine sets the nonzero values */
      program_version = current_program_version;
      max_seg_limit = component_size_arg;
      minimum_block_size = minimum_block_size_val;
      node_size = node_size_val;
      last_branch_num_root = 1;
      do foo = 0, 1;
         addr (index_state_blocks (foo)) -> new_key_pos = node_head_length + branch_and_descrip_length + 1;
      end;
      max_comp_num = true_max_comp_num;
      seg_limit (0) = node_size * (1 + divide (size (file_base) + node_size - 1, node_size, 17, 0));
      call hcs_$set_bc_seg (file_base_ptr, 36 * size (file_base), foo);
      file_version = current_file_version;		/* creation is thus atomic */
      return;
      dcl	    hcs_$set_bc_seg	       entry (ptr,		/* pointer to seg, input */
			       fixed bin (24),	/* bit count to be set */
			       fixed bin (35));	/* status code */
   end initialize_new_file;

check_file_substate:
   proc;						/* keeps track of logical block during recovery execution */
      next_substate = next_substate + 1;
      if file_substate = next_substate
      then repeating = "0"b;				/* execution resumes normally */
   end check_file_substate;

check_code:
   proc (er_code, message);				/* unusual abort detector */
      if er_code = 0
      then return;
      code = er_code;				/* give code back to caller after warning */
      call sub_err_ (code, "vfile_", "c", null, code, message);
      indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr;
      indx_cb.pos_incorrect = "1"b;
      if cleanup_flags = "000000"b
      then go to passive_abort;
      aborting = "1"b;
      go to unlock_exit;
      dcl	    er_code	       fixed (35);
      dcl	    message	       char (*);
   end check_code;

/* DECLARATIONS */
      dcl	    i_locked_rec_mask      static internal options (constant) bit (36) aligned
			       init ("010101000000000000000000000000000000"b);
      dcl	    i_locked_new_mask      static internal options (constant) bit (36) aligned
			       init ("001010100000000000000000000000000000"b);
      dcl	    rec_lock_mask	       static internal options (constant) bit (36) aligned
			       init ("011000000000000000000000000000000000"b);
      dcl	    negmod_mask	       static internal options (constant) bit (36) aligned
			       init ("000001100000000000000000000000000000"b);
      dcl	    passive_ref_bit_mask   static internal options (constant) bit (36) aligned
			       init ("000110000000000000000000000000000000"b);
      dcl	    old_passive_ref_mask   static internal options (constant) bit (36) aligned
			       init ("000100000000000000000000000000000000"b);
      dcl	    new_passive_ref_mask   static internal options (constant) bit (36) aligned
			       init ("000010000000000000000000000000000000"b);
      dcl	    seek_kso_retry	       static internal options (constant) init (1);
      dcl	    seek_retry	       static internal options (constant) init (2);
      dcl	    read_len_retry	       static internal options (constant) init (3);
      dcl	    read_key_retry	       static internal options (constant) init (4);
      dcl	    read_retry	       static internal options (constant) init (5);
      dcl	    skip_retry	       static internal options (constant) init (6);
      dcl	    pos_bof_or_eof_retry   static internal options (constant) init (7);
      dcl	    gk_retry	       static internal options (constant) init (8);
      dcl	    rs_retry_2	       static internal options (constant) init (9);
      dcl	    rs_retry_1	       static internal options (constant) init (10);
      dcl	    sh_retry	       static internal options (constant) init (11);
      dcl	    rew_retry	       static internal options (constant) init (12);
      dcl	    write_retry	       static internal options (constant) init (13);
      dcl	    del_retry	       static internal options (constant) init (14);
      dcl	    adj_retry	       static internal options (constant) init (15);
      dcl	    ak_retry	       static internal options (constant) init (16);
      dcl	    dk_retry	       static internal options (constant) init (17);
      dcl	    init_retry	       static internal options (constant) init (18);
      dcl	    inner_retry	       static internal options (constant) init (19);
      dcl	    outer_retry	       static internal options (constant) init (20);
      dcl	    rk_retry	       static internal options (constant) init (21);
      dcl	    reass_key_retry_2      static internal options (constant) init (22);
      dcl	    cleanup_retry	       static internal options (constant) init (23);
      dcl	    lock_file_retry	       static internal options (constant) init (24);
      dcl	    adj_file_retry	       static internal options (constant) init (25);
      dcl	    based_area	       area based;
      dcl	    system_freep	       ptr static internal init (null);
      dcl	    get_system_free_area_  entry returns (ptr);
      dcl	    delete_old_subsets     entry (ptr);
      dcl	    rec_deleted	       bit (1) aligned;
      dcl	    (stacq, string, clock, addrel, hbound,index,lbound,stac)
			       builtin;
      dcl	    len		       fixed;
      dcl	    1 saved_state	       like indx_cb.state_vars;
      dcl	    saved_state_block      char (length (current_state_block)) based (addr (saved_state));
      dcl	    saved_subset_selected  bit (2) aligned;
      dcl	    saved_current_subset   fixed (34);
      dcl	    1 saved_error_info     like indx_cb.error;
      dcl	    current_state_block    char (4 * size (fixed_state_block) + 4 + length (indx_cb.new_key))
			       based (addr (indx_cb.state_vars));
      dcl	    1 fixed_state_block    like indx_cb.fixed_state_part based;
      dcl	    os_ptr	       ptr;
      dcl	    branches_left	       fixed;
      dcl	    count		       fixed (34);
      dcl	    chunk_size	       fixed (34);
      dcl	    first_code	       fixed (35);
      dcl	    key_is_dup	       bit (1) aligned;
      dcl	    passive_op	       bit (1) aligned;
      dcl	    del_cur	       bit (1) aligned;
      dcl	    fault_ok	       bit (1) aligned;
      dcl	    (any_other, seg_fault_error)
			       condition;
      dcl	    cleanup	       condition;
      dcl	    current_retry_loc      fixed;
      dcl	    need_pos	       fixed static options (constant) internal init (5);
      dcl	    time_left	       fixed;
      dcl	    timeout	       fixed (71);
      dcl	    eternity	       static internal options (constant) fixed (71) init (1f70b);
      dcl	    new_change_count       fixed (35);
      dcl	    continue_to_signal_    entry (fixed (35));
      dcl	    branch_and_descrip_length
			       static options (constant) fixed init (12);
      dcl	    node_head_length       static options (constant) fixed init (16);
      dcl	    restart	       entry (ptr, fixed (35));
      dcl	    check_file_version     entry (ptr, fixed (35));
      dcl	    find_key	       entry (ptr, ptr, fixed (35));
      dcl	    find_key$last	       entry (ptr, ptr, fixed bin (35));
      dcl	    set_lock_$lock	       entry (bit (36) aligned, fixed, fixed (35));
      dcl	    set_lock_$unlock       entry (bit (36) aligned, fixed (35));
						/* Arguments */

      dcl	    buff_len	       fixed (21);
      dcl	    buff_ptr	       ptr;
      dcl	    close_x	       entry;
      dcl	    code		       fixed (35);
      dcl	    component_size_arg     fixed (19);
      dcl	    fcb_ptr_arg	       ptr;
      dcl	    first_seg_bitcount     fixed (24);
      dcl	    first_seg_ptr	       ptr;
      dcl	    iocb_ptr	       ptr;
      dcl	    is_new_file	       bit (1) aligned;
      dcl	    key		       char (256) varying;
      dcl	    mode_arg	       fixed;
      dcl	    pos_type	       fixed;
      dcl	    skip		       fixed;
      dcl	    rec_len	       fixed (21);

/* Local Variables */

      dcl	    1 current_des	       like designator_struct aligned based (addr (indx_cb.current_descrip));
      dcl	    record_action	       fixed;
      dcl	    record_len	       fixed (21);
      dcl	    record_ptr	       ptr;
      dcl	    foo		       fixed (35);
      dcl	    pos_ptr	       ptr;
      dcl	    buffer	       char (record_len) based (buff_ptr);
      dcl	    block_ptr	       ptr;
      dcl	    1 block_with_lock      based (block_ptr),
	      2 words	       (record_block.block_size - 1) fixed,
						/* body of block */
	      2 record_lock	       bit (36) aligned;	/* set/cleared by "record_status" order */
      dcl	    1 temp_ts_words	       aligned,
	      2 ind_offset	       bit (18) unal,
	      2 time_last_modified bit (54) unal;
      dcl	    1 new_rec_des	       based (addr (file_base.new_descriptor)),
	      2 comp	       fixed (17) unal,
	      2 offset	       bit (18) unal;
      dcl	    lock_ptr	       ptr;
      dcl	    based_vstring	       char (1000000) var based;
      dcl	    bstring	       char (1000000) based;
      dcl	    based_lock	       bit (36) aligned based;

      dcl	    1 ak_inf	       based (info_ptr),
	      2 header	       like ak_header,
	      2 key	       char (ak_inf.key_len);
      dcl	    1 rk_inf	       based (info_ptr),
	      2 header	       like rk_header,
	      2 key	       char (rk_inf.key_len);
      dcl	    1 gk_inf	       based (info_ptr),
	      2 header	       like gk_header,
	      2 key	       char (gk_inf.key_len);
      dcl	    ak_info_key	       char (256) var based (addr (ak_inf.key_len));
      dcl	    key_to_reassign	       char (256) var based (addr (rk_inf.key_len));
						/* File Parameter Values */
      dcl	    current_file_version   static options (constant) fixed init (40);
      dcl	    current_program_version
			       static options (constant) fixed init (41);
      dcl	    current_program_version_1
			       static options (constant) fixed init (32);
      dcl	    current_program_version_2
			       static options (constant) fixed init (33);
      dcl	    node_size_val	       static options (constant) fixed init (1024);
      dcl	    minimum_block_size_val static options (constant) fixed init (8);
      dcl	    msf_manager_$get_ptr   entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35));
      dcl	    1 record_block	       like record_block_structure based (block_ptr);
      dcl	    1 stat_struct	       like stat_structure based (block_ptr);
      dcl	    1 ind_struct	       like ind_structure based (block_ptr);
      dcl	    1 time_stamp_struct    like time_stamp_structure based (addr (stat_struct.time_stamp_words));
      dcl	    1 ind_des	       like ind_des_structure based (addr (ind_desc));

      dcl	    hcs_$delentry_file     entry (char (*), char (*), fixed (35));
      dcl	    hcs_$get_uid_seg       entry (ptr, bit (36) aligned, fixed (35));
      dcl	    unique_name	       char (27);
      dcl	    get_pdir_	       entry returns (char (168));
      dcl	    lock_copy	       bit (36) aligned;
      dcl	    ind_desc	       fixed (35);
      dcl	    cur_mod	       fixed (35);
      dcl	    transaction_call_$assign
			       entry (ptr, fixed (35), fixed (35));
      dcl	    transaction_call_$setup_ref_list
			       entry (ptr, fixed (35));
      dcl	    descrip_arg	       fixed (35);
      dcl	    rollback_sw	       bit (1) aligned;
      dcl	    p		       ptr;
      dcl	    modifier_arg	       fixed (35);
      dcl	    time_stamp	       fixed (71) aligned;
      dcl	    mod		       fixed (35);
      dcl	    cleanup_flags	       bit (36) aligned;
      dcl	    1 cleanup_flag_struct  based (addr (cleanup_flags)),
	      2 i_locked_file      bit (1) unal,
	      2 i_locked_rec       bit (1) unal,
	      2 i_locked_new       bit (1) unal,
	      2 old_passive_ref    bit (1) unal,
	      2 new_passive_ref    bit (1) unal,
	      2 i_set_negmod       bit (1) unal,
	      2 i_set_new_negmod   bit (1) unal,
	      2 aborting	       bit (1) unal,
	      2 pad	       bit (28) unal;
      dcl	    order		       char (*);
      dcl	    (
	    vfile_io_control,
	    vfile_io_control$af
	    )		       entry (ptr, ptr, ptr, fixed (35));
      dcl	    vfile_status_$seg      entry (ptr, ptr, ptr, fixed (35));
      dcl	    (info_ptr, info_ptr_arg)
			       ptr;
      dcl	    blanks	       char (256) aligned static internal options (constant) init ("");
      dcl	    1 gk_pad_key,
	      2 len	       fixed,
	      2 string	       char (256);
      dcl	    1 pad_key_info	       based (pad_key_ptr),
	      2 pad_key_len	       fixed,
	      2 pad_key	       char (256);
      dcl	    pad_key_ptr	       ptr;
      dcl	    1 info	       based (info_ptr),
	      2 rel_type	       fixed,
	      2 n		       fixed,
	      2 search_key	       char (0 refer (n));

      dcl	    1 mbs_info	       based (info_ptr),
	      2 min_residue	       fixed (21),		/* min unused capacity in bytes */
	      2 min_capacity       fixed (21);		/* minimum bytes which will be allocated */

      dcl	    1 error_info	       based (info_ptr),
	      2 version	       fixed bin (35),	/* must =1 (Input) */
	      2 type	       fixed bin (35),	/* identifies type of error--only one currently exists */
	      2 requested	       fixed bin (35),	/* skip arg passed to vfile_ for positioning */
	      2 received	       fixed bin (35);	/* skips completed successfully */
      dcl	    skip_error	       fixed static options (constant) internal init (1);
      dcl	    1 set_lock_info	       based (info_ptr) aligned,
	      2 set_lock_flag      bit (1) unal,	/* "1"b means lock, "0"b means unlock */
	      2 exclusive	       bit (1) unal;	/* "1"b means lock out readers too */
      dcl	    new_wait_time	       float based (info_ptr);
      dcl	    1 wt_info	       based (info_ptr),
	      2 version	       float,		/* -2 indicates collection delay, not new_wait_time */
	      2 collection_delay_time
			       float;
      dcl	    max_rec_wds	       fixed (19);
      dcl	    ref_cnt	       fixed;
      dcl	    delta_ref_count	       fixed;
      dcl	    new_block_ptr	       ptr;
      dcl	    new_lock_ptr	       ptr;
      dcl	    transaction	       defined indx_cb_ptr -> indx_cb.trans bit (1) aligned;
      dcl	    passive	       bit (1) aligned;
      dcl	    max_ref_count	       static internal options (constant) init (65535);
						/* 2**16 -1 */
      dcl	    sub_err_	       entry options (variable);
      dcl	    current_descrip	       fixed (35) defined indx_cb.current_descrip;
      dcl	    old_ref_cnt	       fixed;
      dcl	    new_des	       fixed (35);
      dcl	    old_des	       fixed (35);
      dcl	    pos_unchanged	       bit (1) aligned;
      dcl	    next_subset	       fixed (34);
      dcl	    i		       fixed;
      dcl	    last_head	       char (256) var;
      dcl	    last_head_len	       fixed based (addr (last_head));
      dcl	    temp_key_words	       (1:2) fixed bin (35) based (addr (temp_key));
      dcl	    vpad_key	       char (256) var based (addr (pad_key_info));
      dcl	    1 temp_ak_inf,
	      2 flags	       bit (36) aligned,
	      2 descriptor	       fixed (35),
	      2 key_len	       fixed,
	      2 temp_key	       char (8);
      dcl	    flag		       bit (1) aligned;
      dcl	    head_spec	       bit (1) aligned;
      dcl	    open_ended	       bit (1) aligned;
      dcl	    max_list_type	       static fixed options (constant) init (2) internal;
      dcl	    n_int		       fixed;
      dcl	    last_info_ptr	       ptr;
      dcl	    1 last_info_block      (0:1),
	      2 new_ptr	       ptr,
	      2 des	       fixed (35),
	      2 lkey	       char (256) var;
      dcl	    1 last_info	       based (last_info_ptr),
	      2 new_last_info_ptr  ptr,
	      2 last_descrip       fixed (35),
	      2 last_key	       char (256) var;
      dcl	    1 new_last_info	       based (last_info.new_last_info_ptr),
	      2 new_last_info_ptr  ptr,
	      2 new_last_descrip   fixed (35),
	      2 new_last_key       char (256) var;
      dcl	    select_flag	       static internal bit (1) aligned init ("0"b) options (constant);
      dcl	    exclude_flag	       static internal bit (1) aligned init ("1"b) options (constant);
      dcl	    timer_manager_$sleep   entry (fixed (71), bit (2));
      dcl	    min_max_rec_len	       static options (constant) internal fixed (21) init (24);
%page;
%include vf_attach_block;
%page;
%include iox_entries;
%page;
%include rs_info;
%page;
%include ak_info;
%page;
%include select_info;
%page;
%include vfile_error_codes;
%page;
%include vfile_indx;
%page;
%include iocb;
   end /* end open_indx_file */;




		    open_seq_file.pl1               11/04/82  1940.0rew 11/04/82  1620.8      350262



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


/* Modified 8/8/74 to correct bug. Declared header size increased by four words
   to retroactively justify declaration of first_record_pos as having vale 61.
   New file version number is 1.1. Only difference is that initial_descriptor
   now is (correctly) immediately before the first records descriptor. Version 1.0 files are ok except for
   backspacing past beginning of segment, which was the bug */

open_seq_file:
     proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_component_size, code);
	call validate_initialize_file;
	if code = 0
	then do;					/* initialize cb, set iocb items */
		call create_initialize_cb;
		if first_seg_ptr -> header.version < current_version
		then if mode > 4			/* OK to update file version */
		     then if (first_seg_ptr -> header.version = 12)
			     & ^iocb_ptr -> iocb.attach_data_ptr -> atb.inv_lock_reset
			then call adjust_file_v12;	/* needs end_desc */
			else do;			/* needs both end_pos and end_desc */
				call adjust_file;	/* sets end_pos */
				if code = 0
				then first_seg_ptr -> header.version = current_version;
						/* makes change */
			     end;
		     else end_not_valid =
			     (iocb_ptr -> iocb.attach_data_ptr -> atb.inv_lock_reset
			     | first_seg_ptr -> header.version ^= 12);
		else do;				/* new version file */
			end_not_valid = "0"b;	/* end_pos is valid */
			if first_seg_ptr -> header.file_action ^= 0
						/* not consistent */
			then if first_seg_ptr -> header.file_action = must_rollback
			     then if mode > 4
				then do;
					call save_position;
					call rollback;
					call restore_position;
				     end;
				else ;
			     else if first_seg_ptr -> header.file_action = must_adjust
			     then if mode > 4
				then call adjust_file;
						/* skips forward */
				else seq_cb.end_not_valid = "1"b;
			     else code = error_table_$bad_file;
		     end;
		if code = 0
		then do;
			call set_entries_and_positions;
			if mode > 4		/* opening for modification */
			then if seq_cb.checkpoint
			     then first_seg_ptr -> header.file_action = must_rollback;
			     else first_seg_ptr -> header.file_action = must_adjust;
		     end;
		else call free_cb_file (size (seq_cb), open_data_ptr);
	     end;
	return;					/* end of opening routine */

control_seq_file:
     entry (iocb_ptr, order, info_ptr, code);
	code = 0;

	if order = "read_position"
	then do;
		if end_not_valid			/* old version file -- must compute positions */
		then call get_positions;
		info.end_position = seq_cb.end_pos;
		info.next_position = next_pos;
		return;
	     end;

	if order = "record_status"
	then do;
		rs_info_ptr = info_ptr;
		if (rs_info.version < rs_info_version_1) | (rs_info.version > rs_info_version_2)
		then code = error_table_$unimplemented_version;
		else if substr (string (rs_info.flags), 1, 6) ^= "0"b
		then code = error_table_$bad_arg;	/* flags not supported for seq files */
		else do;
			if rs_info.locate_pos_sw
			then if (rs_info.descriptor = 0) | (rs_info.record_length < 0)
				| (^seq_cb.end_not_valid & (rs_info.record_length > seq_cb.end_pos))
			     then do;
				     code = error_table_$bad_arg;
				     return;	/* abort */
				end;
			     else if seq_cb.opening_mode = 5
						/* output */
			     then do;
				     code = error_table_$no_operation;
				     return;
				end;
			     else do;		/* set position as indicated */
				     if seq_cb.write_pos ^= beyond_limits
						/* in write state */
				     then call switch_to_read_state;
				     call set_position (rs_info.descriptor);
				     seq_cb.next_is_current = "1"b;
				     seq_cb.next_pos = rs_info.record_length;
				     seq_cb.current_record_ptr = null;
				end;
			call check_current;		/* current record position required */
			if code = 0
			then do;			/* fill in info structure */
				dbytes = current_record_ptr -> descrip;
				rs_info.record_length = d;
				rs_info.record_ptr = addr (current_record_ptr -> record);
						/* get pointer to record contents */
				packed_curp = current_record_ptr;
						/* get into packed format */
				unspec (rs_info.descriptor) = unspec (packed_curp);
				seq_desc.comp_num = component;
				rs_info.max_rec_len = d;
			     end;
		     end;
		return;				/* finished with record_status control order */
	     end;

	if (order = "checkpoint") & seq_cb.checkpoint & ^seq_cb.input_only
	then do;					/* make note of present end of file position */
		call checkpoint;
		return;				/* end of file position now saved in file header */
	     end;					/* end of checkpoint order */

	if (order = "truncate") & ^input_only
	then do;					/* truncate unless already at eof */
		if read_pos ^= minus_one_pos		/* not in write state */
		then if seq_cb.checkpoint & (seq_cb.next_pos < seq_cb.header_end_pos /* below checkpoint */)
		     then do;			/* purely logical truncation */
			     pos = seq_cb.read_pos;
			     call set_end_desc;	/* note new eof location */
			     seq_cb.end_pos = seq_cb.next_pos;
			end;			/* logically current eof precedes rollback eof */
		     else do;
			     call truncate_file;
			     return;
			end;
		seq_cb.current_record_ptr = null;
		seq_cb.next_is_current = "1"b;
		return;
	     end;

	if (order = "rollback") & ^input_only & seq_cb.checkpoint
	then do;
		call rollback;
		return;
	     end;

	else if order = "error_status"
	then do;
		if error_info.version ^= 1
		then code = error_table_$bad_arg;
		else do;
			error_info.type = error.type;
			error_info.requested = error.requested;
			error_info.received = error.received;
		     end;
		return;
	     end;

	else if order = "file_status"
	then do;
		call vfile_status_$seg (iocb_ptr, file_base_ptr, info_ptr, code);
		return;
	     end;

	else if order = "io_call"
	then call vfile_io_control (iocb_ptr, file_base_ptr, info_ptr, code);
	else code = error_table_$no_operation;
	return;					/* end of control routine */

read_length_seq_file:
     entry (iocb_ptr, rec_len, code);
	call find_next_record;
	if code = 0
	then do;					/* record found */
		rec_len = d;
		current_record_ptr = addr (descrip);	/* becomes current record */
		next_is_current = "1"b;		/* unstaggerred */
	     end;
	return;					/* end of read length routine */

read_seq_file:
     entry (iocb_ptr, buff_ptr, buff_len, rec_len, code);
	call find_next_record;
	if code = 0
	then do;
		rec_len = d;
		if d > buff_len
		then do;
			code = error_table_$long_record;
			d = buff_len;
		     end;
		if d > 0
		then buffer = record;
		current_record_ptr = addr (descrip);
		next_pos = next_pos + 1;
		next_is_current = "0"b;		/* staggerred */
		read_pos = read_pos + 8 + rec_len;
	     end;
	return;					/* end read routine */

position_seq_file:
     entry (iocb_ptr, pos_type, skip, code);
	code = 0;
	pos = read_pos;
	dbytes = descrip;
	if pos_type = 0
	then call position_skip;
	else if pos_type = 1
	then do;					/* position to eof */
		if d ^= -1			/* not already at eof, therefore in read state */
		then if seq_cb.write_pos = beyond_limits/* else must be checkpoint truncation case */
		     then call position_eof;
		read_pos = pos;
	     end;
	else if pos_type = -1
	then do;					/* position to beginning */
		call position_bof;
		code = er_code;
	     end;
	else code = error_table_$bad_arg;
	return;					/* end position routine */

write_seq_file:
     entry (iocb_ptr, buff_ptr, buff_len, code);
	if buff_len < 0
	then do;
		code = error_table_$negative_nelem;
		return;
	     end;
write:
	pos = write_pos;
	write_pos = write_pos + 8 + buff_len;
	if write_pos > write_limit
	then call write_exception;
	else do;
		code = 0;
		d = buff_len;
		addr (seg (write_pos)) -> descrip = minus_one_descrip;
		trailer_descrip = dbytes;
		record = buffer;
		descrip = dbytes;
		next_is_current = "0"b;		/* positions staggerred after write */
		current_record_ptr = addr (descrip);
		seq_cb.end_pos = seq_cb.end_pos + 1;
		next_pos = seq_cb.end_pos;
	     end;
	return;					/* end write routine */

rewrite_seq_file:
     entry (iocb_ptr, buff_ptr, buff_len, code);
	call check_current;				/* sets code */
	if buff_len < 0
	then code = error_table_$negative_nelem;
	if code = 0				/* current record is defined */
	then if seq_cb.checkpoint
	     then do;
		     if seq_cb.next_is_current
		     then cur_pos = seq_cb.next_pos;
		     else cur_pos = seq_cb.next_pos - 1;
		     if cur_pos < seq_cb.header_end_pos
		     then code = error_table_$no_operation;
		     else call replace_record;
		end;
	     else call replace_record;
	return;					/* end rewrite routine */

delete_seq_file:
     entry (iocb_ptr, code);
	call check_current;
	if code = 0				/* current record is defined */
	then if seq_cb.checkpoint			/* may be a purely logical deletion or disallowed */
	     then do;
		     if seq_cb.next_is_current
		     then cur_pos = seq_cb.next_pos;
		     else cur_pos = seq_cb.next_pos - 1;
		     if cur_pos < seq_cb.header_end_pos
		     then if cur_pos < seq_cb.end_pos - 1
						/* not supported */
			then code = error_table_$no_operation;
			else if cur_pos = seq_cb.end_pos - 1
						/* new low pos */
			then do;			/* adjust low end */
				last_desc_ptr = current_record_ptr;
				last_desc.compno = seq_cb.component;
				go to set_positions;/* don't actually delete now */
			     end;
		end;
	if code = 0
	then do;
		dbytes = current_record_ptr -> descrip;
		d = -(deleted_size_bias + d);
		current_record_ptr -> descrip = dbytes;
set_positions:
		current_record_ptr = null;
		seq_cb.end_pos = seq_cb.end_pos - 1;	/* decrement count of records in file */
		if ^next_is_current			/* next position moves back */
		then do;
			next_pos = next_pos - 1;	/* predecessor is deleted */
			next_is_current = "1"b;	/* current becomes next */
		     end;
	     end;
	return;					/* end delete routine */

close_seq_file:
     entry (iocb_ptr);
	pos = write_pos;
	if pos ^= beyond_limits
	then call switch_to_read_state;
	if ^seq_cb.input_only
	then if (unspec (seq_cb.header_end_info) = unspec (seq_cb.checkpoint_data))
	     then file_base_ptr -> header.file_action = 0;
	     else if ^seq_cb.checkpoint
	     then do;
		     file_base_ptr -> header.checkpoint_data = seq_cb.checkpoint_data;
		     file_base_ptr -> header.file_action = 0;
		end;
	call free_cb_file (size (seq_cb), open_data_ptr);
	return;					/* end close routine */

find_next_record:
     proc;
						/* If read pos designates a record, this procedure sets
						   pos and d and returns with code = 0.  If read_pos
						   designates eof, it sets current_record_ptr and code
						   accordingly and returns.  In other cases it advances read_pos
						   to the first undeleted record or eof, setting pos, d,
						   and code accordingly. */

	code = 0;
	do while ("1"b);				/* may cross msf component boundaries */
	     pos = read_pos;
	     dbytes = descrip;
	     if seq_cb.next_pos >= seq_cb.end_pos
	     then d = -1;				/* as if eof marker encountered */
	     if d >= 0
	     then return;
	     do while (d < -2);			/* skip deleted record */
		pos = pos + 8 - d - deleted_size_bias;
		dbytes = descrip;
	     end;
	     read_pos = pos;
	     if d = -1				/* end of file, applies in read or write state */
	     then do;
		     if seq_cb.end_not_valid
		     then do;			/* note that we have found eof */
			     seq_cb.end_pos = seq_cb.next_pos;
			     call set_end_desc;
			end;
		     code = error_table_$end_of_info;
		end;
	     else if d = -2
	     then call next_seg_read;
	     if code ^= 0
	     then do;
		     current_record_ptr = null;	/* current position is undefined */
		     return;
		end;
	end;
     end;						/* end find_next_record */

position_skip:
     proc;
	next_is_current = "1"b;			/* positions always the same after a skip */
	if skip > 0
	then do;					/* forward skip */
		count = skip;
		do while (count > 0);
		     seq_cb.current_record_ptr = null;
		     call find_next_record;
		     if code = 0
		     then do;
			     read_pos = read_pos + 8 + d;
			     next_pos = next_pos + 1; /* bump next record position */
			     count = count - 1;
			end;
		     else count = -count;
		end;
		if code ^= 0
		then do;
			error.type = skip_error;	/* for "error_status" control order */
			error.requested = skip;
			error.received = skip + count;
		     end;
	     end;
	else if skip < 0
	then do;					/* backwards skip */
		if write_pos ^= beyond_limits
		then call switch_to_read_state;
		count = -skip;
		call backspace;
		read_pos = pos;
		current_record_ptr = addr (descrip);
		if code ^= 0			/* attempt to pass end of info */
		then do;				/* save error info */
			error.type = skip_error;
			error.requested = skip;
			error.received = skip - count;
		     end;
	     end;
	else do;					/* don't move next position, just set current */
		call find_next_record;
		if code = 0			/* record found */
		then current_record_ptr = addr (descrip);
		else code = 0;			/* not error if at end of file */
	     end;

backspace:
     proc;
						/* This position backspaces over count records
						   setting pos.  If there are less than count records
						   code is set to end_of_info. */

	do while (count > 0);
	     pos = pos - 4;				/* locate trailer descrip, prev record */
	     dbytes = descrip;
	     if d >= 0				/* not beginning of segment */
	     then do;
		     pos = pos - 4 - d;		/* descrip for record */
		     dbytes = descrip;
		     if d >= 0			/* not deleted record */
		     then do;			/* decrement count and next_pos */
			     count = count - 1;
			     next_pos = next_pos - 1;
			end;
		end;
	     else if component = 0			/* beginning of file */
	     then do;
		     code = error_table_$end_of_info;
		     pos = pos + 4;			/* reset to record descrip */
		     dbytes = descrip;
		     count = -count;
		end;
	     else do;				/* get preceding segment */
		     next_comp = component - 1;
		     call msf_manager_$get_ptr (fcb_ptr, next_comp, "0"b, next_seg_ptr, foo24, foo);
		     if next_seg_ptr = null
		     then do;
			     code = error_table_$bad_file;
			     pos = pos + 4;		/* reset to record descrip */
			     dbytes = descrip;
			     count = 0;
			end;
		     else do;
			     pos = end_prev_seg;
			     component = next_comp;
			     seg_ptr = next_seg_ptr;
			     dbytes = descrip;
						/* Note count is not decremented.  All
						   that has happened is to position to the
						   final descriptor of the preceding segment.
						   A record must still be backspaced over. */
			end;
		end;
	end;
     end;						/* end backspace */

	dcl     count		 fixed bin;
     end;						/* end position_skip */

check_current:
     proc;					/* routines sets code to indicate whether current rec found */
	if current_record_ptr = null			/* may be valid if current is next */
	then do;					/* set current to next */
		call find_next_record;		/* sets code */
		if code = 0			/* record found */
		then current_record_ptr = addr (descrip);
		else code = error_table_$no_record;
	     end;
	else code = 0;				/* current defined since non-null */
     end check_current;

position_eof:
     proc;					/* called in read state */
	if seq_cb.end_not_valid			/* must scan to find true eof */
	then call set_end_pos;
	current_record_ptr = null;
	seq_cb.next_is_current = "1"b;
	next_pos = seq_cb.end_pos;
	if seq_cb.end_desc = 0			/* must be an old version file */
	then do;					/* handle first positioning to eof as special case */
		call find_eof_v12;			/* will set end_desc */
		return;
	     end;
	call set_position (seq_cb.end_desc);
	pos = seq_cb.read_pos;
     end position_eof;

set_position:
     proc (descriptor);				/* sets position to location specified by descriptor */
	seq_cb.read_pos = 4 * fixed (ds.wordno) + divide (fixed (ds.bitno, 6, 0), 9, 17, 0) + 1;
						/* byte offset of descriptor */
	if seq_cb.component ^= ds.compno
	then do;					/* get another component */
		seq_cb.component = ds.compno;
		call msf_manager_$get_ptr (fcb_ptr, seq_cb.component, "0"b, seq_cb.seg_ptr, foo24, foo);
	     end;
	dcl     descriptor		 fixed (35);
	dcl     1 ds		 based (addr (descriptor)),
		2 bitno		 fixed (5) unal,
		2 compno		 fixed (11) unal,
		2 wordno		 bit (18) unal;
     end set_position;

position_bof:
     proc;					/* sets position to beginning of file */
	er_code = 0;
	if component ^= 0
	then call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, next_seg_ptr, foo24, foo);
	else next_seg_ptr = seg_ptr;
	if next_seg_ptr = null
	then er_code = error_table_$bad_file;
	else do;
		if write_pos ^= beyond_limits
		then call switch_to_read_state;
		seg_ptr = next_seg_ptr;
		component = 0;
		read_pos = first_record_pos;
		next_is_current = "1"b;
		next_pos = 0;			/* beginning of file */
		pos = read_pos;			/* offset of first descriptor */
		current_record_ptr = addr (descrip);
	     end;
     end position_bof;

replace_record:
     proc;					/* tries to insert new rec at current position */
	dbytes = current_record_ptr -> descrip;
	if buff_len = d
	then do;
		code = 0;
		if d ^= 0
		then current_record_ptr -> record = buffer;
		if next_is_current			/* positions not staggerred */
		then do;				/* advance next record position */
			next_pos = next_pos + 1;
			next_is_current = "0"b;
			read_pos = read_pos + 8 + buff_len;
						/* skip over the current record */
		     end;
	     end;
	else if buff_len < d
	then code = error_table_$short_record;
	else code = error_table_$long_record;
     end replace_record;

checkpoint:
     proc;					/* saves eof position in checkpoint data in file header */
	if seq_cb.write_pos ^= beyond_limits		/* write state */
	then do;					/* note eof position */
		pos = seq_cb.write_pos;
		call set_seg_end;
	     end;					/* this already done if in read state */
	file_base_ptr -> header.checkpoint_data = seq_cb.checkpoint_data;
						/* atomically
						   changes eof setting */
	if seq_cb.header_end_pos >= seq_cb.end_pos	/* dispose of tail garbage */
	then do;
		call save_position;			/* must be able to leave user's pos unchanged */
		call position_eof;			/* locate last descriptor */
		call truncate_file;			/* zero tail contents */
		call restore_position;		/* like when we started */
	     end;
	seq_cb.header_end_info = seq_cb.checkpoint_data;	/* if file is closed now
						   the file_action can be cleared, since trunc is done and
						   header end info is correct checkpoint value */
     end checkpoint;

save_position:
     proc;					/* keeps track of file positions so they can be reset */
	saved_seg_ptr = seg_ptr;
	saved_comp = component;
	saved_write_pos = write_pos;
	saved_read_pos = read_pos;
	saved_curr_ptr = current_record_ptr;
	saved_next_curr = next_is_current;
	saved_next_pos = seq_cb.next_pos;
     end save_position;

restore_position:
     proc;
	seg_ptr = saved_seg_ptr;
	component = saved_comp;
	write_pos = saved_write_pos;
	read_pos = saved_read_pos;
	current_record_ptr = saved_curr_ptr;
	next_is_current = saved_next_curr;
	seq_cb.next_pos = saved_next_pos;
     end restore_position;

switch_to_read_state:
     proc;
	pos = seq_cb.write_pos;
	if seq_cb.checkpoint
	then if seq_cb.end_pos <= seq_cb.header_end_pos	/* don't alter file yet */
	     then call set_end_desc;			/* note eof location */
	     else call set_seg_end;			/* mark the file as well */
	else call set_seg_end;			/* change is immediate */
	seq_cb.write_pos = beyond_limits;		/* read state */
     end switch_to_read_state;

set_seg_end:
     proc;
						/* This procedure sets the current segment's bit count and the
						   end_seg field in the header.  It expects pos to be at the final
						   descriptor. */

	end_seg = pos;
	call hcs_$set_bc_seg (seg_ptr, 9 * (pos + 3), foo);

set_end_desc:
     entry;					/* notes eof location */
	last_desc_ptr = addr (descrip);		/* get packed ptr */
	last_desc.compno = seq_cb.component;
     end set_seg_end;

write_exception:
     proc;
	if pos = beyond_limits			/* read state */
	then do;
		if append_sw
		then if seq_cb.checkpoint		/* may not append if already has truncated */
		     then if seq_cb.end_pos < seq_cb.header_end_pos
			then go to no_op;		/* not supported at this time */
			else call position_eof;
		     else call position_eof;
		else if updating
		then do;				/* replace or insert next record */
			if seq_cb.checkpoint
			then if seq_cb.next_pos < seq_cb.header_end_pos
			     then do;		/* dissallow this case, because it can't be rolled back */
no_op:
				     seq_cb.write_pos = pos;
						/* initial state */
				     code = error_table_$no_operation;
				     return;	/* abort */
				end;
			call find_next_record;
			if code = 0		/* not at end of file */
			then do;			/* replace */
				write_pos = beyond_limits;
						/* leave file in read state */
				current_record_ptr = addr (descrip);
				next_is_current = "1"b;
						/* will be changed by replacement */
				call replace_record;/* lengths must match */
				return;
			     end;
		     end;
		else if seq_cb.checkpoint & (seq_cb.next_pos < seq_cb.header_end_pos)
		then go to no_op;
		else do;
			call truncate_file;
			go to write;
		     end;
		pos = seq_cb.read_pos;
		seq_cb.read_pos = minus_one_pos;	/* switch to write state */
		seq_cb.write_pos = pos;
		go to write;			/* appends to eof */
	     end;
	else if buff_len > max_record_size
	then do;
		write_pos = pos;
		code = error_table_$long_record;
	     end;
	else do;					/* end of segment case */
		write_pos = pos;
		if ssf_sw				/* no msf's allowed */
		then do;				/* flag the error */
			code = error_table_$file_is_full;
			call set_seg_end;
			return;
		     end;
		next_comp = component + 1;
		if ^is_msf			/* first open msf */
		then do;
			call msf_manager_$open (substr (attach_descrip_string, 8, dname_len),
			     substr (attach_descrip_string, 9 + dname_len, ename_len), fcb_ptr, code);
			is_msf = "1"b;
			atb.fcbp = fcb_ptr;
		     end;
		call msf_manager_$get_ptr (fcb_ptr, next_comp, "1"b, next_seg_ptr, foo24, code);
		if next_seg_ptr ^= null
		then do;
			prev_seg_ptr = seg_ptr;	/* save ptr to base of seg */
			code = 0;
			call set_seg_end;
			seg_ptr = next_seg_ptr;
			component = next_comp;
			header.version = 1;
			end_prev_seg = pos;
			minus_one = -1;
			addr (seg (header_size + 1)) -> descrip = minus_one_descrip;
						/* sets initial descriptor */
			pos = first_record_pos;
			call set_seg_end;
			write_pos = first_record_pos;
			descrip = minus_one_descrip;	/* first record descrip */
			d = -2;
			addr (prev_seg_ptr -> seg (end_prev_seg)) -> descrip = dbytes;
			go to write;		/* add record to end of file */
		     end;
	     end;
	dcl     prev_seg_ptr	 ptr;
     end;						/* end write exception */

next_seg_read:
     proc;					/* called in read state when another seg exists */
	next_comp = component + 1;
	call msf_manager_$get_ptr (fcb_ptr, next_comp, "0"b, next_seg_ptr, foo24, foo);
	if next_seg_ptr = null
	then code = error_table_$bad_file;
	else do;
		component = next_comp;
		seg_ptr = next_seg_ptr;
		read_pos = first_record_pos;
	     end;
     end;						/* end next_seg_read */

truncate_file:
     proc;					/* sets end of file to next record position */
	pos = read_pos;
	read_pos = minus_one_pos;			/* first change to write state */
	write_pos = pos;
	seq_cb.current_record_ptr = null;
	seq_cb.next_is_current = "1"b;
	descrip = minus_one_descrip;
	call set_seg_end;
	seq_cb.end_pos = next_pos;
	if ^is_msf				/* single segment */
	then call hcs_$truncate_seg (seg_ptr, divide (pos + 6, 4, 18, 0), foo);
	else call msf_manager_$adjust (fcb_ptr, component, 9 * (pos + 3), "010"b, foo);
						/* truncate file */
     end truncate_file;

create_initialize_cb:
     proc;
	call alloc_cb_file (size (seq_cb), open_data_ptr);
	fcb_ptr = fcb_ptr_arg;
	seg_ptr = first_seg_ptr;
	component = 0;
	write_limit = 4 * max_component_size - 3;
	max_record_size = 4 * max_component_size - header_size - 12;
	beyond_limits = write_limit + 4;
	write_pos = beyond_limits;			/* initialize to read state */
	read_pos = first_record_pos;
	next_is_current = "1"b;			/* positions initially not staggerred */
	pos = read_pos;
	current_record_ptr = null;
	next_pos = 0;
	file_base_ptr = seg_ptr;
	seq_cb.checkpoint_data, seq_cb.header_end_info = file_base_ptr -> header.checkpoint_data;
	append_sw = (iocb_ptr -> iocb.attach_data_ptr -> atb.appending) & (mode = 6 /* input_output */);
	updating = (mode = 7 /* sequential_update */);
	input_only = (mode = 4);
	seq_cb.opening_mode = mode;
	is_msf = atb.msf;				/* set if file is already an msf */
	ssf_sw = atb.ssf;				/* -ssf option indicates no msf's allowed */
	minus_one_word = -1;
	seq_cb.checkpoint = atb.checkpoint_sw;
     end;						/* end create_initialize_cb */

set_entries_and_positions:
     proc;					/* sets iocb entries for valid operations
						   and positions to end of file in some output modes */
	close_x = close_seq_file;
	control = control_seq_file;			/* supported in all modes */

	if mode = 4				/* input */
	then do;
		read_record = read_seq_file;
		read_length = read_length_seq_file;
		position = position_seq_file;
	     end;

	else if mode = 5				/* output */
	then write_record = write_seq_file;

	else if mode = 6				/* input_output */
	then do;
		read_record = read_seq_file;
		read_length = read_length_seq_file;
		position = position_seq_file;
		write_record = write_seq_file;
	     end;

	else do;					/* update */
		read_record = read_seq_file;
		read_length = read_length_seq_file;
		position = position_seq_file;
		write_record = write_seq_file;
		rewrite_record = rewrite_seq_file;
		delete_record = delete_seq_file;
	     end;

	if (mode = 5) | ((mode = 6) & ^append_sw)	/* output or input-output */
	then do;					/* change to write state */
		call position_eof;
		write_pos = pos;
		read_pos = minus_one_pos;
	     end;

     end set_entries_and_positions;

validate_initialize_file:
     proc;
	code = 0;
	if is_new_file
	then do;					/* initialize file */
		first_seg_ptr -> end_prev_seg = 0;
		first_seg_ptr -> minus_one = -1;
		first_seg_ptr -> end_seg = first_record_pos;
		first_seg_ptr -> header.checkpoint_data.end_desc = initial_end_desc;
		addr (first_seg_ptr -> seg (header_size + 1)) -> descrip = addr (first_seg_ptr -> minus_one) -> descrip;

/* this sets the initial descriptor */
		addr (first_seg_ptr -> seg (first_record_pos)) -> descrip = addr (first_seg_ptr -> minus_one) -> descrip;
						/* this set the eof descriptor */
		call hcs_$set_bc_seg (first_seg_ptr, 9 * (header_size + 8), foo);
		first_seg_ptr -> header.version = current_version;
	     end;
	else do;					/* validate header, init descriptor */
		dbytes = addr (first_seg_ptr -> seg (header_size + 1)) -> descrip;
		if ((first_seg_ptr -> header.version < 10) | (first_seg_ptr -> header.version > current_version))
		     | (first_seg_ptr -> end_prev_seg ^= 0) | (first_seg_ptr -> minus_one ^= -1)
		     | ((d ^= -1) & (first_seg_ptr -> header.version = 11))
		then code = error_table_$bad_file;
	     end;
     end;						/* end validate_initialize_file */

rollback:
     proc;					/* restores eof according to checkpoint data */
	if seq_cb.write_pos ^= beyond_limits
	then call switch_to_read_state;
	if seq_cb.end_pos >= seq_cb.header_end_pos	/* file was extended */
	then do;					/* rollback requires truncation */
		seq_cb.next_pos = seq_cb.header_end_pos;
		call set_position (seq_cb.header_end_desc);
		call truncate_file;			/* dispose of new stuff */
		seq_cb.checkpoint_data = seq_cb.header_end_info;
	     end;
	else do;					/* un-truncate file */
		seq_cb.checkpoint_data = seq_cb.header_end_info;
		call position_eof;
	     end;
     end rollback;

adjust_file:
     proc;					/* truncates file after setting eof properly */
	call save_position;
	seq_cb.end_pos = infinity;			/* let find_next_rec scan for marker */
	call set_end_pos;
	call set_seg_end;
	file_base_ptr -> header.checkpoint_data = seq_cb.checkpoint_data;
	if ^is_msf				/* single segment */
	then call hcs_$truncate_seg (seg_ptr, divide (pos + 6, 4, 18, 0), code);
	else call msf_manager_$adjust (fcb_ptr, component, 9 * (pos + 3), "010"b, code);
						/* truncate any garbage */
	seq_cb.header_end_info = seq_cb.checkpoint_data;
	call restore_position;
     end adjust_file;				/* file properly adjusted to last rec */

set_end_pos:
     proc;					/* determines true record count */

	do while (code = 0);			/* advance position to true eof */
	     call find_next_record;			/* may advance file position */
	     next_pos = next_pos + 1;
	     read_pos = read_pos + 8 + d;		/* skips the record */
	end;

	seq_cb.end_pos = next_pos - 1;		/* true end of file position */
	call set_end_desc;
	end_not_valid = "0"b;			/* remember end pos is now correct */
	code = 0;
     end set_end_pos;

find_eof_v12:
     proc;					/* positions to end of file in version 12 or older files */
	flag = "1"b;

	do while (flag);
	     pos = end_seg;
	     dbytes = descrip;
	     read_pos = pos;
	     if d = -2				/* another segment exists */
	     then do;
		     call next_seg_read;
		     if code ^= 0
		     then flag = "0"b;		/* found file bad */
		end;
	     else flag = "0"b;			/* this is the last seg */
	end;

	call set_end_desc;
	dcl     flag		 bit (1) aligned;
     end find_eof_v12;

adjust_file_v12:
     proc;					/* converts version 12 to current */
	call save_position;
	call find_eof_v12;
	first_seg_ptr -> header.checkpoint_data.end_desc = seq_cb.end_desc;
	first_seg_ptr -> header.version = current_version;
	call restore_position;
     end adjust_file_v12;

get_positions:
     proc;					/* used on initial attempt to read positions in old version files */
	call save_position;

/* now find next and end positions */
	ei_ptr = addr (ei_block);
	ei_ptr -> error_info.version = 1;
	call position_seq_file (iocb_ptr, 0, -infinity, foo);
						/* will produce error */
	call control_seq_file (iocb_ptr, "error_status", ei_ptr, foo);
	next_pos = 0;
	call set_end_pos;
	next_pos = -ei_ptr -> error_info.received;

	call restore_position;
	dcl     ei_ptr		 ptr;
	dcl     1 ei_block,
		2 words		 (4) fixed;
     end get_positions;

	dcl     (addr, divide)	 builtin;
	dcl     infinity		 static options (constant) internal fixed (34) init (17179870);
	dcl     (vfile_io_control, vfile_status_$seg)
				 entry (ptr, ptr, ptr, fixed (35));
	dcl     order		 char (*);
	dcl     info_ptr		 ptr;
	dcl     alloc_cb_file	 entry (fixed bin, ptr);
	dcl     buffer		 char (d) based (buff_ptr);
	dcl     buff_ptr		 ptr;
	dcl     buff_len		 fixed bin (21);
	dcl     close_x		 entry;
	dcl     code		 fixed bin (35);
	dcl     1 error_info	 based (info_ptr),	/* used with "error_status" control order */
		2 version		 fixed,		/* must =1 (Input) */
		2 type		 fixed,		/* identifies type of error--only one currently exists */
		2 requested	 fixed,		/* skip arg passed to vfile_ for positioning */
		2 received	 fixed;		/* skips completed successfully */
	dcl     skip_error		 fixed static options (constant) internal init (1);
	dcl     1 complete_record	 based (addr (seg (pos))),
		2 descrip		 char (4),	/* descriptor for record, actually
						   an integer, = length of record normally, = -(header_size + length)
						   for deleted record */
		2 record		 char (d),
		2 trailer_descrip	 char (4);	/* always = record length */
	dcl     d			 fixed bin (21);	/* value of descriptor, length of record */
	dcl     dbytes		 char (4) based (addr (d));
						/* alias for assignment between d and descrip */
	dcl     deleted_size_bias	 static options (constant) internal fixed bin (21) init (40);
						/* this is added to the record size
						   before commplementing it to get the descriptor for a deleted record. 40 is an arbitrary value >0. */
	dcl     error_table_$bad_file	 external fixed bin (35);
	dcl     error_table_$negative_nelem
				 external fixed (35);
	dcl     error_table_$file_busy external fixed (35);
	dcl     error_table_$unimplemented_version
				 external fixed (35);
	dcl     error_table_$file_is_full
				 static external fixed (35);
	dcl     error_table_$no_operation
				 external fixed (35);
	dcl     error_table_$no_record external fixed bin (35);
	dcl     error_table_$long_record
				 external fixed bin (35);
	dcl     error_table_$short_record
				 external fixed bin (35);
	dcl     error_table_$end_of_info
				 external fixed bin (35);
	dcl     error_table_$bad_arg	 external fixed bin (35);
	dcl     free_cb_file	 entry (fixed bin, ptr);
	dcl     fcb_ptr_arg		 ptr;
	dcl     first_record_pos	 static options (constant) internal fixed bin init (61);
						/* =header_size+4+1, 4 for initial descriptor */
	dcl     first_seg_ptr	 ptr;
	dcl     first_seg_bitcount	 fixed bin (24);
	dcl     foo		 fixed bin (35);	/* used when status code is to
						   be ignored */
	dcl     foo24		 fixed bin (24);	/* used when bit count is to
						   be ignored */
	dcl     1 header		 based (seg_ptr),
		2 common_header_words
				 (4) fixed bin,
		2 version_word	 aligned,
		  3 file_action	 fixed (17) unal,
		  3 version	 fixed (17) unal,
		2 end_prev_seg	 fixed bin (21),	/* = 0 in first seg,
						   otherwise = pos of final descrip in preceding
						   segment */
		2 end_seg		 fixed bin (21),	/* = pos of final
						   descriptor in this segment except while
						   in write state.  In write state indicates
						   end of seg when write state entered */
		2 minus_one	 fixed bin (21),	/* always -1 */
		2 checkpoint_data,
		  3 end_pos	 fixed (34),
		  3 end_desc	 fixed (35),
		2 reserved	 (4) fixed;
	dcl     cur_pos		 fixed (34);
	dcl     low_end_ptr		 ptr unal based (addr (seq_cb.low_end_desc));
	dcl     1 low_ds_struct	 based (addr (seq_cb.low_end_desc)),
		2 bitno		 bit (6) unal,
		2 low_end_comp	 fixed (11) unal,
		2 wordno		 bit (18) unal;
	dcl     must_rollback	 static internal fixed options (constant) init (3);
	dcl     must_adjust		 static internal fixed options (constant) init (2);
	dcl     header_size		 static options (constant) internal fixed bin init (56);
	dcl     checkpoint_info_words	 fixed (71);
	dcl     1 checkpoint_info	 based (addr (checkpoint_info_words)) aligned,
		2 end_pos		 fixed (34),
		2 end_desc	 fixed (35);
	dcl     hcs_$truncate_seg	 entry (ptr, fixed (18), fixed (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed (35));
	dcl     msf_manager_$open	 entry (char (*), char (*), ptr, fixed (35));
	dcl     hcs_$set_bc_seg	 entry (ptr,	/* pointer to seg, input */
				 fixed bin (24),	/* bit count to be set */
				 fixed bin (35));	/* status code */
	dcl     iocb_ptr		 ptr;		/* for open and close entries this points to the actual iocb.
						   For other entries the iocb may be attached as a syn */
	dcl     is_new_file		 bit (1) aligned;
	dcl     max_component_size	 fixed bin (19);
	dcl     mode		 fixed bin;	/* 4, 5, 6, or 7 */
	dcl     minus_one_pos	 static options (constant) internal fixed bin (21) init (29);
						/* 4*common_header_size+13 = position of header.minus_one */
	dcl     msf_manager_$adjust	 entry (ptr,	/* fcb_ptr */
				 fixed bin,	/* component number of segment to be
						   made last segment */
				 fixed bin (24),	/* bit count for that seg */
				 bit (3),		/* "010" = dont set bit counts, truncate
						   segment, dont terminate components */
				 fixed bin (35));	/* status code */
	dcl     msf_manager_$get_ptr	 entry (ptr,	/* fcb_ptr */
				 fixed bin,	/* component number of desired segment */
				 bit (1),		/* create switch */
				 ptr,		/* ptr to seg or null if error, output */
				 fixed bin (24),	/* bitcount of segment, output */
				 fixed bin (35));	/* status code */
	dcl     next_comp		 fixed bin;
	dcl     next_seg_ptr	 ptr;
	dcl     null		 builtin;
	dcl     rec_len		 fixed bin (21);
	dcl     pos		 fixed bin (21);	/* position of next descriptor */
	dcl     pos_type		 fixed bin;
	dcl     seg		 (1048576) char (1) based (seg_ptr);
	dcl     1 info		 based (info_ptr),	/* used for "read_position" order call */
		2 next_position	 fixed (34),
		2 end_position	 fixed (34);
	dcl     1 seq_cb		 based (open_data_ptr),
		2 seg_ptr		 ptr,		/* ptr to current seg */
		2 fcb_ptr		 ptr,		/* ptr to msf control block */
		2 component	 fixed bin,	/* component number of
						   current seg */
		2 write_limit	 fixed bin (21),	/* set at open to max seg size + 1 */
		2 beyond_limits	 fixed bin (21),	/* set at open to write_limit + 4 */
		2 max_record_size	 fixed bin (21),	/* set at open to 4*max_component_size-
						   header_size-12(i.e. 3 desciptor words */
		2 write_pos	 fixed bin (21),	/* in write state =
						   pos of final descriptor, in read state =
						   beyond limits */
		2 read_pos	 fixed bin (21),	/* in read state =
						   pos of next descriptor, in write state
						   = minus_one_pos */
		2 current_record_ptr ptr,
		2 checkpoint_data,
		  3 end_pos	 fixed (34),
		  3 end_desc	 fixed (35),
		2 next_pos	 fixed (34),	/* next record number */
		2 next_is_current	 bit (1) aligned,	/* "0"b if positions staggerred */
		2 updating	 bit (1) aligned,	/* set if mode=7 (sequential_update) */
		2 append_sw	 bit (1) aligned,	/* set if mode=6 (seq in out) and -append attachment */
		2 input_only	 bit (1) aligned,
		2 ssf_sw		 bit (1) aligned,	/* -ssf option indicator */
		2 is_msf		 bit (1) aligned,	/* set when msf is opened */
		2 end_not_valid	 bit (1) aligned,	/* used with old version files */
		2 error,				/* used by "error_status" control order */
		  3 type		 fixed,
		  3 requested	 fixed (34),
		  3 received	 fixed (34),
		2 minus_one_word	 fixed,
		2 file_base_ptr	 ptr,
		2 header_end_info,
		  3 header_end_pos	 fixed (34),
		  3 header_end_desc	 fixed (35),
		2 checkpoint	 bit (1) aligned,	/* set if -checkpoint attachment */
		2 opening_mode	 fixed;
	dcl     packed_curp		 ptr unal;
	dcl     minus_one_descrip	 char (4) based (addr (minus_one_word));
	dcl     size		 builtin;
	dcl     er_code		 fixed (35);
	dcl     current_version	 fixed static options (constant) internal init (13);
	dcl     initial_end_desc	 static fixed (35) internal options (constant) init (15);
	dcl     1 last_desc		 based (addr (seq_cb.end_desc)),
		2 bitno		 fixed (5) unal,
		2 compno		 fixed (11) unal,
		2 wordno		 bit (18) unal;
	dcl     last_desc_ptr	 ptr unal based (addr (seq_cb.end_desc));
	dcl     1 eof_data		 based (addr (eof_data_word)),
		2 end_pos		 fixed (34),
		2 end_desc	 fixed (35);
	dcl     eof_data_word	 fixed (71) aligned;
%include vf_attach_block;
%include rs_info;
	dcl     skip		 fixed (34);
	dcl     (saved_seg_ptr, saved_curr_ptr)
				 ptr;
	dcl     saved_comp		 fixed;
	dcl     saved_next_pos	 fixed (34);
	dcl     (saved_read_pos, saved_write_pos)
				 fixed (21);
	dcl     saved_next_curr	 bit (1) aligned;
%include iocbv;
     end /* end of sequential file i-o program */;




		    open_uns_file.pl1               11/04/82  1940.0rew 11/04/82  1620.8      276543



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


/* changed October, 1978 by Jim Paradise to impliment the -no_end option (see end of source for comments) */

open_uns_file:
     proc (iocb_ptr, fcb_ptr_arg, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount, max_component_size, code);

	code = 0;
	if atb.header_present			/* -header attach option present */
	then if is_new_file				/*  set header identifier in new file */
	     then do;				/* initialize header */
		     call hcs_$set_bc_seg (first_seg_ptr, 36 * size (header), code);
		     if code ^= 0
		     then return;			/* shouldn't happen */
		     first_seg_ptr -> header.identifier = atb.header_id;
		end;
	     else if (first_seg_ptr -> file_code ^= uns_code)
		     | ((first_seg_ptr -> header.identifier ^= atb.header_id) & (atb.header_id ^= 0))
	     then do;				/* signal error--identifiers must match */
		     code = error_table_$incompatible_attach;
		     return;			/* opening is unsuccessful */
		end;
	call create_initialize_cb;
	close_x = close_uns_file;
	control = control_uns_file;
	if mode = 1				/* input */
	then do;
		get_line = get_line_uns_file;
		get_chars = get_chars_uns_file;
		position = position_uns_file;
	     end;
	else if mode = 2				/* output */
	then do;
		put_chars = fast_put;
	     end;
	else do;					/* input - output */
		get_line = get_line_uns_file;
		get_chars = get_chars_uns_file;
		position = position_uns_file;
		put_chars = fast_put;
	     end;
	return;					/* end open routine */

control_uns_file:
     entry (iocb_ptr, order, info_ptr, code);
	code = 0;
	call get_current_state;

	if order = "read_position"
	then if current_state = read_state
	     then do;
		     info.next_position = base_pos + read_pos - 1;
						/* essentially the defining
						   relationship for absolute position in the read state */
		     info.end_position = end_pos;	/* always valid in read state */
		end;
	     else if current_state = write_state
	     then do;
		     info.next_position = base_pos + write_pos - 1;
						/* -1 because byte offset
						   starts with 1 at base of segment */
		     info.end_position = info.next_position;
						/* pos always at eof in write state */
		end;
	     else do;				/* beyond eof */
		     info.next_position = base_pos + write_pos - 1;
		     info.end_position = end_pos;
		end;

/* for debugging
   else if order = "display_uns_cb" then call display_uns_cb;
*/

	else if (order = "truncate") & (^input_only)
	then do;
		if current_state = read_state
		then do;				/* might not be at eof so truncate */
			call truncate_and_change_to_write;
			code = foo;		/* what the hell */
		     end;
		else if current_state = beyond_eof_state
		then code = error_table_$no_operation;	/* not allowed */
	     end;

	else if order = "file_status"
	then do;
		call vfile_status_$seg (iocb_ptr, file_base_ptr, info_ptr, code);
		return;
	     end;

	else if order = "io_call"
	then call vfile_io_control (iocb_ptr, file_base_ptr, info_ptr, code);
	else code = error_table_$no_operation;

	return;					/* end of control routine */

create_initialize_cb:
     proc;
	call alloc_cb_file (size (cb_uns_file), open_data_ptr);
	write_limit = 4 * max_component_size + 1;
	beyond_limits = 2 ** 34 - 1;
	fcb_ptr = fcb_ptr_arg;
	seg_ptr = first_seg_ptr;
	call hcs_$status_mins (seg_ptr, foo2, bitcount, foo35);
	component = 0;
	header_is_present = atb.header_present;		/* -header option was used for attachment */
	if header_is_present
	then base_pos = -4 * size (header);		/* absolute byte position of file base is negative */
	else base_pos = 0;				/* no header--first byte is byte_0 */
	if is_new_file & header_is_present
	then end_seg = 4 * size (header) + 1;
	else end_seg = divide (first_seg_bitcount + 8, 9, 21, 0) + 1;
	read_pos = 1 - base_pos;			/* byte offset of zeroth position in file */
	tail_len = end_seg - read_pos;		/* bytes remaining beyond next_pos in this segment */
	write_pos, old_write_pos = beyond_limits;	/* start in read state */
	input_only = (mode = 1);			/* stream_input */
	ssf_sw = atb.ssf;				/* -ssf option indicates no msf's allowed */
	noend = atb.noend_sw;			/* -no_end attach option */
	is_msf = atb.msf;				/* on if already an msf */
	append_sw = atb.appending;			/* -append attachment */
	no_trunc_sw = atb.no_trunc;			/* -no_trunc attach option */
	current_state = read_state;
	call set_end_pos;				/* gets total byte count of file */
	if (mode = 2) | (^append_sw & ^no_trunc_sw & (mode = 3))
						/* start in write state */
	then do;
		write_pos, old_write_pos = read_pos;	/* tail_len already zero */
		current_state = write_state;		/* for completeness */
	     end;
	file_base_ptr = seg_ptr;
     end;						/* end create_initialize_cb */


close_uns_file:
     entry (iocb_ptr);
	call get_current_state;
	call change_to_read_state;
						/* sets bit count of file */
	call free_cb_file (size (cb_uns_file), open_data_ptr);
	return;					/* end close routine */

get_chars_uns_file:
     entry (iocb_ptr, buff_ptr, buff_len, rec_len, code);
	call get_current_state;
	if current_state = beyond_eof_state
	then do;
		code = error_table_$end_of_info;
		rec_len = 0;			/* no data */
		return;
	     end;
	len = min (tail_len, buff_len);
	if len > 0
	then do;
		buffer = record_read;
		read_pos = read_pos + len;
		tail_len = tail_len - len;
		if buff_len = len			/* all bytes moved */
		then do;
			code = 0;
			rec_len = len;
		     end;
		else do;				/* exceptional case_end of segment */
			call get_chars_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, rec_len, code);
			rec_len = rec_len + len;
			if (code ^= 0) & (rec_len > 0)
			then code = error_table_$short_record;
		     end;
	     end;
	else if buff_len <= 0
	then do;					/* no move */
		code = 0;
		rec_len = 0;
	     end;
	else do;					/* end of segment case */
		call next_seg_read;
		if code ^= 0 & code ^= error_table_$end_of_info
						/* msf error */
		then return;
		if code ^= 0
		then rec_len = 0;
		else call get_chars_uns_file (iocb_ptr, buff_ptr, buff_len, rec_len, code);
	     end;
	return;					/* end get chars routine */

get_line_uns_file:
     entry (iocb_ptr, buff_ptr, buff_len, rec_len, code);
	call get_current_state;
	if current_state = beyond_eof_state
	then do;
		code = error_table_$end_of_info;
		rec_len = 0;			/* no data */
		return;
	     end;
	len = min (tail_len, buff_len);
	if len > 0
	then do;
		len2 = len;
		len = index (record_read, new_line);
		if len ^= 0			/* new line found */
		then do;
			code = 0;
			buffer = record_read;
			rec_len = len;
			read_pos = read_pos + len;
			tail_len = tail_len - len;
		     end;
		else do;				/* new_line not found */
			len = len2;
			buffer = record_read;	/* move len bytes */
			read_pos = read_pos + len;
			tail_len = tail_len - len;
			if buff_len = len
			then do;			/* long record case */
				rec_len = len;
				code = error_table_$long_record;
			     end;
			else do;			/* end of segment case */
				call get_line_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, rec_len, code);
				rec_len = rec_len + len;
				if (code ^= 0) & (rec_len > 0)
				then code = error_table_$short_record;
			     end;
		     end;
	     end;
	else if buff_len <= 0
	then do;					/* no move */
		code = error_table_$long_record;
		rec_len = 0;
	     end;
	else do;					/* end of segment case */
		call next_seg_read;
		if code ^= 0 & code ^= error_table_$end_of_info
						/* msf error */
		then return;
		if code ^= 0
		then rec_len = 0;
		else call get_line_uns_file (iocb_ptr, buff_ptr, buff_len, rec_len, code);
	     end;
	return;					/* end of get_line routine */

skip_record:
     proc;					/* skips one record and (as needed by read) increments len2 by
						   length skipped, excluding new_line */
	do while ("1"b);				/* may cross boundaries of msf components */
	     len = tail_len;
	     if len ^= 0
	     then do;
		     len = index (record_read, new_line);
		     if len ^= 0
		     then do;			/* new line found */
			     code = 0;
			     len2 = len2 + len - 1;
			     read_pos = read_pos + len;
			     tail_len = tail_len - len;
			     return;
			end;
		     else do;			/* record extends to next seg */
			     len2 = len2 + tail_len;
			     read_pos = read_pos + tail_len;
			     tail_len = 0;
			end;
		end;
	     else do;				/* at end of seg */
		     call next_seg_read;
		     if code ^= 0
		     then return;
		end;
	end;
     end;						/* end skip record */

next_seg_read:
     proc;
	if current_state ^= read_state
	then code = error_table_$end_of_info;
	else do;
		foo = 0;
		if ^is_msf
		then next_seg_ptr = null;
		else do;
			call msf_manager_$get_ptr (fcb_ptr, component + 1, "0"b, next_seg_ptr, bitcount, foo);
		     end;
		if next_seg_ptr = null
		then do;
			if foo ^= 0		/* msf error? */
			then do;			/* return a code back */
				if foo = error_table_$noentry
						/* way to find eof */
				then code = error_table_$end_of_info;
				else code = foo;	/* return the code */
			     end;
			else code = error_table_$end_of_info;
			return;
		     end;
		else do;
			base_pos = base_pos + end_seg - 1;
						/* absolute byte position of new seg base */
			seg_ptr = next_seg_ptr;
			call hcs_$status_mins (seg_ptr, foo2, bitcount, foo35);
			component = component + 1;
			tail_len = divide (bitcount + 8, 9, 21, 0);
			end_seg = tail_len + 1;
			read_pos = 1;
			code = 0;
		     end;
	     end;
     end;						/* end next seg read */

position_uns_file:
     entry (iocb_ptr, pos_type, skip, code);
	call get_current_state;
	if pos_type = 0
	then call position_skip;
	else if pos_type = 2			/* direct positioning */
	then call position_abs;
	else if pos_type = 1
	then call position_eof;
	else if pos_type ^= -1
	then code = error_table_$bad_arg;
	else call position_bof;
	return;					/* end position routine */

change_to_read_state:
     proc;					/* no effect if already in read state */
	if current_state = read_state
	then return;
	if current_state = beyond_eof_state
	then write_pos, old_write_pos = beyond_limits;	/* switch to read state
						   no change, since the positioning absolute to beyond eof
						   did a position_eof before everything */
	else do;
		end_seg = write_pos;
		read_pos = write_pos;
		end_pos = base_pos + end_seg - 1;	/* must be last comp since write state */
		tail_len = 0;
		write_pos, old_write_pos = beyond_limits;
		call hcs_$set_bc_seg (seg_ptr, 9 * (end_seg - 1), foo);
	     end;
     end;						/* end change_to_read_state */


position_abs:
     proc;					/* sets position directly to specified byte */
	if skip < 0				/* negative absolute position is undefined */
	then code = error_table_$negative_nelem;
	else do;
		call change_to_read_state;
		code = 0;
		if skip >= end_pos
		then do;
			call position_eof;
			if skip > end_pos		/* attempt to pass eof */
			then if ^noend		/* not allowed by specifying -no_end */
			     then code = error_table_$end_of_info;
			     else do;		/* -no_end specified */
				     write_pos, old_write_pos = skip + 1 - base_pos;
						/* set the position beyond to the absolute position: */
				     current_state = beyond_eof_state;
				end;		/* segment(s) may not be defined */
			return;			/* done processing in this case */
		     end;

		do while ((skip < base_pos) & (code = 0));
						/* requested pos in previous component */
		     call prev_seg_read;
		end;

		do while ((skip >= base_pos + end_seg) & (code = 0));
						/* requested pos in succeeding component */
		     call next_seg_read;
		end;

		if code ^= 0 & code ^= error_table_$end_of_info
						/* msf error */
		then return;

		if code = 0			/* position lies within current segment */
		then do;
			read_pos = skip + 1 - base_pos;
						/* set next byte offset for reading */
			tail_len = end_seg - read_pos;
						/* bytes following next in this segment */
		     end;
	     end;
     end position_abs;

position_skip:
     proc;
	if skip > 0
	then do;					/* check if pos'ed after eof */
		if current_state = beyond_eof_state
		then do;
			code = error_table_$end_of_info;
			return;
		     end;
		else do;				/* forwards skip */
			code = 0;
			count = skip;
			do while (count > 0);
			     len2 = 0;		/* skip record increments this for read */
			     call skip_record;
			     if code ^= 0 & code ^= error_table_$end_of_info
						/* msf error */
			     then return;
			     if code ^= 0
			     then count = 0;
			     else count = count - 1;
			end;
		     end;
	     end;
	else do;					/* backwards skip */
		count = -skip;
		code = 0;
		call change_to_read_state;
		do while (count > 0);
		     call find_preceding_new_line;
		     if code = 0
		     then count = count - 1;
		     else count = 0;
		end;
		if code = 0			/* positioned at new_line character */
		then do;
			call find_preceding_new_line;
			if code = 0		/* positioned at new_line character */
			then call get_chars_uns_file (iocb_ptr, addr (dummy_buffer), 1, foo21, foo);
						/* skips over new line character */
			code = 0;
		     end;
	     end;
     end position_skip;

find_preceding_new_line:
     proc;
						/* this moves read_pos back to first preceding new_line
						   character or beginning of file if there is none.
						   In the latter case code is set to end_of_info */

	do while (code = 0);			/* may cross msf component boundaries */
	     flag = "1"b;
	     k = read_pos;
	     if header_is_present
	     then if component = 0
		then min_pos = 4 * size (header) + 1;	/* can't position beneath header */
		else min_pos = 1;
	     else min_pos = 1;
	     do while (flag);
		k = k - 1;
		if k < min_pos			/* at base of segment */
		then flag = "0"b;
		else if seg (k) = new_line
		then flag = "0"b;
	     end;
	     if k >= min_pos			/* new_line found */
	     then do;
		     code = 0;
		     read_pos = k;
		     tail_len = end_seg - k;
		     return;
		end;
	     else do;				/* beginning of segment */
		     read_pos = min_pos;
		     tail_len = end_seg - read_pos;
		     if component = 0		/* beginning of file */
		     then do;
			     code = error_table_$end_of_info;
			     return;
			end;
		     else call prev_seg_read;		/* moves pos to end of prev seg */
		end;
	end;

	dcl     flag		 bit (1) aligned;
	dcl     (k, min_pos)	 fixed bin (21);
     end;						/* end_find_preceding_line */
	dcl     count		 fixed bin;
	dcl     foo21		 fixed bin (21);

position_eof:
     proc;
	if current_state = beyond_eof_state
	then do;
		call change_to_read_state;
	     end;
	code = 0;
	if current_state = read_state
	then do;
		do while (code = 0);
		     call next_seg_read;
		end;
		if code ^= error_table_$end_of_info	/* msf error */
		then return;
		code = 0;
		read_pos = end_seg;
		tail_len = 0;
	     end;
     end;						/* end position_eof */

position_bof:
     proc;					/* sets position to beginning of file */
	code = 0;
	call change_to_read_state;
	if ^is_msf
	then do;					/* current segment must be first */
		read_pos = 1 - base_pos;
		tail_len = end_seg - read_pos;
		return;
	     end;
	call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, next_seg_ptr, bitcount, foo);
	if next_seg_ptr ^= null
	then do;
		seg_ptr = next_seg_ptr;
		call hcs_$status_mins (seg_ptr, foo2, bitcount, foo35);
		component = 0;
		if header_is_present
		then base_pos = -4 * size (header);	/* abs pos of first seg base is neg */
		else base_pos = 0;			/* first byte in seg is zeroth absolute byte position */
		end_seg = divide (bitcount + 8, 9, 21, 0) + 1;
		read_pos = 1 - base_pos;
		tail_len = end_seg - read_pos;	/* always holds in read state */
	     end;
	else code = foo;
     end position_bof;

put_chars_uns_file:
     entry (iocb_ptr, buff_ptr, buff_len, code);
	code = 0;
	call get_current_state;
	len = max (buff_len, 0);
	old_pos = write_pos;
	write_pos, old_write_pos = write_pos + len;
	if write_pos <= write_limit			/* normal case */
	then do;
		record_write = buffer;
	     end;
	else if old_pos < write_limit			/* long record case */
	then do;
		len = write_limit - old_pos;
		write_pos, old_write_pos = write_limit;
		record_write = buffer;
		call put_chars_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, code);
	     end;
	else do;					/* end of seg or read state */
		write_pos, old_write_pos = old_pos;
		code = 0;
		if write_pos = write_limit		/* end of seg case */
		then call new_seg_write;
		else if current_state = beyond_eof_state
		then do;				/* spacing beyond eof */
			do while ((write_pos > write_limit) & (code = 0));
						/* space to proper component */
			     old_pos = write_pos;	/* save position */
			     call new_seg_write;	/* write out seg, and get new one */
			     write_pos, old_write_pos = old_pos - write_limit + 1;
			     end_seg = write_pos;
			end;
			if code = 0		/* only continue if no errors */
			then do;			/* output the characters */
				current_state = write_state;
				call put_chars_uns_file (iocb_ptr, buff_ptr, buff_len, code);
						/* output */
				return;		/* done */
			     end;
		     end;
		else if append_sw			/* -append attachment */
		then do;				/* go to end of file and change to write state */
			call position_eof;		/* sets tail_len to 0 */
			write_pos, old_write_pos = end_seg;
						/* changes to write state */
			current_state = write_state;
		     end;
		else if ^no_trunc_sw		/* did not use -no_trunc option */
		then call truncate_and_change_to_write;
		else do;				/* rewrite and possibly append */
			if buff_len <= 0
			then return;		/* no-op in this case */
			if tail_len > 0		/* not yet at end of seg */
			then do;			/* replace bytes in tail */
				len = min (tail_len, buff_len);
						/* may need next comp */
				old_pos = read_pos; /* start at read position */
				record_write = buffer;
						/* move buffer contents */
				read_pos = read_pos + len;
						/* advance next position */
				tail_len = tail_len - len;
						/* fewer chars remain */
				if buff_len > len	/* part of buffer not moved */
				then call put_chars_uns_file (iocb_ptr, addr (buff_tail), buff_len - len, code);
						/* move rest of buffer */
				return;		/* finished put operation */
			     end;
			else do;			/* end of segment case */
				call next_seg_read; /* looks for next component */
				if code ^= 0	/* end of file */
				then do;
					write_pos, old_write_pos = end_seg;
						/* change to write state */
					current_state = write_state;
					code = 0; /* not an error */
				     end;
			     end;
		     end;
		if code = 0
		then call put_chars_uns_file (iocb_ptr, buff_ptr, buff_len, code);
	     end;
	current_state = write_state;
	return;					/* end put chars routine */

prev_seg_read:
     proc;					/* moves position to end of previous component */
	call msf_manager_$get_ptr (fcb_ptr, component - 1, "0"b, next_seg_ptr, bitcount, foo);
	if next_seg_ptr = null
	then do;
		code = error_table_$bad_file;
		return;
	     end;
	else do;
		seg_ptr = next_seg_ptr;
		component = component - 1;
		read_pos = divide (bitcount + 8, 9, 21, 0) + 1;
						/* position at end of seg */
		end_seg = read_pos;
		tail_len = 0;
		if (header_is_present) & (component = 0)
		then base_pos = -4 * size (header);	/* offsets header at file base */
		else base_pos = base_pos - end_seg + 1; /* subtract contents of prev segment */
	     end;
     end prev_seg_read;

new_seg_write:
     proc;
	if ssf_sw					/* prevents adding new component */
	then do;					/* flag the error */
		code = error_table_$file_is_full;
		return;
	     end;
	if ^is_msf				/* single segment */
	then do;
		call msf_manager_$open (substr (attach_descrip_string, 8, dname_len),
		     substr (attach_descrip_string, 9 + dname_len, ename_len), fcb_ptr, foo);
		is_msf = "1"b;
		atb.fcbp = fcb_ptr;
	     end;
	call msf_manager_$get_ptr (fcb_ptr, component + 1, "1"b, next_seg_ptr, foo24, foo);
	if next_seg_ptr = null
	then code = foo;
	else do;
		call hcs_$set_bc_seg (seg_ptr, 9 * (write_limit - 1), foo);
		seg_ptr = next_seg_ptr;
		component = component + 1;
		write_pos, old_write_pos = 1;
		base_pos = base_pos + write_limit - 1;	/* set base position of new comp */
		end_seg = 1;
		read_pos = 1;
		code = 0;
	     end;
     end;						/* end new_seg_write */

set_end_pos:
     proc;					/* determines number of bytes in file */
	if is_new_file
	then end_pos = 0;				/* file is empty */
	else do;					/* get last component, set end_pos , and reset position if necessary */
		call position_eof;			/*  finds last component */
		end_pos = base_pos + end_seg - 1;	/* base pos was set by position_eof */
		if (mode = 1) | ((mode = 3) & (append_sw | no_trunc_sw))
						/* bof at open */
		then call position_bof;		/* resets positions */
	     end;
     end set_end_pos;

truncate_and_change_to_write:
     proc;
	end_seg = read_pos;
	write_pos, old_write_pos = end_seg;
	current_state = write_state;
	tail_len = 0;
	call hcs_$set_bc_seg (seg_ptr, 9 * (end_seg - 1), foo);
	if ^is_msf
	then call hcs_$truncate_seg (seg_ptr, divide (end_seg + 2, 4, 18, 0), foo);
	else call msf_manager_$adjust (fcb_ptr, component, 9 * (end_seg - 1), "010"b, foo);
     end;						/* end truncate_and_change_to_write */

get_current_state:
     proc;
	if write_pos = beyond_limits
	then do;
		current_state = read_state;
		return;
	     end;
	if write_pos ^= old_write_pos			/* fast_put has done some work */
	then do;
		current_state = write_state;
		return;
	     end;
	if current_state = beyond_eof_state
	then return;
	current_state = write_state;
	return;
     end get_current_state;

/* for debugging
   display_uns_cb: proc;
   call ioa_ ( "uns_cb: ^p ^- current_state: ^d ^- write_limit: ^d ^- is_msf: ^b",
   open_data_ptr, current_state, write_limit, is_msf);
   call ioa_ ( "ptrs: ^-fcb: ^p ^-file_base: ^p ^-comp num: ^d ^-seg: ^p",
   fcb_ptr, file_base_ptr, component, seg_ptr );
   call ioa_ ( "read_pos: ^d ^-tail_len: ^d ^-base_pos: ^d ^-end_pos: ^d",
   read_pos, tail_len, base_pos, end_pos );
   call ioa_ ( "end_seg: ^d ^-write_pos: ^d ^-old_write_pos: ^d",
   end_seg, write_pos, old_write_pos );
   return;
   end;
*/

/* DECLARATIONS FOR WHOLE PROGRAM */
	dcl     (vfile_io_control, vfile_status_$seg)
				 entry (ptr, ptr, ptr, fixed (35));
	dcl     fast_put		 entry (ptr, ptr, fixed (21), fixed (35));
	dcl     max		 builtin;
	dcl     addr		 builtin;
	dcl     alloc_cb_file	 entry (fixed bin, ptr);
	dcl     bitcount		 fixed bin (24);
	dcl     buffer		 char (len) based (buff_ptr);
						/* len is length
						   that will be used in data transfer */
	dcl     buff_len		 fixed bin (21);	/* length as specified in call */
	dcl     buff_ptr		 ptr;
	dcl     buff_tail		 char (buff_len - len) based (addr (buff_array (len + 1)));
						/* remainder of buffer after
						   data transfer, its length is > 0 */
	dcl     buff_array		 (buff_len) char (1) based (buff_ptr);
	dcl     1 header		 based (seg_ptr),	/* optional header for unstructured files */
		2 common_header_words,
		  3 file_code	 fixed,		/* identifies file type */
		  3 words		 (3) fixed,
		2 identifier	 fixed (35),	/* user defined field */
		2 words		 (11) fixed;	/* for possible future use */
	dcl     uns_code		 static internal fixed init (31191);
%include vf_attach_block;
	dcl     order		 char (*);
	dcl     info_ptr		 ptr;
	dcl     1 info		 based (info_ptr),	/* used for "read_position" order */
		2 next_position	 fixed (34),	/* absolute position of next byte */
		2 end_position	 fixed (34);	/* total number of bytes in the file */
	dcl     1 cb_uns_file	 based (open_data_ptr),
		2 seg_ptr		 ptr,		/* ptr to base of current segment in file */
		2 write_limit	 fixed bin (34),	/* 1+(max size of first component) */
		2 beyond_limits	 fixed bin (34),	/* max 34 bit number */
		2 fcb_ptr		 ptr,		/* ptr to msf_manager control block */
		2 component	 fixed bin,	/* component number for current seg */
		2 end_seg		 fixed bin (34),	/* in read state =
						   first byte beyond countents of current segment
						   in write state is same for moment write state
						   entered */
		2 read_pos	 fixed bin (34),	/* in read state =
						   next byte to be read, in write state is
						   same as end_seg */
		2 tail_len	 fixed bin (34),	/* in read state = number of
						   bytes remaining in current seg, in
						   write state = 0 */
		2 write_pos	 fixed bin (34),	/* in read state =
						   beyond_limits, in write state = next byte
						   to be written.  Hence write_pos = write_limit
						   is end of segment condition for writing */
		2 base_pos	 fixed (34),	/* absolute position of first byte in current seg */
		2 end_pos		 fixed (34),	/* in read state gives total byte count of file */
		2 input_only	 bit (1) aligned,	/* mode is stream_input */
		2 append_sw	 bit (1) aligned,	/* -append attach option used */
		2 no_trunc_sw	 bit (1) aligned,	/* -no_trunc option */
		2 header_is_present	 bit (1) aligned,	/* -header option */
		2 ssf_sw		 bit (1) aligned,	/* prevents growth to msf */
		2 is_msf		 bit (1) aligned,	/* set when msf opened */
		2 file_base_ptr	 ptr,
		2 noend		 bit (1) aligned,	/* -no_end attach option */
		2 old_write_pos	 fixed (34),	/* save of the previous write_pos to determine
						   if fast_put did any writing */
		2 current_state	 fixed bin;	/* what state the file is in at time of entry */
	dcl     close_x		 entry;
	dcl     code		 fixed bin (35);
	dcl     divide		 builtin;
	dcl     dummy_buffer	 char (1);
	dcl     error_table_$bad_file	 external fixed bin (35);
	dcl     error_table_$short_record
				 external fixed (35) static;
	dcl     (error_table_$incompatible_attach, error_table_$file_is_full, error_table_$no_operation,
	        error_table_$negative_nelem)
				 fixed (35) external static;
	dcl     error_table_$end_of_info
				 external fixed bin (35);
	dcl     error_table_$noentry	 external fixed bin (35);
	dcl     error_table_$long_record
				 external fixed bin (35);
	dcl     error_table_$bad_arg	 external fixed bin (35);
	dcl     fcb_ptr_arg		 ptr;
	dcl     first_seg_ptr	 ptr;
	dcl     first_seg_bitcount	 fixed bin (24);
	dcl     foo		 fixed bin (35);
	dcl     foo2		 fixed bin (2);
	dcl     foo24		 fixed bin (24);
	dcl     foo35		 fixed bin (35);
	dcl     free_cb_file	 entry (fixed bin, ptr);
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed (35));
	dcl     hcs_$truncate_seg	 entry (ptr, fixed (18), fixed (35));
	dcl     msf_manager_$open	 entry (char (*), char (*), ptr, fixed (35));
	dcl     hcs_$set_bc_seg	 entry (ptr,	/* ptr to segment */
				 fixed bin (24),	/* bitcount */
				 fixed bin (35));	/* status code */
	dcl     index		 builtin;
	dcl     is_new_file		 bit (1) aligned;
						/* for debugging
						   dcl ioa_ entry options (variable);
						*/
	dcl     iocb_ptr		 ptr;		/* for open and close entries this points to the actual iocb.
						   for other entries it points to an iocb that may be syned */
	dcl     len		 fixed bin (21);	/* length of string to be
						   moved in one operation */
	dcl     len2		 fixed bin (21);
	dcl     max_component_size	 fixed bin (19);
	dcl     min		 builtin;
	dcl     mode		 fixed bin;	/* = 1, 2, or 3 */
	dcl     msf_manager_$adjust	 entry (ptr,	/* fcb_ptr */
				 fixed bin,	/* component number of segment to be
						   made last segment */
				 fixed bin (24),	/* bitcount for that seg -- not reliable */
				 bit (3),		/* "010" =  don't set bit counts (use hcs_$set_bc_seg), truncate
						   segment, dont terminate components */
				 fixed bin (35));	/* status code */
	dcl     msf_manager_$get_ptr	 entry (ptr,	/* fcb_ptr */
				 fixed bin,	/* component number of desired segment */
				 bit (1),		/* create switch */
				 ptr,		/* ptr to seg or null if error, output */
				 fixed bin (24),	/* bitcount of segment, output */
				 fixed bin (35));	/* status code */
	dcl     null		 builtin;
	dcl     next_seg_ptr	 ptr;
	dcl     new_line		 static internal char (1) init ("
");
	dcl     old_pos		 fixed bin (21);
	dcl     pos_type		 fixed bin;
	dcl     record_read		 char (len) based (addr (seg (read_pos)));
	dcl     record_write	 char (len) based (addr (seg (old_pos)));
	dcl     rec_len		 fixed bin (21);
	dcl     seg		 (1048576) char (1) based (seg_ptr);
	dcl     skip		 fixed (34);
	dcl     size		 builtin;
						/* state variables */
	dcl     read_state		 fixed bin init (1);
	dcl     beyond_eof_state	 fixed bin init (2);
	dcl     write_state		 fixed bin init (3);
%include iocbv;

/* GENERAL COMMENTS
   This external procedure implements io to-from
   unstructured files.  The entries open and close are
   called from open_file and close_file, see vfile_attach .
   They setup (respectively free) the control block, which
   the other entries access through open_data_ptr
   in the actual iocb.  The other entries are called
   through the iocb.  The code for each entry immediately
   follows the entry and terminates with a return
   statement.

   Before reading the code, familiarize yourself with
   the general conventions for implementing attachments
   (see the MPM), and the specs for the operations.


   At the beginning (and again at the end) of an
   operation (e.g. get_line), the control block is
   in either the read state or the write state.
   See the declaration of cb_uns_file for details.
   The two states are distinguished by the value
   of write_pos, but there are other differences as well.

   The general method for each operation is to test for
   the nonexceptional case, control block in the
   correct state and the buffer not too long for
   the remainder of the segment.  In the exceptional
   cases some progress is made, i.e. some data is
   transferred, or the contro blocks state is
   changed, or a new segment is obtained.  Then
   the operation is completed by a recursive call. */

/* changes due to implimenting of the -no_end option:
   1. operations were changed to accept the idea of being beyond end-of-file (eof)
   2. the positioning to allow the changing of write_pos to be greater than the end_pos
   3. a way of identifying the state of the file
   4. a new state of the file was added: beyond eof
   5. the write_pos needed to be stored away in another place to be able to determine
   that fast_put had done some work, and therefore the file was in write state
   6. mostly in need of determining if there was a problem in msf_manager_
   changes were made to allow error codes other than expected to reflect through
*/
     end /* end of open_uns_file program */;




		    record_stream_attach_.pl1       09/10/87  1507.0rew 09/10/87  1445.7      176031



/****^  ***********************************************************
        *                                                         *
        * 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(84-08-22,Ranzenbach), approve(), audit(), install():
     Modified to call unique_chars_.
  2) change(87-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-09-10,GDixon),
     install(87-09-10,MR12.1-1104):
     Completely restructured the code. Added any_other handlers.
     Changed the close routine to always close the control block.
     Changed the detach routine to always detach the control block.
     Changed recursive call for -target attachment to a nonrecursive
     method.
                                                   END HISTORY COMMENTS */


/* format: off */
%page;
/* main program of record_stream_ io module */

record_stream_attach: proc (Piocb_ptr,	/* (input) - control block pointer  */
		        option_array, 
				/* (input) - control arguments      */
		        Pcom_err,	/* (input) - ON = report errors     */
		        Pcode);	/* (output)- error status	      */

       iocb_ptr = Piocb_ptr;
       Scom_err = Pcom_err;
       call initialize$attach();

       if iocb.attach_descrip_ptr ^= null then
	call CHECK_CODE_return_on_error (error_table_$not_detached, ME,
	"^a", iocb.name);

       call get_args ();

/* create and initialize rs attach block, with cleanup handler for block */

       rsab_ptr = null;
       on cleanup call record_stream_detach_ ();
       EXIT = EXIT_WITH_DETACH;

       call alloc_cb_file (size (rs_attach_block), rsab_ptr);

/* If the -target option is present. Attach the target descrip. */

       if target_args ^= "" then do;
	rs_attach_desc.switch_name =  "rs_" || unique_chars_ ("0"b);
	rs_attach_block.i_attached_target = TRUE;
	call iox_$attach_name (rs_attach_desc.switch_name,
	   rs_attach_block.target_iocb_ptr, (target_args), null, code);
	call CHECK_CODE_return_on_error (code, ME,
	   "Target attach description failed:^/^a",
	      target_args);
	end;

/* Otherwise, find target IOCB. */

       else do;
	rs_attach_block.i_attached_target = FALSE;
	call iox_$find_iocb (rs_attach_desc.switch_name,
	   rs_attach_block.target_iocb_ptr, code);
	call CHECK_CODE_return_on_error (code, ME,
	   "Looking for target IOCB ^a",
	   rs_attach_desc.switch_name);
	end;

       rs_attach_block.attach_descrip_string =
	rs_attach_desc.module_name 
	|| rtrim(rs_attach_desc.switch_name)
	|| rtrim(rs_attach_desc.args);
       rs_attach_block.attach_descrip_len = 
	length (rtrim (rs_attach_block.attach_descrip_string));

       rs_attach_block.target_name = rs_attach_desc.switch_name;
       rs_attach_block.length_n = arg_record_length;
       rs_attach_block.open_descrip_len = 0;
       rs_attach_block.open_descrip_string = "";
       rs_attach_block.mode = 0;
       rs_attach_block.i_opened_target = FALSE;
       rs_attach_block.base = 0;
       rs_attach_block.n_left = 0;

/* Set the iocb to the attach state */
       
       ips_mask = ""b;
       on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
       call hcs_$set_ips_mask ("0"b, ips_mask);
       iocb.attach_data_ptr = rsab_ptr;
       iocb.attach_descrip_ptr = addr (rs_attach_block.attach_descrip);
       iocb.detach_iocb = record_stream_detach;
       iocb.open = record_stream_open;
       iocb.modes = record_stream_modes;
       iocb.control = record_stream_control;

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

EXIT_BY_RETURN:
       return;

EXIT_WITH_DETACH:  
       call record_stream_detach_();
       return;
%page;
get_args: proc ();

       arg_record_length = 0;
       rs_attach_desc.module_name = ME;
       rs_attach_desc.switch_name = "";
       rs_attach_desc.args = "";
       target_args = "";

       do i = 1 to hbound (option_array, 1);

	code = 0;

	if option_array (i) = "-no_newline" | option_array (i) = "-nnl" then
	   arg_record_length = -1;
	else
	   if option_array (i) = "-length"
	      | option_array (i) = "-ln" then do;
	      if i + 1 > hbound (option_array, 1) then
	         call CHECK_CODE (error_table_$noarg, ME,
"^/^a requires a positive integer value.",
		  option_array (i));
	      else do;
	         i = i + 1;
	         arg_record_length =
		  cv_dec_check_ ((option_array (i)), ercode);
	         if ercode ^= 0
		  | arg_record_length <= 0
		  | arg_record_length > CHARS_PER_SEGMENT then
		  call CHECK_CODE (error_table_$bad_arg, ME,
"^/^a ^a.  The value must be a positive integer less than ^d.",
		  option_array (i - 1), option_array (i),
		  CHARS_PER_SEGMENT+1);
	         end;
	      end;

          else
	   if option_array (i) = "-target" then do;

/* Build the attach description for the target I/O module. */

	      if i + 1 > hbound (option_array, 1) then
	         call CHECK_CODE (error_table_$noarg, ME,
	         "^a requires an attach description operand.",
	         option_array(i));
	      else do;
	         i = i + 1;
	         target_args = target_args || option_array (i);
	         do i = i + 1 to hbound (option_array, 1);	
		  target_args = target_args || " ";
		  target_args =
		     target_args || requote_string_ ((option_array (i)));
		  end;
	         end;
	      end;

          else
	   if i = 1 then do;	/* switch name must be in position 1*/
	      if length (option_array (i)) >
	         length(rs_attach_desc.switch_name) then
	         call CHECK_CODE (error_table_$bigarg, ME,
"^/Target switch name value is longer than ^a characters: ^a.",
		  length(rs_attach_desc.switch_name), option_array (i));
	      else
	         rs_attach_desc.switch_name = option_array (i);
	      end;

	else
	   if index (option_array(i), "-") = 1 then
	      call CHECK_CODE (error_table_$bad_opt, ME,
	   "^a", option_array (i));

          else
	   call CHECK_CODE (error_table_$bad_arg, ME,
	   "^a", option_array (i));
	end;

       if rs_attach_desc.switch_name = "" then do;
	if target_args = "" then
	   call CHECK_CODE (error_table_$noarg, ME, "Target switch name");
          end;
       else
	if target_args ^= "" then
	   call CHECK_CODE (error_table_$bad_arg, ME,
"^/Cannot give both a target switch name and -target attach description.");

       if Serror_occurred then 
	go to EXIT;

       if arg_record_length < 0 then	/* leading space separates switch    */
	rs_attach_desc.args = " -nnl";/* name from control args in attach  */
       else			/* description.		       */
	if arg_record_length > 0 then		
	   rs_attach_desc.args =			
	      " -length " || ltrim (char (arg_record_length));

       return;
       end get_args;
%page;
record_stream_open: entry (Piocb_ptr,	/* (input) - control block pointer  */
		       open_mode,	/* (input) - opening mode(sqi etc.) */
		       Sextend,	/* (input) - ON = add to the file   */
		       Pcode);	/* (output)- error status	      */

       dcl open_mode		fixed bin parameter,
	 Sextend			bit (1) aligned parameter;

       call initialize;
				/* verify open args & set descript. */

       if open_mode < lbound (iox_modes, 1)
	| open_mode > hbound(iox_modes, 1)
	| Sextend then
	call CHECK_CODE_return_on_error (error_table_$bad_arg, ME);

       else
	if open_mode = Stream_input_output
	   | open_mode > Sequential_output then
	   call CHECK_CODE_return_on_error (error_table_$bad_mode, ME);

       else
	if open_mode = Stream_output | open_mode = Sequential_input then do;
	   if rs_attach_block.length_n < 0 then
	      call CHECK_CODE_return_on_error (
	      error_table_$invalid_record_length, ME);
	   end;

       else
	if open_mode = Sequential_output | open_mode = Stream_input then do;
	   if rs_attach_block.length_n > 0 then
	      call CHECK_CODE_return_on_error (
	      error_table_$invalid_record_length, ME);
	   end;

/* The open_mode is valid set the open description */

       rs_attach_block.mode = open_mode;
       rs_attach_block.open_descrip_len =
	length (rtrim (iox_modes (open_mode)));
       rs_attach_block.open_descrip_string = iox_modes (open_mode);
%page;
/* If the target switch exists, find out how the targets was opened. */
       
       if rs_attach_block.target_iocb_ptr = null then
	call CHECK_CODE_return_on_error (error_table_$no_iocb, ME);

       target_open_mode_ptr =
	rs_attach_block.target_iocb_ptr -> iocb.open_descrip_ptr;

       if target_open_mode_ptr ^= null then
	target_open_mode = before (target_open_mode, SPACE);

/* If switch is its own target report the error -- looping attachment */

       if iocb_ptr -> iocb.actual_iocb_ptr
	= rs_attach_block.target_iocb_ptr -> iocb.actual_iocb_ptr then
	   call CHECK_CODE_return_on_error (error_table_$att_loop, ME);

/* Set i_opened_target before the cleanup handler. */

       if rs_attach_block.target_iocb_ptr -> iocb.open_descrip_ptr = null then
	rs_attach_block.i_opened_target = TRUE;

       on cleanup call record_stream_close_ ();
       EXIT = EXIT_WITH_CLOSE;

/* If not open, open the target switch else check its current open mode. */
/* Open the target switch using the opposite mode of what was input. */

       if rs_attach_block.i_opened_target then
	call iox_$open (rs_attach_block.target_iocb_ptr,
	   (op_mode (rs_attach_block.mode)), "0"b, code);

       else			/* target already opened            */
	if (target_open_mode ^= iox_modes (op_mode (rs_attach_block.mode)))
	   & (target_open_mode ^= iox_modes (op_io_mode (rs_attach_block.mode))) then
	   code = error_table_$incompatible_attach;

       call CHECK_CODE_return_on_error (code, ME);
%page;
/* Non-Sequential outputs require an internal buffer. */

       if rs_attach_block.mode ^= Sequential_output then do;
	call get_temp_segment_ (ME, iocb.open_data_ptr, code);
	call CHECK_CODE_return_on_error (code, ME);
	end;

/* call initialization routine appropriate to opening mode */

       ips_mask = ""b;
       on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
       call hcs_$set_ips_mask ("0"b, ips_mask);

       if rs_attach_block.mode = Stream_input then
	call rs_open_str_in_ (iocb_ptr);
       else
	if rs_attach_block.mode = Stream_output then
	   call rs_open_str_out_ (iocb_ptr);
       else
	if rs_attach_block.mode = Sequential_input then
	   call rs_open_seq_in_ (iocb_ptr);
       else
	call rs_open_seq_out_ (iocb_ptr);

/* Set up the iocb entries */

       iocb.open_descrip_ptr = addr (rs_attach_block.open_descrip);
       iocb.close = record_stream_close;

       call iox_$propagate (iocb_ptr);

       call hcs_$reset_ips_mask (ips_mask, ips_mask);
       return;

EXIT_WITH_CLOSE:
       call record_stream_close_();
       return;
%page;
record_stream_close: entry (Piocb_ptr,	/* (input) control block pointer   */
		        Pcode);	/* (output) error status	     */

       call initialize;
       call record_stream_close_ ();
       call CHECK_CODE_return_on_error (code, ME);
       return;


record_stream_close_: proc ();

/* This is an internal procedure so that the open entry can use it
   in its cleanup handler. */

/* If Stream_output, the target is open for sequential output. Flush the
   temp work buffer. */

       if rs_attach_block.mode ^= Sequential_output then do;

	if rs_attach_block.mode = Stream_output
	   & rs_attach_block.n_left > 0 then
	   call iox_$write_record (rs_attach_block.target_iocb_ptr,
	      iocb.open_data_ptr, rs_attach_block.n_left, code);

	if iocb.open_data_ptr ^= null then
	   call release_temp_segment_ (ME, iocb.open_data_ptr, ercode);
	end;

       if rs_attach_block.i_opened_target then do;
	call iox_$close (rs_attach_block.target_iocb_ptr, ercode);
	if code = 0 then
	   code = ercode;
	end;

       ips_mask = ""b;
       on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
       call hcs_$set_ips_mask ("0"b, ips_mask);

       iocb.open_descrip_ptr = null;
       iocb.open_data_ptr = null;
       iocb.detach_iocb = record_stream_detach;
       iocb.open = record_stream_open;

       call iox_$propagate (iocb_ptr);

       call hcs_$reset_ips_mask (ips_mask, ips_mask);
       return;
       end record_stream_close_;
%page;
record_stream_detach: entry (Piocb_ptr, /* (input) - control block pointer  */
		         Pcode);	/* (output)- error status	      */

       call initialize();		  
       call record_stream_detach_ ();
       call CHECK_CODE_return_on_error (code, ME);
       return;

record_stream_detach_: proc ();

/* This is an internal procedure so that the attach entry can use it
   in its cleanup handler. */

/* detach target if it was attached with the -target option */

       if rsab_ptr = null then
	return;
	
       if rs_attach_block.i_attached_target then do;
	call iox_$detach_iocb (rs_attach_block.target_iocb_ptr, code);
	call iox_$destroy_iocb (rs_attach_block.target_iocb_ptr, ercode);
	end;

       ips_mask = ""b;
       on any_other call hcs_$reset_ips_mask (ips_mask, ips_mask);
       call hcs_$set_ips_mask ("0"b, ips_mask);

       iocb.attach_data_ptr = null;
       iocb.attach_descrip_ptr = null;

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

       call free_cb_file (size (rs_attach_block), rsab_ptr);
       rsab_ptr = null;

       return;
       end record_stream_detach_;
%page;
record_stream_modes: entry (Piocb_ptr,	/* (input) - control block pointer  */
		        new_modes,	/* (input) - modes to set to        */
		        old_modes,	/* (output)- current modes	      */
		        Pcode);	/* (output)- error status	      */

       dcl new_modes		char (*) parameter,
	 old_modes		char (*) parameter;

       call initialize;
       call iox_$modes (rs_attach_block.target_iocb_ptr, new_modes, old_modes,
	Pcode);
				/* pass call to target              */
       return;
%page;
record_stream_control: entry (Piocb_ptr,/* (input) - control block pointer  */
		          order,    /* (input) - requested order	      */
			info_ptr, /* (input) - info for the control et*/
			Pcode);	/* (output)- error status           */

       dcl order			char(*) parameter,
	 info_ptr			ptr parameter;

       call initialize;
       call iox_$control (rs_attach_block.target_iocb_ptr, order, info_ptr,
	Pcode);
				/* pass call to target              */
       return;
%page;
initialize: proc;
/* internal procedure for initializing pointers and other variables */

       iocb_ptr = Piocb_ptr -> iocb.actual_iocb_ptr;
       rsab_ptr = iocb.attach_data_ptr;
       Scom_err = FALSE;

initialize$attach:
       entry;

       Pcode, code = 0;
       Serror_occurred = FALSE;
       EXIT = EXIT_BY_RETURN;
       return;

       end initialize;
%page;
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*							       */
/* This procedure examines its code parameter.  If it is nonzero, it sets    */
/* the code output parameter of the current external entrypoint.  It	       */
/* optionally prints an error message.  Execution stops (via nonlocal goto)  */
/* for nonzero codes passed to CHECK_CODE_return_on_error.  If code is 0,    */
/* these programs do nothing but return to their caller.		       */
/*							       */
/* Syntax:  call CHECK_CODE (code, program_name, ioa_ctl_str, ioa_args);     */
/*	  call CHECK_CODE_return_on_error			       */
/*	       (code, program_name, ioa_ctl_str, ioa_args);	       */
/*							       */
/* *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

CHECK_CODE:
       proc options(variable);

       dcl error_code		fixed bin(35) based (p_error_code),
	 p_error_code		ptr;

       dcl Sfatal			bit (1) aligned;

       dcl cu_$arg_list_ptr		entry returns(ptr),
	 cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21),
				      fixed bin(35)),
           cu_$generate_call		entry (entry, ptr);

       Sfatal = FALSE;
       go to ERROR_COMMON;

CHECK_CODE_return_on_error:
       entry options (variable);
       
       Sfatal = TRUE;

ERROR_COMMON:

       call cu_$arg_ptr (1, p_error_code, 0, 0);
       if error_code = 0 then return;
       if Pcode = 0 then		/* set output code parameter if it   */
	Pcode = error_code;		/*  hasn't been set before.	       */

       if Scom_err then
	call cu_$generate_call (com_err_, cu_$arg_list_ptr());

       Serror_occurred = TRUE;
       if Sfatal then
	go to EXIT;
       return;
       end CHECK_CODE;
%page;
/* parameters */

       dcl Piocb_ptr		ptr parameter,
	 Pcom_err			bit (1) aligned parameter,
	 Pcode			fixed bin (35) parameter,
	 option_array(*)		char (*) varying parameter;

/* automatic */

       dcl EXIT			label variable,
	 Scom_err			bit (1) aligned,
	 Serror_occurred		bit (1) aligned,
	 arg_record_length		fixed bin (35),
	 code			fixed bin(35),
	 ercode			fixed bin (35),
	 i			fixed bin,
	 ips_mask			bit(36) aligned,
           1 rs_attach_desc		aligned,
	   2 module_name		char (15),
	   2 switch_name		char (32) unal,
	   2 args			char (20),
           target_args		char (1024) varying;

/* based */

       dcl target_open_mode_ptr	ptr,
	 target_open_mode		char (24) varying
				based (target_open_mode_ptr);

/* entries */

       dcl alloc_cb_file		entry (fixed bin, ptr),
	 cv_dec_check_		entry (char(*), fixed bin(35)) returns(fixed bin(35)),
	 com_err_			entry() options(variable),
	 get_temp_segment_		entry (char(*), ptr, fixed bin(35)),
	 free_cb_file		entry (fixed bin, ptr),
	 hcs_$reset_ips_mask	entry (bit(36) aligned, bit(36) aligned),
	 hcs_$set_ips_mask		entry (bit(36) aligned, bit(36) aligned),
	 release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
           requote_string_		entry (char(*)) returns(char(*)),
	 rs_open_seq_in_		entry (ptr),
	 rs_open_seq_out_		entry (ptr),
	 rs_open_str_in_		entry (ptr),
	 rs_open_str_out_		entry (ptr),
	 unique_chars_		entry (bit(*)) returns(char(15));

/* external static */  

       dcl (error_table_$att_loop,
	 error_table_$bad_arg,
	 error_table_$bad_opt ,
	 error_table_$bad_mode,	
	 error_table_$bigarg,
	 error_table_$incompatible_attach,
	 error_table_$invalid_record_length,
	 error_table_$no_iocb,
	 error_table_$noarg,
	 error_table_$not_detached)	fixed bin(35) ext static;

/* internal static */  

       dcl FALSE			bit (1) aligned internal static
				options (constant) init ("0"b);

       dcl ME			char (14) internal static
				options (constant) 
				init ("record_stream_");

       dcl TRUE			bit (1) aligned internal static
				options (constant) init ("1"b);

       dcl SPACE			char (1) aligned internal static
				options (constant) init (" ");

       dcl op_io_mode (5)		fixed bin internal static options
				(constant) init (6, 6, 6, 3, 3);

       dcl op_mode (5)		fixed bin internal static options
				(constant) init (4, 5, 6, 1, 2);

/* builtins */

       dcl (addr, before, char, hbound, index, lbound, length, ltrim, null,
	 rtrim, size)		builtin;

/* conditions */

       dcl (any_other, cleanup)	condition;
%page;
%include rs_attach_block;
%page;
       dcl iocb_ptr			ptr;
%include iocbv;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include system_constants;
%page;
%include sub_err_flags;

end record_stream_attach;




		    restart.pl1                     10/16/90  1526.9rew 10/16/90  1518.1      135540



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






/****^  HISTORY COMMENTS:
  1) change(90-10-12,Zimmerman), approve(90-10-12,MCR8216),
     audit(90-10-15,Zwick), install(90-10-16,MR12.4-1043):
     Data_Mgt 63 (phx21194): Raise the max number of components in an MSF to
     1250.
                                                   END HISTORY COMMENTS */




restart:
     proc (iocb_ptr, code);				/* tries to complete interrupted operation */
	indx_cb_ptr = open_data_ptr;
	f_b_ptr = file_base_ptr;
	fs_ptr = file_state_ptr;
	call save_restart_proc_info;
	on cleanup
	     call restore_restart_proc_info;
	indx_cb.mode = 10;				/* ksu */
	indx_cb.min_res = saved_min_res;
	indx_cb.min_cap = saved_min_cap;
	indx_cb.outside_index = file_base.out_of_index;
	indx_cb.current_descrip = file_base.old_record_designator;
	indx_cb.stat = file_base.was_stat;
	indx_cb.trans = "0"b;
	repeating = "1"b;
	indx_cb.shared = "0"b;
	indx_cb.subset_selected = "00"b;
	indx_cb.current_record_is_valid = "1"b;
	pos_incorrect = "0"b;
	indx_cb.dup_ok = "1"b;
	indx_cb.next_record_position = 1;
	if (file_action = adjust_action) | (file_action = rollback_action)
	then do;
		if ^((file_action = rollback_action) & (file_base.old_prev_mod = -3) & (file_base.old_ref_count <= 0))
						/* not total collection of storage */
		then call lock_record (file_base.old_record_designator);
		call open_indx_file$adjust_record (iocb_ptr, file_base.old_record_designator, 0, code);
	     end;
	else if file_action = replace_action
	then call restart_replacement;
	else if file_action = reassigning_key
	then call restart_reassignment;
	else do;
		call restore_old_proc_info;
		if file_action = insert_action
		then call restart_insertion;
		else if file_action = delete_action
		then do;
			if file_base.was_stat
			     & (file_base.is_partial_deletion | (file_base.old_modifier > 0)
			     | (file_base.old_ref_count > fixed (^file_base.out_of_index)))
						/*
						   not case of total collection, including stationary header */
			then call lock_record (file_base.old_record_designator);
						/* else protect this storage--don't clobber free list */
			call open_indx_file$delete_indx_file (iocb_ptr, code);
		     end;
		else if file_action = adding_key
		then call restart_add_key;
		else if file_action = deleting_key
		then do;
			indx_cb.outside_index = "0"b;
			if file_base.was_stat	/* watch out for low level synch */
			then call lock_record (file_base.old_record_designator);
			call open_indx_file$control_indx_file (iocb_ptr, "delete_key", null, code);
		     end;
		else if file_action = adding_record
		then call restart_rs_create;
		else if file_action = bumping_count
		then do;
			file_base.change_count = file_base.old_file_ch_count + 1;
			file_action = 0;
		     end;
		else code = error_table_$bad_file;
	     end;
	call restore_restart_proc_info;
	if indx_cb.file_state_ptr -> file_action = 0
	then code = 0;
	else if code = 0
	then code = error_table_$bad_file;
	return;					/* end of restart routine */

save_restart_proc_info:
     proc;
	saved_state = indx_cb.state_vars;
	saved_subset_selected = indx_cb.subset_selected;
	was_ks_out = is_ks_out;
	my_min_res = indx_cb.min_res;
	my_min_cap = indx_cb.min_cap;
	was_stat = indx_cb.stat;
	was_dup_ok = indx_cb.dup_ok;
	was_trans = indx_cb.trans;
	old_mode = indx_cb.mode;
	return;

restore_restart_proc_info:
     entry;
	indx_cb.state_vars = saved_state;
	indx_cb.subset_selected = saved_subset_selected;
	repeating = "0"b;
	is_ks_out = was_ks_out;
	indx_cb.min_res = my_min_res;
	indx_cb.min_cap = my_min_cap;
	file_base.max_comp_num = true_max_comp_num;
	indx_cb.pos_incorrect = "1"b;
	indx_cb.stat = was_stat;
	indx_cb.dup_ok = was_dup_ok;
	indx_cb.trans = was_trans;
	indx_cb.mode = old_mode;
     end save_restart_proc_info;

restore_old_proc_info:
     proc;
	if ^(indx_cb.outside_index & ((file_action = delete_action) | (file_action = adding_record)))
	then do;					/* restore position stack */
		is_ptr = index_state_ptr;
		p = root_position_ptr;
		file_position_ptr = p;
		change_position_ptr = p;

		do i = 1 to index_height;
		     p = p -> son_position_ptr;
		     p -> node = saved_node (i);
		     p -> branch_num = saved_branch_num (i);
		     p -> node_ptr = get_ptr (p -> node);
		     if p -> node = current_node
		     then file_position_ptr = p;
		     if p -> node = change_node
		     then change_position_ptr = p;
		end;

	     end;
	is_ks_out = saved_ks_out;
	indx_cb.ready_to_write = "1"b;
	dcl     p			 ptr;
	dcl     i			 fixed;
     end restore_old_proc_info;

restart_add_key:
     proc;					/* recovers from interrupted add_key operation */
	indx_cb.current_descrip = file_base.new_descriptor;
	if file_base.was_stat
	then call lock_record (indx_cb.current_descrip);
	indx_cb.outside_index = "0"b;
	string (ak_inf.flags) = "00"b;
	call open_indx_file$control_indx_file (iocb_ptr, "add_key", addr (ak_inf), code);
     end restart_add_key;

restart_rs_create:
     proc;					/* finish allocation, then delete */
	if file_base.out_of_index			/* no key with the record--always delete since user can't find this record */
	then do;
		if file_substate = 0
		then indx_cb.repeating = "0"b;
		else indx_cb.next_substate = 0;
		call change_record_list (iocb_ptr, allocate_action, null, abort_exit);
		file_base.old_record_designator = file_base.new_descriptor;
		file_base.old_ref_count = 0;
		file_base.change_count = file_base.old_file_ch_count + 1;
		call change_record_list (iocb_ptr, delete_action, null, abort_exit);
		file_action = 0;
		return;
	     end;
	if file_base.was_stat
	then call lock_record (file_base.new_descriptor);
	rs_inf.record_length = new_record_length;
	rs_inf.max_rec_len = saved_min_cap;
	unspec (rs_inf.flags) = "0"b;
	rs_inf.inc_ref_count = (file_base.was_stat & (file_base.old_ref_count = 2));
	rs_inf.create_sw = "1"b;
	rs_inf.locate_sw = out_of_index;
	rs_inf.version = rs_info_version_2;
	call open_indx_file$control_indx_file (iocb_ptr, "record_status", addr (rs_inf), code);
     end restart_rs_create;

restart_replacement:
     proc;					/* finish interrupted replace operation */
	call reinit_rewrite_proc;
	if ^file_base.was_stat			/* non-stationary type record rewritten */
	then do;					/* see if contents may be invalid */
		old_rec_ptr = get_rec_ptr (old_record_designator);
		if (fixed (old_rec_des.offset) + 2 + divide (new_record_length + 3, 4, 21, 0)) > max_seg_limit
		then new_rec_ptr = file_base_ptr;	/* avoids seg_fault */
		else new_rec_ptr = old_rec_ptr;
		if ((old_record_length ^= new_record_length) | (file_substate > 1)
		     | (old_record_designator ^= new_descriptor)) & (new_record_length > 0)
		then if ^indx_cb.outside_index
		     then call sub_err_ (0, "vfile_", "c", null, code, "Record contents may be incorrect for key: ^a",
			     substr (keys, key_pos (branch_num), key_length (branch_num)));
		     else call sub_err_ (0, "vfile_", "c", null, code,
			     "Record contents may be incorrect for record with descriptor: ^o", old_record_designator);
	     end;
	else do;
		call lock_record (file_base.old_record_designator);
		if file_base.change_count = file_base.old_file_ch_count
						/* op will be undone */
		then do;				/* undo the rewrite--old stuff still is intact */
			if file_base.new_record_length + indx_cb.min_res + indx_cb.min_cap > 0
			then do;
				if file_substate = 1
				then indx_cb.repeating = "0"b;
				else indx_cb.next_substate = 1;
				call change_record_list (iocb_ptr, allocate_action, f_b_ptr, abort_exit);
				call change_record_list (iocb_ptr, free_action, null, abort_exit);
			     end;
			block_ptr -> stat_block.lock_flag = "0"b;
			block_ptr -> stat_structure.modifier = -1;
			file_action = bumping_count;
			file_base.change_count = file_base.old_file_ch_count + 1;
			file_action = 0;
						/* now just unlock the record */
			block_ptr = get_pointer (file_base.old_record_designator);
			block_ptr -> stat_block.modifier = 0;
			if stacq (block_ptr -> stat_block.record_lock, "0"b, indx_cb.saved_lock_copy)
						/* clear record lock */
			then ;
			return;
		     end;
		else if file_base.new_descriptor > 0
		then new_rec_ptr = get_rec_ptr (file_base.new_descriptor);
		else new_rec_ptr = null;
	     end;
	call open_indx_file$rewrite_indx_file (iocb_ptr, new_rec_ptr, new_record_length, code);
     end restart_replacement;

reinit_rewrite_proc:
     proc;					/* set up position info */
	file_position_ptr = root_position_ptr -> son_position_ptr;
	node = first_branch;
	branch_num = count;
	node_ptr = get_ptr (node);
     end reinit_rewrite_proc;

restart_reassignment:
     proc;
	if file_base.was_stat
	then do;
		block_ptr = get_pointer (file_base.old_record_designator);
		if block_ptr ^= null
		then if block_ptr -> record_block_structure.stationary
		     then call lock_record (file_base.old_record_designator);
		new_block_ptr = get_pointer (file_base.new_descriptor);
		if new_block_ptr ^= null
		then if new_block_ptr -> record_block_structure.stationary
		     then call lock_record (file_base.new_descriptor);
	     end;
	indx_cb.outside_index = "0"b;
	string (rk_inf.flags) = "001"b;		/* input new descrip */
	rk_inf.new_descrip = file_base.new_descriptor;
	call reinit_rewrite_proc;			/* finds index position */
	call open_indx_file$control_indx_file (iocb_ptr, "reassign_key", addr (rk_inf), code);
     end restart_reassignment;

restart_insertion:
     proc;					/* finish interrupted write operation */
	if file_base.change_count = file_base.old_file_ch_count
						/* buffer may not be saved yet */
	then do;					/* undo any allocation */
		if file_base.was_stat
		     | (file_base.new_record_length + file_base.saved_min_cap + file_base.saved_min_res > 0)
						/* allocation was required */
		then do;				/* restart, then reverse */
			if file_substate = 1
			then indx_cb.repeating = "0"b;
			else indx_cb.next_substate = 1;
						/* tracking variable--set_add_ent_info routine must have been used */
			call change_record_list (iocb_ptr, insert_action, null, abort_exit);
			file_base.old_record_designator = file_base.new_descriptor;
			file_base.out_of_index = "0"b;
			file_base.is_partial_deletion = "0"b;
			call change_record_list (iocb_ptr, delete_action, null, abort_exit);
		     end;
		file_action = bumping_count;
		file_base.change_count = file_base.old_file_ch_count + 1;
		file_action = 0;
		return;
	     end;
	if file_base.new_descriptor <= 0
	then new_rec_ptr = null;
	else do;
		new_rec_ptr = get_rec_ptr (file_base.new_descriptor);
		if file_base.was_stat
		then new_rec_ptr = addrel (new_rec_ptr, 6);
						/* larger header */
	     end;
	call open_indx_file$write_indx_file (iocb_ptr, new_rec_ptr, new_record_length, code);
     end restart_insertion;

get_ptr:
     proc (designator_arg) returns (ptr);
	return (addr (seg_ptr_array (des_arg.comp_num) -> seg_array (fixed (des_arg.offset))));
	dcl     designator_arg	 fixed (35);
	dcl     1 des_arg		 like designator_struct aligned based (addr (designator_arg));
     end;

get_rec_ptr:
     proc (designator_arg) returns (ptr);
	return (addrel (get_pointer (designator_arg), 2));
	dcl     designator_arg	 fixed (35);
     end get_rec_ptr;

get_pointer:
     proc (designator_arg) returns (ptr);
	return (addr (get_seg_ptr (iocb_ptr, (des_arg.comp_num)) -> seg_array (fixed (des_arg.offset))));
	dcl     designator_arg	 fixed (35);
	dcl     1 des_arg		 like designator_struct aligned based (addr (designator_arg));
     end get_pointer;

lock_record:
     proc (designator_arg);
	if designator_arg <= 0
	then return;
	blockp = get_pointer (designator_arg);
	if blockp = null
	then return;
	call set_lock_$lock (blockp -> stat_structure.record_lock, 0, code);
	if (code = 0) | (code = error_table_$invalid_lock_reset) | (code = error_table_$locked_by_this_process)
	then do;
		code = 0;
		return;
	     end;
	if file_action = reassigning_key
	then if block_ptr ^= null
	     then if block_ptr -> record_block_structure.stationary
		then if stacq (block_ptr -> stat_structure.record_lock, (36)"1"b, indx_cb.saved_lock_copy)
		     then ;			/* invalidate other lock, if I set it */
	code = error_table_$file_busy;
	call restore_restart_proc_info;
	go to exit;
	dcl     designator_arg	 fixed (35);
	dcl     blockp		 ptr;
     end lock_record;

abort_exit:
	code = error_table_$file_is_full;
	call restore_restart_proc_info;
	if (file_action ^= replace_action)
	then return;
	block_ptr = get_pointer (file_base.old_record_designator);
	if stacq (block_ptr -> stat_block.record_lock, (36)"1"b, indx_cb.saved_lock_copy)
	then ;					/* invalidate record lock */
exit:
	return;					/* abort with error code set */

	dcl     current_program_version
				 static options (constant) internal fixed init (31);
	dcl     block_ptr		 ptr;
	dcl     new_block_ptr	 ptr;
	dcl     1 stat_block	 based (block_ptr),
		2 pad		 bit (22) unal,
		2 lock_flag	 bit (1) unal,
		2 pad2		 bit (13) unal,
		2 word,
		2 record_lock	 bit (36) aligned,
		2 modifier	 fixed (35);
%include rs_info;
%include ak_info;
	dcl     1 rk_inf,
		2 header		 like rk_header;
	dcl     1 ak_inf		 based (addr (rk_inf)),
		2 header		 like ak_header;
	dcl     1 rs_inf		 like rs_info;
	dcl     sub_err_		 entry options (variable);
%include vfile_error_codes;
	dcl     pos_ptr		 ptr defined (file_position_ptr);
	dcl     code		 fixed (35);
	dcl     iocb_ptr		 ptr;
	dcl     open_indx_file$rewrite_indx_file
				 entry (ptr, ptr, fixed (21), fixed (35));
	dcl     open_indx_file$adjust_record
				 entry (ptr, fixed (35), fixed (35), fixed (35));
	dcl     open_indx_file$write_indx_file
				 entry (ptr, ptr, fixed (21), fixed (35));
	dcl     open_indx_file$delete_indx_file
				 entry (ptr, fixed (35));
	dcl     open_indx_file$control_indx_file
				 entry (ptr, char (*), ptr, fixed (35));
	dcl     (old_rec_ptr, new_rec_ptr)
				 ptr;
	dcl     1 old_rec_des	 like designator_struct aligned based (addr (old_record_designator));
	dcl     was_ks_out		 bit (1) aligned;
	dcl     saved_subset_selected	 bit (2) aligned;
	dcl     my_min_res		 fixed (21);
	dcl     my_min_cap		 fixed (19);
	dcl     was_stat		 bit (1) aligned;
	dcl     was_dup_ok		 bit (1) aligned;
	dcl     was_trans		 bit (1) aligned;
	dcl     1 saved_state	 like indx_cb.state_vars;
	dcl     old_mode		 fixed;
%include iocbv;
%include vfile_indx;
	dcl     cleanup		 condition;
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed, fixed (35));
          dcl     (addrel, stacq, string) builtin;

     end restart;




		    rs_open_seq_in_.pl1             09/10/87  1507.0r w 09/10/87  1448.2       56520



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


/* record_stream_ program for handling sequential input openings */
rs_open_seq_in_:
     proc (iocb_ptr_arg, code);
	iocb_ptr = iocb_ptr_arg;
						/* set entries in iocb for valid operations in this mode */
	read_record = read_record_rs;
	read_length = read_length_rs;
	position = position_seq_rs;
	return;					/* end of opening routine */

read_record_rs:
     entry (iocb_ptr_arg, buff_ptr_arg, buff_len, rec_len, code);
	call initialize;
	buff_ptr = buff_ptr_arg;
	if n_left ^= 0
	then /* internal buffer contains a record */
	     do;					/* get record from rs_buffer */
		if n_left > 0
		then rec_len = n_left;
		else rec_len = 0;
		n_left = 0;			/* set rs_buffer empty */
		if rec_len > buff_len
		then code = error_table_$long_record;
		n_moved = min (rec_len, buff_len);
		if n_moved > 0
		then substr (buffer, 1, n_moved) = substr (rs_buffer, 1, n_moved);
	     end;					/* record moved between buffers */

	else /* rs_buffer empty */
	     if length_n > 0
	then do;					/* -length n case */
		rec_len = 0;
		n_asked = min (buff_len, length_n);
get_data:
		call iox_$get_chars (target_iocb_ptr, buff_ptr, n_asked, n_read, code);
		rec_len = rec_len + n_read;
		if code ^= 0
		then if code = error_table_$short_record
		     then do;			/* pick up more chars */
			     n_asked = n_asked - n_read;
			     buff_ptr = addr (buff (n_read + 1));
			     go to get_data;
			end;
		     else go to eof_exit;
		else /* no errors yet */
		     if length_n > buff_len
		then /* long record case unless we are at EOF */
		     do;				/* munch past record tail */
			n_extra = length_n - buff_len;
			call iox_$get_chars (target_iocb_ptr, rs_buff_ptr, n_extra, n_read, code);
			rec_len = rec_len + n_read;
			if n_read > 0
			then code = error_table_$long_record;
			else if code = error_table_$end_of_info
			then code = 0;		/* short last record is OK */
		     end;
	     end;					/* end of -length n case */

	else do;					/* default case */
		call iox_$get_line (target_iocb_ptr, buff_ptr_arg, buff_len, rec_len, code);
		if code = 0
		then rec_len = rec_len - 1;		/* delete newline char */
		else if code ^= error_table_$long_record
		then do;				/* check for short record */
eof_exit:
			if rec_len > 0
			then code = 0;
		     end;				/* done */
		else do;				/* line is longer than input buffer */
			call iox_$get_chars (target_iocb_ptr, addr (next_char), 1, n_read, code);
			if code = 0
			then if substr (next_char, 1, 1) = newline
						/* avoids compiler bug */
			     then return;		/* normal return */
			     else do;		/* munch record tail */
				     rec_len = rec_len + 1;
				     call iox_$get_line (target_iocb_ptr, rs_buff_ptr, max_bufsize, n_read, code);
				     rec_len = rec_len + n_read;
				end;
			code = error_table_$long_record;
		     end;				/* entire record processed */
	     end;					/* end of default case */
	return;					/* end of read record routine */


read_length_rs:
     entry (iocb_ptr_arg, rec_len, code);
	call initialize;
	if n_left = 0				/* rs_buffer is empty */
	then do;					/* get a new record */
		call read_record_rs (iocb_ptr, rs_buff_ptr, max_bufsize, n_left, code);
		if (n_left = 0) & (code = 0)
		then n_left = -1;
	     end;
	if n_left > 0
	then rec_len = n_left;
	else rec_len = 0;
	return;					/* end of read length routine */

position_seq_rs:
     entry (iocb_ptr_arg, type, count, code);
	call initialize;
	n = count;
	if type ^= 0
	then do;					/* bof and eof cases */
		n_left = 0;			/* discard rs_buffer contents */
pass_call:
		call iox_$position (target_iocb_ptr, type, n, code);
						/* pass call to target */
	     end;
	else do;					/* skip case */
		if n ^= 0
		then do;				/* skip n records */
			old_n_left = n_left;
			if n_left ^= 0
			then do;			/* skip record in rs_buffer */
				n = n - 1;
				n_left = 0;
			     end;
			if length_n = 0		/* default case */
			then go to pass_call;
			else /* -length case */
			     if n < 0
			then do;			/* error: no backwards skips */
				code = error_table_$negative_nelem;
				n_left = old_n_left;/* restore rs_buffer */
			     end;
			else /* read past n records */
			     do while ((n > 0) & (code = 0));
				call read_record_rs (iocb_ptr, rs_buff_ptr, max_bufsize, n_read, code);
				n = n - 1;
			     end;
		     end;				/* n records skipped */
	     end;					/* end of skip case */
	return;					/* end of seq position routine */

/* internal procedure for initializing pointers upon entry */
initialize:
     proc;
	iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr;
	rsab_ptr = attach_data_ptr;
	rs_buff_ptr = open_data_ptr;
	code = 0;
	return;

     end initialize;

/* declarations for entire program */
	dcl     (iocb_ptr_arg, iocb_ptr)
				 ptr;
	dcl     code		 fixed bin (35);
%include iocbv;
%include rs_attach_block;
%include rs_buffer;
	dcl     (buff_ptr_arg, buff_ptr)
				 ptr;
	dcl     (buff_len, rec_len, n_moved)
				 fixed (21);
	dcl     (substr, min, addr)	 builtin;
	dcl     error_table_$long_record
				 external fixed (35);
	dcl     error_table_$short_record
				 external fixed (35);
	dcl     (n_asked, n_read)	 fixed (21);
	dcl     iox_$get_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     buffer		 char (buff_len) based (buff_ptr);
	dcl     buff		 (buff_len) char (1) based (buff_ptr);
	dcl     n_extra		 fixed (21);
	dcl     error_table_$end_of_info
				 external fixed (35);
	dcl     next_char		 char (2);
	dcl     newline		 char (1) static internal aligned init ("
");
	dcl     type		 fixed;
	dcl     (count, n, old_n_left) fixed (21);
	dcl     iox_$position	 entry (ptr, fixed, fixed (21), fixed (35));
	dcl     error_table_$negative_nelem
				 external fixed (35);
	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));

     end rs_open_seq_in_;




		    rs_open_seq_out_.pl1            09/10/87  1507.0r w 09/10/87  1447.6       14607



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


/* record_stream_ program for handling sequential output openings */
rs_open_seq_out_:
     proc (iocb_ptr_arg);
	iocb_ptr = iocb_ptr_arg;
						/* set iocb entries for valid operations in this mode and return */
	write_record = write_record_rs;
	return;					/* end of opening routine */

write_record_rs:
     entry (iocb_ptr_arg, buff_ptr, buff_len, code);
	iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr;
	rsab_ptr = attach_data_ptr;
	call iox_$put_chars (target_iocb_ptr, buff_ptr, buff_len, code);
	if length_n = 0				/* then append newline character */
	then call iox_$put_chars (target_iocb_ptr, addr (newline), 1, code);
	return;					/* end of sequential write routine */

/* declarations for  entire program */
	dcl     (iocb_ptr_arg, iocb_ptr)
				 ptr;
	dcl     code		 fixed bin (35);
%include rs_attach_block;
%include iocbv;
	dcl     buff_ptr		 ptr;
	dcl     buff_len		 fixed bin (21);
	dcl     buffer		 char (buff_len) based (buff_ptr);
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     newline		 char (1) static internal aligned init ("
");

     end rs_open_seq_out_;




		    rs_open_str_in_.pl1             09/10/87  1507.0r w 09/10/87  1447.6       53037



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


/* record_stream_ program for handling stream input openings */
rs_open_str_in_:
     proc (iocb_ptr_arg);
	iocb_ptr = iocb_ptr_arg;

/* set entries for valid operations in this mode */
	get_chars = get_chars_rs;
	get_line = get_line_rs;
	position = position_str_rs;
	return;					/* end of open initialization routine */

get_chars_rs:
     entry (iocb_ptr_arg, buff_ptr_arg, buff_len_arg, n_read, code);
	call init_args;
	if buff_len < 0
	then code = error_table_$negative_nelem;
	do while ((buff_len > 0) & (code = 0));		/* get buff_len characters */
	     if n_left > 0
	     then /* internal buffer is not empty */
		do;				/* move chars between buffers */
		     n_moved = min (buff_len, n_left);
		     call move;
		     if n_moved = buff_len
		     then do;			/* normal return */
exit:
			     base = base + n_moved;
			     return;
			end;
		     else /* more characters to be moved */
			do;			/* advance through input buffer */
			     buff_len = buff_len - n_moved;
			     buff_ptr = addr (buff (n_moved + 1));
			end;
		end;
	     call get_record;
	end;
	return;					/* end of get_chars routine */

get_line_rs:
     entry (iocb_ptr_arg, buff_ptr_arg, buff_len_arg, n_read, code);
	call init_args;
	if buff_len <= 0
	then code = error_table_$smallarg;
	do while ((buff_len > 0) & (code = 0));		/* pick up remainder of line */
	     if n_left > 0
	     then /* internal buffer is not empty */
		do;				/* move line between buffers */
		     line_len = index (substr (rs_buffer, base, n_left), newline);
		     if line_len = 0
		     then length = n_left;
		     else length = line_len;
		     n_moved = min (length, buff_len);
		     call move;			/* transfer n_moved chars from rs_buff to input buff */
		     if length > buff_len
		     then do;			/* error: line too long */
			     code = error_table_$long_record;
			     go to exit;
			end;
		     else if line_len > 0		/* newline has been found */
		     then go to exit;
		     else /* keep looking for end of line */
			do;			/* advance through input_buffer */
			     buff_len = buff_len - n_moved;
			     buff_ptr = addr (buff (n_moved + 1));
			end;
		end;
	     call get_record;			/* rs_buffer empty-- get another record */
	end;
	return;					/* end of get_line routine */

position_str_rs:
     entry (iocb_ptr_arg, type, count, code);
	call brief_init;
	if type ^= 0
	then do;					/* position to start or end of file */
		n_left = 0;			/* flush rs_buffer */
		call iox_$position (target_iocb_ptr, type, count, code);
						/* pass call to target */
	     end;
	else /* skip case */
	     do;					/* skip n lines */
		if count < 0			/* no backward skips permitted */
		then code = error_table_$negative_nelem;
		n = count;
		do while ((n > 0) & (code = 0));	/* skip n lines */
		     if n_left <= 0
		     then call get_record;		/* if rs_buffer is empty--fill it */
		     else /* internal buffer is not empty */
			do;			/* find newline in rs_buffer */
			     line_len = index (substr (rs_buffer, base, n_left), newline);
			     if line_len > 0
			     then /* newline found */
				do;		/* successful skip */
				     base = base + line_len;
				     n_left = n_left - line_len;
				     n = n - 1;
				end;
			     else n_left = 0;	/* crunch past this record */
			end;
		end;
	     end;					/* n lines skipped */
	return;					/* end of stream position routine */

/* internal procedures */
init_args:
     proc;					/* initialize upon entry */
	buff_len = buff_len_arg;
	buff_ptr = buff_ptr_arg;
	n_read = 0;
brief_init:
     entry;
	code = 0;
	iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr;
	rsab_ptr = attach_data_ptr;
	rs_buff_ptr = open_data_ptr;
	return;

     end init_args;

get_record:
     proc;					/* read a new record into the rs_buffer appending newline if default attachment */
	call iox_$read_record (target_iocb_ptr, rs_buff_ptr, max_bufsize, n_left, code);
	if code = 0
	then do;
		base = 1;
		if length_n = 0
		then /* default attachment */
		     do;				/* append newline */
			n_left = n_left + 1;
			substr (rs_buffer, n_left, 1) = newline;
		     end;
	     end;
	return;
     end get_record;

move:
     proc;					/* take n_moved chars from rs_buffer and append to input buffer */
	substr (buffer, 1, n_moved) = substr (rs_buffer, base, n_moved);
	n_read = n_read + n_moved;
	n_left = n_left - n_moved;
	return;

     end move;

/* declarations for entire program */
	dcl     (iocb_ptr_arg, iocb_ptr, buff_ptr_arg, buff_ptr)
				 ptr;
	dcl     (buff_len_arg, buff_len, n_read)
				 fixed (21);
	dcl     code		 fixed (35);
	dcl     error_table_$negative_nelem
				 external fixed (35);
%include iocbv;
%include rs_attach_block;
	dcl     n_moved		 fixed (21);
	dcl     error_table_$smallarg	 external fixed (35);
	dcl     line_len		 fixed (21);
	dcl     (index, substr, min, addr)
				 builtin;
	dcl     length		 fixed (21);
	dcl     error_table_$long_record
				 external fixed (35);
	dcl     type		 fixed;
	dcl     count		 fixed (21);
	dcl     iox_$position	 entry (ptr, fixed, fixed (21), fixed (35));
	dcl     n			 fixed (21);
	dcl     newline		 char (1) aligned static internal init ("
");
	dcl     iox_$read_record	 entry (ptr, ptr, fixed (21), fixed (21), fixed (35));
	dcl     error_table_$no_record external fixed (35);
%include rs_buffer;
	dcl     buffer		 char (buff_len) based (buff_ptr);
	dcl     buff		 (buff_len) char (1) based (buff_ptr);

     end rs_open_str_in_;




		    rs_open_str_out_.pl1            09/10/87  1507.0r w 09/10/87  1447.6       36504



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


/* record_stream_ program for handling stream output mode of opening */
rs_open_str_out_:
     proc (iocb_ptr_arg);
	iocb_ptr = iocb_ptr_arg;
						/* set entry in iocb for valid operation */
	put_chars = put_chars_rs;
	return;					/* finished with opening routine */

put_chars_rs:
     entry (iocb_ptr_arg, buff_ptr_arg, buff_len_arg, code);
	iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr;
	rsab_ptr = attach_data_ptr;
	rs_buff_ptr = open_data_ptr;
	buff_len = buff_len_arg;
	buff_ptr = buff_ptr_arg;
	if buff_len_arg < 0
	then code = error_table_$negative_nelem;
	else do;					/* process characters in output buffer */
		code = 0;
		if length_n <= 0
		then /* default case */
		     do while ((buff_len > 0) & (code = 0));
			line_len = index (buffer, newline) - 1;
			if line_len ^= 0
			then /* non-null line in output buffer */
			     if line_len < 0	/* no newline found */
			     then go to append;	/* append remaining chars to rs_buffer */
			     else /* newline found in output buffer */
				if n_left > 0
			     then /* rs_buffer not empty */
				do;		/*  append rest of line to rs_buffer and flush */
				     substr (rs_buffer, n_left + 1, line_len) = substr (buffer, 1, line_len);
				     call iox_$write_record (target_iocb_ptr, rs_buff_ptr, line_len + n_left, code);
				     n_left = 0;
				end;		/* rs_buffer now empty */
			     else call iox_$write_record (target_iocb_ptr, buff_ptr, line_len, code);
			buff_len = buff_len - line_len - 1;
			buff_ptr = addr (buff (line_len + 2));
		     end;				/* end of default case */

		else do;				/* -length  n case */
			if n_left > 0
			then /* rs_buffer not empty */
			     if n_left + buff_len >= length_n
			     then /* enough for full record */
				do;		/* append and write out record from rs_buffer */
				     tail_len = length_n - n_left;
				     substr (rs_buffer, n_left + 1, tail_len) = substr (buffer, 1, tail_len);
				     call iox_$write_record (target_iocb_ptr, rs_buff_ptr, length_n, code);
				     buff_len = buff_len - tail_len;
				     buff_ptr = addr (buff (tail_len + 1));
				     n_left = 0;	/* rs_buffer mpty */
				end;
			     else go to append;	/* not enough for full record to be written */

			do while (buff_len >= length_n);
			     call iox_$write_record (target_iocb_ptr, buff_ptr, length_n, code);
			     buff_len = buff_len - length_n;
			     buff_ptr = addr (buff (length_n + 1));
			end;			/* fewer than length_n characters remain */

append:
			if buff_len > 0
			then /* characters remain, but not enough for a full record */
			     do;			/* append remaining chars to rs_buffer */
				substr (rs_buffer, n_left + 1, buff_len) = buffer;
				n_left = n_left + buff_len;
			     end;
		     end;				/* end of -length n case */
	     end;					/* no more characters to process */
	return;					/* end of put_chars routine */

/* declarations for entire program */
	dcl     (iocb_ptr_arg, iocb_ptr)
				 ptr;
	dcl     code		 fixed (35);
%include rs_attach_block;
%include iocbv;
%include rs_buffer;
	dcl     iox_$write_record	 entry (ptr, ptr, fixed (21), fixed (35));
	dcl     (buff_ptr_arg, buff_ptr)
				 ptr;
	dcl     buffer		 char (buff_len) based (buff_ptr);
	dcl     (buff_len_arg, buff_len)
				 fixed (21);
	dcl     error_table_$negative_nelem
				 external fixed (35);
	dcl     line_len		 fixed (21);
	dcl     (addr, index, size, substr)
				 builtin;
	dcl     newline		 char (1) static internal aligned init ("
");
	dcl     buff		 (buff_len) char (1) based (buff_ptr);
	dcl     tail_len		 fixed (21);


     end rs_open_str_out_;




		    transaction_call.pl1            11/04/82  1940.0rew 11/04/82  1620.4      124353



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


/* Command Interface to transaction_call_.

   Rewritten 8-Mar-79 by M. N. Davidoff.
*/
transaction_call:
trc:
     procedure;

/* auotmatic */

	declare arg_count		 fixed binary;
	declare arg_length		 fixed binary (21);
	declare arg_list_ptr	 pointer;
	declare arg_ptr		 pointer;
	declare argument_no		 fixed binary;
	declare argx		 fixed binary;
	declare code		 fixed binary (35);
	declare operation		 char (32);
	declare tcf_io_switch	 char (32);
	declare tcf_iocb_ptr	 pointer;
	declare transaction_no	 fixed binary (35);

/* based */

	declare arg_string		 char (arg_length) based (arg_ptr);

/* builtin */

	declare addr		 builtin;
	declare index		 builtin;
	declare length		 builtin;
	declare null		 builtin;
	declare rtrim		 builtin;
	declare string		 builtin;

/* condition */

	declare program_interrupt	 condition;
	declare transaction_failure	 condition;

/* internal static */

	declare command		 char (16) internal static options (constant) initial ("transaction_call");

/* external static */

	declare error_table_$asynch_change
				 fixed binary (35) external static;
	declare error_table_$badopt	 fixed binary (35) external static;

/* entry */

	declare com_err_		 entry options (variable);
	declare com_err_$suppress_name entry options (variable);
	declare cu_$arg_count	 entry (fixed binary);
	declare cu_$arg_list_ptr	 entry (pointer);
	declare cu_$arg_ptr		 entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
	declare cu_$arg_ptr_rel	 entry (fixed binary, pointer, fixed binary (21), fixed binary (35), pointer);
	declare cv_dec_check_	 entry (char (*), fixed binary (35)) returns (fixed binary (35));
	declare ioa_		 entry options (variable);
	declare iox_$look_iocb	 entry (char (*), pointer, fixed binary (35));
	declare transaction_call_$assign
				 entry (pointer, fixed binary (35), fixed binary (35));
	declare transaction_call_$change_current_transaction_no
				 entry (pointer, fixed binary (35), fixed binary (35));
	declare transaction_call_$commit
				 entry (pointer, fixed binary (35), fixed binary (35));
	declare transaction_call_$number
				 entry (pointer, fixed binary (35), fixed binary (35));
	declare transaction_call_$rollback
				 entry (pointer, fixed binary (35), fixed binary (35));
	declare transaction_call_$status
				 entry (pointer, fixed binary (35), bit (36) aligned, pointer, fixed binary,
				 fixed binary (35));
	declare transaction_call_$transact
				 entry (pointer, char (*), fixed binary (35), fixed binary (35));

%include transaction_call;

/* program */

	call cu_$arg_list_ptr (arg_list_ptr);

	call cu_$arg_count (arg_count);
	if arg_count < 2
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a operation tcf_io_switch {args}", command);
		return;
	     end;

	do argx = 1 to 2;
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;

	     if index (arg_string, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, command, "^a", arg_string);
		     return;
		end;

	     else if argx = 1
	     then operation = arg_string;
	     else tcf_io_switch = arg_string;
	end;

	call iox_$look_iocb (tcf_io_switch, tcf_iocb_ptr, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "^a", tcf_io_switch);
		return;
	     end;

	if operation = "assign" | operation = "a"
	then call assign;

	else if operation = "change_current_transaction_no" | operation = "cctn"
	then call change_current_transaction_no;

	else if operation = "commit" | operation = "c"
	then call commit;

	else if operation = "number" | operation = "n"
	then call number;

	else if operation = "rollback" | operation = "r"
	then call rollback;

	else if operation = "status" | operation = "s"
	then call status;

	else if operation = "transact" | operation = "t"
	then call transact;

	else do;
		call com_err_ (0, command, "Specified operation is not implemented by this command. ^a", operation);
		return;
	     end;

	return;

/* Get a new transaction number. */

assign:
     procedure;

	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a assign tcf_io_switch", command);
		return;
	     end;

	call transaction_call_$assign (tcf_iocb_ptr, transaction_no, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Assigning a transaction number.");
		return;
	     end;

	call ioa_ ("Transaction ^d.", transaction_no);
     end assign;

/* Change to another transaction. */

change_current_transaction_no:
     procedure;

	argument_no = 0;
	do argx = 3 to arg_count;
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;

	     if index (arg_string, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, command, "^a", arg_string);
		     return;
		end;

	     else do;
		     argument_no = argument_no + 1;

		     if argument_no = 1
		     then do;
			     transaction_no = cv_dec_check_ (arg_string, code);
			     if code ^= 0
			     then do;
				     call com_err_ (0, command, "Transaction number expected. ^a", arg_string);
				     return;
				end;
			end;
		end;
	end;

	if argument_no ^= 1
	then do;
		call com_err_$suppress_name (0, command,
		     "Usage: ^a change_current_transaction_no tcf_io_switch transaction_no", command);
		return;
	     end;

	call transaction_call_$change_current_transaction_no (tcf_iocb_ptr, transaction_no, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Changing the current transaction number.");
		return;
	     end;
     end change_current_transaction_no;

/* Commit a transaction. */

commit:
     procedure;

	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a commit tcf_io_switch", command);
		return;
	     end;

	call transaction_call_$commit (tcf_iocb_ptr, transaction_no, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Committing transaction ^d.", transaction_no);
		return;
	     end;

	if transaction_no ^= 0
	then call ioa_ ("Transaction ^d committed.", transaction_no);
     end commit;

/* Get the current transaction number. */

number:
     procedure;

	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a number tcf_io_switch", command);
		return;
	     end;

	call transaction_call_$number (tcf_iocb_ptr, transaction_no, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Getting current transaction number.");
		return;
	     end;

	call ioa_ ("The current transaction number is ^d.", transaction_no);
     end number;

/* Rollback a transaction. */

rollback:
     procedure;

	if arg_count ^= 2
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a rollback tcf_io_switch", command);
		return;
	     end;

	call transaction_call_$rollback (tcf_iocb_ptr, transaction_no, code);
	if code ^= 0
	then do;
		call com_err_ (code, command, "Rolling back transaction ^d.", transaction_no);
		return;
	     end;

	if transaction_no ^= 0
	then call ioa_ ("Transaction ^d rolled back.", transaction_no);
     end rollback;

/* Get a transaction's status. */

status:
     procedure;

	declare 1 status_s		 aligned like trc_status;
	declare 1 sw		 unaligned,
		2 brief		 bit (1),
		2 verify_refs	 bit (1),
		2 list		 bit (1);
	declare transaction_status	 fixed binary;

	string (sw) = ""b;
	transaction_no = 0;

	argument_no = 0;
	do argx = 3 to arg_count;
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;

	     if arg_string = "-brief" | arg_string = "-bf"
	     then sw.brief = "1"b;

	     else if arg_string = "-verify" | arg_string = "-vf"
	     then sw.verify_refs = "1"b;

	     else if arg_string = "-list" | arg_string = "-ls"
	     then sw.list = "1"b;

	     else if index (arg_string, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, command, "^a", arg_string);
		     return;
		end;

	     else do;
		     argument_no = argument_no + 1;

		     if argument_no = 1
		     then do;
			     transaction_no = cv_dec_check_ (arg_string, code);
			     if code ^= 0
			     then do;
				     call com_err_ (0, command, "Transaction number expected. ^a", arg_string);
				     return;
				end;
			end;
		end;
	end;

	if argument_no > 1
	then do;
		call com_err_$suppress_name (0, command,
		     "Usage: ^a status tcf_io_switch {transaction_no} {-control_args}", command);
		return;
	     end;

	trc_flags = ""b;
	trc_flag_s.verify_refs = sw.verify_refs;
	trc_flag_s.list = sw.list;

	status_s.version = trc_status_version_1;

	if sw.brief
	then trc_status_ptr = null;
	else trc_status_ptr = addr (status_s);

	if sw.list
	then call ioa_ ("^/Reference list^[ until first asychronous change^]:", sw.verify_refs);

	call transaction_call_$status (tcf_iocb_ptr, transaction_no, trc_flags, trc_status_ptr, transaction_status, code);
	if code ^= 0 & code ^= error_table_$asynch_change
	then do;
		call com_err_ (code, command, "Getting the status of ^[the current transaction^s^;transaction ^d^].",
		     transaction_no = 0, transaction_no);
		return;
	     end;

	if transaction_no ^= 0 | ^sw.brief
	then call ioa_ ("^/transaction:^2-^[^d^s^;^s^d^]", sw.brief, transaction_no, status_s.transaction_no);

	call ioa_ ("status:^3-^[^[incomplete^;committed^;rolled back^;undefined^]^s^;^s^d^]",
	     trc_INCOMPLETE <= transaction_status & transaction_status <= trc_UNDEFINED, transaction_status + 1,
	     transaction_status);

	if transaction_status ^= trc_UNDEFINED & ^sw.brief
	then call ioa_ ("passive references:^2-^d^/non-passive references:^-^d", status_s.passive_refs,
		status_s.non_passive_refs);

	if code ^= 0
	then call com_err_ (code, command);
     end status;

/* Execute a command line as a transaction. */

transact:
     procedure;

	declare command_line_length	 fixed binary (21);
	declare first_command_line_arg fixed binary;
	declare retry_limit		 fixed binary;
	declare 1 sw		 unaligned,
		2 signal		 bit (1),
		2 no_signal	 bit (1);

	string (sw) = ""b;
	retry_limit = 0;

	first_command_line_arg = 0;
	argx = 3;
	do while (argx <= arg_count);
	     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, command, "Argument ^d.", argx);
		     return;
		end;

	     if first_command_line_arg > 0
	     then command_line_length = command_line_length + length (arg_string) + 1;

	     else if arg_string = "-retry"
	     then do;
		     argx = argx + 1;
		     if argx > arg_count
		     then do;
			     call com_err_ (0, command, "Missing retry limit after -retry.");
			     return;
			end;

		     call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
		     if code ^= 0
		     then do;
			     call com_err_ (code, command, "Argument ^d.", argx);
			     return;
			end;

		     retry_limit = cv_dec_check_ (arg_string, code);
		     if code ^= 0
		     then do;
			     call com_err_ (0, command, "Retry limit expected. ^a", arg_string);
			     return;
			end;
		end;

	     else if arg_string = "-signal"
	     then sw.signal = "1"b;

	     else if arg_string = "-no_signal"
	     then sw.no_signal = "1"b;

	     else if index (arg_string, "-") = 1
	     then do;
		     call com_err_ (error_table_$badopt, command, "^a", arg_string);
		     return;
		end;

	     else do;
		     first_command_line_arg = argx;
		     command_line_length = length (arg_string);
		end;

	     argx = argx + 1;
	end;

	if first_command_line_arg = 0
	then do;
		call com_err_$suppress_name (0, command, "Usage: ^a transact tcf_io_switch {-control_args} command_line",
		     command);
		return;
	     end;

	if sw.signal & sw.no_signal
	then do;
		call com_err_ (0, command, "The -signal and -no_signal control arguments are incompatible.");
		return;
	     end;

	sw.signal = ^sw.no_signal;

	begin;
	     declare command_line	      char (command_line_length);
	     declare one_more_time	      bit (1);
	     declare try		      fixed binary;

	     do argx = first_command_line_arg to arg_count;
		call cu_$arg_ptr_rel (argx, arg_ptr, arg_length, code, arg_list_ptr);
		if code ^= 0
		then do;
			call com_err_ (code, command, "Argument ^d.", argx);
			return;
		     end;

		if argx = first_command_line_arg
		then command_line = arg_string;
		else command_line = rtrim (command_line) || " " || arg_string;
	     end;

	     if sw.signal
	     then on program_interrupt
		     goto execute_command_line;

	     try = 0;

execute_command_line:
	     one_more_time = "1"b;
	     do while (try <= retry_limit & code = error_table_$asynch_change | one_more_time);
		one_more_time = "0"b;
		try = try + 1;

		call transaction_call_$transact (tcf_iocb_ptr, command_line, transaction_no, code);
	     end;

	     if code = 0
	     then call ioa_ ("The transaction committed on try ^d with transaction number ^d.", try, transaction_no);

	     else if code = error_table_$asynch_change
	     then if sw.signal
		then signal transaction_failure;
		else call com_err_ (code, command, "On try ^d.", try);

	     else call com_err_ (code, command, "On transaction ^d.", transaction_no);
	end;
     end transact;

     end transaction_call;




		    transaction_call_.pl1           11/04/82  1940.0rew 11/04/82  1621.0      207009



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


/* Vfile_ Transaction Interfaces.

   Written by Mike Asherman.
Modified:
03/02/79  by  M. N. Davidoff to use better interfaces and cleaned up a little .
05/17/79  by  Lindsey Spratt to interpret 22-byte reflist keys as non-passive references when gk_inf.descrip
		= -1.
07/06/79  by  M. N. Davidoff to fix bug where transaction_call_$status was not verifying if P_trc_status_ptr = null.
*/
transaction_call_:
     procedure;

/* parameter */

	declare P_command_line	 char (*);
	declare P_status		 fixed binary;
	declare P_transaction_no	 fixed binary (35);
	declare P_trc_flags		 bit (36) aligned;
	declare P_trc_status_ptr	 pointer;
	declare code		 fixed binary (35);
	declare tcfp		 pointer;

/* automatic */

	declare adjust_mod		 fixed binary (35);
	declare block_ptr		 pointer;
	declare change_tcf		 bit (1) aligned;
	declare cur_mod		 fixed binary (35);
	declare cur_tcode		 fixed binary (35);
	declare current_descrip	 fixed binary (35);
	declare end_of_reference_list	 bit (1) aligned;
	declare entry_point		 char (32);
	declare 1 gk_inf,
		2 header		 like gk_header,
		2 key		 char (22);
	declare ind_desc		 fixed binary (35);
	declare iocb_ptr		 pointer;
	declare iocbp		 pointer;
	declare last_file_id	 fixed binary (35);
	declare mod		 fixed binary;
	declare pos_ptr		 pointer;
	declare ref_cnt		 fixed binary;
	declare refp		 pointer;
	declare rollback_sw		 bit (1) aligned;
	declare time_stamp		 fixed binary (71);
	declare timeout		 fixed binary (71);
	declare transaction		 bit (1) aligned;
	declare unique_name		 char (32);

/* based */

/* Reference list and TCF key structure.  The TCF has keys which are 4 bytes long.  These keys are transaction
   entries.  The reference list has keys which are 12, 16 or 22 bytes long.  The 12 byte keys are I/O switch entries.
   The 16 and 22 byte keys are reference list entries. */

	declare 1 gk_key		 aligned based (addr (gk_inf.key)),
		2 number		 fixed binary (35),
		2 file_id		 fixed binary (35),
		2 rec_id		 fixed binary (35),
		2 blockp		 pointer unaligned,
		2 time		 fixed binary (53) unaligned;

/* builtin */

	declare binary		 builtin;
	declare codeptr		 builtin;
	declare clock		 builtin;
	declare rtrim		 builtin;
	declare stacq		 builtin;
	declare string		 builtin;

/* condition */

	declare cleanup		 condition;

/* entry */

	declare cu_$cp		 entry (pointer, fixed binary (21), fixed binary (35));
	declare date_time_		 entry (fixed binary (71), char (*));
	declare get_pdir_		 entry returns (char (168));
	declare ioa_		 entry options (variable);
	declare open_indx_file$adjust_record
				 entry (pointer, fixed binary (35), fixed binary (35), fixed binary (35));
	declare sub_err_		 entry options (variable);
	declare unique_chars_	 entry (bit (*)) returns (char (15));

/* Execute a Multics command line as a transaction. */

transact:
     entry (tcfp, P_command_line, P_transaction_no, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_command_line		(Input) Multics command line to execute
   P_transaction_no		(Output) transaction number of the transaction
   code			(Output) standard status code */

	entry_point = "transact";
	code = 0;
	P_transaction_no = 0;

	call check_tcf_io_switch;

	on cleanup
	     call rollback (tcfp, P_transaction_no, code);

	call cu_$cp (addr (P_command_line), length (P_command_line), code);

	call commit (tcfp, P_transaction_no, code);
	if code ^= error_table_$asynch_change
	then return;

	call rollback (tcfp, P_transaction_no, code);

	code = error_table_$asynch_change;
	return;

/* Obtain the status of a transaction. */

status:
     entry (tcfp, P_transaction_no, P_trc_flags, P_trc_status_ptr, P_status, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_transaction_no		(Input) transaction to find the status of.  Zero
			means the current transaction.
   P_trc_flags		(Input) what actions to perform
   P_trc_status_ptr		(Input) pointer to a trc_status structure or null
   P_status		(Output) status of the transaction
   code 			(Output) standard status code */

	entry_point = "status";
	trc_flags = P_trc_flags;
	trc_status_ptr = P_trc_status_ptr;
	P_status = trc_UNDEFINED;
	code = 0;

	call check_tcf_io_switch;

	if P_transaction_no = 0
	then cur_tcode = tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code;
	else cur_tcode = P_transaction_no;

	if cur_tcode ^= 0
	then do;
		unspec (gk_inf.flags) = ""b;
		gk_inf.input_key = "1"b;
		gk_inf.head_size = 4;
		gk_inf.key_len = 4;
		gk_key.number = cur_tcode;

		call iox_$control (tcfp, "get_key", addr (gk_inf), code);

		if code = 0
		then P_status = -gk_inf.descrip;
		else if code = error_table_$no_key | code = error_table_$no_record
		then code = 0;
		else call check_code ("Can't get TCF entry.");
	     end;

/* Return more detailed information only if requested. */

	if trc_status_ptr ^= null
	then do;
		if trc_status.version ^= trc_status_version_1
		then do;
			code = error_table_$unimplemented_version;
			return;
		     end;

		trc_status.transaction_no = cur_tcode;
		trc_status.transaction_status = P_status;
		trc_status.passive_refs = 0;
		trc_status.non_passive_refs = 0;
	     end;

	if P_status = trc_UNDEFINED
	then return;

/* There are no asynchronous changes or references if there is no reference list. */

	refp = tcfp -> iocb.open_data_ptr -> indx_cb.reflp;
	if refp = null
	then return;

	call verification ("1"b, trc_flag_s.verify_refs);

	code = 0;
	return;

/* Clean up after aborting a transaction. */

rollback:
     entry (tcfp, P_transaction_no, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_transaction_no		(Output) transaction number of the aborted transaction
   code			(Output) standard status code */

	entry_point = "rollback";
	rollback_sw = "1"b;
	goto join;

/* Start a new transaction and finish an old one. */

checkpoint:					/* TEMPORARY -- This entry point should be deleted. */
commit:
     entry (tcfp, P_transaction_no, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_transaction_no		(Output) transaction number of the completed transaction
   code			(Output) standard status code */

	entry_point = "commit";
	rollback_sw = "0"b;

join:
	P_transaction_no = 0;
	code = 0;

	call check_tcf_io_switch;

	cur_tcode = tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code;
	P_transaction_no = cur_tcode;

/* Return if there is no transaction in progress. */

	if cur_tcode = 0
	then return;

/* Get the reference list.  It's an error if there isn't one because a transaction is in progress. */

	refp = tcfp -> iocb.open_data_ptr -> indx_cb.reflp;
	if refp = null
	then do;
		code = error_table_$no_operation;
		call check_code ("No reference list.");
	     end;

/* Indicate roll back or roll forward to adjust_record logic.  Perform passive verification before the commitment. */

	if rollback_sw
	then adjust_mod = 0;
	else do;
		adjust_mod = cur_tcode;
		call verification ("0"b, "1"b);
	     end;

/* Go through non-passive references and indicate the status of the transaction. */

	call find_first_ref;
	if code ^= 0
	then do;
		code = error_table_$no_operation;
		call check_code ("No reference list entries after passive verification.");
	     end;

	call get_next_non_passive_ref (end_of_reference_list);

	change_tcf = "1"b;
	last_file_id = 0;
	do while (gk_key.number = cur_tcode & ^end_of_reference_list);
	     if gk_key.file_id ^= last_file_id		/* must set iocbp for this file */
	     then do;
		     call set_iocbp (gk_key.file_id);	/* gets information from start of reference list */
		     last_file_id = gk_key.file_id;
		end;

/* Prepare to alter the TCF entry.  A commitment or rollback is irreversible once the TCF has been changed. */

	     if change_tcf
	     then begin;
		     declare 1 rk_inf,
			     2 header	      like rk_header,
			     2 key	      char (4);
		     declare transaction_status     fixed binary;

		     tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = 0;

		     string (rk_inf.flags) = "111"b;
		     rk_inf.old_descrip = -trc_INCOMPLETE;
		     rk_inf.key_len = length (rk_inf.key);
		     unspec (rk_inf.key) = unspec (cur_tcode);

		     if rollback_sw
		     then rk_inf.new_descrip = -trc_ROLLED_BACK;
		     else rk_inf.new_descrip = -trc_COMMITTED;

		     call iox_$control (tcfp, "reassign_key", addr (rk_inf), code);
		     if code ^= 0
		     then if code = error_table_$no_key
			then call check_code ("No TCF entry for transaction.");
			else if code ^= error_table_$no_record
			then call check_code ("Can't change TCF entry.");
			else do;			/* see if already did operation */
				call status (tcfp, cur_tcode, ""b, null, transaction_status, code);
				call check_code ("Couldn't change TCF entry.  Can't get transaction's status.");

				if transaction_status = trc_UNDEFINED
				then do;
					code = error_table_$no_operation;
					call check_code ("Couldn't change TCF entry.  Transaction's entry is gone.")
					     ;
				     end;

				if rollback_sw
				then if transaction_status = trc_COMMITTED
				     then do;
					     code = error_table_$no_operation;
					     call check_code ("Transaction already committed.");
					end;
				     else if transaction_status ^= trc_ROLLED_BACK
				     then do;
					     code = error_table_$no_operation;
					     call check_code ("Invalid TCF status code found during rollback.");
					end;
				     else ;
				else if transaction_status = trc_ROLLED_BACK
				then do;
					code = error_table_$no_operation;
					call check_code ("Transaction already rolled back.");
				     end;
				else if transaction_status ^= trc_COMMITTED
				then do;
					code = error_table_$no_operation;
					call check_code ("Invalid TCF status code found during commitment.");
				     end;
			     end;

		     change_tcf = "0"b;
		end;

	     call open_indx_file$adjust_record (iocbp, gk_key.rec_id, adjust_mod, code);
	     call check_code ("Can't adjust a modified record.");

	     gk_inf.descrip = 0;			/* move onto the next non-passive reference */
	     call get_next_non_passive_ref (end_of_reference_list);
	end;

	code = 0;
	tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = 0;

return_from_transaction_call_:
	return;

/* Reserve a transaction number for the next transaction. */

assign:
     entry (tcfp, P_transaction_no, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_transaction_no		(Output) new transaction number
   code			(Output) standard status code */

	entry_point = "assign";
	P_transaction_no = 0;

	call check_tcf_io_switch;

	if tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code ^= 0
	then do;
		code = error_table_$no_operation;
		return;
	     end;

/* This loop will try again if there is an asynchronous insertion. */

	code = 1;
	do while (code ^= 0);
	     call iox_$position (tcfp, 1, 0, code);	/* eof */
	     call check_code ("Can't position to end of TCF to find last entry.");

	     call iox_$position (tcfp, 0, -1, code);	/* backspace */
	     if code = 0
	     then do;				/* get last used transaction number */
		     unspec (gk_inf.flags) = ""b;

		     call iox_$control (tcfp, "get_key", addr (gk_inf), code);
		     call check_code ("Can't get last key of TCF.");

		     cur_tcode = gk_key.number + 1;
		end;
	     else if code = error_table_$end_of_info
	     then cur_tcode = 1;			/* first TCF entry */
	     else call check_code ("Can't backspace from end of TCF.");

	     call create_tcf_entry (cur_tcode);
	     if code ^= 0
	     then if code ^= error_table_$key_duplication
		then call check_code ("Can't add a new key to the TCF.");
	end;

	P_transaction_no = cur_tcode;
	return;

/* Get the current transaction number. */

number:
     entry (tcfp, P_transaction_no, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_transaction_no		(Output) current transaction number
   code			(Output) standard status code */

	entry_point = "number";
	P_transaction_no = 0;
	code = 0;

	call check_tcf_io_switch;

	P_transaction_no = tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code;
	return;

/* Change the current transaction number.  This should be used with caution. */

change_current_transaction_no:
     entry (tcfp, P_transaction_no, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   P_transaction_no		(Input) new current transaction number
   code			(Output) standard status code */

	entry_point = "change_current_transaction_no";
	code = 0;

	call check_tcf_io_switch;

	if P_transaction_no < 0
	then do;
		code = error_table_$bad_arg;
		return;
	     end;


	tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = P_transaction_no;
	return;

/* Create a reference list. */

setup_ref_list:
     entry (tcfp, code);

/* tcfp			(Input) pointer to the iocb for the TCF I/O switch
   code			(Output) standard status code */

	entry_point = "setup_ref_list";
	code = 0;

	call check_tcf_io_switch;

	unique_name = unique_chars_ (""b) || ".refl.vfile_";

	call iox_$attach_name (unique_name, iocbp, "vfile_ " || rtrim (get_pdir_ ()) || ">" || unique_name,
	     codeptr (transaction_call_), code);
	call check_code ("Can't attach reference list.");

	call iox_$open (iocbp, Keyed_sequential_update, "0"b, code);
	call check_code ("Can't open reference list.");

	tcfp -> iocb.open_data_ptr -> indx_cb.reflp = iocbp;
	return;

/* Make sure the TCF I/O switch is open. */

check_tcf_io_switch:
     procedure;

	if tcfp -> iocb.open_descrip_ptr ^= null
	then return;

	code = error_table_$not_open;
	goto return_from_transaction_call_;
     end check_tcf_io_switch;

/* Perform passive verification. */

verification:
     procedure (verify_only, check_asynch_changes);

	declare verify_only		 bit (1) aligned;	/* (Input) on if only obtaining a transaction's status */
	declare check_asynch_changes	 bit (1);		/* (Input) on to check for asychronous changes */

	declare end_of_reference_list	 bit (1) aligned;
	declare my_lock_id		 bit (36) aligned;

	call find_first_ref;
	if code ^= 0
	then if verify_only
	     then return;
	     else do;
		     code = error_table_$no_operation;
		     call check_code ("No reference list entries.");
		end;

	my_lock_id = tcfp -> iocb.open_data_ptr -> indx_cb.saved_lock_copy;
	transaction = "1"b;
	timeout = 0;				/* no point waiting to verify */

	end_of_reference_list = "0"b;
	do while (gk_key.number = cur_tcode & ^end_of_reference_list);
	     block_ptr = gk_key.blockp;		/* pointer to stat record header */

/* If the record is locked, then we have a non-passive reference, otherwise if the record is not locked, the
   reference is passive.  For non-passive references before a commitment (^verify_only) make sure
   record_block.lock_flag is on.  All flags will then be set before the commitment starts.  This will force users to
   examine the TCF to determine which record image currently applies.  When record_block.lock_flag is off, the before
   image is guaranteed to be valid.  */

	     if gk_inf.descrip = -1
	     then if verify_only
		then do;
			if trc_status_ptr ^= null
			then trc_status.non_passive_refs = trc_status.non_passive_refs + 1;

			if trc_flag_s.list
			then if gk_inf.key_len = 16
			     then call ioa_ ("File: ^o, Descriptor: ^o Locked.", gk_key.file_id, gk_key.rec_id);
			     else begin;
				     declare date_time_string	      char (24);
				     call date_time_ ((gk_key.time), date_time_string);
				     call ioa_ ("File: ^o, Descriptor: ^o, Last modified: ^a, Locked.",
					gk_key.file_id, gk_key.rec_id, date_time_string);
				end;
		     end;
		else if stacq (block_ptr -> stat_struct.record_lock, my_lock_id, my_lock_id)
						/* be sure under own lock */
		then if ^block_ptr -> record_block.lock_flag & stat_struct.modifier = cur_tcode
		     then block_ptr -> record_block.lock_flag = "1"b;
		     else ;
		else ;
	     else do;

/* Verify a passive reference. */

		     if verify_only
		     then do;
			     if trc_status_ptr ^= null
			     then trc_status.passive_refs = trc_status.passive_refs + 1;

			     if trc_flag_s.list
			     then if gk_inf.key_len = 16
				then call ioa_ ("File: ^o, Descriptor: ^o, Last modifier: ^d.", gk_key.file_id,
					gk_key.rec_id, gk_inf.descrip);
				else begin;
					declare date_time_string	 char (24);

					call date_time_ ((gk_key.time), date_time_string);
					call ioa_
					     ("File: ^o, Descriptor: ^o, Last modified: ^a, Image descriptor: ^o.",
					     gk_key.file_id, gk_key.rec_id, date_time_string, gk_inf.descrip);
				     end;
			end;

		     if check_asynch_changes
		     then begin;
			     declare asynch_change	      bit (1) aligned;

			     current_descrip = gk_key.rec_id;
			     call set_current_image_info;

/* Long form verification uses the time_stamp and the indirect descriptor. */

			     if cur_mod = 0 | cur_mod = -1
			     then if gk_inf.key_len = 16
				then asynch_change = gk_inf.descrip ^= -3 | time_stamp ^= 0 | ind_desc ^= -1;
				else if gk_inf.key_len > 16
						/* A key_len of >16 occurs when: passive & ((cur_mod = 0) | (cur_mod = -1))
		         or; not passive & (stat_struct.prev_mod = 0).
(This latter implies cur_mod = 0.)
		        and; this reference must be the first to this 
			        record in  the reflist by this 
			        transaction.
If not passive then gk_inf.descrip = -1, and the converse.  If gk_inf.descrip
is not = -1, then the old check for inequality with ind_desc is used.
*/
				then if gk_inf.descrip ^= -1
				     then asynch_change = gk_key.time ^= time_stamp | gk_inf.descrip ^= ind_desc;
				     else asynch_change = gk_key.time ^= time_stamp;
				else asynch_change = "0"b;
			     else asynch_change = gk_inf.key_len > 16 | cur_mod ^= gk_inf.descrip;

			     if asynch_change
			     then do;
				     code = error_table_$asynch_change;
				     goto return_from_transaction_call_;
				end;
			end;
		end;

/* Move on to the next reference for this transaction. */

	     call iox_$position (refp, 0, 1, code);
	     call check_code ("Can't position to next reference list entry.");

	     call iox_$control (refp, "get_key", addr (gk_inf), code);
	     if code ^= 0
	     then if code = error_table_$end_of_info
		then end_of_reference_list = "1"b;
		else call check_code ("Can't get next reference list entry for verification.");
	end;
     end verification;

/* Locate first item in reference list for this transaction. */

find_first_ref:
     procedure;

	unspec (gk_inf.flags) = ""b;
	gk_inf.input_key = "1"b;
	gk_inf.head_size = 4;
	gk_inf.key_len = 4;
	gk_key.number = cur_tcode;

	call iox_$control (refp, "get_key", addr (gk_inf), code);
	if code ^= 0
	then if code ^= error_table_$no_record & code ^= error_table_$no_key
	     then call check_code ("Can't find first reference list entry.");

	gk_inf.input_key = "0"b;			/* suppress seeking on next get_key */
     end find_first_ref;

/* Get the next locked item in the reference list. */

get_next_non_passive_ref:
     procedure (end_of_reference_list);

	declare end_of_reference_list	 bit (1) aligned;	/* (Output) on if no more items in reference list */

/* Skip over the passive references. */

	end_of_reference_list = "0"b;
	do while ((gk_inf.descrip >= 0 | gk_inf.descrip = -3) & ^end_of_reference_list);
	     call iox_$position (refp, 0, 1, code);
	     call check_code ("Can't position to next non-passive reference list entry.");

	     call iox_$control (refp, "get_key", addr (gk_inf), code);
	     if code ^= 0
	     then if code = error_table_$no_record | code = error_table_$end_of_info
		then end_of_reference_list = "1"b;
		else call check_code ("Can't get next non-passive reference list entry.");
	end;
     end get_next_non_passive_ref;

/* Create an entry in the TCF for a new transaction. */

create_tcf_entry:
     procedure (mod_arg);

	declare mod_arg		 fixed binary (35); /* (Input) transaction to create a TCF entry for */

	unspec (gk_inf.flags) = "11"b;
	gk_inf.descrip = -trc_INCOMPLETE;
	gk_inf.key_len = 4;
	gk_key.number = mod_arg;

	call iox_$control (tcfp, "add_key", addr (gk_inf), code);
	if code = 0
	then tcfp -> iocb.open_data_ptr -> indx_cb.transaction_code = mod_arg;
     end create_tcf_entry;

/* Obtain a file's iocb pointer. */

set_iocbp:
     procedure (uid_arg);

	declare uid_arg		 fixed binary (35); /* (Input) file_id of the iocb to find */

	declare 1 gk_inf,
		2 header		 like gk_header,
		2 key		 char (12);

	declare gk_desc		 pointer unaligned based (addr (gk_inf.descrip));
	declare 1 gk_key		 aligned based (addr (gk_inf.key)),
		2 zero		 fixed binary (35),
		2 lock_id		 bit (36),
		2 file_id		 fixed binary (35);

	unspec (gk_inf.flags) = ""b;
	gk_inf.input_key = "1"b;
	gk_inf.reset_pos = "1"b;			/* don't lose place in reference list */
	gk_inf.head_size = length (gk_inf.key);
	gk_inf.key_len = length (gk_inf.key);
	gk_key.zero = 0;
	gk_key.lock_id = refp -> iocb.open_data_ptr -> indx_cb.saved_lock_copy;
	gk_key.file_id = uid_arg;

	call iox_$control (refp, "get_key", addr (gk_inf), code);
	call check_code ("Can't get I/O switch reference list entry.");

	iocbp = gk_desc;
     end set_iocbp;

/* Error reporting routine. */

check_code:
     procedure (message);

	declare message		 char (*);	/* (Input) error message */

	declare sub_code		 fixed binary (35);

	if code = 0
	then return;

	sub_code = 0;
	call sub_err_ (code, "transaction_call_$" || entry_point, "c", null, sub_code, message);
	goto return_from_transaction_call_;
     end check_code;

/* The set_current_image_info procedure uses the following global variables as arguments:
   (Who knows, it may also use some more.)

   block_ptr	(Input/Output) pointer to stat record header
   code		(Output) standard status code
   cur_mod	(Output) The transaction number of the current modifier.  Zero and negative numbers are special.
		-1 means the current modifier is outside the transaction system.
   current_descrip	(Input) the current record's descriptor
   ind_desc	(Output) The indirect descriptor.  Component and offset of where the record is.  -1 is special.
   mod		(Output) Some kind of modifier's transaction number.
   ref_cnt	(Output) reference count
   timeout	(Output) when the information becomes invalid?
   time_stamp	(Output) when the record was last modified.
   transaction	(Input) whether or not this opening is in transaction mode
*/
%include set_current_image_info;

%include transaction_call;
%include vfile_indx;
%include ak_info;
%include iocbv;
%include iox_entries;
%include vfile_error_codes;
%include iox_modes;
     end transaction_call_;




		    vfile_adjust.pl1                11/04/82  1940.0rew 11/04/82  1621.0      115488



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


/* This command is used to restore storage system files to a
   consistent state after detecting an interrupted operation */
vfa:
vfile_adjust:
     proc (pathname_arg);
	seg_ptr, fcb_ptr, iocb_ptr = null;
	call cu_$arg_count (n_args);			/* number of args with which command was invoked */
	if n_args <= 0				/* must specify at least the pathname */
	then code = error_table_$noarg;
	else if n_args > 3				/* limit of permissible args */
	then code = error_table_$too_many_args;
	else code = 0;
	call check_code;				/* aborts if error detected */
	call get_file_base;				/* gets first seg ptr */
	if (seg_ptr -> header.file_code ^= seq_code) & (seg_ptr -> header.file_code ^= blk_code)
	     & (seg_ptr -> header.file_code ^= indx_code)
	then call adj_uns_file;			/* makes the adjustment */
	else call adj_struc_file;			/* takes care of structured files */
	call check_code;
cleanup:
	if fcb_ptr ^= null				/* free the msf control block */
	then call msf_manager_$close (fcb_ptr);
	else if seg_ptr ^= null			/* was single segment file */
	then call hcs_$terminate_noname (seg_ptr, code);
	if iocb_ptr ^= null				/* file was opened for adjustment */
	then do;					/* close file and free I/O switch */
		call iox_$close (iocb_ptr, code);
		call iox_$detach_iocb (iocb_ptr, code);
	     end;
	return;					/* end of main file adjustment routine */

check_code:
     proc;					/* aborts if error detected */
	if code = 0
	then return;
	call com_err_ (code, "vfile_adjust");		/* signal the error */
	go to cleanup;				/* don't leave  a mess */
     end check_code;

get_file_base:
     proc;					/* finds first file component and sets seg_ptr */
	call expand_path_ (addr (pathname_arg), length (pathname_arg), addr (d_name), addr (e_name), code);
						/* separate directory and entry names */
	call check_code;
	call hcs_$status_long (d_name, e_name, 1, addr (branch_info), null, code);
	call check_code;
	if branch_info.type = "10"b			/* directory or msf */
	then if branch_info.bit_count = "0"b		/* directory */
	     then code = error_table_$dirseg;
	     else do;				/* get ptr to base of msf */
		     call msf_manager_$open ((d_name), (e_name), fcb_ptr, code);
						/* creates control block */
		     call check_code;		/* abort on error */
		     call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, seg_ptr, bc, code);
						/* pointer to base of file */
		     if seg_ptr ^= null
		     then code = 0;			/* reset spurious code */
		end;
	else do;					/* get ptr to base of segment */
		call hcs_$initiate (d_name, e_name, "", 0, 1, seg_ptr, code);
		if seg_ptr ^= null
		then code = 0;			/* no error if pointer returned */
	     end;
	call check_code;
     end get_file_base;

adj_struc_file:
     proc;					/* adjusts all structured files */
	if n_args > 1				/* no args permitted for structured files */
	then code = error_table_$too_many_args;
	call check_code;
	call check_file_lock;			/* may unlock file */
	call attach_unique_sw;			/* need I/O switch to open and close */
	call iox_$open (iocb_ptr, 7 /* sequential_update */, "0"b, code);
						/* adjustment will automatically be made if necessary */
     end adj_struc_file;

adj_uns_file:
     proc;					/* handles adjustments to unstructured files */
	if n_args <= 1				/* a control option must be specified */
	then code = error_table_$noarg;
	call cu_$arg_ptr (2, opt1_ptr, opt1_len, code);
	call check_code;
	if n_args > 2
	then do;					/* pick up second optional arg */
		call cu_$arg_ptr (3, opt2_ptr, opt2_len, code);
		call check_code;
	     end;
	if n_args = 2
	then if opt1_arg = "-set_bc"			/* indicates setting to last non-zero byte */
	     then call adjust_bit_count_ (d_name, e_name, "1"b /* last byte */, bc, code);
						/* does the work */
	     else if opt1_arg = "-use_nl"		/* indic trunc after last complete line */
	     then call trunc_at_line;
	     else if opt1_arg = "-set_nl"		/* indic newline to be appended if not there */
	     then call append_line;
	     else call get_use_bc;			/* option must be "-use_bc" */
	else call get_use_bc;			/* use existing bit count to truncate */
	return;					/* unstructured file has  been adjusted */

trunc_at_line:
     proc;					/* truncates file after last new-line char */
	call prep_uns_file;				/* positions to last line */
	call iox_$put_chars (iocb_ptr, (null), 0, code);	/* truncates the file */
     end trunc_at_line;

prep_uns_file:
     proc;					/* sets position to last line of file or eof */
	call adjust_bit_count_ (d_name, e_name, "1"b, bc, code);
						/* first set bit count to last non-zero byte */
	call check_code;
	call attach_unique_sw;			/* attaches uniquely named I/O switch with "-extend" option */
	call iox_$open (iocb_ptr, 3 /* stream_input_output */, "0"b, code);
						/* file must be opened */
	call check_code;
	call iox_$position (iocb_ptr, 0, 0, code);	/* positions just past last newline char */
     end prep_uns_file;

append_line:
     proc;					/* puts newline char at eof if none already there */
	call prep_uns_file;				/* position past last newline */
	call iox_$get_chars (iocb_ptr, addr (dummy_buffer), 1, rec_len, code);
						/* get next character */
	if code ^= error_table_$end_of_info
	then do;					/* must append a newline char */
		call iox_$position (iocb_ptr, 1, 0, code);
						/* go to end of file */
		call iox_$put_chars (iocb_ptr, addr (newline), 1, code);
	     end;
	else code = 0;				/* already ends in newline */
     end append_line;

get_use_bc:
     proc;					/* checks option and truncates at existing bitcount  */
	if opt1_arg ^= "-use_bc"			/* no other option will do */
	then code = error_table_$bad_arg;
	else if branch_info.type ^= "10"b		/* single segment case */
	then do;
		if n_args > 2			/* msf component number specified */
		then if opt2_arg ^= "0"
		     then code = error_table_$bad_arg;
		     else call hcs_$truncate_seg (seg_ptr, divide (fixed (bit_count) + 35, 36, 18, 0), code);
	     end;
	else do;					/* get tail num and truncate */
		if n_args = 2			/* n not given--default is last non-zero component */
		then call get_last_nz_comp;
		else call get_comp_n;		/* picks up specified component-num arg */
		call check_code;
		call msf_manager_$adjust (fcb_ptr, n_tail, bc, "011"b, code);
						/* does the truncation */
	     end;
	return;					/* end main routine for handling "-use_bc" option */

get_last_nz_comp:
     proc;					/* finds last non-empty msf component or comp 0 if none */

	do n_tail = 1 repeat n_tail + 1 while (code = 0); /* find last msf comp */
	     call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code);
						/* pointer to next component */
	end;

	n_recs = 0;				/* last comp+1 has no recs */

	do n_tail = n_tail - 2 to 0 by -1 while (n_recs = 0);
						/* find last non-empty comp */
	     call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code);
						/* ptr to preceding comp */
	     call hcs_$fs_get_path_name (seg_ptr, d_name, d_len, e_name, code);
						/* need path for hcs_$status_ */
	     call hcs_$status_ (d_name, e_name, 0, addr (branch_info), null /* no names */, code);
						/* gets n_recs */
	end;

	n_tail = n_tail + 1;			/* loop decrements once too often */

     end get_last_nz_comp;

get_comp_n:
     proc;					/* sets n_tail to specified component number */
	n_tail = cv_dec_check_ (opt2_arg, code);	/* validates conversion */
	call check_code;
	call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code);
						/* n'th comp info */
     end get_comp_n;

     end get_use_bc;

     end adj_uns_file;

attach_unique_sw:
     proc;					/* attaches I/O switch with "-extend" control option */
	call iox_$attach_ioname (unique_chars_ ("0"b), iocb_ptr, "vfile_ " || pathname_arg || " -extend", code);
	call check_code;
     end attach_unique_sw;

check_file_lock:
     proc;					/* may reset file lock */
	lock_word = seg_ptr -> header.lock_word;	/* copy the file lock to examine it */
	call set_lock_$lock (lock_word, 0, code);
	if code ^= 0
	then if code = error_table_$locked_by_this_process
	     then do;				/* warn user about danger of recursive use of vfile_ */
		     call command_query_ (addr (query_info), answer, "vfile_adjust",
			"Warning--file locked
by this process.  Resuming a previous invocation
of vfile_ after adjustment may produce unpredictable
errors.  Close the I/O switch or issue a new_proc to be safe.
Do you still wish to adjust the file?"
			);			/* let user decide */
		     if answer = "no"
		     then go to cleanup;		/* forget the whole thing */
		     seg_ptr -> header.lock_word = bit (-1);
						/* lock becomes invalid */
		end;
     end check_file_lock;

/* declarations for entire program */
	dcl     hcs_$status_long	 entry (char (*) aligned, char (*) aligned, fixed (1), ptr, ptr, fixed (35));
	dcl     hcs_$initiate	 entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed (1), fixed (2),
				 ptr, fixed (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed (35));
	dcl     lock_word		 bit (36) aligned;
	dcl     seq_code		 static internal fixed init (83711);
	dcl     blk_code		 static internal fixed init (22513);
	dcl     indx_code		 static internal fixed init (7129);
	dcl     hcs_$truncate_seg	 entry (ptr, fixed (18), fixed (35));
	dcl     error_table_$end_of_info
				 external fixed (35);
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed (21), fixed (35));
	dcl     iox_$position	 entry (ptr, fixed, fixed, fixed (35));
	dcl     iox_$get_chars	 entry (ptr, ptr, fixed (21), fixed (21), fixed (35));
	dcl     rec_len		 fixed (21);
	dcl     newline		 char (1) aligned static internal init ("
");
	dcl     dummy_buffer	 char (1) aligned;
	dcl     pathname_arg	 char (*);
	dcl     opt1_arg		 char (opt1_len) based (opt1_ptr);
	dcl     opt2_arg		 char (opt2_len) based (opt2_ptr);
	dcl     (opt1_len, opt2_len)	 fixed;
	dcl     (opt1_ptr, opt2_ptr)	 ptr;
	dcl     cu_$arg_ptr		 entry (fixed, ptr, fixed, fixed (35));
	dcl     (fcb_ptr, iocb_ptr)	 ptr;
	dcl     cu_$arg_count	 entry (fixed);
	dcl     n_args		 fixed;
	dcl     code		 fixed (35);
	dcl     (error_table_$noarg, error_table_$dirseg, error_table_$too_many_args, error_table_$bad_arg,
	        error_table_$locked_by_this_process)
				 external fixed (35);
	dcl     (null, fixed, bit, divide, addr)
				 builtin;
	dcl     msf_manager_$close	 entry (ptr);
	dcl     iox_$close		 entry (ptr, fixed (35));
	dcl     iox_$open		 entry (ptr, fixed, bit (1) aligned, fixed (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed (35));
	dcl     com_err_		 entry options (variable);
	dcl     expand_path_	 entry (ptr, fixed, ptr, ptr, fixed (35));
	dcl     msf_manager_$open	 entry (char (*) aligned, char (*) aligned, ptr, fixed (35));
	dcl     msf_manager_$get_ptr	 entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35));
	dcl     d_name		 char (168) aligned;
	dcl     e_name		 char (32) aligned;
	dcl     seg_ptr		 ptr;
	dcl     bc		 fixed (24);
	dcl     1 header		 based (seg_ptr),
		2 file_code	 fixed (35),
		2 lock_word	 bit (36) aligned;
	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed (24),
				 fixed (35));
	dcl     n_tail		 fixed;
	dcl     msf_manager_$adjust	 entry (ptr, fixed, fixed (24), bit (3), fixed (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*) aligned, fixed, char (*) aligned, fixed (35));
	dcl     hcs_$status_	 entry (char (*) aligned, char (*) aligned, fixed (1), ptr, ptr, fixed (35));
	dcl     d_len		 fixed;
	dcl     1 branch_info	 aligned,
	        ( 2 type		 bit (2),
		2 nnames		 fixed (15),
		2 nrp		 bit (18),
		2 dtm		 bit (36),
		2 dtu		 bit (36),
		2 mode		 bit (5),
		2 pad		 bit (13),
		2 n_recs		 fixed (17)
		)		 unaligned,
		2 words1		 (3) fixed,
		2 pad1		 bit (12) unal,
		2 bit_count	 bit (24) unal,
		2 words2		 (2) fixed;
	dcl     cv_dec_check_	 entry (char (*), fixed (35)) returns (fixed (35));
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed, fixed (35));
	dcl     command_query_	 entry options (variable);
	dcl     1 query_info	 aligned,
		2 version		 fixed init (2),
		2 yes_or_no_sw	 bit (1) unal init ("1"b),
		2 suppress_name_sw	 bit (1) unal init ("0"b),
		2 code		 fixed (35),
		2 query_code	 fixed (35);
	dcl     answer		 char (12) var;
	dcl     iox_$attach_ioname	 entry (char (*), ptr, char (*), fixed (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
     end vfile_adjust;




		    vfile_attach.pl1                09/10/87  1507.0rew 09/10/87  1445.1      272412



/****^  ***********************************************************
        *                                                         *
        * 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-07-01,GWMay), approve(87-07-01,MCR7730), audit(87-08-10,JRGray),
     install(87-09-10,MR12.1-1104):
     Added the -truncate, -tc argument so that the -extend arg can be
     overriden.
                                                   END HISTORY COMMENTS */


/* format: style2,ind3 */
vfile_attach:
   proc (iocb_ptr_arg, option_array, command_switch, code);

/* Modified:
04/05/82 by Lindsey Spratt:  Changed to correctly report the blocking value,
	  the wait-time for the share option, and the identifier for the
	  unstructured header.  If more than one of these was present in the
	  attach options, the values for all of them would be reported as
	  being the same as the value for the last one given.  Also, changed
	  "-exclu" to "-exclusive" in the attach description, as -exclu is
	  not a valid attach option.
*/
/* Declarations and general comments are at the end
   of the program. */

      iocb_ptr = iocb_ptr_arg;
      call verify_and_interpret_args;
      if trans_opt & (code = 0)			/* -transaction attachment */
      then
         do;
	  call iox_$look_iocb ((tcf_name), tcf_ptr, code);
	  if code = 0
	  then if tcf_ptr -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr ^= null
	       then if index (tcf_ptr -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr -> attach_descrip_string,
		       "-stationary") ^= 0
		  then
		     do;				/* complain */
		        code = error_table_$incompatible_attach;
		        call sub_err_ (code, "vfile_", "c", null,
			   "The tcf switch must not be attached with the -stationary option.");
		     end;
         end;
      if code = 0
      then call create_attach_block;
      if code = 0
      then
         do;					/* set pointers, entries in iocb */
	  attach_data_ptr = attach_block_ptr;
	  attach_descrip_ptr = addr (attach_descrip);
	  open = open_file;
	  control = control_file;			/* file_status supported with switch closed */
	  detach_iocb = detach_file;
	  call iox_$propagate (iocb_ptr);
         end;
      else if command_switch
      then call com_err_ (code, "vfile_", "^a", name);
      return;

verify_and_interpret_args:
   proc;
      if attach_descrip_ptr ^= null
      then code = error_table_$not_detached;
      else if length (option_array (1)) > 168
      then code = error_table_$pathlong;
      else
         do;
	  code = 0;
	  n_opts = hbound (option_array, 1);
	  if n_opts > 10
	  then code = error_table_$bad_arg;
	  else
	     do i = 2 to n_opts while (code = 0);
	        if option_array (i) = "-extend"
	        then extend_attach_option = "1"b;
	        else if option_array (i) = "-truncate" | option_array (i) = "-tc"
	        then extend_attach_option = "0"b;

	        else if option_array (i) = "-share"
	        then
		 do;				/* pick up wait_time */
		    shared_option = "1"b;
		    call get_n_opt (wait_time_option);	/* pick up number */
		    if wait_time_option < -1
		    then code = error_table_$bad_arg;
		 end;
	        else if option_array (i) = "-blocked"	/* blocked file */
	        then
		 do;				/* pick up max_rec_len if given */
		    blocked_option = "1"b;
		    call get_n_opt (max_recl);	/* get optional number */
		    if max_recl < 0
		    then code = error_table_$negative_nelem;
		 end;
	        else if option_array (i) = "-append"
	        then append_option = "1"b;
	        else if option_array (i) = "-no_trunc"
	        then no_trunc_option = "1"b;
	        else if option_array (i) = "-header"
	        then
		 do;				/* set header info */
		    header_option = "1"b;
		    call get_n_opt (identifier);	/* pick up optional ident number */
		 end;
	        else if option_array (i) = "-old"
	        then old_option = "1"b;		/* prevents creation */
	        else if option_array (i) = "-ssf"
	        then ssf_option = "1"b;
	        else if option_array (i) = "-dup_ok"
	        then dup_ok_opt = "1"b;
	        else if (option_array (i) = "-stationary") | (option_array (i) = "-stat")
	        then stat_opt = "1"b;
	        else if option_array (i) = "-no_end"
	        then noend_option = "1"b;		/* allows positioning beyond eof */
	        else if option_array (i) = "-exclusive"
	        then exclu_option = "1"b;
	        else if (option_array (i) = "-transaction") | (option_array (i) = "-trans")
	        then if i >= n_opts			/* no more args */
		   then code = error_table_$noarg;
		   else
		      do;				/* get tcf switch name */
		         i = i + 1;			/* skip over next arg */
		         tcf_name = option_array (i);
		         trans_opt = "1"b;
		      end;
	        else if (option_array (i) = "-checkpoint")
	        then checkpoint_opt = "1"b;
	        else code = error_table_$bad_arg;
	     end;
         end;
      if code = 0
      then
         do;
	  rel_pathname = option_array (1);
	  rel_pathname_length = length (option_array (1));
	  if ((extend_attach_option & (append_option | no_trunc_option)) | (append_option & no_trunc_option)
	       | (header_option & (checkpoint_opt | blocked_option | exclu_option | shared_option))
	       | (blocked_option & (checkpoint_opt | no_trunc_option))
	       | ((dup_ok_opt | stat_opt | trans_opt)
	       & (checkpoint_opt | ssf_option | blocked_option | no_trunc_option | append_option | noend_option))
	       | (shared_option & (no_trunc_option | exclu_option)))
	  then code = error_table_$bad_arg;
         end;
      return;
   end;						/* end verify args */

get_n_opt:
   proc (n);					/* used to pick up optional numerical argument */
      if i < n_opts
      then
         do;					/* another option exists--look at it */
	  num = cv_dec_check_ ((option_array (i + 1)), er_code);
	  if er_code = 0				/* valid integer */
	  then
	     do;					/* grab next option */
	        i = i + 1;				/* advance option_array index */
	        saved_i = i;			/* save element number */
	        n = num;				/* set the argument */
	     end;
         end;
      dcl	    (n, num)	       fixed (35);
   end get_n_opt;

create_attach_block:
   proc;
      dname, ename = " ";
      call expand_path_ (addr (rel_pathname), rel_pathname_length, addr (dname), addr (ename), code);
      if code = 0
      then
         do;
	  call alloc_cb_file (size (attach_block), attach_block_ptr);
	  dup_ok_sw = dup_ok_opt;
	  noend_sw = noend_option;
	  exclu_sw = exclu_option;
	  stat_sw = stat_opt;
	  trans_sw = trans_opt;
	  checkpoint_sw = checkpoint_opt;
	  ssf = ssf_option;
	  old = old_option;
	  blocked = blocked_option;
	  max_rec_len = max_recl;
	  header_present = header_option;
	  header_id = identifier;
	  no_trunc = no_trunc_option;
	  appending = append_option;
	  extend_attach = extend_attach_option | appending | no_trunc | old;
	  shared = shared_option;
	  wait_time = 1000000 * wait_time_option;
	  interp = 0;				/* this option may be supported in future */
	  dname_len = length (dname) + 1 - verify (reverse (dname), " ");
	  ename_len = length (ename) + 1 - verify (reverse (ename), " ");
	  string = "vfile_ " || substr (dname, 1, dname_len) || ">";
	  string = string || substr (ename, 1, ename_len);
	  if no_trunc
	  then string = string || " -no_trunc";
	  if appending
	  then string = string || " -append";
	  if extend_attach_option
	  then string = string || " -extend";
	  if noend_sw
	  then string = string || " -no_end";
	  if interp = 1
	  then string = string || " -raw";
	  if old
	  then string = string || " -old";
	  if ssf					/* limited to single-segment files */
	  then string = string || " -ssf";
	  if dup_ok_sw
	  then string = string || " -dup_ok";
	  if stat_sw
	  then string = string || " -stationary";
	  if trans_sw
	  then
	     do;
	        string = string || " -transaction " || tcf_name;
	        attach_block.tcf_iocbp = tcf_ptr;
	     end;
	  if checkpoint_sw
	  then string = string || " -checkpoint";
	  if header_present
	  then
	     do;
	        string = string || " -header";
	        string = string || " " || ltrim (char (identifier));
	     end;
	  if blocked
	  then
	     do;
	        string = string || " -blocked";
	        string = string || " " || ltrim (char (max_rec_len));
	     end;
	  if exclu_sw
	  then string = string || " -exclusive";
	  if shared
	  then
	     do;
	        string = string || " -share ";
	        string = string || ltrim (char (wait_time_option));
	     end;
	  attach_descrip_len = length (string);
	  attach_descrip_string = string;
         end;

      dcl	    ename		       char (32) aligned;
      dcl	    expand_path_	       external entry (ptr,	/* ptr to relative pathname */
			       fixed bin,		/* length of relative pathname */
			       ptr,		/* ptr to char(l68) aligned to hold expanded
						   directory name */
			       ptr,		/* ptr to char(32) aligned to hold expanded
						   entry name */
			       fixed bin (35));	/* status code */
      dcl	    dname		       char (168) aligned;
      dcl	    string	       char (256) varying;
   end;						/* end create_attach_block */

open_file:
   entry (iocb_ptr_arg, mode_arg, extend_arg, code);
      begin;
         iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr;
         attach_block_ptr = attach_data_ptr;
         was_msf = "0"b;
         i_set_lock = "0"b;				/* will unlock file only if I locked it */
         fcb_ptr, first_seg_ptr = null;			/* will cleanup if non-null */
         mode = mode_arg;
         call verify_open_args_set_descrip;
         if code = 0
         then call get_file_base;
         if code = 0
         then call check_set_file_type;
         if code = 0
         then call check_set_file_already_open;
         if (code = 0) & (^is_msf) & (file_type = 2 /* indexed */)
         then call open_msf;				/* always use msf_manager with indexed files */
         if code = 0
         then
	  do;
	     if file_type = 0
	     then open_x = open_uns_file;
	     else if file_type = 1
	     then open_x = open_seq_file;
	     else if file_type = 2
	     then open_x = open_indx_file;
	     else if file_type = 3
	     then open_x = open_blk_file;
	     call open_x (iocb_ptr, fcb_ptr, first_seg_ptr, is_new_file, mode, close_x, first_seg_bitcount,
		max_component_size, code);
	  end;
         if code = 0
         then
	  do;
	     close = close_file;
	     open_descrip_ptr = addr (open_descrip);
	     call iox_$propagate (iocb_ptr);
	  end;
         else
	  do;
	     if first_seg_ptr ^= null
	     then if i_set_lock
		then call set_lock_$unlock (open_lock, foo);
	     call cleanup;
	  end;
         return;					/* end of opening main routine */

verify_open_args_set_descrip:
   proc;
      if (mode <= 0) | (mode > 13)
      then code = error_table_$bad_arg;
      else if (interp = 1) & (mode ^= 1)
      then code = error_table_$incompatible_attach;
      else if (((blocked | checkpoint_sw) & ((mode < 4) | (mode > 7))) | ((ssf | noend_sw) & (mode > 7))
	 | (exclu_sw & is_input_only_mode (mode))
	 | ((trans_sw | shared | exclu_sw | dup_ok_sw | stat_sw)
	 & ((mode < 4) | (^(extend_arg | extend_attach) & ((mode = 5) | (mode = 6)))))
	 | ((no_trunc | header_present) & (mode > 3)))
      then code = error_table_$incompatible_attach;
      else
         do;
	  code = 0;
	  open_descrip_len = length (mode_descrip (mode));
	  open_descrip_string = mode_descrip (mode);
         end;

      dcl	    string	       char (32) varying;
   end;						/* end verify_open_args_set_descrip */

get_file_base:
   proc;
      branch_info.bit_count = "0"b;
      is_msf = "0"b;
      attach_block.last_comp = 0;
      call hcs_$status_long (substr (attach_descrip_string, 8, dname_len),
	 substr (attach_descrip_string, 9 + dname_len, ename_len), 1, addr (branch_info), null, foo);
      if foo ^= 0
      then if foo = error_table_$no_s_permission
	 then foo = 0;				/* we don't need any missing info */
      if (type = "10"b) & (bit_count = "0"b) & (foo = 0)
      then
         do;					/* entry is a directory--flag the error */
	  code = error_table_$dirseg;
	  return;					/* unsuccessfulopening */
         end;
      else if (type = "10"b) & (foo = 0)		/* must be an msf */
      then if ssf					/* -ssf option was specified--no msf's allowed */
	 then
	    do;					/* flag the error */
	       code = error_table_$incompatible_attach;
	       return;
	    end;
	 else
	    do;
	       was_msf = "1"b;
	       attach_block.last_comp = fixed (bit_count) - 1;
	       call open_msf;
	       call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, first_seg_ptr, first_seg_bitcount, foo);
	    end;
      is_new_file =
	 (is_output_mode (mode) & ^extend_attach & ^extend_arg)
	 | ((branch_info.bit_count = "0"b) & ^is_input_only_mode (mode) & ^old);
      if ^is_msf
      then
         do;					/* get pointer to base of single segment file */
	  first_seg_bitcount = fixed (branch_info.bit_count, 24, 0);
	  if is_new_file
	  then call hcs_$make_seg (substr (attach_descrip_string, 8, dname_len),
		  substr (attach_descrip_string, 9 + dname_len, ename_len), "", 01010b /* rw access */, first_seg_ptr,
		  foo);
	  else call hcs_$initiate (substr (attach_descrip_string, 8, dname_len),
		  substr (attach_descrip_string, 9 + dname_len, ename_len), "", 0, 1, first_seg_ptr, foo);
         end;
      if first_seg_ptr = null
      then code = foo;
      if code = 0
      then
         do;					/* check access */
	  access_mode = 0;
	  call hcs_$fs_get_mode (first_seg_ptr, access_mode, foo);
	  if (access_required (mode) & ^bit (access_mode)) ^= "0"b
	  then code = error_table_$moderr;
         end;
      if code = 0
      then
         do;
	  call hcs_$get_max_length_seg (first_seg_ptr, max_component_size, foo);
	  if is_new_file
	  then
	     do;
	        if ^is_msf				/* single segment */
	        then call hcs_$truncate_seg (first_seg_ptr, 0, foo);
	        else call msf_manager_$adjust (fcb_ptr, 0, 0, "010"b, foo);
						/* truncate file, which leaves first
						   page set to zero */
	        call hcs_$set_bc_seg (first_seg_ptr, 0, foo);
	        first_seg_bitcount = 0;
	     end;
         end;

      dcl	    access_mode	       fixed bin (5);
      dcl	    hcs_$fs_get_mode       external entry (ptr, fixed bin (5), fixed bin (35));
						/* second arg
						   interpreted as bit(5), second bit = read access,
						   fourth bit is write access, other bits irrelevant here */
      dcl	    hcs_$get_max_length_seg
			       entry (ptr,		/* ptr to seg */
			       fixed bin (19),	/* max length in words */
			       fixed bin (35));	/* code */
      dcl	    hcs_$set_bc_seg	       entry (ptr,		/* ptr to segment */
			       fixed bin (24),	/* bitcount */
			       fixed bin (35));	/* status code */
   end get_file_base;

check_set_file_type:
   proc;
      if mode < 4
      then
         do;
	  file_type = 0;
	  if is_new_file & header_present
	  then file_code = file_code_table (0);
         end;
      else if is_new_file
      then
         do;
	  if mode < 8
	  then if blocked
	       then file_type = 3;
	       else file_type = 1;			/* normal sequential file */
	  else file_type = 2;
	  call check_type;
	  if code = 0
	  then file_code = file_code_table (file_type);
         end;
      else
         do;
	  if file_code = file_code_table (1)
	  then file_type = 1;
	  else if file_code = file_code_table (2)
	  then file_type = 2;
	  else if file_code = file_code_table (3)
	  then file_type = 3;
	  else code = error_table_$bad_file;
	  if code = 0
	  then call check_type;
         end;
      return;					/* end of check_set_file_type main routine */

check_type:
   proc;
      if ^substr (compatible_types (mode), file_type, 1) | ((file_type = 2) & ssf)
	 | (((file_type = 1) | (file_type = 2)) & noend_sw) | (checkpoint_sw & ^(file_type = 1))
	 | ((dup_ok_sw | stat_sw | trans_sw) & (file_type ^= 2)) | ((shared | exclu_sw) & (file_type < 2))
      then code = error_table_$incompatible_attach;
   end check_type;

      dcl	    compatible_types       (4:13) bit (3) static
			       init ("111"b, "101"b, "101"b, "111"b, "010"b, "010"b, "010"b, "010"b, "010"b, "010"b)
			       ;
      dcl	    file_code_table	       (0:3) static internal fixed bin init (31191, 83711, 7129, 22513);
   end;						/* end check_set_file_type */

open_msf:
   proc;						/* opens ssf as msf for indexed file */
      is_msf = "1"b;
      call msf_manager_$open (substr (attach_descrip_string, 8, dname_len),
	 substr (attach_descrip_string, 9 + dname_len, ename_len), fcb_ptr, foo);
						/* creates msf control block */
      if (fcb_ptr = null) & (foo ^= 0)
      then code = foo;				/* unexpected error */
   end open_msf;

check_set_file_already_open:
   proc;
      if file_type ^= 0
      then
         do;
	  if is_input_only_mode (mode)
	  then
	     do;
	        if ^shared & (open_lock ^= "0"b)
	        then code = error_table_$file_busy;
	     end;
	  else
	     do;
	        call set_lock_$lock (open_lock, divide (wait_time + 500000, 1000000, 35, 0), foo);
	        if foo ^= 0
	        then if foo = error_table_$invalid_lock_reset
						/* locked by dead proc */
		   then
		      do;
		         inv_lock_reset = "1"b;
		         i_set_lock = "1"b;
		      end;
		   else code = error_table_$file_busy;
	        else
		 do;
		    inv_lock_reset = "0"b;
		    i_set_lock = "1"b;
		 end;
	     end;
         end;

   end;						/* end check_set_file_already_open */

         dcl     i_set_lock		bit (1) aligned;
         dcl     first_seg_bitcount	fixed bin (24);
         dcl     is_new_file		bit (1) aligned;
         dcl     open_x		variable entry (ptr,/* iocb_ptr, input */
				ptr,		/* fcb_ptr, input */
				ptr,		/* first_seg_ptr, input */
				bit (1) aligned,	/* is_new_file, input */
				fixed bin,	/* mode */
				entry,		/* close_x, output */
				fixed bin (24),	/* first seg bitcount */
				fixed bin (19),	/* max_component_size */
				fixed bin (35));	/* code, if not 0, open_x leaves iocb as is */
         dcl     open_uns_file	entry external;
         dcl     open_seq_file	entry external;
         dcl     open_blk_file	entry external;
         dcl     open_indx_file	entry external;
      end;					/* end of open_file routine */

cleanup:
   proc;
      if fcb_ptr ^= null
      then call msf_manager_$close (fcb_ptr);
      if (^was_msf) & (first_seg_ptr ^= null)
      then call hcs_$terminate_noname (first_seg_ptr, foo);
   end cleanup;

control_file:
   entry (iocb_ptr_arg, order, info_ptr, code);
      iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr;


      if order = "file_status"
      then call vfile_status_$seg (iocb_ptr, (null), info_ptr, code);

      else if order = "io_call"
      then call vfile_io_control (iocb_ptr, (null), info_ptr, code);

      else code = error_table_$no_operation;
      return;					/* end of control operation supported with switch closed */

close_file:
   entry (iocb_ptr_arg, code);
      code = 0;
      iocb_ptr = iocb_ptr_arg -> actual_iocb_ptr;
      attach_block_ptr = attach_data_ptr;
      call close_x (iocb_ptr);
      if (file_type = 1 /* seq */) & (^is_input_only_mode (mode))
      then call set_lock_$unlock (open_lock, foo);
      iocb.control = control_file;
      open_descrip_ptr = null;
      open = open_file;
      detach_iocb = detach_file;
      call iox_$propagate (iocb_ptr);
      call cleanup;
      return;					/* end of close routine */

detach_file:
   entry (iocb_ptr_arg, code);
      begin;
         iocb_ptr = iocb_ptr_arg;
         attach_block_ptr = attach_data_ptr;
         code = 0;
         attach_descrip_ptr = null;
         call iox_$propagate (iocb_ptr);
         call free_cb_file (size (attach_block), attach_block_ptr);
      end;
      return;					/* end detach routine */

/* DECLARATIONS FOR COMPLETE PROGRAM */
      dcl	    sub_err_	       entry options (variable);

      dcl	    info_ptr	       ptr;
      dcl	    order		       char (*);
      dcl	    vfile_status_$seg      entry (ptr, ptr, ptr, fixed (35));
      dcl	    vfile_io_control       entry (ptr, ptr, ptr, fixed (35));
      dcl	    1 branch_info	       aligned,		/* info returned by hcs_$status_long */
	      2 type	       bit (2) unal,
	      2 pad0	       bit (34) unal,
	      2 words1	       (6) fixed,		/* of no interest */
	      2 pad1	       bit (12) unal,
	      2 bit_count	       bit (24) unal,	/* distinguishes msf and dir */
	      2 words2	       (2);
      dcl	    hcs_$status_long       entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35));
      dcl	    hcs_$initiate	       entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
      dcl	    hcs_$terminate_noname  entry (ptr, fixed (35));
      dcl	    hcs_$truncate_seg      entry (ptr, fixed (18), fixed (35));
      dcl	    hcs_$make_seg	       entry (char (*), char (*), char (*), fixed (5), ptr, fixed (35));
      dcl	    msf_manager_$close     external entry (ptr);	/* This entry frees the msf file control block
						   and terminates all initiated components */
      dcl	    msf_manager_$adjust    external entry (ptr,	/* fcb_ptr input */
			       fixed bin,		/* component number, input */
			       fixed bin (24),	/* bit count, input */
			       bit (3),		/* "010"b implies don't set bit counts (use hcs_$set_bc_seg), truncate
						   seg, don't terminate seg */
			       fixed bin (35));	/* code, output */
      dcl	    msf_manager_$get_ptr   external entry (ptr,	/* fcb_ptr, input */
			       fixed bin,		/* create switch, input */
			       bit (1),		/* create switch, input */
			       ptr,		/* pointer to seg., output, null if error */
			       fixed bin (24),	/* bit count, output */
			       fixed bin (35));	/* code, output */
      dcl	    msf_manager_$open      external entry (char (*),
						/* directory pathname, input */
			       char (*),		/* entry name, input */
			       ptr,		/* fcb_ptr, output, good unless code is
						   error_table_$dirseg */
			       fixed bin (35));	/* code, output */
      dcl	    (extend_attach_option, shared_option, blocked_option, append_option, old_option, dup_ok_opt, exclu_option,
	    noend_option, stat_opt, trans_opt, checkpoint_opt)
			       bit (1) aligned init ("0"b);
      dcl	    tcf_name	       char (32) var;
      dcl	    tcf_ptr	       ptr;
      dcl	    (no_trunc_option, ssf_option, header_option)
			       bit (1) aligned init ("0"b);
      dcl	    wait_time_option       fixed (35) init (1);
      dcl	    identifier	       fixed (35) init (0);
      dcl	    max_recl	       fixed (35) init (0);
      dcl	    (n, i, n_opts, er_code);
      dcl	    saved_i	       fixed init (0);
      dcl	    cv_dec_check_	       entry (char (*), fixed) returns (fixed (35));
      dcl	    access_required	       (13) bit (5) static internal
			       init ("01000"b, "00010"b, "01010"b, "01000"b, "01010"b, "01010"b, "01010"b, "01000"b,
			       "01010"b, "01010"b, "01000"b, "01010"b, "01010"b);
						/* second bit is r access, fourth bit is w access */
      dcl	    addr		       builtin;
      dcl	    alloc_cb_file	       external entry (fixed bin,
						/* size of block in words, input */
			       ptr);		/* pointer to block, output */
      dcl	    1 attach_block	       based (attach_block_ptr),
						/* the following are set by attach_file */
	      2 flags	       aligned,
	        3 (extend_attach, appending, no_trunc, old, ssf, header_present, blocked, shared, was_msf, is_msf,
		   inv_lock_reset, dup_ok_sw, trans_sw, noend_sw, exclu_sw, stat_sw, checkpoint_sw)
			       bit (1) unal,
	        3 pad	       bit (19) unal,
	      2 wait_time	       fixed (35),
	      2 interp	       fixed,
	      2 max_rec_len	       fixed (35),
	      2 header_id	       fixed (35),
	      2 attach_descrip,
	        3 attach_descrip_len
			       fixed bin (35),	/* < = 256 */
	        3 attach_descrip_string
			       char (256),		/* "-pn " (4 chars), the directory
						   pathname (dname_len chars), ">", the entry
						   name (ename_len chars), " -extend" (optional 8 chars),
						   and " -raw" or " -extend"(optional 8 chars) */
	      2 dname_len	       fixed bin,		/* < = l68 */
	      2 ename_len	       fixed bin,		/* < = 32 */
						/* The following are set by open_file */
	      2 open_descrip,
	        3 open_descrip_len fixed bin (35),	/* < = 31 */
	        3 open_descrip_string
			       char (32),		/* The string
						   contains the opening mode, e.g., "stream output",
						   (< = 23 chars) and " -extend" (8chars optional) */
	      2 mode	       fixed bin,		/* opening mode 1 <= 13 */
	      2 file_type	       fixed bin,		/* 0 = uns, 1 = seq, 2 = indx, 3 = blk */
	      2 fcb_ptr	       ptr,		/* pointer to msf_manager control block */
	      2 first_seg_ptr      ptr,		/* pointer to first component
						   of the file.  Thie pointer is valid throughout the
						   file opening */
	      2 close_x	       entry (ptr),		/* routine to perform operations required
						   for closing specific type of file obtained from open_x see
						   open_file */
	      2 last_comp	       fixed,		/* msf component number at open */
	      2 tcf_iocbp	       ptr;		/* iocb ptr for transaction control switch */
      dcl	    attach_block_ptr       ptr;
      dcl	    bit		       builtin;
      dcl	    code		       fixed bin (35);	/* status code argument */
      dcl	    com_err_	       entry options (variable);
      dcl	    command_switch	       bit (1) aligned;
      dcl	    1 common_header	       based (first_seg_ptr), /* This
						   header is used for all seq and indx files.  Its contents
						   are manipulated by open_file and close_file but not by the
						   specific access methods.  Its size is 4 words */
	      2 file_code	       fixed bin (35),
	      2 open_lock	       bit (36) aligned,	/* nonzero if file open unless shared */
	      2 reserved	       (2) fixed bin;
      dcl	    extend_arg	       bit (1) aligned;
      dcl	    foo		       fixed bin (35);	/* used when output parameters value is to
						   beignored */
      dcl	    hbound	       builtin;
      dcl	    iocb_ptr	       ptr;
      dcl	    iocb_ptr_arg	       ptr;
      dcl	    is_input_only_mode     (13) static internal bit (1)
			       init ("1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b);
      dcl	    is_output_mode	       (13) static internal bit (1)
			       init ("0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b);
      dcl	    length	       builtin;
      dcl	    max_component_size     fixed bin (19);
      dcl	    mode_arg	       fixed bin;
      dcl	    mode_descrip	       (13) char (24) varying static internal
			       init ("stream_input", "stream_output", "stream_input_output", "sequential_input",
			       "sequential_output", "sequential_input_output", "sequential_update",
			       "keyed_sequential_input", "keyed_sequential_output", "keyed_sequential_update",
			       "direct_input", "direct_output", "direct_update");
      dcl	    null		       builtin;
      dcl	    option_array	       (*) char (*) varying;
      dcl	    iox_$propagate	       entry (ptr);
      dcl	    iox_$look_iocb	       entry (char (*), ptr, fixed (35));
      dcl	    rel_pathname	       char (168);
      dcl	    rel_pathname_length    fixed bin;
      dcl	    reverse	       builtin;
      dcl	    set_lock_$lock	       entry (bit (36) aligned,
						/* lock word */
			       fixed bin,		/* num of seconds to wait */
			       fixed bin (35));	/* code=0 or et_$invalid_lock_reset are success codes */
      dcl	    set_lock_$unlock       entry (bit (36) aligned,
						/* lock word */
			       fixed bin (35));	/* code */
      dcl	    size		       builtin;
      dcl	    substr	       builtin;
      dcl	    verify	       builtin;
      dcl	    error_table_$negative_nelem
			       external fixed (35);
      dcl	    error_table_$noarg     external fixed (35);
      dcl	    error_table_$no_s_permission
			       external fixed (35);
      dcl	    error_table_$no_operation
			       fixed (35) external;
      dcl	    error_table_$bad_arg   external fixed bin (35);
      dcl	    error_table_$pathlong  external fixed bin (35);
      dcl	    error_table_$moderr    external fixed bin (35);
      dcl	    error_table_$dirseg    external fixed bin (35);
      dcl	    error_table_$not_detached
			       external fixed bin (35);
      dcl	    error_table_$bad_file  external fixed bin (35);
      dcl	    error_table_$file_busy external fixed bin (35);
      dcl	    error_table_$incompatible_attach
			       external fixed bin (35);
      dcl	    error_table_$invalid_lock_reset
			       external fixed bin (35);
      dcl	    free_cb_file	       external entry (fixed bin,
						/* size of block in words, input */
			       ptr);		/* pointer to block); input */
%include iocbv;

/* GENERAL COMMENTS
   This external procedure implements file attachment and the
   i-o operations open, close and detach for this attachment
   (entries: open_file, close_file, detach_file).  The code for
   each entry immediately follows the entry and terminates with
   a return statement.

   Before reading the code familiarize yourself with the general
   conventions for implementing attachments (see the MPM) and read
   the declarations of attach_block and common header.

   The whole thing can be considered a single program in which attach,
   open, close, and detach are done in that order.  The difficult operation
   is open.  It does that which is common to the various types of
   files.  The specific access method is called (via open_x) to set up its
   control block and perform any special file initialization.  open_file will
   have to be changed when file types are put in the directory branches. */
   end /* end of vfile_attach program */;




		    vfile_copy_opening_.pl1         11/04/82  1940.0rew 11/04/82  1607.2       83088



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
vfile_copy_opening_:
   proc (p_source_iocb_ptr, p_target_sw_name, p_target_iocb_ptr, p_code);

/* This module makes an iocb (at p_target_iocb_ptr) with the same attributes
as the source iocb.  The target iocb is positioned "outside" of the index and
has  the pos_incorrect bit set.  This iocb, then, has basically the same
appearance as (and is indistinguishable from) an iocb which has just been
attached and opened in the normal fashion.

As much as possible, the copied opening is made by actually copying the data
structures.  For the seg_ptr_array and the position_stack, the vfile_
utilities are used to do the copying, as various protocols must be followed
in filling in these structures and some data must be unique to each iocb
(hence cant just be copied).  In the case of the seg_ptr_array, there must
be one initiation per opening per segment and create_seg_ptrs takes care of
setting this up.  In the case of the position_stack, various pointers in the
stack must be set to point elsewhere in the same stack and some pointers in
the indx_cb have to be set to point to the position_stack.  This is done by
create_position_stack.

Written 03/01/81 by Lindsey Spratt.
Modified:
06/22/81 by Lindsey Spratt: Replace call to msf_manager_$open with direct copy
	  of the fcb.  The initiated_components portion of the structure
	  must be set to 0 to indicate that this new fcb opening has no
	  initiated 	  segments associated with it.  The following
	  msf_get_ptr adds the first one,
	  and successive calls by create_seg_ptrs finishes this processes.
06/30/81 by Lindsey Spratt: Changed to use vfile_attach_block.incl.pl1,
	  iocb.incl.pl1 instead of iocbv.incl.pl1, deleted position_stack
	  declaration.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_source_iocb_ptr      ptr;
      dcl	    p_target_sw_name       char (*);
      dcl	    p_target_iocb_ptr      ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    iocb_ptr	       ptr;
      dcl	    pos_ptr	       ptr;
      dcl	    fcbp		       ptr;		/* The msf_manager_ File Control Block, fcb, is based on this variable. */
      dcl	    bead_idx	       fixed bin;
      dcl	    source_fcb_ptr	       ptr;
      dcl	    old_target_ibp	       ptr;
      dcl	    target_ibp	       ptr;
      dcl	    source_ibp	       ptr;

/* Based */

      dcl	    free_area	       area (sys_info$max_seg_size - 1) based (system_areap);

      dcl	    1 fcb		       based (fcbp) aligned,	/* the multi-segment file control block */
	      2 version	       fixed bin,		/* version of this structure - 0 now */
	      2 type	       fixed bin,		/* form of msf - ssf, msf, or not_exists */
	      2 max_components     fixed bin,		/* maximum number of components (same as bitcount) */
	      2 max_len	       fixed bin (19),	/* Max number of words in each component. */
	      2 pad	       (1) fixed bin,
	      2 pathnames,				/* dirnname, ename, and combined of the file */
	        3 dname	       char (168),
	        3 ename	       char (32),
	        3 path	       char (168),
	      2 initiated_components,			/* information about the initiated components in the file */
	        3 number	       fixed bin,		/* how many are initiated */
	        3 highest_value    fixed bin,		/* the highest component value of those inited */
	        3 listp	       ptr,		/* ptr to head of the list of inited segs */
	      2 rbs	       (3) fixed bin (3),	/* save ring bracks */
	      2 upgrade_sw	       bit (1) aligned,	/* if components are multiclass segments */
	      2 access_class       bit (72) aligned;	/* acc if upgrade_sw ON */
						/* DRV - add volume backup switch to FCB here */


      dcl	    1 initiation_bead      based aligned,	/* one for each initiated component of the msf */
	      2 component	       fixed bin,		/* which component it is */
	      2 bitcount	       fixed bin (24),	/* its bitcount */
	      2 segptr	       ptr,		/* a ptr to it */
	      2 next	       ptr;		/* next bead in list or null */


/* Builtin */
/* Controlled */
/* Constant */
/* Entry */

      dcl	    msf_manager_$get_ptr   entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
      dcl	    msf_manager_$open      entry (char (*), char (*), ptr, fixed bin (35));
      dcl	    get_system_free_area_  entry () returns (ptr);

/* External */

      dcl	    error_table_$badcall   fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext;

/* Static */

      dcl	    system_areap	       ptr internal static init (null);

/* END OF DECLARATIONS */


/* Validate the source opening for being copied.  It must be an index
sequential opening, must not be opened for exclusive operations.
It must be opened in shared mode, and it must be an msf.
*/
      iocb_ptr = null;
      attach_block_ptr = p_source_iocb_ptr -> iocb.attach_data_ptr;
      if attach_block.mode ^= Keyed_sequential_update & attach_block.mode ^= Keyed_sequential_output
         & attach_block.mode ^= Keyed_sequential_input
      then
         do;
	  p_code = error_table_$badcall;
	  return;
         end;

      if attach_block.exclu_sw | ^attach_block.shared | ^attach_block.is_msf
      then
         do;
	  p_code = error_table_$badcall;
	  return;
         end;

/* Find and/or create the target iocb. */

      call iox_$find_iocb (p_target_sw_name, p_target_iocb_ptr, p_code);
      if p_code ^= 0
      then return;

      p_target_iocb_ptr -> iocb = p_source_iocb_ptr -> iocb;
      p_target_iocb_ptr -> iocb.actual_iocb_ptr = p_target_iocb_ptr;
      p_target_iocb_ptr -> iocb.name = p_target_sw_name;

      call alloc_cb_file (size (attach_block), attach_block_ptr);

      attach_block = p_source_iocb_ptr -> iocb.attach_data_ptr -> attach_block;
      p_target_iocb_ptr -> iocb.attach_data_ptr = attach_block_ptr;
      p_target_iocb_ptr -> iocb.attach_descrip_ptr = addr (attach_block.attach_descrip);
      p_target_iocb_ptr -> iocb.open_descrip_ptr = addr (attach_block.open_descrip);

      call alloc_cb_file (size (indx_cb), indx_cb_ptr);

      indx_cb = p_source_iocb_ptr -> iocb.open_data_ptr -> indx_cb;
      p_target_iocb_ptr -> iocb.open_data_ptr = indx_cb_ptr;
      indx_cb.pos_incorrect = "1"b;
      indx_cb.next_record_position = 0;
      indx_cb.current_record_is_valid = "0"b;
      indx_cb.ready_to_write = "0"b;
      indx_cb.repeating = "0"b;
      indx_cb.error.type = 0;
      indx_cb.at_bof = "0"b;
      indx_cb.at_eof = "0"b;
      indx_cb.min_res = 0;
      indx_cb.min_cap = 0;
      indx_cb.leave_locked = "0"b;
      indx_cb.outside_index = "0"b;
      indx_cb.new_key = "";
      indx_cb.skip_state = 0;
      indx_cb.transaction_code = 0;
      indx_cb.reflp = null;
      indx_cb.collection_delay_time = 0;

/* The subsetting information must be set to indicate that no subsetting has been
done yet on this opening.
*/

      indx_cb.current_subset = 0;
      indx_cb.last_subset = 0;
      indx_cb.subset_count = 0;
      indx_cb.temp_iocbp = null;

/* It is necessary for each opening to have its own MSF fcb to point at.
*/

      if system_areap = null
      then system_areap = get_system_free_area_ ();

      alloc fcb in (free_area) set (fcbp);

      fcb = p_source_iocb_ptr -> iocb.attach_data_ptr -> attach_block.fcb_ptr -> fcb;
      indx_cb.fcb_ptr = fcbp;
      fcb.initiated_components.number = 0;
      fcb.initiated_components.highest_value = 0;
      fcb.initiated_components.listp = null;

      attach_block.fcb_ptr = indx_cb.fcb_ptr;		/* The attach_block fcb_ptr is used when closing. */

      call msf_manager_$get_ptr (indx_cb.fcb_ptr, 0, "0"b, indx_cb.file_base_ptr, 0, p_code);
      if p_code ^= 0
      then return;

/* create_seg_ptrs is called to set up the seg_ptr_array and initiate all of
the segments in the msf.  It does this by doing msf_manager_$get_ptr.  The end
result of this is to have an fcb identical to the fcb of the opening being
copied.  The reason it is necessary to go through all of the mechanism of
create_seg_ptrs and msf_manager_$get_ptr is to have the hcs_$initiate calls
made on all of the segments, since (at close time) hcs_$terminate_noname is
called.
     The other approach, to allocate and copy data explicitly to build the fcb
and seg_ptr_array structures without
invoking other routines, works fine except that the segments are terminated out
from under the iocbs which are copies of the iocb being closed and detached.
*/

      call create_seg_ptrs (p_target_iocb_ptr);

/* The position stack and
some data in the indx_cb must be initialized.  For this it is necessary to call
create_position_stack.
*/

      call create_position_stack (indx_cb_ptr);
      attach_block.was_msf = (indx_cb.file_base_ptr -> file_base.max_comp_num > 1);

      return;

%include iocb;
%include iox_entries;
%include vfile_indx;
%include vfile_attach_block;
%include iox_modes;
   end vfile_copy_opening_;




		    vfile_io_control.pl1            11/04/82  1940.0rew 11/04/82  1620.4      242937



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


/* this routine is used by io_call to support control
   orders issued to vfile_ from command level */

/* format: style2 */
vfile_io_control:
     proc (iocb_ptr, file_base_ptr, io_call_infop, code);
	is_af = "0"b;				/* not active function entry */
mainline:
	brief_sw = "0"b;
	info_ptr = addr (info);
	if (io_call_info.order_name = "get_key") | (io_call_info.order_name = "gk")
	then do;
		substr_sw = "0"b;
		gk_info_ptr = info_ptr;
		unspec (gk_info.flags) = "0"b;
		gk_info.version = gk_info_version_0;

		do i = 1 to nargs;			/* pick up optional args */
		     if (io_call_info.args (i) = "-substr") | (io_call_info.args (i) = "-su")
		     then if io_call_info.nargs < i + 1
			then go to noarg;
			else do;
				i = i + 1;
				comma_off = index (io_call_info.args (i), ",");
				substr_sw = "1"b;
				if comma_off = 0	/* whole tail wanted */
				then substr_off = fixed (io_call_info.args (i));
				else do;
					substr_off = fixed (substr (io_call_info.args (i), 1, comma_off - 1));
					substr_len = fixed (substr (io_call_info.args (i), comma_off + 1));
				     end;
			     end;
		     else if io_call_info.args (i) = "-head"
						/* next arg is head */
		     then if io_call_info.nargs <= i	/* not enough args */
			then do;
noarg:
				code = error_table_$noarg;
				return;		/* abort */
			     end;
			else do;
				i = i + 1;
handle_head:
				gk_info.input_key = "1"b;
				if gk_info.current
				then go to badarg;	/* -cur_pos and -head conflict */
				gk_info.key_len = length (io_call_info.args (i));
				gk_info.head_size = gk_info.key_len;
				gk_info.key = io_call_info.args (i);
			     end;
		     else if (io_call_info.args (i) = "-desc") | (io_call_info.args (i) = "-ds")
		     then if i = io_call_info.nargs
			then go to noarg;
			else do;
				i = i + 1;
				if gk_info.desc_code = 1
						/* -current descriptor specified */
				then go to badarg;	/* conflicts with given descriptor */
				gk_info.input_desc = "1"b;
				gk_info.descrip = cv_oct_ ((io_call_info.args (i)));
			     end;
		     else if (io_call_info.args (i) = "-reset") | (io_call_info.args (i) = "-rs")
		     then gk_info.reset_pos = "1"b;
		     else if (io_call_info.args (i) = "-current") | (io_call_info.args (i) = "-cur")
		     then if gk_info.input_desc
			then go to badarg;		/* conflicting options */
			else gk_info.desc_code = 1;
		     else if (io_call_info.args (i) = "-rel_type") | (io_call_info.args (i) = "-rel")
		     then if io_call_info.nargs = i
			then go to noarg;
			else do;
				if gk_info.current	/* -cur_pos specified */
				then go to badarg;	/* conflicts */
				i = i + 1;
				gk_info.rel_type = fixed (io_call_info.args (i));
				if (gk_info.rel_type < 0) | (gk_info.rel_type > 2)
				then go to badarg;
			     end;
		     else if io_call_info.args (i) = "-cur_pos"
		     then if gk_info.input_key | (gk_info.rel_type ^= 0)
			then go to badarg;
			else gk_info.current = "1"b;
		     else if (io_call_info.args (i) = "-brief") | (io_call_info.args (i) = "-bf")
		     then brief_sw = "1"b;
		     else if gk_info.input_key	/* head already given */
		     then do;			/* must be an invalid arg */
badarg:
			     code = error_table_$bad_arg;
			     return;
			end;
		     else go to handle_head;
		end;

		call control ("get_key");
		if substr_sw
		then if comma_off = 0
		     then substr_len = gk_info.key_len + 1 - substr_off;
		     else ;
		else do;
			substr_off = 1;
			substr_len = gk_info.key_len;
		     end;
		substr_len = min (substr_len, gk_info.key_len + 1 - substr_off);
		if is_af
		then if code = 0
		     then do;
			     io_call_af_ret = substr (gk_info.key, substr_off, min (af_returnl, substr_len));
			     return;
			end;
		     else do;
			     io_call_af_ret = "";
			     if brief_sw
			     then do;
brief_ret:
				     if code = 0
				     then return;
				     if (code ^= error_table_$no_operation) & (code ^= error_table_$bad_arg)
				     then code = 0;
				     return;
				end;
			end;
		if brief_sw
		then go to brief_ret;
		if code = 0
		then if substr_sw
		     then call io_call_info.report (substr (gk_info.key, substr_off, substr_len));
		     else call io_call_info.report ("key: ^a
descrip: ^o", gk_info.key, gk_info.descrip);
		return;
	     end;

	if ((io_call_info.order_name = "read_position") | (io_call_info.order_name = "rp")) & ^is_af
	then do;					/* no input args--just print results */
		call control ("read_position");
		if code = 0
		then call io_call_info.report ("next pos: ^d
end pos: ^d", rp_info.next_pos, rp_info.end_pos);
	     end;

	else if ((io_call_info.order_name = "record_status") | (io_call_info.order_name = "rs")
		| (io_call_info.order_name = "rsb")) & ^is_af
	then do;
		brief_sw = (io_call_info.order_name = "rsb");
		i = 0;
		if io_call_info.nargs > 0
		then if (io_call_info.args (1) = "-brief") | (io_call_info.args (1) = "-bf")
		     then do;
			     i = 1;
			     brief_sw = "1"b;
			end;
		rs_info_ptr = info_ptr;
		rs_info.version = rs_info_version_2;
		rs_info.record_ptr = null;
		rs_info.ref_count = -1;
		rs_info.modifier = 0;
		rs_info.last_image_modifier = 0;
		if io_call_info.nargs - i >= 1	/* more optional argument given */
		then if io_call_info.args (1 + i) = "-pos"
		     then string (rs_info.flags) = "0000001"b;
						/* locate_pos_sw */
		     else string (rs_info.flags) = substr (bit (io_call_info.args (1 + i)), 1, 7);
		else string (rs_info.flags) = "0"b;
		if rs_info.create_sw		/* two more args required */
		then do;				/* get rec_len and block_size */
			if io_call_info.nargs - i < 2
			then do;
				code = error_table_$noarg;
				return;		/* abort */
			     end;
			rs_info.record_length = fixed (io_call_info.args (2 + i), 21, 0);
						/* length in bytes */
			if nargs = 2 + i		/* max_rec_len not specified, use default */
			then rs_info.max_rec_len = rs_info.record_length;
			else rs_info.max_rec_len = fixed (io_call_info.args (3 + i), 19, 0);
						/* max rec len in bytes */
		     end;
		else if rs_info.locate_sw		/* one additional arg required */
		then if io_call_info.nargs < 2 + i
		     then do;
			     code = error_table_$noarg;
			     return;
			end;
		     else rs_info.descriptor = cv_oct_ ((io_call_info.args (2 + i)));
		else if rs_info.locate_pos_sw
		then if io_call_info.nargs < 2 + i
		     then go to noarg;		/* pos specification required */
		     else do;
			     rs_info.record_length = fixed (io_call_info.args (2 + i));
			     if io_call_info.nargs < 3 + i
			     then rs_info.descriptor = 0;
			     else rs_info.descriptor = cv_oct_ ((io_call_info.args (3 + i)));
			end;
		if rs_info.lock_sw			/* modifier code may be supplied */
		then if rs_info.create_sw & (io_call_info.nargs > 3 + i)
		     then rs_info.modifier = fixed (io_call_info.args (4 + i), 35, 0);
		     else if rs_info.locate_sw & (io_call_info.nargs > 2 + i)
		     then rs_info.modifier = fixed (io_call_info.args (3 + i), 35, 0);
		     else if io_call_info.nargs > 1 + i
		     then rs_info.modifier = fixed (io_call_info.args (2 + i), 35, 0);
		call control ("record_status");
		if brief_sw
		then go to brief_ret;
		if (code ^= 0) & (rs_info.record_ptr = null) & (rs_info.ref_count = -1)
						/* no info returned */
		then return;			/* don't print out a bunch of garbage */
		call io_call_info.report ("record bytes: ^d
max rec bytes: ^d", rs_info.record_length, rs_info.max_rec_len);
		if rs_info.max_rec_len ^= 0		/* block has been allocated */
		then call io_call_info.report ("record ptr: ^p
descriptor: ^o", rs_info.record_ptr, rs_info.descriptor);
		if rs_info.ref_count >= 0		/* more stats to print */
		then do;
			call date_time_ (rs_info.time_last_modified, date_time);
			call io_call_info.report ("ref count: ^d
last changed: ^a", rs_info.ref_count, date_time);

			if rs_info.modifier ^= 0
			then call io_call_info.report ("modifier: ^d", rs_info.modifier);
			if rs_info.last_image_modifier ^= 0
			then call io_call_info.report ("last modifier: ^d", rs_info.last_image_modifier);
		     end;
	     end;

	else if ((io_call_info.order_name = "seek_head") | (io_call_info.order_name = "sh")) & ^is_af
	then if io_call_info.nargs < 1		/* one or two are required */
	     then code = error_table_$noarg;
	     else if io_call_info.nargs > 3
	     then code = error_table_$too_many_args;
	     else do;				/* set up info structure */
		     i = 0;
		     if (io_call_info.args (1) = "-brief") | (io_call_info.args (1) = "-bf")
		     then do;
			     i = 1;
			     brief_sw = "1"b;
			end;
		     if io_call_info.nargs = 1 + i	/* use default rel_type=0 */
		     then sh_info.rel_type = 0;
		     else sh_info.rel_type = fixed (io_call_info.args (1 + i), 17, 0);
						/* 0,1, or 2 to
						   indicate =,>=, or > */
		     if (io_call_info.nargs = 3) & ^brief_sw
		     then code = error_table_$bad_arg;
		     else do;
			     sh_info.key_len = length (io_call_info.args (io_call_info.nargs));
						/* length of search key */
			     sh_info.key = io_call_info.args (io_call_info.nargs);
						/* for comparison with key heads */
			     call control ("seek_head");
			end;
		     if brief_sw
		     then go to brief_ret;
		     return;
		end;

	else if ((io_call_info.order_name = "add_key") | (io_call_info.order_name = "ak")) & ^is_af
	then if io_call_info.nargs < 1		/* one arg required */
	     then code = error_table_$noarg;
	     else do;
		     call get_ak_args;
		     call control ("add_key");
		end;

	else if ((io_call_info.order_name = "delete_key") | (io_call_info.order_name = "dk")) & ^is_af
	then if io_call_info.nargs >= 1		/* args are optional */
	     then do;
		     call get_ak_args;
		     call control ("delete_key");
		end;
	     else call iox_$control (iocb_ptr, "delete_key", (null), code);

	else if ((io_call_info.order_name = "reassign_key") | (io_call_info.order_name = "rk")) & ^is_af
	then if io_call_info.nargs < 2		/* two args required */
	     then code = error_table_$noarg;
	     else do;
		     call get_rk_args;
		     call control ("reassign_key");	/* make given key point to current rec */
		end;

	else if (io_call_info.order_name = "select") | (io_call_info.order_name = "sl")
	then do;
		unspec (common_sl_info.flags) = "0"b;
		common_sl_info.version = sl_info_version_0;
		common_sl_info.desc_arrayp = null;
		if nargs = 0			/* just return status of current subset */
		then do;
			common_sl_info.array_limit = 0;
						/* without tail structure */
			common_sl_info.status_only = "1"b;
		     end;
		else do;
			call process_select_args;
			if code ^= 0
			then go to exit;
			call build_select_info;
		     end;
		call control ("select");
		if is_af
		then do;				/* handle active function reference */
			if (code ^= 0) & (code = error_table_$no_record)
						/* seletion of null set */
			then io_call_af_ret = "-0";	/* special notation for the null set */
			else io_call_af_ret = char (common_sl_info.subset_no);
						/* return the subset number */
			if brief_sw
			then go to brief_ret;	/* see if code should be cleared */
			return;			/* finished with active function evaluation */
		     end;
		if (code = 0) & ^brief_sw
		then call report_subset_status;
		if common_sl_info.output_descriptors & (code = 0)
		then call list_descriptors;		/* frees temporary descriptor array */
		if brief_sw
		then go to brief_ret;
	     end;

	else if (io_call_info.order_name = "exclude") | (io_call_info.order_name = "ex")
	then if io_call_info.nargs < 1		/* arg required */
	     then code = error_table_$noarg;
	     else do;
		     unspec (common_sl_info.flags) = "0"b;
		     common_sl_info.version = sl_info_version_0;
		     common_sl_info.desc_arrayp = null;
		     call process_select_args;
		     if code ^= 0
		     then go to exit;
		     call build_select_info;
		     call control ("exclude");
		     if is_af
		     then do;
			     if (code ^= 0) & (code = error_table_$no_record)
						/* seletion of null set */
			     then io_call_af_ret = "-0";
						/* special notation for the null set */
			     else io_call_af_ret = char (common_sl_info.subset_no);
						/* return the subset number */
			     if brief_sw
			     then go to brief_ret;
			     return;
			end;
		     if (code = 0) & ^brief_sw
		     then call report_subset_status;
		     if common_sl_info.output_descriptors & (code = 0)
		     then call list_descriptors;
		     if brief_sw
		     then go to brief_ret;
		end;

	else if is_af				/* called as an active function */
	then do;					/* error -- not permitted for any of the following orders */
		code = error_table_$no_operation;
		return;
	     end;
	else if (io_call_info.order_name = "tr") /* no info struc required */ | (io_call_info.order_name = "tc")
	then call control ("truncate");

	else if (io_call_info.order_name = "max_rec_len") | (io_call_info.order_name = "mx")
	then do;					/* takes one optional arg */
		if io_call_info.nargs >= 1		/* arg present */
		then mx_info.new_max_recl = fixed (io_call_info.args (1), 21, 0);
		else mx_info.new_max_recl = 0;	/* indicates no chanfge */
		call control ("max_rec_len");
		if code = 0
		then call io_call_info.report ("old max recl: ^d", mx_info.old_max_recl);
	     end;

	else if (io_call_info.order_name = "error_status") | (io_call_info.order_name = "er")
	then do;					/* no inputs--print results */
		er_info.version = 1;		/* only version supported */
		call control ("error_status");
		if code = 0
		then if er_info.error_type = 0
		     then call io_call_info.error (0, io_call_info.caller_name, "no errors");
		     else call io_call_info.report ("requested: ^d
received: ^d", er_info.requested, er_info.received);
	     end;

	else if (io_call_info.order_name = "min_block_size") | (io_call_info.order_name = "mb")
	then do;
		if io_call_info.nargs < 1
		then do;
			mb_info.min_cap = 0;
			mb_info.min_res = 0;
		     end;
		else mb_info.min_res = fixed (io_call_info.args (1), 17, 0);
		if io_call_info.nargs < 2
		then mb_info.min_cap = 0;
		else mb_info.min_cap = fixed (io_call_info.args (2), 21, 0);
		call control ("min_block_size");
	     end;

	else if (io_call_info.order_name = "set_wait_time") | (io_call_info.order_name = "sw")
	then if io_call_info.nargs < 1
	     then code = error_table_$noarg;
	     else do;
		     if io_call_info.nargs = 1
		     then new_wait_time = float (io_call_info.args (1));
		     else if (io_call_info.args (1) = "-cdtm") | (io_call_info.args (1) = "-collection_delay_time")
		     then do;
			     wt_info.version = -2;
			     wt_info.collection_delay_time = float (io_call_info.args (2));
			end;
		     else do;
			     code = error_table_$too_many_args;
			     return;
			end;
		     call control ("set_wait_time");
		end;

	else if (io_call_info.order_name = "set_file_lock") | (io_call_info.order_name = "sf")
	then if io_call_info.nargs < 1
	     then code = error_table_$noarg;
	     else do;
		     set_lock_flag = bit (io_call_info.args (1), 2);
		     call control ("set_file_lock");
		end;

	else if (io_call_info.order_name = "file_status") | (io_call_info.order_name = "fs")
	then call vfile_status$print_ (iocb_ptr, file_base_ptr, io_call_info.report, code);
	else call control ((io_call_info.order_name));	/* no info struc */

	return;					/* end of vfile_io_control main routine */

af:
     entry (iocb_ptr, file_base_ptr, io_call_infop, code);
	is_af = "1"b;
	go to mainline;				/* let each order do it's thing */

control:
     proc (order_arg);				/* passes order call through iox_ */
	call iox_$control (iocb_ptr, (order_arg), addr (info), code);
	dcl     order_arg		 char (24) var;
     end control;

get_ak_args:
     proc;					/*  picks up optional key and descrip */
	ak_info_ptr = info_ptr;
	if nargs = 1
	then do;					/* use default switch settings--adding key to current */
		string (ak_info.flags) = "10"b;	/* just input key */
		ak_info.key_len = length (io_call_info.args (1));
		ak_info.key = io_call_info.args (1);
		return;
	     end;
	string (ak_info.flags) = bit (io_call_info.args (1));
	if ak_info.input_key & ak_info.input_desc & (io_call_info.nargs < 3)
	then do;					/* error */
noarg:
		code = error_table_$noarg;
		go to exit;
	     end;
	if ak_info.input_key
	then do;					/* pick up key arg */
		ak_info.key_len = length (io_call_info.args (2));
		ak_info.key = io_call_info.args (2);
		if ak_info.input_desc		/* descrip also given */
		then ak_info.descrip = cv_oct_ ((io_call_info.args (3)));
	     end;
	else ak_info.descrip = cv_oct_ ((io_call_info.args (2)));
	return;					/* end of get_ak_args routine */

get_rk_args:
     entry;					/* picks up optional args for "reassign_key" order */
	rk_info_ptr = info_ptr;
	string (rk_info.flags) = bit (io_call_info.args (1));
	if rk_info.input_key
	then do;					/* pick up key arg */
		rk_info.key_len = length (io_call_info.args (2));
		rk_info.key = io_call_info.args (2);
		if io_call_info.nargs < 3		/* at least one more arg required */
		then go to noarg;			/* error */
		if rk_info.input_old_desc
		then do;				/* may be two more args */
			rk_info.old_descrip = cv_oct_ ((io_call_info.args (3)));
			if rk_info.input_new_desc	/* yes--there is another arg */
			then if io_call_info.nargs < 4
			     then go to noarg;
			     else rk_info.new_descrip = cv_oct_ ((io_call_info.args (4)));
		     end;
		else rk_info.new_descrip = cv_oct_ ((io_call_info.args (3)));
	     end;
	else if rk_info.input_old_desc
	then do;
		rk_info.old_descrip = cv_oct_ ((io_call_info.args (2)));
		if rk_info.input_new_desc
		then if io_call_info.nargs < 3
		     then go to noarg;
		     else rk_info.new_descrip = cv_oct_ ((io_call_info.args (3)));
	     end;
	else rk_info.new_descrip = cv_oct_ ((io_call_info.args (2)));
	return;					/* end of get_rk_args routine */
     end get_ak_args;

process_select_args:
     proc;					/* builds info structure elements for "select" order */
	sl_array_limit = 0;
	i = 1;
	if is_bf_or_ls_opt ()
	then do;
		i = 2;
		if io_call_info.nargs = 1
		then do;
			common_sl_info.status_only = "1"b;
			return;
		     end;
	     end;
	common_sl_info.status_only = "0"b;
	if (io_call_info.args (i) = "-reset") | (io_call_info.args (i) = "-rs")
	then do;
		common_sl_info.list_type = 0;		/* indicates re-selection */
		if nargs > i
		then common_sl_info.subset_no = fixed (io_call_info.args (i + 1));
		else common_sl_info.subset_no = 0;	/* default is identity subset */
		common_sl_info.array_limit = 0;	/* smallest info structure supported */
		return;				/* done processing args */
	     end;
	common_sl_info.list_type = 1;
	if io_call_info.args (io_call_info.nargs) = "-delete_old_subsets" | io_call_info.args (io_call_info.nargs) = "-dos"
	then common_sl_info.delete_old_subsets = "1"b;

	if (io_call_info.args (i) = "-or") | /* wants default delimiter */ (io_call_info.args (i) = "-or_key")
	     | (io_call_info.args (i) = "-ork")
	then do;
		default_delim = io_call_info.args (i);
		if default_delim = "-or_key"
		then default_delim = "-ork";
		i = i + 1;
		if i > nargs
		then go to no_arg;
	     end;
	else default_delim = "";
	if (default_delim = "") & ((io_call_info.args (i) = "-desc") | (io_call_info.args (i) = "-ds"))
	then do;
		call build_array;
		return;
	     end;
	if (default_delim = "") | (default_delim = "-or")
	then if io_call_info.args (i) = "-head"
	     then do;
		     i = i + 1;			/* advance to next arg */
		     head = "1"b;			/* list of intervals representation */
		end;
	     else if io_call_info.args (i) = "-key"
	     then do;
		     i = i + 1;
		     head = "0"b;			/* first interval must match key exactly */
		end;
	     else head = "1"b;
	else head = "0"b;

	do int = 1 to max_int;			/* for each index interval specified */
	     len = length (io_call_info.args (i));
	     f_head.length (int) = len;
	     f_head.kptr (int) = addrel (addr (io_call_info.args (i)), 1);
	     i = i + 1;
	     if i > nargs - bin (common_sl_info.delete_old_subsets)
	     then do;
		     if head
		     then l_head.length (int) = len;
		     else l_head.length (int) = -1;	/* by convention, indicates exact key match */
		     l_head.kptr (int) = f_head.kptr (int);
		     return;
		end;
	     if (default_delim = "")
		& ((io_call_info.args (i) = "-or") | (io_call_info.args (i) = "-ork")
		| (io_call_info.args (i) = "-or_key"))
	     then do;
		     i = i + 1;
new_int:
		     if head
		     then l_head.length (int) = len;
		     else l_head.length (int) = -1;
		     l_head.kptr (int) = f_head.kptr (int);
		     if (default_delim = "-or") | ((default_delim ^= "-ork") & (io_call_info.args (i - 1) = "-or"))
		     then head = "1"b;
		     else head = "0"b;
		     if i > nargs
		     then do;
no_arg:
			     code = error_table_$noarg;
			     return;
			end;
		end;
	     else if (default_delim ^= "-ork") & ((io_call_info.args (i) = "-thru") | (io_call_info.args (i) = "-to"))
	     then if ^head
		then do;				/* error-- "-thru" not allowed with key match spec */
bad_arg:
			code = error_table_$bad_arg;
			return;			/* abort */
		     end;
		else do;
			i = i + 1;
			if i > nargs
			then go to no_arg;
			len = length (io_call_info.args (i));
			if io_call_info.args (i - 1) = "-to"
						/* open ended interval */
			then l_head.length (int) = -len;
						/* convention for indicating open interval */
			else l_head.length (int) = len;
						/* inclusive interval */
			l_head.kptr (int) = addrel (addr (io_call_info.args (i)), 1);
			i = i + 1;
			if i > nargs
			then return;
			if (default_delim = "")
			     & ((io_call_info.args (i) ^= "-or") & (io_call_info.args (i) ^= "-ork")
			     & (io_call_info.args (i) ^= "-or_key"))
			then go to bad_arg;
			if default_delim = ""
			then i = i + 1;
			if i > nargs
			then go to no_arg;
		     end;
	     else if default_delim = ""
	     then go to bad_arg;
	     else go to new_int;
	end;					/* end of arg pick-up loop */

	code = error_table_$too_many_args;
     end process_select_args;

report_subset_status:
     proc;
	call io_call_info.report ("subset: ^d ,records: ^d", common_sl_info.subset_no, common_sl_info.count);
     end report_subset_status;

list_descriptors:
     proc;					/* prints list of octal descriptors and frees list allocation */

	do i = 1 to common_sl_info.count;		/* loop through array elements */
	     call io_call_info.report ("^o", common_sl_info.desc_arrayp -> desc_array (i));
	end;

	free common_sl_info.desc_arrayp -> desc_array;
     end list_descriptors;

is_bf_or_ls_opt:
     proc returns (bit (1) aligned);
	if (io_call_info.args (i) = "-brief") | (io_call_info.args (i) = "-bf")
	then do;
		brief_sw = "1"b;
		return ("1"b);
	     end;
	if (io_call_info.args (i) = "-list") | (io_call_info.args (i) = "-ls")
	then do;
		common_sl_info.output_descriptors = "1"b;
		return ("1"b);
	     end;
	return ("0"b);
     end is_bf_or_ls_opt;

build_select_info:
     proc;					/* prepares info structure for select or exclude */
	if common_sl_info.list_type ^= 1
	then return;				/* no tail structure required */
	common_sl_info.array_limit = int;
	if size (hi_sl_info) > max_info_size
	then do;					/* implementation limit */
		code = error_table_$too_many_args;
		go to exit;
	     end;

	do i = 1 to int;
	     hi_sl_info.interval (i) = temp_int (i);
	end;

	dcl     i			 fixed;
     end build_select_info;

build_array:
     proc;					/* prepares info structure for descriptor list */
	common_sl_info.list_type = 2;			/* code for descriptor array specification */
	common_sl_info.array_limit = nargs - i;		/* prev arg was -ds or -desc */
	if size (da_sl_info) > max_info_size		/* implementation limit--should do allocation if necessary */
	then do;					/* cop out solution--eventually do this better */
		code = error_table_$too_many_args;
		go to exit;			/* abort */
	     end;

	do n = i + 1 to nargs;			/* pick up descriptor args */
	     da_sl_info.desc_array (n - i) = cv_oct_ ((io_call_info.args (n)));
	end;

	dcl     n			 fixed;
     end build_array;

exit:
	return;					/* external exit */

	dcl     iocb_ptr		 ptr;
	dcl     is_af		 bit (1) aligned;
	dcl     brief_sw		 bit (1) aligned;
	dcl     (i, len)		 fixed;
	dcl     info_ptr		 ptr;
	dcl     vfile_status$print_	 entry (ptr, ptr, entry options (variable), fixed (35));
	dcl     date_time_		 entry (fixed (71), char (*));
	dcl     date_time		 char (24);
	dcl     file_base_ptr	 ptr;
%include rs_info;
%include io_call_info;
	dcl     code		 fixed (35);
	dcl     (char, fixed, unspec, string, length, addr, null, size)
				 builtin;
%include vfile_error_codes;
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed (35));
	dcl     max_info_size	 static fixed internal options (constant) init (200);
	dcl     1 wt_info		 based (addr (info)),
		2 version		 float,
		2 collection_delay_time
				 float;
	dcl     1 info,				/* large enough for any vfile_ supported info struc */
		2 words		 (max_info_size) fixed;
						/* largest info structure */
	dcl     1 sh_info		 based (addr (info)),
						/* for "seek_head" */
		2 rel_type	 fixed,		/* 0,1, or 2 for =,>=, or > */
		2 key_len		 fixed,		/* length of search key below */
		2 key		 char (256);	/* compared with key heads in file */
	dcl     1 rp_info		 based (addr (info)),
						/* for "read_position" */
		2 next_pos	 fixed (34),	/* abs position of next byte or record */
		2 end_pos		 fixed (34);	/* total count of bytes or records in file */
	dcl     1 mx_info		 based (addr (info)),
						/* for "max_rec_len" */
		2 old_max_recl	 fixed (21),	/* output */
		2 new_max_recl	 fixed (21);	/* input--zero indicates no change */
	dcl     1 er_info		 based (addr (info)),
						/* for "error_status" */
		2 version		 fixed,		/* (Input) must=1 */
		2 error_type	 fixed,		/* only one currently supported */
		2 requested	 fixed (34),	/* position skip arg issued on call */
		2 received	 fixed (34);	/* successful skips actually made */
	dcl     1 mb_info		 based (addr (info)),
						/* for "min_block_size" */
		2 min_res		 fixed (21),
		2 min_cap		 fixed (21);	/* minimum allocation for record block */
	dcl     new_wait_time	 float based (addr (info));
	dcl     set_lock_flag	 bit (2) aligned based (addr (info));
	dcl     cv_oct_		 entry (char (*)) returns (fixed (35));
%include ak_info;
%include select_info;
	dcl     int		 fixed;
	dcl     1 temp_int		 (1:max_int),
		2 f_head,
		  3 length	 fixed,
		  3 kptr		 ptr,
		2 l_head,
		  3 length	 fixed,
		  3 kptr		 ptr;
	dcl     max_int		 static fixed options (constant) init (50);
	dcl     head		 bit (1) aligned;
	dcl     default_delim	 char (8) aligned;
	dcl     comma_off		 fixed;
	dcl     substr_off		 fixed;
	dcl     substr_len		 fixed;
	dcl     substr_sw		 bit (1) aligned;
     end vfile_io_control;




		    vfile_status.pl1                11/04/82  1940.0rew 11/04/82  1621.3       99162



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


/* This routine prints information about storage system
   files given a pathname (star convention permitted).
   Info provided includes the file's apparent type
   and various statistics */

vfs:
vfile_status:
     proc (pathname_arg);
	command_entry = "1"b;
	report = ioa_;				/* differs for subroutine entry */
	e_ptr = null;				/* won't free unless non-null */
	call cu_$arg_count (n_args);			/* args with which command was invoked */
	if n_args <= 0
	then code = error_table_$noarg;
	else if n_args > 1
	then code = error_table_$too_many_args;
	else code = 0;
	call check_code;				/* aborts on error */
	call get_star_names;			/* interprets pathname_arg */
status_loop:
	info.info_version = vfs_version_1;

	do i = 1 to e_count;			/* check each entry matching star_name */
	     if is_real_file ()			/* don't consider directories */
	     then if info.type = 1			/* unstructured */
		then call proc_uns_file;
		else if info.type = 2		/* sequential */
		then call proc_seq_file;
		else if info.type = 3		/* blocked */
		then call proc_blk_file;
		else if info.type = 4		/* indexed */
		then call proc_indx_file;		/* must be indexed */
	end;

	if command_entry & ^file_found		/* only directories or empty files found */
	then call com_err_ (0, "vfile_status", "No file found for given pathname.");
	else do;
cleanup:
		if ^command_entry			/* set return code */
		then code_arg = code;
	     end;
	if e_ptr ^= null
	then free entries, names in (a);
	return;					/* end of main file status routine */

print_:
     entry (iocb_ptr, file_base_ptr, report_arg, code_arg);
	report = report_arg;			/* set by io_call */
	command_entry = "0"b;
	e_count = 1;				/* one file only */
	is_star_name = "0"b;
	e_ptr = null;				/* prevents attempt to cleanup */
	go to status_loop;				/* print status of file */

get_star_names:
     proc;					/* expands argument in star convention */
	file_found = "0"b;				/* will be set if non-null, non-dir seg is found */
	call expand_path_ (addr (pathname_arg), length (pathname_arg), addr (d_name), addr (e_name), code);
						/* gets full path and ent names */
	call check_code;				/* aborts on non-zero error code */
	if index (e_name, "*") = 0			/* not a star name */
	then do;
		e_count = 1;			/* only one entry to consider */
		is_star_name = "0"b;		/* suppresses printout of pathname */
		return;
	     end;
	else is_star_name = "1"b;
	area_ptr = get_system_free_area_ ();		/* temp space for star_name info */
	call hcs_$star_ (d_name, e_name, 3 /* all types of entries */, area_ptr, e_count, e_ptr, n_ptr, code);
						/* finds matching entries */
	call check_code;
	d_len = length (d_name) + 1 - verify (reverse (d_name), " ");
						/* directory
						   pathname length */
	tot_names = 0;				/* will be set in following loop */

	do i = 1 to e_count;			/* get total extent of names structure allocated */
	     tot_names = tot_names + fixed (n_names (i));
	end;

     end get_star_names;

check_code:
     proc;					/* aborts if nonzero error code detected */
	if code = 0
	then return;
	if command_entry				/* first print message */
	then call com_err_ (code, "vfile_status");	/* prints error info */
	go to cleanup;				/* frees allocated system storage and closes msf */
     end check_code;

is_real_file:
     proc returns (bit (1) aligned);			/* non-dir seg */
	if is_star_name				/* get an entry name */
	then e_name = n_ptr -> names (fixed (e_ptr -> entries.n_index (i)));
						/* the i'th entry name */
	if command_entry
	then call vfile_status_ (d_name, e_name, addr (info), code);
						/* gets file info */
	else call vfile_status_$seg (iocb_ptr, file_base_ptr, addr (info), code);
	if (code = error_table_$dirseg) | (code = error_table_$noentry)
	then if command_entry
	     then return ("0"b);			/* ignore directories and non-existing entries */
	call check_code;
	if is_star_name				/* print pathname */
	then call report ("^a", substr (d_name, 1, d_len) || ">" || e_name);
	file_found = "1"b;
	return ("1"b);				/* indicates real data file found for i'th entry */
     end is_real_file;

proc_uns_file:
     proc;					/* prints info about unstructured files */
	call report ("type: unstructured
bytes: ^d", uns_info.end_pos);
	if uns_info.header_present			/* header is optional */
	then call report ("header: ^d", uns_info.header_id);
     end proc_uns_file;

proc_seq_file:
     proc;					/* prints info about sequential files */
	call report ("type: sequential");
	call print_common_info;
	if seq_info.version < 12
	then call report ("version: old (no record count)");
	else if seq_info.version < current_seq_version
	then call report ("version: old (pre-MR6.0)");
	call report_action (seq_info.action);
     end proc_seq_file;

proc_blk_file:
     proc;					/* prints info about blocked files */
	call report ("type: blocked");
	call print_common_info;
	if blk_info.version < current_blk_version
	then call report ("version: old (pre-MR6.0)");
	else do;					/* version supports time_stamp */
		call date_time_ (blk_info.time_last_modified, date_time);
		call report ("last changed: ^a", date_time);
	     end;
	call report_action (blk_info.action);
	call report ("max recl: ^d bytes", blk_info.max_rec_len);
     end proc_blk_file;

report_action:
     proc (action_code);				/* routine deciphers action codes for updates in progress */
	if (action_code < -14) | (action_code > 3)	/* unknown code */
	then call report ("action: unknown operation in progress");
	else if action_code ^= 0			/* operation in progress */
	then call report ("action: ^a in progress", operation (-1 * (action_code)));
	dcl     operation		 (-3:14) char (24) var static options (constant)
				 init ("checkpoint", "non-checkpoint opening", "truncate", "", "write_record",
				 "rewrite_record", "delete_record", "add_key", "delete_key", "record_status(create)",
				 "exclusive opening", "reassign_key", "write_record (truncate)",
				 "delete_record (non-eof)", "unshared opening", "adjust_record",
				 "adjust_record (rollback)", "recovery");
	dcl     action_code		 fixed;
     end report_action;

print_common_info:
     proc;					/* if file is locked, info is printed out; also record count */
	if ^((info.type = 2 /* sequential */) & (seq_info.version < 12))
	then call report ("records: ^d", info.records);	/* end pos in same loc for all struc files */
	if info.lock_status ^= "00"b			/* file is locked */
	then if info.lock_status = "01"b		/* busy in another process */
	     then call report ("state: locked by another process");
	     else if info.lock_status = "10"b
	     then call report ("state: locked by this process");
	     else call report ("state: locked by dead process");
     end print_common_info;

proc_indx_file:
     proc;					/* prints info about indexed files */
	call report ("type: indexed");
	call print_common_info;			/* record count and lock status */
	if (indx_info.program_version < 33)
	then if ((indx_info.program_version = 21) | ((indx_info.program_version < 21) & (indx_info.file_version = 20)))
	     then call report
		     (
		     "version: Warning--total record length statistic is bad
because of vfile_ bug.  Use the vfile_adjust command to
correct the problem."
		     );				/* opening the file for modification also will
						   automatically adjust the bad statistic */
	     else call report ("version: old version--does not support even-word aligned records.");
	call report_action (indx_info.action);		/* prints if file inconsistent */
	if (indx_info.non_null_recs ^= indx_info.records)
	     & ((indx_info.program_version >= 23) | (indx_info.file_version = 10))
	then call report ("alloc recs: ^d", indx_info.non_null_recs);
	if (indx_info.records ^= 0) | (indx_info.record_bytes ^= 0)
	then call report ("record bytes: ^d", indx_info.record_bytes);
	if (indx_info.records ^= 0) | (indx_info.free_blocks ^= 0)
	then call report ("free blocks: ^d", indx_info.free_blocks);
	if (indx_info.num_keys ^= 0) | (indx_info.nodes ^= 0) | (indx_info.index_height ^= 0) | (indx_info.key_bytes ^= 0)
	then call report ("index height: ^d
nodes: ^d
key bytes: ^d", indx_info.index_height, indx_info.nodes,
		indx_info.key_bytes);
	if indx_info.num_keys ^= indx_info.records
	then call report ("keys: ^d", indx_info.num_keys);
	if indx_info.dup_keys ^= 0
	then call report ("dup keys: ^d
dup key bytes: ^d", indx_info.dup_keys, indx_info.dup_key_bytes);
     end proc_indx_file;

/* declarations for entire program */
	dcl     code_arg		 fixed (35);
	dcl     is_star_name	 bit (1) aligned;
	dcl     command_entry	 bit (1) aligned;
	dcl     file_base_ptr	 ptr;
	dcl     iocb_ptr		 ptr;
	dcl     vfile_status_	 entry (char (*) aligned, char (*) aligned, ptr, fixed (35));
	dcl     vfile_status_$seg	 entry (ptr, ptr, ptr, fixed (35));
	dcl     a			 area based (area_ptr);
	dcl     cu_$arg_count	 entry (fixed);
	dcl     n_args		 fixed;
	dcl     (error_table_$noarg, error_table_$noentry, error_table_$too_many_args)
				 external fixed (35);
	dcl     pathname_arg	 char (*);
	dcl     (i, e_count)	 fixed;
	dcl     report		 entry variable options (variable);
	dcl     (ioa_, report_arg)	 entry options (variable);
	dcl     code		 fixed (35);
	dcl     (null, index, fixed)	 builtin;
	dcl     file_found		 bit (1) aligned;
	dcl     (e_ptr, n_ptr)	 ptr;
	dcl     expand_path_	 entry (ptr, fixed, ptr, ptr, fixed (35));
	dcl     (addr, length)	 builtin;
	dcl     d_name		 char (168) aligned;
	dcl     e_name		 char (32) aligned;
	dcl     area_ptr		 ptr;
	dcl     get_system_free_area_	 entry returns (ptr);
	dcl     hcs_$star_		 entry (char (*) aligned, char (*) aligned, fixed (2), ptr, fixed, ptr, ptr,
				 fixed (35));
	dcl     d_len		 fixed;
	dcl     (verify, reverse)	 builtin;
	dcl     com_err_		 entry options (variable);
	dcl     names		 (tot_names) char (32) aligned based (n_ptr);
	dcl     tot_names		 fixed;
	dcl     1 entries		 (e_count) aligned based (e_ptr),
	        ( 2 type		 bit (2),
		2 n_names		 bit (16),
		2 n_index		 bit (18)
		)		 unal;
	dcl     error_table_$dirseg	 external fixed (35);
	dcl     substr		 builtin;
	dcl     current_indx_version	 static options (constant) internal fixed init (40);
	dcl     current_blk_version	 static options (constant) internal fixed init (1);
	dcl     current_seq_version	 static options (constant) internal fixed init (13);
	dcl     abs		 builtin;
	dcl     truncating		 fixed static options (constant) internal init (1);
	dcl     1 info		 like indx_info;
	dcl     date_time_		 entry (fixed (71), char (*));
	dcl     date_time		 char (24);
%include vfs_info;

     end vfile_status;




		    vfile_status_.pl1               09/26/83  1121.8re  09/26/83  1117.4      195408



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

/* DESCRIPTION:
   This routine supplies information about a storage system file
   given its pathname.  Information includes the file's type and
   various appropriate statistics. 
*/

/* HISTORY:

Written by Mike Asherman.
Modified:
05/16/83 by Lindsey Spratt:  Fixed to destroy the temporary iocb.
*/

/* format: style2 */
vfile_status_:
     proc (d_name_arg, e_name_arg, info_ptr, code);
	seg_ptr_entry = "0"b;			/* this is the pathname entry */
	d_name = d_name_arg;
	e_name = e_name_arg;
	iocb_ptr = null;				/* indicates no I/O switch */
	call get_file_base;				/* finds first seg and gets pointer */
	call check_access;				/* verifies that user has read access */
get_status:
	if info_ptr -> info.version ^= vfs_version_1
	then do;
		code = error_table_$bad_arg;
		return;
	     end;
	if seg_ptr -> common_header.file_code = seq_code	/* file is sequential */
	then call proc_seq_file;
	else if seg_ptr -> common_header.file_code = blk_code
						/* file is blocked */
	then call proc_blk_file;
	else if seg_ptr -> common_header.file_code = indx_code
						/* indexed file */
	then call proc_indx_file;
	else call proc_uns_file;			/* must be unstructured */
cleanup:
	if seg_ptr_entry & ^not_open			/* no cleanup necessary */
	then return;
	if fcb_ptr ^= null
	then call msf_manager_$close (fcb_ptr);		/* frees the control block */
	else if seg_ptr ^= null
	then call hcs_$terminate_noname (seg_ptr, foo);
	if iocb_ptr ^= null				/* I/O switch may be attached and open */
	then do;					/* close and detach */
		call iox_$close (iocb_ptr, foo);
		if ^seg_ptr_entry
		then do;
			call iox_$detach_iocb (iocb_ptr, foo);
			call iox_$destroy_iocb (iocb_ptr, foo);
		     end;
	     end;
	return;					/* end of main vfile_status_ routine */

seg:
     entry (iocb_ptr_arg, seg_ptr_arg, info_ptr, code);
	seg_ptr_entry = "1"b;
	iocb_ptr = iocb_ptr_arg;
	not_open = (iocb_ptr -> iocb.open_descrip_ptr = null);
	if not_open				/* seg pointer not yet obtained */
	then do;
		d_name = substr (atb.attach_descrip_string, 8, atb.dname_len);
		e_name = substr (atb.attach_descrip_string, 9 + dname_len, ename_len);
		call get_file_base;
		call check_access;
		go to get_status;
	     end;
	seg_ptr = seg_ptr_arg;
	code = 0;
	go to get_status;

check_code:
     proc;					/* aborts if non-zero error code */
	if code ^= 0
	then go to cleanup;				/* don't leave a mess */
     end check_code;

get_file_base:
     proc;					/* finds first file component and sets seg_ptr */
	seg_ptr = null;				/* segment not initiated */
	fcb_ptr = null;				/* will be non-null if msf opened */
	call hcs_$status_long (d_name, e_name, 1, addr (branch_info), null, code);
	if code ^= 0
	then if code = error_table_$no_s_permission
	     then code = 0;				/* not really an error */
	     else go to cleanup;			/* error--abort */
	if branch_info.type = "10"b			/* directory or msf */
	then if branch_info.bit_count = "0"b		/* directory */
	     then code = error_table_$dirseg;
	     else do;				/* get ptr to base of msf */
		     call msf_manager_$open ((d_name), (e_name), fcb_ptr, code);
						/* creates control block */
		     call check_code;		/* abort on error */
		     call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, seg_ptr, bc, code);
						/* pointer to base of file */
		     if seg_ptr ^= null
		     then code = 0;			/* reset spurious code */
		end;
	else do;					/* get ptr to base of segment */
		call hcs_$initiate (d_name, e_name, "", 0, 1, seg_ptr, code);
		if seg_ptr ^= null
		then code = 0;			/* no error if pointer returned */
	     end;
	call check_code;
     end get_file_base;

check_access:
     proc;					/* checks for read access to segment */
	mode = 0;					/* read bit will be set if access OK */
	call hcs_$fs_get_mode (seg_ptr, mode, code);	/* gets access mode */
	if ^substr (bit (mode), 2, 1)			/* read bit not set */
	then code = error_table_$moderr;
	call check_code;
     end check_access;

get_lock_status:
     proc;					/* finds state of file lock */
	lock_word = seg_ptr -> common_header.file_lock;	/* copy the file's lock */
	call set_lock_$lock (lock_word, 0, foo);	/* returned code (foo) reveals status */
	if foo = 0				/* not locked */
	then info_ptr -> seq_info.lock_status = "00"b;	/* all structured files have this in the same place */
	else if foo = error_table_$lock_wait_time_exceeded
	then info_ptr -> seq_info.lock_status = "01"b;	/* locked by another process */
	else if foo = error_table_$locked_by_this_process
	then info_ptr -> seq_info.lock_status = "10"b;	/* busy in caller's process */
	else info_ptr -> seq_info.lock_status = "11"b;	/* locked by defunct process */
     end get_lock_status;

proc_uns_file:
     proc;					/* gets info for unstructured files */
	info_ptr -> uns_info.type = 1;		/* identifies file as unstructured */
	info_ptr -> uns_info.header_present = (seg_ptr -> common_header.file_code = uns_code);
						/* no header unless code */
	if info_ptr -> uns_info.header_present		/* pick up identifier from header */
	then info_ptr -> uns_info.header_id = seg_ptr -> uns_header.identifier;
	if ^seg_ptr_entry				/* don't already have an I/O switch */
	then do;
		d_len = length (d_name) + 1 - verify (reverse (d_name), " ");
						/* don't count trailing blanks */
		atd = "vfile_ " || substr (d_name, 1, d_len) || ">" || e_name;
		if info_ptr -> uns_info.header_present
		then atd = atd || " -header";
		call iox_$attach_ioname (unique_chars_ ("0"b), iocb_ptr, atd, code);
						/* attach uniquely named switch */
		call check_code;
open_it:
		call iox_$open (iocb_ptr, 1 /* stream_input */, "0"b, code);
						/* open file for input */
		call check_code;
	     end;
	else if not_open				/* switch already attached */
	then go to open_it;
	call iox_$control (iocb_ptr, "read_position", addr (rp_info), code);
						/* gets byte count of file */
	call check_code;
	info_ptr -> uns_info.end_pos = rp_info.end_pos;
	dcl     d_len		 fixed;
     end proc_uns_file;

proc_seq_file:
     proc;					/* sets info for unstructured files */
	info_ptr -> seq_info.type = 2;		/* identifies file type */
	call get_lock_status;			/* looks at file lock */
	info_ptr -> seq_info.version = seg_ptr -> seq_header.version;
						/* file version */
	info_ptr -> seq_info.action = seg_ptr -> seq_header.file_state;
	if seg_ptr_entry & ^not_open
	then if ^iocb_ptr -> iocb.open_data_ptr -> seq_cb.input_only
						/* modify opening */
	     then do;				/* use open data stats */
		     info_ptr -> seq_info.end_pos = iocb_ptr -> iocb.open_data_ptr -> seq_cb.end_pos;
						/* latest end pos */
		     return;
		end;
	info_ptr -> seq_info.end_pos = seg_ptr -> seq_header.end_pos;
						/* record count--only valid
						   if version is current */
     end proc_seq_file;

proc_blk_file:
     proc;					/* gets info for blocked files */
	info_ptr -> blk_info.type = 3;		/* identifies blocked file info struc */
	call get_lock_status;
	info_ptr -> blk_info.version = seg_ptr -> blk_header.version;
	info_ptr -> blk_info.action = seg_ptr -> blk_header.action;
						/* non-zero if update
						   is in progress */
	info_ptr -> blk_info.max_rec_len = seg_ptr -> blk_header.max_rec_len;
						/*
						   maximum record length associated with file (bytes) */
	if seg_ptr_entry & ^not_open			/* we have an iocb */
	then if (iocb_ptr -> iocb.open_data_ptr -> blk_cb.mode > 4 /* modify opening */)
		& ^iocb_ptr -> iocb.open_data_ptr -> blk_cb.shared
	     then do;
		     info_ptr -> blk_info.end_pos = iocb_ptr -> iocb.open_data_ptr -> blk_cb.end_pos;
						/* latest end pos */
		     go to get_time_stamp;
		end;
	info_ptr -> blk_info.end_pos = seg_ptr -> blk_header.end_pos;
						/* record count */
get_time_stamp:
	info_ptr -> blk_info.time_last_modified = seg_ptr -> common_header.time_last_modified;
     end proc_blk_file;

proc_indx_file:
     proc;					/* gets info for indexed files */
	info_ptr -> indx_info.type = 4;		/* identifies indexed file info struc */
	call get_lock_status;
	info_ptr -> indx_info.file_version = seg_ptr -> indx_header.file_version;
	info_ptr -> indx_info.program_version = seg_ptr -> indx_header.program_version;
						/*
						   if old this may indicate file has bugs */
	state = seg_ptr -> indx_header.file_state;	/* selects valid block of stats */
	if (info_ptr -> indx_info.file_version = 30 /* file is latest version */)
	     | (info_ptr -> indx_info.file_version = 40)
	then call get_latest_indx_stats;
	else if info_ptr -> indx_info.file_version = 20
	then call get_new_stats;
	else if info_ptr -> indx_info.file_version = 10
	then call get_old_stats;			/* old version header is differently organized */
	else code = error_table_$bad_file;
	return;					/* end of routine for handling indexed files */

get_latest_indx_stats:
     proc;					/* routine gets statistics for version 4.0 files */
	call get_common_indx_stats;			/* change count and index state */
	f_s_ptr = addr (seg_ptr -> new_indx_header.file_state_blocks (state));
	info_ptr -> indx_info.action = f_s_ptr -> new_fs_block.file_action;
						/* ^=0 if operation in progress */
	info_ptr -> indx_info.records = f_s_ptr -> new_fs_block.number_of_records;
	info_ptr -> indx_info.record_bytes = f_s_ptr -> new_fs_block.total_record_length;
	info_ptr -> indx_info.non_null_recs = f_s_ptr -> new_fs_block.number_of_allocated_records;
	info_ptr -> indx_info.free_blocks = f_s_ptr -> new_fs_block.number_of_free_blocks;
	info_ptr -> indx_info.num_keys = f_s_ptr -> new_fs_block.number_of_keys;
	info_ptr -> indx_info.key_bytes = f_s_ptr -> new_fs_block.total_key_length;
	info_ptr -> indx_info.dup_keys = f_s_ptr -> new_fs_block.duplicate_keys;
	info_ptr -> indx_info.dup_key_bytes = f_s_ptr -> new_fs_block.dup_key_bytes;
     end get_latest_indx_stats;

get_common_indx_stats:
     proc;					/* routine used with latest two file versions */
	info_ptr -> indx_info.change_count = seg_ptr -> indx_header.change_count;
	i_state = seg_ptr -> indx_header.index_state;	/* locates proper index state block */
	i_s_ptr = addr (seg_ptr -> indx_header.index_state_blocks (i_state));
						/* pointer to index state block */
	info_ptr -> indx_info.index_height = i_s_ptr -> index_state_block.index_height;
	info_ptr -> indx_info.nodes = i_s_ptr -> index_state_block.number_of_nodes;
     end get_common_indx_stats;

set_default_stats:
     proc;					/* used with old version indexed files */
	info_ptr -> indx_info.num_keys = info_ptr -> indx_info.records;
	info_ptr -> indx_info.dup_keys = 0;
	info_ptr -> indx_info.dup_key_bytes = 0;
     end set_default_stats;

get_new_stats:
     proc;					/* gets file statistics for MR3.0 version indexed files */
	call get_common_indx_stats;
	f_s_ptr = addr (seg_ptr -> indx_header.file_state_blocks (state));
						/* pointer to file state block */
	info_ptr -> indx_info.action = f_s_ptr -> file_state_block.file_action;
						/* ^=0 if operation in progress */
	info_ptr -> indx_info.records = f_s_ptr -> file_state_block.number_of_records;
	info_ptr -> indx_info.record_bytes = f_s_ptr -> file_state_block.total_record_length;
	info_ptr -> indx_info.non_null_recs = f_s_ptr -> file_state_block.number_of_allocated_records;
	info_ptr -> indx_info.free_blocks = f_s_ptr -> file_state_block.number_of_free_blocks;
	info_ptr -> indx_info.key_bytes = f_s_ptr -> file_state_block.total_key_length;
	call set_default_stats;
     end get_new_stats;

get_old_stats:
     proc;					/* gets statistics for old version indexed files */
	info_ptr -> indx_info.change_count = 0;		/* not supported */
	old_f_s_ptr = addr (seg_ptr -> old_indx_header.old_file_state_blocks (state));
						/* pointer
						   to old version file state block */
	info_ptr -> indx_info.action = old_f_s_ptr -> old_f_s_block.file_action;
						/* if ^=0 file cannot be restored */
	info_ptr -> indx_info.records = old_f_s_ptr -> old_f_s_block.number_of_records;
	info_ptr -> indx_info.record_bytes = old_f_s_ptr -> old_f_s_block.total_record_length;
	info_ptr -> indx_info.key_bytes = old_f_s_ptr -> old_f_s_block.total_key_length;
	r_state = seg_ptr -> old_indx_header.record_state;/* selects a record_state_block */
	r_s_ptr = addr (seg_ptr -> old_indx_header.record_state_blocks (r_state));
						/* points to record
						   state block--part of file state block in new version files */
	info_ptr -> indx_info.non_null_recs = r_s_ptr -> r_s_block.number_of_allocated_records;
	info_ptr -> indx_info.free_blocks = r_s_ptr -> r_s_block.number_of_free_blocks;
	info_ptr -> indx_info.index_height = seg_ptr -> old_indx_header.old_version_index_height;
	info_ptr -> indx_info.nodes = seg_ptr -> old_indx_header.old_version_number_of_nodes;
	call set_default_stats;
     end get_old_stats;

     end proc_indx_file;

/* declarations for entire program */
	dcl     seg_ptr_entry	 bit (1) aligned;
	dcl     seg_ptr_arg		 ptr;
	dcl     iocb_ptr_arg	 ptr;
	dcl     1 branch_info	 aligned,		/* info returned by hcs_$status_long */
		2 type		 bit (2) unal,
		2 pad0		 bit (34) unal,
		2 words1		 (6) fixed,	/* of no interest */
		2 pad1		 bit (12) unal,
		2 bit_count	 bit (24) unal,	/* distinguishes msf and dir */
		2 words2		 (2);
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed (1), ptr, ptr, fixed (35));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
	dcl     hcs_$terminate_noname	 entry (ptr, fixed (35));
	dcl     hcs_$fs_get_mode	 entry (ptr, fixed (5), fixed (35));
	dcl     mode		 fixed (5);
	dcl     iocb_ptr		 ptr;
	dcl     iox_$close		 entry (ptr, fixed (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$attach_ioname	 entry (char (*), ptr, char (*), fixed (35));
	dcl     iox_$open		 entry (ptr, fixed, bit (1) aligned, fixed (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed (35));
	dcl     state		 fixed;
	dcl     (
	        error_table_$lock_wait_time_exceeded,
	        error_table_$no_s_permission,
	        error_table_$bad_file,
	        error_table_$bad_arg,
	        error_table_$moderr,
	        error_table_$dirseg,
	        error_table_$locked_by_this_process
	        )			 external fixed (35);
	dcl     set_lock_$lock	 entry (bit (36) aligned, fixed, fixed (35));
	dcl     lock_word		 bit (36) aligned;
	dcl     seg_ptr		 ptr;
	dcl     1 rp_info,				/* used in "read_position" control order */
		2 next_pos	 fixed (34),	/* of no interest in this routine */
		2 end_pos		 fixed (34);	/* used to get byte count of uns files */
	dcl     1 uns_header	 based (seg_ptr),	/* optional header for unstructured files */
		2 common_header_words
				 (4) fixed,
		2 identifier	 fixed (35);	/* set and interpreted by user */
	dcl     1 seq_header	 based (seg_ptr),	/* standard header for sequential files */
		2 common_header_words
				 (4) fixed,
		2 version_word	 aligned,
		  3 file_state	 fixed (17) unal,
		  3 version	 fixed (17) unal,
		2 words		 (3) fixed,	/* not of interest to this program */
		2 end_pos		 fixed (34),	/* record count */
		2 end_desc	 fixed (35);
	dcl     1 common_header	 based (seg_ptr),	/* common header for structured files */
		2 file_code	 fixed (35),
		2 file_lock	 bit (36) aligned,
		2 time_last_modified fixed (71);
	dcl     (code, foo)		 fixed (35);
	dcl     fcb_ptr		 ptr;
	dcl     (null, bit, substr, length, verify, reverse, addr, fixed)
				 builtin;
	dcl     msf_manager_$close	 entry (ptr);
	dcl     (d_name_arg, e_name_arg)
				 char (*);
	dcl     d_name		 char (168);
	dcl     e_name		 char (32);
	dcl     atd		 char (256);
	dcl     not_open		 bit (1) aligned;
	dcl     msf_manager_$open	 entry (char (*) aligned, char (*) aligned, ptr, fixed (35));
	dcl     msf_manager_$get_ptr	 entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35));
	dcl     bc		 fixed (24);
	dcl     uns_code		 static internal fixed init (31191);
	dcl     seq_code		 static internal fixed init (83711);
	dcl     blk_code		 static internal fixed init (22513);
	dcl     indx_code		 static internal fixed init (7129);
	dcl     1 indx_header	 aligned based (seg_ptr),
						/* current version */
		2 words1		 (4),
		2 file_version	 fixed,
		2 program_version	 fixed,
		2 words2		 (8),
		2 file_state	 fixed,
		2 change_count	 fixed (35),
		2 words3		 (46),
		2 file_state_blocks	 (0:1),
		  3 words		 (7) fixed,
		2 index_state	 fixed,
		2 index_state_blocks (0:1),
		  3 words		 (104);
	dcl     1 new_indx_header	 aligned based (seg_ptr),
						/* version 4.0 indexed file header */
		2 words		 (361) fixed,
		2 file_state_blocks	 (0:1),
		  3 words		 (12) fixed;
	dcl     1 new_fs_block	 based (f_s_ptr),	/* version 4.0 file state block */
		2 file_action	 fixed,
		2 file_substate	 fixed,
		2 number_of_keys	 fixed (34),
		2 duplicate_keys	 fixed (34),	/* 0 if no duplications */
		2 dup_key_bytes	 fixed (34),
		2 total_key_length	 fixed (34),
		2 number_of_records	 fixed (34),
		2 total_record_length
				 fixed (34),
		2 number_of_allocated_records
				 fixed (34),
		2 number_of_free_blocks
				 fixed (34),
		2 words		 (2) fixed;
	dcl     (f_s_ptr, i_s_ptr, old_f_s_ptr, r_s_ptr)
				 ptr;
	dcl     (i_state, r_state)	 fixed;
	dcl     1 file_state_block	 based (f_s_ptr),
		2 file_action	 fixed,
		2 word1,
		2 number_of_records	 fixed,
		2 total_key_length	 fixed (34),
		2 total_record_length
				 fixed (34),
		2 number_of_allocated_records
				 fixed (34),
		2 number_of_free_blocks
				 fixed (34);
	dcl     1 index_state_block	 based (i_s_ptr),
		2 number_of_nodes	 fixed (34),
		2 words1		 (2),
		2 index_height	 fixed;
	dcl     1 old_indx_header	 based (seg_ptr),	/* old version indexed file header */
		2 words1		 (15),
		2 old_file_state_blocks
				 (0:1),
		  3 words		 (5),
		2 words2		 (7),
		2 record_state	 fixed,
		2 record_state_blocks
				 (0:1),
		  3 words		 (4),
		2 words3		 (14),
		2 old_version_index_height
				 fixed,
		2 old_version_number_of_nodes
				 fixed (34);
	dcl     1 old_f_s_block	 based (old_f_s_ptr),
		2 file_action	 fixed,
		2 word,
		2 number_of_records	 fixed (34),
		2 total_key_length	 fixed (34),
		2 total_record_length
				 fixed (34);
	dcl     1 r_s_block		 based (r_s_ptr),
		2 word,
		2 number_of_allocated_records
				 fixed (34),
		2 number_of_free_blocks
				 fixed (34);
	dcl     1 blk_header	 aligned based,	/* standard header for blocked files */
		2 words1		 (4) fixed,	/* of no interest here */
		2 version		 fixed,
		2 words2		 (3) fixed,
		2 max_rec_len	 fixed (21),
		2 end_pos		 fixed (34),
		2 action		 fixed;		/* non-zero indicates operation in progress */
	dcl     1 seq_cb		 aligned based,	/* open data block for sequential files */
		2 seg_ptr		 ptr,		/* ptr to current seg */
		2 fcb_ptr		 ptr,		/* ptr to msf control block */
		2 component	 fixed bin,	/* component number of
						   current seg */
		2 write_limit	 fixed bin (21),	/* set at open to max seg size + 1 */
		2 beyond_limits	 fixed bin (21),	/* set at open to write_limit + 4 */
		2 max_record_size	 fixed bin (21),	/* set at open to 4*max_component_size-
						   header_size-12(i.e. 3 desciptor words */
		2 write_pos	 fixed bin (21),	/* in write state =
						   pos of final descriptor, in read state =
						   beyond limits */
		2 read_pos	 fixed bin (21),	/* in read state =
						   pos of next descriptor, in write state
						   = minus_one_pos */
		2 current_record_ptr ptr,
		2 end_pos		 fixed (34),	/* number of records in file */
		2 end_desc	 fixed (35),
		2 next_pos	 fixed (34),	/* next record number */
		2 next_is_current	 bit (1) aligned,	/* "0"b if positions staggerred */
		2 updating	 bit (1) aligned,	/* set if mode=7 (sequential_update) */
		2 append_sw	 bit (1) aligned,	/* set if mode=6 (seq in out) and -append attachment */
		2 input_only	 bit (1) aligned,
		2 ssf_sw		 bit (1) aligned,	/* -ssf option indicator */
		2 is_msf		 bit (1) aligned,	/* set when msf is opened */
		2 end_not_valid	 bit (1) aligned,	/* used with old version files */
		2 error,				/* used by "error_status" control order */
		  3 type		 fixed,
		  3 requested	 fixed (34),
		  3 received	 fixed (34),
		2 minus_one_word	 fixed,
		2 file_base_ptr	 ptr;
	dcl     1 blk_cb		 aligned based,	/* open data block for blocked files */
		2 file_base_ptr	 ptr,		/* points to base of segment */
		2 seg_ptr_array_ptr	 ptr,
		2 fcb_ptr		 ptr,
		2 mode		 fixed,		/* opening mode (=4,5,6, or 7) */
		2 appending	 bit (1) aligned,	/* -append option */
		2 max_comp_size	 fixed (19),	/* determines capacity of file */
		2 max_rec_len	 fixed (21),	/* determines block size */
		2 block_size	 fixed (19),	/* words, including header */
		2 capacity	 fixed (19),	/* max number of records per comp */
		2 current_pos	 fixed (34),	/* current record number */
		2 next_pos	 fixed (34),	/* next record position (0,1,2,...) */
		2 end_pos		 fixed (34),	/* number of records in file */
		2 last_comp_num	 fixed,
		2 is_msf		 bit (1) aligned,
		2 ssf_sw		 bit (1) aligned,
		2 seg_ptr_array_limit
				 fixed,
		2 words		 (3) fixed,
		2 shared		 bit (1) aligned;
	dcl     cb_ptr		 ptr;
	dcl     info_ptr		 ptr;
	dcl     1 info		 based (info_ptr),	/* structure to receive file information */
		2 version		 fixed,		/* must =1 */
		2 words		 (size (indx_info) - 1) fixed;
%include vfs_info;
%include vf_attach_block;
%include iocbv;

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