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 (, 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, , 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 */