



		    im_basic_search.pl1             10/24/88  1644.7r w 10/24/88  1358.8      557172



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


/* DESCRIPTION:

          This module searches the index for a specified key.  It returns the
     element_id of the found key (or the element_id for the correct location
     for the missing key) and the leaf_ci_header of the control interval
     containing the returned element_id.

     All internal subroutines have uppercase names.  If an error is
     encountered in an internal subroutine, ERROR_RETURN is called directly
     with the appropriate error code.  Control is not returned to the caller
     of the subroutine.  Instead, a non-local transfer is performed to the
     MAIN_RETURN label, following which the main procedure returns to its
     caller.  For this reason, there are no error code checks after subroutine
     calls.

     This subroutine accesses data in a collection exclusively via direct
     access, i.e., first gets a pointer to a control interval (node) by
     calling collection_manager_$get_control_interval_ptr then gets elements
     (keys and ci_headers) by copying the contents of the elements into local
     buffers. It is imperative that a new
     pointer to the current node (current_node_ptr) is gotten whenever the
     current node (current_node_id) changes.  For this reason, the value of
     current_node_id should never be manually changed; the subroutine
     GET_NEW_NODE is called to change the value of current_node_id and get a
     new current_node_ptr.  Calls to get a new node should always look like
     the following:
     
      call GET_NEW_NODE (<new node id>, current_node_id, current_node_ptr);
     
     Because im_basic_search is such a heavily used routine and must be as
     performant as possible, it gets elements out of control intervals
     directly without calling collection_manager_.  This trade-off of
     modularity in favor of performance is absolutely necessary.  Actual
     knowledge of the format of a control interval is limited to the two
     internal subroutines GET_CI_HEADER and GET_NEW_KEY.  These two routines
     copy data out of the control interval into local buffers to avoid
     problems with proper alignment.

     GET_CI_HEADER and GET_NEW_KEY maintain the values of certain variables
     that must be kept in synch.  The caller must co-operate by always calling
     these routines in one of the following ways:
     
      call GET_CI_HEADER (current_node_ptr,
                          current_node_id,
                          common_ci_header_ptr,
                          leaf_ci_header_ptr,
                          branch_ci_header_ptr,
                          element_id_string);
     
      call GET_NEW_KEY (current_node_ptr,
                        current_node_id,
                        <index>,
                        leaf_key_ptr     | branch_key_ptr,
                        lk_string_length | (0),
                        (0)              | bk_string_length,
                        element_id_string);

     Also for performance reasons, the subroutine COMPARE_VECTOR_TO_STRING is
     included in dm_comp_vec_str_proc.incl.pl1.  This routine, which is shared
     by several modules, is written as an internal subroutine to eliminate the
     call overhead that would be necessary were it an external routine.  This
     routine takes no arguments and relies on global variables declared and
     set in the main procedure to simulate parameters, again to avoid the cost
     of argument list preparation.  All such pseudo-parameters are automatic
     variables prefixed with the string "cvs_p_".
*/

/* HISTORY:

Written by Lindsey Spratt, 03/28/82.
Modified:
04/22/82 by Lindsey Spratt: Added capability to deal with branch keys which
	  have fewer than the full set of fields.
05/26/82 by Lindsey Spratt: Changed calculation of new current_idx when vector
	  is greater than the key to add the mod(current_idx + high_idx, 2)
	  instead of just adding "1".  The old technique gave a result one
	  too great when (current_idx + high_idx) was a multiple of two.
06/21/82 by Lindsey Spratt: Changed name from im_search_$location to
	  im_basic_search.  Added p_want_* flags to calling sequence, to
	  support the im_structural_search routine.  Added case statement to
	  determine what value to return for the p_key_id, based on the
	  vector_*key flags and the p_want_* flags.
07/26/82 by Lindsey Spratt:  Added the duplicate-field-filtering feature and
	  extended the search algorithm to allow for "degenerate" branch
	  nodes, those with no keys.
08/09/82 by Matthew Pierret:  Changed calling sequence of 
            collection_manager_$get_element to not use offset and length.
08/27/82 by Lindsey Spratt:  Added p_is_relative_search and
	  p_position_stack_ptr to calling sequence.  Changed to use local
	  variable "first_idx" instead of referencing key_range.first
	  directly as part of implementing "relative" searches.  The
	  position_stack is only modified/used by im_basic_search, it is
	  held by im_basic_search's caller, though, to make it so that this
	  module only needs to calculate the position_stack once in a series
	  of searches.
09/13/82 by Lindsey Spratt:  Added check of the parent thread.  Rebuilt the
	  search algorithm for branch nodes.
10/20/82 by Lindsey Spratt:  Changed the leaf_node key search to be the same
	  algorithm as that used for branch nodes.  Corrected the algorithm
	  for the case where the search vector is equal to more than one key
	  (in either a branch or leaf node).  If a key is desired which is
	  <= the vector, or > the vector, then the rightmost (highest) key =
	  the vector must be located.  If a key is desired which is >=
	  the vector, or < the vector, then the leftmost (lowest) key = the
	  vector must be located.
10/27/82 by Lindsey Spratt:  Moved get_new_key to top of LEAF_KEY_LOOP.
11/03/82 by Lindsey Spratt:  Added code to catch the case where an exact match
	  is being sought and when exiting from the leaf loop it
	  is the key identified by the high_idx, not the current_idx (which
	  equals low_idx). 
11/04/82 by Lindsey Spratt:  Added the insertion entry point, to be called by
	  im_put_key.
11/15/82 by Matthew Pierret: Added code to catch the case where an exact match
	  is being sought and when exiting from the leaf loop it is equal
            to the vector and is the first key.
11/19/82 by Matthew Pierret: Changed to use buffered control interval
            technology. To reduce on calls to file_manager_ (by 
            collection_manager_) and on copying of data, when a node is to be
            searched the whole node is retrieved into a local buffer by calling
            cm_$setup_buffered_ci. Elements are then retrieved from that buffer
            using cm_$get_element_buffered.
            Also made current_node_id, parent_node_id, less_branch_id unsigned.
01/19/83 by Lindsey Spratt:  Fixed to correctly set the p_key_id when working
	  with the first key of a CI.  It was testing current_idx, which may
	  be one greater or less  than the last key tested, whose slot index
	  is accurately recorded in element_id.index.  Added some logic to
	  check for the "low" limit when doing relative searching and trying
	  to set the p_key_id one less than the element_id.index value.
01/25/83 by Lindsey Spratt:  Fixed to set the parent_idx correctly when the
	  "found" key is the first key in the CI, it is equal to the vector
	  (hence, first_inequal_field_id >
	  simple_typed_vector.number_of_dimensions), and the caller wants
	  keys  ">=" to the vector.  The correct value is =
	  key_range.first, it was being set to key_range.first - 1.
02/23/83 by Lindsey Spratt: Added a new entry, $reposition, to support
	  automatic re-positioning of cursors when they are found to have
	  become invalid.  Added support for the version 3 cursor, which
	  includes the ability for the cursor to have any combination of the
	  the three possible operations (current, next, previous) be defined
	  and the remaining operations be invalid for a given cursor.
	       Changed the calling sequences to use the index_opening_info
	  structure.
03/02/83 by Lindsey Spratt:  Fixed execution path for $reposition entry to not
	  reference the simple_typed_vector.
03/07/83 by Lindsey Spratt:  Fixed the position_stack initialization to get
	  the stack in the right order when doing a top_down init.  Also,
	  fixed position_stack init to consistently set the id_string.index
	  value to be the first (or leftmost) valid key slot; it was being
	  set to be one to the left of the the first valid key slot on some
	  occasions.
03/24/83 by Lindsey Spratt:  Changed im_compare* to data_mgmt_util_$compare*.
	  Was changed to use field_table version 2.
04/09/83 by Lindsey L. Spratt:  Changed the post-BRANCH_KEY_LOOP
	  interpretation of the comparison of the "vector" and the key.  If
	  they compared equal, but the vector is shorter than the key, then
	  the comparison is reinterpreted to be "less-than".
05/02/83 by Lindsey L. Spratt:  Fixed a bug in the setting of the first_idx
            for a branch node when doing a relative search.
07/12/83 by Matthew Pierret:  Changed to set up the current node when the 
            position_stack does not need to be set up for a relative search.
07/13/83 by Matthew Pierret:  Changed all internal subroutine names to be 
            uppercase. Adopted the convention of prefixing variable names 
            declared in subroutines with the initials of the subroutine.
            Added an ERROR_RETURN subroutine which takes an error code, sets
            p_code to the value of the error code, and non-locally goes to
            the return statement in the main procedure. Changed all subroutines
            to call ERROR_RETURN when encountering an error and removed passing
            of error codes, allowing callers of subroutines to assume that if
            control is returned, no errors were encountered.
03/14/84 by Lindsey L. Spratt:  Fixed GET_*CI_HEADER programs to allow for
            branch CI's with key_range.first = key_range.last = 0.
03/23/84 by Matthew Pierret:  Changed to get a pointer to a control interval
            (node) in a file instead of setting up a CI buffer. Converted all
            file access to this direct access method, including those that
            were previously buffered and those that were previously standard.
            Changed all modifications of the value of current_node_id to be 
            done by the subroutine GET_NEW_NODE, which sets current_node_id and
            current_node_ptr synchronously. Removed SETUP_NODE_BUFFER,
            GET_NEW_BUFFERED_KEY and GET_BUFFERED_CI_HEADER.
04/09/84 by Matthew Pierret:  Changed to access control intervals directly
            instead of calling collection_manager_$simple_get_buffered_element.
            This means that the subroutines GET_CI_HEADER and GET_NEW_KEY now
            have sufficient knowledge about the format of control intervals to
            find where keys and headers are stored.  This drastic step is taken
            because this module is in a critical path and its performance is
            very important to performance of the index_manager_. Also changed
            these two subroutines to be completely parameterized.
04/20/84 by Matthew Pierret:  Changed calls to
            data_format_util_$compare_vector_to_string to be calls to the
            internal subroutine COMPARE_VECTOR_TO_STRING, which is contained
            in the include file dm_comp_vec_str_proc.incl.pl1.  Changed the
            names of variables which were passed to dfu_$cvts to the names
            expected by COMPARE_VECTOR_TO_STRING as global variables
            simulating parameters.
05/04/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
05/10/84 by Matthew Pierret:  Changed to align local_key_buffer on an even
            word boundary.  Changed references to data_mgmt_util_ to be to
            data_format_util_.
05/23/84 by Lindsey L. Spratt:  Fixed a reference to field_table.version in a
            sub_err_ call to use the cvs_p_field_table_ptr as it was supposed
            to.
10/12/84 by Matthew Pieret:  Changed to use the new dm_cm_basic_ci and
            dm_cm_basic_ci_const include files.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 index_opening_info,
            and version 4 index_header.  Added some internal procedures to
            help clarify the top level algorithm.
10/30/84 by Lindsey L. Spratt:  Introduced the only_want_key_equal_to_vector
            and want_highest_equal_key flags, derived from the other want_*
            flags.  Remodularized the ANALYZE_RESULTS internal proc.
11/08/84 by Lindsey L. Spratt:  Added documentation to the internal
            procedures.  Moved the local variable initialization into an
            internal program.
11/14/84 by Lindsey L. Spratt:  Change REPOSITION_CURSOR to use its rp_code
            instead of the global code variable.  Added the failed_exact_match
            flag.  Changed REPORT_PREVIOUS_KEY to set the p_key_id.index to 0
            when there is no previous key.  Fixed INIT_POSITION_STACK to do a
            RETURN when the "least key" is after the end of the index and
            therefore no searching is possible.  Changed INIT_POSITION_STACK
            to use its own ips_code instead of the global code variable.
            Fixed the setting of only_want_key_equal_to_vector.
01/10/85 by Lindsey L. Spratt:  Changed the position_stack inversion in the
            INIT_TOP_DOWN block of INIT_POSITION_STACK to only loop through
            half of the position_stack.  As it was, the stack was being
            inverted twice.  Changed SKIP_DEGENERATE_NODE to use
            current_depth=max(current_depth -1,1) rather than just
            "=current_depth".
	  Fixed parent_idx setting in FIND_NEXT_BRANCH.
02/15/85 by Lindsey L. Spratt:  Changed test after BRANCH_KEY_LOOP in
	  FIND_NEXT_BRANCH to be "cvs_p_vector_less_than_key |
	  ^want_highest_equal_key" instead of "cvs_p_vector_less_than_key |
	  cvs_p_first_inequal_field_id <= number_of_fields_in_vector |
	  want_highest_equal_key".
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
04/19/85 by Lindsey L. Spratt:  Fixed two problems with relative searches.
            INIT_POSITION was setting element_id.control_interval_id at one
            point in INIT_TOP_DOWN where it should have been setting
            element_id.index.  FIND_LEAF_NODE, at the end of the
            BRANCH_NODE_LOOP, was incorrectly setting the first_idx when the
            current_node_id = position_stack.id_string.control_interval_id.
            The proc SET_RELATIVE_FIRST_IDX has been created for setting the
            first_idx in this case, and SETUP_FIRST_NODE and FIND_LEAF_NODE
            changed to use it.
           Fixed REPORT_PREVIOUS_KEY to always check for the previous key
            being before the logical beginning of the index, as defined by the
            position_stack, when doing a relative search.
*/

/****^  HISTORY COMMENTS:
  1) change(87-05-06,Dupuis), approve(87-05-29,MCR7695), audit(87-06-02,Blair),
     install(87-07-17,MR12.1-1042):
     Changed the buffer alignment so that branch_key.string would be on a
     double-word boundary. The key string was being aligned on an odd-word
     boundary and this was causing bad comparisons when dealing with fields
     that needed to be aligned on double-word boundaries.
  2) change(87-11-19,Dupuis), approve(87-12-11,MCR7812), audit(87-12-11,Blair),
     install(88-01-12,MR12.2-1012):
     Changed the CURRENT_KEY_SATISFIES_CONSTRAINTS internal proc to correct
     phx20998. When the vector was less than the key, but the number of fields
     matching was equal to the index_header.number_of_duplication_fields, the
     subroutine was determining that they weren't equal. This wasn't true,
     because the tuple ids were the only fields that were inequal.
  3) change(88-06-24,Dupuis), approve(88-08-31,MCR7974), audit(88-09-01,Blair),
     install(88-09-06,MR12.2-1099):
     Changed the FIND_NEXT_BRANCH to correctly get the correct branch in all
     cases. See phx21803 for complete details.
                                                   END HISTORY COMMENTS */


/* format: style2,ind3 */

im_basic_search:
   proc (p_index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search, p_position_stack_ptr,
        p_want_key_equal_to_vector, p_want_keys_greater_than_vector, p_want_keys_less_than_vector, p_typed_vector_ptr,
        p_key_id_string, p_leaf_ci_header_ptr, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_is_relative_search   bit (1) aligned parameter;
      dcl	    p_position_stack_ptr   ptr parameter;
      dcl	    (p_want_key_equal_to_vector, p_want_keys_less_than_vector, p_want_keys_greater_than_vector)
			       bit (1) aligned parameter;
      dcl	    p_typed_vector_ptr     ptr parameter;
      dcl	    p_key_id_string	       bit (36) aligned parameter;
      dcl	    p_leaf_ci_header_ptr   ptr parameter;
      dcl	    p_maximum_duplication_field
			       fixed bin parameter;
      dcl	    p_key_string_ptr       ptr parameter;
      dcl	    p_key_string_length    fixed bin (24) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    cvs_p_field_table_ptr  ptr;
      dcl	    cvs_p_simple_typed_vector_ptr
			       ptr;
      dcl	    cvs_p_key_string_ptr   ptr;
      dcl	    cvs_p_key_string_length
			       fixed bin (35);
      dcl	    cvs_p_last_field_idx   fixed bin (17);
      dcl	    cvs_p_first_inequal_field_id
			       fixed bin (17);
      dcl	    cvs_p_vector_equal_to_key
			       bit (1) aligned;
      dcl	    cvs_p_vector_less_than_key
			       bit (1) aligned;
      dcl	    cvs_p_code	       fixed bin (35);

      dcl	    (want_key_equal_to_vector, want_keys_greater_than_vector, want_keys_less_than_vector,
	    only_want_key_equal_to_vector, want_highest_equal_key, is_relative_search, is_reposition, is_insertion,
	    failed_exact_match)    bit (1) aligned init ("0"b);
      dcl	    position_stack_ptr     ptr init (null);
      dcl	    (high_duplication_field, low_duplication_field)
			       fixed bin init (0);

      dcl	    is_first_pass_through_loop
			       bit (1) aligned;

      dcl	    current_depth	       fixed bin init (0);
      dcl	    first_idx	       fixed bin;
      dcl	    equal_idx	       fixed bin init (0);
      dcl	    low_idx	       fixed bin;
      dcl	    high_idx	       fixed bin;
      dcl	    current_idx	       fixed bin;
      dcl	    parent_idx	       fixed bin init (-1);
      dcl	    depth_idx	       fixed bin (17) init (0);

      dcl	    number_of_fields_in_vector
			       fixed bin (35) init (0);

      dcl	    parent_node_id	       fixed bin (24) unsigned init (0);
      dcl	    current_node_id	       fixed bin (24) unsigned;
      dcl	    less_branch_id	       fixed bin (24) unsigned;

      dcl	    key_id_ptr	       ptr;
      dcl	    current_node_ptr       ptr;

      dcl	    local_header_buffer    bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)) aligned;
      dcl	    local_key_buffer       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
      dcl	    local_key_id_string    bit (36) aligned init ("0"b);
      dcl	    temp_id_string	       bit (36) aligned init ("0"b);

/* Based */

      dcl	    1 position_stack       aligned based (position_stack_ptr),
	      2 depth	       fixed bin (17),
	      2 id_string	       (10) bit (36) aligned;

      dcl	    1 p_key_id	       like element_id based (key_id_ptr);

/* Builtin */

      dcl	    (addcharno, addr, addrel, ceil, divide, length, max, null, string, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    (
	    ALL_FIELDS_ARE_PRESENT init (-1),
	    BYTES_PER_WORD	       init (4),
	    BITS_PER_BYTE	       init (9),
	    DOUBLE_WORDS_PER_PAGE  init (512)
	    )		       fixed bin (17) unal internal static options (constant);
      dcl	    myname	       init ("im_basic_search") char (16) internal static options (constant);

/* Entry */

      dcl	    im_validate_cursor     entry (ptr, ptr, fixed bin (35));
      dcl	    data_format_util_$compare_string_to_string
			       entry (ptr, ptr, fixed bin (24), ptr, fixed bin (24), fixed bin unal, fixed bin,
			       bit (1) aligned, bit (1) aligned, fixed bin (35));

      dcl	    im_set_cursor$at_current
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));
      dcl	    im_set_cursor$no_current
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));
      dcl	    im_set_cursor$at_beginning
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));
      dcl	    im_set_cursor$at_end   entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));

      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    vd_error_$wrong_type,
	    dm_error_$key_not_found,
	    dm_error_$bad_first_key_idx,
	    dm_error_$bad_last_key_idx,
	    dm_error_$bad_parent_thread,
	    dm_error_$long_return_element,
	    dm_error_$no_element,
   	    dm_error_$programming_error
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      want_key_equal_to_vector = p_want_key_equal_to_vector;
      want_keys_less_than_vector = p_want_keys_less_than_vector;
      want_keys_greater_than_vector = p_want_keys_greater_than_vector;
      is_relative_search = p_is_relative_search;
      position_stack_ptr = p_position_stack_ptr;
      cvs_p_simple_typed_vector_ptr = p_typed_vector_ptr;
      if cvs_p_simple_typed_vector_ptr -> simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
      then call sub_err_ (vd_error_$wrong_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected a simple_typed_vector, type ^d, structure. Received type ^d.", SIMPLE_TYPED_VECTOR_TYPE,
	      cvs_p_simple_typed_vector_ptr -> simple_typed_vector.type);

      key_id_ptr = addr (p_key_id_string);
      goto JOIN;

insert:
   entry (p_index_opening_info_ptr, p_index_cursor_ptr, p_typed_vector_ptr, p_key_id_string, p_maximum_duplication_field,
        p_leaf_ci_header_ptr, p_code);
      is_insertion = "1"b;
      want_key_equal_to_vector = "1"b;
      want_keys_less_than_vector = "0"b;
      want_keys_greater_than_vector = "0"b;
      is_relative_search = "0"b;
      position_stack_ptr = null;
      cvs_p_simple_typed_vector_ptr = p_typed_vector_ptr;
      if cvs_p_simple_typed_vector_ptr -> simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
      then call sub_err_ (vd_error_$wrong_type, myname, "s", null, 0,
	      "^/Expected a simple_typed_vector, type ^d, structure. Received type ^d.", SIMPLE_TYPED_VECTOR_TYPE,
	      cvs_p_simple_typed_vector_ptr -> simple_typed_vector.type);

      key_id_ptr = addr (p_key_id_string);
      goto JOIN;

reposition:
   entry (p_index_opening_info_ptr, p_index_cursor_ptr, p_key_string_ptr, p_key_string_length, p_code);
      index_opening_info_ptr = p_index_opening_info_ptr;

      key_id_ptr = addr (local_key_id_string);
      local_key_id_string = p_index_cursor_ptr -> index_cursor.key_id_string;

      is_reposition = "1"b;
      want_key_equal_to_vector = "1"b;
      want_keys_less_than_vector = "0"b;
      want_keys_greater_than_vector = "0"b;
      is_relative_search = "0"b;
      position_stack_ptr = null;
      cvs_p_simple_typed_vector_ptr = null;
      goto JOIN;
%page;
JOIN:
      call INITIALIZE_LOCAL_VARIABLES ();

      call SETUP_FIRST_NODE ();

      if ^common_ci_header.is_leaf
      then call FIND_LEAF_NODE ();

      call FIND_LEAF_KEY ();

      call ANALYZE_RESULTS ();

      if is_reposition
      then call REPOSITION_CURSOR ();
      else if p_leaf_ci_header_ptr ^= null
      then p_leaf_ci_header_ptr -> leaf_ci_header = leaf_ci_header;


      if failed_exact_match | p_key_id.index = 0
      then call ERROR_RETURN (dm_error_$key_not_found);
      else call RETURN ();

MAIN_RETURN:
      return;

RETURN:
   proc ();
      p_code = 0;
      goto MAIN_RETURN;
   end RETURN;


ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      goto MAIN_RETURN;

   end ERROR_RETURN;

/* Internal procedure description:

          This program decides how to report the results of the search
     through the index.  The global variables which are its "output" are:
     code, p_key_id, and p_maximum_duplication_field.
*/

ANALYZE_RESULTS:
   proc ();

      if CURRENT_KEY_SATISFIES_CONSTRAINTS ()
      then p_key_id = element_id;
      else if only_want_key_equal_to_vector
      then call REPORT_FAILED_EXACT_MATCH ();
      else if want_keys_greater_than_vector
      then call REPORT_NEXT_KEY ();
      else call REPORT_PREVIOUS_KEY ();
   end ANALYZE_RESULTS;



/* Internal procedure description:

          This program verifies that the current node's recorded parent key is
     the same key as the one from which the search just came.  If not, there
     is a problem in the structure of the index.
*/

CHECK_PARENT_THREAD:
   proc (cpt_parent_node_id, cpt_parent_idx, cpt_header_parent_id_string);

      dcl	    cpt_parent_node_id     fixed bin (24) unsigned;
      dcl	    cpt_parent_idx	       fixed bin;
      dcl	    cpt_header_parent_id_string
			       bit (36) aligned;


      if addr (cpt_header_parent_id_string) -> element_id.control_interval_id ^= cpt_parent_node_id
	 | addr (cpt_header_parent_id_string) -> element_id.index ^= cpt_parent_idx
      then call sub_err_ (dm_error_$bad_parent_thread, myname, "h", null, 0,
	      "^/The child node's recorded parent is node ^d, slot index ^d.
The actual parent is node ^d, slot index ^d.", addr (cpt_header_parent_id_string) -> element_id.control_interval_id,
	      addr (cpt_header_parent_id_string) -> element_id.index, cpt_parent_node_id, cpt_parent_idx);

   end CHECK_PARENT_THREAD;



CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned parameter;
      dcl	    p_expected_version     char (8) aligned parameter;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;



/* Internal procedure description:

          This program determines if the key pointed at at the end of the
     search is a key which satisfies the caller's search constraints.
*/

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

      if is_insertion
      then if cvs_p_first_inequal_field_id > index_header.number_of_duplication_fields
	 | cvs_p_vector_equal_to_key
	 then return (want_key_equal_to_vector);

      if cvs_p_vector_less_than_key
      then return (want_keys_greater_than_vector);
      else if cvs_p_vector_equal_to_key | cvs_p_first_inequal_field_id > index_header.number_of_duplication_fields
      then return (want_key_equal_to_vector);
      else return (want_keys_less_than_vector);

   end CURRENT_KEY_SATISFIES_CONSTRAINTS;
%page;
/* Internal procedure description:

          This program determines if the desired leaf key
     is present in the current leaf node (located by FIND_LEAF_NODE).
*/

FIND_LEAF_KEY:
   proc ();
      cvs_p_vector_equal_to_key = "0"b;

      low_idx = first_idx - 1;
      high_idx = leaf_ci_header.common.key_range.last + 1;
      current_idx = divide (low_idx + high_idx, 2, 17, 0);

      cvs_p_last_field_idx = ALL_FIELDS_ARE_PRESENT;
      cvs_p_first_inequal_field_id = index_header.number_of_duplication_fields;

LEAF_KEY_LOOP:
      do while (cvs_p_first_inequal_field_id <= index_header.number_of_duplication_fields & current_idx ^= low_idx);

         call GET_NEW_KEY (current_node_ptr, current_node_id, current_idx, cvs_p_key_string_ptr, cvs_p_key_string_length,
	    (0), element_id_string);

         if is_reposition
         then call data_format_util_$compare_string_to_string (cvs_p_field_table_ptr, p_key_string_ptr,
	         p_key_string_length, cvs_p_key_string_ptr, (cvs_p_key_string_length), (cvs_p_last_field_idx),
	         cvs_p_first_inequal_field_id, cvs_p_vector_equal_to_key, cvs_p_vector_less_than_key, cvs_p_code);
         else call COMPARE_VECTOR_TO_STRING ();

         if cvs_p_code ^= 0
         then call ERROR_RETURN (cvs_p_code);

         if cvs_p_first_inequal_field_id <= index_header.number_of_duplication_fields
         then
	  do;
	     if cvs_p_vector_less_than_key
	     then
	        do;
		 high_duplication_field = cvs_p_first_inequal_field_id - 1;
		 high_idx = current_idx;
		 current_idx = divide (low_idx + current_idx, 2, 17, 0);
	        end;
	     else if cvs_p_first_inequal_field_id <= number_of_fields_in_vector
						/* Vector is greater than key, in some field which was tested. */
	     then
	        do;
		 low_duplication_field = cvs_p_first_inequal_field_id - 1;
		 low_idx = current_idx;
		 current_idx = divide (high_idx + current_idx, 2, 17, 0);
	        end;
	     else if want_highest_equal_key		/* For all tested fields, vector = key. */
	     then
	        do;				/* Find the highest key such that  the key <= vector. */
		 low_idx = current_idx;
		 current_idx = divide (high_idx + current_idx, 2, 17, 0);
	        end;
	     else
	        do;				/* Find the lowest key such that the key >= vector. */
		 equal_idx = current_idx;		/* Record that the current key exactly matches the vector. */
		 high_idx = current_idx;
		 current_idx = divide (low_idx + current_idx, 2, 17, 0);
	        end;
	  end;
      end LEAF_KEY_LOOP;

      if current_idx < first_idx			/* Vector is less than all of the keys in the leaf ci. */
      then if current_idx + 1 = equal_idx & only_want_key_equal_to_vector
	 then
	    do;
	       current_idx = equal_idx;
	       cvs_p_vector_less_than_key = "0"b;
	       cvs_p_vector_equal_to_key = "1"b;
	       element_id.index = current_idx;
	    end;
	 else
	    do;
	       cvs_p_vector_less_than_key = "1"b;
	       cvs_p_vector_equal_to_key = "0"b;
	       current_idx = first_idx;
	       element_id.index = current_idx;
	    end;
      else if ^(cvs_p_vector_less_than_key | cvs_p_vector_equal_to_key) & current_idx + 1 = equal_idx
	 & only_want_key_equal_to_vector
      then
         do;
	  current_idx = equal_idx;
	  cvs_p_vector_less_than_key = "0"b;
	  cvs_p_vector_equal_to_key = "1"b;
	  element_id.index = current_idx;
         end;
   end FIND_LEAF_KEY;
%page;
/* Internal procedure description:

          This program, given a branch node, finds the leaf node which should
     contain the desired leaf key.
*/

FIND_LEAF_NODE:
   proc ();
BRANCH_NODE_LOOP:
      do while (^common_ci_header.is_leaf);

         if is_relative_search
         then if addr (position_stack.id_string (current_depth)) -> element_id.control_interval_id = current_node_id
	    then
	       do;
		current_idx = addr (position_stack.id_string (current_depth)) -> element_id.index;
		if current_idx > 0
		then
		   do;
		      call GET_NEW_KEY (current_node_ptr, current_node_id, current_idx, branch_key_ptr, (0),
			 bk_string_length, element_id_string);
		      less_branch_id = branch_key.branch_id;
		   end;
		else less_branch_id = branch_ci_header.low_branch_id;
	       end;
	    else less_branch_id = branch_ci_header.low_branch_id;
         else less_branch_id = branch_ci_header.low_branch_id;
						/* The low_idx identifies the highest "key" which is */
						/* less than or equal to the vector.  To begin with, */
						/* this is the non-existant key before the first key */
						/* of the node. */
         low_idx = first_idx - 1;			/* The high_idx identifies the lowest key which is */
						/* greater than vector.  To begin with, this is the */
						/* non-existant key after the last key of the node. */
         high_idx = branch_ci_header.common.key_range.last + 1;

         current_idx = divide (low_idx + high_idx, 2, 17, 0);

         call FIND_NEXT_BRANCH ();

         if is_relative_search
         then current_depth = max (current_depth - 1, 1);


         call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
	    branch_ci_header_ptr, element_id_string);

         call CHECK_PARENT_THREAD (parent_node_id, parent_idx, common_ci_header.parent_id_string);

         call SKIP_DEGENERATE_NODES ();

         if is_relative_search
         then if current_node_id = addr (position_stack.id_string (current_depth)) -> element_id.control_interval_id
	    then call SET_RELATIVE_FIRST_IDX (position_stack_ptr, common_ci_header_ptr, first_idx);
	    else first_idx = common_ci_header.key_range.first;
         else first_idx = common_ci_header.key_range.first;

      end BRANCH_NODE_LOOP;

   end FIND_LEAF_NODE;
%page;
/* Internal procedure description:

          This program, given a branch node, finds the next branch node
     indicated by the keys in the given branch node.  Its search algorithm is
     similar to that used for finding a leaf key in a leaf node
     (FIND_LEAF_KEY).
*/

FIND_NEXT_BRANCH:
   proc ();

      is_first_pass_through_loop = "1"b;

/* if the first_idx is after the end of the key_range, then skip to the next CI. */

      if first_idx < high_idx
      then
BRANCH_KEY_LOOP:
         do while (current_idx ^= low_idx | is_first_pass_through_loop);
	  is_first_pass_through_loop = "0"b;

	  call GET_NEW_KEY (current_node_ptr, current_node_id, current_idx, branch_key_ptr, (0), bk_string_length,
	       element_id_string);

	  if is_reposition
	  then call data_format_util_$compare_string_to_string (cvs_p_field_table_ptr, p_key_string_ptr,
		  p_key_string_length, addr (branch_key.string), length (branch_key.string),
		  (branch_key.last_field_idx), cvs_p_first_inequal_field_id, cvs_p_vector_equal_to_key,
		  cvs_p_vector_less_than_key, cvs_p_code);
	  else
	     do;
	        cvs_p_key_string_ptr = addr (branch_key.string);
	        cvs_p_key_string_length = length (branch_key.string);
	        cvs_p_last_field_idx = branch_key.last_field_idx;

	        call COMPARE_VECTOR_TO_STRING ();
	     end;
	  if cvs_p_code ^= 0
	  then call ERROR_RETURN (cvs_p_code);

	  if cvs_p_vector_less_than_key
	  then
	     do;
	        high_idx = current_idx;
	        current_idx = divide (low_idx + current_idx, 2, 17, 0);
	     end;
	  else if cvs_p_first_inequal_field_id <= number_of_fields_in_vector
	  then
	     do;
	        low_idx = current_idx;
	        less_branch_id = branch_key.branch_id;
	        current_idx = divide (high_idx + current_idx, 2, 17, 0);
	     end;
	  else if want_highest_equal_key
	  then
	     do;
	        low_idx = current_idx;
	        less_branch_id = branch_key.branch_id;
	        current_idx = divide (high_idx + current_idx, 2, 17, 0);
	     end;
	  else
	     do;
	        if ^(cvs_p_vector_equal_to_key & want_key_equal_to_vector)
	        then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		   "The vector and the key should have been equal.");
	        if want_key_equal_to_vector & want_keys_greater_than_vector
	        then do;
		   high_idx = current_idx;
		   current_idx = divide (low_idx + current_idx, 2, 17, 0);
	        end;
	        else do;
		   low_idx = current_idx;
		   less_branch_id = branch_key.branch_id;
	        end;
	     end;

         end BRANCH_KEY_LOOP;

      if cvs_p_vector_less_than_key | ^want_highest_equal_key
      then
         do;
	  parent_idx = current_idx;
	  if parent_idx < common_ci_header.key_range.first
	  then parent_idx = 0;
	  parent_node_id = current_node_id;
	  call GET_NEW_NODE (less_branch_id, current_node_id, current_node_ptr);
         end;
      else
         do;

/* current_idx is not used here to set parent_idx because it can be 1
slot lower than the actual parent slot (if the case which caused the
exit from the above loop was the ^want_highest_equal_key case).
element_id.index is always the index of the last key actually inspected.
*/
	  parent_idx = element_id.index;
	  if parent_idx < common_ci_header.key_range.first
	  then parent_idx = common_ci_header.key_range.first;
	  parent_node_id = current_node_id;
	  call GET_NEW_NODE ((branch_key.branch_id), current_node_id, current_node_ptr);
         end;
   end FIND_NEXT_BRANCH;
%page;
/* Internal procedure description:

          This routine gets a pointer to the control interval which is used as
     node gnn_p_node_id.  It also sets gnn_p_current_node_id to this value and
     returns the value of the pointer in gnn_p_current_node_ptr.  In this way
     this routine is used as a double-assignment statement, setting the global
     variables current_node_id and current_node_ptr in tandem. This is to help
     keep the two in synch. 
*/

GET_NEW_NODE:
   proc (gnn_p_node_id, gnn_p_current_node_id, gnn_p_current_node_ptr);

      dcl	    gnn_p_node_id	       fixed bin (24) unsigned;
      dcl	    gnn_p_current_node_id  fixed bin (24) unsigned;
      dcl	    gnn_p_current_node_ptr ptr;

      dcl	    gnn_code	       fixed bin (35);

      gnn_p_current_node_id = gnn_p_node_id;

      call collection_manager_$get_control_interval_ptr (index_cursor.file_opening_id, index_cursor.collection_id,
	 gnn_p_current_node_id, gnn_p_current_node_ptr, gnn_code);
      if gnn_code ^= 0
      then call ERROR_RETURN (gnn_code);

      return;

   end GET_NEW_NODE;
%page;
/* Internal procedure description:

          This routine copies the element at slot 1 in the control interval
     pointed to by gch_p_node_ptr to the buffer pointed to by
     gch_p_common_ci_header_ptr. Slot 1 is reserved for the index control
     interval header. Of the two output parameters, gch_p_leaf_ci_header_ptr
     and gch_p_branch_ci_header_ptr, one will be set to null and the other to
     gch_p_common_ci_header_ptr depending on whether the node is a branch or
     leaf node.
*/

GET_CI_HEADER:
   proc (gch_p_node_ptr, gch_p_node_id, gch_p_common_ci_header_ptr, gch_p_leaf_ci_header_ptr, gch_p_branch_ci_header_ptr,
        gch_p_header_id_string);

      dcl	    (gch_p_node_ptr, gch_p_common_ci_header_ptr, gch_p_leaf_ci_header_ptr, gch_p_branch_ci_header_ptr)
			       ptr;
      dcl	    gch_p_node_id	       fixed bin (24) unsigned;
      dcl	    gch_p_header_id_string bit (36) aligned;

      dcl	    1 gch_p_header_id      aligned like element_id based (addr (gch_p_header_id_string));

      dcl	    gch_header_length_in_bytes
			       fixed bin (35);
      dcl	    gch_header_string      char (gch_header_length_in_bytes) based;
      dcl	    1 gch_slot	       aligned like datum_slot based (gch_slot_ptr);
      dcl	    gch_slot_ptr	       ptr;

      gch_p_header_id.control_interval_id = gch_p_node_id;
      gch_p_header_id.index = 1;

      gch_slot_ptr = addcharno (gch_p_node_ptr, DATUM_POSITION_TABLE_OFFSET_IN_BYTES);
						/* First slot */

      if gch_slot.offset_in_bytes = FREE_SLOT
      then call sub_err_ (dm_error_$no_element, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected an index control interval header at the first slot of^/control interval ^d.", gch_p_node_id);
      if gch_slot.length_in_bits > max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)
      then call sub_err_ (dm_error_$long_return_element, myname, ACTION_CANT_RESTART, null, 0,
	      "^/An index control interval header should be no longer than ^d bits;^/the one in control interval ^d is ^d bits.",
	      max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS), gch_p_node_id,
	      gch_slot.length_in_bits);

      gch_header_length_in_bytes = ceil (divide (gch_slot.length_in_bits, BITS_PER_BYTE, 35, 18));

      gch_p_common_ci_header_ptr -> gch_header_string =
	 addcharno (gch_p_node_ptr, gch_slot.offset_in_bytes) -> gch_header_string;


      if gch_p_common_ci_header_ptr -> common_ci_header.is_leaf
      then
         do;
	  gch_p_leaf_ci_header_ptr = gch_p_common_ci_header_ptr;
	  gch_p_branch_ci_header_ptr = null;

	  if gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first < 0
	  then call ERROR_RETURN (dm_error_$bad_first_key_idx);
	  else if gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.last
	       < gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first
	  then call ERROR_RETURN (dm_error_$bad_last_key_idx);
         end;
      else
         do;
	  gch_p_leaf_ci_header_ptr = null;
	  gch_p_branch_ci_header_ptr = gch_p_common_ci_header_ptr;

	  if gch_p_branch_ci_header_ptr -> branch_ci_header.common.key_range.last
	       < gch_p_branch_ci_header_ptr -> branch_ci_header.common.key_range.first
	  then call ERROR_RETURN (dm_error_$bad_last_key_idx);
         end;

      return;

   end GET_CI_HEADER;
%page;
/* Internal procedure description:
     
          This routine gets a key out of a control interval.  The pointer to
     the control interval (gnk_p_node_ptr) and the index of the key in the
     slot table (gnk_p_index) are input. The gnk_p_key_ptr points to a local
     buffer in which the key will be copied. The two output values are the
     length of the leaf_key.string (gnk_p_lk_string_length) should the key be
     a leaf key, and the length of branch_key.string (gnk_p_bk_string_length)
     should the key be a branch key.  
*/

GET_NEW_KEY:
   proc (gnk_p_node_ptr, gnk_p_node_id, gnk_p_index, gnk_p_key_ptr, gnk_p_lk_string_length, gnk_p_bk_string_length,
        gnk_p_key_id_string);

      dcl	    gnk_p_node_ptr	       ptr;
      dcl	    gnk_p_node_id	       fixed bin (24) unsigned;
      dcl	    gnk_p_index	       fixed bin;
      dcl	    gnk_p_key_ptr	       ptr;
      dcl	    gnk_p_lk_string_length fixed bin (35);
      dcl	    gnk_p_bk_string_length fixed bin (35);
      dcl	    gnk_p_key_id_string    bit (36) aligned;

      dcl	    1 gnk_p_key_id	       aligned like element_id based (addr (gnk_p_key_id_string));

      dcl	    gnk_key_length_in_bytes
			       fixed bin (35);
      dcl	    gnk_key_string	       char (gnk_key_length_in_bytes) based;
      dcl	    1 gnk_slot	       aligned like datum_slot based (gnk_slot_ptr);
      dcl	    gnk_slot_ptr	       ptr;

      gnk_p_key_id.control_interval_id = gnk_p_node_id;
      gnk_p_key_id.index = gnk_p_index;

      gnk_slot_ptr =
	 addcharno (gnk_p_node_ptr, DATUM_POSITION_TABLE_OFFSET_IN_BYTES + BYTES_PER_WORD * (gnk_p_index - 1));

      if gnk_slot.offset_in_bytes = FREE_SLOT
      then call ERROR_RETURN (dm_error_$no_element);
      if gnk_slot.length_in_bits > CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES * BITS_PER_BYTE
      then call ERROR_RETURN (dm_error_$long_return_element);

      gnk_key_length_in_bytes = ceil (divide (gnk_slot.length_in_bits, BITS_PER_BYTE, 35, 18));

      gnk_p_key_ptr -> gnk_key_string = addcharno (gnk_p_node_ptr, gnk_slot.offset_in_bytes) -> gnk_key_string;

      gnk_p_lk_string_length = gnk_slot.length_in_bits;
      gnk_p_bk_string_length = gnk_slot.length_in_bits - BRANCH_KEY_HEADER_LENGTH_IN_BITS;

      return;
   end GET_NEW_KEY;
%page;
/* Internal procedure description:

          This program sets up the local variables, mostly by copying data
     from the parameters.  Input structures are checked to ensure that they
     are of the same version as the structures used by im_basic_search.
*/

INITIALIZE_LOCAL_VARIABLES:
   proc ();

      want_highest_equal_key =
	 (want_keys_less_than_vector & want_key_equal_to_vector)
	 | (want_keys_greater_than_vector & ^want_key_equal_to_vector);
      only_want_key_equal_to_vector =
	 want_key_equal_to_vector & ^(want_keys_less_than_vector | want_keys_greater_than_vector);

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      index_header_ptr = index_opening_info.index_header_ptr;
      call CHECK_VERSION (index_header.version, INDEX_HEADER_VERSION_4, "index_header");

      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected an index type cursor, cursor type ^d.  Received type ^d instead.", INDEX_CURSOR_TYPE,
	      index_cursor.type);

      if index_cursor.version ^= INDEX_CURSOR_VERSION_3
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the index_cursor structure. Received version ^d.", INDEX_CURSOR_VERSION_3,
	      index_cursor.version);

      cvs_p_field_table_ptr = index_opening_info.field_table_ptr;

      if cvs_p_simple_typed_vector_ptr = null
      then
         do;
	  if cvs_p_field_table_ptr -> field_table.version ^= FIELD_TABLE_VERSION_3
	  then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Expected version ^a of the field_table structure.  Received version ^a.", FIELD_TABLE_VERSION_3,
		  cvs_p_field_table_ptr -> field_table.version);
	  number_of_fields_in_vector = cvs_p_field_table_ptr -> field_table.number_of_fields;
         end;
      else number_of_fields_in_vector = cvs_p_simple_typed_vector_ptr -> simple_typed_vector.number_of_dimensions;

      cvs_p_key_string_ptr = addr (local_key_buffer);
      branch_key_ptr = addrel (cvs_p_key_string_ptr, 1);
      common_ci_header_ptr = addr (local_header_buffer);
   end INITIALIZE_LOCAL_VARIABLES;
%page;
/* Internal procedure description:
     
          This program fills in the values in the position_stack structure.
     Ths position_stack defines the effective low (left) end of the index,
     below which (i.e. to the left of which) searches cannot go.  The position
     stack is only used for relative searches.  It is initialized to point at
     the key in the index_cursor and each of that key's ancestors (that key's
     parent key, the parent key's parent key, up to the root parent key).


          In the INIT_TOP_DOWN case, there is no known key position in a leaf
     node stored in the index_cursor, so it is necessary to initialize the
     position_stack by starting with the first (or last) branch in the root
     node and working down the tree.  This finds the levels of the position
     stack in reverse order from the way INIT_BOTTOM_UP finds them, so it's
     necessary to reverse the elements of the position_stack.
     
          In the INIT_BOTTOM_UP case, there is a known key position in a leaf
     which is the least key value, so the position_stack initialization is
     done from the leaf node up to the root node.
     
*/


INIT_POSITION_STACK:
   proc ();
      dcl	    ips_code	       fixed bin (35) init (0);

      call im_validate_cursor (index_opening_info_ptr, index_cursor_ptr, ips_code);
      if ips_code ^= 0
      then call ERROR_RETURN (ips_code);

      if index_cursor.flags.is_at_end_of_index | index_cursor.flags.is_at_beginning_of_index
      then
INIT_TOP_DOWN:
         do;


	  call GET_NEW_NODE ((index_header.root_id), current_node_id, current_node_ptr);
	  call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
	       branch_ci_header_ptr, element_id_string);

	  do while (^common_ci_header.is_leaf);

	     position_stack.depth = position_stack.depth + 1;
	     addr (position_stack.id_string (position_stack.depth)) -> element_id.control_interval_id = current_node_id;

	     if index_cursor.flags.is_at_beginning_of_index
	     then
	        do;
		 call GET_NEW_NODE ((branch_ci_header.low_branch_id), current_node_id, current_node_ptr);
						/* Set current_node_id, current_node_ptr */
		 addr (position_stack.id_string (position_stack.depth)) -> element_id.index = 0;
	        end;
	     else
	        do;
		 current_idx = branch_ci_header.common.key_range.last;
		 addr (position_stack.id_string (position_stack.depth)) -> element_id.index = current_idx;
		 if current_idx = 0
		 then call GET_NEW_NODE ((branch_ci_header.low_branch_id), current_node_id, current_node_ptr);
		 else
		    do;
		       call GET_NEW_KEY (current_node_ptr, current_node_id, current_idx, branch_key_ptr, (0),
			  bk_string_length, element_id_string);
		       call GET_NEW_NODE ((branch_key.branch_id), current_node_id, current_node_ptr);
		    end;
	        end;
	  end;
	  position_stack.depth = position_stack.depth + 1;
	  addr (position_stack.id_string (position_stack.depth)) -> element_id.control_interval_id = current_node_id;
	  if index_cursor.flags.is_at_beginning_of_index
	  then addr (position_stack.id_string (position_stack.depth)) -> element_id.index =
		  common_ci_header.key_range.first;
	  else addr (position_stack.id_string (position_stack.depth)) -> element_id.index =
		  common_ci_header.key_range.last;

/*  The position_stack is "upside down" at this point and needs to be inverted,
to get position_stack(1) to correspond to a position in a leaf node and 
position_stack(position_stack.depth) to correspond to a position in the root. 
*/

	  do depth_idx = 1 to divide (position_stack.depth, 2, 35, 0);
	     temp_id_string = position_stack.id_string (depth_idx);
	     position_stack.id_string (depth_idx) = position_stack.id_string (position_stack.depth - depth_idx + 1);
	     position_stack.id_string (position_stack.depth - depth_idx + 1) = temp_id_string;
	  end;

         end INIT_TOP_DOWN;
      else
INIT_BOTTOM_UP:
         do;
	  call GET_NEW_NODE ((addr (index_cursor.key_id_string) -> element_id.control_interval_id), current_node_id,
	       current_node_ptr);
	  call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
	       branch_ci_header_ptr, element_id_string);

	  position_stack.depth = 1;

	  current_idx = addr (index_cursor.key_id_string) -> element_id.index;
	  if index_cursor.flags.current_key_exists
	  then current_idx = current_idx + 1;

	  if current_idx > common_ci_header.key_range.last
	  then if common_ci_header.next_id > 0
	       then
		do;
		   call GET_NEW_NODE ((common_ci_header.next_id), current_node_id, current_node_ptr);
		   call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
		        branch_ci_header_ptr, element_id_string);
		   current_idx = common_ci_header.key_range.first;
		end;
	       else
		do;
		   p_key_id_string = "0"b;
		   call RETURN ();
		end;

	  addr (position_stack.id_string (1)) -> element_id.control_interval_id = current_node_id;
	  addr (position_stack.id_string (1)) -> element_id.index = current_idx;

	  do while (common_ci_header.parent_id_string ^= "0"b);
	     position_stack.depth = position_stack.depth + 1;
	     position_stack.id_string (position_stack.depth) = common_ci_header.parent_id_string;

	     call GET_NEW_NODE ((addr (common_ci_header.parent_id_string) -> element_id.control_interval_id),
		current_node_id, current_node_ptr);
	     call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
		branch_ci_header_ptr, element_id_string);

	  end;
         end INIT_BOTTOM_UP;

      current_depth = position_stack.depth;

   end INIT_POSITION_STACK;
%page;
/* Internal procedure description:
     
          This program sets up the output parameters of im_basic_search to
     report the failure of a search for an exact match of the input
     typed_vector.  This is the expected result for the im_basic_search$insert
     entry, and the p_key_id and p_maximum_duplication_field output parameters
     provide important information to the caller.
*/

REPORT_FAILED_EXACT_MATCH:
   proc ();
      failed_exact_match = "1"b;

      if is_insertion
      then p_maximum_duplication_field = max (high_duplication_field, low_duplication_field);

      if cvs_p_vector_less_than_key
      then p_key_id = element_id;
      else
         do;
	  p_key_id.control_interval_id = element_id.control_interval_id;
	  p_key_id.index = current_idx + 1;
         end;
   end REPORT_FAILED_EXACT_MATCH;
%page;
/* Internal procedure description:
     
          This procedure makes p_key_id point at the next key after the one
     pointed at by element_id (the current key).  This is the result of the
     search, to be returned to the caller of im_basic_search.
*/

REPORT_NEXT_KEY:
   proc ();
      if element_id.index >= leaf_ci_header.common.key_range.last
      then
         do;
	  p_key_id.control_interval_id = leaf_ci_header.common.next_id;
	  if leaf_ci_header.common.next_id > 0
	  then
	     do;
	        call GET_NEW_NODE ((leaf_ci_header.common.next_id), current_node_id, current_node_ptr);
	        call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
		   branch_ci_header_ptr, element_id_string);
	        p_key_id.index = leaf_ci_header.common.key_range.first;
	     end;
	  else p_key_id.index = 0;
         end;
      else
         do;
	  p_key_id.control_interval_id = element_id.control_interval_id;
	  p_key_id.index = element_id.index + 1;
         end;

   end REPORT_NEXT_KEY;
%page;
/* Internal procedure description:
     
          This procedure makes p_key_id point at the key previous to the one
     pointed at by element_id (the current key).  This is the result of the
     search, to be returned to the caller of im_basic_search.
*/

REPORT_PREVIOUS_KEY:
   proc ();
      if is_relative_search
      then
         do;

/* It's necessary to check that the "previous" key is not before the logical
beginning of the index, as defined in position_stack.
*/
	  if element_id.control_interval_id
	       = addr (position_stack.id_string (current_depth)) -> element_id.control_interval_id
	       & element_id.index <= addr (position_stack.id_string (current_depth)) -> element_id.index
	  then
	     do;
	        p_key_id.control_interval_id = 0;
	        p_key_id.index = 0;
	        return;
	     end;
         end;

      if element_id.index <= leaf_ci_header.common.key_range.first
      then
         do;
	  p_key_id.control_interval_id = leaf_ci_header.common.previous_id;

	  if leaf_ci_header.common.previous_id > 0
	  then
	     do;
	        call GET_NEW_NODE ((leaf_ci_header.common.previous_id), current_node_id, current_node_ptr);
	        call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
		   branch_ci_header_ptr, element_id_string);
	        p_key_id.index = leaf_ci_header.common.key_range.last;
	     end;
	  else p_key_id.index = 0;
         end;
      else
         do;
	  p_key_id.control_interval_id = element_id.control_interval_id;
	  p_key_id.index = element_id.index - 1;
         end;

   end REPORT_PREVIOUS_KEY;
%page;
/* Internal procedure description:
     
          This program changes the index_cursor to point to the new position
     which is the result of the entire search.
*/

REPOSITION_CURSOR:
   proc ();
      dcl	    rp_code	       fixed bin (35);

      string (index_cursor.flags) = "0"b;

      if ^failed_exact_match
      then call im_set_cursor$at_current (index_cursor_ptr, unspec (p_key_id), index_cursor.current_key_string_ptr,
	      (index_cursor.current_key_string_length), rp_code);
      else if p_key_id.index > leaf_ci_header.common.key_range.last
      then if leaf_ci_header.common.next_id ^= 0
	 then
	    do;
	       call GET_NEW_NODE ((leaf_ci_header.common.next_id), current_node_id, current_node_ptr);
	       call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
		  branch_ci_header_ptr, element_id_string);

	       p_key_id.control_interval_id = current_node_id;
	       p_key_id.index = leaf_ci_header.common.key_range.first;
	       call im_set_cursor$no_current (index_cursor_ptr, unspec (p_key_id), index_cursor.current_key_string_ptr,
		  (index_cursor.current_key_string_length), rp_code);
	    end;
	 else
	    do;
	       p_key_id.index = leaf_ci_header.common.key_range.last;
	       call im_set_cursor$at_end (index_cursor_ptr, unspec (p_key_id), index_cursor.current_key_string_ptr,
		  (index_cursor.current_key_string_length), rp_code);
	    end;
      else if p_key_id.index = leaf_ci_header.common.key_range.first & leaf_ci_header.previous_id = 0
      then call im_set_cursor$at_beginning (index_cursor_ptr, unspec (p_key_id), index_cursor.current_key_string_ptr,
	      (index_cursor.current_key_string_length), rp_code);
      else call im_set_cursor$no_current (index_cursor_ptr, unspec (p_key_id), index_cursor.current_key_string_ptr,
	      (index_cursor.current_key_string_length), rp_code);
      if rp_code ^= 0
      then call ERROR_RETURN (rp_code);
   end REPOSITION_CURSOR;
%page;
SET_RELATIVE_FIRST_IDX:
   proc (srfi_p_position_stack_ptr, srfi_p_common_ci_header_ptr, srfi_p_first_idx);
      dcl	    srfi_p_position_stack_ptr
			       ptr parm;
      dcl	    srfi_p_common_ci_header_ptr
			       ptr parm;
      dcl	    srfi_p_first_idx       fixed bin parm;


      srfi_p_first_idx = addr (srfi_p_position_stack_ptr -> position_stack.id_string (current_depth)) -> element_id.index;

/* For branch nodes, the position_stack index indicates the least branch to be
searched, and the first_idx should be set to one greater than this index.
The first_idx is used to indicate the least branch key to be compared against.
Depending on the result of this comparison, the branch greater or less than
(the less_branch_id) this "first" branch key may be used.  The branch less
than the "first" branch key then should be the least branch, that identified
by the position_stack index.

For leaf nodes, the position_stack index indicates the least key which is a
valid result.  Keys less than this key logically don't exist in relative
searches.
*/

      if ^common_ci_header.is_leaf
      then srfi_p_first_idx = max (srfi_p_first_idx + 1, srfi_p_common_ci_header_ptr -> common_ci_header.key_range.first);

   end SET_RELATIVE_FIRST_IDX;
%page;
/* Internal procedure description:

          This procedure finds the first node to be searched and makes it the
     current one.  The first node to search in the absolute search case is
     simply the root node, the first_idx is the key_range.first key in the
     root node.  In the relative search case, it is necessary to
     use the position stack to determine where the effective lower limit of
     the root node is (the value specified in first_idx).
     
*/

SETUP_FIRST_NODE:
   proc ();
      if is_relative_search
      then
         do;
	  if position_stack.depth = 0
	  then call INIT_POSITION_STACK ();
	  else
	     do;
	        current_depth = position_stack.depth;

	        call GET_NEW_NODE ((addr (position_stack.id_string (current_depth)) -> element_id.control_interval_id),
		   current_node_id, current_node_ptr);
	        call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
		   branch_ci_header_ptr, element_id_string);

	     end;

	  call SET_RELATIVE_FIRST_IDX (position_stack_ptr, common_ci_header_ptr, first_idx);
         end;
      else
         do;
	  call GET_NEW_NODE ((index_header.root_id), current_node_id, current_node_ptr);
	  call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
	       branch_ci_header_ptr, element_id_string);

	  first_idx = common_ci_header.key_range.first;
         end;
      parent_node_id = current_node_id;

   end SETUP_FIRST_NODE;
%page;
/* Internal procedure description:

          This procedure ensures that the current node is either a
     non-degenerate branch node, or a leaf node.  A degenerte branch node is
     one which contains no keys and has only a "low_branch", identified by the
     low_branch_id.  Degenerate branches are skipped by just following the
     low_branch_id "pointer".  Degenerate branches can be identified by the
     fact that the key_range.first value in their headers is equal to 0.
*/

SKIP_DEGENERATE_NODES:
   proc ();

      do while (^common_ci_header.is_leaf & common_ci_header.key_range.first = 0);
         parent_node_id = current_node_id;
         parent_idx = 0;

         call GET_NEW_NODE ((branch_ci_header.low_branch_id), current_node_id, current_node_ptr);

         if is_relative_search
         then current_depth = max (current_depth - 1, 1);

         call GET_CI_HEADER (current_node_ptr, current_node_id, common_ci_header_ptr, leaf_ci_header_ptr,
	    branch_ci_header_ptr, element_id_string);

         call CHECK_PARENT_THREAD (parent_node_id, parent_idx, common_ci_header.parent_id_string);
      end;
   end SKIP_DEGENERATE_NODES;
%page;
%include dm_comp_vec_str_proc;
%page;
%include dm_im_cursor;
%page;
%include dm_im_ci_header;
%page;
%include dm_im_key;
%page;
%include dm_element_id;
%page;
%include dm_ci_lengths;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include vu_typed_vector;
%page;
%include dm_im_opening_info;
%page;
%include dm_im_header;
%page;
%include sub_err_flags;
%page;
%include dm_field_table;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;

   end im_basic_search;




		    im_build_interval_spec.pl1      10/02/86  1219.4r w 10/02/86  1204.8      178569



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

/* DESCRIPTION:

         This  module  takes  a search_specification as input and produces an
     interval_specification as output.  The interval_specification consists of
     a series of value intervals which  are  non-overlapping,  each  of  which
     "points"   at   one   or   more   of   the   and_groups   in   the  input
     search_specification.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 10/06/82.
Modified:
10/27/82 by Lindsey Spratt:  Fixed check for purely sequential and_group.
12/06/82 by Lindsey Spratt:  Extended to return a single "null" interval_bead
	  when there are no and_groups.  Also, added a finish proc which
	  is called before returning and on cleanup.
12/09/82 by Lindsey Spratt:  Fixed to initialize interval_bead.next to null.
05/24/83 by Matthew Pierret: Changed to use version 4 of specification_head,
            which includes constraint().value_field_id.
07/11/83 by Matthew Pierret: Extended field_presence_array to keep track of
            non_structural, structural equal and structural less or greater
            fields.  Changed to allow number_of_equal_fields to include the
            first_range_field if that field is an equal field.
            Changed to allow for the possibility of first_range_field being
            equal to number_of_equal_fields when setting the low and high
            constraint idx in SIMPLE_RANGE_CONSTRAINT.   
08/05/83 by Matthew Pierret: Fixed a bug in the setting of the low and high 
            constraint idx.  In the case where the last equal field has more
            than one constraint on it, one being an equal operator and the other
            a range operator, the range operator should be considered to be
            non-structural.  
07/16/84 by Matthew C. Pierret:  Changed the CONSTRAINT_LOOP to detect that
            there are multiple equal constraints on the same field, and to
            consider that case to be both an equal and a non-structural
            constraint.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2
            interval_specification.  Some remodularization was done.
*/

/* format: style2,ind3 */
im_build_interval_spec:
   proc (p_work_area_ptr, p_search_specification_ptr, p_interval_specification_ptr, p_code);

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

      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_search_specification_ptr
			       ptr parameter;
      dcl	    p_interval_specification_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    first_range_field_is_not_adjacent_to_equal_fields
			       bit (1) aligned init ("0"b);

      dcl	    old_interval_bead_ptr  ptr init (null);
      dcl	    root_interval_bead_ptr ptr init (null);
      dcl	    temp_interval_bead_ptr ptr init (null);
      dcl	    field_presence_array_ptr
			       ptr init (null);
      dcl	    temp_next_ptr	       ptr init (null);

      dcl	    fpa_number_of_fields   fixed bin;
      dcl	    and_group_idx	       fixed bin;
      dcl	    first_range_field      fixed bin;
      dcl	    number_of_equal_fields fixed bin;
      dcl	    number_of_intervals    fixed bin init (0);
      dcl	    constraint_idx	       fixed bin;
      dcl	    (last_constraint_idx, low_constraint_idx, high_constraint_idx)
			       fixed bin init (0);

      dcl	    constraint_field_id    fixed bin;
      dcl	    constraint_operator_code
			       fixed bin (18) uns;

      dcl	    work_area_ptr	       ptr init (null);

/* Based */

      dcl	    1 field_presence_array (fpa_number_of_fields) aligned based (field_presence_array_ptr),
	      2 non_structural     bit (1) unal,
	      2 structural	       unal,
	        3 equal	       bit (1) unal,
	        3 less_or_greater  bit (1) unal;

      dcl	    work_area	       based (work_area_ptr) area;

/* Builtin */

      dcl	    (sum, null, min)       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("im_build_interval_spec") char (32) varying internal static options (constant);
      dcl	    (
	    IS_PRESENT	       init ("1"b),
	    NOT_PRESENT	       init ("0"b)
	    )		       bit (1) unal internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$programming_error,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      work_area_ptr = p_work_area_ptr;
      search_specification_ptr = p_search_specification_ptr;
      call CHECK_VERSION (search_specification.version, SPECIFICATION_VERSION_4, "specification");
      if search_specification.head.type ^= ABSOLUTE_SEARCH_SPECIFICATION_TYPE
	 & search_specification.head.type ^= RELATIVE_SEARCH_SPECIFICATION_TYPE
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected a ""search"" type (^d or ^d) specification structure.
Received a structure of type ^d, instead.", ABSOLUTE_SEARCH_SPECIFICATION_TYPE, RELATIVE_SEARCH_SPECIFICATION_TYPE,
	      search_specification.head.type);
      p_code = 0;

      interval_specification_ptr = null;
      interval_bead_ptr = null;
      field_presence_array_ptr = null;

      on cleanup call FINISH;

      if search_specification.number_of_and_groups = 0
      then
         do;
	  alloc interval_bead in (work_area);
	  interval_bead.next = null;
	  interval_bead.simple_typed_vector_ptr = null;
	  interval_bead.low.value_ptr, interval_bead.high.value_ptr = null;
	  interval_bead.low.operator_code, interval_bead.high.operator_code = 0;
	  interval_bead.number_of_fully_structural_fields = 0;
	  interval_bead.id_list_ptr = null;
	  interval_bead.low.id_string, interval_bead.high.id_string = "0"b;
	  root_interval_bead_ptr = interval_bead_ptr;
	  number_of_intervals = 1;
         end;
      else
         do;
	  fpa_number_of_fields = sum (search_specification.and_group.number_of_constraints) + 1;
	  alloc field_presence_array in (work_area);
	  string (field_presence_array (*)) = "0"b;

/* For each and_group, one interval_bead is constructed.  The interval_bead */
/* identifies the "low" end of the interval and the "high" end, among other */
/* things. */

AND_GROUP_LOOP:
	  do and_group_idx = 1 to search_specification.number_of_and_groups;
	     call PROCESS_AND_GROUP (and_group_idx);
	  end AND_GROUP_LOOP;
         end;

      alloc interval_specification in (work_area);
      interval_specification.version = INTERVAL_SPECIFICATION_VERSION_2;
      interval_specification.number_of_intervals = number_of_intervals;
      interval_specification.first_interval_bead_ptr = root_interval_bead_ptr;
      interval_specification.last_interval_bead_ptr = interval_bead_ptr;

      p_interval_specification_ptr = interval_specification_ptr;
      call FINISH;

      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
FINISH:
   proc;
      if interval_specification_ptr = null | interval_specification_ptr ^= p_interval_specification_ptr
      then
         do;
	  do interval_bead_ptr = root_interval_bead_ptr repeat (temp_interval_bead_ptr)
	       while (interval_bead_ptr ^= null);
	     temp_interval_bead_ptr = interval_bead.next;
	     if interval_bead.simple_typed_vector_ptr ^= null
	     then free interval_bead.simple_typed_vector_ptr -> simple_typed_vector in (work_area);
	     if interval_bead.id_list_ptr ^= null
	     then free interval_bead.id_list_ptr -> id_list in (work_area);
	     free interval_bead in (work_area);
	  end;
	  if interval_specification_ptr ^= null
	  then free interval_specification in (work_area);
         end;
      if field_presence_array_ptr ^= null
      then free field_presence_array in (work_area);
   end FINISH;
%page;
PROCESS_AND_GROUP:
   proc (pag_p_and_group_idx);
      dcl	    pag_p_and_group_idx    fixed bin parameter;

      first_range_field = search_specification.and_group (pag_p_and_group_idx).number_of_constraints + 1;
CONSTRAINT_LOOP:
      do constraint_idx = 1 to search_specification.and_group (pag_p_and_group_idx).number_of_constraints;
         call PROCESS_CONSTRAINT (pag_p_and_group_idx, constraint_idx);
      end CONSTRAINT_LOOP;

      do number_of_equal_fields = 1 to min (hbound (field_presence_array, 1) - 1, first_range_field)
	 while (field_presence_array (number_of_equal_fields).structural.equal = IS_PRESENT);
      end;
      if number_of_equal_fields ^= first_range_field
	 | field_presence_array (number_of_equal_fields).structural.equal = NOT_PRESENT
      then number_of_equal_fields = number_of_equal_fields - 1;

      if number_of_equal_fields = first_range_field & field_presence_array (first_range_field).structural.equal
	 & field_presence_array (first_range_field).structural.less_or_greater
      then
         do;
	  field_presence_array (first_range_field).structural.less_or_greater = NOT_PRESENT;
	  field_presence_array (first_range_field).non_structural = IS_PRESENT;
         end;

      if number_of_equal_fields = 0
	 & (first_range_field > 1
	 | (first_range_field = 1 & field_presence_array (first_range_field).structural.less_or_greater = NOT_PRESENT))
      then
NON_STRUCTURAL_CONSTRAINT:
         do;
	  p_interval_specification_ptr = null;

	  do interval_bead_ptr = root_interval_bead_ptr repeat (temp_next_ptr) while (interval_bead_ptr ^= null);
	     temp_next_ptr = interval_bead.next;
	     if interval_bead.simple_typed_vector_ptr ^= null
	     then free interval_bead.simple_typed_vector_ptr -> simple_typed_vector in (work_area);
	     free interval_bead in (work_area);
	  end;
	  return;
         end NON_STRUCTURAL_CONSTRAINT;

      if number_of_equal_fields < first_range_field - 1
      then first_range_field_is_not_adjacent_to_equal_fields = "1"b;
						/* There is a gap following the last equal field. */

      if first_range_field_is_not_adjacent_to_equal_fields
	 | field_presence_array (first_range_field).structural.less_or_greater = NOT_PRESENT
						/* The first_range_field has no "structural" constraint. */
      then
EQUAL_CONSTRAINT:
         do;
	  number_of_intervals = number_of_intervals + 1;
	  old_interval_bead_ptr = interval_bead_ptr;

	  alloc interval_bead in (work_area);
	  interval_bead.next = null;

/* Thread in the new interval_bead. */

	  if old_interval_bead_ptr = null
	  then root_interval_bead_ptr = interval_bead_ptr;
	  else old_interval_bead_ptr -> interval_bead.next = interval_bead_ptr;

/* Build the list of and_group ids for this interval. */

	  il_number_of_ids = 1;
	  alloc id_list in (work_area);
	  id_list.version = ID_LIST_VERSION_1;
	  id_list.id (1) = pag_p_and_group_idx;

	  interval_bead.id_list_ptr = id_list_ptr;

/* Determine the number of fully structural fields. It is possible for the 
last equal field to contain a non structural constraint. This is only
possible if that field is also the first range field. */

	  if ^first_range_field_is_not_adjacent_to_equal_fields
	       & field_presence_array (first_range_field).non_structural = IS_PRESENT
	  then interval_bead.number_of_fully_structural_fields = number_of_equal_fields - 1;
	  else interval_bead.number_of_fully_structural_fields = number_of_equal_fields;

/* Build a simple_typed_vector containing all of the values for the dimensions
defining the interval but the last.  The last defining-dimension's value will
always appear in the low.value_ptr (and high.value_ptr if not doing an
exact-match).
*/

	  stv_number_of_dimensions = number_of_equal_fields;
	  alloc simple_typed_vector in (work_area);
	  simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
	  last_constraint_idx = 0;
	  do constraint_idx = 1 to search_specification.and_group (pag_p_and_group_idx).number_of_constraints;
	     constraint_field_id =
		search_specification.and_group (pag_p_and_group_idx).constraint (constraint_idx).field_id;
	     if constraint_field_id < number_of_equal_fields & constraint_field_id > 0
	     then simple_typed_vector.dimension (constraint_field_id).value_ptr =
		     search_specification.and_group (pag_p_and_group_idx).constraint (constraint_idx).value_ptr;
	     else if constraint_field_id = number_of_equal_fields
		     & search_specification.and_group (pag_p_and_group_idx).constraint (constraint_idx).operator_code
		     = EQUAL_OPERATOR_CODE
	     then last_constraint_idx = constraint_idx;
	  end;

	  interval_bead.simple_typed_vector_ptr = simple_typed_vector_ptr;
	  interval_bead.low.value_ptr =
	       search_specification.and_group (pag_p_and_group_idx).constraint (last_constraint_idx).value_ptr;
	  interval_bead.low.operator_code = GREATER_OR_EQUAL_OPERATOR_CODE;
	  interval_bead.high.value_ptr = interval_bead.low.value_ptr;
	  interval_bead.high.operator_code = LESS_OR_EQUAL_OPERATOR_CODE;

         end EQUAL_CONSTRAINT;
      else if field_presence_array (first_range_field).structural.less_or_greater = IS_PRESENT
      then
SIMPLE_RANGE_CONSTRAINT:
         do;

	  number_of_intervals = number_of_intervals + 1;
	  old_interval_bead_ptr = interval_bead_ptr;
	  alloc interval_bead in (work_area);
	  interval_bead.next = null;

/* Thread the new interval_bead into the list of intervals. */

	  if old_interval_bead_ptr = null
	  then root_interval_bead_ptr = interval_bead_ptr;
	  else old_interval_bead_ptr -> interval_bead.next = interval_bead_ptr;

/* Build the list of and_group ids for this interval. */

	  il_number_of_ids = 1;
	  alloc id_list in (work_area);
	  id_list.version = ID_LIST_VERSION_1;
	  id_list.id (1) = pag_p_and_group_idx;

	  interval_bead.id_list_ptr = id_list_ptr;

/* Determine the number of fully structural fields. The first range field
is the last fully structual field if there are no non-structural contraints
on that field. */

	  if field_presence_array (first_range_field).non_structural = NOT_PRESENT
	  then interval_bead.number_of_fully_structural_fields = first_range_field;

	  else interval_bead.number_of_fully_structural_fields = first_range_field - 1;

/* Build the simple_typed_vector for the interval. */

	  stv_number_of_dimensions = first_range_field;
	  alloc simple_typed_vector in (work_area);
	  simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;

	  low_constraint_idx, high_constraint_idx = 0;
	  do constraint_idx = 1 to search_specification.and_group (pag_p_and_group_idx).number_of_constraints;
	     constraint_field_id =
		search_specification.and_group (pag_p_and_group_idx).constraint (constraint_idx).field_id;
	     constraint_operator_code =
		search_specification.and_group (pag_p_and_group_idx).constraint (constraint_idx).operator_code;

	     if constraint_field_id <= number_of_equal_fields & constraint_field_id > 0
	     then simple_typed_vector.dimension (constraint_field_id).value_ptr =
		     search_specification.and_group (pag_p_and_group_idx).constraint (constraint_idx).value_ptr;

	     if constraint_field_id = first_range_field
	     then if USES_GREATER_OPERATOR (constraint_operator_code)
		then low_constraint_idx = constraint_idx;
		else if USES_LESS_OPERATOR (constraint_operator_code)
		then high_constraint_idx = constraint_idx;
	  end;
	  interval_bead.simple_typed_vector_ptr = simple_typed_vector_ptr;

	  if low_constraint_idx <= 0 & high_constraint_idx <= 0
	  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		  "^/In a simple range specification the low and high constraint indices^/are not set.  One of them must be set."
		  );

	  if low_constraint_idx > 0
	  then
	     do;
	        interval_bead.low.value_ptr =
		   search_specification.and_group (pag_p_and_group_idx).constraint (low_constraint_idx).value_ptr;
	        interval_bead.low.operator_code =
		   search_specification.and_group (pag_p_and_group_idx).constraint (low_constraint_idx).operator_code;
	     end;
	  else
	     do;
	        interval_bead.low.operator_code = GREATER_OPERATOR_CODE;
	        interval_bead.low.value_ptr = null;
	     end;

	  if high_constraint_idx > 0
	  then
	     do;
	        interval_bead.high.value_ptr =
		   search_specification.and_group (pag_p_and_group_idx).constraint (high_constraint_idx).value_ptr;
	        interval_bead.high.operator_code =
		   search_specification.and_group (pag_p_and_group_idx).constraint (high_constraint_idx)
		   .operator_code;
	     end;
	  else
	     do;
	        interval_bead.high.operator_code = LESS_OPERATOR_CODE;
	        interval_bead.high.value_ptr = null;
	     end;
         end SIMPLE_RANGE_CONSTRAINT;
      else
MULTIPLE_RANGE_CONSTRAINT:
         do;

/* The use of "^=" should be addressed by building one interval_bead for */
/* each "^=" present.  Currently, these are applied in the sequential */
/* search. */

         end MULTIPLE_RANGE_CONSTRAINT;
   end PROCESS_AND_GROUP;
%page;
PROCESS_CONSTRAINT:
   proc (pc_p_and_group_idx, pc_p_constraint_idx);
      dcl	    pc_p_and_group_idx     fixed bin parameter;
      dcl	    pc_p_constraint_idx    fixed bin parameter;

      constraint_field_id = search_specification.and_group (pc_p_and_group_idx).constraint (pc_p_constraint_idx).field_id;
      constraint_operator_code =
	 search_specification.and_group (pc_p_and_group_idx).constraint (pc_p_constraint_idx).operator_code;

      if constraint_field_id <= first_range_field & constraint_field_id > 0
      then if constraint_operator_code = EQUAL_OPERATOR_CODE
	 then if field_presence_array (constraint_field_id).structural.equal = NOT_PRESENT
	      then field_presence_array (constraint_field_id).structural.equal = IS_PRESENT;
	      else
	         do;				/* Only one equal constraint on field can be processed structurally */
		  first_range_field = min (first_range_field, constraint_field_id);
		  field_presence_array (constraint_field_id).non_structural = IS_PRESENT;
	         end;
	 else if USES_REGULAR_EXPRESSION_OPERATOR (constraint_operator_code)
		 | constraint_operator_code = NOT_EQUAL_OPERATOR_CODE
		 | search_specification.and_group (pc_p_and_group_idx).constraint (pc_p_constraint_idx).value_field_id
		 >= 1
	 then
	    do;
	       first_range_field = min (first_range_field, constraint_field_id);
	       field_presence_array (constraint_field_id).non_structural = IS_PRESENT;
	    end;
	 else if USES_LESS_OPERATOR (constraint_operator_code) | USES_GREATER_OPERATOR (constraint_operator_code)
	 then
	    do;
	       first_range_field = min (first_range_field, constraint_field_id);
	       field_presence_array (constraint_field_id).structural.less_or_greater = IS_PRESENT;
	    end;
	 else call sub_err_ (dm_error_$programming_error, myname, ACTION_CAN_RESTART, null, 0,
		 "^/The operator code ^d is not recognized as valid.", constraint_operator_code);

   end PROCESS_CONSTRAINT;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include dm_interval_spec;
%page;
%include vu_typed_vector;
%page;
%include dm_id_list;
%page;
%include dm_operator_constants;
%page;
%include sub_err_flags;
   end im_build_interval_spec;




		    im_compare_subset.pl1           01/04/85  0917.4re  01/03/85  1146.1       39960



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
im_compare_subset:
   proc (p_subset_specification_ptr, p_simple_typed_vector_ptr, p_work_area_ptr, p_satisfies_specification,
      p_pseudo_field_value, p_code);

/* DESCRIPTION:

         This  subroutine checks for a keys presence (or lack thereof) in one
     or more subset indices.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 08/23/82.
Modified:
10/12/82 by Lindsey Spratt:  Changed to use version 2 of the
	  search_specification structure.
12/13/82 by Lindsey Spratt:  Upgraded to the version 3 specification.
	  Corrected the calling sequence to position_cursor.
05/23/83 by Matthew Pierret: Upgraded to version 4 specification.
06/08/84 by Lee Baldwin:  Fixed to call dm_error_$key_not_found instead
            of dm_error_$no_key which didn't exist.
*/

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

      dcl	    p_subset_specification_ptr
			       ptr parameter;
      dcl	    p_simple_typed_vector_ptr
			       ptr;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_satisfies_specification
			       bit (1) aligned parameter;
      dcl	    p_pseudo_field_value   bit (*) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    subset_idx	       fixed bin;
      dcl	    search_idx	       fixed bin;

/* Based */

      dcl	    work_area	       based (p_work_area_ptr) area;

/* Builtin */

      dcl	    (null, max, hbound)    builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */
/* Entry */
/* External */

      dcl	    dm_error_$key_not_found fixed bin (35) ext;

/* END OF DECLARATIONS */

      subset_specification_ptr = p_subset_specification_ptr;
      simple_typed_vector_ptr = p_simple_typed_vector_ptr;


      ss_maximum_number_of_constraints = 0;

      do subset_idx = 1 to hbound (subset_specification.subset, 1);
         ss_maximum_number_of_constraints =
	  max (ss_maximum_number_of_constraints,
	  subset_specification.subset (subset_idx).id_list_ptr -> id_list.number_of_ids);
      end;
      search_specification_ptr = null;
      ss_number_of_and_groups = 1;
      on cleanup call finish;
      alloc search_specification in (work_area);
      search_specification.version = SPECIFICATION_VERSION_4;
      search_specification.head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE;
      search_specification.and_group (1).constraint (*).operator_code = EQUAL_OPERATOR_CODE;
      search_specification.and_group (1).constraint (*).value_field_id = -1;
      search_specification.and_group (1).number_of_constraints = ss_maximum_number_of_constraints;

      do search_idx = 1 to ss_maximum_number_of_constraints;
         search_specification.and_group (1).constraint (search_idx).field_id = search_idx;
      end;

      p_satisfies_specification = "1"b;
      do subset_idx = 1 to hbound (subset_specification.subset, 1) while (p_satisfies_specification & p_code = 0);
         id_list_ptr = subset_specification.subset (subset_idx).id_list_ptr;
         do search_idx = 1 to hbound (id_list.id, 1);
	  search_specification.and_group (1).constraint (search_idx).value_ptr =
	     simple_typed_vector.dimension (id_list.id (search_idx)).value_ptr;
         end;
         call
	  index_manager_$position_cursor (search_specification_ptr, p_work_area_ptr,
	  subset_specification.subset (subset_idx).cursor_ptr, p_code);
         if p_code = 0
         then p_satisfies_specification = subset_specification.subset (subset_idx).is_member;
         else if p_code = dm_error_$key_not_found
         then
	  do;
	     p_satisfies_specification = ^subset_specification.subset (subset_idx).is_member;
	     p_code = 0;
	  end;

      end;
      call finish;
      return;
%page;
finish:
   proc;
      if search_specification_ptr ^= null
      then free search_specification in (work_area);
   end finish;
%page;
%include dm_subset_specification;
%page;
%include dm_operator_constants;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include dm_id_list;
%page;
%include vu_typed_vector;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
   end im_compare_subset;




		    im_create_cursor.pl1            01/04/85  0917.4re  01/03/85  1146.1       39393



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
im_create_cursor:
create_cursor:
   proc (p_file_opening_id, p_collection_id, p_work_area_ptr, p_index_cursor_ptr, p_code);

/* DESCRIPTION
   Allocates a index_cursor structure in the provided work area.  This
   cursor is tailored for the index collection with which it is to be used.
   Its initial position is at the beginning of the collection.
*/

/* Written by Matthew Pierret.
Modified:
08/09/82 by Matthew Pierret:  Changed p_collection_id from "fixed bin (17)" to
            "bit (36) aligned".
09/01/82 by Lindsey Spratt:  Changed to use version 2 of the index_cursor.  
02/28/83 by Lindsey Spratt:  Changed to use version 3 of the index_cursor.
	  Added the $destroy entry.
*/

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

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_collection_id	       bit (36) aligned;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_index_cursor_ptr     ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    work_area_ptr	       ptr;
      dcl	    myname	       init ("im_create_cursor") char (32) varying;
      dcl	    cks_length	       fixed bin (24);

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);
      dcl	    current_key_string     bit (cks_length) based;

/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    area		       condition;

/* Constant */
/* Entry */

      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    (
	    error_table_$area_too_small,
	    error_table_$unimplemented_version,
	    dm_error_$wrong_cursor_type
	    )		       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* END OF DECLARATIONS */

      work_area_ptr = p_work_area_ptr;

      on area
         begin;
	  p_code = error_table_$area_too_small;
	  goto RETURN;
         end;

      alloc index_cursor in (work_area);
      index_cursor.version = INDEX_CURSOR_VERSION_3;
      index_cursor.type = INDEX_CURSOR_TYPE;
      index_cursor.area_ptr = work_area_ptr;
      index_cursor.file_opening_id = p_file_opening_id;
      index_cursor.collection_id = p_collection_id;
      index_cursor.key_id_string = "0"b;
      index_cursor.current_key_string_ptr = null;
      index_cursor.current_key_string_length = 0;
      string (index_cursor.flags) = "0"b;
      index_cursor.flags.is_at_beginning_of_index = "1"b;
      index_cursor.flags.is_valid = "1"b;
      p_index_cursor_ptr = index_cursor_ptr;

      p_code = 0;
RETURN:
      return;
%page;
destroy:
   entry (p_index_cursor_ptr, p_code);
      myname = "im_create_cursor$destroy";
      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, "s", null, 0,
	    "^/Expected an index cursor, type ^d. Received a cursor of type ^d.", INDEX_CURSOR_TYPE, index_cursor.type);

      call check_version ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");
      p_code = 0;

      work_area_ptr = index_cursor.area_ptr;
      if index_cursor.current_key_string_ptr ^= null
      then
         do;
	  cks_length = index_cursor.current_key_string_length;
	  free index_cursor.current_key_string_ptr -> current_key_string in (work_area);
         end;
      free index_cursor in (work_area);
      p_index_cursor_ptr = null;
      return;
%page;
check_version:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end check_version;
%page;
%include dm_im_cursor;

   end im_create_cursor;




		    im_create_index.pl1             04/02/87  1313.1r w 04/02/87  1304.8       94302



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



/****^  HISTORY COMMENTS:
  1) change(86-12-03,Dupuis), approve(86-12-03,PBF7311), audit(86-12-05,Blair),
     install(86-12-09,MR12.0-1237):
     Changed the created area to be a freeing area. im_set_cursor
     expected this to be a freeing area and was getting an out-of-bounds
     when it tried to free something.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION

        Creates an empty index collection in the given file with the fields
   specified in typed_vector_array.  An index collection identifier is
   assigned for referencing this collection which is the element id of the
   collection header in the header for this file.  The index collection header
   (index_header) contains the element_id of the field table for this
   collection.  If there are vectors in the typed_vector_array
   (typed_vector_array.number_of_vectors > 0) the new index collection is
   loaded with these vectors.
*/

/* HISTORY:
Written by Lindsey Spratt, 04/01/82.
  (From the source for rcm_create_collection.)
Modified:
04/22/82 by Matthew Pierret: Changed to use data_mgmt_util_$cv_typed_array_to_table
            instead of dmu_build_field_table.
07/27/82 by Lindsey Spratt:  Added p_number_of_duplication_fields to the
	  calling sequence.  Also, changed to using version 2 of the
	  index_header structure.
08/10/82 by Matthew Pierret:  Changed collection ids from "fixed bin (17)" to
            "bit (36) aligned".
08/19/82 by Lindsey Spratt:  Renamed to create_index, from create_collection
	  (it now conforms with the specification).  Added ability to load
	  the index if any vectors are in the typed_vector_array used to
	  define the fields.
11/01/82 by Lindsey Spratt:  Changed to use the version 3 index_header.  This
	  has the key_count_array in it.
03/23/83 by Lindsey Spratt:  Fixed to use version 2 of the field_table.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3, to use
            local structures instead of allocated ones where possible, to use
            "file_" instead of "pf_" and check the version in-line.
            Changed to set index_header.number_of_duplication_fields to
            field_table.number_of_fields+1 if the input value of
            p_number_of_duplication_fields is 0.
05/20/84 by Matthew Pierret:  Changed to use new versions of the 
            ordered_esm_info and unblocked_cism_info structures, and to use
            dm_(esm cism)_info.incl.pl1 instead of 
            dm_cm_(esm cism)_info.incl.pl1.
06/12/84 by Matthew Pierret:  Re-named cm_$allocate_element to cm_$put.
10/28/84 by Lindsey L. Spratt:  Changed to use version 4 of the index_header,
            and to separately allocate the new version 2 key_count_array.
            Changed to use the ERROR_RETURN technology.  Changed DEFINE_AREA
            to take an explicit parameter.
*/

/* format: style2,ind3 */

im_create_index:
   proc (p_file_opening_id, p_typed_vector_array_ptr, p_number_of_duplication_fields, p_index_collection_id, p_code);

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

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_number_of_duplication_fields
			       fixed bin (17);
      dcl	    p_index_collection_id  bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    field_table_id_string  bit (36) aligned init ("0"b);
      dcl	    file_opening_id	       bit (36) aligned init ("0"b);
      dcl	    index_collection_id    bit (36) aligned init ("0"b);
      dcl	    key_count_array_id_string
			       bit (36) aligned init ("0"b);
      dcl	    1 local_ordered_esm_info
			       aligned like ordered_esm_info;
      dcl	    1 local_unblocked_cism_info
			       aligned like unblocked_cism_info;
      dcl	    maximum_element_length fixed bin (35);
      dcl	    work_area_ptr	       ptr;
      dcl	    cursor_ptr	       ptr;

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

      dcl	    (addr, size, currentsize, null, string)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("im_create_index") char (32) varying int static options (constant);
      dcl	    HEADER_COLLECTION_ID   init ("000000000001"b3) bit (36) aligned int static options (constant);
      dcl	    BITS_PER_WORD	       init (36) fixed bin int static options (constant);

/* Entry */

      dcl	    data_format_util_$cv_typed_array_to_table
			       entry (ptr, ptr, ptr, fixed bin (35), fixed bin (35));
      dcl	    define_area_	       entry (ptr, fixed bin (35));
      dcl	    release_area_	       entry (ptr);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    sys_info$max_seg_size  ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

      p_code = 0;
      file_opening_id = p_file_opening_id;
      typed_vector_array_ptr = p_typed_vector_array_ptr;

      on cleanup call FINISH ();

      call DEFINE_AREA (work_area_ptr);

      ft_length_of_field_names, ft_number_of_fields = 0;	/* So compiler won't complain */

      call data_format_util_$cv_typed_array_to_table (typed_vector_array_ptr, work_area_ptr, field_table_ptr,
	 maximum_element_length, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      call CHECK_VERSION (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      local_unblocked_cism_info.version = CISM_INFO_VERSION_1;
      local_unblocked_cism_info.type = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD;
      local_unblocked_cism_info.must_be_zero = 0;

      local_ordered_esm_info.version = ESM_INFO_VERSION_1;
      local_ordered_esm_info.type = ORDERED_ELEMENT_STORAGE_METHOD;
      local_ordered_esm_info.flags.fixed_length = "0"b;
      local_ordered_esm_info.flags.pad = "0"b;
      local_ordered_esm_info.maximum_element_length = maximum_element_length;

      call collection_manager_$create_collection (file_opening_id, addr (local_unblocked_cism_info),
	 addr (local_ordered_esm_info), index_collection_id, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      call collection_manager_$put (file_opening_id, HEADER_COLLECTION_ID, field_table_ptr, length (unspec (field_table)),
	 field_table_id_string, (0), p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      kca_number_of_counts = field_table.number_of_fields;
      alloc key_count_array in (work_area);
      key_count_array.version = KEY_COUNT_ARRAY_VERSION_2;
      key_count_array.count = 0;

      call collection_manager_$put (file_opening_id, HEADER_COLLECTION_ID, key_count_array_ptr,
	 length (unspec (key_count_array)), key_count_array_id_string, (0), p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      alloc index_header in (work_area);
      index_header.version = INDEX_HEADER_VERSION_4;
      unspec (index_header.field_table_element_id) = field_table_id_string;
      if p_number_of_duplication_fields = 0
      then index_header.number_of_duplication_fields = field_table.number_of_fields + 1;
      else index_header.number_of_duplication_fields = p_number_of_duplication_fields;
      index_header.root_id = 0;
      unspec (index_header.key_count_array_element_id) = key_count_array_id_string;
      index_header.pad1 = "0"b;
      index_header.pad2 = "0"b;

      call collection_manager_$put_header (file_opening_id, index_collection_id, index_header_ptr,
	 length (unspec (index_header)), p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      if typed_vector_array.number_of_vectors > 0
      then
         do;
	  call index_manager_$create_cursor (file_opening_id, index_collection_id, work_area_ptr, cursor_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  call index_manager_$put_key_array (typed_vector_array_ptr, cursor_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);
         end;

      call FINISH;

      p_index_collection_id = index_collection_id;

MAIN_RETURN:
      return;



FINISH:
   proc;
      if work_area_ptr ^= null
      then call release_area_ (work_area_ptr);

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;

      call FINISH ();
      p_code = er_p_code;
      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_expected_version, p_received_version, p_structure_name);
      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
DEFINE_AREA:
   proc (da_p_work_area_ptr);
      dcl	    da_p_work_area_ptr     ptr parameter;

      dcl	    1 da_area_info	       aligned like area_info;
      dcl	    da_code	       fixed bin (35) init (0);

      da_area_info.version = area_info_version_1;
      string (da_area_info.control) = "0"b;
      da_area_info.control.extend = "1"b;
      da_area_info.owner = myname;
      da_area_info.size = sys_info$max_seg_size;
      da_area_info.areap = null;

      call define_area_ (addr (da_area_info), da_code);
      if da_code ^= 0
      then call ERROR_RETURN (da_code);

      da_p_work_area_ptr = da_area_info.areap;

   end DEFINE_AREA;
%page;
%include sub_err_flags;
%page;
%include dm_key_count_array;
%page;
%include vu_typed_vector_array;
%page;
%include dm_im_header;
%page;
%include dm_field_table;
%page;
%include dm_cism_info;
%page;
%include dm_esm_info;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include area_info;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include dm_element_id;
   end im_create_index;




		    im_create_subset_index.pl1      01/04/85  0917.4re  01/03/85  1146.2       28179



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
im_create_subset_index:
   proc (p_specification_ptr, p_subset_pf_opening_id, p_cursor_ptr, p_id_list_ptr, p_subset_index_id, p_code);

/* DESCRIPTION:

         This  module  creates  a  subset  index  from  an index.  The subset
     index's keys are derived from keys found in the source index.  The subset
     index keys can have any of the fields in the source index in any order.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 08/19/82.
Modified:
12/13/82 by Lindsey Spratt:  Added interval_list_ptr ptr to get_key call.
*/

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

      dcl	    p_specification_ptr    ptr parameter;
      dcl	    p_subset_pf_opening_id bit (36) aligned parameter;
      dcl	    p_cursor_ptr	       ptr parameter;
      dcl	    p_id_list_ptr	       ptr parameter;
      dcl	    p_subset_index_id      bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    1 local_area_info      like area_info;
      dcl	    (typed_vector_array_ptr, subset_typed_vector_array_ptr)
			       ptr;
      dcl	    subset_cursor_ptr      ptr;

/* Based */
/* Builtin */

      dcl	    (null, hbound, addr)   builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("im_create_subset_index") char (23) internal static options (constant);

/* Entry */

      dcl	    define_area_	       entry (ptr, fixed bin (35));
      dcl	    release_area_	       entry (ptr);

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;

/* END OF DECLARATIONS */

      id_list_ptr = p_id_list_ptr;
      p_code = 0;

      local_area_info.version = area_info_version_1;
      local_area_info.control = "0"b;
      local_area_info.extend = "1"b;
      local_area_info.owner = myname;
      local_area_info.size = sys_info$max_seg_size;
      local_area_info.areap = null;

      on cleanup call finish;

      call define_area_ (addr (local_area_info), p_code);
      if p_code ^= 0
      then goto ERROR_RETURN;

      call
         index_manager_$get_key (p_specification_ptr, id_list_ptr, local_area_info.areap, p_cursor_ptr,
         typed_vector_array_ptr, null, p_code);
      if p_code ^= 0
      then goto ERROR_RETURN;

      call
         index_manager_$create_index (p_subset_pf_opening_id, subset_typed_vector_array_ptr, hbound (id_list.id, 1),
         p_subset_index_id, p_code);
      if p_code ^= 0
      then goto ERROR_RETURN;


ERROR_RETURN:
      call finish;
      return;
%page;
finish:
   proc;
      if local_area_info.areap ^= null
      then call release_area_ (local_area_info.areap);
   end finish;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include dm_id_list;
%page;
%include area_info;
   end im_create_subset_index;




		    im_delete_node.pl1              04/04/85  1109.9r w 04/04/85  0913.2       55674



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

/* DESCRIPTION:

         This module is used to free a node from an index.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 08/06/82.
Modified:
12/10/82 by Lindsey Spratt:  Updated to use version 2 of the index_cursor.
12/13/82 by Lindsey Spratt:  Fixed wrong calling sequence of
	  $free_control_interval, the zero_on_free argument was missing.
02/28/83 by Lindsey Spratt:  Updated to use version 3 of the index_cursor.
04/26/83 by Lindsey L. Spratt:  Fixed to update the "sibling" node CI pointers
            in the preceding and following nodes of the node being deleted.
04/27/83 by Lindsey L. Spratt:  Fixed to pass the correct buffer size to
            $get_element.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get,
            cm_$put_element to cm_$modify.  Switched the order of the
            ci header length and ptr in the call to cm_$modify.
*/
/* format: style2,ind3 */
%page;
im_delete_node:
   proc (p_index_cursor_ptr, p_control_interval_id, p_code);

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

      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_control_interval_id  fixed bin (24) unsigned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (ci_following_deleted_node, ci_preceding_deleted_node)
			       fixed bin (24) unsigned unaligned;
      dcl	    local_ci_header_buffer bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)) aligned;

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    DEFAULT_AREA_PTR       init (null) ptr internal static options (constant);
      dcl	    DEFAULT_ELEMENT_LENGTH init (-1) fixed bin (35) internal static options (constant);

      dcl	    myname	       init ("im_delete_node") char (14) internal static options (constant);
      dcl	    ZERO_ON_FREE	       init ("1"b) bit aligned internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$wrong_cursor_type
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, "s", null, 0,
	    "^/Expected an ""index"" type cursor (type ^d).  
Received a cursor of type ^d instead.", INDEX_CURSOR_TYPE, index_cursor.type);
      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");


      common_ci_header_ptr = addr (local_ci_header_buffer);
      call GET_CI_HEADER ((p_control_interval_id), common_ci_header_ptr, p_code);
      if p_code ^= 0
      then return;

      ci_preceding_deleted_node = common_ci_header.previous_id;
      ci_following_deleted_node = common_ci_header.next_id;

      if ci_preceding_deleted_node > 0
      then
         do;
	  call GET_CI_HEADER (ci_preceding_deleted_node, common_ci_header_ptr, p_code);
	  if p_code ^= 0
	  then return;
	  common_ci_header.next_id = ci_following_deleted_node;
	  call PUT_CI_HEADER (ci_preceding_deleted_node, common_ci_header_ptr, p_code);
	  if p_code ^= 0
	  then return;
         end;

      if ci_following_deleted_node > 0
      then
         do;
	  call GET_CI_HEADER (ci_following_deleted_node, common_ci_header_ptr, p_code);
	  if p_code ^= 0
	  then return;
	  common_ci_header.previous_id = ci_preceding_deleted_node;
	  call PUT_CI_HEADER (ci_following_deleted_node, common_ci_header_ptr, p_code);
	  if p_code ^= 0
	  then return;
         end;

      call
         collection_manager_$free_control_interval (index_cursor.file_opening_id, index_cursor.collection_id,
         p_control_interval_id, ZERO_ON_FREE, p_code);

      return;
%page;
GET_CI_HEADER:
   proc (p_control_interval_id, p_ci_header_ptr, p_code);
      dcl	    p_control_interval_id  fixed bin (24) unsigned unal;
      dcl	    p_ci_header_ptr	       ptr;
      dcl	    p_code	       fixed bin (35);


      element_id.control_interval_id = p_control_interval_id;
      element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
      p_code = 0;

      call
         collection_manager_$get (index_cursor.file_opening_id, index_cursor.collection_id, element_id_string, 0,
         p_ci_header_ptr, max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS), DEFAULT_AREA_PTR, "0"b,
         p_ci_header_ptr, (0), p_code);
      if p_code ^= 0
      then return;
   end GET_CI_HEADER;
%page;
PUT_CI_HEADER:
   proc (p_control_interval_id, p_ci_header_ptr, p_code);
      dcl	    p_control_interval_id  fixed bin (24) unsigned unal;
      dcl	    p_ci_header_ptr	       ptr;
      dcl	    p_code	       fixed bin (35);


      element_id.control_interval_id = p_control_interval_id;
      element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
      p_code = 0;

      call
         collection_manager_$modify (index_cursor.file_opening_id, index_cursor.collection_id, p_ci_header_ptr,
         DEFAULT_ELEMENT_LENGTH, element_id_string, (0), p_code);
      if p_code ^= 0
      then return;
   end PUT_CI_HEADER;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_expected_version ^= p_received_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname,
	    "^/Expected version ^d of the ^a structure. Received version ^d instead.", p_expected_version,
	    p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include dm_im_cursor;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_im_ci_header;
%page;
%include dm_element_id;
   end im_delete_node;




		    im_destroy_index.pl1            01/04/85  0917.4re  01/03/85  1146.3       16506



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

/* DESCRIPTION:
         This  routine  destroys  an index collection.  Currently the opening
     ingo, if there is any, is left intact.  This should be  changed  to  free
     all opening info.
*/

/* HISTORY:

Written by Matthew Pierret, 04/07/83.
Modified:
05/23/84 by Lindsey L. Spratt:  Removed the unused CHECK_VERSION procedure.
*/

/* format: style2,ind3 */
im_destroy_index:
   proc (p_file_opening_id, p_index_collection_id, p_code);

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

      dcl	    p_file_opening_id      bit (36) aligned;	/*is a file opening identifier*/
      dcl	    p_index_collection_id  bit (36) aligned;	/*is the collection id of the
                                          index*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system error code*/

/* Automatic */
/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("im_destroy_collection") char (32) varying internal static options (constant);

/* Entry */

      dcl	    collection_manager_$destroy_collection
			       entry (bit (36) aligned, bit (36) aligned, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;
      call collection_manager_$destroy_collection (p_file_opening_id, p_index_collection_id, p_code);
      return;
%page;
%include sub_err_flags;
   end im_destroy_index;




		    im_general_delete.pl1           04/04/85  1109.9r w 04/04/85  0913.3      174159



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

/* DESCRIPTION:

         This module is used to delete a specific key, either a leaf or
     branch.  If the leaf key being deleted is the last key in the node, then
     the node is deleted and im_general_delete is recursively invoked to
     delete its parent key.  If the branch being deleted is not the low branch
     id, then the key is simply deleted and the procedure is done.  If the
     branch being deleted is the low_branch_id and there exist one or more
     keys in the branch node, then the lowest key in the node is deleted and
     its branch is made the low_branch_id, and the procedure is done.  The
     last case is if the branch being deleted is the low_branch_id and there
     are no keys in the branch node (i.e., it is a "degenerate" node).  In
     this situation, the branch node is freed and im_general_delete is
     recursively invoked to delete the parent key.

     This module does not directly modify the contents of a file.  All 
     modifications are actually made by the support routine im_simple_delete.
     
     This module accesses data via the "direct access" method, which involves
     first getting a pointer to a control interval then getting data from it
     by calling collection_manager_$simple_get_by_ci_ptr or
     $get_portion_from_ci_buffer.

     ***** This module must not attempt to modify the contents of the   *****
     ***** current node/control interval.  All modification is done     *****
     ***** in the subroutine im_simple_delete.  This includes both      *****
     ***** modifications via collection_manager_ and via direct access. *****
*/

/* HISTORY:

Written by Lindsey L. Spratt, 08/06/82.
Modified:
10/18/82 by Matthew Pierret:  Added '"s", null, 0' arguments to sub_err_ call
            in check_version.  Updated to use INDEX_CURSOR_VERSION_2 and
            cm_$get_element_portion where appropriate.
11/09/82 by Lindsey Spratt:  Changed calling sequence to remove
	  index_header_ptr.  Changed to set the new root_id via the
	  im_update_opening_info$root_id, rather than doing so directly.
12/10/82 by Lindsey Spratt:  Changed to do a delete_node when deleting the
	  last key in a leaf node, rather than doing a simple_delete.
	  Changed to set the root_id to 0 after deleting the root (leaf)
	  node.  Also, changed to not re-use the ci_header space provided by
	  the  caller when doing a recursive delete on the parent node, but
	  to use a local ci_header.
02/28/83 by Lindsey Spratt:  Changed to use version 3 index_cursor.
04/27/83 by Lindsey L. Spratt:  Fixed to update the parent_id_string of the
            new root node to be "0"b.
04/28/83 by Lindsey L. Spratt:  Fixed to update the parent_id_string of the
            node pointed to by the low_branch_id.
11/07/83 by Lindsey L. Spratt:  CHanged to use the "buffered" technology.
            Also, converted to use the "call ERROR_RETURN(code)" protocol.
03/27/84 by Matthew Pierret:  Changed from the "buffered access" technology
            to the "direct access" technology, in which a pointer to a
            control interval in the file is obtained.  Changed to not
            replace the ci buffer contents after recursively invoking
            itself.  All modifications are actually made by the support
            routine im_simple_delete.
06/07/84 by Matthew Pierret:  Re-named cm_$simple_get_element_ptr to
            cm_$simple_get_by_ci_ptr, cm_$get_element to cm_$get,
            cm_$get_element_portion_buffered to cm_$get_portion_from_ci_buffer,
            cm_$put_element to cm_$modify, PUT_ELEMENT to MODIFY_ELEMENT.
10/28/84 by Lindsey L. Spratt:  Removed dm_im_header.incl.pl1.  Made
            index_opening_info_ptr local to the internal proc which references
            it.
*/

/* format: style2,ind3 */
%page;
im_general_delete:
   proc (p_node_ptr, p_index_cursor_ptr, p_common_ci_header_ptr, p_key_id_string, p_deleted_node, p_code);


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

      dcl	    p_node_ptr	       ptr parameter;
      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_common_ci_header_ptr ptr parameter;
      dcl	    p_key_id_string	       bit (36) aligned;
      dcl	    p_deleted_node	       bit (1) aligned;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    local_ci_header_buffer bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)) aligned;

      dcl	    (node_ptr, parent_node_ptr, parent_branch_ci_header_ptr)
			       ptr init (null);
      dcl	    (parent_node_id, new_root_id)
			       fixed bin (24) uns init (0);
      dcl	    parent_key_id_string   bit (36) aligned;
      dcl	    (new_buffer_was_allocated, deleted_node)
			       bit (1) aligned init ("0"b);
      dcl	    local_key_buffer       bit (BRANCH_KEY_HEADER_LENGTH_IN_BITS) aligned;
      dcl	    local_node_buffer      bit (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES * BITS_PER_BYTE) aligned;


/* Based */
/* Builtin */

      dcl	    (null, addr, length)   builtin;

/* Constant */

      dcl	    DEFAULT_AREA_PTR       init (null) ptr internal static options (constant);
      dcl	    (
	    DEFAULT_ELEMENT_LENGTH init (-1),
	    BITS_PER_BYTE	       init (9)
	    )		       fixed bin (35) internal static options (constant);

      dcl	    myname	       init ("im_general_delete") char (17) internal static options (constant);

/* Entry */

      dcl	    im_get_opening_info    entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    im_update_opening_info$root_id
			       entry (ptr, uns fixed bin (24), fixed bin (35));
      dcl	    im_simple_delete       entry (ptr, ptr, ptr, bit (36) aligned, fixed bin (35));
      dcl	    im_delete_node	       entry (ptr, fixed bin (24) unsigned, ptr, fixed bin (35));
      dcl	    im_general_delete      entry (ptr, ptr, ptr, bit (36) aligned, bit (1) aligned, fixed bin (35));
      dcl	    im_update_branches$single
			       entry (ptr, bit (36) aligned, bit (36) aligned, ptr, uns fixed bin (24) unal,
			       uns fixed bin (12) unal, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$wrong_cursor_type,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;
      p_deleted_node = "0"b;
      node_ptr = p_node_ptr;
      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected an ""index"" type cursor (type ^d).  
Received a cursor of type ^d instead.", INDEX_CURSOR_TYPE, index_cursor.type);

      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      common_ci_header_ptr = p_common_ci_header_ptr;

      if common_ci_header.is_leaf
      then
         do;
	  leaf_ci_header_ptr = common_ci_header_ptr;
	  if leaf_ci_header.common.key_range.last > leaf_ci_header.common.key_range.first
	  then /* There is more than one key in the ci. */
	     do;
	        call im_simple_delete (node_ptr, index_cursor_ptr, leaf_ci_header_ptr, p_key_id_string, p_code);
	        if p_code ^= 0
	        then call ERROR_RETURN (p_code);
	     end;
	  else
	     do;
	        parent_key_id_string = leaf_ci_header.common.parent_id_string;

	        call im_delete_node (index_cursor_ptr, (addr (p_key_id_string) -> element_id.control_interval_id),
		   common_ci_header_ptr, p_code);
	        if p_code ^= 0
	        then call ERROR_RETURN (p_code);

	        common_ci_header.key_range.first, common_ci_header.key_range.last = 0;
	        p_deleted_node = "1"b;		/* To indicate that the current leaf node is empty and gone. */
	        if parent_key_id_string = "0"b
	        then call UPDATE_ROOT_ID (0);
	        else
		 do;

		    parent_branch_ci_header_ptr = addr (local_ci_header_buffer);
		    call GET_PARENT_NODE ((addr (parent_key_id_string) -> element_id.control_interval_id),
		         parent_node_id, parent_node_ptr);
		    call GET_CI_HEADER_PTR (parent_node_ptr, parent_node_id, parent_branch_ci_header_ptr);

		    call im_general_delete (parent_node_ptr, index_cursor_ptr, parent_branch_ci_header_ptr,
		         parent_key_id_string, deleted_node, p_code);
		    if p_code ^= 0
		    then call ERROR_RETURN (p_code);
		 end;
	     end;
         end;
      else if common_ci_header.parent_id_string = "0"b
	      & common_ci_header.key_range.first = common_ci_header.key_range.last
	      & common_ci_header.key_range.first > 0
      then
         do;					/* Current node is the root node, and the "upcoming" */
						/* deletion will leave it "degenerate".  Rather than */
						/* have a degenerate root node, this root node is deleted */
						/* and the single child of its degenerate form is made */
						/* the new root node. */
	  branch_ci_header_ptr = common_ci_header_ptr;

	  if addr (p_key_id_string) -> element_id.index > 0
	  then new_root_id = branch_ci_header.low_branch_id;
	  else
	     do;
	        bk_string_length = 0;
	        element_id.control_interval_id = addr (p_key_id_string) -> element_id.control_interval_id;
	        element_id.index = branch_ci_header.common.key_range.first;
	        call collection_manager_$get_portion_from_ci_buffer (node_ptr, index_cursor.file_opening_id,
		   index_cursor.collection_id, element_id_string, addr (local_key_buffer), length (local_key_buffer),
		   null, 1, BRANCH_KEY_HEADER_LENGTH_IN_BITS, new_buffer_was_allocated, branch_key_ptr, (0), p_code);
	        if p_code ^= 0
	        then call ERROR_RETURN (p_code);
	        new_root_id = branch_key.branch_id;
	     end;
	  call im_delete_node (index_cursor_ptr, (addr (p_key_id_string) -> element_id.control_interval_id),
	       common_ci_header_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  p_deleted_node = "1"b;

/* The node which is to become the new root node must have its
parent_id_string updated to be "0"b, indicating it is the root node. */

	  common_ci_header_ptr = addr (local_ci_header_buffer);
	  call GET_CI_HEADER ((new_root_id), common_ci_header_ptr);

	  common_ci_header.parent_id_string = "0"b;

	  call PUT_CI_HEADER ((new_root_id), common_ci_header_ptr);

/* The root_id values in the index_opening_info and the index header must be
updated. */

	  call UPDATE_ROOT_ID (new_root_id);
         end;
      else if addr (p_key_id_string) -> element_id.index > 0
      then call im_simple_delete (node_ptr, index_cursor_ptr, common_ci_header_ptr, p_key_id_string, p_code);
      else if common_ci_header.key_range.first > 0
      then
         do;
	  branch_ci_header_ptr = common_ci_header_ptr;

	  bk_string_length = 0;
	  element_id.control_interval_id = addr (p_key_id_string) -> element_id.control_interval_id;
	  element_id.index = branch_ci_header.common.key_range.first;
	  call collection_manager_$get_portion_from_ci_buffer (node_ptr, index_cursor.file_opening_id,
	       index_cursor.collection_id, element_id_string, addr (local_key_buffer), length (local_key_buffer), null,
	       1, BRANCH_KEY_HEADER_LENGTH_IN_BITS, new_buffer_was_allocated, branch_key_ptr, (0), p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  branch_ci_header.low_branch_id = branch_key.branch_id;
	  call im_simple_delete (node_ptr, index_cursor_ptr, branch_ci_header_ptr, element_id_string, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

/* im_simple_delete knows to update the branches grater than or equal to
element_id.index, but the 0'th branch (the low_branch_id) must also be
updated. */

	  call im_update_branches$single (node_ptr, index_cursor.file_opening_id, index_cursor.collection_id,
	       branch_ci_header_ptr, element_id.control_interval_id, 0, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

         end;
      else
         do;
	  parent_key_id_string = common_ci_header.parent_id_string;

	  call im_delete_node (index_cursor_ptr, (addr (p_key_id_string) -> element_id.control_interval_id),
	       common_ci_header_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  p_deleted_node = "1"b;

	  common_ci_header.key_range.first, common_ci_header.key_range.last = 0;
						/* This indicates that the node in question is empty (gone, as well). */

	  call GET_PARENT_NODE ((addr (parent_key_id_string) -> element_id.control_interval_id), parent_node_id,
	       parent_node_ptr);

	  parent_branch_ci_header_ptr = addr (local_ci_header_buffer);
	  call GET_CI_HEADER_PTR (parent_node_ptr, parent_node_id, parent_branch_ci_header_ptr);

	  call im_general_delete (parent_node_ptr, index_cursor_ptr, parent_branch_ci_header_ptr, parent_key_id_string,
	       deleted_node, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

         end;

MAIN_RETURN:
      return;
%page;
FINISH:
   proc ();
   end FINISH;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);
      call FINISH;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;


CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ^d of the ^a structure. Received version ^d instead.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
UPDATE_ROOT_ID:
   proc (uri_p_root_id);
      dcl	    uri_p_root_id	       fixed bin (24) uns;
      dcl	    uri_code	       fixed bin (35) init (0);
      dcl	    uri_index_opening_info_ptr
			       ptr init (null);

      call im_get_opening_info (index_cursor.file_opening_id, index_cursor.collection_id, uri_index_opening_info_ptr,
	 uri_code);
      if uri_code ^= 0
      then call ERROR_RETURN (uri_code);

      call im_update_opening_info$root_id (uri_index_opening_info_ptr, uri_p_root_id, uri_code);
      if uri_code ^= 0
      then call ERROR_RETURN (uri_code);
   end UPDATE_ROOT_ID;
%page;
GET_CI_HEADER:
   proc (gch_p_control_interval_id, gch_p_ci_header_ptr);
      dcl	    gch_p_control_interval_id
			       fixed bin (24) unsigned;
      dcl	    gch_p_ci_header_ptr    ptr;
      dcl	    gch_p_node_ptr	       ptr;
      dcl	    gch_by_node_ptr	       bit (1) aligned;

      gch_by_node_ptr = "0"b;
      goto GCH_JOIN;

GET_CI_HEADER_PTR:
   entry (gch_p_node_ptr, gch_p_control_interval_id, gch_p_ci_header_ptr);
      gch_by_node_ptr = "1"b;
GCH_JOIN:
      if gch_by_node_ptr
      then call GET_ELEMENT_PTR (gch_p_node_ptr, gch_p_control_interval_id, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	      gch_p_ci_header_ptr, max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS), (0));
      else call GET_ELEMENT (gch_p_control_interval_id, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT), gch_p_ci_header_ptr,
	      max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS), (0));
   end GET_CI_HEADER;




PUT_CI_HEADER:
   proc (pch_p_control_interval_id, pch_p_ci_header_ptr);
      dcl	    pch_p_control_interval_id
			       fixed bin (24) unsigned;
      dcl	    pch_p_ci_header_ptr    ptr;
      dcl	    pch_p_node_ptr	       ptr;

      call MODIFY_ELEMENT (pch_p_control_interval_id, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	 DEFAULT_ELEMENT_LENGTH, pch_p_ci_header_ptr);
   end PUT_CI_HEADER;
%page;
GET_ELEMENT:
   proc (ge_p_control_interval_id, ge_p_slot_index, ge_p_buffer_ptr, ge_p_buffer_length, ge_p_element_length);

      dcl	    ge_p_control_interval_id
			       fixed bin (24) uns;
      dcl	    ge_p_slot_index	       fixed bin (12) uns;
      dcl	    ge_p_buffer_ptr	       ptr;
      dcl	    ge_p_buffer_length     fixed bin (35);
      dcl	    ge_p_element_length    fixed bin (35);
      dcl	    ge_p_node_ptr	       ptr;

      dcl	    ge_code	       fixed bin (35) init (0);

      dcl	    1 ge_element_id	       aligned based (addr (ge_element_id_string)) like element_id;
      dcl	    ge_element_id_string   bit (36) aligned;
      dcl	    ge_by_node_ptr	       bit (1) aligned;

      ge_by_node_ptr = "0"b;
      goto GE_JOIN;

GET_ELEMENT_PTR:
   entry (ge_p_node_ptr, ge_p_control_interval_id, ge_p_slot_index, ge_p_buffer_ptr, ge_p_buffer_length,
        ge_p_element_length);

      ge_by_node_ptr = "1"b;
GE_JOIN:
      ge_element_id.control_interval_id = ge_p_control_interval_id;
      ge_element_id.index = ge_p_slot_index;

      if ge_by_node_ptr
      then call collection_manager_$simple_get_by_ci_ptr (ge_p_node_ptr, index_cursor.collection_id, ge_element_id_string,
	      ge_p_buffer_ptr, ge_p_buffer_length, ge_p_element_length, ge_code);
      else call collection_manager_$get (index_cursor.file_opening_id, index_cursor.collection_id, ge_element_id_string,
	      (0), ge_p_buffer_ptr, ge_p_buffer_length, null, ("0"b), null, ge_p_element_length, ge_code);
      if ge_code ^= 0
      then call ERROR_RETURN (ge_code);

   end GET_ELEMENT;
%page;
MODIFY_ELEMENT:
   proc (me_p_control_interval_id, me_p_slot_index, me_p_element_length, me_p_element_ptr);
      dcl	    me_p_control_interval_id
			       fixed bin (24) uns;
      dcl	    me_p_slot_index	       fixed bin (12) uns;
      dcl	    me_p_element_length    fixed bin (35);
      dcl	    me_p_element_ptr       ptr;
      dcl	    me_p_node_ptr	       ptr;

      dcl	    me_code	       fixed bin (35) init (0);

      dcl	    1 me_element_id	       aligned based (addr (me_element_id_string)) like element_id;
      dcl	    me_element_id_string   bit (36) aligned;

      me_element_id.control_interval_id = me_p_control_interval_id;
      me_element_id.index = me_p_slot_index;

      call collection_manager_$modify (index_cursor.file_opening_id, index_cursor.collection_id, me_p_element_ptr,
	 me_p_element_length, me_element_id_string, (0), me_code);
      if me_code ^= 0
      then call ERROR_RETURN (me_code);

   end MODIFY_ELEMENT;
%page;
GET_PARENT_NODE:
   proc (gpn_p_node_id, gpn_p_parent_node_id, gpn_p_parent_node_ptr);

      dcl	    (gpn_p_node_id, gpn_p_parent_node_id)
			       fixed bin (24) unsigned;
      dcl	    gpn_p_parent_node_ptr  ptr;

      dcl	    gpn_code	       fixed bin (35) init (0);

      gpn_p_parent_node_id = gpn_p_node_id;

      call collection_manager_$get_control_interval_ptr (index_cursor.file_opening_id, index_cursor.collection_id,
	 gpn_p_parent_node_id, gpn_p_parent_node_ptr, gpn_code);
      if gpn_code ^= 0
      then call ERROR_RETURN (gpn_code);

   end GET_PARENT_NODE;
%page;
%include dm_im_cursor;
%page;
%include dm_im_key;
%page;
%include dm_im_ci_header;
%page;
%include dm_element_id;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_ci_lengths;
%page;
%include sub_err_flags;
   end im_general_delete;




		    im_general_insert.pl1           01/04/85  0917.4re  01/03/85  1146.3       63234



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

/* DESCRIPTION:
          This module is used primarily by im_put_key to insert a key into an
     index at a specified location in the index.  (Location is meant in terms
     of between to particular leaf or branch keys, although it is specified in
     terms of control_interval_id and slot index, a standard element_id.)

          im_general_insert first tries to do a simple insertion, then it does
     a rotate left, then a rotate right, and finally it does a split.  The
     split may recursively invoke im_general_insert on the parent of the nodes
     which result from the split.  The rotations, right and left, also use
     im_general_insert to place a new value of the parent key into the parent
     node.
*/

/* HISTORY:
Written by Lindsey Spratt, 04/01/82.
Modified:
07/22/82 by Lindsey Spratt:  Changed to use im_rotate_insert instead of
	  im_rotate_previous_insert and im_rotate_next_insert.
11/02/82 by Lindsey Spratt:  Changed to use the index_opening_info structure.
	  Changed to use new calling sequences for im_split,
	  im_rotate_insert.  Removed the cursor_ptr and the index_header_ptr
	  from the calling sequence of this module,  adding the
	  index_opening_info_ptr.
10/28/84 by Lindsey L. Spratt:  Removed spurious reference to the
            dm_im_opening_info include file.  Changed to use ERROR_RETURN.
            Changed to use ACTION_CANT_RESTART instead of "s" in calls to
            sub_err-.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */
im_general_insert:
   proc (p_index_opening_info_ptr, p_leaf_ci_header_ptr, p_insert_new_key, p_key_string, p_key_id_string, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_leaf_ci_header_ptr   ptr;
      dcl	    p_insert_new_key       bit (1) aligned;
      dcl	    p_key_string	       bit (*);
      dcl	    p_key_id_string	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    local_header_buffer    bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)) aligned;

      dcl	    new_previous_ci	       fixed bin (24) unsigned unaligned;

      dcl	    additional_storage_required
			       fixed bin (35);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("im_general_insert") char (32) varying internal static options (constant);
      dcl	    (
	    ROTATE_PREVIOUS	       init ("1"b),
	    ROTATE_NEXT	       init ("0"b),
	    REPLACE_PARENT_KEY     init ("0"b),
	    INSERT_PARENT_KEY      init ("1"b)
	    )		       bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

      dcl	    im_simple_insert       entry (ptr, ptr, bit (1) aligned, bit (*), bit (36) aligned, fixed bin (35),
			       fixed bin (35));
      dcl	    im_rotate_insert       entry (ptr, ptr, bit (1) aligned, bit (1) aligned, bit (1) aligned, bit (*),
			       bit (36) aligned, fixed bin (35), fixed bin (35));

      dcl	    im_split	       entry (ptr, ptr, fixed bin (24) unsigned unaligned, ptr,
			       fixed bin (24) unsigned unaligned, fixed bin (35));

/* External */

      dcl	    dm_error_$long_element fixed bin (35) ext;
      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;

/* END OF DECLARATIONS */


      call im_simple_insert (p_index_opening_info_ptr, p_leaf_ci_header_ptr, p_insert_new_key, p_key_string,
	 p_key_id_string, additional_storage_required, p_code);
      if p_code ^= 0
      then if p_code ^= dm_error_$long_element
	 then call ERROR_RETURN (p_code);
	 else if additional_storage_required <= 0
	 then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		 "^/Attempt to insert a key failed because of insufficient space, according to
the im_simple_insert module, but the addition storage required, as specified by
this module, is ^d.", additional_storage_required);
	 else
SIMPLE_INSERT_INSUFFICIENT_SPACE:
	    do;
	       call im_rotate_insert (p_index_opening_info_ptr, p_leaf_ci_header_ptr, ROTATE_PREVIOUS, p_insert_new_key,
		  REPLACE_PARENT_KEY, p_key_string, p_key_id_string, additional_storage_required, p_code);
	       if p_code ^= 0
	       then if p_code ^= dm_error_$long_element
		  then call ERROR_RETURN (p_code);
		  else if additional_storage_required <= 0
		  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
			  "^/Attempt to insert a key (after rotating keys from the target node into the
left-sibling) failed because of insufficient space, according to
the im_rotate_insert module, but the additional storage required, as specified 
by this module, is ^d.", additional_storage_required);
		  else
ROTATE_LEFT_INSUFFICIENT_SPACE:
		     do;
		        call im_rotate_insert (p_index_opening_info_ptr, p_leaf_ci_header_ptr, ROTATE_NEXT,
			   p_insert_new_key, REPLACE_PARENT_KEY, p_key_string, p_key_id_string,
			   additional_storage_required, p_code);

		        if p_code ^= 0
		        then if p_code ^= dm_error_$long_element
			   then call ERROR_RETURN (p_code);
			   else if additional_storage_required <= 0
			   then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
				   "^/Attempt to insert a key (after rotating keys from the target node into the
right-sibling) failed because of insufficient space, according to
the im_rotate_insert module, but the additional storage required, as specified  
by this module, is ^d.", additional_storage_required);
			   else
ROTATE_RIGHT_INSUFFICIENT_SPACE:
			      do;
			         call im_split (p_index_opening_info_ptr, p_leaf_ci_header_ptr,
				    addr (p_key_id_string) -> element_id.control_interval_id,
				    addr (local_header_buffer), new_previous_ci, p_code);
			         if p_code ^= 0
			         then call ERROR_RETURN (p_code);
			         call im_rotate_insert (p_index_opening_info_ptr, p_leaf_ci_header_ptr,
				    ROTATE_PREVIOUS, p_insert_new_key, INSERT_PARENT_KEY, p_key_string,
				    p_key_id_string, additional_storage_required, p_code);
			         if p_code ^= 0
			         then call ERROR_RETURN (p_code);

			      end ROTATE_RIGHT_INSUFFICIENT_SPACE;
		     end ROTATE_LEFT_INSUFFICIENT_SPACE;
	    end SIMPLE_INSERT_INSUFFICIENT_SPACE;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
%include dm_im_ci_header;
%page;
%include sub_err_flags;
%page;
%include dm_element_id;
   end im_general_insert;




		    im_general_search.pl1           04/02/87  1313.1r w 04/02/87  1300.0      291888



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

/* DESCRIPTION:

          This subroutine searches an index and returns all of the keys (as
     typed_vectors in a typed_vector_array) which satisfy the specification
     provided by the caller.

*/

/* HISTORY:

Written by Lindsey Spratt, 06/16/82.
Modified:
07/13/82 by Lindsey Spratt:  Added support of ranges.
08/06/82 by Lindsey Spratt:  Renamed from im_get_key to im_general_search.
	  The get_key operation is now supported by the "get" entry.  Added
	  support for deleting keys, via the "delete" entry.
08/09/82 by Matthew Pierret:  Removed offset and length arguments from calls to
            collection_manager_$get_element which requested the entire element,
            and changed calls to get portions of an element into
            collection_manager_$get_element_portion.
08/17/82 by Matthew Pierret:  Changed calls to im_build_sequential_spec to
            calls to data_mgmt_util_$build_sequential_spec.
08/19/82 by Matthew Pierret:  Changed field_ids argument to data_mgmt_util_
            $cv_table_to_typed_array to be null, meaning convert all fields.
            Removed begin block and code which built field_ids array.
08/19/82 by Lindsey Spratt:  Changed to take p_id_list_ptr in the "get"
	  calling sequence.  Changed to pass this on the cv_table_to_array
	  and im_process_keys$get.
08/24/82 by Lindsey Spratt:  Changed the calling sequence of
	  im_process_keys$(delete get) to pass the subset_specification_ptr.
08/26/82 by Lindsey Spratt:  Added the "position" entry.  Added the "delete"
	  switch, which, with the "get" switch, allows the common code to
	  determine whether a get, delete, or position operation is being
	  done.  Added capability to do "relative" searching.
10/07/82 by Lindsey Spratt:  Changed to use the new search_specification
	  (version 2).  Added the "count" entry.
10/14/82 by Matthew Pierret:  Added number_of_slots argument to
            dmu_$cv_table_to_typed_array.
10/21/82 by Lindsey Spratt:  Added code for the numeric_specification.
	  Changed to use version 3 of the specification structures.
10/26/82 by Lindsey Spratt:  Fixed to catch "no_key" situations.  If the low
	  and high id_strings in an interval_bead are both "0"b, then there
	  is no key which satisfies that interval.
10/27/82 by Lindsey Spratt:  Fixed to set the first (or last) key ids to just
	  outside the index when doing an absolute numeric search.  This
	  causes an abs pos of 1 to get the first key, for instance.
10/28/82 by Lindsey Spratt:  Changed to use the opening_info, and to keep
	  track of the various key counts.
11/09/82 by Lindsey Spratt:  Added the interval_list_ptr to the calling
	  sequence for the get entry.  This is to support the
	  relation_manager_ in satisfying search_specifications which
	  specify more than the fields in the index.  The interval_list
	  identifies what intervals of the returned typed_vectors were
	  selected to satisfy which and_groups of the supplied
	  search_specification.

	  Changed to remove index_header_ptr from im_process_keys entry
	  points.  Also, changed to use dm_key_count_array include file.
11/23/82 by Lindsey Spratt:  Fixed to set the p_interval_list_ptr before
	  returning.
12/06/82 by Lindsey Spratt:  Fixed to handle the  0 and_groups in a
	  search_specification case, and the null specification case.
12/08/82 by Lindsey Spratt:  Fixed to return dm_error_$key_not_found if the
	  index_header.root_id is 0.
12/09/82 by Lindsey Spratt:  Changed to use the
	  im_update_opening_info$key_count_array entry instead of the
	  (non-existent) key_counts entry.
12/17/82 by Lindsey Spratt:  Fixed get_ci_header to work for branch and leaf
	  headers.
01/20/83 by Matthew Pierret: Changed to use p_typed_vector_array_ptr with
            every reference to typed_vector_array so that one needn't worry
            about failing to set it before returning.
            Changed to finish and return when get_keys returns a non-zero
            p_code.
02/28/83 by Lindsey Spratt:  Changed to use version 3 index_cursor.  Also
	  fixed to call im_validate_cursor when doing a relative position,
	  which will "automatically" re-position a cursor when the key the
	  cursor identifies has moved.
	       Changed to make the finish procedure convert
	  dm_error_$key_not_found to 0 when returning a count.
03/07/83 by Lindsey Spratt:  Fixed relative "find_key_id" to be sensitive to
	  the case where index_cursor.flags.is_at_end_of_index is true and
	  (separately) the case where index_cursor.flags.current_key_exists
	  is false.
03/16/83 by Matthew Pierret: Fixed to check interval_specification_ptr for
            "null-ness" after returning from im_build_interval_spec. 
            Changed $get to always return a non-null interval_list_ptr.
            Changed all subroutine names to be upper-case. Changed
            "do;call FINISH;return;end;" cliche to "call ERROR_RETURN;"
03/23/83 by Lindsey Spratt:  Changed to use version 2 of field_table.
05/23/83 by Matthew Pierret: Changed to use version 4 of specification_head.
            Split dm_specification.incl.pl1 into dm_specification_head,
            dm_specification and dm_range_types.incl.pl1.
            Changed to free key_count_array and interval_list in the
            finish subroutine.
            Changed to detect the situation where the caller has supplied
            an absolute numeric specification and a position_number of 0 -
            this combination is not meaningful. Changed FIND_KEY_ID to set
            p_element_id_string to index_cursor.key_id for relative numeric
            specifications, instead of moving it up or back one slot as it
            does for search specifications.
01/20/84 by Matthew Pierret:  Changed to initialize
            interval_list.and_group_id_list_ptr to null.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.  Changed
            references to data_mgmt_util_ to data_format_util_.  Removed
            declarations un-used error codes.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get,
            cm_$get_element_portion to cm_$get_portion.
10/28/84 by Lindsey L. Spratt:  Changed ERROR_RETURN to take a code arg.
            Changed internal procs to call ERROR_RETURN, and to not have code
            args.  Changed to use version 2 index_opening_info, version 2
            interval_list, version 2 interval_specification, version 4
            index_header.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */
im_general_search$get:
   proc (p_specification_ptr, p_id_list_ptr, p_work_area_ptr, p_index_cursor_ptr, p_typed_vector_array_ptr,
        p_interval_list_ptr, p_code);


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

      dcl	    p_specification_ptr    ptr;
      dcl	    p_id_list_ptr	       ptr parameter;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_index_cursor_ptr     ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_interval_list_ptr    ptr parameter;
      dcl	    p_number_of_keys_deleted
			       fixed bin (35);
      dcl	    p_key_count	       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    work_area_ptr	       ptr init (null);
      dcl	    (get, delete, count, position, is_relative_specification, is_search_specification)
			       bit (1) aligned init ("0"b);
      dcl	    number_of_keys_accepted
			       fixed bin (35) init (0);
      dcl	    number_of_structural_fields
			       fixed bin init (0);
      dcl	    (high_element_id_string, low_element_id_string)
			       bit (36) init ("0"b) aligned;
      dcl	    (new_buffer_was_allocated, no_match)
			       bit (1) aligned init ("0"b);
      dcl	    interval_idx	       fixed bin (17);


/* Based */

      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (addr, length, max, null)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    DEFAULT_AND_GROUP_ID_LIST_PTR
			       ptr init (null) internal static options (constant);
      dcl	    (
	    DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS
			       init (0),
	    DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID
			       init (0)
	    )		       fixed bin (17) internal static options (constant);

      dcl	    BEGINNING_OF_ELEMENT   init (1) fixed bin (35) internal static options (constant);

      dcl	    HEADER_COLLECTION_ID   init ("000000000001"b3) bit (36) aligned internal static options (constant);

      dcl	    myname	       init ("im_general_search") char (17) internal static options (constant);

      dcl	    (
	    FIRST_KEY	       init ("0"b),
	    LAST_KEY	       init ("1"b)
	    )		       bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    im_get_opening_info    entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    im_update_opening_info$key_count_array
			       entry (ptr, ptr, fixed bin (35));

      dcl	    im_build_interval_spec entry (ptr, ptr, ptr, fixed bin (35));

      dcl	    im_structural_search   entry (ptr, ptr, bit (1) aligned, ptr, bit (1) aligned, fixed bin (35));
      dcl	    im_validate_cursor     entry (ptr, ptr, fixed bin (35));

      dcl	    im_process_keys$get    entry (ptr, ptr, ptr, ptr, ptr, ptr, fixed bin, fixed bin, bit (36) aligned,
			       bit (36) aligned, ptr, fixed bin (35));
      dcl	    im_process_keys$delete entry (ptr, ptr, ptr, ptr, ptr, fixed bin, fixed bin, bit (36) aligned,
			       bit (36) aligned, ptr, fixed bin (35), fixed bin (35));
      dcl	    im_process_keys$position
			       entry (ptr, ptr, ptr, ptr, ptr, fixed bin, fixed bin, bit (36) aligned,
			       bit (36) aligned, fixed bin (35), fixed bin (35));
      dcl	    im_process_keys$count  entry (ptr, ptr, ptr, ptr, ptr, fixed bin, fixed bin, bit (36) aligned,
			       bit (36) aligned, fixed bin (35), fixed bin (35));

      dcl	    data_format_util_$cv_table_to_typed_array
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, fixed bin (35));
      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    (
	    dm_error_$key_not_found,
	    dm_error_$bad_first_key_idx,
	    dm_error_$programming_error,
	    dm_error_$bad_last_key_idx,
	    dm_error_$bad_specification_type,
	    dm_error_$invalid_cursor_position,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

/*
get:
   entry (p_specification_ptr, p_id_list_ptr, p_work_area_ptr, p_index_cursor_ptr, p_typed_vector_array_ptr,
      p_interval_list_ptr, p_code);
*/
      work_area_ptr = p_work_area_ptr;
      get = "1"b;
      goto JOIN;

position:
   entry (p_specification_ptr, p_work_area_ptr, p_index_cursor_ptr, p_code);
      work_area_ptr = p_work_area_ptr;
      position = "1"b;
      goto JOIN;

delete:
   entry (p_specification_ptr, p_work_area_ptr, p_index_cursor_ptr, p_number_of_keys_deleted, p_code);
      work_area_ptr = p_work_area_ptr;
      p_number_of_keys_deleted = 0;
      delete = "1"b;
      goto JOIN;

count:
   entry (p_specification_ptr, p_index_cursor_ptr, p_key_count, p_code);
      work_area_ptr = get_dm_free_area_ ();
      p_key_count = 0;
      count = "1"b;

JOIN:
      numeric_specification_ptr, search_specification_ptr, specification_head_ptr, interval_list_ptr,
	 key_count_array_ptr = null;
      p_code = 0;
      index_cursor_ptr = p_index_cursor_ptr;

      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      specification_head_ptr = p_specification_ptr;
      if specification_head_ptr ^= null
      then
         do;
	  call CHECK_VERSION ((specification_head.version), (SPECIFICATION_VERSION_4), "specification");

	  if specification_head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE
	  then
	     do;
	        search_specification_ptr = specification_head_ptr;
	        is_relative_specification = "1"b;
	        is_search_specification = "1"b;
	     end;
	  else if specification_head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE
	  then
	     do;
	        search_specification_ptr = specification_head_ptr;
	        is_relative_specification = "0"b;
	        is_search_specification = "1"b;
	     end;
	  else if specification_head.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE
	  then
	     do;
	        numeric_specification_ptr = specification_head_ptr;
	        is_relative_specification = "1"b;
	        is_search_specification = "0"b;
	     end;
	  else if specification_head.type = ABSOLUTE_NUMERIC_SPECIFICATION_TYPE
	  then
	     do;
	        numeric_specification_ptr = specification_head_ptr;
	        if numeric_specification.position_number = 0
	        then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		        "^/The given position_number, ^d, is not supported by the given specification^/type, type ^d - absolute numeric.",
		        numeric_specification.position_number, ABSOLUTE_NUMERIC_SPECIFICATION_TYPE);
	        is_relative_specification = "0"b;
	        is_search_specification = "0"b;
	     end;
	  else call sub_err_ (dm_error_$bad_specification_type, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The  specification structure does not have a recognizable type.
The recognizable types are: ^d, ^d, ^d or ^d. Received a type ^d structure.", ABSOLUTE_SEARCH_SPECIFICATION_TYPE,
		  RELATIVE_SEARCH_SPECIFICATION_TYPE, ABSOLUTE_NUMERIC_SPECIFICATION_TYPE,
		  RELATIVE_NUMERIC_SPECIFICATION_TYPE, search_specification.head.type);
         end;

      on cleanup call FINISH;

      call im_get_opening_info (index_cursor.file_opening_id, index_cursor.collection_id, index_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      call CHECK_VERSION_CHAR (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      index_header_ptr = index_opening_info.index_header_ptr;
      call CHECK_VERSION_CHAR (index_header.version, INDEX_HEADER_VERSION_4, "index_header");

      if index_header.root_id = 0			/* There are no keys. */
      then call ERROR_RETURN (dm_error_$key_not_found);

      field_table_ptr = index_opening_info.field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      if is_search_specification
      then
         do;

	  call im_build_interval_spec (work_area_ptr, search_specification_ptr, interval_specification_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  if interval_specification_ptr ^= null
	  then
	     do;
	        call CHECK_VERSION_CHAR (interval_specification.version, INTERVAL_SPECIFICATION_VERSION_2,
		   "interval_specification");

	        if search_specification.number_of_and_groups <= 0
	        then call FIND_KEY_ID (FIRST_KEY,
		        interval_specification.first_interval_bead_ptr -> interval_bead.low.id_string);
	     end;
         end;


      if interval_specification_ptr ^= null
      then if search_specification.number_of_and_groups > 0
	 then
	    do;


	       call im_structural_search (index_opening_info_ptr, index_cursor_ptr, is_relative_specification,
		  interval_specification_ptr, no_match, p_code);
	       if p_code ^= 0
	       then call ERROR_RETURN (p_code);

	       if no_match
	       then call ERROR_RETURN (dm_error_$key_not_found);

	       if get
	       then
		do;
		   intl_number_of_intervals = interval_specification.number_of_intervals;
		   alloc interval_list in (work_area);
		   interval_list.version = INTERVAL_LIST_VERSION_2;
		   interval_list.and_group_id_list_ptr = null;
		end;
	    end;

      if get
      then
         do;

	  call data_format_util_$cv_table_to_typed_array (field_table_ptr, p_id_list_ptr, work_area_ptr, 0,
	       p_typed_vector_array_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);
         end;

      if delete
      then
         do;
	  call CHECK_VERSION_CHAR (index_opening_info.key_count_array_ptr -> key_count_array.version,
	       KEY_COUNT_ARRAY_VERSION_2, "key_count_array");
	  kca_number_of_counts = index_opening_info.key_count_array_ptr -> key_count_array.number_of_counts;

	  alloc key_count_array in (work_area);

	  key_count_array = index_opening_info.key_count_array_ptr -> key_count_array;
         end;

      if interval_specification_ptr = null
      then
PROCESS_ALL_KEYS:
         do;
	  if ^is_search_specification & numeric_specification_ptr ^= null
	  then
	     do;
	        if numeric_specification.position_number >= 0
	        then
		 do;
		    call FIND_KEY_ID (FIRST_KEY, low_element_id_string);
		    high_element_id_string = "0"b;
		 end;
	        else
		 do;
		    low_element_id_string = "0"b;
		    call FIND_KEY_ID (LAST_KEY, high_element_id_string);
		 end;
	     end;
	  else
	     do;
	        high_element_id_string = "0"b;
	        call FIND_KEY_ID (FIRST_KEY, low_element_id_string);
	     end;

	  if get
	  then call im_process_keys$get (index_cursor_ptr, work_area_ptr, field_table_ptr, p_id_list_ptr,
		  p_specification_ptr, DEFAULT_AND_GROUP_ID_LIST_PTR, DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
		  DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID, low_element_id_string, high_element_id_string,
		  p_typed_vector_array_ptr, p_code);
	  else if delete
	  then call im_process_keys$delete (index_cursor_ptr, work_area_ptr, field_table_ptr, p_specification_ptr,
		  DEFAULT_AND_GROUP_ID_LIST_PTR, DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
		  DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID, low_element_id_string, high_element_id_string,
		  key_count_array_ptr, number_of_keys_accepted, p_code);
	  else if position
	  then call im_process_keys$position (index_cursor_ptr, work_area_ptr, field_table_ptr, p_specification_ptr,
		  DEFAULT_AND_GROUP_ID_LIST_PTR, DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
		  DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID, low_element_id_string, high_element_id_string,
		  number_of_keys_accepted, p_code);
	  else call im_process_keys$count (index_cursor_ptr, work_area_ptr, field_table_ptr, p_specification_ptr,
		  DEFAULT_AND_GROUP_ID_LIST_PTR, DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
		  DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID, low_element_id_string, high_element_id_string,
		  number_of_keys_accepted, p_code);

	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  if get
	  then
	     do;
	        intl_number_of_intervals = 1;
	        alloc interval_list in (work_area);
	        interval_list.version = INTERVAL_LIST_VERSION_2;
	        interval_list.interval (1).low_vector_idx = 1;
	        interval_list.interval (1).high_vector_idx =
		   p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors;
	        interval_list.interval (1).and_group_id_list_ptr = null;
	     end;

         end PROCESS_ALL_KEYS;
      else if search_specification.range.type = HIGH_RANGE_TYPE
      then
         do;
	  interval_bead_ptr = interval_specification.last_interval_bead_ptr;
	  if interval_bead.high.id_string = "0"b & USES_GREATER_OPERATOR (interval_bead.low.operator_code)
	       & interval_bead.low.id_string ^= "0"b
	  then call FIND_KEY_ID (LAST_KEY, interval_bead.high.id_string);

	  interval_bead_ptr = interval_specification.first_interval_bead_ptr;
	  do interval_idx = interval_specification.number_of_intervals to 1 by -1
	       while (search_specification.range.size > number_of_keys_accepted);
	     call GET_KEYS;

	     interval_bead_ptr = interval_bead.next;
	  end;
         end;
      else if search_specification.range.type = LOW_RANGE_TYPE
      then
         do;
	  interval_bead_ptr = interval_specification.first_interval_bead_ptr;
	  if interval_bead.low.id_string = "0"b
	  then call FIND_KEY_ID (FIRST_KEY, interval_bead.low.id_string);

	  interval_bead_ptr = interval_specification.first_interval_bead_ptr;
	  do interval_idx = 1 to interval_specification.number_of_intervals
	       while ((search_specification.range.size > number_of_keys_accepted & (get | delete | count))
	       | (position & number_of_keys_accepted = 0));
	     call GET_KEYS;

	     interval_bead_ptr = interval_bead.next;
	  end;
         end;
      else
         do;
	  interval_bead_ptr = interval_specification.first_interval_bead_ptr;
FORWARD_INTERVAL_LOOP:
	  do interval_idx = 1 to interval_specification.number_of_intervals
	       while (get | delete | (position & number_of_keys_accepted = 0) | count);
	     call GET_KEYS;

	     interval_bead_ptr = interval_bead.next;
	  end FORWARD_INTERVAL_LOOP;
         end;
      if get
      then p_interval_list_ptr = interval_list_ptr;
      else if delete
      then
         do;
	  call im_update_opening_info$key_count_array (index_opening_info_ptr, key_count_array_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  p_number_of_keys_deleted = number_of_keys_accepted;
         end;
      else if count
      then p_key_count = number_of_keys_accepted;

      call FINISH;

MAIN_RETURN:
      return;
%page;
FINISH:
   proc;
      dcl	    next_ptr	       ptr;

      if count & p_code = dm_error_$key_not_found
      then p_code = 0;

      if interval_specification_ptr ^= null
      then
         do;
	  interval_bead_ptr = interval_specification.first_interval_bead_ptr;
	  do while (interval_bead_ptr ^= null);
	     next_ptr = interval_bead.next;
	     if interval_bead.simple_typed_vector_ptr ^= null
	     then free interval_bead.simple_typed_vector_ptr -> simple_typed_vector in (work_area);
	     if interval_bead.id_list_ptr ^= null
	     then free interval_bead.id_list_ptr -> id_list in (work_area);
	     free interval_bead in (work_area);
	     interval_bead_ptr = next_ptr;
	  end;
	  free interval_specification in (work_area);
         end;

      if interval_list_ptr ^= null
      then if p_interval_list_ptr ^= interval_list_ptr
	 then free interval_list in (work_area);

      if key_count_array_ptr ^= null
      then free key_count_array in (work_area);

   end FINISH;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;

      p_code = er_p_code;				/* p_code must be set before calling FINISH. */
      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_expected_version, p_received_version, p_structure_name);

      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
GET_CI_HEADER:
   proc (gch_p_control_interval_id, gch_p_ci_header_ptr);
      dcl	    gch_p_control_interval_id
			       fixed bin (24) unsigned;
      dcl	    gch_p_ci_header_ptr    ptr;

      dcl	    gch_code	       fixed bin (35);
      dcl	    1 gch_element_id       aligned like element_id;


      gch_element_id.control_interval_id = gch_p_control_interval_id;
      gch_element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
      gch_code = 0;

      call collection_manager_$get (index_cursor.file_opening_id, index_cursor.collection_id, unspec (gch_element_id), 0,
	 gch_p_ci_header_ptr, max (BRANCH_CI_HEADER_LENGTH_IN_BITS, LEAF_CI_HEADER_LENGTH_IN_BITS), null, "0"b,
	 gch_p_ci_header_ptr, (0), gch_code);
      if gch_code ^= 0
      then call ERROR_RETURN (gch_code);

      if gch_p_ci_header_ptr -> common_ci_header.key_range.first < 0
      then call ERROR_RETURN (dm_error_$bad_first_key_idx);
      else if gch_p_ci_header_ptr -> common_ci_header.key_range.last
	 < gch_p_ci_header_ptr -> common_ci_header.key_range.first
      then call ERROR_RETURN (dm_error_$bad_last_key_idx);
      return;
   end GET_CI_HEADER;
%page;
FIND_KEY_ID:
   proc (fki_p_find_last_key, fki_p_element_id_string);
      dcl	    fki_p_find_last_key    bit (1) aligned;
      dcl	    fki_p_element_id_string
			       bit (*) aligned;

      dcl	    fki_branch_key_head_buffer
			       bit (BRANCH_KEY_HEADER_LENGTH_IN_BITS) aligned;
      dcl	    fki_code	       fixed bin (35);
      dcl	    1 fki_element_id       aligned like element_id;
      dcl	    fki_element_id_string  based (addr (fki_element_id)) bit (36) aligned;
      dcl	    fki_local_header_buffer
			       bit (max (BRANCH_CI_HEADER_LENGTH_IN_BITS, LEAF_CI_HEADER_LENGTH_IN_BITS)) aligned;

      fki_code = 0;
      branch_ci_header_ptr, common_ci_header_ptr, leaf_ci_header_ptr = addr (fki_local_header_buffer);
      if is_relative_specification & ((^fki_p_find_last_key & is_search_specification) | ^is_search_specification)
      then
GET_CURSOR_POSITION:
         do;
	  if ^index_cursor.flags.is_valid
	  then call ERROR_RETURN (dm_error_$invalid_cursor_position);
	  else
	     do;
	        call im_validate_cursor (index_opening_info_ptr, index_cursor_ptr, fki_code);
	        if fki_code ^= 0
	        then call ERROR_RETURN (fki_code);
	     end;
	  fki_element_id_string = index_cursor.key_id_string;
	  call GET_CI_HEADER ((fki_element_id.control_interval_id), common_ci_header_ptr);

	  if index_cursor.flags.is_at_end_of_index
	  then call ERROR_RETURN (dm_error_$key_not_found);
	  else if index_cursor.flags.current_key_exists
	  then if ^is_search_specification
	       then fki_element_id_string = index_cursor.key_id_string;
	       else
POSITION_TO_SLOT_AFTER_CURRENT:
		do;
		   if fki_element_id.index + 1 > common_ci_header.key_range.last
		   then
GOTO_NEXT_CONTROL_INTERVAL:
		      do;
		         fki_element_id.control_interval_id = common_ci_header.next_id;
		         if fki_element_id.control_interval_id = 0
						/* There is no next control interval. */
		         then call ERROR_RETURN (dm_error_$key_not_found);
		         call GET_CI_HEADER ((fki_element_id.control_interval_id), common_ci_header_ptr);
		         fki_element_id.index = common_ci_header.key_range.first;
		      end GOTO_NEXT_CONTROL_INTERVAL;
		   else fki_element_id.index = fki_element_id.index + 1;
		end POSITION_TO_SLOT_AFTER_CURRENT;
	  fki_p_element_id_string = fki_element_id_string;
	  return;
         end GET_CURSOR_POSITION;
      fki_element_id.control_interval_id = index_header.root_id;
      call GET_CI_HEADER ((fki_element_id.control_interval_id), common_ci_header_ptr);

      bk_string_length = 0;
      do while (^common_ci_header.is_leaf);

         if fki_p_find_last_key
         then
	  do;
	     fki_element_id.index = branch_ci_header.common.key_range.last;
	     call collection_manager_$get_portion (index_cursor.file_opening_id, index_cursor.collection_id,
		fki_element_id_string, 0, addr (fki_branch_key_head_buffer), length (fki_branch_key_head_buffer),
		null, 1, length (fki_branch_key_head_buffer), "0"b, branch_key_ptr, 0, fki_code);
	     if fki_code ^= 0
	     then call ERROR_RETURN (fki_code);

	     fki_element_id.control_interval_id = branch_key.branch_id;
	  end;
         else fki_element_id.control_interval_id = branch_ci_header.low_branch_id;
         call GET_CI_HEADER ((fki_element_id.control_interval_id), common_ci_header_ptr);
      end;

      if is_search_specification | is_relative_specification
      then if fki_p_find_last_key
	 then fki_element_id.index = leaf_ci_header.common.key_range.last;
	 else fki_element_id.index = leaf_ci_header.common.key_range.first;
      else if fki_p_find_last_key
      then fki_element_id.index = leaf_ci_header.common.key_range.last + 1;
      else fki_element_id.index = leaf_ci_header.common.key_range.first - 1;

      fki_p_element_id_string = fki_element_id_string;
      return;
%include dm_im_key;
   end FIND_KEY_ID;
%page;
GET_KEYS:
   proc;
      dcl	    gk_code	       fixed bin (35);
      dcl	    partial_structural_field_id
			       fixed bin;
      if interval_bead.low.id_string = "0"b & interval_bead.high.id_string = "0"b
      then return;
      simple_typed_vector_ptr = interval_bead.simple_typed_vector_ptr;
      if simple_typed_vector_ptr = null
      then partial_structural_field_id = DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID;
      else if interval_bead.number_of_fully_structural_fields = simple_typed_vector.number_of_dimensions
      then partial_structural_field_id = DEFAULT_PARTIAL_STRUCTURAL_FIELD_ID;
      else partial_structural_field_id = simple_typed_vector.number_of_dimensions;
      if interval_bead.low.id_string = "0"b & is_relative_specification
      then call FIND_KEY_ID (FIRST_KEY, interval_bead.low.id_string);

      if get
      then call im_process_keys$get (index_cursor_ptr, work_area_ptr, field_table_ptr, p_id_list_ptr,
	      search_specification_ptr, interval_bead.id_list_ptr, (interval_bead.number_of_fully_structural_fields),
	      partial_structural_field_id, interval_bead.low.id_string, interval_bead.high.id_string,
	      p_typed_vector_array_ptr, gk_code);
      else if delete
      then call im_process_keys$delete (index_cursor_ptr, work_area_ptr, field_table_ptr, search_specification_ptr,
	      interval_bead.id_list_ptr, (interval_bead.number_of_fully_structural_fields), partial_structural_field_id,
	      interval_bead.low.id_string, interval_bead.high.id_string, key_count_array_ptr, number_of_keys_accepted,
	      gk_code);
      else if position
      then call im_process_keys$position (index_cursor_ptr, work_area_ptr, field_table_ptr, search_specification_ptr,
	      interval_bead.id_list_ptr, (interval_bead.number_of_fully_structural_fields), partial_structural_field_id,
	      interval_bead.low.id_string, interval_bead.high.id_string, number_of_keys_accepted, gk_code);
      else call im_process_keys$count (index_cursor_ptr, work_area_ptr, field_table_ptr, search_specification_ptr,
	      interval_bead.id_list_ptr, (interval_bead.number_of_fully_structural_fields), partial_structural_field_id,
	      interval_bead.low.id_string, interval_bead.high.id_string, number_of_keys_accepted, gk_code);

      if gk_code ^= 0
      then call ERROR_RETURN (gk_code);

      if get
      then
         do;
	  if number_of_keys_accepted < p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors
	       & interval_list_ptr ^= null
	  then
	     do;
	        interval_list.interval (interval_idx).low_vector_idx = number_of_keys_accepted + 1;
	        interval_list.interval (interval_idx).high_vector_idx =
		   p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors;
	        interval_list.interval (interval_idx).and_group_id_list_ptr = interval_bead.id_list_ptr;
	        interval_bead.id_list_ptr = null;
	     end;

	  number_of_keys_accepted = p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors;
         end;
   end GET_KEYS;
%page;
%include vu_typed_vector;
%page;
%include dm_im_header;
%page;
%include dm_im_ci_header;
%page;
%include dm_im_cursor;
%page;
%include dm_element_id;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include dm_operator_constants;
%page;
%include dm_range_constants;
%page;
%include dm_field_table;
%page;
%include vu_typed_vector_array;
%page;
%include dm_interval_spec;
%page;
%include dm_im_opening_info;
%page;
%include dm_id_list;
%page;
%include dm_interval_list;
%page;
%include dm_key_count_array;
%page;
%include sub_err_flags;
   end im_general_search$get;




		    im_get_key_count_array.pl1      04/02/87  1313.1r w 04/02/87  1304.9       40212



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

/* DESCRIPTION:
         This  subroutine  returns  the  key_count_array  for  a  given index
     collection.
*/

/* HISTORY:
Written by Lindsey L. Spratt, 12/06/82.
Modified:
02/28/83 by Lindsey Spratt:  Changed to use version 3 of the index_cursor.
03/23/83 by Lindsey Spratt:  Changed to use version 2 of the field_table.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.
10/28/84 by Lindsey L. Spratt:  Changed to use version 4 index_opening_info.
            Changed to use ERROR_RETURN; Changed to simply return
            index_opening_info.key_count_array_ptr.
01/10/85 by Lindsey L. Spratt:  Removed some unreferenced include files.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
*/

/* format: style2,ind3 */

im_get_key_count_array:
   proc (p_index_cursor_ptr, p_work_area_ptr, p_key_count_array_ptr, p_code);

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

      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_key_count_array_ptr  ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    work_area_ptr	       ptr init (null);

/* Based */

      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (addr, null)	       builtin;

/* Constant */

      dcl	    myname	       init ("im_get_key_count_array") char (32) varying internal static options (constant);

/* Entry */

      dcl	    im_get_opening_info    entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      index_cursor_ptr = p_index_cursor_ptr;
      work_area_ptr = p_work_area_ptr;
      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      call im_get_opening_info (index_cursor.file_opening_id, index_cursor.collection_id, index_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      call CHECK_VERSION_CHAR (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      call CHECK_VERSION_CHAR (index_opening_info.key_count_array_ptr -> key_count_array.version,
	 KEY_COUNT_ARRAY_VERSION_2, "key_count_array");

      kca_number_of_counts = index_opening_info.key_count_array_ptr -> key_count_array.number_of_counts;

      alloc key_count_array in (work_area);
      key_count_array = index_opening_info.key_count_array_ptr -> key_count_array;

      p_key_count_array_ptr = key_count_array_ptr;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
%include sub_err_flags;
%page;
%include dm_key_count_array;
%page;
%include dm_im_opening_info;
%page;
%include dm_im_cursor;
   end im_get_key_count_array;




		    im_get_opening_info.pl1         04/02/87  1313.1r w 04/02/87  1304.9       94284



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

/* DESCRIPTION:

         This  subroutine returns a pointer to the im_opening_info structure,
     given a file  opening_id  and  a  collection  id.    If  no  opening_info
     structure  has been creted for this collection in this process, then this
     module  will  create  it.    The   opening_info   is   managed   by   the
     opening_manager_.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 10/28/82.
Modified:
12/08/82 by Lindsey Spratt:  Fixed static_opening_table_ptr to be declared
	  with the internal static  attributes.  Changed to use
	  dm_data_$area_ptr to set the work_area_ptr.  Fixed to only
	  "put_opening" when there was no pre-existing allocation of the
	  index_opening_info structure.
12/10/82 by Lindsey Spratt:  Protect frees of old index_header and field_table
	  when the pointers are null.
03/21/83 by Lindsey Spratt:  Changed to not use dm_data_ $area_ptr or
	  $current_txn_id, but get_dm_free_area_ and
	  transaction_manager_$get_current_current_txn_id instead.
	  Also, made the work_area_ptr internal static.
03/23/83 by Lindsey Spratt:  Changed to use version 2 of the field_table.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.  Added
            ERROR_RETURN subroutine for returning with non-zero p_code.
            Changed to use local copies of the file_opening_id and the
            collection_id and the code.
06/07/84 by Matthew Pierret:  Re-named cm_get_element to cm_$get.
10/27/84 by Lindsey L. Spratt:  Changed to handl version 2 index_opening_info,
            and version 4 index_header.  Also handles version 3 index_headers.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3 and
	  changed to set index_opening_info.flags.key_count_postcommt_written
	  to zero for new transactons and rollbacks.  Removed index_header
	  version conversion code.
*/
%page;
/* format: style2,ind3 */

im_get_opening_info:
   proc (p_file_opening_id, p_collection_id, p_index_opening_info_ptr, p_code);


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

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    new_buffer_was_allocated
			       bit (1) aligned init ("0"b);
      dcl	    (collection_id, file_opening_id, current_txn_id)
			       bit (36) aligned;
      dcl	    current_rollback_count fixed bin;

/* Based */

      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (addr, bin, null, unspec)
			       builtin;

/* Constant */

      dcl	    myname	       init ("im_get_opening_info") char (32) varying internal static options (constant);

      dcl	    NUMBER_OF_BUCKETS      init (101) fixed bin (17) internal static options (constant);
      dcl	    HEADER_COLLECTION_ID   bit (36) aligned init ("000000000001"b3) internal static options (constant);
      dcl	    INDEX_HEADER_VERSION_3 init (3) fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    opening_manager_$init  entry (fixed bin, ptr, fixed bin (35));
      dcl	    opening_manager_$get_opening
			       entry (ptr, bit (*), ptr, fixed bin (35));
      dcl	    opening_manager_$put_opening
			       entry (ptr, bit (*), ptr, fixed bin (35));

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    transaction_manager_$get_current_ids
			       entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* Static */

      dcl	    static_opening_table_ptr
			       ptr init (null) static internal;
      dcl	    work_area_ptr	       ptr init (null) static internal;

/* END OF DECLARATIONS */

      p_code = 0;
      p_index_opening_info_ptr = null;
      file_opening_id = p_file_opening_id;
      collection_id = p_collection_id;
      index_header_ptr, field_table_ptr, index_opening_info_ptr = null;

      call transaction_manager_$get_current_ids (current_txn_id, (0), current_rollback_count, (0));

      code = 0;

      if static_opening_table_ptr = null
      then
         do;
	  call opening_manager_$init (NUMBER_OF_BUCKETS, static_opening_table_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;
      else
         do;
	  call opening_manager_$get_opening (static_opening_table_ptr, (file_opening_id || collection_id),
	       p_index_opening_info_ptr, code);
	  if code = 0
	  then if p_index_opening_info_ptr -> index_opening_info.current_txn_id = bin (current_txn_id, 35, 0)
		  & p_index_opening_info_ptr -> index_opening_info.current_rollback_count = current_rollback_count
	       then call RETURN ();			/* ** Got the opening info. ** */
	       else index_opening_info_ptr = p_index_opening_info_ptr;
         end;

      if work_area_ptr = null
      then work_area_ptr = get_dm_free_area_ ();

      if index_opening_info_ptr ^= null
      then
         do;
	  call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");
	  if index_opening_info.index_header_ptr ^= null
	  then
	     do;
	        call CHECK_VERSION (index_opening_info.index_header_ptr -> index_header.version, INDEX_HEADER_VERSION_4,
		   "index_header");
	        free index_opening_info.index_header_ptr -> index_header in (work_area);
	     end;
	  if index_opening_info.key_count_array_ptr ^= null
	  then
	     do;
	        call CHECK_VERSION (index_opening_info.key_count_array_ptr -> key_count_array.version,
		   KEY_COUNT_ARRAY_VERSION_2, "key_count_array");
	        free index_opening_info.key_count_array_ptr -> key_count_array in (work_area);
	     end;
	  if index_opening_info.field_table_ptr ^= null
	  then
	     do;
	        call CHECK_VERSION (index_opening_info.field_table_ptr -> field_table.version, FIELD_TABLE_VERSION_3,
		   "field_table");
	        free index_opening_info.field_table_ptr -> field_table in (work_area);
	     end;
	  if index_opening_info.key_count_increments_ptr ^= null
	  then call CHECK_VERSION (index_opening_info.key_count_increments_ptr -> key_count_array.version,
		  KEY_COUNT_ARRAY_VERSION_2, "key_count_increments_array");
						/* Note: Do not free the increment array */
         end;
      else
         do;
	  alloc index_opening_info in (work_area);
	  index_opening_info.version = INDEX_OPENING_INFO_VERSION_3;
	  index_opening_info.collection_id = collection_id;
	  index_opening_info.file_opening_id = file_opening_id;
	  index_opening_info.key_count_increments_ptr = null;
         end;

      call GET_INDEX_HEADER ();
      call collection_manager_$get (file_opening_id, HEADER_COLLECTION_ID, unspec (index_header.field_table_element_id),
	 0, null, (0), work_area_ptr, new_buffer_was_allocated, field_table_ptr, 0, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      index_opening_info.index_header_ptr = index_header_ptr;
      index_opening_info.field_table_ptr = field_table_ptr;
      index_opening_info.key_count_array_ptr = key_count_array_ptr;
      index_opening_info.flags.key_count_postcommit_written = "0"b;
      index_opening_info.current_txn_id = bin (current_txn_id, 35, 0);
      index_opening_info.current_rollback_count = current_rollback_count;

      if p_index_opening_info_ptr = null
      then
         do;
	  call opening_manager_$put_opening (static_opening_table_ptr, (file_opening_id || collection_id),
	       index_opening_info_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  p_index_opening_info_ptr = index_opening_info_ptr;
         end;

      call RETURN ();
MAIN_RETURN:
      return;
%page;
RETURN:
   proc ();
      p_code = 0;
      call FINISH ();
      goto MAIN_RETURN;
   end RETURN;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH;
      go to MAIN_RETURN;

   end ERROR_RETURN;



FINISH:
   proc;
      if (p_index_opening_info_ptr ^= index_opening_info_ptr | p_index_opening_info_ptr = null) & work_area_ptr ^= null
      then
         do;
	  if index_opening_info_ptr ^= null
	  then free index_opening_info in (work_area);
	  if index_header_ptr ^= null
	  then free index_header in (work_area);
	  if key_count_array_ptr ^= null
	  then free key_count_array in (work_area);
	  if field_table_ptr ^= null
	  then free field_table in (work_area);
         end;
   end FINISH;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
GET_INDEX_HEADER:
   proc ();
      dcl	    gih_code	       fixed bin (35);
      call collection_manager_$get_header (file_opening_id, collection_id, null, (0), work_area_ptr,
	 new_buffer_was_allocated, index_header_ptr, (0), code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call CHECK_VERSION (index_header.version, INDEX_HEADER_VERSION_4, "index_header");
      call collection_manager_$get (file_opening_id, HEADER_COLLECTION_ID,
	 unspec (index_header.key_count_array_element_id), 0, null, (0), work_area_ptr, new_buffer_was_allocated,
	 key_count_array_ptr, 0, gih_code);
      if gih_code ^= 0
      then call ERROR_RETURN (gih_code);
   end GET_INDEX_HEADER;
%page;
%include dm_im_opening_info;
%page;
%include dm_im_header;
%page;
%include dm_field_table;
%page;
%include dm_element_id;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include sub_err_flags;
%page;
%include dm_key_count_array;
   end im_get_opening_info;




		    im_init_branch_ci_header.pl1    01/04/85  0917.4re  01/03/85  1146.4       12249



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

/* DESCRIPTION:

     This program initializes the branch_ci_header structure.
*/

/* HISTORY:

Written by Lindsey Spratt, 01/01/82.
Modified:
11/08/84 by Lindsey L. Spratt:  Added the description and history sections.
            Fixed to initialize the flags.pad.
*/

/* format: style2,ind3 */
im_init_branch_ci_header:
   proc (p_branch_ci_header_ptr);

      dcl	    p_branch_ci_header_ptr ptr;

      branch_ci_header_ptr = p_branch_ci_header_ptr;

      branch_ci_header.common.is_leaf = "0"b;
      branch_ci_header.common.flags.pad = "0"b;
      branch_ci_header.common.key_range.first = 0;
      branch_ci_header.common.key_range.last = 0;
      branch_ci_header.common.parent_id_string = "0"b;
      branch_ci_header.common.pad = "0"b;
      branch_ci_header.common.key_tail_space_used_since_last_prefix_compaction = 0;
      branch_ci_header.common.previous_id = 0;
      branch_ci_header.common.next_id = 0;
      branch_ci_header.low_branch_id = 0;
      return;
%page;
%include dm_im_ci_header;
   end im_init_branch_ci_header;




		    im_init_leaf_ci_header.pl1      01/04/85  0917.4re  01/03/85  1146.4       11439



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

/* DESCRIPTION:

          This program sets the initial values in a leaf_ci_header.
*/

/* HISTORY:

Written by Lindsey Spratt, 01/01/82.
Modified:
11/08/84 by Lindsey L. Spratt:  Added the history and description comments
            sections.
*/

/* format: style2,ind3 */
im_init_leaf_ci_header:
   proc (p_leaf_ci_header_ptr);

      dcl	    p_leaf_ci_header_ptr   ptr;

      leaf_ci_header_ptr = p_leaf_ci_header_ptr;

      leaf_ci_header.common.is_leaf = "1"b;
      leaf_ci_header.common.flags.pad = "0"b;
      leaf_ci_header.common.key_range.first = 0;
      leaf_ci_header.common.key_range.last = 0;
      leaf_ci_header.common.parent_id_string = "0"b;
      leaf_ci_header.common.pad = "0"b;
      leaf_ci_header.common.key_tail_space_used_since_last_prefix_compaction = 0;
      leaf_ci_header.common.previous_id = 0;
      leaf_ci_header.common.next_id = 0;
      return;
%page;
%include dm_im_ci_header;
   end im_init_leaf_ci_header;




		    im_initial_insert.pl1           04/04/85  1109.9re  04/04/85  0823.4       49941



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

/* DESCRIPTION:
          This module does the initial insertion of a key into an empty index
     collection.  It creates the first control interval node of the index,
     which is a leaf node as well as being the root node.
*/

/* HISTORY:
Written by Lindsey Spratt, 04/05/82.
Modified:
04/14/82 by Lindsey Spratt: Changed to use the new allocate_element calling
	  sequence, which has added the maximum_space_available.
08/12/82 by Matthew Pierret:  Changed calling sequence to 
            collection_manager_$allocate_control_interval to accept the new
            control interval id in the aligned automatic variable root_ci.
            The unaligned index_header.root_id is then assigned this value.
08/30/82 by Lindsey Spratt:  Added the p_key_element_id_string parameter to
	  return the location of the newly allocated key.
11/02/82 by Lindsey Spratt:  Removed the p_index_cursor_ptr and
	  p_index_header_ptr parameters and added the
	  p_index_opening_info_ptr parameter.  General alterations to use
	  the opening info, to not update the key count (this
	  is now done by the caller), and to update the index_header root_id
	  via the im_update_opening_info$root_id operation.
06/12/84 by Matthew Pierret:  Re-named cm_$allocate_element to cm_$put.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 index_opening_info.
            Changed to use ERROR_RETURN.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

im_initial_insert:
   proc (p_index_opening_info_ptr, p_key_string, p_key_element_id_string, p_code);


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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_key_string	       bit (*);
      dcl	    p_key_element_id_string
			       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 local_leaf_header    like leaf_ci_header;
      dcl	    root_ci	       fixed bin (24) unsigned;

/* Based */

/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("im_initial_insert") char (32) varying internal static options (constant);

/* Entry */

      dcl	    im_update_opening_info$root_id
			       entry (ptr, uns fixed bin (24), fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    im_init_leaf_ci_header entry (ptr);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35);

/* END OF DECLARATIONS */

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      p_code = 0;
      p_key_element_id_string = "0"b;

      call collection_manager_$allocate_control_interval (index_opening_info.file_opening_id,
	 index_opening_info.collection_id, root_ci, p_code);

      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      element_id.control_interval_id = root_ci;
      element_id.index = DEFAULT_INITIAL_KEY_SLOT;
      call collection_manager_$put (index_opening_info.file_opening_id, index_opening_info.collection_id,
	 addr (p_key_string), length (p_key_string), element_id_string, (0), p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);
      p_key_element_id_string = element_id_string;

      call im_init_leaf_ci_header (addr (local_leaf_header));

      local_leaf_header.common.key_tail_space_used_since_last_prefix_compaction = length (p_key_string);
      local_leaf_header.common.key_range = DEFAULT_INITIAL_KEY_SLOT;
      element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
      call collection_manager_$put (index_opening_info.file_opening_id, index_opening_info.collection_id,
	 addr (local_leaf_header), length (unspec (local_leaf_header)), element_id_string, (0), p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

/* Record the modified index_header in the index collection.  The new version
of the header has the root_id and the updated number of keys.
*/

      call im_update_opening_info$root_id (index_opening_info_ptr, root_ci, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned parameter;
      dcl	    p_expected_version     char (8) aligned parameter;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include dm_im_ci_header;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_element_id;
%page;
%include dm_im_opening_info;
   end im_initial_insert;




		    im_make_parent_key.pl1          10/24/88  1644.7r w 10/24/88  1359.9      149184



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


/****^  HISTORY COMMENTS:
  1) change(86-12-17,Dupuis), approve(87-04-01,MCR7632), audit(87-01-13,Blair),
     install(87-04-02,MR12.1-1020):
     Fixed a bug (phx20420) where the parent key was being built incorrectly if
     it was a char varying or bit varying field.
                                                   END HISTORY COMMENTS */


/* format: style2,ind3 */
im_make_parent_key:
   proc (p_field_table_ptr, p_low_key_string_ptr, p_last_field_in_low_key, p_high_key_string_ptr,
      p_last_field_in_high_key, p_parent_key_buffer_ptr, p_parent_key_buffer_length, p_work_area_ptr, p_branch_key_ptr,
      p_branch_key_string_length, p_new_buffer_was_allocated, p_code);

/* DESCRIPTION:

          This module takes two input key strings and produces a "parent" key
     string which will compare greater than the "low" key and less than or
     equal to the "high" key.  The "parent" key which is produced may not have
     as many fields as the either or both of the "low" and "high" keys.
     Similarly the "low" and "high" keys need not have all of the fields
     defined in the field_table.  The subset of fields present in any of these
     keys, however, must be a continuous set  from the first field (i.e., if
     field N is absent, then all fields with identifiers greater than N must
     be absent as well).
*/

/* HISTORY:

Written by Lindsey Spratt, 04/22/82.
Modified:
01/06/83 by Lindsey Spratt:  Fixed to correctly initialize the 
	  (low high)_varying_data_idx when the input keys are full length and
	  a varying field is present.
03/23/83 by Lindsey Spratt:  Changed to use version 2 of field_table.  Also,
	  converted to use data_mgmt_util_$compare_field_to_field instead of
	  im_compare_values$field_to_field.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.  Changed
            references to data_mgmt_util_ to data_format_util_.
*/

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

      dcl	    p_field_table_ptr      ptr;
      dcl	    p_low_key_string_ptr   ptr;
      dcl	    p_last_field_in_low_key
			       fixed bin (17) unal;
      dcl	    p_high_key_string_ptr  ptr;
      dcl	    p_last_field_in_high_key
			       fixed bin (17) unal;
      dcl	    p_parent_key_buffer_ptr
			       ptr;
      dcl	    p_parent_key_buffer_length
			       fixed bin (35);
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_branch_key_ptr       ptr;
      dcl	    p_branch_key_string_length
			       fixed bin (35);
      dcl	    p_new_buffer_was_allocated
			       bit (1) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    last_field_is_truncated
			       bit (1) aligned init ("0"b);
      dcl	    bit_idx	       fixed bin (35) init (0);
      dcl	    number_of_bits_needed_to_adjust_for_byte_alignment
			       fixed bin init (0);
      dcl	    char_idx	       fixed bin (35) init (0);

      dcl	    maximum_field_idx      fixed bin (17) init (0);
      dcl	    low_varying_data_idx   fixed bin (17) init (0);
      dcl	    high_varying_data_idx  fixed bin (17) init (0);
      dcl	    low_equal_to_high      bit (1) aligned init ("0"b);
      dcl	    low_less_than_high     bit (1) aligned init ("0"b);
      dcl	    field_idx	       fixed bin (17) init (0);
      dcl	    low_value_length       fixed bin (35) init (0);
      dcl	    high_value_length      fixed bin (35) init (0);
      dcl	    low_value_ptr	       ptr init (null);
      dcl	    high_value_ptr	       ptr init (null);
      dcl	    myname	       init ("im_make_parent_key") char (32) varying;
      dcl	    branch_key_varying_data_idx
			       fixed bin (35) init (0);

/* Based */

      dcl	    low_key_string	       bit (sys_info$max_seg_size * BITS_PER_WORD) based (p_low_key_string_ptr);
      dcl	    high_key_string	       bit (sys_info$max_seg_size * BITS_PER_WORD) based (p_high_key_string_ptr);
      dcl	    low_key_bit_array      (sys_info$max_seg_size * BITS_PER_WORD) bit (1) based (p_low_key_string_ptr);
      dcl	    high_key_bit_array     (sys_info$max_seg_size * BITS_PER_WORD) bit (1) based (p_high_key_string_ptr);
      dcl	    based_char_string      char (sys_info$max_seg_size * BYTES_PER_WORD) based;

/* Builtin */

      dcl	    (addr, bin, copy, divide, hbound, length, min, mod, null, substr, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    ALL_FIELDS_PRESENT     init (-1) fixed bin (17) internal static options (constant);

      dcl	    (
	    BITS_PER_WORD	       init (36),
	    BYTES_PER_WORD	       init (4),
	    BITS_PER_BYTE	       init (9)
	    )		       fixed bin (17) internal static options (constant);

/* Entry */

      dcl	    data_format_util_$compare_field_to_field
			       entry (ptr, ptr, fixed bin (35), ptr, fixed bin (35), bit (1) aligned,
			       bit (1) aligned, fixed bin (35));
      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;
      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$programming_error,
	    dm_error_$key_duplication,
	    dm_error_$keys_out_of_order
	    )		       fixed bin (35) ext static;

/* END OF DECLARATIONS */

      p_code = 0;

      field_table_ptr = p_field_table_ptr;
      if field_table.version ^= FIELD_TABLE_VERSION_3
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^a of the field_table structure.  Received version ^a.", FIELD_TABLE_VERSION_3,
	    field_table.version);

      p_new_buffer_was_allocated = "0"b;
      p_branch_key_ptr = null;
      p_branch_key_string_length = 0;
      branch_key_ptr = p_parent_key_buffer_ptr;
      bk_string_length = 0;
      bk_string_length = p_parent_key_buffer_length - length (unspec (branch_key));

      if p_last_field_in_low_key = ALL_FIELDS_PRESENT | p_last_field_in_high_key = ALL_FIELDS_PRESENT
      then maximum_field_idx = hbound (field_table.field, 1);
      else maximum_field_idx = min (p_last_field_in_low_key, p_last_field_in_high_key);
      if p_last_field_in_low_key = ALL_FIELDS_PRESENT
      then low_varying_data_idx = field_table.location_of_first_varying_field;
      else low_varying_data_idx =
	    field_table.field (p_last_field_in_low_key).location
	    + field_table.field (p_last_field_in_low_key).length_in_bits;
      if p_last_field_in_high_key = ALL_FIELDS_PRESENT
      then high_varying_data_idx = field_table.location_of_first_varying_field;
      else high_varying_data_idx =
	    field_table.field (p_last_field_in_high_key).location
	    + field_table.field (p_last_field_in_high_key).length_in_bits;

      low_equal_to_high = "1"b;
COMPARISON_LOOP:
      do field_idx = 1 to maximum_field_idx while (low_equal_to_high & p_code = 0);
         if field_table.varying_field_map (field_idx).varying_field_index > 0
         then
	  do;
	     unspec (low_value_length) =
	        copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
	        ||
	        substr (low_key_string, field_table.field (field_idx).location,
	        field_table.field (field_idx).length_in_bits);
	     unspec (high_value_length) =
	        copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
	        ||
	        substr (high_key_string, field_table.field (field_idx).location,
	        field_table.field (field_idx).length_in_bits);
	     low_value_ptr = addr (low_key_bit_array (low_varying_data_idx));
	     high_value_ptr = addr (high_key_bit_array (high_varying_data_idx));
	     if field_table.field (field_idx).length_is_in_characters
	     then
	        do;
		 low_varying_data_idx = low_varying_data_idx + low_value_length * BITS_PER_BYTE;
		 high_varying_data_idx = high_varying_data_idx + high_value_length * BITS_PER_BYTE;
	        end;
	     else
	        do;
		 low_varying_data_idx = low_varying_data_idx + low_value_length;
		 high_varying_data_idx = high_varying_data_idx + high_value_length;
	        end;
	  end;
         else
	  do;
	     low_value_length, high_value_length = -1;
	     low_value_ptr = addr (low_key_bit_array (field_table.field (field_idx).location));
	     high_value_ptr = addr (high_key_bit_array (field_table.field (field_idx).location));

	  end;

         call
	  data_format_util_$compare_field_to_field (addr (field_table.field (field_idx).descriptor), low_value_ptr,
	  low_value_length, high_value_ptr, high_value_length, low_equal_to_high, low_less_than_high, p_code);

      end COMPARISON_LOOP;

      if low_equal_to_high
      then
         do;
	  p_code = dm_error_$key_duplication;
	  return;
         end;

      if ^low_less_than_high
      then call sub_err_ (dm_error_$keys_out_of_order, myname, "h", null, 0);

      branch_key.last_field_idx = field_idx - 1;		/* The loop increments the field idx one too many times. */

/* Copy the fields which compared "equal" and the first field which compared
"inequal" into the new parent key. */

      arg_descriptor_ptr = addr (field_table.field (branch_key.last_field_idx).descriptor);
      last_field_is_truncated = "0"b;
      if field_table.varying_field_map (branch_key.last_field_idx).varying_field_index = 0
      then if arg_descriptor.type = bit_dtype
	 then
	    do;
	       if arg_descriptor.size > BITS_PER_WORD + BITS_PER_BYTE
	       then
		do;
		   do bit_idx = 1 to field_table.field (branch_key.last_field_idx).length_in_bits
		      while (
		      substr (high_key_string, field_table.field (branch_key.last_field_idx).location + bit_idx - 1,
		      1)
		      =
		      substr (low_key_string, field_table.field (branch_key.last_field_idx).location + bit_idx - 1, 1)
		      );
		   end;
		   if bit_idx > field_table.field (branch_key.last_field_idx).length_in_bits
		   then call
			 sub_err_ (dm_error_$programming_error, myname, "s", null, 0,
			 "^/Two bit values compared equal which im_compare_values claims are not equal.");


		   substr (branch_key.string, field_table.field (branch_key.last_field_idx).location + BITS_PER_WORD,
		      bit_idx) =
		      substr (high_key_string, field_table.field (branch_key.last_field_idx).location, bit_idx);

		   number_of_bits_needed_to_adjust_for_byte_alignment =
		      mod (bit_idx + field_table.field (branch_key.last_field_idx).location + BITS_PER_BYTE - 1,
		      BITS_PER_BYTE);
		   substr (branch_key.string,
		      field_table.field (branch_key.last_field_idx).location + bit_idx + BITS_PER_WORD,
		      number_of_bits_needed_to_adjust_for_byte_alignment) = "0"b;
		   bit_idx = bit_idx + number_of_bits_needed_to_adjust_for_byte_alignment;
		   substr (branch_key.string, field_table.field (branch_key.last_field_idx).location, BITS_PER_WORD) =
		      unspec (bit_idx);
		   branch_key_varying_data_idx =
		      field_table.field (branch_key.last_field_idx).location + BITS_PER_WORD + bit_idx;
		   last_field_is_truncated = "1"b;
		end;
	    end;
	 else if arg_descriptor.type = char_dtype
	 then
	    do;
	       if arg_descriptor.size > BYTES_PER_WORD + 1
	       then
		do;

		   do char_idx = 1
		      to divide (field_table.field (branch_key.last_field_idx).length_in_bits, BITS_PER_BYTE, 35, 0)
		      while (
		      substr (addr (high_key_bit_array (field_table.field (branch_key.last_field_idx).location))
		      -> based_char_string, char_idx, 1)
		      =
		      substr (addr (low_key_bit_array (field_table.field (branch_key.last_field_idx).location))
		      -> based_char_string, char_idx, 1));
		   end;
		   bit_idx = char_idx * BITS_PER_BYTE;
		   if bit_idx > field_table.field (branch_key.last_field_idx).length_in_bits
		   then call
			 sub_err_ (dm_error_$programming_error, myname, "s", null, 0,
			 "^/Two character values compared equal which im_compare_values claims are not 
equal.");

		   substr (branch_key.string, field_table.field (branch_key.last_field_idx).location + BITS_PER_WORD,
		      bit_idx) =
		      substr (high_key_string, field_table.field (branch_key.last_field_idx).location, bit_idx);
		   substr (branch_key.string, field_table.field (branch_key.last_field_idx).location, BITS_PER_WORD) =
		      unspec (char_idx);
		   branch_key_varying_data_idx =
		      field_table.field (branch_key.last_field_idx).location + BITS_PER_WORD + bit_idx;
		   last_field_is_truncated = "1"b;
		end;
	    end;

      low_varying_data_idx = field_table.location_of_first_varying_field;
      high_varying_data_idx = field_table.location_of_first_varying_field;
      if ^last_field_is_truncated
      then branch_key_varying_data_idx = field_table.location_of_first_varying_field;

COPY_LOOP:
      do field_idx = 1 to branch_key.last_field_idx - bin (last_field_is_truncated);
         if field_table.varying_field_map (field_idx).varying_field_index = 0
         then substr (branch_key.string, field_table.field (field_idx).location,
	       field_table.field (field_idx).length_in_bits) =
	       substr (high_key_string, field_table.field (field_idx).location,
	       field_table.field (field_idx).length_in_bits);
         else
	  do;
	     unspec (low_value_length) =
	        copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
	        ||
	        substr (low_key_string, field_table.field (field_idx).location,
	        field_table.field (field_idx).length_in_bits);
	     unspec (high_value_length) =
	        copy ("0"b, BITS_PER_WORD - field_table.field (field_idx).length_in_bits)
	        ||
	        substr (high_key_string, field_table.field (field_idx).location,
	        field_table.field (field_idx).length_in_bits);

	     if field_table.field (field_idx).length_is_in_characters
	     then do;
		low_value_length = low_value_length * BITS_PER_BYTE;
		high_value_length = high_value_length * BITS_PER_BYTE;
	     end;
	     if field_idx = branch_key.last_field_idx
	     then if addr (field_table.field (field_idx).descriptor) -> arg_descriptor.type = varying_char_dtype
		then
		   do;
		      do char_idx = 1
		         to divide (min (high_value_length, low_value_length), BITS_PER_BYTE, 35, 0)
		         while (
		         substr (addr (high_key_bit_array (high_varying_data_idx)) -> based_char_string, char_idx, 1)
		         = substr (addr (low_key_bit_array (low_varying_data_idx)) -> based_char_string, char_idx, 1))
		         ;
		      end;
		      high_value_length = char_idx * BITS_PER_BYTE;
		   end;
		else
		   do;
		      do bit_idx = 1 to min (high_value_length, low_value_length)
		         while (substr (high_key_string, high_varying_data_idx + bit_idx - 1, 1)
		         = substr (low_key_string, low_varying_data_idx + bit_idx - 1, 1));
		      end;
		      high_value_length =
		         bit_idx + (BITS_PER_BYTE - 1) - mod (bit_idx + (BITS_PER_BYTE - 1), BITS_PER_BYTE);
						/* This adjusts the bit idx to fall on a byte boundary. */
		   end;

	     substr (branch_key.string, branch_key_varying_data_idx, high_value_length) =
	        substr (high_key_string, high_varying_data_idx, high_value_length);
	     if ^field_table.field (field_idx).length_is_in_characters
	     then substr (branch_key.string, field_table.field (field_idx).location,
	        field_table.field (field_idx).length_in_bits) =
	        "0"b
	        ||
	        substr (unspec (high_value_length), BITS_PER_WORD + 2 - field_table.field (field_idx).length_in_bits,
	        field_table.field (field_idx).length_in_bits - 1);
	     else substr (branch_key.string, field_table.field (field_idx).location,
	        field_table.field (field_idx).length_in_bits) =
	        substr (bit (divide (high_value_length, BITS_PER_BYTE, 35), 35),
	        BITS_PER_WORD - field_table.field (field_idx).length_in_bits,
	        field_table.field (field_idx).length_in_bits);
	     high_varying_data_idx = high_varying_data_idx + high_value_length;
	     branch_key_varying_data_idx = branch_key_varying_data_idx + high_value_length;
	  end;


      end COPY_LOOP;

      p_branch_key_ptr = branch_key_ptr;
      p_branch_key_string_length = branch_key_varying_data_idx - 1;

      return;
%page;
%include dm_field_table;
%page;
%include dm_im_key;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
%page;
%include sub_err_flags;
   end im_make_parent_key;




		    im_process_keys.pl1             04/04/85  1109.9r w 04/04/85  0913.3      654966



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

/* DESCRIPTION:

         This subroutine takes all of the leaf keys in a range (specified by
     the element_id of the low key and the element_id of the high key), and
     processes those which pass the supplied filter (identified by
     p_specification_ptr) according to the specified operation (get, delete,
     count, or position).  

     Getting keys consists of creating simple_typed_vector representations of
     them and adding these STVs to a typed_vector_array, which is returned to
     the caller.  Deleting keys is accomplished by calling im_general_delete
     on each key to be deleted.  The "count" processing is simply achieved by
     incrementing a counter. The "position" processing simply stops with the
     first key found to satisfy the filters.

     The index_cursor is set in different ways, depending on the operation
     (see SET_INDEX_CURSOR for the details).

     All of the external entries have the following input parameters in common:
     p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_id_list_ptr,
     p_specification_ptr, p_and_group_id_list_ptr,
     p_number_of_fully_structural_fields, p_partial_structural_field_id, and
     p_first_key_id_string, p_last_key_id_string.
     
     
     They all have p_code as an output parameter.
     
     For the other parameters:
     
     
     get - p_typed_vector_array_ptr (input/output)

     position - p_number_of_keys_accepted (input/output)
     
     delete - p_key_count_array_ptr, p_number_of_keys_accepted (input/output)
     
     count - p_number_of_keys_accepted (input/output)


     POSITION_INFO:     

     All of the information which is global in this procedure is gathered
     together in a structure called global_position_info.  The global data is
     largely concerned with information related to (or derived from) the
     current position in the index, hence the name of the structure.  There
     are 3 major types of procedures which know about the structure of
     position_info, the GET_*, SET_* and RESET_* procedures.  The other
     procedures which know about the structure of position_info are NOTE_*
     procedures, INITIALIZE_POSITION, NODE_IS_DELETED,
     DECREMENT_LAST_KEY_ID_SLOT_INDEX, and FREE_VECTOR_STORAGE.  Each of these
     procedures only references a very limited portion of the position_info
     structure, using the other procedures (where possible) to access other
     portions of the position_info structure.
     
     ***All other procedures rely entirely on the aforementioned procedures to
     use any of the data in position_info.***
     
     The kind of data in position_info is logically divided into variables
     and constants.  The constants are only referenced by GET_* procedures,
     and never change after being initialized by INITIALIZE_POSITION.
     
     The variables are again of two kinds, those for which the value is
     generated from other info in position_info,  and those which are
     explicitly set (via a SET_* routine).  Each of the generated variables in
     position_info is dependent on the value of (at least) one of the
     explicitly set values.  Therefore, whenever a SET_* procedure is invoked,
     it must RESET_* all of the generated variables which depend on it, as
     well as RESET_*'ing the explicitly set values whose correct
     interpretation depends on the variable being SET_*.
     
     A GET_* of a generated variable will generate the value for that variable
     if there is no valid value for it already.  (RESET_*'ing a generated
     variable sets the variable to "invalid", as does INITIALIZE_POSITION.)

     The elements of the position_info structure are as follows:

     - entire_vector_ptr
         This points at a vector which contains all of the fields in the
       current key.  This value is GENERATED by GET_ENTIRE_VECTOR, RESET by
       RESET_VECTORS.  It depends on key_buffer_contains_current_key.

     - field_table_ptr
         This is a CONSTANT, from p_field_table_ptr.  

     - first_key_id_string
         This is a CONSTANT from p_first_key_id_string.  

     - flags.header_buffer_contains_current_header
         Indicates the validity of the header buffer contents.  This value is
       GENERATED by GET_CI_HEADER, RESET by RESET_CI_HEADER. It depends on
       node_id. 

     - flags.key_buffer_contains_current_key
         Indicates the validity of the key buffer contents.  This value is
       GENERATED by GET_KEY, RESET by RESET_KEY. It depends on slot_index.

     - flags.node_is_deleted
         Indicates that the current node was deleted by the deletion of the
       current key. This value is SET by NOTE_NODE_IS_DELETED, RESET by
       RESET_NODE_ID. 

     - flags.vector_in_use
         Indicates the selected_vector is to be saved for use in the output.
       This value is SET by NOTE_VECTOR_IN_USE, RESET by RESET_VECTORS.

     - header_buffer_length
         This is a CONSTANT from length(unspec(local_leaf_ci_header)). 

     - header_buffer_ptr
         This buffer holds the leaf_ci_header for the current node.  This is a
       CONSTANT from addr(local_leaf_ci_header). 

     - id_list_ptr
         This is a CONSTANT from p_id_list_ptr. 

     - index_cursor_ptr
         This is a CONSTANT from p_index_cursor_ptr. 

     - key_buffer_length
         This is a CONSTANT from  length(key_buffer). 

     - key_buffer_ptr
         This buffer holds the data string for the current leaf key.  This is
       a CONSTANT from addr(key_buffer).

     - last_key_id_string
         This is SET by INITIALIZE_POSITION and DECREMENT_LAST_KEY_SLOT_INDEX. 

     - lk_string_length
         This is the length of the data string for the current leaf key. This
       value is GENERATED by GET_KEY, RESET by RESET_KEY.  It depends on
       slot_index.

     - node_id
         The current node id.  This value is SET by SET_NODE_ID, RESET by
       RESET_NODE_ID. 

     - node_ptr
         The ptr to the current node.  This value is GENERATED by
       GET_NODE_PTR, RESET by RESET_NODE_PTR.  It depends on node_id. 

     - selected_vector_ptr
         This points to a vector which contains only those fields listed by
       p_id_list. This value is GENERATED by GET_SELECTED_VECTOR, RESET by
       RESET_VECTORS.  It depends on key_buffer_contains_current_key.

     - slot_index
         This is the slot index of the current key.  This value is SET by
       SET_SLOT_INDEX, RESET by RESET_SLOT_INDEX. 

     - work_area_ptr
         This is a CONSTANT from p_work_area_ptr. 

*/

/* HISTORY:

Written by Lindsey L. Spratt, 06/21/82.
Modified:
07/07/82 by Lindsey Spratt:  Added the use of the sequential_specification.
	  Added the p_sequential_specification_ptr to the calling sequence.
07/13/82 by Lindsey Spratt:  Added the p_range and p_range_type parameters.
	  If p_range is greater than 0, then no more than p_range vectors
	  will be put in the typed_vector_array (including any which may
	  have already been present in the array).  If p_range_type equals
	  HIGH_RANGE_TYPE, then the vectors will be taken from the high end
	  of the given interval first (i.e., get_keys_in_reverse is turned
	  on).
08/06/82 by Lindsey Spratt:  Changed from im_add_keys_to_array to
	  im_process_keys.  There are now two entry points, get and delete.
	  A "get" switch was added to distinguish which entry was called.
	  The delete entry invokes im_general_delete on all of the matching
	  keys.
08/09/82 by Matthew Pierret:  Removed offset and length arguments from calls
            to collection_manager_$get_element.
08/17/82 by Matthew Pierret:  Changed call to im_compare_sequential to call to
            data_mgmt_util_$compare_sequential.
08/19/82 by Lindsey Spratt:  Added the p_id_list_ptr parameter to the "get"
	  call and passed the pointer on to the dmu_$cv_string_to_vector
	  utility.
08/26/82 by Lindsey Spratt:  Added the "position" entry.  Added the "delete"
	  switch which , in combination with the "get" switch, distinguishes
	  between the three entries, get, delete and position.
	  Also, added setting of the index_cursor to the correct position.
10/07/82 by Lindsey Spratt:  Changed to use the search_specification version
	  2. Added the "count" entry.  Changes to all calling sequences.
10/18/82 by Lindsey Spratt:  Fixed to create a "full" simple_typed_vector for
	  the call to im_compare_subset, rather than use the p_id_list_ptr.
	  This vector is freed when using the "get" entry and the
	  p_id_list_ptr is not equal to null.
10/19/82 by Lindsey Spratt:  Changed to get the last key positioned to, when
	  executing the "position" entry and the last key positioned to was
	  not gotten in the course of doing comparisons.  This is done so
	  that the index_cursor.key_check_value can be set.
10/21/82 by Lindsey Spratt:  Added code to implement the numeric specification.
10/27/82 by Lindsey Spratt:  Changed KEY_LOOP to always initialize
	  leaf_key_ptr to null, then for each place which needs to have the
	  leaf_key value to check that leaf_key_ptr ^= null before using the
	  value.  If it is null, then the value is
	  retrieved at that time.
10/29/82 by Lindsey Spratt:  Added updating of the key counts.  Changed the
	  calling sequence of delete to include the pointer to the
	  key_count_array.
11/09/82 by Lindsey Spratt:  Removed the index_header_ptr from all entry
	  sequences.  Changed to use new calling sequence of
	  im_general_delete which does not use the index_header_ptr.
12/09/82 by Lindsey Spratt:  Fixed to set the element_id_string when the
	  leaf_key_ptr is null and the current key is supposed to be deleted.
12/10/82 by Lindsey Spratt:  Fixed deletion to set the current_slot_index to 0
	  after a successful deletion of the last key in the current
	  ci.  The various positioning activities were changed to be
	  cognizant of this protocol.
01/20/83 by Matthew Pierret: Fixed to set p_typed_vector_array_ptr after
            allocating a new typed_vector_array.
02/28/83 by Lindsey Spratt:  Changed to use the new index_cursor (version 3)
	  and the new im_set_cursor module for setting it.
03/23/83 by Lindsey Spratt:  Changed to use version 2 of the field_table.
	  Also, uppercased the internal procedure names.
04/28/83 by Lindsey L. Spratt:  Fixed the AFTER_END routine to return true if
            the current CI is the "last" one and the next key to be processed
            is in the next CI.
05/23/83 by Matthew Pierret: Changed to use version 4 of specification_head.
            Split dm_specification.incl.pl1 into dm_specification_head,
            dm_specification and dm_range_types.incl.pl1.
11/07/83 by Lindsey L. Spratt:  Converted to use the buffered access method of
            the collection_manager_.  Also, made minor changes to the coding
            style including:  Added unique prefixes to all variables local to
            an internal procedure; and, converted all error reporting to be
            done through an internal procedure ERROR_RETURN, so that calls to
            internal procedures only return when they are successful and no
            code need be passed or checked by the caller.
11/17/83 by Lindsey L. Spratt:  Fixed to put a modified node buffer after the
            KEY_LOOP.
11/28/83 by Lindsey L. Spratt:  Fixed to not replace the current ci/node when
            the node is deleted.
03/27/84 by Matthew Pierret:  Changed to get a pointer to the current ci/node
            instead of setting up a buffer, and accessing it via 
            collection_manager_$simple_get_element_ptr. Replaced 
            SETUP_NODE_BUFFER with GET_NEW_NODE, which gets a pointer to a
            ci/node and sets the value of the current node. Removed all
            logic relating to replacing the node buffer (PUT_NODE_BUFFER,
            current_node_has_been_modified) as modifications are now 
            actually done by im_general_delete (and its subroutines).
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.  Chnaged
            value of myname to be im_process_keys.
05/10/84 by Matthew Pierret:  Changed to align key_buffer on an even-word
            boundary.
06/07/84 by Matthew Pierret:  Re-named cm_$simple_get_element_ptr to
            cm_$simple_get_by_ci_ptr.
10/02/84 by Lindsey L. Spratt:  Changed to have $get as the main entry point
            (the proc statement label).  Changed a loop that was using
            (vector_slot_index + 1) as its initial value for its loop index to
            use the more meaningful (typed_vector_array.number_of_vectors +
            1).
10/17/84 by Lindsey L. Spratt:  Completely restructured the code.  Introduced
	  the position_info structure, added many internal procedures, and
	  added a great deal of documentation.
*/

/* format: style2,ind3 */

im_process_keys$get:
   proc (p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_id_list_ptr, p_specification_ptr,
        p_and_group_id_list_ptr, p_number_of_fully_structural_fields, p_partial_structural_field_id,
        p_first_key_id_string, p_last_key_id_string, p_typed_vector_array_ptr, p_code);


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

      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_field_table_ptr      ptr parameter;
      dcl	    p_id_list_ptr	       ptr parameter;
      dcl	    p_specification_ptr    ptr parameter;
      dcl	    p_and_group_id_list_ptr
			       ptr parameter;
      dcl	    p_number_of_fully_structural_fields
			       fixed bin (17);
      dcl	    p_partial_structural_field_id
			       fixed bin (17);
      dcl	    p_first_key_id_string  bit (36) aligned parameter;
      dcl	    p_last_key_id_string   bit (36) aligned parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_key_count_array_ptr  ptr parameter;
      dcl	    p_number_of_keys_accepted
			       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    operation	       fixed bin init (0);

      dcl	    (number_of_keys_accepted, input_number_of_keys_accepted, position_count, range_size)
			       fixed bin (35) init (0);
      dcl	    finished	       bit (1) aligned;
      dcl	    (get_keys_in_reverse_order, is_search_specification, key_satisfies_specification, set_cursor)
			       bit (1) aligned init ("0"b);
      dcl	    key_count	       fixed bin (35);
      dcl	    1 local_leaf_ci_header like leaf_ci_header;
      dcl	    local_key_buffer       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
						/* Forces even-word alignment */

      dcl	    global_position_info_ptr
			       ptr init (null);

      dcl	    1 global_position_info aligned like position_info;


/* Based */

      dcl	    1 position_info	       aligned based,
	      2 entire_vector_ptr  ptr,
	      2 field_table_ptr    ptr,
	      2 first_key_id_string
			       bit (36) aligned,
	      2 flags	       aligned,
	        3 header_buffer_contains_current_header
			       bit (1) unaligned,
	        3 key_buffer_contains_current_key
			       bit (1) unaligned,
	        3 node_is_deleted  bit (1) unaligned,
	        3 vector_in_use    bit (1) unaligned,
	        3 pad	       bit (32) unaligned,
	      2 header_buffer_length
			       fixed bin (35),
	      2 header_buffer_ptr  ptr,
	      2 id_list_ptr	       ptr,
	      2 index_cursor_ptr   ptr,
	      2 key_buffer_length  fixed bin (35),
	      2 key_buffer_ptr     ptr,
	      2 last_key_id_string bit (36) aligned,
	      2 lk_string_length   fixed bin (35),
	      2 node_id	       fixed bin (24) unsigned,
	      2 node_ptr	       ptr,
	      2 selected_vector_ptr
			       ptr,
	      2 slot_index	       fixed bin (12) unsigned,
	      2 work_area_ptr      ptr;

      dcl	    key_buffer	       bit (BITS_PER_PAGE) aligned based (addr (local_key_buffer));

/* Builtin */

      dcl	    (addr, abs, bin, divide, length, null, string, unspec)
			       builtin;

/* Constant */

      dcl	    myname	       init ("im_process_keys") char (32) varying internal static options (constant);

      dcl	    NULL_PSEUDO_FIELD_VALUE
			       init ("0"b) bit (36) internal static options (constant);
      dcl	    IS_BEING_DELETED       init ("0"b) bit (1) aligned internal static options (constant);

      dcl	    (
	    COUNT_OPERATION	       init (1),
	    DELETE_OPERATION       init (2),
	    GET_OPERATION	       init (3),
	    POSITION_OPERATION     init (4),
	    BITS_PER_BYTE	       init (9),
	    BITS_PER_PAGE	       init (1024 * 36),
	    DOUBLE_WORDS_PER_PAGE  init (512),
	    VECTOR_SLOT_PAD	       init (100),
	    LIMIT_TO_STOP_INFINITE_LOOPING
			       init (1e6)
	    )		       fixed bin (35) internal static options (constant);

/* Entry */

      dcl	    hash_index_	       entry (ptr, fixed bin (35), fixed bin (35), fixed bin (35)) returns (fixed bin (35));

      dcl	    im_general_delete      entry (ptr, ptr, ptr, bit (36) aligned, bit (1) aligned, fixed bin (35));
      dcl	    im_compare_subset      entry (ptr, ptr, ptr, bit (1) aligned, bit (*), fixed bin (35));
      dcl	    im_update_key_counts   entry (ptr, ptr, ptr, ptr, bit (1) aligned, ptr, bit (36) aligned, ptr,
			       fixed bin (35), ptr, fixed bin (35));

      dcl	    im_set_cursor$at_current
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));
      dcl	    im_set_cursor$no_current
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));
      dcl	    im_set_cursor$at_beginning
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));
      dcl	    im_set_cursor$at_end   entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));

      dcl	    data_format_util_$compare_sequential
			       entry (ptr, ptr, ptr, fixed bin (17), fixed bin (17), bit (*), bit (1) aligned,
			       fixed bin (35));
      dcl	    sub_err_	       entry options (variable);
      dcl	    data_format_util_$cv_string_to_vector
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35));

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$wrong_cursor_type,
	    dm_error_$bad_first_key_idx,
	    dm_error_$bad_last_key_idx,
	    dm_error_$bad_leaf_node,
	    dm_error_$programming_error
	    )		       fixed bin (35) ext;


/* END OF DECLARATIONS */

/* The main entry is - 
get:
   entry (p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_id_list_ptr, p_specification_ptr,
      p_and_group_id_list_ptr, p_number_of_fully_structural_fields, p_partial_structural_field_id, p_first_key_id_string,
      p_last_key_id_string, p_typed_vector_array_ptr, p_code);
*/

      operation = GET_OPERATION;
      typed_vector_array_ptr = p_typed_vector_array_ptr;
      call CHECK_VERSION ((typed_vector_array.version), (TYPED_VECTOR_ARRAY_VERSION_2), "typed_vector_array");
      goto JOIN;

position:
   entry (p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_specification_ptr, p_and_group_id_list_ptr,
        p_number_of_fully_structural_fields, p_partial_structural_field_id, p_first_key_id_string, p_last_key_id_string,
        p_number_of_keys_accepted, p_code);

      operation = POSITION_OPERATION;
      typed_vector_array_ptr = null;
      goto JOIN;

delete:
   entry (p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_specification_ptr, p_and_group_id_list_ptr,
        p_number_of_fully_structural_fields, p_partial_structural_field_id, p_first_key_id_string, p_last_key_id_string,
        p_key_count_array_ptr, p_number_of_keys_accepted, p_code);
      operation = DELETE_OPERATION;
      typed_vector_array_ptr = null;
      goto JOIN;

count:
   entry (p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_specification_ptr, p_and_group_id_list_ptr,
        p_number_of_fully_structural_fields, p_partial_structural_field_id, p_first_key_id_string, p_last_key_id_string,
        p_number_of_keys_accepted, p_code);

      operation = COUNT_OPERATION;
      typed_vector_array_ptr = null;
      goto JOIN;
%page;
/*   The operation of the top level of this program (starting with JOIN), is as
     follows:

     - Set up the global data (copied from the parameters, largely), and
       initialize various control variables based on the specification.
     - For a numeric_specification, make the current position whatever the spec
       says.

     - Find all of the keys between the current position and the end of the
       interval (last_key_id, if getting keys in forward order, first_key_id if
       getting keys in reverse order).
     - For each of these keys, check against the "filters" (the search_spec and
       the subset_spec).
     - For the keys which pass the filter, do the operation appropriate to the
       external entry (ADD_KEY_TO_OUTPUT for get, DELETE_KEY_FROM_INDEX for 
       delete, others just need to have the accepted-keys count incremented).

     - Finally, prepare for returning to the caller by setting the output
     parameters as appropriate.
*/

JOIN:
      p_code = 0;
      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, "s", null, 0,
	      "^/Expected an index cursor, type ^d. Received a cursor of type ^d.", INDEX_CURSOR_TYPE,
	      index_cursor.type);

      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      specification_head_ptr = p_specification_ptr;
      call CHECK_VERSION (specification_head.version, SPECIFICATION_VERSION_4, "specification");


      field_table_ptr = p_field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      call INTERPRET_SPECIFICATION (p_specification_ptr, p_first_key_id_string, is_search_specification,
	 search_specification_ptr, numeric_specification_ptr, get_keys_in_reverse_order, range_size, position_count);

      global_position_info_ptr = addr (global_position_info);

      call INITIALIZE_POSITION (index_cursor_ptr, addr (local_leaf_ci_header), length (unspec (local_leaf_ci_header)),
	 addr (key_buffer), length (key_buffer), field_table_ptr, p_work_area_ptr, p_first_key_id_string,
	 p_last_key_id_string, p_id_list_ptr, get_keys_in_reverse_order, global_position_info_ptr);


      if operation = GET_OPERATION
      then number_of_keys_accepted, input_number_of_keys_accepted = typed_vector_array.number_of_vectors;
      else number_of_keys_accepted, input_number_of_keys_accepted = p_number_of_keys_accepted;

      finished = "0"b;

      if ^is_search_specification
      then call FIND_POSITION (get_keys_in_reverse_order, global_position_info_ptr, position_count, finished);

KEY_LOOP:
      do key_count = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (^finished);

         if is_search_specification
         then call SEARCH_SPEC_COMPARISON (search_specification_ptr, p_and_group_id_list_ptr,
	         p_number_of_fully_structural_fields, p_partial_structural_field_id, global_position_info_ptr,
	         key_satisfies_specification);
         else key_satisfies_specification = "1"b;

         if key_satisfies_specification & specification_head.subset_specification_ptr ^= null
         then call SUBSET_SPEC_COMPARISON (specification_head.subset_specification_ptr, global_position_info_ptr,
	         key_satisfies_specification);


         if key_satisfies_specification
         then
	  do;
	     set_cursor = "1"b;
	     if operation = GET_OPERATION
	     then call ADD_KEY_TO_OUTPUT (global_position_info_ptr, typed_vector_array_ptr, number_of_keys_accepted);
	     else if operation = DELETE_OPERATION
	     then call DELETE_KEY_FROM_INDEX (get_keys_in_reverse_order, global_position_info_ptr,
		     number_of_keys_accepted, p_key_count_array_ptr);
	     else number_of_keys_accepted = number_of_keys_accepted + 1;
	  end;


         call SETUP_NEXT_KEY (operation, is_search_specification, range_size, get_keys_in_reverse_order,
	    key_satisfies_specification, global_position_info_ptr, number_of_keys_accepted, finished);

      end KEY_LOOP;

      if key_count > LIMIT_TO_STOP_INFINITE_LOOPING
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/This program was apparently infinitely looping processing a range of keys.
This either indicates a damaged index or an internal programming logic problem.
The first key id is ^.3b, and the last key id is ^.3b.", p_first_key_id_string, p_last_key_id_string);

      if operation = GET_OPERATION
      then
         do;
	  if get_keys_in_reverse_order
	  then call REVERSE_VECTOR_SLOTS (input_number_of_keys_accepted, typed_vector_array_ptr);
	  p_typed_vector_array_ptr = typed_vector_array_ptr;
         end;
      else p_number_of_keys_accepted = number_of_keys_accepted;


      if set_cursor
      then call SET_INDEX_CURSOR (operation, global_position_info_ptr);

MAIN_RETURN:
      return;



FINISH:
   proc ();
   end;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);
      p_code = er_p_code;
      call FINISH;
      goto MAIN_RETURN;
   end ERROR_RETURN;

%page;
ADD_KEY_TO_OUTPUT:
   proc (akto_p_position_info_ptr, akto_p_typed_vector_array_ptr, akto_p_number_of_keys_accepted);

      dcl	    akto_p_position_info_ptr
			       ptr parameter;
      dcl	    akto_p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    akto_p_number_of_keys_accepted
			       fixed bin (35) parameter;

      dcl	    akto_code	       fixed bin (35) init (0);
      dcl	    akto_new_tva_ptr       ptr init (null);
      dcl	    akto_old_tva_ptr       ptr init (null);
      dcl	    akto_vector_ptr	       ptr;
      dcl	    akto_vector_slot_idx   fixed bin;
      dcl	    akto_work_area	       area based (akto_work_area_ptr);
      dcl	    akto_work_area_ptr     ptr init (null);


      call GET_SELECTED_VECTOR (akto_p_position_info_ptr, akto_vector_ptr);

      akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors =
	 akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors + 1;
      if akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors
	 <= akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vector_slots
      then akto_p_typed_vector_array_ptr
	      -> typed_vector_array
	      .vector_slot (akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors) = akto_vector_ptr;
      else
         do;
	  call GET_WORK_AREA (akto_p_position_info_ptr, akto_work_area_ptr);
	  tva_number_of_vector_slots =
	       akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors + VECTOR_SLOT_PAD;
	  tva_number_of_dimensions = akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_dimensions;
	  tva_maximum_dimension_name_length =
	       akto_p_typed_vector_array_ptr -> typed_vector_array.maximum_dimension_name_length;

	  akto_old_tva_ptr = akto_p_typed_vector_array_ptr;

	  alloc typed_vector_array in (akto_work_area) set (akto_new_tva_ptr);

	  akto_new_tva_ptr -> typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;
	  akto_new_tva_ptr -> typed_vector_array.number_of_vectors =
	       akto_old_tva_ptr -> typed_vector_array.number_of_vectors;
	  akto_new_tva_ptr -> typed_vector_array.dimension_table =
	       akto_old_tva_ptr -> typed_vector_array.dimension_table;
	  do akto_vector_slot_idx = 1 to akto_new_tva_ptr -> typed_vector_array.number_of_vectors - 1;
	     akto_new_tva_ptr -> typed_vector_array.vector_slot (akto_vector_slot_idx) =
		akto_old_tva_ptr -> typed_vector_array.vector_slot (akto_vector_slot_idx);
	  end;
	  akto_new_tva_ptr
	       -> typed_vector_array.vector_slot (akto_new_tva_ptr -> typed_vector_array.number_of_vectors) =
	       akto_vector_ptr;
	  do akto_vector_slot_idx = akto_new_tva_ptr -> typed_vector_array.number_of_vectors + 1
	       to akto_new_tva_ptr -> typed_vector_array.number_of_vector_slots;
	     akto_new_tva_ptr -> typed_vector_array.vector_slot (akto_vector_slot_idx) = null;
	  end;
	  free akto_old_tva_ptr -> typed_vector_array in (akto_work_area);
	  akto_p_typed_vector_array_ptr = akto_new_tva_ptr;
         end;
      akto_p_number_of_keys_accepted = akto_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors;

      call NOTE_VECTOR_IN_USE (akto_p_position_info_ptr);
   end ADD_KEY_TO_OUTPUT;
%page;
AFTER_END:
   proc (ae_p_position_info_ptr, ae_p_ci, ae_p_index) returns (bit (1) aligned);
      dcl	    ae_p_position_info_ptr ptr parameter;
      dcl	    ae_p_ci	       fixed bin (24) unsigned parameter;
      dcl	    ae_p_index	       fixed bin (12) unsigned parameter;

      dcl	    1 ae_last_key_id       based (addr (ae_last_key_id_string)) like element_id;
      dcl	    ae_last_key_id_string  bit (36) aligned;
      dcl	    1 ae_leaf_ci_header    based (ae_leaf_ci_header_ptr) like leaf_ci_header;
      dcl	    ae_leaf_ci_header_ptr  ptr;

      call GET_CI_HEADER (ae_p_position_info_ptr, ae_leaf_ci_header_ptr);
      call GET_LAST_KEY_ID (ae_p_position_info_ptr, ae_last_key_id_string);

      return ((ae_p_ci = ae_last_key_id.control_interval_id & (ae_p_index > ae_last_key_id.index | ae_p_index = 0))
	 | ((ae_p_index = 0 | ae_p_index > ae_leaf_ci_header.common.key_range.last)
	 & ae_leaf_ci_header.common.next_id = 0));	/* ae_p_index = 0 indicates that the current ci is empty. */
   end AFTER_END;

BEFORE_BEGINNING:
   proc (bb_p_position_info_ptr, bb_p_ci, bb_p_index) returns (bit (1) aligned);
      dcl	    bb_p_position_info_ptr ptr parameter;
      dcl	    bb_p_ci	       fixed bin (24) unsigned parameter;
      dcl	    bb_p_index	       fixed bin (12) unsigned parameter;

      dcl	    1 bb_first_key_id      based (addr (bb_first_key_id_string)) like element_id;
      dcl	    bb_first_key_id_string bit (36) aligned;
      dcl	    1 bb_leaf_ci_header    based (bb_leaf_ci_header_ptr) like leaf_ci_header;
      dcl	    bb_leaf_ci_header_ptr  ptr;

      call GET_CI_HEADER (bb_p_position_info_ptr, bb_leaf_ci_header_ptr);
      call GET_FIRST_KEY_ID (bb_p_position_info_ptr, bb_first_key_id_string);

      return ((bb_p_ci = bb_first_key_id.control_interval_id & bb_p_index < bb_first_key_id.index)
	 | (bb_leaf_ci_header.common.previous_id = 0 & bb_leaf_ci_header.common.key_range.first > bb_p_index));

   end BEFORE_BEGINNING;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;

CHECK_VERSION_CHAR:
   proc (cvc_p_expected_version, cvc_p_received_version, cvc_p_structure_name);
      dcl	    (cvc_p_expected_version, cvc_p_received_version)
			       char (8) aligned;
      dcl	    cvc_p_structure_name   char (*) parameter;

      if cvc_p_expected_version ^= cvc_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", cvc_p_expected_version, cvc_p_structure_name, cvc_p_received_version);
   end CHECK_VERSION_CHAR;
%page;
DECREMENT_LAST_KEY_SLOT_INDEX:
   proc (dlksi_p_position_info_ptr);
      dcl	    dlksi_p_position_info_ptr
			       ptr parameter;
      dcl	    1 dlksi_p_position_info
			       based (dlksi_p_position_info_ptr) aligned like position_info;

      addr (dlksi_p_position_info.last_key_id_string) -> element_id.index =
	 addr (dlksi_p_position_info.last_key_id_string) -> element_id.index - 1;

   end DECREMENT_LAST_KEY_SLOT_INDEX;




DELETE_KEY_FROM_INDEX:
   proc (dkfi_p_get_keys_in_reverse_order, dkfi_p_position_info_ptr, dkfi_p_number_of_keys_accepted,
        dkfi_p_key_count_array_ptr);

      dcl	    dkfi_p_get_keys_in_reverse_order
			       bit (1) aligned parameter;
      dcl	    dkfi_p_position_info_ptr
			       ptr parameter;
      dcl	    dkfi_p_number_of_keys_accepted
			       fixed bin (35) parameter;
      dcl	    dkfi_p_key_count_array_ptr
			       ptr parameter;


      dcl	    dkfi_code	       fixed bin (35) init (0);
      dcl	    dkfi_deleted_node      bit (1) aligned init ("0"b);
      dcl	    1 dkfi_element_id      based (addr (dkfi_element_id_string)) like element_id;
      dcl	    dkfi_element_id_string bit (36) aligned;
      dcl	    dkfi_field_table_ptr   ptr;
      dcl	    dkfi_index_cursor_ptr  ptr;
      dcl	    1 dkfi_last_key_id     based (addr (dkfi_last_key_id_string)) like element_id;
      dcl	    dkfi_last_key_id_string
			       bit (36) aligned;
      dcl	    dkfi_leaf_ci_header_ptr
			       ptr;
      dcl	    dkfi_leaf_key_ptr      ptr;
      dcl	    dkfi_lk_string_length  fixed bin (35);
      dcl	    dkfi_node_id	       fixed bin (24) unsigned;
      dcl	    dkfi_node_ptr	       ptr;
      dcl	    dkfi_slot_index	       fixed bin (12) unsigned;
      dcl	    dkfi_work_area_ptr     ptr;

      call GET_WORK_AREA (dkfi_p_position_info_ptr, dkfi_work_area_ptr);
      call GET_FIELD_TABLE (dkfi_p_position_info_ptr, dkfi_field_table_ptr);
      call GET_INDEX_CURSOR (dkfi_p_position_info_ptr, dkfi_index_cursor_ptr);
      call GET_CI_HEADER (dkfi_p_position_info_ptr, dkfi_leaf_ci_header_ptr);
      call GET_NODE_ID (dkfi_p_position_info_ptr, dkfi_node_id);
      call GET_NODE_PTR (dkfi_p_position_info_ptr, dkfi_node_ptr);
      call GET_SLOT_INDEX (dkfi_p_position_info_ptr, dkfi_slot_index);
      call GET_KEY (dkfi_p_position_info_ptr, dkfi_leaf_key_ptr, dkfi_lk_string_length);
      call GET_LAST_KEY_ID (dkfi_p_position_info_ptr, dkfi_last_key_id_string);

      dkfi_element_id.control_interval_id = dkfi_node_id;
      dkfi_element_id.index = dkfi_slot_index;

      call im_update_key_counts (dkfi_node_ptr, dkfi_index_cursor_ptr, dkfi_work_area_ptr, dkfi_field_table_ptr,
	 IS_BEING_DELETED, dkfi_leaf_ci_header_ptr, dkfi_element_id_string, dkfi_leaf_key_ptr, dkfi_lk_string_length,
	 dkfi_p_key_count_array_ptr, dkfi_code);
      if dkfi_code ^= 0
      then call ERROR_RETURN (dkfi_code);

      dkfi_p_number_of_keys_accepted = dkfi_p_number_of_keys_accepted + 1;

      call im_general_delete (dkfi_node_ptr, dkfi_index_cursor_ptr, dkfi_leaf_ci_header_ptr, dkfi_element_id_string,
	 dkfi_deleted_node, dkfi_code);		/* This modifies the contents of the control interval */
						/* at which dkfi_p_current_node_ptr points. */
      if dkfi_code ^= 0
      then call ERROR_RETURN (dkfi_code);

      if dkfi_deleted_node
      then call NOTE_NODE_IS_DELETED (dkfi_p_position_info_ptr);


      if dkfi_last_key_id.control_interval_id = dkfi_node_id & ^dkfi_p_get_keys_in_reverse_order
      then call DECREMENT_LAST_KEY_SLOT_INDEX (dkfi_p_position_info_ptr);
   end DELETE_KEY_FROM_INDEX;
%page;
FIND_POSITION:
   proc (fp_p_get_keys_in_reverse_order, fp_p_position_info_ptr, fp_p_position_count, fp_p_finished);

      dcl	    fp_p_get_keys_in_reverse_order
			       bit (1) aligned parameter;
      dcl	    fp_p_position_info_ptr ptr parameter;
      dcl	    fp_p_position_count    fixed bin (35) parameter;
      dcl	    fp_p_finished	       bit (1) aligned parameter;


      dcl	    1 fp_leaf_ci_header    based (fp_leaf_ci_header_ptr) like leaf_ci_header;
      dcl	    fp_leaf_ci_header_ptr  ptr;
      dcl	    fp_node_id	       fixed bin (24) unsigned;
      dcl	    fp_position_change     fixed bin (35) init (0);
      dcl	    fp_slot_index	       fixed bin (12) unsigned;

      call GET_NODE_ID (fp_p_position_info_ptr, fp_node_id);
      call GET_CI_HEADER (fp_p_position_info_ptr, fp_leaf_ci_header_ptr);
      call GET_SLOT_INDEX (fp_p_position_info_ptr, fp_slot_index);

      if fp_p_get_keys_in_reverse_order
      then
         do;
	  fp_position_change = fp_p_position_count;	/* Try to move the entire distance. */
	  if BEFORE_BEGINNING (fp_p_position_info_ptr, fp_node_id, fp_slot_index - fp_position_change)
	  then fp_p_finished = "1"b;
	  else if fp_slot_index - fp_position_change >= fp_leaf_ci_header.common.key_range.first
	  then call SET_SLOT_INDEX (fp_slot_index - fp_position_change, fp_p_position_info_ptr);
	  else
	     do;
	        do while (^BEFORE_BEGINNING (fp_p_position_info_ptr, fp_node_id, fp_slot_index - fp_position_change)
		   & (fp_slot_index - fp_position_change < fp_leaf_ci_header.common.key_range.first));
		 fp_position_change =
		      fp_position_change - (fp_slot_index - fp_leaf_ci_header.common.key_range.first + 1);

		 fp_node_id = fp_leaf_ci_header.common.previous_id;
		 call SET_NODE_ID (fp_node_id, fp_p_position_info_ptr);

		 call GET_CI_HEADER (fp_p_position_info_ptr, fp_leaf_ci_header_ptr);
		 fp_slot_index = fp_leaf_ci_header.common.key_range.last;
	        end;
	        call SET_SLOT_INDEX (fp_slot_index, fp_p_position_info_ptr);
	        if BEFORE_BEGINNING (fp_p_position_info_ptr, fp_node_id, fp_slot_index - fp_position_change)
	        then fp_p_finished = "1"b;
	        else
		 do;
		    fp_p_position_count = 0;
		    fp_slot_index = fp_slot_index - fp_position_change;
		    call SET_SLOT_INDEX (fp_slot_index, fp_p_position_info_ptr);
		 end;
	     end;
         end;
      else
         do;
	  fp_position_change = fp_p_position_count;
	  if AFTER_END (fp_p_position_info_ptr, fp_node_id, fp_slot_index + fp_position_change)
	  then fp_p_finished = "1"b;
	  else if fp_slot_index + fp_position_change <= fp_leaf_ci_header.common.key_range.last
	  then call SET_SLOT_INDEX (fp_slot_index + fp_position_change, fp_p_position_info_ptr);
	  else
	     do;
	        do while (^AFTER_END (fp_p_position_info_ptr, fp_node_id, fp_slot_index + fp_position_change)
		   & (fp_slot_index + fp_position_change > fp_leaf_ci_header.common.key_range.last));
		 fp_position_change =
		      fp_position_change - (fp_leaf_ci_header.common.key_range.last - fp_slot_index + 1);

		 fp_node_id = fp_leaf_ci_header.common.next_id;
		 call SET_NODE_ID (fp_node_id, fp_p_position_info_ptr);

		 call GET_CI_HEADER (fp_p_position_info_ptr, fp_leaf_ci_header_ptr);
		 fp_slot_index = fp_leaf_ci_header.common.key_range.first;
	        end;
	        call SET_SLOT_INDEX (fp_slot_index, fp_p_position_info_ptr);

	        if AFTER_END (fp_p_position_info_ptr, fp_node_id, fp_slot_index + fp_position_change)
	        then fp_p_finished = "1"b;
	        else
		 do;
		    fp_slot_index = fp_slot_index + fp_position_change;
		    call SET_SLOT_INDEX (fp_slot_index, fp_p_position_info_ptr);
		 end;
	     end;
	  fp_p_position_count = 0;
         end;

   end FIND_POSITION;
%page;
FREE_ENTIRE_VECTOR:
   proc (fev_p_vector_ptr);
      dcl	    fev_p_vector_ptr       ptr parameter;

      dcl	    fev_based_dummy	       fixed bin based;
      dcl	    fev_dimension_idx      fixed bin (35) init (0);

      do fev_dimension_idx = 1 to fev_p_vector_ptr -> simple_typed_vector.number_of_dimensions;
         free fev_p_vector_ptr -> simple_typed_vector.dimension (fev_dimension_idx).value_ptr -> fev_based_dummy;
      end;
      free fev_p_vector_ptr -> simple_typed_vector;
      fev_p_vector_ptr = null;

   end FREE_ENTIRE_VECTOR;




GET_CI_HEADER:
   proc (gch_p_position_info_ptr, gch_p_leaf_ci_header_ptr);
      dcl	    gch_p_position_info_ptr
			       ptr parameter;
      dcl	    gch_p_leaf_ci_header_ptr
			       ptr parameter;

      dcl	    gch_code	       fixed bin (35) init (0);
      dcl	    gch_collection_id      bit (36) aligned;
      dcl	    1 gch_element_id       aligned based (addr (gch_element_id_string)) like element_id;
      dcl	    gch_element_id_string  bit (36) aligned;
      dcl	    gch_node_id	       fixed bin (24) unsigned;
      dcl	    gch_node_ptr	       ptr;
      dcl	    1 gch_p_position_info  based (gch_p_position_info_ptr) aligned like position_info;

      if ^gch_p_position_info.header_buffer_contains_current_header
      then
         do;
	  call GET_COLLECTION_ID (gch_p_position_info_ptr, gch_collection_id);
	  call GET_NODE_ID (gch_p_position_info_ptr, gch_node_id);
	  call GET_NODE_PTR (gch_p_position_info_ptr, gch_node_ptr);

	  gch_element_id.control_interval_id = gch_node_id;
	  gch_element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;

	  call collection_manager_$simple_get_by_ci_ptr (gch_node_ptr, gch_collection_id, gch_element_id_string,
	       gch_p_position_info.header_buffer_ptr, gch_p_position_info.header_buffer_length, (0), gch_code);
	  if gch_code ^= 0
	  then call ERROR_RETURN (gch_code);
	  if ^gch_p_position_info.header_buffer_ptr -> common_ci_header.is_leaf
	  then call ERROR_RETURN (dm_error_$bad_leaf_node);
	  else if gch_p_position_info.header_buffer_ptr -> leaf_ci_header.common.key_range.first < 0
	  then call ERROR_RETURN (dm_error_$bad_first_key_idx);
	  else if gch_p_position_info.header_buffer_ptr -> leaf_ci_header.common.key_range.last
		  < gch_p_position_info.header_buffer_ptr -> leaf_ci_header.common.key_range.first
	  then call ERROR_RETURN (dm_error_$bad_last_key_idx);
	  gch_p_position_info.header_buffer_contains_current_header = "1"b;
         end;
      gch_p_leaf_ci_header_ptr = gch_p_position_info.header_buffer_ptr;

      return;
   end GET_CI_HEADER;
%page;
GET_COLLECTION_ID:
   proc (gci_p_position_info_ptr, gci_p_collection_id);
      dcl	    gci_p_position_info_ptr
			       ptr parameter;
      dcl	    gci_p_collection_id    bit (36) aligned parameter;

      gci_p_collection_id = gci_p_position_info_ptr -> position_info.index_cursor_ptr -> index_cursor.collection_id;

   end GET_COLLECTION_ID;



GET_ENTIRE_VECTOR:
   proc (gev_p_position_info_ptr, gev_p_vector_ptr);
      dcl	    gev_p_position_info_ptr
			       ptr parameter;
      dcl	    gev_p_vector_ptr       ptr parameter;

      dcl	    1 gev_p_position_info  aligned based (gev_p_position_info_ptr) like position_info;

      dcl	    gev_code	       fixed bin (35);
      dcl	    gev_field_table_ptr    ptr;
      dcl	    gev_leaf_key_ptr       ptr;
      dcl	    gev_lk_string_length   fixed bin (35);
      dcl	    gev_work_area_ptr      ptr;

      if gev_p_position_info.entire_vector_ptr = null
      then
         do;

	  call GET_KEY (gev_p_position_info_ptr, gev_leaf_key_ptr, gev_lk_string_length);
	  call GET_FIELD_TABLE (gev_p_position_info_ptr, gev_field_table_ptr);
	  call GET_WORK_AREA (gev_p_position_info_ptr, gev_work_area_ptr);

	  call data_format_util_$cv_string_to_vector (gev_field_table_ptr, gev_work_area_ptr, gev_leaf_key_ptr,
	       gev_lk_string_length, null (), gev_p_position_info.entire_vector_ptr, gev_code);
	  if gev_code ^= 0
	  then call ERROR_RETURN (gev_code);

         end;
      gev_p_vector_ptr = gev_p_position_info.entire_vector_ptr;

   end GET_ENTIRE_VECTOR;
%page;
GET_FIELD_TABLE:
   proc (gft_p_position_info_ptr, gft_p_field_table_ptr);
      dcl	    gft_p_position_info_ptr
			       ptr parameter;
      dcl	    gft_p_field_table_ptr  ptr parameter;

      gft_p_field_table_ptr = gft_p_position_info_ptr -> position_info.field_table_ptr;

   end GET_FIELD_TABLE;


GET_FILE_OPENING_ID:
   proc (gfoi_p_position_info_ptr, gfoi_p_file_opening_id);
      dcl	    gfoi_p_position_info_ptr
			       ptr parameter;
      dcl	    gfoi_p_file_opening_id bit (36) aligned parameter;

      gfoi_p_file_opening_id = gfoi_p_position_info_ptr -> position_info.index_cursor_ptr -> index_cursor.file_opening_id;

   end GET_FILE_OPENING_ID;


GET_FIRST_KEY_ID:
   proc (gfki_p_position_info_ptr, gfki_p_first_key_id_string);
      dcl	    gfki_p_position_info_ptr
			       ptr parameter;
      dcl	    gfki_p_first_key_id_string
			       bit (36) aligned parameter;

      gfki_p_first_key_id_string = gfki_p_position_info_ptr -> position_info.first_key_id_string;

   end GET_FIRST_KEY_ID;


GET_INDEX_CURSOR:
   proc (gic_p_position_info_ptr, gic_p_index_cursor_ptr);
      dcl	    gic_p_position_info_ptr
			       ptr parameter;
      dcl	    gic_p_index_cursor_ptr ptr parameter;

      gic_p_index_cursor_ptr = gic_p_position_info_ptr -> position_info.index_cursor_ptr;
   end GET_INDEX_CURSOR;
%page;
GET_KEY:
   proc (gk_p_position_info_ptr, gk_p_leaf_key_ptr, gk_p_leaf_key_string_length);
      dcl	    gk_p_position_info_ptr ptr parameter;
      dcl	    gk_p_leaf_key_ptr      ptr parameter;
      dcl	    gk_p_leaf_key_string_length
			       fixed bin (35) parameter;

      dcl	    gk_code	       fixed bin (35);
      dcl	    gk_collection_id       bit (36) aligned;
      dcl	    1 gk_element_id	       aligned based (addr (gk_element_id_string)) like element_id;
      dcl	    gk_element_id_string   bit (36) aligned;
      dcl	    gk_node_id	       fixed bin (24) unsigned;
      dcl	    gk_node_ptr	       ptr;
      dcl	    1 gk_p_position_info   based (gk_p_position_info_ptr) aligned like position_info;
      dcl	    gk_slot_index	       fixed bin (12) unsigned;

      if ^gk_p_position_info.key_buffer_contains_current_key
      then
         do;
	  call GET_COLLECTION_ID (gk_p_position_info_ptr, gk_collection_id);
	  call GET_NODE_ID (gk_p_position_info_ptr, gk_node_id);
	  call GET_NODE_PTR (gk_p_position_info_ptr, gk_node_ptr);
	  call GET_SLOT_INDEX (gk_p_position_info_ptr, gk_slot_index);

	  gk_element_id.control_interval_id = gk_node_id;
	  gk_element_id.index = gk_slot_index;

	  call collection_manager_$simple_get_by_ci_ptr (gk_node_ptr, gk_collection_id, gk_element_id_string,
	       gk_p_position_info.key_buffer_ptr, gk_p_position_info.key_buffer_length,
	       gk_p_position_info.lk_string_length, gk_code);
	  if gk_code ^= 0
	  then call ERROR_RETURN (gk_code);
	  gk_p_position_info.key_buffer_contains_current_key = "1"b;
         end;

      gk_p_leaf_key_ptr = gk_p_position_info.key_buffer_ptr;
      gk_p_leaf_key_string_length = gk_p_position_info.lk_string_length;


   end GET_KEY;



GET_LAST_KEY_ID:
   proc (glki_p_position_info_ptr, glki_p_last_key_id_string);
      dcl	    glki_p_position_info_ptr
			       ptr parameter;
      dcl	    glki_p_last_key_id_string
			       bit (36) aligned parameter;

      glki_p_last_key_id_string = glki_p_position_info_ptr -> position_info.last_key_id_string;

   end GET_LAST_KEY_ID;


GET_NODE_ID:
   proc (gni_p_position_info_ptr, gni_p_node_id);
      dcl	    gni_p_position_info_ptr
			       ptr parameter;
      dcl	    gni_p_node_id	       fixed bin (24) unsigned parameter;

      gni_p_node_id = gni_p_position_info_ptr -> position_info.node_id;

   end GET_NODE_ID;
%page;
GET_NODE_PTR:
   proc (gnp_p_position_info_ptr, gnp_p_node_ptr);
      dcl	    gnp_p_position_info_ptr
			       ptr parameter;
      dcl	    gnp_p_node_ptr	       ptr parameter;

      dcl	    gnp_code	       fixed bin (35);
      dcl	    gnp_collection_id      bit (36) aligned;
      dcl	    gnp_file_opening_id    bit (36) aligned;
      dcl	    gnp_node_id	       fixed bin (24) unsigned;
      dcl	    1 gnp_p_position_info  based (gnp_p_position_info_ptr) aligned like position_info;

      if gnp_p_position_info.node_ptr = null
      then
         do;
	  call GET_FILE_OPENING_ID (gnp_p_position_info_ptr, gnp_file_opening_id);
	  call GET_COLLECTION_ID (gnp_p_position_info_ptr, gnp_collection_id);
	  call GET_NODE_ID (gnp_p_position_info_ptr, gnp_node_id);

	  call collection_manager_$get_control_interval_ptr (gnp_file_opening_id, gnp_collection_id, gnp_node_id,
	       gnp_p_position_info.node_ptr, gnp_code);
	  if gnp_code ^= 0
	  then call ERROR_RETURN (gnp_code);
         end;

      gnp_p_node_ptr = gnp_p_position_info.node_ptr;
   end GET_NODE_PTR;
%page;
GET_SELECTED_VECTOR:
   proc (gsv_p_position_info_ptr, gsv_p_vector_ptr);

      dcl	    gsv_p_position_info_ptr
			       ptr parameter;
      dcl	    gsv_p_vector_ptr       ptr parameter;

      dcl	    gsv_code	       fixed bin (35);
      dcl	    gsv_field_table_ptr    ptr;
      dcl	    gsv_leaf_key_ptr       ptr;
      dcl	    gsv_lk_string_length   fixed bin (35);
      dcl	    1 gsv_p_position_info  based (gsv_p_position_info_ptr) aligned like position_info;
      dcl	    gsv_work_area_ptr      ptr;

      if gsv_p_position_info.selected_vector_ptr = null
      then if gsv_p_position_info.id_list_ptr = null
	 then call GET_ENTIRE_VECTOR (gsv_p_position_info_ptr, gsv_p_position_info.selected_vector_ptr);
	 else
	    do;

	       call GET_KEY (gsv_p_position_info_ptr, gsv_leaf_key_ptr, gsv_lk_string_length);
	       call GET_FIELD_TABLE (gsv_p_position_info_ptr, gsv_field_table_ptr);
	       call GET_WORK_AREA (gsv_p_position_info_ptr, gsv_work_area_ptr);

	       call data_format_util_$cv_string_to_vector (gsv_field_table_ptr, gsv_work_area_ptr, gsv_leaf_key_ptr,
		  gsv_lk_string_length, gsv_p_position_info.id_list_ptr, gsv_p_position_info.selected_vector_ptr,
		  gsv_code);
	       if gsv_code ^= 0
	       then call ERROR_RETURN (gsv_code);
	    end;
      gsv_p_vector_ptr = gsv_p_position_info.selected_vector_ptr;

   end GET_SELECTED_VECTOR;


GET_SLOT_INDEX:
   proc (gsi_p_position_info_ptr, gsi_p_slot_index);
      dcl	    gsi_p_position_info_ptr
			       ptr parameter;
      dcl	    gsi_p_slot_index       fixed bin (12) unsigned parameter;

      gsi_p_slot_index = gsi_p_position_info_ptr -> position_info.slot_index;
   end GET_SLOT_INDEX;



GET_WORK_AREA:
   proc (gci_p_position_info_ptr, gci_p_work_area_ptr);
      dcl	    gci_p_position_info_ptr
			       ptr parameter;
      dcl	    gci_p_work_area_ptr    ptr parameter;

      gci_p_work_area_ptr = gci_p_position_info_ptr -> position_info.work_area_ptr;

   end GET_WORK_AREA;
%page;
INITIALIZE_POSITION:
   proc (ip_p_index_cursor_ptr, ip_p_header_buffer_ptr, ip_p_header_buffer_length, ip_p_key_buffer_ptr,
        ip_p_key_buffer_length, ip_p_field_table_ptr, ip_p_work_area_ptr, ip_p_first_key_id_string,
        ip_p_last_key_id_string, ip_p_id_list_ptr, ip_p_get_keys_in_reverse_order, ip_p_position_info_ptr);

      dcl	    ip_p_index_cursor_ptr  ptr parameter;
      dcl	    ip_p_header_buffer_ptr ptr parameter;
      dcl	    ip_p_header_buffer_length
			       fixed bin (35) parameter;
      dcl	    ip_p_key_buffer_ptr    ptr parameter;
      dcl	    ip_p_key_buffer_length fixed bin (35) parameter;
      dcl	    ip_p_field_table_ptr   ptr parameter;
      dcl	    ip_p_work_area_ptr     ptr parameter;
      dcl	    ip_p_first_key_id_string
			       bit (36) aligned;
      dcl	    ip_p_last_key_id_string
			       bit (36) aligned;
      dcl	    ip_p_id_list_ptr       ptr parameter;
      dcl	    ip_p_get_keys_in_reverse_order
			       bit (1) aligned parameter;
      dcl	    ip_p_position_info_ptr ptr parameter;

      dcl	    1 ip_p_position_info   based (ip_p_position_info_ptr) aligned like position_info;

      ip_p_position_info.node_ptr = null;
      ip_p_position_info.entire_vector_ptr = null;
      ip_p_position_info.selected_vector_ptr = null;
      ip_p_position_info.lk_string_length = 0;
      ip_p_position_info.node_id = 0;
      ip_p_position_info.slot_index = 0;
      string (ip_p_position_info.flags) = "0"b;
      ip_p_position_info.index_cursor_ptr = ip_p_index_cursor_ptr;
      ip_p_position_info.key_buffer_length = ip_p_key_buffer_length;
      ip_p_position_info.key_buffer_ptr = ip_p_key_buffer_ptr;
      ip_p_position_info.header_buffer_length = ip_p_header_buffer_length;
      ip_p_position_info.header_buffer_ptr = ip_p_header_buffer_ptr;
      ip_p_position_info.field_table_ptr = ip_p_field_table_ptr;
      ip_p_position_info.work_area_ptr = ip_p_work_area_ptr;
      ip_p_position_info.first_key_id_string = ip_p_first_key_id_string;
      ip_p_position_info.last_key_id_string = ip_p_last_key_id_string;
      ip_p_position_info.id_list_ptr = ip_p_id_list_ptr;


      if ip_p_get_keys_in_reverse_order
      then
         do;
	  call SET_NODE_ID ((addr (ip_p_last_key_id_string) -> element_id.control_interval_id), ip_p_position_info_ptr);
	  call SET_SLOT_INDEX ((addr (p_last_key_id_string) -> element_id.index), ip_p_position_info_ptr);
         end;
      else
         do;
	  call SET_NODE_ID ((addr (ip_p_first_key_id_string) -> element_id.control_interval_id), ip_p_position_info_ptr)
	       ;
	  call SET_SLOT_INDEX ((addr (ip_p_first_key_id_string) -> element_id.index), ip_p_position_info_ptr);
         end;


   end INITIALIZE_POSITION;
%page;
INTERPRET_SPECIFICATION:
   proc (is_p_specification_head_ptr, is_p_first_key_id_string, is_p_is_search_specification,
        is_p_search_specification_ptr, is_p_numeric_specification_ptr, is_p_get_keys_in_reverse_order, is_p_range_size,
        is_p_position_count);

      dcl	    is_p_specification_head_ptr
			       ptr parameter;
      dcl	    is_p_first_key_id_string
			       bit (36) aligned parameter;
      dcl	    is_p_is_search_specification
			       bit (1) aligned parameter;
      dcl	    is_p_search_specification_ptr
			       ptr parameter;
      dcl	    is_p_numeric_specification_ptr
			       ptr parameter;
      dcl	    is_p_get_keys_in_reverse_order
			       bit (1) aligned parameter;
      dcl	    is_p_range_size	       fixed bin (35) parameter;
      dcl	    is_p_position_count    fixed bin (35) parameter;


      if is_p_specification_head_ptr -> specification_head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE
	 | is_p_specification_head_ptr -> specification_head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE
      then
         do;
	  is_p_is_search_specification = "1"b;
	  is_p_search_specification_ptr = is_p_specification_head_ptr;
	  is_p_get_keys_in_reverse_order =
	       (is_p_first_key_id_string = "0"b
	       | is_p_search_specification_ptr -> search_specification.range.type = HIGH_RANGE_TYPE);
	  is_p_range_size = is_p_search_specification_ptr -> search_specification.range.size;
         end;
      else if is_p_specification_head_ptr -> specification_head.type = ABSOLUTE_NUMERIC_SPECIFICATION_TYPE
	      | is_p_specification_head_ptr -> specification_head.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE
      then
         do;
	  is_p_is_search_specification = "0"b;
	  is_p_numeric_specification_ptr = is_p_specification_head_ptr;
	  is_p_get_keys_in_reverse_order =
	       (is_p_numeric_specification_ptr -> numeric_specification.position_number < 0);
	  is_p_range_size = is_p_numeric_specification_ptr -> numeric_specification.range_size;
	  is_p_position_count = abs (is_p_numeric_specification_ptr -> numeric_specification.position_number);
         end;
      else call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/The specification structure does not have a recognizable type.  
Recognized types are ^d, ^d, ^d, or ^d.  Received type was ^d.", ABSOLUTE_SEARCH_SPECIFICATION_TYPE,
	      RELATIVE_SEARCH_SPECIFICATION_TYPE, ABSOLUTE_NUMERIC_SPECIFICATION_TYPE,
	      RELATIVE_NUMERIC_SPECIFICATION_TYPE, is_p_specification_head_ptr -> specification_head.type);

   end INTERPRET_SPECIFICATION;
%page;
NODE_IS_DELETED:
   proc (nie_p_position_info_ptr) returns (bit (1) aligned);
      dcl	    nie_p_position_info_ptr
			       ptr parameter;

      return (nie_p_position_info_ptr -> position_info.node_is_deleted);
   end NODE_IS_DELETED;



NOTE_NODE_IS_DELETED:
   proc (nnid_p_position_info_ptr);
      dcl	    nnid_p_position_info_ptr
			       ptr parameter;

      nnid_p_position_info_ptr -> position_info.node_is_deleted = "1"b;
      nnid_p_position_info_ptr -> position_info.node_ptr = null;
   end NOTE_NODE_IS_DELETED;


NOTE_VECTOR_IN_USE:
   proc (nviu_p_position_info_ptr);
      dcl	    nviu_p_position_info_ptr
			       ptr parameter;

      nviu_p_position_info_ptr -> position_info.vector_in_use = "1"b;
   end NOTE_VECTOR_IN_USE;
%page;
RESET_CI_HEADER:
   proc (rch_p_position_info_ptr);
      dcl	    rch_p_position_info_ptr
			       ptr parameter;
      rch_p_position_info_ptr -> position_info.header_buffer_contains_current_header = "0"b;
   end RESET_CI_HEADER;


RESET_KEY:
   proc (rk_p_position_info_ptr);
      dcl	    rk_p_position_info_ptr ptr parameter;
      call RESET_VECTORS (rk_p_position_info_ptr);
      rk_p_position_info_ptr -> position_info.key_buffer_contains_current_key = "0"b;
      rk_p_position_info_ptr -> position_info.lk_string_length = 0;
   end RESET_KEY;


RESET_NODE_ID:
   proc (rni_p_position_info_ptr);

      dcl	    rni_p_position_info_ptr
			       ptr parameter;

      rni_p_position_info_ptr -> position_info.node_id = 0;
      rni_p_position_info_ptr -> position_info.node_is_deleted = "0"b;

      call RESET_CI_HEADER (rni_p_position_info_ptr);
      call RESET_NODE_PTR (rni_p_position_info_ptr);
      call RESET_SLOT_INDEX (rni_p_position_info_ptr);

   end RESET_NODE_ID;


RESET_NODE_PTR:
   proc (rnp_p_position_info_ptr);
      dcl	    rnp_p_position_info_ptr
			       ptr parameter;
      rnp_p_position_info_ptr -> position_info.node_ptr = null ();
   end RESET_NODE_PTR;


RESET_SLOT_INDEX:
   proc (rsi_p_position_info_ptr);
      dcl	    rsi_p_position_info_ptr
			       ptr parameter;
      call RESET_KEY (rsi_p_position_info_ptr);
      rsi_p_position_info_ptr -> position_info.slot_index = 0;
   end RESET_SLOT_INDEX;
%page;
RESET_VECTORS:
   proc (rv_p_position_info_ptr);
      dcl	    rv_p_position_info_ptr ptr parameter;

      dcl	    1 rv_p_position_info   based (rv_p_position_info_ptr) aligned like position_info;

/* If the entire and selected vectors are the same vector, avoid trying to free
it twice (or freeing it as the entire_vector when the vector, as the
selected_vector, should not be freed because it is in the output array)
by setting the entire_vector_ptr to null.
*/

      if rv_p_position_info.entire_vector_ptr = rv_p_position_info.selected_vector_ptr
      then rv_p_position_info.entire_vector_ptr = null;

      if rv_p_position_info.entire_vector_ptr ^= null
      then call FREE_ENTIRE_VECTOR (rv_p_position_info.entire_vector_ptr);

      if ^rv_p_position_info.vector_in_use & rv_p_position_info.selected_vector_ptr ^= null
      then call FREE_ENTIRE_VECTOR (rv_p_position_info.selected_vector_ptr);

      rv_p_position_info.selected_vector_ptr = null;
      rv_p_position_info.entire_vector_ptr = null;
      rv_p_position_info.vector_in_use = "0"b;

   end RESET_VECTORS;
%page;
REVERSE_VECTOR_SLOTS:
   proc (rvs_p_input_number_of_keys_accepted, rvs_p_typed_vector_array_ptr);
      dcl	    rvs_p_input_number_of_keys_accepted
			       fixed bin (35) parameter;
      dcl	    rvs_p_typed_vector_array_ptr
			       ptr parameter;

      dcl	    rvs_vector_slot_idx    fixed bin (35) init (0);
      dcl	    rvs_vector_ptr	       ptr init (null);

      do rvs_vector_slot_idx = rvs_p_input_number_of_keys_accepted + 1
	 to
	 divide (rvs_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors
	 - rvs_p_input_number_of_keys_accepted, 2, 35, 0) + rvs_p_input_number_of_keys_accepted;
         rvs_vector_ptr = rvs_p_typed_vector_array_ptr -> typed_vector_array.vector_slot (rvs_vector_slot_idx);
         rvs_p_typed_vector_array_ptr -> typed_vector_array.vector_slot (rvs_vector_slot_idx) =
	    rvs_p_typed_vector_array_ptr
	    -> typed_vector_array
	    .
	    vector_slot (rvs_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors - rvs_vector_slot_idx + 1)
	    ;
         rvs_p_typed_vector_array_ptr
	    -> typed_vector_array
	    .
	    vector_slot (rvs_p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors - rvs_vector_slot_idx + 1)
	    = rvs_vector_ptr;
      end;
   end REVERSE_VECTOR_SLOTS;
%page;
SEARCH_SPEC_COMPARISON:
   proc (sesc_p_search_specification_ptr, sesc_p_and_group_id_list_ptr, sesc_p_number_of_fully_structural_fields,
        sesc_p_partial_structural_field_id, sesc_p_position_info_ptr, sesc_p_key_satisfies_specification);

      dcl	    sesc_p_search_specification_ptr
			       ptr parameter;
      dcl	    sesc_p_and_group_id_list_ptr
			       ptr parameter;
      dcl	    sesc_p_number_of_fully_structural_fields
			       fixed bin parameter;
      dcl	    sesc_p_partial_structural_field_id
			       fixed bin (17) parameter;
      dcl	    sesc_p_position_info_ptr
			       ptr parameter;
      dcl	    sesc_p_key_satisfies_specification
			       bit (1) aligned parameter;

      dcl	    sesc_code	       fixed bin (35) init (0);
      dcl	    sesc_field_table_ptr   ptr init (null);
      dcl	    sesc_leaf_key_ptr      ptr init (null);
      dcl	    sesc_lk_string_length  fixed bin (35) init (0);



      call GET_FIELD_TABLE (sesc_p_position_info_ptr, sesc_field_table_ptr);

      if (sesc_p_search_specification_ptr -> search_specification.number_of_and_groups = 0
	 & sesc_p_and_group_id_list_ptr = null)
	 | (sesc_p_number_of_fully_structural_fields = sesc_field_table_ptr -> field_table.number_of_fields)
      then sesc_p_key_satisfies_specification = "1"b;
      else
         do;
	  call GET_KEY (sesc_p_position_info_ptr, sesc_leaf_key_ptr, sesc_lk_string_length);

	  lk_string_length = sesc_lk_string_length;	/* The global variable lk_string_length is used here because leaf_key references it. */
	  call data_format_util_$compare_sequential (sesc_field_table_ptr, sesc_p_search_specification_ptr,
	       sesc_p_and_group_id_list_ptr, sesc_p_number_of_fully_structural_fields,
	       sesc_p_partial_structural_field_id, sesc_leaf_key_ptr -> leaf_key.string,
	       sesc_p_key_satisfies_specification, sesc_code);
	  if sesc_code ^= 0
	  then call ERROR_RETURN (sesc_code);
         end;

   end SEARCH_SPEC_COMPARISON;
%page;
SET_INDEX_CURSOR:
   proc (sc_p_operation, sc_p_position_info_ptr);

      dcl	    sc_p_operation	       fixed bin parameter;
      dcl	    sc_p_position_info_ptr ptr parameter;

      dcl	    sc_code	       fixed bin (35) init (0);
      dcl	    sc_index_cursor_ptr    ptr;
      dcl	    sc_leaf_ci_header_ptr  ptr;
      dcl	    1 sc_leaf_ci_header    based (sc_leaf_ci_header_ptr) like leaf_ci_header;
      dcl	    sc_leaf_key_ptr	       ptr;
      dcl	    sc_lk_string_length    fixed bin (35);
      dcl	    sc_node_id	       fixed bin (24) unsigned;
      dcl	    sc_slot_index	       fixed bin (12) unsigned;

      dcl	    sc_element_id_string   bit (36) aligned;
      dcl	    1 sc_element_id	       based (addr (sc_element_id_string)) like element_id;


      call GET_INDEX_CURSOR (sc_p_position_info_ptr, sc_index_cursor_ptr);
      call GET_CI_HEADER (sc_p_position_info_ptr, sc_leaf_ci_header_ptr);
      call GET_KEY (sc_p_position_info_ptr, sc_leaf_key_ptr, sc_lk_string_length);
      call GET_NODE_ID (sc_p_position_info_ptr, sc_node_id);
      call GET_SLOT_INDEX (sc_p_position_info_ptr, sc_slot_index);

      sc_element_id.control_interval_id = sc_node_id;
      sc_element_id.index = sc_slot_index;

      if sc_p_operation = GET_OPERATION
      then
         do;
	  call im_set_cursor$at_current (sc_index_cursor_ptr, sc_element_id_string, sc_leaf_key_ptr,
	       (sc_lk_string_length), sc_code);
	  if sc_code ^= 0
	  then call ERROR_RETURN (sc_code);
         end;
      else if sc_p_operation = POSITION_OPERATION
      then
         do;
	  call GET_KEY (sc_p_position_info_ptr, sc_leaf_key_ptr, sc_lk_string_length);
	  call im_set_cursor$at_current (sc_index_cursor_ptr, sc_element_id_string, sc_leaf_key_ptr,
	       (sc_lk_string_length), sc_code);
	  if sc_code ^= 0
	  then call ERROR_RETURN (sc_code);
         end;
      else if sc_p_operation = DELETE_OPERATION
      then
         do;
	  if sc_slot_index > sc_leaf_ci_header.common.key_range.last | NODE_IS_DELETED (sc_p_position_info_ptr)
	  then
	     do;
	        sc_node_id = sc_leaf_ci_header.common.next_id;
	        call SET_NODE_ID (sc_node_id, sc_p_position_info_ptr);
	        if sc_node_id ^= 0
	        then
		 do;
		    call GET_CI_HEADER (sc_p_position_info_ptr, sc_leaf_ci_header_ptr);
		    sc_slot_index = sc_leaf_ci_header.common.key_range.first;
		    call SET_SLOT_INDEX (sc_slot_index, sc_p_position_info_ptr);
		 end;

	     end;
	  if sc_node_id > 0
	  then
	     do;
	        call GET_KEY (sc_p_position_info_ptr, sc_leaf_key_ptr, sc_lk_string_length);

	        sc_element_id.control_interval_id = sc_node_id;
	        sc_element_id.index = sc_slot_index;

	        call im_set_cursor$at_current (sc_index_cursor_ptr, sc_element_id_string, sc_leaf_key_ptr,
		   (sc_lk_string_length), sc_code);
	        if sc_code ^= 0
	        then call ERROR_RETURN (sc_code);
	     end;
	  else
	     do;
	        call im_set_cursor$at_end (sc_index_cursor_ptr, "0"b, null, 0, sc_code);
	        if sc_code ^= 0
	        then call ERROR_RETURN (sc_code);
	     end;
         end;
   end SET_INDEX_CURSOR;
%page;
SET_NODE_ID:
   proc (sni_p_node_id, sni_p_position_info_ptr);

/* This subroutine sets the current node id and gets a pointer to it. */

      dcl	    sni_p_node_id	       fixed bin (24) unsigned;
      dcl	    sni_p_position_info_ptr
			       ptr parameter;

      if sni_p_position_info_ptr -> position_info.node_id > 0
      then call RESET_NODE_ID (sni_p_position_info_ptr);

      sni_p_position_info_ptr -> position_info.node_id = sni_p_node_id;
   end SET_NODE_ID;



SET_SLOT_INDEX:
   proc (ssi_p_slot_index, ssi_p_position_info_ptr);
      dcl	    ssi_p_slot_index       fixed bin (12) unsigned parameter;
      dcl	    ssi_p_position_info_ptr
			       ptr parameter;

      if ssi_p_position_info_ptr -> position_info.slot_index > 0
      then call RESET_SLOT_INDEX (ssi_p_position_info_ptr);

      ssi_p_position_info_ptr -> position_info.slot_index = ssi_p_slot_index;


   end SET_SLOT_INDEX;
%page;
/* This procedure determines if there is a "next" key, and, if so, it advances
the current position to that next key.
*/

SETUP_NEXT_KEY:
   proc (snk_p_operation, snk_p_is_search_specification, snk_p_range_size, snk_p_get_keys_in_reverse_order,
        snk_p_key_satisfies_specification, snk_p_position_info_ptr, snk_p_number_of_keys_accepted, snk_p_finished);

      dcl	    snk_p_operation	       fixed bin parameter;
      dcl	    snk_p_is_search_specification
			       bit (1) aligned parameter;
      dcl	    snk_p_range_size       fixed bin (35) parameter;
      dcl	    snk_p_get_keys_in_reverse_order
			       bit (1) aligned parameter;
      dcl	    snk_p_key_satisfies_specification
			       bit (1) aligned parameter;
      dcl	    snk_p_position_info_ptr
			       ptr parameter;
      dcl	    snk_p_number_of_keys_accepted
			       fixed bin (35) parameter;
      dcl	    snk_p_finished	       bit (1) aligned parameter;


      dcl	    snk_leaf_ci_header_ptr ptr init (null);
      dcl	    1 snk_leaf_ci_header   based (snk_leaf_ci_header_ptr) like leaf_ci_header;
      dcl	    snk_node_id	       fixed bin (24) unsigned;
      dcl	    snk_position_change    fixed bin (35) init (0);
      dcl	    snk_slot_index	       fixed bin (12) unsigned;

      snk_p_finished = "0"b;

      if snk_p_range_size > 0 & snk_p_number_of_keys_accepted = snk_p_range_size
      then
         do;
	  snk_p_finished = "1"b;
	  return;
         end;
      else
REALLY_LOOK:
         do;

	  call GET_NODE_ID (snk_p_position_info_ptr, snk_node_id);
	  call GET_SLOT_INDEX (snk_p_position_info_ptr, snk_slot_index);
	  call GET_CI_HEADER (snk_p_position_info_ptr, snk_leaf_ci_header_ptr);

	  if snk_p_is_search_specification
	  then
	     do;
	        if snk_p_get_keys_in_reverse_order
	        then
		 do;
		    snk_position_change = 1;
		    if BEFORE_BEGINNING (snk_p_position_info_ptr, snk_node_id, snk_slot_index - snk_position_change)
		    then
		       do;
			snk_p_finished = "1"b;
			return;
		       end;
		    else if snk_slot_index - snk_position_change >= snk_leaf_ci_header.common.key_range.first
		    then call SET_SLOT_INDEX (snk_slot_index - snk_position_change, snk_p_position_info_ptr);
		    else
		       do;
			call SET_NODE_ID ((snk_leaf_ci_header.common.previous_id), snk_p_position_info_ptr);
			call GET_CI_HEADER (snk_p_position_info_ptr, snk_leaf_ci_header_ptr);

			call SET_SLOT_INDEX ((snk_leaf_ci_header.common.key_range.last), snk_p_position_info_ptr);
		       end;
		 end;
	        else
		 do;
		    snk_position_change = bin (snk_p_operation ^= DELETE_OPERATION);
		    if AFTER_END (snk_p_position_info_ptr, snk_node_id, snk_slot_index + snk_position_change)
		         | (snk_p_operation = POSITION_OPERATION & snk_p_key_satisfies_specification)
		    then
		       do;
			snk_p_finished = "1"b;
			return;
		       end;
		    else if snk_slot_index + snk_position_change <= snk_leaf_ci_header.common.key_range.last
			    & snk_slot_index ^= 0
		    then call SET_SLOT_INDEX (snk_slot_index + snk_position_change, snk_p_position_info_ptr);
		    else
		       do;
			call SET_NODE_ID ((snk_leaf_ci_header.common.next_id), snk_p_position_info_ptr);
			call GET_CI_HEADER (snk_p_position_info_ptr, snk_leaf_ci_header_ptr);
			call SET_SLOT_INDEX ((DEFAULT_INITIAL_KEY_SLOT), snk_p_position_info_ptr);
		       end;
		 end;
	     end;
	  else
FINISH_NUMERIC:
	     do;
	        if snk_p_range_size = 0 & snk_p_key_satisfies_specification
	        then
		 do;
		    snk_p_finished = "1"b;
		    return;
		 end;

	        else if snk_p_get_keys_in_reverse_order
	        then
		 do;
		    snk_position_change = 1;
		    if BEFORE_BEGINNING (snk_p_position_info_ptr, snk_node_id, snk_slot_index - snk_position_change)
		    then
		       do;
			snk_p_finished = "1"b;
			return;
		       end;
		    else if snk_slot_index - snk_position_change >= snk_leaf_ci_header.common.key_range.first
		    then call SET_SLOT_INDEX (snk_slot_index - snk_position_change, snk_p_position_info_ptr);
		    else
		       do;
			call SET_NODE_ID ((snk_leaf_ci_header.common.previous_id), snk_p_position_info_ptr);
			call GET_CI_HEADER (snk_p_position_info_ptr, snk_leaf_ci_header_ptr);

			call SET_SLOT_INDEX ((snk_leaf_ci_header.common.key_range.last), snk_p_position_info_ptr);
		       end;
		 end;
	        else
		 do;
		    snk_position_change = bin (snk_p_operation ^= DELETE_OPERATION);
		    if AFTER_END (snk_p_position_info_ptr, snk_node_id, snk_slot_index + snk_position_change)
		    then
		       do;
			snk_p_finished = "1"b;
			return;
		       end;
		    else if snk_slot_index + snk_position_change <= snk_leaf_ci_header.common.key_range.last
			    & snk_slot_index ^= 0
		    then call SET_SLOT_INDEX (snk_slot_index + snk_position_change, snk_p_position_info_ptr);
		    else
		       do;
			call SET_NODE_ID ((snk_leaf_ci_header.common.next_id), snk_p_position_info_ptr);
			call GET_CI_HEADER (snk_p_position_info_ptr, snk_leaf_ci_header_ptr);

			call SET_SLOT_INDEX ((snk_leaf_ci_header.common.key_range.first), snk_p_position_info_ptr);
		       end;
		 end;
	     end FINISH_NUMERIC;
         end REALLY_LOOK;
   end SETUP_NEXT_KEY;
%page;
/* This procedure determines if the current key satisfies the subset
specification.
*/

SUBSET_SPEC_COMPARISON:
   proc (susc_p_subset_specification_ptr, susc_p_position_info_ptr, susc_p_key_satisfies_specification);

      dcl	    susc_p_subset_specification_ptr
			       ptr parameter;
      dcl	    susc_p_position_info_ptr
			       ptr parameter;
      dcl	    susc_p_key_satisfies_specification
			       bit (1) aligned parameter;

      dcl	    susc_code	       fixed bin (35) init (0);
      dcl	    susc_vector_ptr	       ptr init (null);
      dcl	    susc_work_area_ptr     ptr;

      call GET_ENTIRE_VECTOR (susc_p_position_info_ptr, susc_vector_ptr);

      call GET_WORK_AREA (susc_p_position_info_ptr, susc_work_area_ptr);

      call im_compare_subset (susc_p_subset_specification_ptr, susc_vector_ptr, susc_work_area_ptr,
	 susc_p_key_satisfies_specification, NULL_PSEUDO_FIELD_VALUE, susc_code);
      if susc_code ^= 0
      then call ERROR_RETURN (susc_code);
   end SUBSET_SPEC_COMPARISON;
%page;
%page;
%include dm_im_cursor;
%page;
%include vu_typed_vector_array;
%page;
%include sub_err_flags;
%page;
%include dm_element_id;
%page;
%include dm_im_ci_header;
%page;
%include dm_im_key;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_specification;
%page;
%include dm_specification_head;
%page;
%include dm_range_constants;
%page;
%include dm_field_table;
%page;
%include dm_ci_lengths;
%page;
%include vu_typed_vector;
   end im_process_keys$get;




		    im_put_key.pl1                  07/17/87  1232.2rew 07/17/87  1056.6      153729



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


/*  DESCRIPTION:
     This module puts keys into an index collection.  

          If the index is empty, a "node" is created and the key(s) is
     inserted into it.

          Otherwise, the existing index is searched for the key to be "put".
     If the key is found (and duplicates aren't allowed) then an error is
     noted and the module returns to its caller.

          If the key was not found, then an attempt is made to insert the new
     key at the location specified by the im_search_$location operation.  If
     this attempt succeeds then the task is completed and the module returns
     to its caller.

          If there isn't room in the "target" control interval for the new
     key, then sufficient keys are "rotated" into the left-sibling control
     interval to make room for the new key.  This rotation may move the
     location of the new key into the left-sibling control interval, making
     the left-sibling the target control interval.  The branching key which
     divides the two nodes being rotated between is updated  to reflect the
     new values in the rotated nodes.  If not enough room can be made in this
     fashion for the new key, then the procedure is repeated on the
     right-sibling.

          If there isn't room for the new key in either the left or right
     sibling nodes, then the original target node is "split".  Half of its
     keys are moved into a new node, which becomes its new right sibling.  The
     new key is inserted into the appropriate one of the nodes involved in the
     split, and a new branching key is added to the parent node of the
     original target node.  

          In those cases where a branching key is added or changed, the new
     value is put into the parent node using the same algorithm outlined above
     for inserting a new leaf key.  This may cause splits to take place all
     the way up to the root of the tree (index).  When the root splits, a new
     root is created to go above it, and the index has grown a level deeper.
*/

/* HISTORY:
Written by Lindsey Spratt, 04/01/82
Modified:
06/30/82 by Lindsey Spratt: Changed to use im_basic_search instead of
	  im_search_$location (which is  now obsolete).
07/27/82 by Lindsey Spratt: Changed to use
	  index_header.number_of_duplication_fields to enforce the
	  duplication constraint for the index.
08/02/82 by Lindsey Spratt:  Changed to use the new calling sequence for
	  im_compare_vector_and_key.  There is now an argument (which is
	  ignored) which identifies the first field which is not-equal.
08/09/82 by Matthew Pierret:  Changed to use calling sequence of 
            collection_manager_$get_element which does not require specifying
            offset and length. Changed use of 0 for header collection id to
            HEADER_COLLECTION_ID, a constant declared in dm_cm_header.incl.pl1.
            Also added that include file.
08/19/82 by Lindsey Spratt:  Added the array entry point.  Created the
	  put_vector internal subroutine.
08/27/82 by Lindsey Spratt:  Changed to use the new calling sequence to
	  im_basic_search.
08/30/82 by Lindsey Spratt:  Changed to set the cursor to the last
	  successfully "put" key.  Changed the calling sequence of
	  im_initial_insert to return the element_id of the key inserted.
10/13/82 by Matthew Pierret:  Changed to initialize key_string_buffer to "0"b;
11/02/82 by Lindsey Spratt:  Changed to use new calling sequence of
	  im_initial_insert; removing cursor_ptr and index_header_ptr and
	  adding the index_opening_info_ptr.  Changed to set
	  key_count_array.count(0) to 1 when doing the initial_insert rather
	  than invoking im_update_key_counts.  Capitalized internal
	  procedure names.
11/04/82 by Lindsey Spratt:  Changed to use the insert entry of
	  im_basic_search.  This returns the maximum_duplication_field for
	  the given insertion, which interval_specification used to update
	  the key_count_array.
12/09/82 by Lindsey Spratt:  Changed to use the dm_key_count_array incl file.
12/22/82 by Lindsey Spratt:  Changed to use 
	  data_mgmt_util_$cv_vector_to_string.
02/28/83 by Lindsey Spratt:  Changed to use version 3 index_cursor, and to set
	  the cursor using im_set_cursor.
03/24/83 by Lindsey Spratt:  Changed to use version 2 of the field_table.
	  Changed im_compare* to data_mgmt_util_$compare.
09/20/83 by Lindsey L. Spratt:  Fixed to free the key_count_array.  Changed to
            use the ERROR_RETURN and FINISH protocol (eliminating code-passing
            for internal procedures).  Added the internal_debug_sw which can
            be set via the $debug_on and $debug_off entries.  This controls
            the check of the conversion from the vector to the string format.
            (Off by default.)  Changed to not initialize the key_string_buffer.
03/21/84 by Matthew Pierret:  Changed im_basic_search$insert to 
            im_basic_search_insert.
04/09/84 by Matthew Pierret:  Changed im_basic_search_insert to
            im_basic_search$insert.  Jeez, I wish these guys would make up
            their minds.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3, to use
            get_dm_free_area_ instead of get_system_free_area_, and to remove
            un-used variables.
05/10/84 by Matthew Pierret:  Changed to align key_string_buffer on an
            even-word boundary.  Changed references to data_mgmt_util_ to be
            to data_format_util_.  Removed the put_key procedure label.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 of
            index_opening_info, and version 2 of key_count_array.
12/03/84 by Matthew Pierret:  Changed to use dm_hdr_collection_id.incl.pl1
            instead of the obsolete dm_cm_header.incl.pl1.
*/

/****^  HISTORY COMMENTS:
  1) change(87-05-06,Dupuis), approve(87-05-29,MCR7695), audit(87-06-02,Blair),
     install(87-07-17,MR12.1-1042):
     Changed the buffer alignment so that key.string would be on a double-word
     boundary. The key string was being aligned on an odd-word boundary and
     this was causing bad comparisons when dealing with fields that needed to
     be aligned on double-word boundaries.
                                                   END HISTORY COMMENTS */


/* format: style2,ind3 */

im_put_key:
   proc (p_typed_vector_ptr, p_cursor_ptr, p_code);

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

      dcl	    p_typed_vector_ptr     ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_cursor_ptr	       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    1 local_leaf_ci_header like leaf_ci_header;
      dcl	    maximum_duplication_field
			       fixed bin;

      dcl	    (vector_idx, count_idx)
			       fixed bin (35);
      dcl	    use_array	       bit (1) aligned init ("0"b);
      dcl	    vector_equal_to_key    bit (1) aligned;
      dcl	    vector_less_than_key   bit (1) aligned;
      dcl	    myname	       char (32) init ("im_put_key") varying;
      dcl	    key_string_buffer      (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
						/* Forces even-word alignment */
      dcl	    key_string_buffer_length /* Force key.string to double-word boundary */
			       fixed bin (35) init (BITS_PER_PAGE - BITS_PER_WORD);

      dcl	    key_string_ptr	       ptr;

      dcl	    1 key_element_id       like element_id aligned;

/* Based */

      dcl	    work_area	       based (work_area_ptr) area;

      dcl	    1 key		       based (key_string_ptr),
	      2 length	       fixed bin (35),
	      2 string	       bit (0 refer (key.length));

      dcl	    key_element_id_string  bit (36) aligned based (addr (key_element_id));

/* Builtin */

      dcl	    (null, addr, length)   builtin;

/* Controlled */
/* Constant */

      dcl	    INSERT_KEY	       init ("1"b) bit (1) aligned internal static options (constant);
      dcl	    ALL_FIELDS_ARE_PRESENT init (-1) fixed bin (17) unal internal static options (constant);
      dcl	    BITS_PER_PAGE	       init (1024 * 36) fixed bin (35) internal static options (constant);
      dcl	    BITS_PER_WORD	       init (36) fixed bin (35) internal static options (constant);
      dcl	    DOUBLE_WORDS_PER_PAGE  init (512) fixed bin (17) internal static options (constant);

/* Entry */

      dcl	    im_get_opening_info    entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    im_update_opening_info$key_count_array
			       entry (ptr, ptr, fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);
      dcl	    data_format_util_$cv_vector_to_string
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35), fixed bin (35));
      dcl	    data_format_util_$compare_vector_to_string
			       entry (ptr, ptr, ptr, fixed bin (24), fixed bin unal, fixed bin, bit (1) aligned,
			       bit (1) aligned, fixed bin (35));
      dcl	    im_initial_insert      entry (ptr, bit (*), bit (36) aligned, fixed bin (35));
      dcl	    im_general_insert      entry (ptr, ptr, bit (1) aligned, bit (*), bit (36) aligned, fixed bin (35));
      dcl	    im_basic_search$insert entry (ptr, ptr, ptr, bit (36) aligned, fixed bin, ptr, fixed bin (35));
      dcl	    im_set_cursor$at_current
			       entry (ptr, bit (36) aligned, ptr, fixed bin (24), fixed bin (35));

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$key_duplication,
	    dm_error_$wrong_cursor_type,
	    dm_error_$key_not_found,
	    dm_error_$programming_error
	    )		       fixed bin (35) ext;

/* Internal Static */

      dcl	    work_area_ptr	       ptr init (null) internal static;
      dcl	    internal_debug_sw      bit (1) aligned init ("0"b) internal static;

/* END OF DECLARATIONS */

      typed_vector_array_ptr = null;
      use_array = "0"b;
      goto JOIN;

array:
   entry (p_typed_vector_array_ptr, p_cursor_ptr, p_code);
      typed_vector_array_ptr = p_typed_vector_array_ptr;
      use_array = "1"b;
      goto JOIN;

debug_on:
   entry ();
      internal_debug_sw = "1"b;
      return;

debug_off:
   entry ();
      internal_debug_sw = "0"b;
      return;

JOIN:
      if work_area_ptr = null
      then work_area_ptr = get_dm_free_area_ ();

      index_cursor_ptr = p_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected an index cursor, type ^d.  Recieved a cursor of type ^d instead.", INDEX_CURSOR_TYPE,
	      index_cursor.type);

      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      call im_get_opening_info (index_cursor.file_opening_id, index_cursor.collection_id, index_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      index_header_ptr = index_opening_info.index_header_ptr;
      call CHECK_VERSION_CHAR (index_header.version, INDEX_HEADER_VERSION_4, "index_header");

      field_table_ptr = index_opening_info.field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      call CHECK_VERSION_CHAR (index_opening_info.key_count_array_ptr -> key_count_array.version,
	 KEY_COUNT_ARRAY_VERSION_2, "key_count_array");

      kca_number_of_counts = index_opening_info.key_count_array_ptr -> key_count_array.number_of_counts;
      alloc key_count_array in (work_area);
      key_count_array = index_opening_info.key_count_array_ptr -> key_count_array;

      if use_array
      then
         do vector_idx = 1 to typed_vector_array.number_of_vectors;
	  call PUT_VECTOR ((typed_vector_array.vector_slot (vector_idx)));
	  call im_set_cursor$at_current (index_cursor_ptr, key_element_id_string, addr (key.string),
	       length (key.string), p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);
         end;
      else
         do;
	  call PUT_VECTOR (p_typed_vector_ptr);
	  call im_set_cursor$at_current (index_cursor_ptr, key_element_id_string, addr (key.string),
	       length (key.string), p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);
         end;

      call im_update_opening_info$key_count_array (index_opening_info_ptr, key_count_array_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      call FINISH;

MAIN_RETURN:
      return;					/* Effective end of im_put_key */
%page;
FINISH:
   proc;
      if key_count_array_ptr ^= null
      then free key_count_array;
   end FINISH;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      p_code = er_p_code;
      call FINISH;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
PUT_VECTOR:
   proc (pv_p_vector_ptr);
      dcl	    pv_p_vector_ptr	       ptr;
      dcl	    pv_code	       fixed bin (35);

      call data_format_util_$cv_vector_to_string (field_table_ptr, pv_p_vector_ptr, addrel (addr (key_string_buffer), 1),
	 key_string_buffer_length, null, key_string_ptr, (0), pv_code);
      if pv_code ^= 0
      then call ERROR_RETURN (pv_code);

      if internal_debug_sw
      then
         do;					/* Validate that the converted string is equal to the vector from which it was created. */
	  call data_format_util_$compare_vector_to_string (field_table_ptr, pv_p_vector_ptr, addr (key.string),
	       (key.length), ALL_FIELDS_ARE_PRESENT, (0), vector_equal_to_key, vector_less_than_key, pv_code);
	  if pv_code ^= 0
	  then call sub_err_ (pv_code, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Unable to compare the input typed_vector and its converted bit string form.");
	  else if ^vector_equal_to_key
	  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The input typed vector does not compare equal to its internal bit string form.");
         end;

      if index_header.root_id = 0			/* Canonical value meaning no root has been allocated. */
      then
         do;
	  call im_initial_insert (index_opening_info_ptr, key.string, key_element_id_string, pv_code);
	  if pv_code ^= 0
	  then call ERROR_RETURN (pv_code);
	  key_count_array.count (0) = 1;
         end;
      else call SEARCH_AND_INSERT;
      return;
%page;
SEARCH_AND_INSERT:
   proc;
      dcl	    sai_code	       fixed bin (35);

      call im_basic_search$insert (index_opening_info_ptr, p_cursor_ptr, pv_p_vector_ptr, key_element_id_string,
	 maximum_duplication_field, addr (local_leaf_ci_header), sai_code);
      if sai_code = 0
      then call ERROR_RETURN (dm_error_$key_duplication);
      else if sai_code ^= dm_error_$key_not_found
      then call ERROR_RETURN (sai_code);

      call im_general_insert (index_opening_info_ptr, addr (local_leaf_ci_header), INSERT_KEY, key.string,
	 key_element_id_string, sai_code);
      if sai_code ^= 0
      then call ERROR_RETURN (sai_code);

      do count_idx = 0 to maximum_duplication_field;
         key_count_array.count (count_idx) = key_count_array.count (count_idx) + 1;
      end;

   end SEARCH_AND_INSERT;
   end PUT_VECTOR;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure. Received version ^d instead.", p_expected_version,
	      p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_expected_version, p_received_version, p_structure_name);
      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
%include dm_im_cursor;
%page;
%include dm_im_header;
%page;
%include dm_element_id;
%page;
%include dm_im_ci_header;
%page;
%include dm_hdr_collection_id;
%page;
%include vu_typed_vector_array;
%page;
%include sub_err_flags;
%page;
%include dm_im_opening_info;
%page;
%include dm_field_table;
%page;
%include dm_key_count_array;
%page;
%include dm_collmgr_entry_dcls;
   end im_put_key;




		    im_rotate_insert.pl1            04/04/85  1109.9re  04/04/85  0823.4      665811



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

/* DESCRIPTION

          This module attempts to make room in the node control interval in
     which the new key is to be inserted by moving keys, one-at-a-time, from
     the lower numbered slots of the new key's node into the previous node.
     Keys are rotated until:
          1) enough room is made in the new key's node to
	   insert the new key;
	2) there is no more room in the previous node to
	   rotate keys into it; or,
	3) all of the lower-slot keys have been rotated.
     
          The first case is a successful rotation, and this module is done.

          The second case indicates that the  "rotate_previous" can not
     (ultimately) succeed in finding room to insert the new key, and this
     module has "failed", also indicating the module is done.

          The third case requires further investigation.  Either the new key
     will fit in the "previous" node or it won't.  In the former situation, it
     is inserted in the previous node and this module has succeeded.  In the
     latter case this module has failed.  In either event, it is done.

     NOTE:
          The target node (control interval) of the rotation, the previous
     node, may be empty (i.e., contain no keys).  This requires some special
     care in using/setting the key_range of the target node's header.  This
     situation arises when a node is being split.  First a new node is set up
     by im_general_insert/replace, using im_split, then keys are rotated out
     of the "old" node into the "new" one, using this module.

*/

/* HISTORY:
Written by Lindsey Spratt, 04/07/82.
Modified:
06/07/82 by Lindsey Spratt:  Changed to set the "new" (target) node (from a
	  split) to point to the "old" (source) node's old parent key as its
	  parent key, rather than having the "new" and "old" nodes point to
	  the same key as their parent key.
06/16/82 by Matthew Pierret: Removed the beginning_offset argument from
            calls to collection_manager_$put_element.
07/20/82 by Lindsey Spratt:  Fixed branch node rotation.  The control interval
	  pointed at by the low_branch_id was being "lost" when one or more
	  keys was rotated and the target of the rotation was not empty
	  (i.e., the rotation was not being done as part of a "split").
	  Added rotation to the "next" node.  Changed name of procedure from
	  im_rotate_previous_insert to im_rotate_insert.
08/02/82 by Lindsey Spratt:  Fixed rotate "next" to correctly increment the
	  key_range.last value in the target_ci.  Fixed setting of the
	  key_string_ptr to set the correct string_ptr.
08/05/82 by Lindsey Spratt:  Fixed the calls to general_insert to have the
	  local_branch_ci_header filled in correctly in the case where the
	  parent key is to be replaced.
08/09/82 by Matthew Pierret:  Removed offset and length arguments in calls to
            collection_manager_$get_element.  Changed new_ci to be aligned.
09/02/82 by Lindsey Spratt:  Changed to use version 2 of the index_cursor
	  structure.  Fixed "bad version" sub_err_ call (in check_version).
09/11/82 by Lindsey Spratt:  Changed to set the branch_ci_header_ptr or 
            leaf_ci_header_ptr equal to common_ci_header_ptr, according to the
            value of common_ci_header.is_leaf.
09/16/82 by Lindsey Spratt:  Completely re-structured the module from a single
	  main execution path with many conditionals to 8 major cases based
	  on: rotate previous or next, nodes are branches or leaves, target
	  node is initially empty or non-empty.
09/21/82 by Lindsey Spratt:  Added the internal_debug switch.  When on, the
	  "rotate" internal procedure prints a description of what kind of
	  rotation was done and how much was rotated.  The debug_on and
	  debug_off entries set this switch.  Also, changed the rotation
	  loop (labeled "ROTATE_KEY_LOOP") to terminate based on the
	  amount_of_storage_to_be_moved, rather than the
	  additional_storage_required.  The amount_of_storage_to_be_moved is
	  set to the maximum of the additional_storage_required and half of
	  the key_tail_space_used_since_last_prefix_compaction.
09/22/82 by Lindsey Spratt:  All four of the branch rotation cases  now
	  attempt to put/alloc the new key string in the low_branch_id, if
	  possible.  It is only possible if the desired slot has been
	  rotated down (or up, if it is a next rotation) to the "low_branch"
	  location.  Added the "put_headers" and "convert_low_branch_to_key"
	  internal procedures.  Changed the "empty branch" rotations to be
	  prepared for a target with a non-zero low_branch_id.
09/24/82 by Lindsey Spratt:  Removed the superfluous
	  "there_is_more_room_in_target_ci" case from the branch rotations.
	  Changed the next_branch rotations to compare the desired slot
	  against the last source slot, instead of the last target slot,
	  when deciding to insert or put at the low_branch_id.  Changed the
	  nex_branch_rotations to update the source branches when the result
	  of the rotation is to insert into the midst of the source node.
11/02/82 by Lindsey Spratt:  Changed to use index_opening_info to get  the
	  file_opening_id and the collection_id instead of the index_cursor.
	  Changed to get the field_table_ptr out of the index_opening_info
	  rather than passing it as a separate parameter.  Changed all
	  internal procedure names to uppercase.  Changed the calling
	  sequence to have p_index_opening_info_ptr instead of
	  p_index_header_ptr, p_cursor_ptr, and p_field_table_ptr.  Changed
	  to record the new root_id by calling im_update_opening_info$root_id
	  rather than setting it directly.  Changed to use new calling
	  sequences to im_update_branches and im_general_insert.
01/17/83 by Matthew Pierret:  Changed to fully qualify references to
            (common branch leaf)_ci_header. source_ci_header_ptr is used in 
            those places that were previously unqualified.
            Changed to use the buffered access method during rotation.
            Added the internal subroutines ALLOCATE_ELEMENT and FREE_ELEMENT,
            which, along with GET_ELEMENT and PUT_ELEMENT, access CIs in 
            either buffered or unbuffered mode according to the value of the 
            global flag use_soure_and_target_ci_buffers.
01/19/83 by Matthew Pierret: Changed to correctly intitialize range.last in
            the target ci when allocating the first key in the ci (in
            ALLOCATE_KEY_IN_TARGET_CI).
01/25/83 by Lindsey Spratt:  Changed SETUP_PARENT_KEY_FROM_LEAF to get
	  the "high" key from key_range.first and the "low" key from
	  key_range.last, using the source or target CI based on whether a
	  rotate previous or next (respectively) is being done.  Changed
	  ROTATE to set the (high low)_key_string_ptr's appropriately.
	  Changed all of the rotation cases to return immediately upon
	  discovering that nothing can be moved from the source CI into the
	  target CI, and that the p_key_string cannot be put/allocated
	  anywhere, rather than continuing through the "cleanup" code at the
	  end of each case (which is pointless and potentially harmful).
01/26/83 by Lindsey Spratt:  Changed the get,put, free and allocate primitives
	  to check not only that use_source_and_target_ci_buffers is on
	  before using the buffered constraint_idx cm_ entry, but also that
	  the requested CI is either the source or the target CI.
01/27/83 by Lindsey Spratt:  Fixed FREE_ELEMENT to not always call
	  cm_$free_element, which it was doing regardless of whether it 
	  call cm_$free_element_buffered or not.
04/12/83 by Lindsey L. Spratt:  Changed ALLOCATE_KEY_IN_TARGET_CI to set the
            one_or_more_keys_were_rotated flag on so that its callers will
            know to fix the parent key.
04/13/83 by Lindsey L. Spratt:  Fixed CONVERT_LOW_BRANCH_TO_KEY to set the
            branch_key.branch_id before putting the new branch_key, rather
            than after (when it no longer matters).  The branch_key was being
            stored with a garbage branch_id.
10/24/83 by Lindsey L. Spratt:  Fixed to invoke update_branches on the source
            in the PREVIOUS_NONEMPTY_BRANCH rotation case after putting the
            buffered ci's.
10/28/83 by Lindsey L. Spratt:  Fixed to update the source branches in a
            particular subcase of the PREVIOUS_ROTATION_INTO_NONEMPTY_BRANCH
            case which was not being caught previously.
10/31/83 by Lindsey L. Spratt:  Fixed next rotations to not move the target
            slot out of the source ci when doing a replacement
            (^p_insert_new_key) operation.
11/08/83 by Lindsey L. Spratt:  Changed to use new im_update_branches calling
            sequence, which requires a node_buffer_ptr.
03/13/84 by Lindsey L. Spratt:  Fixed the PREVIOUS_ROTATION_INTO_EMPTY_BRANCH
            procedure to set low_index to key_range.first + 1 instead of + 2.
            This only caused a problem when the key_id.index = 3.
03/14/84 by Lindsey L. Spratt:  Fixed the previous branch rotations to
            decrement the addr(p_key_id_string) -> element_id.index when doing
            a COMPRESS_LOW_BRANCH, since the p_key insertion point will move
            down by one as a result of the compression.
           Fixed previous_rotation_into_empty_branch to do a
            im_update_branches$single when just the low_branch_id of the
            source_ci was changed.
05/10/84 by Matthew Pierret:  Changed to align buffers on even-word
            boundaries.
06/06/84 by Matthew Pierret:  Re-named cm_$free_element to cm_$delete,
            cm_$free_element_buffered to cm_$delete_from_ci_buffer,
            cm_$*buffered_ci to cm_$=ci_buffer, cm_$simple_get_element_buffered
            to cm_$simple_get_from_ci_buffer, cm_$get_element to cm_$get,
            cm_$put_element to cm_$modify, cm_$put_element_buffered to
            cm_$modify_in_ci_buffer, PUT_ELEMENT to MODIFY_ELEMENT,
            cm_$allocate_element to cm_$put, cm_$allocate_element_buffered to
            cm_$put_in_ci_buffer, ALLOCATE_ELEMENT to PUT_ELEMENT.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 index_opening_info.
11/15/84 by Lindsey L. Spratt:  Changed the modularization of the program.
02/08/84 by R. Michael Tague:  Changed so that ROTATE_(PREVIOUS NEXT)_BRANCH
            will always correctly set the low branch id.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
03/22/85 by Lindsey L. Spratt:  Fixed to always call im_update_branches on the
            target_ci in ROTATE_PREVIOUS_BRANCH.
*/

/* format: style2,ind3 */

im_rotate_insert:
   proc (p_index_opening_info_ptr, p_common_ci_header_ptr, p_rotate_previous, p_insert_new_key, p_insert_parent_key,
        p_key_string, p_key_id_string, p_additional_storage_required, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_insert_new_key       bit (1) aligned parameter;
      dcl	    p_common_ci_header_ptr ptr parameter;
      dcl	    p_rotate_previous      bit (1) aligned parameter;
      dcl	    p_insert_parent_key    bit (1) aligned parameter;
      dcl	    p_key_string	       bit (*) parameter;
      dcl	    p_key_id_string	       bit (36) aligned parameter;
      dcl	    p_additional_storage_required
			       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    1 local_branch_ci_header
			       like branch_ci_header;
      dcl	    new_ci	       fixed bin (24) unsigned;


      dcl	    temp_key_string_length fixed bin (35);

      dcl	    (source_ci, target_ci) fixed bin (24) unsigned unaligned;
      dcl	    target_element_id_string
			       bit (36) aligned;
      dcl	    source_key_index       fixed bin (12) unsigned unaligned;
      dcl	    (source_ci_header_ptr, target_ci_header_ptr, source_ci_ptr, target_ci_ptr)
			       ptr;
      dcl	    temp_key_string_ptr    ptr;
      dcl	    old_temp_key_string_ptr
			       ptr;
      dcl	    one_or_more_keys_were_rotated
			       bit (1) aligned;
      dcl	    target_ci_was_empty    bit (1) aligned;
      dcl	    high_key_string_ptr    ptr;
      dcl	    low_key_string_ptr     ptr;
      dcl	    current_key_buffer_ptr ptr;
      dcl	    old_key_buffer_ptr     ptr;

      dcl	    (source_ci_header_has_changed, source_ci_has_changed, target_ci_header_has_changed, target_ci_has_changed,
	    update_target_branches, update_source_branches, there_is_more_room_in_target_ci,
	    use_source_and_target_ci_buffers)
			       bit (1) aligned init ("0"b);
      dcl	    original_target_index  fixed bin (12) unsigned unaligned;
      dcl	    (low_index, high_index)
			       fixed bin (35);
      dcl	    rotate_idx	       fixed bin (35);

      dcl	    (target_header_buffer, local_fsk_header_buffer)
			       bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)) aligned;
      dcl	    (local_key_buffer_1, local_key_buffer_2, local_key_buffer_3, local_parent_key_buffer,
	    local_source_ci_buffer, local_target_ci_buffer)
			       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);

      dcl	    total_amount_of_storage_moved
			       fixed bin (24);
      dcl	    additional_storage_required
			       fixed bin (24);
      dcl	    total_storage_available
			       fixed bin (35);
      dcl	    amount_of_storage_to_be_moved
			       fixed bin (24);

/* Based */

      dcl	    based_header_buffer    bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS))
			       based aligned;
      dcl	    (
	    key_buffer	       based,
	    key_buffer_1	       based (addr (local_key_buffer_1)),
	    key_buffer_2	       based (addr (local_key_buffer_2)),
	    key_buffer_3	       based (addr (local_key_buffer_3)),
	    parent_key_buffer      based (addr (local_parent_key_buffer)),
	    source_ci_buffer       based (addr (local_source_ci_buffer)),
	    target_ci_buffer       based (addr (local_target_ci_buffer))
	    )		       bit (BITS_PER_PAGE) aligned;
      dcl	    1 target_element_id    like element_id based (addr (target_element_id_string));
      dcl	    1 p_key_id	       aligned like element_id based (addr (p_key_id_string));
      dcl	    1 source_parent_id     aligned like element_id
			       based (addr (source_ci_header_ptr -> common_ci_header.parent_id_string));
      dcl	    source_parent_id_string
			       aligned bit (36)
			       based (addr (source_ci_header_ptr -> common_ci_header.parent_id_string));
      dcl	    1 target_parent_id     aligned like element_id
			       based (addr (target_ci_header_ptr -> common_ci_header.parent_id_string));
      dcl	    target_parent_id_string
			       aligned bit (36)
			       based (addr (target_ci_header_ptr -> common_ci_header.parent_id_string));

/* Builtin */

      dcl	    (addr, divide, length, max, null, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    ALL_FIELDS_PRESENT     init (-1) fixed bin (17) unal internal static options (constant);

      dcl	    (
	    LEAF_NODE	       init ("1"b),
	    BRANCH_NODE	       init ("0"b),
	    REPLACE_KEY	       init ("0"b),
	    INSERT_KEY	       init ("1"b),
	    PREVIOUS_ROTATION      init ("1"b),
	    NEXT_ROTATION	       init ("0"b),
	    DONT_UPDATE_STORAGE_MOVED
			       init ("0"b),
	    UPDATE_STORAGE_MOVED   init ("1"b)
	    )		       bit (1) aligned internal static options (constant);

      dcl	    (
	    BITS_PER_PAGE	       init (36 * 1024),
	    DOUBLE_WORDS_PER_PAGE  init (512)
	    )		       fixed bin internal static options (constant);

      dcl	    myname	       init ("im_rotate_insert") char (16) internal static options (constant);

/* Entry */

      dcl	    ioa_		       entry () options (variable);
      dcl	    sub_err_	       entry () options (variable);
      dcl	    im_general_insert      entry (ptr, ptr, bit (1) aligned, bit (*), bit (36) aligned, fixed bin (35));
      dcl	    im_init_branch_ci_header
			       entry (ptr);
      dcl	    im_make_parent_key     entry (ptr, ptr, fixed bin unal, ptr, fixed bin unal, ptr, fixed bin (35), ptr, ptr,
			       fixed bin (35), bit (1) aligned, fixed bin (35));
      dcl	    im_update_branches     entry (ptr, bit (36) aligned, bit (36) aligned, ptr, uns fixed bin (24) unal,
			       uns fixed bin (12) unal, fixed bin (35));
      dcl	    im_update_branches$single
			       entry (ptr, bit (36) aligned, bit (36) aligned, ptr, uns fixed bin (24) unal,
			       uns fixed bin (12) unal, fixed bin (35));
      dcl	    im_update_opening_info$root_id
			       entry (ptr, uns fixed bin (24), fixed bin (35));


/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    dm_error_$long_element fixed bin (35) ext;

/* Static */

      dcl	    internal_debug	       bit (1) aligned internal static init ("0"b);

/* END OF DECLARATIONS */

      p_code = 0;

      call INITIALIZE (p_rotate_previous);

      if source_ci_header_ptr -> common_ci_header.is_leaf
      then if p_rotate_previous
	 then if target_ci_was_empty
	      then call PREVIOUS_ROTATION_INTO_EMPTY_LEAF;
	      else call PREVIOUS_ROTATION_INTO_NONEMPTY_LEAF;
	 else if target_ci_was_empty
	 then call NEXT_ROTATION_INTO_EMPTY_LEAF;
	 else call NEXT_ROTATION_INTO_NONEMPTY_LEAF;
      else if p_rotate_previous
      then if target_ci_was_empty
	 then call PREVIOUS_ROTATION_INTO_EMPTY_BRANCH;
	 else call PREVIOUS_ROTATION_INTO_NONEMPTY_BRANCH;
      else if target_ci_was_empty
      then call NEXT_ROTATION_INTO_EMPTY_BRANCH;
      else call NEXT_ROTATION_INTO_NONEMPTY_BRANCH;

      if p_additional_storage_required > 0
      then call ERROR_RETURN (dm_error_$long_element);

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;


debug_on:
   entry ();
      internal_debug = "1"b;
      return;

debug_off:
   entry ();
      internal_debug = "0"b;
      return;

%page;
/* This procedure is used to increment the target_element_id. */

ADJUST_TARGET_ELEMENT_ID_FOR_PREVIOUS_INSERT:
   proc ();
      if target_element_id.index = 0
      then target_element_id.index = DEFAULT_INITIAL_KEY_SLOT;
      else target_element_id.index = target_element_id.index + 1;
   end ADJUST_TARGET_ELEMENT_ID_FOR_PREVIOUS_INSERT;


/* This procedure is used to decrement the target_element_id. */

ADJUST_TARGET_ELEMENT_ID_FOR_NEXT_INSERT:
   proc ();
      if target_element_id.index = 0
      then target_element_id.index = DEFAULT_INITIAL_KEY_SLOT;
   end ADJUST_TARGET_ELEMENT_ID_FOR_NEXT_INSERT;


%page;
/* This procedure is used to attempt to place the new key in the target ci.
If the key is being modified (^p_insert_key), then the old version of the key
exists in the source ci, and must be deleted.

The two parameters are both output parameters.  akitc_p_key_string_ptr only
being set if the attempted insertion is successful, and akitc_p_key_doesnt_fit
being set to "1"b if the insertion is unsuccessful.
*/

ALLOCATE_KEY_IN_TARGET_CI:
   proc (akitc_p_key_string_ptr, akitc_p_key_doesnt_fit);
      dcl	    akitc_p_key_string_ptr ptr parameter;
      dcl	    akitc_p_key_doesnt_fit bit (1) aligned parameter;

      dcl	    akitc_element_allocated
			       bit (1) aligned;

      call PUT_ELEMENT_TEST (target_element_id_string, length (p_key_string), addr (p_key_string),
	 total_storage_available, akitc_element_allocated);
      if akitc_element_allocated
      then
         do;					/* Success !! */
	  additional_storage_required = 0;
	  one_or_more_keys_were_rotated = "1"b;
	  if target_ci_header_ptr -> common_ci_header.key_range.first = 0
	  then target_ci_header_ptr -> common_ci_header.key_range.first,
		  target_ci_header_ptr -> common_ci_header.key_range.last = DEFAULT_INITIAL_KEY_SLOT;
	  else target_ci_header_ptr -> common_ci_header.key_range.last =
		  target_ci_header_ptr -> common_ci_header.key_range.last + 1;
	  target_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction =
	       target_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction
	       + length (p_key_string);

	  target_ci_header_has_changed = "1"b;
	  call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, addr (p_key_string),
	       akitc_p_key_string_ptr);

/* The old version of the key being replaced must be freed from the source_ci,
as the new version is now in the target_ci. */

	  if ^p_insert_new_key
	  then call DELETE_KEY (p_key_id.control_interval_id, p_key_id.index, source_ci_header_ptr,
		  length (p_key_string), source_ci_header_has_changed, update_source_branches);
						/* length(p_key_string) is an approximation of the length of the old version of the key. */

	  p_key_id_string = target_element_id_string;

         end;
      akitc_p_key_doesnt_fit = ^akitc_element_allocated;
   end ALLOCATE_KEY_IN_TARGET_CI;
%page;
/* This procedure is used to enforce a constraint on the structure of indexes,
that only adjacent nodes **with the same parent node** may be used when
rotating keys.
*/

CHECK_NODES_HAVE_SAME_PARENT:
   proc;
      if target_parent_id.control_interval_id ^= source_parent_id.control_interval_id
      then call ERROR_RETURN (dm_error_$long_element);

   end CHECK_NODES_HAVE_SAME_PARENT;
%page;
/* This procedure is invoked when the insertion of p_key_string has failed
(presumably for lack of space in both the source and target CIs).  The
csr_p_additional_storage_required parameter is an input/output parameter which
is decremented  by the csr_p_total_amount_of_storage_moved.  If no storage was
moved at all, then the error exit of im_rotate_insert is invoked.
*/

CHECK_STORAGE_REQUIREMENTS:
   proc (csr_p_total_amount_of_storage_moved, csr_p_additional_storage_required);
      dcl	    csr_p_total_amount_of_storage_moved
			       fixed bin (24) parameter;
      dcl	    csr_p_additional_storage_required
			       fixed bin (24) parameter;

      if csr_p_total_amount_of_storage_moved = 0
      then call ERROR_RETURN (dm_error_$long_element);

      csr_p_additional_storage_required = csr_p_additional_storage_required - csr_p_total_amount_of_storage_moved;

   end CHECK_STORAGE_REQUIREMENTS;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  char (8) aligned parameter;
      dcl	    cv_p_expected_version  char (8) aligned parameter;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure. Received version ^d instead.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
/* This procedure takes a node which has no key in its low_branch_id slot and
moves the first branch key branch id into the low_branch_id slot, deleting
(freeing) the branch_key itself.
*/

COMPRESS_LOW_BRANCH_ID:
   proc (clbi_p_update_storage_moved, clbi_p_control_interval_id, clbi_p_ci_header_ptr, clbi_p_ci_header_has_changed,
        clbi_p_update_branches);
      dcl	    clbi_p_update_storage_moved
			       bit (1) aligned parameter;
      dcl	    clbi_p_control_interval_id
			       fixed bin (24) unsigned unaligned parameter;
      dcl	    clbi_p_ci_header_ptr   ptr parameter;
      dcl	    clbi_p_ci_header_has_changed
			       bit (1) aligned parameter;
      dcl	    clbi_p_update_branches bit (1) aligned parameter;

      dcl	    1 clbi_element_id      aligned like element_id;
      dcl	    clbi_temp_key_string_length
			       fixed bin (35);

      clbi_element_id.control_interval_id = clbi_p_control_interval_id;
      clbi_element_id.index = clbi_p_ci_header_ptr -> common_ci_header.key_range.first;

      call GET_ELEMENT (clbi_element_id.control_interval_id, clbi_element_id.index, key_buffer_3,
	 clbi_temp_key_string_length);

      bk_string_length = 0;

      clbi_p_ci_header_ptr -> branch_ci_header.low_branch_id = addr (key_buffer_3) -> branch_key.branch_id;

      call DELETE_KEY (clbi_element_id.control_interval_id, clbi_element_id.index, clbi_p_ci_header_ptr,
	 clbi_temp_key_string_length, clbi_p_ci_header_has_changed, clbi_p_update_branches);

      if clbi_p_update_storage_moved = UPDATE_STORAGE_MOVED
      then total_amount_of_storage_moved = total_amount_of_storage_moved + clbi_temp_key_string_length;

   end COMPRESS_LOW_BRANCH_ID;
%page;
/* This procedure takes the low_branch_id of a node and creates an
appropriately valued branch_key with that branch id.  The newly created key is
always inserted into the target_ci, although it can be created from either the
source or target ci's low_branch_id.
*/

CONVERT_LOW_BRANCH_TO_TARGET_KEY:
   proc (clbttk_p_target_element_id_adjustment_proc, clbttk_p_ci_header_ptr, clbttk_p_ci_header_has_changed);
      dcl	    clbttk_p_target_element_id_adjustment_proc
			       entry () variable parameter;
      dcl	    clbttk_p_ci_header_ptr ptr parameter;
      dcl	    clbttk_p_ci_header_has_changed
			       bit (1) aligned parameter;

      dcl	    clbttk_code	       fixed bin (35);


      call FIND_SPLIT_KEYS (clbttk_p_ci_header_ptr -> branch_ci_header.low_branch_id, key_buffer_1, key_buffer_2);

      call im_make_parent_key (index_opening_info.field_table_ptr, addr (key_buffer_1), ALL_FIELDS_PRESENT,
	 addr (key_buffer_2), ALL_FIELDS_PRESENT, addr (parent_key_buffer), length (parent_key_buffer), null,
	 branch_key_ptr, bk_string_length, "0"b, clbttk_code);
      if clbttk_code ^= 0
      then call ERROR_RETURN (clbttk_code);

      branch_key.branch_id = clbttk_p_ci_header_ptr -> branch_ci_header.low_branch_id;

      call clbttk_p_target_element_id_adjustment_proc ();

      call PUT_KEY (target_element_id.control_interval_id, target_element_id.index, length (unspec (branch_key)),
	 branch_key_ptr, target_ci_header_ptr, target_ci_header_has_changed, update_target_branches,
	 total_storage_available);


      clbttk_p_ci_header_has_changed = "1"b;
      clbttk_p_ci_header_ptr -> branch_ci_header.low_branch_id = 0;

   end CONVERT_LOW_BRANCH_TO_TARGET_KEY;
%page;
/* This procedure deletes a key from the source ci. */

DELETE_KEY:
   proc (dk_p_control_interval_id, dk_p_index, dk_p_ci_header_ptr, dk_p_key_length, dk_p_ci_header_has_changed,
        dk_p_update_branches);
      dcl	    dk_p_control_interval_id
			       fixed bin (24) unsigned unaligned parameter;
      dcl	    dk_p_index	       fixed bin (12) unsigned unaligned parameter;
      dcl	    dk_p_ci_header_ptr     ptr parameter;
      dcl	    dk_p_key_length	       fixed bin (35) parameter;
      dcl	    dk_p_ci_header_has_changed
			       bit (1) aligned parameter;
      dcl	    dk_p_update_branches   bit (1) aligned parameter;

      call DELETE_ELEMENT (dk_p_control_interval_id, dk_p_index);

      dk_p_ci_header_ptr -> common_ci_header.key_range.last = dk_p_ci_header_ptr -> common_ci_header.key_range.last - 1;
      dk_p_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction =
	 max (0,
	 dk_p_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction - dk_p_key_length);

      dk_p_ci_header_has_changed = "1"b;

/* Set the dk_p_update_branches indicator only if it hasn't already been
turned on.  Once on, leave it on.
*/

      if ^dk_p_update_branches
      then if (dk_p_index < dk_p_ci_header_ptr -> common_ci_header.key_range.last)
	 then dk_p_update_branches = "1"b;

   end DELETE_KEY;
%page;
/* This procedure finds the two leaf keys "split" by a branch key.  It does so
by finding the least leaf key in the subtree identified by the branch_id of the
branch key (fsk_p_origin_ci), and the key immediately preceding this least
leaf key.
*/

FIND_SPLIT_KEYS:
   proc (fsk_p_origin_ci, fsk_p_low_key_buffer, fsk_p_high_key_buffer);
      dcl	    fsk_p_origin_ci	       fixed bin (24) unsigned unaligned parameter;
      dcl	    fsk_p_low_key_buffer   bit (*) aligned parameter;
      dcl	    fsk_p_high_key_buffer  bit (*) aligned parameter;
      dcl	    fsk_current_ci	       fixed bin (24) unsigned unaligned;

      fsk_current_ci = fsk_p_origin_ci;
      call GET_ELEMENT (fsk_current_ci, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	 addr (local_fsk_header_buffer) -> based_header_buffer, 0);

      do while (^addr (local_fsk_header_buffer) -> common_ci_header.is_leaf);
         fsk_current_ci = addr (local_fsk_header_buffer) -> branch_ci_header.low_branch_id;
         call GET_ELEMENT (fsk_current_ci, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	    addr (local_fsk_header_buffer) -> based_header_buffer, 0);
      end;

      call GET_ELEMENT (fsk_current_ci, (addr (local_fsk_header_buffer) -> leaf_ci_header.key_range.first),
	 fsk_p_high_key_buffer, 0);
      fsk_current_ci = addr (local_fsk_header_buffer) -> leaf_ci_header.previous_id;
      call GET_ELEMENT (fsk_current_ci, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	 addr (local_fsk_header_buffer) -> based_header_buffer, 0);
      call GET_ELEMENT (fsk_current_ci, (addr (local_fsk_header_buffer) -> leaf_ci_header.key_range.last),
	 fsk_p_low_key_buffer, 0);
   end FIND_SPLIT_KEYS;
%page;
/* This procedure deletes an element from a node. */

DELETE_ELEMENT:
   proc (fe_p_ci, fe_p_index);

      dcl	    fe_p_ci	       fixed bin (24) unsigned unaligned parameter;
      dcl	    fe_p_index	       fixed bin (12) unsigned unaligned parameter;
      dcl	    fe_code	       fixed bin (35);
      dcl	    fe_ci_ptr	       ptr;

      dcl	    1 fe_element_id	       aligned like element_id based (addr (fe_element_id_string));
      dcl	    fe_element_id_string   bit (36) aligned;

      fe_element_id.control_interval_id = fe_p_ci;
      fe_element_id.index = fe_p_index;

      if use_source_and_target_ci_buffers & (fe_p_ci = source_ci | fe_p_ci = target_ci)
      then
         do;
	  if fe_element_id.control_interval_id = source_ci
	  then fe_ci_ptr = source_ci_ptr;
	  else fe_ci_ptr = target_ci_ptr;

	  call collection_manager_$delete_from_ci_buffer (fe_ci_ptr, index_opening_info.file_opening_id,
	       index_opening_info.collection_id, fe_element_id_string, "0"b, fe_code);
         end;
      else call collection_manager_$delete (index_opening_info.file_opening_id, index_opening_info.collection_id,
	      fe_element_id_string, "0"b, fe_code);
      if fe_code ^= 0
      then call ERROR_RETURN (fe_code);

   end DELETE_ELEMENT;
%page;
/* This procedure copies an element from a node into the provided buffer. */

GET_ELEMENT:
   proc (ge_p_ci, ge_p_index, ge_p_buffer, ge_p_length);

      dcl	    ge_p_ci	       fixed bin (24) unsigned unaligned;
      dcl	    ge_p_index	       fixed bin (12) unsigned unaligned;
      dcl	    ge_p_buffer	       bit (*) aligned parameter;
      dcl	    ge_p_length	       fixed bin (35);
      dcl	    ge_code	       fixed bin (35);
      dcl	    ge_ci_ptr	       ptr;

      dcl	    1 ge_element_id	       aligned like element_id based (addr (ge_element_id_string));
      dcl	    ge_element_id_string   bit (36) aligned;

      ge_element_id.control_interval_id = ge_p_ci;
      ge_element_id.index = ge_p_index;

      if use_source_and_target_ci_buffers & (ge_p_ci = source_ci | ge_p_ci = target_ci)
      then
         do;
	  if ge_element_id.control_interval_id = source_ci
	  then ge_ci_ptr = source_ci_ptr;
	  else ge_ci_ptr = target_ci_ptr;

	  call collection_manager_$simple_get_from_ci_buffer (ge_ci_ptr, index_opening_info.collection_id,
	       ge_element_id_string, addr (ge_p_buffer), length (ge_p_buffer), ge_p_length, ge_code);
         end;
      else call collection_manager_$get (index_opening_info.file_opening_id, index_opening_info.collection_id,
	      ge_element_id_string, 0, addr (ge_p_buffer), length (ge_p_buffer), null, "0"b, null, ge_p_length, ge_code)
	      ;
      if ge_code ^= 0
      then call ERROR_RETURN (ge_code);

   end GET_ELEMENT;
%page;
/* This procedure initializes the global variables for im_rotate_insert. */

INITIALIZE:
   proc (i_p_rotate_previous);
      dcl	    i_p_rotate_previous    bit (1) aligned;
      dcl	    i_code	       fixed bin (35) init (0);

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      source_ci_header_ptr = p_common_ci_header_ptr;

      common_ci_header_ptr, leaf_ci_header_ptr, branch_ci_header_ptr = null;

      source_ci = p_key_id.control_interval_id;
      source_ci_ptr = addr (source_ci_buffer);

      call collection_manager_$setup_ci_buffer (index_opening_info.file_opening_id, index_opening_info.collection_id,
	 (source_ci), source_ci_ptr, length (source_ci_buffer), i_code);
      if i_code ^= 0
      then call ERROR_RETURN (i_code);

      i_code = 0;
      use_source_and_target_ci_buffers = "1"b;

      if i_p_rotate_previous
      then target_element_id.control_interval_id = source_ci_header_ptr -> common_ci_header.previous_id;
      else target_element_id.control_interval_id = source_ci_header_ptr -> common_ci_header.next_id;

      target_ci = target_element_id.control_interval_id;
      if target_ci = 0
      then call ERROR_RETURN (dm_error_$long_element);

      target_ci_ptr = addr (target_ci_buffer);

      call collection_manager_$setup_ci_buffer (index_opening_info.file_opening_id, index_opening_info.collection_id,
	 (target_ci), target_ci_ptr, length (target_ci_buffer), i_code);
      if i_code ^= 0
      then call ERROR_RETURN (i_code);

      call GET_ELEMENT (target_ci, 1, target_header_buffer, (0));

      target_ci_header_ptr = addr (target_header_buffer);
      if i_p_rotate_previous
      then target_element_id.index = target_ci_header_ptr -> common_ci_header.key_range.last;
      else target_element_id.index = target_ci_header_ptr -> common_ci_header.key_range.first;

      original_target_index = target_element_id.index;
      target_ci_was_empty = (original_target_index = 0);

      if i_p_rotate_previous
      then source_key_index = source_ci_header_ptr -> common_ci_header.key_range.first;
      else source_key_index = source_ci_header_ptr -> common_ci_header.key_range.last;

      temp_key_string_ptr = null;
      one_or_more_keys_were_rotated = "0"b;
      high_key_string_ptr = null;
      low_key_string_ptr = null;

      current_key_buffer_ptr = addr (key_buffer_1);
      old_key_buffer_ptr = addr (key_buffer_2);
      total_amount_of_storage_moved = 0;

      additional_storage_required = p_additional_storage_required;
      amount_of_storage_to_be_moved =
	 max (additional_storage_required,
	 divide (source_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction, 2, 24, 0));
   end INITIALIZE;
%page;
/* This procedure inserts a branch key into the source ci. */

INSERT_BRANCH_KEY_IN_SOURCE:
   proc ();

      if ^p_insert_new_key
      then call MODIFY_ELEMENT (p_key_id.control_interval_id, p_key_id.index, p_key_string);
      else call PUT_KEY (p_key_id.control_interval_id, p_key_id.index, length (p_key_string), addr (p_key_string),
	      source_ci_header_ptr, source_ci_header_has_changed, update_source_branches, total_storage_available);

      additional_storage_required = 0;

   end INSERT_BRANCH_KEY_IN_SOURCE;
%page;
/* This procedure sets the low_branch_id of the given ci_header to be the
branch_id of the branch_key in p_key_string.  This branch key is assumed to
have already been inserted in the source_ci at the location specified by
p_key_id_string, and therefore the key at p_key_id_string is deleted from the
source ci.
*/

INSERT_KEY_AS_LOW_BRANCH_ID:
   proc (ikalbi_p_ci_header_ptr, ikalbi_p_ci_header_has_changed);
      dcl	    ikalbi_p_ci_header_ptr ptr parameter;
      dcl	    ikalbi_p_ci_header_has_changed
			       bit (1) aligned parameter;

      ikalbi_p_ci_header_ptr -> branch_ci_header.low_branch_id = addr (p_key_string) -> branch_key.branch_id;
      ikalbi_p_ci_header_has_changed = "1"b;

/* If there is an old version of p_key_string, delete it. */

      if ^p_insert_new_key
      then call DELETE_KEY (p_key_id.control_interval_id, p_key_id.index, source_ci_header_ptr, length (p_key_string),
	      source_ci_header_has_changed, update_source_branches);
						/* length (p_key_string) is an approximation for the length of the old version of the key. */

      additional_storage_required = 0;

   end INSERT_KEY_AS_LOW_BRANCH_ID;
%page;
/* This procedure inserts a leaf key into the source ci at the slot index
given by ilkisc_p_key_index.  If ilkisc_p_key_index = p_key_id.index, then
ilkisc_p_key_string_ptr is set to point at p_key_string.
*/

INSERT_LEAF_KEY_IN_SOURCE_CI:
   proc (ilkisc_p_key_index, ilkisc_p_key_string_ptr);
      dcl	    ilkisc_p_key_index     fixed bin (18) unsigned unaligned parameter;
      dcl	    ilkisc_p_key_string_ptr
			       ptr parameter;

      if ^p_insert_new_key
      then call MODIFY_ELEMENT (source_ci, p_key_id.index, p_key_string);
      else call PUT_KEY (p_key_id.control_interval_id, p_key_id.index, length (p_key_string), addr (p_key_string),
	      source_ci_header_ptr, source_ci_header_has_changed, update_source_branches, total_storage_available);

      if p_key_id.index = ilkisc_p_key_index
      then call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, addr (p_key_string),
	      ilkisc_p_key_string_ptr);

      additional_storage_required = 0;

   end INSERT_LEAF_KEY_IN_SOURCE_CI;
%page;
/* This procedure inserts a leaf key into the targe ci. It is prepared for
there to be insufficient room for the insertion.  If the insertion works,
ilktc_p_key_string_ptr is set to point at p_key_string.
*/

INSERT_LEAF_KEY_IN_TARGET_CI:
   proc (ilktc_p_target_element_id_adjustment_proc, ilktc_p_key_string_ptr);
      dcl	    ilktc_p_target_element_id_adjustment_proc
			       entry () variable parameter;
      dcl	    ilktc_p_key_string_ptr ptr parameter;

      dcl	    ilktc_key_doesnt_fit   bit (1) aligned init ("0"b);

      call ilktc_p_target_element_id_adjustment_proc ();

      call ALLOCATE_KEY_IN_TARGET_CI (ilktc_p_key_string_ptr, ilktc_key_doesnt_fit);
      if ilktc_key_doesnt_fit
      then call CHECK_STORAGE_REQUIREMENTS (total_amount_of_storage_moved, additional_storage_required);

   end INSERT_LEAF_KEY_IN_TARGET_CI;
%page;
/* This procedure modifies the value of an existing element. */

MODIFY_ELEMENT:
   proc (me_p_ci, me_p_index, me_p_buffer);

      dcl	    me_p_ci	       fixed bin (24) unsigned unaligned;
      dcl	    me_p_index	       fixed bin (12) unsigned unaligned;
      dcl	    me_p_buffer	       bit (*);
      dcl	    me_code	       fixed bin (35);
      dcl	    me_ci_ptr	       ptr;

      dcl	    1 me_element_id	       aligned like element_id based (addr (me_element_id_string));
      dcl	    me_element_id_string   bit (36) aligned;

      me_element_id.control_interval_id = me_p_ci;
      me_element_id.index = me_p_index;

      if use_source_and_target_ci_buffers & (me_p_ci = source_ci | me_p_ci = target_ci)
      then
         do;
	  if me_element_id.control_interval_id = source_ci
	  then me_ci_ptr = source_ci_ptr;
	  else me_ci_ptr = target_ci_ptr;

	  call collection_manager_$modify_in_ci_buffer (me_ci_ptr, index_opening_info.file_opening_id,
	       index_opening_info.collection_id, addr (me_p_buffer), length (me_p_buffer), me_element_id_string,
	       total_storage_available, me_code);
         end;
      else call collection_manager_$modify (index_opening_info.file_opening_id, index_opening_info.collection_id,
	      addr (me_p_buffer), length (me_p_buffer), me_element_id_string, total_storage_available, me_code);
      if me_code ^= 0
      then call ERROR_RETURN (me_code);

   end MODIFY_ELEMENT;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.next_id node (the target_ci).  This
procedure requires that the target_ci be empty, and that the nodes involved be
branch (as opposed to leaf) nodes.
*/

NEXT_ROTATION_INTO_EMPTY_BRANCH:
   proc;
      dcl	    nrieb_code	       fixed bin (35) init (0);

      if target_ci_header_ptr -> branch_ci_header.low_branch_id ^= 0
      then call CONVERT_LOW_BRANCH_TO_TARGET_KEY (ADJUST_TARGET_ELEMENT_ID_FOR_NEXT_INSERT, target_ci_header_ptr,
	      target_ci_header_has_changed);

      call ROTATE_NEXT_BRANCH ();

/* Update the parent key. */

      call SETUP_PARENT_KEY (target_ci_header_ptr, target_ci);

      if p_insert_parent_key
      then
         do;
	  call SETUP_PARENT_NODE_FOR_INSERTION (NEXT_ROTATION);

	  call MODIFY_HEADERS (BRANCH_NODE);

	  call im_general_insert (index_opening_info_ptr, addr (local_branch_ci_header), INSERT_KEY,
	       unspec (branch_key), source_parent_id_string, nrieb_code);
	  if nrieb_code ^= 0
	  then call ERROR_RETURN (nrieb_code);
         end;
      else call REPLACE_PARENT_KEY (target_ci_header_ptr);

      p_additional_storage_required = additional_storage_required;
   end NEXT_ROTATION_INTO_EMPTY_BRANCH;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.next_id node (the target_ci).  This
procedure requires that the target_ci be empty, and that the nodes involved be
leaf (as opposed to branch) nodes.
*/

NEXT_ROTATION_INTO_EMPTY_LEAF:
   proc;
      dcl	    nriel_code	       fixed bin (35) init (0);

      call ROTATE_NEXT_LEAF ();

/* Update the parent key. */

      call SETUP_PARENT_KEY_FROM_LEAF_NODE (NEXT_ROTATION);

      if p_insert_parent_key
      then
         do;
	  call SETUP_PARENT_NODE_FOR_INSERTION (NEXT_ROTATION);

	  call MODIFY_HEADERS (LEAF_NODE);

	  call im_general_insert (index_opening_info_ptr, addr (local_branch_ci_header), INSERT_KEY,
	       unspec (branch_key), source_parent_id_string, nriel_code);
	  if nriel_code ^= 0
	  then call ERROR_RETURN (nriel_code);
         end;
      else call REPLACE_PARENT_KEY (target_ci_header_ptr);

      p_additional_storage_required = additional_storage_required;

   end NEXT_ROTATION_INTO_EMPTY_LEAF;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.next_id node (the target_ci).  This
procedure requires that the target_ci has a low_branch_id > 0 and that the
nodes involved be branch (as opposed to leaf), i.e. is a
nonempty branch node.
*/

NEXT_ROTATION_INTO_NONEMPTY_BRANCH:
   proc;

      call CHECK_NODES_HAVE_SAME_PARENT;

/* Convert the low_branch_id "across" which the rotation will be done */
/* into a branch key. */

      call CONVERT_LOW_BRANCH_TO_TARGET_KEY (ADJUST_TARGET_ELEMENT_ID_FOR_NEXT_INSERT, target_ci_header_ptr,
	 target_ci_header_has_changed);

      call ROTATE_NEXT_BRANCH ();

/* Update the parent key. */

      if additional_storage_required = 0 | one_or_more_keys_were_rotated
      then
         do;
	  call SETUP_PARENT_KEY (target_ci_header_ptr, target_ci);
	  call REPLACE_PARENT_KEY (target_ci_header_ptr);
         end;

      p_additional_storage_required = additional_storage_required;
   end NEXT_ROTATION_INTO_NONEMPTY_BRANCH;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.next_id node (the target_ci).  Thi.
procedure requires that the target_ci contain at least one key
and that the nodes involved be leaf (as opposed to branch) nodes.
*/

NEXT_ROTATION_INTO_NONEMPTY_LEAF:
   proc;

      call CHECK_NODES_HAVE_SAME_PARENT;

      call ROTATE_NEXT_LEAF ();

/* Update the parent key. */
      if one_or_more_keys_were_rotated
      then
         do;
	  call SETUP_PARENT_KEY_FROM_LEAF_NODE (NEXT_ROTATION);
	  call REPLACE_PARENT_KEY (target_ci_header_ptr);
         end;

      p_additional_storage_required = additional_storage_required;
   end NEXT_ROTATION_INTO_NONEMPTY_LEAF;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.previous_id node (the target_ci).
This procedure requires that the target_ci be empty, and that the nodes
involved be branch (as opposed to leaf) nodes.
*/

PREVIOUS_ROTATION_INTO_EMPTY_BRANCH:
   proc;
      dcl	    prieb_code	       fixed bin (35) init (0);

      if target_ci_header_ptr -> branch_ci_header.low_branch_id = 0
      then
         do;
	  update_target_branches = "1"b;
	  target_ci_header_has_changed = "1"b;
	  target_ci_header_ptr -> branch_ci_header.low_branch_id =
	       source_ci_header_ptr -> branch_ci_header.low_branch_id;
	  source_ci_header_ptr -> branch_ci_header.low_branch_id = 0;
         end;
      else call CONVERT_LOW_BRANCH_TO_TARGET_KEY (ADJUST_TARGET_ELEMENT_ID_FOR_PREVIOUS_INSERT, source_ci_header_ptr,
	      source_ci_header_has_changed);

      call ROTATE_PREVIOUS_BRANCH ();

      if p_insert_parent_key
      then
         do;
	  call SETUP_PARENT_NODE_FOR_INSERTION (PREVIOUS_ROTATION);

	  call MODIFY_HEADERS (BRANCH_NODE);

	  call im_general_insert (index_opening_info_ptr, addr (local_branch_ci_header), INSERT_KEY,
	       unspec (branch_key), source_parent_id_string, prieb_code);
	  if prieb_code ^= 0
	  then call ERROR_RETURN (prieb_code);
         end;
      else call REPLACE_PARENT_KEY (source_ci_header_ptr);

      p_additional_storage_required = additional_storage_required;
   end PREVIOUS_ROTATION_INTO_EMPTY_BRANCH;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.previous_id node (the target_ci).
This procedure requires that the target_ci be empty, and that the nodes
involved be leaf (as opposed to branch) nodes.
*/

PREVIOUS_ROTATION_INTO_EMPTY_LEAF:
   proc;
      dcl	    priel_code	       fixed bin (35) init (0);

      call ROTATE_PREVIOUS_LEAF ();

/* Update the parent key. */

      call SETUP_PARENT_KEY_FROM_LEAF_NODE (PREVIOUS_ROTATION);

      if p_insert_parent_key
      then
         do;
	  call SETUP_PARENT_NODE_FOR_INSERTION (PREVIOUS_ROTATION);

	  call MODIFY_HEADERS (LEAF_NODE);

	  call im_general_insert (index_opening_info_ptr, addr (local_branch_ci_header), INSERT_KEY,
	       unspec (branch_key), source_parent_id_string, priel_code);
	  if priel_code ^= 0
	  then call ERROR_RETURN (priel_code);
         end;
      else call REPLACE_PARENT_KEY (source_ci_header_ptr);

      p_additional_storage_required = additional_storage_required;

   end PREVIOUS_ROTATION_INTO_EMPTY_LEAF;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.previous_id node (the target_ci).
This procedure requires that the target_ci has a low_branch_id > 0
and that the nodes involved be branch (as opposed to leaf) nodes, i.e. that
the target_ci be a non-empty branch node.
*/

PREVIOUS_ROTATION_INTO_NONEMPTY_BRANCH:
   proc;
      dcl	    prinb_code	       fixed bin (35) init (0);

      call CHECK_NODES_HAVE_SAME_PARENT;

/* Convert the low_branch_id "across" which the rotation will be done */
/* into a branch key. */

      call CONVERT_LOW_BRANCH_TO_TARGET_KEY (ADJUST_TARGET_ELEMENT_ID_FOR_PREVIOUS_INSERT, source_ci_header_ptr,
	 source_ci_header_has_changed);

      call ROTATE_PREVIOUS_BRANCH ();

      call REPLACE_PARENT_KEY (source_ci_header_ptr);

      p_additional_storage_required = additional_storage_required;
   end PREVIOUS_ROTATION_INTO_NONEMPTY_BRANCH;
%page;
/* This procedure attempts to insert p_key_string at
p_key_id_string after first making room for the insertion by rotating keys
from the p_key_id.control_interval_id node (the source_ci) into the
common_ci_header.previous_id node (the target_ci).
This procedure requires that the target_ci has at least one key in it
and that the nodes involved be leaf (as opposed to branch) nodes.
*/

PREVIOUS_ROTATION_INTO_NONEMPTY_LEAF:
   proc;

      call CHECK_NODES_HAVE_SAME_PARENT;

      call ROTATE_PREVIOUS_LEAF ();

/* Update the parent key. */
      if one_or_more_keys_were_rotated
      then
         do;
	  call SETUP_PARENT_KEY_FROM_LEAF_NODE (PREVIOUS_ROTATION);
	  call REPLACE_PARENT_KEY (source_ci_header_ptr);
         end;

      p_additional_storage_required = additional_storage_required;

   end PREVIOUS_ROTATION_INTO_NONEMPTY_LEAF;
%page;
/* This procedure replaces the buffered nodes, source_ci and target_ci, in the
index_collection.
*/

REPLACE_NODE_BUFFERS:
   proc ();
      dcl	    pcb_code	       fixed bin (35);

      if source_ci_has_changed
      then
         do;
	  call collection_manager_$replace_ci_buffer (index_opening_info.file_opening_id,
	       index_opening_info.collection_id, (source_ci), source_ci_ptr, length (source_ci_buffer), pcb_code);
	  if pcb_code ^= 0
	  then call ERROR_RETURN (pcb_code);
         end;
      if target_ci_has_changed
      then
         do;
	  call collection_manager_$replace_ci_buffer (index_opening_info.file_opening_id,
	       index_opening_info.collection_id, (target_ci), target_ci_ptr, length (target_ci_buffer), pcb_code);
	  if pcb_code ^= 0
	  then call ERROR_RETURN (pcb_code);
         end;

      use_source_and_target_ci_buffers, target_ci_has_changed, source_ci_has_changed = "0"b;

   end REPLACE_NODE_BUFFERS;
%page;
/* This procedure puts an element into a node. */

PUT_ELEMENT:
   proc (pe_p_element_id_string, pe_p_element_length, pe_p_element_ptr, pe_p_space_left);

      dcl	    pe_p_element_id_string bit (36) aligned;
      dcl	    pe_p_element_length    fixed bin (35);
      dcl	    pe_p_element_ptr       ptr;
      dcl	    pe_p_space_left	       fixed bin (35);
      dcl	    pe_p_element_was_allocated
			       bit (1) aligned;
      dcl	    pe_code	       fixed bin (35);
      dcl	    pe_ci_ptr	       ptr;
      dcl	    1 pe_element_id	       aligned like element_id based (addr (pe_element_id_string));
      dcl	    pe_element_id_string   bit (36) aligned;
      dcl	    pe_report_allocated    bit (1) aligned;

      pe_report_allocated = "0"b;
      goto PE_JOIN;

PUT_ELEMENT_TEST:
   entry (pe_p_element_id_string, pe_p_element_length, pe_p_element_ptr, pe_p_space_left, pe_p_element_was_allocated);
      pe_report_allocated = "1"b;
      pe_p_element_was_allocated = "1"b;
PE_JOIN:
      pe_element_id_string = pe_p_element_id_string;

      if use_source_and_target_ci_buffers
	 & (pe_element_id.control_interval_id = source_ci | pe_element_id.control_interval_id = target_ci)
      then
         do;
	  if pe_element_id.control_interval_id = source_ci
	  then pe_ci_ptr = source_ci_ptr;
	  else pe_ci_ptr = target_ci_ptr;

	  call collection_manager_$put_in_ci_buffer (pe_ci_ptr, index_opening_info.file_opening_id,
	       index_opening_info.collection_id, pe_p_element_ptr, pe_p_element_length, pe_element_id_string,
	       pe_p_space_left, pe_code);
         end;
      else call collection_manager_$put (index_opening_info.file_opening_id, index_opening_info.collection_id,
	      pe_p_element_ptr, pe_p_element_length, pe_element_id_string, pe_p_space_left, pe_code);
      if pe_code ^= 0
      then if (pe_report_allocated & pe_code = dm_error_$long_element)
	 then pe_p_element_was_allocated = "0"b;
	 else call ERROR_RETURN (pe_code);

   end PUT_ELEMENT;
%page;
PUT_KEY:
   proc (pk_p_control_interval_id, pk_p_index, pk_p_key_length, pk_p_key_ptr, pk_p_ci_header_ptr,
        pk_p_ci_header_has_changed, pk_p_update_branches, pk_p_total_storage_available);

      dcl	    pk_p_control_interval_id
			       fixed bin (24) unsigned unaligned parameter;
      dcl	    pk_p_index	       fixed bin (12) unsigned unaligned parameter;
      dcl	    pk_p_key_length	       fixed bin (35) parameter;
      dcl	    pk_p_key_ptr	       ptr parameter;
      dcl	    pk_p_ci_header_ptr     ptr parameter;
      dcl	    pk_p_ci_header_has_changed
			       bit (1) aligned parameter;
      dcl	    pk_p_update_branches   bit (1) aligned parameter;
      dcl	    pk_p_total_storage_available
			       fixed bin (35) parameter;

      dcl	    1 pk_p_ci_header       aligned like common_ci_header based (pk_p_ci_header_ptr);
      dcl	    1 pk_element_id	       aligned like element_id based (addr (pk_element_id_string));
      dcl	    pk_element_id_string   bit (36) aligned;

      pk_element_id.control_interval_id = pk_p_control_interval_id;
      pk_element_id.index = pk_p_index;

      call PUT_ELEMENT (pk_element_id_string, pk_p_key_length, pk_p_key_ptr, pk_p_total_storage_available);

      pk_p_ci_header.key_range.last = pk_p_ci_header.key_range.last + 1;
      pk_p_ci_header.key_tail_space_used_since_last_prefix_compaction =
	 pk_p_ci_header.key_tail_space_used_since_last_prefix_compaction + pk_p_key_length;

      pk_p_ci_header_has_changed = "1"b;

      if ^pk_p_update_branches
      then if pk_p_ci_header.key_range.last > pk_p_index
	 then pk_p_update_branches = "1"b;

   end PUT_KEY;
%page;
/* This procedure modifies the node headers in the nodes, using the global
header copies.
*/

MODIFY_HEADERS:
   proc (ph_p_is_leaf);
      dcl	    ph_p_is_leaf	       bit (1) aligned;

      if ph_p_is_leaf
      then
         do;
	  if source_ci_header_has_changed
	  then call MODIFY_ELEMENT (source_ci, 1, unspec (source_ci_header_ptr -> leaf_ci_header));
	  if target_ci_header_has_changed
	  then call MODIFY_ELEMENT (target_ci, 1, unspec (target_ci_header_ptr -> leaf_ci_header));
         end;
      else
         do;
	  if source_ci_header_has_changed
	  then call MODIFY_ELEMENT (source_ci, 1, unspec (source_ci_header_ptr -> branch_ci_header));
	  if target_ci_header_has_changed
	  then call MODIFY_ELEMENT (target_ci, 1, unspec (target_ci_header_ptr -> branch_ci_header));
         end;

      source_ci_has_changed = source_ci_header_has_changed;
      target_ci_has_changed = target_ci_header_has_changed;

      target_ci_header_has_changed, source_ci_header_has_changed = "0"b;

   end MODIFY_HEADERS;
%page;
/* This procedure replaces the old parent key splitting the target and source
nodes with a new parent key which has a value that correctly splits the
rotated contents of the target and source nodes.
*/

REPLACE_PARENT_KEY:
   proc (rpk_p_ci_header_ptr);
      dcl	    rpk_p_ci_header_ptr    ptr parameter;
      dcl	    1 rpk_p_ci_header      aligned based (rpk_p_ci_header_ptr) like common_ci_header;
      dcl	    1 rpk_p_parent_element_id
			       aligned like element_id based (addr (rpk_p_ci_header.parent_id_string));

      dcl	    rpk_code	       fixed bin (35);

      call GET_ELEMENT (rpk_p_parent_element_id.control_interval_id, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	 addr (local_branch_ci_header) -> based_header_buffer, 0);
      call im_general_insert (index_opening_info_ptr, addr (local_branch_ci_header), REPLACE_KEY, unspec (branch_key),
	 unspec (rpk_p_ci_header.parent_id_string), rpk_code);
      if rpk_code ^= 0
      then call ERROR_RETURN (rpk_code);
   end REPLACE_PARENT_KEY;
%page;
/* This procedure is the heart of the rotation algorithm.  It moves keys from
a source node into a target node.  The move is accomplished by copying the key
from source to target, then deleting the source copy.
*/

ROTATE:
   proc (r_p_rotate_previous);
      dcl	    r_p_rotate_previous    bit (1) aligned;
      dcl	    r_element_allocated    bit (1) aligned;

      r_element_allocated = "1"b;

ROTATE_KEY_LOOP:
      do rotate_idx = high_index to low_index by -1
	 while (r_element_allocated & total_amount_of_storage_moved < amount_of_storage_to_be_moved);

         if ^r_p_rotate_previous
         then source_key_index = rotate_idx;

         old_temp_key_string_ptr = temp_key_string_ptr;

         temp_key_string_ptr = current_key_buffer_ptr;

/* temp_key_string_ptr is just a convenient holder during the switch of old and current. */

         current_key_buffer_ptr = old_key_buffer_ptr;
         old_key_buffer_ptr = temp_key_string_ptr;

         call GET_ELEMENT (source_ci, source_key_index, current_key_buffer_ptr -> key_buffer, temp_key_string_length);

         temp_key_string_ptr = current_key_buffer_ptr;
         if r_p_rotate_previous
         then call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, temp_key_string_ptr,
	         high_key_string_ptr);
         else call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, temp_key_string_ptr,
	         low_key_string_ptr);

/* The target_element_id.index will be 0 if there were no keys already in the
target  node.  In this case, target_element_id.index must be set to the
default initial key slot value.
*/
         if target_element_id.index = 0
         then target_element_id.index = DEFAULT_INITIAL_KEY_SLOT;
         else if r_p_rotate_previous
         then target_element_id.index = target_element_id.index + 1;

         call PUT_ELEMENT_TEST (target_element_id_string, temp_key_string_length, temp_key_string_ptr,
	    total_storage_available, r_element_allocated);
         if r_element_allocated
         then
	  do;
	     one_or_more_keys_were_rotated = "1"b;

/* If the target node was empty of keys, prior to rotation from the source,
then the key_range.first = 0. It is necessary to initialize key_range.first, 
in this case.
*/

	     if target_ci_header_ptr -> common_ci_header.key_range.first = 0
	     then target_ci_header_ptr -> common_ci_header.key_range.first,
		     target_ci_header_ptr -> common_ci_header.key_range.last = DEFAULT_INITIAL_KEY_SLOT;
	     else target_ci_header_ptr -> common_ci_header.key_range.last =
		     target_ci_header_ptr -> common_ci_header.key_range.last + 1;

	     target_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction =
		target_ci_header_ptr -> common_ci_header.key_tail_space_used_since_last_prefix_compaction
		+ temp_key_string_length;

	     target_ci_header_has_changed = "1"b;
	     source_ci_header_has_changed = "1"b;
	     if r_p_rotate_previous
	     then update_source_branches = "1"b;
	     update_target_branches = "1"b;

	     total_amount_of_storage_moved = total_amount_of_storage_moved + temp_key_string_length;

	     if r_p_rotate_previous
	     then
	        do;
		 high_key_string_ptr = null;
		 call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, temp_key_string_ptr,
		      low_key_string_ptr);
	        end;
	     else
	        do;
		 low_key_string_ptr = null;
		 call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, temp_key_string_ptr,
		      high_key_string_ptr);
	        end;

	     call DELETE_KEY (source_ci, (source_key_index), source_ci_header_ptr, temp_key_string_length,
		source_ci_header_has_changed, update_source_branches);
	  end;

      end ROTATE_KEY_LOOP;


      there_is_more_room_in_target_ci = r_element_allocated;
      if r_p_rotate_previous
      then if there_is_more_room_in_target_ci
	 then p_key_id.index = rotate_idx;
	 else p_key_id.index = rotate_idx + 1;

      if internal_debug
      then
         do;
	  if ^there_is_more_room_in_target_ci
	  then rotate_idx = rotate_idx + 1;
	  call ioa_ ("^[Previous^;Next^] rotation into ^[^;non^]empty ^[leaf^;branch^] node (from ^d to ^d):
^10xKeys rotated - ^d out of ^d.
^10xBits rotated - ^d out of ^d.", r_p_rotate_previous, target_ci_was_empty,
	       source_ci_header_ptr -> common_ci_header.is_leaf, source_ci, target_ci, high_index - rotate_idx,
	       source_ci_header_ptr -> common_ci_header.key_range.last
	       - source_ci_header_ptr -> common_ci_header.key_range.first + 1 + high_index - rotate_idx,
	       total_amount_of_storage_moved, amount_of_storage_to_be_moved * 2);
         end;
   end ROTATE;
%page;
/* This procedure does the rotation of keys into the next branch node, then
attempts to insert p_key_string.
*/

ROTATE_NEXT_BRANCH:
   proc ();
      dcl	    rnb_code	       fixed bin (35);

      high_index = source_ci_header_ptr -> common_ci_header.key_range.last;
      if p_insert_new_key
      then low_index = p_key_id.index;
      else low_index = p_key_id.index + 1;


      call ROTATE (NEXT_ROTATION);


      if (p_insert_new_key & p_key_id.index > source_ci_header_ptr -> common_ci_header.key_range.last)
	 | (^p_insert_new_key & p_key_id.index = source_ci_header_ptr -> common_ci_header.key_range.last)
      then call INSERT_KEY_AS_LOW_BRANCH_ID (target_ci_header_ptr, target_ci_header_has_changed);
      else
         do;
	  if target_ci_header_ptr -> branch_ci_header.low_branch_id = 0
	  then call COMPRESS_LOW_BRANCH_ID (DONT_UPDATE_STORAGE_MOVED, target_ci, target_ci_header_ptr,
		  target_ci_header_has_changed, update_target_branches);
	  if total_amount_of_storage_moved >= additional_storage_required
	  then call INSERT_BRANCH_KEY_IN_SOURCE ();
	  else call CHECK_STORAGE_REQUIREMENTS (total_amount_of_storage_moved, additional_storage_required);
         end;


/* Replace the modified headers. */

      call MODIFY_HEADERS (BRANCH_NODE);

/* Update the "parent" threads of the children of the target and source CIs. */

      if update_source_branches
      then
         do;
	  call im_update_branches (source_ci_ptr, index_opening_info.file_opening_id, index_opening_info.collection_id,
	       source_ci_header_ptr, source_ci, (p_key_id.index), rnb_code);
	  if rnb_code ^= 0
	  then call ERROR_RETURN (rnb_code);
         end;

      call im_update_branches (target_ci_ptr, index_opening_info.file_opening_id, index_opening_info.collection_id,
	 target_ci_header_ptr, target_ci, 0, rnb_code);
      if rnb_code ^= 0
      then call ERROR_RETURN (rnb_code);

/* Replace the modified CI buffers. */

      call REPLACE_NODE_BUFFERS ();

   end ROTATE_NEXT_BRANCH;
%page;
/* This procedure rotates keys into the next leaf node and attempts to insert
p_key_string.
*/

ROTATE_NEXT_LEAF:
   proc ();

      high_index = source_ci_header_ptr -> common_ci_header.key_range.last;
      if p_insert_new_key
      then low_index = p_key_id.index;
      else low_index = p_key_id.index + 1;

      call ROTATE (NEXT_ROTATION);

      if total_amount_of_storage_moved >= additional_storage_required
      then call INSERT_LEAF_KEY_IN_SOURCE_CI (source_ci_header_ptr -> common_ci_header.key_range.last, low_key_string_ptr)
	      ;
      else if there_is_more_room_in_target_ci		/* Didn't move enough storage to put the new key into the
original ci, but there may be enough room in the target (or previous) ci. */
      then call INSERT_LEAF_KEY_IN_TARGET_CI (ADJUST_TARGET_ELEMENT_ID_FOR_NEXT_INSERT, high_key_string_ptr);
      else call CHECK_STORAGE_REQUIREMENTS (total_amount_of_storage_moved, additional_storage_required);

/* Replace the modified headers. */

      call MODIFY_HEADERS (LEAF_NODE);

/* Replace the modified CI buffers. */

      call REPLACE_NODE_BUFFERS ();

   end ROTATE_NEXT_LEAF;
%page;
/* This procedure rotates keys into the previous branch node and attempts to
insert p_key_string.
*/

ROTATE_PREVIOUS_BRANCH:
   proc ();
      dcl	    rpb_code	       fixed bin (35);

      high_index = p_key_id.index;
      low_index = source_ci_header_ptr -> common_ci_header.key_range.first + 1;
      call ROTATE (PREVIOUS_ROTATION);


      if p_key_id.index = source_ci_header_ptr -> common_ci_header.key_range.first
      then call INSERT_KEY_AS_LOW_BRANCH_ID (source_ci_header_ptr, source_ci_header_has_changed);
      else
         do;
	  if source_ci_header_ptr -> branch_ci_header.low_branch_id = 0
	  then
	     do;
	        call COMPRESS_LOW_BRANCH_ID (UPDATE_STORAGE_MOVED, source_ci, source_ci_header_ptr,
		   source_ci_header_has_changed, update_source_branches);
	        p_key_id.index = p_key_id.index - 1;
	     end;
	  if total_amount_of_storage_moved >= additional_storage_required
	  then call INSERT_BRANCH_KEY_IN_SOURCE ();
	  else call CHECK_STORAGE_REQUIREMENTS (total_amount_of_storage_moved, additional_storage_required);
         end;

      call MODIFY_HEADERS (BRANCH_NODE);

/* Update the parent threads of the children of the source and target CIs. */

      if update_source_branches
      then call im_update_branches (source_ci_ptr, index_opening_info.file_opening_id, index_opening_info.collection_id,
	      source_ci_header_ptr, source_ci, 0, rpb_code);
      else call im_update_branches$single (source_ci_ptr, index_opening_info.file_opening_id,
	      index_opening_info.collection_id, source_ci_header_ptr, source_ci, 0, rpb_code);
      if rpb_code ^= 0
      then call ERROR_RETURN (rpb_code);

      call im_update_branches (target_ci_ptr, index_opening_info.file_opening_id, index_opening_info.collection_id,
	 target_ci_header_ptr, target_ci, original_target_index, rpb_code);
      if rpb_code ^= 0
      then call ERROR_RETURN (rpb_code);

/* Replace the modified CI buffers. */

      call REPLACE_NODE_BUFFERS ();

/* Update the parent key. */

      call SETUP_PARENT_KEY (source_ci_header_ptr, source_ci);
   end ROTATE_PREVIOUS_BRANCH;
%page;
/* This procedure rotates keys into the previous leaf node and attempts to
insert the p_key_string.
*/

ROTATE_PREVIOUS_LEAF:
   proc ();
      high_index = p_key_id.index;
      low_index = source_ci_header_ptr -> common_ci_header.key_range.first + 1;

      call ROTATE (PREVIOUS_ROTATION);

      if total_amount_of_storage_moved >= additional_storage_required
      then call INSERT_LEAF_KEY_IN_SOURCE_CI (source_ci_header_ptr -> common_ci_header.key_range.first,
	      high_key_string_ptr);
      else if there_is_more_room_in_target_ci
      then call INSERT_LEAF_KEY_IN_TARGET_CI (ADJUST_TARGET_ELEMENT_ID_FOR_PREVIOUS_INSERT, low_key_string_ptr);
      else call CHECK_STORAGE_REQUIREMENTS (total_amount_of_storage_moved, additional_storage_required);

/* Replace the modified headers. */

      call MODIFY_HEADERS (LEAF_NODE);

/* Replace the modified CI buffers. */

      call REPLACE_NODE_BUFFERS ();

   end ROTATE_PREVIOUS_LEAF;
%page;
/* This procedure sets ssp_p_key_string_ptr to point at the key value portion
of the key at ssp_p_key_ptr.
*/

SET_STRING_PTR:
   proc (ssp_p_is_leaf, ssp_p_key_ptr, ssp_p_key_string_ptr);
      dcl	    ssp_p_is_leaf	       bit (1);
      dcl	    ssp_p_key_ptr	       ptr;
      dcl	    ssp_p_key_string_ptr   ptr;

      bk_string_length, lk_string_length = 0;
      if ssp_p_is_leaf
      then ssp_p_key_string_ptr = addr (ssp_p_key_ptr -> leaf_key.string);
      else ssp_p_key_string_ptr = addr (ssp_p_key_ptr -> branch_key.string);

%include dm_im_key;
   end SET_STRING_PTR;
%page;
/* This procedure creates a parent key from the source and target leaf nodes. */

SETUP_PARENT_KEY_FROM_LEAF_NODE:
   proc (spkfln_p_rotate_previous);
      dcl	    spkfln_p_rotate_previous
			       bit (1) aligned;
      dcl	    spkfln_code	       fixed bin (35);

      if high_key_string_ptr = null
      then
         do;
	  if spkfln_p_rotate_previous
	  then call GET_ELEMENT (source_ci, (source_ci_header_ptr -> common_ci_header.key_range.first), key_buffer_3,
		  (0));
	  else call GET_ELEMENT (target_ci, (target_ci_header_ptr -> common_ci_header.key_range.first), key_buffer_3,
		  (0));
	  call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, addr (key_buffer_3),
	       high_key_string_ptr);
         end;
      else if low_key_string_ptr = null
      then
         do;
	  if spkfln_p_rotate_previous
	  then call GET_ELEMENT (target_ci, (target_ci_header_ptr -> common_ci_header.key_range.last), key_buffer_3,
		  (0));
	  else call GET_ELEMENT (source_ci, (source_ci_header_ptr -> common_ci_header.key_range.last), key_buffer_3,
		  (0));

	  call SET_STRING_PTR (source_ci_header_ptr -> common_ci_header.is_leaf, addr (key_buffer_3),
	       low_key_string_ptr);
         end;
      call im_make_parent_key (index_opening_info.field_table_ptr, low_key_string_ptr, ALL_FIELDS_PRESENT,
	 high_key_string_ptr, ALL_FIELDS_PRESENT, addr (parent_key_buffer), length (parent_key_buffer), null,
	 branch_key_ptr, bk_string_length, "0"b, spkfln_code);
      if spkfln_code ^= 0
      then call ERROR_RETURN (spkfln_code);

      if spkfln_p_rotate_previous
      then branch_key.branch_id = source_ci;
      else branch_key.branch_id = target_ci;

   end SETUP_PARENT_KEY_FROM_LEAF_NODE;
%page;
/* This procedure prepares the parent node of the source and target nodes for
the insertion of the new value parent key.
*/

SETUP_PARENT_NODE_FOR_INSERTION:
   proc (spnfi_p_rotate_previous);
      dcl	    spnfi_p_rotate_previous
			       bit (1) aligned;
      dcl	    spnfi_code	       fixed bin (35);
      dcl	    1 spnfi_element_id     aligned like element_id based (addr (spnfi_element_id_string));
      dcl	    spnfi_element_id_string
			       bit (36) aligned;

      if source_parent_id.control_interval_id > 0
      then
         do;
	  call GET_ELEMENT (source_parent_id.control_interval_id, (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT),
	       addr (local_branch_ci_header) -> based_header_buffer, 0);

	  if spnfi_p_rotate_previous
	  then
	     do;
	        source_ci_header_has_changed = "1"b;
	        target_ci_header_has_changed = "1"b;	/* The "new" (target) node (produced by the split) */
						/* has as its parent key the key which was */
						/* the parent of the "old" (source) node. */
	        target_parent_id_string = source_parent_id_string;
						/* The "old" (source) node's new parent key */
						/* going to be just 1 position greater than */
						/* its old parent key. */
	        if source_parent_id.index = 0
	        then source_parent_id.index = DEFAULT_INITIAL_KEY_SLOT;
	        else source_parent_id.index = source_parent_id.index + 1;
	     end;
	  else
	     do;
	        target_ci_header_has_changed = "1"b;
	        if source_parent_id.index = 0
	        then target_parent_id.index = DEFAULT_INITIAL_KEY_SLOT;
	        else target_parent_id.index = target_parent_id.index + 1;
	     end;
         end;
      else
         do;
	  call im_init_branch_ci_header (addr (local_branch_ci_header));
	  call collection_manager_$allocate_control_interval (index_opening_info.file_opening_id,
	       index_opening_info.collection_id, new_ci, spnfi_code);
	  if spnfi_code ^= 0
	  then call ERROR_RETURN (spnfi_code);

	  if spnfi_p_rotate_previous
	  then local_branch_ci_header.low_branch_id = target_ci;
	  else local_branch_ci_header.low_branch_id = source_ci;

	  local_branch_ci_header.key_range = 0;
	  spnfi_element_id.control_interval_id = new_ci;
	  spnfi_element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
	  call PUT_ELEMENT (spnfi_element_id_string, length (unspec (local_branch_ci_header)),
	       addr (local_branch_ci_header), (0));

/* Record the new root control interval's location in the header. */

	  call im_update_opening_info$root_id (index_opening_info_ptr, new_ci, spnfi_code);
	  if spnfi_code ^= 0
	  then call ERROR_RETURN (spnfi_code);

/* Fix the ci_headers of the target and source control intervals to
"point" at the new root ci as their parent. */

	  spnfi_element_id.index = DEFAULT_INITIAL_KEY_SLOT;

	  if spnfi_p_rotate_previous
	  then source_parent_id_string = spnfi_element_id_string;
	  else target_parent_id_string = spnfi_element_id_string;

	  spnfi_element_id.index = 0;

	  if spnfi_p_rotate_previous
	  then target_parent_id_string = spnfi_element_id_string;
	  else source_parent_id_string = spnfi_element_id_string;
	  source_ci_header_has_changed, target_ci_header_has_changed = "1"b;
         end;
   end SETUP_PARENT_NODE_FOR_INSERTION;
%page;
/* This procedure builds a new parent key for splitting the rotated source and
target branch nodes.
*/

SETUP_PARENT_KEY:
   proc (spk_p_ci_header_ptr, spk_p_ci_id);
      dcl	    spk_p_ci_header_ptr    ptr parameter;
      dcl	    spk_p_ci_id	       fixed bin (24) unsigned unaligned parameter;
      dcl	    spk_code	       fixed bin (35);

      if addr (p_key_string) -> branch_key.branch_id = spk_p_ci_header_ptr -> branch_ci_header.low_branch_id
      then
         do;
	  branch_key_ptr = addr (p_key_string);
	  bk_string_length = length (p_key_string) - BRANCH_KEY_HEADER_LENGTH_IN_BITS;
         end;
      else
         do;
	  call FIND_SPLIT_KEYS (spk_p_ci_header_ptr -> branch_ci_header.low_branch_id, key_buffer_1, key_buffer_2);

	  call SET_STRING_PTR ("1"b, addr (key_buffer_1), low_key_string_ptr);
	  call SET_STRING_PTR ("1"b, addr (key_buffer_2), high_key_string_ptr);
	  call im_make_parent_key (index_opening_info.field_table_ptr, low_key_string_ptr, ALL_FIELDS_PRESENT,
	       high_key_string_ptr, ALL_FIELDS_PRESENT, addr (parent_key_buffer), length (parent_key_buffer), null,
	       branch_key_ptr, bk_string_length, "0"b, spk_code);
	  if spk_code ^= 0
	  then call ERROR_RETURN (spk_code);
         end;
      branch_key.branch_id = spk_p_ci_id;
   end SETUP_PARENT_KEY;
%page;
%include dm_im_key;
%page;
%include dm_element_id;
%page;
%include dm_im_ci_header;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_im_opening_info;
%page;
%include sub_err_flags;
   end im_rotate_insert;




		    im_set_cursor.pl1               01/04/85  0917.4re  01/03/85  1146.9       44019



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

/* DESCRIPTION:

         This  subroutine  sets a cursor to a caller-specified position.  The
     defined positions are:  1) to a "current key value"; 2) to the  beginning
     of the index; 3) to the end of the index.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 02/25/83.
Modified:
05/10/84 by Matthew Pierret:  Changed to align current_key_string on an
            even_word boundary.
*/

/* format: style2,ind3 */

im_set_cursor:
   proc;
      return;

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

      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_key_id_string	       bit (36) aligned parameter;
      dcl	    p_key_string_ptr       ptr parameter;
      dcl	    p_key_string_length    fixed bin (24) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (local_current_key_exists, local_at_beginning_of_index, local_at_end_of_index)
			       bit (1) aligned init ("0"b);
      dcl	    cks_length	       fixed bin (35) init (0);
      dcl	    cksb_length	       fixed bin (35) init (0);
      dcl	    current_key_string_ptr ptr init (null);
      dcl	    index_cursor_area_ptr  ptr init (null);

/* Based */

      dcl	    current_key_string_buffer
			       (cksb_length) fixed bin (71) based (current_key_string_ptr);
      dcl	    current_key_string     bit (cks_length) based (current_key_string_ptr);
      dcl	    index_cursor_area      area based (index_cursor_area_ptr);

/* Builtin */

      dcl	    (divide, null, string) builtin;

/* Constant */

      dcl	    myname	       init ("im_set_cursor") char (32) varying internal static options (constant);
      dcl	    BITS_PER_DOUBLE_WORD   init (72) fixed bin internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

at_current:
   entry (p_index_cursor_ptr, p_key_id_string, p_key_string_ptr, p_key_string_length, p_code);
      local_current_key_exists = "1"b;
      goto JOIN;

no_current:
   entry (p_index_cursor_ptr, p_key_id_string, p_key_string_ptr, p_key_string_length, p_code);
      goto JOIN;

at_beginning:
   entry (p_index_cursor_ptr, p_key_id_string, p_key_string_ptr, p_key_string_length, p_code);
      local_at_beginning_of_index = "1"b;
      goto JOIN;

at_end:
   entry (p_index_cursor_ptr, p_key_id_string, p_key_string_ptr, p_key_string_length, p_code);
      local_at_end_of_index = "1"b;

JOIN:
      index_cursor_ptr = p_index_cursor_ptr;
      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      p_code = 0;
      index_cursor_area_ptr = index_cursor.area_ptr;
      cks_length = index_cursor.current_key_string_length;

      string (index_cursor.flags) = "0"b;
      if index_cursor.current_key_string_ptr ^= null & index_cursor.current_key_string_ptr ^= p_key_string_ptr
      then free index_cursor.current_key_string_ptr -> current_key_string in (index_cursor_area);

      if p_key_string_ptr = null
      then index_cursor.current_key_string_ptr = null;
      else if index_cursor.current_key_string_ptr ^= p_key_string_ptr
      then
         do;
	  cks_length = p_key_string_length;
	  cksb_length = divide (cks_length, BITS_PER_DOUBLE_WORD, 35, 0) + 1;
	  alloc current_key_string_buffer in (index_cursor_area);
	  current_key_string = p_key_string_ptr -> current_key_string;
	  index_cursor.current_key_string_ptr = current_key_string_ptr;
	  index_cursor.current_key_string_length = cks_length;
         end;
      index_cursor.flags.is_at_end_of_index = local_at_end_of_index;
      index_cursor.flags.is_at_beginning_of_index = local_at_beginning_of_index;
      index_cursor.flags.current_key_exists = local_current_key_exists;
      index_cursor.key_id_string = p_key_id_string;
      index_cursor.flags.is_valid = "1"b;
      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include dm_im_cursor;
   end im_set_cursor;




		    im_simple_delete.pl1            04/04/85  1109.9r w 04/04/85  0913.4      141192



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

/* DESCRIPTION:

         This  module  frees  a single key from a node of the index.  It also
     updates the key_tail_space_used_since_last_prefix_compaction and
     key_range.last is decremented by 1.  If the node is a branch node, the
     nodes pointed to by the keys between the one freed and the high end of
     node have their parent_id_strings updated to point to the new locations
     of the keys (which slide over one to close up the gap left by the freed
     key).

          This module does all of the modification to the control interval
     (node) in which the key to be deleted exists necessary to delete it.
     For reasons of efficiency, it makes these modifications by bypassing
     the collection_manager_ and calling file_manager_ directly.  Again for
     reasons of efficiency, it does so in one call to file_manager_ by 
     consolidating all of the modifications in one ci_parts structure.

          Because this module bypasses the collection_manager_, it must
     understand the format of the control interval.  The format is described
     by the basic_control_interval structure (dm_cm_basic_ci.incl.pl1).
     Following is a diagram of a control interval accompanied with the names
     of some of the structures which overlay it:
     
     basic_control_interval.header, bci_header
     |          basic_control_interval.datum_position_table, slots
     |          |
     v          v
      ------------------------------------------------------------------
     |          | | | | | | | | |               |    | / / |    | / |   |
     | 20 bytes | | four bytes| | un-used space |    |/ / /|    |/ /|   |
     |          | | per  slot | |               |    | / / |    | / |   |
      ------------------------------------------------------------------
                                                  ^     ^         ^   ^
                                                  |     |         |   |
                                                  |     free space    |
                                                  |                   |
                                                  stored data - keys and
                                                     index CI header
     
     This control interval is not modified in place. New values for parts
     of the control interval are kept in local buffers.  Four modifications
     are made: the bci_header is updated, part of the slots are shifted one
     slot to the left, the last slot is made to zero and the element which
     holds the index CI header is updated.  To make the first modification, a
     local copy of bci_header is made, modified and identified as a new value
     to be placed where the old bci_header was.  The shift is accomplished by
     identifiying the slots to the right of the slot of the key being deleted
     as a new part to be placed starting at the slot of the old key. Since the
     values of the slots are not actually change, just moved, a local copy is
     not necessary.  A one-word constant is used as the new value to be placed
     on top of the last slot.  An automatic copy of the index CI header is
     passed to this procedure, is updated and placed over its old location in
     the control interval.
     
     The parameter p_node_ptr must point to a control interval in a file.
     This pointer should have been set by calling
     collection_manager_$get_control_interval_ptr or file_manager_$get_ci_ptr.
     
     The parameter p_common_ci_header_ptr points to the index CI header
     (the structure common_ci_header and one of leaf_ci_header or
     branch_ci_header).  This must not point directly into the control
     interval but point to some local copy of the index CI header.  The index
     CI header is stored as the first element in the control interval.
     
     The parameter p_key_id_string consists of two parts, the control interval
     id of the control interval to which p_node_ptr points and the index in
     the slot table (datum_position_table) of the key to be deleted.
     
     The parameter p_index_cursor_ptr points to an index cursor.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 08/06/82.
Modified:
10/18/82 by Matthew Pierret:  Corrected cm_$get_element calling sequence by
            removing offset/length arguments.  Fixed call to sub_err_ in
            check_version by adding '"s", null, 0' arguments.
12/10/82 by Lindsey Spratt:  Fixed to leave the the key_range.first and
	  key_range.last equal to 0 after deleting the last key in the
	  control interval.
02/28/83 by Lindsey Spratt:  Updated to use version 3 of the index_cursor.
04/27/83 by Lindsey L. Spratt:  Fixed to update the parent_id_strings of the
            branch nodes pointed to by keys which are moved as a result of the
            deletion.
11/08/83 by Lindsey L. Spratt:  Changed to use the "buffered" access method.
            ALso changed to use the "call ERROR_RETURN (code)" protocol.
03/28/84 by Matthew Pierret:  Changed to modify the control interval without
            calling collection_manager_, but by setting up a ci_parts structure
            on its own and calling file_manager_$put. p_node_ptr must now point
            directly to the CI in the file instead of to a buffer because a
            CI buffer would not be updated when the actual CI is updated by
            file_manager_$put.
10/12/84 by Matthew Pierret:  Changed to use the new dm_cm_basic_ci and
            dm_cm_basic_ci_const include files.
*/

/* format: style2,ind3 */

im_simple_delete:
   proc (p_node_ptr, p_index_cursor_ptr, p_common_ci_header_ptr, p_key_id_string, p_code);

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

      dcl	    p_node_ptr	       ptr parameter;
      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_common_ci_header_ptr ptr parameter;
      dcl	    p_key_id_string	       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    file_opening_id	       bit (36) aligned;
      dcl	    index_ci_header_slot_ptr
			       ptr init (null);
      dcl	    key_ci_id	       fixed bin (24) unsigned;
      dcl	    key_index	       fixed bin (12) unsigned;
      dcl	    key_length_in_bits     fixed bin (35);
      dcl	    key_length_in_bytes    fixed bin;
      dcl	    key_offset_in_bytes    fixed bin;
      dcl	    key_slot_offset_in_bytes
			       fixed bin;
      dcl	    key_slot_ptr	       ptr init (null);
      dcl	    1 local_bci_header     aligned like bci_header;
      dcl	    local_ci_parts_buffer  (10) fixed bin (71) init ((10) 0);
						/* Four parts */
      dcl	    node_ptr	       ptr init (null);

/* Based */

      dcl	    1 p_key_id	       aligned like element_id based (addr (p_key_id_string));
      dcl	    1 index_ci_header_slot aligned like datum_slot based (index_ci_header_slot_ptr);
      dcl	    1 key_slot	       aligned like datum_slot based (key_slot_ptr);

/* Builtin */

      dcl	    (addcharno, addr, ceil, divide, max, null, size, unspec)
			       builtin;

/* Constant */

      dcl	    myname	       init ("im_simple_delete") char (16) internal static options (constant);
      dcl	    (
	    BYTES_PER_WORD	       init (4),
	    BITS_PER_BYTE	       init (9)
	    )		       fixed bin internal static options (constant);
      dcl	    ZERO_SLOT	       init (0) fixed bin (35) internal static options (constant);

      dcl	    (
	    BCI_HEADER_PART_IDX    init (1),
	    INDEX_CI_HEADER_PART_IDX
			       init (2),
	    TRAILING_SLOTS_PART_IDX
			       init (3),
	    LAST_SLOT_PART_IDX     init (4),
	    NUMBER_OF_PARTS	       init (4)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    im_update_branches     entry (ptr, bit (36) aligned, bit (36) aligned, ptr, uns fixed bin (24) unal,
			       uns fixed bin (12) unal, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$wrong_cursor_type
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

/* format: indcomtxt,^indblkcom */

      code = 0;

/**** Copy paramters into local storage for efficiency. */

      node_ptr = p_node_ptr;

      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, "s", null, 0,
	      "^/Expected an ""index"" type cursor (type ^d).^/Received a cursor of type ^d instead.",
	      INDEX_CURSOR_TYPE, index_cursor.type);
      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");
      file_opening_id = index_cursor.file_opening_id;

      common_ci_header_ptr, leaf_ci_header_ptr, branch_ci_header_ptr = p_common_ci_header_ptr;

      key_ci_id = p_key_id.control_interval_id;
      key_index = p_key_id.index;

/**** Init local buffers. */

      unspec (local_bci_header) = unspec (node_ptr -> bci_header);
      ci_parts_ptr = addr (local_ci_parts_buffer);
      ci_parts.number_of_parts = NUMBER_OF_PARTS;

/**** Get length of key to be deleted. */

      key_slot_offset_in_bytes = DATUM_POSITION_TABLE_OFFSET_IN_BYTES + (key_index - 1) * BYTES_PER_WORD;
      key_slot_ptr = addcharno (node_ptr, key_slot_offset_in_bytes);

      key_offset_in_bytes = key_slot.offset_in_bytes;
      key_length_in_bits = key_slot.length_in_bits;

      if common_ci_header.is_leaf
      then common_ci_header.key_tail_space_used_since_last_prefix_compaction =
	      max (common_ci_header.key_tail_space_used_since_last_prefix_compaction - key_length_in_bits, 0);
      else common_ci_header.key_tail_space_used_since_last_prefix_compaction =
	      max (common_ci_header.key_tail_space_used_since_last_prefix_compaction
	      - (key_length_in_bits - BRANCH_KEY_HEADER_LENGTH_IN_BITS), 0);

/**** Setup to free the key by setting the ci parts to trailing shift the
      slots to the left (if there are any) and to zero out the last slot. */

      if key_index >= local_bci_header.number_of_datums
      then ci_parts.part (TRAILING_SLOTS_PART_IDX).length_in_bytes = 0;
						/* No trailing slots. Skip this part. */
      else
         do;					/* Shift trailing slots */
	  ci_parts.part (TRAILING_SLOTS_PART_IDX).offset_in_bytes = key_slot_offset_in_bytes;
	  ci_parts.part (TRAILING_SLOTS_PART_IDX).length_in_bytes =
	       BYTES_PER_WORD * (local_bci_header.number_of_datums - key_index);
	  ci_parts.part (TRAILING_SLOTS_PART_IDX).local_ptr =
	       addcharno (node_ptr, key_slot_offset_in_bytes + BYTES_PER_WORD);
						/* Points to slot after slot being freed.  */
         end;

      ci_parts.part (LAST_SLOT_PART_IDX).offset_in_bytes =
	 DATUM_POSITION_TABLE_OFFSET_IN_BYTES + BYTES_PER_WORD * (local_bci_header.number_of_datums - 1);
      ci_parts.part (LAST_SLOT_PART_IDX).length_in_bytes = BYTES_PER_WORD;
      ci_parts.part (LAST_SLOT_PART_IDX).local_ptr = addr (ZERO_SLOT);

/**** Update the bci_header.  This includes decrementing the number of
      datums (slots) in the control interval, adding the space taken up by
      the key to be deleted to the count of scattered free bytes, and, if the
      contents of the key was at the beginning of the used space, change the
      value of the start of used space. */

      local_bci_header.number_of_datums = local_bci_header.number_of_datums - 1;
      key_length_in_bytes = ceil (divide (key_length_in_bits, BITS_PER_BYTE, 35, 18));

      if local_bci_header.start_of_used_space = key_offset_in_bytes
      then local_bci_header.start_of_used_space = local_bci_header.start_of_used_space + key_length_in_bytes;
						/* The deletion increased the size of the un-used portion */
      else local_bci_header.scattered_free_space = local_bci_header.scattered_free_space + key_length_in_bytes;
						/* The deletion created more scattered free space */

      ci_parts.part (BCI_HEADER_PART_IDX).offset_in_bytes = 0;
						/* bci_header is at beginning of control interval */
      ci_parts.part (BCI_HEADER_PART_IDX).length_in_bytes = BCI_HEADER_LENGTH_IN_BYTES;
      ci_parts.part (BCI_HEADER_PART_IDX).local_ptr = addr (local_bci_header);

/**** Update key range in common_ci_header to reflect fact that there is one less key. */

      if common_ci_header.key_range.last = common_ci_header.key_range.first
      then common_ci_header.key_range.last, common_ci_header.key_range.first = 0;
      else common_ci_header.key_range.last = common_ci_header.key_range.last - 1;

/**** Replace common_ci_header.  It is the datum described by the slot
      with the index DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT.  The slot does
      not change so is not replaced. */

      index_ci_header_slot_ptr =
	 addcharno (node_ptr,
	 DATUM_POSITION_TABLE_OFFSET_IN_BYTES + (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT - 1) * BYTES_PER_WORD);

      ci_parts.part (INDEX_CI_HEADER_PART_IDX).offset_in_bytes = index_ci_header_slot.offset_in_bytes;
      ci_parts.part (INDEX_CI_HEADER_PART_IDX).length_in_bytes =
	 divide (index_ci_header_slot.length_in_bits, BITS_PER_BYTE, 17, 0);
						/* The index ci header is always an integral number of bytes long. */
      ci_parts.part (INDEX_CI_HEADER_PART_IDX).local_ptr = common_ci_header_ptr;

/**** Actually modify the control interval in the file. */

      call file_manager_$put (file_opening_id, (key_ci_id), ci_parts_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);


      if ^common_ci_header.is_leaf
      then if common_ci_header.key_range.last >= key_index
	 then
	    do;

	    /*** There are keys higher than the one deleted,
	         whose branch nodes need to have their
	         parent_id_strings updated. Note that the key at
	         key_index is now the one which was next higher
	         than the deleted key, hence the check is for ">="
	         instead of just ">". */

	       call im_update_branches (node_ptr, file_opening_id, index_cursor.collection_id, common_ci_header_ptr,
		  (key_ci_id), (key_index), code);
	       if code ^= 0
	       then call ERROR_RETURN (code);
	    end;

      p_code = 0;
MAIN_RETURN:
      return;


FINISH:
   proc ();
   end FINISH;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);
      call FINISH;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ^d of the ^a structure. Received version ^d instead.", p_expected_version,
	      p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include dm_im_cursor;
%page;
%include dm_im_key;
%page;
%include dm_im_ci_header;
%page;
%include dm_element_id;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_ci_parts;
%page;
%include dm_collmgr_entry_dcls;
   end im_simple_delete;




		    im_simple_insert.pl1            04/04/85  1109.9re  04/04/85  0823.4      186696



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


/* DESCRIPTION:
     
           This module attempts to allocate the specified key_string into
     a control and slot as specified by the p_element_id_string. If
     successful, it updates the index_header.  If not successful, it just
     returns the amount of additional storage needed to complete the storage
     operation in the specified control interval.  This information is used by
     im_rotate_insert.

          This module does all of the modification to the control interval
     (node) in which the key to be inserted exists necessary to insert it.
     For reasons of efficiency, it makes these modifications by bypassing
     the collection_manager_ and calling file_manager_ directly.  Again for
     reasons of efficiency, it does so in one call to file_manager_ by 
     consolidating all of the modifications in one ci_parts structure.

          Because this module bypasses the collection_manager_, it must
     understand the format of the control interval.  The format is described
     by the basic_control_interval structure (dm_cm_basic_ci.incl.pl1).
     Following is a diagram of a control interval accompanied with the names
     of some of the structures which overlay it:
     
     basic_control_interval.header, bci_header
     |          basic_control_interval.datum_position_table, slots
     |          |
     v          v
      ------------------------------------------------------------------
     |          | | | | | | | | |               |    | / / |    | / |   |
     | 20 bytes | | four bytes| | un-used space |    |/ / /|    |/ /|   |
     |          | | per  slot | |  (free pool)  |    | / / |    | / |   |
      ------------------------------------------------------------------
                                                  ^     ^         ^   ^
                                                  |     |         |   |
                                                  |     free space    |
                                                  |                   |
                                                  stored data - keys and
                                                     index CI header
     
     This control interval is not modified in place. New values for parts
     of the control interval are kept in local buffers.  Modifiactions are
     actually made by creating a ci_parts structure describing the offset and
     length of the new value in the control interval and a pointer to a local
     buffer, then by calling file_manager_$put to do the modification.
     
     Four or five modifications are made:
      1) the bci_header is updated to reflect existence of new datum;
      2) trailing slots are shifted one slot to the right to make room for the
         new slot if the new slot is not the last slot;
      3) the new key is placed in the free pool;
      4) the slot for the new key is updated with the correct values for it
         offset and length;
      5) the element which holds the index CI header is updated.

     It is possible that the control interval will have to be compacted to get
     rid of scattered free space and concentrate all free space in the free
     pool.  This module is not equipped to handle this and must call
     collection_manager_$compact_control_interval.  It is important that any
     information copied out of the control interval into local storage prior
     to the compaction be copied out again after the compaction as its value
     may have changed during the compaction.
     
     Both the bci_header and the slots from the slot for the new key to the
     last slot (the trailing slots) are copied into local buffers.  This is
     because the bci_header will be modified.  The trailing slots are not
     modified, just moved, so it would seem that they need not be copied out
     of the control interval.  In fact, when shifting slots to the left, one
     can give file_manager_ a pointer to the beginning of the slots and
     pretend they are in a local buffer.  When shifting to the right,
     file_manager_ is implemented such that it would over-write the buffer if
     a pointer into the control interval were given as the local buffer
     pointer.  For this reason the trailing slots must be copied out of the
     control interval into local storage.

     The parameter p_index_opening_info_ptr points to an index_opening_info
     structure.  This contains general information about the index and
     information specific to this process's activity relative to the index.
     
     The parameter p_common_ci_header_ptr points to the index CI header
     (the structure common_ci_header and one of leaf_ci_header or
     branch_ci_header).  This must not point directly into the control
     interval but point to some local copy of the index CI header.  The index
     CI header is stored as the first element in the control interval.

     The parameter p_insert_key is a flag which, if on, indicates that the
     input key is to be inserted as a new key.  If off, the input key is to
     replace an existing key.
          
     The parameter p_key_id_string consists of two parts, the control interval
     id of the control interval to which p_node_ptr points and the index in
     the slot table (datum_position_table) of the key to be inserted/replaced.
     If a key is inserted, slots to the right of the specified slot must be
     shifted one slot to the right to make room for the new slot.
     
     The output parameter p_additional_storage_required has one of two
     meanings.  If the operation is successful (p_code is equal to 0), it is
     the amount of free space in bits left in the control interval after the
     insertion; if the operation fails for a lack of room (p_code is equal to
     dm_error_$long_element), it is the amount of used space in bits that must
     be removed from the control interval in order for the key to fit; if the
     operation fails for any other reason, the parameter has no meaning.
     
*/

/* HISTORY:

Written by Lindsey Spratt, 04/07/82.
Modified:
06/16/82 by Matthew Pierret: Removed the beginning_offset argument from
            calls to collection_manager_$put_element.
10/28/82 by Lindsey Spratt:  Changed to not modify the key_count.  This is
	  now done by im_put_key.
11/01/82 by Lindsey Spratt:  Changed to use the index_opening_info instead of
	  the index_cursor and index_header.
11/16/82 by Matthew Pierret: Changed the meaning of total_storage_available.
            cm_$(allocate put)_element now returns a negative value for
            total_storage_available, it is the additional space required.
11/08/83 by Lindsey L. Spratt:  Changed to use the "buffered" access method
            when p_insert_new_key is "1"b.  This was forced by
            im_update_branches requiring a node_buffer.
04/03/84 by Matthew Pierret:  Changed extensively to do its own storage 
            management.  This module was taught about control interval
            format so that it could bypass collection_manager_
            $allocate_element and $put_element.
06/12/84 by Matthew Pierret:  Re-named cm_$put_element to cm_$modify.
10/12/84 by Matthew Pierret:  Changed to use new dm_cm_basic_ci and
            dm_cm_basic_ci_const include files.
10/28/84 by Lindsey L. Spratt:  Changed to use the version 2
            index_opening_info structure.  Changed CHECK_VERSION to take
            char(8) aligned parameters, and changed it use ACTION_CANT_RESTART
            instead of the obsolete "s" flag.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
*/

/* format: style2,ind3 */

im_simple_insert:
   proc (p_index_opening_info_ptr, p_common_ci_header_ptr, p_insert_new_key, p_key_string, p_key_id_string,
        p_additional_storage_required, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_common_ci_header_ptr ptr;
      dcl	    p_insert_new_key       bit (1) aligned;
      dcl	    p_key_string	       bit (*);
      dcl	    p_key_id_string	       bit (36) aligned;
      dcl	    p_additional_storage_required
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    free_bytes_in_ci       fixed bin (35) init (-1);
      dcl	    free_bytes_in_pool     fixed bin (35) init (-1);
      dcl	    index_ci_header_slot_offset_in_bytes
			       fixed bin;
      dcl	    index_ci_header_slot_ptr
			       ptr init (null);
      dcl	    key_ci_id	       fixed bin (24) unsigned;
      dcl	    key_index	       fixed bin (12) unsigned;
      dcl	    key_slot_offset_in_bytes
			       fixed bin (35);
      dcl	    key_string_offset_in_bytes
			       fixed bin (35);
      dcl	    key_string_length_in_bits
			       fixed bin (35);
      dcl	    key_string_length_in_bytes
			       fixed bin (35);
      dcl	    key_string_ptr	       ptr init (null);
      dcl	    local_ci_parts_buffer  (12) fixed bin (71) init ((12) 0);
						/* 5 parts */
      dcl	    1 local_bci_header     aligned like bci_header;
      dcl	    1 local_key_slot       aligned like datum_slot;
      dcl	    local_slots_buffer     (404) fixed bin (71);	/* Largest possible slot table */
      dcl	    new_number_of_slots    fixed bin;
      dcl	    node_ptr	       ptr init (null);
      dcl	    number_of_new_slots    fixed bin;
      dcl	    number_of_slots_to_shift
			       fixed bin (35);
      dcl	    slots_in_ci_ptr	       ptr init (null);
      dcl	    slots_in_local_ptr     ptr init (null);
      dcl	    total_storage_available
			       fixed bin (35) init (0);

/* Based */

      dcl	    1 p_key_id	       aligned like element_id based (addr (p_key_id_string));
      dcl	    1 index_ci_header_slot aligned like datum_slot based (index_ci_header_slot_ptr);
      dcl	    key_string	       bit (key_string_length_in_bits) based (key_string_ptr);
      dcl	    1 shifted_slots	       aligned based,
	      2 slot	       (number_of_slots_to_shift) fixed bin (35);

/* Builtin */

      dcl	    (length, null, addr, abs, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    (
	    BITS_PER_BYTE	       init (9),
	    BYTES_PER_WORD	       init (4),
	    BEGINNING_OF_ELEMENT   init (-1)
	    )		       fixed bin (35) internal static options (constant);
      dcl	    myname	       init ("im_simple_insert") char (32) varying internal static options (constant);
      dcl	    (
	    BCI_HEADER_PART_IDX    init (1),
	    INDEX_CI_HEADER_PART_IDX
			       init (2),
	    KEY_SLOT_PART_IDX      init (3),
	    KEY_PART_IDX	       init (4),
	    SHIFTED_SLOTS_PART_IDX init (5),
	    DEFAULT_NUMBER_OF_PARTS
			       init (5)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    file_manager_$get_ci_ptr
			       entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    file_manager_$put      entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
      dcl	    im_update_branches     entry (ptr, bit (36) aligned, bit (36) aligned, ptr, fixed bin (24) unsigned unal,
			       fixed bin (12) unsigned unal, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$long_element fixed bin (35) ext;
      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

/* format: indcomtxt,^indblkcom */

/**** Copy parameters into local storage. */

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      common_ci_header_ptr = p_common_ci_header_ptr;
      leaf_ci_header_ptr, branch_ci_header_ptr = null;

      key_string_ptr = addr (p_key_string);
      key_string_length_in_bits = length (p_key_string);
      key_string_length_in_bytes = ceil (divide (key_string_length_in_bits, BITS_PER_BYTE, 35, 18));

      key_ci_id = p_key_id.control_interval_id;
      key_index = p_key_id.index;

/**** Insert or replace key. */

      if p_insert_new_key
      then
INSERT_KEY:
         do;

         /*** Get a pointer to the control interval which is the node which
	    is to contain the new key. */

	  call file_manager_$get_ci_ptr (index_opening_info.file_opening_id, (key_ci_id), node_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Copy bci_header from control interval to local storage.  This is necessary
	    because the control interval cannot be modified directly.  A local copy is
	    made and updated, then replaced in the control interval by file_manager_. */

	  unspec (local_bci_header) = unspec (node_ptr -> bci_header);

         /*** Init ci_parts structure. */

	  ci_parts_ptr = addr (local_ci_parts_buffer);
	  ci_parts.number_of_parts = DEFAULT_NUMBER_OF_PARTS;


	  new_number_of_slots = max (key_index, local_bci_header.number_of_datums + 1);
						/* Is the max really necessary? */

         /*** Determine if there is enough space in the control interval for the key. */

	  number_of_new_slots = new_number_of_slots - local_bci_header.number_of_datums;
	  free_bytes_in_pool =
	       local_bci_header.start_of_used_space
	       - (DATUM_POSITION_TABLE_OFFSET_IN_BYTES + new_number_of_slots * BYTES_PER_WORD);
	  free_bytes_in_ci =
	       free_bytes_in_pool + local_bci_header.scattered_free_space - key_string_length_in_bytes
	       - (number_of_new_slots * BYTES_PER_WORD);

	  if free_bytes_in_ci < 0
	  then
	     do;
	        p_additional_storage_required = abs (free_bytes_in_ci) * BITS_PER_BYTE;
	        call ERROR_RETURN (dm_error_$long_element);
	     end;

/* Must the control interval be compacted? */
	  if free_bytes_in_pool < key_string_length_in_bytes
	  then
	     do;
	        call collection_manager_$compact_control_interval (index_opening_info.file_opening_id, key_ci_id, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	        unspec (local_bci_header) = unspec (node_ptr -> bci_header);
						/* The bci_header may have been modified by the previous call */
						/* so refresh it. */
	     end;

         /*** The key can now be inserted in the free pool. */

	  key_string_offset_in_bytes = local_bci_header.start_of_used_space - key_string_length_in_bytes;

	  ci_parts.part (KEY_PART_IDX).offset_in_bytes = key_string_offset_in_bytes;
	  ci_parts.part (KEY_PART_IDX).length_in_bytes = key_string_length_in_bytes;
	  ci_parts.part (KEY_PART_IDX).local_ptr = key_string_ptr;

	  unspec (local_key_slot) = "0"b;
	  local_key_slot.offset_in_bytes = key_string_offset_in_bytes;
	  local_key_slot.length_in_bits = key_string_length_in_bits;

	  key_slot_offset_in_bytes = DATUM_POSITION_TABLE_OFFSET_IN_BYTES + BYTES_PER_WORD * (key_index - 1);

	  ci_parts.part (KEY_SLOT_PART_IDX).offset_in_bytes = key_slot_offset_in_bytes;
	  ci_parts.part (KEY_SLOT_PART_IDX).length_in_bytes = BYTES_PER_WORD;
	  ci_parts.part (KEY_SLOT_PART_IDX).local_ptr = addr (local_key_slot);

         /*** If necessary, shift trailing slots one to the rigth to make room. */

	  if key_index < new_number_of_slots
	  then
	     do;					/* Slots to the right must be shifted to make room */

	     /*** Copy slots from control interval to local buffer.  This copy must be done
		after the potential call to collection_manager_$compact_control_interval
		since that routine alters the values of the slots. */

	        slots_in_ci_ptr = addcharno (node_ptr, key_slot_offset_in_bytes);
	        slots_in_local_ptr = addr (local_slots_buffer);
	        number_of_slots_to_shift = new_number_of_slots - key_index;

	        unspec (slots_in_local_ptr -> shifted_slots) = unspec (slots_in_ci_ptr -> shifted_slots);

/* Setup part for shifted slots. */
	        ci_parts.part (SHIFTED_SLOTS_PART_IDX).offset_in_bytes = key_slot_offset_in_bytes + BYTES_PER_WORD;
	        ci_parts.part (SHIFTED_SLOTS_PART_IDX).length_in_bytes = number_of_slots_to_shift * BYTES_PER_WORD;
	        ci_parts.part (SHIFTED_SLOTS_PART_IDX).local_ptr = slots_in_local_ptr;
	     end;
	  else if key_index > new_number_of_slots
	  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0);

         /*** Update the bci_header to reflect the new state of the control interval. */

	  local_bci_header.start_of_used_space = key_string_offset_in_bytes;
	  local_bci_header.number_of_datums = new_number_of_slots;

	  ci_parts.part (BCI_HEADER_PART_IDX).offset_in_bytes = 0;
	  ci_parts.part (BCI_HEADER_PART_IDX).length_in_bytes = BCI_HEADER_LENGTH_IN_BYTES;
	  ci_parts.part (BCI_HEADER_PART_IDX).local_ptr = addr (local_bci_header);

         /*** Since the key fits, no more storage is required. */

	  p_additional_storage_required = 0;

         /*** Update the index ci header to include new key. */

	  if common_ci_header.key_range.last = 0
	  then common_ci_header.key_range.last, common_ci_header.key_range.first = key_index;
	  else common_ci_header.key_range.last = common_ci_header.key_range.last + 1;
	  common_ci_header.key_tail_space_used_since_last_prefix_compaction =
	       common_ci_header.key_tail_space_used_since_last_prefix_compaction + key_string_length_in_bits;

	  index_ci_header_slot_offset_in_bytes =
	       DATUM_POSITION_TABLE_OFFSET_IN_BYTES + (DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT - 1) * BYTES_PER_WORD;
	  index_ci_header_slot_ptr = addcharno (node_ptr, index_ci_header_slot_offset_in_bytes);

	  ci_parts.part (INDEX_CI_HEADER_PART_IDX).offset_in_bytes = index_ci_header_slot.offset_in_bytes;
	  ci_parts.part (INDEX_CI_HEADER_PART_IDX).length_in_bytes =
	       divide (index_ci_header_slot.length_in_bits, BITS_PER_BYTE, 17, 0);
	  ci_parts.part (INDEX_CI_HEADER_PART_IDX).local_ptr = common_ci_header_ptr;

         /*** Finally, make the actual modification to the control interval in the file. */

	  call file_manager_$put (index_opening_info.file_opening_id, (key_ci_id), ci_parts_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

         /*** Update branches if this is a branch key and some branch keys have shifted. */

	  if ^common_ci_header.is_leaf & common_ci_header.key_range.last > key_index
	  then
	     do;
	        call im_update_branches (node_ptr, index_opening_info.file_opening_id, index_opening_info.collection_id,
		   common_ci_header_ptr, (key_ci_id), key_index + 1, code);
	        if code ^= 0
	        then call ERROR_RETURN (code);
	     end;

         end INSERT_KEY;
      else
REPLACE_KEY:
         do;
	  call collection_manager_$modify (index_opening_info.file_opening_id, index_opening_info.collection_id,
	       addr (p_key_string), length (p_key_string), p_key_id_string, total_storage_available, code);
	  if code ^= 0
	  then call CHECK_ERROR (code);
         end REPLACE_KEY;

      p_code = 0;
MAIN_RETURN:
      return;


FINISH:
   proc ();
   end FINISH;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);
      call FINISH;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;


CHECK_ERROR:
   proc (ce_p_code);
      dcl	    ce_p_code	       fixed bin (35);
      if ce_p_code = dm_error_$long_element
      then p_additional_storage_required = abs (total_storage_available);

      call ERROR_RETURN (ce_p_code);
   end CHECK_ERROR;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  char (8) aligned parameter;
      dcl	    cv_p_expected_version  char (8) aligned parameter;
      dcl	    cv_p_structure_name    char (*) parameter;

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include dm_im_ci_header;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_im_header;
%page;
%include dm_element_id;
%page;
%include dm_im_opening_info;
%page;
%include dm_cm_basic_ci;
%page;
%include dm_cm_basic_ci_const;
%page;
%include dm_ci_parts;
%page;
%include sub_err_flags;
   end im_simple_insert;




		    im_split.pl1                    04/04/85  1109.9re  04/04/85  0823.5       89721



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

/* DESCRIPTION:

          This module splits the "old" control interval (identified by
     p_old_ci).  A new control interval is allocated which becomes the "old"
     control interval's new "left" sibling in the index.  This is referred to
     as the "new" control interval and its identifier is placed in p_new_ci. 

          It is necessary to get the "old" control interval's original "left"
     sibling to update the doubly threaded list of siblings. The
     index_header's count of control intervals is also updated.
*/

/* HISTORY:

Written by Lindsey Spratt, 04/21/82.
Modified:
06/16/82 by Matthew Pierret: Removed the beginning_offset argument from
            calls to collection_manager_$put_element.
08/09/82 by Matthew Pierret: Removed offset and length arguments from calls to
            collection_manager_$get_element.
08/11/82 by Matthew Pierret:  Changed to use the aligned new_ci variable in the
            calling sequence to collection_manager_$allocate_control_interval.
05/10/84 by Matthew Pierret:  Changed to align key_buffer on an even-word
            boundary.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get,
            cm_$put_element to cm_$modify, cm_$allocate_element to cm_$put.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 of
            index_opening_info.  Changed to base old_common_ci_header and
            new_common_ci_header on automatic pointers instead of directly on
            parameters.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
*/

/* format: style2,ind3 */

im_split:
   proc (p_index_opening_info_ptr, p_old_common_ci_header_ptr, p_old_ci, p_new_common_ci_header_ptr, p_new_ci, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_old_common_ci_header_ptr
			       ptr;
      dcl	    p_old_ci	       fixed bin (24) unsigned unaligned;
      dcl	    p_new_common_ci_header_ptr
			       ptr;
      dcl	    p_new_ci	       fixed bin (24) unsigned unaligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    key_buffer	       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
      dcl	    key_buffer_length      fixed bin (35) init (BITS_PER_PAGE);
      dcl	    key_length	       fixed bin (35);
      dcl	    new_ci	       fixed bin (24) unsigned;
      dcl	    new_common_ci_header_ptr
			       ptr init (null);
      dcl	    old_common_ci_header_ptr
			       ptr init (null);
      dcl	    prev_ci	       fixed bin (24) unsigned unaligned;

      dcl	    1 local_leaf_ci_header like leaf_ci_header;
      dcl	    1 local_branch_ci_header
			       like branch_ci_header;
      dcl	    splitting_leaf	       bit (1) aligned;
      dcl	    prev_common_header_ptr ptr;

/* Based */

      dcl	    1 old_common_header    like common_ci_header based (old_common_ci_header_ptr);
      dcl	    1 new_common_header    like common_ci_header based (new_common_ci_header_ptr);
      dcl	    1 prev_common_header   like common_ci_header based (prev_common_header_ptr);

/* Builtin */

      dcl	    null		       builtin;
      dcl	    (addr, length, unspec) builtin;

/* Controlled */
/* Constant */

      dcl	    BEGINNING_OF_ELEMENT   init (-1) fixed bin (35) internal static options (constant);
      dcl	    BITS_PER_PAGE	       init (36 * 1024) fixed bin (17) internal static options (constant);
      dcl	    DOUBLE_WORDS_PER_PAGE  init (512) fixed bin (17) internal static options (constant);
      dcl	    myname	       init ("im_split") char (32) varying internal static options (constant);


/* Entry */

      dcl	    sub_err_	       entry () options (variable);

      dcl	    im_init_leaf_ci_header entry (ptr);
      dcl	    im_init_branch_ci_header
			       entry (ptr);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      old_common_ci_header_ptr = p_old_common_ci_header_ptr;
      new_common_ci_header_ptr = p_new_common_ci_header_ptr;

      splitting_leaf = old_common_header.is_leaf;

/* Allocate a new control interval.  This is the new "left" sibling for p_old_ci. */

      call collection_manager_$allocate_control_interval (index_opening_info.file_opening_id,
	 index_opening_info.collection_id, new_ci, p_code);
      if p_code ^= 0
      then return;
      else p_new_ci = new_ci;

/* The header (leaf or branch) for the new ci must be initialized. */

      if splitting_leaf
      then call im_init_leaf_ci_header (p_new_common_ci_header_ptr);
      else call im_init_branch_ci_header (p_new_common_ci_header_ptr);
      new_common_header.key_range = 0;

/* Thread in with siblings ("old" and "prev"). */

      new_common_header.previous_id = old_common_header.previous_id;
      new_common_header.next_id = p_old_ci;
      old_common_header.previous_id = p_new_ci;
      element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
      element_id.control_interval_id = p_new_ci;
      if splitting_leaf
      then call collection_manager_$put (index_opening_info.file_opening_id, index_opening_info.collection_id,
	      p_new_common_ci_header_ptr, length (unspec (local_leaf_ci_header)), element_id_string, (0), p_code);
      else call collection_manager_$put (index_opening_info.file_opening_id, index_opening_info.collection_id,
	      p_new_common_ci_header_ptr, length (unspec (local_branch_ci_header)), element_id_string, (0), p_code);

/* Adjust the parent of the split node so the old pointer to the split node
becomes a pointer to the new node (the split node's new left sibling).
*/

      if addr (old_common_header.parent_id_string) -> element_id.control_interval_id ^= 0
      then
         do;
	  if addr (old_common_header.parent_id_string) -> element_id.index = 0
	  then
	     do;
	        element_id_string = old_common_header.parent_id_string;
	        element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
	        call collection_manager_$get (index_opening_info.file_opening_id, index_opening_info.collection_id,
		   element_id_string, 0, addr (local_branch_ci_header), length (unspec (local_branch_ci_header)),
		   null, "0"b, branch_ci_header_ptr, 0, p_code);
	        if p_code ^= 0
	        then return;

	        branch_ci_header.low_branch_id = p_new_ci;


	        call collection_manager_$modify (index_opening_info.file_opening_id, index_opening_info.collection_id,
		   branch_ci_header_ptr, length (unspec (local_branch_ci_header)), element_id_string, 0, p_code);
	        if p_code ^= 0
	        then return;
	     end;
	  else
	     do;
	        element_id_string = old_common_header.parent_id_string;
	        call collection_manager_$get (index_opening_info.file_opening_id, index_opening_info.collection_id,
		   element_id_string, 0, addr (key_buffer), key_buffer_length, null, "0"b, branch_key_ptr, key_length,
		   p_code);
	        if p_code ^= 0
	        then return;

	        bk_string_length = key_length - BRANCH_KEY_HEADER_LENGTH_IN_BITS;
	        branch_key.branch_id = p_new_ci;

	        call collection_manager_$modify (index_opening_info.file_opening_id, index_opening_info.collection_id,
		   branch_key_ptr, key_length, element_id_string, 0, p_code);
	        if p_code ^= 0
	        then return;

	     end;
         end;

/* Pick up the "prev" (now the "new" node's "left" sibling) node's header.
This is adjusted to complete the threading in of the "new" node. */

      prev_ci = new_common_header.previous_id;
      if prev_ci > 0
      then
         do;

	  element_id.control_interval_id = prev_ci;
	  element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;

	  if splitting_leaf
	  then call collection_manager_$get (index_opening_info.file_opening_id, index_opening_info.collection_id,
		  element_id_string, (0), addr (local_leaf_ci_header), length (unspec (local_leaf_ci_header)), null,
		  "0"b, prev_common_header_ptr, (0), p_code);
	  else call collection_manager_$get (index_opening_info.file_opening_id, index_opening_info.collection_id,
		  element_id_string, (0), addr (local_branch_ci_header), length (unspec (local_branch_ci_header)),
		  null, "0"b, prev_common_header_ptr, (0), p_code);
	  prev_common_header.next_id = p_new_ci;
	  if splitting_leaf
	  then call collection_manager_$modify (index_opening_info.file_opening_id, index_opening_info.collection_id,
		  prev_common_header_ptr, length (unspec (local_leaf_ci_header)), element_id_string, (0), p_code);
	  else call collection_manager_$modify (index_opening_info.file_opening_id, index_opening_info.collection_id,
		  prev_common_header_ptr, length (unspec (local_branch_ci_header)), element_id_string, (0), p_code);
         end;

      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned parameter;
      dcl	    p_expected_version     char (8) aligned parameter;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_im_ci_header;
%page;
%include dm_im_key;
%page;
%include dm_im_opening_info;
%page;
%include dm_element_id;
   end im_split;




		    im_structural_search.pl1        10/02/86  1219.4r w 10/02/86  1204.8      168318



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


/* DESCRIPTION:

         This   subroutine  searches  an  index  under  the  control  of  the
     structural_specification (produced  by  im_build_structural_spec).    The
     basic  algorithm  is  to  loop over the intervals in the structural spec,
     invoking im_search_ on the high and low ends of each interval.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 06/17/82.
Modified:
08/26/82 by Lindsey Spratt:  Added "relative" searching, based on the current
	  value of the cursor.  Extended the im_basic_search calling
	  sequence to take the p_is_relative_search flag and a
	  "position_stack" which it fills in if it calculates the location
	  of the cursor.
10/07/82 by Lindsey Spratt:  Changed to use the interval_specification.
10/26/82 by Lindsey Spratt:  Changed to check for matches being found within
	  each interval.  If no match is found for any interval then
	  p_no_match is set on.  Intervals in which no match was found have
	  their id_strings set to "0"b.
10/27/82 by Lindsey Spratt:  Changed to use a "number of partial duplication
	  fields" of simple_typed_vector.number_of_dimensions + 1.
11/04/82 by Lindsey Spratt:  Fixed bug where ranges were always returning "not
	  found".  
02/25/83 by Lindsey Spratt:  Changed to take p_index_opening_info_ptr as an
	  input parameter.  Changed to call im_basic_search with
	  index_opening_info_ptr instead of field_table_ptr and root_id
	  values.  Changed to use version 3 index_cursor.  Changed the
	  calling sequence of this module to have p_index_opening_info_otr
	  instead of p_root_node_id and p_field_table_ptr.
03/24/83 by Lindsey Spratt:   Changed to use version 2 of the field_table.
	  Uppercased all of the internal proc names.
04/10/83 by Lindsey L. Spratt:  Fixed to check the validity of a range where
            values for both the low and high ends have been found by (among
            other things) looking to see if the "high" key is in the previous
            CI of the CI holding the "low" key.  This indicates that no keys
            satisfied the range, if true.
           Added error analysis and reporting to the RANGE case.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3, added
            undeclared builtins, and changed to use dm_error_$bad_vector_type
            instead of $wrong_vector_type.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 index_opening_info.
            Changed to use ERROR_RETURN.
03/01/85 by Matthew C. Pierret:  Changed to always check if the low_id_string
            is "greater" than the high_id_string if both are non-zero.
            Previously it was thought that this case could only occur in an
            equals-only search.  but it can happen in a range search also.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
03/12/85 by Lindsey Spratt:  Fixed RANGE portion of algorithm to only do the
	  low_id_string/high_id_string check if there is a non-null
	  low.value_ptr (i.e., there is an explicit low end of the range).
03/30/85 by Lindsey Spratt: Fixed RANGE searches to always honor the equal
	  portions of the constraint.  When only one of the two ends of the
	  range is explicitly given in a RANGE, and there are one or more
	  equal fields (preceding the RANGE field), then the other end of
	  the range must be searched for explicitly to be the most distant
	  keys from the specified end which still meet the equality
	  contraints.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

im_structural_search:
   proc (p_index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search, p_interval_specification_ptr, p_no_match,
        p_code);


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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_is_relative_search   bit (1) aligned parameter;
      dcl	    p_interval_specification_ptr
			       ptr parameter;
      dcl	    p_no_match	       bit (1) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    found_key	       bit (1) aligned init ("0"b);
      dcl	    1 local_leaf_ci_header like leaf_ci_header;
      dcl	    1 position_stack       aligned,
	      2 depth	       fixed bin (17),
	      2 id_string	       (10) bit (36) aligned;

      dcl	    interval_idx	       fixed bin;

/* Based */
/* Builtin */

      dcl	    (addr, length, null, unspec)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("im_structural_search") char (32) varying internal static options (constant);
      dcl	    (WANT_EQUAL, WANT_GREATER, WANT_LESS)
			       init ("1"b) bit (1) aligned options (constant) internal static;

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

/* Entry */

      dcl	    sub_err_	       entry () options (variable);
      dcl	    im_basic_search	       entry (ptr, ptr, bit (1) aligned, ptr, bit (1) aligned, bit (1) aligned,
			       bit (1) aligned, ptr, bit (36) aligned, ptr, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$wrong_cursor_type,
	    dm_error_$programming_error,
	    dm_error_$bad_first_key_idx,
	    dm_error_$bad_last_key_idx,
	    dm_error_$bad_leaf_node,
	    dm_error_$bad_vector_type,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION_CHAR (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected an ""index"" type cursor (type ^d).  Received a cursor of type ^d.", INDEX_CURSOR_TYPE,
	      index_cursor.type);
      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      field_table_ptr = index_opening_info.field_table_ptr;
      call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      interval_specification_ptr = p_interval_specification_ptr;
      call CHECK_VERSION_CHAR (interval_specification.version, INTERVAL_SPECIFICATION_VERSION_2, "interval_specification")
	 ;

      p_code = 0;

      position_stack.depth = 0;
      interval_bead_ptr = interval_specification.first_interval_bead_ptr;

      p_no_match = "1"b;

INTERVAL_LOOP:
      do interval_idx = 1 to interval_specification.number_of_intervals;
         simple_typed_vector_ptr = interval_bead.simple_typed_vector_ptr;

         if simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
         then call sub_err_ (dm_error_$bad_vector_type, myname, ACTION_CANT_RESTART, null, 0,
	         "^/Expecting a simple_typed_vector, type ^d, 
but received a type ^d structure.", SIMPLE_TYPED_VECTOR_TYPE, simple_typed_vector.type);

         found_key = "0"b;
         if interval_bead.low.value_ptr = interval_bead.high.value_ptr
	    & simple_typed_vector.number_of_dimensions = field_table.number_of_fields
         then
EXACT_MATCH:
	  do;
	     simple_typed_vector.dimension (simple_typed_vector.number_of_dimensions).value_ptr =
		interval_bead.low.value_ptr;

	     call im_basic_search (index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search,
		addr (position_stack), WANT_EQUAL, "0"b, "0"b, simple_typed_vector_ptr, interval_bead.low.id_string,
		null, p_code);
	     if p_code ^= 0
	     then call ERROR_RETURN (p_code);
	     interval_bead.high.id_string = interval_bead.low.id_string;
	     found_key = (interval_bead.low.id_string ^= "0"b);

	  end EXACT_MATCH;
         else
RANGE:
	  do;
	     if interval_bead.low.value_ptr ^= null
	     then
	        do;
		 simple_typed_vector.dimension (simple_typed_vector.number_of_dimensions).value_ptr =
		      interval_bead.low.value_ptr;

		 call im_basic_search (index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search,
		      addr (position_stack), (USES_EQUAL_OPERATOR (interval_bead.low.operator_code)),
		      (USES_GREATER_OPERATOR (interval_bead.low.operator_code)), "0"b, simple_typed_vector_ptr,
		      interval_bead.low.id_string, null, p_code);
		 if p_code ^= 0
		 then call ERROR_RETURN (p_code);
		 found_key = (interval_bead.low.id_string ^= "0"b);
	        end;
	     else if simple_typed_vector.number_of_dimensions > 1
	     then
	        do;				/* There are one or more fields constrained to be equal,  All of the keys
found must be greater than or equal to the key-head consisting of only 
these equal fields.
*/
		 simple_typed_vector.number_of_dimensions = simple_typed_vector.number_of_dimensions - 1;
						/* Hide the Range Field from basic search. */
		 call im_basic_search (index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search,
		      addr (position_stack), WANT_EQUAL, WANT_GREATER, "0"b, simple_typed_vector_ptr,
		      interval_bead.low.id_string, null, p_code);
		 if p_code ^= 0
		 then call ERROR_RETURN (p_code);
		 simple_typed_vector.number_of_dimensions = simple_typed_vector.number_of_dimensions + 1;
						/* Put it back the way it's supposed to be. */
		 found_key = (interval_bead.low.id_string ^= "0"b);
	        end;

	     if (interval_bead.high.value_ptr ^= null | simple_typed_vector.number_of_dimensions > 1)
		& (interval_bead.low.value_ptr = null | found_key)
	     then
	        do;
		 if interval_bead.high.value_ptr ^= null ()
		 then
		    do;
		       simple_typed_vector.dimension (simple_typed_vector.number_of_dimensions).value_ptr =
			  interval_bead.high.value_ptr;

		       call im_basic_search (index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search,
			  addr (position_stack), (LESS_OR_EQUAL_OPERATOR_CODE = interval_bead.high.operator_code),
			  "0"b, WANT_KEY_LESS_THAN_VECTOR, simple_typed_vector_ptr, interval_bead.high.id_string,
			  null, p_code);
		       if p_code ^= 0
		       then call ERROR_RETURN (p_code);
		    end;
		 else
		    do;				/* This case is for when there is one or more "equal" fields, the highest key 
in this range must still be less than or equal to the equal fields key-head.
*/
		       simple_typed_vector.number_of_dimensions = simple_typed_vector.number_of_dimensions - 1;
						/* Hide the Range Field from basic search. */
		       call im_basic_search (index_opening_info_ptr, p_index_cursor_ptr, p_is_relative_search,
			  addr (position_stack), WANT_EQUAL, "0"b, WANT_LESS, simple_typed_vector_ptr,
			  interval_bead.high.id_string, null, p_code);
		       if p_code ^= 0
		       then call ERROR_RETURN (p_code);
		       simple_typed_vector.number_of_dimensions = simple_typed_vector.number_of_dimensions + 1;
						/* Put it back the way it's supposed to be. */
		    end;
		 if interval_bead.high.id_string = "0"b
		 then found_key = "0"b;
		 else if interval_bead.low.value_ptr = null ()
		 then found_key = "1"b;

/* For special search situations, it is possible for the "high" search to
return a key which is one below the key returned by the "low" search.  This
indicates that there are no keys which satisfy the range specification.
This situation is easy to check for when the keys are in the same CI.  When
they are in different CIs, it is necessary to get the CI header for the "low"
key.  Then, if the "low" key is the first key in its CI, it is possible that
the "high" key is the last key in the "low" key CI's preceding CI (indicating
that no keys in the index satisfy the range request).
*/

		 else if addr (interval_bead.low.id_string) -> element_id.control_interval_id
		      = addr (interval_bead.high.id_string) -> element_id.control_interval_id
		 then
		    do;
		       found_key =
			  (addr (interval_bead.low.id_string) -> element_id.index
			  <= addr (interval_bead.high.id_string) -> element_id.index);
		       if ^found_key
		       then if (addr (interval_bead.low.id_string) -> element_id.index - 1
			       ^= addr (interval_bead.high.id_string) -> element_id.index)
			  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
				  "^/A range search failed with the ""low"" key more than one slot greater than
the ""high"" key.  They are in control interval ^d, slots ^d and ^d
respectively. The ""low"" key and the ""high"" key may only be in reverse
order if they are consecutive.", addr (interval_bead.low.id_string) -> element_id.control_interval_id,
				  addr (interval_bead.low.id_string) -> element_id.index,
				  addr (interval_bead.high.id_string) -> element_id.index);
		    end;
		 else
		    do;
		       call GET_CI_HEADER ((addr (interval_bead.low.id_string) -> element_id.control_interval_id),
			  addr (local_leaf_ci_header));
		       found_key =
			  (local_leaf_ci_header.common.previous_id
			  ^= addr (interval_bead.high.id_string) -> element_id.control_interval_id);
		       if ^found_key
		       then if addr (interval_bead.low.id_string) -> element_id.index
			       ^= local_leaf_ci_header.common.key_range.first
			  then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
				  "^a (^d)^/^a (^d), ^a^/^a ^d ^a (^d). ^a^/^a",
				  "^/A range search failed with the ""low"" key in the control interval",
				  addr (interval_bead.low.id_string) -> element_id.control_interval_id,
				  "following the ""high"" key's control interval",
				  addr (interval_bead.high.id_string) -> element_id.control_interval_id,
				  "but the ""low"" key was", "in slot",
				  addr (interval_bead.low.id_string) -> element_id.index,
				  "instead of the first key slot", local_leaf_ci_header.common.key_range.first,
				  "The ""low"" key and the",
				  """high"" key may only be in reverse order if they are consecutive.");
			  else
			     do;
			        call GET_CI_HEADER
				   ((addr (interval_bead.high.id_string) -> element_id.control_interval_id),
				   addr (local_leaf_ci_header));
			        if local_leaf_ci_header.common.key_range.last
				   ^= addr (interval_bead.high.id_string) -> element_id.index
			        then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null,
				        0, "^a (^d)^/^a (^d), ^a^/^a ^d ^a (^d). ^a^/^a",
				        "^/A range search failed with the ""low"" key in the control interval",
				        addr (interval_bead.low.id_string) -> element_id.control_interval_id,
				        "following the ""high"" key's control interval",
				        addr (interval_bead.high.id_string) -> element_id.control_interval_id,
				        "but the ""high"" key was", "in slot",
				        addr (interval_bead.high.id_string) -> element_id.index,
				        "instead of the last key slot",
				        local_leaf_ci_header.common.key_range.last, "The ""low"" key and the",
				        """high"" key may only be in reverse order if they are consecutive.");
			     end;
		    end;
	        end;
	  end RANGE;

         if ^found_key
         then interval_bead.low.id_string, interval_bead.high.id_string = "0"b;
         p_no_match = p_no_match & ^found_key;
         interval_bead_ptr = interval_bead.next;

      end INTERVAL_LOOP;
MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_expected_version, p_received_version, p_structure_name);

      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;
%page;
GET_CI_HEADER:
   proc (gch_p_control_interval_id, gch_p_leaf_ci_header_ptr);
      dcl	    gch_p_control_interval_id
			       fixed bin (24) unsigned;
      dcl	    gch_p_leaf_ci_header_ptr
			       ptr;

      dcl	    gch_code	       fixed bin (35);
      dcl	    1 gch_element_id       aligned like element_id;
      dcl	    gch_element_id_string  bit (36) aligned based (addr (gch_element_id));

      gch_element_id.control_interval_id = gch_p_control_interval_id;
      gch_element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;
      gch_code = 0;

      call collection_manager_$get (index_cursor.file_opening_id, index_cursor.collection_id, gch_element_id_string, 0,
	 gch_p_leaf_ci_header_ptr, length (unspec (gch_p_leaf_ci_header_ptr -> leaf_ci_header)), null, "0"b,
	 gch_p_leaf_ci_header_ptr, (0), gch_code);
      if gch_code ^= 0
      then call ERROR_RETURN (gch_code);

      if gch_p_leaf_ci_header_ptr -> common_ci_header.is_leaf
      then
         do;
	  if gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first < 0
	  then call ERROR_RETURN (dm_error_$bad_first_key_idx);
	  else if gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.last
	       < gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first
	  then call ERROR_RETURN (dm_error_$bad_last_key_idx);
         end;
      else call ERROR_RETURN (dm_error_$bad_leaf_node);
      return;

   end GET_CI_HEADER;
%page;
%include vu_typed_vector;
%page;
%include dm_interval_spec;
%page;
%include dm_operator_constants;
%page;
%include sub_err_flags;
%page;
%include dm_element_id;
%page;
%include dm_im_ci_header;
%page;
%include dm_im_cursor;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_field_table;
%page;
%include dm_im_opening_info;
   end im_structural_search;




		    im_update_branches.pl1          05/10/85  0805.9re  05/08/85  1034.9       74079



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

/* DESCRIPTION:

          This program updates (some subset of) the parent node_id's recorded
     in the children of a specified parent node.  There are two entrypoints,
     im_update_branches$im_update_branches and im_update_branches$single.  The
     latter entrypoint, $single, is used to update the parent node_id of
     exactly one child node.  The main entrypoint is used to update a
     contiguous interval of branches (the children pointed to by branches
     p_index through key_range.last of the specified parent node).
     
     The assumed need for updating (in the $im_update_branches entrypoint
     case) is that all of the slots in the specified parent node were shifted
     to a higher numbered slot from their old position, starting with the
     branch now at p_index slot.
*/

/* HISTORY:
Written by Lindsey Spratt, 05/06/82.
Modified:
06/16/82 by Matthew Pierret: Removed the beginning_offset argument from
            calls to collection_manager_$put_element.
08/09/82 by Matthew Pierret: Removed offset and length arguments from calls
            to collection_manager_$get_element.
09/17/82 by Lindsey Spratt:  Changed to accept p_index = 0 as a valid request
	  to start the "update" from the low_branch_id.  Accordingly changed
	  to jump the index from 0 to the key_range.first value in the
	  CHILD_NODE_LOOP.  Also, changed to call sub_err_ if invoked on a
	  leaf node.
09/22/82 by Lindsey Spratt:  Added the "single" entry, for updating just one
	  branch, the one specified in p_index.
11/08/83 by Lindsey L. Spratt:  Changed to use the "buffered" access method on
            the parent node.  Calls of the $single entry with a p_index = 0
            (update the low_branch_id branch) can have a null
            p_node_buffer_ptr, all other calls must have a valid
            p_node_buffer_ptr.
05/10/84 by Matthew Pierret:  Changed to align local_key_buffer on an
            even-word boundary.  Made to use key_index instead of
            addr(key_id_string)->element_id.index to avoid a compiler bug.
06/07/84 by Matthew Pierret:  Re-named cm_$simple_get_buffered_element
            to cm_$simple_get_from_ci_buffer, cm_$get_element to cm_$get,
            cm_$put_element to cm_$modify,
10/10/84 by Lindsey L. Spratt:  Added a DESCRIPTION and various comments.
04/19/85 by Lindsey L. Spratt:  Fixed to work in the case where the multiple
            key entrypoint is used, but there is only one branch which is the
            low_branch_id.
*/

/* format: style2,ind3 */

im_update_branches:
   proc (p_node_buffer_ptr, p_file_opening_id, p_collection_id, p_common_ci_header_ptr, p_ci, p_index, p_code);

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

      dcl	    p_node_buffer_ptr      ptr parameter;
      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_common_ci_header_ptr ptr;
      dcl	    p_ci		       fixed bin (24) unsigned unaligned;
      dcl	    p_index	       fixed bin (12) unsigned unaligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    (child_header_id_string, key_id_string)
			       bit (36) aligned;
      dcl	    single_update	       bit (1) aligned init ("0"b);
      dcl	    last_index	       fixed bin (18) uns;
      dcl	    key_index	       fixed bin (12) uns;

      dcl	    local_header_buffer    bit (max (LEAF_CI_HEADER_LENGTH_IN_BITS, BRANCH_CI_HEADER_LENGTH_IN_BITS)) aligned;
      dcl	    local_key_buffer       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
      dcl	    key_buffer_length      fixed bin (35) init (BITS_PER_PAGE);
      dcl	    branch_key_length      fixed bin (35);
      dcl	    child_header_ptr       ptr;
      dcl	    child_header_length    fixed bin (35);

/* Based */
/* Builtin */

      dcl	    (max, null, length, addr)
			       builtin;

/* Controlled */
/* Constant */

      dcl	    BITS_PER_PAGE	       init (36 * 1024) fixed bin (17) internal static options (constant);
      dcl	    DOUBLE_WORDS_PER_PAGE  init (512) fixed bin (17) internal static options (constant);
      dcl	    myname	       init ("im_update_branches") char (18) internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      single_update = "0"b;
      goto JOIN;

single:
   entry (p_node_buffer_ptr, p_file_opening_id, p_collection_id, p_common_ci_header_ptr, p_ci, p_index, p_code);
      single_update = "1"b;

JOIN:
      common_ci_header_ptr = p_common_ci_header_ptr;
      if common_ci_header.is_leaf
      then call sub_err_ (dm_error_$programming_error, myname, "s", null, 0,
	      "^/This program may only be invoked on branch nodes.  It was invoked on the
leaf node with id ^d.", p_ci);
      else branch_ci_header_ptr = common_ci_header_ptr;

      addr (child_header_id_string) -> element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;

      addr (key_id_string) -> element_id.control_interval_id = p_ci;
      if single_update
      then last_index = p_index;
      else last_index = common_ci_header.key_range.last;

CHILD_NODE_LOOP:
      do key_index = p_index to last_index;

         addr (key_id_string) -> element_id.index = key_index;

/* A slot_index of 0 indicates that the child node pointed at by the
low_branch_id of the parent node is to be updated.

Other values of slot_index are actual indexes into the slot table, identifying
real elements.
*/

         if addr (key_id_string) -> element_id.index = 0
         then
	  do;

	     if common_ci_header.key_range.first > 0
	     then key_index = common_ci_header.key_range.first - 1;
						/* This sets key_index so it will be key_range.first for the next loop.*/
	     else ;				/* last_index is 0, so this will be a one-pass loop because */
						/* key_index is going to be incremented to 1 at its bottom. */

	     addr (child_header_id_string) -> element_id.control_interval_id = branch_ci_header.low_branch_id;
	  end;
         else
	  do;

/* To find out what the node_id of the child node identified by the current
branch is, it's necessary to pick up the branch key.
*/

	     branch_key_ptr = addr (local_key_buffer);
	     call collection_manager_$simple_get_from_ci_buffer (p_node_buffer_ptr, p_collection_id, key_id_string,
		branch_key_ptr, key_buffer_length, branch_key_length, p_code);

	     if p_code ^= 0
	     then call ERROR_RETURN (p_code);

	     bk_string_length = branch_key_length - BRANCH_KEY_HEADER_LENGTH_IN_BITS;

	     addr (child_header_id_string) -> element_id.control_interval_id = branch_key.branch_id;
	  end;


/* Now the child node's parent id string is actually updated.  First the
ci_header for the child node is retrieved, then the parent_node_id is changed,
and finally the updated ci_header is replaced in the child node.
*/

         call collection_manager_$get (p_file_opening_id, p_collection_id, child_header_id_string, 0,
	    addr (local_header_buffer), length (local_header_buffer), null, "0"b, child_header_ptr, child_header_length,
	    p_code);

         if p_code ^= 0
         then call ERROR_RETURN (p_code);

         child_header_ptr -> common_ci_header.parent_id_string = key_id_string;

         call collection_manager_$modify (p_file_opening_id, p_collection_id, child_header_ptr, child_header_length,
	    child_header_id_string, 0, p_code);
         if p_code ^= 0
         then call ERROR_RETURN (p_code);

      end CHILD_NODE_LOOP;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
%include dm_im_key;
%page;
%include dm_im_ci_header;
%page;
%include dm_element_id;
%page;
%include dm_collmgr_entry_dcls;
   end im_update_branches;




		    im_update_key_counts.pl1        04/02/87  1313.1r w 04/02/87  1304.9      132255



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

/* DESCRIPTION:

         This subroutine takes a key_count_array and increments or decrements
     it  by  one  in each partial duplicate count for which the "current" is a
     partial duplicate of the previous or following keys.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 10/28/82.
Modified:
11/15/82 by Matthew Pierret:  Changed to not try to free the leaf_ci_header
            pointed to by temp_leaf_ci_header_ptr if equal to
	  leaf_ci_header_ptr.
12/09/82 by Lindsey Spratt:  Changed to use the dm_key_count_array incl file.
	  Changed to check error codes after calls.
02/10/83 by Lindsey Spratt:  Changed to use automatic buffers for local,
	  temporary  copies of leaf_ci_headers.  There is no longer any
	  explicit freeing or allocation of leaf_ci_headers.  Also, fixed to
	  not set the 0-th key_count when doing the "previous key" key_count
	  adjustment and there was no previous key.  This was done by
	  initializing the previous_first_inequal_field_id to 1 instead of 0.
02/28/83 by Lindsey Spratt:  Changed to use version 3 of the index_cursor.
04/03/83 by Lindsey L. Spratt:  Changed to call
            data_mgmt_util_$compare_string_to_string instead of
            im_compare_key_and_key.
11/08/83 by Lindsey L. Spratt:  Changed to use the "buffered" access method.
            Also, converted to use the "call ERROR RETURN(code)" protocol.
06/07/84 by Matthew Pierret:  Re-named cm_$setup_buffered_ci to
            cm_$setup_ci_buffer, cm_$simple_get_buffered_element to
            cm_$simple_get_from_ci_buffer, cm_$get_element_buffered to
            cm_$get_from_ci_buffer.
            Changed to use data_format_util_ instead of data_mgmt_util_.
10/13/84 by Lindsey L. Spratt:  Added the current_key_string_length to the
            calling sequence.  This is necessary for using a caller supplied
            key.
10/29/84 by Lindsey L. Spratt:



            Changed to use version 2 key_count_array.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

im_update_key_counts:
   proc (p_node_buffer_ptr, p_index_cursor_ptr, p_work_area_ptr, p_field_table_ptr, p_is_being_inserted,
        p_leaf_ci_header_ptr, p_current_key_id, p_current_key_ptr, p_current_key_string_length, p_key_count_array_ptr,
        p_code);


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

      dcl	    p_node_buffer_ptr      ptr parameter;
      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_field_table_ptr      ptr parameter;
      dcl	    p_is_being_inserted    bit (1) aligned parameter;
      dcl	    p_leaf_ci_header_ptr   ptr parameter;
      dcl	    p_current_key_id       bit (36) aligned parameter;
      dcl	    p_current_key_ptr      ptr parameter;
      dcl	    p_current_key_string_length
			       fixed bin (35) parameter;
      dcl	    p_key_count_array_ptr  ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    count_idx	       fixed bin;
      dcl	    current_key_ptr	       ptr init (null);
      dcl	    current_key_string_length
			       fixed bin (35) init (0);
      dcl	    current_node_buffer_ptr
			       ptr init (null);

      dcl	    (local_main_ci_header_buffer, local_temp_ci_header_buffer)
			       bit (LEAF_CI_HEADER_LENGTH_IN_BITS) aligned;
      dcl	    local_node_buffer      bit (CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES * BITS_PER_BYTE) aligned;

      dcl	    temp_key_ptr	       init (null) ptr;
      dcl	    temp_key_string_length fixed bin (35) init (0);
      dcl	    temp_leaf_ci_header_ptr
			       ptr init (null);
      dcl	    (previous_first_inequal_field_id, next_first_inequal_field_id)
			       fixed bin (17) init (1);
      dcl	    work_area_ptr	       ptr init (null);

/* Based */

      dcl	    temp_key	       bit (temp_key_string_length) based (temp_key_ptr);
      dcl	    current_key	       bit (current_key_string_length) based (current_key_ptr);
      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (null, bin)	       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    ALL_FIELDS	       init (-1) fixed bin (17) internal static options (constant);
      dcl	    BITS_PER_BYTE	       init (9) fixed bin (17) internal static options (constant);

      dcl	    myname	       init ("im_update_key_counts") char (32) varying internal static options (constant);

/* Entry */

      dcl	    data_format_util_$compare_string_to_string
			       entry (ptr, ptr, fixed bin (24), ptr, fixed bin (24), fixed bin unal, fixed bin,
			       bit (1) aligned, bit (1) aligned, fixed bin (35));


      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$wrong_cursor_type,
	    dm_error_$bad_first_key_idx,
	    dm_error_$bad_last_key_idx,
	    dm_error_$bad_leaf_node
	    )		       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;
      work_area_ptr = p_work_area_ptr;
      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected a an index type cursor, type ^d,. Received a cursor of type ^d.", INDEX_CURSOR_TYPE,
	      index_cursor.type);

      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      current_node_buffer_ptr = p_node_buffer_ptr;
      element_id_string = p_current_key_id;
      leaf_ci_header_ptr = p_leaf_ci_header_ptr;

      on cleanup call FINISH;


      if leaf_ci_header_ptr = null
      then
         do;
	  leaf_ci_header_ptr = addr (local_main_ci_header_buffer);
	  call GET_CI_HEADER (current_node_buffer_ptr, (element_id.control_interval_id), leaf_ci_header_ptr);
         end;

      current_key_ptr = p_current_key_ptr;
      current_key_string_length = p_current_key_string_length;
      if current_key_ptr = null
      then call GET_KEY (current_node_buffer_ptr, element_id_string, current_key_ptr, current_key_string_length);


      key_count_array_ptr = p_key_count_array_ptr;
      call CHECK_VERSION_CHAR (key_count_array.version, KEY_COUNT_ARRAY_VERSION_2, "key_count_array");

/* check previous key. */

      element_id.index = element_id.index - 1;
      if element_id.index < leaf_ci_header.common.key_range.first
      then
         do;
	  element_id.control_interval_id = leaf_ci_header.common.previous_id;
	  if element_id.control_interval_id ^= 0
	  then
	     do;

	        current_node_buffer_ptr = addr (local_node_buffer);
	        call SETUP_NODE_BUFFER ((element_id.control_interval_id), current_node_buffer_ptr);

	        temp_leaf_ci_header_ptr = addr (local_temp_ci_header_buffer);
	        call GET_CI_HEADER (current_node_buffer_ptr, element_id.control_interval_id, temp_leaf_ci_header_ptr);
	        element_id.index = temp_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.last;
	     end;
         end;
      else temp_leaf_ci_header_ptr = leaf_ci_header_ptr;

      if temp_leaf_ci_header_ptr ^= null
      then
         do;
	  call GET_KEY (current_node_buffer_ptr, element_id_string, temp_key_ptr, temp_key_string_length);
	  call data_format_util_$compare_string_to_string (p_field_table_ptr, current_key_ptr,
	       (current_key_string_length), temp_key_ptr, (temp_key_string_length), (ALL_FIELDS),
	       previous_first_inequal_field_id, "0"b, "0"b, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  do count_idx = 1 to previous_first_inequal_field_id - 1;
	     key_count_array.count (count_idx) =
		key_count_array.count (count_idx) + 1 + -2 * bin (^p_is_being_inserted);
	  end;
         end;

      if temp_key_ptr ^= null
      then
         do;

	  free temp_key_ptr -> temp_key in (work_area);
	  temp_key_ptr = null;
         end;

      element_id_string = p_current_key_id;		/* Reset to the current key. */

/* Check for duplications with next key. */

      current_node_buffer_ptr = p_node_buffer_ptr;

      element_id.index = element_id.index + 1;
      if element_id.index > leaf_ci_header.common.key_range.last
      then
         do;
	  element_id.control_interval_id = leaf_ci_header.common.next_id;
	  if element_id.control_interval_id ^= 0
	  then
	     do;

	        current_node_buffer_ptr = addr (local_node_buffer);
	        call SETUP_NODE_BUFFER ((element_id.control_interval_id), current_node_buffer_ptr);
	        temp_leaf_ci_header_ptr = addr (local_temp_ci_header_buffer);
	        call GET_CI_HEADER (current_node_buffer_ptr, element_id.control_interval_id, temp_leaf_ci_header_ptr);
						/* If a ci_header was gotten for the previous key, this would overwrite it. */
	        element_id.index = temp_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first;
	     end;
         end;
      else temp_leaf_ci_header_ptr = leaf_ci_header_ptr;

      if element_id.control_interval_id ^= 0
      then
         do;
	  call GET_KEY (current_node_buffer_ptr, element_id_string, temp_key_ptr, temp_key_string_length);

	  call data_format_util_$compare_string_to_string (p_field_table_ptr, current_key_ptr,
	       (current_key_string_length), temp_key_ptr, (temp_key_string_length), (ALL_FIELDS),
	       next_first_inequal_field_id, "0"b, "0"b, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);

	  do count_idx = max (1, previous_first_inequal_field_id) to next_first_inequal_field_id - 1;
	     key_count_array.count (count_idx) =
		key_count_array.count (count_idx) + 1 + -2 * bin (^p_is_being_inserted);
	  end;
         end;

      if temp_key_ptr ^= null
      then free temp_key_ptr -> temp_key in (work_area);
      temp_key_ptr = null;

      key_count_array.count (0) = key_count_array.count (0) + 1 + -2 * bin (^p_is_being_inserted);
MAIN_RETURN:
      call FINISH;
      return;
%page;
FINISH:
   proc;
      if current_key_ptr ^= null & p_current_key_ptr ^= current_key_ptr
      then free current_key in (work_area);
      if temp_key_ptr ^= null
      then free temp_key in (work_area);
   end FINISH;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35);
      call FINISH;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;

%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
CHECK_VERSION_CHAR:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned parameter;
      dcl	    p_expected_version     char (8) aligned parameter;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION_CHAR;
%page;
GET_CI_HEADER:
   proc (gch_p_node_buffer_ptr, gch_p_control_interval_id, gch_p_leaf_ci_header_ptr);
      dcl	    gch_p_node_buffer_ptr  ptr;
      dcl	    gch_p_control_interval_id
			       fixed bin (24) unsigned unal;
      dcl	    gch_p_leaf_ci_header_ptr
			       ptr;
      dcl	    gch_code	       fixed bin (35) init (0);


      element_id.control_interval_id = gch_p_control_interval_id;
      element_id.index = DEFAULT_INDEX_CONTROL_INTERVAL_HEADER_SLOT;

      call collection_manager_$simple_get_from_ci_buffer (gch_p_node_buffer_ptr, index_cursor.collection_id,
	 element_id_string, gch_p_leaf_ci_header_ptr, length (unspec (gch_p_leaf_ci_header_ptr -> leaf_ci_header)), (0),
	 gch_code);
      if gch_code ^= 0
      then call ERROR_RETURN (gch_code);

      if ^gch_p_leaf_ci_header_ptr -> common_ci_header.is_leaf
      then call ERROR_RETURN (dm_error_$bad_leaf_node);
      else if gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first < 0
      then call ERROR_RETURN (dm_error_$bad_first_key_idx);
      else if gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.last
	      < gch_p_leaf_ci_header_ptr -> leaf_ci_header.common.key_range.first
      then call ERROR_RETURN (dm_error_$bad_last_key_idx);

      return;
%include dm_element_id;
   end GET_CI_HEADER;
%page;
GET_KEY:
   proc (gk_p_node_buffer_ptr, gk_p_key_id_string, gk_p_leaf_key_ptr, gk_p_leaf_key_string_length);
      dcl	    gk_p_node_buffer_ptr   ptr;
      dcl	    gk_p_key_id_string     bit (36) aligned;
      dcl	    gk_p_leaf_key_ptr      ptr;
      dcl	    gk_p_leaf_key_string_length
			       fixed bin (35);
      dcl	    gk_code	       fixed bin (35);


      call collection_manager_$get_from_ci_buffer (gk_p_node_buffer_ptr, index_cursor.file_opening_id,
	 index_cursor.collection_id, gk_p_key_id_string, gk_p_leaf_key_ptr, gk_p_leaf_key_string_length, work_area_ptr,
	 "0"b, gk_p_leaf_key_ptr, gk_p_leaf_key_string_length, gk_code);
      if gk_code ^= 0
      then call ERROR_RETURN (gk_code);

   end GET_KEY;
%page;
SETUP_NODE_BUFFER:
   proc (snb_p_control_interval_id, snb_p_buffer_ptr);
      dcl	    snb_p_control_interval_id
			       fixed bin (24) unsigned;
      dcl	    snb_p_buffer_ptr       ptr;

      dcl	    snb_code	       fixed bin (35) init (0);

      call collection_manager_$setup_ci_buffer (index_cursor.file_opening_id, index_cursor.collection_id,
	 snb_p_control_interval_id, snb_p_buffer_ptr, CONTROL_INTERVAL_ADDRESSABLE_LENGTH_IN_BYTES * BITS_PER_BYTE,
	 snb_code);
      if snb_code ^= 0
      then call ERROR_RETURN (snb_code);

   end SETUP_NODE_BUFFER;
%page;
%include sub_err_flags;
%page;
%include dm_im_cursor;
%page;
%include dm_im_ci_header;
%page;
%include dm_element_id;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_key_count_array;
%page;
%include dm_ci_lengths;
   end im_update_key_counts;




		    im_update_opening_info.pl1      04/02/87  1313.1r w 04/02/87  1304.9      125496



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

/* DESCRIPTION:

         This  module  update  the index_opening_info data.  Separate entries
     are provided for updating  the  root_id  and  the  key_count_array.
     For the key_count_array entry, this module maintains an increments array.
     This is an array of increments that are to be applied to the actual key
     count array in the index when the transaction commits.  When this entry is
     called, the key count array that is passed (pointed to by pkca_ptr) is
     compared to the opening key count array (pointed to by okca_ptr), the
     differences are applied to the internal increments array (pointed to by
     ikca_ptr), and the opening key count array is updated.  If increments
     key_count_array has never been allocated, that is, this is the first time
     this entry has been called for this index since this index has been opened
     in this process, then the increments structure is allocated in the DM free
     area.  If this is the first time this entry has been called for this index
     since the current transaction began or since a rollback occured, a
     postcommit handler is written that will cause the file key count array
     to be updated with the increments key_count_array at postcommit time.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 10/28/82.
Modified:
12/09/82 by Lindsey Spratt: Changed to use dm_key_count_array incl file.
04/28/83 by Matthew Pierret:  Changed $key_count_array to use the new
            collection_manager_$put_unprotected_header.  This entry does not
            obtain an exclusive lock while writing the header.  This is
            considered safe because only the information in the header
            pertaining to key_counts is changed, and this information is not
            critical.  This change was made in the hopes of relieving a major
            concurrency bottleneck.
10/27/84 by Lindsey L. Spratt:  Changed to use version 2 index_opening_info,
            version 4 index_header, version 2 key_count_array.  Changed to put
            the key_count_array (rather than modify it) when the
            key_count_array was not previously in the index (this is the
            second step in the conversion of the index to using version 4
            index_headers from version 3).
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
03/11/85 by R. Michael Tague:  Changed the $key_count_array entry to manage a
            increments structure instead of simply replacing the 
	  key_count_array in the collection.  A postcommit handler is written
	  to insure that the key_count_array is eventually updated.  Removed
	  the index_header automatic version conversion.
03/25/85 by R. Michael Tague:  Changed to update the key count array of 
	  unprotected files by calling UPDATE_UNPROTECTED_COUNTS and to 
	  maintain index_opening_info.flags.key_count_unprotected_file.
*/

/* format: style2,ind3 */
im_update_opening_info$key_count_array:
   proc (p_index_opening_info_ptr, p_key_count_array_ptr, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_key_count_array_ptr  ptr parameter;
      dcl	    p_root_id	       fixed bin (24) uns parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (update_key_counts, update_root_id)
			       bit (1) aligned init ("0"b);
      dcl	    pkca_ptr	       ptr;		/* parameter (passed) kca ptr */
      dcl	    okca_ptr	       ptr;		/* opening info kca ptr */
      dcl	    ikca_ptr	       ptr;		/* increments kca ptr */
      dcl	    1 increment_info       aligned like cm_increment_info;

/* Based */

      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (addr, bin, length, null, rel, unspec)
			       builtin;

/* Constant */

      dcl	    BITS_PER_WORD	       fixed bin init (36) internal static options (constant);
      dcl	    HEADER_COLLECTION_ID   bit (36) aligned init ("000000000001"b3) internal static options (constant);
      dcl	    myname	       init ("im_update_opening_info") char (32) varying internal static options (constant);
      dcl	    work_area_ptr	       ptr init (null) internal static;

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$file_must_be_protected
			       fixed bin (35) ext static;
      dcl	    dm_error_$programming_error
			       fixed bin (35) ext static;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext static;

/* END OF DECLARATIONS */

/* key_count_array:
   entry (p_index_opening_info_ptr, p_key_count_array_ptr, p_code);
*/
      update_key_counts = "1"b;
      pkca_ptr = p_key_count_array_ptr;
      goto JOIN;

root_id:
   entry (p_index_opening_info_ptr, p_root_id, p_code);
      update_root_id = "1"b;
JOIN:
      p_code = 0;
      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      index_header_ptr = index_opening_info.index_header_ptr;
      call CHECK_VERSION (index_header.version, INDEX_HEADER_VERSION_4, "index_header");

      if update_key_counts
      then
         do;
	  call CHECK_VERSION (pkca_ptr -> key_count_array.version, KEY_COUNT_ARRAY_VERSION_2, "passed key_count_array");
	  okca_ptr = index_opening_info.key_count_array_ptr;
	  call CHECK_VERSION (okca_ptr -> key_count_array.version, KEY_COUNT_ARRAY_VERSION_2,
	       "opening info key_count_array");
	  if index_opening_info.key_count_unprotected_file
	  then call UPDATE_UNPROTECTED_COUNTS ();
	  else call UPDATE_PROBABLY_PROTECTED_COUNTS ();
         end;
      else
         do;
	  index_header.root_id = p_root_id;
	  call collection_manager_$put_header (index_opening_info.file_opening_id, index_opening_info.collection_id,
	       index_header_ptr, length (unspec (index_header)), p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);
         end;
MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     char (8) aligned parameter;
      dcl	    p_expected_version     char (8) aligned parameter;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
/* *************************************************************************
   * SET_UP_KEY_INCREMENTS_ARRAY - This procedure allocates a key count    *
   * array in the DM work area the same size as the opening info key count *
   * array.  This allocated array is used to hold the key count increments *
   * that the postcommit handler uses to update the index's key count	     *
   * array.						     *
   *							     *
   * A pointer to the created array is returned.			     *
   ************************************************************************* */

SET_UP_KEY_INCREMENTS_ARRAY:
   proc (p_ikca_ptr);
      dcl	    p_ikca_ptr	       ptr;

      if work_area_ptr = null
      then work_area_ptr = get_dm_free_area_ ();
      kca_number_of_counts = okca_ptr -> key_count_array.number_of_counts;
      alloc key_count_array in (work_area);
      key_count_array.version = KEY_COUNT_ARRAY_VERSION_2;
      unspec (key_count_array.count) = ""b;

      p_ikca_ptr = addr (key_count_array);
   end SET_UP_KEY_INCREMENTS_ARRAY;
%page;
/* *************************************************************************
   * UPDATE_INCREMENTS_ARRAY - This procedure updates the increments key   *
   * count array with the difference of parameter key count and opening    *
   * key count.  Afterwards the opening key count array is set equal to    *
   * the passed (parameter) key count array.			     *
   ************************************************************************* */

UPDATE_INCREMENTS_ARRAY:
   proc ();

      dcl	    uia_key_count_index    fixed bin;

      do uia_key_count_index = lbound (okca_ptr -> key_count_array.count, 1)
	 to hbound (okca_ptr -> key_count_array.count, 1);
         ikca_ptr -> key_count_array.count (uia_key_count_index) =
	    ikca_ptr -> key_count_array.count (uia_key_count_index)
	    + (pkca_ptr -> key_count_array.count (uia_key_count_index)
	    - okca_ptr -> key_count_array.count (uia_key_count_index));
         okca_ptr -> key_count_array.count (uia_key_count_index) =
	    pkca_ptr -> key_count_array.count (uia_key_count_index);
      end;
   end UPDATE_INCREMENTS_ARRAY;
%page;
/* *************************************************************************
   * UPDATE_PROBABLY_PROTECTED_COUNTS - This procedure updates the key     *
   * count array for protected files.  The first time this procedure is    *
   * called for a given file, a postcommit handler is written.  If the     *
   * handler cannot be written because the file is not protected then      *
   * UPDATE_UNPROTECTED_COUNTS is called and index_opening_info.flags.     *
   * key_count_unprotected_file is set so that future updates on this file *
   * will use UPDATE_UNPROTECTED_COUNTS.			     *
   ************************************************************************* */

UPDATE_PROBABLY_PROTECTED_COUNTS:
   proc ();

      dcl	    uppc_code	       fixed bin (35);

      ikca_ptr = index_opening_info.key_count_increments_ptr;
      if ikca_ptr = null
      then
         do;
	  call SET_UP_KEY_INCREMENTS_ARRAY (ikca_ptr);
	  index_opening_info.key_count_increments_ptr = ikca_ptr;
         end;
      else call CHECK_VERSION (ikca_ptr -> key_count_array.version, KEY_COUNT_ARRAY_VERSION_2,
	      "increment key_count_array");

      if okca_ptr -> key_count_array.number_of_counts ^= pkca_ptr -> key_count_array.number_of_counts
	 | okca_ptr -> key_count_array.number_of_counts ^= ikca_ptr -> key_count_array.number_of_counts
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "^/The sizes of the opening key_count_array, the passed key_count_array, and^/the increments key_count_array arrays are inconsistant."
	      );

      if ^index_opening_info.flags.key_count_postcommit_written
      then
         do;
	  call WRITE_INCREMENTS_POSTCOMMIT_HANDLER (uppc_code);
	  if uppc_code = dm_error_$file_must_be_protected
	  then
	     do;
	        call UPDATE_UNPROTECTED_COUNTS ();
	        index_opening_info.flags.key_count_unprotected_file = "1"b;
	     end;
	  else if uppc_code ^= 0
	  then call ERROR_RETURN (uppc_code);
	  else
	     do;
	        index_opening_info.flags.key_count_postcommit_written = "1"b;
	        call UPDATE_INCREMENTS_ARRAY ();
	     end;
         end;
      else call UPDATE_INCREMENTS_ARRAY ();
   end UPDATE_PROBABLY_PROTECTED_COUNTS;
%page;
/* *************************************************************************
   * UPDATE_UNPROTECTED_COUNTS - Updates the opening info key count array  *
   * and then writes this array out to the unprotected index file.	     *
   ************************************************************************* */

UPDATE_UNPROTECTED_COUNTS:
   proc ();

      dcl	    upc_code	       fixed bin (35);

      okca_ptr -> key_count_array.count = pkca_ptr -> key_count_array.count;
      call collection_manager_$modify_unprotected (index_opening_info.file_opening_id, HEADER_COLLECTION_ID,
	 okca_ptr, length (unspec (okca_ptr -> key_count_array)), unspec (index_header.key_count_array_element_id), (0),
	 upc_code);
      if upc_code ^= 0
      then call ERROR_RETURN (upc_code);
   end UPDATE_UNPROTECTED_COUNTS;
%page;
/* *************************************************************************
   * WRITE_INCREMENTS_POSTCOMMIT_HANDLER - Builds the increment info       *
   * structure and tries to write the increments postcommit handler.  The  *
   * postcommit handler is given a pointer to the local increments array   *
   * so that an update can be made using stacq's at postcommit time.	     *
   ************************************************************************* */

WRITE_INCREMENTS_POSTCOMMIT_HANDLER:
   proc (wiph_code);
      dcl	    wiph_code	       fixed bin (35);

      unspec (ikca_ptr -> key_count_array.count) = ""b;
      unspec (increment_info) = ""b;
      increment_info.version = CM_INCREMENT_INFO_VERSION_1;
      increment_info.increments_ptr = ikca_ptr;
      increment_info.offset_in_bits =
	 BITS_PER_WORD * (bin (rel (addr (ikca_ptr -> key_count_array.count (0)))) - bin (rel (ikca_ptr)));
      increment_info.number_of_words =
	 hbound (ikca_ptr -> key_count_array.count, 1) - lbound (ikca_ptr -> key_count_array.count, 1) + 1;
      call collection_manager_$postcommit_increments (index_opening_info.file_opening_id, HEADER_COLLECTION_ID,
	 unspec (index_header.key_count_array_element_id), addr (increment_info), wiph_code);
   end WRITE_INCREMENTS_POSTCOMMIT_HANDLER;
%page;
%include dm_cm_increment_info;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_element_id;
%page;
%include dm_key_count_array;
%page;
%include dm_im_header;
%page;
%include dm_im_opening_info;
%page;
%include sub_err_flags;

   end im_update_opening_info$key_count_array;




		    im_validate_cursor.pl1          04/04/85  1109.9re  04/04/85  0823.5       71037



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

/* DESCRIPTION:

         This   subroutine   checks   that  the  provided  cursor's  position
     information is consistent.  If the cursor has a current key  value  which
     doesn't  match  with  the  key  at  the  current key location, then it is
     re-positioned.  Also, if the current key doesn't  exist,  the  cursor  is
     re-positioned.        Re-positioning   is   achieved   by   calling   the
     im_basic_search$reposition entry.

     This module  does  not  attempt  to  validate  the  file  opening  id  or
     collection ids.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 02/23/83.
Modified:
03/18/83 by Matthew Pierret: Changed dm_error_$invalid_cursor to
            $invalid_cursor_position.
04/03/83 by Lindsey L. Spratt:  Converted to use
            data_mgmt_util_$compare_string_to_string instead of
            im_compare_key_and_key.
05/10/84 by Matthew Pierret:  Changed to align key_buffer on an even-word
            boundary.  Changed to compare key_string and the current key with
            a bit-string comparison instead of calling
            data_format_util_$compare_string_to_string.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 index_opening_info.
            Changed to use ERROR_RETURN.
03/07/85 by R. Michael Tague:  Changed opening info version to version 3.
*/

/* format: style2,ind3 */

im_validate_cursor:
   proc (p_index_opening_info_ptr, p_index_cursor_ptr, p_code);

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

      dcl	    p_index_opening_info_ptr
			       ptr parameter;
      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    reposition_cursor      bit (1) init ("0"b) aligned;
      dcl	    key_buffer	       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
      dcl	    key_buffer_length      fixed bin (35) init (BITS_PER_PAGE);
      dcl	    key_string_ptr	       ptr init (null);
      dcl	    key_string_length      fixed bin (35) aligned init (0);
      dcl	    first_inequal_field_id fixed bin;
      dcl	    (cursor_key_equal_to_index_key, cursor_key_less_than_index_key)
			       bit (1) init ("0"b) aligned;

/* Based */

      dcl	    key_string	       bit (key_string_length) based (key_string_ptr) aligned;

/* Builtin */

      dcl	    (null, addr, length)   builtin;

/* Constant */

      dcl	    myname	       init ("im_validate_cursor") char (32) varying internal static options (constant);
      dcl	    (
	    BITS_PER_PAGE	       init (1024 * 36),
	    DOUBLE_WORDS_PER_PAGE  init (512),
	    DEFAULT_POSITION       init (0) fixed bin (35),
	    DEFAULT_AREA	       init (null) ptr,
	    ALL_FIELDS	       init (-1) fixed bin
	    )		       internal static options (constant);

/* Entry */

      dcl	    im_basic_search$reposition
			       entry (ptr, ptr, ptr, fixed bin (24), fixed bin (35));

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$invalid_cursor_position,
	    dm_error_$wrong_cursor_type
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      index_cursor_ptr = p_index_cursor_ptr;
      p_code = 0;

      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected an index cursor (type ^d). Received a cursor of type ^d, instead.", INDEX_CURSOR_TYPE,
	      index_cursor.type);

      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      index_opening_info_ptr = p_index_opening_info_ptr;
      call CHECK_VERSION_CHAR (index_opening_info.version, INDEX_OPENING_INFO_VERSION_3, "index_opening_info");

      index_header_ptr = index_opening_info.index_header_ptr;
      call CHECK_VERSION_CHAR (index_header.version, INDEX_HEADER_VERSION_4, "index_header");

      if ^index_cursor.flags.is_valid
      then call ERROR_RETURN (dm_error_$invalid_cursor_position);
      else if index_cursor.flags.is_at_beginning_of_index
      then
         do;
	  if index_cursor.flags.current_key_exists | index_cursor.flags.is_at_end_of_index
	  then
	     do;
	        index_cursor.flags.is_valid = "0"b;
	        call ERROR_RETURN (dm_error_$invalid_cursor_position);
	     end;
	  else if index_cursor.current_key_string_ptr ^= null
	  then reposition_cursor = "1"b;
         end;
      else if index_cursor.flags.is_at_end_of_index
      then
         do;
	  if index_cursor.flags.current_key_exists | index_cursor.flags.is_at_beginning_of_index
	  then
	     do;
	        index_cursor.flags.is_valid = "0"b;
	        call ERROR_RETURN (dm_error_$invalid_cursor_position);
	     end;
	  else if index_cursor.current_key_string_ptr ^= null
	  then reposition_cursor = "1"b;
         end;
      else if index_cursor.current_key_string_ptr = null
      then
         do;
	  index_cursor.flags.is_valid = "0"b;
	  call ERROR_RETURN (dm_error_$invalid_cursor_position);
         end;
      else if ^index_cursor.current_key_exists
      then reposition_cursor = "1"b;
      else
         do;
	  call collection_manager_$get (index_cursor.file_opening_id, index_cursor.collection_id,
	       index_cursor.key_id_string, (DEFAULT_POSITION), addr (key_buffer), key_buffer_length, DEFAULT_AREA, "0"b,
	       key_string_ptr, key_string_length, p_code);
	  if p_code ^= 0
	  then reposition_cursor = "1"b;
	  else if key_string_length ^= index_cursor.current_key_string_length
	  then reposition_cursor = "1"b;
	  else if key_string ^= index_cursor.current_key_string_ptr -> key_string
	  then reposition_cursor = "1"b;
         end;

      if reposition_cursor
      then
         do;
	  p_code = 0;
	  call im_basic_search$reposition (index_opening_info_ptr, index_cursor_ptr,
	       index_cursor.current_key_string_ptr, (index_cursor.current_key_string_length), p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN (p_code);
         end;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parameter;

      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION_CHAR:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    (p_expected_version, p_received_version)
			       char (8) aligned parameter;
      dcl	    p_structure_name       char (*) parameter;

      if p_expected_version ^= p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION_CHAR;


CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include dm_im_cursor;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_im_header;
%page;
%include dm_im_opening_info;
%page;
%include dm_element_id;
   end im_validate_cursor;




		    index_manager_.alm              01/04/85  0917.4re  01/03/85  1147.1       19089



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	index_manager_

" Modified:
" 06/30/82 by Lindsey Spratt: Changed to use im_foo$im_foo entries instead of
"	    im_foo$foo entries.
" 08/06/82 by Lindsey Spratt:  Changed get_key to use im_general_search$get
"             and delete_key to use im_general_search$delete.
" 08/19/82 by Lindsey Spratt:  Added the create_subset_index and put_key_array
"	    entries.  Also, changed the name of create_collection to
"	    create_index.
" 10/18/82 by Lindsey Spratt:  Added the position_cursor entry.
" 11/15/82 by Lindsey Spratt:  Added the get_key_count_array entry.
" 03/10/83 by Lindsey Spratt:  Added the destroy_cursor entry.  Sorted the
"	    definitions.
" 04/07/83 by Matthew Pierret: Added the destroy_index entry.
" 04/04/84 by Lee Baldwin:  Added the key_count entry.  Sorted the definitions.
" 05/02/84 by Lee Baldwin:  Renamed $key_count to $get_key_count_by_spec.
" 11/09/84 by Lindsey Spratt:  Fixed order of $get_key_count_array and
"	    $get_key_count_by_spec.
"
" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer create_cursor,im_create_cursor$im_create_cursor
	ext_transfer create_index,im_create_index$im_create_index
	ext_transfer create_subset_index,im_create_subset_index$im_create_subset_index
	ext_transfer delete_key,im_general_search$delete
	ext_transfer destroy_cursor,im_create_cursor$destroy
	ext_transfer destroy_index,im_destroy_index$im_destroy_index
	ext_transfer get_key,im_general_search$get
	ext_transfer get_key_count_array,im_get_key_count_array$im_get_key_count_array
	ext_transfer get_key_count_by_spec,im_general_search$count
	ext_transfer position_cursor,im_general_search$position
	ext_transfer put_key,im_put_key$im_put_key
	ext_transfer put_key_array,im_put_key$array
	end




		    rcm_create_collection.pl1       04/04/85  1109.9r w 04/04/85  0913.6       67347



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


/* DESCRIPTION
   Creates an empty record collection in the given page file with the
fields specified in typed_vector_array.  A record collection identifier is
assigned for referencing this collection which is the index of the
collection in the collmr_header.collection array for this page file.  The
record_collection_header contains the element_id of the field
table for this collection.
*/

/* HISTORY:
Written by Matthew Pierret, 04/01/82.
Modified:
04/22/82 by Matthew Pierret: Changed to use data_mgmt_util_$cv_typed_array_to_table
            instead of dmu_build_field_table.
04/28/82 by Matthew Pierret: Changed calling sequence to accept p_cism_info_ptr
            and p_esm_info_ptr so that the caller can specify what storage
            methods to use. Defaults are UCISM and Unthreaded BESM.
12/07/82 by Matthew Pierret: Changed to call FINISH before returning in the
            normal case.  Changed to define an area with the no_freeing bit off.
03/16/83 by Matthew Pierret: Added use of ERROR_RETURN, local structures
            instead of allocated ones, cleanup handler, get_dm_free_area_,
            RECORD_COLLECTION_HEADER_VERSION_2.
03/24/83 by Lindsey Spratt:  Changed to use version 2 of the field_table, and
	  to check its version number.
07/28/83 by Matthew Pierret: Changed name from rm_create_collection to
            rcm_create_collection, and all rm_ prefixes to rcm_.
            Also changed to set basic_esm_info.fixed_length to "1"b if there
            are no varying fields.
05/04/84 by Matthew Pierret: Changed to use FIELD_TABLE_VERSION_3, to use
            data_format_util_ instead of data_mgmt_util_ and to remove un-used
            builtin declarations.
05/20/84 by Matthew Pierret: Changed to use (ESM CISM)_INFO_VERSION_1
            structures.  Changed name of include files dm_cm_(esm cism)_info
            to dm_(esm cism)_info.
06/12/84 by Matthew Pierret: Re-named cm_$allocate_element to cm_$put.
*/

/* format: style2 */

rcm_create_collection:
     proc (p_file_opening_id, p_typed_vector_array_ptr, p_cism_info_ptr, p_esm_info_ptr, p_record_collection_id, p_code);


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

	dcl     p_file_opening_id	 bit (36) aligned;
	dcl     p_typed_vector_array_ptr
				 ptr;
	dcl     p_cism_info_ptr	 ptr;
	dcl     p_esm_info_ptr	 ptr;
	dcl     p_record_collection_id bit (36) aligned;
	dcl     p_code		 fixed bin (35);

/* Automatic */

	dcl     (file_opening_id, record_collection_id, field_table_element_id)
				 bit (36) aligned init ("0"b);
	dcl     maximum_element_length fixed bin (35);
	dcl     work_area_ptr	 ptr init (null);

	dcl     1 local_record_collection_header
				 aligned like record_collection_header;
	dcl     1 local_unblocked_cism_info
				 aligned like unblocked_cism_info;
	dcl     1 local_basic_esm_info aligned like basic_esm_info;

/* Based */

	dcl     work_area		 area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

	dcl     (addr, null, length, unspec)
				 builtin;

/* Condition */

	dcl     cleanup		 condition;

/* Constant */

	dcl     myname		 init ("rcm_create_collection") char (32) varying int static options (constant);

/* Entry */

	dcl     data_format_util_$cv_typed_array_to_table
				 entry (ptr, ptr, ptr, fixed bin (35), fixed bin (35));
	dcl     get_dm_free_area_	 entry () returns (ptr);
	dcl     sub_err_		 entry () options (variable);

/* External */

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

	dcl     sys_info$max_seg_size	 ext fixed bin (35);

/* END OF DECLARATIONS */

	p_code = 0;
	p_record_collection_id = "0"b;

	file_opening_id = p_file_opening_id;
	typed_vector_array_ptr = p_typed_vector_array_ptr;
	field_table_ptr = null;

	if p_cism_info_ptr ^= null
	then unblocked_cism_info_ptr = p_cism_info_ptr;
	else do;
		unblocked_cism_info_ptr = addr (local_unblocked_cism_info);
		unblocked_cism_info.version = CISM_INFO_VERSION_1;
		unblocked_cism_info.type = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD;
		unblocked_cism_info.must_be_zero = 0;
	     end;
	if p_esm_info_ptr ^= null
	then do;
		basic_esm_info_ptr = p_esm_info_ptr;
		call CHECK_VERSION_CHAR (ESM_INFO_VERSION_1, basic_esm_info.version, "esm_info");
	     end;
	else do;
		basic_esm_info_ptr = addr (local_basic_esm_info);
		basic_esm_info.version = ESM_INFO_VERSION_1;
		basic_esm_info.type = BASIC_ELEMENT_STORAGE_METHOD;
		basic_esm_info.flags.threaded = "0"b;
		basic_esm_info.flags.fixed_length = "0"b;
		basic_esm_info.flags.pad = "0"b;
		basic_esm_info.maximum_element_length = -1;
	     end;

	on cleanup call FINISH ();

	work_area_ptr = get_dm_free_area_ ();

	ft_length_of_field_names, ft_number_of_fields = 0;/* So compiler won't complain */

	call data_format_util_$cv_typed_array_to_table (typed_vector_array_ptr, work_area_ptr, field_table_ptr,
	     maximum_element_length, p_code);
	if p_code ^= 0
	then call ERROR_RETURN;

	call CHECK_VERSION_CHAR (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

	if field_table.varying_field_map (1).field_id = 0 /* No varying fields */
	then basic_esm_info.flags.fixed_length = "1"b;

	basic_esm_info.maximum_element_length = maximum_element_length;

	call collection_manager_$create_collection (file_opening_id, unblocked_cism_info_ptr, basic_esm_info_ptr,
	     record_collection_id, p_code);
	if p_code ^= 0
	then call ERROR_RETURN;


	call collection_manager_$put (file_opening_id, HEADER_COLLECTION_ID, field_table_ptr,
	     length (unspec (field_table)), field_table_element_id, (0), p_code);
	if p_code ^= 0
	then call ERROR_RETURN;

	record_collection_header_ptr = addr (local_record_collection_header);

	record_collection_header.version = RECORD_COLLECTION_HEADER_VERSION_2;
	record_collection_header.field_table_element_id = field_table_element_id;

	call collection_manager_$put_header (file_opening_id, record_collection_id, record_collection_header_ptr,
	     length (unspec (record_collection_header)), p_code);
	if p_code ^= 0
	then call ERROR_RETURN;


	p_record_collection_id = record_collection_id;

	call FINISH ();

MAIN_RETURN:
	return;

%page;
ERROR_RETURN:
     proc ();

	call FINISH ();
	goto MAIN_RETURN;

     end ERROR_RETURN;


FINISH:
     proc;

	if work_area_ptr ^= null
	then if field_table_ptr ^= null
	     then free field_table in (work_area);

     end FINISH;
%page;
CHECK_VERSION_CHAR:
     proc (p_expected_version, p_received_version, p_structure_name);

	dcl     (p_expected_version, p_received_version)
				 char (8) aligned;
	dcl     p_structure_name	 char (*) parameter;

	if p_expected_version ^= p_received_version
	then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
		"^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
     end CHECK_VERSION_CHAR;
%page;
%include sub_err_flags;
%page;
%include vu_typed_vector_array;
%page;
%include dm_rcm_header;
%page;
%include dm_field_table;
%page;
%include dm_cism_info;
%page;
%include dm_esm_info;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_hdr_collection_id;

     end rcm_create_collection;




		    rcm_create_cursor.pl1           01/04/85  0917.4re  01/03/85  1147.1       22293



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2 */
rcm_create_cursor:
create_cursor:
     proc (p_file_opening_id, p_record_collection_id, p_work_area_ptr, p_record_cursor_ptr, p_code);

/* DESCRIPTION
   Allocates a record_cursor structure in the provided work area.  This
   cursor is tailored for the record collection with which it is to be used.
   Its initial position is at the beginning of the collection.
*/

/* Written by Matthew Pierret.
Modified:
09/07/82 by Matthew Pierret:  Changed collection_id to bit (36) aligned.
07/28/83 by Matthew Pierret: Changed name from rm_create_cursor to
            rcm_create_cursor, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin:  Renamed the parameters to coincide with all the other
            rcm_XX routines.
*/

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

	dcl     p_file_opening_id	 bit (36) aligned;
	dcl     p_record_collection_id bit (36) aligned;
	dcl     p_work_area_ptr	 ptr;
	dcl     p_record_cursor_ptr	 ptr;
	dcl     p_code		 fixed bin (35);

/* Automatic */

	dcl     work_area_ptr	 ptr;

/* Based */

	dcl     work_area		 area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */
/* Condition */

	dcl     area		 condition;

/* Controlled */
/* Constant */

	dcl     myname		 init ("rcm_create_cursor") char (32) varying internal static options (constant);

/* Entry */
/* External */

	dcl     error_table_$area_too_small
				 ext fixed bin (35);
	dcl     sys_info$max_seg_size	 ext fixed bin (35);

/* END OF DECLARATIONS */

	p_code = 0;
	work_area_ptr = p_work_area_ptr;

	on area
	     begin;
		p_code = error_table_$area_too_small;
		goto RETURN;
	     end;

	alloc record_cursor in (work_area);
	record_cursor.version = RECORD_CURSOR_VERSION_2;
	record_cursor.type = RECORD_CURSOR_TYPE;
	record_cursor.area_ptr = work_area_ptr;
	record_cursor.file_opening_id = p_file_opening_id;
	record_cursor.collection_id = p_record_collection_id;
	record_cursor.record_id = BEGINNING_OF_COLLECTION_RECORD_ID;
	record_cursor.record_check_value = "0"b;
	string (record_cursor.flags) = "0"b;

	p_record_cursor_ptr = record_cursor_ptr;
RETURN:
	return;

%page;
%include dm_rcm_cursor;

     end rcm_create_cursor;




		    rcm_delete_record_by_id.pl1     04/04/85  1109.9r w 04/04/85  0913.6       57195



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


/* DESCRIPTION

          Deletes the records specified by the given identifiers. The cursor is
     positioned to the record following the last record deleted.

          This routine always gets the record collection's opening information.
     A later performance gain can be achieved by adding single_info and
     array_info entry points that take pointers to opening information.
*/

/* HISTORY:
Written by Matthew Pierret 04/23/82.
Modified:
08/20/82 by Matthew Pierret:  Made enter-able only by the entry points single 
            and array.  Added use of rm_get_opening_info, which is in reality
            simply the field_table.
03/16/83 by Matthew Pierret:  Changed to use the record_collection_opening_info
            structure returned from rm_get_opening_info.
            Changed to translate some collection_manager_ errors to
            dm_error_$record_not_found.
03/24/83 by Lindsey Spratt:  Removed references to the field_table and the
	  record_collection_opening_info structures.
07/28/83 by Matthew Pierret: Changed name from rm_delete_record_by_id to
            rcm_delete_record_by_id, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin:  Renamed the parameters to coincide with all the other
            rcm_XX routines.  Changed the declaration of 
            number_of_records_processed to fixed bin (35). (was (17)).
06/06/84 by Matthew Pierret: Re-named cm_$free_element to cm_$delete.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

rcm_delete_record_by_id:
   proc ();

      call
         sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0, "^/^a$^a is not a valid entrypoint",
         myname, myname);


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

      dcl	    p_record_cursor_ptr    ptr;
      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_record_id	       bit (36) aligned;
      dcl	    p_number_of_records_processed
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    delete_single_record   bit (1) aligned init ("0"b);
      dcl	    record_id	       bit (36) aligned;
      dcl	    record_idx	       fixed bin;

/* Based */
/* Builtin */

      dcl	    (null, hbound)	       builtin;

/* Controlled */
/* Constant */

      dcl	    BITS_PER_CHAR	       init (9) fixed bin internal static options (constant);
      dcl	    myname	       init ("rcm_delete_record_by_id") char (32) varying internal static
			       options (constant);

/* Entry */

      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$programming_error,
	    dm_error_$record_not_found,
	    dm_error_$wrong_cursor_type,
	    error_table_$unimplemented_version
	    )		       ext fixed bin (35);

/* END OF DECLARATIONS */

single:
   entry (p_record_id, p_record_cursor_ptr, p_code);

      delete_single_record = "1"b;
      record_id = p_record_id;

      goto JOIN;


array:
   entry (p_element_id_list_ptr, p_record_cursor_ptr, p_number_of_records_processed, p_code);

      element_id_list_ptr = p_element_id_list_ptr;

      call CHECK_VERSION ((element_id_list.version), (ELEMENT_ID_LIST_VERSION_1), "element_id_list");

      record_id = element_id_list.id (1);
      delete_single_record = "0"b;

      goto JOIN;

%page;
JOIN:
      p_code = 0;

      record_cursor_ptr = p_record_cursor_ptr;

      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");

      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected record cursor, type ^d; received type ^d.", RECORD_CURSOR_TYPE, record_cursor.type);


      record_cursor.flags.position_is_valid = "0"b;

      call
         collection_manager_$delete (record_cursor.file_opening_id, record_cursor.collection_id, record_id, "0"b, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);


      if ^delete_single_record
      then
DELETE_REST_OF_RECORDS:
         do;
	  p_number_of_records_processed = 1;

	  do record_idx = 2 to hbound (element_id_list.id, 1);

	     record_id = element_id_list.id (record_idx);

	     call
	        collection_manager_$delete (record_cursor.file_opening_id, record_cursor.collection_id, record_id,
	        ("0"b), p_code);
	     if p_code ^= 0
	     then call ERROR_RETURN (p_code);

	     p_number_of_records_processed = p_number_of_records_processed + 1;

	  end;
         end DELETE_REST_OF_RECORDS;

      record_cursor.record_id = record_id;
      record_cursor.flags.position_is_valid = "1"b;

MAIN_RETURN:
      return;

%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
ERROR_RETURN:
   proc (p_code);

      dcl	    p_code	       fixed bin (35);
      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element
	    )		       fixed bin ext;

      if p_code = dm_error_$no_element
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_in_collection
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_allocated
      then p_code = dm_error_$record_not_found;

      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
%include dm_rcm_cursor;
%page;
%include dm_element_id_list;
%page;
%include sub_err_flags;
%page;
%include dm_collmgr_entry_dcls;

   end rcm_delete_record_by_id;




		    rcm_destroy_collection.pl1      01/04/85  0917.4re  01/03/85  1147.1       22671



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

/* format: style2,ind3 */

rcm_destroy_collection:
   proc (p_file_opening_id, p_record_collection_id, p_code);

/* DESCRIPTION:
         This  routine  destroys  a  record  collection by first freeing this
     process' opening information associated with the collection, then calling
     collection_manager_$destroy_collection to actually destroy the collection
     and free the storage it uses.
*/

/* HISTORY:
Written by Matthew Pierret, 04/04/83.
Modified:
07/28/83 by Matthew Pierret: Changed name from rm_destroy_collection to
            rcm_destroy_collection, and all rm_ prefixes to rcm_.
08/08/83 by Matthew Pierret: Changed use of non-existent entry
            rcm_get_opening_info$free to the correct entry
            rcm_free_opening_info.
*/

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

      dcl	    p_file_opening_id      bit (36) aligned;	/*Identifier of the open
                                                   file in which the record
                                                   collection resides.*/
      dcl	    p_record_collection_id bit (36) aligned;	/*Identifier of the record collection to be destroyed*/
      dcl	    p_code	       fixed bin (35);	/*Error code*/

/* Automatic */
/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("rcm_destroy_collection") char (32) varying internal static options (constant);

/* Entry */

      dcl	    collection_manager_$destroy_collection
			       entry (bit (36) aligned, bit (36) aligned, fixed bin (35));
      dcl	    rcm_free_opening_info  entry (bit (36) aligned, bit (36) aligned, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$no_opening   fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;

      call rcm_free_opening_info (p_file_opening_id, p_record_collection_id, p_code);
      if p_code ^= 0
      then if p_code = dm_error_$no_opening
	 then p_code = 0;
	 else return;

      call collection_manager_$destroy_collection (p_file_opening_id, p_record_collection_id, p_code);

      return;
%page;
%include sub_err_flags;

   end rcm_destroy_collection;




		    rcm_destroy_cursor.pl1          01/04/85  0917.4re  01/03/85  1147.1       24750



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

/* format: style2,ind3 */

rcm_destroy_cursor:
   proc (p_record_cursor_ptr, p_code);

/* DESCRIPTION:
         This routine frees the storage used by the given record_cursor.
*/

/* HISTORY:
Written by Matthew Pierret, 04/04/83.
Modified:
07/28/83 by Matthew Pierret: Changed name from rm_destroy_cursor to
            rcm_destroy_cursor, and all rm_ prefixes to rcm_.
*/

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

      dcl	    p_record_cursor_ptr    ptr;		/*Pointer to record_cursor to be
                                        destroyed.*/
      dcl	    p_code	       fixed bin (35);	/*Error code*/

/* Automatic */

      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("rcm_destroy_cursor") char (32) varying internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$wrong_cursor_type,
	    error_table_$unimplemented_version,
	    sys_info$max_seg_size
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;
      record_cursor_ptr = p_record_cursor_ptr;

      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected a record cursor, type ^d.  Received cursor of type ^d.", RECORD_CURSOR_TYPE, record_cursor.type)
	    ;
      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");

      work_area_ptr = record_cursor.area_ptr;

      free record_cursor in (work_area);

      p_record_cursor_ptr = null;

      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
%include dm_rcm_cursor;
%page;
%include sub_err_flags;
   end rcm_destroy_cursor;




		    rcm_free_opening_info.pl1       01/04/85  0917.4re  01/03/85  1147.2       35451



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

/* format: style2,ind3 */

rcm_free_opening_info:
   proc (p_file_opening_id, p_record_collection_id, p_code);

/* DESCRIPTION:
         This  routine  frees  the  opening  information held for this record
     collection.
*/

/* HISTORY:
Written by Matthew Pierret, 04/04/83.
Modified:
07/28/83 by Matthew Pierret: Changed name from rm_free_opening_info to
            rcm_free_opening_info, and all rm_ prefixes to rcm_.
05/04/84 by Matthew Pierret:  Changed to FIELD_TABLE_VERSION_3.
*/

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

      dcl	    p_file_opening_id      bit (36) aligned;	/*is the opening identifier of a
                                           file*/
      dcl	    p_record_collection_id bit (36) aligned;	/*is the identifier of a record
                                           collection*/
      dcl	    p_code	       fixed bin (35);	/*is a standard system error code*/

/* Automatic */

      dcl	    opening_table_ptr      ptr;

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (dm_area_ptr);

/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("rcm_free_opening_info") char (32) varying internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    rcm_get_opening_info$opening_table_ptr
			       entry () returns (ptr);
      dcl	    opening_manager_$get_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$free_opening
			       entry (ptr, bit (72) aligned, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$programming_error,
	    dm_error_$no_opening,
	    sys_info$max_seg_size
	    )		       fixed bin (35) ext;

/* Static */

      dcl	    dm_area_ptr	       ptr internal static init (null);

/* END OF DECLARATIONS */

      p_code = 0;

      opening_table_ptr = rcm_get_opening_info$opening_table_ptr ();
      if opening_table_ptr = null
      then return;					/* Nothing to free */

      call
         opening_manager_$get_opening (opening_table_ptr, (p_file_opening_id || p_record_collection_id),
         record_collection_opening_info_ptr, p_code);
      if p_code ^= 0
      then
         do;
	  if p_code = dm_error_$no_opening
	  then p_code = 0;
	  return;
         end;

      if record_collection_opening_info.version ^= RECORD_COLLECTION_OPENING_INFO_VERSION_1
      then call
	    sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^8a of the record_collection_opening_info structure.^/Received version ^8a.",
	    RECORD_COLLECTION_OPENING_INFO_VERSION_1, record_collection_opening_info.version);

      field_table_ptr = record_collection_opening_info.field_table_ptr;
      if field_table.version ^= FIELD_TABLE_VERSION_3
      then call
	    sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the record_collection_opening_info structure.^/Received version ^d.",
	    FIELD_TABLE_VERSION_3, field_table.version);

      call opening_manager_$free_opening (opening_table_ptr, (p_file_opening_id || p_record_collection_id), p_code);
      if p_code ^= 0
      then return;

      if dm_area_ptr = null
      then dm_area_ptr = get_dm_free_area_ ();

      free record_collection_opening_info in (dm_area);
      free field_table in (dm_area);

      return;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_field_table;
%page;
%include sub_err_flags;
   end rcm_free_opening_info;




		    rcm_general_search.pl1          04/04/85  1109.9r w 04/04/85  0913.6      237762



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


/* DESCRIPTION:

          This routine implements the several record_manager_ operations
     which require searching a record collection. The operations (and the
     entry into this routine which implements the operation) are:
     get_records_by_spec ($get), get_record_ids_by_spec ($get_id),
     get_records_and_ids_by_spec ($get_records_and_ids), 
     delete_records_by_spec ($delete), get_record_count ($count),
     and modify_records_by_spec ($modify).
          Each entry takes as input a search_specification and a
     record_cursor. Records are returned in typed_vector_arrays;
     record ids are returned in element_id_lists.

     The actual work processing of the records, such as deleting a record,
     is done in one of two subroutines depending if the operation is an update
     operation or a retrieval.  This routine, rcm_general_search, sets up the 
     environment in which the utility subroutines run, thereby making those
     subroutines relatively simple.
     
     All entries in this procedure share the following of parameters:
     
     p_record_cursor_ptr: points to a record_cursor.  The record_cursor holds
		      the file_opening_id, the collection_id, and the
		      record_id of the current record.  The record_id may
		      be "0"b for no-current-record.  If non-zero and the 
		      search is relative to that record, that record is 
		      retrieved for verification.
     p_specification_ptr: points to a numeric_specification or to a
		      search_specification.  The spec determines how the 
		      search is to be conducted and applies constraints on
		      records selected.  The spec is used to set up the 
		      search environment as from it are determined whether
		      numeric poistioning or search on constraints is to be
		      done, whether any record value satisfies the 
		      constraints, whether the search is relative to the
		      current record (in the record_cursor) or absolute
		      (actually, relative to the beginning or end of the 
		      record collection), the maximum number of records to
		      return (if specified), and the number of records
		      away from the current (or beginning or end) record
		      the first record to process is.  This last item can
		      be the number specified in a numeric_specification
		      or, if for a search_specification, +1 or -1, with the
		      sign indicating whether to process records backwards
		      or forwards.  It is important to note that the 
		      current record is not the first record processed.
		      The first record processed is always some number of 
		      records away from the current record.
*/

/* HISTORY:

Written by Matthew Pierret, 08/19/82.
   (Largely copied from im_general_search, written by Lindsey Spratt, 06/16/82.
Modified:
10/12/82 by Lindsey Spratt:  Changed to use version 2 of the 
	  search_specification.
11/09/82 by Lindsey Spratt:  Changed to use version 3 of the specification
	  structures.
11/22/82 by Lindsey Spratt:  Changed to use the correct calling sequence  for
	  data_mgmt_util_$cv_table_to_typed_array.
12/14/82 by Matthew Pierret: Added $count, $get_id, $modify, $position.
            Changed calling sequence to rm_process_records$get and $delete to
            include is_numeric_specification and is_relative_specification 
            flags.
12/22/82 by Matthew Pierret: Removed initial_record_id from rm_process_records
            entries.  Changed to handle case of null p_specification_ptr.
02/28/83 by Lindsey Spratt:  Changed to return a 0 error code when asked to
	  count an empty collection.
03/16/83 by Matthew Pierret: Changed to use record_collection_opening_info.
            Removed cleanup handler and FINISH. Added check of record_cursor
            type prior to version check.
04/22/83 by Matthew Pierret:  Added the $get_records_and_ids entry.
04/27/83 by Matthew Pierret:  Changed to allocate a typed_vector_array before
            calling rm_process_records $get_records_and_ids.
05/23/83 by Matthew Pierret:  Changed to use version 4 of specification_head.
06/14/83 by Lindsey L. Spratt:  Moved conversion of field table to
            typed_vector_array into rm_process_records.  Added cleanup
            handler, FINISH and ERROR_RETURN procedures.
07/28/83 by Matthew Pierret: Changed name from rm_general_search to
            rcm_general_search, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin: Added the entry for $position.  Removed the
            p_typed_vector_array_type parameter since it never got used.
12/04/84 by Matthew Pierret: Changed to use dm_vector_util_ instead of
            vector_util_, and rcm_get_by_spec and rcm_update_by_spec instead
            of rcm_process_records. Fixed for audit.
12/13/84 by R. Michael Tague: Made get the main procedure, removed some
            CHECK_VERISON pass by values.
02/12/85 by Lindsey L. Spratt:  Changed to test the code after each call in
            the main "case" statement, rather than in the end of the case.
            Changed the GET, GET_ID, and GET_RECORDS_AND_IDS to check for
            et_$area_too_small.
 */

/* format: style2,ind3 */

get:
   proc (p_specification_ptr, p_id_list_ptr, p_work_area_ptr, p_record_cursor_ptr, p_typed_vector_array_ptr, p_code);

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

      dcl	    p_specification_ptr    ptr parameter;
      dcl	    p_id_list_ptr	       ptr parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_record_cursor_ptr    ptr parameter;
      dcl	    p_element_id_list_ptr  ptr parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_general_typed_vector_ptr
			       ptr parameter;
      dcl	    p_number_of_records_processed
			       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    entry		       fixed bin;
      dcl	    spec_is_relative       bit (1) aligned;
      dcl	    spec_is_numeric	       bit (1) aligned;
      dcl	    spec_is_always_satisfied
			       bit (1) aligned;
      dcl	    search_in_reverse_order
			       bit (1) aligned;

      dcl	    first_record_id	       bit (36) aligned;
      dcl	    low_record_id_bound    bit (36) aligned;
      dcl	    high_record_id_bound   bit (36) aligned;

      dcl	    code		       fixed bin (35);
      dcl	    maximum_number_of_records
			       fixed bin (35);
      dcl	    direction_of_search    fixed bin (17);
      dcl	    position_from_initial  fixed bin (17);
      dcl	    (typed_vector_array_ptr, field_table_ptr)
			       ptr init (null);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       char (32) varying init ("rcm_general_search") internal static options (constant);
      dcl	    DEFAULT_RECORD_ID_BOUND
			       init ("0"b) bit (36) aligned internal static options (constant);
      dcl	    DEFAULT_MAXIMUM_NUMBER_OF_RECORDS
			       init (3435974000) fixed bin (35) internal static options (constant);
      dcl	    NO_POSITIONING	       init (0) fixed bin (17) internal static options (constant);
      dcl	    SPECIFIED_ID_IS_NOT_DEFAULT_ID
			       init ("0"b) bit (1) aligned internal static options (constant);
      dcl	    (
	    GET_ENTRY	       init (1),
	    GET_ID_ENTRY	       init (2),
	    GET_RECORDS_AND_IDS_ENTRY
			       init (3),
	    COUNT_ENTRY	       init (4),
	    POSITION_ENTRY	       init (5),
	    DELETE_ENTRY	       init (6),
	    MODIFY_ENTRY	       init (7)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    rcm_get_by_spec$count  entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), fixed bin (35), fixed bin (35));
      dcl	    rcm_get_by_spec$get    entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), ptr, ptr, ptr, fixed bin (35));
      dcl	    rcm_get_by_spec$get_records_and_ids
			       entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), ptr, ptr, ptr, ptr, fixed bin (35));
      dcl	    rcm_get_by_spec$get_id entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), ptr, ptr, fixed bin (35));
      dcl	    rcm_get_by_spec$position
			       entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), fixed bin (35));
      dcl	    rcm_update_by_spec$delete
			       entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), fixed bin (35), fixed bin (35));
      dcl	    rcm_update_by_spec$modify
			       entry (ptr, ptr, ptr, bit (36) aligned, bit (36) aligned, bit (1) aligned, fixed bin,
			       fixed bin (35), ptr, fixed bin (35), fixed bin (35));

      dcl	    sub_err_	       entry options (variable);
      dcl	    dm_vector_util_$free_typed_vector_array
			       entry (ptr, ptr, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$bad_specification_type,
	    dm_error_$beginning_of_collection,
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$end_of_collection,
	    dm_error_$invalid_cursor_position,
	    dm_error_$no_element,
	    dm_error_$programming_error,
	    dm_error_$record_not_found,
	    dm_error_$wrong_cursor_type,
	    error_table_$area_too_small,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

/* rcm_general_search$get entry point. */

      entry = GET_ENTRY;
      goto JOIN;

get_id:
   entry (p_specification_ptr, p_work_area_ptr, p_record_cursor_ptr, p_element_id_list_ptr, p_code);

      entry = GET_ID_ENTRY;
      goto JOIN;

get_records_and_ids:
   entry (p_specification_ptr, p_id_list_ptr, p_work_area_ptr, p_record_cursor_ptr, p_element_id_list_ptr,
        p_typed_vector_array_ptr, p_code);

      entry = GET_RECORDS_AND_IDS_ENTRY;
      goto JOIN;

delete:
   entry (p_specification_ptr, p_record_cursor_ptr, p_number_of_records_processed, p_code);

      entry = DELETE_ENTRY;
      p_number_of_records_processed = 0;
      goto JOIN;

modify:
   entry (p_specification_ptr, p_general_typed_vector_ptr, p_record_cursor_ptr, p_number_of_records_processed, p_code);

      entry = MODIFY_ENTRY;
      p_number_of_records_processed = 0;
      goto JOIN;

count:
   entry (p_specification_ptr, p_record_cursor_ptr, p_number_of_records_processed, p_code);

      entry = COUNT_ENTRY;
      p_number_of_records_processed = 0;
      goto JOIN;

position:
   entry (p_specification_ptr, p_record_cursor_ptr, p_code);

      entry = POSITION_ENTRY;
      goto JOIN;
%page;
JOIN:
      p_code = 0;
      code = 0;
      record_cursor_ptr = p_record_cursor_ptr;
      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected record cursor, type ^d; received type ^d.", RECORD_CURSOR_TYPE, record_cursor.type);
      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");

      specification_head_ptr = p_specification_ptr;
      call GET_SPEC_VALUES (specification_head_ptr, spec_is_relative, spec_is_numeric, spec_is_always_satisfied,
	 search_in_reverse_order, maximum_number_of_records, position_from_initial);
      if spec_is_relative
      then
         do;
	  call VERIFY_POSITION (record_cursor_ptr);
	  if search_in_reverse_order
	  then
	     do;
	        low_record_id_bound = DEFAULT_RECORD_ID_BOUND;
	        high_record_id_bound = record_cursor.record_id;
	     end;
	  else
	     do;
	        low_record_id_bound = record_cursor.record_id;
	        high_record_id_bound = DEFAULT_RECORD_ID_BOUND;
	     end;
         end;
      else low_record_id_bound, high_record_id_bound = DEFAULT_RECORD_ID_BOUND;

      first_record_id = FIRST_RECORD_TO_PROCESS (record_cursor_ptr, low_record_id_bound, position_from_initial);

      if search_in_reverse_order
      then direction_of_search = -1;
      else direction_of_search = +1;

      call rcm_get_opening_info (record_cursor.file_opening_id, record_cursor.collection_id,
	 record_collection_opening_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);
      call CHECK_VERSION_CHAR_8 (record_collection_opening_info.version, RECORD_COLLECTION_OPENING_INFO_VERSION_1,
	 "record_collection_opening_info");
      field_table_ptr = record_collection_opening_info.field_table_ptr;

      on cleanup call FINISH;

      if entry = GET_ENTRY
      then
         do;
	  call rcm_get_by_spec$get (record_cursor_ptr, field_table_ptr, specification_head_ptr, first_record_id,
	       high_record_id_bound, spec_is_always_satisfied, direction_of_search, maximum_number_of_records,
	       p_work_area_ptr, p_id_list_ptr, typed_vector_array_ptr, code);
	  if code ^= 0
	  then if code ^= error_table_$area_too_small
	       then call ERROR_RETURN (code);
         end;
      else if entry = GET_ID_ENTRY
      then
         do;
	  call rcm_get_by_spec$get_id (record_cursor_ptr, field_table_ptr, specification_head_ptr, first_record_id,
	       high_record_id_bound, spec_is_always_satisfied, direction_of_search, maximum_number_of_records,
	       p_work_area_ptr, p_element_id_list_ptr, code);
	  if code ^= 0
	  then if code ^= error_table_$area_too_small
	       then call ERROR_RETURN (code);
         end;

      else if entry = GET_RECORDS_AND_IDS_ENTRY
      then
         do;
	  call rcm_get_by_spec$get_records_and_ids (record_cursor_ptr, field_table_ptr, specification_head_ptr,
	       first_record_id, high_record_id_bound, spec_is_always_satisfied, direction_of_search,
	       maximum_number_of_records, p_work_area_ptr, p_id_list_ptr, p_element_id_list_ptr, typed_vector_array_ptr,
	       code);
	  if code ^= 0
	  then if code ^= error_table_$area_too_small
	       then call ERROR_RETURN (code);
         end;

      else if entry = COUNT_ENTRY
      then
         do;
	  call rcm_get_by_spec$count (record_cursor_ptr, field_table_ptr, specification_head_ptr, first_record_id,
	       high_record_id_bound, spec_is_always_satisfied, direction_of_search, maximum_number_of_records,
	       p_number_of_records_processed, code);
	  if code ^= 0
	  then if code ^= dm_error_$record_not_found
	       then call ERROR_RETURN (code);
         end;
      else if entry = POSITION_ENTRY
      then
         do;
	  call rcm_get_by_spec$position (record_cursor_ptr, field_table_ptr, specification_head_ptr, first_record_id,
	       high_record_id_bound, spec_is_always_satisfied, direction_of_search, maximum_number_of_records, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;
      else if entry = DELETE_ENTRY
      then
         do;
	  call rcm_update_by_spec$delete (record_cursor_ptr, field_table_ptr, specification_head_ptr, first_record_id,
	       high_record_id_bound, spec_is_always_satisfied, direction_of_search, maximum_number_of_records,
	       p_number_of_records_processed, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;
      else if entry = MODIFY_ENTRY
      then
         do;
	  call rcm_update_by_spec$modify (record_cursor_ptr, field_table_ptr, specification_head_ptr, first_record_id,
	       high_record_id_bound, spec_is_always_satisfied, direction_of_search, maximum_number_of_records,
	       p_general_typed_vector_ptr, p_number_of_records_processed, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;
      else call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null (), 0,
	      "The entry code ^d is not one of the possible valid entry codes.", entry);

      if entry = GET_ENTRY | entry = GET_RECORDS_AND_IDS_ENTRY
      then p_typed_vector_array_ptr = typed_vector_array_ptr;
      else ;

      p_code = code;

      call FINISH;
MAIN_RETURN:
      return;
%page;
FINISH:
   proc;
      if entry = GET_ENTRY | entry = GET_RECORDS_AND_IDS_ENTRY
      then if typed_vector_array_ptr ^= null & p_typed_vector_array_ptr ^= typed_vector_array_ptr
	 then call dm_vector_util_$free_typed_vector_array (p_work_area_ptr, typed_vector_array_ptr, code);
   end FINISH;


ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35) parm;

      p_code = er_p_code;
      call FINISH;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_CHAR_8:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION_CHAR_8;
%page;
VERIFY_POSITION:
   proc (vp_p_record_cursor_ptr);

/* VERIFY_POSITION attempts to access the record specified by
   record_cursor.record_id.  If that record does not exist, the cursor
   is invalid.  If it does exist but some other error occurs, return that
   error.  Either type of error results in a return to the caller of the
   main procedure.  This routine returns to the main procedure only if the
   cursor is valid. */

      dcl	    vp_p_record_cursor_ptr ptr parm;
      dcl	    vp_code	       fixed bin (35);

      vp_code = 0;
      call collection_manager_$get_id (vp_p_record_cursor_ptr -> record_cursor.file_opening_id,
	 vp_p_record_cursor_ptr -> record_cursor.collection_id, vp_p_record_cursor_ptr -> record_cursor.record_id,
	 NO_POSITIONING, SPECIFIED_ID_IS_NOT_DEFAULT_ID, ("0"b), vp_code);
      if vp_code ^= 0
      then if vp_code = dm_error_$no_element | vp_code = dm_error_$ci_not_in_collection
	      | vp_code = dm_error_$ci_not_allocated
	 then call ERROR_RETURN (dm_error_$invalid_cursor_position);
	 else call ERROR_RETURN (vp_code);
      else return;

   end VERIFY_POSITION;
%page;
FIRST_RECORD_TO_PROCESS:
   proc (frp_p_record_cursor_ptr, frp_p_initial_record_id, frp_p_position_from_initial) returns (bit (36) aligned);

/* FIRST_RECORD_TO_PROCESS is a function which returns the record id of
   the first record to process. 
   The error processing is different from that in VERIFY_CURSOR.  This is
   because we know that frp_p_initial_record_id is either a valid record id
   or "0"b.  Any error codes cannot refer to the frp_p_initial_record_id.
   dm_error_$no_element (necessarily with frp_p_initial_record_id = "0"b)
   can only mean that there are no records at all, and
   dm_error_$(beginning end)_of_collection can only mean that we attempted to
   position past the beginning or end of the collection.  All three simply
   mean that the desired record was not found.  Any other error is an
   unexpected error and should be reported as is.  
*/

      dcl	    frp_p_record_cursor_ptr
			       ptr parm;
      dcl	    frp_p_initial_record_id
			       bit (36) aligned parm;
      dcl	    frp_p_position_from_initial
			       fixed bin (17) parm;
      dcl	    frp_code	       fixed bin (35);
      dcl	    frp_start_from_edge    bit (1) aligned;
      dcl	    frp_first_record_id    bit (36) aligned;

      frp_code = 0;
      frp_start_from_edge = (frp_p_initial_record_id = "0"b);

      call collection_manager_$get_id (frp_p_record_cursor_ptr -> record_cursor.file_opening_id,
	 frp_p_record_cursor_ptr -> record_cursor.collection_id, frp_p_initial_record_id, frp_p_position_from_initial,
	 frp_start_from_edge, frp_first_record_id, frp_code);
      if frp_code ^= 0
      then if frp_code = dm_error_$no_element | frp_code = dm_error_$end_of_collection
	      | frp_code = dm_error_$beginning_of_collection
	 then call ERROR_RETURN (dm_error_$record_not_found);
	 else call ERROR_RETURN (frp_code);
      else return (frp_first_record_id);

   end FIRST_RECORD_TO_PROCESS;
%page;
GET_SPEC_VALUES:
   proc (gsv_p_spec_ptr, gsv_p_spec_is_relative, gsv_p_spec_is_numeric, gsv_p_spec_is_always_satisfied,
        gsv_p_search_in_reverse_order, gsv_p_maximum_number_of_records, gsv_p_position_from_initial);

/* This routine analyzes the given specification to determine various
   information to be used in selecting records.  Determination of such
   information is dependent upon the type of specification supplied:
   absolute or relative, search or numeric.  The information returned is:
  
   gsv_p_spec_is_relative : ON if the type of the spec is relative, 
		        OFF if absolute.
   gsv_p_spec_is_numeric :  ON if the type of the spec is numeric,
		        OFF if the type is search.
   gsv_p_spec_is_always_satisfied : ON if the specification is such that
                    any record satisfies its constraints.  This is true if
		a search spec has no constraints, if no spec is supplied,
		or if a numeric spec is supplied.
   gsv_p_search_in_reverse_order : ON if the records are to be processed 
                    backwards.  This is true if a negative position_number is
                    supplied with a numeric_spec, or if a search_spec specifies
                    a range of records which is at the end of acceptable 
                    records (range.type = HIGH_RANGE_TYPE).
   gsv_p_maximum_number_of_records : specifies the most records allowed by the
                    spec.
   gsv_p_position_from_initial : is the number of records to position from the 
                    initial position to get the first record to examine.
                    This can be positive or negative for positioning forward
                    or backward.
*/

      dcl	    gsv_p_spec_ptr	       ptr parm;
      dcl	    gsv_p_spec_is_relative bit (1) aligned parm;
      dcl	    gsv_p_spec_is_numeric  bit (1) aligned parm;
      dcl	    gsv_p_spec_is_always_satisfied
			       bit (1) aligned parm;
      dcl	    gsv_p_search_in_reverse_order
			       bit (1) aligned parm;
      dcl	    gsv_p_maximum_number_of_records
			       fixed bin (35) parm;
      dcl	    gsv_p_position_from_initial
			       fixed bin (17) parm;

      if gsv_p_spec_ptr = null ()
      then
         do;
	  gsv_p_spec_is_relative = "0"b;
	  gsv_p_spec_is_numeric = "0"b;
	  gsv_p_spec_is_always_satisfied = "1"b;
	  gsv_p_search_in_reverse_order = "0"b;
	  gsv_p_position_from_initial = 1;
	  gsv_p_maximum_number_of_records = DEFAULT_MAXIMUM_NUMBER_OF_RECORDS;
         end;
      else
         do;
	  call CHECK_VERSION (gsv_p_spec_ptr -> specification_head.version, SPECIFICATION_VERSION_4, "specification");

	  if gsv_p_spec_ptr -> specification_head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE
	       | gsv_p_spec_ptr -> specification_head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE
	  then
	     do;
	        if gsv_p_spec_ptr -> specification_head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE
	        then gsv_p_spec_is_relative = "1"b;
	        else gsv_p_spec_is_relative = "0"b;

	        search_specification_ptr = gsv_p_spec_ptr;
	        gsv_p_spec_is_numeric = "0"b;
	        gsv_p_spec_is_always_satisfied = (search_specification.number_of_and_groups <= 0);
	        gsv_p_search_in_reverse_order = (search_specification.range.type = HIGH_RANGE_TYPE);
	        gsv_p_position_from_initial = 1;
	        if search_specification.range.type ^= ALL_RANGE_TYPE & search_specification.range.size > 0
	        then gsv_p_maximum_number_of_records = search_specification.range.size;
	        else gsv_p_maximum_number_of_records = DEFAULT_MAXIMUM_NUMBER_OF_RECORDS;
	     end;
	  else if gsv_p_spec_ptr -> specification_head.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE
	       | gsv_p_spec_ptr -> specification_head.type = ABSOLUTE_NUMERIC_SPECIFICATION_TYPE
	  then
	     do;
	        if gsv_p_spec_ptr -> specification_head.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE
	        then gsv_p_spec_is_relative = "1"b;
	        else gsv_p_spec_is_relative = "0"b;

	        numeric_specification_ptr = gsv_p_spec_ptr;
	        gsv_p_spec_is_numeric = "1"b;
	        gsv_p_spec_is_always_satisfied = "1"b;
	        gsv_p_position_from_initial = numeric_specification.position_number;
	        gsv_p_search_in_reverse_order = (gsv_p_position_from_initial < 0);
	        if numeric_specification.range_size > 0
	        then gsv_p_maximum_number_of_records = numeric_specification.range_size;
	        else gsv_p_maximum_number_of_records = DEFAULT_MAXIMUM_NUMBER_OF_RECORDS;
	     end;
	  else call sub_err_ (dm_error_$bad_specification_type, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The  specification structure does not have a recognizable type.^/The recognizable types are: ^d, ^d, ^d or ^d. Received a type ^d structure."
		  , ABSOLUTE_SEARCH_SPECIFICATION_TYPE, RELATIVE_SEARCH_SPECIFICATION_TYPE,
		  ABSOLUTE_NUMERIC_SPECIFICATION_TYPE, RELATIVE_NUMERIC_SPECIFICATION_TYPE,
		  gsv_p_spec_ptr -> specification_head.type);
         end;

      return;


   end GET_SPEC_VALUES;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_rcm_cursor;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include dm_range_constants;
%page;
%include sub_err_flags;
%page;
%include dm_collmgr_entry_dcls;

   end get;




		    rcm_get_by_spec.pl1             10/24/88  1644.7r w 10/24/88  1400.0      280755



/* format: ^indcomtxt */
/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

   This subroutine examines a range of records, selecting records
   according to a sequential_specification.  The records selected are
   processed according to the entrypoint used to enter the subroutine:
   get converts selected records to simple_typed_vectors; $delete deletes
   the selected records.
*/

/* HISTORY:

Written by Matthew Pierret, 08/30/84.
Extracted from rcm_process_records.pl1)
Modified:
12/20/84 by Lindsey L. Spratt:  Fixed to reference dm_vector_util_ instead of
	  vector_util_.
02/05/85 by Lindsey L. Spratt:  Changed SETUP_OUTPUT_RECORDS to take a
            work_area_ptr parm, fixed calls to SETUP_OUTPUT_RECORDS to provide
            an id_list_ptr, changed SOR to use the sor_p_work_area_ptr and
            sor_p_work_area.  Upped the VECTOR_SLOT_INCREMENT to 500 from 50.
	  Fixed SETUP_ID_LIST to set record_id_field_id to the correct value
	  when the last value in the id_list is = to
	  DEFAULT_RECORD_ID_FIELD_ID (-1).
02/12/85 by Lindsey L. Spratt:  Extended to handle area_too_small when adding
            records and ids.
02/16/85 by Lindsey L. Spratt:  Added initializations of all automatic
            variables at declaration time.  Fixed to set the
            record_buffer_length variable.
*/

/* format: style2,ind3,ll79,^indnoniterdo,indnoniterend,^indprocbody,comcol50,^indblkcom,indcomtxt */

rcm_get_by_spec:
   proc ();

   call sub_err_ (dm_error_$programming_error, MYNAME, ACTION_CANT_RESTART,
        null, 0, "^/^a$^a is not a valid entrypoint", MYNAME, MYNAME);

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

   dcl	 p_record_cursor_ptr    ptr parameter;
   dcl	 p_work_area_ptr	    ptr parameter;
   dcl	 p_field_table_ptr	    ptr parameter;
   dcl	 p_id_list_ptr	    ptr parameter;
   dcl	 p_element_id_list_ptr  ptr parameter;
   dcl	 p_specification_ptr    ptr parameter;
   dcl	 p_typed_vector_array_ptr
			    ptr parameter;
   dcl	 p_direction_to_process fixed bin parameter;
   dcl	 p_first_record_to_process
			    bit (36) aligned parameter;
   dcl	 p_last_record_to_process
			    bit (36) aligned parameter;
   dcl	 p_spec_is_always_satisfied
			    bit (1) aligned parameter;
   dcl	 p_maximum_number_of_records
			    fixed bin (35) parameter;
   dcl	 p_number_of_records_accepted
			    fixed bin (35) parameter;
   dcl	 p_code		    fixed bin (35) parameter;

/* Automatic */

   dcl	 (get, get_id, count, position)
			    bit (1) aligned init ("0"b);
   dcl	 (get_each_record, record_satisfies_spec, spec_is_always_satisfied)
			    bit (1) aligned init ("0"b);

   dcl	 area_status	    fixed bin init (AREA_IS_BIG_ENOUGH);
   dcl	 code		    fixed bin (35);
   dcl	 current_ci_ptr	    ptr init (null ());
   dcl	 direction_to_process   fixed bin (17);
   dcl	 field_table_ptr	    ptr init (null ());
   dcl	 first_record_to_process
			    bit (36) aligned init (NO_RECORD);
   dcl	 highest_accepted_record
			    bit (36) aligned init (NO_RECORD);
   dcl	 last_record_to_process bit (36) aligned init (NO_RECORD);
   dcl	 maximum_number_of_records
			    fixed bin (35) init (-1);
   dcl	 number_of_records_accepted
			    fixed bin (35) init (-1);
   dcl	 previous_record_id	    bit (36) aligned init (NO_RECORD);
   dcl	 record_count	    fixed bin (35) init (-1);
   dcl	 record_buffer_length   fixed bin (35) init (-1);
   dcl	 record_buffer_ptr	    ptr init (null ());
   dcl	 record_id	    bit (36) aligned init (NO_RECORD);
   dcl	 record_id_field_id	    fixed bin (17)
			    init (DEFAULT_RECORD_ID_FIELD_ID);
   dcl	 record_string_length   fixed bin (35) init (-1);
   dcl	 record_string_ptr	    ptr init (null ());
   dcl	 specification_ptr	    ptr init (null ());
   dcl	 (old_eil_ptr, old_tva_ptr, vector_ptr, work_area_ptr,
	 based_bit_36_aligned_ptr)
			    ptr init (null);
   dcl	 local_record_buffer    (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
   dcl	 temp_element_id_list_ptr
			    ptr init (null ());
   dcl	 temp_typed_vector_array_ptr
			    ptr init (null ());

/* Based */

   dcl	 based_bit_36_aligned   bit (36) aligned
			    based (based_bit_36_aligned_ptr);

   dcl	 record_string	    bit (record_string_length)
			    based (record_string_ptr);
   dcl	 work_area	    area based (work_area_ptr);
   dcl	 record_buffer	    bit (record_buffer_length) aligned
			    based (record_buffer_ptr);

/* Builtin */

   dcl	 (addr, divide, hbound, min, null, unspec)
			    builtin;

/* Condition */

   dcl	 (area, cleanup)	    condition;

/* Constant */

   dcl	 MYNAME		    init ("rcm_get_by_spec") char (32)
			    varying internal static options (constant);
   dcl	 (
	 AREA_IS_BIG_ENOUGH	    init (1) fixed bin,
	 AREA_IS_TOO_SMALL	    init (2) fixed bin,
	 BACKWARD_DIRECTION	    init (-1) fixed bin,
	 DEFAULT_AND_GROUP_ID_LIST_PTR
			    init (null ()) ptr,
	 DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS
			    init (0) fixed bin,
	 DEFAULT_PARTIAL_STRUCTURAL_FIELD
			    init (0) fixed bin,
	 DEFAULT_RECORD_ID_FIELD_ID
			    init (-1) fixed bin,
	 DOUBLE_WORDS_PER_PAGE  init (512) fixed bin,
	 ELEMENT_ID_LIST_INCREMENT
			    init (100) fixed bin,
	 FALSE		    init ("0"b) bit (1) aligned,
	 FREE_OLD_TYPED_VECTOR_ARRAY
			    init ("1"b) bit (1) aligned,
	 GET_CURRENT	    init (0) fixed bin,
	 IS_RELATIVE	    init ("0"b) bit (1) aligned,
	 LIMIT_TO_STOP_INFINITE_LOOPING
			    init (1e6) fixed bin (35),
	 NO_RECORD	    init ("0"b) bit (36) aligned,
	 TRUE		    init ("1"b) bit (1) aligned,
	 VECTOR_SLOT_INCREMENT  init (500) fixed bin
	 )		    internal static options (constant);

/* Entry */

   dcl	 data_format_util_$compare_sequential
			    entry (ptr, ptr, ptr, fixed bin, fixed bin,
			    bit (*), bit (1) aligned, fixed bin (35));
   dcl	 data_format_util_$cv_table_to_typed_array
			    entry (ptr, ptr, ptr, fixed bin (35), ptr,
			    fixed bin (35));
   dcl	 data_format_util_$new_cv_string_to_vector
			    entry (ptr, ptr, ptr, fixed bin (35), ptr,
			    ptr, fixed bin (35));

   dcl	 dm_vector_util_$append_simple_typed_vector
			    entry options (variable) returns (ptr);
   dcl	 dm_vector_util_$free_typed_vector
			    entry (ptr, ptr, ptr, fixed bin (35));

   dcl	 sub_err_		    entry options (variable);

/* External */

   dcl	 (
	 error_table_$area_too_small,
	 error_table_$unimplemented_version,
	 dm_error_$long_return_element,
	 dm_error_$beginning_of_collection,
	 dm_error_$end_of_collection,
	 dm_error_$record_not_found,
	 dm_error_$programming_error
	 )		    fixed bin (35) ext;


/* END OF DECLARATIONS */

count:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_number_of_records_accepted, p_code);

   count = TRUE;
   maximum_number_of_records = p_maximum_number_of_records;
   field_table_ptr = p_field_table_ptr;
   work_area_ptr = null;
   id_list_ptr = null;
   record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
   element_id_list_ptr = null;
   typed_vector_array_ptr = null;

   go to JOIN;


get:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_work_area_ptr, p_id_list_ptr,
        p_typed_vector_array_ptr, p_code);

   get = TRUE;
   maximum_number_of_records = p_maximum_number_of_records;
   field_table_ptr = p_field_table_ptr;
   work_area_ptr = p_work_area_ptr;
   call SETUP_ID_LIST (p_id_list_ptr, id_list_ptr, record_id_field_id);
   element_id_list_ptr = null;
   call SETUP_OUTPUT_RECORDS (p_typed_vector_array_ptr,
        maximum_number_of_records, record_id_field_id, field_table_ptr,
        id_list_ptr, work_area_ptr, typed_vector_array_ptr);
   go to JOIN;

get_id:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_work_area_ptr, p_element_id_list_ptr,
        p_code);

   get_id = TRUE;
   maximum_number_of_records = p_maximum_number_of_records;
   field_table_ptr = p_field_table_ptr;
   work_area_ptr = p_work_area_ptr;
   call SETUP_ID_LIST (p_id_list_ptr, id_list_ptr, record_id_field_id);
   call SETUP_OUTPUT_IDS (p_element_id_list_ptr, maximum_number_of_records,
        element_id_list_ptr);
   typed_vector_array_ptr = null ();

   go to JOIN;

get_records_and_ids:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_work_area_ptr, p_element_id_list_ptr,
        p_typed_vector_array_ptr, p_code);

   get, get_id = TRUE;
   maximum_number_of_records = p_maximum_number_of_records;
   field_table_ptr = p_field_table_ptr;
   work_area_ptr = p_work_area_ptr;
   call SETUP_ID_LIST (p_id_list_ptr, id_list_ptr, record_id_field_id);
   call SETUP_OUTPUT_IDS (p_element_id_list_ptr, maximum_number_of_records,
        element_id_list_ptr);
   call SETUP_OUTPUT_RECORDS (p_typed_vector_array_ptr,
        maximum_number_of_records, record_id_field_id, field_table_ptr,
        id_list_ptr, work_area_ptr, typed_vector_array_ptr);

   go to JOIN;


position:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_code);

   position = TRUE;
   maximum_number_of_records = p_maximum_number_of_records;
   field_table_ptr = p_field_table_ptr;
   work_area_ptr = null;
   id_list_ptr = null;
   record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
   element_id_list_ptr = null;
   typed_vector_array_ptr = null;

   go to JOIN;

JOIN:
   p_code, code = 0;
   record_cursor_ptr = p_record_cursor_ptr;
   call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2),
        "record_cursor");
   specification_ptr = p_specification_ptr;
   spec_is_always_satisfied = p_spec_is_always_satisfied;
   direction_to_process = p_direction_to_process;
   first_record_to_process = p_first_record_to_process;
   last_record_to_process = p_last_record_to_process;

   record_buffer_ptr = addr (local_record_buffer);
   record_buffer_length = length (unspec (local_record_buffer));

   current_ci_ptr = null;

   if get | ^spec_is_always_satisfied
   then get_each_record = TRUE;
   else get_each_record = FALSE;

   record_id = first_record_to_process;
   highest_accepted_record = NO_RECORD;
   number_of_records_accepted = 0;
   previous_record_id = NO_RECORD;

   on cleanup call FINISH ();

   if get_each_record
   then call GET_RECORD (current_ci_ptr, record_id, GET_CURRENT,
	   record_buffer_ptr, record_buffer_length, record_string_ptr,
	   record_string_length, record_id);

RECORD_LOOP:
   do record_count = 1 to LIMIT_TO_STOP_INFINITE_LOOPING
        while (record_id ^= NO_RECORD);

      if spec_is_always_satisfied
      then record_satisfies_spec = TRUE;
      else
COMPARE:
         do;
         record_satisfies_spec = FALSE;
         call data_format_util_$compare_sequential (field_table_ptr,
	    specification_ptr, DEFAULT_AND_GROUP_ID_LIST_PTR,
	    DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
	    DEFAULT_PARTIAL_STRUCTURAL_FIELD, record_string,
	    record_satisfies_spec, code);
         if code ^= 0
         then call ERROR_RETURN (code);
         end COMPARE;

      if record_satisfies_spec
      then
ACCEPT_THIS_RECORD:
         do;
         number_of_records_accepted = number_of_records_accepted + 1;
         if direction_to_process = BACKWARD_DIRECTION
         then if highest_accepted_record = NO_RECORD
	    then highest_accepted_record = record_id;
	    else ;
         else highest_accepted_record = record_id;

         if get
         then call APPEND_OUTPUT_RECORD (record_string_ptr,
	         record_string_length, typed_vector_array_ptr,
	         field_table_ptr, work_area_ptr, id_list_ptr,
	         record_id_field_id, record_id, area_status);
         if get_id & area_status = AREA_IS_BIG_ENOUGH
         then
	  do;
	  call APPEND_OUTPUT_RECORD_ID (record_id, element_id_list_ptr,
	       number_of_records_accepted, maximum_number_of_records,
	       temp_element_id_list_ptr, area_status);

	  if area_status = AREA_IS_TOO_SMALL & get
	  then
	     do;
	     call dm_vector_util_$free_typed_vector (work_area_ptr,
		typed_vector_array_ptr,
		typed_vector_array
		.vector_slot (typed_vector_array.number_of_vectors), code);
	     if code ^= 0
	     then call ERROR_RETURN (code);
	     typed_vector_array.number_of_vectors =
		typed_vector_array.number_of_vectors - 1;
	     end;
	  end;
         end ACCEPT_THIS_RECORD;

      if number_of_records_accepted >= maximum_number_of_records
	 | record_id = last_record_to_process
      then record_id = NO_RECORD;	         /* Finished */
      else if area_status = AREA_IS_TOO_SMALL
      then
         do;
         record_id = NO_RECORD;
         highest_accepted_record = previous_record_id;
         end;
      else
GET_NEXT:
         do;			         /* More records to look at */
         previous_record_id = record_id;
         if get_each_record
         then call GET_RECORD (current_ci_ptr, previous_record_id,
	         direction_to_process, record_buffer_ptr,
	         record_buffer_length, record_string_ptr,
	         record_string_length, record_id);
         else call GET_RECORD_ID (previous_record_id, direction_to_process,
	         record_id);
         end GET_NEXT;
   end RECORD_LOOP;

   if record_count > LIMIT_TO_STOP_INFINITE_LOOPING
   then call sub_err_ (dm_error_$programming_error, MYNAME,
	   ACTION_CANT_RESTART, null, 0,
	   "^/The search algorithm was apparently looping indefinitely.");

   if number_of_records_accepted <= 0 & area_status = AREA_IS_BIG_ENOUGH
   then call ERROR_RETURN (dm_error_$record_not_found);

/*** Records were found. Return 0 code and prepare return data. */

   if direction_to_process = BACKWARD_DIRECTION
   then
      do;

   /*** The records were retrieved backwards, and must be re-ordered before
        returning to the caller. Reverse the order of the vectors in the
        typed_vector_array and/or the element_ids in the element_id_list. */

      call REVERSE_RECORD_ORDER (typed_vector_array_ptr);
      call REVERSE_RECORD_ID_ORDER (element_id_list_ptr);

      end;

   if get
   then p_typed_vector_array_ptr = typed_vector_array_ptr;

   if get_id
   then
      do;
      p_element_id_list_ptr = element_id_list_ptr;
      element_id_list.number_of_elements = number_of_records_accepted;
      end;

   if count
   then p_number_of_records_accepted = number_of_records_accepted;
   else
      do;				         /* get | get_id | position */
      record_cursor.record_id = highest_accepted_record;
      record_cursor.flags.position_is_valid = TRUE;
      end;

   call RETURN (area_status);

MAIN_RETURN:
   return;


RETURN:
   proc (r_p_area_status);
   dcl	 r_p_area_status	    fixed bin parm;

   call FINISH ();

   if r_p_area_status = AREA_IS_TOO_SMALL
   then p_code = error_table_$area_too_small;
   else p_code = 0;

   goto MAIN_RETURN;

   end RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

   dcl	 cv_p_received_version  fixed bin (35);
   dcl	 cv_p_expected_version  fixed bin (35);
   dcl	 cv_p_structure_name    char (*);

   if cv_p_received_version ^= cv_p_expected_version
   then call sub_err_ (error_table_$unimplemented_version, MYNAME,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ^d of the ^a structure. Received version ^d.",
	   cv_p_expected_version, cv_p_structure_name, cv_p_received_version)
	   ;

   end CHECK_VERSION;
%page;
FINISH:
   proc ();

   call RESET_CI_PTR (current_ci_ptr, current_ci_ptr);
   if temp_typed_vector_array_ptr ^= null
   then free temp_typed_vector_array_ptr -> typed_vector_array;
   if temp_element_id_list_ptr ^= null
   then free temp_element_id_list_ptr -> element_id_list;
   if record_buffer_ptr ^= addr (local_record_buffer)
        & record_buffer_ptr ^= null ()
   then free record_buffer;

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);

   dcl	 er_p_code	    fixed bin (35);

   p_code = er_p_code;
   call FINISH;
   go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
GET_RECORD:
   proc (gr_p_ci_ptr, gr_p_previous_record_id, gr_p_direction,
        gr_p_record_buffer_ptr, gr_p_record_buffer_length,
        gr_p_record_string_ptr, gr_p_record_string_length, gr_p_record_id);

   dcl	 gr_p_ci_ptr	    ptr parameter;
   dcl	 gr_p_previous_record_id
			    bit (36) aligned parameter;
   dcl	 gr_p_record_id	    bit (36) aligned parameter;
   dcl	 gr_p_record_string_ptr ptr parameter;
   dcl	 gr_p_direction	    fixed bin (17) parameter;
   dcl	 gr_p_record_string_length
			    fixed bin (35) parameter;
   dcl	 gr_p_record_buffer_ptr ptr parameter;
   dcl	 gr_p_record_buffer_length
			    fixed bin (35) parameter;
   dcl	 gr_p_record_buffer	    bit (gr_p_record_buffer_length) aligned
			    based (gr_p_record_buffer_ptr);

   dcl	 gr_record_id	    bit (36) aligned;
   dcl	 gr_code		    fixed bin (35);
   dcl	 gr_new_ci_ptr	    ptr;

   gr_code = 0;
   gr_new_ci_ptr = null ();
   gr_record_id = gr_p_previous_record_id;
   call collection_manager_$get_by_ci_ptr (gr_p_ci_ptr,
        record_cursor.file_opening_id, record_cursor.collection_id,
        gr_record_id, gr_p_direction, gr_p_record_buffer_ptr,
        gr_p_record_buffer_length, work_area_ptr, ("0"b),
        gr_p_record_string_ptr, gr_p_record_string_length, gr_new_ci_ptr,
        gr_code);
   if gr_code = 0
   then gr_p_record_id = gr_record_id;
   else
      do;
      if gr_code = dm_error_$end_of_collection
	 | gr_code = dm_error_$beginning_of_collection
      then gr_p_record_id = NO_RECORD;
      else if gr_code = dm_error_$long_return_element
      then call ERROR_RETURN (gr_code);
      else call sub_err_ (gr_code, MYNAME, ACTION_CANT_RESTART, null, 0,
	      "^/This error, which occurred while retrieving record ^b3o, indicates that^/record collection ^b3o is damaged."
	      , gr_p_record_id, record_cursor.collection_id);
      end;

   if gr_p_ci_ptr ^= null & gr_p_ci_ptr ^= gr_new_ci_ptr
   then call RESET_CI_PTR (gr_new_ci_ptr, gr_p_ci_ptr);
   else /* gr_p_ci_ptr remains the same */
        ;

   if gr_p_record_string_ptr ^= gr_p_record_buffer_ptr
   then
      do;
      if gr_p_record_buffer_ptr ^= addr (local_record_buffer)
      then free gr_p_record_buffer;
      gr_p_record_buffer_ptr = gr_p_record_string_ptr;
      gr_p_record_buffer_length = gr_p_record_string_length;
      end;

   return;

   end GET_RECORD;
%page;
GET_RECORD_ID:
   proc (gri_p_previous_record_id, gri_p_direction, gri_p_record_id);

   dcl	 gri_p_previous_record_id
			    bit (36) aligned parameter;
   dcl	 gri_p_record_id	    bit (36) aligned parameter;
   dcl	 gri_p_direction	    fixed bin (17) parameter;

   dcl	 gri_code		    fixed bin (35);


   call collection_manager_$get_id (record_cursor.file_opening_id,
        record_cursor.collection_id, gri_p_previous_record_id, gri_p_direction,
        IS_RELATIVE, gri_p_record_id, gri_code);
   if gri_code ^= 0
   then if gri_code = dm_error_$beginning_of_collection
	   | gri_code = dm_error_$end_of_collection
        then gri_p_record_id = NO_RECORD;
        else call ERROR_RETURN (gri_code);

   return;

   end GET_RECORD_ID;
%page;
RESET_CI_PTR:
   proc (rcp_p_new_ci_ptr, rcp_p_ci_ptr);

/* Releases the ci_ptr held in rcp_p_ci_ptr, if non-null, then resets */
/* rcp_p_ci_ptr with the value of rcp_p_new_ci_ptr. */

   dcl	 rcp_p_ci_ptr	    ptr parameter;
   dcl	 rcp_p_new_ci_ptr	    ptr parameter;

   if rcp_p_ci_ptr ^= null
   then /* After MR11, should call collection_manager_$release_ci_ptr */
        ;

   rcp_p_ci_ptr = rcp_p_new_ci_ptr;

   return;

   end RESET_CI_PTR;
%page;
APPEND_OUTPUT_RECORD:
   proc (aor_p_record_string_ptr, aor_p_record_string_length,
        aor_p_typed_vector_array_ptr, aor_p_field_table_ptr,
        aor_p_work_area_ptr, aor_p_id_list_ptr, aor_p_record_id_field_id,
        aor_p_record_id, aor_p_area_status);

   dcl	 aor_p_record_string_ptr
			    ptr parameter;
   dcl	 aor_p_record_string_length
			    fixed bin (35) parameter;
   dcl	 aor_p_typed_vector_array_ptr
			    ptr parameter;
   dcl	 aor_p_field_table_ptr  ptr parameter;
   dcl	 aor_p_work_area_ptr    ptr parameter;
   dcl	 aor_p_id_list_ptr	    ptr parameter;
   dcl	 aor_p_record_id_field_id
			    fixed bin parameter;
   dcl	 aor_p_record_id	    bit (36) aligned parameter;
   dcl	 aor_p_area_status	    fixed bin parm;

   dcl	 aor_vector_ptr	    ptr;
   dcl	 aor_record_id_ptr	    ptr;
   dcl	 aor_code		    fixed bin (35);

   aor_code = 0;

   aor_vector_ptr =
        dm_vector_util_$append_simple_typed_vector (aor_p_work_area_ptr,
        VECTOR_SLOT_INCREMENT, FREE_OLD_TYPED_VECTOR_ARRAY,
        aor_p_typed_vector_array_ptr, aor_code);
   if aor_code ^= 0
   then if aor_code = error_table_$area_too_small
        then call AOR_RETURN (AREA_IS_TOO_SMALL);
        else call ERROR_RETURN (aor_code);

   call data_format_util_$new_cv_string_to_vector (aor_p_field_table_ptr,
        aor_p_work_area_ptr, aor_p_record_string_ptr,
        aor_p_record_string_length, aor_p_id_list_ptr, aor_vector_ptr,
        aor_code);
   if aor_code ^= 0
   then if aor_code = error_table_$area_too_small
        then
	 do;
	 aor_p_typed_vector_array_ptr
	      -> typed_vector_array.number_of_vectors =
	      aor_p_typed_vector_array_ptr
	      -> typed_vector_array.number_of_vectors - 1;
	 call dm_vector_util_$free_typed_vector (aor_p_work_area_ptr,
	      aor_p_typed_vector_array_ptr, aor_vector_ptr, aor_code);
	 if aor_code ^= 0
	 then call ERROR_RETURN (aor_code);
	 call AOR_RETURN (AREA_IS_TOO_SMALL);
	 end;
        else call ERROR_RETURN (aor_code);

   if aor_p_record_id_field_id ^= DEFAULT_RECORD_ID_FIELD_ID
   then
      do;
      alloc element_id in (aor_p_work_area_ptr -> work_area)
	 set (aor_record_id_ptr);
      aor_vector_ptr
	 -> simple_typed_vector.dimension (aor_p_record_id_field_id)
	 .value_ptr = aor_record_id_ptr;
      unspec (aor_record_id_ptr -> element_id) = aor_p_record_id;
      end;

   call AOR_RETURN (AREA_IS_BIG_ENOUGH);
AOR_MAIN_RETURN:
   return;

AOR_RETURN:
   proc (aorr_p_area_status);
   dcl	 aorr_p_area_status	    fixed bin parm;
   aor_p_area_status = aorr_p_area_status;
   goto AOR_MAIN_RETURN;
   end AOR_RETURN;

   end APPEND_OUTPUT_RECORD;
%page;
APPEND_OUTPUT_RECORD_ID:
   proc (aori_p_record_id, aori_p_eil_ptr, aori_p_number_of_records_accepted,
        aori_p_maximum_number_of_records, aori_p_temp_eil_ptr,
        aori_p_area_status);

   dcl	 aori_p_record_id	    bit (36) aligned parameter;
   dcl	 aori_p_eil_ptr	    ptr parameter;
   dcl	 aori_p_number_of_records_accepted
			    fixed bin (35) parameter;
   dcl	 aori_p_maximum_number_of_records
			    fixed bin (35) parameter;
   dcl	 aori_p_temp_eil_ptr    ptr parameter;
   dcl	 aori_p_area_status	    fixed bin parm;

   dcl	 aori_eil_ptr	    ptr init (null);
   dcl	 aori_slot_idx	    fixed bin (35);

   if aori_p_eil_ptr -> element_id_list.number_of_elements
        < aori_p_number_of_records_accepted
   then
      do;
      eil_number_of_elements =
	 min (aori_p_eil_ptr -> element_id_list.number_of_elements
	 + ELEMENT_ID_LIST_INCREMENT, aori_p_maximum_number_of_records);
      aori_p_temp_eil_ptr = element_id_list_ptr;

      on area call AORI_RETURN (AREA_IS_TOO_SMALL);
      alloc element_id_list in (work_area) set (aori_eil_ptr);
      aori_p_eil_ptr = aori_eil_ptr;

      aori_p_eil_ptr -> element_id_list.version = ELEMENT_ID_LIST_VERSION_1;

      do aori_slot_idx = 1
	 to hbound (aori_p_temp_eil_ptr -> element_id_list.id, 1);
         aori_p_eil_ptr -> element_id_list.id (aori_slot_idx) =
	    aori_p_temp_eil_ptr -> element_id_list.id (aori_slot_idx);
      end;

      free aori_p_temp_eil_ptr -> element_id_list;
      aori_p_temp_eil_ptr = null ();
      end;
   aori_p_eil_ptr -> element_id_list.id (aori_p_number_of_records_accepted) =
        aori_p_record_id;

   call AORI_RETURN (AREA_IS_BIG_ENOUGH);

AORI_MAIN_RETURN:
   return;

AORI_RETURN:
   proc (aorir_p_area_status);
   dcl	 aorir_p_area_status    fixed bin parm;
   aori_p_area_status = aorir_p_area_status;

   goto AORI_MAIN_RETURN;
   end AORI_RETURN;

   end APPEND_OUTPUT_RECORD_ID;
%page;
REVERSE_RECORD_ORDER:
   proc (rro_p_tva_ptr);

   dcl	 rro_p_tva_ptr	    ptr;

   dcl	 rro_slot_idx	    fixed bin;
   dcl	 rro_vector_ptr	    ptr;

   if rro_p_tva_ptr = null
   then return;

   do rro_slot_idx = 1
        to
        divide (rro_p_tva_ptr -> typed_vector_array.number_of_vectors, 2, 35,
        0);
      rro_vector_ptr =
	 rro_p_tva_ptr -> typed_vector_array.vector_slot (rro_slot_idx);
      rro_p_tva_ptr -> typed_vector_array.vector_slot (rro_slot_idx) =
	 rro_p_tva_ptr
	 -> typed_vector_array
	 .
	 vector_slot (rro_p_tva_ptr -> typed_vector_array.number_of_vectors
	 - rro_slot_idx + 1);
      rro_p_tva_ptr
	 -> typed_vector_array
	 .
	 vector_slot (rro_p_tva_ptr -> typed_vector_array.number_of_vectors
	 - rro_slot_idx + 1) = rro_vector_ptr;
   end;

   return;

   end REVERSE_RECORD_ORDER;
%page;
REVERSE_RECORD_ID_ORDER:
   proc (rrio_p_eil_ptr);

   dcl	 rrio_p_eil_ptr	    ptr;
   dcl	 rrio_slot_idx	    fixed bin;
   dcl	 rrio_id		    bit (36) aligned;

   if rrio_p_eil_ptr = null
   then return;

   do rrio_slot_idx = 1
        to divide (typed_vector_array.number_of_vectors, 2, 35, 0);
      rrio_id = rrio_p_eil_ptr -> element_id_list.id (rrio_slot_idx);
      rrio_p_eil_ptr -> element_id_list.id (rrio_slot_idx) =
	 rrio_p_eil_ptr
	 -> element_id_list
	 .
	 id (rrio_p_eil_ptr -> element_id_list.number_of_elements
	 - rrio_slot_idx + 1);
      rrio_p_eil_ptr
	 -> element_id_list
	 .
	 id (rrio_p_eil_ptr -> element_id_list.number_of_elements
	 - rrio_slot_idx + 1) = rrio_id;
   end;

   return;

   end REVERSE_RECORD_ID_ORDER;
%page;
SETUP_ID_LIST:
   proc (sil_p_input_id_list_ptr, sil_p_output_id_list_ptr,
        sil_p_record_id_field_id);

   dcl	 sil_p_input_id_list_ptr
			    ptr parameter;
   dcl	 sil_p_output_id_list_ptr
			    ptr parameter;
   dcl	 sil_p_record_id_field_id
			    fixed bin;

   sil_p_output_id_list_ptr = sil_p_input_id_list_ptr;
   if sil_p_output_id_list_ptr = null ()
   then
      do;
      sil_p_record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
      end;
   else
      do;
      call CHECK_VERSION (sil_p_output_id_list_ptr -> id_list.version,
	 (ID_LIST_VERSION_1), "id_list");
      if sil_p_output_id_list_ptr -> id_list.number_of_ids = 0
      then
         do;
         sil_p_output_id_list_ptr = null ();
         sil_p_record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
         end;
      else
         do;
         if sil_p_output_id_list_ptr
	    -> id_list.id (sil_p_output_id_list_ptr -> id_list.number_of_ids)
	    = DEFAULT_RECORD_ID_FIELD_ID
         then sil_p_record_id_field_id =
	         sil_p_output_id_list_ptr -> id_list.number_of_ids;
         else sil_p_record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
         end;
      end;

   return;

   end SETUP_ID_LIST;
%page;
SETUP_OUTPUT_IDS:
   proc (soi_p_input_eil_ptr, soi_p_maximum_number_of_ids,
        soi_p_output_eil_ptr);

   dcl	 soi_p_input_eil_ptr    ptr parameter;
   dcl	 soi_p_maximum_number_of_ids
			    fixed bin (35) parameter;
   dcl	 soi_p_output_eil_ptr   ptr parameter;

   if soi_p_input_eil_ptr = null ()
   then
      do;
      eil_number_of_elements =
	 min (soi_p_maximum_number_of_ids, ELEMENT_ID_LIST_INCREMENT);
      alloc element_id_list in (work_area) set (soi_p_output_eil_ptr);
      soi_p_output_eil_ptr -> element_id_list.version =
	 ELEMENT_ID_LIST_VERSION_1;
      end;
   else
      do;
      soi_p_output_eil_ptr = soi_p_input_eil_ptr;
      call CHECK_VERSION (soi_p_output_eil_ptr -> element_id_list.version,
	 ELEMENT_ID_LIST_VERSION_1, "element_id");
      end;

   return;

   end SETUP_OUTPUT_IDS;
%page;
SETUP_OUTPUT_RECORDS:
   proc (sor_p_input_tva_ptr, sor_p_maximum_number_of_records,
        sor_p_record_id_field_id, sor_p_field_table_ptr, sor_p_id_list_ptr,
        sor_p_work_area_ptr, sor_p_output_tva_ptr);

   dcl	 sor_p_input_tva_ptr    ptr parameter parameter;
   dcl	 sor_p_maximum_number_of_records
			    fixed bin (35) parameter;
   dcl	 sor_p_record_id_field_id
			    fixed bin parameter;
   dcl	 sor_p_field_table_ptr  ptr parameter;
   dcl	 sor_p_id_list_ptr	    ptr parameter;
   dcl	 sor_p_work_area_ptr    ptr parameter;
   dcl	 sor_p_output_tva_ptr   ptr parameter;

   dcl	 sor_p_work_area	    area based (sor_p_work_area_ptr);

   dcl	 sor_record_id_descriptor_ptr
			    ptr;
   dcl	 sor_code		    fixed bin (35);

   if sor_p_input_tva_ptr = null ()
   then
      do;
      sor_code = 0;
      call data_format_util_$cv_table_to_typed_array (sor_p_field_table_ptr,
	 sor_p_id_list_ptr, sor_p_work_area_ptr, (VECTOR_SLOT_INCREMENT),
	 sor_p_output_tva_ptr, sor_code);
      if sor_code ^= 0
      then call ERROR_RETURN (sor_code);
      call CHECK_VERSION (sor_p_output_tva_ptr -> typed_vector_array.version,
	 TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");
      if sor_p_record_id_field_id ^= DEFAULT_RECORD_ID_FIELD_ID
      then
         do;
         alloc arg_descriptor in (sor_p_work_area)
	    set (sor_record_id_descriptor_ptr);
         sor_record_id_descriptor_ptr -> arg_descriptor.flag = TRUE;
         sor_record_id_descriptor_ptr -> arg_descriptor.type = bit_dtype;
         sor_record_id_descriptor_ptr -> arg_descriptor.packed = FALSE;
         sor_record_id_descriptor_ptr -> arg_descriptor.number_dims = 0;
         sor_record_id_descriptor_ptr -> arg_descriptor.size = 36;
         sor_p_output_tva_ptr
	    -> typed_vector_array.dimension_table (sor_p_record_id_field_id)
	    .name = "0";
         sor_p_output_tva_ptr
	    -> typed_vector_array.dimension_table (sor_p_record_id_field_id)
	    .descriptor_ptr = sor_record_id_descriptor_ptr;
         end;
      end;
   else
      do;
      sor_p_output_tva_ptr = sor_p_input_tva_ptr;
      call CHECK_VERSION (sor_p_output_tva_ptr -> typed_vector_array.version,
	 TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");
      end;

   return;

   end SETUP_OUTPUT_RECORDS;
%page;
%include dm_rcm_cursor;
%page;
%include vu_typed_vector_array;
%page;
%include vu_typed_vector;
%page;
%include dm_element_id;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_element_id_list;
%page;
%include sub_err_flags;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
%page;
%include dm_id_list;
   end rcm_get_by_spec;




		    rcm_get_field_info.pl1          01/04/85  0917.4re  01/03/85  1147.2       49599



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

/* DESCRIPTION:
          This routine gets the field_table of the specified record collection
     and constructs from that field_table a typed_vector_array whose
     dimension_table describes the fields of the collection.
*/

/* HISTORY:
Written by Matthew Pierret 05/05/82.
Modified:
09/07/82 by Matthew Pierret:  Changed to use rm_get_opening_info.
03/16/83 by Matthew Pierret:  Changed to receive from rm_get_opening_info the
            record_collection_opening_info structure.
03/24/83 by Lindsey Spratt:  Changed to use version 2 field_table, removed
	  CHECK_VERSION.
07/28/83 by Matthew Pierret: Changed name from rm_get_field_info to
            rcm_get_field_info, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin:  Renamed the parameters to coincide with all the other
            rcm_XX routines.
05/04/84 by Matthew Pierret:  Changed to use FIELD_TABLE_VERSION_3.
09/27/84 by Maggie Sharpe:  corrected program format; cleaned up declarations;
            added some comments.
11/27/84 by Lindsey L. Spratt:  Changed to use dm_vector_util_ instead of
            vector_util_.
*/

/* format: style2,ind3 */

rcm_get_field_info:
   proc (p_file_opening_id, p_record_collection_id, p_work_area_ptr, p_typed_vector_array_ptr, p_code);

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

      dcl	    p_file_opening_id      bit (36) aligned;
      dcl	    p_record_collection_id bit (36) aligned;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    dimension_idx	       fixed bin;
      dcl	    descriptor_string_ptr  ptr;
      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    descriptor_string      bit (36) aligned based (descriptor_string_ptr);
      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);

/* Builtin */

      dcl	    (max, null, substr)    builtin;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("rcm_get_field_info") char (32) varying int static options (constant);

/* Entry */

      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    dm_vector_util_$init_typed_vector_array
			       entry options (variable);

/* External */

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

/* END OF DECLARATIONS */

      p_code = 0;
      work_area_ptr = p_work_area_ptr;
      if work_area_ptr = null
      then
         do;
	  p_code = error_table_$bad_arg;
	  return;
         end;

      call rcm_get_opening_info (p_file_opening_id, p_record_collection_id, record_collection_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION (record_collection_opening_info.version, RECORD_COLLECTION_OPENING_INFO_VERSION_1,
	 "record_collection_opening_info");

      field_table_ptr = record_collection_opening_info.field_table_ptr;

      call CHECK_VERSION (field_table.version, FIELD_TABLE_VERSION_3, "field_table");

      tva_maximum_dimension_name_length = 0;
      do dimension_idx = 1 to field_table.number_of_fields;
         tva_maximum_dimension_name_length =
	    max (tva_maximum_dimension_name_length, field_table.field (dimension_idx).length_of_name);
      end;

      call dm_vector_util_$init_typed_vector_array (work_area_ptr, 0, (field_table.number_of_fields),
	 (tva_maximum_dimension_name_length), typed_vector_array_ptr, p_code);
      if p_code ^= 0
      then return;

      do dimension_idx = 1 to typed_vector_array.number_of_dimensions;
         typed_vector_array.dimension_table (dimension_idx).name =
	    substr (field_table.field_names, field_table.field (dimension_idx).location_of_name,
	    field_table.field (dimension_idx).length_of_name);
         if field_table.field (dimension_idx).flags.descriptor_is_varying
         then ;					/* Aggragate storage items are not supported at this time */
         else
	  do;
	     alloc descriptor_string in (work_area);
	     descriptor_string = field_table.field (dimension_idx).descriptor;
	  end;
         typed_vector_array.dimension_table (dimension_idx).descriptor_ptr = descriptor_string_ptr;
      end;

      p_typed_vector_array_ptr = typed_vector_array_ptr;

      return;
%page;
CHECK_VERSION:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^a"" of ^a structure; received ""^a"".", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_field_table;
%page;
%include vu_typed_vector_array;
%page;
%include sub_err_flags;

   end rcm_get_field_info;




		    rcm_get_opening_info.pl1        04/04/85  1109.9r w 04/04/85  0913.7       99072



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

/* format: style2,ind3 */

rcm_get_opening_info:
   proc (p_file_opening_id, p_collection_id, p_record_collection_opening_info_ptr, p_code);

/* DESCRIPTION:

         Gets  opening  information  associated  with  the  specified  record
     collection.  If no opening information exists for this record collection,
     the record collection is opened,  by  retrieving  the  record  collection
     header and associated field_table.
*/

/* HISTORY:

Written by Matthew Pierret, 08/17/82.
Modified:
03/15/83 by Matthew Pierret: Changed to use record_collection_opening_info,
            refresh each transaction, use RECORD_COLLECTION_HEADER_VERSION_2.
03/24/83 by Lindsey Spratt:  Changed to use version 2 of the field_table, and
	  to check the version of the field_table.
04/04/83 by Matthew Pierret:  Added $opening_table_ptr, which returns the
            value of static_opening_table_ptr.
07/28/83 by Matthew Pierret: Changed name from rm_get_opening_info to
            rcm_get_opening_info, and all rm_ prefixes to rcm_.
05/04/84 by Matthew Pierret: Changed to use FIELD_TABLE_VERSION_3.
06/11/84 by Matthew Pierret: Changed cm_$get_element to cm_$get.
*/

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

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_collection_id	       bit (36) aligned parameter;
      dcl	    p_record_collection_opening_info_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    1 local_rc_header      aligned like record_collection_header;
      dcl	    (init, refresh, new_buffer_was_allocated)
			       init ("0"b) bit (1) aligned;
      dcl	    current_transaction_id bit (36) aligned;
      dcl	    current_rollback_count fixed bin (35);
      dcl	    field_table_buffer_length
			       fixed bin (35) init (0);
      dcl	    field_table_buffer_ptr ptr init (null);

/* Based */

      dcl	    dm_work_area	       area (sys_info$max_seg_size) based (dm_work_area_ptr);

/* Builtin */

      dcl	    (addr, length, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("rcm_get_opening_info") char (32) varying internal static options (constant);
      dcl	    (
	    BITS_PER_WORD	       init (36),
	    NUMBER_OF_BUCKETS      init (20)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    opening_manager_$get_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$put_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$init  entry (fixed bin, ptr, fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$misformatted_ci,
	    dm_error_$no_element,
	    dm_error_$no_opening,
	    sys_info$max_seg_size
	    )		       fixed bin (35) external;

/* Static */

      dcl	    static_opening_table_ptr
			       ptr init (null) internal static;
      dcl	    dm_work_area_ptr       ptr init (null) internal static;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

      p_code = 0;
      p_record_collection_opening_info_ptr = null;

      current_transaction_id = CURRENT_TRANSACTION_ID ();
      current_rollback_count = CURRENT_ROLLBACK_COUNT ();

      if static_opening_table_ptr = null
      then
         do;

         /*** The record_manager_ has not set up an opening table for this process yet. Do so. */

	  init, refresh = "1"b;

	  call opening_manager_$init (NUMBER_OF_BUCKETS, static_opening_table_ptr, p_code);
	  if p_code ^= 0
	  then return;
         end;
      else
         do;

         /*** The record_manager_ opening table is already set up, so get the
	    record_collection_opening_info_ptr if one has been set up for this collection. */

	  call
	     opening_manager_$get_opening (static_opening_table_ptr, (p_file_opening_id || p_collection_id),
	     record_collection_opening_info_ptr, p_code);
	  if p_code ^= 0
	  then if p_code ^= dm_error_$no_opening
	       then return;				/* This should not happen. */
	       else
		do;

		/*** No opening information exists yet for this record collection. Setup the opening information. */

		   refresh, init = "1"b;
		end;
	  else
	     do;

	     /*** A record_collection_opening_info structure is already set up. Verify
		the structure and test to see if that information can be trusted. */

	        call
		 CHECK_VERSION_CHAR_8 (record_collection_opening_info.version,
		 RECORD_COLLECTION_OPENING_INFO_VERSION_1, "record_collection_opening_info");

	        if record_collection_opening_info.current_transaction_id ^= current_transaction_id
	        then refresh = "1"b;
	        else if record_collection_opening_info.current_rollback_count ^= current_rollback_count
	        then refresh = "1"b;
	        else if record_collection_opening_info.field_table_ptr = null
	        then refresh = "1"b;
	     end;
         end;

      if refresh
      then
REFRESH:
         do;

         /*** Record collection information must be retrieved from the file, either
	    because a new transaction requires refreshing the old info or because this
	    is the first time the information is retrieved. */

	  if dm_work_area_ptr = null
	  then dm_work_area_ptr = get_dm_free_area_ ();

	  field_table_ptr = null;

	  on cleanup call FINISH ();

	  if init
	  then
	     do;
	        alloc record_collection_opening_info in (dm_work_area);
	        record_collection_opening_info.file_opening_id = p_file_opening_id;
	        record_collection_opening_info.collection_id = p_collection_id;
	     end;

	  field_table_buffer_ptr = record_collection_opening_info.field_table_ptr;
	  if field_table_buffer_ptr ^= null
	  then
	     do;
	        call
		 CHECK_VERSION_CHAR_8 (field_table_buffer_ptr -> field_table.version, FIELD_TABLE_VERSION_3,
		 "field_table");
	        field_table_buffer_length = currentsize (field_table_buffer_ptr -> field_table) * BITS_PER_WORD;
	     end;

	  call
	     collection_manager_$get_header (p_file_opening_id, p_collection_id, addr (local_rc_header),
	     length (unspec (local_rc_header)), null, "0"b, record_collection_header_ptr, (0), p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN ();

	  call
	     CHECK_VERSION_CHAR_8 (record_collection_header.version, RECORD_COLLECTION_HEADER_VERSION_2,
	     "record_collection_header");

	  call
	     collection_manager_$get (p_file_opening_id, HEADER_COLLECTION_ID,
	     record_collection_header.field_table_element_id, 0, field_table_buffer_ptr, field_table_buffer_length,
	     dm_work_area_ptr, new_buffer_was_allocated, field_table_ptr, (0), p_code);
	  if p_code ^= 0
	  then if p_code = dm_error_$no_element
	       then call REPORT_FIELD_TABLE_RETRIEVAL_ERROR ();
	       else if p_code = dm_error_$ci_not_allocated
	       then call REPORT_FIELD_TABLE_RETRIEVAL_ERROR ();
	       else if p_code = dm_error_$ci_not_in_collection
	       then call REPORT_FIELD_TABLE_RETRIEVAL_ERROR ();
	       else if p_code = dm_error_$misformatted_ci
	       then call REPORT_FIELD_TABLE_RETRIEVAL_ERROR ();

	  call CHECK_VERSION_CHAR_8 (field_table.version, FIELD_TABLE_VERSION_3, "field_table");


	  record_collection_opening_info.current_transaction_id = current_transaction_id;
	  record_collection_opening_info.current_rollback_count = current_rollback_count;

	  if init
	  then call
		opening_manager_$put_opening (static_opening_table_ptr, (p_file_opening_id || p_collection_id),
		record_collection_opening_info_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN ();
	  else record_collection_opening_info.field_table_ptr = field_table_ptr;

         end REFRESH;

      if p_code = 0
      then p_record_collection_opening_info_ptr = record_collection_opening_info_ptr;

      call FINISH ();

MAIN_RETURN:
      return;
%page;
opening_table_ptr:
   entry () returns (ptr);

      return (static_opening_table_ptr);
%page;
FINISH:
   proc ();

      if new_buffer_was_allocated
      then
         do;
	  if p_record_collection_opening_info_ptr = null
	  then /* Operation was unsuccessful. */
	       if field_table_ptr ^= null
	       then free field_table in (dm_work_area);
	       else ;
	  else /* Operation was successful. */
	       if field_table_buffer_ptr ^= null
	  then free field_table_buffer_ptr -> field_table in (dm_work_area);
	  else ;
         end;

      if init
      then
         do;
	  if p_record_collection_opening_info_ptr = null
	  then /* Operation was unsuccessful. */
	       if record_collection_opening_info_ptr ^= null
	       then free record_collection_opening_info in (dm_work_area);
         end;

   end FINISH;


ERROR_RETURN:
   proc ();

      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;


REPORT_FIELD_TABLE_RETRIEVAL_ERROR:
   proc ();

      call
         sub_err_ (p_code, myname, ACTION_CANT_RESTART, null, 0,
         "^/The field_table for record collection ^3bo could not be retrieved.", p_collection_id);

   end REPORT_FIELD_TABLE_RETRIEVAL_ERROR;
%page;
CHECK_VERSION_CHAR_8:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;
      dcl	    sub_err_	       entry () options (variable);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

      if p_given_version ^= p_correct_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	    "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	    p_given_version);

      return;

   end CHECK_VERSION_CHAR_8;
%page;
CURRENT_TRANSACTION_ID:
   proc () returns (bit (36) aligned);

      dcl	    p_transaction_id       bit (36) aligned init ("0"b);
      dcl	    transaction_manager_$get_current_txn_id
			       entry (bit (36) aligned, fixed bin (35));

      call transaction_manager_$get_current_txn_id (p_transaction_id, (0));

      return (p_transaction_id);

   end CURRENT_TRANSACTION_ID;


CURRENT_ROLLBACK_COUNT:
   proc () returns (fixed bin (35));

      return (0);

   end CURRENT_ROLLBACK_COUNT;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_rcm_header;
%page;
%include dm_field_table;
%page;
%include dm_hdr_collection_id;
%page;
%include sub_err_flags;
%page;
%include dm_collmgr_entry_dcls;

   end rcm_get_opening_info;




		    rcm_get_record_by_id.pl1        10/24/88  1644.7r w 10/24/88  1400.0      185544



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

/* DESCRIPTION

          Gets the record or set of records specified by the caller. Records
     are returned as simple_typed_vectors allocated in the provided area. If
     called by the array entry point, these vectors are combined in a
     typed_vector_array. 
          This routine always gets the record collection's opening information.
     A later performance gain can be achieved by adding single_info and
     array_info entry points that take pointers to opening information.
*/

/* HISTORY:
Written by Matthew Pierret 04/23/82.
Modified:
08/20/82 by Matthew Pierret:  Made enter-able only by the entry points single 
            and array.  Added use of rm_get_opening_info, which is in reality
            simply the field_table.
10/14/82 by Matthew Pierret:  Made to set p_typed_vector_array_ptr before 
            returning.  Made to use dmu_$cv_table_to_typed_array.
10/20/82 by Matthew Pierret:  Changed to incrementally up the number of vectors
            in the output typed_vector_array as each new record is retrieved.
01/04/83 by Lindsey Spratt:  Changed to allow calls to cm_$get_element to
	  allocate a new buffer when the provided buffer is too small.
02/09/83 by Lindsey Spratt:  Changed to use the
	  data_mgmt_util_$new_cv_string_to_vector entry instead of
	  $cv_string_to_vector.  The difference is that the $new_* entry
	  will re-use an input vector rather than allocating a new one, if
	  the input vector_ptr is non-null, rather than the old behavior of
	  always allocating a new vector regardless of the value of the
	  input vector_ptr.  Only the $single entry is actually set up to
	  take advantage of this feature.
03/16/83 by Matthew Pierret: Changed to receive record_collection_opening_info
            structure from rm_get_opening_info, use get_dm_free_area_ () 
            instead of dm_data_$area_ptr, use dm_error_$wrong_cursor_type,
            convert some collection_manager_ error codes to $record_not_found.
            Added cleanup handler. Moved record_cursor type check before
            version check.
03/24/83 by Lindsey Spratt:  Removed reference to the field_table include
	  file, declared field_table_ptr locally.
07/28/83 by Matthew Pierret: Changed name from rm_get_record_by_id to
            rcm_get_record_by_id, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin:  Renamed the parameters to coincide with all the other
            rcm_XX routines.  Removed the p_typed_vector_type and
            p_typed_vector_array_version parameters because they aren't used.
05/10/84 by Matthew Pierret:  Changed to align the record buffer on an even
            word.  Changed references to data_mgmt_util_ to be to
            data_format_util_.  Removed declarations of un-used variables.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get.
09/27/84 by Maggie Sharpe:  Changed the call to sub_err in CHECK_VERSION and
            CHECK_VERSION_CHAR_8 to use new flag parameter for restart option;
	  removed a (harmless) duplicate statement; cleaned up dcls.
03/19/85 by Lindsey L. Spratt:  Fixed to handle the TUPLE_ID_FIELD_ID.
03/20/85 by Lindsey L. Spratt:  Fixed to set aor_vector_ptr equal to
            aor_p_result_ptr for the CREATE_OUTPUT_RECORD process.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

rcm_get_record_by_id:
   proc ();

      return;					/* Not a real entry */

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

      dcl	    p_record_cursor_ptr    ptr;
      dcl	    p_simple_typed_vector_ptr
			       ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_id_list_ptr	       ptr;
      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_record_id	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    get_array_of_records   bit (1) aligned init ("0"b);
      dcl	    get_single_record      bit (1) aligned init ("0"b);
      dcl	    record_id	       bit (36) aligned;
      dcl	    record_id_field_id     fixed bin init (DEFAULT_RECORD_ID_FIELD_ID);
      dcl	    record_idx	       fixed bin;
      dcl	    record_string_length   fixed bin (35);
      dcl	    record_string_ptr      ptr init (null);
      dcl	    field_table_ptr	       ptr init (null);
      dcl	    descriptor_string_ptr  ptr init (null);
      dcl	    local_record_buffer    (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
						/* This declaration forces an even-word boundary */
      dcl	    new_buffer_was_allocated
			       bit (1) aligned init ("0"b);
      dcl	    record_buffer_ptr      ptr init (null);
      dcl	    record_buffer_length   fixed bin (35) init (BITS_PER_PAGE);
      dcl	    dm_work_area_ptr       ptr init (null);

/* Based */

      dcl	    dm_work_area	       area based (dm_work_area_ptr);
      dcl	    record_buffer	       based (record_buffer_ptr) bit (record_buffer_length) aligned;

/* Builtin */

      dcl	    (addr, hbound, null)   builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    AREA_IS_BIG_ENOUGH     init (1),
	    AREA_IS_TOO_SMALL      init (2),
	    BITS_PER_PAGE	       init (1024 * 36),
	    DEFAULT_RECORD_ID_FIELD_ID
			       init (-1),
	    DOUBLE_WORDS_PER_PAGE  init (512),
	    VECTOR_SLOT_INCREMENT  init (500)
	    )		       fixed bin internal static options (constant);

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

      dcl	    myname	       init ("rcm_get_record_by_id") char (32) varying internal static options (constant);

/* Entry */

      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    data_format_util_$new_cv_string_to_vector
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35));
      dcl	    data_format_util_$cv_table_to_typed_array
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, fixed bin (35));
      dcl	    dm_vector_util_$append_simple_typed_vector
			       entry options (variable) returns (ptr);
      dcl	    dm_vector_util_$free_typed_vector
			       entry (ptr, ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry options (variable);
      dcl	    get_dm_free_area_      entry () returns (ptr);

/* External */

      dcl	    (
	    error_table_$area_too_small,
	    error_table_$unimplemented_version,
	    dm_error_$record_not_found,
	    dm_error_$wrong_cursor_type
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

single:
   entry (p_record_id, p_id_list_ptr, p_work_area_ptr, p_record_cursor_ptr, p_simple_typed_vector_ptr, p_code);

      get_single_record = "1"b;
      record_id = p_record_id;
      simple_typed_vector_ptr = p_simple_typed_vector_ptr;
      typed_vector_array_ptr = null ();
      goto JOIN;


array:
   entry (p_element_id_list_ptr, p_id_list_ptr, p_work_area_ptr, p_record_cursor_ptr, p_typed_vector_array_ptr, p_code);

      element_id_list_ptr = p_element_id_list_ptr;

      call CHECK_VERSION ((element_id_list.version), (ELEMENT_ID_LIST_VERSION_1), "element_id_list");

      record_id = element_id_list.id (1);
      get_single_record = "0"b;
      simple_typed_vector_ptr = null;
      typed_vector_array_ptr = p_typed_vector_array_ptr;
      goto JOIN;

%page;
JOIN:
      p_code = 0;

      record_cursor_ptr = p_record_cursor_ptr;

      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected record cursor, type ^d; received type ^d.", RECORD_CURSOR_TYPE, record_cursor.type);

      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");


      call rcm_get_opening_info (record_cursor.file_opening_id, record_cursor.collection_id,
	 record_collection_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION_CHAR_8 (record_collection_opening_info.version, RECORD_COLLECTION_OPENING_INFO_VERSION_1,
	 "record_collection_opening_info");

      field_table_ptr = record_collection_opening_info.field_table_ptr;

      dm_work_area_ptr = get_dm_free_area_ ();

      record_buffer_ptr = addr (local_record_buffer);

      on cleanup call FINISH ();

      call SETUP_ID_LIST (p_id_list_ptr, id_list_ptr, record_id_field_id);

      call collection_manager_$get (record_cursor.file_opening_id, record_cursor.collection_id, record_id, 0,
	 record_buffer_ptr, record_buffer_length, dm_work_area_ptr, new_buffer_was_allocated, record_string_ptr,
	 record_string_length, p_code);
      if p_code ^= 0
      then call GET_ELEMENT_ERROR_RETURN (p_code);

      if new_buffer_was_allocated
      then
         do;
	  record_buffer_ptr = record_string_ptr;
	  record_buffer_length = record_string_length;
         end;


      call CREATE_OUTPUT_RECORD (record_string_ptr, record_string_length, simple_typed_vector_ptr, field_table_ptr,
	 p_work_area_ptr, id_list_ptr, record_id_field_id, record_id, (0));

      if get_single_record
      then p_simple_typed_vector_ptr = simple_typed_vector_ptr;
      else
GET_REST_OF_RECORDS:
         do;
	  call SETUP_OUTPUT_RECORDS (typed_vector_array_ptr, hbound (element_id_list.id, 1), record_id_field_id,
	       field_table_ptr, id_list_ptr, p_work_area_ptr, typed_vector_array_ptr);

	  typed_vector_array.number_of_vectors = 1;
	  typed_vector_array.vector_slot (1) = simple_typed_vector_ptr;

	  do record_idx = 2 to hbound (element_id_list.id, 1);

	     record_id = element_id_list.id (record_idx);

	     call collection_manager_$get (record_cursor.file_opening_id, record_cursor.collection_id, record_id, 0,
		record_buffer_ptr, record_buffer_length, dm_work_area_ptr, new_buffer_was_allocated,
		record_string_ptr, record_string_length, p_code);
	     if p_code ^= 0
	     then call GET_ELEMENT_ERROR_RETURN (p_code);

	     if new_buffer_was_allocated
	     then
	        do;
		 if record_buffer_ptr ^= addr (local_record_buffer)
		 then free record_buffer in (dm_work_area);
		 record_buffer_ptr = record_string_ptr;
		 record_buffer_length = record_string_length;
	        end;
	     call APPEND_OUTPUT_RECORD (record_string_ptr, record_string_length, typed_vector_array_ptr,
		field_table_ptr, p_work_area_ptr, id_list_ptr, record_id_field_id, record_id, (0));
	  end;
	  p_typed_vector_array_ptr = typed_vector_array_ptr;

         end GET_REST_OF_RECORDS;

      record_cursor.record_id = record_id;
      record_cursor.flags.position_is_valid = "1"b;

      call FINISH;
RETURN:
      return;
%page;
FINISH:
   proc;
      if record_buffer_ptr ^= addr (local_record_buffer)
      then free record_buffer in (dm_work_area);
   end FINISH;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parm;


      call FINISH ();
      p_code = er_p_code;
      goto RETURN;

   end ERROR_RETURN;
%page;
APPEND_OUTPUT_RECORD:
   proc (aor_p_record_string_ptr, aor_p_record_string_length, aor_p_result_ptr, aor_p_field_table_ptr,
        aor_p_work_area_ptr, aor_p_id_list_ptr, aor_p_record_id_field_id, aor_p_record_id, aor_p_area_status);

      dcl	    aor_p_record_string_ptr
			       ptr parameter;
      dcl	    aor_p_record_string_length
			       fixed bin (35) parameter;
      dcl	    aor_p_result_ptr       ptr parameter;
      dcl	    aor_p_field_table_ptr  ptr parameter;
      dcl	    aor_p_work_area_ptr    ptr parameter;
      dcl	    aor_p_id_list_ptr      ptr parameter;
      dcl	    aor_p_record_id_field_id
			       fixed bin parameter;
      dcl	    aor_p_record_id	       bit (36) aligned parameter;
      dcl	    aor_p_area_status      fixed bin parm;

      dcl	    aor_p_work_area	       based (aor_p_work_area_ptr) area;

      dcl	    aor_vector_ptr	       ptr init (null ());
      dcl	    aor_record_id_ptr      ptr init (null ());
      dcl	    aor_set_result_ptr_to_new_vector
			       bit (1) aligned init ("0"b);
      dcl	    aor_typed_vector_array_ptr
			       ptr init (null ());
      dcl	    aor_code	       fixed bin (35);

      aor_typed_vector_array_ptr = aor_p_result_ptr;
      aor_set_result_ptr_to_new_vector = "0"b;

      aor_code = 0;

      aor_vector_ptr =
	 dm_vector_util_$append_simple_typed_vector (aor_p_work_area_ptr, VECTOR_SLOT_INCREMENT,
	 FREE_OLD_TYPED_VECTOR_ARRAY, aor_typed_vector_array_ptr, aor_code);
      if aor_code ^= 0
      then if aor_code = error_table_$area_too_small
	 then call AOR_RETURN (AREA_IS_TOO_SMALL);
	 else call ERROR_RETURN (aor_code);
      goto AOR_JOIN;

CREATE_OUTPUT_RECORD:
   entry (aor_p_record_string_ptr, aor_p_record_string_length, aor_p_result_ptr, aor_p_field_table_ptr,
        aor_p_work_area_ptr, aor_p_id_list_ptr, aor_p_record_id_field_id, aor_p_record_id, aor_p_area_status);
      aor_typed_vector_array_ptr = null ();
      aor_vector_ptr = aor_p_result_ptr;
      aor_set_result_ptr_to_new_vector = "1"b;
AOR_JOIN:
      call data_format_util_$new_cv_string_to_vector (aor_p_field_table_ptr, aor_p_work_area_ptr, aor_p_record_string_ptr,
	 aor_p_record_string_length, aor_p_id_list_ptr, aor_vector_ptr, aor_code);
      if aor_code ^= 0
      then if aor_code = error_table_$area_too_small
	 then
	    do;
	       if aor_typed_vector_array_ptr ^= null ()
	       then
		do;
		   aor_typed_vector_array_ptr -> typed_vector_array.number_of_vectors =
		        aor_typed_vector_array_ptr -> typed_vector_array.number_of_vectors - 1;
		   call dm_vector_util_$free_typed_vector (aor_p_work_area_ptr, aor_typed_vector_array_ptr,
		        aor_vector_ptr, aor_code);
		   if aor_code ^= 0
		   then call ERROR_RETURN (aor_code);
		end;
	       call AOR_RETURN (AREA_IS_TOO_SMALL);
	    end;
	 else call ERROR_RETURN (aor_code);

      if aor_p_record_id_field_id ^= DEFAULT_RECORD_ID_FIELD_ID
      then
         do;
	  alloc element_id in (aor_p_work_area) set (aor_record_id_ptr);
	  aor_vector_ptr -> simple_typed_vector.dimension (aor_p_record_id_field_id).value_ptr = aor_record_id_ptr;
	  unspec (aor_record_id_ptr -> element_id) = aor_p_record_id;
         end;

      call AOR_RETURN (AREA_IS_BIG_ENOUGH);
AOR_MAIN_RETURN:
      return;

AOR_RETURN:
   proc (aorr_p_area_status);
      dcl	    aorr_p_area_status     fixed bin parm;
      aor_p_area_status = aorr_p_area_status;
      if aor_set_result_ptr_to_new_vector
      then aor_p_result_ptr = aor_vector_ptr;
      else aor_p_result_ptr = aor_typed_vector_array_ptr;
      goto AOR_MAIN_RETURN;
   end AOR_RETURN;

   end APPEND_OUTPUT_RECORD;
%page;
GET_ELEMENT_ERROR_RETURN:
   proc (p_code);

      dcl	    p_code	       fixed bin (35);
      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element
	    )		       fixed bin (35) ext;

      if p_code = dm_error_$no_element
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_in_collection
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_allocated
      then p_code = dm_error_$record_not_found;

      call ERROR_RETURN (p_code);

   end GET_ELEMENT_ERROR_RETURN;


SETUP_ID_LIST:
   proc (sil_p_input_id_list_ptr, sil_p_output_id_list_ptr, sil_p_record_id_field_id);

      dcl	    sil_p_input_id_list_ptr
			       ptr parameter;
      dcl	    sil_p_output_id_list_ptr
			       ptr parameter;
      dcl	    sil_p_record_id_field_id
			       fixed bin;

      sil_p_output_id_list_ptr = sil_p_input_id_list_ptr;
      if sil_p_output_id_list_ptr = null ()
      then
         do;
	  sil_p_record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
         end;
      else
         do;
	  call CHECK_VERSION (sil_p_output_id_list_ptr -> id_list.version, (ID_LIST_VERSION_1), "id_list");
	  if sil_p_output_id_list_ptr -> id_list.number_of_ids = 0
	  then
	     do;
	        sil_p_output_id_list_ptr = null ();
	        sil_p_record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
	     end;
	  else
	     do;
	        if sil_p_output_id_list_ptr -> id_list.id (sil_p_output_id_list_ptr -> id_list.number_of_ids)
		   = DEFAULT_RECORD_ID_FIELD_ID
	        then sil_p_record_id_field_id = sil_p_output_id_list_ptr -> id_list.number_of_ids;
	        else sil_p_record_id_field_id = DEFAULT_RECORD_ID_FIELD_ID;
	     end;
         end;

      return;

   end SETUP_ID_LIST;
%page;
SETUP_OUTPUT_RECORDS:
   proc (sor_p_input_tva_ptr, sor_p_maximum_number_of_records, sor_p_record_id_field_id, sor_p_field_table_ptr,
        sor_p_id_list_ptr, sor_p_work_area_ptr, sor_p_output_tva_ptr);

      dcl	    sor_p_input_tva_ptr    ptr parameter parameter;
      dcl	    sor_p_maximum_number_of_records
			       fixed bin (35) parameter;
      dcl	    sor_p_record_id_field_id
			       fixed bin parameter;
      dcl	    sor_p_field_table_ptr  ptr parameter;
      dcl	    sor_p_id_list_ptr      ptr parameter;
      dcl	    sor_p_work_area_ptr    ptr parameter;
      dcl	    sor_p_output_tva_ptr   ptr parameter;

      dcl	    sor_p_work_area	       area based (sor_p_work_area_ptr);

      dcl	    sor_record_id_descriptor_ptr
			       ptr;
      dcl	    sor_code	       fixed bin (35);

      if sor_p_input_tva_ptr = null ()
      then
         do;
	  sor_code = 0;
	  call data_format_util_$cv_table_to_typed_array (sor_p_field_table_ptr, sor_p_id_list_ptr, sor_p_work_area_ptr,
	       (VECTOR_SLOT_INCREMENT), sor_p_output_tva_ptr, sor_code);
	  if sor_code ^= 0
	  then call ERROR_RETURN (sor_code);
	  call CHECK_VERSION (sor_p_output_tva_ptr -> typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2,
	       "typed_vector_array");
	  if sor_p_record_id_field_id ^= DEFAULT_RECORD_ID_FIELD_ID
	  then
	     do;
	        alloc arg_descriptor in (sor_p_work_area) set (sor_record_id_descriptor_ptr);
	        sor_record_id_descriptor_ptr -> arg_descriptor.flag = TRUE;
	        sor_record_id_descriptor_ptr -> arg_descriptor.type = bit_dtype;
	        sor_record_id_descriptor_ptr -> arg_descriptor.packed = FALSE;
	        sor_record_id_descriptor_ptr -> arg_descriptor.number_dims = 0;
	        sor_record_id_descriptor_ptr -> arg_descriptor.size = 36;
	        sor_p_output_tva_ptr -> typed_vector_array.dimension_table (sor_p_record_id_field_id).name = "0";
	        sor_p_output_tva_ptr -> typed_vector_array.dimension_table (sor_p_record_id_field_id).descriptor_ptr =
		   sor_record_id_descriptor_ptr;
	     end;
         end;
      else
         do;
	  sor_p_output_tva_ptr = sor_p_input_tva_ptr;
	  call CHECK_VERSION (sor_p_output_tva_ptr -> typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2,
	       "typed_vector_array");
         end;

      return;

   end SETUP_OUTPUT_RECORDS;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_CHAR_8:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION_CHAR_8;
%page;
%include arg_descriptor;
%page;
%include dm_rcm_cursor;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_id_list;
%page;
%include dm_element_id;
%page;
%include dm_element_id_list;
%page;
%include dm_ci_lengths;
%page;
%include vu_typed_vector_array;
%page;
%include vu_typed_vector;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include sub_err_flags;
%page;
%include std_descriptor_types;
   end rcm_get_record_by_id;




		    rcm_modify_record_by_id.pl1     04/04/85  1109.9r w 04/04/85  0913.8      113454



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

/* DESCRIPTION

          Modifies the records specified by the caller. Record fields to
     be modified are fields 1-N if a simple_typed_vector is given, or the
     fields specified by identifier if a general_typed_vector is given.
     The cursor is positioned to the last record modified.  The parameter
     p_number_of_records_processed contains the number of records that were
     were succesfully modified.
     
          This routine always gets the record collection's opening information.
     A later performance gain can be achieved by adding single_info and
     array_info entry points that take pointers to opening information.
*/

/* HISTORY:
Written by Matthew Pierret 04/23/82.
Modified:
08/20/82 by Matthew Pierret:  Made enter-able only by the entry points single 
            and array.  Added use of rm_get_opening_info, which is in reality
            simply the field_table.
10/06/82 by Matthew Pierret:  Made to use dmu_$general_modify_string.
01/04/83 by Lindsey Spratt:  Enhanced to cope with arbitrarily long records.
03/03/83 by Lindsey Spratt:  Changed to correctly interpret buffer management
	  done by dmu_$general_modify_string.
03/16/83 by Matthew Pierret: Changed to receive record_collection_opening_info
            structure from rm_get_opening_info, to translate some error codes
            returned from collection_manager_$get_element to
            dm_error_$record_not_found, to use dm_error_$wrong_cursor_type,
            to use get_dm_free_area_ () and to keep the internal static
            dm_work_area_ptr so that ony one call to get_dm_free_area need be
            per process. Changed dm_data_area to dm_work_area.
            Moved the record_cursor type check after the version check.
03/24/83 by Lindsey Spratt:  Removed the field_table include file, declared
	  field_table_ptr locally.
07/28/83 by Matthew Pierret: Changed name from rm_modify_record_by_id to
            rcm_modify_record_by_id, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin:  Renamed the parameters to coincide with all the other
            rcm_XX routines.
05/10/84 by Matthew Pierret:  Changed to align record buffers on even word
            boundaries.  Removed declarations of un-used variables.  Changed
            references to data_mgmt_util_ to be to data_format_util_.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get,
            cm_$put_element to cm_$modify.
09/27/84 by Maggie Sharpe:  Cleaned up declarations; changed the call to
            CHECK_VERSION for element_id_list to pass parameters by reference
	  instead of value.
*/

/* format: style2,ind3 */

rcm_modify_record_by_id:
   proc ();

      call
         sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0, "^/^a$^a is not a valid entrypoint",
         myname, myname);


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

      dcl	    p_record_cursor_ptr    ptr;
      dcl	    p_general_typed_vector_ptr
			       ptr;
      dcl	    p_number_of_records_processed
			       fixed bin (35);
      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_record_id	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    (modify_single_record, new_buffer_was_allocated)
			       bit (1) aligned init ("0"b);
      dcl	    new_record_string_length
			       fixed bin (35);
      dcl	    new_record_string_ptr  ptr;
      dcl	    number_of_records_to_modify
			       fixed bin (35);
      dcl	    field_table_ptr	       ptr init (null);
      dcl	    automatic_new_record_buffer
			       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
						/* Forces even-word alignment */
      dcl	    automatic_old_record_buffer
			       (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
						/* Forces even-word alignment */
      dcl	    old_record_string_length
			       fixed bin (35);
      dcl	    old_record_string_ptr  ptr;
      dcl	    record_count	       fixed bin (35);
      dcl	    record_id	       bit (36) aligned;
      dcl	    (old_record_buffer_ptr, new_record_buffer_ptr)
			       ptr init (null);
      dcl	    (
	    old_record_buffer_length
			       init (BITS_PER_PAGE),
	    new_record_buffer_length
			       init (BITS_PER_PAGE),
	    new_new_record_buffer_length
			       init (0)
	    )		       fixed bin (35);

/* Based */

      dcl	    new_record_buffer      bit (new_record_buffer_length) based (new_record_buffer_ptr);
      dcl	    old_record_buffer      bit (old_record_buffer_length) based (old_record_buffer_ptr);
      dcl	    dm_work_area	       area based (dm_work_area_ptr);

/* Builtin */

      dcl	    (addr, null)	       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    BITS_PER_PAGE	       init (1024 * 36) fixed bin internal static options (constant);
      dcl	    DOUBLE_WORDS_PER_PAGE  init (512) fixed bin internal static options (constant);
      dcl	    myname	       init ("rcm_modify_record_by_id") char (32) varying internal static
			       options (constant);

/* Entry */

      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    data_format_util_$general_modify_string
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, fixed bin (35), ptr, ptr, fixed bin (35),
			       fixed bin (35), fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$programming_error,
	    dm_error_$record_not_found,
	    dm_error_$wrong_cursor_type
	    )		       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* Static */

      dcl	    dm_work_area_ptr       ptr internal static init (null);

/* END OF DECLARATIONS */

single:
   entry (p_record_id, p_general_typed_vector_ptr, p_record_cursor_ptr, p_code);

      modify_single_record = "1"b;
      number_of_records_to_modify = 1;

      goto JOIN;


array:
   entry (p_element_id_list_ptr, p_general_typed_vector_ptr, p_record_cursor_ptr, p_number_of_records_processed, p_code);

      modify_single_record = "0"b;
      p_number_of_records_processed = 0;

      element_id_list_ptr = p_element_id_list_ptr;

      call CHECK_VERSION (element_id_list.version, ELEMENT_ID_LIST_VERSION_1, "element_id_list");

      number_of_records_to_modify = element_id_list.number_of_elements;

      goto JOIN;

%page;
JOIN:
      p_code = 0;

      record_cursor_ptr = p_record_cursor_ptr;

      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected record cursor, type ^d; received type ^d.", RECORD_CURSOR_TYPE, record_cursor.type);

      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");

      general_typed_vector_ptr = p_general_typed_vector_ptr;

      call CHECK_VERSION ((general_typed_vector.type), (GENERAL_TYPED_VECTOR_TYPE), "general_typed_vector");


      call
         rcm_get_opening_info (record_cursor.file_opening_id, record_cursor.collection_id,
         record_collection_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call
         CHECK_VERSION_CHAR_8 (record_collection_opening_info.version, RECORD_COLLECTION_OPENING_INFO_VERSION_1,
         "record_collection_opening_info");

      field_table_ptr = record_collection_opening_info.field_table_ptr;

      old_record_buffer_ptr = addr (automatic_old_record_buffer);
      new_record_buffer_ptr = addr (automatic_new_record_buffer);

      if dm_work_area_ptr = null
      then dm_work_area_ptr = get_dm_free_area_ ();

      on cleanup call FINISH;

RECORD_LOOP:
      do record_count = 1 to number_of_records_to_modify;

         if modify_single_record
         then record_id = p_record_id;
         else record_id = element_id_list.id (record_count);


         call
	  collection_manager_$get (record_cursor.file_opening_id, record_cursor.collection_id, record_id, 0,
	  old_record_buffer_ptr, old_record_buffer_length, dm_work_area_ptr, new_buffer_was_allocated,
	  old_record_string_ptr, old_record_string_length, p_code);
         if p_code ^= 0
         then call GET_ELEMENT_ERROR_RETURN (p_code);

         if new_buffer_was_allocated
         then
	  do;
	     if old_record_buffer_ptr ^= addr (automatic_old_record_buffer) & old_record_buffer_ptr ^= null
	     then free old_record_buffer in (dm_work_area);
	     old_record_buffer_ptr = old_record_string_ptr;
	     old_record_buffer_length = old_record_string_length;
	  end;

         call
	  data_format_util_$general_modify_string (field_table_ptr, general_typed_vector_ptr, old_record_string_ptr,
	  old_record_string_length, new_record_buffer_ptr, new_record_buffer_length, dm_work_area_ptr,
	  new_record_string_ptr, new_record_string_length, new_new_record_buffer_length, p_code);
         if p_code ^= 0
         then call ERROR_RETURN ();

         if new_new_record_buffer_length > 0		/* Only true if a new buffer was allocated. */
         then
	  do;
	     if new_record_buffer_ptr ^= addr (automatic_new_record_buffer)
	     then free new_record_buffer in (dm_work_area);
	     new_record_buffer_ptr = new_record_string_ptr;
	     new_record_buffer_length = new_new_record_buffer_length;
	  end;
         call
	  collection_manager_$modify (record_cursor.file_opening_id, record_cursor.collection_id, new_record_string_ptr,
	  new_record_string_length, record_id, (0), p_code);
         if p_code ^= 0
         then call ERROR_RETURN ();

      end RECORD_LOOP;

      record_cursor.record_id = record_id;
      record_cursor.flags.position_is_valid = "1"b;

      call FINISH ();

MAIN_RETURN:
      return;

%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_CHAR_8:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	    p_given_version);

      return;

   end CHECK_VERSION_CHAR_8;
%page;
FINISH:
   proc ();

      if ^modify_single_record
      then p_number_of_records_processed = record_count - 1;

      if old_record_buffer_ptr ^= addr (automatic_old_record_buffer) & old_record_buffer_ptr ^= null
      then free old_record_buffer in (dm_work_area);

      if new_record_buffer_ptr ^= addr (automatic_new_record_buffer) & new_record_buffer_ptr ^= null
      then free new_record_buffer in (dm_work_area);

   end FINISH;


ERROR_RETURN:
   proc ();

      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;


GET_ELEMENT_ERROR_RETURN:
   proc (p_code);

      dcl	    p_code	       fixed bin (35);
      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element
	    )		       fixed bin (35) ext;

      if p_code = dm_error_$no_element
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_in_collection
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_allocated
      then p_code = dm_error_$record_not_found;

      call ERROR_RETURN;

   end GET_ELEMENT_ERROR_RETURN;
%page;
%include dm_rcm_cursor;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_element_id_list;
%page;
%include vu_typed_vector;
%page;
%include sub_err_flags;
%page;
%include dm_collmgr_entry_dcls;

   end rcm_modify_record_by_id;




		    rcm_process_intervals.pl1       04/04/85  1109.9r w 04/04/85  0913.8      162513



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

/* DESCRIPTION:

         This     subroutine     is    similar    in    function    to    the
     general_search/process_records pair of modules, except that it  takes  as
     input  a list of record_ids, a search_specification to be applied against
     the records in the record_id_list, and an interval_list to specify  which
     and_groups  in  the  search_specification  apply  to which records in the
     record_id_list.  The supported entry points are:   get,  get_id,  delete,
     get_records_and_ids, and count.

          The work_area supplied must be a freeing area. 
*/

/* HISTORY:

Written by Lindsey L. Spratt, 11/10/82.
Modified:
11/23/82 by Lindsey Spratt:  Fixed setting of typed_vector_array ptr.  Added
	  support  for the get_id entry.
03/16/83 by Matthew Pierret: Changed to receive the 
            record_collection_opening_info structure from rm_get_opening_info.
            Added the ERROR_RETURN proc
            and the GET_ELEMENT_ERROR_RETURN proc (the latter translates
            collection_manager_$get_element error codes into 
            dm_error_$record_not_found).
03/24/83 by Lindsey Spratt:  Removed the field_table include file, declared the
	  field_table_ptr locally.
04/22/83 by Matthew Pierret:  Added the $get_records_and_ids entry.  This
            entry merges the $get and $get_id entries, returning both a
            typed_vector_array and an element_id_list.  Also changed this
            module to always use explicit qualifiers when accessing
            element_id_lists (p_input_eil_ptr and p_output_eil_ptr), and to
            set the implicit qualifier (eil_ptr) to null if the
            element_id_list is not to be freed by the FINISH routine.
05/23/83 by Matthew Pierret: Changed to use version 4 of specification_head.
06/22/83 by Lindsey L. Spratt:  Changed to return dm_error_$record_not_found
            when no matches are found.
07/28/83 by Matthew Pierret: Changed name from rm_process_intervals to
            rcm_process_intervals, and all rm_ prefixes to rcm_.
04/13/84 by Lee Baldwin:  Changed reference to record_cursor.pf_opening_id
            to record_cursor.file_opening_id.
04/26/84 by Lee Baldwin:  Changed $count to not take a work_area_ptr, since
            it doesn't allocate an output structure.
05/10/84 by Matthew Pierret:  Changed to align record buffers on even word
            boundaries.  Changed references to
            data_mgmt_util_ to be to data_format_util_.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get.
09/27/84 by Maggie Sharpe:  set word_area_ptr ot p_work_area_ptr in the delete
            entry; check the version of element_id_list before the structure
            was first used; ERROR_RETURN was called (instead of a simple
            "return") in lines 245 and 260.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 interval_list.
10/30/84 by Lindsey L. Spratt:  Removed spurious CHECK_VERSION of
            element_id_list.  It was using the (null) element_id_list_ptr,
            instead of p_input_element_id_list_ptr, which was already check
            elsewhere.
*/

/* format: style2,ind3 */

rcm_process_intervals:
   proc ();

      call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	 "^/^a$^a is not a valid entrypoint", myname, myname);

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

      dcl	    p_input_element_id_list_ptr
			       ptr parameter;
      dcl	    p_id_list_ptr	       ptr parameter;
      dcl	    p_search_specification_ptr
			       ptr parameter;
      dcl	    p_interval_list_ptr    ptr parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_typed_vector_array_version
			       fixed bin (35) parameter;
      dcl	    p_record_cursor_ptr    ptr parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_output_element_id_list_ptr
			       ptr parameter;
      dcl	    p_record_count	       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (work_area_ptr, old_tva_ptr, vector_ptr, field_table_ptr)
			       ptr init (null);

      dcl	    (get, delete, get_id, count, new_buffer_was_allocated, record_satisfies_specification)
			       bit (1) aligned init ("0"b);
      dcl	    number_of_accepted_records
			       fixed bin (35) init (0);
      dcl	    (interval_idx, record_id_idx, vector_slot_idx, element_id_idx)
			       fixed bin init (0);
      dcl	    record_buffer_ptr      ptr init (null);
      dcl	    record_buffer_length   fixed bin (35) init (BITS_PER_PAGE);
      dcl	    local_record_buffer    (DOUBLE_WORDS_PER_PAGE) fixed bin (71);
      dcl	    record_string_ptr      ptr init (null);
      dcl	    record_string_length   fixed bin (35) init (0);
      dcl	    maximum_number_of_accepted_records
			       fixed bin (35);
      dcl	    accepted_record_ptr    ptr aligned init (null);


/* Based */

      dcl	    accepted_record	       (maximum_number_of_accepted_records) bit (1) unal based (accepted_record_ptr);
      dcl	    work_area	       based (work_area_ptr) area;
      dcl	    record_string	       bit (record_string_length) based (record_string_ptr);
      dcl	    record_buffer	       bit (record_buffer_length) based (record_buffer_ptr);

/* Builtin */

      dcl	    (addr, string, null)   builtin;

/* Constant */

      dcl	    DOUBLE_WORDS_PER_PAGE  init (512) fixed bin internal static options (constant);
      dcl	    BITS_PER_PAGE	       init (1024 * 36) fixed bin internal static options (constant);
      dcl	    VECTOR_SLOT_PAD	       init (200) fixed bin internal static options (constant);
      dcl	    DEFAULT_POSITION       init (0) fixed bin (35) internal static options (constant);
      dcl	    (
	    DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS
			       init (0),
	    DEFAULT_PARTIAL_STRUCTURAL_FIELD
			       init (0)
	    )		       fixed bin internal static options (constant);
      dcl	    myname	       init ("rcm_process_intervals") char (32) varying internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);
      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    data_format_util_$cv_table_to_typed_array
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, fixed bin (35));
      dcl	    data_format_util_$cv_string_to_vector
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35));
      dcl	    data_format_util_$compare_sequential
			       entry (ptr, ptr, ptr, fixed bin, fixed bin, bit (*), bit (1) aligned, fixed bin (35))
			       ;

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$programming_error,
	    dm_error_$record_not_found,
	    dm_error_$wrong_cursor_type
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

get:
   entry (p_input_element_id_list_ptr, p_id_list_ptr, p_search_specification_ptr, p_interval_list_ptr, p_work_area_ptr,
        p_typed_vector_array_version, p_record_cursor_ptr, p_typed_vector_array_ptr, p_code);

      if p_typed_vector_array_version ^= TYPED_VECTOR_ARRAY_VERSION_2
      then
         do;
	  p_code = error_table_$unimplemented_version;
	  return;
         end;

      get = "1"b;
      work_area_ptr = p_work_area_ptr;
      goto JOIN;

get_id:
   entry (p_input_element_id_list_ptr, p_search_specification_ptr, p_interval_list_ptr, p_work_area_ptr,
        p_record_cursor_ptr, p_output_element_id_list_ptr, p_code);

      get_id = "1"b;
      p_output_element_id_list_ptr = null;
      work_area_ptr = p_work_area_ptr;
      goto JOIN;

count:
   entry (p_input_element_id_list_ptr, p_search_specification_ptr, p_interval_list_ptr, p_record_cursor_ptr,
        p_record_count, p_code);

      count = "1"b;
      goto JOIN;

get_records_and_ids:
   entry (p_input_element_id_list_ptr, p_id_list_ptr, p_search_specification_ptr, p_interval_list_ptr, p_work_area_ptr,
        p_typed_vector_array_version, p_record_cursor_ptr, p_output_element_id_list_ptr, p_typed_vector_array_ptr, p_code)
        ;

      get, get_id = "1"b;
      if p_typed_vector_array_version ^= TYPED_VECTOR_ARRAY_VERSION_2
      then
         do;
	  p_code = error_table_$unimplemented_version;
	  return;
         end;
      work_area_ptr = p_work_area_ptr;
      goto JOIN;

delete:
   entry (p_input_element_id_list_ptr, p_search_specification_ptr, p_interval_list_ptr, p_work_area_ptr,
        p_record_cursor_ptr, p_record_count, p_code);

      delete = "1"b;
      work_area_ptr = p_work_area_ptr;
JOIN:
      p_code = 0;
      element_id_list_ptr, typed_vector_array_ptr = null;

      call CHECK_VERSION (p_input_element_id_list_ptr -> element_id_list.version, ELEMENT_ID_LIST_VERSION_1,
	 "element_id_list");

      search_specification_ptr = p_search_specification_ptr;
      call CHECK_VERSION (search_specification.version, SPECIFICATION_VERSION_4, "search_specification");

      interval_list_ptr = p_interval_list_ptr;

      call CHECK_VERSION_CHAR_8 (interval_list.version, INTERVAL_LIST_VERSION_2, "interval_list");

      record_cursor_ptr = p_record_cursor_ptr;

      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected a record cursor, type ^d.  Received a cursor of type ^d.", RECORD_CURSOR_TYPE,
	      record_cursor.type);
      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");

      if get_id
      then
         do;
	  maximum_number_of_accepted_records = p_input_element_id_list_ptr -> element_id_list.number_of_elements;
	  alloc accepted_record in (work_area);
	  string (accepted_record) = "0"b;
         end;

      call rcm_get_opening_info (record_cursor.file_opening_id, record_cursor.collection_id,
	 record_collection_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

      call CHECK_VERSION_CHAR_8 (record_collection_opening_info.version, RECORD_COLLECTION_OPENING_INFO_VERSION_1,
	 "record_collection_opening_info");

      field_table_ptr = record_collection_opening_info.field_table_ptr;

      if get
      then
         do;
	  call data_format_util_$cv_table_to_typed_array (field_table_ptr, p_id_list_ptr, work_area_ptr,
	       (VECTOR_SLOT_PAD), typed_vector_array_ptr, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN ();
	  call CHECK_VERSION (typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");

         end;

      record_buffer_ptr = addr (local_record_buffer);

INTERVAL_LIST_LOOP:
      do interval_idx = 1 to interval_list.number_of_intervals
	 while (number_of_accepted_records < search_specification.range.size | search_specification.range.size = 0);
RECORD_LOOP:
         do record_id_idx = interval_list.interval (interval_idx).low_vector_idx
	    to interval_list.interval (interval_idx).high_vector_idx
	    while (number_of_accepted_records < search_specification.range.size | search_specification.range.size = 0);
	  call collection_manager_$get (record_cursor.file_opening_id, record_cursor.collection_id,
	       p_input_element_id_list_ptr -> element_id_list.id (record_id_idx), (DEFAULT_POSITION), record_buffer_ptr,
	       record_buffer_length, work_area_ptr, new_buffer_was_allocated, record_string_ptr, record_string_length,
	       p_code);
	  if p_code ^= 0
	  then call GET_ELEMENT_ERROR_RETURN (p_code);

	  if new_buffer_was_allocated
	  then if record_buffer_ptr ^= addr (local_record_buffer)
	       then
		do;
		   free record_buffer in (work_area);
		   record_buffer_ptr = record_string_ptr;
		   record_buffer_length = record_string_length;
		end;

	  call data_format_util_$compare_sequential (field_table_ptr, search_specification_ptr,
	       interval_list.interval (interval_idx).and_group_id_list_ptr, DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
	       DEFAULT_PARTIAL_STRUCTURAL_FIELD, record_string, record_satisfies_specification, p_code);
	  if p_code ^= 0
	  then call ERROR_RETURN;

	  if record_satisfies_specification
	  then
	     do;
	        number_of_accepted_records = number_of_accepted_records + 1;
	        if get
	        then call ADD_TO_ARRAY;
	        if get_id
	        then accepted_record (record_id_idx) = "1"b;
	        else if delete
	        then call DELETE_RECORD;
	     end;
         end RECORD_LOOP;
      end INTERVAL_LIST_LOOP;

      if get & number_of_accepted_records > 0
      then p_typed_vector_array_ptr = typed_vector_array_ptr;

      else if delete | count
      then p_record_count = number_of_accepted_records;

      if get_id & number_of_accepted_records > 0
      then
         do;
	  eil_number_of_elements = number_of_accepted_records;
	  alloc element_id_list in (work_area);
	  element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
	  record_id_idx = 0;
	  do element_id_idx = 1 to p_input_element_id_list_ptr -> element_id_list.number_of_elements;
	     if accepted_record (element_id_idx)
	     then
	        do;
		 record_id_idx = record_id_idx + 1;
		 element_id_list.id (record_id_idx) =
		      p_input_element_id_list_ptr -> element_id_list.id (element_id_idx);
	        end;
	  end;
	  p_output_element_id_list_ptr = element_id_list_ptr;
	  element_id_list_ptr = null;
         end;

      if number_of_accepted_records = 0
      then p_code = dm_error_$record_not_found;

      call FINISH;
RETURN:
      return;
%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_CHAR_8:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	      p_given_version);

      return;

   end CHECK_VERSION_CHAR_8;
%page;
DELETE_RECORD:
   proc;
   end DELETE_RECORD;
%page;
ADD_TO_ARRAY:
   proc;
      call data_format_util_$cv_string_to_vector (field_table_ptr, work_area_ptr, record_string_ptr, record_string_length,
	 p_id_list_ptr, vector_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN;

      typed_vector_array.number_of_vectors = typed_vector_array.number_of_vectors + 1;
      if typed_vector_array.number_of_vectors <= typed_vector_array.number_of_vector_slots
      then typed_vector_array.vector_slot (typed_vector_array.number_of_vectors) = vector_ptr;
      else
         do;
	  tva_number_of_vector_slots = typed_vector_array.number_of_vectors + VECTOR_SLOT_PAD;
	  tva_number_of_dimensions = typed_vector_array.number_of_dimensions;
	  tva_maximum_dimension_name_length = typed_vector_array.maximum_dimension_name_length;

	  old_tva_ptr = typed_vector_array_ptr;

	  alloc typed_vector_array in (work_area);

	  typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;
	  typed_vector_array.number_of_vectors = old_tva_ptr -> typed_vector_array.number_of_vectors;
	  typed_vector_array.dimension_table = old_tva_ptr -> typed_vector_array.dimension_table;

	  do vector_slot_idx = 1 to typed_vector_array.number_of_vectors - 1;
	     typed_vector_array.vector_slot (vector_slot_idx) =
		old_tva_ptr -> typed_vector_array.vector_slot (vector_slot_idx);
	  end;

	  typed_vector_array.vector_slot (typed_vector_array.number_of_vectors) = vector_ptr;

	  do vector_slot_idx = vector_slot_idx + 1 to typed_vector_array.number_of_vector_slots;
	     typed_vector_array.vector_slot (vector_slot_idx) = null;
	  end;

	  free old_tva_ptr -> typed_vector_array in (work_area);

         end;
      number_of_accepted_records = typed_vector_array.number_of_vectors;

   end ADD_TO_ARRAY;
%page;
FINISH:
   proc;
      if accepted_record_ptr ^= null
      then free accepted_record;

      if element_id_list_ptr ^= null
      then free element_id_list;

      if record_buffer_ptr ^= addr (local_record_buffer) & record_buffer_ptr ^= null
      then free record_buffer;
   end FINISH;


ERROR_RETURN:
   proc ();

      call FINISH ();
      goto RETURN;

   end ERROR_RETURN;

GET_ELEMENT_ERROR_RETURN:
   proc (p_code);

      dcl	    p_code	       fixed bin (35);
      dcl	    (
	    dm_error_$ci_not_allocated,
	    dm_error_$ci_not_in_collection,
	    dm_error_$no_element
	    )		       fixed bin (35) ext;

      if p_code = dm_error_$no_element
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_in_collection
      then p_code = dm_error_$record_not_found;
      if p_code = dm_error_$ci_not_allocated
      then p_code = dm_error_$record_not_found;

      call ERROR_RETURN;

   end GET_ELEMENT_ERROR_RETURN;
%page;
%include sub_err_flags;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include dm_interval_list;
%page;
%include dm_rcm_cursor;
%page;
%include dm_rcm_opening_info;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_element_id_list;
%page;
%include vu_typed_vector_array;
   end rcm_process_intervals;




		    rcm_put_record_by_id.pl1        04/04/85  1109.9r w 04/04/85  0913.8      103752



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


/* DESCRIPTION:
        This module stores records in a record collection. The location to 
   put the record is specified explicitly using the p_related_record_id.
   The caller supplies a pointer to a simple_typed_vector or an array of
   pointers to simple_typed_vectors. These vectors are converted into bit
   strings for storage by collection_manager_$allocate_element. Multiple
   records are stored adjacently if possible. The cursor defines the page
   file and collection into which the record(s) are to be stored, and the
   cursor is positioned to the last record put, if successful; otherwise
   the position is left unchanged. If an error occurs while storing a
   record, records which have already been stored are deleted.
        The p_related_record_id identifies an existing record or a canonical
   null location ("0"b). If null, the record(s) is placed at the end of the 
   collection. Otherwise, the control interval that p_related_record_id 
   identifies is used to store the new record(s). If there is no room, the
   new record(s) is placed at the end of the collection.
*/

/* HISTORY:
Written by Matthew Pierret.
Modified:
04/15/82 by Matthew Pierret: Added array_by_* entries.
04/23/82 by Matthew Pierret: Changed dmu_* calls to data_mgmt_util_$* calls.
09/07/82 by Matthew Pierret: Changed to use rm_get_opening_info.
12/22/82 by Lindsey Spratt:  Changed to handle large records.
01/04/83 by Lindsey Spratt:  Fixed to cleanup allocated records and storage.
03/16/83 by Matthew Pierret: Changed to receive record_collection_opening_info
            structure from rm_get_opening_info. Changed to get work area from
            get_dm_free_area_ instead of dm_data_$area_ptr.
            Changed to not attempt to roll back. Moved record_cursor type check
            before version check.
03/24/83 by Lindsey Spratt:  Removed the field_table include file, added local
	  dcl of field_table_ptr.
03/28/83 by Lindsey Spratt:  Fixed test to set dm_work_area_ptr to test for "=
	  null" rather than "^= null".
03/29/83 by Lindsey Spratt:  Changed to always call ERROR_RETURN on errors.
07/28/83 by Matthew Pierret: Changed name from rm_put_record_by_id to
            rcm_put_record_by_id, and all rm_ prefixes to rcm_.
04/12/84 by Lee Baldwin:  Renamed the parameters to coincide with all the other
            rcm_XX routines.
06/12/84 by Matthew Pierret: Renamed cm_$allocate_element to cm_$put and
            data_mgmt_util_ to data_format_util_.
09/27/84 by Maggie Sharpe:  Cleaned up dcls; changed the call to CHECK_VERSION
            on line 164 to pass parameters by reference instead of value.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

rcm_put_record_by_id:
   proc ();

      call
         sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0, "^/^a$^a is not a valid entrypoint",
         myname, myname);


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

      dcl	    p_related_record_id    bit (36) aligned;
      dcl	    p_simple_typed_vector_ptr
			       ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_minimum_free_space   fixed bin (35);	/* not implemented */
      dcl	    p_record_cursor_ptr    ptr;
      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_record_id	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    returned_buffer_length fixed bin (35);
      dcl	    local_record_string_buffer
			       char (4096);
      dcl	    put_array_of_records   bit (1) aligned init ("0"b);
      dcl	    put_only_a_single_record
			       bit (1) aligned;
      dcl	    record_id	       bit (36) aligned;
      dcl	    record_idx	       fixed bin;
      dcl	    field_table_ptr	       ptr init (null);
      dcl	    record_string_ptr      ptr;
      dcl	    record_string_buffer_ptr
			       ptr init (null);
      dcl	    record_string_buffer_length
			       fixed bin (35) init (0);

/* Based */

      dcl	    dm_work_area	       area based (dm_work_area_ptr);

      dcl	    1 record_string	       based (record_string_ptr),
	      2 length	       fixed bin (35),
	      2 contents	       bit (0 refer (record_string.length));

      dcl	    record_string_buffer   bit (record_string_buffer_length) based (record_string_buffer_ptr);

/* Builtin */

      dcl	    (null, length, addr, unspec, hbound)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;


/* Constant */

      dcl	    myname	       init ("rcm_put_record_by_id") char (32) varying int static options (constant);


/* Entry */

      dcl	    rcm_get_opening_info   entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    data_format_util_$cv_vector_to_string
			       entry (ptr, ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35), fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);

/* External */

      dcl	    (
	    error_table_$unimplemented_version,
	    dm_error_$programming_error,
	    dm_error_$wrong_cursor_type
	    )		       ext fixed bin (35);

/* Static */

      dcl	    dm_work_area_ptr       ptr internal static init (null);

/* END OF DECLARATIONS */

single:
   entry (p_related_record_id, p_simple_typed_vector_ptr, p_minimum_free_space, p_record_cursor_ptr, p_record_id, p_code);

      put_only_a_single_record = "1"b;
      simple_typed_vector_ptr = p_simple_typed_vector_ptr;
      record_id = p_related_record_id;
      p_record_id = "0"b;
      goto JOIN;


array:
   entry (p_related_record_id, p_typed_vector_array_ptr, p_minimum_free_space, p_record_cursor_ptr, p_element_id_list_ptr,
      p_code);

      typed_vector_array_ptr = p_typed_vector_array_ptr;
      call CHECK_VERSION ((typed_vector_array.version), (TYPED_VECTOR_ARRAY_VERSION_2), "typed_vector_array");

      simple_typed_vector_ptr = typed_vector_array.vector_slot (1);
      record_id = p_related_record_id;
      put_array_of_records = "1"b;
      element_id_list_ptr = p_element_id_list_ptr;
      call CHECK_VERSION (element_id_list.version, ELEMENT_ID_LIST_VERSION_1, "element_id_list");

      goto JOIN;
%page;
JOIN:
      p_code = 0;

      record_cursor_ptr = p_record_cursor_ptr;

      if record_cursor.type ^= RECORD_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected record cursor, type ^d; received type ^d.", RECORD_CURSOR_TYPE, record_cursor.type);
      call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2), "record_cursor");

      call
         rcm_get_opening_info (record_cursor.file_opening_id, record_cursor.collection_id,
         record_collection_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN;

      call
         CHECK_VERSION_CHAR_8 (record_collection_opening_info.version, RECORD_COLLECTION_OPENING_INFO_VERSION_1,
         "record_collection_opening_info");

      field_table_ptr = record_collection_opening_info.field_table_ptr;

      record_string_buffer_ptr = addr (local_record_string_buffer);
      record_string_buffer_length = length (unspec (local_record_string_buffer));

      if dm_work_area_ptr = null
      then dm_work_area_ptr = get_dm_free_area_ ();

      on cleanup call FINISH ();

      call
         data_format_util_$cv_vector_to_string (field_table_ptr, simple_typed_vector_ptr, record_string_buffer_ptr,
         record_string_buffer_length, dm_work_area_ptr, record_string_ptr, returned_buffer_length, p_code);
      if p_code ^= 0
      then call ERROR_RETURN;

      call
         collection_manager_$put (record_cursor.file_opening_id, record_cursor.collection_id,
         addr (record_string.contents), record_string.length, record_id, (0), p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();


      if record_string_ptr ^= record_string_buffer_ptr
      then
         do;
	  if record_string_buffer_ptr ^= addr (local_record_string_buffer)
	  then free record_string_buffer in (dm_work_area);
	  record_string_buffer_ptr = record_string_ptr;
	  record_string_buffer_length = returned_buffer_length;
         end;

      if put_only_a_single_record
      then p_record_id = record_id;
      else
         do;
	  element_id_list.id (record_idx) = record_id;
	  do record_idx = 2 to hbound (element_id_list.id, 1);

	     call
	        data_format_util_$cv_vector_to_string (field_table_ptr, typed_vector_array.vector_slot (record_idx),
	        record_string_buffer_ptr, record_string_buffer_length, dm_work_area_ptr, record_string_ptr,
	        returned_buffer_length, p_code);
	     if p_code ^= 0
	     then call ERROR_RETURN ();

	     call
	        collection_manager_$put (record_cursor.file_opening_id, record_cursor.collection_id,
	        addr (record_string.contents), record_string.length, record_id, (0), p_code);
	     if p_code = 0
	     then element_id_list.id (record_idx) = record_id;
	     else call ERROR_RETURN ();

	     if record_string_ptr ^= record_string_buffer_ptr
	     then
	        do;
		 if record_string_buffer_ptr ^= addr (local_record_string_buffer)
		 then free record_string_buffer in (dm_work_area);
		 record_string_buffer_ptr = record_string_ptr;
		 record_string_buffer_length = returned_buffer_length;
	        end;
	  end;
         end;

      record_cursor.record_id = record_id;
      record_cursor.flags.position_is_valid = "1"b;

      call FINISH ();
RETURN:
      return;

%page;
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_CHAR_8:
   proc (p_given_version, p_correct_version, p_structure_name);

      dcl	    p_structure_name       char (*);
      dcl	    p_given_version	       char (8) aligned;
      dcl	    p_correct_version      char (8) aligned;

      if p_given_version ^= p_correct_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", p_correct_version, p_structure_name,
	    p_given_version);

      return;

   end CHECK_VERSION_CHAR_8;
%page;
FINISH:
   proc ();

      if record_string_buffer_ptr ^= null
      then if record_string_buffer_ptr ^= addr (local_record_string_buffer)
	 then free record_string_buffer in (dm_work_area);

   end FINISH;


ERROR_RETURN:
   proc ();

      call FINISH ();
      goto RETURN;

   end ERROR_RETURN;
%page;
%include dm_rcm_cursor;
%page;

%include dm_rcm_opening_info;
%page;
%include dm_element_id_list;
%page;
%include vu_typed_vector;
%page;
%include vu_typed_vector_array;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include sub_err_flags;

   end rcm_put_record_by_id;




		    rcm_update_by_spec.pl1          10/24/88  1644.7r w 10/24/88  1400.0      131391



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */

/* DESCRIPTION:

        This routine is the sibling of rcm_get_by_spec, this implementing
   update operations of records selected by a specification.  This
   routine is not used and is not fully implemented.  It is kept as part
   of the record_manager_ so that we get around to implementing the
   operations (post MR11), most of the job will already be done.

   This subroutine examines a range of records, selecting records
   according to a sequential specification.  The records selected are
   processed according to the entrypoint used to enter the subroutine:
   delete deletes each record which satisfies the specification;
   modify changes the value of each record which satisfies the specification
   by changing the value of each field specified in the modify_vector to
   the value in the modify_vector.
*/

/* HISTORY:

Written by Matthew Pierret, 12/03/84.
   (Extracted from rcm_process_records.pl1)
Modified:
*/

/* format: style2,ind3,ll79,^indnoniterdo,indnoniterend,^indprocbody,comcol50*/
/* format: indblkcom,indcomtxt */

rcm_update_by_spec:
   proc ();

   call sub_err_ (dm_error_$programming_error, MYNAME, ACTION_CANT_RESTART,
        null, 0, "^/^a$^a is not a valid entrypoint", MYNAME, MYNAME);

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

   dcl	 p_record_cursor_ptr    ptr parameter;
   dcl	 p_field_table_ptr	    ptr parameter;
   dcl	 p_specification_ptr    ptr parameter;
   dcl	 p_direction_to_process fixed bin parameter;
   dcl	 p_first_record_to_process
			    bit (36) aligned parameter;
   dcl	 p_last_record_to_process
			    bit (36) aligned parameter;
   dcl	 p_spec_is_always_satisfied
			    bit (1) aligned parameter;
   dcl	 p_maximum_number_of_records
			    fixed bin (35) parameter;
   dcl	 p_number_of_records_accepted
			    fixed bin (35) parameter;
   dcl	 p_modify_vector_ptr    ptr parameter;
   dcl	 p_code		    fixed bin (35) parameter;

/* Automatic */

   dcl	 (delete, modify)	    bit (1) aligned init ("0"b);
   dcl	 (get_each_record, record_satisfies_spec, spec_is_always_satisfied)
			    bit (1) aligned init ("0"b);

   dcl	 code		    fixed bin (35);
   dcl	 current_ci_ptr	    ptr init (null ());
   dcl	 direction_to_process   fixed bin (17);
   dcl	 field_table_ptr	    ptr init (null ());
   dcl	 first_record_to_process
			    bit (36) aligned;
   dcl	 highest_accepted_record
			    bit (36) aligned;
   dcl	 last_record_to_process bit (36) aligned;
   dcl	 maximum_number_of_records
			    fixed bin (35);
   dcl	 number_of_records_accepted
			    fixed bin (35);
   dcl	 previous_record_id	    bit (36) aligned;
   dcl	 record_count	    fixed bin (35);
   dcl	 record_buffer_length   fixed bin (35);
   dcl	 record_buffer_ptr	    ptr init (null ());
   dcl	 record_id	    bit (36) aligned;
   dcl	 record_string_length   fixed bin (35);
   dcl	 record_string_ptr	    ptr init (null ());
   dcl	 specification_ptr	    ptr init (null ());
   dcl	 modify_vector_ptr	    ptr init (null ());
   dcl	 work_area_ptr	    ptr init (null ());
   dcl	 local_record_buffer    (DOUBLE_WORDS_PER_PAGE) fixed bin (71);

/* Based */

   dcl	 record_string	    bit (record_string_length)
			    based (record_string_ptr);
   dcl	 record_buffer	    bit (record_buffer_length) aligned
			    based (record_buffer_ptr);

/* Builtin */

   dcl	 null		    builtin;

/* Condition */

   dcl	 cleanup		    condition;

/* Constant */

   dcl	 MYNAME		    init ("rcm_update_by_spec") char (32)
			    varying internal static options (constant);
   dcl	 (
	 BACKWARD_DIRECTION	    init (-1) fixed bin,
	 BITS_PER_PAGE	    init (1024 * 36) fixed bin,
	 DEFAULT_AND_GROUP_ID_LIST_PTR
			    init (null ()) ptr,
	 DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS
			    init (0) fixed bin,
	 DEFAULT_PARTIAL_STRUCTURAL_FIELD
			    init (0) fixed bin,
	 DEFAULT_RECORD_ID_FIELD_ID
			    init (-1) fixed bin,
	 DOUBLE_WORDS_PER_PAGE  init (512) fixed bin,
	 ELEMENT_ID_LIST_INCREMENT
			    init (100) fixed bin,
	 FALSE		    init ("0"b) bit (1) aligned,
	 FREE_OLD_TYPED_VECTOR_ARRAY
			    init ("1"b) bit (1) aligned,
	 GET_CURRENT	    init (0) fixed bin,
	 IS_RELATIVE	    init ("0"b) bit (1) aligned,
	 LIMIT_TO_STOP_INFINITE_LOOPING
			    init (1e6) fixed bin (35),
	 NO_RECORD	    init ("0"b) bit (36) aligned,
	 TRUE		    init ("1"b) bit (1) aligned,
	 VECTOR_SLOT_INCREMENT  init (50) fixed bin
	 )		    internal static options (constant);

/* Entry */

   dcl	 data_format_util_$compare_sequential
			    entry (ptr, ptr, ptr, fixed bin, fixed bin,
			    bit (*), bit (1) aligned, fixed bin (35));
   dcl	 sub_err_		    entry options (variable);
   dcl	 get_system_free_area_  entry () returns (ptr);
   dcl	 data_format_util_$cv_table_to_typed_array
			    entry (ptr, ptr, ptr, fixed bin (35), ptr,
			    fixed bin (35));
   dcl	 data_format_util_$new_cv_string_to_vector
			    entry (ptr, ptr, ptr, fixed bin (35), ptr,
			    ptr, fixed bin (35));

/* External */

   dcl	 (
	 error_table_$unimplemented_version,
	 dm_error_$long_return_element,
	 dm_error_$beginning_of_collection,
	 dm_error_$end_of_collection,
	 dm_error_$record_not_found,
	 dm_error_$programming_error
	 )		    fixed bin (35) ext;


/* END OF DECLARATIONS */

delete:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_number_of_records_accepted, p_code);

   delete = TRUE;
   modify_vector_ptr = null;

   go to JOIN;

modify:
   entry (p_record_cursor_ptr, p_field_table_ptr, p_specification_ptr,
        p_first_record_to_process, p_last_record_to_process,
        p_spec_is_always_satisfied, p_direction_to_process,
        p_maximum_number_of_records, p_modify_vector_ptr,
        p_number_of_records_accepted, p_code);


   modify = TRUE;
   modify_vector_ptr = p_modify_vector_ptr;
   if modify_vector_ptr -> general_typed_vector.type
        ^= GENERAL_TYPED_VECTOR_TYPE
   then call sub_err_ (error_table_$unimplemented_version, MYNAME, null (), 0,
	   "^/Expected type ^d typed_vector. Received type ^d.",
	   GENERAL_TYPED_VECTOR_TYPE,
	   modify_vector_ptr -> general_typed_vector.type);

   go to JOIN;
%page;
JOIN:
   maximum_number_of_records = p_maximum_number_of_records;
   field_table_ptr = p_field_table_ptr;
   work_area_ptr = get_system_free_area_ ();
   p_code, code = 0;
   record_cursor_ptr = p_record_cursor_ptr;
   call CHECK_VERSION ((record_cursor.version), (RECORD_CURSOR_VERSION_2),
        "record_cursor");
   specification_ptr = p_specification_ptr;
   spec_is_always_satisfied = p_spec_is_always_satisfied;
   direction_to_process = p_direction_to_process;
   first_record_to_process = p_first_record_to_process;
   last_record_to_process = p_last_record_to_process;

   record_buffer_ptr = addr (local_record_buffer);
   current_ci_ptr = null;

   if modify | ^spec_is_always_satisfied
   then get_each_record = TRUE;
   else get_each_record = FALSE;

   record_id = first_record_to_process;
   highest_accepted_record = NO_RECORD;
   number_of_records_accepted = 0;

   if get_each_record
   then call GET_RECORD (current_ci_ptr, record_id, GET_CURRENT,
	   record_buffer_ptr, record_buffer_length, record_string_ptr,
	   record_string_length, record_id);

RECORD_LOOP:
   do record_count = 1 to LIMIT_TO_STOP_INFINITE_LOOPING
        while (record_id ^= NO_RECORD);

      if spec_is_always_satisfied
      then record_satisfies_spec = TRUE;
      else
COMPARE:
         do;
         record_satisfies_spec = FALSE;
         call data_format_util_$compare_sequential (field_table_ptr,
	    specification_ptr, DEFAULT_AND_GROUP_ID_LIST_PTR,
	    DEFAULT_NUMBER_OF_FULLY_STRUCTURAL_FIELDS,
	    DEFAULT_PARTIAL_STRUCTURAL_FIELD, record_string,
	    record_satisfies_spec, code);
         if code ^= 0
         then call ERROR_RETURN (code);
         end COMPARE;

      if record_satisfies_spec
      then
ACCEPT_THIS_RECORD:
         do;
         number_of_records_accepted = number_of_records_accepted + 1;
         if direction_to_process = BACKWARD_DIRECTION
         then if highest_accepted_record = NO_RECORD
	    then highest_accepted_record = record_id;
	    else ;
         else highest_accepted_record = record_id;

         if delete
         then call DELETE_RECORD ();
         else if modify
         then call MODIFY_RECORD ();

         end ACCEPT_THIS_RECORD;

      if number_of_records_accepted >= maximum_number_of_records
	 | record_id = last_record_to_process
      then record_id = NO_RECORD;	         /* Finished */
      else
GET_NEXT:
         do;			         /* More records to look at */
         previous_record_id = record_id;
         if get_each_record
         then call GET_RECORD (current_ci_ptr, previous_record_id,
	         direction_to_process, record_buffer_ptr,
	         record_buffer_length, record_string_ptr,
	         record_string_length, record_id);
         else call GET_RECORD_ID (previous_record_id, direction_to_process,
	         record_id);
         end GET_NEXT;
   end RECORD_LOOP;

   if record_count > LIMIT_TO_STOP_INFINITE_LOOPING
   then call sub_err_ (dm_error_$programming_error, MYNAME,
	   ACTION_CANT_RESTART, null, 0,
	   "^/The search algorithm was apparently looping indefinitely.");

   if number_of_records_accepted <= 0
   then call ERROR_RETURN (dm_error_$record_not_found);

   p_number_of_records_accepted = number_of_records_accepted;

   record_cursor.record_id = highest_accepted_record;
   record_cursor.flags.position_is_valid = TRUE;


MAIN_RETURN:
   return;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

   dcl	 cv_p_received_version  fixed bin (35);
   dcl	 cv_p_expected_version  fixed bin (35);
   dcl	 cv_p_structure_name    char (*);

   if cv_p_received_version ^= cv_p_expected_version
   then call sub_err_ (error_table_$unimplemented_version, MYNAME,
	   ACTION_CANT_RESTART, null, 0,
	   "^/Expected version ^d of the ^a structure. Received version ^d.",
	   cv_p_expected_version, cv_p_structure_name, cv_p_received_version)
	   ;

   end CHECK_VERSION;
%page;
FINISH:
   proc ();

   if record_buffer_ptr ^= addr (local_record_buffer)
        & record_buffer_ptr ^= null ()
   then free record_buffer;

   end FINISH;

ERROR_RETURN:
   proc (er_p_code);

   dcl	 er_p_code	    fixed bin (35);

   p_code = er_p_code;
   call FINISH;
   go to MAIN_RETURN;

   end ERROR_RETURN;
%page;
GET_RECORD:
   proc (gr_p_ci_ptr, gr_p_previous_record_id, gr_p_direction,
        gr_p_record_buffer_ptr, gr_p_record_buffer_length,
        gr_p_record_string_ptr, gr_p_record_string_length, gr_p_record_id);

   dcl	 gr_p_ci_ptr	    ptr parameter;
   dcl	 gr_p_previous_record_id
			    bit (36) aligned parameter;
   dcl	 gr_p_record_id	    bit (36) aligned parameter;
   dcl	 gr_p_record_string_ptr ptr parameter;
   dcl	 gr_p_direction	    fixed bin (17) parameter;
   dcl	 gr_p_record_string_length
			    fixed bin (35) parameter;
   dcl	 gr_p_record_buffer_ptr ptr parameter;
   dcl	 gr_p_record_buffer_length
			    fixed bin (35) parameter;
   dcl	 gr_p_record_buffer	    bit (gr_p_record_buffer_length) aligned
			    based (gr_p_record_buffer_ptr);

   dcl	 gr_code		    fixed bin (35);
   dcl	 gr_new_ci_ptr	    ptr;

   gr_code = 0;
   gr_new_ci_ptr = null ();
   call collection_manager_$get_by_ci_ptr (gr_p_ci_ptr,
        record_cursor.file_opening_id, record_cursor.collection_id,
        gr_p_previous_record_id, gr_p_direction, gr_p_record_buffer_ptr,
        gr_p_record_buffer_length, work_area_ptr, ("0"b),
        gr_p_record_string_ptr, gr_p_record_string_length, gr_new_ci_ptr,
        gr_code);
   if gr_code ^= 0
   then
      do;
      if gr_code = dm_error_$end_of_collection
	 | gr_code = dm_error_$beginning_of_collection
      then gr_p_record_id = NO_RECORD;
      else if gr_code = dm_error_$long_return_element
      then call ERROR_RETURN (gr_code);
      else call sub_err_ (gr_code, MYNAME, ACTION_CANT_RESTART, null, 0,
	      "^/This error, which occurred while retrieving record ^3bo, indicates that^/record collection ^3bo is damaged."
	      , gr_p_record_id, record_cursor.collection_id);
      end;

   if gr_p_ci_ptr ^= null & gr_p_ci_ptr ^= gr_new_ci_ptr
   then call RESET_CI_PTR (gr_new_ci_ptr, gr_p_ci_ptr);
   else /* gr_p_ci_ptr remains the same */
        ;

   if gr_p_record_string_ptr ^= gr_p_record_buffer_ptr
   then
      do;
      if gr_p_record_buffer_ptr ^= addr (local_record_buffer)
      then free gr_p_record_buffer;
      gr_p_record_buffer_ptr = gr_p_record_string_ptr;
      gr_p_record_buffer_length = gr_p_record_string_length;
      end;

   return;

   end GET_RECORD;
%page;
GET_RECORD_ID:
   proc (gri_p_previous_record_id, gri_p_direction, gri_p_record_id);

   dcl	 gri_p_previous_record_id
			    bit (36) aligned parameter;
   dcl	 gri_p_record_id	    bit (36) aligned parameter;
   dcl	 gri_p_direction	    fixed bin (17) parameter;

   dcl	 gri_code		    fixed bin (35);


   call collection_manager_$get_id (record_cursor.file_opening_id,
        record_cursor.collection_id, gri_p_previous_record_id, gri_p_direction,
        IS_RELATIVE, gri_p_record_id, gri_code);
   if gri_code ^= 0
   then if gri_code = dm_error_$beginning_of_collection
	   | gri_code = dm_error_$end_of_collection
        then gri_p_record_id = NO_RECORD;
        else call ERROR_RETURN (gri_code);

   return;

   end GET_RECORD_ID;
%page;
RESET_CI_PTR:
   proc (rcp_p_new_ci_ptr, rcp_p_ci_ptr);

/* Releases the ci_ptr held in rcp_p_ci_ptr, if non-null, then resets */
/* rcp_p_ci_ptr with the value of rcp_p_new_ci_ptr. */

   dcl	 rcp_p_ci_ptr	    ptr parameter;
   dcl	 rcp_p_new_ci_ptr	    ptr parameter;

   if rcp_p_ci_ptr ^= null
   then /* After MR11, should call collection_manager_$release_ci_ptr */
        ;

   rcp_p_ci_ptr = rcp_p_new_ci_ptr;

   return;

   end RESET_CI_PTR;
%page;
DELETE_RECORD:
   proc ();
   end DELETE_RECORD;
%page;
MODIFY_RECORD:
   proc ();
   end MODIFY_RECORD;
%page;
%include dm_rcm_cursor;
%page;
%include vu_typed_vector;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include sub_err_flags;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
   end rcm_update_by_spec;




		    record_manager_.alm             01/04/85  0917.4re  01/03/85  1147.4       30960



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
	name	record_manager_
"
" Modified:
" 11/15/82 by Lindsey Spratt: Added entries to use the interval_list structure.
" 12/21/82 by Lindsey Spratt: Fixed get_record_count_by_interval to refer to
"             $count instead of $get_count.  Fixed position_cursor to refer
" 	    to $position instead of $position_cursor.
" 12/21/82 by Matthew Pierret: Changed $get_record_count to refer to
"             rm_general_search$count instead of the obsolete
"             rm_get_record_count$get_record_count.
" 03/16/83 by Matthew Pierret: Changed XXX to tra to rm_XXX$rm_XXX instead
"             rm_XXX$XXX.
" 04/21/83 by Matthew Pierret: Added rm_$get_records_and_ids("" _by_interval)
" 07/28/83 by Matthew Pierret: Changed rm_XXX to rcm_XXX.
" 04/11/84 by Lee Baldwin: Changed $XX_records_by_id to $XX_records_by_id_list
"             to better distinguish them from $XX_get_record_by_id, changed
"             $get_ids_by_interval to $get_record_ids_by_interval, changed
"             $get_records_and_ids to $get_records_and_ids_by_spec, changed
"             $get_record_id to $get_record_ids_by_spec, deleted $get_id
"             (use $get_record_ids_by_spec instead) and $calculate_storage.
"             Alphabetized the entries.
" 

" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

" (unimplemented) ext_transfer copy_cursor,rcm_copy_cursor$rcm_copy_cursor
	ext_transfer create_collection,rcm_create_collection$rcm_create_collection
	ext_transfer create_cursor,rcm_create_cursor$rcm_create_cursor
	ext_transfer delete_record_by_id,rcm_delete_record_by_id$single
	ext_transfer delete_records_by_id_list,rcm_delete_record_by_id$array
	ext_transfer delete_records_by_interval,rcm_process_intervals$delete
	ext_transfer delete_records_by_spec,rcm_general_search$delete
	ext_transfer destroy_collection,rcm_destroy_collection$rcm_destroy_collection
	ext_transfer destroy_cursor,rcm_destroy_cursor$rcm_destroy_cursor
          ext_transfer get_field_info,rcm_get_field_info$rcm_get_field_info
	ext_transfer get_record_by_id,rcm_get_record_by_id$single
	ext_transfer get_record_ids_by_interval,rcm_process_intervals$get_id
	ext_transfer get_record_ids_by_spec,rcm_general_search$get_id
	ext_transfer get_record_count,rcm_general_search$count
	ext_transfer get_record_count_by_interval,rcm_process_intervals$count
	ext_transfer get_records_and_ids_by_interval,rcm_process_intervals$get_records_and_ids
	ext_transfer get_records_and_ids_by_spec,rcm_general_search$get_records_and_ids
	ext_transfer get_records_by_id_list,rcm_get_record_by_id$array
	ext_transfer get_records_by_interval,rcm_process_intervals$get
	ext_transfer get_records_by_spec,rcm_general_search$get
	ext_transfer modify_record_by_id,rcm_modify_record_by_id$single
	ext_transfer modify_records_by_id_list,rcm_modify_record_by_id$array
	ext_transfer modify_records_by_spec,rcm_general_search$modify
	ext_transfer position_cursor,rcm_general_search$position
	ext_transfer put_record_by_id,rcm_put_record_by_id$single
          ext_transfer put_records_by_id,rcm_put_record_by_id$array

	end




		    relation_manager_.alm           10/02/86  1219.4rew 10/02/86  1204.1       50481



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-02-05,Pierret), approve(86-02-27,MCR7349),
"     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
"     Changed the put_tuples entry to transfer to rlm_put_tuple$list instead
"     of rlm_put_tuple$rlm_put_tuple.
"  2) change(86-08-19,Dupuis), approve(86-08-19,MCR7401),
"     audit(86-09-26,Blair), install(86-10-02,MR12.0-1173):
"     There were a number of entries into rlm_general_search that were
"     untested because mrds doesn't use them. Changed these entrypoints
"     ($get_tuples_by_spec, $get_tuple_array_by_spec, $get_tuples_and_ids,
"     $get_tuple_array_and_ids) to head into the rlm_unimplemented_entries
"     module instead. Changed the rlm_general_search$get_count target to
"     be rlm_get_count$rlm_get_count. Changed the rlm_general_search$get_id
"     target to be rlm_get_tuple_id.
"                                                      END HISTORY COMMENTS


name	relation_manager_
"
" Written by Matthew Pierret, probably done during August of '82.
" Modified:
" 11/22/82 by Lindsey Spratt:  Added the get_tuple_array_by spec entry.
"	    Changed get_tuples_by_spec to use the
"	    rlm_general_search$get_list_by_spec entry.
" 02/17/83 by Matthew Pierret: Changed $create_relation to transfer to
"             rlm_create_relation$array (instead of $rlm_create_relation).
" 03/04/83 by Matthew Pierret: Changed $destroy_relation_by_(opening path)
"             to tra to rlm_destroy_relation$by_(opening path) instead of
"             of rlm_unimplemented_entries. Changed $set_scope to tra to
"             rlm_set_scope$rlm_set_scope instead of rlm_unimplemented_entries.
" 04/08/83 by Matthew Pierret: Changed $destroy_(index cursor) to tra to
"             rlm_destroy(index cursor) isntead of rlm_unimplemented_entries.
" 04/21/83 by Matthew Pierret: Added $get_tuples_and_ids and 
"             $get_tuple_array_and_ids
" 08/08/83 by Matthew Pierret: Changed rlm_destroy_relation$by_opening to
"             $by_opening_id.
" 08/09/83 by Matthew Pierret: Added $get_population.
" 09/13/83 by Matthew Pierret: Changed $get_population to transfer to
"             rlm_get_approximate_count$get_populaiton. Changed
"             $get_duplicate_key_count to transfer to
"             rlm_get_approximate_count$get_duplicate_key_count.
" 05/24/84 by Matthew Pierret: Added $get_cursor_area_ptr, 
"             $get_cursor_opening_id, $get_index_id, $get_record_collection_id
"
" Macro to generate a call to an external entrypoint in the manager

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer create_relation,rlm_create_relation$array
          ext_transfer destroy_relation_by_opening,rlm_destroy_relation$by_opening_id
          ext_transfer destroy_relation_by_path,rlm_destroy_relation$by_path

          ext_transfer create_index,rlm_create_index$rlm_create_index
          ext_transfer create_subset_index,rlm_unimplemented_entries$create_subset_index
          ext_transfer destroy_index,rlm_destroy_index$rlm_destroy_index

          ext_transfer create_cursor,rlm_create_cursor$rlm_create_cursor
          ext_transfer destroy_cursor,rlm_destroy_cursor$rlm_destroy_cursor

          ext_transfer open,rlm_open$open
          ext_transfer close,rlm_open$close

          ext_transfer set_scope,rlm_set_scope$rlm_set_scope

          ext_transfer delete_tuple_by_id,rlm_process_tuples_by_id$delete
          ext_transfer delete_tuples_by_id,rlm_process_tuples_by_id$delete_array
          ext_transfer delete_tuples_by_spec,rlm_unimplemented_entries$delete_tuples_by_spec

          ext_transfer get_cursor_area_ptr,rlm_get_cursor_info$area_ptr
          ext_transfer get_cursor_opening_id,rlm_get_cursor_info$opening_id

          ext_transfer get_index_id,rlm_get_info$get_index_id
          ext_transfer get_record_collection_id,rlm_get_info$get_record_collection_id

          ext_transfer get_tuple_by_id,rlm_get_tuple_by_id$single
          ext_transfer get_tuples_by_id,rlm_get_tuple_by_id$list
          ext_transfer get_tuple_array_by_id,rlm_get_tuple_by_id$array
          ext_transfer get_tuples_by_spec,rlm_unimplemented_entries$get_tuples_by_spec
	ext_transfer get_tuple_array_by_spec,rlm_unimplemented_entries$get_tuple_array_by_spec
          ext_transfer get_tuple_id,rlm_get_tuple_id$rlm_get_tuple_id
          ext_transfer get_tuples_and_ids,rlm_unimplemented_entries$get_tuples_and_ids
          ext_transfer get_tuple_array_and_ids,rlm_unimplemented_entries$get_tuple_array_and_ids
          ext_transfer modify_tuple_by_id,rlm_process_tuples_by_id$modify
          ext_transfer modify_tuples_by_id,rlm_process_tuples_by_id$modify_array
          ext_transfer modify_tuples_by_spec,rlm_unimplemented_entries$modify_tuples_by_spec

          ext_transfer put_tuple,rlm_put_tuple$single
          ext_transfer put_tuples,rlm_put_tuple$list

          ext_transfer get_count,rlm_get_count$rlm_get_count
          ext_transfer get_duplicate_key_count,rlm_get_approximate_count$get_duplicate_key_count
          ext_transfer get_population,rlm_get_approximate_count$get_population
          ext_transfer get_max_and_min_attributes,rlm_unimplemented_entries$get_max_and_min_attributes
          ext_transfer get_description,rlm_get_description$rlm_get_description

          end




		    rlm_create_cursor.pl1           03/06/85  0749.6r w 03/05/85  0836.7       25236



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

/* format: style2,ind3 */

rlm_create_cursor:
   proc (p_rel_opening_id, p_work_area_ptr, p_relation_cursor_ptr, p_code);

/* DESCRIPTION:


*/

/* HISTORY:

Written by Matthew Pierret, 09/13/82.
Modified:
10/13/82 by Matthew Pierret:  Changed to accept p_collection_id = "0"b to 
            indicate the record collection.
01/18/83 by Matthew Pierret:  Changed to use RELATION_INFO_VERSION_2.
02/28/83 by Matthew Pierret:  Changed to use relation_opening_info, 
            relation_header and index_attribute_map instead of relation_info.
05/24/83 by Matthew Pierret:  Changed to use relation_cursor instead of
            index and record_cursor.  This reduced the routine to little
            more than an allocation.
06/08/84 by Lee Baldwin:  Took out the dcl of dm_error_$index_not_in_relation
            since it isn't being used here.
10/31/84 by Stanford S. Cox:  Added asgn. of relation_cursor.version.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_rel_opening_id       bit (36) aligned parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_relation_cursor_ptr  ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    relation_opening_info_ptr
			       ptr init (null);

/* Based */

      dcl	    p_work_area	       area (99999) based (p_work_area_ptr);

/* Builtin */

      dcl	    (null, hbound)	       builtin;

/* Constant */

      dcl	    myname	       init ("rlm_create_cursor") char (17) internal static options (constant);

/* Entry */

      dcl	    record_manager_$create_cursor
			       entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
      dcl	    index_manager_$create_cursor
			       entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));

/* END OF DECLARATIONS */

      p_code = 0;
      p_relation_cursor_ptr = null;

/* To verify that p_rel_opening_id is valid */
      call rlm_opening_info$get (p_rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      alloc relation_cursor in (p_work_area);
      relation_cursor.version = RELATION_CURSOR_VERSION_2;
      relation_cursor.work_area_ptr = p_work_area_ptr;
      relation_cursor.file_opening_id = p_rel_opening_id;

      p_relation_cursor_ptr = relation_cursor_ptr;

      return;
%page;
%include dm_rlm_cursor;

   end rlm_create_cursor;




		    rlm_create_index.pl1            10/24/88  1644.7r w 10/24/88  1400.0      234981



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


/* DESCRIPTION:

          This routine creates an index in a relation.  The fields in the keys
     of the index are either all of the fields of the record tuples if
     p_id_list_ptr is null, or those fields identified by
     p_id_list_ptr->id_list if non-null.  The keys also have one addition
     field, which is the tuple_id of the tuple which the key identifies.  This
     field is bit (36) aligned.
          Before creating the index, all of the records of the relation are
     retrieved in a typed_vector_array.  If there are no records in the
     relation, a typed_vector_array whose dimension_table describes the fields
     of the keys is created by hand.  index_manager_$create_index stores the
     keys in the typed_vector_array, if there are any, after creating the
     index. 
*/

/* HISTORY:
Written by Matthew Pierret, 06/01/82.
Modified:
06/18/82 by Matthew Pierret: Removed BEGINNING_OF_ELEMENT argument from
            put_element calling sequence.
09/22/82 by Matthew Pierret:  Changed to use id_list and to create unique or
            non-unique indices.
09/30/82 by Matthew Pierret:  Changed to use the area pointed to by
            dm_area_ptr.  Added cleanup handler.
10/12/82 by Matthew Pierret:  Changed to get and reset the opening info.
            Changed to allocate descriptor_string in dm_area rather than
            use an automatic structure so that vu_$free_typed_vector_array
            doesn't blow out.
            Changed to use index_manager_$create_index instead of
	  $create_collection.
11/30/82 by Lindsey Spratt:  Added the (nosubrg) condition prefix to protect
	  statements for which the compiler emits the wrong code (i.e., when
	  assigning from an array into another array which are different
	  instances of the same structure, with different refer extents).
12/02/82 by Lindsey Spratt:  Fixed to copy the attribute_descriptor array
	  when extending the index_attribute_map.
03/01/83 by Matthew Pierret: Added copyright notice. Removed the create_index 
            label. Changed to use relation_opening_info, and to update the
            file copy of index_attribute_map via rlm_update_opening_info.
06/14/83 by Matthew Pierret:  Changed to load the newly created index if there
            are any data already stored in the relation.  This is done by
            retrieving the appropriate fields and the record_id of each record
            in the record collection, and passing the typed_vector_array
            holding these values to index_manager_$create_index, which stores
            them as keys after creating the index.  The record_id is retrieved
            by specifying a value of -1 for the last field_id in the 
            retrieval_id_list.  
            Also added the ERROR_RETURN routine to replace the
            "do;call FINISH;return;end;" cliche with 
            "call ERROR_RETURN (code);".
            Changed BUILD_TVA to use local variables and a parameter.
09/20/83 by Lindsey L. Spratt:  Changed to use
            dm_relation_index_flags.incl.pl1.
04/13/84 by Lee Baldwin:  Changed the calling sequence of 
            record_manager_$get_records_by_spec which no longer takes
            typed_vector_array_version.
05/29/84 by Matthew Pierret:  Changed to RELATION_HEADER_VERSION_3.  Changed
            to copy p_code and p_id_list_ptr parameters into local variables.
            Moved setting of dm_area_ptr and establishment of cleanup handler
            to just before they are needed.
06/07/84 by Lee Baldwin:  Renamed dm_error_$nonempty_relation to
            dm_error_$non_empty_relation.
10/31/84 by Stanford S. Cox: MAIN - Added p_style check.  GET_OR_CREATE_* - Added
   	  index_attribute_map version asgn.
11/01/84 by Lindsey L. Spratt:  Changed to use error_table_$unsupported
            operation instead of the (obsolete) dm_error_$not_implemented.
12/20/84 by Lindsey L. Spratt:  Fixed to use dm_vector_util_ instead of
            vector_util_.
02/05/85 by Lindsey L. Spratt:  Fixed to handle the case where the keys to be
            loaded won't all fit into a single TVA.
02/14/85 by Lindsey L. Spratt:  Moved "on cleanup" statement to precede the
            define_area_ call and changed FINISH to test and release
            local_area_info.areap instead of vector_area_ptr.  Changed
            PUT_REST_OF_KEYS to simply return if the prok_code =
            dm_error_$record_not_found.  Fixed the builtin dcls to be only
            those builtins actually used.
*/

/* format: style2,ind3 */

rlm_create_index:
   proc (p_rel_opening_id, p_id_list_ptr, p_flags, p_style, p_index_collection_id, p_code);

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

      dcl	    p_rel_opening_id       bit (36) aligned;
      dcl	    p_id_list_ptr	       ptr;
      dcl	    p_flags	       bit (36) aligned;
      dcl	    p_style	       fixed bin (17);
      dcl	    p_index_collection_id  bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    attribute_idx	       fixed bin;
      dcl	    code		       fixed bin (35);
      dcl	    index_all_attributes   bit (1) aligned init ("0"b);
      dcl	    index_idx	       fixed bin;
      dcl	    1 local_area_info      aligned like area_info;
      dcl	    number_of_key_fields   fixed bin;
      dcl	    relation_is_nonempty   bit (1) aligned init (NO);
      dcl	    there_are_more_records bit (1) aligned init (NO);
      dcl	    vector_area_ptr	       ptr init (null ());

      dcl	    (descriptor_string_ptr, index_cursor_ptr, input_id_list_ptr, old_index_attribute_map_ptr, record_cursor_ptr,
	    retrieval_id_list_ptr) ptr init (null);

/* Based */

      dcl	    descriptor_string      bit (36) aligned based (descriptor_string_ptr);
      dcl	    dm_area	       area (sys_info$max_seg_size) based (dm_area_ptr);
      dcl	    vector_area	       area (sys_info$max_seg_size) based (vector_area_ptr);

/* Builtin */

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

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("rlm_create_index") char (32) varying;
      dcl	    BITS_PER_WORD	       init (36) fixed bin int static options (constant);
      dcl	    MAXIMUM_RANGE_SIZE_FOR_SUBSEQUENT_RETRIEVALS
			       init (131072 /* 2**17 */) fixed bin (35) int static options (constant);
      dcl	    TREE_STYLE_INDEX       init (1) fixed bin int static options (constant);
      dcl	    (
	    YES		       init ("1"b),
	    NO		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    ioa_$rsnnl	       entry () options (variable);
      dcl	    define_area_	       entry (ptr, fixed bin (35));
      dcl	    dm_vector_util_$free_typed_vector_array
			       entry (ptr, ptr, fixed bin (35));
      dcl	    dm_vector_util_$merge_typed_vector_array
			       entry (ptr, fixed bin (17), ptr, ptr, ptr, fixed bin (35));
      dcl	    record_manager_$get_field_info
			       entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
      dcl	    release_area_	       entry (ptr);
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$index_attribute_map
			       entry (ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$record_not_found,
	    dm_error_$non_empty_relation,
	    error_table_$area_too_small,
	    error_table_$unimplemented_version,
	    error_table_$unsupported_operation
	    )		       fixed bin (35) ext;

      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* Static */

      dcl	    dm_area_ptr	       ptr init (null) internal static;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */


      p_code, code = 0;
      typed_vector_array_ptr = null;
      input_id_list_ptr = p_id_list_ptr;
      if p_style ^= TREE_STYLE_INDEX			/* hash index is not implemented */
      then call ERROR_RETURN (error_table_$unsupported_operation);

/**** Get opening information structures for this relation. */

      call rlm_opening_info$get (p_rel_opening_id, relation_opening_info_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);			/* relation not open */

      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      attribute_info_ptr = relation_opening_info.attribute_info_ptr;
      call CHECK_VERSION ("attribute_info", attribute_info.version, ATTRIBUTE_INFO_VERSION_1);

      index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
      call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);

/**** Determine how many fields will make up the key. One is added to the number
      of attributes selected because all keys have an extra field for the tuple
      identifier. */

      if input_id_list_ptr = null
      then
         do;
	  index_all_attributes = "1"b;
	  number_of_key_fields = attribute_info.number_of_attributes + 1;
         end;
      else
         do;
	  call CHECK_VERSION_FB ("id_list", (input_id_list_ptr -> id_list.version), (ID_LIST_VERSION_1));
	  number_of_key_fields = input_id_list_ptr -> id_list.number_of_ids + 1;
         end;

/**** Get a pointer to an area and set up a cleanup handler. */

      if dm_area_ptr = null
      then dm_area_ptr = get_dm_free_area_ ();

      local_area_info.version = area_info_version_1;
      local_area_info.owner = myname;
      string (local_area_info.control) = "0"b;
      local_area_info.control.zero_on_alloc = YES;
      local_area_info.areap = null ();


      local_area_info.size = sys_info$max_seg_size;

      on cleanup call FINISH ();

      call define_area_ (addr (local_area_info), code);
      if code ^= 0
      then call ERROR_RETURN (code);

      vector_area_ptr = local_area_info.areap;


/**** Find an entry in the index_attribute_map.index array for the new index.
      If all of the entries are in use, the array must be extended. */

      index_idx = -1;

      call GET_OR_CREATE_INDEX_ATTRIBUTE_MAP_ENTRY
	 ((index_attribute_map.number_of_indices = index_attribute_map.maximum_number_of_indices),
	 (number_of_key_fields - 1 > index_attribute_map.maximum_number_of_attributes_per_index), index_idx);

/**** Retrieve the field values that will be stored in the new index
      in a typed_vector_array, or, if there are no data in the relation,
      create a typed_vector_array with a dimension_table describing the
      fields of the keys of the new index. */

      call BUILD_ID_LIST_WITH_TUPLE_ID (number_of_key_fields, input_id_list_ptr, retrieval_id_list_ptr);

      call record_manager_$create_cursor (p_rel_opening_id, relation_header.record_collection_id, dm_area_ptr,
	 record_cursor_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call record_manager_$get_records_by_spec (null (), retrieval_id_list_ptr, vector_area_ptr, record_cursor_ptr,
	 typed_vector_array_ptr, code);
      if code = 0
      then
         do;
	  relation_is_nonempty = YES;
	  there_are_more_records = NO;
         end;
      else if code = dm_error_$record_not_found
      then
         do;
	  there_are_more_records = NO;
	  relation_is_nonempty = NO;
         /*** There are no tuples in the relation. This is not an error.
	    Create a typed_vector_array by hand to use in creating the index. */

	  code = 0;
	  call BUILD_TVA (typed_vector_array_ptr);
         end;
      else if code = error_table_$area_too_small
      then
         do;
	  code = 0;
	  there_are_more_records = YES;
	  relation_is_nonempty = YES;
         end;
      else call ERROR_RETURN (code);

      if addr (p_flags) -> relation_index_flags.relation_must_be_empty & relation_is_nonempty = YES
      then call ERROR_RETURN (dm_error_$non_empty_relation);


/**** Create the new index collection. Use the typed_vector_array to
      describe the fields in the keys of the new index, and set up
      the number of duplication fields (the third argument in the calling
      sequence of index_mananager_$create_index).  If the index is to be
      unique, the number of duplication fields is equal to the number of
      fields excluding the field which contains the tuple_id.  Otherwise,
      the number of duplication fields is equal to the number of key fields.
*/

      if addr (p_flags) -> relation_index_flags.index_is_unique
      then call index_manager_$create_index (p_rel_opening_id, typed_vector_array_ptr, number_of_key_fields - 1,
	      index_attribute_map.index (index_idx).collection_id, code);
      else call index_manager_$create_index (p_rel_opening_id, typed_vector_array_ptr, number_of_key_fields,
	      index_attribute_map.index (index_idx).collection_id, code);

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

      if there_are_more_records
      then
         do;
	  call index_manager_$create_cursor (p_rel_opening_id, index_attribute_map.index (index_idx).collection_id,
	       dm_area_ptr, index_cursor_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  call PUT_REST_OF_KEYS (record_cursor_ptr, retrieval_id_list_ptr, vector_area_ptr, index_cursor_ptr,
	       typed_vector_array_ptr);
         end;


/**** Update the index_attribute_map to reflect the exixtence of the new
      index. */

      index_attribute_map.number_of_indices = index_attribute_map.number_of_indices + 1;
      index_attribute_map.index (index_idx).number_of_attributes = number_of_key_fields - 1;
      do attribute_idx = 1 to number_of_key_fields - 1;
         if index_all_attributes
         then index_attribute_map.index (index_idx).attribute_id (attribute_idx) = attribute_idx;
         else index_attribute_map.index (index_idx).attribute_id (attribute_idx) =
	         input_id_list_ptr -> id_list.id (attribute_idx);
      end;

/**** Update the opening copy of the index_attribute_map, as well as the file
      copy and any necessary updates to relation_header to keep the relation
      consistent. */

      call rlm_update_opening_info$index_attribute_map (relation_opening_info_ptr, index_attribute_map_ptr, code);

      if code ^= 0
      then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
	      "The index was created, but an error occurred while resetting the opening information.");


/**** Set return argument and return. */

      p_index_collection_id = index_attribute_map.index (index_idx).collection_id;

      call FINISH ();

MAIN_RETURN:
      return;
%page;
CHECK_VERSION:
   proc (p_structure_name, p_received_version, p_expected_version);

      dcl	    p_received_version     char (8) aligned;
      dcl	    p_expected_version     char (8) aligned;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_FB:
   proc (p_structure_name, p_received_version, p_expected_version);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION_FB;
%page;
ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;


FINISH:
   proc ();

      if local_area_info.areap ^= null
      then call release_area_ (local_area_info.areap);

      if retrieval_id_list_ptr ^= null
      then free retrieval_id_list_ptr -> id_list in (dm_area);

      if record_cursor_ptr ^= null
      then call record_manager_$destroy_cursor (record_cursor_ptr, (0));

      if index_cursor_ptr ^= null
      then call index_manager_$destroy_cursor (index_cursor_ptr, (0));

      if old_index_attribute_map_ptr ^= index_attribute_map_ptr
      then if old_index_attribute_map_ptr ^= null
	      & old_index_attribute_map_ptr ^= relation_opening_info.index_attribute_map_ptr
	 then free old_index_attribute_map_ptr -> index_attribute_map in (dm_area);
	 else if index_attribute_map_ptr ^= null
	      & index_attribute_map_ptr ^= relation_opening_info.index_attribute_map_ptr
	 then free index_attribute_map in (dm_area);


   end FINISH;
%page;
BUILD_ID_LIST_WITH_TUPLE_ID:
   proc (bil_number_of_key_fields, bil_input_id_list_ptr, bil_output_id_list_ptr);

      dcl	    bil_number_of_key_fields
			       fixed bin parameter;
      dcl	    bil_input_id_list_ptr  ptr parameter;
      dcl	    bil_output_id_list_ptr ptr parameter;
      dcl	    bil_id_idx	       fixed bin;


      il_number_of_ids = bil_number_of_key_fields;
      alloc id_list in (dm_area) set (bil_output_id_list_ptr);
      bil_output_id_list_ptr -> id_list.version = ID_LIST_VERSION_1;

      if bil_input_id_list_ptr = null
      then
         do bil_id_idx = 1 to bil_number_of_key_fields - 1;
	  bil_output_id_list_ptr -> id_list.id (bil_id_idx) = bil_id_idx;
         end;
      else
         do bil_id_idx = 1 to bil_number_of_key_fields - 1;
	  bil_output_id_list_ptr -> id_list.id (bil_id_idx) = bil_input_id_list_ptr -> id_list.id (bil_id_idx);
         end;
      bil_output_id_list_ptr -> id_list.id (bil_id_idx) = -1;

      return;

   end BUILD_ID_LIST_WITH_TUPLE_ID;
%page;
BUILD_TVA:
   proc (bt_key_typed_vector_array_ptr);

      dcl	    bt_key_typed_vector_array_ptr
			       ptr parameter;
      dcl	    bt_record_typed_vector_array_ptr
			       ptr;
      dcl	    bt_dimension_name      char (32) varying init ("");
      dcl	    bt_code	       fixed bin (35);

      call record_manager_$get_field_info (p_rel_opening_id, relation_header.record_collection_id, vector_area_ptr,
	 bt_record_typed_vector_array_ptr, bt_code);
      if bt_code ^= 0
      then call ERROR_RETURN (bt_code);

      call CHECK_VERSION_FB ("typed_vector_array", (bt_record_typed_vector_array_ptr -> typed_vector_array.version),
	 (TYPED_VECTOR_ARRAY_VERSION_2));

      if index_all_attributes
      then number_of_key_fields = bt_record_typed_vector_array_ptr -> typed_vector_array.number_of_dimensions + 1;

      call dm_vector_util_$merge_typed_vector_array (vector_area_ptr, number_of_key_fields, input_id_list_ptr,
	 bt_record_typed_vector_array_ptr, bt_key_typed_vector_array_ptr, bt_code);
      if bt_code ^= 0
      then call ERROR_RETURN (bt_code);

      call CHECK_VERSION_FB ("typed_vector_array", (bt_key_typed_vector_array_ptr -> typed_vector_array.version),
	 (TYPED_VECTOR_ARRAY_VERSION_2));

/*
   Append the tuple_id field to the end.
*/

      alloc descriptor_string in (vector_area);
      arg_descriptor_ptr = descriptor_string_ptr;
      unspec (descriptor_string) = "0"b;
      fixed_arg_descriptor.flag = "1"b;
      fixed_arg_descriptor.type = bit_dtype;
      fixed_arg_descriptor.precision = 36;

      bt_key_typed_vector_array_ptr -> typed_vector_array.dimension_table (number_of_key_fields).name = "0";
      bt_key_typed_vector_array_ptr -> typed_vector_array.dimension_table (number_of_key_fields).descriptor_ptr =
	 arg_descriptor_ptr;

      return;

   end BUILD_TVA;
%page;
GET_OR_CREATE_INDEX_ATTRIBUTE_MAP_ENTRY:
   proc (p_extend_index_array, p_increase_maximum_number_of_attributes, p_index_idx);

      dcl	    p_extend_index_array   bit (1) aligned;
      dcl	    p_increase_maximum_number_of_attributes
			       bit (1) aligned;
      dcl	    p_index_idx	       fixed bin;
      dcl	    iam_idx	       fixed bin;
      dcl	    attribute_idx	       fixed bin;

      old_index_attribute_map_ptr = index_attribute_map_ptr;

      if p_extend_index_array | p_increase_maximum_number_of_attributes
      then
ALLOCATE_NEW_IAM:
         do;
	  if p_extend_index_array
	  then iam_maximum_number_of_indices =
		  hbound (old_index_attribute_map_ptr -> index_attribute_map.index, 1) + INITIAL_NUMBER_OF_INDICES;
	  else iam_maximum_number_of_indices = hbound (old_index_attribute_map_ptr -> index_attribute_map.index, 1);

	  iam_maximum_number_of_attributes_per_index =
	       max (old_index_attribute_map_ptr -> index_attribute_map.maximum_number_of_attributes_per_index,
	       number_of_key_fields - 1);

	  alloc index_attribute_map in (dm_area);
	  index_attribute_map.version = INDEX_ATTRIBUTE_MAP_VERSION_2;
	  index_attribute_map.number_of_indices = old_index_attribute_map_ptr -> index_attribute_map.number_of_indices;

	  do iam_idx = 1 to hbound (old_index_attribute_map_ptr -> index_attribute_map.index, 1);
	     if ^p_increase_maximum_number_of_attributes
	     then
(nosubrg):
	        index_attribute_map.index (iam_idx) =
		   old_index_attribute_map_ptr -> index_attribute_map.index (iam_idx);
	     else
	        do;
(nosubrg):
		 index_attribute_map.index (iam_idx).collection_id =
		      old_index_attribute_map_ptr -> index_attribute_map.index (iam_idx).collection_id;
(nosubrg):
		 index_attribute_map.index (iam_idx).style =
		      old_index_attribute_map_ptr -> index_attribute_map.index (iam_idx).style;
(nosubrg):
		 index_attribute_map.index (iam_idx).number_of_duplication_fields =
		      old_index_attribute_map_ptr -> index_attribute_map.index (iam_idx).number_of_duplication_fields;
(nosubrg):
		 index_attribute_map.index (iam_idx).number_of_attributes =
		      old_index_attribute_map_ptr -> index_attribute_map.index (iam_idx).number_of_attributes;
		 index_attribute_map.index (iam_idx).attribute_id (*) = 0;

		 do attribute_idx = 1 to index_attribute_map.index (iam_idx).number_of_attributes;
(nosubrg):
		    index_attribute_map.index (iam_idx).attribute_id (attribute_idx) =
		         old_index_attribute_map_ptr
		         -> index_attribute_map.index (iam_idx).attribute_id (attribute_idx);
		 end;
	        end;
	  end;

	  if p_extend_index_array
	  then
	     do;

	        p_index_idx = iam_idx;

	        do iam_idx = iam_idx to index_attribute_map.maximum_number_of_indices;
		 unspec (index_attribute_map.index (iam_idx)) = "0"b;
	        end;
	     end;
         end ALLOCATE_NEW_IAM;

      if p_index_idx = -1
      then
         do p_index_idx = 1 to hbound (index_attribute_map.index, 1)
	    while (index_attribute_map.index (p_index_idx).number_of_attributes ^= UNUSED_INDEX_ATTRIBUTE_MAP_ENTRY);
         end;

      return;

   end GET_OR_CREATE_INDEX_ATTRIBUTE_MAP_ENTRY;
%page;
PUT_REST_OF_KEYS:
   proc (prok_p_record_cursor_ptr, prok_p_record_id_list_ptr, prok_p_vector_area_ptr, prok_p_index_cursor_ptr,
        prok_p_typed_vector_array_ptr);
      dcl	    prok_p_record_cursor_ptr
			       ptr parm;
      dcl	    prok_p_record_id_list_ptr
			       ptr parm;
      dcl	    prok_p_vector_area_ptr ptr parm;
      dcl	    prok_p_index_cursor_ptr
			       ptr parm;
      dcl	    prok_p_typed_vector_array_ptr
			       ptr parm;

      dcl	    prok_p_vector_area     area based (prok_p_vector_area_ptr);

      dcl	    prok_code	       fixed bin (35) init (0);
      dcl	    1 prok_numeric_specification
			       aligned like numeric_specification;
      dcl	    prok_there_are_more_records
			       bit (1) aligned init (YES);

      prok_numeric_specification.head.version = SPECIFICATION_VERSION_4;
      prok_numeric_specification.head.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE;
      prok_numeric_specification.position_number = 1;
      prok_numeric_specification.range_size = MAXIMUM_RANGE_SIZE_FOR_SUBSEQUENT_RETRIEVALS;

      do while (prok_there_are_more_records);

         call release_area_ (prok_p_vector_area_ptr);
         local_area_info.areap = null ();
         call define_area_ (addr (local_area_info), prok_code);
         prok_p_vector_area_ptr = local_area_info.areap;

         prok_p_typed_vector_array_ptr = null ();

         call record_manager_$get_records_by_spec (addr (prok_numeric_specification), prok_p_record_id_list_ptr,
	    prok_p_vector_area_ptr, prok_p_record_cursor_ptr, prok_p_typed_vector_array_ptr, prok_code);
         if prok_code = 0
         then prok_there_are_more_records = NO;
         else if prok_code = error_table_$area_too_small
         then prok_there_are_more_records = YES;
         else if prok_code = dm_error_$record_not_found
         then return;
         else call ERROR_RETURN (prok_code);

         call index_manager_$put_key_array (prok_p_typed_vector_array_ptr, prok_p_index_cursor_ptr, prok_code);
         if prok_code ^= 0
         then call ERROR_RETURN (prok_code);
      end;
   end PUT_REST_OF_KEYS;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_id_list;
%page;
%include vu_typed_vector_array;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_specification;
%page;
%include dm_specification_head;
%page;
%include dm_relation_index_flags;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include area_info;
%page;
%include sub_err_flags;
   end rlm_create_index;




		    rlm_create_relation.pl1         05/06/86  1320.1rew 05/06/86  1258.4      149202



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




/****^  HISTORY COMMENTS:
  1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Changed to be sure that file_create_info_ptr is set before using it.
  2) change(86-04-22,Pierret), approve(86-04-22,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Removed dm_hdr_collection_id.incl.pl1, ltrim, rtrim, string as they were
     not used.  Added addr builtin as it is used but was not declared.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION
*/

/* HISTORY:
Written by Matthew Pierret, 05/01/82.
Modified:
06/18/82 by Matthew Pierret: Changed to use collection_manager_$create_file
            instead of file_manager_$create.
09/20/82 by Matthew Pierret:  Changed to use attribute_descriptor_list.
10/12/82 by Matthew Pierret:  Changed to set the maximum number of attributes
            per index in the index_attribute_map to be the minimum of the
            actual number of attributes and 
            INITIAL_NUMBER_OF_ATTRIBUTES_PER_INDEX.
10/20/82 by Matthew Pierret:  Converted to use file_manager_, cm_$create_file
            instead of cm_$create_page_file, file_create_info instead of
            pf_creation_info, REL_CREATION_INFO_VERION_2.
02/17/83 by Matthew Pierret:  Changed to always use typed_vector_array
            instead of attribute_descriptor_list.
02/28/83 by Matthew Pierret:  Split index_attribute_map into attribute_info
            and index_attribute_map. Changed to use relation_opening_info,
            with pointers to relation_header, attribute_info, and
            index_attribute_map, and to update these structures using
            rlm_update_opening_info.
03/14/83 by Lindsey Spratt:  Fixed to initialize the relation_opening_info_ptr
	  to null.
03/21/83 by Matthew Pierret: Fixed to create record_cursor.
08/09/83 by Matthew Pierret:  Removed the obsolete dm_data_$area_ptr.
08/18/83 by Lindsey L. Spratt:  Fixed to always set the
            attribute_descriptor_list_ptr.
05/20/84 by Matthew Pierret:  Changed to use (ESM CISM)_INFO_VERSION_1.
08/20/84 by Matthew C. Pierret:  Changed to use FILE_CREATE_INFO_VERSION_2.
            Also changed to use automatic structures instead of allocating
            based ones for the structures pointed to by rel_creation_info.
            This fixed a bug where in some cases they weren't being freed.
            Removed the un-used $descriptor_list entry.
10/30/84 by Stanford S. Cox:  INIT_* - Added structure version asgn. 
11/26/84 by Stanford S. Cox:  IDFCI: Add init of file_create_info.mbz_2.
05/02/85 by S. Cox: Init to null the *info_ptr which may be init by INIT_*.
            This fixes a bug where a null rel_creation_info_ptr didn't work.
*/

/* format: style2,ind3 */

rlm_create_relation:
   proc ();

      return;					/* Not a valid entry point. */


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

      dcl	    p_rel_dir	       char (*);
      dcl	    p_rel_name	       char (*);
      dcl	    p_rel_creation_info_ptr
			       ptr;
      dcl	    p_rel_opening_id       bit (36) aligned;
      dcl	    p_record_collection_id bit (36) aligned;
      dcl	    p_code	       fixed bin (35);
      dcl	    p_typed_vector_array_ptr
			       ptr;

/* Automatic */

      dcl	    1 my_file_create_info  aligned like file_create_info;
      dcl	    1 my_basic_esm_info    aligned like basic_esm_info;
      dcl	    1 my_unblocked_cism_info
			       aligned like unblocked_cism_info;
      dcl	    (record_collection_id, rel_opening_id)
			       bit (36) aligned init ("0"b);
      dcl	    typed_vector_array_supplied
			       bit (1) aligned;
      dcl	    record_cursor_ptr      ptr init (null);

/* Static */

      dcl	    dm_area_ptr	       ptr static init (null ());

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (dm_area_ptr);

/* Builtin */

      dcl	    (addr, hbound, unspec, min, null)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("rlm_create_relation") char (19) int static options (constant);
      dcl	    BYTES_PER_WORD	       init (4) fixed bin;

/* Entry */

      dcl	    file_manager_$delete_close
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    get_ring_	       entry () returns (fixed bin (3));
      dcl	    rlm_opening_info$free  entry (ptr, fixed bin (35));
      dcl	    rlm_opening_info$init  entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$attribute_info
			       entry (ptr, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$index_attribute_map
			       entry (ptr, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$increment_openings
			       entry (ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$relation_header
			       entry (ptr, ptr, fixed bin (35));
      dcl	    vector_util_$init_typed_vector_array
			       entry options (variable);
      dcl	    ioa_$rsnnl	       entry options (variable);
      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    dm_error_$unimplemented_cism
			       ext fixed bin (35);
      dcl	    dm_error_$unimplemented_esm
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin;

/* END OF DECLARATIONS */

array:
   entry (p_rel_dir, p_rel_name, p_rel_creation_info_ptr, p_typed_vector_array_ptr, p_rel_opening_id,
        p_record_collection_id, p_code);

      typed_vector_array_ptr = p_typed_vector_array_ptr;
      call CHECK_VERSION ((typed_vector_array.version), (TYPED_VECTOR_ARRAY_VERSION_2), "typed_vector_array");

      basic_esm_info_ptr, unblocked_cism_info_ptr, file_create_info_ptr, relation_opening_info_ptr = null;

      if dm_area_ptr = null
      then dm_area_ptr = get_dm_free_area_ ();

      p_code = 0;
      p_rel_opening_id = "0"b;
      p_record_collection_id = "0"b;


      on cleanup call FINISH;

      if p_rel_creation_info_ptr ^= null
      then
         do;
	  rel_creation_info_ptr = p_rel_creation_info_ptr;
	  call CHECK_VERSION ((rel_creation_info.version), (REL_CREATION_INFO_VERSION_2), "rel_creation_info");

	  file_create_info_ptr = rel_creation_info.file_create_info_ptr;
	  basic_esm_info_ptr = rel_creation_info.esm_info_ptr;
	  unblocked_cism_info_ptr = rel_creation_info.cism_info_ptr;

         end;

      if file_create_info_ptr = null
      then call INIT_DEFAULT_FILE_CREATE_INFO (file_create_info_ptr);
      else if file_create_info.version ^= FILE_CREATE_INFO_VERSION_2
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the file_create_info structure.^/Received version ^a",
	      FILE_CREATE_INFO_VERSION_2, file_create_info.version);

      if basic_esm_info_ptr = null
      then call INIT_DEFAULT_ESM_INFO (basic_esm_info_ptr);
      else
         do;
	  call CHECK_VERSION_CHAR (basic_esm_info.version, ESM_INFO_VERSION_1, "esm_info");
	  if basic_esm_info.type ^= BASIC_ELEMENT_STORAGE_METHOD
	  then call sub_err_ (dm_error_$unimplemented_esm, myname, ACTION_CANT_RESTART, null, 0,
		  "^/This routine does not implement element storage method ^d.", basic_esm_info.type);
         end;

      if unblocked_cism_info_ptr = null
      then call INIT_DEFAULT_CISM_INFO (unblocked_cism_info_ptr);
      else
         do;
	  call CHECK_VERSION_CHAR (unblocked_cism_info.version, CISM_INFO_VERSION_1, "cism_info");
	  if unblocked_cism_info.type ^= UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD
	  then call sub_err_ (dm_error_$unimplemented_cism, myname, ACTION_CANT_RESTART, null, 0,
		  "^/This routine does not implement control interval storage method ^d.", unblocked_cism_info.type);
         end;


/* Create the file which will hold the relation. This operation leaves the 
   file open. */

      call collection_manager_$create_file (p_rel_dir, p_rel_name, file_create_info_ptr, rel_opening_id, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

/* Create the record collection which will hold the tuples of the relation. */

      call record_manager_$create_collection (rel_opening_id, typed_vector_array_ptr, unblocked_cism_info_ptr,
	 basic_esm_info_ptr, record_collection_id, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

      call record_manager_$create_cursor (rel_opening_id, record_collection_id, dm_area_ptr, record_cursor_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

/* Set up the relation_opening_info structure. */

      call rlm_opening_info$init (rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

      relation_opening_info.per_process.record_cursor_ptr = record_cursor_ptr;

      call INIT_RELATION_HEADER (record_collection_id, relation_header_ptr);

      call rlm_update_opening_info$relation_header (relation_opening_info_ptr, relation_header_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

      call INIT_ATTRIBUTE_INFO (attribute_info_ptr);
      call rlm_update_opening_info$attribute_info (relation_opening_info_ptr, attribute_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();

      call INIT_INDEX_ATTRIBUTE_MAP (index_attribute_map_ptr);
      call rlm_update_opening_info$index_attribute_map (relation_opening_info_ptr, index_attribute_map_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN ();


      call rlm_update_opening_info$increment_openings (relation_opening_info_ptr, (0));

      p_rel_opening_id = rel_opening_id;
      p_record_collection_id = record_collection_id;

      call FINISH ();

MAIN_RETURN:
      return;					/* Effective end of rlm_create_relation. */

%page;
FINISH:
   proc ();



      if p_rel_opening_id = "0"b
      then
         do;

	  if rel_opening_id ^= "0"b
	  then
	     do;
	        call file_manager_$delete_close (rel_opening_id, (0));
	        p_rel_opening_id = "0"b;
	     end;

	  if relation_opening_info_ptr ^= null
	  then
	     do;
	        call rlm_opening_info$free (relation_opening_info_ptr, (0));

	        if relation_header_ptr ^= null
	        then free relation_header_ptr -> relation_header in (dm_area);
	        if attribute_info_ptr ^= null
	        then free attribute_info in (dm_area);
	        if index_attribute_map_ptr ^= null
	        then free index_attribute_map in (dm_area);
	     end;
         end;

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_CHAR:
   proc (cvc_p_received_version, cvc_p_expected_version, cvc_p_structure_name);

      dcl	    cvc_p_received_version char (8) aligned;
      dcl	    cvc_p_expected_version char (8) aligned;
      dcl	    cvc_p_structure_name   char (*);

      if cvc_p_received_version ^= cvc_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^a, instead.", cvc_p_expected_version, cvc_p_structure_name, cvc_p_received_version);

   end CHECK_VERSION_CHAR;


ERROR_RETURN:
   proc ();

      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
INIT_DEFAULT_FILE_CREATE_INFO:
   proc (idfci_p_file_create_info_ptr);

      dcl	    idfci_p_file_create_info_ptr
			       ptr;


      idfci_p_file_create_info_ptr = addr (my_file_create_info);

      idfci_p_file_create_info_ptr -> file_create_info.version = FILE_CREATE_INFO_VERSION_2;
      idfci_p_file_create_info_ptr -> file_create_info.mbz_2 (*) = 0;
      idfci_p_file_create_info_ptr -> file_create_info.ring_brackets (*) = get_ring_ ();


      return;

   end INIT_DEFAULT_FILE_CREATE_INFO;

INIT_DEFAULT_ESM_INFO:
   proc (idei_p_esm_info_ptr);

      dcl	    idei_p_esm_info_ptr    ptr;

      idei_p_esm_info_ptr = addr (my_basic_esm_info);

      unspec (idei_p_esm_info_ptr -> basic_esm_info) = ""b;
      idei_p_esm_info_ptr -> basic_esm_info.version = ESM_INFO_VERSION_1;
      idei_p_esm_info_ptr -> basic_esm_info.type = BASIC_ELEMENT_STORAGE_METHOD;
      idei_p_esm_info_ptr -> basic_esm_info.maximum_element_length = -1;


      return;

   end INIT_DEFAULT_ESM_INFO;

INIT_DEFAULT_CISM_INFO:
   proc (idci_p_cism_info_ptr);

      dcl	    idci_p_cism_info_ptr   ptr;

      idci_p_cism_info_ptr = addr (my_unblocked_cism_info);

      unspec (idci_p_cism_info_ptr -> unblocked_cism_info) = ""b;
      idci_p_cism_info_ptr -> unblocked_cism_info.version = CISM_INFO_VERSION_1;
      idci_p_cism_info_ptr -> unblocked_cism_info.type = UNBLOCKED_CONTROL_INTERVAL_STORAGE_METHOD;


      return;

   end INIT_DEFAULT_CISM_INFO;
%page;
INIT_RELATION_HEADER:
   proc (irh_p_record_collection_id, irh_p_relation_header_ptr);

      dcl	    irh_p_record_collection_id
			       bit (36) aligned;
      dcl	    irh_p_relation_header_ptr
			       ptr;

      alloc relation_header in (dm_area);
      relation_header.version = RELATION_HEADER_VERSION_3;

      relation_header.record_collection_id = irh_p_record_collection_id;

      irh_p_relation_header_ptr = relation_header_ptr;

      return;

   end INIT_RELATION_HEADER;
%page;
INIT_ATTRIBUTE_INFO:
   proc (iai_p_attribute_info_ptr);

      dcl	    iai_p_attribute_info_ptr
			       ptr;
      dcl	    iai_based_descriptor_string
			       bit (36) aligned based;
      dcl	    iai_attribute_idx      fixed bin (17);

      ai_number_of_attributes = hbound (typed_vector_array.dimension_table, 1);
      ai_maximum_attribute_name_length = typed_vector_array.maximum_dimension_name_length;

      alloc attribute_info in (dm_area);
      attribute_info.version = ATTRIBUTE_INFO_VERSION_1;
      iai_p_attribute_info_ptr = attribute_info_ptr;

      do iai_attribute_idx = 1 to hbound (typed_vector_array.dimension_table, 1);
         attribute_info.attribute (iai_attribute_idx).name = typed_vector_array.dimension_table (iai_attribute_idx).name;
         attribute_info.attribute (iai_attribute_idx).descriptor =
	    typed_vector_array.dimension_table (iai_attribute_idx).descriptor_ptr -> iai_based_descriptor_string;
      end;

      return;

   end INIT_ATTRIBUTE_INFO;
%page;
INIT_INDEX_ATTRIBUTE_MAP:
   proc (iiam_p_index_attribute_map_ptr);

      dcl	    iiam_p_index_attribute_map_ptr
			       ptr;
      dcl	    INITIAL_NUMBER_OF_INDICES
			       init (5) fixed bin (17) int static options (constant);
      dcl	    INITIAL_NUMBER_OF_ATTRIBUTES_PER_INDEX
			       init (5) fixed bin (17) int static options (constant);


      iam_maximum_number_of_indices = INITIAL_NUMBER_OF_INDICES;
      iam_maximum_number_of_attributes_per_index =
	 min (INITIAL_NUMBER_OF_ATTRIBUTES_PER_INDEX, typed_vector_array.number_of_dimensions);

      alloc index_attribute_map in (dm_area);
      index_attribute_map.version = INDEX_ATTRIBUTE_MAP_VERSION_2;
      unspec (index_attribute_map.index) = "0"b;

      iiam_p_index_attribute_map_ptr = index_attribute_map_ptr;

      return;

   end INIT_INDEX_ATTRIBUTE_MAP;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_rel_creation_info;
%page;
%include dm_file_create_info;
%page;
%include dm_cism_info;
%page;
%include dm_esm_info;
%page;
%include vu_typed_vector_array;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include dm_collmgr_entry_dcls;
%page;
%include dm_ci_lengths;
%page;
%include sub_err_flags;

   end rlm_create_relation;




		    rlm_destroy_cursor.pl1          03/06/85  0749.6r w 03/05/85  0836.7       39366



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

/* format: style2,ind3 */

rlm_destroy_cursor:
   proc (p_relation_cursor_ptr, p_work_area_ptr, p_code);

/* DESCRIPTION:
          This routine frees the storage occupied by a relation_cursor,
     destroys the index or record cursor hanging off the relation_cursor
     by calling index/record_manager_$destroy_cursor and frees the
     specification structure hanging off the relation_cursor.
*/

/* HISTORY:
Written by Matthew Pierret, 04/04/83.
Modified:
06/24/83 by Lindsey L. Spratt:  Changed to use version 2 of the
            relation_cursor.
07/28/83 by Matthew Pierret: Changed name of dm_rm_cursor.incl.pl1 to
            dm_rcm_cursor.incl.pl1.
11/01/84 by Stanford S. Cox: CHECK_VERSION: Changed for new sub_err_ syntax
*/

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

      dcl	    p_work_area_ptr	       ptr;		/*The area in which the cursor was
                                    created.*/
						/*For vfile_relmgr_ compatibility only */
      dcl	    p_relation_cursor_ptr  ptr;		/*A pointer to a record or index cursor*/
      dcl	    p_code	       fixed bin (35);	/*Status code*/

/* Automatic */
/* Based */

      dcl	    cursor_work_area       area (9999) based;

/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("rlm_destroy_cursor") char (32) varying internal static options (constant);

/* Entry */

      dcl	    index_manager_$destroy_cursor
			       entry (ptr, fixed bin (35));
      dcl	    record_manager_$destroy_cursor
			       entry (ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      p_code = 0;
      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_VERSION ("relation_cursor", relation_cursor.version, RELATION_CURSOR_VERSION_2);

      if relation_cursor.current.cursor_ptr ^= null
      then if relation_cursor.current.cursor_ptr -> record_cursor.type = RECORD_CURSOR_TYPE
	 then call record_manager_$destroy_cursor (relation_cursor.current.cursor_ptr, p_code);
	 else if relation_cursor.current.cursor_ptr -> index_cursor.type = INDEX_CURSOR_TYPE
	 then call index_manager_$destroy_cursor (relation_cursor.current.cursor_ptr, p_code);
	 else ;

      if relation_cursor.current.specification_ptr ^= null
      then if relation_cursor.current.specification_ptr -> specification_head.type = ABSOLUTE_NUMERIC_SPECIFICATION_TYPE
	      | relation_cursor.current.specification_ptr -> specification_head.type
	      = RELATIVE_NUMERIC_SPECIFICATION_TYPE
	 then free relation_cursor.current.specification_ptr
		 -> numeric_specification in (relation_cursor.work_area_ptr -> cursor_work_area);
	 else if relation_cursor.current.specification_ptr -> specification_head.type
		 = ABSOLUTE_SEARCH_SPECIFICATION_TYPE
		 | relation_cursor.current.specification_ptr -> specification_head.type
		 = RELATIVE_SEARCH_SPECIFICATION_TYPE
	 then free relation_cursor.current.specification_ptr
		 -> search_specification in (relation_cursor.work_area_ptr -> cursor_work_area);

      p_relation_cursor_ptr = null;

      free relation_cursor in (relation_cursor.work_area_ptr -> cursor_work_area);


      return;
%page;
CHECK_VERSION:
   proc (p_structure_name, p_received_version, p_expected_version);

      dcl	    p_received_version     char (8) aligned;
      dcl	    p_expected_version     char (8) aligned;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rcm_cursor;
%page;
%include dm_im_cursor;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include sub_err_flags;

   end rlm_destroy_cursor;




		    rlm_destroy_index.pl1           01/04/85  0917.4re  01/03/85  1147.5       48042



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


/* DESCRIPTION:
         This  routine destroys an index in a relation.  The relation must be
     open.
*/

/* HISTORY:
Written by Matthew Pierret, 03/28/83.
Modified:
06/21/84 by Matthew Pierret: Added prefices to variables local to
            CHECK_VERSION and CHECK_VERSION_CHAR_8. Declared hbound.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

rlm_destroy_index:
   proc (p_rel_opening_id, p_index_collection_id, p_code);


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

      dcl	    p_index_cursor_ptr     ptr parameter;
      dcl	    p_rel_opening_id       bit (36) aligned parameter;
      dcl	    p_index_collection_id  bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (file_opening_id, index_collection_id)
			       bit (36) aligned;
      dcl	    index_idx	       fixed bin (17);

/* Based */
/* Builtin */

      dcl	    (hbound, null)	       builtin;

/* Constant */

      dcl	    myname	       init ("rlm_destroy_index") char (32) varying internal static options (constant);

/* Entry */

      dcl	    index_manager_$destroy_index
			       entry (bit (36) aligned, bit (36) aligned, fixed bin (35));
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$index_attribute_map
			       entry (ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$index_not_in_relation,
	    dm_error_$wrong_cursor_type,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

      file_opening_id = p_rel_opening_id;
      index_collection_id = p_index_collection_id;
      goto JOIN;

by_cursor:
   entry (p_index_cursor_ptr, p_code);

      index_cursor_ptr = p_index_cursor_ptr;
      if index_cursor.type ^= INDEX_CURSOR_TYPE
      then call
	    sub_err_ (dm_error_$wrong_cursor_type, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected an index cursor, type ^d.  Received type ^d.", INDEX_CURSOR_TYPE, index_cursor.type);
      call CHECK_VERSION ((index_cursor.version), (INDEX_CURSOR_VERSION_3), "index_cursor");

      file_opening_id = index_cursor.file_opening_id;
      index_collection_id = index_cursor.collection_id;
      goto JOIN;

JOIN:
      p_code = 0;
      relation_opening_info_ptr = null;

      call rlm_opening_info$get (file_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION_CHAR_8 (relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2, "relation_opening_info");
      index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
      call CHECK_VERSION_CHAR_8 (index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2, "index_attribute_map");

      do index_idx = 1 to hbound (index_attribute_map.index, 1)
         while (index_attribute_map.index (index_idx).collection_id ^= index_collection_id);
      end;
      if index_idx > hbound (index_attribute_map.index, 1)
      then p_code = dm_error_$index_not_in_relation;
      else
         do;
	  index_attribute_map.index (index_idx).number_of_attributes = 0;
	  index_attribute_map.number_of_indices = index_attribute_map.number_of_indices - 1;

	  call rlm_update_opening_info$index_attribute_map (relation_opening_info_ptr, index_attribute_map_ptr, p_code);
	  if p_code ^= 0
	  then return;

	  call index_manager_$destroy_index (file_opening_id, index_collection_id, p_code);
	  if p_code ^= 0
	  then return;
         end;

      return;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);
      if cv_p_received_version ^= cv_p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;



CHECK_VERSION_CHAR_8:
   proc (cvc8_p_received_version, cvc8_p_expected_version, cvc8_p_structure_name);
      dcl	    cvc8_p_received_version
			       char (8) aligned;
      dcl	    cvc8_p_expected_version
			       char (8) aligned;
      dcl	    cvc8_p_structure_name  char (*);
      if cvc8_p_received_version ^= cvc8_p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^8a of the ^a structure.
Received version ^8a instead.", cvc8_p_expected_version, cvc8_p_structure_name, cvc8_p_received_version);
   end CHECK_VERSION_CHAR_8;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_im_cursor;
%page;
%include sub_err_flags;
   end rlm_destroy_index;




		    rlm_destroy_relation.pl1        01/04/85  0917.4re  01/03/85  1147.6       28728



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

/* format: style2,ind3 */

rlm_destroy_relation:
   proc ();

/* DESCRIPTION:

         This  routine  destroys  a  relation  identified  by a path or by an
     opening id.  The two entries $by_path and $by_opening_id  allow  the  for
     the two methods of destruction.
          $by_path:    In this entry file_manager_$delete is called to destroy
     the file in which the relation resides. 
          $by_opening_id:  In this entry the  opening  information  associated
     with p_rel_opening_id is retrieved, checked for validity and freed.  Then
     file_manager_$delete_close is invoked to close and delete the relation.
*/
/* HISTORY:
Written by Matthew Pierret, 12/06/82.
Modified:
03/14/83 by Lindsey Spratt: Fixed the $by_path entry to not have the
	  p_rel_opening_id parameter, in conformance with the spec.
11/01/84 by Stanford S. Cox: Changed DESCRIPTION, removed unref. vars
*/
/* START OF DECLARATIONS */
/* Parameter */
      dcl	    p_rel_dir	       char (*) parameter;
      dcl	    p_rel_name	       char (*) parameter;
      dcl	    p_rel_opening_id       bit (36) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    local_code	       fixed bin (35) init (0);
      dcl	    relation_info_ptr      ptr init (null);
      dcl	    rel_opening_id	       bit (36) aligned init ("0"b);

/* Based */
/* Builtin */
      dcl	    null		       builtin;

/* Entry */

      dcl	    file_manager_$delete   entry (char (*), char (*), fixed bin (35));
      dcl	    file_manager_$delete_close
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));

/* External */


/* END OF DECLARATIONS */

by_path:
   entry (p_rel_dir, p_rel_name, p_code);

      p_code = 0;

      call file_manager_$delete (p_rel_dir, p_rel_name, p_code);

      return;

by_opening_id:
   entry (p_rel_opening_id, p_code);

      p_code = 0;

      call rlm_opening_info$get (p_rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;
      else
         do;


	  call file_manager_$delete_close (p_rel_opening_id, p_code);

         end;

      return;
%page;
/*
CHECK_VERSION:
   proc (p_received_version, p_expected_version, p_structure_name);
      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);
      if p_received_version ^= p_expected_version
      then call
	    sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	    "^/Expected version ^d of the ^a structure.
Received version ^d instead.", p_expected_version, p_structure_name, p_received_version);
   end CHECK_VERSION;
%page;
*/
%include dm_rlm_opening_info;
%page;
%include sub_err_flags;
   end rlm_destroy_relation;




		    rlm_general_search.pl1          10/24/88  1644.7r w 10/24/88  1400.0      765567



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

/* DESCRIPTION:

         This   module   searches   through  a  relation,  using  either  the
     record_manager_ or the  index_manager_,  returning  either  an  arbitrary
     subset  of  the  attributes  of  the  tuples  found  (as specified by the
     attribute id_list), or a list of element ids (which identify  the  tuples
     found).
*/

/* HISTORY:

Written by Lindsey L. Spratt, 09/23/82.
Modified:
11/12/82 by Lindsey Spratt: Changed to use version 3 of the
	  search_specification.  This means using the interval_list
	  structure which the index_manager_ may return in calls to the
	  record_manager_, and doing the conversion of the
	  search_specification field_ids to support search specs with
	  constraints on fields not present in the index being searched.
11/22/82 by Lindsey Spratt:  Added the get_array_by_spec entry and changed the
	  get_by_spec entry to be get_list_by_spec.
12/06/82 by Lindsey Spratt:  Fixed get_duplicate_key_count to a largely
	  "independent" entry, since it is the only entry which does not use
	  a specification.Also, changed code to allow for the
	  specification_ptr being null.  Changed to convert record_not_found
	  and key_not_found errors to mdbm_error_$tuple_not_found error
	  codes.
12/16/82 by Matthew Pierret:  Made to set p_element_id_list_ptr to null.
01/18/83 by Matthew Pierret:  
            Changed to not pass p_code to vector_util_$free_typed_vector_array
            in the finish procedure. It would reset p_code to 0.
02/07/83 by Lindsey Spratt:  Changed to not allocate anything but final
	  results in the caller-provided area, and to never free from the
	  caller's area.  This requires doing a full copy of the resulting
	  typed_vector_array or element_id_list.  The work_area is the
	  dm_data_$area_ptr area.
02/28/83 by Lindsey Spratt:  Changed to use version 3 index_cursor.
03/04/83 by Matthew Pierret: Changed to use the structures attribute_info,
            relation_opening_info, and index_attribute_map instead of the
            previously kept relation_info structure. Changed CHECK_VERSION
            CHECK_VERSION_FB, and added a new CHECK_VERSION which checks
            char(8)aligned versions. Removed references to dm_data$area_ptr.
            The work_area_ptr is now gotten using get_dm_free_area_ ().
            Changed work_area_ptr to be "internal static init (null)" so that
            only one call to get_dm_free_area_ need be made per process.
03/11/83 by Matthew Pierret: Changed to use mrds_error_ instead of mdbm_error_.
04/01/83 by Matthew Pierret: Changed to use dm_error_$tuple_not_found instead
            of mrds_error_$==. Added the entries $get_list_and_ids and
            $get_array_and_ids. Added use of CV_ERROR_TO_TUPLE_NOT_FOUND_RETURN
            to translate appropriate error codes to dm_error_$tuple_not_found,
            clean up and return. Added record_manager_ $get_records_and_ids
            and $get_records_and_ids_by_interval. Changed 
            record_field_is_in_index to all_desired_fields_are_in_index.
            Upper-cased finish. Added format comment after declarations which
            allows for comments to start at one indentation level before the
            current indentation level.
            Removed the check to see if a record_cursor was supplied
            via the $get_duplicate_key_count entry in the SEARCH_RECORDS
            do-group.  It is impossible to reach this point in the code
            when called through $get_duplicate_key_count.
05/05/83 by Matthew Pierret:  Changed entries which return a p_element_id_list
            to not allocate a new structure if p_element_id_list_ptr is not
            null.  Rather, just set the number of elements and fill in the
            identifiers.  It is not assumed that the value of
            peil.number_of_elements constitutes an upper bound.
05/31/83 by Matthew Pierret:  Added CV_V3_TO_V4_SPEC as a temporary means of
            converting the version 3 specifications passed in by MRDS to 
            the version 4 specifications used by index/record_managers.
06/07/83 by Lindsey L. Spratt:  Fixed the initialization of the value_field_id
            to -1 to only be done when the number of and groups is > 0.  This
            was overwriting the storage of the following allocation when the
            noag = 0, since PL1 assumes that there is always at least 1
            element in an array (even if its a 0-refer-extent based array).
06/08/83 by Matthew Pierret: Changed to support relation_cursors and
            relation_specifications. Removed the temporary CV_V3_TO_V4_SPEC.
            Changed interfaces as follows:
            - moved p_id_list_ptr immediately before p_caller_area_ptr in all
            calling sequences which have these two parameters;
            - added p_index_collection_id parameter to $get_duplicate_key_count
            to determine the index on which to operate (this determination
            previously was made by checking the cursor supplied);
            - moved p_relation_cursor_ptr to the beginning of all calling
            sequences for consistency.
            Added dm_specification_head.incl.pl1, dm_range_constants.incl.pl1.
            Changed basic searching technology with respect as follows:
            - each and-group is processed as a separate index and/or record
            search;
            - search_specifications are modified so as to exclude tuples found
            in previous and-group searches by toggling the NOT bit in the 
            operator codes;
            - if the desired number of tuples are found before the end of the
            relation is reached, the specification and cursor currently being
            used to search an index or record collection is maintained in the
            relation_cursor.
06/13/83 by Matthew Pierret:  Changed record_manager_$*_by_intervals to
            correctly be =$=_by_interval.
06/20/83 by Matthew Pierret:  Fixed incorrect ordering of arguments to
            record_manager_$get_ids_by_interval.
06/22/83 by Lindsey L. Spratt:  Moved SEARCH_RECORD_COLLECTION and
            SEARCH_INDEX into internal procedures.  Fixed AND_GROUP_LOOP to
            continue searching with the next and_group if the current
            and_group selects no tuples.
06/23/83 by Lindsey L. Spratt:  Fixed $get_duplicate_key_count to recognize
            p_number_of_duplicate_fields = -1 as a request for a count of all
            of the keys (available as the 0-th element in the
            key_count_array).  Also, changed myname to "rlm_general_search".
            Changed to handle relative searches better.  The search_spec was
            being re-used without paying attention to whether the field_ids
            were left set up for an index search or a record search.  This
            caused problems with a relative search which involved an index
            (whether or not there was also a record search).
07/30/83 by Matthew Pierret:  Made to free the old internal specification
            when resetting the cursor. Changed to allocate and copy the values
            in the relation_search_specification for use by the internal
            search_specification, rather than just making ss.value_ptr
            point to the same place as rss.value_ptr.  This is because the 
            values are used accross calls, and the caller might free the values
            and allocate new ones between calls.
08/11/83 by Matthew Pierret:  Removed the SET_CURRENT_NUMBER_OF_AND_GROUPS
            subroutine, replacing it with all 3 lines in-line.
            Made to free values copied for the internal search_specification.
            Removed attempts to not return data from the same tuple more than
            once.  Right now MRDS doesn't assume that we do, so why bother?
            ****                                                         ****
            **** Later, we will have to change this to strip duplicates. ****
            ****                                                         ****
            Changed to not copy specification values until the cursor is reset.
            This eliminates unnecessray copying. Changed SEARCH_INDEX and
            SEARCH_RECORD_COLLECTION to use a local code. Changed to allow
            an internal search_specification to have 0 and-groups.
09/13/83 by Matthew Pierret:  Removed $get_duplicate_key_count (moved it to
            rlm_get_approximate_count)
09/16/83 by Matthew Pierret:  Added frees of typed_vector_arrays and
            element_id_lists throughout much of the code.  Failure to free
            these structures and the structures to which they point was
            causing a great deal of extra space to hang around past its
            welcome. Added frees of interval_lists.            
01/19/84 by Matthew Pierret:  Changed FINISH to never free constraint values
            in the internal_specification because these values are actually
            the values pointed to by the caller's
            relation_search_specification.  These constraint values are only
            copied into the relation_manager_'s work area when resetting the
            cursor.
01/23/84 by Matthew Pierret:  Changed FINISH to correctly null
            return_eil_or_tva_array.ptr instead of return_eil_or_tva_array_ptr
            after freeing each typed_vector_array.
04/13/84 by Lee Baldwin:  Some of the record_manager_ entrypoints have been
            renamed, and their calling sequences changed (*): get_records_by_id_list(*),
            get_records_and_ids_by_spec(*), get_records_by_spec(*), get_record_ids_by_spec,
            get_record_ids_by_interval.
04/27/84 by Lee Baldwin:  Changed the calling sequence of
            record_manager_$get_record_bount_by_interval which no longer takes
            a work_area_ptr.  
05/02/84 by Lee Baldwin:  Changed name of index_manager_$get_count to 
            $get_key_count_by_spec.
05/08/84 by Matthew Pierret:  Changed to free typed_vector_arrays with the
            internal procedure FREE_TYPED_VECTOR_ARRAY.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.  Made
            temporary fix to restrict the maximum number of tuples to accept
            to that which can be held in a fixed bin (17) value.  This should
            be changed to fixed bin (35) by changing the declaration of
            range.size and range_size in the specification structures.
06/07/84 by Lee Baldwin:  Renamed dm_error_$rel_cursor_pos_bad to
            $bad_rel_cursor_pos.
10/28/84 by Lindsey L. Spratt:  Changed to use version 2 interval_list, and to
            check the version of this structure.
11/02/84 by Stanford S.  Cox: MAIN: Added version check of relation_cursor,
            chg to copy parameters.  FINISH: Chg to call FREE_SPEC*, add free
            of structures alloc in RETURN*.  FREE_SPEC*: Chg to also free
            numeric specs.  COPY_VALUE: Removed based clause from
            cv_value_string dcl.  SETUP_INT_SPEC: Asgn. MAX_FB35_VALUE to
            max_#_tuples.  RTVL: Chg.  typed_vector_list_ptr check to be an
            if-then-else, moved typed_vector_list to MAIN.  RTVA: Chg.
            typed_vector_array_ptr check to be an if-then-else, added
            typed_vector_array version check, chg.  tva to use explicit ptr
            refs so local tva not reqd.  REIL: Chg.  element_id_list check to
            be an if-then-else, chg.  eil to use explicit ptr refs so local
            eil not reqd.  
11/30/84 by Stanford S. Cox: RECORD_DATA: Chg nested if structure which calls
	  RECORD*RETURN. FTVA: Chg to return if tva_ptr is null. SI: Chg to
	  free eil. SIC: Chg to delete sic_cursor_ptr if ^null. RTVA: Add
	  call to sub_err.
12/02/84 by Lindsey L. Spratt:  Changed to use dm_vector_util_ instead of
            vector_util_.
12/08/84 by Lindsey L. Spratt:  Renamed dm_error_$rel_cursor_pos_bad to
            $bad_rel_cursor_pos.
01/17/84 by Stanford S. Cox: FINISH: Chg to free internal spec instead of
	  calling FREE_SPECIFICATION.
03/01/85 by S. Cox: Removed declared & unreferenced variables.
03/10/85 by Lindsey Spratt: Fixed to FINISH to check
	  local_typed_vector_array_ptr ^= null (instead of
	  local_typed_vector_list_ptr ^= null) before freeing
	  the local_typed_vector_array.
03/11/85 by Lindsey L. Spratt:  Fixed RETURN_TYPED_VECTOR_ARRAY to set the
            number_of_vectors in the output tva (pointed at by
            rtva_typed_vector_array_ptr).
03/19/85 by Lindsey L. Spratt:  Fixed to handle the TUPLE_ID_FIELD_ID when
            doing a get for which all of the desired fields are in the index
            being searched.
*/

/* format: style2,ind3 */

rlm_general_search:
   proc ();
      return;					/* Not a legal entry. */

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

      dcl	    p_specification_ptr    ptr parameter;
      dcl	    p_caller_area_ptr      ptr parameter;
      dcl	    p_id_list_ptr	       ptr parameter;
      dcl	    p_relation_cursor_ptr  ptr parameter;
      dcl	    p_element_id_list_ptr  ptr parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_typed_vector_list_ptr
			       ptr parameter;
      dcl	    p_tuple_count	       fixed bin (35) parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (local_typed_vector_list_ptr, local_typed_vector_array_ptr, local_element_id_list_ptr)
			       ptr;

      dcl	    (caller_area_ptr, interval_element_id_list_ptr, old_search_specification_ptr, internal_specification_ptr,
	    internal_cursor_ptr, internal_record_cursor_ptr, return_eil_or_tva_array_ptr, return_tva_array_ptr)
			       ptr init (null);

      dcl	    (current_collection_id, previous_collection_id)
			       bit (36) aligned init ("0"b);

      dcl	    (current_index_idx, record_id_idx, index_id_idx, element_idx, current_and_group_idx, and_group_idx,
	    return_structure_idx)  fixed bin;

      dcl	    (maximum_number_of_tuples_to_accept, number_of_and_groups, number_of_tuples_accepted,
	    number_of_tuples_accepted_by_this_and_group, reota_number_of_entries, rta_number_of_entries)
			       fixed bin (35) init (0);

      dcl	    (all_desired_fields_are_in_index, get_id, get_typed_vector_list, get_tuple, get_tuples_and_ids, get_count,
	    search_records, is_search_specification, is_numeric_specification, is_relative_specification, found_tuple)
			       bit (1) aligned init ("0"b);

      dcl	    1 local_relation_cursor
			       aligned like relation_cursor;

      dcl	    1 local_id_list,
	      2 version	       fixed bin (35),
	      2 number_of_ids      fixed bin (17),
	      2 id	       (1) fixed bin (17);

      dcl	    1 local_return_eil_or_tva_entry
			       (1) like return_eil_or_tva_array;
						/* used if only 1 entry of return= needed */

      dcl	    1 local_return_tva_entry
			       (1) like return_tva_array;
						/* used if only 1 entry of return= needed */

/* Based */

      dcl	    work_area	       area (1024) based (work_area_ptr);
      dcl	    caller_area	       area (1024) based (caller_area_ptr);
      dcl	    based_bit_36_aligned   bit (36) aligned based;
      dcl	    1 return_eil_or_tva_array
			       (reota_number_of_entries) aligned based (return_eil_or_tva_array_ptr),
	      2 flags	       unal,
	        3 is_element_id_list
			       bit (1) unal,
	        3 mbz	       bit (71) unal,
	      2 ptr	       ptr;

      dcl	    1 return_tva_array     (rta_number_of_entries) aligned based (return_tva_array_ptr),
	      2 ptr	       ptr;

/* Builtin */

      dcl	    (addr, hbound, max, min, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    myname	       init ("rlm_general_search") char (32) varying,
	    BITS_PER_BYTE	       init (9) fixed bin,
	    BITS_PER_WORD	       init (36) fixed bin,
	    MAX_FB17_VALUE	       init (131071) fixed bin,
	    MAXIMUM_FB35_VALUE     init (3e10) fixed bin (35),
	    TUPLE_ID_FIELD_ID      init (-1) fixed bin (35)
	    )		       internal static options (constant);
      dcl	    (
	    IS_ELEMENT_ID_LIST     init ("1"b),
	    IS_TYPED_VECTOR_ARRAY  init ("0"b),
	    IS_RECORD_COLLECTION   init ("1"b),
	    IS_INDEX_COLLECTION    init ("0"b),
	    USE_RELATION_CURSOR    init ("1"b),
	    USE_PREVIOUS_CURSOR    init ("0"b)
	    )		       bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    dm_vector_util_$copy_typed_vector
			       entry (ptr, ptr, ptr, ptr, fixed bin (35));

/* External */

      dcl	    (
	    dm_error_$bad_rel_cursor_pos,
	    dm_error_$index_not_in_relation,
	    dm_error_$key_not_found,
	    dm_error_$programming_error,
	    dm_error_$record_not_found,
	    dm_error_$rel_cursor_spec_mismatch,
	    dm_error_$tuple_not_found,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext;

/* Static */

      dcl	    work_area_ptr	       ptr init (null) internal static;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

get_list_by_spec:
   entry (p_relation_cursor_ptr, p_specification_ptr, p_id_list_ptr, p_caller_area_ptr, p_typed_vector_list_ptr, p_code);
      get_tuple = "1"b;
      get_typed_vector_list = "1"b;
      caller_area_ptr = p_caller_area_ptr;
      local_typed_vector_list_ptr = p_typed_vector_list_ptr;
      if p_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("id_list", p_id_list_ptr -> id_list.version, (ID_LIST_VERSION_1));
      goto JOIN;

get_array_by_spec:
   entry (p_relation_cursor_ptr, p_specification_ptr, p_id_list_ptr, p_caller_area_ptr, p_typed_vector_array_ptr, p_code);
      get_tuple = "1"b;
      get_typed_vector_list = "0"b;
      caller_area_ptr = p_caller_area_ptr;
      local_typed_vector_array_ptr = p_typed_vector_array_ptr;
      if p_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("id_list", p_id_list_ptr -> id_list.version, (ID_LIST_VERSION_1));
      goto JOIN;


get_id:
   entry (p_relation_cursor_ptr, p_specification_ptr, p_caller_area_ptr, p_element_id_list_ptr, p_code);
      get_id = "1"b;
      caller_area_ptr = p_caller_area_ptr;
      local_element_id_list_ptr = p_element_id_list_ptr;
      if p_element_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("element_id_list", p_element_id_list_ptr -> element_id_list.version,
	      ELEMENT_ID_LIST_VERSION_1);
      goto JOIN;

get_count:
   entry (p_relation_cursor_ptr, p_specification_ptr, p_tuple_count, p_code);
      get_count = "1"b;
      caller_area_ptr = null;
      goto JOIN;

get_list_and_ids:
   entry (p_relation_cursor_ptr, p_specification_ptr, p_id_list_ptr, p_caller_area_ptr, p_element_id_list_ptr,
        p_typed_vector_list_ptr, p_code);

      get_tuples_and_ids = "1"b;
      get_typed_vector_list = "1"b;
      caller_area_ptr = p_caller_area_ptr;
      local_typed_vector_list_ptr = p_typed_vector_list_ptr;
      local_element_id_list_ptr = p_element_id_list_ptr;
      if p_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("id_list", p_id_list_ptr -> id_list.version, (ID_LIST_VERSION_1));
      if p_element_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("element_id_list", p_element_id_list_ptr -> element_id_list.version,
	      ELEMENT_ID_LIST_VERSION_1);
      goto JOIN;

get_array_and_ids:
   entry (p_relation_cursor_ptr, p_specification_ptr, p_id_list_ptr, p_caller_area_ptr, p_element_id_list_ptr,
        p_typed_vector_array_ptr, p_code);

      get_tuples_and_ids = "1"b;
      get_typed_vector_list = "0"b;
      caller_area_ptr = p_caller_area_ptr;
      local_typed_vector_array_ptr = p_typed_vector_array_ptr;
      local_element_id_list_ptr = p_element_id_list_ptr;
      if p_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("id_list", p_id_list_ptr -> id_list.version, (ID_LIST_VERSION_1));
      if p_element_id_list_ptr ^= null
      then call CHECK_VERSION_FB ("element_id_list", p_element_id_list_ptr -> element_id_list.version,
	      ELEMENT_ID_LIST_VERSION_1);

      goto JOIN;
%page;
JOIN:
      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_VERSION ("relation_cursor", relation_cursor.version, RELATION_CURSOR_VERSION_2);
      if work_area_ptr = null
      then work_area_ptr = get_dm_free_area_ ();

      id_list_ptr, element_id_list_ptr, typed_vector_array_ptr, relation_search_specification_ptr,
	 search_specification_ptr, relation_numeric_specification_ptr, numeric_specification_ptr,
	 internal_specification_ptr, internal_cursor_ptr = null;

      specification_head_ptr = p_specification_ptr;
      if specification_head_ptr ^= null
      then
         do;
	  call CHECK_VERSION_FB ("specification", specification_head.version, SPECIFICATION_VERSION_4);


	  if specification_head.type = ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE
	       | specification_head.type = RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE
	  then
	     do;
	        is_search_specification = "1"b;
	        relation_search_specification_ptr = specification_head_ptr;
	     end;
	  else if specification_head.type = ABSOLUTE_RELATION_NUMERIC_SPECIFICATION_TYPE
	       | specification_head.type = RELATIVE_RELATION_NUMERIC_SPECIFICATION_TYPE
	  then
	     do;
	        is_numeric_specification = "1"b;
	        relation_numeric_specification_ptr = specification_head_ptr;
	     end;

	  if specification_head.type = RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE
	       | specification_head.type = RELATIVE_RELATION_NUMERIC_SPECIFICATION_TYPE
	  then is_relative_specification = "1"b;
         end;

/**** Set up opening information structures. */

      call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      attribute_info_ptr = relation_opening_info.attribute_info_ptr;
      call CHECK_VERSION ("attribute_info", attribute_info.version, ATTRIBUTE_INFO_VERSION_1);

      index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
      call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);

/**** Set up current state of search. */

      if is_search_specification
      then number_of_and_groups = relation_search_specification.number_of_and_groups;
      else number_of_and_groups = 1;

      call CHECK_CURSOR_STATE (is_relative_specification, is_search_specification, is_numeric_specification,
	 current_and_group_idx);			/* Also returns current_and_group_idx */

      on cleanup call FINISH ();

      call SETUP_INTERNAL_SPECIFICATION (is_search_specification, is_numeric_specification, is_relative_specification,
	 internal_specification_ptr, maximum_number_of_tuples_to_accept);
						/* Returns internal_specification_ptr, maximum...accept */
      call SETUP_RETURN_STRUCTURES (max (1, number_of_and_groups), (get_id | get_tuples_and_ids),
	 (get_tuple | get_tuples_and_ids), return_eil_or_tva_array_ptr, return_tva_array_ptr);

AND_GROUP_LOOP:
      do and_group_idx = current_and_group_idx to number_of_and_groups
	 while (number_of_tuples_accepted < maximum_number_of_tuples_to_accept);

      /*** Satisfy the constraints of each and-group. */

         search_records = "0"b;

         previous_collection_id = current_collection_id;
         call SET_CURRENT_COLLECTION_ID (is_search_specification, is_numeric_specification, and_group_idx,
	    current_collection_id, current_index_idx);	/* Set the collection_id from the specification. */

         if is_relative_specification & and_group_idx = current_and_group_idx
         then
	  do;

	  /*** This is the first and-group of a relative specification to be processed.
	       Use the internal cursor already present in the relation_cursor. */

	     call SETUP_INTERNAL_CURSOR (USE_RELATION_CURSOR, (current_index_idx = -1), current_collection_id, ("0"b),
		internal_cursor_ptr);
	  end;
         else
	  do;

	  /*** This is not a relative search, or this is not the first and-group processed.
	       Setup a cursor and a specification to satisfy the constraints of this and-group.
	       Re-use the previous internal cursor if the same collection is being searched. */

	     call SETUP_INTERNAL_CURSOR (USE_PREVIOUS_CURSOR, (current_index_idx = -1), current_collection_id,
		previous_collection_id, internal_cursor_ptr);
						/* Get an index or record cursor for the current collection. */

	     call SETUP_INTERNAL_SPECIFICATION_FOR_THIS_AND_GROUP (internal_specification_ptr, and_group_idx,
		is_search_specification, is_numeric_specification,
		(maximum_number_of_tuples_to_accept - number_of_tuples_accepted));
						/* Convert this and-group into a proper internal specification. */
	  end;

         if current_index_idx = -1
         then call SEARCH_RECORD_COLLECTION (found_tuple);
         else call SEARCH_INDEX (found_tuple);

         if found_tuple
         then
RECORD_DATA:
	  do;
	     return_structure_idx = max (1, and_group_idx);

	     if get_id
	     then if search_records
		then call RECORD_IDS_TO_RETURN (IS_ELEMENT_ID_LIST, return_structure_idx, element_id_list_ptr,
			number_of_tuples_accepted_by_this_and_group);
		else if get_tuples_and_ids
		then call RECORD_IDS_TO_RETURN (IS_ELEMENT_ID_LIST, return_structure_idx, element_id_list_ptr,
			number_of_tuples_accepted_by_this_and_group);
		else call RECORD_IDS_TO_RETURN (IS_TYPED_VECTOR_ARRAY, return_structure_idx, typed_vector_array_ptr,
			number_of_tuples_accepted_by_this_and_group);
	     else if get_tuple
	     then call RECORD_TUPLES_TO_RETURN (return_structure_idx, typed_vector_array_ptr,
		     number_of_tuples_accepted_by_this_and_group);
	     else if get_tuples_and_ids
	     then
	        do;
		 if search_records
		 then call RECORD_IDS_TO_RETURN (IS_ELEMENT_ID_LIST, return_structure_idx, element_id_list_ptr,
			 number_of_tuples_accepted_by_this_and_group);
		 else if get_tuples_and_ids
		 then call RECORD_IDS_TO_RETURN (IS_ELEMENT_ID_LIST, return_structure_idx, element_id_list_ptr,
			 number_of_tuples_accepted_by_this_and_group);
		 else call RECORD_IDS_TO_RETURN (IS_TYPED_VECTOR_ARRAY, return_structure_idx, typed_vector_array_ptr,
			 number_of_tuples_accepted_by_this_and_group);
		 call RECORD_TUPLES_TO_RETURN (return_structure_idx, typed_vector_array_ptr,
		      number_of_tuples_accepted_by_this_and_group);
	        end;

	     number_of_tuples_accepted = number_of_tuples_accepted + number_of_tuples_accepted_by_this_and_group;
	  end RECORD_DATA;

      end AND_GROUP_LOOP;

      and_group_idx = and_group_idx - 1;

      if ^get_count
      then if number_of_tuples_accepted = 0
	 then p_code = dm_error_$tuple_not_found;
	 else
	    do;
	       if get_tuple | get_tuples_and_ids
	       then if get_typed_vector_list
		  then call RETURN_TYPED_VECTOR_LIST (number_of_tuples_accepted, local_typed_vector_list_ptr);
		  else call RETURN_TYPED_VECTOR_ARRAY (number_of_tuples_accepted, local_typed_vector_array_ptr);

	       if get_id | get_tuples_and_ids
	       then call RETURN_ELEMENT_ID_LIST (number_of_tuples_accepted, local_element_id_list_ptr);

	       call RESET_CURSOR (and_group_idx, current_collection_id, internal_specification_ptr, search_records,
		  internal_cursor_ptr, is_search_specification);
	    end;

      if get_typed_vector_list
      then p_typed_vector_list_ptr = local_typed_vector_list_ptr;
      if get_id | get_tuples_and_ids
      then p_element_id_list_ptr = local_element_id_list_ptr;
      if (get_tuple | get_tuples_and_ids) & ^get_typed_vector_list
      then p_typed_vector_array_ptr = local_typed_vector_array_ptr;
      call FINISH;
RETURN:
      return;
%page;
FINISH:
   proc;

      dcl	    f_tva_idx	       fixed bin;

      if get_typed_vector_list
      then if p_typed_vector_list_ptr = null & local_typed_vector_list_ptr ^= null
	 then free local_typed_vector_list_ptr -> typed_vector_list;
      if get_id | get_tuples_and_ids
      then if p_element_id_list_ptr = null & local_element_id_list_ptr ^= null
	 then free local_element_id_list_ptr -> element_id_list;
      if (get_tuple | get_tuples_and_ids) & ^get_typed_vector_list
      then if p_typed_vector_array_ptr = null & local_typed_vector_array_ptr ^= null
	 then free local_typed_vector_array_ptr -> typed_vector_array;

      if typed_vector_array_ptr ^= null
      then call FREE_TYPED_VECTOR_ARRAY (typed_vector_array_ptr);

      if id_list_ptr ^= null & id_list_ptr ^= addr (local_id_list) & id_list_ptr ^= p_id_list_ptr
      then free id_list in (work_area);

      if element_id_list_ptr ^= null
      then free element_id_list in (work_area);

      if interval_element_id_list_ptr ^= null
      then free interval_element_id_list_ptr -> element_id_list in (work_area);

      if interval_list_ptr ^= null
      then call FREE_INTERVAL_LIST (interval_list_ptr);

      if relation_cursor.flags.current_state_is_consistent
      then
         do;
	  if internal_specification_ptr ^= null
	       & internal_specification_ptr ^= relation_cursor.current.specification_ptr
	  then if is_numeric_specification
	       then free internal_specification_ptr -> numeric_specification in (work_area);
	       else free internal_specification_ptr -> search_specification;

	  if internal_cursor_ptr ^= null & internal_cursor_ptr ^= relation_cursor.current.cursor_ptr
	  then if current_collection_id = relation_header.record_collection_id
	       then call record_manager_$destroy_cursor (internal_cursor_ptr, (0));
	       else call index_manager_$destroy_cursor (internal_cursor_ptr, (0));
         end;

      if internal_record_cursor_ptr ^= null & internal_record_cursor_ptr ^= relation_cursor.current.cursor_ptr
      then call record_manager_$destroy_cursor (internal_record_cursor_ptr, (0));

      if return_tva_array_ptr ^= null
      then
         do;
	  do f_tva_idx = 1 to hbound (return_tva_array, 1);
	     if return_tva_array (f_tva_idx).ptr ^= null
	     then call FREE_TYPED_VECTOR_ARRAY (return_tva_array (f_tva_idx).ptr);
	  end;
	  if return_tva_array_ptr ^= addr (local_return_tva_entry)
	  then free return_tva_array in (work_area);
         end;

      if return_eil_or_tva_array_ptr ^= null
      then
         do;
	  do f_tva_idx = 1 to hbound (return_eil_or_tva_array, 1);
	     if return_eil_or_tva_array (f_tva_idx).ptr ^= null
	     then if return_eil_or_tva_array (f_tva_idx).flags.is_element_id_list
		then free return_eil_or_tva_array (f_tva_idx).ptr -> element_id_list;
		else call FREE_TYPED_VECTOR_ARRAY (return_eil_or_tva_array (f_tva_idx).ptr);
	  end;
	  if return_eil_or_tva_array_ptr ^= addr (local_return_eil_or_tva_entry)
	  then free return_eil_or_tva_array in (work_area);
	  else return_eil_or_tva_array_ptr = null;
         end;

   end FINISH;

ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      call FINISH;
      goto RETURN;


   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_structure_name, cv_received_version, cv_expected_version);
      dcl	    cv_received_version    char (8) aligned;
      dcl	    cv_expected_version    char (8) aligned;
      dcl	    cv_structure_name      char (*);

      if cv_received_version ^= cv_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a instead.", cv_expected_version, cv_structure_name, cv_received_version);

   end CHECK_VERSION;


CHECK_VERSION_FB:
   proc (cvf_structure_name, cvf_received_version, cvf_expected_version);
      dcl	    cvf_received_version   fixed bin (35);
      dcl	    cvf_expected_version   fixed bin (35);
      dcl	    cvf_structure_name     char (*);

      if cvf_received_version ^= cvf_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", cvf_expected_version, cvf_structure_name, cvf_received_version);

   end CHECK_VERSION_FB;
%page;
CHECK_CURSOR_STATE:
   proc (ccs_is_relative_specification, ccs_is_search_specification, ccs_is_numeric_specification, ccs_and_group_idx);

      dcl	    ccs_and_group_idx      fixed bin;
      dcl	    ccs_is_relative_specification
			       bit (1) aligned;
      dcl	    ccs_is_search_specification
			       bit (1) aligned;
      dcl	    ccs_is_numeric_specification
			       bit (1) aligned;

      call CHECK_VERSION ("relation_cursor", relation_cursor.version, RELATION_CURSOR_VERSION_2);

      if ccs_is_relative_specification
      then
CCS_RELATIVE_CURSOR_CHECK:
         do;
	  if ^relation_cursor.flags.current_state_is_consistent
	  then call sub_err_ (dm_error_$bad_rel_cursor_pos, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The relative specification cannot be satisfied because the relation cursor^/does not completely describe a current position."
		  );

	  if relation_cursor.current.cursor_ptr = null
	  then call sub_err_ (dm_error_$bad_rel_cursor_pos, myname, ACTION_CANT_RESTART, null, 0,
		  "^/The relative specification cannot be satisfied because the relation cursor^/does not completely describe a current position."
		  );

	  if ccs_is_numeric_specification
	  then
	     do;
	        if relation_cursor.current.specification_ptr = null
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/Expected a numeric specification; received a null specification.");
	        if relation_cursor.current.specification_ptr -> specification_head.type
		   ^= ABSOLUTE_NUMERIC_SPECIFICATION_TYPE
		   & relation_cursor.current.specification_ptr -> specification_head.type
		   ^= RELATIVE_NUMERIC_SPECIFICATION_TYPE
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/Expected a search specification; received a numeric specification.");
	        if relation_numeric_specification.collection_id ^= relation_cursor.current.collection_id
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/Expected a specification for collection ^.3bo; received one for ^.3bo.",
		        relation_cursor.current.collection_id, relation_numeric_specification.collection_id);
	     end;
	  else if ccs_is_search_specification
	  then
	     do;
	        if relation_cursor.current.specification_ptr = null
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/Expected a search specification; received a null specification.");
	        if relation_cursor.current.specification_ptr -> specification_head.type
		   ^= ABSOLUTE_SEARCH_SPECIFICATION_TYPE
		   & relation_cursor.current.specification_ptr -> specification_head.type
		   ^= RELATIVE_SEARCH_SPECIFICATION_TYPE
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/Expected a numeric specification; received a search specification.");
	        if (relation_search_specification.number_of_and_groups > 0 & relation_cursor.current.and_group_idx < 1)
		   | relation_cursor.current.and_group_idx > relation_search_specification.number_of_and_groups
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/The current and-group is ^d; the given search specification has^/^[no^s^;^d^] and-group^[s^].",
		        relation_cursor.current.and_group_idx,
		        (relation_search_specification.number_of_and_groups = 0),
		        relation_search_specification.number_of_and_groups,
		        (relation_search_specification.number_of_and_groups ^= 1));
	        ;
	        if relation_search_specification.and_group (relation_cursor.current.and_group_idx).flags
		   .collection_id_supplied
	        then if relation_search_specification.and_group (relation_cursor.current.and_group_idx)
		        .search_collection_id ^= relation_cursor.current.collection_id
		   then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
			   "^/Expected a specification for collection ^.3bo; received one for ^.3bo.",
			   relation_cursor.current.collection_id,
			   relation_search_specification.and_group (relation_cursor.current.and_group_idx)
			   .search_collection_id);
		   else ;
	        else if relation_cursor.current.collection_id ^= relation_header.record_collection_id
	        then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		        "^/Expected a specification for collection ^.3bo; received on with no^/collection specified.",
		        relation_cursor.current.collection_id);
	     end;
	  else if relation_cursor.current.specification_ptr ^= null
	  then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Expected a non-null specification; received a null specification.");

	  ccs_and_group_idx = relation_cursor.current.and_group_idx;
         end CCS_RELATIVE_CURSOR_CHECK;
      else if ccs_is_search_specification
      then ccs_and_group_idx = min (1, relation_search_specification.number_of_and_groups);
      else ccs_and_group_idx = 1;

      return;

   end CHECK_CURSOR_STATE;
%page;
CV_SEARCH_SPECIFICATION_FOR_INDEX:
   proc (cssfi_number_of_fields, cssfi_index_idx, cssfi_search_specification_ptr, cssfi_search_records);

/* This subroutine converts the attribute_ids in the internal specification
   into field_ids for the given index.  If an attribute is not a field in a
   key, the attribute_id is negated.  This tells inex_manager_ to ignore
   the constraint.  If constraint.value_field_id is -1 (indicating no
   value_field_id) or if value_field_id and field_id are in the index, then
   both are translated.  Otherwise, the value of value_field_id is left
   unchanged and the value of field_id is negated.  Reference is made to
   and_group (1) since an internal_specification contains only one and group.

   As a side-effect, this subroutine also
   determines if the search can be satisfied entirely by searching the index,
   or if it is necessry to also search the records. */

      dcl	    cssfi_number_of_fields fixed bin parameter;
      dcl	    cssfi_index_idx	       fixed bin parameter;
      dcl	    cssfi_search_specification_ptr
			       ptr parameter;
      dcl	    cssfi_search_records   bit (1) aligned parameter;

      dcl	    cssfi_field_map	       (cssfi_number_of_fields) fixed bin;
      dcl	    (cssfi_field_id, cssfi_value_field_id, cssfi_temp_value_field_id)
			       fixed bin init (0);
      dcl	    (cssfi_field_idx, cssfi_constraint_idx, cssfi_index_field_idx)
			       fixed bin;

      search_specification_ptr = cssfi_search_specification_ptr;

      do cssfi_field_idx = 1 to cssfi_number_of_fields;
         cssfi_field_map (cssfi_field_idx) = -cssfi_field_idx;
      end;

      do cssfi_index_field_idx = 1 to index_attribute_map.index (cssfi_index_idx).number_of_attributes;
         cssfi_field_map (index_attribute_map.index (cssfi_index_idx).attribute_id (cssfi_index_field_idx)) =
	    cssfi_index_field_idx;
      end;

      cssfi_search_records = "0"b;

      do cssfi_constraint_idx = 1 to search_specification.and_group (1).number_of_constraints;
         cssfi_field_id = cssfi_field_map (search_specification.and_group (1).constraint (cssfi_constraint_idx).field_id);
         cssfi_value_field_id = search_specification.and_group (1).constraint (cssfi_constraint_idx).value_field_id;

         if cssfi_value_field_id <= 0
         then
	  do;
	     search_specification.and_group (1).constraint (cssfi_constraint_idx).field_id = cssfi_field_id;
	     if cssfi_field_id < 0
	     then cssfi_search_records = "1"b;
	  end;
         else
	  do;
	     cssfi_temp_value_field_id = cssfi_field_map (cssfi_value_field_id);
	     if cssfi_temp_value_field_id > 0 & cssfi_field_id > 0
	     then
	        do;
		 search_specification.and_group (1).constraint (cssfi_constraint_idx).field_id = cssfi_field_id;
		 search_specification.and_group (1).constraint (cssfi_constraint_idx).value_field_id =
		      cssfi_temp_value_field_id;
	        end;
	     else
	        do;
		 search_specification.and_group (1).constraint (cssfi_constraint_idx).field_id =
		      -(search_specification.and_group (1).constraint (cssfi_constraint_idx).field_id);
		 cssfi_search_records = "1"b;
	        end;
	  end;
      end;

   end CV_SEARCH_SPECIFICATION_FOR_INDEX;
%page;
CV_SEARCH_SPECIFICATION_FOR_RECORDS:
   proc (cssfr_search_specification_ptr);

/* This routine converts the field_ids in the internal specification into
   field_ids of record.  This routine is called to undo the effects of
   CV_SEARCH_SPECIFICATION_FOR_INDEX by simply negating the field_ids.
   On input, the constraints which were not satisfied by the index search
   have negative field_ids; those that were have positive field_ids.
   This routine switches the sign of the field_ids so that those constraints
   that were satisfied by the index search will be ignored, and those that
   were previously ignored will be satisfied.  value_field_ids are not changed
   because value_field_ids for un-satisfied constraints were never negated. */

      dcl	    cssfr_search_specification_ptr
			       ptr parameter;

      dcl	    cssfr_constraint_idx   fixed bin;

INVERT_SEARCH_SPECIFICATION:
   entry (cssfr_search_specification_ptr);

      do cssfr_constraint_idx = 1
	 to cssfr_search_specification_ptr -> search_specification.and_group (1).number_of_constraints;
         cssfr_search_specification_ptr -> search_specification.and_group (1).constraint (cssfr_constraint_idx).field_id =
	    -cssfr_search_specification_ptr
	    -> search_specification.and_group (1).constraint (cssfr_constraint_idx).field_id;
      end;

   end CV_SEARCH_SPECIFICATION_FOR_RECORDS;
%page;
COPY_VALUE:
   proc (cv_arg_descriptor_ptr, cv_source_value_ptr, cv_target_value_ptr);

      dcl	    cv_arg_descriptor_ptr  ptr parameter;
      dcl	    cv_source_value_ptr    ptr parameter;
      dcl	    cv_target_value_ptr    ptr parameter;
      dcl	    cv_value_string_size   fixed bin (35) init (0);
      dcl	    cv_value_string	       bit (cv_value_string_size) based;
      dcl	    cv_based_real_fix_bin_1u
			       fixed bin (35) unal based;
      dcl	    cv_code	       fixed bin (35) init (0);

      dcl	    data_format_util_$get_data_bit_length
			       entry (bit (36) aligned, fixed bin (35), fixed bin (35));

      arg_descriptor_ptr = cv_arg_descriptor_ptr;
      if arg_descriptor.type = varying_char_dtype
      then cv_value_string_size = cv_source_value_ptr -> cv_based_real_fix_bin_1u * BITS_PER_BYTE + BITS_PER_WORD;
      else if arg_descriptor.type = varying_bit_dtype
      then cv_value_string_size = cv_source_value_ptr -> cv_based_real_fix_bin_1u + BITS_PER_WORD;
      else call data_format_util_$get_data_bit_length (unspec (arg_descriptor), cv_value_string_size, cv_code);
      if cv_code ^= 0
      then call ERROR_RETURN (cv_code);
      alloc cv_value_string in (relation_cursor.work_area_ptr -> work_area) set (cv_target_value_ptr);
      cv_target_value_ptr -> cv_value_string = cv_source_value_ptr -> cv_value_string;

      return;


%include std_descriptor_types;
%include arg_descriptor;

   end COPY_VALUE;
%page;
FREE_INTERVAL_LIST:
   proc (fil_p_interval_list_ptr);

      dcl	    fil_p_interval_list_ptr
			       ptr;
      dcl	    fil_interval_idx       fixed bin;

      if fil_p_interval_list_ptr ^= null
      then
         do;
	  do fil_interval_idx = 1 to hbound (fil_p_interval_list_ptr -> interval_list.interval, 1);
	     if fil_p_interval_list_ptr -> interval_list.interval (fil_interval_idx).and_group_id_list_ptr ^= null
	     then free fil_p_interval_list_ptr -> interval_list.interval (fil_interval_idx).and_group_id_list_ptr
		     -> id_list;
	  end;
	  free fil_p_interval_list_ptr -> interval_list;
         end;

      return;

   end FREE_INTERVAL_LIST;
%page;
FREE_SPECIFICATION:
   proc (fs_specification_ptr);

      dcl	    fs_specification_ptr   ptr parameter;
      dcl	    fs_and_group_idx       fixed bin init (-1);
      dcl	    fs_constraint_idx      fixed bin init (-1);
      dcl	    fs_dummy_value	       bit (1) based;

      if fs_specification_ptr -> specification_head.type = ABSOLUTE_NUMERIC_SPECIFICATION_TYPE
	 | fs_specification_ptr -> specification_head.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE
      then free fs_specification_ptr -> numeric_specification;
      else if fs_specification_ptr -> specification_head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE
	 | fs_specification_ptr -> specification_head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE
      then
         do;
	  do fs_and_group_idx = 1 to fs_specification_ptr -> search_specification.number_of_and_groups;
	     do fs_constraint_idx = 1
		to fs_specification_ptr -> search_specification.and_group (fs_and_group_idx).number_of_constraints;
	        free fs_specification_ptr
		   -> search_specification.and_group (fs_and_group_idx).constraint (fs_constraint_idx).value_ptr
		   -> fs_dummy_value;
	     end;
	  end;
         end;
      return;

   end FREE_SPECIFICATION;
%page;
FREE_TYPED_VECTOR_ARRAY:
   proc (ftva_typed_vector_array_ptr);

      dcl	    ftva_typed_vector_array_ptr
			       ptr parameter;
      dcl	    ftva_vector_ptr	       ptr;
      dcl	    ftva_vector_idx	       fixed bin;
      dcl	    ftva_value_idx	       fixed bin;
      dcl	    ftva_dummy_value       bit (1) based;

      if ftva_typed_vector_array_ptr ^= null ()
      then
         do;
	  do ftva_vector_idx = 1 to ftva_typed_vector_array_ptr -> typed_vector_array.number_of_vectors;
	     if ftva_typed_vector_array_ptr -> typed_vector_array.vector_slot (ftva_vector_idx) ^= null
	     then
	        do;
		 ftva_vector_ptr = ftva_typed_vector_array_ptr -> typed_vector_array.vector_slot (ftva_vector_idx);
		 if ftva_vector_ptr -> simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE
		 then
		    do;
		       do ftva_value_idx = 1 to ftva_vector_ptr -> simple_typed_vector.number_of_dimensions;
			if ftva_vector_ptr -> simple_typed_vector.value_ptr (ftva_value_idx) ^= null
			then
			   do;
			      free ftva_vector_ptr -> simple_typed_vector.value_ptr (ftva_value_idx)
				 -> ftva_dummy_value;
			      ftva_vector_ptr -> simple_typed_vector.value_ptr (ftva_value_idx) = null;
			   end;
		       end;

		       free ftva_vector_ptr -> simple_typed_vector;
		       ftva_typed_vector_array_ptr -> typed_vector_array.vector_slot (ftva_vector_idx) = null;
		    end;
	        end;
	  end;

	  free ftva_typed_vector_array_ptr -> typed_vector_array;
	  ftva_typed_vector_array_ptr = null;

	  return;
         end;

   end FREE_TYPED_VECTOR_ARRAY;
%page;
RECORD_IDS_TO_RETURN:
   proc (ritr_is_element_id_list, ritr_and_group_idx, ritr_eil_or_tva_ptr, ritr_number_of_tuple_ids);

/* This subroutine records the location of a data structure containing
   the tuple ids found by a particular and-group. The data structure is
   either an element_id_list or a typed_vector_array containing simple_typed_vectors of a single dimension. */

      dcl	    ritr_is_element_id_list
			       bit (1) aligned;
      dcl	    ritr_and_group_idx     fixed bin;
      dcl	    ritr_eil_or_tva_ptr    ptr;
      dcl	    ritr_number_of_tuple_ids
			       fixed bin (35);

      return_eil_or_tva_array (ritr_and_group_idx).flags.is_element_id_list = ritr_is_element_id_list;
      return_eil_or_tva_array (ritr_and_group_idx).ptr = ritr_eil_or_tva_ptr;

      if ritr_is_element_id_list
      then ritr_number_of_tuple_ids = ritr_eil_or_tva_ptr -> element_id_list.number_of_elements;
      else ritr_number_of_tuple_ids = ritr_eil_or_tva_ptr -> typed_vector_array.number_of_vectors;

      ritr_eil_or_tva_ptr = null;

      return;

   end RECORD_IDS_TO_RETURN;
%page;
RECORD_TUPLES_TO_RETURN:
   proc (rttr_and_group_idx, rttr_tva_ptr, rttr_number_of_tuples);

/* This subroutine records the location of typed_vector_array containing
   the tuples found by a particular and-group. */

      dcl	    rttr_and_group_idx     fixed bin;
      dcl	    rttr_tva_ptr	       ptr;
      dcl	    rttr_number_of_tuples  fixed bin (35);


      return_tva_array (rttr_and_group_idx).ptr = rttr_tva_ptr;

      rttr_number_of_tuples = rttr_tva_ptr -> typed_vector_array.number_of_vectors;

      rttr_tva_ptr = null;

      return;

   end RECORD_TUPLES_TO_RETURN;
%page;
RESET_CURSOR:
   proc (rc_and_group_idx, rc_collection_id, rc_specification_ptr, rc_search_records, rc_cursor_ptr,
        rc_is_search_specification);

/* This subroutine destroys information kept to maintain the previous
   current state, replacing with information about the new current state.
*/

      dcl	    rc_and_group_idx       fixed bin parameter;
      dcl	    rc_collection_id       bit (36) aligned parameter;
      dcl	    rc_specification_ptr   ptr parameter;
      dcl	    rc_search_records      bit (1) aligned parameter;
      dcl	    rc_cursor_ptr	       ptr parameter;
      dcl	    rc_is_search_specification
			       bit (1) aligned parameter;
      dcl	    rc_constraint_idx      fixed bin init (-1);
      dcl	    rc_value_ptr	       ptr init (null);
      dcl	    rc_code	       fixed bin (35) init (0);

      relation_cursor.flags.current_state_is_consistent = "0"b;

      if relation_cursor.current.cursor_ptr ^= null
      then if relation_cursor.current.cursor_ptr ^= rc_cursor_ptr
	 then if relation_cursor.current.collection_id = relation_header.record_collection_id
	      then call record_manager_$destroy_cursor (relation_cursor.current.cursor_ptr, rc_code);
	      else call index_manager_$destroy_cursor (relation_cursor.current.cursor_ptr, rc_code);

      if relation_cursor.current.specification_ptr ^= null
      then if rc_specification_ptr ^= relation_cursor.current.specification_ptr
	 then call FREE_SPECIFICATION (relation_cursor.current.specification_ptr);

      relation_cursor.current.and_group_idx = rc_and_group_idx;
      relation_cursor.current.collection_id = rc_collection_id;
      relation_cursor.current.specification_ptr = rc_specification_ptr;
      relation_cursor.current.search_index_and_record_collection = rc_search_records;
      relation_cursor.current.cursor_ptr = rc_cursor_ptr;

      if rc_specification_ptr ^= null & rc_is_search_specification & rc_and_group_idx > 0
      then
         do;

         /*** Copy values from relation_search_specification to internal specification. */

	  do rc_constraint_idx = 1 to relation_search_specification.and_group (rc_and_group_idx).number_of_constraints;
	     call COPY_VALUE (
		addr (attribute_info
		.
		attribute (relation_search_specification.and_group (rc_and_group_idx).constraint (rc_constraint_idx)
		.field_id).descriptor),
		relation_search_specification.and_group (rc_and_group_idx).constraint (rc_constraint_idx).value_ptr,
		rc_value_ptr);
	     rc_specification_ptr -> search_specification.and_group (1).constraint (rc_constraint_idx).value_ptr =
		rc_value_ptr;
	  end;
         end;

      rc_cursor_ptr, rc_specification_ptr = null;

      if rc_code = 0
      then relation_cursor.flags.current_state_is_consistent = "1"b;

      return;

   end RESET_CURSOR;
%page;
SEARCH_INDEX:
   proc (si_p_found_tuple);

      dcl	    si_p_found_tuple       bit (1) aligned parameter;
      dcl	    si_code	       fixed bin (35) init (0);

   /*** An index collection was specified. As much of the internal specification as possible
        will be satisfied by searching the index. If fields are constrained which
        are not in the index, then the record collection will also be searched. */



      if is_search_specification & internal_specification_ptr ^= null
      then if is_relative_specification & and_group_idx = current_and_group_idx
	 then
	    do;
	       search_records = relation_cursor.current.search_index_and_record_collection;
	       if search_records
	       then call INVERT_SEARCH_SPECIFICATION (internal_specification_ptr);
						/* The search_spec was set up for use with */
						/* the record_collection by the previous */
						/* invocation.  Inverting the field ids */
						/* make the ones for the indexed fields */
						/* positive and the ones for the record */
						/* collection negative. */
	    end;
	 else call CV_SEARCH_SPECIFICATION_FOR_INDEX ((attribute_info.number_of_attributes), current_index_idx,
		 internal_specification_ptr, search_records);


      call TRANSLATE_ID_LIST ();			/* Sets id_list_ptr and all_desired_fields_are_in_index. */

      if get_count & ^search_records
      then
         do;
	  call index_manager_$get_key_count_by_spec (internal_specification_ptr, internal_cursor_ptr, p_tuple_count,
	       si_code);
	  if si_code ^= 0
	  then call SI_ERROR_RETURN (si_code, dm_error_$key_not_found);
         end;
      else
         do;
	  call index_manager_$get_key (internal_specification_ptr, id_list_ptr, work_area_ptr, internal_cursor_ptr,
	       typed_vector_array_ptr, interval_list_ptr, si_code);
	  if si_code ^= 0
	  then call SI_ERROR_RETURN (si_code, dm_error_$key_not_found);
	  call CHECK_VERSION ("interval_list", interval_list.version, INTERVAL_LIST_VERSION_2);
         end;

      if search_records
      then
SEARCH_RECORDS:
         do;

         /*** The index search did not satisfy all of the constraints of the specification.
	    Set up an interval_element_id_list and use it in searching the tuple records
	    associated with the keys which were selected by the index search. */

	  call CV_SEARCH_SPECIFICATION_FOR_RECORDS (internal_specification_ptr);
	  eil_number_of_elements = typed_vector_array.number_of_vectors;
	  element_id_list_ptr = null;
	  alloc element_id_list in (work_area) set (interval_element_id_list_ptr);
	  interval_element_id_list_ptr -> element_id_list.version = ELEMENT_ID_LIST_VERSION_1;

	  do element_idx = 1 to typed_vector_array.number_of_vectors;
	     interval_element_id_list_ptr -> element_id_list.id (element_idx) =
		typed_vector_array.vector_slot (element_idx) -> simple_typed_vector.value_ptr (1)
		-> based_bit_36_aligned;
	  end;

	  call FREE_TYPED_VECTOR_ARRAY (typed_vector_array_ptr);

	  if internal_record_cursor_ptr = null
	  then call SETUP_INTERNAL_CURSOR (USE_PREVIOUS_CURSOR, IS_RECORD_COLLECTION,
		  relation_header.record_collection_id, ("0"b), internal_record_cursor_ptr);

	  if get_id
	  then call record_manager_$get_record_ids_by_interval (interval_element_id_list_ptr,
		  internal_specification_ptr, interval_list_ptr, work_area_ptr, internal_record_cursor_ptr,
		  element_id_list_ptr, si_code);
	  else if get_tuple
	  then call record_manager_$get_records_by_interval (interval_element_id_list_ptr, p_id_list_ptr,
		  internal_specification_ptr, interval_list_ptr, work_area_ptr, (TYPED_VECTOR_ARRAY_VERSION_2),
		  internal_record_cursor_ptr, typed_vector_array_ptr, si_code);
	  else if get_tuples_and_ids
	  then call record_manager_$get_records_and_ids_by_interval (interval_element_id_list_ptr, p_id_list_ptr,
		  internal_specification_ptr, interval_list_ptr, work_area_ptr, (TYPED_VECTOR_ARRAY_VERSION_2),
		  internal_record_cursor_ptr, element_id_list_ptr, typed_vector_array_ptr, si_code);
	  else call record_manager_$get_record_count_by_interval (interval_element_id_list_ptr,
		  internal_specification_ptr, interval_list_ptr, internal_record_cursor_ptr, p_tuple_count, si_code);

	  if si_code ^= 0
	  then call SI_ERROR_RETURN (si_code, dm_error_$record_not_found);
	  free interval_element_id_list_ptr -> element_id_list;
         end SEARCH_RECORDS;
      else if ^all_desired_fields_are_in_index & (get_tuple | get_tuples_and_ids)
      then
GET_DATA_FROM_RECORD_COLLECTION:
         do;
	  eil_number_of_elements = typed_vector_array.number_of_vectors;
	  alloc element_id_list in (work_area);
	  element_id_list.version = ELEMENT_ID_LIST_VERSION_1;

	  do element_idx = 1 to typed_vector_array.number_of_vectors;
	     element_id_list.id (element_idx) =
		typed_vector_array.vector_slot (element_idx) -> simple_typed_vector.value_ptr (1)
		-> based_bit_36_aligned;
	  end;

	  call FREE_TYPED_VECTOR_ARRAY (typed_vector_array_ptr);

	  call record_manager_$get_records_by_id_list (element_id_list_ptr, p_id_list_ptr, work_area_ptr,
	       (relation_opening_info.per_process.record_cursor_ptr), typed_vector_array_ptr, si_code);
	  if si_code ^= 0
	  then call ERROR_RETURN (si_code);

         end GET_DATA_FROM_RECORD_COLLECTION;

SI_MAIN_RETURN:
      si_p_found_tuple = (si_code = 0);

      call FREE_INTERVAL_LIST (interval_list_ptr);

      return;

SI_ERROR_RETURN:
   proc (ser_code, ser_non_fatal_code);

      dcl	    (ser_code, ser_non_fatal_code)
			       fixed bin (35);

      if ser_code ^= ser_non_fatal_code & ser_code ^= 0
      then call ERROR_RETURN (ser_code);

      goto SI_MAIN_RETURN;

   end SI_ERROR_RETURN;

   end SEARCH_INDEX;
%page;
SEARCH_RECORD_COLLECTION:
   proc (src_p_found_tuple);

      dcl	    src_p_found_tuple      bit (1) aligned parameter;
      dcl	    src_code	       fixed bin (35) init (0);

   /*** The caller specified the record collection should be used to
        satisfy the constraints of this and group.
        All searching will be done on the record collection directly. */

      search_records = "1"b;

      if get_id
      then call record_manager_$get_record_ids_by_spec (internal_specification_ptr, work_area_ptr, internal_cursor_ptr,
	      element_id_list_ptr, src_code);
      else if get_tuple
      then call record_manager_$get_records_by_spec (internal_specification_ptr, p_id_list_ptr, work_area_ptr,
	      internal_cursor_ptr, typed_vector_array_ptr, src_code);
      else if get_tuples_and_ids
      then call record_manager_$get_records_and_ids_by_spec (internal_specification_ptr, p_id_list_ptr, work_area_ptr,
	      internal_cursor_ptr, element_id_list_ptr, typed_vector_array_ptr, src_code);

      else if get_count
      then call record_manager_$get_record_count (internal_specification_ptr, internal_cursor_ptr, p_tuple_count,
	      src_code);
      if src_code ^= 0
      then if src_code ^= dm_error_$record_not_found
	 then call ERROR_RETURN (src_code);

      src_p_found_tuple = (src_code = 0);
      return;
   end SEARCH_RECORD_COLLECTION;
%page;
SET_CURRENT_COLLECTION_ID:
   proc (scci_is_search_specification, scci_is_numeric_specification, scci_and_group_idx, scci_collection_id,
        scci_index_idx);

/* This subroutine returns the value of the collection_id specified by the caller
   for this and-group or for this numeric specification, or, if none
   is specified, returns the record_collection_id. The element in the index attribute
   map containing the index collection, or -1 if collection is not an index, is returned.
*/

      dcl	    scci_is_search_specification
			       bit (1) aligned;
      dcl	    scci_is_numeric_specification
			       bit (1) aligned;
      dcl	    scci_and_group_idx     fixed bin;
      dcl	    scci_collection_id     bit (36) aligned;
      dcl	    scci_index_idx	       fixed bin;

      if scci_is_search_specification
      then if relation_search_specification.number_of_and_groups <= 0
	 then scci_collection_id = relation_header.record_collection_id;
	 else if relation_search_specification.and_group (scci_and_group_idx).flags.collection_id_supplied
	 then scci_collection_id = relation_search_specification.and_group (scci_and_group_idx).search_collection_id;
	 else scci_collection_id = relation_header.record_collection_id;
      else if scci_is_numeric_specification
      then scci_collection_id = relation_numeric_specification.collection_id;
      else scci_collection_id = relation_header.record_collection_id;

      if scci_collection_id = relation_header.record_collection_id
      then scci_index_idx = -1;
      else
         do;
	  do scci_index_idx = 1 to hbound (index_attribute_map.index, 1)
	       while (index_attribute_map.index (scci_index_idx).collection_id ^= scci_collection_id);
	  end;
	  if scci_index_idx > hbound (index_attribute_map.index, 1)
	  then call ERROR_RETURN (dm_error_$index_not_in_relation);
         end;

      return;

   end SET_CURRENT_COLLECTION_ID;
%page;
SETUP_INTERNAL_CURSOR:
   proc (sic_from_relation_cursor, sic_is_record_collection, sic_collection_id, sic_previous_collection_id,
        sic_cursor_ptr);

/* This subroutine function creates a cursor for the given collection, returning
   a pointer to the cursor. */

      dcl	    (sic_collection_id, sic_previous_collection_id)
			       bit (36) aligned;
      dcl	    (sic_from_relation_cursor, sic_is_record_collection)
			       bit (1) aligned;
      dcl	    sic_code	       fixed bin (35);
      dcl	    sic_cursor_ptr	       ptr;

      if sic_from_relation_cursor
      then
         do;

         /*** If the relation_cursor already has a cursor for this collection, use it
	    rather than create a new one. */

	  if relation_cursor.current.collection_id = sic_collection_id & relation_cursor.current.cursor_ptr ^= null
	  then sic_cursor_ptr = relation_cursor.current.cursor_ptr;
	  else
	     do;
	        if relation_cursor.current.collection_id ^= sic_collection_id
	        then call DESTROY_CURSOR;
	        call CREATE_CURSOR;
	     end;
         end;
      else
         do;
	  if sic_cursor_ptr = null
	  then call CREATE_CURSOR;
	  else if sic_collection_id ^= sic_previous_collection_id
	  then
	     do;
	        call DESTROY_CURSOR;
	        call CREATE_CURSOR;
	     end;
         end;

      return;					/* Effective end of SETUP_INTERNAL_CURSOR */



/**** Subroutines of SETUP_INTERNAL_CURSOR follow. ****/
%page;
/**** Begin subroutines of SETUP_INTERNAL_CURSOR. ****/

CREATE_CURSOR:
   proc ();

      if sic_is_record_collection
      then call record_manager_$create_cursor (relation_cursor.file_opening_id, sic_collection_id,
	      relation_cursor.work_area_ptr, sic_cursor_ptr, sic_code);
      else call index_manager_$create_cursor (relation_cursor.file_opening_id, sic_collection_id,
	      relation_cursor.work_area_ptr, sic_cursor_ptr, sic_code);
      if sic_code ^= 0
      then call ERROR_RETURN (sic_code);

   end CREATE_CURSOR;

DESTROY_CURSOR:
   proc ();

      if sic_is_record_collection
      then call record_manager_$destroy_cursor (sic_cursor_ptr, sic_code);
      else call index_manager_$destroy_cursor (sic_cursor_ptr, sic_code);
      if sic_code ^= 0
      then call ERROR_RETURN (sic_code);

   end DESTROY_CURSOR;

/**** End of subroutines of SETUP_INTERNAL_CURSOR. ****/

   end SETUP_INTERNAL_CURSOR;
%page;
SETUP_INTERNAL_SPECIFICATION:
   proc (sis_is_search_specification, sis_is_numeric_specification, sis_is_relative_specification, sis_specification_ptr,
        sis_maximum_number_of_tuples_to_accept);

      dcl	    sis_is_search_specification
			       bit (1) aligned;
      dcl	    sis_is_numeric_specification
			       bit (1) aligned;
      dcl	    sis_is_relative_specification
			       bit (1) aligned;
      dcl	    sis_specification_ptr  ptr;
      dcl	    sis_maximum_number_of_tuples_to_accept
			       fixed bin (35);

      if sis_is_relative_specification
      then
         do;
	  sis_specification_ptr = relation_cursor.current.specification_ptr;

	  if sis_is_numeric_specification
	  then
	     do;
	        sis_specification_ptr -> numeric_specification.type = RELATIVE_NUMERIC_SPECIFICATION_TYPE;
	        sis_specification_ptr -> numeric_specification.range_size = relation_numeric_specification.range_size;
	        sis_specification_ptr -> numeric_specification.position_number =
		   relation_numeric_specification.position_number;
	     end;
	  else if sis_is_search_specification
	  then
	     do;
	        sis_specification_ptr -> search_specification.head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE;
	        sis_specification_ptr -> search_specification.range.size = relation_search_specification.range.size;
	     end;
         end;
      else if sis_is_search_specification
      then
         do;
	  ss_number_of_and_groups = max (0, min (1, relation_search_specification.number_of_and_groups));
	  ss_maximum_number_of_constraints = relation_search_specification.maximum_number_of_constraints;
	  alloc search_specification in (relation_cursor.work_area_ptr -> work_area) set (sis_specification_ptr);
	  sis_specification_ptr -> search_specification.head = relation_search_specification.head;
	  sis_specification_ptr -> search_specification.head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE;
	  sis_specification_ptr -> search_specification.range = relation_search_specification.range;

	  if sis_specification_ptr -> search_specification.number_of_and_groups > 0
	  then sis_specification_ptr -> search_specification.and_group (1).number_of_constraints = 0;
         end;
      else if sis_is_numeric_specification
      then
         do;
	  alloc numeric_specification in (relation_cursor.work_area_ptr -> work_area) set (sis_specification_ptr);
	  sis_specification_ptr -> numeric_specification.head = relation_numeric_specification.head;
	  sis_specification_ptr -> numeric_specification.head.type = ABSOLUTE_NUMERIC_SPECIFICATION_TYPE;
	  sis_specification_ptr -> numeric_specification.position_number =
	       relation_numeric_specification.position_number;
	  sis_specification_ptr -> numeric_specification.range_size = relation_numeric_specification.range_size;
	  sis_specification_ptr -> numeric_specification.pad = "0"b;
         end;
      else sis_specification_ptr = null;

      if sis_is_search_specification
      then if relation_search_specification.range.type ^= ALL_RANGE_TYPE
	 then sis_maximum_number_of_tuples_to_accept = relation_search_specification.range.size;
	 else sis_maximum_number_of_tuples_to_accept = MAXIMUM_FB35_VALUE;
      else if sis_is_numeric_specification
      then sis_maximum_number_of_tuples_to_accept = relation_numeric_specification.range_size;
      else sis_maximum_number_of_tuples_to_accept = MAXIMUM_FB35_VALUE;

      return;

   end SETUP_INTERNAL_SPECIFICATION;
%page;
SETUP_INTERNAL_SPECIFICATION_FOR_THIS_AND_GROUP:
   proc (sisftag_specification_ptr, sisftag_and_group_idx, sisftag_is_search_specification,
        sisftag_is_numeric_specification, sisftag_maximum_number_of_tuples_to_accept);

      dcl	    sisftag_specification_ptr
			       ptr;
      dcl	    sisftag_is_search_specification
			       bit (1) aligned;
      dcl	    sisftag_is_numeric_specification
			       bit (1) aligned;
      dcl	    sisftag_maximum_number_of_tuples_to_accept
			       fixed bin (35);
      dcl	    sisftag_total_number_of_constraints
			       fixed bin init (0);
      dcl	    (sisftag_constraint_idx, sisftag_and_group_idx)
			       fixed bin;

      if sisftag_is_numeric_specification
      then sisftag_specification_ptr -> numeric_specification.range_size =
	      min (MAX_FB17_VALUE, sisftag_maximum_number_of_tuples_to_accept);

      else if sisftag_is_search_specification
      then
         do;
	  sisftag_specification_ptr -> search_specification.range.size =
	       min (MAX_FB17_VALUE, sisftag_maximum_number_of_tuples_to_accept);

	  if sisftag_specification_ptr -> search_specification.number_of_and_groups > 0
	  then
	     do;
	        sisftag_specification_ptr -> search_specification.and_group (1).number_of_constraints =
		   relation_search_specification.and_group (sisftag_and_group_idx).number_of_constraints;
	        do sisftag_constraint_idx = 1
		   to relation_search_specification.and_group (sisftag_and_group_idx).number_of_constraints;

	        /*** Copy the constraints for this and group from the relation specification to
		   the internal specification. */

		 sisftag_specification_ptr -> search_specification.and_group (1).constraint (sisftag_constraint_idx) =
		      relation_search_specification.and_group (sisftag_and_group_idx)
		      .constraint (sisftag_constraint_idx);
	        end;

	     end;
         end;

      return;


   end SETUP_INTERNAL_SPECIFICATION_FOR_THIS_AND_GROUP;
%page;
SETUP_RETURN_STRUCTURES:
   proc (srs_maximum_number_of_return_structures, srs_setup_for_ids, srs_setup_for_tuples,
        srs_return_eil_or_tva_array_ptr, srs_return_tva_array_ptr);

/* This subroutine sets up two arrays of pointers to return structures,
   element_id_lists or typed_vector_arrays, for those entries that return
   such data.  In each array, there is one entry for each and group.
   If more than one and-group is specified, the array is allocated. If only one
   and-group is specified, or if a numeric or null specification is specified,
   an automatic one element array is used. */

      dcl	    srs_maximum_number_of_return_structures
			       fixed bin (35);
      dcl	    srs_setup_for_ids      bit (1) aligned;
      dcl	    srs_setup_for_tuples   bit (1) aligned;
      dcl	    srs_return_eil_or_tva_array_ptr
			       ptr;
      dcl	    srs_return_tva_array_ptr
			       ptr;

      if srs_setup_for_ids
      then
         do;
	  reota_number_of_entries = max (1, srs_maximum_number_of_return_structures);

	  if srs_maximum_number_of_return_structures <= 1
	  then srs_return_eil_or_tva_array_ptr = addr (local_return_eil_or_tva_entry);
	  else
	     do;
	        alloc return_eil_or_tva_array in (work_area);
	        srs_return_eil_or_tva_array_ptr = return_eil_or_tva_array_ptr;
	     end;

	  unspec (srs_return_eil_or_tva_array_ptr -> return_eil_or_tva_array) = ""b;
	  srs_return_eil_or_tva_array_ptr -> return_eil_or_tva_array (*).flags.is_element_id_list = "0"b;
	  srs_return_eil_or_tva_array_ptr -> return_eil_or_tva_array (*).flags.mbz = "0"b;
	  srs_return_eil_or_tva_array_ptr -> return_eil_or_tva_array (*).ptr = null;
         end;

      if srs_setup_for_tuples
      then
         do;
	  rta_number_of_entries = max (1, srs_maximum_number_of_return_structures);

	  if srs_maximum_number_of_return_structures <= 1
	  then srs_return_tva_array_ptr = addr (local_return_tva_entry);
	  else
	     do;
	        alloc return_tva_array in (work_area);
	        srs_return_tva_array_ptr = return_tva_array_ptr;
	     end;

	  unspec (srs_return_tva_array_ptr -> return_tva_array) = ""b;
	  srs_return_tva_array_ptr -> return_tva_array (*).ptr = null;
         end;

      return;

   end SETUP_RETURN_STRUCTURES;
%page;
TRANSLATE_ID_LIST:
   proc ();


      if get_id | get_tuples_and_ids | (get_count & search_records)
      then
         do;

         /*** Tuple_ids are needed to return to the caller or to be used in
	    getting tuples from the record collection. Get the tuple_ids of keys
	    which match the specification in a typed_vector_array. This typed_vector_array
	    must be converted to an element_id_list later. */

	  all_desired_fields_are_in_index = "0"b;
	  local_id_list.id (1) = index_attribute_map.index (current_index_idx).number_of_attributes + 1;
	  local_id_list.version = ID_LIST_VERSION_1;
	  local_id_list.number_of_ids = 1;
	  id_list_ptr = addr (local_id_list);
         end;
      else if get_tuple
      then
         do;
	  all_desired_fields_are_in_index = "0"b;
	  id_list_ptr = null;
	  if ^search_records
	  then
	     do;

	     /*** The specification can be satisfied completely by searching the index.
		Determine if all fields to be returned to the caller are also in the index,
		and build an id_list that identifies the desired fields in the key (the fields
		in the key may have different ids than the fields in the tuple). */

	        all_desired_fields_are_in_index = "1"b;

	        if p_id_list_ptr ^= null
	        then
TRANSLATE_SPECIFIED_ID_LIST:				/* Translate the tuple field ids to key field ids. */
		 do;
		    il_number_of_ids = p_id_list_ptr -> id_list.number_of_ids;
		    alloc id_list in (work_area);
		    id_list.version = ID_LIST_VERSION_1;

RECORD_ID_LOOP:
		    do record_id_idx = 1 to id_list.number_of_ids while (all_desired_fields_are_in_index);

		       if p_id_list_ptr -> id_list.id (record_id_idx) = TUPLE_ID_FIELD_ID
		       then id_list.id (record_id_idx) =
			       index_attribute_map.index (current_index_idx).number_of_attributes + 1;
		       else
			do;
INDEX_ID_LOOP:
			   do index_id_idx = 1
			        to index_attribute_map.index (current_index_idx).number_of_attributes
			        while (p_id_list_ptr -> id_list.id (record_id_idx)
			        ^= index_attribute_map.index (current_index_idx).attribute_id (index_id_idx));
			   end INDEX_ID_LOOP;
			   if index_id_idx <= index_attribute_map.index (current_index_idx).number_of_attributes
			   then id_list.id (record_id_idx) = index_id_idx;
			   else all_desired_fields_are_in_index = "0"b;
						/* This tuple field is not present in the key. */
			end;
		    end RECORD_ID_LOOP;

		 end TRANSLATE_SPECIFIED_ID_LIST;
	        else if attribute_info.number_of_attributes
		   = index_attribute_map.index (current_index_idx).number_of_attributes
	        then
TRANSLATE_DEFAULT_ID_LIST:				/* The key contains all tuple fields. */
		 do;
		    all_desired_fields_are_in_index = "1"b;
		    il_number_of_ids = attribute_info.number_of_attributes;
		    alloc id_list in (work_area);
		    id_list.version = ID_LIST_VERSION_1;
		    do index_id_idx = 1 to il_number_of_ids;
		       id_list.id (index_attribute_map.index (current_index_idx).attribute_id (index_id_idx)) =
			  index_id_idx;
		    end;

		 end TRANSLATE_DEFAULT_ID_LIST;
	        else
		 do;
		    id_list_ptr = null;
		    all_desired_fields_are_in_index = "0"b;
		 end;
	     end;
	  if ^all_desired_fields_are_in_index
	  then
	     do;

	     /*** There exists at least one desired field which is not in the index.
		Getting this field will require getting the tuple record from the record collection,
		so there is no need to get fields from the index.
		Set up an id_list which will retrieve only the tuple_id field from keys.
		Free any id_list that was created
		previously, as it won't be needed after all. */

	        local_id_list.id (1) = index_attribute_map.index (current_index_idx).number_of_attributes + 1;
	        local_id_list.number_of_ids = 1;
	        local_id_list.version = ID_LIST_VERSION_1;
	        if id_list_ptr ^= null
	        then free id_list in (work_area);
	        id_list_ptr = addr (local_id_list);
	     end;
         end;

      return;

   end TRANSLATE_ID_LIST;
%page;
RETURN_TYPED_VECTOR_LIST:
   proc (rtvl_number_of_vectors, rtvl_typed_vector_list_ptr);


   /*** The caller expects the tuples to be returned in a typed_vector_list.
        Convert the typed_vector_array in the work_area to a typed_vector_list
        in the caller_area. */

      dcl	    rtvl_number_of_vectors fixed bin (35);	/* total number of vectors in return typed_vector_list */
      dcl	    rtvl_typed_vector_list_ptr
			       ptr;
      dcl	    rtvl_code	       fixed bin (35);
      dcl	    rtvl_tva_idx	       fixed bin;		/* index into return_tva_array */
      dcl	    rtvl_vector_idx	       fixed bin;		/* index into current typed_vector_array */
      dcl	    rtvl_return_vector_idx fixed bin;		/* index into typed_vector_list */

      if rtvl_number_of_vectors <= 0
      then return;

      if rtvl_typed_vector_list_ptr ^= null
      then
         do;

         /*** The caller provided a typed_vector_list. Do not allocate a new one. */

	  typed_vector_list_ptr = rtvl_typed_vector_list_ptr;
         end;
      else
         do;

         /*** The caller did not provide a typed_vector_list.
	    Allocate a new one. */

	  tvl_maximum_number_of_vectors = rtvl_number_of_vectors;
	  alloc typed_vector_list in (caller_area);	/* freed in FINISH if necessary */
	  typed_vector_list.version = TYPED_VECTOR_LIST_VERSION_1;
	  typed_vector_list.pad = 0;
         end;

      typed_vector_list.number_of_vectors = rtvl_number_of_vectors;

      rtvl_return_vector_idx = 1;
      do rtvl_tva_idx = 1 to hbound (return_tva_array, 1) while (rtvl_return_vector_idx <= rtvl_number_of_vectors);

         if return_tva_array (rtvl_tva_idx).ptr ^= null
         then
	  do;
	     do rtvl_vector_idx = 1 to return_tva_array (rtvl_tva_idx).ptr -> typed_vector_array.number_of_vectors;

	        call dm_vector_util_$copy_typed_vector (caller_area_ptr, return_tva_array (rtvl_tva_idx).ptr,
		   return_tva_array (rtvl_tva_idx).ptr -> typed_vector_array.vector_slot (rtvl_vector_idx),
		   typed_vector_list.vector_ptr (rtvl_return_vector_idx), rtvl_code);
	        if rtvl_code ^= 0
	        then call ERROR_RETURN (rtvl_code);
	        rtvl_return_vector_idx = rtvl_return_vector_idx + 1;
	     end;

	     call FREE_TYPED_VECTOR_ARRAY (return_tva_array (rtvl_tva_idx).ptr);

	  end;
      end;

      rtvl_typed_vector_list_ptr = typed_vector_list_ptr;

      return;

   end RETURN_TYPED_VECTOR_LIST;
%page;
RETURN_TYPED_VECTOR_ARRAY:
   proc (rtva_number_of_vectors, rtva_typed_vector_array_ptr);

/* Allocate a typed_vector_array in the caller's area and copy the
   vectors in the various temporary typed_vector_arrays from the
   work_area to the caller's area. */

      dcl	    rtva_number_of_vectors fixed bin (35);
      dcl	    rtva_typed_vector_array_ptr
			       ptr;
      dcl	    dm_vector_util_$init_typed_vector_array
			       entry options (variable);
      dcl	    rtva_code	       fixed bin (35) init (0);
      dcl	    (
	    rtva_dimension_idx,			/* index into dimension_table */
	    rtva_return_vector_idx,			/* index into return typed_vector_array */
	    rtva_tva_idx,				/* index into return_tva_array */
	    rtva_vector_idx				/* index into current typed_vector_array */
	    )		       fixed bin;

      if rtva_number_of_vectors <= 0
      then return;

      do rtva_tva_idx = 1 to hbound (return_tva_array, 1) while (return_tva_array (rtva_tva_idx).ptr = null);
      end;
      if rtva_tva_idx > hbound (return_tva_array, 1)
      then call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	      "There are ^d tuples to return, but no vector structure has been allocated.", rtva_number_of_vectors);

      if rtva_typed_vector_array_ptr ^= null
      then
        /*** The caller supplied a typed_vector_array. Do not allocate a new one. */
	 rtva_typed_vector_array_ptr -> typed_vector_array.number_of_vectors = rtva_number_of_vectors;
      else
         do;

         /*** The caller did not provide a typed_vector_array. Allocate one in the
	    caller_area. */

	  call dm_vector_util_$init_typed_vector_array (caller_area_ptr, rtva_number_of_vectors,
	       return_tva_array (rtva_tva_idx).ptr -> typed_vector_array.number_of_dimensions,
	       return_tva_array (rtva_tva_idx).ptr -> typed_vector_array.maximum_dimension_name_length,
	       rtva_typed_vector_array_ptr, rtva_code);
	  if rtva_code ^= 0
	  then call ERROR_RETURN (rtva_code);
	  call CHECK_VERSION_FB ("typed_vector_array", rtva_typed_vector_array_ptr -> typed_vector_array.version,
	       (TYPED_VECTOR_ARRAY_VERSION_2));

	  unspec (rtva_typed_vector_array_ptr -> typed_vector_array.dimension_table) = ""b;

	  do rtva_dimension_idx = 1 to rtva_typed_vector_array_ptr -> typed_vector_array.number_of_dimensions;
(nosubrg):
	     rtva_typed_vector_array_ptr -> typed_vector_array.dimension_table (rtva_dimension_idx) =
		return_tva_array (rtva_tva_idx).ptr -> typed_vector_array.dimension_table (rtva_dimension_idx);
	  end;
         end;

      rtva_typed_vector_array_ptr -> typed_vector_array.number_of_vectors = rtva_number_of_vectors;
      rtva_return_vector_idx = 1;
      do rtva_tva_idx = rtva_tva_idx to hbound (return_tva_array, 1)
	 while (rtva_return_vector_idx <= rtva_number_of_vectors);

         if return_tva_array (rtva_tva_idx).ptr ^= null
         then
	  do;
	     do rtva_vector_idx = 1 to return_tva_array (rtva_tva_idx).ptr -> typed_vector_array.number_of_vectors;

	        call dm_vector_util_$copy_typed_vector (caller_area_ptr, return_tva_array (rtva_tva_idx).ptr,
		   return_tva_array (rtva_tva_idx).ptr -> typed_vector_array.vector_slot (rtva_vector_idx),
		   rtva_typed_vector_array_ptr -> typed_vector_array.vector_slot (rtva_return_vector_idx), rtva_code);
	        if rtva_code ^= 0
	        then call ERROR_RETURN (rtva_code);
	        rtva_return_vector_idx = rtva_return_vector_idx + 1;
	     end;
	     call FREE_TYPED_VECTOR_ARRAY (return_tva_array (rtva_tva_idx).ptr);
	  end;
      end;

      return;

   end RETURN_TYPED_VECTOR_ARRAY;
%page;
RETURN_ELEMENT_ID_LIST:
   proc (reil_number_of_ids, reil_element_id_list_ptr);

/* This subroutine allocates an element_id_list in the caller's area large
   enough to hold all of the ids to be returned.  It is referenced by explicit
   ptr to prevent conflict with element_id_lists alloc when processing the search.
   Ids are copied from the element_id_lists and typed_vector_arrays (holding
   simple_typed_vectors with a single value, a tuple id) recorded in the
   return_eil_or_tva_array. */

      dcl	    reil_number_of_ids     fixed bin (35);
      dcl	    reil_element_id_list_ptr
			       ptr;
      dcl	    (
	    reil_eil_or_tva_idx,			/* index into return_eil_or_tva_array */
	    reil_return_id_idx,			/* index into return element_id_list */
	    reil_id_idx				/* index into current eil or tva */
	    )		       fixed bin;
      dcl	    reil_code	       fixed bin (35) init (0);
      dcl	    reil_based_b36a	       bit (36) aligned based;/* for element_id */

      if reil_number_of_ids <= 0
      then return;					/* No tuples found. */
      if reil_element_id_list_ptr ^= null
      then
        /*** The caller supplied an element_id_list. Do not allocate a new one. */
	 reil_element_id_list_ptr -> element_id_list.number_of_elements = reil_number_of_ids;
      else
         do;
         /*** The caller did not supply an element_id_list. Allocate one in the
	    caller area. */

	  eil_number_of_elements = reil_number_of_ids;
	  alloc element_id_list in (caller_area) set (reil_element_id_list_ptr);
						/* freed in FINISH if necessary */
	  reil_element_id_list_ptr -> element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
         end;

      reil_return_id_idx = 0;

      do reil_eil_or_tva_idx = 1 to hbound (return_eil_or_tva_array, 1);

         if return_eil_or_tva_array (reil_eil_or_tva_idx).ptr ^= null
         then
	  do;
	     if return_eil_or_tva_array (reil_eil_or_tva_idx).is_element_id_list
	     then
	        do;
		 do reil_id_idx = 1
		      to return_eil_or_tva_array (reil_eil_or_tva_idx).ptr -> element_id_list.number_of_elements;
		    reil_return_id_idx = reil_return_id_idx + 1;
		    reil_element_id_list_ptr -> element_id_list.id (reil_return_id_idx) =
		         return_eil_or_tva_array (reil_eil_or_tva_idx).ptr -> element_id_list.id (reil_id_idx);
		 end;
		 free return_eil_or_tva_array (reil_eil_or_tva_idx).ptr -> element_id_list;
		 return_eil_or_tva_array (reil_eil_or_tva_idx).ptr = null;
	        end;
	     else
	        do;
		 do reil_id_idx = 1
		      to return_eil_or_tva_array (reil_eil_or_tva_idx).ptr -> typed_vector_array.number_of_vectors;
		    ;
		    reil_return_id_idx = reil_return_id_idx + 1;
		    reil_element_id_list_ptr -> element_id_list.id (reil_return_id_idx) =
		         return_eil_or_tva_array (reil_eil_or_tva_idx).ptr
		         -> typed_vector_array.vector_slot (reil_id_idx) -> simple_typed_vector.value_ptr (1)
		         -> reil_based_b36a;
		 end;
		 call FREE_TYPED_VECTOR_ARRAY (return_eil_or_tva_array (reil_eil_or_tva_idx).ptr);
	        end;

	  end;
      end;

      return;

   end RETURN_ELEMENT_ID_LIST;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_relation_spec;
%page;
%include dm_specification_head;
%page;
%include vu_typed_vector_array;
%page;
%include vu_typed_vector;
%page;
%include dm_id_list;
%page;
%include dm_element_id_list;
%page;
%include dm_interval_list;
%page;
%include dm_specification;
%page;
%include dm_range_constants;
%page;
%include sub_err_flags;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include dm_typed_vector_list;

   end rlm_general_search;




		    rlm_get_approximate_count.pl1   04/02/87  1313.1r w 04/02/87  1304.9       80298



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


/* DESCRIPTION:

         Returns an approximate count depending on the entry.  The two
     entries are:
     
     $get_population:
         Returns  an  approximate  count of the tuples in the given relation.
     The count returned is the number of keys in the primary index as kept  in
     the key_count_array.

     $get_duplicate_key_count:
          Returns  an  approximate  count of the duplicate keys in the given 
     index. The count returned depends on the number of fields in a key that
     must be duplicated in order for the key to be considered a duplicate
     (p_number_of_dulication_fields). This information is kept in the index's
     key_count_array.
*/

/* HISTORY:

Written by Matthew Pierret, 08/10/83.
Modified:
09/13/83 by Matthew Pierret:  Changed calling sequence to take a pointer to a
            relation_cursor instead of an opening_id.
            Changed name to rlm_get_approximate_count and added the
            $get_population and $get_duplicate_key_count entries.  The latter
            formerly existed in rlm_general_search.
06/22/84 by Matthew Pierret: Added a cleanup handler to call FINISH, a sub_err_
            call to report an improper entry into the routine, and subroutine
            prefix on each CHECK_VERSION variable.
10/29/84 by Lindsey L. Spratt:  Changed to use version 2 of the
            key_count_array.
11/12/84 by Stanford S. Cox:  Chg to return a minimum tuple count of 1.
03/05/85 by Lindsey L. Spratt:  Fixed to guarantee that the key count returend
            (p_tuple_count) is always non-negative, and is no greater than one
            less than the total (approx.)  tuple count (key_count_idx = 0).
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

rlm_get_approximate_count$get_population:
   proc (p_relation_cursor_ptr, p_tuple_count, p_code);


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

      dcl	    p_relation_cursor_ptr  ptr parameter;	/* points to relation_cursor */
      dcl	    p_index_collection_id  bit (36) aligned parameter;
						/* is the collection id of an index from which to get counts */
      dcl	    p_number_of_duplication_fields
			       fixed bin (17) parameter;
      dcl	    p_tuple_count	       fixed bin (35) parameter;
						/* approximate number of tuples in relation */
      dcl	    p_code	       fixed bin (35) parameter;
						/* standard error code*/

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    index_idx	       fixed bin;
      dcl	    key_count_idx	       fixed bin;
      dcl	    (get_population, get_duplicate_key_count)
			       bit (1) aligned;
      dcl	    index_collection_id    bit (36) aligned;
      dcl	    index_cursor_ptr       ptr init (null);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("rlm_get_approximate_count") char (32) varying internal static
			       options (constant);
      dcl	    TOTAL_KEY_COUNT_INDICATOR
			       init (-1) fixed bin (17) internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* Static */

      dcl	    work_area_ptr	       ptr internal static init (null);

/* END OF DECLARATIONS */

/* get_population:
   entry (p_relation_cursor_ptr, p_tuple_count, p_code);
*/
      get_population = "1"b;
      get_duplicate_key_count = "0"b;
      key_count_idx = 0;
      goto JOIN;

get_duplicate_key_count:
   entry (p_relation_cursor_ptr, p_index_collection_id, p_number_of_duplication_fields, p_tuple_count, p_code);

      get_population = "0"b;
      get_duplicate_key_count = "1"b;
      if p_number_of_duplication_fields = TOTAL_KEY_COUNT_INDICATOR
      then key_count_idx = 0;
      else key_count_idx = p_number_of_duplication_fields;
      goto JOIN;

JOIN:
      p_tuple_count, p_code = 0;

      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_VERSION (relation_cursor.version, RELATION_CURSOR_VERSION_2, "relation_cursor");

      key_count_array_ptr, index_cursor_ptr = null;

      if get_duplicate_key_count
      then index_collection_id = p_index_collection_id;
      else
         do;

	  /*** Set up opening info. Only the index_attribute_map is needed. */

	  call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
	  call CHECK_VERSION (relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2, "relation_opening_info");
	  index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
	  call CHECK_VERSION (index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2, "index_attribute_map");

/**** Get collection id of first index.  */

	  do index_idx = 1 to hbound (index_attribute_map.index, 1)
	       while (index_attribute_map.index (index_idx).collection_id = "0"b
	       | index_attribute_map.index (index_idx).number_of_attributes <= 0);
	  end;
	  if index_idx > hbound (index_attribute_map.index, 1)
	  then call ERROR_RETURN (0);

	  index_collection_id = index_attribute_map.index (index_idx).collection_id;
         end;

      if work_area_ptr = null
      then work_area_ptr = get_dm_free_area_ ();

      on cleanup call FINISH ();

/**** Get a pointer to an index_cursor to use in calling index_manager_ */

      if relation_cursor.flags.current_state_is_consistent & relation_cursor.current.cursor_ptr ^= null
	 & relation_cursor.current.collection_id = index_collection_id
      then index_cursor_ptr = relation_cursor.current.cursor_ptr;
						/* already have index_cursor */
      else
         do;

	  /*** Create an index_cursor to use in calling index_manager_. */

	  call index_manager_$create_cursor (relation_cursor.file_opening_id, index_collection_id, work_area_ptr,
	       index_cursor_ptr, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;

/**** Get the count */

      call index_manager_$get_key_count_array (index_cursor_ptr, work_area_ptr, key_count_array_ptr, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call CHECK_VERSION (key_count_array.version, KEY_COUNT_ARRAY_VERSION_2, "key_count_array");

/* The following is done as a kluge to get around a problem with the key counts
where the key counts can be negative, or equal to the tuple 
count (key_count_idx = 0), due to the unprotected nature of the key counts.
(Neither of these cases would happen if the key counts were maintained in a
protected fashion.)

This code guarantees that the count returned is always at least zero, and if
greater than zero, no more than one less than the full tuple count.
*/

      if key_count_idx = 0
      then p_tuple_count = key_count_array.count (0);
      else p_tuple_count = min (key_count_array.count (key_count_idx), key_count_array.count (0) - 1);
      p_tuple_count = max (0, p_tuple_count);

      call FINISH ();
MAIN_RETURN:
      return;
%page;
ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;


FINISH:
   proc ();

      if index_cursor_ptr ^= null & index_cursor_ptr ^= relation_cursor.current.cursor_ptr
      then call index_manager_$destroy_cursor (index_cursor_ptr, (0));

      if key_count_array_ptr ^= null
      then free key_count_array;

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  char (8) aligned parameter;
      dcl	    cv_p_expected_version  char (8) aligned parameter;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_key_count_array;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include sub_err_flags;
   end rlm_get_approximate_count$get_population;




		    rlm_get_count.pl1               10/15/86  1429.6rew 10/15/86  1408.7       47673



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(86-08-19,Dupuis), approve(86-08-19,MCR7401), audit(86-09-29,Blair),
     install(86-10-02,MR12.0-1173):
     This module implements the relation_manager_$get_count entrypoint. This
     functionality was previously contained in the rlm_general_search program,
     but was moved here when that program was replaced.
  2) change(86-10-13,Dupuis), approve(86-10-13,MCR7401), audit(86-10-13,Blair),
     install(86-10-15,MR12.0-1186):
     Changed it to not pass dm_error_$record_not_found back to the calling
     program. This caused mrds to report an error back to the user, when
     really it was just an empty database and a count of zero would suffice.
                                                   END HISTORY COMMENTS */

/* format: off */

rlm_get_count: proc (

	p_relation_cursor_ptr,    /* input: to the relation cursor */
	p_specification_ptr,      /* input: to the relation search spec */
	p_tuple_count,            /* output: number that matched */
	p_code                    /* output: success or failure */
		);

dcl p_code fixed bin (35) parameter;
dcl p_relation_cursor_ptr ptr parameter;
dcl p_specification_ptr ptr parameter;
dcl p_tuple_count fixed bin (35) parameter;


	relation_cursor_ptr = p_relation_cursor_ptr;
	p_tuple_count = 0;
	p_code = 0;

	call INITIALIZE;

	on cleanup call TERMINATE;

	call SET_AND_CHECK_OPENING_INFO;
	call GET_COUNT_OF_TUPLES;
	call TERMINATE;

RETURN:

	return;
%page;
CHECK_VERSION: proc (

	cv_structure_name,   /* input: name of structure */
	cv_received_version, /* input: version of structure */
	cv_expected_version  /* input: expected version of structure */
		   );

dcl cv_expected_version char (8) aligned;
dcl cv_received_version char (8) aligned;
dcl cv_structure_name char (*);

	if cv_received_version ^= cv_expected_version
	then call sub_err_ (error_table_$unimplemented_version, RLM_GET_COUNT, ACTION_CANT_RESTART, null, 0,
	     "^/Expected version ^a of the ^a structure.^/Received version ^a instead.",
	     cv_expected_version, cv_structure_name, cv_received_version);

	return;

     end CHECK_VERSION;
%page;
ERROR_RETURN: proc (er_code);

dcl er_code fixed bin (35) parameter;

	p_code = er_code;
	call TERMINATE;

	goto RETURN;

     end ERROR_RETURN;
%page;
GET_COUNT_OF_TUPLES: proc;

dcl gcot_code fixed bin (35);

	call record_manager_$create_cursor (relation_cursor.file_opening_id,
	     relation_header.record_collection_id, relation_cursor.work_area_ptr, record_cursor_ptr, gcot_code);
	if gcot_code ^= 0
	then call ERROR_RETURN (gcot_code);

	call record_manager_$get_record_count (null, record_cursor_ptr, p_tuple_count, gcot_code);
	if gcot_code ^= 0 & gcot_code ^= dm_error_$record_not_found
	then call ERROR_RETURN (gcot_code);

	return;

     end GET_COUNT_OF_TUPLES;
%page;
INITIALIZE: proc;

	call CHECK_VERSION ("relation_cursor", relation_cursor.version, RELATION_CURSOR_VERSION_2);

	if p_specification_ptr ^= null
	then call sub_err_ (error_table_$null_info_ptr, RLM_GET_COUNT,
	     ACTION_CANT_RESTART, null, 0,
	     "^/A relation_search_specification isn't implemented for relation_manager_$get_count.");

	if relation_cursor.work_area_ptr ^= null
	then relation_cursor.work_area_ptr = get_dm_free_area_ ();

	record_cursor_ptr = null;

	return;

     end INITIALIZE;
%page;
SET_AND_CHECK_OPENING_INFO: proc;

dcl sacoi_code fixed bin (35);

	call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, sacoi_code);
	if sacoi_code ^= 0
	then call ERROR_RETURN (sacoi_code);

	call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

	relation_header_ptr = relation_opening_info.relation_header_ptr;
	call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

	return;

     end SET_AND_CHECK_OPENING_INFO;
%page;
TERMINATE: proc;

dcl t_code fixed bin (35);

	if record_cursor_ptr ^= null
	then call record_manager_$destroy_cursor (record_cursor_ptr, t_code);

	return;

     end TERMINATE;
%page;
dcl RLM_GET_COUNT char (13) internal static options (constant) init ("rlm_get_count");
dcl cleanup condition;
dcl dm_error_$record_not_found fixed bin(35) ext static;
dcl error_table_$null_info_ptr fixed bin(35) ext static;
dcl error_table_$unimplemented_version fixed bin(35) ext static;
dcl get_dm_free_area_ entry() returns(ptr);
dcl null builtin;
dcl record_cursor_ptr ptr;
dcl record_manager_$create_cursor entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
dcl record_manager_$destroy_cursor entry (ptr, fixed bin (35));
dcl record_manager_$get_record_count entry (ptr, ptr, fixed bin (35), fixed bin (35));
dcl rlm_opening_info$get entry (bit(36) aligned, ptr, fixed bin(35));
dcl sub_err_ entry() options(variable);
%page;
%include dm_rlm_cursor;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_opening_info;
%page;
%include sub_err_flags;

end rlm_get_count;




		    rlm_get_cursor_info.pl1         03/06/85  0749.6r w 03/05/85  0836.8       30240



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This  routine is a utility which returns selected information stored
     in the relation_cursor structure  pointed  to  by  p_relation_cursor_ptr.
     The only error situation occurs when the relation_cursor structure is not
     a  valid  relation_cursor  (relation_cursor.version  is  not equal to the
     correct version).  This error is reported via sub_err_.

     The entry points are:

          $area_ptr - returns the value of relation_cursor.work_area_ptr

          $opening_id - returns the value of relation_cursor.file_opening_id.
*/

/* HISTORY:

Written by Matthew Pierret, 05/23/84.
Modified:
11/01/84 by Stanford S. Cox:  MAIN: changed nonparm p_ variable prefixes to local_.
   CHECK_VERSION: Added cv_ prefixes.
*/

/* format: style2,ind3 */

rlm_get_cursor_info:
   proc ();

      return;

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

      dcl	    p_relation_cursor_ptr  ptr;		/*points to a relation_cursor created by either the
                                                              create_cursor or copy_cursor operation.*/

/* Automatic */

      dcl	    local_area_ptr	       ptr;		/*points to the area 
in which
the cursor was allocated.*/
      dcl	    local_rel_opening_id   bit (36) aligned;	/*is the opening identifier of the*/
						/*relation for which the cursor is
defined.*/

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("rlm_get_cursor_info") char (32) varying internal static options (constant);

/* Entry */

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

area_ptr:
   entry (p_relation_cursor_ptr) returns (ptr);

      relation_cursor_ptr = p_relation_cursor_ptr;

      call CHECK_VERSION (relation_cursor.version, RELATION_CURSOR_VERSION_2, "relation_cursor");

      local_area_ptr = relation_cursor.work_area_ptr;

      return (local_area_ptr);


opening_id:
   entry (p_relation_cursor_ptr) returns (bit (36) aligned);

      relation_cursor_ptr = p_relation_cursor_ptr;

      call CHECK_VERSION (relation_cursor.version, RELATION_CURSOR_VERSION_2, "relation_cursor");

      local_rel_opening_id = relation_cursor.file_opening_id;

      return (local_rel_opening_id);

%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include dm_rlm_cursor;
%page;
%include sub_err_flags;
   end rlm_get_cursor_info;




		    rlm_get_description.pl1         01/04/85  0917.4re  01/03/85  1147.8       64953



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


/* DESCRIPTION:

         Return  a  description of the specified relation.  The relation must
     be open, and the description is based solely on  the  relation's  opening
     information (relation_opening_info, attribute_info, relation_header and
     index_attribute_map).
*/

/* HISTORY:

Written by Matthew Pierret, 09/22/82.
Modified:
12/09/82 by Matthew Pierret:  Added setting of record_collection_id.
            Changed to RELATION_DESCRIPTION_VERSION_2.
02/18/83 by Matthew Pierret:  Changed to RELATION_DESCRIPTION_VERSION_3,
            which contains attribute names. Currently attribute names are
            not supported in index_attribute_map, so a canonical name "x"
            is returned for all attributes.
03/01/83 by Matthew Pieret:  Changed to use relation_opening_info instead of
            relation_info.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.
11/01/84 by Stanford S. Cox:  LOOP_OVER_INDICES: Changed to use hbound of rel_dscp 
	  instead of iam.   FINISH: Added as cleanup handler.
            CV: Added unique var prefix, removed dup var dcls.
*/

/* format: style2,ind3 */

rlm_get_description:
   proc (p_rel_opening_id, p_work_area_ptr, p_relation_description_ptr, p_code);


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

      dcl	    p_rel_opening_id       bit (36) aligned parameter;
      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_relation_description_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    attribute_idx	       fixed bin (17);
      dcl	    description_index_idx  fixed bin (17);
      dcl	    index_attribute_idx    fixed bin (17);
      dcl	    iam_index_idx	       fixed bin (17);

      dcl	    based_descriptor_string_ptr
			       ptr;

/* Based */

      dcl	    p_work_area	       area (sys_info$max_seg_size) based (p_work_area_ptr);
      dcl	    based_descriptor_string
			       bit (36) aligned based (based_descriptor_string_ptr);

/* Builtin */

      dcl	    (hbound, null, string) builtin;

/* Constant */

      dcl	    myname	       init ("rlm_get_description") char (19) internal static options (constant);

/* Condition */

      dcl	    cleanup	       condition;

/* Entry */

      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* END OF DECLARATIONS */

      p_relation_description_ptr, relation_description_ptr = null ();
      p_code = 0;

      call rlm_opening_info$get (p_rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION ("relation_opening_info", (relation_opening_info.version), (RELATION_OPENING_INFO_VERSION_2));

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      attribute_info_ptr = relation_opening_info.attribute_info_ptr;
      call CHECK_VERSION ("attribute_info", attribute_info.version, ATTRIBUTE_INFO_VERSION_1);

      index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
      call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);

      rd_maximum_number_of_attributes_per_index = index_attribute_map.maximum_number_of_attributes_per_index;
      rd_number_of_indices = index_attribute_map.number_of_indices;
      rd_number_of_attributes = attribute_info.number_of_attributes;
      rd_maximum_attribute_name_length = attribute_info.maximum_attribute_name_length;

      on cleanup call FINISH ();
      alloc relation_description in (p_work_area);

      relation_description.version = RELATION_DESCRIPTION_VERSION_3;

      relation_description.record_collection_id = relation_header.record_collection_id;

      description_index_idx = 0;
LOOP_OVER_INDICES:
      do iam_index_idx = 1 to hbound (relation_description.index, 1);
         if index_attribute_map.index (iam_index_idx).number_of_attributes > 0
         then
	  do;
	     description_index_idx = description_index_idx + 1;

	     relation_description.index (description_index_idx).collection_id =
		index_attribute_map.index (iam_index_idx).collection_id;
	     relation_description.index (description_index_idx).style = index_attribute_map.index (iam_index_idx).style;
	     relation_description.index (description_index_idx).number_of_attributes =
		index_attribute_map.index (iam_index_idx).number_of_attributes;
	     string (relation_description.index (description_index_idx).flags) = "0"b;
	     relation_description.index (description_index_idx).flags.is_unique =
		(index_attribute_map.index (iam_index_idx).number_of_duplication_fields
		= attribute_info.number_of_attributes);

	     do index_attribute_idx = 1 to relation_description.index (description_index_idx).number_of_attributes;
	        relation_description.index (description_index_idx).attribute (index_attribute_idx) =
		   index_attribute_map.index (iam_index_idx).attribute_id (index_attribute_idx);
	     end;
	  end;
      end LOOP_OVER_INDICES;

LOOP_OVER_ATTRIBUTES:
      do attribute_idx = 1 to hbound (relation_description.attribute, 1);
         alloc based_descriptor_string in (p_work_area);
         based_descriptor_string = attribute_info.attribute (attribute_idx).descriptor;
         relation_description.attribute (attribute_idx).descriptor_ptr = based_descriptor_string_ptr;
         relation_description.attribute (attribute_idx).name = attribute_info.attribute (attribute_idx).name;
      end LOOP_OVER_ATTRIBUTES;

      p_relation_description_ptr = relation_description_ptr;

      return;
%page;
FINISH:
   proc ();

      if p_relation_description_ptr = null ()		/*unsuccessful*/
      then if relation_description_ptr ^= null ()
	 then free relation_description;
   end;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_received_version, cv_p_expected_version);

      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_relation_description;
%page;
%include sub_err_flags;
   end rlm_get_description;




		    rlm_get_info.pl1                03/06/85  0749.6r w 03/05/85  0836.8       62559



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */


/* DESCRIPTION:

         This  routine  is a utility which returns selected information about
     the structure of a relation.    The  information  which  is  returned  is
     restricted  to  commonly  used  single pieces of information, such as the
     identifier of an  index.    For  more  information,  the  get_description
     operation should be used.

     Errors are reported via sub_err_.

     The entrypoints in this routine are:
          $get_index_id - given a relation_cursor and an id_list, returns
                          the  identifier  of the index constructed of exactly
                          the set of attributes specified in the id_list in the
                          order specified in the id_list. If no match is found,
                          "0"b is returned.

          $get_record_collection_id - given  a  relation_cursor,  returns  the
                          identifier of the record collection.
*/

/* HISTORY:

Written by Matthew Pierret, 05/23/84.
Modified:
11/09/84 by Stanford S. Cox:  MAIN: Chg upper bound on CEIL do to id_list.number_of_ids.
*/

/* format: style2,ind3 */

rlm_get_info:
   proc ();

      return;

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

      dcl	    p_relation_cursor_ptr  ptr parameter;	/* points to a cursor for the relation*/
      dcl	    p_id_list_ptr	       ptr parameter;	/* points to an id_list structure containing    */
						/* the identifiers of the attributes which make */
						/* up the desired index */

/* Automatic */

      dcl	    code		       fixed bin (35) init (0);
      dcl	    (attribute_idx, index_idx)
			       fixed bin;
      dcl	    local_index_id	       bit (36) aligned;	/* is the identifier of the desired index, or "0"b*/
      dcl	    p_record_collection_id bit (36) aligned;	/* is the identifier of the record collection*/

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("rlm_get_info") char (32) varying internal static options (constant);

/* Entry */

      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

get_record_collection_id:
   entry (p_relation_cursor_ptr) returns (bit (36) aligned);

      relation_cursor_ptr = p_relation_cursor_ptr;

      call CHECK_VERSION (relation_cursor.version, RELATION_CURSOR_VERSION_2, "relation_cursor");

      call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, code);
      if code ^= 0
      then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Unable to get opening information associated with the supplied^/relation_cursor_ptr value, ^p, which is associated with the^/relation opening identifier ^3bo."
	      , relation_cursor_ptr, relation_cursor.file_opening_id);

      call CHECK_VERSION (relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2, "relation_opening_info");

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION (relation_header.version, RELATION_HEADER_VERSION_3, "relation_header");

      p_record_collection_id = relation_header.record_collection_id;

      return (p_record_collection_id);
%page;
get_index_id:
   entry (p_relation_cursor_ptr, p_id_list_ptr) returns (bit (36) aligned);

      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_VERSION (relation_cursor.version, RELATION_CURSOR_VERSION_2, "relation_cursor");

      id_list_ptr = p_id_list_ptr;
      call CHECK_VERSION_FB (id_list.version, (ID_LIST_VERSION_1), "id_list");

      call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, code);
      if code ^= 0
      then call sub_err_ (code, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Unable to get opening information associated with the supplied^/relation_cursor_ptr value, ^p, which is associated with the^/relation opening identifier ^3bo."
	      , relation_cursor_ptr, relation_cursor.file_opening_id);

      call CHECK_VERSION (relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2, "relation_opening_info");

      index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
      call CHECK_VERSION (index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2, "index_attribute_map");

CHECK_EACH_INDEX_LOOP:
      do index_idx = 1 to index_attribute_map.number_of_indices;

         if id_list.number_of_ids = index_attribute_map.index (index_idx).number_of_attributes
         then
	  do;
	     do attribute_idx = 1 to id_list.number_of_ids
		while (id_list.id (attribute_idx)
		= index_attribute_map.index (index_idx).attribute_id (attribute_idx));
	     end;

	     if attribute_idx > index_attribute_map.index (index_idx).number_of_attributes
	     then
	        do;				/* The attributes of this index match the supplied attributes */
		 local_index_id = index_attribute_map.index (index_idx).collection_id;
		 return (local_index_id);
	        end;
	  end;
      end CHECK_EACH_INDEX_LOOP;

      local_index_id = "0"b;

      return (local_index_id);
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%skip;
CHECK_VERSION_FB:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^a of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION_FB;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_id_list;
%page;
%include sub_err_flags;
   end rlm_get_info;




		    rlm_get_tuple_by_id.pl1         03/06/85  0749.6r w 03/05/85  0836.8       89865



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



/* DESCRIPTION:

          Gets a tuple or set of tuples identified by a tuple_id or an array
     of tuple_ids (p_element_id_list_ptr).  The tuples returned consist of the
     subset of attributes identified by the attribute id_list (p_id_list_ptr).
     The tuples returned are actually simple_typed_vectors.  The relation and
     record collection from which to get the tuples are identified in the
     supplied relation_cursor.  If the cursor is not a relation_cursor (e.g.,
     is an index_cursor), the call is in error.
     
          Three entries exist: rlm_get_tuple_by_id$single takes a single
     tuple_id and returns a single simple_typed_vector_ptr;
     rlm_get_tuple_by_id$list takes an array of tuple_ids and returns an array
     of simple_typed_vector_ptrs in a typed_vector_list;
     rlm_get_tuple_by_id$array takes an array of tuple_ids and returns a
     typed_vector_array.
*/

/* HISTORY:
Written by Matthew Pierret 05/10/82.
Modified:
09/24/82 by Matthew Pierret:  Changed to check to see if the supplied cursor
            contains the proper record collection id.  Made to use opening
            information (relation_info) via rlm_opening_info$get.
12/21/82 by Matthew Pierret:  Changed to convert dm_error_$record_not_found to 
            dm_error_$no_tuple_id.
01/18/83 by Matthew Pierret:  Changed to use relation_info version 2.
03/01/83 by Matthew Pierret:  Changed to not use relation_info. Use instead
            relation_opening_info.
05/23/83 by Matthew Pierret:  Changed to use relation_cursor. Added 
            ERROR_RETURN routine. Moved p_relation_cursor_ptr (formerly
            p_record_cursor_ptr) to first in all calling sequences.
            Changed calling sequences: moved p_id_list_ptr to immediately
            before p_work_area_ptr. Changed the name of 
            p_attribute_id_list_ptr to simply p_id_list_ptr.
06/24/83 by Lindsey L. Spratt:  Changed to use version 2 of the
            relation_cursor.
04/13/84 by Lee Baldwin:  Changed calling sequences of record_manager_$get_record_by_id
            and $get_records_by_id_list.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.
11/02/84 by Stanford S. Cox:  MAIN: Asgn. of tva_ptr to null.
   	  FINISH: Added free of tva.  CV: Added unique var prefixes.
*/

/* format: style2,ind3 */

rlm_get_tuple_by_id:
   proc ();

      return;					/* Not a real entry */

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

      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_tuple_id	       bit (36) aligned;
      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_id_list_ptr	       ptr;
      dcl	    p_relation_cursor_ptr  ptr;
      dcl	    p_simple_typed_vector_ptr
			       ptr;
      dcl	    p_typed_vector_list_ptr
			       ptr;
      dcl	    p_typed_vector_array_ptr
			       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    get_single_tuple       bit (1) aligned init ("0"b);
      dcl	    get_list_of_tuples     bit (1) aligned init ("0"b);
      dcl	    get_array_of_tuples    bit (1) aligned init ("0"b);
      dcl	    vector_idx	       fixed bin;
      dcl	    record_collection_cursor_ptr
			       ptr init (null);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Controlled */
/* Constant */

      dcl	    myname	       init ("rlm_get_tuple_by_id") char (32) varying static options (constant);

/* Entry */

      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$record_not_found,
	    dm_error_$tuple_not_found_id
	    )		       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

/* END OF DECLARATIONS */

single:
   entry (p_relation_cursor_ptr, p_tuple_id, p_id_list_ptr, p_work_area_ptr, p_simple_typed_vector_ptr, p_code);

      get_single_tuple = "1"b;
      goto JOIN;


list:
   entry (p_relation_cursor_ptr, p_element_id_list_ptr, p_id_list_ptr, p_work_area_ptr, p_typed_vector_list_ptr, p_code);

      get_list_of_tuples = "1"b;
      goto JOIN;


array:
   entry (p_relation_cursor_ptr, p_element_id_list_ptr, p_id_list_ptr, p_work_area_ptr, p_typed_vector_array_ptr, p_code);

      get_array_of_tuples = "1"b;
      goto JOIN;
%page;
JOIN:
      p_code = 0;
      typed_vector_array_ptr = null ();

      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_VERSION ("relation_cursor", (relation_cursor.version), (RELATION_CURSOR_VERSION_2));

      call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call CHECK_VERSION ("relation_opening_info", (relation_opening_info.version), (RELATION_OPENING_INFO_VERSION_2));

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      on cleanup call FINISH ();

      record_collection_cursor_ptr = SET_RECORD_COLLECTION_CURSOR_PTR ();

/* if relation_info.flags.protected then call lock_manager_$lock */

      if get_single_tuple
      then
         do;
	  call record_manager_$get_record_by_id (p_tuple_id, p_id_list_ptr, p_work_area_ptr,
	       record_collection_cursor_ptr, p_simple_typed_vector_ptr, p_code);
	  if p_code ^= 0
	  then if p_code = dm_error_$record_not_found
	       then call ERROR_RETURN (dm_error_$tuple_not_found_id);
	       else call ERROR_RETURN (p_code);
         end;
      else
         do;
	  call record_manager_$get_records_by_id_list (p_element_id_list_ptr, p_id_list_ptr, p_work_area_ptr,
	       record_collection_cursor_ptr, typed_vector_array_ptr, p_code);
	  if p_code ^= 0
	  then if p_code = dm_error_$record_not_found
	       then call ERROR_RETURN (dm_error_$tuple_not_found_id);
	       else call ERROR_RETURN (p_code);


	  call CHECK_VERSION_FB ("typed_vector_array", (typed_vector_array.version), (TYPED_VECTOR_ARRAY_VERSION_2));

	  if get_array_of_tuples
	  then p_typed_vector_array_ptr = typed_vector_array_ptr;
	  else
	     do;
	        typed_vector_list_ptr = p_typed_vector_list_ptr;
	        call CHECK_VERSION_FB ("typed_vector_list", (typed_vector_list.version), (TYPED_VECTOR_LIST_VERSION_1));

	        typed_vector_list.number_of_vectors =
		   min (typed_vector_list.maximum_number_of_vectors, typed_vector_array.number_of_vectors);

	        do vector_idx = 1 to typed_vector_list.number_of_vectors;
		 typed_vector_list.vector_ptr (vector_idx) = typed_vector_array.vector_slot (vector_idx);
	        end;

	        p_typed_vector_list_ptr = typed_vector_list_ptr;
	     end;

         end;

RETURN:
      return;
%page;
ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      goto RETURN;

   end ERROR_RETURN;

FINISH:
   proc ();

      if typed_vector_array_ptr ^= null ()
      then free typed_vector_array;
      if record_collection_cursor_ptr ^= null & record_collection_cursor_ptr ^= relation_cursor.current.cursor_ptr
      then call record_manager_$destroy_cursor (record_collection_cursor_ptr, (0));

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_received_version, cv_p_expected_version);

      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;


CHECK_VERSION_FB:
   proc (cvf_p_structure_name, cvf_p_received_version, cvf_p_expected_version);

      dcl	    cvf_p_received_version fixed bin (35);
      dcl	    cvf_p_expected_version fixed bin (35);
      dcl	    cvf_p_structure_name   char (*);

      if cvf_p_received_version ^= cvf_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", cvf_p_expected_version, cvf_p_structure_name, cvf_p_received_version);

   end CHECK_VERSION_FB;
%page;
SET_RECORD_COLLECTION_CURSOR_PTR:
   proc () returns (ptr);

      dcl	    srccp_record_collection_cursor_ptr
			       ptr init (null);
      dcl	    srccp_code	       fixed bin (35) init (0);

      if relation_cursor.flags.current_state_is_consistent
	 & relation_cursor.current.collection_id = relation_header.record_collection_id
      then srccp_record_collection_cursor_ptr = relation_cursor.current.cursor_ptr;
      else
         do;
	  call record_manager_$create_cursor (relation_cursor.file_opening_id, relation_header.record_collection_id,
	       relation_cursor.work_area_ptr, srccp_record_collection_cursor_ptr, srccp_code);
	  if srccp_code ^= 0
	  then call ERROR_RETURN (srccp_code);
         end;

      return (srccp_record_collection_cursor_ptr);

   end SET_RECORD_COLLECTION_CURSOR_PTR;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include vu_typed_vector;
%page;
%include vu_typed_vector_array;
%page;
%include dm_typed_vector_list;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include sub_err_flags;

   end rlm_get_tuple_by_id;




		    rlm_get_tuple_id.pl1            12/01/87  1040.4rew 12/01/87  0913.6      351378



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

/* format: off */

/* DESCRIPTION:

         This module searches through a relation, using the
     record_manager_ and/or the index_manager_, returning an array
     of tuple ids that identify the tuples found. This program is a
     replacement for rlm_general_search$get_tuple_id. A call to
     rlm_general_search$get_id has been retained because in the future
     a requirement to implement multiple and-groups or provide the other
     rlm_general_search entrypoints may arise.

         If a search specification is supplied that doesn't have constraints,
     then the record_manager_ is used to get the tuple ids (case 3 in the
     table below). If constraints are present and they only constrain 
     non-indexed fields, then the record_manager_ is used to get the tuple ids
     (this is also case 3). If constraints are present and they only constrain
     fields that are in one index, then the index_manager_ is used to get the
     tuple ids (case 2). Otherwise the index_manager_ is used to get the tuple
     ids, and then record_manager_ is used to search these tuples to determine
     if they meet the rest of the constraints (case 1). Case 1 is implemented
     by the internal subroutine SEARCH_INDEX_AND_RECORD_COLLECTIONS. Case 2
     is implemented by the internal subroutine SEARCH_INDEX_COLLECTION. Case 3
     is implemented by the internal subroutine SEARCH_RECORD_COLLECTION.

     ______________________________________________
     |            | Index Search  |  Record Search |
     |------------|---------------|----------------|
     |    Case 1. |     Yes       |      Yes       |
     |    Case 2. |     Yes       |      No        |
     |    Case 3. |     No        |      Yes       |
     |____________|_______________|________________|
*/

/****^  HISTORY COMMENTS:
  1) change(86-08-19,Dupuis), approve(86-08-19,MCR7401), audit(86-09-30,Blair),
     install(86-10-02,MR12.0-1173):
     Written during August/September of 1986.
  2) change(87-10-27,Hergert), approve(87-11-25,MCR7799),
     audit(87-11-25,Dupuis), install(87-12-01,MR12.2-1007):
     Fixed bug where an uninitialized variable was causing the procedure
     to return to its caller a zero error code when there were no more tuples.
                                                   END HISTORY COMMENTS */
%page;
rlm_get_tuple_id: proc (

	p_relation_cursor_ptr,    /* input: to the relation cursor */
	p_specification_ptr,      /* input: to the relation search spec */
	p_callers_area_ptr,       /* input: element_id_list might go here */
	p_element_id_list_ptr,    /* input/output: to the element_id_list */
	p_code                    /* output: success or failure */
	   );

dcl p_callers_area_ptr ptr parameter;
dcl p_code fixed bin (35) parameter;
dcl p_element_id_list_ptr ptr;
dcl p_relation_cursor_ptr ptr parameter;
dcl p_specification_ptr ptr parameter;

	relation_cursor_ptr = p_relation_cursor_ptr;
	relation_search_specification_ptr = p_specification_ptr;
	callers_area_ptr = p_callers_area_ptr;
	element_id_list_ptr = p_element_id_list_ptr;
	p_code = 0;

	call INITIALIZE;

	on cleanup begin;
	     cleanup_signalled = ON;
	     call TERMINATE;
	end;

	call SETUP_SEARCH_SPECIFICATION (there_is_an_and_group_supplied,
	     primary_collection_id, secondary_collection_id,
	     current_indexes_index, search_the_index, search_the_records,
	     search_specification_is_relative, id_list_ptr);

	call SETUP_REQUIRED_CURSORS_AND_AREA (primary_cursor_ptr, secondary_cursor_ptr, temporary_area_ptr);

	if search_the_index & search_the_records
	then call SEARCH_INDEX_AND_RECORD_COLLECTIONS (number_of_tuples_found);
	else if search_the_records
	     then call SEARCH_RECORD_COLLECTION (number_of_tuples_found);
	     else call SEARCH_INDEX_COLLECTION (number_of_tuples_found);

	if number_of_tuples_found = 0
	then p_code = dm_error_$tuple_not_found;

	call TERMINATE;
	call UPDATE_RELATION_CURSOR;

RETURN:
	return;
%page;
CHECK_VERSION: proc (

	cv_p_structure_name,   /* input: name of structure */
	cv_p_received_version, /* input: version of structure */
	cv_p_expected_version  /* input: expected version of structure */
		   );

dcl cv_p_expected_version char (8) aligned;
dcl cv_p_received_version char (8) aligned;
dcl cv_p_structure_name char (*);

	if cv_p_received_version ^= cv_p_expected_version
	then call sub_err_ (error_table_$unimplemented_version, MY_NAME, ACTION_CANT_RESTART, null, 0,
	     "^/Expected version ^a of the ^a structure.^/Received version ^a instead.",
	     cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

	return;

     end CHECK_VERSION;
%page;
CHECK_VERSION_FB: proc (

	cvf_p_structure_name,   /* input: name of structure */
	cvf_p_received_version, /* input: version of structure */
	cvf_p_expected_version  /* input: expected version of structure */
		   );

dcl cvf_p_expected_version fixed bin (35);
dcl cvf_p_received_version fixed bin (35);
dcl cvf_p_structure_name char (*);

	if cvf_p_received_version ^= cvf_p_expected_version
	then call sub_err_ (error_table_$unimplemented_version, MY_NAME, ACTION_CANT_RESTART, null, 0,
	     "^/Expected version ^d of the ^a structure.^/Received version ^d instead.",
	     cvf_p_expected_version, cvf_p_structure_name, cvf_p_received_version);

	return;

     end CHECK_VERSION_FB;
%page;
ERROR_RETURN: proc (

	er_p_code	/* input: a standard Multics error code */
	         );

dcl er_p_code fixed bin (35) parameter;

	p_code = er_p_code;
	call TERMINATE;

	goto RETURN;

     end ERROR_RETURN;
%page;
INITIALIZE: proc;

dcl i_code fixed bin (35);

	call CHECK_VERSION ("relation_cursor", relation_cursor.version, RELATION_CURSOR_VERSION_2);

	if relation_search_specification_ptr = null
	then call sub_err_ (error_table_$null_info_ptr, MY_NAME, ACTION_CANT_RESTART, null, 0,
	     "^/Support for a null search specification isn't implemented.");
	call CHECK_VERSION_FB ("specification", relation_search_specification.head.version, SPECIFICATION_VERSION_4);

	if element_id_list_ptr ^= null
	then call CHECK_VERSION_FB ("element_id_list", element_id_list.version, ELEMENT_ID_LIST_VERSION_1);
	else call sub_err_ (error_table_$null_info_ptr, MY_NAME, ACTION_CANT_RESTART, null, 0,
	     "^/Only support for a pre-allocated element_id_list is implemented.");

	id_list_ptr = null;
	index_constraints_field_ids_ptr = null;
	index_element_id_list_ptr = null;
	interval_list_ptr = null;
	primary_cursor_ptr = null;
	record_constraints_field_ids_ptr = null;
	record_element_id_list_ptr = null;
	secondary_cursor_ptr = null;
	temporary_area_ptr = null;
	typed_vector_array_ptr = null;
	cleanup_signalled = OFF;
	search_specification_is_relative = OFF;

	if relation_cursor.work_area_ptr = null
	then relation_cursor.work_area_ptr = get_dm_free_area_ ();
	work_area_ptr = relation_cursor.work_area_ptr;

	call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, i_code);
	if i_code ^= 0
	then call ERROR_RETURN (i_code);

	call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

	relation_header_ptr = relation_opening_info.relation_header_ptr;
	call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

	attribute_info_ptr = relation_opening_info.attribute_info_ptr;
	call CHECK_VERSION ("attribute_info", attribute_info.version, ATTRIBUTE_INFO_VERSION_1);

	index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
	call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);

          /* MRDS *never* *ever* sets number_of_and_groups to more than 1. */
	if relation_search_specification.number_of_and_groups > 1
	then do;
	     call rlm_general_search$get_id (p_relation_cursor_ptr, p_specification_ptr,
		p_callers_area_ptr, p_element_id_list_ptr, p_code);
	     return;
	end;

	return;

     end INITIALIZE;
%page;
MOVE_TYPED_VECTOR_ARRAY_TO_ELEMENT_ID_LIST: proc (

	mtvateil_p_typed_vector_array_ptr, /* input: to a typed_vector_array  */
	mtvateil_p_area_ptr,               /* input: to an area for allocations */
	mtvateil_p_element_id_list_ptr,    /* input/output: to an element_id_list */
	mtvateil_p_number_of_tuple_ids     /* output: that the typed_vector_array contained */
				         );

/*   This subroutine moves tuple ids from a typed_vector_array to an 
     element_id_list. The element_id_list is allocated, if necessary, in the
     area provided by the caller. The typed_vector_array points to
     simple_typed_vectors, which in turn point to tuple ids. These structures
     aren't freed after the tuple ids have been moved into the
     element_id_list. Instead, the area is refreshed or thrown away later
     in this program. */

dcl mtvateil_area area (sys_info$max_seg_size) based (mtvateil_p_area_ptr);
dcl mtvateil_loop fixed bin (35);
dcl mtvateil_p_area_ptr ptr parameter;
dcl mtvateil_p_element_id_list_ptr ptr parameter;
dcl mtvateil_p_number_of_tuple_ids fixed bin (35) parameter;
dcl mtvateil_p_typed_vector_array_ptr ptr parameter;
dcl mtvateil_tuple_id bit (36) aligned based;

	if mtvateil_p_typed_vector_array_ptr = null
	then return;

	call CHECK_VERSION_FB ("typed_vector_array", 
	     mtvateil_p_typed_vector_array_ptr -> typed_vector_array.version, 
	     TYPED_VECTOR_ARRAY_VERSION_2);
	mtvateil_p_number_of_tuple_ids = mtvateil_p_typed_vector_array_ptr 
	     -> typed_vector_array.number_of_vectors;

	if mtvateil_p_element_id_list_ptr = null
	then do;
	     eil_number_of_elements = mtvateil_p_number_of_tuple_ids;
	     allocate element_id_list in (mtvateil_area) set (mtvateil_p_element_id_list_ptr);
	     mtvateil_p_element_id_list_ptr -> element_id_list.version = ELEMENT_ID_LIST_VERSION_1;
	end;
	else mtvateil_p_element_id_list_ptr -> element_id_list.number_of_elements
	     = mtvateil_p_number_of_tuple_ids;

	do mtvateil_loop = 1 to mtvateil_p_number_of_tuple_ids;
	     mtvateil_p_element_id_list_ptr -> element_id_list.id (mtvateil_loop)
		= mtvateil_p_typed_vector_array_ptr -> typed_vector_array
		.vector_slot (mtvateil_loop) -> simple_typed_vector.value_ptr (1) -> mtvateil_tuple_id;
	end;

	return;

     end MOVE_TYPED_VECTOR_ARRAY_TO_ELEMENT_ID_LIST;
%page;
SEARCH_INDEX_AND_RECORD_COLLECTIONS: proc (

	siarc_p_number_of_tuples_found   /* output: from the search */
				  );

/*   This subroutine implements case 1. The caller has requested that N tuple 
     ids be retrieved, and the index and records must be searched in order to
     satisfy the search constraints. For this example we will use 1,000 for N
     (the default value of mrds_data_$max_tids_returned_per_call). This
     subroutine first retrieves 1000 tuple ids via index_manager_. It then
     uses record_manager_ to search these 1000 tuples to determine if they
     satisfy the remaining constraints. Let's say that 50 tuples do. It will
     then change the search specification to be relative, and will go back to
     the index_manager_ to get 950 tuple ids. These 950 will be passed to
     record_manager_, etc., etc. This looping between the index_manager_ and
     record_manager_ will continue until all of the keys in the index have
     been examined, or, 1000 tuple ids that match the constraints have been
     retrieved. */

dcl siarc_another_pass_is_required bit (1) aligned;
dcl siarc_code fixed bin (35);
dcl siarc_field_id fixed bin;
dcl siarc_number_of_tuples_remaining_after_record_search fixed bin;
dcl siarc_p_number_of_tuples_found fixed bin (35) parameter;

	call MAKE_CONSTRAINT_LISTS_FOR_INDEX_AND_RECORD_COLLECTIONS;
	siarc_p_number_of_tuples_found = 0;
	siarc_another_pass_is_required = ON;
	element_id_list.number_of_elements = 0;

	do while (siarc_another_pass_is_required);
	     search_specification.range.size
		= number_of_tuples_to_retrieve - siarc_p_number_of_tuples_found;
	     call GET_TUPLE_IDS_FROM_INDEX_COLLECTION;
	     if index_element_id_list_ptr ^= null
	     then call SEARCH_THESE_RECORDS_FOR_MATCHES;
	     else siarc_number_of_tuples_remaining_after_record_search = 0;
	     siarc_p_number_of_tuples_found = siarc_p_number_of_tuples_found
		+ siarc_number_of_tuples_remaining_after_record_search;
	     search_specification.head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE;
	     if siarc_another_pass_is_required
	     then if siarc_p_number_of_tuples_found >= number_of_tuples_to_retrieve
		then siarc_another_pass_is_required = OFF;
	          else do;
		     call define_area_ (area_infop, siarc_code);
		     if siarc_code ^= 0
		     then call ERROR_RETURN (siarc_code);
		end;
	     else;
	end; 

	return;
%page;
GET_TUPLE_IDS_FROM_INDEX_COLLECTION: proc;

/*  This subroutine gets tuple ids from the index_manager_. Any
    element_id_list that is left over from the previous call is freed,
    and then the constraints for this index search are moved into the
    search_specification structure. The index_manager_ is then called and
    returns a typed_vector_array that eventually points to the tuple ids that
    satisfy the constraints of the search. These tuple ids are moved to the
    element_id_list pointed to by index_element_id_list_ptr, and this 
    element_id_list will later be input to the record_manager_'s search. */

dcl gtific_code fixed bin (35);
dcl gtific_loop fixed bin;

	index_element_id_list_ptr = null;
	typed_vector_array_ptr = null;
	interval_list_ptr = null;

	do gtific_loop = 1 to number_of_index_and_record_constraints;
	     search_specification.and_group (1).constraint (gtific_loop).field_id
		= index_constraints_field_ids (gtific_loop);
	end;

	call index_manager_$get_key (search_specification_ptr, id_list_ptr,
	     temporary_area_ptr, primary_cursor_ptr, typed_vector_array_ptr,
	     interval_list_ptr, gtific_code);
	if gtific_code ^= 0 & gtific_code ^= dm_error_$key_not_found
	then call ERROR_RETURN (gtific_code);

	if gtific_code = dm_error_$key_not_found
	then siarc_another_pass_is_required = OFF;
	else if typed_vector_array.number_of_vectors < search_specification.range.size
	     then siarc_another_pass_is_required = OFF;

	call MOVE_TYPED_VECTOR_ARRAY_TO_ELEMENT_ID_LIST (typed_vector_array_ptr,
	     temporary_area_ptr, index_element_id_list_ptr, (0));

	return;

     end GET_TUPLE_IDS_FROM_INDEX_COLLECTION;
%page;
MAKE_CONSTRAINT_LISTS_FOR_INDEX_AND_RECORD_COLLECTIONS: proc;

/*   This subroutine makes a constraint list for the index_manager_ and a 
     constraint list for the record_manager_. It makes them from the
     constraints present in the relation_search_specification that is passed in
     by the caller. The constraints will identify attributes by their position
     in the relation. The record_manager_ and index_manager_ will use any
     constraints whose value is greater than zero, so an attribute that isn't
     present in the index or record collection needs to be set to zero by
     this subroutine, so that the index_manager_ or record_manager_ will
     ignore it. Also, the index_manager_ wants an index into the 
     index_attribute_map instead of the attributes position within the 
     relation, so this adjustment must also be done.

     An example best illustrates this. Suppose that attribute number 6 is
     indexed for this example. The transformation could look something like:

         ON INPUT             FOR THE INDEX           FOR THE RECORD
     constraint (1) = 5     constraint (1) = 0       constraint (1) = 5
     constraint (2) = 2     constraint (2) = 0       constraint (2) = 2
     constraint (3) = 6     constraint (3) = 1       constraint (3) = 0
     constraint (4) = 5     constraint (4) = 0       constraint (4) = 5
     constraint (5) = 3     constraint (5) = 0       constraint (5) = 3 */

dcl mclfiarc_inner_loop fixed bin;
dcl mclfiarc_loop fixed bin;

	number_of_index_and_record_constraints = relation_search_specification.and_group (1).number_of_constraints;
	allocate index_constraints_field_ids in (work_area) set (index_constraints_field_ids_ptr);
	allocate record_constraints_field_ids in (work_area) set (record_constraints_field_ids_ptr);
	index_constraints_field_ids (*) = 0;
	record_constraints_field_ids (*) = 0;
	
	do mclfiarc_loop = 1 to number_of_index_and_record_constraints;
	     siarc_field_id = relation_search_specification.and_group (1)
		.constraint (mclfiarc_loop).field_id;
	     do mclfiarc_inner_loop = 1 to index_attribute_map.index (current_indexes_index).number_of_attributes
		while (siarc_field_id ^= index_attribute_map.index (current_indexes_index)
		.attribute_id (mclfiarc_inner_loop));
	     end;
	     if mclfiarc_inner_loop > index_attribute_map.index (current_indexes_index).number_of_attributes
	     then record_constraints_field_ids (mclfiarc_loop) = siarc_field_id;
	     else index_constraints_field_ids (mclfiarc_loop) = mclfiarc_inner_loop;
	end;

	return;

     end MAKE_CONSTRAINT_LISTS_FOR_INDEX_AND_RECORD_COLLECTIONS;
%page;
SEARCH_THESE_RECORDS_FOR_MATCHES: proc;

/*   This subroutine takes an element_id_list as input that identifies the 
     tuples selected by the index search, and gets the record_manager_ to
     search these tuples applying the additional constraints. The tuples that
     satisfy these additional constraints will be returned to the caller. These
     tuples have their ids returned by record_manager_ in the element_id_list
     pointed to by record_element_id_list_ptr. These tuple ids are then moved
     into the caller's element_id_list. */

dcl strfm_code fixed bin (35);
dcl strfm_loop fixed bin;

	record_element_id_list_ptr = null;

	do strfm_loop = 1 to number_of_index_and_record_constraints;
	     search_specification.and_group (1).constraint (strfm_loop).field_id
		= record_constraints_field_ids (strfm_loop);
	end;

	call record_manager_$get_record_ids_by_interval (index_element_id_list_ptr,
	     search_specification_ptr, interval_list_ptr, temporary_area_ptr,
	     secondary_cursor_ptr, record_element_id_list_ptr, strfm_code);
	if strfm_code ^= dm_error_$record_not_found & strfm_code ^= 0
	then call ERROR_RETURN (strfm_code);

	if strfm_code = 0
	then do;
	     siarc_number_of_tuples_remaining_after_record_search
		= record_element_id_list_ptr -> element_id_list.number_of_elements;
	     do strfm_loop = 1 to siarc_number_of_tuples_remaining_after_record_search;
		element_id_list.number_of_elements = element_id_list.number_of_elements + 1;
		element_id_list.id (element_id_list.number_of_elements)
		     = record_element_id_list_ptr -> element_id_list.id (strfm_loop);
	     end;
	end;
	else siarc_number_of_tuples_remaining_after_record_search = 0;

	return;

     end SEARCH_THESE_RECORDS_FOR_MATCHES;

     end SEARCH_INDEX_AND_RECORD_COLLECTIONS;
%page;
SEARCH_INDEX_COLLECTION: proc (

	sic_p_number_of_tuples_found  /* output: from the index search */
			);

/*   This subroutine searches an index via the index_manager_ and returns the
     tuple ids of tuples that satisfied the search constraints. The constraints
     are moved from the caller-supplied relation_search_specification into the
     search_specification structure, and then the attribute ids (the position
     of the attribute within the relation) are transformed into indexes into 
     the index_attribute_map. The index_manager_ is then called, and the
     returned tuple ids are moved from the typed_vector_array to the caller's
     element_id_list. */

dcl sic_attribute_id fixed bin;
dcl sic_code fixed bin (35);
dcl sic_inner_loop fixed bin;
dcl sic_loop fixed bin;
dcl sic_p_number_of_tuples_found fixed bin (35) parameter;

	do sic_loop = 1 to relation_search_specification.and_group (1).number_of_constraints;
	     sic_attribute_id = relation_search_specification.and_group (1).constraint (sic_loop).field_id;
	     do sic_inner_loop = 1 to index_attribute_map.index (current_indexes_index).number_of_attributes
		while (index_attribute_map.index (current_indexes_index)
		.attribute_id (sic_inner_loop) ^= sic_attribute_id);
	     end;
	     if sic_inner_loop > index_attribute_map.index (current_indexes_index).number_of_attributes
	     then call sub_err_ (dm_error_$unexpected_search_case, MY_NAME, ACTION_CANT_RESTART, null, 0,
		"^/Attribute #^d wasn't found in the index_attribute_map.", sic_attribute_id);
	     search_specification.and_group (1).constraint (sic_loop).field_id = sic_inner_loop;
	end;

	call index_manager_$get_key (search_specification_ptr, id_list_ptr,
	     temporary_area_ptr, primary_cursor_ptr, typed_vector_array_ptr,
	     interval_list_ptr, sic_code);
	if sic_code = 0
	then call MOVE_TYPED_VECTOR_ARRAY_TO_ELEMENT_ID_LIST (
	     typed_vector_array_ptr, callers_area_ptr, element_id_list_ptr, sic_p_number_of_tuples_found);
	else if sic_code = dm_error_$key_not_found
	     then sic_p_number_of_tuples_found = 0;
	     else call ERROR_RETURN (sic_code);

	return;

     end SEARCH_INDEX_COLLECTION;
%page;
SEARCH_RECORD_COLLECTION: proc (

	src_p_number_of_tuples_found /* output: from the record search */
			 );

/*   This subroutine searches a relation via the record_manager_ and returns
     the tuple ids of tuples that satisified the search constraints. The tuple
     ids are moved into the caller-supplied element_id_list by the
     record_manager_. */

dcl src_code fixed bin (35);
dcl src_p_number_of_tuples_found fixed bin (35) parameter;

	call record_manager_$get_record_ids_by_spec (search_specification_ptr,
	     work_area_ptr, primary_cursor_ptr, element_id_list_ptr, src_code);

	if src_code = 0
	then src_p_number_of_tuples_found = element_id_list_ptr -> element_id_list.number_of_elements;
	else if src_code = dm_error_$record_not_found
	     then src_p_number_of_tuples_found = 0;
	     else call ERROR_RETURN (src_code);

	return;

     end SEARCH_RECORD_COLLECTION;
%page;
SETUP_REQUIRED_CURSORS_AND_AREA: proc (

	srcaa_p_primary_cursor_ptr,      /* output: for index_manager_ or record_manager_ */
	srcaa_p_secondary_cursor_ptr,    /* output: for record_manager_ or null */
	srcaa_p_area_ptr                 /* output: to an area or null */
		         );

/*   This subroutine sets up the required cursors and area. If it is case 1 
     then the primary cursor will be for the index and the secondary cursor 
     will be for the records. If it is case 2 the primary cursor will be
     for the index and the secondary cursor will be null. If it is case 3
     the primary cursor will be for the records and the secondary cursor
     will be null. If the index has to be searched then a temporary area
     will be acquired so that the typed_vector_array, simple_typed_vectors,
     etc. don't have to be freed. Instead the area will be refreshed. */

dcl srcaa_code fixed bin (35);
dcl srcaa_p_area_ptr ptr;
dcl srcaa_p_primary_cursor_ptr ptr parameter;
dcl srcaa_p_secondary_cursor_ptr ptr parameter;

	if ^search_specification_is_relative
	then do;
	     if search_the_index
	     then call index_manager_$create_cursor (relation_cursor.file_opening_id,
		primary_collection_id, relation_cursor.work_area_ptr,
		srcaa_p_primary_cursor_ptr, srcaa_code);
	     else call record_manager_$create_cursor (relation_cursor.file_opening_id,
		primary_collection_id, relation_cursor.work_area_ptr,
		srcaa_p_primary_cursor_ptr, srcaa_code);
	     if srcaa_code ^= 0
	     then call ERROR_RETURN (srcaa_code);
	end;
	else srcaa_p_primary_cursor_ptr = relation_cursor.current.cursor_ptr;

	if search_the_index & search_the_records
	then do;
	     call record_manager_$create_cursor (
		relation_cursor.file_opening_id, secondary_collection_id,
		relation_cursor.work_area_ptr, srcaa_p_secondary_cursor_ptr, srcaa_code);
	     if srcaa_code ^= 0
	     then call ERROR_RETURN (srcaa_code);
	end;
	else srcaa_p_secondary_cursor_ptr = null;

	if search_the_index
	then do;
	     call get_temp_segment_ (MY_NAME, srcaa_p_area_ptr, srcaa_code);
	     if srcaa_code ^= 0
	     then call ERROR_RETURN (srcaa_code);
	     area_infop = addr (automatic_area_info);
	     unspec (area_info) = OFF;
	     area_info.version = area_info_version_1;
	     unspec (area_info.control) = OFF;
	     area_info.control.extend = ON;
	     area_info.owner = MY_NAME;
	     area_info.size = sys_info$max_seg_size;
	     area_info.areap = srcaa_p_area_ptr;
	     call define_area_ (area_infop, srcaa_code);
	     if srcaa_code ^= 0
	     then call ERROR_RETURN (srcaa_code);
	end;
	else srcaa_p_area_ptr = null;

	relation_cursor.flags.current_state_is_consistent = OFF;

	return;

     end SETUP_REQUIRED_CURSORS_AND_AREA;
%page;
SETUP_SEARCH_SPECIFICATION: proc (

	sss_p_there_is_an_and_group,   /* output: if number_of_and_groups = 1*/
	sss_p_primary_collection_id,   /* output: for the index or record collection */
	sss_p_secondary_collection_id, /* output: for the record collection when primary is for the index collection */
	sss_p_current_indexes_index,   /* output: index of our current index, or -1 if there isn't one */
	sss_p_search_the_index,        /* output: on if we have to search the index collection */
	sss_p_search_the_records,      /* output: on if we have to search the record collection */
	sss_p_search_specification_is_relative,
                                         /* output: on if this search is a continuation of a previous search */
	sss_p_id_list_ptr              /* output: to an id_list if we have to search the index collection */
			   );

/*   This subroutine takes a relation_search_specification as input and
     creates a search_specification that will later be used by the 
     index_manager_ and/or the record_manager_. The search_specification
     is the internal version of the relation_search_specification. Additional
     comments are provided in-line in the code below. */

dcl sss_current_attribute fixed bin;
dcl sss_current_constraint fixed bin;
dcl sss_loop fixed bin;
dcl sss_p_current_indexes_index fixed bin parameter;
dcl sss_p_id_list_ptr ptr parameter;
dcl sss_p_primary_collection_id bit (36) aligned parameter;
dcl sss_p_search_specification_is_relative bit (1) aligned parameter;
dcl sss_p_search_the_index bit (1) aligned parameter;
dcl sss_p_search_the_records bit (1) aligned parameter;
dcl sss_p_secondary_collection_id bit (36) aligned parameter;
dcl sss_p_there_is_an_and_group bit (1) aligned parameter;

	if relation_search_specification.head.type = ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE
	then call SETUP_ABSOLUTE_SEARCH_SPEC;
	else if relation_search_specification.head.type = RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE
	     then call SETUP_RELATIVE_SEARCH_SPEC;
	     else call sub_err_ (dm_error_$unsup_search_spec_head_type,
		MY_NAME, ACTION_CANT_RESTART, null, 0,
		"^/The type of specification supplied (^d) is not supported.",
		relation_search_specification.head.type);

          /* size is not supposed to be used for ALL_RANGE_TYPE */

	if search_specification.range.type ^= ALL_RANGE_TYPE
	then number_of_tuples_to_retrieve = search_specification.range.size;
	else number_of_tuples_to_retrieve = MAXIMUM_REASONABLE_VALUE;
	element_id_list.number_of_elements = number_of_tuples_to_retrieve;

	sss_p_there_is_an_and_group = (search_specification.number_of_and_groups = 1);

          /* Move each constraint from relation_search_specification to search_specification. */

	if sss_p_there_is_an_and_group
	then do sss_loop = 1 to relation_search_specification.and_group (1).number_of_constraints;
	     search_specification.and_group (1).number_of_constraints = sss_loop;
	     search_specification.and_group (1).constraint (sss_loop)
		= relation_search_specification.and_group (1).constraint (sss_loop);
	end;
%page;
	/* If the search is a continuation get the primary collection id from the relation_cursor. Otherwise */
          /* set the primary collection id to the index or record collection id. */

	if sss_p_search_specification_is_relative
	then sss_p_primary_collection_id = relation_cursor.current.collection_id;
	else if sss_p_there_is_an_and_group
	     then if relation_search_specification.and_group (1).flags.collection_id_supplied
	          then sss_p_primary_collection_id = relation_search_specification.and_group (1).search_collection_id;
	          else sss_p_primary_collection_id = relation_header.record_collection_id;
	     else sss_p_primary_collection_id = relation_header.record_collection_id;

          /* If the primary collection id is for the index then look up the index into the index_attribute_map. */

	if sss_p_primary_collection_id = relation_header.record_collection_id
	then do;
	     sss_p_current_indexes_index = -1;
	     sss_p_search_the_index = OFF;
	end;
	else do;
	     do sss_p_current_indexes_index = 1 to hbound (index_attribute_map.index, 1)
		while (index_attribute_map.index (sss_p_current_indexes_index).collection_id 
		^= sss_p_primary_collection_id);
	     end;
	     if sss_p_current_indexes_index > hbound (index_attribute_map.index, 1)
	     then call ERROR_RETURN (dm_error_$index_not_in_relation);
	     sss_p_search_the_index = ON;
	end;

          /* If we aren't going to do an index search then a record search is necessary. */
          /* A record search is also necessary if all of the fields constrained aren't present in the index. */

	if ^sss_p_search_the_index
	then sss_p_search_the_records = ON;
	else if sss_p_search_specification_is_relative
	     then sss_p_search_the_records = relation_cursor.current.flags.search_index_and_record_collection;
	     else do;
		sss_p_search_the_records = OFF;
		do sss_current_constraint = 1 to search_specification.and_group (1).number_of_constraints
		     while (^sss_p_search_the_records);
		     do sss_current_attribute = 1 to 
			index_attribute_map.index (sss_p_current_indexes_index).number_of_attributes
			while (search_specification.and_group (1).constraint (sss_current_constraint).field_id
			^= index_attribute_map.index (sss_p_current_indexes_index)
			.attribute_id (sss_current_attribute));
		     end;
		     if sss_current_attribute
		     > index_attribute_map.index (sss_p_current_indexes_index).number_of_attributes
		     then sss_p_search_the_records = ON;
		end;
	     end;
%page;
          /* Set the secondary collection id to the record collection or nothing. */

	if sss_p_search_the_index & sss_p_search_the_records
	then sss_p_secondary_collection_id = relation_header.record_collection_id;
	else sss_p_secondary_collection_id = OFF;

          /*  If we're going to search the index then set the id_list to point to the tuple identifier. */

	if sss_p_search_the_index
	then do;
	     il_number_of_ids = 1;
	     allocate id_list in (work_area) set (sss_p_id_list_ptr);
	     sss_p_id_list_ptr -> id_list.version = ID_LIST_VERSION_1;
	     sss_p_id_list_ptr -> id_list.id (1) = index_attribute_map.index
		(sss_p_current_indexes_index).number_of_attributes + 1;
	end;

	return;
%page;
SETUP_ABSOLUTE_SEARCH_SPEC: proc;

/*   This subroutine is called the first time through a search. It initializes
     relation_cursor.current and allocates/initializes the search_specification
     structure used by the index_manager_ and record_manager_. */

	unspec (relation_cursor.flags) = OFF;
	unspec (relation_cursor.current) = OFF;
	relation_cursor.current.specification_ptr = null;
	relation_cursor.current.cursor_ptr = null;

	ss_maximum_number_of_constraints = relation_search_specification.maximum_number_of_constraints;
	ss_number_of_and_groups = max (0, relation_search_specification.number_of_and_groups);
	allocate search_specification in (work_area) set (search_specification_ptr);

	search_specification.head = relation_search_specification.head;
	search_specification.head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE;
	search_specification.range.type = relation_search_specification.range.type;
	search_specification.range.size = relation_search_specification.range.size;

	return;

     end SETUP_ABSOLUTE_SEARCH_SPEC;
%page;
SETUP_RELATIVE_SEARCH_SPEC: proc;

/*   This subroutine is called the second thru Nth phase of the search. It
     mostly does consistency checks. */

	sss_p_search_specification_is_relative = ON;

	if ^relation_cursor.flags.current_state_is_consistent
	| relation_cursor.current.cursor_ptr = null
	then call sub_err_ (dm_error_$bad_rel_cursor_pos, MY_NAME,
	     ACTION_CANT_RESTART, null, 0,
	     "^/The relation cursor does not completely describe a current position.");

	if relation_cursor.current.specification_ptr = null
	then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, MY_NAME,
	     ACTION_CANT_RESTART, null, 0,
	     "^/Expected a search specification; received a null specification.");

	search_specification_ptr = relation_cursor.current.specification_ptr;
	search_specification.head.type = RELATIVE_SEARCH_SPECIFICATION_TYPE;
	search_specification.range.type = relation_search_specification.range.type;
	search_specification.range.size = relation_search_specification.range.size;

	if relation_search_specification.number_of_and_groups > 0
	then do;
	     if relation_search_specification.and_group (1).flags.collection_id_supplied
	     then if relation_search_specification.and_group (1)
		.search_collection_id ^= relation_cursor.current.collection_id
		then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, MY_NAME, ACTION_CANT_RESTART, null, 0,
		     "^/Expected a specification for collection ^w; received one for ^w.",
		     relation_cursor.current.collection_id,
		     relation_search_specification.and_group (1).search_collection_id);
	          else;
	     else if relation_cursor.current.collection_id ^= relation_header.record_collection_id
		then call sub_err_ (dm_error_$rel_cursor_spec_mismatch, MY_NAME, ACTION_CANT_RESTART, null, 0,
		     "^/Expected a specification for collection ^w; received one^/with no collection specified.",
		     relation_cursor.current.collection_id);
	end;

	return;

     end SETUP_RELATIVE_SEARCH_SPEC;

end SETUP_SEARCH_SPECIFICATION;
%page;
TERMINATE: proc;

/*   This subroutine is called on normal termination or when cleanup has been
     signalled. It frees things, releases an area, and destroys the secondary
     cursor. */

	if secondary_cursor_ptr ^= null
	then call record_manager_$destroy_cursor (secondary_cursor_ptr, (0));

	if id_list_ptr ^= null
	then free id_list;

	if record_element_id_list_ptr ^= null
	then free record_element_id_list_ptr -> element_id_list;

	if index_constraints_field_ids_ptr ^= null
	then free index_constraints_field_ids;

	if record_constraints_field_ids_ptr ^= null
	then free record_constraints_field_ids;

	if temporary_area_ptr ^= null
	then call release_temp_segment_ (MY_NAME, temporary_area_ptr, (0));

	return;

     end TERMINATE;
%page;
UPDATE_RELATION_CURSOR: proc;

/*   This subroutine updates the relation_cursor.current fields so that on
     subsequent calls it can search relative to where it currently is. */

	if ^search_specification_is_relative
	then do;
	     relation_cursor.current.flags.search_index_and_record_collection
		= search_the_index & search_the_records;
	     relation_cursor.current.collection_id = primary_collection_id;
	     relation_cursor.current.specification_ptr = search_specification_ptr;
	     relation_cursor.current.cursor_ptr = primary_cursor_ptr;
	end;

	relation_cursor.flags.current_state_is_consistent = ON;

	return;

     end UPDATE_RELATION_CURSOR;
%page;
dcl OFF bit (1) internal static options (constant) init ("0"b);
dcl ON bit (1) internal static options (constant) init ("1"b);

dcl MAXIMUM_REASONABLE_VALUE fixed bin (35) internal static options (constant) init (225000);
dcl MY_NAME char (16) internal static options (constant) init ("rlm_get_tuple_id");

dcl addr builtin;
dcl 1 automatic_area_info like area_info automatic;

dcl callers_area_ptr ptr;
dcl cleanup condition;
dcl cleanup_signalled bit (1) aligned;
dcl current_indexes_index fixed bin;

dcl define_area_ entry (ptr, fixed bin(35));
dcl dm_error_$bad_rel_cursor_pos fixed bin(35) ext static;
dcl dm_error_$index_not_in_relation fixed bin(35) ext static;
dcl dm_error_$key_not_found fixed bin(35) ext static;
dcl dm_error_$record_not_found fixed bin(35) ext static;
dcl dm_error_$rel_cursor_spec_mismatch fixed bin(35) ext static;
dcl dm_error_$tuple_not_found fixed bin(35) ext static;
dcl dm_error_$unexpected_search_case fixed bin(35) ext static;
dcl dm_error_$unsup_search_spec_head_type fixed bin(35) ext static;

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

dcl get_dm_free_area_ entry() returns(ptr);
dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35));

dcl hbound builtin;

dcl index_constraints_field_ids (number_of_index_and_record_constraints) fixed bin based (index_constraints_field_ids_ptr);
dcl index_constraints_field_ids_ptr ptr;
dcl index_element_id_list_ptr ptr;

dcl max builtin;

dcl null builtin;
dcl number_of_index_and_record_constraints fixed bin;
dcl number_of_tuples_found fixed bin (35);
dcl number_of_tuples_to_retrieve fixed bin (35);

dcl primary_collection_id bit (36) aligned;
dcl primary_cursor_ptr ptr;

dcl record_constraints_field_ids (number_of_index_and_record_constraints) fixed bin based (record_constraints_field_ids_ptr);
dcl record_constraints_field_ids_ptr ptr;
dcl record_element_id_list_ptr ptr;
dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl rlm_general_search$get_id entry (ptr, ptr, ptr, ptr, fixed bin(35));
dcl rlm_opening_info$get entry (bit(36) aligned, ptr, fixed bin(35));

dcl search_the_index bit (1) aligned;
dcl search_the_records bit (1) aligned;
dcl search_specification_is_relative bit (1) aligned;
dcl secondary_collection_id bit (36) aligned;
dcl secondary_cursor_ptr ptr;
dcl sub_err_ entry() options(variable);
dcl sys_info$max_seg_size fixed bin(35) ext static;

dcl temporary_area_ptr ptr;
dcl there_is_an_and_group_supplied bit (1) aligned;

dcl unspec builtin;

dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include area_info;
%page;
%include dm_element_id_list;
%page;
%include dm_range_constants;
%page;
%include dm_id_list;
%page;
%include dm_idxmgr_entry_dcls;
%page;
%include dm_interval_list;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_relation_spec;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_specification;
%page;
%include dm_specification_head;
%page;
%include sub_err_flags;
%page;
%include vu_typed_vector;
%page;
%include vu_typed_vector_array;

end rlm_get_tuple_id;




		    rlm_open.pl1                    01/04/85  0917.4re  01/03/85  1147.9       56628



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

/* format: style2,ind3 */

rlm_open:
   proc ();

      return;					/* Not a valid entry point. */


/* DESCRIPTION

          This routine handles open and close requests with the two entries:
     $open:
          opens a relation, sets up relation opening structures if they have
     not been set up by a prior open, increments the count of openings for this
     process for this relation, and returns the file opening id as the
     rel_opening_id.

     $close: 
          decrements the count of openings. The relation_opening_info structure
     is gotten via rlm_opening_info$get_dont_refresh.  If the count of
     openings becomes 0, the relation_opening_info structure is freed (causing
     the relation_opening_info_ptr to become null) and the file is closed.
*/

/* HISTORY:
Written by Matthew Pierret, 04/28/82.
Modified:
10/19/82 by Matthew Pierret:  Added capability to generate and store 
            relation_info, maintain number of openings.
10/20/82 by Matthew Pierret:  Converted to use file_manager_.
03/01/83 by Matthew Pierret:  Changed to use rlm_update_opening_info.
            Added $close.
03/16/83 by Matthew Pierret:  Changed $close to use rlm_opening_info
            $get_dont_refresh. This is because to close a relation, the
            refresh-able information is not needed (or desired).
05/16/83 by Lindsey L. Spratt:  Changed to call file_manager_$close in the
            $close entry if the call to rlm_update_opening_info$decrement*
            causes the relation_opening_info to be freed.
04/19/84 by Lindsey L. Spratt:  Fixed to only do the $init and $refresh if the
            error code from $get is dm_error_$relation_not_open, otherwise if
            the code is non-zero then this module just returns.
10/26/84 by Stanford S. Cox:  $open: Added cleanup. $close: moved fm_$close
            call from rlm_opening_info$free. ERROR_RETURN: modified from OPEN_=
            for use by $close. RETURN(added): for a common return point.
            FINISH(added)
11/26/84 by Stanford S. Cox:  ERROR_RETURN: Added call to FINISH.
*/

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

      dcl	    p_rel_dir	       char (*);
      dcl	    p_rel_entry	       char (*);
      dcl	    p_rel_opening_id       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */
/* Based */
/* Cleanup */

      dcl	    cleanup	       condition;

/* Builtin */

      dcl	    null		       builtin;

/* Controlled */
/* Constant */

      dcl	    IS_OPEN_ENTRY	       init ("1"b) bit (1) int static options (constant);
      dcl	    IS_CLOSE_ENTRY	       init ("0"b) bit (1) int static options (constant);
      dcl	    myname	       init ("rlm_open") char (8) internal static options (constant);

/* Entry */

      dcl	    file_manager_$open     entry (char (*), char (*), bit (36) aligned, fixed bin (35));
      dcl	    file_manager_$close    entry (bit (36) aligned, fixed bin (35));

      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_opening_info$get_dont_refresh
			       entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_opening_info$refresh
			       entry (ptr, fixed bin (35));
      dcl	    rlm_opening_info$init  entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$increment_openings
			       entry (ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$decrement_openings
			       entry (ptr, fixed bin (35));

/* External */

      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    dm_error_$file_already_open
			       ext fixed bin (35);
      dcl	    dm_error_$relation_not_open
			       ext fixed bin (35);

/* END OF DECLARATIONS */

open:
   entry (p_rel_dir, p_rel_entry, p_rel_opening_id, p_code);

      p_code = 0;
      p_rel_opening_id = "0"b;

      on cleanup call FINISH;
      call file_manager_$open (p_rel_dir, p_rel_entry, p_rel_opening_id, p_code);

      if p_code ^= 0 & p_code ^= dm_error_$file_already_open
      then call ERROR_RETURN (IS_OPEN_ENTRY, p_code);

      p_code = 0;

      call rlm_opening_info$get (p_rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then if p_code ^= dm_error_$relation_not_open
	 then call ERROR_RETURN (IS_OPEN_ENTRY, p_code);
	 else
	    do;
	       call rlm_opening_info$init (p_rel_opening_id, relation_opening_info_ptr, p_code);
	       if p_code ^= 0
	       then call ERROR_RETURN (IS_OPEN_ENTRY, p_code);

	       call rlm_opening_info$refresh (relation_opening_info_ptr, p_code);
	       if p_code ^= 0
	       then call ERROR_RETURN (IS_OPEN_ENTRY, p_code);
	    end;


      call rlm_update_opening_info$increment_openings (relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (IS_OPEN_ENTRY, p_code);

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_is_open_entry, er_p_code);

      dcl	    er_p_is_open_entry     bit (1) parameter;
      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      if er_p_is_open_entry
      then
         do;
	  call FINISH ();
	  p_rel_opening_id = "0"b;
         end;
      call RETURN;
   end ERROR_RETURN;
%skip;
RETURN:
   proc ();
      goto MAIN_RETURN;
   end;
%skip;
FINISH:
   proc ();
      call file_manager_$close (p_rel_opening_id, p_code);
   end;
%page;
close:
   entry (p_rel_opening_id, p_code);

      call rlm_opening_info$get_dont_refresh (p_rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (IS_CLOSE_ENTRY, p_code);

      call rlm_update_opening_info$decrement_openings (relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (IS_CLOSE_ENTRY, p_code);

      call file_manager_$close (p_rel_opening_id, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (IS_CLOSE_ENTRY, p_code);

      call RETURN;
%page;
%include dm_rlm_opening_info;

   end rlm_open;




		    rlm_opening_info.pl1            04/04/85  1109.9re  04/04/85  0823.6      216279



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


/* DESCRIPTION:

     $get:
         Gets a pointer to the relation_opening_info structure associated with
     the current opening of the specified relation.  If the relation is not 
     open, dm_error_$relation_not_open is returned. If this is the first "get"
     for a transaction, "refresh" also. 

     $get_dont_refresh:
          Same as above, but never "refresh."

     $refresh:
          Re-read the opening information out of the file. If the 
     header_info_update_count is unchanged, the attribute_info and
     index_attribute_map have not been changed, so need not be read again.

     $init:
          Allocate a relation_opening_info structure in the dm free area
     and record a pointer to it in the opening table.
     
     $free:
          Free the relation_opening_info structure and remove the entry
     in the opening table.
     
         The  opening_manager_  is  used  to  keep  a  table of openings.  The
     pointer   to   that   table   is    kept    in    a    static    variable
     (static_opening_table_ptr).
          NOTE: p_file_opening_id is the same as the file_opening_id for the page
     file in which the relation resides.
*/

/* HISTORY:

Written by Matthew Pierret, 07/27/82.
Modified:
10/12/82 by Matthew Pierret:  Changed $set to interpret a non-null p_opening_info_ptr
            to be a pointer to an old relation_info_ptr that must be freed.
            Fixed subscript range bug encountered when index_attribute_map.index
            and relation_info.index are of different extent.
02/25/83 by Matthew Pierret: Changed to use relatin_opening_info instead of
            relation_info. Removed $set; added $free. This module now deals
            only with the relation_opening_info structure and interactions
            with opening_manager_.
03/10/83 by Matthew Pierret: Fixed $free to use roi.pp.file_opening_id
            instead of p_file_opening_id.
            Fixed attempts to do "currentsize (XXX)" when XXX_ptr was null.
            Changed to correctly set roi.pp.index_cursor_array_ptr after
            allocating an index_cursor_array for the first time.
            Changed to refresh whenever any roi pointers are null.
03/14/83 by Matthew Pierret: Changed CURRENT_TRANSACTION_ID to use a local
            variable (cti_code) instead of p_code, so that the non-error
            dm_error_$no_current_transaction is not reported.
03/16/83 by Matthew Pierret: Added $get_dont_refresh. This entry is used by
            rlm_$close and rlm_$set_scope to get only the 
            relation_opening_info structure. No refreshing is done because
            these operations are defined to work outside of transactions.
03/21/83 by Matthew Pierret: Changed to always create a record cursor if
            none exists (in $get, $refresh).
03/24/83 by Matthew Pierret: Moved creation of record cursor ($get, $refresh)
            after retrieval of relation_header, because the relation_header
            is needed to create the cursor. Removed maintenance of 
            old_relation_header_ptr: there should never be an "old" 
            relation_header. Changed FINISH to free old_XXX_ptr->XXX
            instead of XXX.
03/24/83 by Jeffrey D. Ives for Matthew Pierret: changed the logic following
            the call to opening_manager_$get_opening after "GET:" to return
            an error code when the relation is not open instead of falling
            through with a null relation_opening_info_ptr.
04/11/83 by Lindsey L. Spratt:  Changed to return immediately after
            determining that the static_opening_table_ptr is null (and,
            therefore, the desired opening can't exist).
04/19/84 by Lindsey L. Spratt:  Fixed $free to also close the DM file.  Fixed
            $init to signal a sub_err_ when the relation_opening_info to be
            initialized already exists.
           Changed to use transaction_manager_$get_current_ids to get both
            the transaction_id and the rollback_count.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.
06/07/84 by Matthew Pierret:  Re-named cm_$get_element to cm_$get.

10/25/84 by Stanford S.  Cox:  REFRESH - Changed call to rm_$create_cursor to use 
	  local variable instead of record_cursor_ptr, added asgn. of
	  index_cursor_array.version.  $init - Added cleanup handler, asgmt.
	  of p_relation_opening_info_ptr to null, asgn. of
	  relation_opening_info.version.  $free - Moved call to fm_$close to
	  rlm_open 
03/17/85 by Lindsey L. Spratt:  Fixed setting of
            roi.per_process.record_cursor_ptr to use local_record_cursor_ptr.
            Was mistakenly using "record_cursor_ptr", which turned into a
            reference to relation_opening_info.per_process.record_cursor_ptr,
            which was null, so the record_cursor_ptr would always be null.
*/

/* format: style2,ind3 */

rlm_opening_info:
   proc ();

      call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	 "^/^a$^a is not a valid entrypoint", myname, myname);


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

      dcl	    p_file_opening_id      bit (36) aligned parameter;
      dcl	    p_relation_opening_info_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (attribute_info_buffer_length, index_attribute_map_buffer_length)
			       fixed bin (35) init (0);
      dcl	    header_info_update_count
			       fixed bin (17) init (-1);
      dcl	    index_idx	       fixed bin (17);
      dcl	    current_rollback_count fixed bin (35);
      dcl	    (get, dont_refresh, init, refresh)
			       bit (1) aligned init ("0"b);
      dcl	    current_transaction_id bit (36) aligned;
      dcl	    om_file_opening_id     bit (72) aligned;
      dcl	    (local_record_cursor_ptr, old_attribute_info_ptr, old_index_attribute_map_ptr, old_index_cursor_array_ptr)
			       ptr init (null);

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (static_dm_area_ptr);

/* Builtin */

      dcl	    (currentsize, hbound, length, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("rlm_opening_info") char (32) varying internal static options (constant);
      dcl	    BITS_PER_WORD	       init (36) fixed bin internal static options (constant);
      dcl	    NUMBER_OF_BUCKETS      init (20) fixed bin internal static options (constant);
      dcl	    CANONICAL_SECOND_WORD_OF_RELATION_OPENING_ID
			       init ("0"b) bit (36) aligned internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    opening_manager_$get_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$put_opening
			       entry (ptr, bit (72) aligned, ptr, fixed bin (35));
      dcl	    opening_manager_$init  entry (fixed bin, ptr, fixed bin (35));
      dcl	    opening_manager_$free_opening
			       entry (ptr, bit (72) aligned, fixed bin (35));
      dcl	    record_manager_$create_cursor
			       entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    transaction_manager_$get_current_ids
			       entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));

/* External */

      dcl	    dm_error_$no_opening   ext fixed bin (35);
      dcl	    dm_error_$programming_error
			       ext fixed bin (35);
      dcl	    dm_error_$relation_not_open
			       ext fixed bin (35);
      dcl	    error_table_$fatal_error
			       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* Static */

      dcl	    (static_opening_table_ptr, static_dm_area_ptr)
			       ptr init (null) internal static;

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

get:
   entry (p_file_opening_id, p_relation_opening_info_ptr, p_code);

      get = "1"b;
      p_relation_opening_info_ptr = null;
      goto GET_REFRESH_JOIN;

get_dont_refresh:
   entry (p_file_opening_id, p_relation_opening_info_ptr, p_code);

      get, dont_refresh = "1"b;
      p_relation_opening_info_ptr = null;
      goto GET_REFRESH_JOIN;

refresh:
   entry (p_relation_opening_info_ptr, p_code);

      refresh = "1"b;
      relation_opening_info_ptr = p_relation_opening_info_ptr;
      call CHECK_VERSION ("relation_opening_info", (relation_opening_info.version), (RELATION_OPENING_INFO_VERSION_2));

      call CURRENT_TRANSACTION_ID (current_transaction_id, current_rollback_count);
      goto GET_REFRESH_JOIN;

GET_REFRESH_JOIN:
      p_code = 0;

      if get
      then
GET:
         do;
	  om_file_opening_id = p_file_opening_id || CANONICAL_SECOND_WORD_OF_RELATION_OPENING_ID;

	  if static_opening_table_ptr = null
	  then
	     do;
	        p_code = dm_error_$relation_not_open;
	        return;
	     end;
	  else
	     do;
	        call opening_manager_$get_opening (static_opening_table_ptr, om_file_opening_id,
		   relation_opening_info_ptr, p_code);
	        if p_code ^= 0
	        then
		 do;
		    if p_code = dm_error_$no_opening
		    then p_code = dm_error_$relation_not_open;
		    return;
		 end;
	        else /* p_code = 0 */
		   if relation_opening_info_ptr = null
	        then
		 do;
		    p_code = dm_error_$relation_not_open;
		    return;
		 end;
	        else
		 do;
		    call CHECK_VERSION ("relation_opening_info", (relation_opening_info.version),
		         (RELATION_OPENING_INFO_VERSION_2));

		    if ^dont_refresh
		    then
		       do;

		       /*** See if the opening info needs to be refreshed. */

			call CURRENT_TRANSACTION_ID (current_transaction_id, current_rollback_count);

			if relation_opening_info.per_process.current_transaction_id ^= current_transaction_id
			then refresh = "1"b;
			else if relation_opening_info.per_process.current_rollback_count ^= current_rollback_count
			then refresh = "1"b;
		       end;
		 end;
	     end;
         end GET;

      if refresh
      then
REFRESH:
         do;
	  if static_dm_area_ptr = null
	  then static_dm_area_ptr = get_dm_free_area_ ();


	  on cleanup call FINISH ();

	  if relation_opening_info.relation_header_ptr = null
	  then header_info_update_count = -1;
	  else header_info_update_count =
		  relation_opening_info.relation_header_ptr -> relation_header.header_info_update_count;

         /*** Get the relation_header structure. */

	  call collection_manager_$get (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	       CALLER_HEADER_ELEMENT_ID, 0, relation_opening_info.relation_header_ptr,
	       length (unspec (relation_header)), static_dm_area_ptr, ("0"b), relation_header_ptr, (0), p_code);
	  if p_code ^= 0
	  then return;

	  call CHECK_VERSION ("relation_header", (relation_header.version), (RELATION_HEADER_VERSION_3));

	  if relation_opening_info.per_process.record_cursor_ptr = null
	  then
	     do;

	     /*** No record cursor exists for this process, so create one. */

	        call record_manager_$create_cursor (relation_opening_info.per_process.file_opening_id,
		   relation_header.record_collection_id, static_dm_area_ptr, local_record_cursor_ptr, p_code);
	        if p_code ^= 0
	        then return;
	        else relation_opening_info.per_process.record_cursor_ptr = local_record_cursor_ptr;
	     end;

	  if relation_header.header_info_update_count ^= header_info_update_count
	  then
REFRESH_UPDATED_HEADER_INFO:
	     do;

	     /*** Either some header information has been updated since the last time the
		information was retrieved or this is the first retrieval of the header
		information. First, get the attribute_info structure. */

	        if relation_opening_info.attribute_info_ptr ^= null
	        then attribute_info_buffer_length =
		        currentsize (relation_opening_info.attribute_info_ptr -> attribute_info) * BITS_PER_WORD;
	        call collection_manager_$get (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
		   relation_header.attribute_info_element_id, 0, relation_opening_info.attribute_info_ptr,
		   attribute_info_buffer_length, static_dm_area_ptr, ("0"b), attribute_info_ptr, (0), p_code);
	        if p_code ^= 0
	        then return;

	        call CHECK_VERSION ("attribute_info", (attribute_info.version), (ATTRIBUTE_INFO_VERSION_1));

	     /*** Get index_attribute_map. */

	        if relation_opening_info.index_attribute_map_ptr ^= null
	        then index_attribute_map_buffer_length =
		        currentsize (relation_opening_info.index_attribute_map_ptr -> index_attribute_map)
		        * BITS_PER_WORD;

	        call collection_manager_$get (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
		   relation_header.index_attribute_map_element_id, 0, relation_opening_info.index_attribute_map_ptr,
		   index_attribute_map_buffer_length, static_dm_area_ptr, ("0"b), index_attribute_map_ptr, (0),
		   p_code);
	        if p_code ^= 0
	        then return;

	        call CHECK_VERSION ("index_attribute_map", (index_attribute_map.version),
		   (INDEX_ATTRIBUTE_MAP_VERSION_2));

	        if relation_opening_info.per_process.index_cursor_array_ptr = null
	        then
		 do;

		 /*** No index_cursor_array exists, so set one up with a null cursor_ptr for each index. */

		    ica_number_of_indices = hbound (index_attribute_map.index, 1);
		    alloc index_cursor_array in (dm_area);
		    index_cursor_array.version = INDEX_CURSOR_ARRAY_VERSION_1;
		    index_cursor_array.cursor_ptr (*) = null;
		    relation_opening_info.per_process.index_cursor_array_ptr = index_cursor_array_ptr;
		 end;
	        else
INDEX_CURSOR_ARRAY_EXISTS:
		 do;

		 /*** An index_cursor_array already exists, but since the index_attribute_map
		      may have been changed, update index_cursor_array to match the current
		      state of the index_attribute_map. */

		    call CHECK_VERSION ("index_attribute_map", index_attribute_map.version,
		         INDEX_ATTRIBUTE_MAP_VERSION_2);

		    index_cursor_array_ptr = relation_opening_info.per_process.index_cursor_array_ptr;
		    call CHECK_VERSION ("index_cursor_array", index_cursor_array.version,
		         INDEX_CURSOR_ARRAY_VERSION_1);

		    if hbound (index_cursor_array.cursor_ptr, 1) >= hbound (index_attribute_map.index, 1)
		    then
REMOVE_CURSORS_FOR_DELETED_INDICES:
		       do;

		       /*** Indices for which cursors are stored in index_cursor_array may have been
			  deleted. Destroy the cursors for any such index. */

			do index_idx = 1 to hbound (index_attribute_map.index, 1);
			   if index_cursor_array.cursor_ptr (index_idx) ^= null
			   then if index_attribute_map.index (index_idx).number_of_attributes <= 0
			        then
				 do;
				 /***			              call index_manager_$destroy_cursor (index_cursor_array.cursor_ptr(index_idx), (0)); */
				    index_cursor_array.cursor_ptr (index_idx) = null;
				 end;
			end;
		       end REMOVE_CURSORS_FOR_DELETED_INDICES;
		    else
EXTEND_INDEX_CURSOR_ARRAY:
		       do;

		       /*** The index_attribute_map has been extended to contain more indices than
			  index_cursor_array components, so index_cursor_array must likewise be
			  extended. Allocate a new one, and copy over the old cursor_ptr values.
			  If a non-null cursor_ptr exists for an index which no longer exists,
			  destroy the cursor. */

			old_index_cursor_array_ptr = index_cursor_array_ptr;
			ica_number_of_indices = hbound (index_attribute_map.index, 1);

			alloc index_cursor_array in (dm_area);
			index_cursor_array.version = INDEX_CURSOR_ARRAY_VERSION_1;

			if old_index_cursor_array_ptr ^= null
			then relation_opening_info.per_process.index_cursor_array_ptr = index_cursor_array_ptr;

			index_cursor_array.cursor_ptr (*) = null;

			do index_idx = 1 to hbound (old_index_cursor_array_ptr -> index_cursor_array.cursor_ptr, 1);
			   if old_index_cursor_array_ptr -> index_cursor_array.cursor_ptr (index_idx) ^= null
			   then if index_attribute_map.index (index_idx).number_of_attributes > 0
			        then index_cursor_array.cursor_ptr (index_idx) =
				        old_index_cursor_array_ptr -> index_cursor_array.cursor_ptr (index_idx);
			/***			        else call index_manager_$destroy_cursor (old_index_cursor_array_ptr->index_cursor_array.cursor_ptr(index_idx), (0)); */
			end;
		       end EXTEND_INDEX_CURSOR_ARRAY;
		 end INDEX_CURSOR_ARRAY_EXISTS;

	     /*** Reset relation_opening_info values. */

	        if attribute_info_ptr ^= relation_opening_info.attribute_info_ptr
	        then
		 do;
		    old_attribute_info_ptr = relation_opening_info.attribute_info_ptr;
		    relation_opening_info.attribute_info_ptr = attribute_info_ptr;
		 end;

	        if index_attribute_map_ptr ^= relation_opening_info.index_attribute_map_ptr
	        then
		 do;
		    old_index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
		    relation_opening_info.index_attribute_map_ptr = index_attribute_map_ptr;
		 end;


	     end REFRESH_UPDATED_HEADER_INFO;

	  if relation_header_ptr ^= relation_opening_info.relation_header_ptr
	  then relation_opening_info.relation_header_ptr = relation_header_ptr;

	  relation_opening_info.per_process.current_transaction_id = current_transaction_id;
	  relation_opening_info.per_process.current_rollback_count = current_rollback_count;

	  call FINISH ();

         end REFRESH;

      if get
      then p_relation_opening_info_ptr = relation_opening_info_ptr;

      return;					/* Effective end of $get, $refresh, $get_dont_refresh. */
%page;
init:
   entry (p_file_opening_id, p_relation_opening_info_ptr, p_code);

      init = "1"b;
      p_code = 0;
      om_file_opening_id = p_file_opening_id || CANONICAL_SECOND_WORD_OF_RELATION_OPENING_ID;
      p_relation_opening_info_ptr = null ();

      on cleanup call FINISH ();
      if static_dm_area_ptr = null
      then static_dm_area_ptr = get_dm_free_area_ ();

      if static_opening_table_ptr = null
      then
         do;
	  call opening_manager_$init (NUMBER_OF_BUCKETS, static_opening_table_ptr, p_code);
	  if p_code ^= 0
	  then return;
         end;
      else
         do;
	  call opening_manager_$get_opening (static_opening_table_ptr, om_file_opening_id, (null), p_code);
	  if p_code = 0
	  then call sub_err_ (error_table_$fatal_error, myname, ACTION_CANT_RESTART, null, 0,
		  "^/Unable to initialize the relation opening info for the file with opening id
^.3b.  There is already an opening for a relation with this file_opening_id,"
		  || "but there should not be.  This indicates either a damaged per-process relation
opening info table or a programming error in the relation_manager_.", p_file_opening_id);
	  else p_code = 0;
         end;

      alloc relation_opening_info in (dm_area);
      relation_opening_info.version = RELATION_OPENING_INFO_VERSION_2;

      relation_opening_info.per_process.file_opening_id = p_file_opening_id;
      call CURRENT_TRANSACTION_ID (relation_opening_info.per_process.current_transaction_id,
	 relation_opening_info.per_process.current_rollback_count);

      call opening_manager_$put_opening (static_opening_table_ptr, om_file_opening_id, relation_opening_info_ptr, p_code);
      if p_code = 0
      then p_relation_opening_info_ptr = relation_opening_info_ptr;
      else call FINISH ();

      return;					/* End of rlm_opening_info$init */
%page;
free:
   entry (p_relation_opening_info_ptr, p_code);

      if static_opening_table_ptr = null
      then return;

      relation_opening_info_ptr = p_relation_opening_info_ptr;
      call CHECK_VERSION ("relation_opening_info", (relation_opening_info.version), (RELATION_OPENING_INFO_VERSION_2));



      om_file_opening_id =
	 relation_opening_info.per_process.file_opening_id || CANONICAL_SECOND_WORD_OF_RELATION_OPENING_ID;

      call opening_manager_$free_opening (static_opening_table_ptr, om_file_opening_id, p_code);
      if p_code ^= 0
      then return;

      if relation_opening_info.relation_header_ptr ^= null
      then free relation_opening_info.relation_header_ptr -> relation_header in (dm_area);
      if relation_opening_info.attribute_info_ptr ^= null
      then free relation_opening_info.attribute_info_ptr -> attribute_info in (dm_area);
      if relation_opening_info.index_attribute_map_ptr ^= null
      then free relation_opening_info.index_attribute_map_ptr -> index_attribute_map in (dm_area);

      free relation_opening_info in (dm_area);

      p_relation_opening_info_ptr = null;

      return;					/* End of rlm_opening_info$free */
%page;
FINISH:
   proc ();

      if relation_opening_info_ptr ^= null
      then
         do;

	  if old_attribute_info_ptr ^= null & old_attribute_info_ptr ^= relation_opening_info.attribute_info_ptr
	  then free old_attribute_info_ptr -> attribute_info in (dm_area);
	  if attribute_info_ptr ^= null & attribute_info_ptr ^= relation_opening_info.attribute_info_ptr
	  then free attribute_info in (dm_area);
	  if old_index_attribute_map_ptr ^= null
	       & old_index_attribute_map_ptr ^= relation_opening_info.index_attribute_map_ptr
	  then free old_index_attribute_map_ptr -> index_attribute_map in (dm_area);
	  if index_attribute_map_ptr ^= null & index_attribute_map_ptr ^= relation_opening_info.index_attribute_map_ptr
	  then free index_attribute_map in (dm_area);
	  if relation_header_ptr ^= null & relation_header_ptr ^= relation_opening_info.relation_header_ptr
	  then free relation_header in (dm_area);
	  if old_index_cursor_array_ptr ^= null
	       & old_index_cursor_array_ptr ^= relation_opening_info.per_process.index_cursor_array_ptr
	  then free old_index_cursor_array_ptr -> index_cursor_array in (dm_area);
	  if index_cursor_array_ptr ^= null
	       & index_cursor_array_ptr ^= relation_opening_info.per_process.index_cursor_array_ptr
	  then free index_cursor_array in (dm_area);

	  if init
	  then if relation_opening_info_ptr ^= p_relation_opening_info_ptr
	       then free relation_opening_info in (dm_area);
         end;

      return;

   end FINISH;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_given_version, cv_p_correct_version);

      dcl	    cv_p_structure_name    char (*);
      dcl	    cv_p_given_version     char (8) aligned;
      dcl	    cv_p_correct_version   char (8) aligned;
      dcl	    sub_err_	       entry () options (variable);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);

      if cv_p_given_version ^= cv_p_correct_version
      then call sub_err_ (error_table_$unimplemented_version, myname, "s", null, 0,
	      "^/Expected version ""^8a"" of ^a structure; received ""^8a"".", cv_p_correct_version,
	      cv_p_structure_name, cv_p_given_version);

      return;

   end CHECK_VERSION;
%page;
CURRENT_TRANSACTION_ID:
   proc (cti_p_txn_id, cti_p_rollback_count);

      dcl	    cti_p_txn_id	       bit (36) aligned;
      dcl	    cti_p_rollback_count   fixed bin (35);
      dcl	    cti_rollback_count     fixed bin;
      dcl	    cti_code	       fixed bin (35) init (0);

      call transaction_manager_$get_current_ids (cti_p_txn_id, (0), cti_rollback_count, cti_code);
      if cti_code ^= 0
      then cti_p_txn_id = "0"b;
      cti_p_rollback_count = cti_rollback_count;

   end CURRENT_TRANSACTION_ID;

%page;
%include sub_err_flags;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_rlm_idx_cursor_array;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_hdr_col_ids;
%page;
%include dm_collmgr_entry_dcls;

   end rlm_opening_info;




		    rlm_process_tuples_by_id.pl1    10/24/88  1644.7r w 10/24/88  1400.0      327042



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


/* DESCRIPTION:

          Deletes or modifies a tuple or set of tuples identified by a
     tuple_id or by an array of identifiers (element_id_list).  For each tuple
     to be deleted, the keys associated with the tuple are first deleted and
     then the tuple itself is deleted from the record collection.  In order to
     delete the keys, each tuple must be retrieved so that a
     search_specification can be constructed which will match the key field
     values.  For each tuple to be modified, the keys associated with the
     tuple which have a field which may change in value are first deleted then
     re-inserted.  The cursor supplied must be a relation_cursor.
     
          Four entries exist:
     
     rlm_process_tuples_by_id$delete - takes a single
     tuple_id and deletes the tuple (record and associated keys);
     
     rlm_proess_tuples_by_id$delete_array - takes an array of tuple_ids
     (element_id_list) and deletes each tuple identified;
     
     rlm_process_tuples_by_id$modify - modifies selected atribute values of a
     single tuple identified by p_tuple_id;
     
     rlm_process_tuples_by_id$modify_array - modifies selected attribute
     values of an array of tuples identified by an element_id_list
     (p_element_id_list_ptr).
*/

/* HISTORY:
Written by Matthew Pierret 09/28/82.
Modified:
10/18/82 by Matthew Pierret:  Initialized ss.subset_specification_ptr to null.
12/08/82 by Lindsey Spratt:  Fixed to put the new versions of keys when
	  modifying, and to use the old values when doing deletions.
12/09/82 by Lindsey Spratt:  Fixed to reference key_stv_ptr only when
	  modifying. Fixed to use the ALL_RANGE_TYPE search spec.
	  Changed the freeing logic in FINISH to use the current length when
	  determining the amount of storage used by a varying string value,
	  rather than the maximum length.  Changed the
	  DELETE_KEYS_AND_RECORD_FOR_EACH_TUPLE_LOOP to free the
	  simple_typed_vector for the record each time through the loop.
12/21/82 by Matthew Pierret:  Changed to convert dm_error_$record_not_found to
            dm_error_$no_tuple_id.
01/18/83 by Matthew Pierret:  Changed to use relation_info version 2.
03/10/83 by Matthew Pierret:  Changed to use get_dm_free_area_ instead of 
            dm_data_$area_ptr. Changed to use relation_opening_info.
            Changed to not assume that all index_attribute_map entries
            contain an index.  Changed to allocate search_specification
            with one more constraint than the maximum number of attributes
            (to account for the tuple id).
05/23/83 by Matthew Pierret: Changed to use relation_cursors. Moved cursor_ptr
            parameter to be the first parameter in each calling sequence.
            Changed the "do;call FINISH;return;end;" cliche to 
            "call ERROR_RETURN (code);". Changed dm_error_$no_tuple_id to
            dm_error_$tuple_not_found_id. Removed CHECK_TYPE.
            Changed to use version 4 of specification_head.
            Added dm_specification_head.incl.pl1, dm_range_constants.incl.pl1.
06/27/83 by Lindsey L. Spratt:  Changed to use version 2 of the
            relation_cursor.
08/26/83 by Lindsey L. Spratt:  Fixed to only modify an index key when there
	  is a real modification.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.
11/06/84 by Stanford S. Cox:  MAIN: Chg to ref simple_typed_vector by explicit ptr
	  when alloc, Chg all sub_err_ calls for new syntax.  IKS: Chg to
   	  set p_search_specification_ptr when alloc instead of global ptr,
   	  Add unique var prefixes. FSTV: Add unique var prefixes.
11/29/84 by Stanford S. Cox:  DELETE_KEYS*: Added by moving code from MAIN.
12/11/84 by Lindsey Spratt:  Changed to call data_format_util_ instead of 
	  data_mgmt_util_.
03/19/85 by Matthew C. Pierret:  Added the ability to rollback a partially
            modified tuple if the modification causes a key_duplication error.
            Replaced the DELETE_KEYS_AND_RECORD_FOR_ONE_TUPLE with the
            routines DELETE_TUPLE, MODIFY_TUPLE, and ROLLBACK_TUPLE, and added
            the utility routines BUILD_RECORD, BUILD_KEY, and BUILD_SPEC.
            Moved the ERROR_RETURN and FINISH routines to just after the main
            return statement, as in most other modules.
            Re-named INIT_KEY_SPECIFICATION to INIT_SPEC and fully 
            parameterized its calling sequence.  Removed the check in FINISH
            for number_of_tuples_processed > 0, as if it is 0, setting the
            parameter to that value is correct.
04/10/85 by Matthew C. Pierret:  Added BUILD_RECORD_TEMPLATE, which takes the
            record returned by record_manager_$get_record_by_id, and replaces
            the varying fields with varying fields allocated at the maximum
            length.  This is so that the record can be used as input on
            subsequent calls to record_manager_$get_record_by_id.
04/12/85 by Matthew C. Pierret:  Changed BUILD_RECORD_TEMPLATE to allocate
            values as aligned.
*/

/* format: style2,ind3 */

rlm_process_tuples_by_id:
   proc ();

      return;					/* Not a real entry */


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

      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_tuple_id	       bit (36) aligned;
      dcl	    p_typed_vector_ptr     ptr;
      dcl	    p_relation_cursor_ptr  ptr;
      dcl	    p_number_of_tuples_processed
			       fixed bin (35);
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    an_index_field_is_modified
			       bit (1) aligned init ("0"b);
      dcl	    delete	       bit (1) aligned;
      dcl	    process_single_tuple   bit (1) aligned init ("0"b);
      dcl	    (key_ptr, key_spec_ptr, new_record_ptr, old_record_ptr, dm_area_ptr, record_cursor_ptr)
			       ptr init (null);
      dcl	    code		       fixed bin (35) init (0);
      dcl	    index_idx	       fixed bin init (0);
      dcl	    number_of_tuples_processed
			       fixed bin (35) init (0);
      dcl	    number_of_tuples_to_process
			       fixed bin (35) init (0);
      dcl	    tuple_idx	       fixed bin (17);
      dcl	    tuple_id	       bit (36) aligned;

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (dm_area_ptr);

/* Builtin */

      dcl	    (addr, hbound, null)   builtin;

/* Constant */

      dcl	    BITS_PER_BYTE	       fixed bin init (9) int static options (constant);
      dcl	    BITS_PER_WORD	       fixed bin init (36) int static options (constant);
      dcl	    myname	       init ("rlm_process_tuple_by_id") char (32) varying static options (constant);
      dcl	    (
	    TRUE		       init ("1"b),
	    FALSE		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);

/* Condition */

      dcl	    cleanup	       condition;

/* Entry */

      dcl	    data_format_util_$get_data_bit_length
			       entry (bit (36) aligned, fixed bin (35), fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    index_manager_$create_cursor
			       entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
      dcl	    index_manager_$delete_key
			       entry (ptr, ptr, ptr, fixed bin (35), fixed bin (35));
      dcl	    index_manager_$put_key entry (ptr, ptr, fixed bin (35));

      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$key_duplication,
	    dm_error_$key_not_found,
	    dm_error_$record_not_found,
	    dm_error_$tuple_not_found_id
	    )		       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* END OF DECLARATIONS */

delete:
   entry (p_relation_cursor_ptr, p_tuple_id, p_code);

      delete = "1"b;
      process_single_tuple = "1"b;
      number_of_tuples_to_process = 1;
      goto JOIN;


delete_array:
   entry (p_relation_cursor_ptr, p_element_id_list_ptr, p_number_of_tuples_processed, p_code);

      delete = "1"b;
      process_single_tuple = "0"b;

      element_id_list_ptr = p_element_id_list_ptr;
      call CHECK_VERSION_FB ("element_id_list", (element_id_list.version), (ELEMENT_ID_LIST_VERSION_1));

      number_of_tuples_to_process = element_id_list.number_of_elements;
      goto JOIN;


modify:
   entry (p_relation_cursor_ptr, p_tuple_id, p_typed_vector_ptr, p_code);

      delete = "0"b;
      process_single_tuple = "1"b;
      number_of_tuples_to_process = 1;
      goto MODIFY_JOIN;

modify_array:
   entry (p_relation_cursor_ptr, p_element_id_list_ptr, p_typed_vector_ptr, p_number_of_tuples_processed, p_code);

      delete = "0"b;
      process_single_tuple = "0"b;

      element_id_list_ptr = p_element_id_list_ptr;
      call CHECK_VERSION_FB ("element_id_list", (element_id_list.version), (ELEMENT_ID_LIST_VERSION_1));

      number_of_tuples_to_process = element_id_list.number_of_elements;

MODIFY_JOIN:
      general_typed_vector_ptr = p_typed_vector_ptr;
      if general_typed_vector.type ^= GENERAL_TYPED_VECTOR_TYPE
      then call sub_err_ (0, myname, ACTION_CANT_RESTART, null, 0,
	      "The wrong type of typed_vector was supplied.^/Expected type ^d.  Received ^d.",
	      GENERAL_TYPED_VECTOR_TYPE, general_typed_vector.type);

%page;
JOIN:
      simple_typed_vector_ptr, key_ptr, old_record_ptr, new_record_ptr, key_spec_ptr = null ();

      p_code, code = 0;

      relation_cursor_ptr = p_relation_cursor_ptr;

      call CHECK_VERSION ("relation_cursor", (relation_cursor.version), (RELATION_CURSOR_VERSION_2));

      dm_area_ptr = get_dm_free_area_ ();
      on cleanup call FINISH;

GET_OPENING_INFO_STRUCTURES:
      do;

         call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, code);
         if code ^= 0
         then call ERROR_RETURN (code);
         call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);
         relation_header_ptr = relation_opening_info.relation_header_ptr;
         call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);
         attribute_info_ptr = relation_opening_info.attribute_info_ptr;
         call CHECK_VERSION ("attribute_info", attribute_info.version, ATTRIBUTE_INFO_VERSION_1);
         index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
         call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);
         index_cursor_array_ptr = relation_opening_info.per_process.index_cursor_array_ptr;
         call CHECK_VERSION ("index_cursor_array", index_cursor_array.version, INDEX_CURSOR_ARRAY_VERSION_1);

      end GET_OPENING_INFO_STRUCTURES;

GET_CURSORS:
      do;

         record_cursor_ptr = SET_RECORD_COLLECTION_CURSOR_PTR (relation_cursor_ptr, relation_header.record_collection_id);

         do index_idx = 1 to hbound (index_attribute_map.index, 1);
	  call SET_CURSOR_PTR_FOR_THIS_INDEX (index_idx);
         end;

      end GET_CURSORS;

      call INIT_SPEC (key_spec_ptr, index_attribute_map_ptr, dm_area_ptr);

      if delete
      then
DELETE:
         do;
	  if process_single_tuple
	  then
	     do;
	        tuple_id = p_tuple_id;
	        call DELETE_TUPLE (tuple_id, old_record_ptr, key_spec_ptr, index_attribute_map_ptr,
		   index_cursor_array_ptr, record_cursor_ptr, dm_area_ptr);
	     end;
	  else
	     do;
	        tuple_id = element_id_list.id (1);
	        call DELETE_TUPLE (tuple_id, old_record_ptr, key_spec_ptr, index_attribute_map_ptr,
		   index_cursor_array_ptr, record_cursor_ptr, dm_area_ptr);
	        number_of_tuples_processed = 1;
	        call BUILD_RECORD_TEMPLATE (old_record_ptr, dm_area_ptr, attribute_info_ptr);
	        do tuple_idx = 2 to number_of_tuples_to_process;
		 tuple_id = element_id_list.id (tuple_idx);
		 call DELETE_TUPLE (tuple_id, old_record_ptr, key_spec_ptr, index_attribute_map_ptr,
		      index_cursor_array_ptr, record_cursor_ptr, dm_area_ptr);
		 number_of_tuples_processed = number_of_tuples_processed + 1;
	        end;
	     end;
         end DELETE;
      else
MODIFY:
         do;
	  stv_number_of_dimensions = index_attribute_map.maximum_number_of_attributes_per_index + 1;
	  alloc simple_typed_vector in (dm_area) set (key_ptr);
	  key_ptr -> simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;

	  if process_single_tuple
	  then
	     do;
	        tuple_id = p_tuple_id;
	        call MODIFY_TUPLE (tuple_id, old_record_ptr, new_record_ptr, key_ptr, general_typed_vector_ptr,
		   key_spec_ptr, index_attribute_map_ptr, index_cursor_array_ptr, record_cursor_ptr, dm_area_ptr);
	     end;
	  else
	     do;
	        tuple_id = element_id_list.id (1);
	        call MODIFY_TUPLE (tuple_id, old_record_ptr, new_record_ptr, key_ptr, general_typed_vector_ptr,
		   key_spec_ptr, index_attribute_map_ptr, index_cursor_array_ptr, record_cursor_ptr, dm_area_ptr);
	        number_of_tuples_processed = 1;
	        call BUILD_RECORD_TEMPLATE (old_record_ptr, dm_area_ptr, attribute_info_ptr);
	        do tuple_idx = 2 to number_of_tuples_to_process;
		 tuple_id = element_id_list.id (tuple_idx);
		 call MODIFY_TUPLE (tuple_id, old_record_ptr, new_record_ptr, key_ptr, general_typed_vector_ptr,
		      key_spec_ptr, index_attribute_map_ptr, index_cursor_array_ptr, record_cursor_ptr, dm_area_ptr);
		 number_of_tuples_processed = number_of_tuples_processed + 1;
	        end;
	     end;
         end MODIFY;


      call FINISH ();
MAIN_RETURN:
      return;
%skip (4);
FINISH:
   proc ();
      if ^process_single_tuple
      then p_number_of_tuples_processed = number_of_tuples_processed;

      if key_ptr ^= null
      then
         do;
	  key_ptr -> simple_typed_vector.number_of_dimensions =
	       index_attribute_map.maximum_number_of_attributes_per_index + 1;
	  free key_ptr -> simple_typed_vector in (dm_area);
         end;

      if old_record_ptr ^= null
      then call FREE_SIMPLE_TYPED_VECTOR (old_record_ptr);	/* Free vector and targets of value_ptrs */

      if new_record_ptr ^= null
      then free new_record_ptr -> simple_typed_vector in (dm_area);
						/* Don't free targets of value_ptrs */

      if key_spec_ptr ^= null
      then free key_spec_ptr -> search_specification in (dm_area);

      if record_cursor_ptr ^= null & record_cursor_ptr ^= relation_cursor.current.cursor_ptr
      then call record_manager_$destroy_cursor (record_cursor_ptr, (0));

   end FINISH;
%skip (4);
ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35);

      p_code = er_p_code;
      call FINISH ();
      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
BUILD_KEY:
   proc (bk_p_key_ptr, bk_p_old_record_ptr, bk_p_new_record_ptr, bk_p_record_id_ptr, bk_p_iam_ptr, bk_p_index_idx,
        bk_p_index_field_is_modified);

/* DESCRIPTION
        This routine builds a key from the values in a record/tuple which
   is appropriate for the given index. */

      dcl	    bk_p_key_ptr	       ptr parameter;
      dcl	    bk_p_old_record_ptr    ptr parameter;
      dcl	    bk_p_new_record_ptr    ptr parameter;
      dcl	    bk_p_record_id_ptr     ptr parameter;
      dcl	    bk_p_iam_ptr	       ptr parameter;
      dcl	    bk_p_index_idx	       fixed bin parameter;
      dcl	    bk_p_index_field_is_modified
			       bit (1) aligned parameter;

      dcl	    bk_field_idx	       fixed bin;
      dcl	    bk_record_field_idx    fixed bin;
      dcl	    bk_old_value_ptr       ptr;
      dcl	    bk_new_value_ptr       ptr;

      bk_p_index_field_is_modified = FALSE;
      bk_p_key_ptr -> simple_typed_vector.number_of_dimensions =
	 bk_p_iam_ptr -> index_attribute_map.index (bk_p_index_idx).number_of_attributes + 1;
BK_FIELD_LOOP:
      do bk_field_idx = 1 to bk_p_iam_ptr -> index_attribute_map.index (bk_p_index_idx).number_of_attributes;
         bk_record_field_idx = bk_p_iam_ptr -> index_attribute_map.index (bk_p_index_idx).attribute_id (bk_field_idx);
         bk_old_value_ptr = bk_p_old_record_ptr -> simple_typed_vector.dimension (bk_record_field_idx).value_ptr;
         bk_new_value_ptr = bk_p_new_record_ptr -> simple_typed_vector.dimension (bk_record_field_idx).value_ptr;
         bk_p_key_ptr -> simple_typed_vector.dimension (bk_field_idx).value_ptr = bk_new_value_ptr;
         if bk_new_value_ptr ^= bk_old_value_ptr
         then bk_p_index_field_is_modified = TRUE;
      end BK_FIELD_LOOP;

      bk_p_key_ptr -> simple_typed_vector.dimension (bk_field_idx).value_ptr = bk_p_record_id_ptr;

      return;

   end BUILD_KEY;
%page;
BUILD_RECORD:
   proc (br_p_old_record_ptr, br_p_new_record_ptr, br_p_gtv_ptr, br_p_area_ptr);

/* This routine builds a record containing the modified field values. */

      dcl	    (
	    br_p_old_record_ptr    ptr,
	    br_p_new_record_ptr    ptr,
	    br_p_gtv_ptr	       ptr,
	    br_p_area_ptr	       ptr
	    )		       parameter;

      dcl	    br_dim_idx	       fixed bin;
      dcl	    br_field_idx	       fixed bin;
      dcl	    br_field_value_ptr     ptr;

      if br_p_new_record_ptr = null ()
      then
BR_ALLOC_NEW_RECORD:
         do;
	  stv_number_of_dimensions = br_p_old_record_ptr -> simple_typed_vector.number_of_dimensions;
	  alloc simple_typed_vector in (br_p_area_ptr -> dm_area) set (br_p_new_record_ptr);
         end BR_ALLOC_NEW_RECORD;

      br_p_new_record_ptr -> simple_typed_vector = br_p_old_record_ptr -> simple_typed_vector;

BR_DIMENSION_LOOP:
      do br_dim_idx = 1 to hbound (br_p_gtv_ptr -> general_typed_vector.dimension, 1);
         br_field_idx = br_p_gtv_ptr -> general_typed_vector.dimension (br_dim_idx).identifier;
         br_field_value_ptr = br_p_gtv_ptr -> general_typed_vector.dimension (br_dim_idx).value_ptr;

         if br_field_idx > 0
         then br_p_new_record_ptr -> simple_typed_vector.dimension (br_field_idx).value_ptr = br_field_value_ptr;

      end BR_DIMENSION_LOOP;

      return;

   end BUILD_RECORD;
%page;
BUILD_RECORD_TEMPLATE:
   proc (brt_p_record_ptr, brt_p_area_ptr, brt_p_attr_info_ptr);

/* This routine takes the pointer to a record simple_typed_vector and */
/* converts it into one which has value_ptrs pointing to maximum sized */
/* values so that the record can be used as input to record_manager_   */
/* get_record_by_id entry.  This means finding the varying length      */
/* values, freeing them, and re-allocating them at the maximum length. */

      dcl	    (
	    brt_p_record_ptr       ptr,
	    brt_p_area_ptr	       ptr,
	    brt_p_attr_info_ptr    ptr
	    )		       parameter;

      dcl	    brt_template_length    fixed bin (35);
      dcl	    brt_template_ptr       ptr;
      dcl	    brt_char_var_template  aligned char (brt_template_length) varying based (brt_template_ptr);
      dcl	    brt_bit_var_template   aligned bit (brt_template_length) varying based (brt_template_ptr);
      dcl	    brt_attr_idx	       fixed bin;
      dcl	    1 brt_descriptor       aligned like arg_descriptor;

BRT_ATTRIBUTE_LOOP:
      do brt_attr_idx = 1 to brt_p_attr_info_ptr -> attribute_info.number_of_attributes;
         unspec (brt_descriptor) = brt_p_attr_info_ptr -> attribute_info.attribute (brt_attr_idx).descriptor;
         if brt_descriptor.type = varying_char_dtype
         then
BRT_CHAR_VARYING:
	  do;
	     brt_template_length = 1 /* the length doesn't matter to free */;
	     free brt_p_record_ptr -> simple_typed_vector.dimension (brt_attr_idx).value_ptr -> brt_char_var_template;
	     brt_template_length = brt_descriptor.size;
	     alloc brt_char_var_template in (brt_p_area_ptr -> dm_area) set (brt_template_ptr);
	     brt_p_record_ptr -> simple_typed_vector.dimension (brt_attr_idx).value_ptr = brt_template_ptr;
	  end BRT_CHAR_VARYING;
         else if brt_descriptor.type = varying_bit_dtype
         then
BRT_BIT_VARYING:
	  do;
	     brt_template_length = 1 /* the length doesn't matter to free */;
	     free brt_p_record_ptr -> simple_typed_vector.dimension (brt_attr_idx).value_ptr -> brt_bit_var_template;
	     brt_template_length = brt_descriptor.size;
	     alloc brt_bit_var_template in (brt_p_area_ptr -> dm_area) set (brt_template_ptr);
	     brt_p_record_ptr -> simple_typed_vector.dimension (brt_attr_idx).value_ptr = brt_template_ptr;
	  end BRT_BIT_VARYING;
         else
BRT_FIXED_SIZE:					/* the existing is fixed size */
	  ;
      end BRT_ATTRIBUTE_LOOP;

   end BUILD_RECORD_TEMPLATE;
%page;
BUILD_SPEC:
   proc (bs_spec_ptr, bs_p_record_ptr, bs_p_record_id_ptr, bs_p_iam_ptr, bs_p_index_idx);

/* DESCRIPTION
        This routine builds a specification from the values in a record/tuple
   which represents an exact match of the appropriate key in the given index. */

      dcl	    bs_spec_ptr	       ptr parameter;
      dcl	    bs_p_record_ptr	       ptr parameter;
      dcl	    bs_p_record_id_ptr     ptr parameter;
      dcl	    bs_p_iam_ptr	       ptr parameter;
      dcl	    bs_p_index_idx	       fixed bin parameter;

      dcl	    bs_field_idx	       fixed bin;

BS_FIELD_LOOP:
      do bs_field_idx = 1 to bs_p_iam_ptr -> index_attribute_map.index (bs_p_index_idx).number_of_attributes;
         bs_spec_ptr -> search_specification.and_group (1).constraint (bs_field_idx).value_ptr =
	    bs_p_record_ptr
	    -> simple_typed_vector
	    .dimension (bs_p_iam_ptr -> index_attribute_map.index (bs_p_index_idx).attribute_id (bs_field_idx))
	    .value_ptr;
      end BS_FIELD_LOOP;
      bs_spec_ptr -> search_specification.and_group (1).constraint (bs_field_idx).value_ptr = bs_p_record_id_ptr;
      bs_spec_ptr -> search_specification.and_group (1).number_of_constraints = bs_field_idx;

      return;

   end BUILD_SPEC;
%skip (4);
INIT_SPEC:
   proc (is_p_spec_ptr, is_p_iam_ptr, is_p_area_ptr);

      dcl	    (
	    is_p_spec_ptr	       ptr,
	    is_p_iam_ptr	       ptr,
	    is_p_area_ptr	       ptr
	    )		       parameter;
      dcl	    is_field_idx	       fixed bin (17);

      ss_number_of_and_groups = 1;
      ss_maximum_number_of_constraints = is_p_iam_ptr -> index_attribute_map.maximum_number_of_attributes_per_index + 1;

      alloc search_specification in (is_p_area_ptr -> dm_area) set (is_p_spec_ptr);

      is_p_spec_ptr -> search_specification.head.version = SPECIFICATION_VERSION_4;
      is_p_spec_ptr -> search_specification.head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE;
      is_p_spec_ptr -> search_specification.head.subset_specification_ptr = null;
      is_p_spec_ptr -> search_specification.range.type = ALL_RANGE_TYPE;
      is_p_spec_ptr -> search_specification.range.size = 0;
      is_p_spec_ptr -> search_specification.and_group (1).constraint (*).operator_code = EQUAL_OPERATOR_CODE;
      is_p_spec_ptr -> search_specification.and_group (1).constraint (*).value_field_id = -1;

      do is_field_idx = 1 to is_p_spec_ptr -> search_specification.maximum_number_of_constraints;
         is_p_spec_ptr -> search_specification.and_group (1).constraint (is_field_idx).field_id = is_field_idx;
      end;

      return;

   end INIT_SPEC;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_received_version, cv_p_expected_version);

      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%skip (4);
CHECK_VERSION_FB:
   proc (cvf_p_structure_name, cvf_p_received_version, cvf_p_expected_version);

      dcl	    cvf_p_received_version fixed bin (35);
      dcl	    cvf_p_expected_version fixed bin (35);
      dcl	    cvf_p_structure_name   char (*);

      if cvf_p_received_version ^= cvf_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", cvf_p_expected_version, cvf_p_structure_name, cvf_p_received_version);

   end CHECK_VERSION_FB;
%page;
DELETE_TUPLE:
   proc (dt_p_record_id, dt_p_record_ptr, dt_p_spec_ptr, dt_p_iam_ptr, dt_p_ica_ptr, dt_p_record_cursor_ptr,
        dt_p_area_ptr);

      dcl	    dt_p_record_id	       bit (36) aligned parameter;
      dcl	    dt_p_record_ptr	       ptr parameter;
      dcl	    dt_p_record_cursor_ptr ptr parameter;
      dcl	    dt_p_spec_ptr	       ptr parameter;
      dcl	    dt_p_iam_ptr	       ptr parameter;
      dcl	    dt_p_ica_ptr	       ptr parameter;
      dcl	    dt_p_area_ptr	       ptr parameter;


      dcl	    dt_code	       fixed bin (35);
      dcl	    dt_index_idx	       fixed bin;
      dcl	    dt_index_cursor_ptr    ptr init (null ());

      dt_code = 0;

      call record_manager_$get_record_by_id (dt_p_record_id, null (), dt_p_area_ptr, dt_p_record_cursor_ptr,
	 dt_p_record_ptr, dt_code);
      if dt_code ^= 0
      then if dt_code = dm_error_$record_not_found
	 then if TUPLE_ALREADY_PROCESSED (dt_p_record_id) = TRUE
	      then return /* caller supplied id twice */;
	      else call ERROR_RETURN (dm_error_$tuple_not_found_id);
	 else call ERROR_RETURN (dt_code);


      do dt_index_idx = 1 to hbound (dt_p_iam_ptr -> index_attribute_map.index, 1);

         if dt_p_iam_ptr -> index_attribute_map.index (dt_index_idx).number_of_attributes > 0
         then
	  do;
	     dt_index_cursor_ptr = dt_p_ica_ptr -> index_cursor_array.cursor_ptr (dt_index_idx);
	     call BUILD_SPEC (dt_p_spec_ptr, dt_p_record_ptr, addr (dt_p_record_id), dt_p_iam_ptr, dt_index_idx);
	     call index_manager_$delete_key (dt_p_spec_ptr, dt_p_area_ptr, dt_index_cursor_ptr, (0), dt_code);
	     if dt_code ^= 0
	     then if dt_code = dm_error_$key_not_found
		then dt_code = 0;
		else call ERROR_RETURN (dt_code);
	  end;
      end;

      call record_manager_$delete_record_by_id (dt_p_record_id, dt_p_record_cursor_ptr, dt_code);
      if dt_code ^= 0
      then call ERROR_RETURN (dt_code);

      return;

   end DELETE_TUPLE;
%page;
FREE_SIMPLE_TYPED_VECTOR:
   proc (fstv_p_vector_ptr);

      dcl	    fstv_p_vector_ptr      ptr parameter;

      dcl	    fstv_vector_ptr	       ptr;
      dcl	    fstv_descriptor_string bit (36) aligned based;
      dcl	    fstv_dimension_idx     fixed bin;
      dcl	    fstv_storage_size      fixed bin (35);
      dcl	    fstv_storage_string    bit (fstv_storage_size) aligned based;
      dcl	    fstv_current_value_ptr ptr init (null);
      dcl	    fstv_based_real_fixed_bin_1u
			       based fixed bin (35) unaligned;

      fstv_vector_ptr = fstv_p_vector_ptr;
      fstv_p_vector_ptr = null ();			/* So we don't try again */

      do fstv_dimension_idx = 1 to fstv_vector_ptr -> simple_typed_vector.number_of_dimensions;
         arg_descriptor_ptr = addr (attribute_info.attribute (fstv_dimension_idx).descriptor);
         fstv_current_value_ptr = fstv_vector_ptr -> simple_typed_vector.dimension (fstv_dimension_idx).value_ptr;
         if arg_descriptor.type = varying_char_dtype
         then fstv_storage_size = fstv_current_value_ptr -> fstv_based_real_fixed_bin_1u * BITS_PER_BYTE + BITS_PER_WORD;
         else if arg_descriptor.type = varying_bit_dtype
         then fstv_storage_size = fstv_current_value_ptr -> fstv_based_real_fixed_bin_1u + BITS_PER_WORD;
         else call data_format_util_$get_data_bit_length (arg_descriptor_ptr -> fstv_descriptor_string, fstv_storage_size,
	         (0));

         free fstv_current_value_ptr -> fstv_storage_string in (dm_area);
      end;

      free fstv_vector_ptr -> simple_typed_vector in (dm_area);

      return;

   end FREE_SIMPLE_TYPED_VECTOR;
%page;
MODIFY_TUPLE:
   proc (mt_p_record_id, mt_p_old_record_ptr, mt_p_new_record_ptr, mt_p_key_ptr, mt_p_gtv_ptr, mt_p_spec_ptr,
        mt_p_iam_ptr, mt_p_ica_ptr, mt_p_record_cursor_ptr, mt_p_area_ptr);

      dcl	    mt_p_record_id	       bit (36) aligned parameter;
      dcl	    mt_p_old_record_ptr    ptr parameter;
      dcl	    mt_p_new_record_ptr    ptr parameter;
      dcl	    mt_p_record_cursor_ptr ptr parameter;
      dcl	    mt_p_key_ptr	       ptr parameter;
      dcl	    mt_p_gtv_ptr	       ptr parameter;
      dcl	    mt_p_spec_ptr	       ptr parameter;
      dcl	    mt_p_iam_ptr	       ptr parameter;
      dcl	    mt_p_ica_ptr	       ptr parameter;
      dcl	    mt_p_area_ptr	       ptr parameter;

      dcl	    mt_code	       fixed bin (35);
      dcl	    mt_index_idx	       fixed bin;
      dcl	    mt_key_must_be_modified
			       bit (1) aligned;
      dcl	    mt_index_cursor_ptr    ptr;

      mt_code = 0;

      call record_manager_$get_record_by_id (mt_p_record_id, null (), mt_p_area_ptr, mt_p_record_cursor_ptr,
	 mt_p_old_record_ptr, mt_code);
      if mt_code ^= 0
      then if mt_code = dm_error_$record_not_found
	 then call ERROR_RETURN (dm_error_$tuple_not_found_id);
	 else call ERROR_RETURN (mt_code);

      call BUILD_RECORD (mt_p_old_record_ptr, mt_p_new_record_ptr, mt_p_gtv_ptr, mt_p_area_ptr);


      do mt_index_idx = 1 to hbound (mt_p_iam_ptr -> index_attribute_map.index, 1);

         if mt_p_iam_ptr -> index_attribute_map.index (mt_index_idx).number_of_attributes > 0
         then
	  do;
	     call BUILD_KEY (mt_p_key_ptr, mt_p_old_record_ptr, mt_p_new_record_ptr, addr (mt_p_record_id),
		mt_p_iam_ptr, mt_index_idx, mt_key_must_be_modified);
	     if mt_key_must_be_modified = TRUE
	     then
	        do;
		 mt_index_cursor_ptr = mt_p_ica_ptr -> index_cursor_array.cursor_ptr (mt_index_idx);
		 call BUILD_SPEC (mt_p_spec_ptr, mt_p_old_record_ptr, addr (mt_p_record_id), mt_p_iam_ptr,
		      mt_index_idx);
		 call index_manager_$delete_key (mt_p_spec_ptr, mt_p_area_ptr, mt_index_cursor_ptr, (0), mt_code);
		 if mt_code ^= 0
		 then call ERROR_RETURN (mt_code);
		 call index_manager_$put_key (mt_p_key_ptr, mt_index_cursor_ptr, mt_code);
		 if mt_code ^= 0
		 then if mt_code = dm_error_$key_duplication
		      then
		         do;
			  call ROLLBACK_TUPLE (mt_p_record_id, mt_p_old_record_ptr, mt_p_new_record_ptr,
			       mt_p_key_ptr, mt_p_spec_ptr, mt_p_iam_ptr, mt_p_ica_ptr, mt_p_area_ptr,
			       (mt_index_idx - 1));
			  call ERROR_RETURN (mt_code);
		         end;
	        end;
	  end;
      end;

      call record_manager_$modify_record_by_id (mt_p_record_id, mt_p_gtv_ptr, mt_p_record_cursor_ptr, mt_code);
      if mt_code ^= 0
      then call ERROR_RETURN (mt_code);

      return;

   end MODIFY_TUPLE;
%page;
ROLLBACK_TUPLE:
   proc (rt_p_record_id, rt_p_old_record_ptr, rt_p_new_record_ptr, rt_p_key_ptr, rt_p_spec_ptr, rt_p_iam_ptr,
        rt_p_ica_ptr, rt_p_area_ptr, rt_p_last_modified_index);

      dcl	    rt_p_record_id	       bit (36) aligned parameter;
      dcl	    rt_p_old_record_ptr    ptr parameter;
      dcl	    rt_p_new_record_ptr    ptr parameter;
      dcl	    rt_p_key_ptr	       ptr parameter;
      dcl	    rt_p_spec_ptr	       ptr parameter;
      dcl	    rt_p_iam_ptr	       ptr parameter;
      dcl	    rt_p_ica_ptr	       ptr parameter;
      dcl	    rt_p_area_ptr	       ptr parameter;
      dcl	    rt_p_last_modified_index
			       fixed bin parameter;

      dcl	    rt_code	       fixed bin (35);
      dcl	    rt_index_idx	       fixed bin;
      dcl	    rt_key_must_be_modified
			       bit (1) aligned;
      dcl	    rt_index_cursor_ptr    ptr;


      do rt_index_idx = 1 to rt_p_last_modified_index;

         if rt_p_iam_ptr -> index_attribute_map.index (rt_index_idx).number_of_attributes > 0
         then
	  do;
	     call BUILD_KEY (rt_p_key_ptr, rt_p_new_record_ptr, rt_p_old_record_ptr, addr (rt_p_record_id),
		rt_p_iam_ptr, rt_index_idx, rt_key_must_be_modified);
	     if rt_key_must_be_modified = TRUE
	     then
	        do;
		 rt_index_cursor_ptr = rt_p_ica_ptr -> index_cursor_array.cursor_ptr (rt_index_idx);
		 if rt_index_idx < rt_p_last_modified_index
		 then
RT_REMOVE_NEW_VALUE:
		    do;
		       call BUILD_SPEC (rt_p_spec_ptr, rt_p_new_record_ptr, addr (rt_p_record_id), rt_p_iam_ptr,
			  rt_index_idx);
		       call index_manager_$delete_key (rt_p_spec_ptr, rt_p_area_ptr, rt_index_cursor_ptr, (0),
			  rt_code);
		       if rt_code ^= 0
		       then call ERROR_RETURN (rt_code);
		    end RT_REMOVE_NEW_VALUE;
RT_REPLACE_OLD_VALUE:
		 do;
		    call index_manager_$put_key (rt_p_key_ptr, rt_index_cursor_ptr, rt_code);
		    if rt_code ^= 0
		    then call ERROR_RETURN (rt_code);
		 end RT_REPLACE_OLD_VALUE;
	        end;
	  end;
      end;

      return;

   end ROLLBACK_TUPLE;
%page;
SET_RECORD_COLLECTION_CURSOR_PTR:
   proc (srccp_p_relation_cursor_ptr, srccp_p_record_collection_id) returns (ptr);

      dcl	    srccp_p_relation_cursor_ptr
			       ptr parameter;
      dcl	    srccp_p_record_collection_id
			       bit (36) aligned parameter;

      dcl	    srccp_record_collection_cursor_ptr
			       ptr init (null);
      dcl	    srccp_code	       fixed bin (35) init (0);

      call record_manager_$create_cursor (srccp_p_relation_cursor_ptr -> relation_cursor.file_opening_id,
	 srccp_p_record_collection_id, srccp_p_relation_cursor_ptr -> relation_cursor.work_area_ptr,
	 srccp_record_collection_cursor_ptr, srccp_code);
      if srccp_code ^= 0
      then call ERROR_RETURN (srccp_code);

      return (srccp_record_collection_cursor_ptr);

   end SET_RECORD_COLLECTION_CURSOR_PTR;
%page;
SET_CURSOR_PTR_FOR_THIS_INDEX:
   proc (scpfti_index_idx);

      dcl	    scpfti_index_idx       fixed bin (17);
      dcl	    scpfti_code	       fixed bin (35);
      dcl	    scpfti_index_cursor_ptr
			       ptr;

      if index_attribute_map.index (scpfti_index_idx).number_of_attributes > 0
      then if index_cursor_array.cursor_ptr (scpfti_index_idx) = null
	 then
	    do;
	       call index_manager_$create_cursor (relation_cursor.file_opening_id,
		  index_attribute_map.index (scpfti_index_idx).collection_id, dm_area_ptr, scpfti_index_cursor_ptr,
		  scpfti_code);
	       if scpfti_code ^= 0
	       then call ERROR_RETURN (scpfti_code);

	       index_cursor_array.cursor_ptr (scpfti_index_idx) = scpfti_index_cursor_ptr;
	    end;

      return;

   end SET_CURSOR_PTR_FOR_THIS_INDEX;
%page;
TUPLE_ALREADY_PROCESSED:
   proc (tap_p_tuple_id) returns (bit (1) aligned);

/* This routine checks to see if tap_p_tuple_id is duplicated
   in the element_id_list.  Specifically, it goes from the current
   entry in the element_id_list.id array backwards looking for a match.
   Global variables are used, in particular element_id_list_ptr and
   tuple_idx.  This is because this routine is called from inside of
   DELETE_TUPLE and MODIFY_TUPLE, which by design have no knowledge of 
   those variables. */

      dcl	    tap_p_tuple_id	       bit (36) aligned parameter;

      dcl	    tap_tuple_idx	       fixed bin (35);

      if element_id_list_ptr = null ()
      then return (FALSE);

      tap_tuple_idx = tuple_idx - 1;
      do tap_tuple_idx = tap_tuple_idx by -1 to 1 while (element_id_list.id (tap_tuple_idx) ^= tap_p_tuple_id);
      end;
      if tap_tuple_idx >= 1
      then return (TRUE);
      else return (FALSE);

   end TUPLE_ALREADY_PROCESSED;
%page;
%include dm_rlm_cursor;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_rlm_idx_cursor_array;
%page;
%include vu_typed_vector;
%page;
%include vu_typed_vector_array;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include dm_range_constants;
%page;
%include dm_operator_constants;
%page;
%include dm_element_id_list;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include sub_err_flags;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;

   end rlm_process_tuples_by_id;




		    rlm_put_tuple.pl1               05/06/86  1320.1rew 05/06/86  1257.9      199458



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

/* format: style2,ind3 */


/****^  HISTORY COMMENTS:
  1) change(86-02-04,Spitzer), approve(86-02-27,MCR7349),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Added the list entry which puts multiple tuples. This is the target
     of relation_manager_$put_tuples.  Also changed the "s" to
     ACTION_CANT_RESTART in each sub_err_ call.
  2) change(86-04-24,Pierret), approve(86-04-24,MCR7349),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     In response to audit comments:
      (1) Added declaration for hbound.
      (2) Changed rlm_put_tuple proc statement to rlm_put_tuple$list.
      (3) Removed dm_range_constants.incl.pl1.
      (4) Declared "constants" as options(constant).
      (5) Used %page instead of FormFeed.
      (6) Added CHECK_PTR_NULL routine to check if pointers are null. Also
      (7) Added null pointer check for relation_cursor_ptr in $list.
      (8) Added use of ERROR_RETURN after call to rlm_opening_info$get.
      (9) Made all returns go through RETURN procedure.
      (10) Moved allocation of simple_typed_vector into INITIALIZE so that only
           one is allocated instead of one for each tuple put.
      (11) Verified type of simple_typed_vector.
      (12) Added freeing of search_specification to FINISH procedure.
  3) change(86-04-25,Pierret), approve(86-04-25,MCR7349),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     More audit changes:  Added SETUP_CURSORS and SETUP_VECTOR, both called
     from the main procedure after the cleanup handler is established, which
     setup record and index cursors and allocate the simple_typed_vector for
     later use.  Previously cursors were being set up in each invocation of
     PUT_SINGLE_TUPLE and the simple_typed_vector was being alloated before the
     cleanup handler was established.  Also moved the cleanup establishment
     from PUT_SINGLE_TUPLE to the main procedure immediately after each call to
     INITIALIZE.  Removed the SET_RECORD_COLLECTION_CURSOR_PTR and
     SET_CURSOR_PTR_FOR_THIS_INDEX routines, incorporating them into
     SETUP_CURSORS.
     Removed declaration of unused constants.
     Changed the FormFeed in the history section to the literal "FormFeed".
     Changed the call to CHECK_PTR_NULL in $list tuple loop to use the name
     "typed_vector_list.vector_ptr("||ltrim(char(tuple_loop))||")" instead of
     "input_typed_vector_ptr".
                                                   END HISTORY COMMENTS */


/* DESCRIPTION

   This module implements the relation_manager_ entries
   put_tuple and put_tuples.  In both cases if an error other
   than dm_error_$key_duplication is encountered it is the
   responsibility of the caller to roll back the transaction in
   order to restore the relation to a consistent state.  If a
   key duplication is encountered - which is not a real error -
   this module rolls back any modifications it may have made in
   storing the tuple which encounterd the key duplication.  In
   the case of the list entry, processing stops when a key
   duplication occurs, leaving the prior tuples stored intact
   and returning to the caller a list of tuple_ids for the
   tuples stored.
   
   In order to store the keys a simple_typed_vector must be
   built to hold the values of the fields in the key plus a
   field for the tuple id.  One vector is allocated large enough
   to hold all of the attributes in the tuple plus 1 for the
   tuple id.  This then is large enough to hold the largest
   possible key.  Before each key is built,
   simple_typed_vector.value_ptr(*) is set to null.  While
   building the key value_ptrs are set to point to the
   appropriate value supplied in the input_simple_typed_vector
   which describes the tuple being stored.  Those that are left
   null are ignored by the index_manager_ when the key is put.
   When the simple_typed_vector is freed the values to which it
   points must not also be freed as they are under the control
   of the caller.
   
   During ROLLBACK a search_specification is built to identify
   the keys which must be deleted.  Again the values used are
   the values supplied by the caller.  When the specification is
   freed the values to which it points must not also be freed as
   the values are under the control of the caller.

   There are three ways to exit this module.  Normal exit is by
   calling the RETURN routine which does a non-local goto to the 
   label MAIN_RETURN which returns.  Most error exits are by
   calling the ERROR_RETURN routine which sets the error code and
   calls the RETURN routine.  Programming errors are reported via
   sub_err_.  Currently the programming errors detected deal with
   bad arguments supplied by the caller: null pointers and incorrect
   versions of structures.
*/

/* HISTORY PRIOR TO MR11 INSTALLATION:
Written by Matthew Pierret, 05/03/82.
Modified:
09/30/82 by Matthew Pierret:  Changed to use the area pointed to by 
            dm_data_$area_ptr.
10/13/82 by Matthew Pierret:  Changed to correctly set the number_of_dimensions
            in simple_typed_vector before calling im_put_key.
12/07/82 by Lindsey Spratt:  Changed to initialize the simple_typed_vector_ptr
	  to null.
02/01/83 by Lindsey Spratt:  Changed to convert dm_error_$key_duplication to
	  mrds_error_$dup_store for external consumption.
03/04/83 by Matthew Pierret: Changed to use the structures attribute_info,
            relation_opening_info, and index_attribute_map instead of the
            previously kept relation_info structure. Changed CHECK_VERSION
            CHECK_VERSION_FB, and added a new CHECK_VERSION which checks
            char(8)aligned versions. Removed references to dm_data$area_ptr.
            The subroutine get_dm_free_area_ is used to get the pointer to 
            the dm_area; this pointer (dm_area_ptr) is "internal static"
            to reduce on the number of calls to get_dm_free_area_.
03/10/83 by Matthew Pierret: Changed to not assume that all entries in 
            index_attribute_map contain an index.
05/23/83 by Matthew Pierret: Changed to use a relation_cursor. Added an
            ERROR_RETURN subroutine and replaced the 
            "do;call FINISH;return;end" cliche with "call ERROR_RETURN (code)"
            Added a cleanup handler.
06/27/83 by Lindsey L. Spratt:  Changed to use the version 2 relation_cursor.
           Fixed the ROLLBACK procedure to delete keys for the current tuple
            when a keydup is found.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.
*/
%page;
rlm_put_tuple$list:
   proc (p_relation_cursor_ptr, p_typed_vector_list_ptr, p_element_id_list_ptr, p_number_of_tuples_put, p_code);


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

      dcl	    p_typed_vector_ptr     ptr;
      dcl	    p_typed_vector_list_ptr
			       ptr;
      dcl	    p_element_id_list_ptr  ptr;
      dcl	    p_number_of_tuples_put fixed bin (35);
      dcl	    p_relation_cursor_ptr  ptr;
      dcl	    p_tuple_id	       bit (36) aligned;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    input_simple_typed_vector_ptr
			       ptr;
      dcl	    (record_collection_cursor_ptr, index_cursor_ptr)
			       ptr init (null);
      dcl	    key_field_idx	       fixed bin;
      dcl	    index_idx	       fixed bin;
      dcl	    tuple_id	       bit (36) aligned;
      dcl	    tuple_loop	       fixed bin (35);

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (dm_area_ptr);

/* Builtin */

      dcl	    (addr, char, hbound, ltrim, null)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("rlm_put_tuple") char (32) varying internal static options (constant);
      dcl	    RANDOM_RECORD_ID       init ("000000000000"b3) bit (36) aligned internal static options (constant);

/* Entry */

      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    rlm_opening_info$get   entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    index_manager_$put_key entry (ptr, ptr, fixed bin (35));
      dcl	    index_manager_$create_cursor
			       entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$bad_arg   ext fixed bin (35);
      dcl	    dm_error_$key_duplication
			       ext fixed bin (35);
      dcl	    error_table_$unimplemented_version
			       ext fixed bin (35);
      dcl	    sys_info$max_seg_size  ext fixed bin (35);

/* Static */

      dcl	    dm_area_ptr	       ptr static init (null);

/* END OF DECLARATIONS */
%page;
/* format: ^indblkcom,indcomtxt */

/* Entry statement repeated for reader.

   list: entry
   (p_relation_cursor_ptr, p_typed_vector_list_ptr, p_element_id_list_ptr, p_number_of_tuples_put, p_code);
   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   */
      p_code = 0;
      p_number_of_tuples_put = 0;

      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_PTR_NULL ("relation_cursor_ptr", relation_cursor_ptr);
      call CHECK_VERSION ("relation_cursor", (relation_cursor.version), (RELATION_CURSOR_VERSION_2));

      typed_vector_list_ptr = p_typed_vector_list_ptr;
      call CHECK_PTR_NULL ("typed_vector_list_ptr", typed_vector_list_ptr);
      call CHECK_VERSION_FB ("typed_vector_list", (typed_vector_list.version), (TYPED_VECTOR_LIST_VERSION_1));

      element_id_list_ptr = p_element_id_list_ptr;
      call CHECK_PTR_NULL ("element_id_list_ptr", element_id_list_ptr);
      call CHECK_VERSION_FB ("element_id_list", element_id_list.version, ELEMENT_ID_LIST_VERSION_1);
      if element_id_list.number_of_elements < typed_vector_list.number_of_vectors
      then call sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0,
	      "There were not enough entries in the element_id_list structure to contain the tuple id's of the tuples stored."
	      );

      call INITIALIZE;

      on cleanup call FINISH;

      call SETUP_CURSORS;
      call SETUP_VECTOR;

      element_id_list.id (*) = "0"b;

      do tuple_loop = 1 to typed_vector_list.number_of_vectors;
         input_simple_typed_vector_ptr = typed_vector_list.vector_ptr (tuple_loop);

         call CHECK_PTR_NULL ("typed_vector_list.vector_ptr(" || ltrim (char (tuple_loop)) || ")",
	    input_simple_typed_vector_ptr);

         call CHECK_VERSION_FB ("simple_typed_vector", (input_simple_typed_vector_ptr -> simple_typed_vector.type),
	    (SIMPLE_TYPED_VECTOR_TYPE));

         call PUT_SINGLE_TUPLE;
         element_id_list.id (tuple_loop) = tuple_id;

         p_number_of_tuples_put = p_number_of_tuples_put + 1;
      end;					/* do tuple_loop */

      call RETURN;
%page;
single:
   entry (p_relation_cursor_ptr, p_typed_vector_ptr, p_tuple_id, p_code);


      p_code = 0;
      p_tuple_id = "0"b;

      input_simple_typed_vector_ptr = p_typed_vector_ptr;
      call CHECK_PTR_NULL ("typed_vector_ptr", input_simple_typed_vector_ptr);
      call CHECK_VERSION_FB ("simple_typed_vector", (input_simple_typed_vector_ptr -> simple_typed_vector.type),
	 (SIMPLE_TYPED_VECTOR_TYPE));

      relation_cursor_ptr = p_relation_cursor_ptr;
      call CHECK_PTR_NULL ("relation_cursor_ptr", relation_cursor_ptr);
      call CHECK_VERSION ("relation_cursor", (relation_cursor.version), (RELATION_CURSOR_VERSION_2));

      call INITIALIZE;

      on cleanup call FINISH;

      call SETUP_CURSORS;
      call SETUP_VECTOR;

      call PUT_SINGLE_TUPLE;

      p_tuple_id = tuple_id;

      call RETURN ();

MAIN_RETURN:
      return;

RETURN:
   proc ();
      call FINISH ();
      goto MAIN_RETURN;
   end RETURN;


ERROR_RETURN:
   proc (er_code);

      dcl	    er_code	       fixed bin (35);

      p_code = er_code;
      call RETURN;

   end ERROR_RETURN;
%page;
PUT_SINGLE_TUPLE:
   proc ();

/*  Put the tuple in the record collection. */

      call record_manager_$put_record_by_id (RANDOM_RECORD_ID, input_simple_typed_vector_ptr,
	 (0) /* relation_header.minimum_free_space */, record_collection_cursor_ptr, tuple_id, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

   /*** Store a key for this tuple for each index in the relation.  Construct
        the keys based on the values in the input_simple_typed_vector.  If
        a duplication error results, back out the modifications by deleting the
        keys and tuple already stored. */


PUT_KEY_FOR_EACH_INDEX_LOOP:
      do index_idx = 1 to index_attribute_map.number_of_indices;
         if index_attribute_map.index (index_idx).number_of_attributes > 0
         then
	  do;
	     simple_typed_vector.number_of_dimensions = index_attribute_map.index (index_idx).number_of_attributes + 1;
	     simple_typed_vector.value_ptr = null;
	     do key_field_idx = 1 to index_attribute_map.index (index_idx).number_of_attributes;
	        simple_typed_vector.value_ptr (key_field_idx) =
		   input_simple_typed_vector_ptr
		   -> simple_typed_vector
		   .value_ptr (index_attribute_map.index (index_idx).attribute_id (key_field_idx));
	     end;

	     simple_typed_vector.value_ptr (key_field_idx) = addr (tuple_id);
						/* The last field is always the tuple id */

	     index_cursor_ptr = index_cursor_array.cursor_ptr (index_idx);

	     call index_manager_$put_key (simple_typed_vector_ptr, index_cursor_ptr, p_code);
	     ;
	     if p_code ^= 0
	     then
	        do;
		 if p_code = dm_error_$key_duplication
		 then call ROLLBACK (index_idx - 1);
		 call ERROR_RETURN (p_code);
	        end;
	  end;

      end PUT_KEY_FOR_EACH_INDEX_LOOP;

      return;
   end PUT_SINGLE_TUPLE;
%page;
INITIALIZE:
   proc ();

      if dm_area_ptr = null
      then dm_area_ptr = get_dm_free_area_ ();

/* Get and verify the opening info structures necessary for this operation. */

      call rlm_opening_info$get (relation_cursor.file_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);			/* relation isn't open */

      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
      call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);

      index_cursor_array_ptr = relation_opening_info.per_process.index_cursor_array_ptr;
      call CHECK_VERSION ("index_cursor_array", index_cursor_array.version, INDEX_CURSOR_ARRAY_VERSION_1);

      search_specification_ptr = null;			/* for FINISH */
      simple_typed_vector_ptr = null;			/* for FINISH */
      record_collection_cursor_ptr = null;		/* for FINISH */

      return;
   end INITIALIZE;


FINISH:
   proc ();

      if simple_typed_vector_ptr ^= null
      then free simple_typed_vector in (dm_area);

      if search_specification_ptr ^= null ()
      then free search_specification in (dm_area);

      if record_collection_cursor_ptr ^= null
      then call record_manager_$destroy_cursor (record_collection_cursor_ptr, (0));

   end FINISH;
%page;
      ;
ROLLBACK:
   proc (rb_p_number_of_keys);

      dcl	    rb_p_number_of_keys    fixed bin;
      dcl	    rb_index_idx	       fixed bin (17);
      dcl	    rb_key_field_idx       fixed bin (17);
      dcl	    rb_code	       fixed bin (35);
      dcl	    rb_index_cursor_ptr    ptr;
      dcl	    index_manager_$delete_key
			       entry (ptr, ptr, ptr, fixed bin (35), fixed bin (35));

      ss_number_of_and_groups = 1;
      ss_maximum_number_of_constraints = index_attribute_map.maximum_number_of_attributes_per_index + 1;
      alloc search_specification in (dm_area);
      search_specification.head.version = SPECIFICATION_VERSION_4;
      search_specification.head.subset_specification_ptr = null;
      search_specification.head.type = ABSOLUTE_SEARCH_SPECIFICATION_TYPE;
      search_specification.head.pad = "0"b;

/* Set the operator code to "=" for all constraints. */

      search_specification.and_group (1).constraint (*).operator_code = EQUAL_OPERATOR_CODE;
      search_specification.and_group (1).constraint (*).value_field_id = -1;

/* All of the key searches have the same record id, so the value ptr is set
   outside of the RB_INDEX_LOOP.  The field_id of the record id field changes
   for each index, so this must be set inside the loop.
*/

      search_specification.and_group (1).constraint (1).value_ptr = addr (tuple_id);

RB_INDEX_LOOP:
      do rb_index_idx = 1 to rb_p_number_of_keys;
         if index_attribute_map.index (rb_index_idx).number_of_attributes > 0
         then
RB_DELETE_KEY:
	  do;
	     search_specification.and_group (1).number_of_constraints =
		index_attribute_map.index (rb_index_idx).number_of_attributes + 1;
	     search_specification.and_group (1).constraint (1).field_id =
		search_specification.and_group (1).number_of_constraints;
RB_KEY_FIELD_LOOP:
	     do rb_key_field_idx = 1 to index_attribute_map.index (rb_index_idx).number_of_attributes;
	        search_specification.and_group (1).constraint (rb_key_field_idx + 1).field_id = rb_key_field_idx;
	        search_specification.and_group (1).constraint (rb_key_field_idx + 1).value_ptr =
		   input_simple_typed_vector_ptr
		   -> simple_typed_vector
		   .value_ptr (index_attribute_map.index (rb_index_idx).attribute_id (rb_key_field_idx));
	     end RB_KEY_FIELD_LOOP;

	     rb_index_cursor_ptr = index_cursor_array (rb_index_idx).cursor_ptr;

	     call index_manager_$delete_key (search_specification_ptr, dm_area_ptr, rb_index_cursor_ptr, (0), rb_code);
	     ;
	  end RB_DELETE_KEY;
      end RB_INDEX_LOOP;


      call record_manager_$delete_record_by_id (tuple_id, record_collection_cursor_ptr, rb_code);

      free search_specification in (dm_area);
      return;

   end ROLLBACK;
%page;
CHECK_VERSION:
   proc (p_structure_name, p_received_version, p_expected_version);

      dcl	    p_received_version     char (8) aligned;
      dcl	    p_expected_version     char (8) aligned;
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION;

CHECK_VERSION_FB:
   proc (p_structure_name, p_received_version, p_expected_version);

      dcl	    p_received_version     fixed bin (35);
      dcl	    p_expected_version     fixed bin (35);
      dcl	    p_structure_name       char (*);

      if p_received_version ^= p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", p_expected_version, p_structure_name, p_received_version);

   end CHECK_VERSION_FB;

CHECK_PTR_NULL:
   proc (cpn_p_ptr_name, cpn_p_ptr);

      dcl	    cpn_p_ptr_name	       char (*) parameter;
      dcl	    cpn_p_ptr	       ptr;

      if cpn_p_ptr = null ()
      then call sub_err_ (error_table_$bad_arg, myname, ACTION_CANT_RESTART, null, 0, "A null value was supplied for ^a.",
	      cpn_p_ptr_name);

   end CHECK_PTR_NULL;
%page;
SETUP_CURSORS:
   proc ();

/* This routine sets up a cursor for the record collection and one cursor
   for each index of the relation.  The record cursor is always created
   (and deleted later in FINISH).  An index cursor is created for each
   index which needs one, that is for each that does not already have a
   cursor in the index_cursor_array.  This array is part of the relation's
   opening info.  When a cursor is created for an index to be used internally
   a pointer to the cursor is put in the index_cursor_array so that it can be
   used again later.  No index cursors created here will be destroyed. */

      dcl	    sc_code	       fixed bin (35) init (0);
      dcl	    sc_index_idx	       fixed bin;

      call record_manager_$create_cursor (relation_cursor.file_opening_id, relation_header.record_collection_id,
	 relation_cursor.work_area_ptr, record_collection_cursor_ptr, sc_code);
      if sc_code ^= 0
      then call ERROR_RETURN (sc_code);

      do sc_index_idx = 1 to hbound (index_attribute_map.index, 1);
         if index_attribute_map.index (sc_index_idx).number_of_attributes > 0
         then if index_cursor_array.cursor_ptr (sc_index_idx) = null
	    then
	       do;
		call index_manager_$create_cursor (relation_cursor.file_opening_id,
		     index_attribute_map.index (sc_index_idx).collection_id, dm_area_ptr,
		     index_cursor_array.cursor_ptr (sc_index_idx), sc_code);
		if sc_code ^= 0
		then call ERROR_RETURN (sc_code);
	       end;
      end;

   end SETUP_CURSORS;
%page;
SETUP_VECTOR:
   proc ();

      stv_number_of_dimensions = index_attribute_map.maximum_number_of_attributes_per_index + 1;
      alloc simple_typed_vector in (dm_area);
      simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;

   end SETUP_VECTOR;
%page;
%include dm_element_id_list;
%page;
%include dm_operator_constants;
%page;
%include dm_rcdmgr_entry_dcls;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_rlm_idx_cursor_array;
%page;
%include dm_rlm_cursor;
%page;
%include dm_specification_head;
%page;
%include dm_specification;
%page;
%include dm_typed_vector_list;
%page;
%include vu_typed_vector;
%page;
%include sub_err_flags;

   end rlm_put_tuple$list;




		    rlm_set_scope.pl1               01/04/85  0917.4re  01/03/85  1148.0       24606



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


/* DESCRIPTION:

         Records  the given scope settings and, if the relation is protected,
     calls page_file_manager_ to record the implied lock advice.
*/

/* HISTORY:

Written by Matthew Pierret, 10/06/82.
Modified:
03/16/83 by Matthew Pierret: Changed to use rlm_opening_info$get_dont_refresh.
06/18/84 by Matthew Pierret:  Removed declaration of the un-used null builtin.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */

rlm_set_scope:
   proc (p_rel_opening_id, p_this_process_permission, p_other_processes_permission, p_code);

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

      dcl	    p_rel_opening_id       bit (36) aligned parameter;
      dcl	    p_this_process_permission
			       bit (2) aligned parameter;
      dcl	    p_other_processes_permission
			       bit (2) aligned parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    lock_mode	       fixed bin;

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

      dcl	    myname	       init ("rlm_set_scope") char (32) varying int static options (constant);

/* Entry */

      dcl	    rlm_opening_info$get_dont_refresh
			       entry (bit (36) aligned, ptr, fixed bin (35));
      dcl	    rlm_update_opening_info$lock_advice
			       entry (ptr, bit (2) aligned, bit (2) aligned, fixed bin (35));
      dcl	    file_manager_$lock_advice
			       entry (bit (36) aligned, fixed bin, fixed bin (35));

/* External */
/* END OF DECLARATIONS */

      p_code = 0;

      call rlm_opening_info$get_dont_refresh (p_rel_opening_id, relation_opening_info_ptr, p_code);
      if p_code ^= 0
      then return;

      call
         rlm_update_opening_info$lock_advice (relation_opening_info_ptr, p_this_process_permission,
         p_other_processes_permission, p_code);

      if p_other_processes_permission = NO_PERMISSION
      then lock_mode = LOCK_MODE_X;
      else if p_other_processes_permission = READ_PERMISSION
      then if p_this_process_permission = READ_PERMISSION
	 then lock_mode = LOCK_MODE_S;
	 else lock_mode = LOCK_MODE_SIX;
      else if p_this_process_permission = READ_PERMISSION
      then lock_mode = LOCK_MODE_IS;
      else lock_mode = LOCK_MODE_IX;

      call file_manager_$lock_advice (p_rel_opening_id, lock_mode, p_code);

      return;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_permissions;
%page;
%include dm_lock_modes;

   end rlm_set_scope;




		    rlm_unimplemented_entries.pl1   10/02/86  1219.4rew 10/02/86  1203.8       35406



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



/****^  HISTORY COMMENTS:
  1) change(86-08-19,Dupuis), approve(86-08-19,MCR7401), audit(86-09-26,Blair),
     install(86-10-02,MR12.0-1173):
     There were a number of entries in rlm_general_search that were
     partially implemented and untested because mrds doesn't use them.
     Changed the relation_manager_ transfer vector to head into this module
     instead, and put the following entries here: get_tuples_by_spec,
     get_tuple_array_by_spec, get_tuples_and_ids, and get_tuple_array_and_ids.
                                                   END HISTORY COMMENTS */



/* format: style2,ind3 */
rlm_unimplemented_entries:
   proc ();

/* DESCRIPTION:

         This  is  a  place  for  all  not-yet implemented entries, so that a
     complete interface to relation_manager_ is possible.  Each simply returns
     with the error_code dm_error_$unimplemented_entry.
*/

/* HISTORY:

Written by Matthew Pierret, 09/24/82.
Modified:
12/03/83 by Jeffrey D. Ives: Changed some entries to return 0 p_code.
01/21/83 by Lindsey Spratt:  Added the destroy_cursor entry.
*/

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

      dcl	    p_code	       fixed bin (35);
      dcl	    p_bit36a	       bit (36) aligned;
      dcl	    p_bit2a	       bit (2) aligned;
      dcl	    p_char_star	       char (*);
      dcl	    p_fb17	       fixed bin (17);
      dcl	    p_fb35	       fixed bin (35);
      dcl	    p_ptr		       ptr;

/* Automatic */
/* Based */
/* Builtin */
/* Constant */
/* Entry */
/* External */

      dcl	    dm_error_$unimplemented_entry
			       ext fixed bin (35);

/* END OF DECLARATIONS */

destroy_relation_by_opening:
   entry (p_bit36a, p_code);

      p_code = 0;
      return;

destroy_relation_by_path:
   entry (p_char_star, p_char_star, p_code);

      p_code = 0;
      return;

create_subset_index:
   entry (p_ptr, p_bit36a, p_ptr, p_ptr, p_bit36a, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

destroy_index:
   entry (p_bit36a, p_bit36a, p_code);

      p_code = 0;
      return;

set_scope:
   entry (p_bit36a, p_bit2a, p_bit2a, p_code);

      p_code = 0;
      return;

delete_tuples_by_spec:
   entry (p_ptr, p_ptr, p_fb35, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

modify_tuples_by_spec:
   entry (p_ptr, p_ptr, p_ptr, p_fb35, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_population:
   entry (p_bit36a, p_fb35, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_count:
   entry (p_ptr, p_ptr, p_fb35, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_duplicate_key_count:
   entry (p_fb17, p_ptr, p_fb35, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_max_and_min_attributes:
   entry (p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

destroy_cursor:
   entry (p_ptr, p_ptr, p_code);
      p_code = 0;
      return;

get_tuples_by_spec:
   entry (p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_tuple_array_by_spec:
   entry (p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_tuples_and_ids:
   entry (p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

get_tuple_array_and_ids:
   entry (p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_ptr, p_code);

      p_code = dm_error_$unimplemented_entry;
      return;

   end rlm_unimplemented_entries;




		    rlm_update_opening_info.pl1     04/04/85  1109.9r w 04/04/85  0914.0      129105



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


/* DESCRIPTION:

Update per relation opening info: $(increment decrement)_openings - Number of
openings for this relation, $lock_advice - Set lock advice, $relation_header -
Update relation header in opening info and relation header, $attribute_info -
Update attribute info as for relation_header.

*/

/* HISTORY:
Written by Matthew Pierret, 02/28/83.
Modified:
05/16/83 by Lindsey L. Spratt:  Changed to set the parameter
            p_relation_opening_info_ptr to null if the call to
            rlm_opening_info$free is successful.
06/22/83 by Lindsey L. Spratt:  Fixed index_attribute_map entry to set the
            relation_opening_info.per_process.index_cursor_array_ptr when the
            index_cursor_array is expanded.
05/29/84 by Matthew Pierret:  Changed to use RELATION_HEADER_VERSION_3.
06/12/84 by Matthew Pierret:  Re-named cm_$put_element to cm_$modify,
            cm_$allocate_element to cm_$put.
10/25/84 by Stanford S. Cox:  $index_attribute_map - Added asgn. of
   index_cursor_array.version.
*/

/* format: style2,ind3 */

rlm_update_opening_info:
   proc ();

      call sub_err_ (dm_error_$programming_error, myname, ACTION_CANT_RESTART, null, 0,
	 "^/^a$^a is not a valid entrypoint", myname, myname);



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

      dcl	    p_relation_opening_info_ptr
			       ptr parameter;
      dcl	    p_relation_header_ptr  ptr parameter;
      dcl	    p_attribute_info_ptr   ptr parameter;
      dcl	    p_index_attribute_map_ptr
			       ptr parameter;
      dcl	    (p_this_process_permission, p_other_processes_permission)
			       bit (2) aligned;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    (current_number_of_openings, index_idx, increment)
			       fixed bin (17);
      dcl	    1 current_lock_advice  aligned like relation_opening_info.per_process.lock_advice;
      dcl	    (old_relation_header_ptr, old_attribute_info_ptr, old_index_attribute_map_ptr, old_index_cursor_array_ptr)
			       ptr init (null);

/* Based */

      dcl	    dm_area	       area (sys_info$max_seg_size) based (static_dm_area_ptr);

/* Builtin */

      dcl	    (currentsize, length, null, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    myname	       init ("rlm_update_opening_info") char (32) varying,
	    BITS_PER_WORD	       init (36) fixed bin (17)
	    )		       internal static options (constant);

/* Entry */

      dcl	    rlm_opening_info$free  entry (ptr, fixed bin (35));
      dcl	    get_dm_free_area_      entry () returns (ptr);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    dm_error_$programming_error
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    sys_info$max_seg_size  fixed bin (35) ext;

/* Static */

      dcl	    static_dm_area_ptr     ptr internal static init (null);

/* END OF DECLARATIONS */

/* format: ^indblkcom,indcomtxt */

increment_openings:
   entry (p_relation_opening_info_ptr, p_code);

      increment = 1;
      goto OPENINGS_JOIN;

decrement_openings:
   entry (p_relation_opening_info_ptr, p_code);

      increment = -1;

OPENINGS_JOIN:
      relation_opening_info_ptr = p_relation_opening_info_ptr;

      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      p_code = 0;
      current_number_of_openings = relation_opening_info.per_process.number_of_openings;
      on cleanup relation_opening_info.per_process.number_of_openings = current_number_of_openings;

      relation_opening_info.per_process.number_of_openings =
	 relation_opening_info.per_process.number_of_openings + increment;

      if increment = -1 & relation_opening_info.per_process.number_of_openings <= 0
      then
         do;
	  call rlm_opening_info$free (relation_opening_info_ptr, p_code);
	  if p_code ^= 0
	  then return;
	  p_relation_opening_info_ptr = null;
         end;

      return;
%page;
lock_advice:
   entry (p_relation_opening_info_ptr, p_this_process_permission, p_other_processes_permission, p_code);

      relation_opening_info_ptr = p_relation_opening_info_ptr;

      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      p_code = 0;
      current_lock_advice = relation_opening_info.per_process.lock_advice;
      on cleanup relation_opening_info.per_process.lock_advice = current_lock_advice;

      relation_opening_info.per_process.lock_advice.this_process = p_this_process_permission;
      relation_opening_info.per_process.lock_advice.other_processes = p_other_processes_permission;

      return;
%page;
relation_header:
   entry (p_relation_opening_info_ptr, p_relation_header_ptr, p_code);

      relation_opening_info_ptr = p_relation_opening_info_ptr;
      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      relation_header_ptr = p_relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      relation_header.header_info_update_count = relation_header.header_info_update_count + 1;

      call collection_manager_$modify (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	 relation_header_ptr, length (unspec (relation_header)), CALLER_HEADER_ELEMENT_ID, (0), p_code);
      if p_code ^= 0
      then return;

      if relation_opening_info.relation_header_ptr ^= relation_header_ptr
      then
         do;
	  old_relation_header_ptr = relation_opening_info.relation_header_ptr;
	  relation_opening_info.relation_header_ptr = relation_header_ptr;
	  if old_relation_header_ptr ^= null
	  then
	     do;
	        if static_dm_area_ptr = null
	        then static_dm_area_ptr = get_dm_free_area_ ();
	        free old_relation_header_ptr -> relation_header in (dm_area);
	     end;
         end;

      return;
%page;
attribute_info:
   entry (p_relation_opening_info_ptr, p_attribute_info_ptr, p_code);

      relation_opening_info_ptr = p_relation_opening_info_ptr;
      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      attribute_info_ptr = p_attribute_info_ptr;
      call CHECK_VERSION ("attribute_info", attribute_info.version, ATTRIBUTE_INFO_VERSION_1);

      if relation_header.attribute_info_element_id = "0"b
      then call collection_manager_$put (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	      attribute_info_ptr, currentsize (attribute_info) * BITS_PER_WORD,
	      relation_header.attribute_info_element_id, (0), p_code);
      else call collection_manager_$modify (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	      attribute_info_ptr, currentsize (attribute_info) * BITS_PER_WORD,
	      relation_header.attribute_info_element_id, (0), p_code);

      if p_code ^= 0
      then return;

      relation_header.header_info_update_count = relation_header.header_info_update_count + 1;

      call collection_manager_$modify (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	 relation_header_ptr, currentsize (relation_header) * BITS_PER_WORD, CALLER_HEADER_ELEMENT_ID, (0), p_code);
      if p_code ^= 0
      then return;

      if relation_opening_info.attribute_info_ptr ^= attribute_info_ptr
      then
         do;
	  old_attribute_info_ptr = relation_opening_info.attribute_info_ptr;
	  relation_opening_info.attribute_info_ptr = attribute_info_ptr;
	  if old_attribute_info_ptr ^= null
	  then
	     do;
	        if static_dm_area_ptr = null
	        then static_dm_area_ptr = get_dm_free_area_ ();
	        free old_attribute_info_ptr -> attribute_info in (dm_area);
	     end;
         end;

      return;
%page;
index_attribute_map:
   entry (p_relation_opening_info_ptr, p_index_attribute_map_ptr, p_code);

      relation_opening_info_ptr = p_relation_opening_info_ptr;
      call CHECK_VERSION ("relation_opening_info", relation_opening_info.version, RELATION_OPENING_INFO_VERSION_2);

      relation_header_ptr = relation_opening_info.relation_header_ptr;
      call CHECK_VERSION ("relation_header", relation_header.version, RELATION_HEADER_VERSION_3);

      index_attribute_map_ptr = p_index_attribute_map_ptr;
      call CHECK_VERSION ("index_attribute_map", index_attribute_map.version, INDEX_ATTRIBUTE_MAP_VERSION_2);

      if relation_header.index_attribute_map_element_id = "0"b
      then call collection_manager_$put (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	      index_attribute_map_ptr, currentsize (index_attribute_map) * BITS_PER_WORD,
	      relation_header.index_attribute_map_element_id, (0), p_code);
      else call collection_manager_$modify (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	      index_attribute_map_ptr, currentsize (index_attribute_map) * BITS_PER_WORD,
	      relation_header.index_attribute_map_element_id, (0), p_code);

      if p_code ^= 0
      then return;

      relation_header.header_info_update_count = relation_header.header_info_update_count + 1;

      call collection_manager_$modify (relation_opening_info.per_process.file_opening_id, HEADER_COLLECTION_ID,
	 relation_header_ptr, currentsize (relation_header) * BITS_PER_WORD, CALLER_HEADER_ELEMENT_ID, (0), p_code);
      if p_code ^= 0
      then return;

      if static_dm_area_ptr = null
      then static_dm_area_ptr = get_dm_free_area_ ();

      if relation_opening_info.per_process.index_cursor_array_ptr = null
      then
         do;

         /*** No index_cursor_array exists, so set one up with a null cursor_ptr for each index. */

	  ica_number_of_indices = hbound (index_attribute_map.index, 1);
	  alloc index_cursor_array in (dm_area);
	  index_cursor_array.version = INDEX_CURSOR_ARRAY_VERSION_1;
	  index_cursor_array.cursor_ptr (*) = null;
	  relation_opening_info.per_process.index_cursor_array_ptr = index_cursor_array_ptr;
         end;
      else
         do;
	  index_cursor_array_ptr = relation_opening_info.per_process.index_cursor_array_ptr;
	  call CHECK_VERSION ("index_cursor_array", index_cursor_array.version, INDEX_CURSOR_ARRAY_VERSION_1);
         end;

      if hbound (index_cursor_array.cursor_ptr, 1) >= hbound (index_attribute_map.index, 1)
      then
REMOVE_CURSORS_FOR_DELETED_INDICES:
         do;

         /*** Indices for which cursors are stored in index_cursor_array may have been
	    deleted. Destroy the cursors for any such index. */

	  do index_idx = 1 to hbound (index_attribute_map.index, 1);
	     if index_cursor_array.cursor_ptr (index_idx) ^= null
	     then if index_attribute_map.index (index_idx).number_of_attributes <= 0
		then
		   do;				/* call index_manager_$destroy_cursor (index_cursor_array.cursor_ptr(index_idx), (0)); */
		      index_cursor_array.cursor_ptr (index_idx) = null;
		   end;
	  end;
         end REMOVE_CURSORS_FOR_DELETED_INDICES;
      else
EXTEND_INDEX_CURSOR_ARRAY:
         do;

         /*** The index_attribute_map has been extended to contain more indices than
	    index_cursor_array components, so index_cursor_array must likewise be
	    extended. Allocate a new one, and copy over the old cursor_ptr values.
	    If a non-null cursor_ptr exists for an index which no longer exists,
	    destroy the cursor. */

	  old_index_cursor_array_ptr = index_cursor_array_ptr;
	  ica_number_of_indices = hbound (index_attribute_map.index, 1);

	  alloc index_cursor_array in (dm_area);
	  index_cursor_array.version = INDEX_CURSOR_ARRAY_VERSION_1;
	  relation_opening_info.per_process.index_cursor_array_ptr = index_cursor_array_ptr;

	  index_cursor_array.cursor_ptr (*) = null;

	  do index_idx = 1 to hbound (old_index_cursor_array_ptr -> index_cursor_array.cursor_ptr, 1);
	     if old_index_cursor_array_ptr -> index_cursor_array.cursor_ptr (index_idx) ^= null
	     then if index_attribute_map.index (index_idx).number_of_attributes > 0
		then index_cursor_array.cursor_ptr (index_idx) =
			old_index_cursor_array_ptr -> index_cursor_array.cursor_ptr (index_idx);
	  /***	          else call index_manager_$destroy_cursor (old_index_cursor_array_ptr->index_cursor_array.cursor_ptr(index_idx), (0)); */
	  end;
	  free old_index_cursor_array_ptr -> index_cursor_array in (dm_area);

         end EXTEND_INDEX_CURSOR_ARRAY;



      if relation_opening_info.index_attribute_map_ptr ^= index_attribute_map_ptr
      then
         do;
	  old_index_attribute_map_ptr = relation_opening_info.index_attribute_map_ptr;
	  relation_opening_info.index_attribute_map_ptr = index_attribute_map_ptr;
	  if old_index_attribute_map_ptr ^= null
	  then free old_index_attribute_map_ptr -> index_attribute_map in (dm_area);
         end;

      return;
%page;
CHECK_VERSION:
   proc (cv_p_structure_name, cv_p_received_version, cv_p_expected_version);

      dcl	    cv_p_received_version  char (8) aligned;
      dcl	    cv_p_expected_version  char (8) aligned;
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^8a of the ^a structure.
Received version ^8a instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;
%page;
%include dm_rlm_opening_info;
%page;
%include dm_rlm_header;
%page;
%include dm_rlm_attribute_info;
%page;
%include dm_rlm_index_attr_map;
%page;
%include dm_rlm_idx_cursor_array;
%page;
%include dm_cm_hdr_col_ids;

%include dm_hdr_collection_id;
%page;
%include sub_err_flags;
%page;
%include dm_collmgr_entry_dcls;

   end rlm_update_opening_info;




*/
                                          -----------------------------------------------------------


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

*/
